From 472db4daeaf2f45a2aa211dab18a27685138e66d Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Wed, 24 Nov 2021 11:51:46 +0100 Subject: [PATCH 001/383] added word type to the choice universe --- theories/Crypt/choice_type.v | 49 +++++++++++++--- theories/Crypt/package/pkg_heap.v | 4 +- theories/Crypt/package/pkg_interpreter.v | 75 +++++++++--------------- 3 files changed, 73 insertions(+), 55 deletions(-) diff --git a/theories/Crypt/choice_type.v b/theories/Crypt/choice_type.v index a0a50a59..d096a3c7 100644 --- a/theories/Crypt/choice_type.v +++ b/theories/Crypt/choice_type.v @@ -18,6 +18,7 @@ From extructures Require Import ord fset fmap. From Mon Require Import SPropBase. Require Equations.Prop.DepElim. From Equations Require Import Equations. +From CoqWord Require Import word ssrZ. Set Equations With UIP. @@ -40,7 +41,8 @@ Inductive choice_type := | chProd (A B : choice_type) | chMap (A B : choice_type) | chOption (A : choice_type) -| chFin (n : positive). +| chFin (n : positive) +| chWord (nbits : nat). Derive NoConfusion NoConfusionHom for choice_type. @@ -52,6 +54,8 @@ Derive NoConfusion NoConfusionHom for choice_type. (* Definition void_ordMixin := OrdMixin void_leqP. *) (* Canonical void_ordType := Eval hnf in OrdType void void_ordMixin. *) +Axiom WordOrd : ordType. (* fixme *) + Fixpoint chElement_ordType (U : choice_type) : ordType := match U with | chUnit => unit_ordType @@ -61,6 +65,7 @@ Fixpoint chElement_ordType (U : choice_type) : ordType := | chMap U1 U2 => fmap_ordType (chElement_ordType U1) (chElement_ordType U2) | chOption U => option_ordType (chElement_ordType U) | chFin n => [ordType of ordinal n.(pos) ] + | chWord nbits => WordOrd (* fixme *) end. Fixpoint chElement (U : choice_type) : choiceType := @@ -72,6 +77,7 @@ Fixpoint chElement (U : choice_type) : choiceType := | chMap U1 U2 => fmap_choiceType (chElement_ordType U1) (chElement U2) | chOption U => option_choiceType (chElement U) | chFin n => [choiceType of ordinal n.(pos) ] + | chWord nbits => word_choiceType nbits end. Coercion chElement : choice_type >-> choiceType. @@ -86,6 +92,7 @@ Coercion chElement : choice_type >-> choiceType. | chMap A B => _ | chOption A => None | chFin n => _ + | chWord nbits => word0 end. Next Obligation. eapply fmap_of_fmap. apply emptym. @@ -106,6 +113,7 @@ Section choice_typeTypes. | chMap a b , chMap a' b' => choice_type_test a a' && choice_type_test b b' | chOption a, chOption a' => choice_type_test a a' | chFin n, chFin n' => n == n' + | chWord nbits, chWord nbits' => nbits == nbits' | _ , _ => false end. @@ -115,9 +123,9 @@ Section choice_typeTypes. Lemma choice_type_eqP : Equality.axiom choice_type_eq. Proof. move=> x y. - induction x as [ | | | x1 ih1 x2 ih2 | x1 ih1 x2 ih2 | x1 ih1 | x1] + induction x as [ | | | x1 ih1 x2 ih2 | x1 ih1 x2 ih2 | x1 ih1 | x1 | x1 ] in y |- *. - all: destruct y as [ | | | y1 y2 | y1 y2 | y1 | y1]. + all: destruct y as [ | | | y1 y2 | y1 y2 | y1 | y1 | y1 ]. all: simpl. all: try solve [ right ; discriminate ]. all: try solve [ left ; reflexivity ]. @@ -139,6 +147,10 @@ Section choice_typeTypes. + move: e => /eqP e. subst. left. reflexivity. + move: e => /eqP e. right. intro h. apply e. inversion h. reflexivity. + - destruct (x1 == y1) eqn:e. + + move: e => /eqP e. subst. left. reflexivity. + + move: e => /eqP e. right. intro h. + apply e. inversion h. reflexivity. Qed. Lemma choice_type_refl : @@ -193,6 +205,15 @@ Section choice_typeTypes. | chFin n, chMap _ _ => false | chFin n, chOption _ => false | chFin n, chFin n' => n < n' + | chFin n, _ => true + | chWord n, chUnit => false + | chWord n, chBool => false + | chWord n, chNat => false + | chWord n, chProd _ _ => false + | chWord n, chMap _ _ => false + | chWord n, chOption _ => false + | chWord n, chFin _ => false + | chWord n, chWord n' => n < n' end. Definition choice_type_leq (t1 t2 : choice_type) := @@ -201,7 +222,7 @@ Section choice_typeTypes. Lemma choice_type_lt_transitive : transitive (T:=choice_type) choice_type_lt. Proof. intros v u w h1 h2. - induction u as [ | | | u1 ih1 u2 ih2 | u1 ih1 u2 ih2 | u ih | u] + induction u as [ | | | u1 ih1 u2 ih2 | u1 ih1 u2 ih2 | u ih | u | u ] in v, w, h1, h2 |- *. - destruct w. all: try auto. destruct v. all: discriminate. @@ -244,7 +265,11 @@ Section choice_typeTypes. simpl in *. eapply ih. all: eauto. - destruct v. all: try discriminate. - destruct w. all: try discriminate. + all: destruct w; try discriminate; auto. + simpl in *. + eapply ltn_trans. all: eauto. + - destruct v. all: try discriminate. + all: destruct w; try discriminate; auto. simpl in *. eapply ltn_trans. all: eauto. Qed. @@ -253,7 +278,7 @@ Section choice_typeTypes. ∀ x, ~~ choice_type_lt x x. Proof. intros x. - induction x as [ | | | x1 ih1 x2 ih2 | x1 ih1 x2 ih2 | x ih | x] in |- *. + induction x as [ | | | x1 ih1 x2 ih2 | x1 ih1 x2 ih2 | x ih | x | x] in |- *. all: intuition; simpl. - simpl. apply/norP. split. @@ -266,6 +291,7 @@ Section choice_typeTypes. + apply/nandP. right. apply ih2. - rewrite ltnn. auto. + - rewrite ltnn. auto. Qed. Lemma choice_type_lt_total_holds : @@ -273,7 +299,7 @@ Section choice_typeTypes. ~~ (choice_type_test x y) ==> (choice_type_lt x y || choice_type_lt y x). Proof. intros x y. - induction x as [ | | | x1 ih1 x2 ih2| x1 ih1 x2 ih2| x ih| x] + induction x as [ | | | x1 ih1 x2 ih2| x1 ih1 x2 ih2| x ih| x | x] in y |- *. all: try solve [ destruct y ; intuition ; reflexivity ]. - destruct y. all: try (intuition; reflexivity). @@ -351,6 +377,11 @@ Section choice_typeTypes. unfold choice_type_test. rewrite -neq_ltn. apply /implyP. auto. + - destruct y. all: try (intuition; reflexivity). + unfold choice_type_lt. + unfold choice_type_test. + rewrite -neq_ltn. + apply /implyP. auto. Qed. Lemma choice_type_lt_asymmetric : @@ -454,6 +485,7 @@ Section choice_typeTypes. | chMap l r => GenTree.Node 2 [:: encode l ; encode r] | chOption u => GenTree.Node 3 [:: encode u] | chFin n => GenTree.Leaf ((4 + n) - 1)%N + | chWord n => GenTree.Leaf ((4 + n) - 1)%N (* fixme *) end. Fixpoint decode (t : GenTree.tree nat) : option choice_type := @@ -494,7 +526,8 @@ Section choice_typeTypes. + discriminate. + cbn. rewrite -subnE subn0. repeat f_equal. apply eq_irrelevance. - Defined. + Admitted. + (* Defined. *) Definition choice_type_choiceMixin := PcanChoiceMixin codeK. Canonical choice_type_choiceType := diff --git a/theories/Crypt/package/pkg_heap.v b/theories/Crypt/package/pkg_heap.v index ed71ab8e..5858e27a 100644 --- a/theories/Crypt/package/pkg_heap.v +++ b/theories/Crypt/package/pkg_heap.v @@ -19,6 +19,7 @@ From Crypt Require Import Prelude Axioms ChoiceAsOrd SubDistr Couplings pkg_tactics pkg_composition. Require Import Equations.Prop.DepElim. From Equations Require Import Equations. +From CoqWord Require Import word. (* Must come after importing Equations.Equations, who knows why. *) From Crypt Require Import FreeProbProg. @@ -63,6 +64,7 @@ Proof. - exact emptym. - exact None. - exact (fintype.Ordinal n.(cond_pos)). + - exact word0. Defined. Definition heap := { h : raw_heap | valid_heap h }. @@ -264,4 +266,4 @@ Proof. intros s ℓ v ℓ' v' ne. apply heap_ext. destruct s as [h vh]. simpl. apply setmC. auto. -Qed. \ No newline at end of file +Qed. diff --git a/theories/Crypt/package/pkg_interpreter.v b/theories/Crypt/package/pkg_interpreter.v index bcb4f058..1c0a5b6c 100644 --- a/theories/Crypt/package/pkg_interpreter.v +++ b/theories/Crypt/package/pkg_interpreter.v @@ -1,6 +1,7 @@ Set Warnings "-notation-overridden,-ambiguous-paths". From mathcomp Require Import all_ssreflect. Set Warnings "notation-overridden,ambiguous-paths". +Require Arith ZArith. From Crypt Require Import Prelude choice_type pkg_core_definition pkg_tactics pkg_distr pkg_notation. @@ -76,51 +77,14 @@ Section Interpreter. | _ => true end. Proof. - induction l. - - rewrite ch_nat_equation_1. - simpl. - rewrite nat_ch_aux_equation_1. - by destruct v. - - rewrite ch_nat_equation_2. - simpl. - rewrite nat_ch_aux_equation_9. - reflexivity. - - rewrite ch_nat_equation_3. - simpl. - rewrite nat_ch_aux_equation_10. - destruct v ; reflexivity. - - destruct v. - rewrite ch_nat_equation_4. - simpl. - specialize (IHl1 s). - specialize (IHl2 s0). - move: IHl1 IHl2. - case (ch_nat l1 s) ; - case (ch_nat l2 s0). - + simpl. - intros. - rewrite nat_ch_aux_equation_32. - by rewrite IHl1 IHl2. - + by simpl ; intros ; try inversion IHl1 ; try inversion IHl2. - + by simpl ; intros ; try inversion IHl1 ; try inversion IHl2. - + by simpl ; intros ; try inversion IHl1 ; try inversion IHl2. - - rewrite ch_nat_equation_5. - done. - - destruct v eqn:e ; simpl. - + rewrite ch_nat_equation_6. - specialize (IHl s). - case (ch_nat l s) eqn:e'. - ++ simpl. - intros. - rewrite nat_ch_aux_equation_20. - f_equal. - done. - ++ done. - + rewrite ch_nat_equation_7. - done. - - rewrite ch_nat_equation_8. - simpl. - rewrite nat_ch_aux_equation_14. + funelim (ch_nat l v). all: try easy. + - simpl. by destruct v. + - simp ch_nat. simpl. simp nat_ch_aux. by destruct v. + - simp ch_nat. destruct (ch_nat l1 v1), (ch_nat l2 v2); try easy. + cbn. simp nat_ch_aux. simpl in *. now rewrite H H0. + - simp ch_nat. destruct ch_nat; try easy. + simpl in *. simp nat_ch_aux. now f_equal. + - simp ch_nat. simpl. simp nat_ch_aux. f_equal. unfold nat_ch_aux_obligation_1. have lv := ltn_ord v. @@ -163,7 +127,6 @@ Section Interpreter. Definition Run {A} := (fun c seed => @Run_aux A c seed (fun (l : Location) => Some NSUnit)). - #[program] Fixpoint sampler (e : choice_type) seed : option (nat * e):= match e with chUnit => Some (seed, Datatypes.tt) @@ -184,6 +147,7 @@ Section Interpreter. | _ => None end | chFin n => Some ((seed + 1)%N, _) + | chWord n => Some ((seed + 1)%N, _) end. Next Obligation. eapply Ordinal. @@ -192,4 +156,23 @@ Section Interpreter. apply n. Defined. + Set Warnings "-notation-overridden,-ambiguous-paths". + Import ZArith. + Import all_algebra. + Set Warnings "notation-overridden,ambiguous-paths". + Local Open Scope Z_scope. + Local Open Scope ring_scope. + + Next Obligation. + eapply word.mkWord. + instantiate (1 := ((Z.of_nat seed) mod word.modulus n)%Z). + pose (Z.mod_bound_pos (Z.of_nat seed) (word.modulus n) + (Zle_0_nat seed)). + pose (word.modulus_gt0 n). + apply / word.iswordZP. + apply a. + move : i => / ssrZ.ltzP. + auto. + Defined. + End Interpreter. From f32603a7c2879b7549fde90f01dd1b7f163840eb Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Thu, 25 Nov 2021 12:28:55 +0100 Subject: [PATCH 002/383] example of jasmin AST --- jasmin/identity.v | 165 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 165 insertions(+) create mode 100644 jasmin/identity.v diff --git a/jasmin/identity.v b/jasmin/identity.v new file mode 100644 index 00000000..27e0de24 --- /dev/null +++ b/jasmin/identity.v @@ -0,0 +1,165 @@ +(** + + translating simple functions/packages between Jasmin and SSProve + +*) + +From Relational Require Import OrderEnrichedCategory GenericRulesSimple. + +Set Warnings "-notation-overridden,-ambiguous-paths". +From mathcomp Require Import all_ssreflect all_algebra reals distr realsum + fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool ssrnum + eqtype choice seq. +Set Warnings "notation-overridden,ambiguous-paths". + +From Crypt Require Import Axioms chUniverse Package Prelude. + +From extructures Require Import ord fset. + +Import PackageNotation. + +From CoqWord Require Import word. + +Module Type Param. + + (* Parameter nbits : nat. *) + Definition chWord : chUniverse := chWord 64. + +End Param. + +Module Identity (param : Param). + + Import param. + + Notation " 'word " := + chWord + (in custom pack_type at level 2). + + Definition x : Location := (chWord ; 1%N). + + Local Open Scope package_scope. + + Definition IdentityLOC := fset [:: x]. + + (* Definition IdentityCode {L : {fset Location}} (i : chWord) : *) + (* code L [interface] chWord := *) + (* {code *) + (* y ← i ;; *) + (* ret y *) + (* }. *) + + Definition IdentityPackage : + package IdentityLOC + [interface] + [interface val #[10] : 'word → 'word ] := + [package + def #[10] (r : 'word) : 'word + { + put x := r ;; + r ← get x ;; + ret r + } + ]. + +End Identity. + +Require Import List. +From Jasmin Require Import expr. +From Crypt Require Import pkg_core_definition. + +Import ListNotations. + +Local Open Scope positive. +Local Open Scope string. + +Notation jas_prog := expr.prog. (* jasmin program *) + +Definition identity : jas_prog := + {| p_globs := []; + p_funcs := + [(1, + {| + f_iinfo := 2; + f_tyin := [sword U64]; + f_params := [{|v_var := {| + vtype := sword U64; + vname := "x.121" + |}; + v_info := xI xH|}]; + f_body := [MkI + (xO (xO xH)) + (Cassgn + (Lvar + {| v_var := + {| vtype := sword U64; + vname := "x.???" |}; (* fixme *) + v_info := xO (xI xH)|}) + AT_none + (sword U64) + (Pvar + {|v_var := + {| vtype := sword U64; + vname := "x.???" |}; (* fixme *) + v_info := xI (xO xH)|}))]; + f_tyout := [sword U64]; + f_res := [{|v_var := + {| vtype := sword U64; + vname := "x.???"|}; (* fixme *) + v_info := xI (xI xH) |}] + |})] + |}. + +(** original ocaml prog **) + +(* cprog: Jasmin.Expr.prog = *) +(* {Jasmin.Expr.p_globs = []; *) +(* p_funcs = *) +(* [(Jasmin.BinNums.Coq_xH, *) +(* {Jasmin.Expr.f_iinfo = Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH; *) +(* f_tyin = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; *) +(* f_params = *) +(* [{Jasmin.Expr.v_var = *) +(* {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; *) +(* vname = }; *) +(* v_info = Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH}]; *) +(* f_body = *) +(* [Jasmin.Expr.MkI *) +(* (Jasmin.BinNums.Coq_xO *) +(* (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH), *) +(* Jasmin.Expr.Cassgn *) +(* (Jasmin.Expr.Lvar *) +(* {Jasmin.Expr.v_var = *) +(* {Jasmin.Var0.Var.vtype = *) +(* Jasmin.Type.Coq_sword Jasmin.Wsize.U64; *) +(* vname = }; *) +(* v_info = *) +(* Jasmin.BinNums.Coq_xO *) +(* (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)}, *) +(* Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, *) +(* Jasmin.Expr.Pvar *) +(* {Jasmin.Expr.v_var = *) +(* {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; *) +(* vname = }; *) +(* v_info = *) +(* Jasmin.BinNums.Coq_xI *) +(* (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)}))]; *) +(* f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; *) +(* f_res = *) +(* [{Jasmin.Expr.v_var = *) +(* {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; *) +(* vname = }; *) +(* v_info = *) +(* Jasmin.BinNums.Coq_xI *) +(* (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)}]})]} *) + +(** ec translation *) + +(* module M = { *) +(* proc identity (x:W64.t) : W64.t = { *) +(* var r:W64.t; *) +(* r <- x; *) +(* return (r); *) +(* } *) +(* }. *) + +(* todo: prove that these two have the same semantics *) From 0cdd95db540ccda9a4a97abee3958d4b1b99a82f Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Wed, 15 Dec 2021 11:33:58 +0100 Subject: [PATCH 003/383] added several examples of jasmin asts the file `jasmin/gen_ast.sh` can generate Coq asts from simple jasmin source files. --- jasmin/add1/add1.cprog | 76 + jasmin/add1/add1.jazz | 7 + jasmin/add1/add1.v | 85 + jasmin/bigadd/bigadd.cprog | 434 ++++ jasmin/bigadd/bigadd.jazz | 22 + jasmin/bigadd/bigadd.v | 443 ++++ jasmin/ex/ex.cprog | 122 ++ jasmin/ex/ex.jazz | 9 + jasmin/ex/ex.v | 131 ++ jasmin/gen_ast.sh | 43 + jasmin/matrix_product/matrix_product.cprog | 1970 +++++++++++++++++ jasmin/matrix_product/matrix_product.jazz | 79 + jasmin/matrix_product/matrix_product.v | 1979 ++++++++++++++++++ jasmin/print_vname.cmi | Bin 0 -> 592 bytes jasmin/print_vname.cmo | Bin 0 -> 556 bytes jasmin/print_vname.ml | 5 + jasmin/retz/retz.cprog | 30 + jasmin/retz/retz.jazz | 6 + jasmin/retz/retz.v | 39 + jasmin/test_for/test_for.cprog | 75 + jasmin/test_for/test_for.jazz | 10 + jasmin/test_for/test_for.v | 84 + jasmin/test_inline_var/test_inline_var.cprog | 283 +++ jasmin/test_inline_var/test_inline_var.jazz | 15 + jasmin/test_inline_var/test_inline_var.v | 292 +++ jasmin/test_shift/test_shift.cprog | 46 + jasmin/test_shift/test_shift.jazz | 9 + jasmin/test_shift/test_shift.v | 55 + 28 files changed, 6349 insertions(+) create mode 100644 jasmin/add1/add1.cprog create mode 100644 jasmin/add1/add1.jazz create mode 100644 jasmin/add1/add1.v create mode 100644 jasmin/bigadd/bigadd.cprog create mode 100644 jasmin/bigadd/bigadd.jazz create mode 100644 jasmin/bigadd/bigadd.v create mode 100644 jasmin/ex/ex.cprog create mode 100644 jasmin/ex/ex.jazz create mode 100644 jasmin/ex/ex.v create mode 100644 jasmin/gen_ast.sh create mode 100644 jasmin/matrix_product/matrix_product.cprog create mode 100644 jasmin/matrix_product/matrix_product.jazz create mode 100644 jasmin/matrix_product/matrix_product.v create mode 100644 jasmin/print_vname.cmi create mode 100644 jasmin/print_vname.cmo create mode 100644 jasmin/print_vname.ml create mode 100644 jasmin/retz/retz.cprog create mode 100644 jasmin/retz/retz.jazz create mode 100644 jasmin/retz/retz.v create mode 100644 jasmin/test_for/test_for.cprog create mode 100644 jasmin/test_for/test_for.jazz create mode 100644 jasmin/test_for/test_for.v create mode 100644 jasmin/test_inline_var/test_inline_var.cprog create mode 100644 jasmin/test_inline_var/test_inline_var.jazz create mode 100644 jasmin/test_inline_var/test_inline_var.v create mode 100644 jasmin/test_shift/test_shift.cprog create mode 100644 jasmin/test_shift/test_shift.jazz create mode 100644 jasmin/test_shift/test_shift.v diff --git a/jasmin/add1/add1.cprog b/jasmin/add1/add1.cprog new file mode 100644 index 00000000..27d0ccab --- /dev/null +++ b/jasmin/add1/add1.cprog @@ -0,0 +1,76 @@ + {Jasmin.Expr.p_funcs = + [(Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH, + {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH; + f_tyin = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = arg.130}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)}]; + f_body = + [Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = z.131}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = arg.130}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}; + gs = Jasmin.Expr.Slocal})); + Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = z.131}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Papp2 + (Jasmin.Expr.Oadd (Jasmin.Expr.Op_w Jasmin.Wsize.U64), + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = z.131}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U64, + Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos Jasmin.BinNums.Coq_xH)))))]; + f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = z.131}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}]; + f_extra = ()})]; + p_globs = []; p_extra = ()} diff --git a/jasmin/add1/add1.jazz b/jasmin/add1/add1.jazz new file mode 100644 index 00000000..7086214c --- /dev/null +++ b/jasmin/add1/add1.jazz @@ -0,0 +1,7 @@ +export +fn add1(reg u64 arg) -> reg u64 { +reg u64 z; +z = arg; +z += 1; +return z; +} diff --git a/jasmin/add1/add1.v b/jasmin/add1/add1.v new file mode 100644 index 00000000..95c8bf85 --- /dev/null +++ b/jasmin/add1/add1.v @@ -0,0 +1,85 @@ +Require Import List. +From Jasmin Require Import expr. +From Jasmin Require Import x86_extra. + +Import ListNotations. +Local Open Scope string. + +Definition add1 := + {| p_funcs := + [(xO xH, + {| f_info := xI xH; + f_tyin := [sword U64]; + f_params := + [{| v_var := + {| vtype := sword U64; + vname := "arg.130" |}; + v_info := + xO + (xO xH) |}]; + f_body := + [MkI + (xO + (xO + (xO xH))) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "z.131" |}; + v_info := + xO + (xI + (xO xH)) |}) + (AT_none) (sword U64) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "arg.130" |}; + v_info := + xI + (xO + (xO xH)) |}; + gs := Slocal |})); + MkI + (xI + (xO xH)) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "z.131" |}; + v_info := + xI + (xI xH) |}) + (AT_none) (sword U64) + (Papp2 + (Oadd (Op_w U64)) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "z.131" |}; + v_info := + xO + (xI xH) |}; + gs := Slocal |}) + (Papp1 (Oword_of_int U64) + (Pconst (Zpos xH)))))]; + f_tyout := [sword U64]; + f_res := + [{| v_var := + {| vtype := sword U64; + vname := "z.131" |}; + v_info := + xI + (xI + (xO xH)) |}]; + f_extra := tt |})]; + p_globs := []; p_extra := tt |} +. \ No newline at end of file diff --git a/jasmin/bigadd/bigadd.cprog b/jasmin/bigadd/bigadd.cprog new file mode 100644 index 00000000..464b8580 --- /dev/null +++ b/jasmin/bigadd/bigadd.cprog @@ -0,0 +1,434 @@ + {Jasmin.Expr.p_funcs = + [(Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH, + {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH; + f_tyin = + [Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))); + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))); + vname = x.140}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)}; + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))); + vname = y.141}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)}]; + f_body = + [Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = xr.143}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Pget (Jasmin.Warray_.AAscale, Jasmin.Wsize.U64, + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))); + vname = x.140}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pconst Jasmin.BinNums.Z0))); + Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = yr.144}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Pget (Jasmin.Warray_.AAscale, Jasmin.Wsize.U64, + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))); + vname = y.141}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pconst Jasmin.BinNums.Z0))); + Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))), + Jasmin.Expr.Copn + ([Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sbool; + vname = cf.145}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}; + Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = xr.143}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}], + Jasmin.Expr.AT_none, Jasmin.Sopn.Oaddcarry Jasmin.Wsize.U64, + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = xr.143}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = yr.144}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Pbool false])); + Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Laset (Jasmin.Warray_.AAscale, Jasmin.Wsize.U64, + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))); + vname = res.142}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}, + Jasmin.Expr.Pconst Jasmin.BinNums.Z0), + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = xr.143}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}; + gs = Jasmin.Expr.Slocal})); + Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH), + Jasmin.Expr.Cfor + ({Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = i.146}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)}, + ((Jasmin.Expr.UpTo, + Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos Jasmin.BinNums.Coq_xH)), + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))), + [Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = xr.143}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Pget (Jasmin.Warray_.AAscale, Jasmin.Wsize.U64, + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))); + vname = x.140}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = i.146}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}; + gs = Jasmin.Expr.Slocal}))); + Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = yr.144}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Pget (Jasmin.Warray_.AAscale, Jasmin.Wsize.U64, + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))); + vname = y.141}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = i.146}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}; + gs = Jasmin.Expr.Slocal}))); + Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)), + Jasmin.Expr.Copn + ([Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sbool; + vname = cf.145}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}; + Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = xr.143}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}], + Jasmin.Expr.AT_none, Jasmin.Sopn.Oaddcarry Jasmin.Wsize.U64, + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = xr.143}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = yr.144}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sbool; + vname = cf.145}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}; + gs = Jasmin.Expr.Slocal}])); + Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Laset (Jasmin.Warray_.AAscale, Jasmin.Wsize.U64, + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))); + vname = res.142}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = i.146}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}; + gs = Jasmin.Expr.Slocal}), + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = xr.143}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}; + gs = Jasmin.Expr.Slocal}))]))]; + f_tyout = + [Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))); + vname = res.142}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}]; + f_extra = ()})]; + p_globs = []; p_extra = ()} diff --git a/jasmin/bigadd/bigadd.jazz b/jasmin/bigadd/bigadd.jazz new file mode 100644 index 00000000..e3902c21 --- /dev/null +++ b/jasmin/bigadd/bigadd.jazz @@ -0,0 +1,22 @@ +export fn add_inline(reg u64[4] x y) -> reg u64[4] { + inline int i; + reg u64[4] res; + + reg u64 xr yr; + reg bool cf; + + xr = x[0]; + yr = y[0]; + cf, xr += yr; + + res[0] = xr; + + for i = 1 to 4 { + xr = x[i]; + yr = y[i]; + cf, xr += yr + cf; + + res[i] = xr; + } + return res; +} \ No newline at end of file diff --git a/jasmin/bigadd/bigadd.v b/jasmin/bigadd/bigadd.v new file mode 100644 index 00000000..f1767d6a --- /dev/null +++ b/jasmin/bigadd/bigadd.v @@ -0,0 +1,443 @@ +Require Import List. +From Jasmin Require Import expr. +From Jasmin Require Import x86_extra. + +Import ListNotations. +Local Open Scope string. + +Definition bigadd := + {| p_funcs := + [(xO xH, + {| f_info := xI xH; + f_tyin := + [sarr + (xO + (xO + (xO + (xO + (xO xH))))); + sarr + (xO + (xO + (xO + (xO + (xO xH)))))]; + f_params := + [{| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO xH))))); + vname := "x.140" |}; + v_info := + xO + (xO xH) |}; + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO xH))))); + vname := "y.141" |}; + v_info := + xI + (xO xH) |}]; + f_body := + [MkI + (xI + (xO + (xI + (xO + (xO xH))))) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "xr.143" |}; + v_info := + xI + (xI + (xI + (xO + (xO xH)))) |}) + (AT_none) (sword U64) + (Pget (AAscale) (U64) + ({| gv := + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO xH))))); + vname := "x.140" |}; + v_info := + xO + (xI + (xI + (xO + (xO xH)))) |}; + gs := Slocal |}) + (Pconst Z0))); + MkI + (xO + (xI + (xO + (xO + (xO xH))))) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "yr.144" |}; + v_info := + xO + (xO + (xI + (xO + (xO xH)))) |}) + (AT_none) (sword U64) + (Pget (AAscale) (U64) + ({| gv := + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO xH))))); + vname := "y.141" |}; + v_info := + xI + (xI + (xO + (xO + (xO xH)))) |}; + gs := Slocal |}) + (Pconst Z0))); + MkI + (xI + (xO + (xI + (xI xH)))) + (Copn + ([Lvar + {| v_var := + {| vtype := sbool; + vname := "cf.145" |}; + v_info := + xO + (xO + (xO + (xO + (xO xH)))) |}; + Lvar + {| v_var := + {| vtype := + sword U64; + vname := "xr.143" |}; + v_info := + xI + (xO + (xO + (xO + (xO xH)))) |}]) + (AT_none) (Oaddcarry U64) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "xr.143" |}; + v_info := + xO + (xI + (xI + (xI xH))) |}; + gs := Slocal |}; + Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "yr.144" |}; + v_info := + xI + (xI + (xI + (xI xH))) |}; + gs := Slocal |}; + Pbool false])); + MkI + (xO + (xI + (xO + (xI xH)))) + (Cassgn + (Laset (AAscale) (U64) + ({| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO xH))))); + vname := "res.142" |}; + v_info := + xO + (xO + (xI + (xI xH))) |}) + (Pconst Z0)) + (AT_none) (sword U64) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "xr.143" |}; + v_info := + xI + (xI + (xO + (xI xH))) |}; + gs := Slocal |})); + MkI + (xO + (xI xH)) + (Cfor + ({| v_var := + {| vtype := sint; vname := "i.146" |}; + v_info := + xI + (xI xH) |}) + (((UpTo, + Pconst (Zpos xH)), + Pconst + (Zpos + (xO + (xO xH))))) + ([MkI + (xO + (xI + (xI + (xO xH)))) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "xr.143" |}; + v_info := + xI + (xO + (xO + (xI xH))) |}) + (AT_none) (sword U64) + (Pget (AAscale) (U64) + ({| gv := + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO xH))))); + vname := "x.140" |}; + v_info := + xO + (xO + (xO + (xI xH))) |}; + gs := Slocal |}) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "i.146" |}; + v_info := + xI + (xI + (xI + (xO xH))) |}; + gs := Slocal |}))); + MkI + (xO + (xI + (xO + (xO xH)))) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "yr.144" |}; + v_info := + xI + (xO + (xI + (xO xH))) |}) + (AT_none) (sword U64) + (Pget (AAscale) (U64) + ({| gv := + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO xH))))); + vname := "y.141" |}; + v_info := + xO + (xO + (xI + (xO xH))) |}; + gs := Slocal |}) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "i.146" |}; + v_info := + xI + (xI + (xO + (xO xH))) |}; + gs := Slocal |}))); + MkI + (xO + (xO + (xI xH))) + (Copn + ([Lvar + {| v_var := + {| vtype := sbool; + vname := "cf.145" |}; + v_info := + xO + (xO + (xO + (xO xH))) |}; + Lvar + {| v_var := + {| vtype := + sword U64; + vname := "xr.143" |}; + v_info := + xI + (xO + (xO + (xO xH))) |}]) + (AT_none) (Oaddcarry U64) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "xr.143" |}; + v_info := + xI + (xO + (xI xH)) |}; + gs := Slocal |}; + Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "yr.144" |}; + v_info := + xO + (xI + (xI xH)) |}; + gs := Slocal |}; + Pvar + {| gv := + {| v_var := + {| vtype := sbool; + vname := "cf.145" |}; + v_info := + xI + (xI + (xI xH)) |}; + gs := Slocal |}])); + MkI + (xO + (xO + (xO xH))) + (Cassgn + (Laset (AAscale) (U64) + ({| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO xH))))); + vname := "res.142" |}; + v_info := + xI + (xI + (xO xH)) |}) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "i.146" |}; + v_info := + xO + (xI + (xO xH)) |}; + gs := Slocal |})) + (AT_none) (sword U64) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "xr.143" |}; + v_info := + xI + (xO + (xO xH)) |}; + gs := Slocal |}))]))]; + f_tyout := + [sarr + (xO + (xO + (xO + (xO + (xO xH)))))]; + f_res := + [{| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO xH))))); + vname := "res.142" |}; + v_info := + xO + (xO + (xO + (xI + (xO xH)))) |}]; + f_extra := tt |})]; + p_globs := []; p_extra := tt |} +. \ No newline at end of file diff --git a/jasmin/ex/ex.cprog b/jasmin/ex/ex.cprog new file mode 100644 index 00000000..33fb65c1 --- /dev/null +++ b/jasmin/ex/ex.cprog @@ -0,0 +1,122 @@ + {Jasmin.Expr.p_funcs = + [(Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH, + {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH; + f_tyin = + [Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = x.133}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)}; + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = y.134}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)}]; + f_body = + [Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)), + Jasmin.Expr.Copn + ([Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sbool; + vname = cf.135}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}; + Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = x.133}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}], + Jasmin.Expr.AT_none, Jasmin.Sopn.Oaddcarry Jasmin.Wsize.U64, + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = x.133}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = y.134}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Pbool false])); + Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH), + Jasmin.Expr.Copn + ([Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sbool; + vname = cf.135}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}; + Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = y.134}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}], + Jasmin.Expr.AT_none, Jasmin.Sopn.Oaddcarry Jasmin.Wsize.U64, + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = y.134}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = x.133}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Pbool false]))]; + f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = y.134}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}]; + f_extra = ()})]; + p_globs = []; p_extra = ()} diff --git a/jasmin/ex/ex.jazz b/jasmin/ex/ex.jazz new file mode 100644 index 00000000..7d49a837 --- /dev/null +++ b/jasmin/ex/ex.jazz @@ -0,0 +1,9 @@ +param int KEYSIZE = 4; + +inline fn add(reg u64 x y) -> reg u64 { + reg bool cf; + cf, x += y; + cf, y += x; + + return y; +} diff --git a/jasmin/ex/ex.v b/jasmin/ex/ex.v new file mode 100644 index 00000000..00d6edb9 --- /dev/null +++ b/jasmin/ex/ex.v @@ -0,0 +1,131 @@ +Require Import List. +From Jasmin Require Import expr. +From Jasmin Require Import x86_extra. + +Import ListNotations. +Local Open Scope string. + +Definition ex := + {| p_funcs := + [(xO xH, + {| f_info := xI xH; + f_tyin := + [sword U64; + sword U64]; + f_params := + [{| v_var := + {| vtype := sword U64; + vname := "x.133" |}; + v_info := + xO + (xO xH) |}; + {| v_var := + {| vtype := sword U64; + vname := "y.134" |}; + v_info := + xI + (xO xH) |}]; + f_body := + [MkI + (xI + (xI + (xO xH))) + (Copn + ([Lvar + {| v_var := + {| vtype := sbool; + vname := "cf.135" |}; + v_info := + xO + (xI + (xI xH)) |}; + Lvar + {| v_var := + {| vtype := + sword U64; + vname := "x.133" |}; + v_info := + xI + (xI + (xI xH)) |}]) + (AT_none) (Oaddcarry U64) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "x.133" |}; + v_info := + xO + (xO + (xI xH)) |}; + gs := Slocal |}; + Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "y.134" |}; + v_info := + xI + (xO + (xI xH)) |}; + gs := Slocal |}; + Pbool false])); + MkI + (xO + (xI xH)) + (Copn + ([Lvar + {| v_var := + {| vtype := sbool; + vname := "cf.135" |}; + v_info := + xI + (xO + (xO xH)) |}; + Lvar + {| v_var := + {| vtype := + sword U64; + vname := "y.134" |}; + v_info := + xO + (xI + (xO xH)) |}]) + (AT_none) (Oaddcarry U64) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "y.134" |}; + v_info := + xI + (xI xH) |}; + gs := Slocal |}; + Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "x.133" |}; + v_info := + xO + (xO + (xO xH)) |}; + gs := Slocal |}; + Pbool false]))]; + f_tyout := [sword U64]; + f_res := + [{| v_var := + {| vtype := sword U64; + vname := "y.134" |}; + v_info := + xO + (xO + (xO + (xO xH))) |}]; + f_extra := tt |})]; + p_globs := []; p_extra := tt |} +. \ No newline at end of file diff --git a/jasmin/gen_ast.sh b/jasmin/gen_ast.sh new file mode 100644 index 00000000..33ac1a7b --- /dev/null +++ b/jasmin/gen_ast.sh @@ -0,0 +1,43 @@ +#!/bin/bash + +echo "open Format + +let print_vname (fmt : formatter) (t : Obj.t) = + let t = Obj.magic t in + ignore (List.map (pp_print_char fmt) t)" > print_vname.ml + +ocamlc -c print_vname.ml + +name=$(basename "${1}" .jazz) +echo $name + +mkdir $name + +echo -n "Require Import List. +From Jasmin Require Import expr. +From Jasmin Require Import x86_extra. + +Import ListNotations. +Local Open Scope string. + +Definition ${name} :=" > $name/$name.v + +(ocamldebug $(which jasminc.byte) < $name/$name.cprog + +sed -i '9,$!d;$d' $name/$name.cprog + +sed 's/Jasmin\.[[:graph:]]*\.//g; s/Coq_//g ; s/=/:=/g ; s/{/{| /g ; s/}/ |}/g ; s/[[:graph:]]*\.[[:graph:]]*/"&"/g ; s/()/tt/g ;/./{H;$!d}; x ; :rename_balanced ; s/(\([^(),@]*\))/<<\1>>/g ; t rename_balanced ; :rename_pairs1 ; s/\([{([|,;][ \t\n]*([^(),]*\),/\1%/g; t rename_pairs1 ; :rename_pairs ; s/\([{([|,;][ \t\n]*\)(\([^(),]*\))/\1<<\2>>/g; t rename_balanced ; :rename_curries1 ; s/\([^{([|,;][ \t\n]*([^()]*\),/\1@/g; t rename_curries1; :rename_curries ; s/\([^{([|,;][ \t\n]*\)(\([^(),]*\))/\1++\2##/g; t rename_balanced; :uncurry ; s/\([^{([|,;][ \t\n]*++[^(),]*\)@\([ \t\n]*\)/\1##\2++/g ; t uncurry s/\([^{([|][ \t\n]*++[^(),]*\)@\([ \t\n]*\)/\1##\2++/g ; t uncurry ; s/<>/)/g ; s/##/)/g ; s/++/(/g ; s/%/,/g ; s/@/,/g' $name/$name.cprog >> $name/$name.v + +echo -n "." >> $name/$name.v + +mv $name.jazz $name diff --git a/jasmin/matrix_product/matrix_product.cprog b/jasmin/matrix_product/matrix_product.cprog new file mode 100644 index 00000000..7a65234e --- /dev/null +++ b/jasmin/matrix_product/matrix_product.cprog @@ -0,0 +1,1970 @@ + {Jasmin.Expr.p_funcs = + [(Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH, + {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH; + f_tyin = + [Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = x.191}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)}; + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = y.192}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)}; + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = z.193}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)}]; + f_body = + [Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), + Jasmin.Expr.Cfor + ({Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = i.194}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}, + ((Jasmin.Expr.UpTo, Jasmin.Expr.Pconst Jasmin.BinNums.Z0), + Jasmin.Expr.Papp2 (Jasmin.Expr.Omul Jasmin.Expr.Op_int, + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))), + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))), + [Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = tmp.195}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Pload (Jasmin.Wsize.U64, + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = x.191}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}, + Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U64, + Jasmin.Expr.Papp2 (Jasmin.Expr.Omul Jasmin.Expr.Op_int, + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))), + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = i.194}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}; + gs = Jasmin.Expr.Slocal}))))); + Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Laset (Jasmin.Warray_.AAscale, Jasmin.Wsize.U64, + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + Jasmin.BinNums.Coq_xH))))))))); + vname = mx.196}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = i.194}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}; + gs = Jasmin.Expr.Slocal}), + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = tmp.195}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}; + gs = Jasmin.Expr.Slocal})); + Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = tmp.195}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Pload (Jasmin.Wsize.U64, + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = y.192}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}, + Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U64, + Jasmin.Expr.Papp2 (Jasmin.Expr.Omul Jasmin.Expr.Op_int, + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))), + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = i.194}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}; + gs = Jasmin.Expr.Slocal}))))); + Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Laset (Jasmin.Warray_.AAscale, Jasmin.Wsize.U64, + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + Jasmin.BinNums.Coq_xH))))))))); + vname = my.197}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = i.194}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}; + gs = Jasmin.Expr.Slocal}), + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = tmp.195}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}; + gs = Jasmin.Expr.Slocal}))])); + Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), + Jasmin.Expr.Ccall (Jasmin.Expr.DoNotInline, + [Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + Jasmin.BinNums.Coq_xH))))))))); + vname = mz.198}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}], + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + Jasmin.BinNums.Coq_xH))))))))); + vname = mx.196}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + Jasmin.BinNums.Coq_xH))))))))); + vname = my.197}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + Jasmin.BinNums.Coq_xH))))))))); + vname = mz.198}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}; + gs = Jasmin.Expr.Slocal}])); + Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH), + Jasmin.Expr.Cfor + ({Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = i.194}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}, + ((Jasmin.Expr.UpTo, Jasmin.Expr.Pconst Jasmin.BinNums.Z0), + Jasmin.Expr.Papp2 (Jasmin.Expr.Omul Jasmin.Expr.Op_int, + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))), + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))), + [Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = tmp.195}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Pget (Jasmin.Warray_.AAscale, Jasmin.Wsize.U64, + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + Jasmin.BinNums.Coq_xH))))))))); + vname = mz.198}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = i.194}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}; + gs = Jasmin.Expr.Slocal}))); + Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lmem (Jasmin.Wsize.U64, + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = z.193}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}, + Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U64, + Jasmin.Expr.Papp2 (Jasmin.Expr.Omul Jasmin.Expr.Op_int, + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))), + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = i.194}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}; + gs = Jasmin.Expr.Slocal}))), + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = tmp.195}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}; + gs = Jasmin.Expr.Slocal}))]))]; + f_tyout = []; f_res = []; f_extra = ()}); + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), + {Jasmin.Expr.f_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))); + f_tyin = + [Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))))))]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); + vname = m1.199}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}; + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); + vname = m2.200}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}; + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); + vname = res.201}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}]; + f_body = + [Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + Jasmin.BinNums.Coq_xH))))))))); + vname = pres.202}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}, + Jasmin.Expr.AT_none, + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))), + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + Jasmin.BinNums.Coq_xH))))))))); + vname = res.201}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}; + gs = Jasmin.Expr.Slocal})); + Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), + Jasmin.Expr.Ccall (Jasmin.Expr.DoNotInline, + [Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + Jasmin.BinNums.Coq_xH))))))))); + vname = m2t.203}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}], + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))), + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + Jasmin.BinNums.Coq_xH))))))))); + vname = m2.200}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + Jasmin.BinNums.Coq_xH))))))))); + vname = m2t.203}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}; + gs = Jasmin.Expr.Slocal}])); + Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))), + Jasmin.Expr.Cfor + ({Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = i.204}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))}, + ((Jasmin.Expr.UpTo, Jasmin.Expr.Pconst Jasmin.BinNums.Z0), + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), + [Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))), + Jasmin.Expr.Ccall (Jasmin.Expr.DoNotInline, + [Jasmin.Expr.Lasub (Jasmin.Warray_.AAscale, Jasmin.Wsize.U64, + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)), + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + Jasmin.BinNums.Coq_xH))))))))); + vname = rest.205}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))}, + Jasmin.Expr.Papp2 (Jasmin.Expr.Omul Jasmin.Expr.Op_int, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = i.204}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))], + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))), + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + Jasmin.BinNums.Coq_xH))))))))); + vname = m1.199}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Psub (Jasmin.Warray_.AAscale, Jasmin.Wsize.U64, + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)), + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + Jasmin.BinNums.Coq_xH))))))))); + vname = m2t.203}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Papp2 (Jasmin.Expr.Omul Jasmin.Expr.Op_int, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = i.204}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))); + Jasmin.Expr.Psub (Jasmin.Warray_.AAscale, Jasmin.Wsize.U64, + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)), + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + Jasmin.BinNums.Coq_xH))))))))); + vname = rest.205}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Papp2 (Jasmin.Expr.Omul Jasmin.Expr.Op_int, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = i.204}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))]))])); + Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + Jasmin.BinNums.Coq_xH))))))))); + vname = res.201}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))}, + Jasmin.Expr.AT_none, + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))), + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + Jasmin.BinNums.Coq_xH))))))))); + vname = pres.202}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))}; + gs = Jasmin.Expr.Slocal})); + Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))), + Jasmin.Expr.Ccall (Jasmin.Expr.DoNotInline, + [Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + Jasmin.BinNums.Coq_xH))))))))); + vname = res.201}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))}], + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))), + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + Jasmin.BinNums.Coq_xH))))))))); + vname = rest.205}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + Jasmin.BinNums.Coq_xH))))))))); + vname = res.201}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}; + gs = Jasmin.Expr.Slocal}]))]; + f_tyout = + [Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))))))]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); + vname = res.201}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}]; + f_extra = ()}); + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))), + {Jasmin.Expr.f_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))); + f_tyin = + [Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))))))]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); + vname = m.206}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}; + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); + vname = res.207}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}]; + f_body = + [Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), + Jasmin.Expr.Cfor + ({Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = i.208}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}, + ((Jasmin.Expr.UpTo, Jasmin.Expr.Pconst Jasmin.BinNums.Z0), + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), + [Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), + Jasmin.Expr.Cfor + ({Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = j.209}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}, + ((Jasmin.Expr.UpTo, Jasmin.Expr.Pconst Jasmin.BinNums.Z0), + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), + [Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = tmp.210}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Pget (Jasmin.Warray_.AAscale, Jasmin.Wsize.U64, + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + Jasmin.BinNums.Coq_xH))))))))); + vname = m.206}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Papp2 (Jasmin.Expr.Oadd Jasmin.Expr.Op_int, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = j.209}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Papp2 (Jasmin.Expr.Omul Jasmin.Expr.Op_int, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = i.208}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + Jasmin.BinNums.Coq_xH)))))}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))))); + Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Laset (Jasmin.Warray_.AAscale, + Jasmin.Wsize.U64, + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + Jasmin.BinNums.Coq_xH))))))))); + vname = res.207}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}, + Jasmin.Expr.Papp2 (Jasmin.Expr.Oadd Jasmin.Expr.Op_int, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = i.208}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + Jasmin.BinNums.Coq_xH)))))}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Papp2 (Jasmin.Expr.Omul Jasmin.Expr.Op_int, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = j.209}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + Jasmin.BinNums.Coq_xH)))))}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))), + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = tmp.210}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}; + gs = Jasmin.Expr.Slocal}))]))]))]; + f_tyout = + [Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))))))]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); + vname = res.207}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}]; + f_extra = ()}); + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))), + {Jasmin.Expr.f_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))); + f_tyin = + [Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))); + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); + vname = m.211}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}; + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))); + vname = v.212}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}; + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))); + vname = res.213}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}]; + f_body = + [Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), + Jasmin.Expr.Cfor + ({Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = i.214}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}, + ((Jasmin.Expr.UpTo, Jasmin.Expr.Pconst Jasmin.BinNums.Z0), + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), + [Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))), + Jasmin.Expr.Ccall (Jasmin.Expr.DoNotInline, + [Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = tmp.215}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}], + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))), + [Jasmin.Expr.Psub (Jasmin.Warray_.AAscale, Jasmin.Wsize.U64, + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)), + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + Jasmin.BinNums.Coq_xH))))))))); + vname = m.211}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Papp2 (Jasmin.Expr.Omul Jasmin.Expr.Op_int, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = i.214}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))); + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))); + vname = v.212}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}; + gs = Jasmin.Expr.Slocal}])); + Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Laset (Jasmin.Warray_.AAscale, Jasmin.Wsize.U64, + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))); + vname = res.213}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = i.214}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}; + gs = Jasmin.Expr.Slocal}), + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = tmp.215}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}; + gs = Jasmin.Expr.Slocal}))]))]; + f_tyout = + [Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))); + vname = res.213}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}]; + f_extra = ()}); + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))), + {Jasmin.Expr.f_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))); + f_tyin = + [Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))); + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))); + vname = v1.216}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}; + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))); + vname = v2.217}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}]; + f_body = + [Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = res.218}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U64, + Jasmin.Expr.Pconst Jasmin.BinNums.Z0))); + Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))), + Jasmin.Expr.Cfor + ({Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = i.219}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}, + ((Jasmin.Expr.UpTo, Jasmin.Expr.Pconst Jasmin.BinNums.Z0), + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), + [Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = tmp.220}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Pget (Jasmin.Warray_.AAscale, Jasmin.Wsize.U64, + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))); + vname = v1.216}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = i.219}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}; + gs = Jasmin.Expr.Slocal}))); + Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = tmp.220}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Papp2 + (Jasmin.Expr.Omul (Jasmin.Expr.Op_w Jasmin.Wsize.U64), + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = tmp.220}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pget (Jasmin.Warray_.AAscale, Jasmin.Wsize.U64, + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))); + vname = v2.217}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = i.219}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}; + gs = Jasmin.Expr.Slocal})))); + Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = res.218}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Papp2 + (Jasmin.Expr.Oadd (Jasmin.Expr.Op_w Jasmin.Wsize.U64), + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = res.218}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = tmp.220}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}; + gs = Jasmin.Expr.Slocal})))]))]; + f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = res.218}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}]; + f_extra = ()})]; + p_globs = []; p_extra = ()} diff --git a/jasmin/matrix_product/matrix_product.jazz b/jasmin/matrix_product/matrix_product.jazz new file mode 100644 index 00000000..bcf43377 --- /dev/null +++ b/jasmin/matrix_product/matrix_product.jazz @@ -0,0 +1,79 @@ +param int N = 10; + +fn dot_product (reg ptr u64[N] v1, reg ptr u64[N] v2) -> reg u64 { + reg u64 res; + reg u64 tmp; + inline int i; + + res = 0; + for i = 0 to N { + tmp = v1[i]; + tmp *= v2[i]; + res += tmp; + } + return res; +} + +fn product_matrix_vector (reg ptr u64[N*N] m, reg ptr u64[N] v, reg ptr u64[N] res) -> reg ptr u64[N] { + reg u64 tmp; + inline int i; + + for i = 0 to N { + tmp = dot_product(m[i*N:N], v); + res[i] = tmp; + } + return res; +} + +fn transpose (reg ptr u64[N*N] m, reg ptr u64[N*N] res) -> reg ptr u64[N*N] { + inline int i, j; + reg u64 tmp; + + for i = 0 to N { + for j = 0 to N { + tmp = m[j+i*N]; + res[i+j*N] = tmp; + } + } + + return res; +} + +// m2 and res are transposed +fn product_matrix_matrix (reg ptr u64[N*N] m1, reg ptr u64[N*N] m2, reg ptr u64[N*N] res) -> reg ptr u64[N*N] { + inline int i; + stack u64[N*N] m2t; + stack u64[N*N] rest; + reg ptr u64[N * N] pres; + + pres = res; + m2t = transpose (m2, m2t); + for i = 0 to N { + rest[i*N:N] = product_matrix_vector(m1, m2t[i*N:N], rest[i*N:N]); + } + res = pres; + res = transpose (rest, res); + + return res; +} + +/* Multiplies row-major matrices in memory at adresses x and y and writes the result at adress z. + Regions may overlap. +*/ +export +fn productMM(reg u64 x y z) { + inline int i; + stack u64[N * N] mx my mz; + reg u64 tmp; + for i = 0 to N * N { + tmp = (u64)[x + 8 * i]; + mx[i] = tmp; + tmp = (u64)[y + 8 * i]; + my[i] = tmp; + } + mz = product_matrix_matrix(mx, my, mz); + for i = 0 to N * N { + tmp = mz[i]; + (u64)[z + 8 * i] = tmp; + } +} diff --git a/jasmin/matrix_product/matrix_product.v b/jasmin/matrix_product/matrix_product.v new file mode 100644 index 00000000..49acefcc --- /dev/null +++ b/jasmin/matrix_product/matrix_product.v @@ -0,0 +1,1979 @@ +Require Import List. +From Jasmin Require Import expr. +From Jasmin Require Import x86_extra. + +Import ListNotations. +Local Open Scope string. + +Definition matrix_product := + {| p_funcs := + [(xO xH, + {| f_info := xI xH; + f_tyin := + [sword U64; + sword U64; + sword U64]; + f_params := + [{| v_var := + {| vtype := sword U64; + vname := "x.191" |}; + v_info := + xO + (xO xH) |}; + {| v_var := + {| vtype := sword U64; + vname := "y.192" |}; + v_info := + xI + (xO xH) |}; + {| v_var := + {| vtype := sword U64; + vname := "z.193" |}; + v_info := + xO + (xI xH) |}]; + f_body := + [MkI + (xI + (xI + (xI + (xO xH)))) + (Cfor + ({| v_var := + {| vtype := sint; vname := "i.194" |}; + v_info := + xO + (xO + (xO + (xI xH))) |}) + (((UpTo, Pconst Z0), + Papp2 (Omul Op_int) + (Pconst + (Zpos + (xO + (xI + (xO xH))))) + (Pconst + (Zpos + (xO + (xI + (xO xH))))))) + ([MkI + (xI + (xO + (xI + (xO + (xO xH))))) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "tmp.195" |}; + v_info := + xO + (xO + (xO + (xI + (xO xH)))) |}) + (AT_none) (sword U64) + (Pload (U64) + ({| v_var := + {| vtype := + sword U64; + vname := "x.191" |}; + v_info := + xI + (xI + (xI + (xO + (xO xH)))) |}) + (Papp1 (Oword_of_int U64) + (Papp2 (Omul Op_int) + (Pconst + (Zpos + (xO + (xO + (xO xH))))) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "i.194" |}; + v_info := + xO + (xI + (xI + (xO + (xO xH)))) |}; + gs := Slocal |}))))); + MkI + (xI + (xO + (xO + (xO + (xO xH))))) + (Cassgn + (Laset (AAscale) (U64) + ({| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI + xH))))))))); + vname := "mx.196" |}; + v_info := + xO + (xO + (xI + (xO + (xO xH)))) |}) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "i.194" |}; + v_info := + xI + (xI + (xO + (xO + (xO xH)))) |}; + gs := Slocal |})) + (AT_none) (sword U64) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "tmp.195" |}; + v_info := + xO + (xI + (xO + (xO + (xO xH)))) |}; + gs := Slocal |})); + MkI + (xI + (xO + (xI + (xI xH)))) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "tmp.195" |}; + v_info := + xO + (xO + (xO + (xO + (xO xH)))) |}) + (AT_none) (sword U64) + (Pload (U64) + ({| v_var := + {| vtype := + sword U64; + vname := "y.192" |}; + v_info := + xI + (xI + (xI + (xI xH))) |}) + (Papp1 (Oword_of_int U64) + (Papp2 (Omul Op_int) + (Pconst + (Zpos + (xO + (xO + (xO xH))))) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "i.194" |}; + v_info := + xO + (xI + (xI + (xI xH))) |}; + gs := Slocal |}))))); + MkI + (xI + (xO + (xO + (xI xH)))) + (Cassgn + (Laset (AAscale) (U64) + ({| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI + xH))))))))); + vname := "my.197" |}; + v_info := + xO + (xO + (xI + (xI xH))) |}) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "i.194" |}; + v_info := + xI + (xI + (xO + (xI xH))) |}; + gs := Slocal |})) + (AT_none) (sword U64) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "tmp.195" |}; + v_info := + xO + (xI + (xO + (xI xH))) |}; + gs := Slocal |}))])); + MkI + (xI + (xO + (xO + (xO xH)))) + (Ccall (DoNotInline) + ([Lvar + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI + xH))))))))); + vname := "mz.198" |}; + v_info := + xO + (xI + (xI + (xO xH))) |}]) + (xI + (xO + (xI + (xO xH)))) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI + xH))))))))); + vname := "mx.196" |}; + v_info := + xO + (xI + (xO + (xO xH))) |}; + gs := Slocal |}; + Pvar + {| gv := + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI + xH))))))))); + vname := "my.197" |}; + v_info := + xI + (xI + (xO + (xO xH))) |}; + gs := Slocal |}; + Pvar + {| gv := + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI + xH))))))))); + vname := "mz.198" |}; + v_info := + xO + (xO + (xI + (xO xH))) |}; + gs := Slocal |}])); + MkI + (xI + (xI xH)) + (Cfor + ({| v_var := + {| vtype := sint; vname := "i.194" |}; + v_info := + xO + (xO + (xO xH)) |}) + (((UpTo, Pconst Z0), + Papp2 (Omul Op_int) + (Pconst + (Zpos + (xO + (xI + (xO xH))))) + (Pconst + (Zpos + (xO + (xI + (xO xH))))))) + ([MkI + (xI + (xO + (xI xH))) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "tmp.195" |}; + v_info := + xO + (xO + (xO + (xO xH))) |}) + (AT_none) (sword U64) + (Pget (AAscale) (U64) + ({| gv := + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI + xH))))))))); + vname := "mz.198" |}; + v_info := + xI + (xI + (xI xH)) |}; + gs := Slocal |}) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "i.194" |}; + v_info := + xO + (xI + (xI xH)) |}; + gs := Slocal |}))); + MkI + (xI + (xO + (xO xH))) + (Cassgn + (Lmem (U64) + ({| v_var := + {| vtype := + sword U64; + vname := "z.193" |}; + v_info := + xO + (xO + (xI xH)) |}) + (Papp1 (Oword_of_int U64) + (Papp2 (Omul Op_int) + (Pconst + (Zpos + (xO + (xO + (xO xH))))) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "i.194" |}; + v_info := + xI + (xI + (xO xH)) |}; + gs := Slocal |})))) + (AT_none) (sword U64) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "tmp.195" |}; + v_info := + xO + (xI + (xO xH)) |}; + gs := Slocal |}))]))]; + f_tyout := []; f_res := []; f_extra := tt |}); + (xI + (xO + (xI (xO xH))), + {| f_info := + xI + (xO + (xO + (xI + (xO xH)))); + f_tyin := + [sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI xH))))))))); + sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI xH))))))))); + sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI xH)))))))))]; + f_params := + [{| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI xH))))))))); + vname := "m1.199" |}; + v_info := + xO + (xI + (xO + (xI + (xO xH)))) |}; + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI xH))))))))); + vname := "m2.200" |}; + v_info := + xI + (xI + (xO + (xI + (xO xH)))) |}; + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI xH))))))))); + vname := "res.201" |}; + v_info := + xO + (xO + (xI + (xI + (xO xH)))) |}]; + f_body := + [MkI + (xO + (xO + (xI + (xO + (xO + (xO xH)))))) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI + xH))))))))); + vname := "pres.202" |}; + v_info := + xO + (xI + (xI + (xO + (xO + (xO xH))))) |}) + (AT_none) + (sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI xH)))))))))) + (Pvar + {| gv := + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI + xH))))))))); + vname := "res.201" |}; + v_info := + xI + (xO + (xI + (xO + (xO + (xO xH))))) |}; + gs := Slocal |})); + MkI + (xO + (xO + (xO + (xO + (xO + (xO xH)))))) + (Ccall (DoNotInline) + ([Lvar + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI + xH))))))))); + vname := "m2t.203" |}; + v_info := + xI + (xI + (xO + (xO + (xO + (xO xH))))) |}]) + (xO + (xO + (xO + (xO + (xI xH))))) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI + xH))))))))); + vname := "m2.200" |}; + v_info := + xI + (xO + (xO + (xO + (xO + (xO xH))))) |}; + gs := Slocal |}; + Pvar + {| gv := + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI + xH))))))))); + vname := "m2t.203" |}; + v_info := + xO + (xI + (xO + (xO + (xO + (xO xH))))) |}; + gs := Slocal |}])); + MkI + (xI + (xO + (xI + (xO + (xI xH))))) + (Cfor + ({| v_var := + {| vtype := sint; vname := "i.204" |}; + v_info := + xO + (xI + (xI + (xO + (xI xH)))) |}) + (((UpTo, Pconst Z0), + Pconst + (Zpos + (xO + (xI + (xO xH)))))) + ([MkI + (xI + (xI + (xI + (xO + (xI xH))))) + (Ccall (DoNotInline) + ([Lasub (AAscale) (U64) + (xO + (xI + (xO xH))) + ({| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI + xH))))))))); + vname := "rest.205" |}; + v_info := + xI + (xI + (xI + (xI + (xI xH)))) |}) + (Papp2 (Omul Op_int) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "i.204" |}; + v_info := + xO + (xI + (xI + (xI + (xI xH)))) |}; + gs := Slocal |}) + (Pconst + (Zpos + (xO + (xI + (xO xH))))))]) + (xI + (xO + (xI + (xI + (xI xH))))) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI + xH))))))))); + vname := "m1.199" |}; + v_info := + xO + (xO + (xO + (xI + (xI xH)))) |}; + gs := Slocal |}; + Psub (AAscale) (U64) + (xO + (xI + (xO xH))) + ({| gv := + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI + xH))))))))); + vname := "m2t.203" |}; + v_info := + xO + (xI + (xO + (xI + (xI xH)))) |}; + gs := Slocal |}) + (Papp2 (Omul Op_int) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "i.204" |}; + v_info := + xI + (xO + (xO + (xI + (xI xH)))) |}; + gs := Slocal |}) + (Pconst + (Zpos + (xO + (xI + (xO xH)))))); + Psub (AAscale) (U64) + (xO + (xI + (xO xH))) + ({| gv := + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI + xH))))))))); + vname := "rest.205" |}; + v_info := + xO + (xO + (xI + (xI + (xI xH)))) |}; + gs := Slocal |}) + (Papp2 (Omul Op_int) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "i.204" |}; + v_info := + xI + (xI + (xO + (xI + (xI xH)))) |}; + gs := Slocal |}) + (Pconst + (Zpos + (xO + (xI + (xO xH))))))]))])); + MkI + (xO + (xI + (xO + (xO + (xI xH))))) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI + xH))))))))); + vname := "res.201" |}; + v_info := + xO + (xO + (xI + (xO + (xI xH)))) |}) + (AT_none) + (sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI xH)))))))))) + (Pvar + {| gv := + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI + xH))))))))); + vname := "pres.202" |}; + v_info := + xI + (xI + (xO + (xO + (xI xH)))) |}; + gs := Slocal |})); + MkI + (xI + (xO + (xI + (xI + (xO xH))))) + (Ccall (DoNotInline) + ([Lvar + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI + xH))))))))); + vname := "res.201" |}; + v_info := + xI + (xO + (xO + (xO + (xI xH)))) |}]) + (xO + (xO + (xO + (xO + (xI xH))))) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI + xH))))))))); + vname := "rest.205" |}; + v_info := + xO + (xI + (xI + (xI + (xO xH)))) |}; + gs := Slocal |}; + Pvar + {| gv := + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI + xH))))))))); + vname := "res.201" |}; + v_info := + xI + (xI + (xI + (xI + (xO xH)))) |}; + gs := Slocal |}]))]; + f_tyout := + [sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI xH)))))))))]; + f_res := + [{| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI xH))))))))); + vname := "res.201" |}; + v_info := + xI + (xI + (xI + (xO + (xO + (xO xH))))) |}]; + f_extra := tt |}); + (xO + (xO + (xO + (xO + (xI xH)))), + {| f_info := + xO + (xO + (xO + (xI + (xO + (xO xH))))); + f_tyin := + [sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI xH))))))))); + sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI xH)))))))))]; + f_params := + [{| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI xH))))))))); + vname := "m.206" |}; + v_info := + xI + (xO + (xO + (xI + (xO + (xO xH))))) |}; + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI xH))))))))); + vname := "res.207" |}; + v_info := + xO + (xI + (xO + (xI + (xO + (xO xH))))) |}]; + f_body := + [MkI + (xI + (xI + (xO + (xI + (xO + (xO xH)))))) + (Cfor + ({| v_var := + {| vtype := sint; vname := "i.208" |}; + v_info := + xO + (xO + (xI + (xI + (xO + (xO xH))))) |}) + (((UpTo, Pconst Z0), + Pconst + (Zpos + (xO + (xI + (xO xH)))))) + ([MkI + (xI + (xO + (xI + (xI + (xO + (xO xH)))))) + (Cfor + ({| v_var := + {| vtype := sint; + vname := "j.209" |}; + v_info := + xO + (xI + (xI + (xI + (xO + (xO xH))))) |}) + (((UpTo, Pconst Z0), + Pconst + (Zpos + (xO + (xI + (xO xH)))))) + ([MkI + (xO + (xO + (xI + (xO + (xI + (xO xH)))))) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "tmp.210" |}; + v_info := + xO + (xO + (xO + (xI + (xI + (xO xH))))) |}) + (AT_none) (sword U64) + (Pget (AAscale) (U64) + ({| gv := + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI + xH))))))))); + vname := "m.206" |}; + v_info := + xI + (xI + (xI + (xO + (xI + (xO xH))))) |}; + gs := Slocal |}) + (Papp2 (Oadd Op_int) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "j.209" |}; + v_info := + xO + (xI + (xI + (xO + (xI + (xO xH))))) |}; + gs := Slocal |}) + (Papp2 (Omul Op_int) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "i.208" |}; + v_info := + xI + (xO + (xI + (xO + (xI + (xO + xH))))) |}; + gs := Slocal |}) + (Pconst + (Zpos + (xO + (xI + (xO xH))))))))); + MkI + (xI + (xI + (xI + (xI + (xO + (xO xH)))))) + (Cassgn + (Laset (AAscale) + (U64) + ({| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI + xH))))))))); + vname := "res.207" |}; + v_info := + xI + (xI + (xO + (xO + (xI + (xO xH))))) |}) + (Papp2 (Oadd Op_int) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "i.208" |}; + v_info := + xO + (xI + (xO + (xO + (xI + (xO + xH))))) |}; + gs := Slocal |}) + (Papp2 (Omul Op_int) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "j.209" |}; + v_info := + xI + (xO + (xO + (xO + (xI + (xO + xH))))) |}; + gs := Slocal |}) + (Pconst + (Zpos + (xO + (xI + (xO xH)))))))) + (AT_none) (sword U64) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "tmp.210" |}; + v_info := + xO + (xO + (xO + (xO + (xI + (xO xH))))) |}; + gs := Slocal |}))]))]))]; + f_tyout := + [sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI xH)))))))))]; + f_res := + [{| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI xH))))))))); + vname := "res.207" |}; + v_info := + xI + (xO + (xO + (xI + (xI + (xO xH))))) |}]; + f_extra := tt |}); + (xI + (xO + (xI + (xI + (xI xH)))), + {| f_info := + xO + (xI + (xO + (xI + (xI + (xO xH))))); + f_tyin := + [sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI xH))))))))); + sarr + (xO + (xO + (xO + (xO + (xI + (xO xH)))))); + sarr + (xO + (xO + (xO + (xO + (xI + (xO xH))))))]; + f_params := + [{| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI xH))))))))); + vname := "m.211" |}; + v_info := + xI + (xI + (xO + (xI + (xI + (xO xH))))) |}; + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xI + (xO xH)))))); + vname := "v.212" |}; + v_info := + xO + (xO + (xI + (xI + (xI + (xO xH))))) |}; + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xI + (xO xH)))))); + vname := "res.213" |}; + v_info := + xI + (xO + (xI + (xI + (xI + (xO xH))))) |}]; + f_body := + [MkI + (xO + (xI + (xI + (xI + (xI + (xO xH)))))) + (Cfor + ({| v_var := + {| vtype := sint; vname := "i.214" |}; + v_info := + xI + (xI + (xI + (xI + (xI + (xO xH))))) |}) + (((UpTo, Pconst Z0), + Pconst + (Zpos + (xO + (xI + (xO xH)))))) + ([MkI + (xO + (xO + (xI + (xO + (xO + (xI xH)))))) + (Ccall (DoNotInline) + ([Lvar + {| v_var := + {| vtype := + sword U64; + vname := "tmp.215" |}; + v_info := + xI + (xO + (xO + (xI + (xO + (xI xH))))) |}]) + (xO + (xO + (xO + (xI + (xO + (xI xH)))))) + ([Psub (AAscale) (U64) + (xO + (xI + (xO xH))) + ({| gv := + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO + (xI + (xO + (xO + (xI + xH))))))))); + vname := "m.211" |}; + v_info := + xO + (xI + (xI + (xO + (xO + (xI xH))))) |}; + gs := Slocal |}) + (Papp2 (Omul Op_int) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "i.214" |}; + v_info := + xI + (xO + (xI + (xO + (xO + (xI xH))))) |}; + gs := Slocal |}) + (Pconst + (Zpos + (xO + (xI + (xO xH)))))); + Pvar + {| gv := + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xI + (xO xH)))))); + vname := "v.212" |}; + v_info := + xI + (xI + (xI + (xO + (xO + (xI xH))))) |}; + gs := Slocal |}])); + MkI + (xO + (xO + (xO + (xO + (xO + (xI xH)))))) + (Cassgn + (Laset (AAscale) (U64) + ({| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xI + (xO xH)))))); + vname := "res.213" |}; + v_info := + xI + (xI + (xO + (xO + (xO + (xI xH))))) |}) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "i.214" |}; + v_info := + xO + (xI + (xO + (xO + (xO + (xI xH))))) |}; + gs := Slocal |})) + (AT_none) (sword U64) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "tmp.215" |}; + v_info := + xI + (xO + (xO + (xO + (xO + (xI xH))))) |}; + gs := Slocal |}))]))]; + f_tyout := + [sarr + (xO + (xO + (xO + (xO + (xI + (xO xH))))))]; + f_res := + [{| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xI + (xO xH)))))); + vname := "res.213" |}; + v_info := + xO + (xI + (xO + (xI + (xO + (xI xH))))) |}]; + f_extra := tt |}); + (xO + (xO + (xO + (xI + (xO + (xI xH))))), + {| f_info := + xI + (xI + (xO + (xI + (xO + (xI xH))))); + f_tyin := + [sarr + (xO + (xO + (xO + (xO + (xI + (xO xH)))))); + sarr + (xO + (xO + (xO + (xO + (xI + (xO xH))))))]; + f_params := + [{| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xI + (xO xH)))))); + vname := "v1.216" |}; + v_info := + xO + (xO + (xI + (xI + (xO + (xI xH))))) |}; + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xI + (xO xH)))))); + vname := "v2.217" |}; + v_info := + xI + (xO + (xI + (xI + (xO + (xI xH))))) |}]; + f_body := + [MkI + (xI + (xO + (xI + (xI + (xI + (xI xH)))))) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "res.218" |}; + v_info := + xO + (xI + (xI + (xI + (xI + (xI xH))))) |}) + (AT_none) (sword U64) + (Papp1 (Oword_of_int U64) + (Pconst Z0))); + MkI + (xO + (xI + (xI + (xI + (xO + (xI xH)))))) + (Cfor + ({| v_var := + {| vtype := sint; vname := "i.219" |}; + v_info := + xI + (xI + (xI + (xI + (xO + (xI xH))))) |}) + (((UpTo, Pconst Z0), + Pconst + (Zpos + (xO + (xI + (xO xH)))))) + ([MkI + (xI + (xO + (xO + (xI + (xI + (xI xH)))))) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "tmp.220" |}; + v_info := + xO + (xO + (xI + (xI + (xI + (xI xH))))) |}) + (AT_none) (sword U64) + (Pget (AAscale) (U64) + ({| gv := + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xI + (xO xH)))))); + vname := "v1.216" |}; + v_info := + xI + (xI + (xO + (xI + (xI + (xI xH))))) |}; + gs := Slocal |}) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "i.219" |}; + v_info := + xO + (xI + (xO + (xI + (xI + (xI xH))))) |}; + gs := Slocal |}))); + MkI + (xO + (xO + (xI + (xO + (xI + (xI xH)))))) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "tmp.220" |}; + v_info := + xO + (xO + (xO + (xI + (xI + (xI xH))))) |}) + (AT_none) (sword U64) + (Papp2 + (Omul (Op_w U64)) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "tmp.220" |}; + v_info := + xI + (xI + (xI + (xO + (xI + (xI xH))))) |}; + gs := Slocal |}) + (Pget (AAscale) (U64) + ({| gv := + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xI + (xO xH)))))); + vname := "v2.217" |}; + v_info := + xO + (xI + (xI + (xO + (xI + (xI xH))))) |}; + gs := Slocal |}) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "i.219" |}; + v_info := + xI + (xO + (xI + (xO + (xI + (xI xH))))) |}; + gs := Slocal |})))); + MkI + (xO + (xO + (xO + (xO + (xI + (xI xH)))))) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "res.218" |}; + v_info := + xI + (xI + (xO + (xO + (xI + (xI xH))))) |}) + (AT_none) (sword U64) + (Papp2 + (Oadd (Op_w U64)) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "res.218" |}; + v_info := + xO + (xI + (xO + (xO + (xI + (xI xH))))) |}; + gs := Slocal |}) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "tmp.220" |}; + v_info := + xI + (xO + (xO + (xO + (xI + (xI xH))))) |}; + gs := Slocal |})))]))]; + f_tyout := [sword U64]; + f_res := + [{| v_var := + {| vtype := sword U64; + vname := "res.218" |}; + v_info := + xI + (xI + (xI + (xI + (xI + (xI xH))))) |}]; + f_extra := tt |})]; + p_globs := []; p_extra := tt |} +. \ No newline at end of file diff --git a/jasmin/print_vname.cmi b/jasmin/print_vname.cmi new file mode 100644 index 0000000000000000000000000000000000000000..fef7128756afd1ed22d1f5a9ebbcf945e7bebc88 GIT binary patch literal 592 zcmZ=x%*`>hw6ydzFtTWwx@;c<1H%R&RtMr9AZ}Tp9Z-~+R}x>AmzbNnV8a6K0tAH7;~{BziFKo7}&z1$pU-@pSbOwPVB4h{=h)Epcf zAbwyB0lM7?i1z^T^aUuMm|#%ATq(RdZYJADCF9MHtT)VCus|2$`1ttJZKFceEV*_4kY>fq^t=B7Bx1G zcTT@+T-0r@am^yzW5EI)nEss1;*tplqUS!SMx044J0^C*pY!U5S4d6(hPJWM1OvSs zhQlf)o4$c zy%T>~vN2dFDFn5@PF>QtU;#9qCKw!&iB)qV!Z literal 0 HcmV?d00001 diff --git a/jasmin/print_vname.cmo b/jasmin/print_vname.cmo new file mode 100644 index 0000000000000000000000000000000000000000..7161344efb9609b08cae5c8e3d0e58d98b3e7ec9 GIT binary patch literal 556 zcmZ=x%*`>hw6yd$FtT7^U}y*d5`sXi3B+1J%m~HYKpLa~1Vn&X5r|=Y0U%omh?9X> z1BjV`SR05z;Qjyq|G9v)J($P9APl5IW?Dk|EmN261B%Q5a-D(rD-fUI02!klP?VWh z5?_{=n422FP_SUZ#7TO=B`GXOC<3)CPUnP6~8CRWWcC2^~>kwnqbz*oEr7O+@OFeqTI z6kZ)SlkKCD@#aU?8|E!oVBrjmb)chCi}Dh4+`xh9lvtdZTs* reg u64 { +reg u64 z; +z = 0; +return z; +} diff --git a/jasmin/retz/retz.v b/jasmin/retz/retz.v new file mode 100644 index 00000000..c81c5463 --- /dev/null +++ b/jasmin/retz/retz.v @@ -0,0 +1,39 @@ +Require Import List. +From Jasmin Require Import expr. +From Jasmin Require Import x86_extra. + +Import ListNotations. +Local Open Scope string. + +Definition retz := + {| p_funcs := + [(xO xH, + {| f_info := xI xH; + f_tyin := []; f_params := []; + f_body := + [MkI + (xO + (xO xH)) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "z.128" |}; + v_info := + xI + (xO xH) |}) + (AT_none) (sword U64) + (Papp1 (Oword_of_int U64) + (Pconst Z0)))]; + f_tyout := [sword U64]; + f_res := + [{| v_var := + {| vtype := sword U64; + vname := "z.128" |}; + v_info := + xO + (xI xH) |}]; + f_extra := tt |})]; + p_globs := []; p_extra := tt |} +. \ No newline at end of file diff --git a/jasmin/test_for/test_for.cprog b/jasmin/test_for/test_for.cprog new file mode 100644 index 00000000..21e51ff8 --- /dev/null +++ b/jasmin/test_for/test_for.cprog @@ -0,0 +1,75 @@ + {Jasmin.Expr.p_funcs = + [(Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH, + {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH; + f_tyin = []; f_params = []; + f_body = + [Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = r.130}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U64, + Jasmin.Expr.Pconst Jasmin.BinNums.Z0))); + Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH), + Jasmin.Expr.Cfor + ({Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = i.131}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)}, + ((Jasmin.Expr.DownTo, Jasmin.Expr.Pconst Jasmin.BinNums.Z0), + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))), + [Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = r.130}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Papp2 + (Jasmin.Expr.Oadd (Jasmin.Expr.Op_w Jasmin.Wsize.U64), + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = r.130}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U64, + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos Jasmin.BinNums.Coq_xH)))))]))]; + f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = r.130}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}]; + f_extra = ()})]; + p_globs = []; p_extra = ()} diff --git a/jasmin/test_for/test_for.jazz b/jasmin/test_for/test_for.jazz new file mode 100644 index 00000000..6ab80164 --- /dev/null +++ b/jasmin/test_for/test_for.jazz @@ -0,0 +1,10 @@ +export +fn f() -> reg u64 { +reg u64 r; +inline int i; +r = 0; +for i = 3 downto 0 { +r += 1; +} +return r; +} diff --git a/jasmin/test_for/test_for.v b/jasmin/test_for/test_for.v new file mode 100644 index 00000000..dec832f0 --- /dev/null +++ b/jasmin/test_for/test_for.v @@ -0,0 +1,84 @@ +Require Import List. +From Jasmin Require Import expr. +From Jasmin Require Import x86_extra. + +Import ListNotations. +Local Open Scope string. + +Definition test_for := + {| p_funcs := + [(xO xH, + {| f_info := xI xH; + f_tyin := []; f_params := []; + f_body := + [MkI + (xI + (xO + (xO xH))) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "r.130" |}; + v_info := + xO + (xI + (xO xH)) |}) + (AT_none) (sword U64) + (Papp1 (Oword_of_int U64) + (Pconst Z0))); + MkI + (xO + (xO xH)) + (Cfor + ({| v_var := + {| vtype := sint; vname := "i.131" |}; + v_info := + xI + (xO xH) |}) + (((DownTo, Pconst Z0), + Pconst + (Zpos + (xI xH)))) + ([MkI + (xO + (xI xH)) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "r.130" |}; + v_info := + xO + (xO + (xO xH)) |}) + (AT_none) (sword U64) + (Papp2 + (Oadd (Op_w U64)) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "r.130" |}; + v_info := + xI + (xI xH) |}; + gs := Slocal |}) + (Papp1 (Oword_of_int U64) + (Pconst + (Zpos xH)))))]))]; + f_tyout := [sword U64]; + f_res := + [{| v_var := + {| vtype := sword U64; + vname := "r.130" |}; + v_info := + xI + (xI + (xO xH)) |}]; + f_extra := tt |})]; + p_globs := []; p_extra := tt |} +. \ No newline at end of file diff --git a/jasmin/test_inline_var/test_inline_var.cprog b/jasmin/test_inline_var/test_inline_var.cprog new file mode 100644 index 00000000..490cf63d --- /dev/null +++ b/jasmin/test_inline_var/test_inline_var.cprog @@ -0,0 +1,283 @@ + {Jasmin.Expr.p_funcs = + [(Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH, + {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH; + f_tyin = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = r1.135}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)}]; + f_body = + [Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = r.136}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = r1.135}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}; + gs = Jasmin.Expr.Slocal})); + Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)), + Jasmin.Expr.Ccall (Jasmin.Expr.InlineFun, + [Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = r.136}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}], + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH), + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = r.136}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U64, + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))])); + Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)), + Jasmin.Expr.Ccall (Jasmin.Expr.InlineFun, + [Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = r.136}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}], + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH), + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = r.136}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U64, + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))])); + Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH), + Jasmin.Expr.Ccall (Jasmin.Expr.InlineFun, + [Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = r.136}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}], + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH), + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = r.136}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U64, + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))]))]; + f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = r.136}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}]; + f_extra = ()}); + (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH), + {Jasmin.Expr.f_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))); + f_tyin = + [Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = r.137}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}; + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = n.138}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}]; + f_body = + [Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = r.137}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Papp2 + (Jasmin.Expr.Oadd (Jasmin.Expr.Op_w Jasmin.Wsize.U64), + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = r.137}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = n.138}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}; + gs = Jasmin.Expr.Slocal}))); + Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = r.137}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Papp2 + (Jasmin.Expr.Oadd (Jasmin.Expr.Op_w Jasmin.Wsize.U64), + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = r.137}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Papp2 + (Jasmin.Expr.Oadd (Jasmin.Expr.Op_w Jasmin.Wsize.U64), + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = n.138}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = n.138}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}; + gs = Jasmin.Expr.Slocal}))))]; + f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = r.137}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}]; + f_extra = ()})]; + p_globs = []; p_extra = ()} diff --git a/jasmin/test_inline_var/test_inline_var.jazz b/jasmin/test_inline_var/test_inline_var.jazz new file mode 100644 index 00000000..c07f94b8 --- /dev/null +++ b/jasmin/test_inline_var/test_inline_var.jazz @@ -0,0 +1,15 @@ +inline +fn addn (reg u64 r, inline u64 n) -> reg u64 { + r = r + n; + r = r + (n + n); + return r; +} + +export fn f(reg u64 r1) -> reg u64 { +reg u64 r; +r = r1; +r = addn(r, 6); +r = addn(r, 3); +r = addn(r, 5); +return r; +} diff --git a/jasmin/test_inline_var/test_inline_var.v b/jasmin/test_inline_var/test_inline_var.v new file mode 100644 index 00000000..cb8c6fe0 --- /dev/null +++ b/jasmin/test_inline_var/test_inline_var.v @@ -0,0 +1,292 @@ +Require Import List. +From Jasmin Require Import expr. +From Jasmin Require Import x86_extra. + +Import ListNotations. +Local Open Scope string. + +Definition test_inline_var := + {| p_funcs := + [(xO xH, + {| f_info := xI xH; + f_tyin := [sword U64]; + f_params := + [{| v_var := + {| vtype := sword U64; + vname := "r1.135" |}; + v_info := + xO + (xO xH) |}]; + f_body := + [MkI + (xI + (xI + (xI xH))) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "r.136" |}; + v_info := + xI + (xO + (xO + (xO xH))) |}) + (AT_none) (sword U64) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "r1.135" |}; + v_info := + xO + (xO + (xO + (xO xH))) |}; + gs := Slocal |})); + MkI + (xO + (xO + (xI xH))) + (Ccall (InlineFun) + ([Lvar + {| v_var := + {| vtype := + sword U64; + vname := "r.136" |}; + v_info := + xO + (xI + (xI xH)) |}]) + (xI + (xI xH)) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "r.136" |}; + v_info := + xI + (xO + (xI xH)) |}; + gs := Slocal |}; + Papp1 (Oword_of_int U64) + (Pconst + (Zpos + (xO + (xI xH))))])); + MkI + (xI + (xO + (xO xH))) + (Ccall (InlineFun) + ([Lvar + {| v_var := + {| vtype := + sword U64; + vname := "r.136" |}; + v_info := + xI + (xI + (xO xH)) |}]) + (xI + (xI xH)) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "r.136" |}; + v_info := + xO + (xI + (xO xH)) |}; + gs := Slocal |}; + Papp1 (Oword_of_int U64) + (Pconst + (Zpos + (xI xH)))])); + MkI + (xI + (xO xH)) + (Ccall (InlineFun) + ([Lvar + {| v_var := + {| vtype := + sword U64; + vname := "r.136" |}; + v_info := + xO + (xO + (xO xH)) |}]) + (xI + (xI xH)) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "r.136" |}; + v_info := + xO + (xI xH) |}; + gs := Slocal |}; + Papp1 (Oword_of_int U64) + (Pconst + (Zpos + (xI + (xO xH))))]))]; + f_tyout := [sword U64]; + f_res := + [{| v_var := + {| vtype := sword U64; + vname := "r.136" |}; + v_info := + xO + (xI + (xO + (xO xH))) |}]; + f_extra := tt |}); + (xI (xI xH), + {| f_info := + xI + (xI + (xO + (xO xH))); + f_tyin := + [sword U64; + sword U64]; + f_params := + [{| v_var := + {| vtype := sword U64; + vname := "r.137" |}; + v_info := + xO + (xO + (xI + (xO xH))) |}; + {| v_var := + {| vtype := sword U64; + vname := "n.138" |}; + v_info := + xI + (xO + (xI + (xO xH))) |}]; + f_body := + [MkI + (xI + (xI + (xO + (xI xH)))) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "r.137" |}; + v_info := + xO + (xI + (xI + (xI xH))) |}) + (AT_none) (sword U64) + (Papp2 + (Oadd (Op_w U64)) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "r.137" |}; + v_info := + xI + (xO + (xI + (xI xH))) |}; + gs := Slocal |}) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "n.138" |}; + v_info := + xO + (xO + (xI + (xI xH))) |}; + gs := Slocal |}))); + MkI + (xO + (xI + (xI + (xO xH)))) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "r.137" |}; + v_info := + xO + (xI + (xO + (xI xH))) |}) + (AT_none) (sword U64) + (Papp2 + (Oadd (Op_w U64)) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "r.137" |}; + v_info := + xI + (xO + (xO + (xI xH))) |}; + gs := Slocal |}) + (Papp2 + (Oadd (Op_w U64)) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "n.138" |}; + v_info := + xO + (xO + (xO + (xI xH))) |}; + gs := Slocal |}) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "n.138" |}; + v_info := + xI + (xI + (xI + (xO xH))) |}; + gs := Slocal |}))))]; + f_tyout := [sword U64]; + f_res := + [{| v_var := + {| vtype := sword U64; + vname := "r.137" |}; + v_info := + xI + (xI + (xI + (xI xH))) |}]; + f_extra := tt |})]; + p_globs := []; p_extra := tt |} +. \ No newline at end of file diff --git a/jasmin/test_shift/test_shift.cprog b/jasmin/test_shift/test_shift.cprog new file mode 100644 index 00000000..66921c17 --- /dev/null +++ b/jasmin/test_shift/test_shift.cprog @@ -0,0 +1,46 @@ + {Jasmin.Expr.p_funcs = + [(Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH, + {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH; + f_tyin = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = a.131}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)}]; + f_body = + [Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = u.132}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U64, + Jasmin.Expr.Papp2 (Jasmin.Expr.Osub Jasmin.Expr.Op_int, + Jasmin.Expr.Papp2 (Jasmin.Expr.Olsl Jasmin.Expr.Op_int, + Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos Jasmin.BinNums.Coq_xH), + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))), + Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos Jasmin.BinNums.Coq_xH)))))]; + f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = u.132}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)}]; + f_extra = ()})]; + p_globs = []; p_extra = ()} diff --git a/jasmin/test_shift/test_shift.jazz b/jasmin/test_shift/test_shift.jazz new file mode 100644 index 00000000..8eb53c35 --- /dev/null +++ b/jasmin/test_shift/test_shift.jazz @@ -0,0 +1,9 @@ +param int rlog = 18; + +export fn reduce(reg u64 a) -> reg u64 +{ + reg u64 u; + u = (1 << rlog) - 1 ; + return u; +} + diff --git a/jasmin/test_shift/test_shift.v b/jasmin/test_shift/test_shift.v new file mode 100644 index 00000000..0e644534 --- /dev/null +++ b/jasmin/test_shift/test_shift.v @@ -0,0 +1,55 @@ +Require Import List. +From Jasmin Require Import expr. +From Jasmin Require Import x86_extra. + +Import ListNotations. +Local Open Scope string. + +Definition test_shift := + {| p_funcs := + [(xO xH, + {| f_info := xI xH; + f_tyin := [sword U64]; + f_params := + [{| v_var := + {| vtype := sword U64; + vname := "a.131" |}; + v_info := + xO + (xO xH) |}]; + f_body := + [MkI + (xI + (xO xH)) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "u.132" |}; + v_info := + xO + (xI xH) |}) + (AT_none) (sword U64) + (Papp1 (Oword_of_int U64) + (Papp2 (Osub Op_int) + (Papp2 (Olsl Op_int) + (Pconst (Zpos xH)) + (Pconst + (Zpos + (xO + (xI + (xO + (xO xH))))))) + (Pconst (Zpos xH)))))]; + f_tyout := [sword U64]; + f_res := + [{| v_var := + {| vtype := sword U64; + vname := "u.132" |}; + v_info := + xI + (xI xH) |}]; + f_extra := tt |})]; + p_globs := []; p_extra := tt |} +. \ No newline at end of file From af42cd1d1dfbeea56a409072ad5477cbdca4dd5d Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Wed, 23 Mar 2022 18:17:25 +0100 Subject: [PATCH 004/383] update scripts --- depgraph.sh | 2 +- jasmin/gen_ast.sh | 10 ++++++---- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/depgraph.sh b/depgraph.sh index 0dadadbc..addb5e94 100755 --- a/depgraph.sh +++ b/depgraph.sh @@ -61,6 +61,6 @@ fi # fat border around modules without clients gvpr -c 'N[indegree == 0]{penwidth=3}' > $fn_out.dot -dot -T svg $fn_out.dot > $fn_out.svg +dot -T pdf $fn_out.dot > ${fn_out}.pdf # dot -T png $fn_out.dot > $fn_out.png # dot -T cmap $fn_out.dot | $SED -e 's,>$,/>,' > $fn_out.map diff --git a/jasmin/gen_ast.sh b/jasmin/gen_ast.sh index 33ac1a7b..4eda692f 100644 --- a/jasmin/gen_ast.sh +++ b/jasmin/gen_ast.sh @@ -1,5 +1,9 @@ #!/bin/bash +# set path to jasminc.byte on command line by invoking the script with +# JASMINC=... ./gen_ast.sh foo.jazz +JASMINC=${JASMINC:-$(which jasminc.byte)} + echo "open Format let print_vname (fmt : formatter) (t : Obj.t) = @@ -22,13 +26,13 @@ Local Open Scope string. Definition ${name} :=" > $name/$name.v -(ocamldebug $(which jasminc.byte) <>/g ; t rename_balanced ; :rename_pairs1 ; s/\([{([|,;][ \t\n]*([^(),]*\),/\1%/g; t rename_pairs1 ; :rename_pairs ; s/\([{([|,;][ \t\n]*\)(\([^(),]*\))/\1<<\2>>/g; t rename_balanced ; :rename_curries1 ; s/\([^{([|,;][ \t\n]*([^()]*\),/\1@/g; t rename_curries1; :rename_curries ; s/\([^{([|,;][ \t\n]*\)(\([^(),]*\))/\1++\2##/g; t rename_balanced; :uncurry ; s/\([^{([|,;][ \t\n]*++[^(),]*\)@\([ \t\n]*\)/\1##\2++/g ; t uncurry s/\([^{([|][ \t\n]*++[^(),]*\)@\([ \t\n]*\)/\1##\2++/g ; t uncurry ; s/<>/)/g ; s/##/)/g ; s/++/(/g ; s/%/,/g ; s/@/,/g' $name/$name.cprog >> $name/$name.v echo -n "." >> $name/$name.v - -mv $name.jazz $name From 0ec7d2bb8b986c7b5640fa91cb6e1281a37f3c8f Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Fri, 25 Mar 2022 10:15:14 +0100 Subject: [PATCH 005/383] Import jasmin translation stub, move jasmin examples into theories/Jasmin/examples --- .gitignore | 8 + README.md | 16 ++ _CoqProject | 4 + theories/Crypt/choice_type.v | 1 + .../Jasmin/examples}/add1/add1.cprog | 0 .../Jasmin/examples}/add1/add1.jazz | 0 .../Jasmin/examples}/add1/add1.v | 0 .../Jasmin/examples}/bigadd/bigadd.cprog | 0 .../Jasmin/examples}/bigadd/bigadd.jazz | 0 .../Jasmin/examples}/bigadd/bigadd.v | 0 .../Jasmin/examples}/ex/ex.cprog | 0 .../Jasmin/examples}/ex/ex.jazz | 0 {jasmin => theories/Jasmin/examples}/ex/ex.v | 0 .../Jasmin/examples}/gen_ast.sh | 0 .../Jasmin/examples}/identity.v | 0 .../examples/int_operations/int_add.jazz | 16 ++ .../examples/int_operations/int_incr.jazz | 15 ++ .../int_operations/int_intr_wrapper.c | 5 + .../examples/int_operations/int_reg.jazz | 5 + .../examples/int_operations/int_shift.jazz | 13 ++ .../int_operations/liveness_bork.jazz | 7 + .../examples/int_operations/u64_incr.jazz | 11 ++ .../matrix_product/matrix_product.cprog | 0 .../matrix_product/matrix_product.jazz | 0 .../examples}/matrix_product/matrix_product.v | 0 .../Jasmin/examples}/print_vname.cmi | Bin .../Jasmin/examples}/print_vname.cmo | Bin .../Jasmin/examples}/print_vname.ml | 0 .../Jasmin/examples}/retz/retz.cprog | 0 .../Jasmin/examples}/retz/retz.jazz | 0 .../Jasmin/examples}/retz/retz.v | 0 .../Jasmin/examples}/test_for/test_for.cprog | 0 .../Jasmin/examples}/test_for/test_for.jazz | 0 .../Jasmin/examples}/test_for/test_for.v | 0 .../test_inline_var/test_inline_var.cprog | 0 .../test_inline_var/test_inline_var.jazz | 0 .../test_inline_var/test_inline_var.v | 0 .../examples}/test_shift/test_shift.cprog | 0 .../examples}/test_shift/test_shift.jazz | 0 .../Jasmin/examples}/test_shift/test_shift.v | 0 theories/Jasmin/jasmin_translate.v | 164 ++++++++++++++++++ 41 files changed, 265 insertions(+) rename {jasmin => theories/Jasmin/examples}/add1/add1.cprog (100%) rename {jasmin => theories/Jasmin/examples}/add1/add1.jazz (100%) rename {jasmin => theories/Jasmin/examples}/add1/add1.v (100%) rename {jasmin => theories/Jasmin/examples}/bigadd/bigadd.cprog (100%) rename {jasmin => theories/Jasmin/examples}/bigadd/bigadd.jazz (100%) rename {jasmin => theories/Jasmin/examples}/bigadd/bigadd.v (100%) rename {jasmin => theories/Jasmin/examples}/ex/ex.cprog (100%) rename {jasmin => theories/Jasmin/examples}/ex/ex.jazz (100%) rename {jasmin => theories/Jasmin/examples}/ex/ex.v (100%) rename {jasmin => theories/Jasmin/examples}/gen_ast.sh (100%) rename {jasmin => theories/Jasmin/examples}/identity.v (100%) create mode 100644 theories/Jasmin/examples/int_operations/int_add.jazz create mode 100644 theories/Jasmin/examples/int_operations/int_incr.jazz create mode 100644 theories/Jasmin/examples/int_operations/int_intr_wrapper.c create mode 100644 theories/Jasmin/examples/int_operations/int_reg.jazz create mode 100644 theories/Jasmin/examples/int_operations/int_shift.jazz create mode 100644 theories/Jasmin/examples/int_operations/liveness_bork.jazz create mode 100644 theories/Jasmin/examples/int_operations/u64_incr.jazz rename {jasmin => theories/Jasmin/examples}/matrix_product/matrix_product.cprog (100%) rename {jasmin => theories/Jasmin/examples}/matrix_product/matrix_product.jazz (100%) rename {jasmin => theories/Jasmin/examples}/matrix_product/matrix_product.v (100%) rename {jasmin => theories/Jasmin/examples}/print_vname.cmi (100%) rename {jasmin => theories/Jasmin/examples}/print_vname.cmo (100%) rename {jasmin => theories/Jasmin/examples}/print_vname.ml (100%) rename {jasmin => theories/Jasmin/examples}/retz/retz.cprog (100%) rename {jasmin => theories/Jasmin/examples}/retz/retz.jazz (100%) rename {jasmin => theories/Jasmin/examples}/retz/retz.v (100%) rename {jasmin => theories/Jasmin/examples}/test_for/test_for.cprog (100%) rename {jasmin => theories/Jasmin/examples}/test_for/test_for.jazz (100%) rename {jasmin => theories/Jasmin/examples}/test_for/test_for.v (100%) rename {jasmin => theories/Jasmin/examples}/test_inline_var/test_inline_var.cprog (100%) rename {jasmin => theories/Jasmin/examples}/test_inline_var/test_inline_var.jazz (100%) rename {jasmin => theories/Jasmin/examples}/test_inline_var/test_inline_var.v (100%) rename {jasmin => theories/Jasmin/examples}/test_shift/test_shift.cprog (100%) rename {jasmin => theories/Jasmin/examples}/test_shift/test_shift.jazz (100%) rename {jasmin => theories/Jasmin/examples}/test_shift/test_shift.v (100%) create mode 100644 theories/Jasmin/jasmin_translate.v diff --git a/.gitignore b/.gitignore index 175b257e..221fe71e 100644 --- a/.gitignore +++ b/.gitignore @@ -11,6 +11,7 @@ _namecheck_ssprove_csf2021/ *.vos *.glob .coqdeps.d +.coq-native/ # coq_makefile .Makefile.d @@ -55,3 +56,10 @@ Makefile.coq.conf .DS_store .Makefile.coq 2.d + +# OCaml +*.cmo +*.cmi + +# Assembly (ignored because we expect them to be jasminc generated) +*.s diff --git a/README.md b/README.md index 869f9fc5..1499849e 100644 --- a/README.md +++ b/README.md @@ -49,6 +49,22 @@ opam install ./ssprove-opam To build the dependency graph, you can optionally install `graphviz`. On macOS, `gsed` is additionally required for this. +#### Jasmin + +In order to build the `jasmin` branch, a recent version of `https://github.com/jasmin-lang/jasmin` should be installed. This can be done via `opam`, by cloning the `jasmin` repo and running +```sh +cd jasmin +opam install . +``` +The last version of Jasmin that is known to work is `ca721130dd`, but we try to track `main`. + +To install a local copy of Jasmin, one may use +```sh +cd jasmin +make +opam install --assume-built --working-dir ./opam +``` + #### Running verification Run `make` from this directory to verify all the Coq files. diff --git a/_CoqProject b/_CoqProject index de0eb968..9cdb5e76 100644 --- a/_CoqProject +++ b/_CoqProject @@ -1,6 +1,7 @@ -Q theories/Mon Mon -Q theories/Relational Relational -Q theories/Crypt Crypt +-Q theories/Jasmin JasminSSProve theories/Mon/Base.v theories/Mon/SPropBase.v @@ -76,6 +77,9 @@ theories/Crypt/rules/UniformStateProb.v #std. distributions # theories/Crypt/only_prob/SymmetricSchemeStateProbStdDistr.v +# Jasmin +theories/Jasmin/jasmin_translate.v + # Examples theories/Crypt/examples/package_usage_example.v theories/Crypt/examples/interpreter_test.v diff --git a/theories/Crypt/choice_type.v b/theories/Crypt/choice_type.v index d096a3c7..de099190 100644 --- a/theories/Crypt/choice_type.v +++ b/theories/Crypt/choice_type.v @@ -37,6 +37,7 @@ Open Scope type_scope. Inductive choice_type := | chUnit | chNat +(* | chInt *) | chBool | chProd (A B : choice_type) | chMap (A B : choice_type) diff --git a/jasmin/add1/add1.cprog b/theories/Jasmin/examples/add1/add1.cprog similarity index 100% rename from jasmin/add1/add1.cprog rename to theories/Jasmin/examples/add1/add1.cprog diff --git a/jasmin/add1/add1.jazz b/theories/Jasmin/examples/add1/add1.jazz similarity index 100% rename from jasmin/add1/add1.jazz rename to theories/Jasmin/examples/add1/add1.jazz diff --git a/jasmin/add1/add1.v b/theories/Jasmin/examples/add1/add1.v similarity index 100% rename from jasmin/add1/add1.v rename to theories/Jasmin/examples/add1/add1.v diff --git a/jasmin/bigadd/bigadd.cprog b/theories/Jasmin/examples/bigadd/bigadd.cprog similarity index 100% rename from jasmin/bigadd/bigadd.cprog rename to theories/Jasmin/examples/bigadd/bigadd.cprog diff --git a/jasmin/bigadd/bigadd.jazz b/theories/Jasmin/examples/bigadd/bigadd.jazz similarity index 100% rename from jasmin/bigadd/bigadd.jazz rename to theories/Jasmin/examples/bigadd/bigadd.jazz diff --git a/jasmin/bigadd/bigadd.v b/theories/Jasmin/examples/bigadd/bigadd.v similarity index 100% rename from jasmin/bigadd/bigadd.v rename to theories/Jasmin/examples/bigadd/bigadd.v diff --git a/jasmin/ex/ex.cprog b/theories/Jasmin/examples/ex/ex.cprog similarity index 100% rename from jasmin/ex/ex.cprog rename to theories/Jasmin/examples/ex/ex.cprog diff --git a/jasmin/ex/ex.jazz b/theories/Jasmin/examples/ex/ex.jazz similarity index 100% rename from jasmin/ex/ex.jazz rename to theories/Jasmin/examples/ex/ex.jazz diff --git a/jasmin/ex/ex.v b/theories/Jasmin/examples/ex/ex.v similarity index 100% rename from jasmin/ex/ex.v rename to theories/Jasmin/examples/ex/ex.v diff --git a/jasmin/gen_ast.sh b/theories/Jasmin/examples/gen_ast.sh similarity index 100% rename from jasmin/gen_ast.sh rename to theories/Jasmin/examples/gen_ast.sh diff --git a/jasmin/identity.v b/theories/Jasmin/examples/identity.v similarity index 100% rename from jasmin/identity.v rename to theories/Jasmin/examples/identity.v diff --git a/theories/Jasmin/examples/int_operations/int_add.jazz b/theories/Jasmin/examples/int_operations/int_add.jazz new file mode 100644 index 00000000..523e27e2 --- /dev/null +++ b/theories/Jasmin/examples/int_operations/int_add.jazz @@ -0,0 +1,16 @@ +fn odd (reg u64 n, reg u64 m) -> reg u64 { + inline int i; + for i = 0 to n { + m = m + 1; + } + return m; +} + + +inline fn add (inline int n, inline int m) -> inline int { + inline int i; + for i = 0 to n { + m = m + 1; + } + return m; +} diff --git a/theories/Jasmin/examples/int_operations/int_incr.jazz b/theories/Jasmin/examples/int_operations/int_incr.jazz new file mode 100644 index 00000000..13f687e3 --- /dev/null +++ b/theories/Jasmin/examples/int_operations/int_incr.jazz @@ -0,0 +1,15 @@ +inline fn incr(inline int n) -> inline int { + inline int m; + m = (n+1); + return m; + } + +export fn f() -> reg u64 { + inline int x; + reg u64 xx; + reg u64 y; + x = incr(0); + xx = y; + y = ((64u)x); + return y; + } \ No newline at end of file diff --git a/theories/Jasmin/examples/int_operations/int_intr_wrapper.c b/theories/Jasmin/examples/int_operations/int_intr_wrapper.c new file mode 100644 index 00000000..745345a2 --- /dev/null +++ b/theories/Jasmin/examples/int_operations/int_intr_wrapper.c @@ -0,0 +1,5 @@ +extern int f(); + +int main() { + return f(); +} diff --git a/theories/Jasmin/examples/int_operations/int_reg.jazz b/theories/Jasmin/examples/int_operations/int_reg.jazz new file mode 100644 index 00000000..87981cca --- /dev/null +++ b/theories/Jasmin/examples/int_operations/int_reg.jazz @@ -0,0 +1,5 @@ +fn foo (reg int k) -> reg int { + reg int x; + x = k; + return x; + } \ No newline at end of file diff --git a/theories/Jasmin/examples/int_operations/int_shift.jazz b/theories/Jasmin/examples/int_operations/int_shift.jazz new file mode 100644 index 00000000..0c03c4e1 --- /dev/null +++ b/theories/Jasmin/examples/int_operations/int_shift.jazz @@ -0,0 +1,13 @@ +inline fn incr(inline int n) -> inline int { + inline int m; + m = n << 65; + return m; + } + +export fn f() -> reg u64 { + inline int x; + reg u64 y; + x = incr(0); + y = ((64u)x); + return y; + } \ No newline at end of file diff --git a/theories/Jasmin/examples/int_operations/liveness_bork.jazz b/theories/Jasmin/examples/int_operations/liveness_bork.jazz new file mode 100644 index 00000000..0581fff6 --- /dev/null +++ b/theories/Jasmin/examples/int_operations/liveness_bork.jazz @@ -0,0 +1,7 @@ +fn double (reg u64 n) -> reg u64 { + inline int i; + for i = 0 to n { + n = n + 1; + } + return n; +} diff --git a/theories/Jasmin/examples/int_operations/u64_incr.jazz b/theories/Jasmin/examples/int_operations/u64_incr.jazz new file mode 100644 index 00000000..2492336e --- /dev/null +++ b/theories/Jasmin/examples/int_operations/u64_incr.jazz @@ -0,0 +1,11 @@ +inline fn incr(reg u64 n) -> reg u64 { + reg u64 m; + m = (n+2); + return m; + } + +export fn f() -> reg u64 { + reg u64 x; + x = incr(0); + return x; + } \ No newline at end of file diff --git a/jasmin/matrix_product/matrix_product.cprog b/theories/Jasmin/examples/matrix_product/matrix_product.cprog similarity index 100% rename from jasmin/matrix_product/matrix_product.cprog rename to theories/Jasmin/examples/matrix_product/matrix_product.cprog diff --git a/jasmin/matrix_product/matrix_product.jazz b/theories/Jasmin/examples/matrix_product/matrix_product.jazz similarity index 100% rename from jasmin/matrix_product/matrix_product.jazz rename to theories/Jasmin/examples/matrix_product/matrix_product.jazz diff --git a/jasmin/matrix_product/matrix_product.v b/theories/Jasmin/examples/matrix_product/matrix_product.v similarity index 100% rename from jasmin/matrix_product/matrix_product.v rename to theories/Jasmin/examples/matrix_product/matrix_product.v diff --git a/jasmin/print_vname.cmi b/theories/Jasmin/examples/print_vname.cmi similarity index 100% rename from jasmin/print_vname.cmi rename to theories/Jasmin/examples/print_vname.cmi diff --git a/jasmin/print_vname.cmo b/theories/Jasmin/examples/print_vname.cmo similarity index 100% rename from jasmin/print_vname.cmo rename to theories/Jasmin/examples/print_vname.cmo diff --git a/jasmin/print_vname.ml b/theories/Jasmin/examples/print_vname.ml similarity index 100% rename from jasmin/print_vname.ml rename to theories/Jasmin/examples/print_vname.ml diff --git a/jasmin/retz/retz.cprog b/theories/Jasmin/examples/retz/retz.cprog similarity index 100% rename from jasmin/retz/retz.cprog rename to theories/Jasmin/examples/retz/retz.cprog diff --git a/jasmin/retz/retz.jazz b/theories/Jasmin/examples/retz/retz.jazz similarity index 100% rename from jasmin/retz/retz.jazz rename to theories/Jasmin/examples/retz/retz.jazz diff --git a/jasmin/retz/retz.v b/theories/Jasmin/examples/retz/retz.v similarity index 100% rename from jasmin/retz/retz.v rename to theories/Jasmin/examples/retz/retz.v diff --git a/jasmin/test_for/test_for.cprog b/theories/Jasmin/examples/test_for/test_for.cprog similarity index 100% rename from jasmin/test_for/test_for.cprog rename to theories/Jasmin/examples/test_for/test_for.cprog diff --git a/jasmin/test_for/test_for.jazz b/theories/Jasmin/examples/test_for/test_for.jazz similarity index 100% rename from jasmin/test_for/test_for.jazz rename to theories/Jasmin/examples/test_for/test_for.jazz diff --git a/jasmin/test_for/test_for.v b/theories/Jasmin/examples/test_for/test_for.v similarity index 100% rename from jasmin/test_for/test_for.v rename to theories/Jasmin/examples/test_for/test_for.v diff --git a/jasmin/test_inline_var/test_inline_var.cprog b/theories/Jasmin/examples/test_inline_var/test_inline_var.cprog similarity index 100% rename from jasmin/test_inline_var/test_inline_var.cprog rename to theories/Jasmin/examples/test_inline_var/test_inline_var.cprog diff --git a/jasmin/test_inline_var/test_inline_var.jazz b/theories/Jasmin/examples/test_inline_var/test_inline_var.jazz similarity index 100% rename from jasmin/test_inline_var/test_inline_var.jazz rename to theories/Jasmin/examples/test_inline_var/test_inline_var.jazz diff --git a/jasmin/test_inline_var/test_inline_var.v b/theories/Jasmin/examples/test_inline_var/test_inline_var.v similarity index 100% rename from jasmin/test_inline_var/test_inline_var.v rename to theories/Jasmin/examples/test_inline_var/test_inline_var.v diff --git a/jasmin/test_shift/test_shift.cprog b/theories/Jasmin/examples/test_shift/test_shift.cprog similarity index 100% rename from jasmin/test_shift/test_shift.cprog rename to theories/Jasmin/examples/test_shift/test_shift.cprog diff --git a/jasmin/test_shift/test_shift.jazz b/theories/Jasmin/examples/test_shift/test_shift.jazz similarity index 100% rename from jasmin/test_shift/test_shift.jazz rename to theories/Jasmin/examples/test_shift/test_shift.jazz diff --git a/jasmin/test_shift/test_shift.v b/theories/Jasmin/examples/test_shift/test_shift.v similarity index 100% rename from jasmin/test_shift/test_shift.v rename to theories/Jasmin/examples/test_shift/test_shift.v diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v new file mode 100644 index 00000000..7e889ba8 --- /dev/null +++ b/theories/Jasmin/jasmin_translate.v @@ -0,0 +1,164 @@ +Set Warnings "-ambiguous-paths,-notation-overridden,-notation-incompatible-format". +From mathcomp Require Import all_ssreflect. +Set Warnings "ambiguous-paths,notation-overridden,notation-incompatible-format". + +From extructures Require Import ord fset fmap. + +From Jasmin Require Import expr compiler_util values sem. + +From Coq Require Import Utf8. + +From Crypt Require Import Prelude Package. +Import PackageNotation. + + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Set Bullet Behavior "Strict Subproofs". +Set Default Goal Selector "!". +Set Primitive Projections. + +Section Section. + +Context `{asmop:asmOp}. +Context (fresh_counter: Ident.ident). + +Context {T} {pT:progT T}. + + +Context {Loc : {fset Location}}. +Context {import : Interface}. + +Context {pd: PointerData}. + +Variable P:uprog. + +Notation gd := (p_globs P). + +Context {encode : stype -> choice_type}. +Context (embed : forall t, sem_t t -> encode t). + +Definition tr_var : (gvar -> Location). + intros X. destruct X. + destruct gv. + destruct v_var. + constructor. + - apply encode. + exact vtype0. + - assert (Ident.ident -> nat) as db_of_ident. + { intros id. + induction id. + - exact 1. + - exact (256 * IHid + (Ascii.nat_of_ascii a))%nat. + } + exact (db_of_ident vname0). +Defined. + +Definition typed_code := ∑ (a : choice_type), raw_code a. +Local Definition unsupported : typed_code. +Proof. + exists chUnit. + exact (pkg_distr.assert false). +Defined. + +Fixpoint translate_pexpr (e : pexpr) : typed_code. +Proof. + destruct e. + - exact unsupported. + - exists chBool. exact (ret b). + - (* Parr_init only gets produced by ArrayInit() in jasmin source; the EC + export asserts false on it, so we don't support it for now. *) + exact unsupported. + - exact unsupported. + - exact unsupported. + - exact unsupported. + - exact unsupported. + - exact unsupported. + - exact unsupported. + - exact unsupported. + - exact unsupported. +Defined. + +(* FIXME: actually perform the truncation *) +Definition truncate_code (s : stype) (c : typed_code) : typed_code := c. + +Definition ssprove_write_lval (l : lval) (tr_p : typed_code) + : raw_code chUnit + := projT2 unsupported +. + +Definition translate_instr (i : instr) : raw_code chUnit. +Proof. + destruct i as [iinfo i]. destruct i. + - (* Cassgn *) + (* l :a=_s p *) + pose (translate_pexpr p) as tr_p. + pose (truncate_code s tr_p) as tr_p'. + exact (ssprove_write_lval l tr_p'). + - exact (projT2 unsupported). (* Copn *) + - exact (projT2 unsupported). (* Cif *) + - exact (projT2 unsupported). (* Cfor *) + - exact (projT2 unsupported). (* Cwhile *) + - (* Ccall i l f l0 *) + (* translate arguments *) + pose (map translate_pexpr l0) as tr_l0. + (* "perform" the call via `opr` *) + (* probably we'd look up the function signature in the current ambient program *) + + (* write_lvals the result of the call into lvals `l` *) + + exact (projT2 unsupported). +Defined. + +Definition translate_cmd (c : cmd) : raw_code chUnit. +Proof. + (* fold bind translate_instr *) + exact (projT2 unsupported). +Defined. + +Record fdef := { _ : typed_raw_function ; _ : {fset Location} ; _ : Interface ; _ : Interface }. + +Definition translate_fundef (fd : _fun_decl extra_fun_t) : funname * fdef. +Proof. + destruct fd. destruct _f. + split. 1: exact f. + constructor. + - exists chUnit. exists chUnit. + intros u. + (* TODO: store function arguments in their locations *) + exact (translate_cmd f_body). + (* TODO: read return values from their locations *) + - exact fset0. + - exact [interface]. + - exact [interface]. +Defined. + +Fixpoint satisfies_globs (globs : glob_decls) : heap -> Prop. +Proof. + exact (fun x => False). +Defined. + +Fixpoint collect_globs (globs : glob_decls) : seq Location. +Proof. + exact nil. +Defined. + +Definition ssprove_prog {T} := seq (funname * T). + +Definition translate_prog (p:expr.prog) : ssprove_prog := + let globs := collect_globs (p_globs p) in + let fds := map translate_fundef (p_funcs p) in + fds. + +(* Theorem translate_correct entries (p : prog) (fn : funname) m va m' vr rf : *) +(* fn \in entries → *) +(* sem.sem_call p m fn va m' vr → *) +(* let sp := (translate_prog p) in *) +(* get_fundef fn sp = Some rf → *) +(* { satisfies_globs (p_globs p) } rf (fix_types rf (translate_values va)) ~ ret vr *) +(* { λ (v1,s1) (v2,s2), v1 = v2} *) +(* Proof. *) + +End Section. From 81b4c1a86a853b4b15e364b265d74955dadb674d Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Fri, 25 Mar 2022 12:07:48 +0100 Subject: [PATCH 006/383] stated the theorem --- theories/Jasmin/jasmin_translate.v | 68 +++++++++++++++++++++++------- 1 file changed, 53 insertions(+), 15 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 7e889ba8..88c2b0fc 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -11,7 +11,6 @@ From Coq Require Import Utf8. From Crypt Require Import Prelude Package. Import PackageNotation. - Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. @@ -118,9 +117,9 @@ Proof. exact (projT2 unsupported). Defined. -Record fdef := { _ : typed_raw_function ; _ : {fset Location} ; _ : Interface ; _ : Interface }. +Record fdef := { ffun : typed_raw_function ; locs : {fset Location} ; imp : Interface ; exp : Interface }. -Definition translate_fundef (fd : _fun_decl extra_fun_t) : funname * fdef. +Definition translate_fundef (fd : _ufun_decl (* extra_fun_t *)) : funname * fdef. Proof. destruct fd. destruct _f. split. 1: exact f. @@ -135,9 +134,9 @@ Proof. - exact [interface]. Defined. -Fixpoint satisfies_globs (globs : glob_decls) : heap -> Prop. +Fixpoint satisfies_globs (globs : glob_decls) : heap * heap -> Prop. Proof. - exact (fun x => False). + exact (fun '(x, y) => False). Defined. Fixpoint collect_globs (globs : glob_decls) : seq Location. @@ -145,20 +144,59 @@ Proof. exact nil. Defined. -Definition ssprove_prog {T} := seq (funname * T). +Definition ssprove_prog := seq (funname * fdef). -Definition translate_prog (p:expr.prog) : ssprove_prog := +Definition translate_prog (p:uprog) : ssprove_prog := let globs := collect_globs (p_globs p) in let fds := map translate_fundef (p_funcs p) in fds. +Print typed_raw_function. +Check Interface. +About rel_jdg. +About package. +Check value. + +Definition type_of_val : value -> choice_type. +Proof. + intros. + exact chUnit. +Defined. + +Fixpoint lchtuple (ts:seq choice_type) : choice_type := + match ts with + | [::] => chUnit + | [::t1] => t1 + | t1::ts => chProd t1 (lchtuple ts) + end. + +Definition get_fundef_ssp (sp : seq (funname * fdef)) (fn : funname) (dom cod : choice_type) : option (dom -> raw_code cod). +Proof. + exact None. +Defined. + +Definition translate_value : value -> ∑ (T: choice_type), T. +Proof. + intros. exists chUnit. exact. +Defined. -(* Theorem translate_correct entries (p : prog) (fn : funname) m va m' vr rf : *) -(* fn \in entries → *) -(* sem.sem_call p m fn va m' vr → *) -(* let sp := (translate_prog p) in *) -(* get_fundef fn sp = Some rf → *) -(* { satisfies_globs (p_globs p) } rf (fix_types rf (translate_values va)) ~ ret vr *) -(* { λ (v1,s1) (v2,s2), v1 = v2} *) -(* Proof. *) +(* Definition seq_prod ls := *) +(* map translate_value ls *) +(* foldr chProd ls *) + +Definition translate_values (vs : seq value) : lchtuple (map type_of_val vs). +Proof. Admitted. + +Theorem translate_correct (p : expr.uprog) (fn : funname) m va m' vr f : + sem.sem_call p m fn va m' vr → + let sp := (translate_prog p) in + let dom := lchtuple (map type_of_val va) in + let cod := lchtuple (map type_of_val vr) in + get_fundef_ssp sp fn dom cod = Some f → + (* let f := ffun rf in *) + (* let (S, f) := f in *) + (* let (T, f) := f in *) + ⊢ ⦃ satisfies_globs (p_globs p) ⦄ f (translate_values va) ≈ ret (translate_values vr) ⦃ λ '(v1, s1) '(v2,s2), v1 = v2 ⦄. +Proof. + Admitted. End Section. From 535b4a198d032d2dbf2c347d84a1afcc764fc601 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Fri, 25 Mar 2022 14:32:02 +0100 Subject: [PATCH 007/383] got induction principle to work --- theories/Jasmin/jasmin_translate.v | 28 +++++++++++++++++++++++----- 1 file changed, 23 insertions(+), 5 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 88c2b0fc..7e2cc9db 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -186,17 +186,35 @@ Defined. Definition translate_values (vs : seq value) : lchtuple (map type_of_val vs). Proof. Admitted. +Definition translate_mem (h : mem) : heap. +Proof. Admitted. + Theorem translate_correct (p : expr.uprog) (fn : funname) m va m' vr f : sem.sem_call p m fn va m' vr → let sp := (translate_prog p) in let dom := lchtuple (map type_of_val va) in let cod := lchtuple (map type_of_val vr) in get_fundef_ssp sp fn dom cod = Some f → - (* let f := ffun rf in *) - (* let (S, f) := f in *) - (* let (T, f) := f in *) - ⊢ ⦃ satisfies_globs (p_globs p) ⦄ f (translate_values va) ≈ ret (translate_values vr) ⦃ λ '(v1, s1) '(v2,s2), v1 = v2 ⦄. + satisfies_globs (p_globs p) (translate_mem m, translate_mem m') -> ⊢ ⦃ satisfies_globs (p_globs p) ⦄ f (translate_values va) ≈ ret (translate_values vr) ⦃ λ '(v1, s1) '(v2,s2), v1 = v2 ⦄. Proof. - Admitted. + (* intros H H1 H2 H3 H4. *) + (* unshelve eapply sem_call_Ind. *) + (* all: shelve_unifiable. *) + intros H. + set (P_fun := + λ (m : mem) (fn : funname) (va : seq value) (m' : mem) (vr : seq value), + forall f, + let sp := translate_prog p in + let dom := lchtuple [seq type_of_val i | i <- va] in + let cod := lchtuple [seq type_of_val i | i <- vr] in + get_fundef_ssp sp fn dom cod = Some f -> + satisfies_globs (p_globs p) (translate_mem m, translate_mem m') → ⊢ ⦃ satisfies_globs (p_globs p) ⦄ f (translate_values va) ≈ + ret (translate_values vr) ⦃ λ '(v1, _) '(v2, _), v1 = v2 ⦄ + ). + + unshelve eapply (@sem_call_Ind _ _ _ _ _ _ _ _ P_fun _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H). + 1-4: intros; exact True. + all: try easy. +Qed. End Section. From 3524640df8d458a74838e879d64119368f360b7e Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Fri, 25 Mar 2022 15:28:11 +0100 Subject: [PATCH 008/383] elaborated induction --- theories/Jasmin/jasmin_translate.v | 87 +++++++++++++++++++++++++++--- 1 file changed, 80 insertions(+), 7 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 7e2cc9db..15199e23 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -88,9 +88,9 @@ Definition ssprove_write_lval (l : lval) (tr_p : typed_code) := projT2 unsupported . -Definition translate_instr (i : instr) : raw_code chUnit. +Definition translate_instr_r (i : instr_r) : raw_code chUnit. Proof. - destruct i as [iinfo i]. destruct i. + destruct i. - (* Cassgn *) (* l :a=_s p *) pose (translate_pexpr p) as tr_p. @@ -189,6 +189,11 @@ Proof. Admitted. Definition translate_mem (h : mem) : heap. Proof. Admitted. +Definition instr_d i := + match i with + | MkI ii i => i + end. + Theorem translate_correct (p : expr.uprog) (fn : funname) m va m' vr f : sem.sem_call p m fn va m' vr → let sp := (translate_prog p) in @@ -201,7 +206,7 @@ Proof. (* unshelve eapply sem_call_Ind. *) (* all: shelve_unifiable. *) intros H. - set (P_fun := + set (Pfun := λ (m : mem) (fn : funname) (va : seq value) (m' : mem) (vr : seq value), forall f, let sp := translate_prog p in @@ -212,9 +217,77 @@ Proof. ret (translate_values vr) ⦃ λ '(v1, _) '(v2, _), v1 = v2 ⦄ ). - unshelve eapply (@sem_call_Ind _ _ _ _ _ _ _ _ P_fun _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H). - 1-4: intros; exact True. - all: try easy. -Qed. + set (Pi_r := + λ (s1 : estate) (i : instr_r) (s2 : estate), + ⊢ ⦃ λ '(h1,h2), False ⦄ translate_instr_r i ≈ ret tt ⦃ λ '(v1, _) '(v2, _), True ⦄ + ). + + set (Pi := λ s1 i s2, (Pi_r s1 (instr_d i) s2)). + set (Pc := + λ (s1 : estate) (c : cmd) (s2 : estate), + ⊢ ⦃ λ '(h1,h2), False ⦄ translate_cmd c ≈ ret tt ⦃ λ '(v1, _) '(v2, _), True ⦄ + ). + + (* FIXME *) + set (Pfor := λ (v : var_i) (ls : seq Z) (s1 : estate) (c : cmd) (s2 : estate), + ⊢ ⦃ λ '(h1,h2), False ⦄ (* ssprove_for *) translate_cmd c ≈ ret tt ⦃ λ '(v1, _) '(v2, _), True ⦄). + + + unshelve eapply (@sem_call_Ind _ _ _ _ Pc Pi_r Pi Pfor Pfun _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H). + - red. intros. + red. unfold translate_cmd. simpl. + admit. + - red. intros. + red. unfold translate_cmd. simpl. + admit. + - red. intros. + apply H1. + - red. intros. + red. + unfold translate_instr_r. + unfold ssprove_write_lval. + simpl. + admit. + - red. intros. + red. + unfold translate_instr_r. + admit. + - red. intros. + red. + unfold translate_instr_r. + admit. + - red. intros. + red. + unfold translate_instr_r. + admit. + - red. intros. + red. + unfold translate_instr_r. + admit. + - red. intros. + red. + unfold translate_instr_r. + admit. + - red. intros. + red. + unfold translate_instr_r. + admit. + - red. intros. + red. + unfold translate_instr_r. + admit. + - red. intros. + red. + unfold translate_cmd. + admit. + - red. intros. + red. + unfold translate_instr_r. + admit. + - red. intros. + unfold Pfun. intros. + unfold get_fundef_ssp in H7. + admit. +Admitted. End Section. From 53c8ea7bbab79f310dfd3ac276473e1b9e7655fb Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Fri, 25 Mar 2022 16:00:18 +0100 Subject: [PATCH 009/383] translation of variables --- theories/Jasmin/jasmin_translate.v | 35 ++++++++++++++++++------------ 1 file changed, 21 insertions(+), 14 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 7e889ba8..ef108c97 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -40,20 +40,27 @@ Notation gd := (p_globs P). Context {encode : stype -> choice_type}. Context (embed : forall t, sem_t t -> encode t). -Definition tr_var : (gvar -> Location). - intros X. destruct X. - destruct gv. - destruct v_var. - constructor. - - apply encode. - exact vtype0. - - assert (Ident.ident -> nat) as db_of_ident. - { intros id. - induction id. - - exact 1. - - exact (256 * IHid + (Ascii.nat_of_ascii a))%nat. - } - exact (db_of_ident vname0). +Definition nat_of_ident (id : Ident.ident) : nat. +Proof. + induction id. + - exact 1. + - exact (256 * IHid + (Ascii.nat_of_ascii a))%nat. +Defined. + +(* injection *) +Definition nat_of_fun_ident (f : funname) (id : Ident.ident) : nat. +Proof. + exact (3^(nat_of_pos f) * 2^(nat_of_ident id))%nat. +Defined. + +Definition translate_var (f : funname) (gv : gvar) : Location. + destruct gv. + destruct gv. + destruct v_var. + constructor. + - apply encode. + exact vtype0. + - exact (nat_of_fun_ident f vname0). Defined. Definition typed_code := ∑ (a : choice_type), raw_code a. From 95395ce6dcb6b8b8936e3d1bfcc66fecfa2e95fe Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Fri, 25 Mar 2022 18:00:17 +0100 Subject: [PATCH 010/383] made relation on estates and heaps --- theories/Crypt/choice_type.v | 27 +++++++++---- theories/Jasmin/jasmin_translate.v | 65 +++++++++++++++++++++++------- 2 files changed, 71 insertions(+), 21 deletions(-) diff --git a/theories/Crypt/choice_type.v b/theories/Crypt/choice_type.v index de099190..f4c3cfe6 100644 --- a/theories/Crypt/choice_type.v +++ b/theories/Crypt/choice_type.v @@ -47,15 +47,28 @@ Inductive choice_type := Derive NoConfusion NoConfusionHom for choice_type. -(* Definition void_leq (x y : void) := true. *) +Check word_ordMixin. -(* Lemma void_leqP : Ord.axioms void_leq. *) -(* Proof. split; by do ![case]. Qed. *) +Definition void_leq (x y : void) := true. +Lemma void_leqP : Ord.axioms void_leq. +Proof. split; by do ![case]. Qed. -(* Definition void_ordMixin := OrdMixin void_leqP. *) -(* Canonical void_ordType := Eval hnf in OrdType void void_ordMixin. *) +Definition void_ordMixin := OrdMixin void_leqP. +Canonical void_ordType := Eval hnf in OrdType void void_ordMixin. -Axiom WordOrd : ordType. (* fixme *) + + +(* Check OrdMixin _ int. *) +(* Check sig_ordMixin. *) + +Definition word_ordMixin nbits := [ ordMixin of word nbits by <: ]. +Canonical word_ordType nbits := Eval hnf in OrdType (word nbits) (word_ordMixin nbits). + +(* Locate "ordType". *) +(* Check fun nbits => Ord.clone (word_ordType nbits). nbits). *) +(* Axiom WordOrd : ordType. (* fixme *) *) + +Check ordMixin. Fixpoint chElement_ordType (U : choice_type) : ordType := match U with @@ -66,7 +79,7 @@ Fixpoint chElement_ordType (U : choice_type) : ordType := | chMap U1 U2 => fmap_ordType (chElement_ordType U1) (chElement_ordType U2) | chOption U => option_ordType (chElement_ordType U) | chFin n => [ordType of ordinal n.(pos) ] - | chWord nbits => WordOrd (* fixme *) + | chWord nbits => word_ordType nbits end. Fixpoint chElement (U : choice_type) : choiceType := diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index c947335f..7e141e54 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -5,6 +5,7 @@ Set Warnings "ambiguous-paths,notation-overridden,notation-incompatible-format". From extructures Require Import ord fset fmap. From Jasmin Require Import expr compiler_util values sem. +From Jasmin Require Import expr_facts. From Coq Require Import Utf8. @@ -52,16 +53,20 @@ Proof. exact (3^(nat_of_pos f) * 2^(nat_of_ident id))%nat. Defined. -Definition translate_var (f : funname) (gv : gvar) : Location. - destruct gv. - destruct gv. - destruct v_var. +Definition translate_var (f : funname) (x : var) : Location. + destruct x. constructor. - apply encode. exact vtype0. - exact (nat_of_fun_ident f vname0). Defined. +Definition translate_gvar (f : funname) (gv : gvar) : Location. + destruct gv. + destruct gv. + now apply translate_var. +Defined. + Definition typed_code := ∑ (a : choice_type), raw_code a. Local Definition unsupported : typed_code. Proof. @@ -181,25 +186,55 @@ Proof. exact None. Defined. -Definition translate_value : value -> ∑ (T: choice_type), T. +Definition typed_chElement := ∑ (T: choice_type), T. + +Definition translate_value : value -> typed_chElement. Proof. - intros. exists chUnit. exact. + intros. + destruct X. + - exists chBool. exact b. + - exists chUnit. exact tt. (* exists chInt *) + - exists chUnit. exact tt. (* exists chMap chInt (chWord 8) *) + - exists (chWord s). exact s0. + - exists chUnit. exact tt. (* maybe return something real? *) Defined. (* Definition seq_prod ls := *) (* map translate_value ls *) (* foldr chProd ls *) +From mathcomp Require Import all_algebra. +Search (GRing.ComRing.sort _ -> Z). -Definition translate_values (vs : seq value) : lchtuple (map type_of_val vs). -Proof. Admitted. +Definition translate_ptr (ptr : pointer) : Location := (chWord Uptr ; Z.to_nat (wunsigned ptr)). -Definition translate_mem (h : mem) : heap. -Proof. Admitted. +Definition coerce_to_choice_type (t : choice_type) (v : typed_chElement) : t. + destruct v. + destruct (x == t) eqn:E. + - move: E => /eqP E. + subst. exact s. + - apply chCanonical. +Defined. -Definition instr_d i := - match i with - | MkI ii i => i - end. +Definition rel_mem (m : mem) (h : heap) := + forall ptr sz v, read m ptr sz = ok v -> get_heap h (translate_ptr ptr) = coerce_to_choice_type _ (translate_value (@to_val (sword sz) v)). +Search (vmap -> _). +Search (var -> _). +From Jasmin Require Import expr. +Local Open Scope vmap_scope. +Search value vtype. +(* Set Printing All. *) +Search vtype sem_t. + + +Definition rel_vmap (vm : vmap) (h : heap) (fn : funname) := + forall (i : var) v, vm.[i] = ok v + -> get_heap h (translate_var fn i) = coerce_to_choice_type _ (encode (vtype i) ; @embed _ v). + +Definition rel_estate (s : estate) (h : heap) (fn : funname) := + rel_mem s.(emem) h /\ rel_vmap s.(evm) h fn. + +Definition translate_values (vs : seq value) : lchtuple (map type_of_val vs). +Proof. Admitted. Theorem translate_correct (p : expr.uprog) (fn : funname) m va m' vr f : sem.sem_call p m fn va m' vr → @@ -252,6 +287,8 @@ Proof. - red. intros. red. unfold translate_instr_r. + induction e. + + simpl. unfold ssprove_write_lval. simpl. admit. From d03fbfc06bacfd7c646606beebafdc1969bdcc69 Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Sat, 26 Mar 2022 10:59:56 +0100 Subject: [PATCH 011/383] Add integers (Z) to the choice universe (choice_type) --- theories/Crypt/choice_type.v | 84 +++++++++++++----------- theories/Crypt/package/pkg_heap.v | 2 + theories/Crypt/package/pkg_interpreter.v | 5 +- 3 files changed, 51 insertions(+), 40 deletions(-) diff --git a/theories/Crypt/choice_type.v b/theories/Crypt/choice_type.v index f4c3cfe6..a4ad6464 100644 --- a/theories/Crypt/choice_type.v +++ b/theories/Crypt/choice_type.v @@ -12,13 +12,14 @@ From Relational Require Import OrderEnrichedCategory Set Warnings "-ambiguous-paths,-notation-overridden,-notation-incompatible-format". From mathcomp Require Import ssrnat ssreflect ssrfun ssrbool ssrnum eqtype choice reals distr realsum seq all_algebra fintype. +From CoqWord Require Import word ssrZ. Set Warnings "ambiguous-paths,notation-overridden,notation-incompatible-format". From Crypt Require Import Prelude Axioms. From extructures Require Import ord fset fmap. +From deriving Require Import deriving. From Mon Require Import SPropBase. Require Equations.Prop.DepElim. From Equations Require Import Equations. -From CoqWord Require Import word ssrZ. Set Equations With UIP. @@ -37,7 +38,7 @@ Open Scope type_scope. Inductive choice_type := | chUnit | chNat -(* | chInt *) +| chInt | chBool | chProd (A B : choice_type) | chMap (A B : choice_type) @@ -47,33 +48,14 @@ Inductive choice_type := Derive NoConfusion NoConfusionHom for choice_type. -Check word_ordMixin. - -Definition void_leq (x y : void) := true. -Lemma void_leqP : Ord.axioms void_leq. -Proof. split; by do ![case]. Qed. - -Definition void_ordMixin := OrdMixin void_leqP. -Canonical void_ordType := Eval hnf in OrdType void void_ordMixin. - - - -(* Check OrdMixin _ int. *) -(* Check sig_ordMixin. *) - Definition word_ordMixin nbits := [ ordMixin of word nbits by <: ]. Canonical word_ordType nbits := Eval hnf in OrdType (word nbits) (word_ordMixin nbits). -(* Locate "ordType". *) -(* Check fun nbits => Ord.clone (word_ordType nbits). nbits). *) -(* Axiom WordOrd : ordType. (* fixme *) *) - -Check ordMixin. - Fixpoint chElement_ordType (U : choice_type) : ordType := match U with | chUnit => unit_ordType | chNat => nat_ordType + | chInt => Z_ordType | chBool => bool_ordType | chProd U1 U2 => prod_ordType (chElement_ordType U1) (chElement_ordType U2) | chMap U1 U2 => fmap_ordType (chElement_ordType U1) (chElement_ordType U2) @@ -86,6 +68,7 @@ Fixpoint chElement (U : choice_type) : choiceType := match U with | chUnit => unit_choiceType | chNat => nat_choiceType + | chInt => Z_choiceType | chBool => bool_choiceType | chProd U1 U2 => prod_choiceType (chElement U1) (chElement U2) | chMap U1 U2 => fmap_choiceType (chElement_ordType U1) (chElement U2) @@ -101,6 +84,7 @@ Coercion chElement : choice_type >-> choiceType. match T with | chUnit => Datatypes.tt | chNat => 0 + | chInt => 0 | chBool => false | chProd A B => (chCanonical A, chCanonical B) | chMap A B => _ @@ -118,9 +102,21 @@ Defined. Section choice_typeTypes. + (* Definition choice_type_indDef := [indDef for choice_type_rect]. *) + (* Canonical choice_type_indType := IndType choice_type choice_type_indDef. *) + (* Definition choice_type_eqMixin := [derive eqMixin for choice_type]. *) + (* Canonical choice_type_eqType := EqType choice_type choice_type_eqMixin. *) + + (* Definition choice_type_eq := *) + (* match choice_type_eqMixin with *) + (* | EqMixin op => op *) + (* end. *) + + Fixpoint choice_type_test (u v : choice_type) : bool := match u, v with | chNat , chNat => true + | chInt , chInt => true | chUnit , chUnit => true | chBool , chBool => true | chProd a b , chProd a' b' => choice_type_test a a' && choice_type_test b b' @@ -137,9 +133,9 @@ Section choice_typeTypes. Lemma choice_type_eqP : Equality.axiom choice_type_eq. Proof. move=> x y. - induction x as [ | | | x1 ih1 x2 ih2 | x1 ih1 x2 ih2 | x1 ih1 | x1 | x1 ] + induction x as [ | | | | x1 ih1 x2 ih2 | x1 ih1 x2 ih2 | x1 ih1 | x1 | x1 ] in y |- *. - all: destruct y as [ | | | y1 y2 | y1 y2 | y1 | y1 | y1 ]. + all: destruct y as [ | | | | y1 y2 | y1 y2 | y1 | y1 | y1 ]. all: simpl. all: try solve [ right ; discriminate ]. all: try solve [ left ; reflexivity ]. @@ -190,24 +186,32 @@ Section choice_typeTypes. | chNat, chBool => false | chNat, chNat => false | chNat, _ => true + | chInt, chUnit => false + | chInt, chBool => false + | chInt, chNat => false + | chInt, chInt => false + | chInt, _ => true | chProd _ _, chUnit => false | chProd _ _, chBool => false | chProd _ _, chNat => false + | chProd _ _, chInt => false | chProd u1 u2, chProd w1 w2 => (choice_type_lt u1 w1) || - (choice_type_eq u1 w1 && choice_type_lt u2 w2) + (choice_type_test u1 w1 && choice_type_lt u2 w2) | chProd _ _, _ => true | chMap _ _, chUnit => false | chMap _ _, chBool => false | chMap _ _, chNat => false + | chMap _ _, chInt => false | chMap _ _, chProd _ _ => false | chMap u1 u2, chMap w1 w2 => (choice_type_lt u1 w1) || - (choice_type_eq u1 w1 && choice_type_lt u2 w2) + (choice_type_test u1 w1 && choice_type_lt u2 w2) | chMap _ _, _ => true | chOption _, chUnit => false | chOption _, chBool => false | chOption _, chNat => false + | chOption _, chInt => false | chOption _, chProd _ _ => false | chOption _, chMap _ _ => false | chOption u, chOption w => choice_type_lt u w @@ -215,6 +219,7 @@ Section choice_typeTypes. | chFin n, chUnit => false | chFin n, chBool => false | chFin n, chNat => false + | chFin n, chInt => false | chFin n, chProd _ _ => false | chFin n, chMap _ _ => false | chFin n, chOption _ => false @@ -223,6 +228,7 @@ Section choice_typeTypes. | chWord n, chUnit => false | chWord n, chBool => false | chWord n, chNat => false + | chWord n, chInt => false | chWord n, chProd _ _ => false | chWord n, chMap _ _ => false | chWord n, chOption _ => false @@ -236,7 +242,7 @@ Section choice_typeTypes. Lemma choice_type_lt_transitive : transitive (T:=choice_type) choice_type_lt. Proof. intros v u w h1 h2. - induction u as [ | | | u1 ih1 u2 ih2 | u1 ih1 u2 ih2 | u ih | u | u ] + induction u as [ | | | | u1 ih1 u2 ih2 | u1 ih1 u2 ih2 | u ih | u | u ] in v, w, h1, h2 |- *. - destruct w. all: try auto. destruct v. all: discriminate. @@ -244,6 +250,8 @@ Section choice_typeTypes. all: destruct v. all: discriminate. - destruct w. all: try auto. all: destruct v. all: discriminate. + - destruct w. all: try auto. + all: destruct v. all: discriminate. - destruct v. all: try discriminate. all: destruct w. all: try discriminate. all: try reflexivity. cbn in *. @@ -292,7 +300,7 @@ Section choice_typeTypes. ∀ x, ~~ choice_type_lt x x. Proof. intros x. - induction x as [ | | | x1 ih1 x2 ih2 | x1 ih1 x2 ih2 | x ih | x | x] in |- *. + induction x as [ | | | | x1 ih1 x2 ih2 | x1 ih1 x2 ih2 | x ih | x | x] in |- *. all: intuition; simpl. - simpl. apply/norP. split. @@ -313,7 +321,7 @@ Section choice_typeTypes. ~~ (choice_type_test x y) ==> (choice_type_lt x y || choice_type_lt y x). Proof. intros x y. - induction x as [ | | | x1 ih1 x2 ih2| x1 ih1 x2 ih2| x ih| x | x] + induction x as [ | | | | x1 ih1 x2 ih2| x1 ih1 x2 ih2| x ih| x | x] in y |- *. all: try solve [ destruct y ; intuition ; reflexivity ]. - destruct y. all: try (intuition; reflexivity). @@ -495,11 +503,12 @@ Section choice_typeTypes. | chUnit => GenTree.Leaf 1 | chBool => GenTree.Leaf 2 | chNat => GenTree.Leaf 3 + | chInt => GenTree.Leaf 4 | chProd l r => GenTree.Node 1 [:: encode l ; encode r] | chMap l r => GenTree.Node 2 [:: encode l ; encode r] | chOption u => GenTree.Node 3 [:: encode u] - | chFin n => GenTree.Leaf ((4 + n) - 1)%N - | chWord n => GenTree.Leaf ((4 + n) - 1)%N (* fixme *) + | chFin n => GenTree.Node 4 [:: GenTree.Leaf (pos n)] + | chWord n => GenTree.Node 5 [:: GenTree.Leaf n] end. Fixpoint decode (t : GenTree.tree nat) : option choice_type := @@ -507,8 +516,7 @@ Section choice_typeTypes. | GenTree.Leaf 1 => Some chUnit | GenTree.Leaf 2 => Some chBool | GenTree.Leaf 3 => Some chNat - | GenTree.Leaf n => - Some ( chFin (mkpos ((n - 4).+1)%N) ) + | GenTree.Leaf 4 => Some chInt | GenTree.Node 1 [:: l ; r] => match decode l, decode r with | Some l, Some r => Some (chProd l r) @@ -524,13 +532,15 @@ Section choice_typeTypes. | Some l => Some (chOption l) | _ => None end + | GenTree.Node 4 [:: GenTree.Leaf (S n)] => Some (chFin (mkpos (S n))) + | GenTree.Node 5 [:: GenTree.Leaf n] => Some (chWord n) | _ => None end. Lemma codeK : pcancel encode decode. Proof. intro t. induction t. - all: intuition. + all: intuition eauto. all: simpl. - rewrite IHt1. rewrite IHt2. reflexivity. - rewrite IHt1. rewrite IHt2. reflexivity. @@ -538,10 +548,8 @@ Section choice_typeTypes. - destruct n as [n npos]. cbn. destruct n. + discriminate. - + cbn. - rewrite -subnE subn0. repeat f_equal. apply eq_irrelevance. - Admitted. - (* Defined. *) + + cbn. repeat f_equal. apply eq_irrelevance. + Defined. Definition choice_type_choiceMixin := PcanChoiceMixin codeK. Canonical choice_type_choiceType := diff --git a/theories/Crypt/package/pkg_heap.v b/theories/Crypt/package/pkg_heap.v index 5858e27a..47749c7a 100644 --- a/theories/Crypt/package/pkg_heap.v +++ b/theories/Crypt/package/pkg_heap.v @@ -5,6 +5,7 @@ From Coq Require Import Utf8. +Require Import ZArith. From Relational Require Import OrderEnrichedCategory OrderEnrichedRelativeMonadExamples. Set Warnings "-ambiguous-paths,-notation-overridden,-notation-incompatible-format". @@ -59,6 +60,7 @@ Proof. intros a. induction a. - exact tt. - exact 0. + - exact Z0. - exact false. - exact (IHa1, IHa2). - exact emptym. diff --git a/theories/Crypt/package/pkg_interpreter.v b/theories/Crypt/package/pkg_interpreter.v index 1c0a5b6c..72ab62af 100644 --- a/theories/Crypt/package/pkg_interpreter.v +++ b/theories/Crypt/package/pkg_interpreter.v @@ -130,8 +130,9 @@ Section Interpreter. #[program] Fixpoint sampler (e : choice_type) seed : option (nat * e):= match e with chUnit => Some (seed, Datatypes.tt) - | chNat => Some ((seed + 1)%N, seed) - | chBool => Some ((seed + 1)%N, Nat.even seed) + | chNat => Some ((seed + 1)%nat, seed) + | chInt => Some ((seed + 1)%nat, BinInt.Z.of_nat seed) (* FIXME: also generate negative numbers *) + | chBool => Some ((seed + 1)%nat, Nat.even seed) | chProd A B => match sampler A seed with | Some (seed' , x) => match sampler B seed' with From 326c9e159c4c4a89eeee33ca7fc83e8c4ec559a2 Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Sat, 26 Mar 2022 12:28:19 +0100 Subject: [PATCH 012/383] translate_values --- theories/Jasmin/jasmin_translate.v | 70 ++++++++++++++++++------------ 1 file changed, 43 insertions(+), 27 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 7e141e54..1ffa34e4 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1,5 +1,5 @@ Set Warnings "-ambiguous-paths,-notation-overridden,-notation-incompatible-format". -From mathcomp Require Import all_ssreflect. +From mathcomp Require Import all_ssreflect all_algebra. Set Warnings "ambiguous-paths,notation-overridden,notation-incompatible-format". From extructures Require Import ord fset fmap. @@ -170,8 +170,13 @@ Check value. Definition type_of_val : value -> choice_type. Proof. - intros. - exact chUnit. + intros val. + destruct val as [b | z | size a | size wd | ?]. + - exact chBool. + - exact chInt. + - exact (chMap chInt (chWord 8)). + - exact (chWord size). + - exact chUnit. Defined. Fixpoint lchtuple (ts:seq choice_type) : choice_type := @@ -188,54 +193,65 @@ Defined. Definition typed_chElement := ∑ (T: choice_type), T. -Definition translate_value : value -> typed_chElement. +Definition translate_value (v : value) : type_of_val v. Proof. - intros. - destruct X. - - exists chBool. exact b. - - exists chUnit. exact tt. (* exists chInt *) - - exists chUnit. exact tt. (* exists chMap chInt (chWord 8) *) - - exists (chWord s). exact s0. - - exists chUnit. exact tt. (* maybe return something real? *) + destruct v as [b | z | size a | size wd | ?]. + - exact b. + - exact z. + - destruct a as [arr_data]. + eapply Mz.fold with (2 := arr_data) (3 := emptym). + intros k v m. + exact (setm m k v). + - exact wd. + - exact tt. (* Vundef: maybe return something real? *) +Defined. + + +Fixpoint type_of_values vs : choice_type := + match vs with + | [::] => chUnit + | [::v] => type_of_val v + | hd::tl => chProd (type_of_val hd) (type_of_values tl) + end. + +(* lchtuple (map type_of_val vs) *) + +Definition translate_values (vs : seq value) : lchtuple (map type_of_val vs). +Proof. + induction vs as [|v vs tr_vs]. + - exact tt. + - destruct vs as [|v' vs']. + + exact (translate_value v). + + exact (translate_value v, tr_vs). Defined. (* Definition seq_prod ls := *) (* map translate_value ls *) (* foldr chProd ls *) -From mathcomp Require Import all_algebra. -Search (GRing.ComRing.sort _ -> Z). Definition translate_ptr (ptr : pointer) : Location := (chWord Uptr ; Z.to_nat (wunsigned ptr)). -Definition coerce_to_choice_type (t : choice_type) (v : typed_chElement) : t. - destruct v. - destruct (x == t) eqn:E. +Definition coerce_to_choice_type (t : choice_type) {tv : choice_type} (v : tv) : t. + destruct (tv == t) eqn:E. - move: E => /eqP E. - subst. exact s. + subst. exact v. - apply chCanonical. Defined. Definition rel_mem (m : mem) (h : heap) := forall ptr sz v, read m ptr sz = ok v -> get_heap h (translate_ptr ptr) = coerce_to_choice_type _ (translate_value (@to_val (sword sz) v)). -Search (vmap -> _). -Search (var -> _). + From Jasmin Require Import expr. Local Open Scope vmap_scope. -Search value vtype. -(* Set Printing All. *) -Search vtype sem_t. - Definition rel_vmap (vm : vmap) (h : heap) (fn : funname) := forall (i : var) v, vm.[i] = ok v - -> get_heap h (translate_var fn i) = coerce_to_choice_type _ (encode (vtype i) ; @embed _ v). + -> get_heap h (translate_var fn i) = coerce_to_choice_type _ (embed v). + Definition rel_estate (s : estate) (h : heap) (fn : funname) := rel_mem s.(emem) h /\ rel_vmap s.(evm) h fn. -Definition translate_values (vs : seq value) : lchtuple (map type_of_val vs). -Proof. Admitted. - Theorem translate_correct (p : expr.uprog) (fn : funname) m va m' vr f : sem.sem_call p m fn va m' vr → let sp := (translate_prog p) in From cab74c619c7f162d8829a8695d4a567c3263a056 Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Sat, 26 Mar 2022 12:43:22 +0100 Subject: [PATCH 013/383] Define `encode : stype -> choice_type`. --- theories/Jasmin/jasmin_translate.v | 45 +++++++++++++++--------------- 1 file changed, 23 insertions(+), 22 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 1ffa34e4..f97bdf4e 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -37,7 +37,14 @@ Variable P:uprog. Notation gd := (p_globs P). -Context {encode : stype -> choice_type}. +Definition encode (t : stype) : choice_type := + match t with + | sbool => chBool + | sint => chInt + | sarr n => chMap chInt (chWord 8) + | sword n => chWord n + end. + Context (embed : forall t, sem_t t -> encode t). Definition nat_of_ident (id : Ident.ident) : nat. @@ -168,16 +175,7 @@ About rel_jdg. About package. Check value. -Definition type_of_val : value -> choice_type. -Proof. - intros val. - destruct val as [b | z | size a | size wd | ?]. - - exact chBool. - - exact chInt. - - exact (chMap chInt (chWord 8)). - - exact (chWord size). - - exact chUnit. -Defined. +Definition choice_type_of_val (val : value) : choice_type := encode (type_of_val val). Fixpoint lchtuple (ts:seq choice_type) : choice_type := match ts with @@ -193,9 +191,9 @@ Defined. Definition typed_chElement := ∑ (T: choice_type), T. -Definition translate_value (v : value) : type_of_val v. +Definition translate_value (v : value) : choice_type_of_val v. Proof. - destruct v as [b | z | size a | size wd | ?]. + destruct v as [b | z | size a | size wd | undef_ty]. - exact b. - exact z. - destruct a as [arr_data]. @@ -203,20 +201,23 @@ Proof. intros k v m. exact (setm m k v). - exact wd. - - exact tt. (* Vundef: maybe return something real? *) + - apply chCanonical. + (* It shouldn't matter which value we pick, because when coercing an undef + value at type ty back to ty via to_{bool,int,word,arr} (defined in + values.v), all of these functions raise an error on Vundef. *) Defined. Fixpoint type_of_values vs : choice_type := match vs with | [::] => chUnit - | [::v] => type_of_val v - | hd::tl => chProd (type_of_val hd) (type_of_values tl) + | [::v] => choice_type_of_val v + | hd::tl => chProd (choice_type_of_val hd) (type_of_values tl) end. -(* lchtuple (map type_of_val vs) *) +(* lchtuple (map choice_type_of_val vs) *) -Definition translate_values (vs : seq value) : lchtuple (map type_of_val vs). +Definition translate_values (vs : seq value) : lchtuple (map choice_type_of_val vs). Proof. induction vs as [|v vs tr_vs]. - exact tt. @@ -255,8 +256,8 @@ Definition rel_estate (s : estate) (h : heap) (fn : funname) := Theorem translate_correct (p : expr.uprog) (fn : funname) m va m' vr f : sem.sem_call p m fn va m' vr → let sp := (translate_prog p) in - let dom := lchtuple (map type_of_val va) in - let cod := lchtuple (map type_of_val vr) in + let dom := lchtuple (map choice_type_of_val va) in + let cod := lchtuple (map choice_type_of_val vr) in get_fundef_ssp sp fn dom cod = Some f → satisfies_globs (p_globs p) (translate_mem m, translate_mem m') -> ⊢ ⦃ satisfies_globs (p_globs p) ⦄ f (translate_values va) ≈ ret (translate_values vr) ⦃ λ '(v1, s1) '(v2,s2), v1 = v2 ⦄. Proof. @@ -268,8 +269,8 @@ Proof. λ (m : mem) (fn : funname) (va : seq value) (m' : mem) (vr : seq value), forall f, let sp := translate_prog p in - let dom := lchtuple [seq type_of_val i | i <- va] in - let cod := lchtuple [seq type_of_val i | i <- vr] in + let dom := lchtuple [seq choice_type_of_val i | i <- va] in + let cod := lchtuple [seq choice_type_of_val i | i <- vr] in get_fundef_ssp sp fn dom cod = Some f -> satisfies_globs (p_globs p) (translate_mem m, translate_mem m') → ⊢ ⦃ satisfies_globs (p_globs p) ⦄ f (translate_values va) ≈ ret (translate_values vr) ⦃ λ '(v1, _) '(v2, _), v1 = v2 ⦄ From aa8df90aa4a79d992b8937a9d4ecd9de6b00faa4 Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Sat, 26 Mar 2022 15:51:39 +0100 Subject: [PATCH 014/383] start proof about `write_lval Lvar` --- theories/Jasmin/jasmin_translate.v | 82 +++++++++++++++++++++++++----- 1 file changed, 70 insertions(+), 12 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index f97bdf4e..be3cc508 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -102,19 +102,54 @@ Defined. (* FIXME: actually perform the truncation *) Definition truncate_code (s : stype) (c : typed_code) : typed_code := c. -Definition ssprove_write_lval (l : lval) (tr_p : typed_code) +Definition cast_typed_code (ty : choice_type) (tc : typed_code) : raw_code ty. +Proof. + destruct tc as [t c]. + destruct (t == ty) eqn:E. + - move : E => /eqP E. subst; exact c. + - apply ret. apply chCanonical. +Defined. + +Definition ssprove_write_lval (fn : funname) (l : lval) (tc : typed_code) : raw_code chUnit - := projT2 unsupported -. + := + match l with + | Lnone _ ty => ret tt + | Lvar x => + (* write_var x v s *) + let l := translate_var fn (v_var x) in + let c := cast_typed_code l tc in + (x ← c ;; #put l := x ;; ret tt)%pack + | _ => projT2 unsupported + (* | Lmem sz x e => *) + (* Let vx := get_var (evm s) x >>= to_pointer in *) + (* Let ve := sem_pexpr s e >>= to_pointer in *) + (* let p := (vx + ve)%R in (* should we add the size of value, i.e vx + sz * se *) *) + (* Let w := to_word sz v in *) + (* Let m := write s.(emem) p w in *) + (* ok {| emem := m; evm := s.(evm) |} *) + (* | Laset aa ws x i => *) + (* Let (n,t) := s.[x] in *) + (* Let i := sem_pexpr s i >>= to_int in *) + (* Let v := to_word ws v in *) + (* Let t := WArray.set t aa i v in *) + (* write_var x (@to_val (sarr n) t) s *) + (* | Lasub aa ws len x i => *) + (* Let (n,t) := s.[x] in *) + (* Let i := sem_pexpr s i >>= to_int in *) + (* Let t' := to_arr (Z.to_pos (arr_size ws len)) v in *) + (* Let t := @WArray.set_sub n aa ws len t i t' in *) + (* write_var x (@to_val (sarr n) t) s *) + end. -Definition translate_instr_r (i : instr_r) : raw_code chUnit. +Definition translate_instr_r (fn : funname) (i : instr_r) : raw_code chUnit. Proof. destruct i. - (* Cassgn *) (* l :a=_s p *) pose (translate_pexpr p) as tr_p. pose (truncate_code s tr_p) as tr_p'. - exact (ssprove_write_lval l tr_p'). + exact (ssprove_write_lval fn l tr_p'). - exact (projT2 unsupported). (* Copn *) - exact (projT2 unsupported). (* Cif *) - exact (projT2 unsupported). (* Cfor *) @@ -253,13 +288,16 @@ Definition rel_vmap (vm : vmap) (h : heap) (fn : funname) := Definition rel_estate (s : estate) (h : heap) (fn : funname) := rel_mem s.(emem) h /\ rel_vmap s.(evm) h fn. +Definition instr_d (i : instr) : instr_r := match i with | MkI _ i => i end. + Theorem translate_correct (p : expr.uprog) (fn : funname) m va m' vr f : sem.sem_call p m fn va m' vr → let sp := (translate_prog p) in let dom := lchtuple (map choice_type_of_val va) in let cod := lchtuple (map choice_type_of_val vr) in get_fundef_ssp sp fn dom cod = Some f → - satisfies_globs (p_globs p) (translate_mem m, translate_mem m') -> ⊢ ⦃ satisfies_globs (p_globs p) ⦄ f (translate_values va) ≈ ret (translate_values vr) ⦃ λ '(v1, s1) '(v2,s2), v1 = v2 ⦄. + (* satisfies_globs (p_globs p) (translate_mem m, translate_mem m') -> *) + ⊢ ⦃ satisfies_globs (p_globs p) ⦄ f (translate_values va) ≈ ret (translate_values vr) ⦃ λ '(v1, s1) '(v2,s2), v1 = v2 ⦄. Proof. (* intros H H1 H2 H3 H4. *) (* unshelve eapply sem_call_Ind. *) @@ -272,13 +310,14 @@ Proof. let dom := lchtuple [seq choice_type_of_val i | i <- va] in let cod := lchtuple [seq choice_type_of_val i | i <- vr] in get_fundef_ssp sp fn dom cod = Some f -> - satisfies_globs (p_globs p) (translate_mem m, translate_mem m') → ⊢ ⦃ satisfies_globs (p_globs p) ⦄ f (translate_values va) ≈ + (* satisfies_globs (p_globs p) (translate_mem m, translate_mem m') → *) + ⊢ ⦃ satisfies_globs (p_globs p) ⦄ f (translate_values va) ≈ ret (translate_values vr) ⦃ λ '(v1, _) '(v2, _), v1 = v2 ⦄ ). set (Pi_r := λ (s1 : estate) (i : instr_r) (s2 : estate), - ⊢ ⦃ λ '(h1,h2), False ⦄ translate_instr_r i ≈ ret tt ⦃ λ '(v1, _) '(v2, _), True ⦄ + ⊢ ⦃ λ '(h1,h2), False ⦄ translate_instr_r fn i ≈ ret tt ⦃ λ '(v1, _) '(v2, _), True ⦄ ). set (Pi := λ s1 i s2, (Pi_r s1 (instr_d i) s2)). @@ -304,11 +343,30 @@ Proof. - red. intros. red. unfold translate_instr_r. - induction e. + destruct x. + + simpl. admit. + simpl. - unfold ssprove_write_lval. - simpl. - admit. + eapply r_transL. + * eapply r_bind with (mid := eq). + -- instantiate (1 := ret (coerce_to_choice_type _ + (translate_value v'))). + admit. (* by H0: sem_pexpr e = ok v *) + -- intros. + eapply rpre_hypothesis_rule. + intros ? ? E. From Equations Require Import Equations. + noconf E. + eapply rpre_weaken_rule. + 1: refine (rreflexivity_rule _). + simpl. + intros. by intuition subst. + * simpl. + eapply r_put_lhs with (pre := (λ '(_, _), False)). + apply r_ret. + intros. + admit. + + admit. + + admit. + + admit. - red. intros. red. unfold translate_instr_r. From c2545a6b3e41d99d192b88f07733488c9ca0a1df Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Sat, 26 Mar 2022 17:01:44 +0100 Subject: [PATCH 015/383] pexpr_correct (wip) --- theories/Jasmin/jasmin_translate.v | 66 ++++++++++++++++++++++++++---- 1 file changed, 58 insertions(+), 8 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index be3cc508..fb67035f 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -12,6 +12,8 @@ From Coq Require Import Utf8. From Crypt Require Import Prelude Package. Import PackageNotation. +From Equations Require Import Equations. + Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. @@ -81,15 +83,17 @@ Proof. exact (pkg_distr.assert false). Defined. -Fixpoint translate_pexpr (e : pexpr) : typed_code. +Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code. Proof. destruct e. - - exact unsupported. + - exists chInt. apply ret. exact z. - exists chBool. exact (ret b). - (* Parr_init only gets produced by ArrayInit() in jasmin source; the EC export asserts false on it, so we don't support it for now. *) exact unsupported. - - exact unsupported. + - pose (translate_gvar fn g). + exists (projT1 l). + apply (getr l). apply ret. - exact unsupported. - exact unsupported. - exact unsupported. @@ -147,7 +151,7 @@ Proof. destruct i. - (* Cassgn *) (* l :a=_s p *) - pose (translate_pexpr p) as tr_p. + pose (translate_pexpr fn p) as tr_p. pose (truncate_code s tr_p) as tr_p'. exact (ssprove_write_lval fn l tr_p'). - exact (projT2 unsupported). (* Copn *) @@ -156,7 +160,7 @@ Proof. - exact (projT2 unsupported). (* Cwhile *) - (* Ccall i l f l0 *) (* translate arguments *) - pose (map translate_pexpr l0) as tr_l0. + pose (map (translate_pexpr fn) l0) as tr_l0. (* "perform" the call via `opr` *) (* probably we'd look up the function signature in the current ambient program *) @@ -277,7 +281,6 @@ Defined. Definition rel_mem (m : mem) (h : heap) := forall ptr sz v, read m ptr sz = ok v -> get_heap h (translate_ptr ptr) = coerce_to_choice_type _ (translate_value (@to_val (sword sz) v)). -From Jasmin Require Import expr. Local Open Scope vmap_scope. Definition rel_vmap (vm : vmap) (h : heap) (fn : funname) := @@ -290,7 +293,53 @@ Definition rel_estate (s : estate) (h : heap) (fn : funname) := Definition instr_d (i : instr) : instr_r := match i with | MkI _ i => i end. -Theorem translate_correct (p : expr.uprog) (fn : funname) m va m' vr f : +Lemma ch_ty_val_enc (sty : stype) (v : sem_t sty) : + @choice_type_of_val (to_val v) = encode sty. +Proof. + admit. Admitted. + +Lemma translate_pexpr_correct fn (e : pexpr) (pg : glob_decls) s1 v ty v' ty' + (H0 : sem_pexpr pg s1 e = ok v) + (H1 : truncate_val ty v = ok v') : + + ⊢ ⦃ λ '(s₀, s₁), s₀ = s₁ ⦄ + ret (coerce_to_choice_type ty' (translate_value v')) + ≈ + cast_typed_code ty' + (truncate_code ty (translate_pexpr fn e)) + ⦃ eq ⦄ +. +Proof. + induction e in H0, H1, v, v', ty, ty' |- *. + all: simpl in H0. + - inversion H0. subst. simpl in H1. + unfold truncate_val in H1. + destruct of_val eqn:E. + 2: discriminate. + apply of_vint in E as E'. + subst. simpl in H1, E. inversion H1. inversion E. subst. + simpl. + destruct ty'. + + unfold coerce_to_choice_type. + + coerce_to_choice_type ty s + pose (@ch_ty_val_enc _ s). + +Set Nested Proofs Allowed. + + + + destruct ty'. all: simpl; try easy. + + unfold coerce_to_choice_type. + + unfold translate_pexpr. simpl. + + + + revert H1. + sem_pexpr pg s1 e + induction H0. + +Theorem translate_prog_correct (p : expr.uprog) (fn : funname) m va m' vr f : sem.sem_call p m fn va m' vr → let sp := (translate_prog p) in let dom := lchtuple (map choice_type_of_val va) in @@ -350,10 +399,11 @@ Proof. * eapply r_bind with (mid := eq). -- instantiate (1 := ret (coerce_to_choice_type _ (translate_value v'))). + by eapply translate_pexpr_sound. admit. (* by H0: sem_pexpr e = ok v *) -- intros. eapply rpre_hypothesis_rule. - intros ? ? E. From Equations Require Import Equations. + intros ? ? E. noconf E. eapply rpre_weaken_rule. 1: refine (rreflexivity_rule _). From 5be79486edba4e22881b15920ed32d879581b5ab Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Sat, 26 Mar 2022 18:33:17 +0100 Subject: [PATCH 016/383] added coerce_cast_code lemma without proof (prove using equations) --- theories/Jasmin/jasmin_translate.v | 85 ++++++++++++++++++++---------- 1 file changed, 57 insertions(+), 28 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index fb67035f..3a85ff89 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -298,6 +298,41 @@ Lemma ch_ty_val_enc (sty : stype) (v : sem_t sty) : Proof. admit. Admitted. +Require Import Coq.Program.Equality. + +(* prove using equations, see pkg_invariants and the proof of lookup_hpv_l *) +Lemma coerce_cast_code (ty vty : choice_type) (v : vty) : + ret (coerce_to_choice_type ty v) + = cast_typed_code ty (vty ; ret v). +Proof. + (* Admitted. *) + + simpl. unfold coerce_to_choice_type. + set (H := (vty == ty) ). + dependent destruction H. + - destruct vty, ty; simpl; try easy. + + match goal with + | |- context[elimTF ?e1 ?e2] => set A:=(elimTF e1 e2) (* with (@erefl choice_type chUnit) *) + end. simpl in A. + assert (A = erefl) by (apply eq_irrelevance). + clearbody A. + subst; reflexivity. + + + match goal with + | |- context[elimTF ?e1 ?e2] => set A:=(elimTF e1 e2) (* with (@erefl choice_type chUnit) *) + end. simpl in A. + assert (A = erefl) by (apply eq_irrelevance). + clearbody A. + subst. cbn. reflexivity. + + + match goal with + | |- context[elimTF ?e1 ?e2] => set A:=(elimTF e1 e2) (* with (@erefl choice_type chUnit) *) + end. simpl in A. + assert (A = erefl) by (apply eq_irrelevance). + clearbody A. + subst. cbn. reflexivity. +Admitted. + Lemma translate_pexpr_correct fn (e : pexpr) (pg : glob_decls) s1 v ty v' ty' (H0 : sem_pexpr pg s1 e = ok v) (H1 : truncate_val ty v = ok v') : @@ -310,34 +345,28 @@ Lemma translate_pexpr_correct fn (e : pexpr) (pg : glob_decls) s1 v ty v' ty' ⦃ eq ⦄ . Proof. - induction e in H0, H1, v, v', ty, ty' |- *. - all: simpl in H0. - - inversion H0. subst. simpl in H1. - unfold truncate_val in H1. - destruct of_val eqn:E. - 2: discriminate. - apply of_vint in E as E'. - subst. simpl in H1, E. inversion H1. inversion E. subst. - simpl. - destruct ty'. - + unfold coerce_to_choice_type. - - coerce_to_choice_type ty s - pose (@ch_ty_val_enc _ s). - -Set Nested Proofs Allowed. - - - - destruct ty'. all: simpl; try easy. - + unfold coerce_to_choice_type. - - unfold translate_pexpr. simpl. - + - - revert H1. - sem_pexpr pg s1 e - induction H0. + Admitted. +(* induction e in H0, H1, v, v', ty, ty' |- *. *) +(* all: simpl in H0. *) +(* - inversion H0. subst. simpl in H1. *) +(* unfold truncate_val in H1. *) +(* destruct of_val eqn:E. *) +(* 2: discriminate. *) +(* apply of_vint in E as E'. *) +(* subst. simpl in H1, E. inversion H1. inversion E. subst. *) +(* simpl. *) +(* destruct ty'. *) +(* + unfold coerce_to_choice_type. *) +(* coerce_to_choice_type ty s *) +(* pose (@ch_ty_val_enc _ s). *) +(* Set Nested Proofs Allowed. *) +(* destruct ty'. all: simpl; try easy. *) +(* + unfold coerce_to_choice_type. *) +(* unfold translate_pexpr. simpl. *) +(* + *) +(* revert H1. *) +(* sem_pexpr pg s1 e *) +(* induction H0. *) Theorem translate_prog_correct (p : expr.uprog) (fn : funname) m va m' vr f : sem.sem_call p m fn va m' vr → From 35dac2938b5aa2b5aa15e2a3918a9c8348f91b10 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Sat, 26 Mar 2022 19:51:03 +0100 Subject: [PATCH 017/383] added coercion functions using equations and coercion lemmas --- theories/Jasmin/jasmin_translate.v | 167 +++++++++++++++++------------ 1 file changed, 96 insertions(+), 71 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 3a85ff89..9839a6ca 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -13,8 +13,10 @@ From Crypt Require Import Prelude Package. Import PackageNotation. From Equations Require Import Equations. +Set Equations With UIP. +Set Equations Transparent. -Set Implicit Arguments. +(* Set Implicit Arguments. *) Unset Strict Implicit. Unset Printing Implicit Defensive. @@ -106,14 +108,39 @@ Defined. (* FIXME: actually perform the truncation *) Definition truncate_code (s : stype) (c : typed_code) : typed_code := c. -Definition cast_typed_code (ty : choice_type) (tc : typed_code) : raw_code ty. +Definition cast_typed_code (t' : choice_type) (c : typed_code) (e : projT1 c = t') : raw_code t'. Proof. - destruct tc as [t c]. - destruct (t == ty) eqn:E. - - move : E => /eqP E. subst; exact c. - - apply ret. apply chCanonical. + subst. exact (projT2 c). Defined. +Lemma cast_typed_code_K : + ∀ t c e, + @cast_typed_code t (t; c) e = c. +Proof. + intros t c e. + assert (e = erefl). + { apply eq_irrelevance. } + subst. reflexivity. +Qed. + +Equations? coerce_typed_code (ty : choice_type) (tc : typed_code) : raw_code ty := + @coerce_typed_code ty tc with inspect (projT1 tc == ty) := { + | @exist true e => @cast_typed_code ty tc _ + | @exist false e => ret (chCanonical ty) + }. +Proof. + symmetry in e. + move: e => /eqP e. subst. reflexivity. +Qed. + +(* Definition cast_typed_code (ty : choice_type) (tc : typed_code) : raw_code ty. *) +(* Proof. *) +(* destruct tc as [t c]. *) +(* destruct (t == ty) eqn:E. *) +(* - move : E => /eqP E. subst; exact c. *) +(* - apply ret. apply chCanonical. *) +(* Defined. *) + Definition ssprove_write_lval (fn : funname) (l : lval) (tc : typed_code) : raw_code chUnit := @@ -122,7 +149,7 @@ Definition ssprove_write_lval (fn : funname) (l : lval) (tc : typed_code) | Lvar x => (* write_var x v s *) let l := translate_var fn (v_var x) in - let c := cast_typed_code l tc in + let c := coerce_typed_code l tc in (x ← c ;; #put l := x ;; ret tt)%pack | _ => projT2 unsupported (* | Lmem sz x e => *) @@ -271,13 +298,32 @@ Defined. Definition translate_ptr (ptr : pointer) : Location := (chWord Uptr ; Z.to_nat (wunsigned ptr)). -Definition coerce_to_choice_type (t : choice_type) {tv : choice_type} (v : tv) : t. - destruct (tv == t) eqn:E. - - move: E => /eqP E. - subst. exact v. - - apply chCanonical. +(* from pkg_invariants *) +Definition cast_ct_val {t t' : choice_type} (e : t = t') (v : t) : t'. +Proof. + subst. auto. Defined. +Lemma cast_ct_val_K : + ∀ t e v, + @cast_ct_val t t e v = v. +Proof. + intros t e v. + assert (e = erefl). + { apply eq_irrelevance. } + subst. reflexivity. +Qed. + +Equations? coerce_to_choice_type (t : choice_type) {tv : choice_type} (v : tv) : t := + @coerce_to_choice_type t tv v with inspect (tv == t) := { + | @exist true e => cast_ct_val _ v + | @exist false e => chCanonical t + }. +Proof. + symmetry in e. + move: e => /eqP e. subst. reflexivity. +Qed. + Definition rel_mem (m : mem) (h : heap) := forall ptr sz v, read m ptr sz = ok v -> get_heap h (translate_ptr ptr) = coerce_to_choice_type _ (translate_value (@to_val (sword sz) v)). @@ -285,7 +331,7 @@ Local Open Scope vmap_scope. Definition rel_vmap (vm : vmap) (h : heap) (fn : funname) := forall (i : var) v, vm.[i] = ok v - -> get_heap h (translate_var fn i) = coerce_to_choice_type _ (embed v). + -> get_heap h (translate_var fn i) = coerce_to_choice_type _ (embed _ v). Definition rel_estate (s : estate) (h : heap) (fn : funname) := @@ -293,45 +339,29 @@ Definition rel_estate (s : estate) (h : heap) (fn : funname) := Definition instr_d (i : instr) : instr_r := match i with | MkI _ i => i end. -Lemma ch_ty_val_enc (sty : stype) (v : sem_t sty) : - @choice_type_of_val (to_val v) = encode sty. -Proof. - admit. Admitted. - -Require Import Coq.Program.Equality. - -(* prove using equations, see pkg_invariants and the proof of lookup_hpv_l *) Lemma coerce_cast_code (ty vty : choice_type) (v : vty) : ret (coerce_to_choice_type ty v) - = cast_typed_code ty (vty ; ret v). + = coerce_typed_code ty (vty ; ret v). Proof. - (* Admitted. *) - - simpl. unfold coerce_to_choice_type. - set (H := (vty == ty) ). - dependent destruction H. - - destruct vty, ty; simpl; try easy. - + match goal with - | |- context[elimTF ?e1 ?e2] => set A:=(elimTF e1 e2) (* with (@erefl choice_type chUnit) *) - end. simpl in A. - assert (A = erefl) by (apply eq_irrelevance). - clearbody A. - subst; reflexivity. - + - match goal with - | |- context[elimTF ?e1 ?e2] => set A:=(elimTF e1 e2) (* with (@erefl choice_type chUnit) *) - end. simpl in A. - assert (A = erefl) by (apply eq_irrelevance). - clearbody A. - subst. cbn. reflexivity. - + - match goal with - | |- context[elimTF ?e1 ?e2] => set A:=(elimTF e1 e2) (* with (@erefl choice_type chUnit) *) - end. simpl in A. - assert (A = erefl) by (apply eq_irrelevance). - clearbody A. - subst. cbn. reflexivity. -Admitted. + simpl. + funelim (coerce_to_choice_type ty v); + funelim (coerce_typed_code t (tv; ret v)). + - rewrite <- Heqcall, <- Heqcall0. + pose proof e as e'. + symmetry in e'. + move: e' => /eqP e'. subst. + rewrite cast_ct_val_K. + simpl. cbn. + rewrite cast_typed_code_K. reflexivity. + - simpl in *. + exfalso. + clear -e e0. rewrite <- e in e0. congruence. + - simpl in *. + exfalso. + clear -e e0. rewrite <- e in e0. congruence. + - rewrite <- Heqcall, <- Heqcall0. + reflexivity. +Qed. Lemma translate_pexpr_correct fn (e : pexpr) (pg : glob_decls) s1 v ty v' ty' (H0 : sem_pexpr pg s1 e = ok v) @@ -340,33 +370,28 @@ Lemma translate_pexpr_correct fn (e : pexpr) (pg : glob_decls) s1 v ty v' ty' ⊢ ⦃ λ '(s₀, s₁), s₀ = s₁ ⦄ ret (coerce_to_choice_type ty' (translate_value v')) ≈ - cast_typed_code ty' + coerce_typed_code ty' (truncate_code ty (translate_pexpr fn e)) ⦃ eq ⦄ . Proof. + rewrite coerce_cast_code. Admitted. -(* induction e in H0, H1, v, v', ty, ty' |- *. *) -(* all: simpl in H0. *) -(* - inversion H0. subst. simpl in H1. *) -(* unfold truncate_val in H1. *) -(* destruct of_val eqn:E. *) -(* 2: discriminate. *) -(* apply of_vint in E as E'. *) -(* subst. simpl in H1, E. inversion H1. inversion E. subst. *) -(* simpl. *) -(* destruct ty'. *) -(* + unfold coerce_to_choice_type. *) -(* coerce_to_choice_type ty s *) -(* pose (@ch_ty_val_enc _ s). *) -(* Set Nested Proofs Allowed. *) -(* destruct ty'. all: simpl; try easy. *) -(* + unfold coerce_to_choice_type. *) -(* unfold translate_pexpr. simpl. *) -(* + *) -(* revert H1. *) -(* sem_pexpr pg s1 e *) -(* induction H0. *) + +(* something like this *) +(* Lemma translate_pexpr_correct fn (e : pexpr) (pg : glob_decls) s1 v ty v' ty' *) +(* (H0 : sem_pexpr pg s1 e = ok v) *) +(* (H1 : truncate_val ty v = ok v') : *) + +(* ⊢ ⦃ λ '(s₀, s₁), s₀ = s₁ ⦄ *) +(* ret (translate_value v') *) +(* ≈ *) +(* projT2 (truncate_code ty (translate_pexpr fn e)) *) +(* ⦃ eq ⦄ *) +(* . *) +(* Proof. *) +(* rewrite coerce_cast_code. *) +(* Admitted. *) Theorem translate_prog_correct (p : expr.uprog) (fn : funname) m va m' vr f : sem.sem_call p m fn va m' vr → From 22715db363b2b5e9d4aadf246c79d6cc4840ecf7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Sun, 27 Mar 2022 18:33:10 +0200 Subject: [PATCH 018/383] Define embed --- theories/Jasmin/jasmin_translate.v | 32 +++++++++++++----------------- 1 file changed, 14 insertions(+), 18 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 9839a6ca..ded00282 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -24,20 +24,15 @@ Set Bullet Behavior "Strict Subproofs". Set Default Goal Selector "!". Set Primitive Projections. -Section Section. +Section Translation. -Context `{asmop:asmOp}. -Context (fresh_counter: Ident.ident). +Context `{asmop : asmOp}. -Context {T} {pT:progT T}. +Context {T} {pT : progT T}. +Context {pd : PointerData}. -Context {Loc : {fset Location}}. -Context {import : Interface}. - -Context {pd: PointerData}. - -Variable P:uprog. +Context (P : uprog). Notation gd := (p_globs P). @@ -49,7 +44,13 @@ Definition encode (t : stype) : choice_type := | sword n => chWord n end. -Context (embed : forall t, sem_t t -> encode t). +Definition embed {t} : sem_t t → encode t := + match t with + | sbool => λ x, x + | sint => λ x, x + | sarr n => λ x, Mz.fold (λ k v m, setm m k v) x.(WArray.arr_data) emptym + | sword n => λ x, x + end. Definition nat_of_ident (id : Ident.ident) : nat. Proof. @@ -235,11 +236,6 @@ Definition translate_prog (p:uprog) : ssprove_prog := let globs := collect_globs (p_globs p) in let fds := map translate_fundef (p_funcs p) in fds. -Print typed_raw_function. -Check Interface. -About rel_jdg. -About package. -Check value. Definition choice_type_of_val (val : value) : choice_type := encode (type_of_val val). @@ -258,7 +254,7 @@ Defined. Definition typed_chElement := ∑ (T: choice_type), T. Definition translate_value (v : value) : choice_type_of_val v. -Proof. +Proof. (* Can we use embed here instead? *) destruct v as [b | z | size a | size wd | undef_ty]. - exact b. - exact z. @@ -513,4 +509,4 @@ Proof. admit. Admitted. -End Section. +End Translation. From d369ae7c4b35b513dd4b9b698c5b7aaade238092 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Sun, 27 Mar 2022 18:33:29 +0200 Subject: [PATCH 019/383] Ignore .Makefile.coq 3.d --- .gitignore | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.gitignore b/.gitignore index 221fe71e..6f6a2b0d 100644 --- a/.gitignore +++ b/.gitignore @@ -63,3 +63,5 @@ Makefile.coq.conf # Assembly (ignored because we expect them to be jasminc generated) *.s + +.Makefile.coq 3.d From 11ee49a57c582697762157325ced46654e512b74 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Sun, 27 Mar 2022 18:46:44 +0200 Subject: [PATCH 020/383] Add notations for word and int --- theories/Crypt/package/pkg_notation.v | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/theories/Crypt/package/pkg_notation.v b/theories/Crypt/package/pkg_notation.v index bfae7fac..44584245 100644 --- a/theories/Crypt/package/pkg_notation.v +++ b/theories/Crypt/package/pkg_notation.v @@ -121,8 +121,10 @@ Module PackageNotation. *) Notation " 'nat " := (chNat) (in custom pack_type at level 2). + Notation " 'int " := (chInt) (in custom pack_type at level 2). Notation " 'bool " := (chBool) (in custom pack_type at level 2). Notation " 'unit " := (chUnit) (in custom pack_type at level 2). + Notation " 'word n " := (chWord n) (in custom pack_type at level 2). Notation " 'option x " := (chOption x) (in custom pack_type at level 2). Notation " 'fin n " := @@ -139,8 +141,10 @@ Module PackageNotation. (** Repeat the above notations here for package_scope. *) Notation " 'nat " := (chNat) (at level 2) : package_scope. + Notation " 'int " := (chInt) (at level 2) : package_scope. Notation " 'bool " := (chBool) (at level 2) : package_scope. Notation " 'unit " := (chUnit) (at level 2) : package_scope. + Notation " 'word n " := (chWord n) (at level 2) : package_scope. Notation " 'option x " := (chOption x) (at level 2) : package_scope. Notation " 'fin x " := From 60eeb94377d2a24924a1e87fedbed654da1a33a6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Sun, 27 Mar 2022 19:06:31 +0200 Subject: [PATCH 021/383] Define some things more directly --- theories/Jasmin/jasmin_translate.v | 251 ++++++++++++++--------------- 1 file changed, 125 insertions(+), 126 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index ded00282..cc12c1e8 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -38,10 +38,10 @@ Notation gd := (p_globs P). Definition encode (t : stype) : choice_type := match t with - | sbool => chBool - | sint => chInt - | sarr n => chMap chInt (chWord 8) - | sword n => chWord n + | sbool => 'bool + | sint => 'int + | sarr n => chMap 'int ('word 8) + | sword n => 'word n end. Definition embed {t} : sem_t t → encode t := @@ -52,39 +52,26 @@ Definition embed {t} : sem_t t → encode t := | sword n => λ x, x end. -Definition nat_of_ident (id : Ident.ident) : nat. -Proof. - induction id. - - exact 1. - - exact (256 * IHid + (Ascii.nat_of_ascii a))%nat. -Defined. +Fixpoint nat_of_ident (id : Ident.ident) : nat := + match id with + | EmptyString => 1 + | String a s => 256 * nat_of_ident s + (Ascii.nat_of_ascii a) + end. (* injection *) -Definition nat_of_fun_ident (f : funname) (id : Ident.ident) : nat. -Proof. - exact (3^(nat_of_pos f) * 2^(nat_of_ident id))%nat. -Defined. +Definition nat_of_fun_ident (f : funname) (id : Ident.ident) : nat := + 3^(nat_of_pos f) * 2^(nat_of_ident id). -Definition translate_var (f : funname) (x : var) : Location. - destruct x. - constructor. - - apply encode. - exact vtype0. - - exact (nat_of_fun_ident f vname0). -Defined. +Definition translate_var (f : funname) (x : var) : Location := + ( encode x.(vtype) ; nat_of_fun_ident f x.(vname)). -Definition translate_gvar (f : funname) (gv : gvar) : Location. - destruct gv. - destruct gv. - now apply translate_var. -Defined. +Definition translate_gvar (f : funname) (x : gvar) : Location := + translate_var f x.(gv).(v_var). Definition typed_code := ∑ (a : choice_type), raw_code a. -Local Definition unsupported : typed_code. -Proof. - exists chUnit. - exact (pkg_distr.assert false). -Defined. + +#[local] Definition unsupported : typed_code := + ('unit ; assert false). Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code. Proof. @@ -109,14 +96,15 @@ Defined. (* FIXME: actually perform the truncation *) Definition truncate_code (s : stype) (c : typed_code) : typed_code := c. -Definition cast_typed_code (t' : choice_type) (c : typed_code) (e : projT1 c = t') : raw_code t'. +Definition cast_typed_code (t' : choice_type) (c : typed_code) (e : c.π1 = t') : + raw_code t'. Proof. subst. exact (projT2 c). Defined. Lemma cast_typed_code_K : ∀ t c e, - @cast_typed_code t (t; c) e = c. + @cast_typed_code t (t ; c) e = c. Proof. intros t c e. assert (e = erefl). @@ -125,7 +113,7 @@ Proof. Qed. Equations? coerce_typed_code (ty : choice_type) (tc : typed_code) : raw_code ty := - @coerce_typed_code ty tc with inspect (projT1 tc == ty) := { + @coerce_typed_code ty tc with inspect (tc.π1 == ty) := { | @exist true e => @cast_typed_code ty tc _ | @exist false e => ret (chCanonical ty) }. @@ -152,7 +140,7 @@ Definition ssprove_write_lval (fn : funname) (l : lval) (tc : typed_code) let l := translate_var fn (v_var x) in let c := coerce_typed_code l tc in (x ← c ;; #put l := x ;; ret tt)%pack - | _ => projT2 unsupported + | _ => unsupported.π2 (* | Lmem sz x e => *) (* Let vx := get_var (evm s) x >>= to_pointer in *) (* Let ve := sem_pexpr s e >>= to_pointer in *) @@ -174,7 +162,7 @@ Definition ssprove_write_lval (fn : funname) (l : lval) (tc : typed_code) (* write_var x (@to_val (sarr n) t) s *) end. -Definition translate_instr_r (fn : funname) (i : instr_r) : raw_code chUnit. +Definition translate_instr_r (fn : funname) (i : instr_r) : raw_code 'unit. Proof. destruct i. - (* Cassgn *) @@ -182,10 +170,10 @@ Proof. pose (translate_pexpr fn p) as tr_p. pose (truncate_code s tr_p) as tr_p'. exact (ssprove_write_lval fn l tr_p'). - - exact (projT2 unsupported). (* Copn *) - - exact (projT2 unsupported). (* Cif *) - - exact (projT2 unsupported). (* Cfor *) - - exact (projT2 unsupported). (* Cwhile *) + - exact (unsupported.π2). (* Copn *) + - exact (unsupported.π2). (* Cif *) + - exact (unsupported.π2). (* Cfor *) + - exact (unsupported.π2). (* Cwhile *) - (* Ccall i l f l0 *) (* translate arguments *) pose (map (translate_pexpr fn) l0) as tr_l0. @@ -194,16 +182,21 @@ Proof. (* write_lvals the result of the call into lvals `l` *) - exact (projT2 unsupported). + exact (unsupported.π2). Defined. -Definition translate_cmd (c : cmd) : raw_code chUnit. +Definition translate_cmd (c : cmd) : raw_code 'unit. Proof. (* fold bind translate_instr *) - exact (projT2 unsupported). + exact (unsupported.π2). Defined. -Record fdef := { ffun : typed_raw_function ; locs : {fset Location} ; imp : Interface ; exp : Interface }. +Record fdef := { + ffun : typed_raw_function ; + locs : {fset Location} ; + imp : Interface ; + exp : Interface +}. Definition translate_fundef (fd : _ufun_decl (* extra_fun_t *)) : funname * fdef. Proof. @@ -220,70 +213,72 @@ Proof. - exact [interface]. Defined. -Fixpoint satisfies_globs (globs : glob_decls) : heap * heap -> Prop. +Fixpoint satisfies_globs (globs : glob_decls) : heap * heap → Prop. Proof. - exact (fun '(x, y) => False). + exact (λ '(x, y), False). (* TODO *) Defined. Fixpoint collect_globs (globs : glob_decls) : seq Location. Proof. - exact nil. + exact [::]. (* TODO *) Defined. Definition ssprove_prog := seq (funname * fdef). -Definition translate_prog (p:uprog) : ssprove_prog := +Definition translate_prog (p : uprog) : ssprove_prog := let globs := collect_globs (p_globs p) in let fds := map translate_fundef (p_funcs p) in fds. -Definition choice_type_of_val (val : value) : choice_type := encode (type_of_val val). +Definition choice_type_of_val (val : value) : choice_type := + encode (type_of_val val). -Fixpoint lchtuple (ts:seq choice_type) : choice_type := +Fixpoint lchtuple (ts : seq choice_type) : choice_type := match ts with | [::] => chUnit | [::t1] => t1 | t1::ts => chProd t1 (lchtuple ts) end. -Definition get_fundef_ssp (sp : seq (funname * fdef)) (fn : funname) (dom cod : choice_type) : option (dom -> raw_code cod). +Definition get_fundef_ssp (sp : seq (funname * fdef)) (fn : funname) (dom cod : choice_type) : + option (dom → raw_code cod). Proof. - exact None. + exact None. (* TODO *) Defined. -Definition typed_chElement := ∑ (T: choice_type), T. +Definition typed_chElement := pointed_value. Definition translate_value (v : value) : choice_type_of_val v. -Proof. (* Can we use embed here instead? *) +Proof. + (* Feels like we could apply embed first, but I don't know what to do with + the undefined case. + *) destruct v as [b | z | size a | size wd | undef_ty]. - - exact b. - - exact z. - - destruct a as [arr_data]. - eapply Mz.fold with (2 := arr_data) (3 := emptym). - intros k v m. - exact (setm m k v). - - exact wd. + - apply embed. exact b. + - apply embed. exact z. + - apply embed. exact a. + - apply embed. exact wd. - apply chCanonical. (* It shouldn't matter which value we pick, because when coercing an undef value at type ty back to ty via to_{bool,int,word,arr} (defined in values.v), all of these functions raise an error on Vundef. *) Defined. - Fixpoint type_of_values vs : choice_type := match vs with - | [::] => chUnit + | [::] => 'unit | [::v] => choice_type_of_val v - | hd::tl => chProd (choice_type_of_val hd) (type_of_values tl) + | hd::tl => choice_type_of_val hd × type_of_values tl end. (* lchtuple (map choice_type_of_val vs) *) -Definition translate_values (vs : seq value) : lchtuple (map choice_type_of_val vs). +Definition translate_values (vs : seq value) : + lchtuple (map choice_type_of_val vs). Proof. - induction vs as [|v vs tr_vs]. + induction vs as [| v vs tr_vs]. - exact tt. - - destruct vs as [|v' vs']. + - destruct vs as [| v' vs']. + exact (translate_value v). + exact (translate_value v, tr_vs). Defined. @@ -292,7 +287,8 @@ Defined. (* map translate_value ls *) (* foldr chProd ls *) -Definition translate_ptr (ptr : pointer) : Location := (chWord Uptr ; Z.to_nat (wunsigned ptr)). +Definition translate_ptr (ptr : pointer) : Location := + ('word Uptr ; Z.to_nat (wunsigned ptr)). (* from pkg_invariants *) Definition cast_ct_val {t t' : choice_type} (e : t = t') (v : t) : t'. @@ -321,58 +317,55 @@ Proof. Qed. Definition rel_mem (m : mem) (h : heap) := - forall ptr sz v, read m ptr sz = ok v -> get_heap h (translate_ptr ptr) = coerce_to_choice_type _ (translate_value (@to_val (sword sz) v)). + ∀ ptr sz v, + read m ptr sz = ok v → + get_heap h (translate_ptr ptr) = + coerce_to_choice_type _ (translate_value (@to_val (sword sz) v)). -Local Open Scope vmap_scope. +#[local] Open Scope vmap_scope. Definition rel_vmap (vm : vmap) (h : heap) (fn : funname) := - forall (i : var) v, vm.[i] = ok v - -> get_heap h (translate_var fn i) = coerce_to_choice_type _ (embed _ v). - + ∀ (i : var) v, + vm.[i] = ok v → + get_heap h (translate_var fn i) = coerce_to_choice_type _ (embed v). Definition rel_estate (s : estate) (h : heap) (fn : funname) := - rel_mem s.(emem) h /\ rel_vmap s.(evm) h fn. + rel_mem s.(emem) h ∧ rel_vmap s.(evm) h fn. -Definition instr_d (i : instr) : instr_r := match i with | MkI _ i => i end. +Definition instr_d (i : instr) : instr_r := + match i with MkI _ i => i end. Lemma coerce_cast_code (ty vty : choice_type) (v : vty) : - ret (coerce_to_choice_type ty v) - = coerce_typed_code ty (vty ; ret v). + ret (coerce_to_choice_type ty v) = coerce_typed_code ty (vty ; ret v). Proof. simpl. - funelim (coerce_to_choice_type ty v); - funelim (coerce_typed_code t (tv; ret v)). + funelim (coerce_to_choice_type ty v) ; + funelim (coerce_typed_code t (tv ; ret v)). - rewrite <- Heqcall, <- Heqcall0. - pose proof e as e'. - symmetry in e'. + pose proof e as e'. symmetry in e'. move: e' => /eqP e'. subst. rewrite cast_ct_val_K. - simpl. cbn. rewrite cast_typed_code_K. reflexivity. - - simpl in *. - exfalso. - clear -e e0. rewrite <- e in e0. congruence. - - simpl in *. - exfalso. - clear -e e0. rewrite <- e in e0. congruence. + - simpl in *. congruence. + - simpl in *. congruence. - rewrite <- Heqcall, <- Heqcall0. reflexivity. Qed. -Lemma translate_pexpr_correct fn (e : pexpr) (pg : glob_decls) s1 v ty v' ty' - (H0 : sem_pexpr pg s1 e = ok v) - (H1 : truncate_val ty v = ok v') : - - ⊢ ⦃ λ '(s₀, s₁), s₀ = s₁ ⦄ - ret (coerce_to_choice_type ty' (translate_value v')) - ≈ - coerce_typed_code ty' - (truncate_code ty (translate_pexpr fn e)) - ⦃ eq ⦄ -. +Lemma translate_pexpr_correct : + ∀ fn (e : pexpr) (pg : glob_decls) s₁ v ty v' ty', + sem_pexpr pg s₁ e = ok v → + truncate_val ty v = ok v' → + ⊢ ⦃ λ '(s₀, s₁), s₀ = s₁ ⦄ + ret (coerce_to_choice_type ty' (translate_value v')) + ≈ + coerce_typed_code ty' + (truncate_code ty (translate_pexpr fn e)) + ⦃ eq ⦄. Proof. + intros fn e pg s₁ v ty v' ty' h1 h2. rewrite coerce_cast_code. - Admitted. +Admitted. (* something like this *) (* Lemma translate_pexpr_correct fn (e : pexpr) (pg : glob_decls) s1 v ty v' ty' *) @@ -396,40 +389,46 @@ Theorem translate_prog_correct (p : expr.uprog) (fn : funname) m va m' vr f : let cod := lchtuple (map choice_type_of_val vr) in get_fundef_ssp sp fn dom cod = Some f → (* satisfies_globs (p_globs p) (translate_mem m, translate_mem m') -> *) - ⊢ ⦃ satisfies_globs (p_globs p) ⦄ f (translate_values va) ≈ ret (translate_values vr) ⦃ λ '(v1, s1) '(v2,s2), v1 = v2 ⦄. + ⊢ ⦃ satisfies_globs (p_globs p) ⦄ + f (translate_values va) ≈ ret (translate_values vr) + ⦃ λ '(v1, s1) '(v2,s2), v1 = v2 ⦄. Proof. (* intros H H1 H2 H3 H4. *) (* unshelve eapply sem_call_Ind. *) (* all: shelve_unifiable. *) intros H. set (Pfun := - λ (m : mem) (fn : funname) (va : seq value) (m' : mem) (vr : seq value), - forall f, - let sp := translate_prog p in - let dom := lchtuple [seq choice_type_of_val i | i <- va] in - let cod := lchtuple [seq choice_type_of_val i | i <- vr] in - get_fundef_ssp sp fn dom cod = Some f -> - (* satisfies_globs (p_globs p) (translate_mem m, translate_mem m') → *) - ⊢ ⦃ satisfies_globs (p_globs p) ⦄ f (translate_values va) ≈ - ret (translate_values vr) ⦃ λ '(v1, _) '(v2, _), v1 = v2 ⦄ - ). - + λ (m : mem) (fn : funname) (va : seq value) (m' : mem) (vr : seq value), + ∀ f, + let sp := translate_prog p in + let dom := lchtuple [seq choice_type_of_val i | i <- va] in + let cod := lchtuple [seq choice_type_of_val i | i <- vr] in + get_fundef_ssp sp fn dom cod = Some f -> + (* satisfies_globs (p_globs p) (translate_mem m, translate_mem m') → *) + ⊢ ⦃ satisfies_globs (p_globs p) ⦄ + f (translate_values va) ≈ + ret (translate_values vr) + ⦃ λ '(v1, _) '(v2, _), v1 = v2 ⦄ + ). set (Pi_r := - λ (s1 : estate) (i : instr_r) (s2 : estate), - ⊢ ⦃ λ '(h1,h2), False ⦄ translate_instr_r fn i ≈ ret tt ⦃ λ '(v1, _) '(v2, _), True ⦄ - ). - + λ (s1 : estate) (i : instr_r) (s2 : estate), + ⊢ ⦃ λ '(h1,h2), False ⦄ + translate_instr_r fn i ≈ ret tt + ⦃ λ '(v1, _) '(v2, _), True ⦄ + ). set (Pi := λ s1 i s2, (Pi_r s1 (instr_d i) s2)). set (Pc := - λ (s1 : estate) (c : cmd) (s2 : estate), - ⊢ ⦃ λ '(h1,h2), False ⦄ translate_cmd c ≈ ret tt ⦃ λ '(v1, _) '(v2, _), True ⦄ - ). - + λ (s1 : estate) (c : cmd) (s2 : estate), + ⊢ ⦃ λ '(h1,h2), False ⦄ translate_cmd c ≈ ret tt ⦃ λ '(v1, _) '(v2, _), True ⦄ + ). (* FIXME *) - set (Pfor := λ (v : var_i) (ls : seq Z) (s1 : estate) (c : cmd) (s2 : estate), - ⊢ ⦃ λ '(h1,h2), False ⦄ (* ssprove_for *) translate_cmd c ≈ ret tt ⦃ λ '(v1, _) '(v2, _), True ⦄). - - + set (Pfor := + λ (v : var_i) (ls : seq Z) (s1 : estate) (c : cmd) (s2 : estate), + ⊢ ⦃ λ '(h1,h2), False ⦄ + (* ssprove_for *) translate_cmd c ≈ + ret tt + ⦃ λ '(v1, _) '(v2, _), True ⦄ + ). unshelve eapply (@sem_call_Ind _ _ _ _ Pc Pi_r Pi Pfor Pfun _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H). - red. intros. red. unfold translate_cmd. simpl. @@ -449,7 +448,7 @@ Proof. * eapply r_bind with (mid := eq). -- instantiate (1 := ret (coerce_to_choice_type _ (translate_value v'))). - by eapply translate_pexpr_sound. + (* by eapply translate_pexpr_sound. *) admit. (* by H0: sem_pexpr e = ok v *) -- intros. eapply rpre_hypothesis_rule. @@ -509,4 +508,4 @@ Proof. admit. Admitted. -End Translation. +End Translation. \ No newline at end of file From 61a754af1d52e43e6e1c0d85a29eba7fdb26ae32 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Sun, 27 Mar 2022 23:48:20 +0200 Subject: [PATCH 022/383] Prove coerce_typed_code_neq --- theories/Jasmin/jasmin_translate.v | 31 ++++++++++++++++++++++++++++-- 1 file changed, 29 insertions(+), 2 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index cc12c1e8..54d066a0 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -122,6 +122,19 @@ Proof. move: e => /eqP e. subst. reflexivity. Qed. +Lemma coerce_typed_code_neq : + ∀ (ty ty' : choice_type) c, + ty ≠ ty' → + coerce_typed_code ty' (ty ; c) = ret (chCanonical _). +Proof. + intros ty ty' c ne. + funelim (coerce_typed_code ty' (ty ; c)). + 1:{ + clear - e ne. symmetry in e. move: e => /eqP e. simpl in e. contradiction. + } + symmetry. assumption. +Qed. + (* Definition cast_typed_code (ty : choice_type) (tc : typed_code) : raw_code ty. *) (* Proof. *) (* destruct tc as [t c]. *) @@ -352,6 +365,8 @@ Proof. reflexivity. Qed. +Derive NoConfusion for result. + Lemma translate_pexpr_correct : ∀ fn (e : pexpr) (pg : glob_decls) s₁ v ty v' ty', sem_pexpr pg s₁ e = ok v → @@ -359,12 +374,24 @@ Lemma translate_pexpr_correct : ⊢ ⦃ λ '(s₀, s₁), s₀ = s₁ ⦄ ret (coerce_to_choice_type ty' (translate_value v')) ≈ - coerce_typed_code ty' - (truncate_code ty (translate_pexpr fn e)) + coerce_typed_code ty' (truncate_code ty (translate_pexpr fn e)) ⦃ eq ⦄. Proof. intros fn e pg s₁ v ty v' ty' h1 h2. rewrite coerce_cast_code. + unfold choice_type_of_val. + (* TODO unfold truncate_code, but for this we need a proper def *) + (* assert (e2 : ty = encode (type_of_val v')). *) + destruct (ty' == encode (type_of_val v')) eqn:e1. + 2:{ + rewrite coerce_typed_code_neq. + 2:{ move: e1 => /eqP e1. congruence. } + (* Ideally we should conclude the other coercion fails too. *) + admit. + } + unfold truncate_val in h2. destruct of_val eqn:ev. 2: discriminate. + simpl in h2. noconf h2. + (* rewrite type_of_to_val. *) Admitted. (* something like this *) From 3fb63335f3998eb053077564f95661749381fe50 Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Mon, 28 Mar 2022 10:08:39 +0200 Subject: [PATCH 023/383] document array lookup --- theories/Jasmin/jasmin_translate.v | 42 ++++++++++++++++++++++++++---- 1 file changed, 37 insertions(+), 5 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 54d066a0..17bb7ef8 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -36,11 +36,14 @@ Context (P : uprog). Notation gd := (p_globs P). +Notation " 'array " := (chMap 'int ('word 8)) (at level 2) : package_scope. +Notation " 'array " := (chMap 'int ('word 8)) (in custom pack_type at level 2). + Definition encode (t : stype) : choice_type := match t with | sbool => 'bool | sint => 'int - | sarr n => chMap 'int ('word 8) + | sarr n => 'array | sword n => 'word n end. @@ -75,16 +78,42 @@ Definition typed_code := ∑ (a : choice_type), raw_code a. Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code. Proof. - destruct e. + destruct e as [z|b| |x|aa ws x e| | | | | | ]. - exists chInt. apply ret. exact z. - exists chBool. exact (ret b). - (* Parr_init only gets produced by ArrayInit() in jasmin source; the EC export asserts false on it, so we don't support it for now. *) exact unsupported. - - pose (translate_gvar fn g). + - pose (translate_gvar fn x) as l. exists (projT1 l). apply (getr l). apply ret. - - exact unsupported. + - (* exists 'array. *) + (* | Pget aa ws x e => *) + (* Let (n, t) := gd, s.[x] in *) + + exact unsupported. + +(* Look up x amongst the evm part of the estate and the globals gd. Monadic Let + because we might find None. If (Some val) is found, fail with type error + unless (val = Varr n t). We obtain (n: positive) and (t: array n). *) + + (* Let i := sem_pexpr s e >>= to_int in *) + + (* Evaluate the indexing expression `e` and coerce it to Z. *) + + (* Let w := WArray.get aa ws t i in *) + + (* array look-up, where + WArray.get aa ws t i = + CoreMem.read t a (i * (if aa == AAscale then (ws/8) else 1)) ws + *) + + (* ok (Vword w) *) + + (* pose (translate_gvar fn x) as lx. *) + (* pose (v ← get lx ;; @ret _ (coerce_to_array v))%pack. *) + (* pose (r ;; ret tt). *) + - exact unsupported. - exact unsupported. - exact unsupported. @@ -93,6 +122,9 @@ Proof. - exact unsupported. Defined. + + + (* FIXME: actually perform the truncation *) Definition truncate_code (s : stype) (c : typed_code) : typed_code := c. @@ -535,4 +567,4 @@ Proof. admit. Admitted. -End Translation. \ No newline at end of file +End Translation. From 52bf0713a9a1e3a6cc7610a84cc302d52d35051a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Mon, 28 Mar 2022 10:33:09 +0200 Subject: [PATCH 024/383] Define truncate_code --- theories/Jasmin/jasmin_translate.v | 71 ++++++++++++++++++------------ 1 file changed, 43 insertions(+), 28 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 17bb7ef8..c013f243 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -122,11 +122,52 @@ Proof. - exact unsupported. Defined. +(* from pkg_invariants *) +Definition cast_ct_val {t t' : choice_type} (e : t = t') (v : t) : t'. +Proof. + subst. auto. +Defined. + +Lemma cast_ct_val_K : + ∀ t e v, + @cast_ct_val t t e v = v. +Proof. + intros t e v. + assert (e = erefl). + { apply eq_irrelevance. } + subst. reflexivity. +Qed. +Equations? coerce_to_choice_type (t : choice_type) {tv : choice_type} (v : tv) : t := + @coerce_to_choice_type t tv v with inspect (tv == t) := { + | @exist true e => cast_ct_val _ v + | @exist false e => chCanonical t + }. +Proof. + symmetry in e. + move: e => /eqP e. subst. reflexivity. +Qed. +Definition truncate_el {t : choice_type} (s : stype) : t → encode s := + match s return t → encode s with + | sbool => λ b, coerce_to_choice_type 'bool b + | sint => λ i, coerce_to_choice_type 'int i + | sarr n => + (* Here we do not perform the check on the length of the array as + performed by to_arr n + *) + λ a, coerce_to_choice_type 'array a + | sword n => + λ w, + let w' := coerce_to_choice_type ('word n) w in + match truncate_word n w' with + | Ok w'' => w'' + | _ => chCanonical _ + end + end. -(* FIXME: actually perform the truncation *) -Definition truncate_code (s : stype) (c : typed_code) : typed_code := c. +Definition truncate_code (s : stype) (c : typed_code) : typed_code := + (encode s ; x ← c.π2 ;; ret (truncate_el s x)). Definition cast_typed_code (t' : choice_type) (c : typed_code) (e : c.π1 = t') : raw_code t'. @@ -335,32 +376,6 @@ Defined. Definition translate_ptr (ptr : pointer) : Location := ('word Uptr ; Z.to_nat (wunsigned ptr)). -(* from pkg_invariants *) -Definition cast_ct_val {t t' : choice_type} (e : t = t') (v : t) : t'. -Proof. - subst. auto. -Defined. - -Lemma cast_ct_val_K : - ∀ t e v, - @cast_ct_val t t e v = v. -Proof. - intros t e v. - assert (e = erefl). - { apply eq_irrelevance. } - subst. reflexivity. -Qed. - -Equations? coerce_to_choice_type (t : choice_type) {tv : choice_type} (v : tv) : t := - @coerce_to_choice_type t tv v with inspect (tv == t) := { - | @exist true e => cast_ct_val _ v - | @exist false e => chCanonical t - }. -Proof. - symmetry in e. - move: e => /eqP e. subst. reflexivity. -Qed. - Definition rel_mem (m : mem) (h : heap) := ∀ ptr sz v, read m ptr sz = ok v → From 76a5bcabf2a62b76a8875df6d90ecd2db298ee88 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Mon, 28 Mar 2022 12:31:16 +0200 Subject: [PATCH 025/383] Prove a few cases of translate_pexpr_correct --- theories/Jasmin/jasmin_translate.v | 115 ++++++++++++++++++++++++++--- 1 file changed, 106 insertions(+), 9 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index c013f243..461cd570 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -82,8 +82,9 @@ Proof. - exists chInt. apply ret. exact z. - exists chBool. exact (ret b). - (* Parr_init only gets produced by ArrayInit() in jasmin source; the EC - export asserts false on it, so we don't support it for now. *) - exact unsupported. + export asserts false on it. *) + exists 'array. + exact (ret emptym). - pose (translate_gvar fn x) as l. exists (projT1 l). apply (getr l). apply ret. @@ -208,6 +209,19 @@ Proof. symmetry. assumption. Qed. +Lemma coerce_typed_code_K : + ∀ (ty : choice_type) c, + coerce_typed_code ty (ty ; c) = c. +Proof. + intros ty c. + funelim (coerce_typed_code ty (ty ; c)). + 2:{ + clear - e. symmetry in e. move: e => /eqP e. simpl in e. contradiction. + } + rewrite <- Heqcall. + apply cast_typed_code_K. +Qed. + (* Definition cast_typed_code (ty : choice_type) (tc : typed_code) : raw_code ty. *) (* Proof. *) (* destruct tc as [t c]. *) @@ -350,6 +364,24 @@ Proof. values.v), all of these functions raise an error on Vundef. *) Defined. +Lemma eq_rect_r_K : + ∀ (A : eqType) (x : A) (P : A → Type) h e, + @eq_rect_r A x P h x e = h. +Proof. + intros A x P' h e. + replace e with (@erefl A x) by apply eq_irrelevance. + reflexivity. +Qed. + +Lemma translate_value_to_val : + ∀ (s : stype) (v : sem_t s), + translate_value (to_val v) = eq_rect_r encode (embed v) (type_of_to_val v). +Proof. + intros s v. + destruct s as [| | size | size]. + all: simpl ; rewrite eq_rect_r_K ; reflexivity. +Qed. + Fixpoint type_of_values vs : choice_type := match vs with | [::] => 'unit @@ -412,13 +444,24 @@ Proof. reflexivity. Qed. +Lemma coerce_to_choice_type_K : + ∀ (t : choice_type) (v : t), + coerce_to_choice_type t v = v. +Proof. + intros t v. + funelim (coerce_to_choice_type t v). + 2:{ clear - e. rewrite eqxx in e. discriminate. } + rewrite <- Heqcall. + apply cast_ct_val_K. +Qed. + Derive NoConfusion for result. Lemma translate_pexpr_correct : ∀ fn (e : pexpr) (pg : glob_decls) s₁ v ty v' ty', sem_pexpr pg s₁ e = ok v → truncate_val ty v = ok v' → - ⊢ ⦃ λ '(s₀, s₁), s₀ = s₁ ⦄ + ⊢ ⦃ λ '(h₀, h₁), rel_estate s₁ h₀ fn ∧ h₀ = h₁ ⦄ ret (coerce_to_choice_type ty' (translate_value v')) ≈ coerce_typed_code ty' (truncate_code ty (translate_pexpr fn e)) @@ -427,18 +470,72 @@ Proof. intros fn e pg s₁ v ty v' ty' h1 h2. rewrite coerce_cast_code. unfold choice_type_of_val. - (* TODO unfold truncate_code, but for this we need a proper def *) - (* assert (e2 : ty = encode (type_of_val v')). *) + unfold truncate_code. + assert (e2 : ty = type_of_val v'). + { unfold truncate_val in h2. destruct of_val eqn:ev. 2: discriminate. + simpl in h2. noconf h2. + symmetry. apply type_of_to_val. + } + subst. destruct (ty' == encode (type_of_val v')) eqn:e1. 2:{ rewrite coerce_typed_code_neq. 2:{ move: e1 => /eqP e1. congruence. } - (* Ideally we should conclude the other coercion fails too. *) - admit. + rewrite coerce_typed_code_neq. + 2:{ move: e1 => /eqP e1. congruence. } + apply r_ret. intuition subst. reflexivity. } + pose proof e1 as e2. move: e2 => /eqP e2. subst. + rewrite 2!coerce_typed_code_K. unfold truncate_val in h2. destruct of_val eqn:ev. 2: discriminate. - simpl in h2. noconf h2. - (* rewrite type_of_to_val. *) + simpl in h2. noconf h2. destruct H. + clear e1. + (* Now we can actually look at the pexpr *) + induction e as [z|b| |x|aa ws x e| | | | | | ]. + - simpl. simpl in h1. noconf h1. + apply of_vint in ev as es. + revert s ev. rewrite es. intros s ev. + simpl. simp coerce_to_choice_type. simpl. + rewrite cast_ct_val_K. + simpl in ev. noconf ev. + apply r_ret. intuition subst. reflexivity. + - simpl. simpl in h1. noconf h1. + apply of_vbool in ev as es. + destruct es as [es _]. + revert s ev. rewrite es. intros s ev. + simpl. simp coerce_to_choice_type. simpl. + rewrite cast_ct_val_K. + simpl in ev. noconf ev. + apply r_ret. intuition subst. reflexivity. + - simpl. simpl in h1. noconf h1. + apply of_varr in ev as es. + move: es => /values.subtypeE es. + destruct es as [m [es hm]]. + revert s ev. rewrite es. intros s ev. + simpl. simp coerce_to_choice_type. simpl. + rewrite cast_ct_val_K. + simpl in ev. apply WArray.cast_empty_ok in ev. subst. + simpl. rewrite Mz.foldP. simpl. + apply r_ret. intuition subst. reflexivity. + - simpl. simpl in h1. + apply type_of_get_gvar in h1 as es. + unfold translate_gvar. unfold translate_var. + unfold get_gvar in h1. + destruct is_lvar eqn:hlvar. + + destruct x as [gx gs]. simpl in *. + unfold is_lvar in hlvar. simpl in hlvar. move: hlvar => /eqP hlvar. subst. + unfold get_var in h1. + unfold on_vu in h1. destruct Fv.get as [sx |] eqn:e1. + 2:{ destruct e. all: discriminate. } + noconf h1. + eapply r_get_remember_rhs with (pre := λ '(h₀, h₁), rel_estate s₁ h₀ fn ∧ h₀ = h₁). + intro vx. simpl in vx. + apply r_ret. intros ? he [[[hmem hvmap] ?] h]. subst. + f_equal. + apply hvmap in e1. simpl in h. + rewrite h in e1. clear h. subst. + simpl. rewrite coerce_to_choice_type_K. + set (ty := type_of_val v') in *. clearbody ty. clear v' es. Admitted. (* something like this *) From 31e056a6dcdeb3a7ff5e89ee2d0a3cd5eebd9a85 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Mon, 28 Mar 2022 14:01:42 +0200 Subject: [PATCH 026/383] Progress on translate_pexpr_correct --- theories/Jasmin/jasmin_translate.v | 56 +++++++++++++++++++++--------- 1 file changed, 40 insertions(+), 16 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 461cd570..b4719336 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -456,6 +456,8 @@ Proof. Qed. Derive NoConfusion for result. +Derive NoConfusion for value. +Derive NoConfusion for wsize. Lemma translate_pexpr_correct : ∀ fn (e : pexpr) (pg : glob_decls) s₁ v ty v' ty', @@ -535,24 +537,46 @@ Proof. apply hvmap in e1. simpl in h. rewrite h in e1. clear h. subst. simpl. rewrite coerce_to_choice_type_K. - set (ty := type_of_val v') in *. clearbody ty. clear v' es. + set (ty := type_of_val v') in *. clearbody ty. + clear - ev. set (ty' := vtype gx) in *. clearbody ty'. clear - ev. + pose proof (type_of_to_val s) as ety. + destruct ty. + * simpl. simpl in ev. + unfold to_bool in ev. destruct to_val eqn:esx. all: try discriminate. + 2:{ destruct t. all: discriminate. } + noconf ev. pose proof (type_of_to_val sx) as ety'. + rewrite esx in ety'. subst. + rewrite coerce_to_choice_type_K. + simpl. noconf esx. reflexivity. + * simpl. simpl in ev. + unfold to_int in ev. destruct to_val eqn:esx. all: try discriminate. + 2:{ destruct t. all: discriminate. } + noconf ev. pose proof (type_of_to_val sx) as ety'. + rewrite esx in ety'. subst. + rewrite coerce_to_choice_type_K. + simpl. noconf esx. reflexivity. + * simpl. simpl in ev. + unfold to_arr in ev. destruct to_val eqn:esx. all: try discriminate. + pose proof (type_of_to_val sx) as ety'. + rewrite esx in ety'. subst. + rewrite coerce_to_choice_type_K. + simpl. noconf esx. + unfold WArray.cast in ev. destruct (_ <=? _)%Z. 2: discriminate. + noconf ev. simpl. reflexivity. + * simpl. simpl in ev. + pose proof (type_of_to_val sx) as ety'. + unfold to_word in ev. destruct to_val eqn:esx. all: try discriminate. + --- subst. noconf esx. inversion H. subst. + (* rewrite coerce_to_choice_type_K. + simpl. noconf esx. + unfold WArray.cast in ev. destruct (_ <=? _)%Z. 2: discriminate. + noconf ev. simpl. reflexivity. + + + unfold truncate_el. + rewrite type_of_to_val. *) Admitted. -(* something like this *) -(* Lemma translate_pexpr_correct fn (e : pexpr) (pg : glob_decls) s1 v ty v' ty' *) -(* (H0 : sem_pexpr pg s1 e = ok v) *) -(* (H1 : truncate_val ty v = ok v') : *) - -(* ⊢ ⦃ λ '(s₀, s₁), s₀ = s₁ ⦄ *) -(* ret (translate_value v') *) -(* ≈ *) -(* projT2 (truncate_code ty (translate_pexpr fn e)) *) -(* ⦃ eq ⦄ *) -(* . *) -(* Proof. *) -(* rewrite coerce_cast_code. *) -(* Admitted. *) - Theorem translate_prog_correct (p : expr.uprog) (fn : funname) m va m' vr f : sem.sem_call p m fn va m' vr → let sp := (translate_prog p) in From 4791f320bc491281a5b445aec6180ba147463176 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Mon, 28 Mar 2022 16:28:40 +0200 Subject: [PATCH 027/383] changed chWord to take a wsize instead of nat --- theories/Crypt/choice_type.v | 35 ++++++++++++++++++------ theories/Crypt/package/pkg_interpreter.v | 5 +++- 2 files changed, 31 insertions(+), 9 deletions(-) diff --git a/theories/Crypt/choice_type.v b/theories/Crypt/choice_type.v index a4ad6464..1ce2bbb9 100644 --- a/theories/Crypt/choice_type.v +++ b/theories/Crypt/choice_type.v @@ -13,6 +13,7 @@ Set Warnings "-ambiguous-paths,-notation-overridden,-notation-incompatible-forma From mathcomp Require Import ssrnat ssreflect ssrfun ssrbool ssrnum eqtype choice reals distr realsum seq all_algebra fintype. From CoqWord Require Import word ssrZ. +From Jasmin Require Import utils word. Set Warnings "ambiguous-paths,notation-overridden,notation-incompatible-format". From Crypt Require Import Prelude Axioms. From extructures Require Import ord fset fmap. @@ -44,7 +45,7 @@ Inductive choice_type := | chMap (A B : choice_type) | chOption (A : choice_type) | chFin (n : positive) -| chWord (nbits : nat). +| chWord (nbits : wsize). Derive NoConfusion NoConfusionHom for choice_type. @@ -233,7 +234,7 @@ Section choice_typeTypes. | chWord n, chMap _ _ => false | chWord n, chOption _ => false | chWord n, chFin _ => false - | chWord n, chWord n' => n < n' + | chWord n, chWord n' => (n < n')%CMP end. Definition choice_type_leq (t1 t2 : choice_type) := @@ -293,7 +294,7 @@ Section choice_typeTypes. - destruct v. all: try discriminate. all: destruct w; try discriminate; auto. simpl in *. - eapply ltn_trans. all: eauto. + eapply cmp_lt_trans. all: eauto. Qed. Lemma choice_type_lt_areflexive : @@ -313,7 +314,7 @@ Section choice_typeTypes. + apply/nandP. right. apply ih2. - rewrite ltnn. auto. - - rewrite ltnn. auto. + - by rewrite /cmp_lt /gcmp cmp_refl. Qed. Lemma choice_type_lt_total_holds : @@ -402,8 +403,14 @@ Section choice_typeTypes. - destruct y. all: try (intuition; reflexivity). unfold choice_type_lt. unfold choice_type_test. - rewrite -neq_ltn. - apply /implyP. auto. + (* Search implb. *) + (* Locate "==>". *) + apply /implyP. + move => H. apply /orP. + destruct (gcmp x nbits) eqn:E. + + by move: E H => /cmp_eq -> /negP. + + left. by apply /eqP. + + right. unfold cmp_lt. rewrite cmp_sym. by move: E => ->. Qed. Lemma choice_type_lt_asymmetric : @@ -508,9 +515,20 @@ Section choice_typeTypes. | chMap l r => GenTree.Node 2 [:: encode l ; encode r] | chOption u => GenTree.Node 3 [:: encode u] | chFin n => GenTree.Node 4 [:: GenTree.Leaf (pos n)] - | chWord n => GenTree.Node 5 [:: GenTree.Leaf n] + | chWord n => GenTree.Node 5 [:: GenTree.Leaf (nat_of_wsize n)] end. + Definition wsize_of_nat n : wsize := + match n with + | 8%nat => U8 + | 16%nat => U16 + | 32%nat => U32 + | 64%nat => U64 + | 128%nat => U128 + | 256%nat => U256 + | _ => U8 + end. + Fixpoint decode (t : GenTree.tree nat) : option choice_type := match t with | GenTree.Leaf 1 => Some chUnit @@ -533,7 +551,7 @@ Section choice_typeTypes. | _ => None end | GenTree.Node 4 [:: GenTree.Leaf (S n)] => Some (chFin (mkpos (S n))) - | GenTree.Node 5 [:: GenTree.Leaf n] => Some (chWord n) + | GenTree.Node 5 [:: GenTree.Leaf n] => Some (chWord (wsize_of_nat n)) | _ => None end. @@ -549,6 +567,7 @@ Section choice_typeTypes. destruct n. + discriminate. + cbn. repeat f_equal. apply eq_irrelevance. + - destruct nbits; reflexivity. Defined. Definition choice_type_choiceMixin := PcanChoiceMixin codeK. diff --git a/theories/Crypt/package/pkg_interpreter.v b/theories/Crypt/package/pkg_interpreter.v index 72ab62af..057ae5c4 100644 --- a/theories/Crypt/package/pkg_interpreter.v +++ b/theories/Crypt/package/pkg_interpreter.v @@ -9,6 +9,8 @@ From Crypt Require Import Prelude choice_type From Coq Require Import Utf8. From extructures Require Import ord fset fmap. +From Jasmin Require Import word. + From Equations Require Import Equations. Set Equations With UIP. @@ -166,7 +168,8 @@ Section Interpreter. Next Obligation. eapply word.mkWord. - instantiate (1 := ((Z.of_nat seed) mod word.modulus n)%Z). + + instantiate (1 := ((Z.of_nat seed) mod (word.modulus (nat_of_wsize n) ))%Z). pose (Z.mod_bound_pos (Z.of_nat seed) (word.modulus n) (Zle_0_nat seed)). pose (word.modulus_gt0 n). From ae31e91b3de839250a0987290a88d7d471839a83 Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Mon, 28 Mar 2022 16:31:13 +0200 Subject: [PATCH 028/383] Also changed chWord to take a wsize instead of nat --- theories/Crypt/choice_type.v | 37 +++++++++++++++++------- theories/Crypt/package/pkg_interpreter.v | 8 ++--- theories/Jasmin/jasmin_translate.v | 4 +-- 3 files changed, 33 insertions(+), 16 deletions(-) diff --git a/theories/Crypt/choice_type.v b/theories/Crypt/choice_type.v index a4ad6464..c1e800a3 100644 --- a/theories/Crypt/choice_type.v +++ b/theories/Crypt/choice_type.v @@ -13,6 +13,7 @@ Set Warnings "-ambiguous-paths,-notation-overridden,-notation-incompatible-forma From mathcomp Require Import ssrnat ssreflect ssrfun ssrbool ssrnum eqtype choice reals distr realsum seq all_algebra fintype. From CoqWord Require Import word ssrZ. +From Jasmin Require Import wsize word utils. Set Warnings "ambiguous-paths,notation-overridden,notation-incompatible-format". From Crypt Require Import Prelude Axioms. From extructures Require Import ord fset fmap. @@ -44,7 +45,7 @@ Inductive choice_type := | chMap (A B : choice_type) | chOption (A : choice_type) | chFin (n : positive) -| chWord (nbits : nat). +| chWord (nbits : wsize). Derive NoConfusion NoConfusionHom for choice_type. @@ -233,7 +234,7 @@ Section choice_typeTypes. | chWord n, chMap _ _ => false | chWord n, chOption _ => false | chWord n, chFin _ => false - | chWord n, chWord n' => n < n' + | chWord n, chWord n' => (n < n')%CMP end. Definition choice_type_leq (t1 t2 : choice_type) := @@ -293,7 +294,7 @@ Section choice_typeTypes. - destruct v. all: try discriminate. all: destruct w; try discriminate; auto. simpl in *. - eapply ltn_trans. all: eauto. + eapply cmp_lt_trans. all: eauto. Qed. Lemma choice_type_lt_areflexive : @@ -313,7 +314,8 @@ Section choice_typeTypes. + apply/nandP. right. apply ih2. - rewrite ltnn. auto. - - rewrite ltnn. auto. + - rewrite cmp_nlt_le. + apply cmp_le_refl. Qed. Lemma choice_type_lt_total_holds : @@ -402,9 +404,22 @@ Section choice_typeTypes. - destruct y. all: try (intuition; reflexivity). unfold choice_type_lt. unfold choice_type_test. - rewrite -neq_ltn. - apply /implyP. auto. - Qed. + unshelve apply /implyP. + intro. + pose proof (cmp_le_eq_lt x nbits). + destruct (x < nbits)%CMP eqn:E. + + easy. + + apply /orP. right. + rewrite E in H0. simpl in *. + (* intuition eauto. *) + (* unshelve apply /implyP. *) + (* Set Printing All. *) + (* rewrite -neq_ltn. *) + (* unshelve apply /implyP. *) + (* intros. Set Printing All. *) + (* auto. *) + admit. + Admitted. Lemma choice_type_lt_asymmetric : ∀ x y, @@ -508,7 +523,7 @@ Section choice_typeTypes. | chMap l r => GenTree.Node 2 [:: encode l ; encode r] | chOption u => GenTree.Node 3 [:: encode u] | chFin n => GenTree.Node 4 [:: GenTree.Leaf (pos n)] - | chWord n => GenTree.Node 5 [:: GenTree.Leaf n] + | chWord n => GenTree.Node 5 [:: GenTree.Leaf (wsize_log2 n)] end. Fixpoint decode (t : GenTree.tree nat) : option choice_type := @@ -533,7 +548,7 @@ Section choice_typeTypes. | _ => None end | GenTree.Node 4 [:: GenTree.Leaf (S n)] => Some (chFin (mkpos (S n))) - | GenTree.Node 5 [:: GenTree.Leaf n] => Some (chWord n) + | GenTree.Node 5 [:: GenTree.Leaf n] => Some (chWord (nth U8 wsizes n)) | _ => None end. @@ -549,7 +564,9 @@ Section choice_typeTypes. destruct n. + discriminate. + cbn. repeat f_equal. apply eq_irrelevance. - Defined. + - repeat f_equal. unfold wsizes. + destruct nbits; reflexivity. + Qed. Definition choice_type_choiceMixin := PcanChoiceMixin codeK. Canonical choice_type_choiceType := diff --git a/theories/Crypt/package/pkg_interpreter.v b/theories/Crypt/package/pkg_interpreter.v index 72ab62af..f9438a39 100644 --- a/theories/Crypt/package/pkg_interpreter.v +++ b/theories/Crypt/package/pkg_interpreter.v @@ -129,7 +129,7 @@ Section Interpreter. #[program] Fixpoint sampler (e : choice_type) seed : option (nat * e):= match e with - chUnit => Some (seed, Datatypes.tt) + | chUnit => Some (seed, Datatypes.tt) | chNat => Some ((seed + 1)%nat, seed) | chInt => Some ((seed + 1)%nat, BinInt.Z.of_nat seed) (* FIXME: also generate negative numbers *) | chBool => Some ((seed + 1)%nat, Nat.even seed) @@ -166,10 +166,10 @@ Section Interpreter. Next Obligation. eapply word.mkWord. - instantiate (1 := ((Z.of_nat seed) mod word.modulus n)%Z). - pose (Z.mod_bound_pos (Z.of_nat seed) (word.modulus n) + instantiate (1 := ((Z.of_nat seed) mod word.modulus (word.nat_of_wsize n))%Z). + pose (Z.mod_bound_pos (Z.of_nat seed) (word.modulus (word.nat_of_wsize n)) (Zle_0_nat seed)). - pose (word.modulus_gt0 n). + pose (word.modulus_gt0 (word.nat_of_wsize n)). apply / word.iswordZP. apply a. move : i => / ssrZ.ltzP. diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index b4719336..95c6d9f0 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -36,8 +36,8 @@ Context (P : uprog). Notation gd := (p_globs P). -Notation " 'array " := (chMap 'int ('word 8)) (at level 2) : package_scope. -Notation " 'array " := (chMap 'int ('word 8)) (in custom pack_type at level 2). +Notation " 'array " := (chMap 'int ('word U8)) (at level 2) : package_scope. +Notation " 'array " := (chMap 'int ('word U8)) (in custom pack_type at level 2). Definition encode (t : stype) : choice_type := match t with From 4ba01f31292a2b55420153a22ee4e264cb5c50e6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Mon, 28 Mar 2022 17:28:27 +0200 Subject: [PATCH 029/383] Fix translation of global variables and prove it correct --- theories/Jasmin/jasmin_translate.v | 238 ++++++++++++++++------------- 1 file changed, 136 insertions(+), 102 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 95c6d9f0..2568369d 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1,10 +1,9 @@ Set Warnings "-ambiguous-paths,-notation-overridden,-notation-incompatible-format". From mathcomp Require Import all_ssreflect all_algebra. +From Jasmin Require Import expr compiler_util values sem. Set Warnings "ambiguous-paths,notation-overridden,notation-incompatible-format". From extructures Require Import ord fset fmap. - -From Jasmin Require Import expr compiler_util values sem. From Jasmin Require Import expr_facts. From Coq Require Import Utf8. @@ -16,7 +15,6 @@ From Equations Require Import Equations. Set Equations With UIP. Set Equations Transparent. -(* Set Implicit Arguments. *) Unset Strict Implicit. Unset Printing Implicit Defensive. @@ -68,61 +66,11 @@ Definition nat_of_fun_ident (f : funname) (id : Ident.ident) : nat := Definition translate_var (f : funname) (x : var) : Location := ( encode x.(vtype) ; nat_of_fun_ident f x.(vname)). -Definition translate_gvar (f : funname) (x : gvar) : Location := - translate_var f x.(gv).(v_var). - Definition typed_code := ∑ (a : choice_type), raw_code a. #[local] Definition unsupported : typed_code := ('unit ; assert false). -Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code. -Proof. - destruct e as [z|b| |x|aa ws x e| | | | | | ]. - - exists chInt. apply ret. exact z. - - exists chBool. exact (ret b). - - (* Parr_init only gets produced by ArrayInit() in jasmin source; the EC - export asserts false on it. *) - exists 'array. - exact (ret emptym). - - pose (translate_gvar fn x) as l. - exists (projT1 l). - apply (getr l). apply ret. - - (* exists 'array. *) - (* | Pget aa ws x e => *) - (* Let (n, t) := gd, s.[x] in *) - - exact unsupported. - -(* Look up x amongst the evm part of the estate and the globals gd. Monadic Let - because we might find None. If (Some val) is found, fail with type error - unless (val = Varr n t). We obtain (n: positive) and (t: array n). *) - - (* Let i := sem_pexpr s e >>= to_int in *) - - (* Evaluate the indexing expression `e` and coerce it to Z. *) - - (* Let w := WArray.get aa ws t i in *) - - (* array look-up, where - WArray.get aa ws t i = - CoreMem.read t a (i * (if aa == AAscale then (ws/8) else 1)) ws - *) - - (* ok (Vword w) *) - - (* pose (translate_gvar fn x) as lx. *) - (* pose (v ← get lx ;; @ret _ (coerce_to_array v))%pack. *) - (* pose (r ;; ret tt). *) - - - exact unsupported. - - exact unsupported. - - exact unsupported. - - exact unsupported. - - exact unsupported. - - exact unsupported. -Defined. - (* from pkg_invariants *) Definition cast_ct_val {t t' : choice_type} (e : t = t') (v : t) : t'. Proof. @@ -149,6 +97,17 @@ Proof. move: e => /eqP e. subst. reflexivity. Qed. +Definition truncate_chWord {t : choice_type} (n : wsize) : t → 'word n := + match t with + | chWord m => + λ w, + match truncate_word n w with + | Ok w' => w' + | _ => chCanonical _ + end + | _ => λ x, chCanonical _ + end. + Definition truncate_el {t : choice_type} (s : stype) : t → encode s := match s return t → encode s with | sbool => λ b, coerce_to_choice_type 'bool b @@ -159,12 +118,7 @@ Definition truncate_el {t : choice_type} (s : stype) : t → encode s := *) λ a, coerce_to_choice_type 'array a | sword n => - λ w, - let w' := coerce_to_choice_type ('word n) w in - match truncate_word n w' with - | Ok w'' => w'' - | _ => chCanonical _ - end + λ w, truncate_chWord n w end. Definition truncate_code (s : stype) (c : typed_code) : typed_code := @@ -262,6 +216,93 @@ Definition ssprove_write_lval (fn : funname) (l : lval) (tc : typed_code) (* write_var x (@to_val (sarr n) t) s *) end. +Fixpoint satisfies_globs (globs : glob_decls) : heap * heap → Prop. +Proof. + exact (λ '(x, y), False). (* TODO *) +Defined. + +Fixpoint collect_globs (globs : glob_decls) : seq Location. +Proof. + exact [::]. (* TODO *) +Defined. + +Definition typed_chElement := pointed_value. + +Definition choice_type_of_val (val : value) : choice_type := + encode (type_of_val val). + +Definition translate_value (v : value) : choice_type_of_val v. +Proof. + (* Feels like we could apply embed first, but I don't know what to do with + the undefined case. + *) + destruct v as [b | z | size a | size wd | undef_ty]. + - apply embed. exact b. + - apply embed. exact z. + - apply embed. exact a. + - apply embed. exact wd. + - apply chCanonical. + (* It shouldn't matter which value we pick, because when coercing an undef + value at type ty back to ty via to_{bool,int,word,arr} (defined in + values.v), all of these functions raise an error on Vundef. *) +Defined. + +Definition translate_gvar (f : funname) (x : gvar) : typed_code := + if is_lvar x + then (_ ; x ← get (translate_var f x.(gv).(v_var)) ;; ret x) + else + (encode (vtype x.(gv)) ; + match get_global gd x.(gv).(v_var) with + | Ok v => ret (coerce_to_choice_type _ (translate_value v)) + | _ => ret (chCanonical _) + end + ). + +Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code. +Proof. + destruct e as [z|b| |x|aa ws x e| | | | | | ]. + - exists chInt. apply ret. exact z. + - exists chBool. exact (ret b). + - (* Parr_init only gets produced by ArrayInit() in jasmin source; the EC + export asserts false on it. *) + exists 'array. + exact (ret emptym). + - exact (translate_gvar fn x). + - (* exists 'array. *) + (* | Pget aa ws x e => *) + (* Let (n, t) := gd, s.[x] in *) + + exact unsupported. + +(* Look up x amongst the evm part of the estate and the globals gd. Monadic Let + because we might find None. If (Some val) is found, fail with type error + unless (val = Varr n t). We obtain (n: positive) and (t: array n). *) + + (* Let i := sem_pexpr s e >>= to_int in *) + + (* Evaluate the indexing expression `e` and coerce it to Z. *) + + (* Let w := WArray.get aa ws t i in *) + + (* array look-up, where + WArray.get aa ws t i = + CoreMem.read t a (i * (if aa == AAscale then (ws/8) else 1)) ws + *) + + (* ok (Vword w) *) + + (* pose (translate_gvar fn x) as lx. *) + (* pose (v ← get lx ;; @ret _ (coerce_to_array v))%pack. *) + (* pose (r ;; ret tt). *) + + - exact unsupported. + - exact unsupported. + - exact unsupported. + - exact unsupported. + - exact unsupported. + - exact unsupported. +Defined. + Definition translate_instr_r (fn : funname) (i : instr_r) : raw_code 'unit. Proof. destruct i. @@ -313,16 +354,6 @@ Proof. - exact [interface]. Defined. -Fixpoint satisfies_globs (globs : glob_decls) : heap * heap → Prop. -Proof. - exact (λ '(x, y), False). (* TODO *) -Defined. - -Fixpoint collect_globs (globs : glob_decls) : seq Location. -Proof. - exact [::]. (* TODO *) -Defined. - Definition ssprove_prog := seq (funname * fdef). Definition translate_prog (p : uprog) : ssprove_prog := @@ -330,9 +361,6 @@ Definition translate_prog (p : uprog) : ssprove_prog := let fds := map translate_fundef (p_funcs p) in fds. -Definition choice_type_of_val (val : value) : choice_type := - encode (type_of_val val). - Fixpoint lchtuple (ts : seq choice_type) : choice_type := match ts with | [::] => chUnit @@ -346,24 +374,6 @@ Proof. exact None. (* TODO *) Defined. -Definition typed_chElement := pointed_value. - -Definition translate_value (v : value) : choice_type_of_val v. -Proof. - (* Feels like we could apply embed first, but I don't know what to do with - the undefined case. - *) - destruct v as [b | z | size a | size wd | undef_ty]. - - apply embed. exact b. - - apply embed. exact z. - - apply embed. exact a. - - apply embed. exact wd. - - apply chCanonical. - (* It shouldn't matter which value we pick, because when coercing an undef - value at type ty back to ty via to_{bool,int,word,arr} (defined in - values.v), all of these functions raise an error on Vundef. *) -Defined. - Lemma eq_rect_r_K : ∀ (A : eqType) (x : A) (P : A → Type) h e, @eq_rect_r A x P h x e = h. @@ -460,8 +470,8 @@ Derive NoConfusion for value. Derive NoConfusion for wsize. Lemma translate_pexpr_correct : - ∀ fn (e : pexpr) (pg : glob_decls) s₁ v ty v' ty', - sem_pexpr pg s₁ e = ok v → + ∀ fn (e : pexpr) s₁ v ty v' ty', + sem_pexpr gd s₁ e = ok v → truncate_val ty v = ok v' → ⊢ ⦃ λ '(h₀, h₁), rel_estate s₁ h₀ fn ∧ h₀ = h₁ ⦄ ret (coerce_to_choice_type ty' (translate_value v')) @@ -469,7 +479,7 @@ Lemma translate_pexpr_correct : coerce_typed_code ty' (truncate_code ty (translate_pexpr fn e)) ⦃ eq ⦄. Proof. - intros fn e pg s₁ v ty v' ty' h1 h2. + intros fn e s₁ v ty v' ty' h1 h2. rewrite coerce_cast_code. unfold choice_type_of_val. unfold truncate_code. @@ -566,15 +576,39 @@ Proof. * simpl. simpl in ev. pose proof (type_of_to_val sx) as ety'. unfold to_word in ev. destruct to_val eqn:esx. all: try discriminate. - --- subst. noconf esx. inversion H. subst. - (* rewrite coerce_to_choice_type_K. - simpl. noconf esx. - unfold WArray.cast in ev. destruct (_ <=? _)%Z. 2: discriminate. - noconf ev. simpl. reflexivity. - - - unfold truncate_el. - rewrite type_of_to_val. *) + 2:{ destruct t. all: discriminate. } + subst. simpl. noconf esx. inversion H. rewrite ev. reflexivity. + + simpl. rewrite h1. simpl. + apply r_ret. intuition subst. f_equal. + rewrite -es. rewrite coerce_to_choice_type_K. + pose proof (type_of_to_val s) as ety. + set (ty := type_of_val v') in *. clearbody ty. + clear - ev. + destruct ty. + * simpl. simpl in ev. + unfold to_bool in ev. destruct v eqn:e. all: try discriminate. + 2:{ destruct t. all: discriminate. } + noconf ev. subst. + rewrite coerce_to_choice_type_K. reflexivity. + * simpl. simpl in ev. + unfold to_int in ev. destruct v eqn:e. all: try discriminate. + 2:{ destruct t. all: discriminate. } + noconf ev. subst. + rewrite coerce_to_choice_type_K. + reflexivity. + * simpl. simpl in ev. + unfold to_arr in ev. destruct v eqn:e. all: try discriminate. + (* pose proof (type_of_to_val sx) as ety'. + rewrite esx in ety'. subst. *) + rewrite coerce_to_choice_type_K. + simpl. subst. + unfold WArray.cast in ev. destruct (_ <=? _)%Z. 2: discriminate. + noconf ev. simpl. reflexivity. + * simpl. simpl in ev. + unfold to_word in ev. destruct v eqn:e. all: try discriminate. + 2:{ destruct t. all: discriminate. } + subst. simpl. rewrite ev. reflexivity. + - Admitted. Theorem translate_prog_correct (p : expr.uprog) (fn : funname) m va m' vr f : From e71d3363087a25c663909f61be507386bb356446 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Mon, 28 Mar 2022 19:16:00 +0200 Subject: [PATCH 030/383] Prove r_bind_unary --- theories/Jasmin/jasmin_translate.v | 87 ++++++++++++++++++++++++++---- 1 file changed, 78 insertions(+), 9 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 2568369d..2dfe1882 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -473,11 +473,11 @@ Lemma translate_pexpr_correct : ∀ fn (e : pexpr) s₁ v ty v' ty', sem_pexpr gd s₁ e = ok v → truncate_val ty v = ok v' → - ⊢ ⦃ λ '(h₀, h₁), rel_estate s₁ h₀ fn ∧ h₀ = h₁ ⦄ + ⊢ ⦃ λ '(h₀, h₁), rel_estate s₁ h₁ fn ⦄ ret (coerce_to_choice_type ty' (translate_value v')) ≈ coerce_typed_code ty' (truncate_code ty (translate_pexpr fn e)) - ⦃ eq ⦄. + ⦃ λ '(a₀, h₀) '(a₁, h₁), a₀ = a₁ ∧ rel_estate s₁ h₁ fn ⦄. Proof. intros fn e s₁ v ty v' ty' h1 h2. rewrite coerce_cast_code. @@ -495,7 +495,7 @@ Proof. 2:{ move: e1 => /eqP e1. congruence. } rewrite coerce_typed_code_neq. 2:{ move: e1 => /eqP e1. congruence. } - apply r_ret. intuition subst. reflexivity. + apply r_ret. intuition subst. } pose proof e1 as e2. move: e2 => /eqP e2. subst. rewrite 2!coerce_typed_code_K. @@ -510,7 +510,7 @@ Proof. simpl. simp coerce_to_choice_type. simpl. rewrite cast_ct_val_K. simpl in ev. noconf ev. - apply r_ret. intuition subst. reflexivity. + apply r_ret. intuition subst. - simpl. simpl in h1. noconf h1. apply of_vbool in ev as es. destruct es as [es _]. @@ -518,7 +518,7 @@ Proof. simpl. simp coerce_to_choice_type. simpl. rewrite cast_ct_val_K. simpl in ev. noconf ev. - apply r_ret. intuition subst. reflexivity. + apply r_ret. intuition subst. - simpl. simpl in h1. noconf h1. apply of_varr in ev as es. move: es => /values.subtypeE es. @@ -528,7 +528,7 @@ Proof. rewrite cast_ct_val_K. simpl in ev. apply WArray.cast_empty_ok in ev. subst. simpl. rewrite Mz.foldP. simpl. - apply r_ret. intuition subst. reflexivity. + apply r_ret. intuition subst. - simpl. simpl in h1. apply type_of_get_gvar in h1 as es. unfold translate_gvar. unfold translate_var. @@ -540,12 +540,13 @@ Proof. unfold on_vu in h1. destruct Fv.get as [sx |] eqn:e1. 2:{ destruct e. all: discriminate. } noconf h1. - eapply r_get_remember_rhs with (pre := λ '(h₀, h₁), rel_estate s₁ h₀ fn ∧ h₀ = h₁). + eapply r_get_remember_rhs with (pre := λ '(h₀, h₁), rel_estate s₁ h₁ fn). intro vx. simpl in vx. - apply r_ret. intros ? he [[[hmem hvmap] ?] h]. subst. - f_equal. + apply r_ret. intros ? he [[hmem hvmap] h]. apply hvmap in e1. simpl in h. rewrite h in e1. clear h. subst. + split. + 2:{ split. all: assumption. } simpl. rewrite coerce_to_choice_type_K. set (ty := type_of_val v') in *. clearbody ty. clear - ev. set (ty' := vtype gx) in *. clearbody ty'. clear - ev. @@ -611,6 +612,74 @@ Proof. - Admitted. +Lemma r_bind_unary : + ∀ {A B : choiceType} m f v fv + (pre : precond) (mid : postcond A A) (post : postcond B B), + ⊢ ⦃ pre ⦄ m ≈ ret v ⦃ λ '(a₀, h₀) '(a₁, h₁), mid (a₀, h₀) (a₁, h₁) ∧ a₀ = a₁ ⦄ → + (∀ a, ⊢ ⦃ λ '(s₀, s₁), mid (a, s₀) (a, s₁) ⦄ f a ≈ ret (fv a) ⦃ post ⦄) → + ⊢ ⦃ pre ⦄ bind m f ≈ ret (fv v) ⦃ post ⦄. +Proof. + intros A B m f v fv pre mid post hm hf. + change (ret (fv v)) with (x ← ret v ;; ret (fv x)). + eapply r_bind. + - exact hm. + - intros a₀ a₁. + eapply rpre_hypothesis_rule. + intros ? ? [? ?]. subst. + eapply rpre_weaken_rule. + 1: apply hf. + simpl. intuition subst. assumption. +Qed. + +Lemma translate_instr_r_correct : + ∀ (fn : funname) (i : instr_r) (s₁ s₂ : estate), + sem_i P s₁ i s₂ → + ⊢ ⦃ λ '(h₀, h₁), rel_estate s₁ h₀ fn ⦄ + translate_instr_r fn i ≈ ret tt + ⦃ λ '(_, h₀) '(_, _), rel_estate s₂ h₀ fn ⦄. +Proof. + intros fn i s₁ s₂ h. + induction h as [? ? x ? ? ? ? ? ? ? hw | | | | | | |]. + - simpl. destruct x. + + simpl. apply r_ret. intros h₀ _ hr. + simpl in hw. unfold write_none in hw. + destruct is_sbool eqn:eb. + * unfold on_vu in hw. destruct of_val as [| []]. + all: noconf hw. all: assumption. + * unfold on_vu in hw. destruct of_val as [| []]. + all: noconf hw. assumption. + + simpl. simpl in hw. unfold write_var in hw. + destruct set_var eqn:eset. 2: discriminate. + simpl in hw. noconf hw. + evar (cty : choice_type). + (* change (ret tt) with ((λ _, ret tt) (chCanonical cty)) at 2. *) + epose proof r_bind_unary as thm. + specialize thm with (fv := λ _, tt). + simpl in thm. + specialize thm with (m := coerce_typed_code (encode (vtype H1)) + (truncate_code ty (translate_pexpr fn e))). + eapply thm. all: clear thm. + * eapply rsymmetry. + 1: eapply rpost_weaken_rule. + 1: eapply translate_pexpr_correct. + 1,2: eassumption. + intros [] []. intuition auto. subst. + admit. + * intros a. + (* eapply r_put_lhs. *) + admit. + + admit. + + admit. + + admit. + - admit. + - admit. + - admit. + - admit. + - admit. + - admit. + - admit. +Admitted. + Theorem translate_prog_correct (p : expr.uprog) (fn : funname) m va m' vr f : sem.sem_call p m fn va m' vr → let sp := (translate_prog p) in From d0e47d2bdb8f32a4a270751537e14a628a6c9b15 Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Mon, 28 Mar 2022 22:02:42 +0200 Subject: [PATCH 031/383] progress on correctness of variable assignment --- theories/Jasmin/jasmin_translate.v | 35 +++++++++++++++++++++++------- 1 file changed, 27 insertions(+), 8 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 2dfe1882..b1bce2a4 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -639,8 +639,8 @@ Lemma translate_instr_r_correct : ⦃ λ '(_, h₀) '(_, _), rel_estate s₂ h₀ fn ⦄. Proof. intros fn i s₁ s₂ h. - induction h as [? ? x ? ? ? ? ? ? ? hw | | | | | | |]. - - simpl. destruct x. + induction h as [s₁ s₂ y tag sty e v v' sem_e trunc hw | | | | | | |]. + - simpl. destruct y as [ | y | | | ]. + simpl. apply r_ret. intros h₀ _ hr. simpl in hw. unfold write_none in hw. destruct is_sbool eqn:eb. @@ -656,18 +656,37 @@ Proof. epose proof r_bind_unary as thm. specialize thm with (fv := λ _, tt). simpl in thm. - specialize thm with (m := coerce_typed_code (encode (vtype H1)) - (truncate_code ty (translate_pexpr fn e))). + specialize thm with + (m := coerce_typed_code (encode (vtype y)) + (truncate_code sty (translate_pexpr fn e))). + pose (( λ '(_, h₀) '(_, _), rel_estate s₁ h₀ fn ) : postcond + (encode (vtype y)) + (encode (vtype y))) as mid. + specialize thm with (mid := mid). eapply thm. all: clear thm. * eapply rsymmetry. 1: eapply rpost_weaken_rule. 1: eapply translate_pexpr_correct. 1,2: eassumption. - intros [] []. intuition auto. subst. - admit. + intros [] []; intuition subst. reflexivity. * intros a. - (* eapply r_put_lhs. *) - admit. + epose proof r_put_lhs as thm. + specialize thm with (ℓ := translate_var fn y). + specialize thm with (v0 := a). + specialize thm with (r₁ := ret tt). + specialize thm with (r₀ := ret tt). + specialize thm with (pre := λ '(s₀, s₁0), mid (a, s₀) (a, s₁0) ). + eapply thm. + apply r_ret. + intros. + simpl in H. + destruct H as [h [[hmem hvmap] Hs₀]]. + subst. + split. + -- simpl. + admit. + -- simpl. + admit. + admit. + admit. + admit. From 6f34dac27744f9807438d3cd07b373eaad542e96 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Mon, 28 Mar 2022 23:43:56 +0200 Subject: [PATCH 032/383] subcase of instr_r_correct and (admitted) lemma on loc/glob memory --- theories/Jasmin/jasmin_translate.v | 26 ++++++++++++++++++++++++-- 1 file changed, 24 insertions(+), 2 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index b1bce2a4..d4eb9327 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -416,7 +416,7 @@ Defined. (* foldr chProd ls *) Definition translate_ptr (ptr : pointer) : Location := - ('word Uptr ; Z.to_nat (wunsigned ptr)). + ('word U8 ; (5 ^ Z.to_nat (wunsigned ptr))%nat). Definition rel_mem (m : mem) (h : heap) := ∀ ptr sz v, @@ -631,6 +631,13 @@ Proof. simpl. intuition subst. assumption. Qed. +Lemma ptr_var_neq (ptr : pointer) (fn : funname) (v : var) : translate_ptr ptr != translate_var fn v. +Proof. + unfold translate_ptr. + unfold translate_var. + unfold nat_of_fun_ident. + Admitted. + Lemma translate_instr_r_correct : ∀ (fn : funname) (i : instr_r) (s₁ s₂ : estate), sem_i P s₁ i s₂ → @@ -684,8 +691,23 @@ Proof. subst. split. -- simpl. - admit. + unfold rel_mem. + intros. + apply hmem in H. + rewrite get_set_heap_neq. 2: apply ptr_var_neq. + apply H. -- simpl. + (* unfold rel_vmap in *. *) + (* intros. simpl. *) + (* Search set_var. *) + (* unfold set_var in eset. *) + (* destruct (is_sbool (vtype y)). *) + (* --- simpl in eset. *) + (* unfold on_vu in eset. *) + (* noconf eset. *) + (* apply hvmap in H. *) + + (* apply hvmap. *) admit. + admit. + admit. From 51b600118c938aa740c1b20a5a1d195bbb1b4796 Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Tue, 29 Mar 2022 08:45:35 +0200 Subject: [PATCH 033/383] more on correctness of variable assignment --- theories/Jasmin/jasmin_translate.v | 104 ++++++++++++++++++++++++----- 1 file changed, 87 insertions(+), 17 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index b1bce2a4..b314e6b2 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -639,8 +639,8 @@ Lemma translate_instr_r_correct : ⦃ λ '(_, h₀) '(_, _), rel_estate s₂ h₀ fn ⦄. Proof. intros fn i s₁ s₂ h. - induction h as [s₁ s₂ y tag sty e v v' sem_e trunc hw | | | | | | |]. - - simpl. destruct y as [ | y | | | ]. + induction h as [es₁ es₂ y tag sty e v v' sem_e trunc hw | | | | | | |]. + - simpl. destruct y as [ | yl | | | ] eqn:case_lval. + simpl. apply r_ret. intros h₀ _ hr. simpl in hw. unfold write_none in hw. destruct is_sbool eqn:eb. @@ -651,42 +651,112 @@ Proof. + simpl. simpl in hw. unfold write_var in hw. destruct set_var eqn:eset. 2: discriminate. simpl in hw. noconf hw. - evar (cty : choice_type). - (* change (ret tt) with ((λ _, ret tt) (chCanonical cty)) at 2. *) epose proof r_bind_unary as thm. specialize thm with (fv := λ _, tt). simpl in thm. specialize thm with - (m := coerce_typed_code (encode (vtype y)) + (m := coerce_typed_code (encode (vtype yl)) (truncate_code sty (translate_pexpr fn e))). - pose (( λ '(_, h₀) '(_, _), rel_estate s₁ h₀ fn ) : postcond - (encode (vtype y)) - (encode (vtype y))) as mid. + pose (( λ '(a, h₀) '(b, _), rel_estate es₁ h₀ fn ) : postcond + (encode (vtype yl)) + (encode (vtype yl))) as mid. specialize thm with (mid := mid). eapply thm. all: clear thm. * eapply rsymmetry. 1: eapply rpost_weaken_rule. 1: eapply translate_pexpr_correct. 1,2: eassumption. - intros [] []; intuition subst. reflexivity. - * intros a. + intros [] []; intuition subst. + -- unfold mid. intuition reflexivity. + * simpl. intros a. + clear sem_e trunc tag sty e v. epose proof r_put_lhs as thm. - specialize thm with (ℓ := translate_var fn y). - specialize thm with (v0 := a). + specialize thm with (ℓ := translate_var fn yl). specialize thm with (r₁ := ret tt). specialize thm with (r₀ := ret tt). - specialize thm with (pre := λ '(s₀, s₁0), mid (a, s₀) (a, s₁0) ). + specialize thm with (v := a). + (* specialize thm with *) + (* (pre := λ '(s₀, h₁), mid (a, s₀) *) + (* (coerce_to_choice_type (encode (vtype y)) *) + (* (translate_value v'), h₁)). *) + specialize thm with (pre := λ '(s₀, h₁), mid (a, s₀) (a, h₁)). + + (* v' instead of a ? *) + simpl in thm. eapply thm. + clear thm. simpl. clear mid. apply r_ret. intros. + unfold set_lhs in H. simpl in H. - destruct H as [h [[hmem hvmap] Hs₀]]. + destruct H as [h [rs Hs₀]]. + (* we're in the *local* var case (cf eset), can only prove + that the vmaps are related *) subst. - split. + split ; destruct rs as [rm rv]. -- simpl. - admit. + (* Morally speaking, this holds because + + - any pointers in `emem es₁` besides `tr(fn,yl)` is related via + `rm`, and + + - `set_heap h (fn,yl) a` will only affect bindings in the `evm` + part of the heap *) + unfold rel_mem. + intros. + destruct ((translate_ptr ptr) == (translate_var fn yl)) eqn:E. + ++ move: E => /eqP E. rewrite E. + unfold rel_mem in rm. + specialize rm with (ptr := ptr) (sz := sz) (v := v) (1 := H). + rewrite E in rm. + simpl. simpl in rm. + get_heap_simpl. + admit. + ++ rewrite get_set_heap_neq. + 2: { + apply /eqP. move: E => /eqP E. assumption. + } + apply rm. assumption. -- simpl. - admit. + unfold rel_vmap. + intros. + destruct ((translate_var fn i) == (translate_var fn yl)) eqn:E. + ++ move: E => /eqP E. + rewrite E. + get_heap_simpl; simpl. + admit. + ++ rewrite get_set_heap_neq. + 2: { + apply /eqP. move: E => /eqP E. assumption. + } + apply rv. rewrite -H. + eapply set_varP. 3: exact eset. + ** intros. subst. + symmetry. + eapply (@Fv.setP_neq _ (evm es₁) _ i). + unshelve apply /eqP. move: E => /eqP E. + assert (injective (translate_var fn)) by admit. + unfold injective in H0. + intro. + epose (H1 yl i). + clearbody e. + subst. apply E. reflexivity. + ** intros. + unfold set_var in eset. + subst. + destruct yl. + destruct v_var. destruct vtype0. + { + - simpl in *. + noconf eset. + symmetry. + eapply (@Fv.setP_neq _ (evm es₁) _ i). + unshelve apply /eqP. move: E => /eqP E. + assert (injective (translate_var fn)) by admit. + unfold injective in H2. + intro. subst. eauto. + } + all: discriminate. + admit. + admit. + admit. From cc57f006d21e515a0e3d445c208725f7748b9ee3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Tue, 29 Mar 2022 12:09:53 +0200 Subject: [PATCH 034/383] Better r_bind_unary rule --- theories/Jasmin/jasmin_translate.v | 83 ++++++++++++++++++------------ 1 file changed, 50 insertions(+), 33 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 031e2346..e2452667 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -477,7 +477,7 @@ Lemma translate_pexpr_correct : ret (coerce_to_choice_type ty' (translate_value v')) ≈ coerce_typed_code ty' (truncate_code ty (translate_pexpr fn e)) - ⦃ λ '(a₀, h₀) '(a₁, h₁), a₀ = a₁ ∧ rel_estate s₁ h₁ fn ⦄. + ⦃ λ '(a₀, h₀) '(a₁, h₁), a₀ = a₁ ∧ a₀ = coerce_to_choice_type ty' (translate_value v') ∧ rel_estate s₁ h₁ fn ⦄. Proof. intros fn e s₁ v ty v' ty' h1 h2. rewrite coerce_cast_code. @@ -508,7 +508,7 @@ Proof. apply of_vint in ev as es. revert s ev. rewrite es. intros s ev. simpl. simp coerce_to_choice_type. simpl. - rewrite cast_ct_val_K. + rewrite !cast_ct_val_K. simpl in ev. noconf ev. apply r_ret. intuition subst. - simpl. simpl in h1. noconf h1. @@ -516,7 +516,7 @@ Proof. destruct es as [es _]. revert s ev. rewrite es. intros s ev. simpl. simp coerce_to_choice_type. simpl. - rewrite cast_ct_val_K. + rewrite !cast_ct_val_K. simpl in ev. noconf ev. apply r_ret. intuition subst. - simpl. simpl in h1. noconf h1. @@ -525,7 +525,7 @@ Proof. destruct es as [m [es hm]]. revert s ev. rewrite es. intros s ev. simpl. simp coerce_to_choice_type. simpl. - rewrite cast_ct_val_K. + rewrite !cast_ct_val_K. simpl in ev. apply WArray.cast_empty_ok in ev. subst. simpl. rewrite Mz.foldP. simpl. apply r_ret. intuition subst. @@ -545,9 +545,9 @@ Proof. apply r_ret. intros ? he [[hmem hvmap] h]. apply hvmap in e1. simpl in h. rewrite h in e1. clear h. subst. - split. - 2:{ split. all: assumption. } - simpl. rewrite coerce_to_choice_type_K. + split. 2: split. + 3:{ split. all: assumption. } +(* simpl. rewrite coerce_to_choice_type_K. set (ty := type_of_val v') in *. clearbody ty. clear - ev. set (ty' := vtype gx) in *. clearbody ty'. clear - ev. pose proof (type_of_to_val s) as ety. @@ -608,15 +608,14 @@ Proof. * simpl. simpl in ev. unfold to_word in ev. destruct v eqn:e. all: try discriminate. 2:{ destruct t. all: discriminate. } - subst. simpl. rewrite ev. reflexivity. - - + subst. simpl. rewrite ev. reflexivity. *) Admitted. Lemma r_bind_unary : ∀ {A B : choiceType} m f v fv (pre : precond) (mid : postcond A A) (post : postcond B B), - ⊢ ⦃ pre ⦄ m ≈ ret v ⦃ λ '(a₀, h₀) '(a₁, h₁), mid (a₀, h₀) (a₁, h₁) ∧ a₀ = a₁ ⦄ → - (∀ a, ⊢ ⦃ λ '(s₀, s₁), mid (a, s₀) (a, s₁) ⦄ f a ≈ ret (fv a) ⦃ post ⦄) → + ⊢ ⦃ pre ⦄ m ≈ ret v ⦃ λ '(a₀, h₀) '(a₁, h₁), mid (a₀, h₀) (a₁, h₁) ∧ a₀ = a₁ ∧ a₁ = v ⦄ → + ⊢ ⦃ λ '(s₀, s₁), mid (v, s₀) (v, s₁) ⦄ f v ≈ ret (fv v) ⦃ post ⦄ → ⊢ ⦃ pre ⦄ bind m f ≈ ret (fv v) ⦃ post ⦄. Proof. intros A B m f v fv pre mid post hm hf. @@ -625,18 +624,22 @@ Proof. - exact hm. - intros a₀ a₁. eapply rpre_hypothesis_rule. - intros ? ? [? ?]. subst. + intuition subst. eapply rpre_weaken_rule. 1: apply hf. simpl. intuition subst. assumption. Qed. -Lemma ptr_var_neq (ptr : pointer) (fn : funname) (v : var) : translate_ptr ptr != translate_var fn v. +Lemma ptr_var_neq (ptr : pointer) (fn : funname) (v : var) : + translate_ptr ptr != translate_var fn v. Proof. unfold translate_ptr. unfold translate_var. unfold nat_of_fun_ident. - Admitted. + apply /eqP. intro e. + noconf e. + apply (f_equal (λ n, n %% 3)) in H0. +Admitted. Lemma translate_instr_r_correct : ∀ (fn : funname) (i : instr_r) (s₁ s₂ : estate), @@ -664,43 +667,41 @@ Proof. specialize thm with (m := coerce_typed_code (encode (vtype yl)) (truncate_code sty (translate_pexpr fn e))). - pose (( λ '(a, h₀) '(b, _), rel_estate es₁ h₀ fn ) : postcond + pose (( λ '(a, h₀) '(b, _), + a = coerce_to_choice_type _ (translate_value v') ∧ + rel_estate es₁ h₀ fn ) : postcond (encode (vtype yl)) (encode (vtype yl))) as mid. specialize thm with (mid := mid). - eapply thm. all: clear thm. + eapply thm. all: clear thm. all: simpl. * eapply rsymmetry. - 1: eapply rpost_weaken_rule. + eapply rpost_weaken_rule. 1: eapply translate_pexpr_correct. 1,2: eassumption. - intros [] []; intuition subst. - -- unfold mid. intuition reflexivity. - * simpl. intros a. - clear sem_e trunc tag sty e v. + simpl. intros [] []. intuition subst. all: reflexivity. + * clear sem_e tag e. epose proof r_put_lhs as thm. - specialize thm with (ℓ := translate_var fn yl). + (* specialize thm with (ℓ := translate_var fn yl). specialize thm with (r₁ := ret tt). specialize thm with (r₀ := ret tt). - specialize thm with (v := a). + specialize thm with (v := a). *) (* specialize thm with *) (* (pre := λ '(s₀, h₁), mid (a, s₀) *) (* (coerce_to_choice_type (encode (vtype y)) *) (* (translate_value v'), h₁)). *) - specialize thm with (pre := λ '(s₀, h₁), mid (a, s₀) (a, h₁)). + specialize thm with (pre := λ '(s₀, h₁), mid (coerce_to_choice_type _ (translate_value v'), s₀) (coerce_to_choice_type _ (translate_value v'), h₁)). (* v' instead of a ? *) simpl in thm. eapply thm. - clear thm. simpl. clear mid. + clear thm. clear mid. apply r_ret. - intros. - unfold set_lhs in H. - simpl in H. - destruct H as [h [rs Hs₀]]. + intros ? ? hs. + unfold set_lhs in hs. + destruct hs as [h [[_ [rm rv]] Hs₀]]. (* we're in the *local* var case (cf eset), can only prove that the vmaps are related *) - subst. - split ; destruct rs as [rm rv]. + subst. split. -- simpl. unfold rel_mem. intros. @@ -712,9 +713,25 @@ Proof. intros. destruct ((translate_var fn i) == (translate_var fn yl)) eqn:E. ++ move: E => /eqP E. - rewrite E. + assert (hinj : injective (translate_var fn)) by admit. + apply hinj in E. subst. get_heap_simpl; simpl. - admit. + move: eset => /set_varP eset. + apply eset. all: clear eset. + ** intros v'' ev' er. subst. + rewrite Fv.setP_eq in H. noconf H. + unfold truncate_val in trunc. + destruct of_val eqn:ev. 2: discriminate. + simpl in trunc. noconf trunc. + (* assert (to_val v0 = v') by admit. *) (* truncate twice (are the types equal though?) *) + (* subst. rewrite translate_value_to_val. + rewrite coerce_to_choice_type_K. *) + give_up. + ** intros. subst. + rewrite Fv.setP_eq in H. + unfold undef_addr in H. + destruct (vtype yl) eqn:e. all: try noconf H. + discriminate H0. ++ rewrite get_set_heap_neq. 2: { apply /eqP. move: E => /eqP E. assumption. From cd64427afc25f5b69860f6f7d19718703dd4e962 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Tue, 29 Mar 2022 14:23:57 +0200 Subject: [PATCH 035/383] State truncate_code_idemp --- theories/Jasmin/jasmin_translate.v | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index e2452667..e3c32885 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -641,6 +641,14 @@ Proof. apply (f_equal (λ n, n %% 3)) in H0. Admitted. +Notation coe_cht := coerce_to_choice_type. +Notation coe_tyc := coerce_typed_code. + +Lemma truncate_code_idemp : + ∀ (sty sty' : stype) (c : typed_code), + truncate_code sty' (truncate_code sty c) = truncate_code sty' c. +Admitted. + Lemma translate_instr_r_correct : ∀ (fn : funname) (i : instr_r) (s₁ s₂ : estate), sem_i P s₁ i s₂ → From 364a9dc0ecfe3a4700e1ac2ab7cb80b49bfbc52c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Tue, 29 Mar 2022 14:43:42 +0200 Subject: [PATCH 036/383] Add missing truncation in ssprove_write_lval, break proof --- theories/Jasmin/jasmin_translate.v | 42 +++++++++++++++++++++++------- 1 file changed, 33 insertions(+), 9 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index e3c32885..b8a8f66c 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -192,7 +192,8 @@ Definition ssprove_write_lval (fn : funname) (l : lval) (tc : typed_code) | Lvar x => (* write_var x v s *) let l := translate_var fn (v_var x) in - let c := coerce_typed_code l tc in + let c' := truncate_code x.(vtype) tc in + let c := coerce_typed_code l c' in (x ← c ;; #put l := x ;; ret tt)%pack | _ => unsupported.π2 (* | Lmem sz x e => *) @@ -672,21 +673,43 @@ Proof. epose proof r_bind_unary as thm. specialize thm with (fv := λ _, tt). simpl in thm. - specialize thm with - (m := coerce_typed_code (encode (vtype yl)) - (truncate_code sty (translate_pexpr fn e))). pose (( λ '(a, h₀) '(b, _), - a = coerce_to_choice_type _ (translate_value v') ∧ rel_estate es₁ h₀ fn ) : postcond (encode (vtype yl)) (encode (vtype yl))) as mid. specialize thm with (mid := mid). + rewrite truncate_code_idemp. + (* Other attempt *) +(* unfold truncate_val in trunc. destruct of_val eqn:ev. 2: discriminate. + simpl in trunc. noconf trunc. + eapply set_varP. 3: exact eset. + 2:{ + intros hbo hof hset. subst. + eapply rpre_hypothesis_rule. + intros ? ? [hmem hvmap]. + red in hvmap. + rewrite Fv.setP_eq in hof. + unfold undef_addr in H. + destruct (vtype yl) eqn:e. all: try noconf H. + discriminate H0. + } *) + (* * *) eapply thm. all: clear thm. all: simpl. * eapply rsymmetry. eapply rpost_weaken_rule. 1: eapply translate_pexpr_correct. - 1,2: eassumption. - simpl. intros [] []. intuition subst. all: reflexivity. +(* -- eassumption. + -- { + unfold truncate_val in *. + destruct of_val eqn:ev. 2: discriminate. + simpl in trunc. noconf trunc. + eapply set_varP. 3: exact eset. + - intros. rewrite + - + } *) + (* 1,2: eassumption. + simpl. intros [] []. intuition eauto. *) + all: admit. * clear sem_e tag e. epose proof r_put_lhs as thm. (* specialize thm with (ℓ := translate_var fn yl). @@ -706,7 +729,7 @@ Proof. apply r_ret. intros ? ? hs. unfold set_lhs in hs. - destruct hs as [h [[_ [rm rv]] Hs₀]]. + (* destruct hs as [h [[_ [rm rv]] Hs₀]]. (* we're in the *local* var case (cf eset), can only prove that the vmaps are related *) subst. split. @@ -771,7 +794,7 @@ Proof. unfold injective in H2. intro. subst. eauto. } - all: discriminate. + all: discriminate. *) (* unfold rel_vmap in *. *) (* intros. simpl. *) (* Search set_var. *) @@ -783,6 +806,7 @@ Proof. (* apply hvmap in H. *) (* apply hvmap. *) + admit. + admit. + admit. + admit. From f26ee6d35c56b95ab97e39159fce9d86b9c713bd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Tue, 29 Mar 2022 17:47:46 +0200 Subject: [PATCH 037/383] Define translate_cmd --- theories/Jasmin/jasmin_translate.v | 25 ++++++++++++++----------- 1 file changed, 14 insertions(+), 11 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index b8a8f66c..77f4ef98 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -327,11 +327,17 @@ Proof. exact (unsupported.π2). Defined. -Definition translate_cmd (c : cmd) : raw_code 'unit. -Proof. - (* fold bind translate_instr *) - exact (unsupported.π2). -Defined. +Definition instr_d (i : instr) : instr_r := + match i with MkI _ i => i end. + +Definition translate_instr (fn : funname) (i : instr) : raw_code 'unit := + translate_instr_r fn (instr_d i). + +Fixpoint translate_cmd (fn : funname) (c : cmd) : raw_code 'unit := + match c with + | [::] => ret tt + | i :: c => translate_instr fn i ;; translate_cmd fn c + end. Record fdef := { ffun : typed_raw_function ; @@ -348,7 +354,7 @@ Proof. - exists chUnit. exists chUnit. intros u. (* TODO: store function arguments in their locations *) - exact (translate_cmd f_body). + exact (translate_cmd f f_body). (* TODO: read return values from their locations *) - exact fset0. - exact [interface]. @@ -435,9 +441,6 @@ Definition rel_vmap (vm : vmap) (h : heap) (fn : funname) := Definition rel_estate (s : estate) (h : heap) (fn : funname) := rel_mem s.(emem) h ∧ rel_vmap s.(evm) h fn. -Definition instr_d (i : instr) : instr_r := - match i with MkI _ i => i end. - Lemma coerce_cast_code (ty vty : choice_type) (v : vty) : ret (coerce_to_choice_type ty v) = coerce_typed_code ty (vty ; ret v). Proof. @@ -856,13 +859,13 @@ Proof. set (Pi := λ s1 i s2, (Pi_r s1 (instr_d i) s2)). set (Pc := λ (s1 : estate) (c : cmd) (s2 : estate), - ⊢ ⦃ λ '(h1,h2), False ⦄ translate_cmd c ≈ ret tt ⦃ λ '(v1, _) '(v2, _), True ⦄ + ⊢ ⦃ λ '(h1,h2), False ⦄ translate_cmd fn c ≈ ret tt ⦃ λ '(v1, _) '(v2, _), True ⦄ ). (* FIXME *) set (Pfor := λ (v : var_i) (ls : seq Z) (s1 : estate) (c : cmd) (s2 : estate), ⊢ ⦃ λ '(h1,h2), False ⦄ - (* ssprove_for *) translate_cmd c ≈ + (* ssprove_for *) translate_cmd fn c ≈ ret tt ⦃ λ '(v1, _) '(v2, _), True ⦄ ). From 3edf447f0bac3c72e29b6703a37f62f14328f944 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Tue, 29 Mar 2022 17:55:04 +0200 Subject: [PATCH 038/383] Fix silent admit --- theories/Jasmin/jasmin_translate.v | 1 + 1 file changed, 1 insertion(+) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 77f4ef98..4142c5ef 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -500,6 +500,7 @@ Proof. rewrite coerce_typed_code_neq. 2:{ move: e1 => /eqP e1. congruence. } apply r_ret. intuition subst. + admit. (* coerce_to_choice_type_neq *) } pose proof e1 as e2. move: e2 => /eqP e2. subst. rewrite 2!coerce_typed_code_K. From 4220c3842adec1ac2bc92667e3d0d24e3790805a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Tue, 29 Mar 2022 18:24:04 +0200 Subject: [PATCH 039/383] Define reverse of embed and semantics of Papp1 --- theories/Jasmin/jasmin_translate.v | 23 ++++++++++++++++++++++- 1 file changed, 22 insertions(+), 1 deletion(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 4142c5ef..a6220a55 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -53,6 +53,22 @@ Definition embed {t} : sem_t t → encode t := | sword n => λ x, x end. +Definition unembed {t : stype} : encode t → sem_t t := + match t return encode t → sem_t t with + | sbool => λ x, x + | sint => λ x, x + | sarr n => λ x, + match + foldr + (λ kv m, Let m' := m in WArray.set m' AAscale kv.1 kv.2) + (Ok _ (WArray.empty _)) x + with + | Ok ar => ar + | _ => WArray.empty _ + end + | sword n => λ x, x + end. + Fixpoint nat_of_ident (id : Ident.ident) : nat := match id with | EmptyString => 1 @@ -298,7 +314,12 @@ Proof. - exact unsupported. - exact unsupported. - - exact unsupported. + - pose proof (sem_sop1_typed s) as f. simpl in f. + pose (e' := translate_pexpr fn e). + pose (e2 := truncate_code (type_of_op1 s).1 e'). + epose (r := cast_typed_code (encode (type_of_op1 s).1) e' _). + epose (c := x ← r ;; ret (embed (f (unembed x)))). + exact (_ ; c). - exact unsupported. - exact unsupported. - exact unsupported. From adf66e04038ab767918fe84f944de7f22e082fa1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Tue, 29 Mar 2022 18:33:01 +0200 Subject: [PATCH 040/383] Translate Papp2 --- theories/Jasmin/jasmin_translate.v | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index a6220a55..d23d3550 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -320,7 +320,22 @@ Proof. epose (r := cast_typed_code (encode (type_of_op1 s).1) e' _). epose (c := x ← r ;; ret (embed (f (unembed x)))). exact (_ ; c). - - exact unsupported. + - pose proof (sem_sop2_typed s) as f. simpl in f. + pose (e1' := translate_pexpr fn e1). + pose (e2' := translate_pexpr fn e2). + pose (e1'' := truncate_code (type_of_op2 s).1.1 e1'). + pose (e2'' := truncate_code (type_of_op2 s).1.2 e2'). + epose (r1 := cast_typed_code (encode (type_of_op2 s).1.1) e1'' _). + epose (r2 := cast_typed_code (encode (type_of_op2 s).1.2) e2'' _). + epose (c := + x1 ← r1 ;; + x2 ← r2 ;; + ret match f (unembed x1) (unembed x2) with + | Ok y => embed y + | _ => chCanonical _ + end + ). + exact (_ ; c). - exact unsupported. - exact unsupported. Defined. From 1b28c1723432c757b196625032f59588ad5509f5 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Wed, 30 Mar 2022 10:52:13 +0200 Subject: [PATCH 041/383] coerce instead of cast in translate pexpr --- theories/Jasmin/jasmin_translate.v | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index d23d3550..ac77d19a 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -317,17 +317,17 @@ Proof. - pose proof (sem_sop1_typed s) as f. simpl in f. pose (e' := translate_pexpr fn e). pose (e2 := truncate_code (type_of_op1 s).1 e'). - epose (r := cast_typed_code (encode (type_of_op1 s).1) e' _). - epose (c := x ← r ;; ret (embed (f (unembed x)))). + pose (r := coerce_typed_code (encode (type_of_op1 s).1) e2). + pose (c := x ← r ;; ret (embed (f (unembed x)))). exact (_ ; c). - pose proof (sem_sop2_typed s) as f. simpl in f. pose (e1' := translate_pexpr fn e1). pose (e2' := translate_pexpr fn e2). pose (e1'' := truncate_code (type_of_op2 s).1.1 e1'). pose (e2'' := truncate_code (type_of_op2 s).1.2 e2'). - epose (r1 := cast_typed_code (encode (type_of_op2 s).1.1) e1'' _). - epose (r2 := cast_typed_code (encode (type_of_op2 s).1.2) e2'' _). - epose (c := + pose (r1 := coerce_typed_code (encode (type_of_op2 s).1.1) e1''). + pose (r2 := coerce_typed_code (encode (type_of_op2 s).1.2) e2''). + pose (c := x1 ← r1 ;; x2 ← r2 ;; ret match f (unembed x1) (unembed x2) with From 8e77a150744896201ff008d18a8b4e791c999deb Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Wed, 30 Mar 2022 11:06:56 +0200 Subject: [PATCH 042/383] coerce_to_choice_type_neq --- theories/Jasmin/jasmin_translate.v | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index ac77d19a..d4a37a97 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -494,6 +494,19 @@ Proof. reflexivity. Qed. +Lemma coerce_to_choice_type_neq : + ∀ (ty ty' : choice_type) (v : ty), + ty ≠ ty' → + coerce_to_choice_type ty' v = chCanonical _. +Proof. + intros ty ty' v ne. + funelim (coerce_to_choice_type ty' v). + 1:{ + clear - e ne. symmetry in e. move: e => /eqP e. simpl in e. contradiction. + } + symmetry. assumption. +Qed. + Lemma coerce_to_choice_type_K : ∀ (t : choice_type) (v : t), coerce_to_choice_type t v = v. From eb244a669678cd5682f238567631f98940ad6f43 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Wed, 30 Mar 2022 11:10:51 +0200 Subject: [PATCH 043/383] cleaned up pexpr_correct --- theories/Jasmin/jasmin_translate.v | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index d4a37a97..d87e74dc 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -549,7 +549,7 @@ Proof. rewrite coerce_typed_code_neq. 2:{ move: e1 => /eqP e1. congruence. } apply r_ret. intuition subst. - admit. (* coerce_to_choice_type_neq *) + symmetry; apply coerce_to_choice_type_neq. move: e1 => /eqP; auto. } pose proof e1 as e2. move: e2 => /eqP e2. subst. rewrite 2!coerce_typed_code_K. @@ -601,7 +601,8 @@ Proof. rewrite h in e1. clear h. subst. split. 2: split. 3:{ split. all: assumption. } -(* simpl. rewrite coerce_to_choice_type_K. + 2: { by rewrite coerce_to_choice_type_K. } + simpl. rewrite coerce_to_choice_type_K. set (ty := type_of_val v') in *. clearbody ty. clear - ev. set (ty' := vtype gx) in *. clearbody ty'. clear - ev. pose proof (type_of_to_val s) as ety. @@ -634,7 +635,9 @@ Proof. 2:{ destruct t. all: discriminate. } subst. simpl. noconf esx. inversion H. rewrite ev. reflexivity. + simpl. rewrite h1. simpl. - apply r_ret. intuition subst. f_equal. + apply r_ret. intuition subst. + 2: { by rewrite coerce_to_choice_type_K. } + f_equal. rewrite -es. rewrite coerce_to_choice_type_K. pose proof (type_of_to_val s) as ety. set (ty := type_of_val v') in *. clearbody ty. @@ -662,7 +665,7 @@ Proof. * simpl. simpl in ev. unfold to_word in ev. destruct v eqn:e. all: try discriminate. 2:{ destruct t. all: discriminate. } - subst. simpl. rewrite ev. reflexivity. *) + subst. simpl. rewrite ev. reflexivity. Admitted. Lemma r_bind_unary : From efda1b663c8520d4f17c527c316207de90561504 Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Wed, 30 Mar 2022 15:24:26 +0200 Subject: [PATCH 044/383] simplify op{1,2} translation we don't need to coerce to the operation type right after we truncate to that very type --- theories/Jasmin/jasmin_translate.v | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index d87e74dc..36cde92a 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -316,17 +316,14 @@ Proof. - exact unsupported. - pose proof (sem_sop1_typed s) as f. simpl in f. pose (e' := translate_pexpr fn e). - pose (e2 := truncate_code (type_of_op1 s).1 e'). - pose (r := coerce_typed_code (encode (type_of_op1 s).1) e2). + pose (r := (truncate_code (type_of_op1 s).1 e').π2). pose (c := x ← r ;; ret (embed (f (unembed x)))). exact (_ ; c). - pose proof (sem_sop2_typed s) as f. simpl in f. pose (e1' := translate_pexpr fn e1). pose (e2' := translate_pexpr fn e2). - pose (e1'' := truncate_code (type_of_op2 s).1.1 e1'). - pose (e2'' := truncate_code (type_of_op2 s).1.2 e2'). - pose (r1 := coerce_typed_code (encode (type_of_op2 s).1.1) e1''). - pose (r2 := coerce_typed_code (encode (type_of_op2 s).1.2) e2''). + pose (r1 := (truncate_code (type_of_op2 s).1.1 e1').π2). + pose (r2 := (truncate_code (type_of_op2 s).1.2 e2').π2). pose (c := x1 ← r1 ;; x2 ← r2 ;; From 814791a0bbc396f59aec641ab2e9e625aaecdb8b Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Wed, 30 Mar 2022 18:13:25 +0200 Subject: [PATCH 045/383] define translation of array_get --- theories/Jasmin/jasmin_translate.v | 160 ++++++++++++++++++++++------- 1 file changed, 123 insertions(+), 37 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 36cde92a..4147916c 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -275,6 +275,18 @@ Definition translate_gvar (f : funname) (x : gvar) : typed_code := end ). +Definition chArray_get ws (a : 'array) ptr scale := + (* Jasmin fails if ptr is not aligned; we may not need it. *) + (* if negb (is_align ptr sz) then chCanonical ws else *) + let f k := + match assoc a (scale * ptr + k)%Z with + | None => chCanonical ('word U8) + | Some x => x + end in + let l := map f (ziota 0 (wsize_size ws)) in + Jasmin.memory_model.LE.decode ws l. + + Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code. Proof. destruct e as [z|b| |x|aa ws x e| | | | | | ]. @@ -285,32 +297,29 @@ Proof. exists 'array. exact (ret emptym). - exact (translate_gvar fn x). - - (* exists 'array. *) - (* | Pget aa ws x e => *) + - (* | Pget aa ws x e => *) + exists 'word ws. + (* Look up x amongst the evm part of the estate and the globals gd. Monadic + Let because we might find None. If (Some val) is found, fail with type + error unless (val = Varr n t). We obtain (n: positive) and (t: array n). *) (* Let (n, t) := gd, s.[x] in *) - exact unsupported. - -(* Look up x amongst the evm part of the estate and the globals gd. Monadic Let - because we might find None. If (Some val) is found, fail with type error - unless (val = Varr n t). We obtain (n: positive) and (t: array n). *) + pose (x' := translate_gvar fn x). + pose (arr := y ← x'.π2 ;; @ret _ (coerce_to_choice_type 'array y)). + (* Evaluate the indexing expression `e` and coerce it to Z. *) (* Let i := sem_pexpr s e >>= to_int in *) + pose (i := coerce_typed_code 'int (translate_pexpr fn e)). - (* Evaluate the indexing expression `e` and coerce it to Z. *) + (* The actual array look-up, where + WArray.get aa ws t i = CoreMem.read t a (i * (mk_scale aa ws)) ws + and + mk_scale = (if aa == AAscale then (ws/8) else 1) *) (* Let w := WArray.get aa ws t i in *) + pose (scale := mk_scale aa ws). - (* array look-up, where - WArray.get aa ws t i = - CoreMem.read t a (i * (if aa == AAscale then (ws/8) else 1)) ws - *) - - (* ok (Vword w) *) - - (* pose (translate_gvar fn x) as lx. *) - (* pose (v ← get lx ;; @ret _ (coerce_to_array v))%pack. *) - (* pose (r ;; ret tt). *) + exact (a ← arr ;; ptr ← i ;; ret (chArray_get ws a ptr scale)). - exact unsupported. - exact unsupported. @@ -519,6 +528,25 @@ Derive NoConfusion for result. Derive NoConfusion for value. Derive NoConfusion for wsize. +Lemma r_bind_unary : + ∀ {A B : choiceType} m f v fv + (pre : precond) (mid : postcond A A) (post : postcond B B), + ⊢ ⦃ pre ⦄ m ≈ ret v ⦃ λ '(a₀, h₀) '(a₁, h₁), mid (a₀, h₀) (a₁, h₁) ∧ a₀ = a₁ ∧ a₁ = v ⦄ → + ⊢ ⦃ λ '(s₀, s₁), mid (v, s₀) (v, s₁) ⦄ f v ≈ ret (fv v) ⦃ post ⦄ → + ⊢ ⦃ pre ⦄ bind m f ≈ ret (fv v) ⦃ post ⦄. +Proof. + intros A B m f v fv pre mid post hm hf. + change (ret (fv v)) with (x ← ret v ;; ret (fv x)). + eapply r_bind. + - exact hm. + - intros a₀ a₁. + eapply rpre_hypothesis_rule. + intuition subst. + eapply rpre_weaken_rule. + 1: apply hf. + simpl. intuition subst. assumption. +Qed. + Lemma translate_pexpr_correct : ∀ fn (e : pexpr) s₁ v ty v' ty', sem_pexpr gd s₁ e = ok v → @@ -663,27 +691,85 @@ Proof. unfold to_word in ev. destruct v eqn:e. all: try discriminate. 2:{ destruct t. all: discriminate. } subst. simpl. rewrite ev. reflexivity. + - (* array access *) + + (* massage the hypotheses into something more usable *) + simpl in h1. + pose proof on_arr_gvarP as p. + unshelve eapply (p _ _ _ _ _ _ _ _ h1) ; clear p h1. + intros. simpl in H1. simpl. + unshelve eapply (@rbindP _ _ _ _ _ _ _ _ H1). + intros. clear H1. + simpl in H2, H3. + unshelve eapply (@rbindP _ _ _ _ _ _ _ _ H2). + intros; clear H2. + unshelve eapply (@rbindP _ _ _ _ _ _ _ _ H3). + intros; clear H3. + simpl in *. + noconf H5. + unfold get_gvar in H0. + apply type_of_get_gvar in H0 as tarr. + + (* Now the actual proof should begin. Instead, here is some mindless mess + following my nose along the structure of the goal. *) + unfold translate_gvar. unfold translate_var. + destruct is_lvar eqn:hlvar. + + simpl in *. + eapply r_get_remember_rhs with (pre := λ '(_, h₁), rel_estate s₁ h₁ fn). + rewrite H. simpl. intros arr. + rewrite bind_assoc. + eapply rsymmetry. + epose r_bind_unary as rbu. + (* specialize rbu with (post := (λ '(a₁, h₁) '(a₀, _), *) + (* a₀ = a₁ *) + (* ∧ a₀ = *) + (* coerce_to_choice_type (encode (type_of_val (to_val s))) *) + (* (translate_value (to_val s)) ∧ rel_estate s₁ h₁ fn)). *) + (* specialize rbu with (pre := (λ '(h₁, h₀), *) + (* ((λ '(_, h₁0), rel_estate s₁ h₁0 fn) *) + (* ⋊ rem_rhs ('array; nat_of_fun_ident fn (vname (gv x))) arr) *) + (* (h₀, h₁))). *) + specialize rbu with (mid := (λ '(_, h₁) '(_, h₀), + ((λ '(_, h₁0), rel_estate s₁ h₁0 fn) + ⋊ rem_rhs ('array; nat_of_fun_ident fn (vname (gv x))) arr) + (h₀, h₁))). + (* specialize rbu with (m := coerce_typed_code 'int (translate_pexpr fn e)). *) + (* specialize rbu with (v := z). *) + specialize rbu with (fv := λ _i, (translate_value (to_val s))). + eapply rbu; clear rbu. + * simpl. + simp coerce_typed_code. + give_up. + * simpl. eapply r_ret. + intuition subst. + -- simpl. give_up. + -- simpl. give_up. + -- apply H3. + + simpl in *. rewrite H0. + simpl. rewrite bind_assoc. + eapply rsymmetry. + epose r_bind_unary as rbu. + specialize rbu with (post := (λ '(a₁, h₁) '(a₀, _), + a₀ = a₁ + ∧ a₀ = + coerce_to_choice_type (encode (type_of_val (to_val s))) + (translate_value (to_val s)) ∧ rel_estate s₁ h₁ fn)). + specialize rbu with (pre := ( λ '(h₁, _), rel_estate s₁ h₁ fn )). + specialize rbu with (mid := (λ '(_, h₁) '(_, h₀), rel_estate s₁ h₁ fn)). + specialize rbu with (m := coerce_typed_code 'int (translate_pexpr fn e)). + specialize rbu with (v := z). + specialize rbu with (fv := λ _i, (translate_value (to_val s))). + simpl in rbu. + eapply rbu; clear rbu. + * simp coerce_typed_code. + give_up. + * simpl. eapply r_ret. + intuition subst. + -- simpl in *. give_up. + -- simpl in *. try reflexivity. admit. + - Admitted. -Lemma r_bind_unary : - ∀ {A B : choiceType} m f v fv - (pre : precond) (mid : postcond A A) (post : postcond B B), - ⊢ ⦃ pre ⦄ m ≈ ret v ⦃ λ '(a₀, h₀) '(a₁, h₁), mid (a₀, h₀) (a₁, h₁) ∧ a₀ = a₁ ∧ a₁ = v ⦄ → - ⊢ ⦃ λ '(s₀, s₁), mid (v, s₀) (v, s₁) ⦄ f v ≈ ret (fv v) ⦃ post ⦄ → - ⊢ ⦃ pre ⦄ bind m f ≈ ret (fv v) ⦃ post ⦄. -Proof. - intros A B m f v fv pre mid post hm hf. - change (ret (fv v)) with (x ← ret v ;; ret (fv x)). - eapply r_bind. - - exact hm. - - intros a₀ a₁. - eapply rpre_hypothesis_rule. - intuition subst. - eapply rpre_weaken_rule. - 1: apply hf. - simpl. intuition subst. assumption. -Qed. - Lemma ptr_var_neq (ptr : pointer) (fn : funname) (v : var) : translate_ptr ptr != translate_var fn v. Proof. From f0adcd967045f17ec1f5148b5c7030f233d9edb5 Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Wed, 30 Mar 2022 19:56:35 +0200 Subject: [PATCH 046/383] translate_pexpr: if-then-else --- theories/Jasmin/jasmin_translate.v | 52 ++++++++++++++++++++++++++---- 1 file changed, 46 insertions(+), 6 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 4147916c..0cf31f24 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -321,8 +321,22 @@ Proof. exact (a ← arr ;; ptr ← i ;; ret (chArray_get ws a ptr scale)). - - exact unsupported. - - exact unsupported. + - (* | Psub aa ws len x e => *) + exists 'array. + (* Let (n, t) := gd, s.[x] in *) + (* Let i := sem_pexpr s e >>= to_int in *) + (* Let t' := WArray.get_sub aa ws len t i in *) + (* ok (Varr t') *) + + exact (ret (chCanonical _)). + (* TODO: still unsupported *) + - (* | Pload sz x e => *) + (* Let w1 := get_var s.(evm) x >>= to_pointer in *) + (* Let w2 := sem_pexpr s e >>= to_pointer in *) + (* Let w := read s.(emem) (w1 + w2)%R sz in *) + (* ok (@to_val (sword sz) w) *) + exists ('word w). exact (ret (chCanonical _)). + (* TODO: still unsupported *) - pose proof (sem_sop1_typed s) as f. simpl in f. pose (e' := translate_pexpr fn e). pose (r := (truncate_code (type_of_op1 s).1 e').π2). @@ -339,11 +353,37 @@ Proof. ret match f (unembed x1) (unembed x2) with | Ok y => embed y | _ => chCanonical _ - end - ). + end). + exact (_ ; c). + - (* | PappN op es => *) + (* Let vs := mapM (sem_pexpr s) es in *) + (* sem_opN op vs *) + pose (vs := map (translate_pexpr fn) l). + pose proof (sem_opN_typed o) as f. simpl in f. + +(* Fixpoint app_sopn T ts : sem_prod ts (exec T) → values → exec T := *) +(* match ts return sem_prod ts (exec T) → values → exec T with *) +(* | [::] => λ (o : exec T) (vs: values), if vs is [::] then o else type_error *) +(* | t :: ts => λ (o: sem_t t → sem_prod ts (exec T)) (vs: values), *) +(* if vs is v :: vs *) +(* then Let v := of_val t v in app_sopn (o v) vs *) +(* else type_error *) +(* end. *) + + (* pose (vs' := fold (fun x => y ← x ;; unembed y) f vs). *) + exact unsupported. + - (* | Pif t e e1 e2 => *) + (* Let b := sem_pexpr s e >>= to_bool in *) + (* Let v1 := sem_pexpr s e1 >>= truncate_val t in *) + (* Let v2 := sem_pexpr s e2 >>= truncate_val t in *) + (* ok (if b then v1 else v2) *) + pose (eb := coerce_typed_code 'bool (translate_pexpr fn e1)). + pose (e1' := translate_pexpr fn e1). + pose (e2' := translate_pexpr fn e2). + pose (r1 := (truncate_code s e1').π2). + pose (r2 := (truncate_code s e2').π2). + pose (c := b ← eb ;; if b then r1 else r2). exact (_ ; c). - - exact unsupported. - - exact unsupported. Defined. Definition translate_instr_r (fn : funname) (i : instr_r) : raw_code 'unit. From 96f0e108de70ae873aa3dff1aaef23e0c3568248 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 31 Mar 2022 10:54:07 +0200 Subject: [PATCH 047/383] Some cleaning --- theories/Jasmin/jasmin_translate.v | 66 ++++++++++++------------------ 1 file changed, 27 insertions(+), 39 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 0cf31f24..f3566248 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -80,9 +80,10 @@ Definition nat_of_fun_ident (f : funname) (id : Ident.ident) : nat := 3^(nat_of_pos f) * 2^(nat_of_ident id). Definition translate_var (f : funname) (x : var) : Location := - ( encode x.(vtype) ; nat_of_fun_ident f x.(vname)). + (encode x.(vtype) ; nat_of_fun_ident f x.(vname)). -Definition typed_code := ∑ (a : choice_type), raw_code a. +Definition typed_code := + ∑ (a : choice_type), raw_code a. #[local] Definition unsupported : typed_code := ('unit ; assert false). @@ -130,7 +131,7 @@ Definition truncate_el {t : choice_type} (s : stype) : t → encode s := | sint => λ i, coerce_to_choice_type 'int i | sarr n => (* Here we do not perform the check on the length of the array as - performed by to_arr n + performed by to_arr n. *) λ a, coerce_to_choice_type 'array a | sword n => @@ -192,14 +193,6 @@ Proof. apply cast_typed_code_K. Qed. -(* Definition cast_typed_code (ty : choice_type) (tc : typed_code) : raw_code ty. *) -(* Proof. *) -(* destruct tc as [t c]. *) -(* destruct (t == ty) eqn:E. *) -(* - move : E => /eqP E. subst; exact c. *) -(* - apply ret. apply chCanonical. *) -(* Defined. *) - Definition ssprove_write_lval (fn : funname) (l : lval) (tc : typed_code) : raw_code chUnit := @@ -233,26 +226,25 @@ Definition ssprove_write_lval (fn : funname) (l : lval) (tc : typed_code) (* write_var x (@to_val (sarr n) t) s *) end. +(* TW: We can remove it right? *) Fixpoint satisfies_globs (globs : glob_decls) : heap * heap → Prop. Proof. exact (λ '(x, y), False). (* TODO *) Defined. -Fixpoint collect_globs (globs : glob_decls) : seq Location. +(* Fixpoint collect_globs (globs : glob_decls) : seq Location. Proof. exact [::]. (* TODO *) -Defined. +Defined. *) -Definition typed_chElement := pointed_value. +Definition typed_chElement := + pointed_value. Definition choice_type_of_val (val : value) : choice_type := encode (type_of_val val). Definition translate_value (v : value) : choice_type_of_val v. Proof. - (* Feels like we could apply embed first, but I don't know what to do with - the undefined case. - *) destruct v as [b | z | size a | size wd | undef_ty]. - apply embed. exact b. - apply embed. exact z. @@ -267,25 +259,25 @@ Defined. Definition translate_gvar (f : funname) (x : gvar) : typed_code := if is_lvar x then (_ ; x ← get (translate_var f x.(gv).(v_var)) ;; ret x) - else - (encode (vtype x.(gv)) ; + else ( + encode (vtype x.(gv)) ; match get_global gd x.(gv).(v_var) with | Ok v => ret (coerce_to_choice_type _ (translate_value v)) | _ => ret (chCanonical _) end - ). + ). Definition chArray_get ws (a : 'array) ptr scale := (* Jasmin fails if ptr is not aligned; we may not need it. *) (* if negb (is_align ptr sz) then chCanonical ws else *) - let f k := - match assoc a (scale * ptr + k)%Z with - | None => chCanonical ('word U8) - | Some x => x - end in - let l := map f (ziota 0 (wsize_size ws)) in - Jasmin.memory_model.LE.decode ws l. - + let f k := + match assoc a (scale * ptr + k)%Z with + | None => chCanonical ('word U8) + | Some x => x + end + in + let l := map f (ziota 0 (wsize_size ws)) in + Jasmin.memory_model.LE.decode ws l. Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code. Proof. @@ -446,15 +438,15 @@ Defined. Definition ssprove_prog := seq (funname * fdef). Definition translate_prog (p : uprog) : ssprove_prog := - let globs := collect_globs (p_globs p) in + (* let globs := collect_globs (p_globs p) in *) let fds := map translate_fundef (p_funcs p) in fds. Fixpoint lchtuple (ts : seq choice_type) : choice_type := match ts with - | [::] => chUnit - | [::t1] => t1 - | t1::ts => chProd t1 (lchtuple ts) + | [::] => 'unit + | [:: t1 ] => t1 + | t1 :: ts => t1 × (lchtuple ts) end. Definition get_fundef_ssp (sp : seq (funname * fdef)) (fn : funname) (dom cod : choice_type) : @@ -483,9 +475,9 @@ Qed. Fixpoint type_of_values vs : choice_type := match vs with - | [::] => 'unit - | [::v] => choice_type_of_val v - | hd::tl => choice_type_of_val hd × type_of_values tl + | [::] => 'unit + | [:: v ] => choice_type_of_val v + | hd :: tl => choice_type_of_val hd × type_of_values tl end. (* lchtuple (map choice_type_of_val vs) *) @@ -500,10 +492,6 @@ Proof. + exact (translate_value v, tr_vs). Defined. -(* Definition seq_prod ls := *) -(* map translate_value ls *) -(* foldr chProd ls *) - Definition translate_ptr (ptr : pointer) : Location := ('word U8 ; (5 ^ Z.to_nat (wunsigned ptr))%nat). From e4fc33816feb2543a5c772b01f07254248dcb957 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 31 Mar 2022 11:43:01 +0200 Subject: [PATCH 048/383] Attempt to define unary judgement --- theories/Jasmin/jasmin_translate.v | 118 ++++++++++++++++------------- 1 file changed, 66 insertions(+), 52 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index f3566248..ddefcba7 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -503,13 +503,13 @@ Definition rel_mem (m : mem) (h : heap) := #[local] Open Scope vmap_scope. -Definition rel_vmap (vm : vmap) (h : heap) (fn : funname) := +Definition rel_vmap (vm : vmap) (fn : funname) (h : heap) := ∀ (i : var) v, vm.[i] = ok v → get_heap h (translate_var fn i) = coerce_to_choice_type _ (embed v). -Definition rel_estate (s : estate) (h : heap) (fn : funname) := - rel_mem s.(emem) h ∧ rel_vmap s.(evm) h fn. +Definition rel_estate (s : estate) (fn : funname) (h : heap) := + rel_mem s.(emem) h ∧ rel_vmap s.(evm) fn h. Lemma coerce_cast_code (ty vty : choice_type) (v : vty) : ret (coerce_to_choice_type ty v) = coerce_typed_code ty (vty ; ret v). @@ -556,6 +556,40 @@ Derive NoConfusion for result. Derive NoConfusion for value. Derive NoConfusion for wsize. +(* Unary judgment concluding on evaluation of program *) + +Definition eval_jdg {A : choiceType} + (pre : heap → Prop) (post : heap → Prop) + (c : raw_code A) (v : A) := + ⊢ ⦃ λ '(h₀, h₁), pre h₀ ⦄ + c ≈ ret v + ⦃ λ '(a₀, h₀) '(a₁, h₁), post h₀ ∧ a₀ = a₁ ∧ a₁ = v ⦄. + +Notation "⊢ ⦃ pre ⦄ c ⇓ v ⦃ post ⦄" := + (eval_jdg pre post c v) + (format "⊢ ⦃ pre ⦄ '/ ' '[' c ']' '/' ⇓ '/ ' '[' v ']' '/' ⦃ post ⦄") + : package_scope. + +Lemma u_bind : + ∀ {A B : choiceType} m f v fv (p q r : heap → Prop), + ⊢ ⦃ p ⦄ m ⇓ v ⦃ q ⦄ → + ⊢ ⦃ q ⦄ f v ⇓ fv v ⦃ r ⦄ → + ⊢ ⦃ p ⦄ @bind A B m f ⇓ fv v ⦃ r ⦄. +Proof. + intros A B m f v fv p q r hm hf. + unfold eval_jdg. + change (ret (fv v)) with (x ← ret v ;; ret (fv x)). + eapply r_bind. + - exact hm. + - intros a₀ a₁. + eapply rpre_hypothesis_rule. + intuition subst. + eapply rpre_weaken_rule. + 1: apply hf. + simpl. intuition subst. assumption. +Qed. + +(* Keeping for compat for now *) Lemma r_bind_unary : ∀ {A B : choiceType} m f v fv (pre : precond) (mid : postcond A A) (post : postcond B B), @@ -579,13 +613,13 @@ Lemma translate_pexpr_correct : ∀ fn (e : pexpr) s₁ v ty v' ty', sem_pexpr gd s₁ e = ok v → truncate_val ty v = ok v' → - ⊢ ⦃ λ '(h₀, h₁), rel_estate s₁ h₁ fn ⦄ - ret (coerce_to_choice_type ty' (translate_value v')) - ≈ - coerce_typed_code ty' (truncate_code ty (translate_pexpr fn e)) - ⦃ λ '(a₀, h₀) '(a₁, h₁), a₀ = a₁ ∧ a₀ = coerce_to_choice_type ty' (translate_value v') ∧ rel_estate s₁ h₁ fn ⦄. + ⊢ ⦃ rel_estate s₁ fn ⦄ + coerce_typed_code ty' (truncate_code ty (translate_pexpr fn e)) ⇓ + coerce_to_choice_type ty' (translate_value v') + ⦃ rel_estate s₁ fn ⦄. Proof. intros fn e s₁ v ty v' ty' h1 h2. + unfold eval_jdg. rewrite coerce_cast_code. unfold choice_type_of_val. unfold truncate_code. @@ -647,13 +681,13 @@ Proof. unfold on_vu in h1. destruct Fv.get as [sx |] eqn:e1. 2:{ destruct e. all: discriminate. } noconf h1. - eapply r_get_remember_rhs with (pre := λ '(h₀, h₁), rel_estate s₁ h₁ fn). + eapply r_get_remember_lhs with (pre := λ '(h₀, h₁), _). intro vx. simpl in vx. - apply r_ret. intros ? he [[hmem hvmap] h]. + apply r_ret. intros he ? [[hmem hvmap] h]. apply hvmap in e1. simpl in h. rewrite h in e1. clear h. subst. split. 2: split. - 3:{ split. all: assumption. } + 1:{ split. all: assumption. } 2: { by rewrite coerce_to_choice_type_K. } simpl. rewrite coerce_to_choice_type_K. set (ty := type_of_val v') in *. clearbody ty. @@ -743,58 +777,40 @@ Proof. unfold translate_gvar. unfold translate_var. destruct is_lvar eqn:hlvar. + simpl in *. - eapply r_get_remember_rhs with (pre := λ '(_, h₁), rel_estate s₁ h₁ fn). + eapply r_get_remember_lhs with (pre := λ '(_, _), _). rewrite H. simpl. intros arr. rewrite bind_assoc. - eapply rsymmetry. epose r_bind_unary as rbu. - (* specialize rbu with (post := (λ '(a₁, h₁) '(a₀, _), *) - (* a₀ = a₁ *) - (* ∧ a₀ = *) - (* coerce_to_choice_type (encode (type_of_val (to_val s))) *) - (* (translate_value (to_val s)) ∧ rel_estate s₁ h₁ fn)). *) - (* specialize rbu with (pre := (λ '(h₁, h₀), *) - (* ((λ '(_, h₁0), rel_estate s₁ h₁0 fn) *) - (* ⋊ rem_rhs ('array; nat_of_fun_ident fn (vname (gv x))) arr) *) - (* (h₀, h₁))). *) - specialize rbu with (mid := (λ '(_, h₁) '(_, h₀), - ((λ '(_, h₁0), rel_estate s₁ h₁0 fn) - ⋊ rem_rhs ('array; nat_of_fun_ident fn (vname (gv x))) arr) - (h₀, h₁))). - (* specialize rbu with (m := coerce_typed_code 'int (translate_pexpr fn e)). *) - (* specialize rbu with (v := z). *) + lazymatch goal with + | |- ⊢ ⦃ ?pre ⦄ _ ≈ _ ⦃ _ ⦄ => + specialize rbu with (mid := λ '(_, h₀) '(_, h₁), pre (h₀, h₁)) + end. specialize rbu with (fv := λ _i, (translate_value (to_val s))). - eapply rbu; clear rbu. - * simpl. - simp coerce_typed_code. + eapply rbu. all: clear rbu. + * simp coerce_typed_code. give_up. * simpl. eapply r_ret. intuition subst. - -- simpl. give_up. - -- simpl. give_up. -- apply H3. + -- give_up. + -- give_up. + simpl in *. rewrite H0. simpl. rewrite bind_assoc. - eapply rsymmetry. - epose r_bind_unary as rbu. - specialize rbu with (post := (λ '(a₁, h₁) '(a₀, _), - a₀ = a₁ - ∧ a₀ = - coerce_to_choice_type (encode (type_of_val (to_val s))) - (translate_value (to_val s)) ∧ rel_estate s₁ h₁ fn)). - specialize rbu with (pre := ( λ '(h₁, _), rel_estate s₁ h₁ fn )). - specialize rbu with (mid := (λ '(_, h₁) '(_, h₀), rel_estate s₁ h₁ fn)). - specialize rbu with (m := coerce_typed_code 'int (translate_pexpr fn e)). + epose proof @r_bind_unary as rbu. + specialize rbu with (A := 'int). + lazymatch goal with + | |- ⊢ ⦃ ?pre ⦄ _ ≈ _ ⦃ _ ⦄ => + specialize rbu with (mid := λ '(_, h₀) '(_, h₁), pre (h₀, h₁)) + end. specialize rbu with (v := z). specialize rbu with (fv := λ _i, (translate_value (to_val s))). - simpl in rbu. - eapply rbu; clear rbu. + eapply rbu with (pre := λ '(_, _), _). all: clear rbu. * simp coerce_typed_code. give_up. * simpl. eapply r_ret. intuition subst. - -- simpl in *. give_up. -- simpl in *. try reflexivity. admit. + -- simpl in *. give_up. - Admitted. @@ -820,9 +836,9 @@ Admitted. Lemma translate_instr_r_correct : ∀ (fn : funname) (i : instr_r) (s₁ s₂ : estate), sem_i P s₁ i s₂ → - ⊢ ⦃ λ '(h₀, h₁), rel_estate s₁ h₀ fn ⦄ + ⊢ ⦃ λ '(h₀, h₁), rel_estate s₁ fn h₀ ⦄ translate_instr_r fn i ≈ ret tt - ⦃ λ '(_, h₀) '(_, _), rel_estate s₂ h₀ fn ⦄. + ⦃ λ '(_, h₀) '(_, _), rel_estate s₂ fn h₀ ⦄. Proof. intros fn i s₁ s₂ h. induction h as [es₁ es₂ y tag sty e v v' sem_e trunc hw | | | | | | |]. @@ -841,7 +857,7 @@ Proof. specialize thm with (fv := λ _, tt). simpl in thm. pose (( λ '(a, h₀) '(b, _), - rel_estate es₁ h₀ fn ) : postcond + rel_estate es₁ fn h₀ ) : postcond (encode (vtype yl)) (encode (vtype yl))) as mid. specialize thm with (mid := mid). @@ -862,9 +878,7 @@ Proof. } *) (* * *) eapply thm. all: clear thm. all: simpl. - * eapply rsymmetry. - eapply rpost_weaken_rule. - 1: eapply translate_pexpr_correct. + * eapply translate_pexpr_correct. (* -- eassumption. -- { unfold truncate_val in *. From c4c3eb197baeb9bb753dba535a93ee2e8b8e388a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 31 Mar 2022 11:48:41 +0200 Subject: [PATCH 049/383] Much more reasonable u_bind --- theories/Jasmin/jasmin_translate.v | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index ddefcba7..db427487 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -571,14 +571,14 @@ Notation "⊢ ⦃ pre ⦄ c ⇓ v ⦃ post ⦄" := : package_scope. Lemma u_bind : - ∀ {A B : choiceType} m f v fv (p q r : heap → Prop), - ⊢ ⦃ p ⦄ m ⇓ v ⦃ q ⦄ → - ⊢ ⦃ q ⦄ f v ⇓ fv v ⦃ r ⦄ → - ⊢ ⦃ p ⦄ @bind A B m f ⇓ fv v ⦃ r ⦄. + ∀ {A B : choiceType} m f v₁ v₂ (p q r : heap → Prop), + ⊢ ⦃ p ⦄ m ⇓ v₁ ⦃ q ⦄ → + ⊢ ⦃ q ⦄ f v₁ ⇓ v₂ ⦃ r ⦄ → + ⊢ ⦃ p ⦄ @bind A B m f ⇓ v₂ ⦃ r ⦄. Proof. - intros A B m f v fv p q r hm hf. + intros A B m f v₁ v₂ p q r hm hf. unfold eval_jdg. - change (ret (fv v)) with (x ← ret v ;; ret (fv x)). + change (ret v₂) with (ret v₁ ;; ret v₂). eapply r_bind. - exact hm. - intros a₀ a₁. From 4a697722948791531a546bb9f4f57e3fb6f4f5f3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 31 Mar 2022 12:02:20 +0200 Subject: [PATCH 050/383] Define unary rules for ret --- theories/Jasmin/jasmin_translate.v | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index db427487..0f91a8d7 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -570,6 +570,28 @@ Notation "⊢ ⦃ pre ⦄ c ⇓ v ⦃ post ⦄" := (format "⊢ ⦃ pre ⦄ '/ ' '[' c ']' '/' ⇓ '/ ' '[' v ']' '/' ⦃ post ⦄") : package_scope. +Lemma u_ret : + ∀ {A : choiceType} (v v' : A) (p q : heap → Prop), + (∀ hp, p hp → q hp ∧ v = v') → + ⊢ ⦃ p ⦄ ret v ⇓ v' ⦃ q ⦄. +Proof. + intros A v v' p q h. + unfold eval_jdg. + apply r_ret. + intros hp hp' hhp. + specialize (h hp). + intuition eauto. +Qed. + +Lemma u_ret_eq : + ∀ {A : choiceType} (v : A) (p q : heap → Prop), + (∀ hp, p hp → q hp) → + ⊢ ⦃ p ⦄ ret v ⇓ v ⦃ q ⦄. +Proof. + intros A v p q h. + apply u_ret. intuition eauto. +Qed. + Lemma u_bind : ∀ {A B : choiceType} m f v₁ v₂ (p q r : heap → Prop), ⊢ ⦃ p ⦄ m ⇓ v₁ ⦃ q ⦄ → From ccd46455f4668ec5938f09ab2247b42fe199ac0b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 31 Mar 2022 14:32:00 +0200 Subject: [PATCH 051/383] Define unary variant of r_put --- theories/Jasmin/jasmin_translate.v | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 0f91a8d7..75203bb3 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -611,6 +611,23 @@ Proof. simpl. intuition subst. assumption. Qed. +(* Unary variant of set_lhs *) +Definition u_set_pre (ℓ : Location) (v : ℓ) (pre : heap → Prop): heap → Prop := + λ m, ∃ m', pre m' ∧ m = set_heap m' ℓ v. + +Lemma u_put : + ∀ {A : choiceType} (ℓ : Location) (v : ℓ) (r : raw_code A) (v' : A) p q, + ⊢ ⦃ u_set_pre ℓ v p ⦄ r ⇓ v' ⦃ q ⦄ → + ⊢ ⦃ p ⦄ #put ℓ := v ;; r ⇓ v' ⦃ q ⦄. +Proof. + intros A ℓ v r v' p q h. + eapply r_put_lhs with (pre := λ '(_,_), _). + eapply rpre_weaken_rule. 1: eapply h. + intros m₀ m₁ hm. simpl. + destruct hm as [m' hm]. + exists m'. exact hm. +Qed. + (* Keeping for compat for now *) Lemma r_bind_unary : ∀ {A B : choiceType} m f v fv From a9f2a63137373a66d62fd2fa87e92fb3b7fba8e9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 31 Mar 2022 14:32:41 +0200 Subject: [PATCH 052/383] Use unary judgment in translate_instr_r_correct --- theories/Jasmin/jasmin_translate.v | 54 ++++++++++++------------------ 1 file changed, 21 insertions(+), 33 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 75203bb3..adfd42d7 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -875,14 +875,14 @@ Admitted. Lemma translate_instr_r_correct : ∀ (fn : funname) (i : instr_r) (s₁ s₂ : estate), sem_i P s₁ i s₂ → - ⊢ ⦃ λ '(h₀, h₁), rel_estate s₁ fn h₀ ⦄ - translate_instr_r fn i ≈ ret tt - ⦃ λ '(_, h₀) '(_, _), rel_estate s₂ fn h₀ ⦄. + ⊢ ⦃ rel_estate s₁ fn ⦄ + translate_instr_r fn i ⇓ tt + ⦃ rel_estate s₂ fn ⦄. Proof. intros fn i s₁ s₂ h. induction h as [es₁ es₂ y tag sty e v v' sem_e trunc hw | | | | | | |]. - simpl. destruct y as [ | yl | | | ] eqn:case_lval. - + simpl. apply r_ret. intros h₀ _ hr. + + simpl. apply u_ret_eq. intros hp hr. simpl in hw. unfold write_none in hw. destruct is_sbool eqn:eb. * unfold on_vu in hw. destruct of_val as [| []]. @@ -892,14 +892,6 @@ Proof. + simpl. simpl in hw. unfold write_var in hw. destruct set_var eqn:eset. 2: discriminate. simpl in hw. noconf hw. - epose proof r_bind_unary as thm. - specialize thm with (fv := λ _, tt). - simpl in thm. - pose (( λ '(a, h₀) '(b, _), - rel_estate es₁ fn h₀ ) : postcond - (encode (vtype yl)) - (encode (vtype yl))) as mid. - specialize thm with (mid := mid). rewrite truncate_code_idemp. (* Other attempt *) (* unfold truncate_val in trunc. destruct of_val eqn:ev. 2: discriminate. @@ -916,7 +908,7 @@ Proof. discriminate H0. } *) (* * *) - eapply thm. all: clear thm. all: simpl. + eapply u_bind. * eapply translate_pexpr_correct. (* -- eassumption. -- { @@ -930,25 +922,22 @@ Proof. (* 1,2: eassumption. simpl. intros [] []. intuition eauto. *) all: admit. - * clear sem_e tag e. - epose proof r_put_lhs as thm. - (* specialize thm with (ℓ := translate_var fn yl). - specialize thm with (r₁ := ret tt). - specialize thm with (r₀ := ret tt). - specialize thm with (v := a). *) - (* specialize thm with *) - (* (pre := λ '(s₀, h₁), mid (a, s₀) *) - (* (coerce_to_choice_type (encode (vtype y)) *) - (* (translate_value v'), h₁)). *) - specialize thm with (pre := λ '(s₀, h₁), mid (coerce_to_choice_type _ (translate_value v'), s₀) (coerce_to_choice_type _ (translate_value v'), h₁)). - - (* v' instead of a ? *) - simpl in thm. - eapply thm. - clear thm. clear mid. - apply r_ret. - intros ? ? hs. - unfold set_lhs in hs. + * { + clear sem_e tag e. + eapply u_put. + apply u_ret_eq. + intros m' [m [hm e]]. subst. + destruct hm as [hm hv]. + split. + - simpl. unfold rel_mem. + intros ptr sz w hrw. + rewrite get_set_heap_neq. 2: apply ptr_var_neq. + apply hm. assumption. + - simpl. unfold rel_vmap. + intros i vi ei. + admit. (* TODO Fix the admit above before! *) + } + (* destruct hs as [h [[_ [rm rv]] Hs₀]]. (* we're in the *local* var case (cf eset), can only prove that the vmaps are related *) @@ -1026,7 +1015,6 @@ Proof. (* apply hvmap in H. *) (* apply hvmap. *) - admit. + admit. + admit. + admit. From b57406187ac7206c4c3465ff544b764529f66c48 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 31 Mar 2022 15:22:36 +0200 Subject: [PATCH 053/383] Add u_get_remember --- theories/Jasmin/jasmin_translate.v | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index adfd42d7..ce801dff 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -628,6 +628,29 @@ Proof. exists m'. exact hm. Qed. +(* Unary variant of inv_conj (⋊) *) +Definition u_pre_conj (p q : heap → Prop) : heap → Prop := + λ m, p m ∧ q m. + +Notation "p ≪ q" := + (u_pre_conj p q) (at level 19, left associativity) : package_scope. + +(* Unary variant of rem_lhs *) +Definition u_get (ℓ : Location) (v : ℓ) : heap → Prop := + λ m, get_heap m ℓ = v. + +Lemma u_get_remember : + ∀ (A : choiceType) (ℓ : Location) (k : ℓ → raw_code A) (v : A) p q, + (∀ x, ⊢ ⦃ p ≪ u_get ℓ x ⦄ k x ⇓ v ⦃ q ⦄) → + ⊢ ⦃ p ⦄ x ← get ℓ ;; k x ⇓ v ⦃ q ⦄. +Proof. + intros A ℓ k v p q h. + eapply r_get_remember_lhs with (pre := λ '(_,_), _). + intro x. + eapply rpre_weaken_rule. 1: eapply h. + simpl. intuition eauto. +Qed. + (* Keeping for compat for now *) Lemma r_bind_unary : ∀ {A B : choiceType} m f v fv From afeec4c0ea389b97b8af3c5aeeba7156ba9b76e7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 31 Mar 2022 16:01:09 +0200 Subject: [PATCH 054/383] Update translate_pexpr_correct to use unary rules --- theories/Jasmin/jasmin_translate.v | 164 ++++++++++++----------------- 1 file changed, 69 insertions(+), 95 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index ce801dff..109c6403 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -555,6 +555,8 @@ Qed. Derive NoConfusion for result. Derive NoConfusion for value. Derive NoConfusion for wsize. +Derive NoConfusion for CoqWord.word.word. +Derive EqDec for wsize. (* Unary judgment concluding on evaluation of program *) @@ -681,9 +683,8 @@ Lemma translate_pexpr_correct : ⦃ rel_estate s₁ fn ⦄. Proof. intros fn e s₁ v ty v' ty' h1 h2. - unfold eval_jdg. - rewrite coerce_cast_code. - unfold choice_type_of_val. + (* rewrite coerce_cast_code. + unfold choice_type_of_val. *) unfold truncate_code. assert (e2 : ty = type_of_val v'). { unfold truncate_val in h2. destruct of_val eqn:ev. 2: discriminate. @@ -695,43 +696,44 @@ Proof. 2:{ rewrite coerce_typed_code_neq. 2:{ move: e1 => /eqP e1. congruence. } - rewrite coerce_typed_code_neq. - 2:{ move: e1 => /eqP e1. congruence. } - apply r_ret. intuition subst. - symmetry; apply coerce_to_choice_type_neq. move: e1 => /eqP; auto. + rewrite coerce_to_choice_type_neq. + 2:{ + move: e1 => /eqP e1. intros ?. subst. + apply e1. + unfold choice_type_of_val. reflexivity. + } + apply u_ret_eq. auto. } pose proof e1 as e2. move: e2 => /eqP e2. subst. - rewrite 2!coerce_typed_code_K. - unfold truncate_val in h2. destruct of_val eqn:ev. 2: discriminate. - simpl in h2. noconf h2. destruct H. - clear e1. + rewrite coerce_typed_code_K. rewrite coerce_to_choice_type_K. clear e1. + unfold truncate_val in h2. destruct of_val as [vv|] eqn:ev. 2: discriminate. + simpl in h2. symmetry in h2. noconf h2. + lazymatch goal with + | h : _ = to_val _ |- _ => rename h into h2 + end. + rewrite h2. + set (ty := type_of_val v') in *. clearbody ty. subst. (* Now we can actually look at the pexpr *) induction e as [z|b| |x|aa ws x e| | | | | | ]. - simpl. simpl in h1. noconf h1. - apply of_vint in ev as es. - revert s ev. rewrite es. intros s ev. - simpl. simp coerce_to_choice_type. simpl. - rewrite !cast_ct_val_K. + apply of_vint in ev as es. subst. + simpl. rewrite coerce_to_choice_type_K. simpl in ev. noconf ev. - apply r_ret. intuition subst. + apply u_ret_eq. auto. - simpl. simpl in h1. noconf h1. apply of_vbool in ev as es. - destruct es as [es _]. - revert s ev. rewrite es. intros s ev. - simpl. simp coerce_to_choice_type. simpl. - rewrite !cast_ct_val_K. + destruct es as [es _]. subst. + simpl. rewrite coerce_to_choice_type_K. simpl in ev. noconf ev. - apply r_ret. intuition subst. + apply u_ret_eq. auto. - simpl. simpl in h1. noconf h1. apply of_varr in ev as es. move: es => /values.subtypeE es. - destruct es as [m [es hm]]. - revert s ev. rewrite es. intros s ev. - simpl. simp coerce_to_choice_type. simpl. - rewrite !cast_ct_val_K. + destruct es as [m [es hm]]. subst. + simpl. rewrite coerce_to_choice_type_K. simpl in ev. apply WArray.cast_empty_ok in ev. subst. simpl. rewrite Mz.foldP. simpl. - apply r_ret. intuition subst. + apply u_ret_eq. auto. - simpl. simpl in h1. apply type_of_get_gvar in h1 as es. unfold translate_gvar. unfold translate_var. @@ -740,56 +742,46 @@ Proof. + destruct x as [gx gs]. simpl in *. unfold is_lvar in hlvar. simpl in hlvar. move: hlvar => /eqP hlvar. subst. unfold get_var in h1. - unfold on_vu in h1. destruct Fv.get as [sx |] eqn:e1. + unfold on_vu in h1. destruct Fv.get as [sx | e] eqn:e1. 2:{ destruct e. all: discriminate. } noconf h1. - eapply r_get_remember_lhs with (pre := λ '(h₀, h₁), _). - intro vx. simpl in vx. - apply r_ret. intros he ? [[hmem hvmap] h]. - apply hvmap in e1. simpl in h. + eapply u_get_remember. simpl. intro vx. + apply u_ret. intros m [[hmem hvmap] h]. + apply hvmap in e1. unfold u_get in h. rewrite h in e1. clear h. subst. - split. 2: split. + split. 1:{ split. all: assumption. } - 2: { by rewrite coerce_to_choice_type_K. } - simpl. rewrite coerce_to_choice_type_K. - set (ty := type_of_val v') in *. clearbody ty. + rewrite coerce_to_choice_type_K. clear - ev. set (ty' := vtype gx) in *. clearbody ty'. clear - ev. - pose proof (type_of_to_val s) as ety. + pose proof (type_of_to_val sx) as ety. destruct ty. * simpl. simpl in ev. unfold to_bool in ev. destruct to_val eqn:esx. all: try discriminate. 2:{ destruct t. all: discriminate. } - noconf ev. pose proof (type_of_to_val sx) as ety'. - rewrite esx in ety'. subst. + noconf ev. subst. rewrite coerce_to_choice_type_K. simpl. noconf esx. reflexivity. * simpl. simpl in ev. unfold to_int in ev. destruct to_val eqn:esx. all: try discriminate. 2:{ destruct t. all: discriminate. } - noconf ev. pose proof (type_of_to_val sx) as ety'. - rewrite esx in ety'. subst. + noconf ev. subst. rewrite coerce_to_choice_type_K. simpl. noconf esx. reflexivity. * simpl. simpl in ev. unfold to_arr in ev. destruct to_val eqn:esx. all: try discriminate. - pose proof (type_of_to_val sx) as ety'. - rewrite esx in ety'. subst. + subst. rewrite coerce_to_choice_type_K. simpl. noconf esx. unfold WArray.cast in ev. destruct (_ <=? _)%Z. 2: discriminate. noconf ev. simpl. reflexivity. * simpl. simpl in ev. - pose proof (type_of_to_val sx) as ety'. unfold to_word in ev. destruct to_val eqn:esx. all: try discriminate. 2:{ destruct t. all: discriminate. } - subst. simpl. noconf esx. inversion H. rewrite ev. reflexivity. + subst. simpl. noconf esx. rewrite ev. reflexivity. + simpl. rewrite h1. simpl. - apply r_ret. intuition subst. - 2: { by rewrite coerce_to_choice_type_K. } - f_equal. + apply u_ret. intros m hm. + split. 1: auto. rewrite -es. rewrite coerce_to_choice_type_K. - pose proof (type_of_to_val s) as ety. - set (ty := type_of_val v') in *. clearbody ty. clear - ev. destruct ty. * simpl. simpl in ev. @@ -805,8 +797,6 @@ Proof. reflexivity. * simpl. simpl in ev. unfold to_arr in ev. destruct v eqn:e. all: try discriminate. - (* pose proof (type_of_to_val sx) as ety'. - rewrite esx in ety'. subst. *) rewrite coerce_to_choice_type_K. simpl. subst. unfold WArray.cast in ev. destruct (_ <=? _)%Z. 2: discriminate. @@ -820,59 +810,43 @@ Proof. (* massage the hypotheses into something more usable *) simpl in h1. pose proof on_arr_gvarP as p. - unshelve eapply (p _ _ _ _ _ _ _ _ h1) ; clear p h1. - intros. simpl in H1. simpl. - unshelve eapply (@rbindP _ _ _ _ _ _ _ _ H1). - intros. clear H1. - simpl in H2, H3. - unshelve eapply (@rbindP _ _ _ _ _ _ _ _ H2). - intros; clear H2. - unshelve eapply (@rbindP _ _ _ _ _ _ _ _ H3). - intros; clear H3. - simpl in *. - noconf H5. - unfold get_gvar in H0. - apply type_of_get_gvar in H0 as tarr. + unshelve eapply (p _ _ _ _ _ _ _ _ h1). clear p h1. + intros n ar evty hgd h. simpl in h. simpl. + eapply rbindP. 2: exact h. + clear h. simpl. intros z h1 h2. + eapply rbindP. 2: exact h1. + clear h1. intros v' hv' ev'. + eapply rbindP. 2: exact h2. + clear h2. simpl. intros w ha ew. + noconf ew. + unfold get_gvar in hgd. + + unfold to_int in ev'. destruct v'. all: try discriminate. + 2:{ destruct t. all: discriminate. } + noconf ev'. + (* TW: The IH might be wrong, could be worth it to use induction in *) + (* TW: It would be nice to conclude here that e is translated to an 'int + Might come from IH though. + *) (* Now the actual proof should begin. Instead, here is some mindless mess following my nose along the structure of the goal. *) unfold translate_gvar. unfold translate_var. destruct is_lvar eqn:hlvar. - + simpl in *. - eapply r_get_remember_lhs with (pre := λ '(_, _), _). - rewrite H. simpl. intros arr. + + simpl. + eapply u_get_remember. + rewrite evty. simpl. intros arr. rewrite bind_assoc. - epose r_bind_unary as rbu. - lazymatch goal with - | |- ⊢ ⦃ ?pre ⦄ _ ≈ _ ⦃ _ ⦄ => - specialize rbu with (mid := λ '(_, h₀) '(_, h₁), pre (h₀, h₁)) - end. - specialize rbu with (fv := λ _i, (translate_value (to_val s))). - eapply rbu. all: clear rbu. - * simp coerce_typed_code. + eapply u_bind. + * give_up. + * simpl. eapply u_ret. give_up. - * simpl. eapply r_ret. - intuition subst. - -- apply H3. - -- give_up. - -- give_up. - + simpl in *. rewrite H0. + + simpl. rewrite hgd. simpl. rewrite bind_assoc. - epose proof @r_bind_unary as rbu. - specialize rbu with (A := 'int). - lazymatch goal with - | |- ⊢ ⦃ ?pre ⦄ _ ≈ _ ⦃ _ ⦄ => - specialize rbu with (mid := λ '(_, h₀) '(_, h₁), pre (h₀, h₁)) - end. - specialize rbu with (v := z). - specialize rbu with (fv := λ _i, (translate_value (to_val s))). - eapply rbu with (pre := λ '(_, _), _). all: clear rbu. - * simp coerce_typed_code. + eapply u_bind. + * give_up. + * simpl. eapply u_ret. give_up. - * simpl. eapply r_ret. - intuition subst. - -- simpl in *. try reflexivity. admit. - -- simpl in *. give_up. - Admitted. From ea52bfa80dd6ab7e283339909a7c6b708ed53e09 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 31 Mar 2022 16:04:37 +0200 Subject: [PATCH 055/383] Remove r_bind_unary --- theories/Jasmin/jasmin_translate.v | 20 -------------------- 1 file changed, 20 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 109c6403..20b2ca0c 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -653,26 +653,6 @@ Proof. simpl. intuition eauto. Qed. -(* Keeping for compat for now *) -Lemma r_bind_unary : - ∀ {A B : choiceType} m f v fv - (pre : precond) (mid : postcond A A) (post : postcond B B), - ⊢ ⦃ pre ⦄ m ≈ ret v ⦃ λ '(a₀, h₀) '(a₁, h₁), mid (a₀, h₀) (a₁, h₁) ∧ a₀ = a₁ ∧ a₁ = v ⦄ → - ⊢ ⦃ λ '(s₀, s₁), mid (v, s₀) (v, s₁) ⦄ f v ≈ ret (fv v) ⦃ post ⦄ → - ⊢ ⦃ pre ⦄ bind m f ≈ ret (fv v) ⦃ post ⦄. -Proof. - intros A B m f v fv pre mid post hm hf. - change (ret (fv v)) with (x ← ret v ;; ret (fv x)). - eapply r_bind. - - exact hm. - - intros a₀ a₁. - eapply rpre_hypothesis_rule. - intuition subst. - eapply rpre_weaken_rule. - 1: apply hf. - simpl. intuition subst. assumption. -Qed. - Lemma translate_pexpr_correct : ∀ fn (e : pexpr) s₁ v ty v' ty', sem_pexpr gd s₁ e = ok v → From 9ea941d78906442656160e5e809cafc6c4ce59d8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 31 Mar 2022 16:14:05 +0200 Subject: [PATCH 056/383] Fix IH in translate_pexpr --- theories/Jasmin/jasmin_translate.v | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 20b2ca0c..d163301a 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -663,8 +663,6 @@ Lemma translate_pexpr_correct : ⦃ rel_estate s₁ fn ⦄. Proof. intros fn e s₁ v ty v' ty' h1 h2. - (* rewrite coerce_cast_code. - unfold choice_type_of_val. *) unfold truncate_code. assert (e2 : ty = type_of_val v'). { unfold truncate_val in h2. destruct of_val eqn:ev. 2: discriminate. @@ -694,7 +692,7 @@ Proof. rewrite h2. set (ty := type_of_val v') in *. clearbody ty. subst. (* Now we can actually look at the pexpr *) - induction e as [z|b| |x|aa ws x e| | | | | | ]. + induction e as [z|b| |x|aa ws x e| | | | | | ] in v, s₁, h1, ty, vv, ev |- *. - simpl. simpl in h1. noconf h1. apply of_vint in ev as es. subst. simpl. rewrite coerce_to_choice_type_K. @@ -804,9 +802,12 @@ Proof. unfold to_int in ev'. destruct v'. all: try discriminate. 2:{ destruct t. all: discriminate. } noconf ev'. - (* TW: The IH might be wrong, could be worth it to use induction in *) + specialize IHe with (1 := hv'). + specialize IHe with (ty := sint) (vv := z). + forward IHe. 1: reflexivity. + (* TW: It would be nice to conclude here that e is translated to an 'int - Might come from IH though. + Is there any way to know it though? *) (* Now the actual proof should begin. Instead, here is some mindless mess From 46b0a2c512c4352ad26b04f19edae13dfc40aa6f Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Thu, 31 Mar 2022 16:11:10 +0200 Subject: [PATCH 057/383] define translation of Cif --- theories/Jasmin/jasmin_translate.v | 36 ++++++++++++++++++++++-------- 1 file changed, 27 insertions(+), 9 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index d163301a..db298157 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -378,16 +378,35 @@ Proof. exact (_ ; c). Defined. -Definition translate_instr_r (fn : funname) (i : instr_r) : raw_code 'unit. + +Definition instr_d (i : instr) : instr_r := + match i with MkI _ i => i end. + +Fixpoint translate_instr_r (fn : funname) (i : instr_r) {struct i} : raw_code 'unit +with +translate_instr (fn : funname) (i : instr) {struct i} : raw_code 'unit. Proof. - destruct i. + { + pose proof (translate_cmd := + (fix translate_cmd (fn : funname) (c : cmd) : raw_code 'unit := + match c with + | [::] => ret tt + | i :: c => translate_instr fn i ;; translate_cmd fn c + end)). + + destruct i as [ | | e c1 c2 | | | ]. - (* Cassgn *) (* l :a=_s p *) pose (translate_pexpr fn p) as tr_p. pose (truncate_code s tr_p) as tr_p'. exact (ssprove_write_lval fn l tr_p'). - exact (unsupported.π2). (* Copn *) - - exact (unsupported.π2). (* Cif *) + - (* Cif e c1 c2 *) + pose (e' := translate_pexpr fn e). + pose (c1' := translate_cmd fn c1). + pose (c2' := translate_cmd fn c2). + pose (rb := coerce_typed_code 'bool e'). + exact (b ← rb ;; if b then c1' else c2'). - exact (unsupported.π2). (* Cfor *) - exact (unsupported.π2). (* Cwhile *) - (* Ccall i l f l0 *) @@ -399,14 +418,13 @@ Proof. (* write_lvals the result of the call into lvals `l` *) exact (unsupported.π2). + } + { +(* Definition translate_instr (fn : funname) (i : instr) : raw_code 'unit := *) + exact (translate_instr_r fn (instr_d i)). + } Defined. -Definition instr_d (i : instr) : instr_r := - match i with MkI _ i => i end. - -Definition translate_instr (fn : funname) (i : instr) : raw_code 'unit := - translate_instr_r fn (instr_d i). - Fixpoint translate_cmd (fn : funname) (c : cmd) : raw_code 'unit := match c with | [::] => ret tt From 9a1601338c1ee3a9a4046b15a3d6a91d4b156b8f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 31 Mar 2022 16:41:44 +0200 Subject: [PATCH 058/383] Style --- theories/Jasmin/jasmin_translate.v | 56 +++++++++++++++--------------- 1 file changed, 28 insertions(+), 28 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index db298157..fbc1411a 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -383,9 +383,9 @@ Definition instr_d (i : instr) : instr_r := match i with MkI _ i => i end. Fixpoint translate_instr_r (fn : funname) (i : instr_r) {struct i} : raw_code 'unit -with -translate_instr (fn : funname) (i : instr) {struct i} : raw_code 'unit. +with translate_instr (fn : funname) (i : instr) {struct i} : raw_code 'unit. Proof. + (* translate_instr_r *) { pose proof (translate_cmd := (fix translate_cmd (fn : funname) (c : cmd) : raw_code 'unit := @@ -394,34 +394,34 @@ Proof. | i :: c => translate_instr fn i ;; translate_cmd fn c end)). - destruct i as [ | | e c1 c2 | | | ]. - - (* Cassgn *) - (* l :a=_s p *) - pose (translate_pexpr fn p) as tr_p. - pose (truncate_code s tr_p) as tr_p'. - exact (ssprove_write_lval fn l tr_p'). - - exact (unsupported.π2). (* Copn *) - - (* Cif e c1 c2 *) - pose (e' := translate_pexpr fn e). - pose (c1' := translate_cmd fn c1). - pose (c2' := translate_cmd fn c2). - pose (rb := coerce_typed_code 'bool e'). - exact (b ← rb ;; if b then c1' else c2'). - - exact (unsupported.π2). (* Cfor *) - - exact (unsupported.π2). (* Cwhile *) - - (* Ccall i l f l0 *) - (* translate arguments *) - pose (map (translate_pexpr fn) l0) as tr_l0. - (* "perform" the call via `opr` *) - (* probably we'd look up the function signature in the current ambient program *) - - (* write_lvals the result of the call into lvals `l` *) - - exact (unsupported.π2). + destruct i as [ | | e c1 c2 | | | ]. + - (* Cassgn *) + (* l :a=_s p *) + pose (translate_pexpr fn p) as tr_p. + pose (truncate_code s tr_p) as tr_p'. + exact (ssprove_write_lval fn l tr_p'). + - exact (unsupported.π2). (* Copn *) + - (* Cif e c1 c2 *) + pose (e' := translate_pexpr fn e). + pose (c1' := translate_cmd fn c1). + pose (c2' := translate_cmd fn c2). + pose (rb := coerce_typed_code 'bool e'). + exact (b ← rb ;; if b then c1' else c2'). + - exact (unsupported.π2). (* Cfor *) + - exact (unsupported.π2). (* Cwhile *) + - (* Ccall i l f l0 *) + (* translate arguments *) + pose (map (translate_pexpr fn) l0) as tr_l0. + (* "perform" the call via `opr` *) + (* probably we'd look up the function signature in the current ambient program *) + + (* write_lvals the result of the call into lvals `l` *) + + exact (unsupported.π2). } + (* translate_instr *) { -(* Definition translate_instr (fn : funname) (i : instr) : raw_code 'unit := *) - exact (translate_instr_r fn (instr_d i)). + exact (translate_instr_r fn (instr_d i)). } Defined. From f1f6cb1f757acffdb13e1a74992d40048e2b512b Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Thu, 31 Mar 2022 16:52:11 +0200 Subject: [PATCH 059/383] new translate_pexpr_correct --- theories/Jasmin/jasmin_translate.v | 33 ++++++++++++++++++++++++++++++ 1 file changed, 33 insertions(+) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 20b2ca0c..3a2f6fc2 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -653,6 +653,39 @@ Proof. simpl. intuition eauto. Qed. +Lemma translate_pexpr_correct_new : + ∀ fn (e : pexpr) s₁ v, + sem_pexpr gd s₁ e = ok v → + ⊢ ⦃ rel_estate s₁ fn ⦄ + coerce_typed_code _ (translate_pexpr fn e) ⇓ + translate_value v + ⦃ rel_estate s₁ fn ⦄. +Proof. + intros fn e s1 v h1. + induction e as [z|b| |x|aa ws x e| | | | | | ]. + - simpl in h1. noconf h1. + rewrite coerce_typed_code_K. + apply u_ret_eq. auto. + - simpl in h1. noconf h1. + rewrite coerce_typed_code_K. + apply u_ret_eq. auto. + - simpl in h1. noconf h1. + rewrite coerce_typed_code_K. + apply u_ret_eq. auto. + - simpl in h1. + apply type_of_get_gvar in h1 as es. + unfold translate_pexpr. + unfold translate_gvar. unfold translate_var. + unfold get_gvar in h1. + destruct is_lvar eqn:hlvar. + + destruct x as [gx gs]. simpl in *. + unfold is_lvar in hlvar. simpl in hlvar. move: hlvar => /eqP hlvar. subst. + unfold get_var in h1. + unfold on_vu in h1. destruct Fv.get as [sx | e] eqn:e1. + 2:{ destruct e. all: discriminate. } + noconf h1. + Admitted. + Lemma translate_pexpr_correct : ∀ fn (e : pexpr) s₁ v ty v' ty', sem_pexpr gd s₁ e = ok v → From 309b0e46f49186c4b5cf35f7f3b422669d91e9ed Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 31 Mar 2022 17:36:03 +0200 Subject: [PATCH 060/383] Define translate_pexpr directly + fix it --- theories/Jasmin/jasmin_translate.v | 123 ++++++++++++++++------------- 1 file changed, 68 insertions(+), 55 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 7f410fea..aa1ecfde 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -279,17 +279,66 @@ Definition chArray_get ws (a : 'array) ptr scale := let l := map f (ziota 0 (wsize_size ws)) in Jasmin.memory_model.LE.decode ws l. -Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code. -Proof. - destruct e as [z|b| |x|aa ws x e| | | | | | ]. - - exists chInt. apply ret. exact z. - - exists chBool. exact (ret b). - - (* Parr_init only gets produced by ArrayInit() in jasmin source; the EC - export asserts false on it. *) - exists 'array. - exact (ret emptym). - - exact (translate_gvar fn x). - - (* | Pget aa ws x e => *) +Definition totc (ty : choice_type) (c : raw_code ty) : typed_code := + (ty ; c). + +Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code := + match e with + | Pconst z => totc 'int (@ret 'int z) (* Why do we need to give 'int twice? *) + | Pbool b => totc 'bool (ret b) + | Parr_init n => + (* Parr_init only gets produced by ArrayInit() in jasmin source. *) + (* The EC export asserts false on it. *) + totc 'array (ret emptym) + | Pvar v => translate_gvar fn v + | Pget aa ws x e => + totc ('word ws) ( + arr ← (translate_gvar fn x).π2 ;; (* Performs the lookup in gd *) + let a := coerce_to_choice_type 'array arr in + i ← (truncate_code sint (translate_pexpr fn e)).π2 ;; (* to_int *) + let scale := mk_scale aa ws in + ret (chArray_get ws a i scale) + ) + | Psub aa ws len x e => + totc 'array ( + arr ← (translate_gvar fn x).π2 ;; (* Performs the lookup in gd *) + let a := coerce_to_choice_type 'array arr in + i ← (truncate_code sint (translate_pexpr fn e)).π2 ;; (* to_int *) + ret (chCanonical _) (* TODO *) + ) + | Pload sz x e => + totc ('word sz) ( + ret (chCanonical _) (* TODO *) + ) + | Papp1 o e => + totc _ ( + (* We truncate and call sem_sop1_typed instead of calling sem_sop1 + which does the truncation and then calls sem_sop1_typed. + *) + x ← (truncate_code (type_of_op1 o).1 (translate_pexpr fn e)).π2 ;; + ret (embed (sem_sop1_typed o (unembed x))) + ) + | Papp2 o e1 e2 => + totc _ ( + (* Same here *) + r1 ← (truncate_code (type_of_op2 o).1.1 (translate_pexpr fn e1)).π2 ;; + r2 ← (truncate_code (type_of_op2 o).1.2 (translate_pexpr fn e2)).π2 ;; + ret match sem_sop2_typed o (unembed r1) (unembed r2) with + | Ok y => embed y + | _ => chCanonical _ + end + ) + | PappN op es => unsupported + | Pif t eb e1 e2 => + totc _ ( + b ← (truncate_code sbool (translate_pexpr fn eb)).π2 ;; (* to_bool *) + if b + then (truncate_code t (translate_pexpr fn e1)).π2 + else (truncate_code t (translate_pexpr fn e2)).π2 + ) + end. + +(* (* | Pget aa ws x e => *) exists 'word ws. (* Look up x amongst the evm part of the estate and the globals gd. Monadic Let because we might find None. If (Some val) is found, fail with type @@ -311,47 +360,25 @@ Proof. (* Let w := WArray.get aa ws t i in *) pose (scale := mk_scale aa ws). - exact (a ← arr ;; ptr ← i ;; ret (chArray_get ws a ptr scale)). + exact (a ← arr ;; ptr ← i ;; ret (chArray_get ws a ptr scale)). *) - - (* | Psub aa ws len x e => *) - exists 'array. + (* | Psub aa ws len x e => *) (* Let (n, t) := gd, s.[x] in *) (* Let i := sem_pexpr s e >>= to_int in *) (* Let t' := WArray.get_sub aa ws len t i in *) (* ok (Varr t') *) - exact (ret (chCanonical _)). - (* TODO: still unsupported *) - - (* | Pload sz x e => *) + (* | Pload sz x e => *) (* Let w1 := get_var s.(evm) x >>= to_pointer in *) (* Let w2 := sem_pexpr s e >>= to_pointer in *) (* Let w := read s.(emem) (w1 + w2)%R sz in *) (* ok (@to_val (sword sz) w) *) - exists ('word w). exact (ret (chCanonical _)). - (* TODO: still unsupported *) - - pose proof (sem_sop1_typed s) as f. simpl in f. - pose (e' := translate_pexpr fn e). - pose (r := (truncate_code (type_of_op1 s).1 e').π2). - pose (c := x ← r ;; ret (embed (f (unembed x)))). - exact (_ ; c). - - pose proof (sem_sop2_typed s) as f. simpl in f. - pose (e1' := translate_pexpr fn e1). - pose (e2' := translate_pexpr fn e2). - pose (r1 := (truncate_code (type_of_op2 s).1.1 e1').π2). - pose (r2 := (truncate_code (type_of_op2 s).1.2 e2').π2). - pose (c := - x1 ← r1 ;; - x2 ← r2 ;; - ret match f (unembed x1) (unembed x2) with - | Ok y => embed y - | _ => chCanonical _ - end). - exact (_ ; c). - - (* | PappN op es => *) + + (* | PappN op es => *) (* Let vs := mapM (sem_pexpr s) es in *) (* sem_opN op vs *) - pose (vs := map (translate_pexpr fn) l). - pose proof (sem_opN_typed o) as f. simpl in f. + (* pose (vs := map (translate_pexpr fn) l). + pose proof (sem_opN_typed o) as f. simpl in f. *) (* Fixpoint app_sopn T ts : sem_prod ts (exec T) → values → exec T := *) (* match ts return sem_prod ts (exec T) → values → exec T with *) @@ -363,21 +390,6 @@ Proof. (* end. *) (* pose (vs' := fold (fun x => y ← x ;; unembed y) f vs). *) - exact unsupported. - - (* | Pif t e e1 e2 => *) - (* Let b := sem_pexpr s e >>= to_bool in *) - (* Let v1 := sem_pexpr s e1 >>= truncate_val t in *) - (* Let v2 := sem_pexpr s e2 >>= truncate_val t in *) - (* ok (if b then v1 else v2) *) - pose (eb := coerce_typed_code 'bool (translate_pexpr fn e1)). - pose (e1' := translate_pexpr fn e1). - pose (e2' := translate_pexpr fn e2). - pose (r1 := (truncate_code s e1').π2). - pose (r2 := (truncate_code s e2').π2). - pose (c := b ← eb ;; if b then r1 else r2). - exact (_ ; c). -Defined. - Definition instr_d (i : instr) : instr_r := match i with MkI _ i => i end. @@ -901,6 +913,7 @@ Lemma truncate_code_idemp : truncate_code sty' (truncate_code sty c) = truncate_code sty' c. Admitted. +(* TODO Make fixpoint too! *) Lemma translate_instr_r_correct : ∀ (fn : funname) (i : instr_r) (s₁ s₂ : estate), sem_i P s₁ i s₂ → From 4885ffd7a1a5fa7d7d0311ae17d86e0bf427f321 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Fri, 1 Apr 2022 11:03:08 +0200 Subject: [PATCH 061/383] translate_pexpr preserves types of well typed expressions --- theories/Jasmin/jasmin_translate.v | 61 ++++++++++++++++++++++++++++++ 1 file changed, 61 insertions(+) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index aa1ecfde..7430fea2 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -683,6 +683,67 @@ Proof. simpl. intuition eauto. Qed. +Lemma translate_pexpr_type fn s₁ e v : + sem_pexpr gd s₁ e = ok v → + (translate_pexpr fn e).π1 = choice_type_of_val v. +Proof with try discriminate; simpl in *. + intros. + revert v H. + destruct e; intros; simpl in *. + 1-3: noconf H; reflexivity. + - eapply type_of_get_gvar in H. + unfold choice_type_of_val. + rewrite H. + unfold translate_gvar. + destruct is_lvar; reflexivity. + - simpl in H. + destruct get_gvar... + + destruct v0... + destruct sem_pexpr... + destruct v0... + * destruct WArray.get... + noconf H. + reflexivity. + * destruct t... + - destruct get_gvar... + destruct v0... + destruct sem_pexpr... + destruct v0... + * destruct WArray.get_sub... + noconf H. + reflexivity. + * destruct t... + - destruct get_var... + destruct to_pointer... + destruct sem_pexpr... + destruct to_pointer... + destruct read... + noconf H. reflexivity. + - destruct sem_pexpr... + apply sem_sop1I in H as []. + rewrite H0. + unfold choice_type_of_val. + rewrite type_of_to_val. + reflexivity. + - destruct (sem_pexpr _ _ e1)... + destruct sem_pexpr... + apply sem_sop2I in H as [? [? [? []]]]. + unfold choice_type_of_val. subst. + by rewrite type_of_to_val. + - admit. + - destruct (sem_pexpr _ _ e1)... + destruct to_bool... + destruct (sem_pexpr _ _ e2)... + destruct truncate_val eqn:E... + destruct sem_pexpr... + destruct (truncate_val s v3) eqn:E2... + unfold truncate_val in *. + repeat destruct of_val... + noconf E. noconf E2. + unfold choice_type_of_val. + destruct b; noconf H; by rewrite type_of_to_val. +Admitted. + Lemma translate_pexpr_correct_new : ∀ fn (e : pexpr) s₁ v, sem_pexpr gd s₁ e = ok v → From fdc1f377118dd4fddcada3343093317383a7678b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Fri, 1 Apr 2022 11:38:34 +0200 Subject: [PATCH 062/383] Define chArray_get_sub --- theories/Jasmin/jasmin_translate.v | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 7430fea2..1e32650a 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -271,7 +271,7 @@ Definition chArray_get ws (a : 'array) ptr scale := (* Jasmin fails if ptr is not aligned; we may not need it. *) (* if negb (is_align ptr sz) then chCanonical ws else *) let f k := - match assoc a (scale * ptr + k)%Z with + match a (scale * ptr + k)%Z with | None => chCanonical ('word U8) | Some x => x end @@ -279,6 +279,20 @@ Definition chArray_get ws (a : 'array) ptr scale := let l := map f (ziota 0 (wsize_size ws)) in Jasmin.memory_model.LE.decode ws l. +Definition chArray_get_sub ws len (a : 'array) ptr scale := + let size := arr_size ws len in + let start := (ptr * scale)%Z in + if (0 <=? start)%Z (* && (start + size <=? ) *) + then ( + foldr (λ (i : Z) (data : 'array), + match assoc a (start + i)%Z with + | Some w => setm data i w + | None => data + end + ) emptym (ziota 0 size) + ) + else chCanonical 'array. + Definition totc (ty : choice_type) (c : raw_code ty) : typed_code := (ty ; c). From 704d31d80261e0a6598d811c0aff002bf7e26367 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Fri, 1 Apr 2022 11:45:48 +0200 Subject: [PATCH 063/383] Define Psub case of translate_pexpr --- theories/Jasmin/jasmin_translate.v | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 1e32650a..7e4325c3 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -296,6 +296,7 @@ Definition chArray_get_sub ws len (a : 'array) ptr scale := Definition totc (ty : choice_type) (c : raw_code ty) : typed_code := (ty ; c). +(* Following sem_pexpr *) Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code := match e with | Pconst z => totc 'int (@ret 'int z) (* Why do we need to give 'int twice? *) @@ -318,7 +319,8 @@ Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code := arr ← (translate_gvar fn x).π2 ;; (* Performs the lookup in gd *) let a := coerce_to_choice_type 'array arr in i ← (truncate_code sint (translate_pexpr fn e)).π2 ;; (* to_int *) - ret (chCanonical _) (* TODO *) + let scale := mk_scale aa ws in + ret (chArray_get_sub ws len a i scale) ) | Pload sz x e => totc ('word sz) ( @@ -376,12 +378,6 @@ Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code := exact (a ← arr ;; ptr ← i ;; ret (chArray_get ws a ptr scale)). *) - (* | Psub aa ws len x e => *) - (* Let (n, t) := gd, s.[x] in *) - (* Let i := sem_pexpr s e >>= to_int in *) - (* Let t' := WArray.get_sub aa ws len t i in *) - (* ok (Varr t') *) - (* | Pload sz x e => *) (* Let w1 := get_var s.(evm) x >>= to_pointer in *) (* Let w2 := sem_pexpr s e >>= to_pointer in *) From 7d15e67e1e14c3cc3102d2322b12a3f495209297 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Fri, 1 Apr 2022 14:37:35 +0200 Subject: [PATCH 064/383] Attempt to prove translate_truncate --- theories/Jasmin/jasmin_translate.v | 98 +++++++++++++++++++----------- 1 file changed, 64 insertions(+), 34 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 7e4325c3..c2d781e6 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -979,9 +979,56 @@ Admitted. Notation coe_cht := coerce_to_choice_type. Notation coe_tyc := coerce_typed_code. -Lemma truncate_code_idemp : - ∀ (sty sty' : stype) (c : typed_code), - truncate_code sty' (truncate_code sty c) = truncate_code sty' c. +(* TODO MOVE *) +(* Lemma u_coerce_typed_code : + ∀ (c : typed_code) (ty : choice_type) (v : ty) p q, + ⊢ ⦃ p ⦄ c.π2 ⇓ coerce_to_choice_type c.π1 v ⦃ q ⦄ → + ⊢ ⦃ p ⦄ coerce_typed_code ty c ⇓ v ⦃ q ⦄. +Proof. + intros c ty v p q h. + destruct c as [ty' c]. simpl in h. + destruct (ty' == ty) eqn:e. + all: move: e => /eqP e. + - subst. rewrite coerce_typed_code_K. rewrite coerce_to_choice_type_K in h. + assumption. + - rewrite coerce_typed_code_neq. 2: assumption. + rewrite coerce_to_choice_type_neq in h. 2: eauto. + WRONG, should just have coercion in the conclusions, including the value +Abort. *) + +Lemma translate_truncate : + ∀ (c : typed_code) (ty : stype) v v' p q, + truncate_val ty v = ok v' → + c.π1 = encode ty → + ⊢ ⦃ p ⦄ c.π2 ⇓ coerce_to_choice_type _ (translate_value v) ⦃ q ⦄ → + ⊢ ⦃ p ⦄ (truncate_code ty c).π2 ⇓ coerce_to_choice_type _ (translate_value v') ⦃ q ⦄. +Proof. + intros c ty v v' p q hv e h. + destruct c as [ty' c]. simpl in *. subst. + eapply u_bind. 1: eapply h. + eapply u_ret. intros m hm. + split. 1: assumption. + unfold truncate_val in hv. + destruct of_val as [vx |] eqn:e. 2: discriminate. + simpl in hv. noconf hv. + clear h. destruct ty, v. all: simpl in e. all: try discriminate. + all: try solve [ + lazymatch type of e with + | match ?t with _ => _ end = _ => destruct t ; discriminate + end + ]. + - noconf e. simpl. rewrite !coerce_to_choice_type_K. reflexivity. + - noconf e. simpl. rewrite !coerce_to_choice_type_K. reflexivity. + - simpl. rewrite !coerce_to_choice_type_K. + unfold WArray.cast in e. destruct (_ <=? _)%Z. 2: discriminate. + noconf e. simpl. reflexivity. + - simpl. rewrite coerce_to_choice_type_K. + unfold choice_type_of_val. simpl. + (* Set Printing All. *) + (* Fail rewrite coerce_to_choice_type_K. *) + (* We have s0 : word s so we can't cast it to word w *) + (* We should not have this cast probably. *) + give_up. Admitted. (* TODO Make fixpoint too! *) @@ -1005,42 +1052,24 @@ Proof. + simpl. simpl in hw. unfold write_var in hw. destruct set_var eqn:eset. 2: discriminate. simpl in hw. noconf hw. - rewrite truncate_code_idemp. - (* Other attempt *) -(* unfold truncate_val in trunc. destruct of_val eqn:ev. 2: discriminate. - simpl in trunc. noconf trunc. - eapply set_varP. 3: exact eset. - 2:{ - intros hbo hof hset. subst. - eapply rpre_hypothesis_rule. - intros ? ? [hmem hvmap]. - red in hvmap. - rewrite Fv.setP_eq in hof. - unfold undef_addr in H. - destruct (vtype yl) eqn:e. all: try noconf H. - discriminate H0. - } *) - (* * *) + rewrite coerce_typed_code_K. eapply u_bind. - * eapply translate_pexpr_correct. -(* -- eassumption. - -- { - unfold truncate_val in *. - destruct of_val eqn:ev. 2: discriminate. - simpl in trunc. noconf trunc. - eapply set_varP. 3: exact eset. - - intros. rewrite - - - } *) - (* 1,2: eassumption. - simpl. intros [] []. intuition eauto. *) - all: admit. + * { + eapply u_bind. + - eapply translate_truncate. + + eassumption. + + erewrite translate_pexpr_type. 2: eassumption. + admit. (* Is it correct? Seems off. *) + + (* eapply translate_pexpr_correct_new. *) + admit. + - admit. + } * { clear sem_e tag e. eapply u_put. apply u_ret_eq. intros m' [m [hm e]]. subst. - destruct hm as [hm hv]. + (* destruct hm as [hm hv]. split. - simpl. unfold rel_mem. intros ptr sz w hrw. @@ -1048,7 +1077,8 @@ Proof. apply hm. assumption. - simpl. unfold rel_vmap. intros i vi ei. - admit. (* TODO Fix the admit above before! *) + admit. *) + admit. } (* destruct hs as [h [[_ [rm rv]] Hs₀]]. From b93cda140a9146fd91acb0d340b5651c5bc07fca Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Fri, 1 Apr 2022 14:45:14 +0200 Subject: [PATCH 065/383] Fix and prove translate_truncate --- theories/Jasmin/jasmin_translate.v | 19 +++++++------------ 1 file changed, 7 insertions(+), 12 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index c2d781e6..b2963732 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -999,7 +999,7 @@ Abort. *) Lemma translate_truncate : ∀ (c : typed_code) (ty : stype) v v' p q, truncate_val ty v = ok v' → - c.π1 = encode ty → + c.π1 = choice_type_of_val v → ⊢ ⦃ p ⦄ c.π2 ⇓ coerce_to_choice_type _ (translate_value v) ⦃ q ⦄ → ⊢ ⦃ p ⦄ (truncate_code ty c).π2 ⇓ coerce_to_choice_type _ (translate_value v') ⦃ q ⦄. Proof. @@ -1022,14 +1022,9 @@ Proof. - simpl. rewrite !coerce_to_choice_type_K. unfold WArray.cast in e. destruct (_ <=? _)%Z. 2: discriminate. noconf e. simpl. reflexivity. - - simpl. rewrite coerce_to_choice_type_K. - unfold choice_type_of_val. simpl. - (* Set Printing All. *) - (* Fail rewrite coerce_to_choice_type_K. *) - (* We have s0 : word s so we can't cast it to word w *) - (* We should not have this cast probably. *) - give_up. -Admitted. + - simpl. rewrite !coerce_to_choice_type_K. + rewrite e. reflexivity. +Qed. (* TODO Make fixpoint too! *) Lemma translate_instr_r_correct : @@ -1058,13 +1053,13 @@ Proof. eapply u_bind. - eapply translate_truncate. + eassumption. - + erewrite translate_pexpr_type. 2: eassumption. - admit. (* Is it correct? Seems off. *) + + eapply translate_pexpr_type. eassumption. + (* eapply translate_pexpr_correct_new. *) admit. - - admit. + - apply u_ret_eq. eauto. } * { + simpl. clear sem_e tag e. eapply u_put. apply u_ret_eq. From a07f1f137e2789d93be5eb8bdb4bf781f45fb83e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Fri, 1 Apr 2022 14:46:27 +0200 Subject: [PATCH 066/383] Move translate_truncate earlier --- theories/Jasmin/jasmin_translate.v | 60 +++++++++++++++--------------- 1 file changed, 30 insertions(+), 30 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index b2963732..8490b679 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -693,6 +693,36 @@ Proof. simpl. intuition eauto. Qed. +Lemma translate_truncate : + ∀ (c : typed_code) (ty : stype) v v' p q, + truncate_val ty v = ok v' → + c.π1 = choice_type_of_val v → + ⊢ ⦃ p ⦄ c.π2 ⇓ coerce_to_choice_type _ (translate_value v) ⦃ q ⦄ → + ⊢ ⦃ p ⦄ (truncate_code ty c).π2 ⇓ coerce_to_choice_type _ (translate_value v') ⦃ q ⦄. +Proof. + intros c ty v v' p q hv e h. + destruct c as [ty' c]. simpl in *. subst. + eapply u_bind. 1: eapply h. + eapply u_ret. intros m hm. + split. 1: assumption. + unfold truncate_val in hv. + destruct of_val as [vx |] eqn:e. 2: discriminate. + simpl in hv. noconf hv. + clear h. destruct ty, v. all: simpl in e. all: try discriminate. + all: try solve [ + lazymatch type of e with + | match ?t with _ => _ end = _ => destruct t ; discriminate + end + ]. + - noconf e. simpl. rewrite !coerce_to_choice_type_K. reflexivity. + - noconf e. simpl. rewrite !coerce_to_choice_type_K. reflexivity. + - simpl. rewrite !coerce_to_choice_type_K. + unfold WArray.cast in e. destruct (_ <=? _)%Z. 2: discriminate. + noconf e. simpl. reflexivity. + - simpl. rewrite !coerce_to_choice_type_K. + rewrite e. reflexivity. +Qed. + Lemma translate_pexpr_type fn s₁ e v : sem_pexpr gd s₁ e = ok v → (translate_pexpr fn e).π1 = choice_type_of_val v. @@ -996,36 +1026,6 @@ Proof. WRONG, should just have coercion in the conclusions, including the value Abort. *) -Lemma translate_truncate : - ∀ (c : typed_code) (ty : stype) v v' p q, - truncate_val ty v = ok v' → - c.π1 = choice_type_of_val v → - ⊢ ⦃ p ⦄ c.π2 ⇓ coerce_to_choice_type _ (translate_value v) ⦃ q ⦄ → - ⊢ ⦃ p ⦄ (truncate_code ty c).π2 ⇓ coerce_to_choice_type _ (translate_value v') ⦃ q ⦄. -Proof. - intros c ty v v' p q hv e h. - destruct c as [ty' c]. simpl in *. subst. - eapply u_bind. 1: eapply h. - eapply u_ret. intros m hm. - split. 1: assumption. - unfold truncate_val in hv. - destruct of_val as [vx |] eqn:e. 2: discriminate. - simpl in hv. noconf hv. - clear h. destruct ty, v. all: simpl in e. all: try discriminate. - all: try solve [ - lazymatch type of e with - | match ?t with _ => _ end = _ => destruct t ; discriminate - end - ]. - - noconf e. simpl. rewrite !coerce_to_choice_type_K. reflexivity. - - noconf e. simpl. rewrite !coerce_to_choice_type_K. reflexivity. - - simpl. rewrite !coerce_to_choice_type_K. - unfold WArray.cast in e. destruct (_ <=? _)%Z. 2: discriminate. - noconf e. simpl. reflexivity. - - simpl. rewrite !coerce_to_choice_type_K. - rewrite e. reflexivity. -Qed. - (* TODO Make fixpoint too! *) Lemma translate_instr_r_correct : ∀ (fn : funname) (i : instr_r) (s₁ s₂ : estate), From 8fc0148975aa11a9384c7f460367392b6eded0fb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Fri, 1 Apr 2022 14:58:58 +0200 Subject: [PATCH 067/383] Restate translate_pexpr_correct_new to use it more easily --- theories/Jasmin/jasmin_translate.v | 31 ++++++++++++++++++------------ 1 file changed, 19 insertions(+), 12 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 8490b679..b1ea1fd2 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -788,20 +788,20 @@ Lemma translate_pexpr_correct_new : ∀ fn (e : pexpr) s₁ v, sem_pexpr gd s₁ e = ok v → ⊢ ⦃ rel_estate s₁ fn ⦄ - coerce_typed_code _ (translate_pexpr fn e) ⇓ - translate_value v + (translate_pexpr fn e).π2 ⇓ + coerce_to_choice_type _ (translate_value v) ⦃ rel_estate s₁ fn ⦄. Proof. intros fn e s1 v h1. - induction e as [z|b| |x|aa ws x e| | | | | | ]. + induction e as [z|b| |x|aa ws x e| | | | | | ] in s1, v, h1 |- *. - simpl in h1. noconf h1. - rewrite coerce_typed_code_K. + rewrite coerce_to_choice_type_K. apply u_ret_eq. auto. - simpl in h1. noconf h1. - rewrite coerce_typed_code_K. + rewrite coerce_to_choice_type_K. apply u_ret_eq. auto. - simpl in h1. noconf h1. - rewrite coerce_typed_code_K. + rewrite coerce_to_choice_type_K. apply u_ret_eq. auto. - simpl in h1. apply type_of_get_gvar in h1 as es. @@ -815,7 +815,7 @@ Proof. unfold on_vu in h1. destruct Fv.get as [sx | e] eqn:e1. 2:{ destruct e. all: discriminate. } noconf h1. - Admitted. +Admitted. Lemma translate_pexpr_correct : ∀ fn (e : pexpr) s₁ v ty v' ty', @@ -1054,8 +1054,7 @@ Proof. - eapply translate_truncate. + eassumption. + eapply translate_pexpr_type. eassumption. - + (* eapply translate_pexpr_correct_new. *) - admit. + + eapply translate_pexpr_correct_new. assumption. - apply u_ret_eq. eauto. } * { @@ -1064,7 +1063,7 @@ Proof. eapply u_put. apply u_ret_eq. intros m' [m [hm e]]. subst. - (* destruct hm as [hm hv]. + destruct hm as [hm hv]. split. - simpl. unfold rel_mem. intros ptr sz w hrw. @@ -1072,8 +1071,16 @@ Proof. apply hm. assumption. - simpl. unfold rel_vmap. intros i vi ei. - admit. *) - admit. + simpl. rewrite coerce_to_choice_type_K. + destruct (i == yl) eqn:evar. + all: move: evar => /eqP evar. + + subst. rewrite get_set_heap_eq. + eapply set_varP. 3: exact eset. + * admit. + * admit. + + rewrite get_set_heap_neq. 2: admit. (* Injectivity *) + (* Maybe use set_varP one level up. *) + admit. } (* destruct hs as [h [[_ [rm rv]] Hs₀]]. From 9b09e83fe9bc353583eee249dd49a657d480a87f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Fri, 1 Apr 2022 15:22:36 +0200 Subject: [PATCH 068/383] One more case in translate_pexpr_correct_new --- theories/Jasmin/jasmin_translate.v | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index b1ea1fd2..416d733f 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -815,6 +815,16 @@ Proof. unfold on_vu in h1. destruct Fv.get as [sx | e] eqn:e1. 2:{ destruct e. all: discriminate. } noconf h1. + eapply u_get_remember. simpl. + intro v. apply u_ret. + intros m [hm e]. unfold u_get in e. subst. + split. 1: auto. + destruct hm as [hm hv]. + apply hv in e1. rewrite e1. clear e1. + simpl. rewrite coerce_to_choice_type_K. + set (ty := vtype gx) in *. clearbody ty. + destruct ty. + all: simpl. all: rewrite coerce_to_choice_type_K. all: reflexivity. Admitted. Lemma translate_pexpr_correct : From a182d41c933179edb92712afb242d343d86a4324 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Fri, 1 Apr 2022 15:58:34 +0200 Subject: [PATCH 069/383] Progress on translate_instr_r_correct --- theories/Jasmin/jasmin_translate.v | 38 +++++++++++++++++++++++------- 1 file changed, 29 insertions(+), 9 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 416d733f..323e855c 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1082,15 +1082,35 @@ Proof. - simpl. unfold rel_vmap. intros i vi ei. simpl. rewrite coerce_to_choice_type_K. - destruct (i == yl) eqn:evar. - all: move: evar => /eqP evar. - + subst. rewrite get_set_heap_eq. - eapply set_varP. 3: exact eset. - * admit. - * admit. - + rewrite get_set_heap_neq. 2: admit. (* Injectivity *) - (* Maybe use set_varP one level up. *) - admit. + eapply set_varP. 3: exact eset. all: clear eset. + + intros v₁ hv₁ eyl. subst. + destruct (i == yl) eqn:evar. + all: move: evar => /eqP evar. + * subst. + rewrite Fv.setP_eq in ei. noconf ei. + rewrite get_set_heap_eq. + (* Should be embedded in the translate_truncate proof *) + admit. + * rewrite Fv.setP_neq in ei. + 2:{ apply /eqP. eauto. } + rewrite get_set_heap_neq. 2: admit. (* Injectivity *) + eapply hv in ei. rewrite ei. + rewrite coerce_to_choice_type_K. reflexivity. + + intros hbo hyl hset. exfalso. + subst. + (* destruct yl as [[vty vna] vinfo]. simpl in *. + move: hbo => /is_sboolP ebo. subst. + simpl in *. *) + destruct (i == yl) eqn:evar. + all: move: evar => /eqP evar. + * subst. rewrite Fv.setP_eq in ei. + clear - ei hbo. destruct (vtype yl). all: discriminate. + * rewrite Fv.setP_neq in ei. + 2:{ apply /eqP. eauto. } + destruct yl as [[vty vna] vinfo]. simpl in *. + move: hbo => /is_sboolP ebo. subst. + (* Did we lose information by clearing eset? *) + admit. } (* destruct hs as [h [[_ [rm rv]] Hs₀]]. From 9928229f05af98451ad90bce402322c8b448c3cc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Fri, 1 Apr 2022 16:01:57 +0200 Subject: [PATCH 070/383] translate_instr_r_correct: Fix undef case --- theories/Jasmin/jasmin_translate.v | 92 ++---------------------------- 1 file changed, 5 insertions(+), 87 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 323e855c..a305ed35 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1096,100 +1096,18 @@ Proof. rewrite get_set_heap_neq. 2: admit. (* Injectivity *) eapply hv in ei. rewrite ei. rewrite coerce_to_choice_type_K. reflexivity. - + intros hbo hyl hset. exfalso. + + intros hbo hyl hset. subst. - (* destruct yl as [[vty vna] vinfo]. simpl in *. - move: hbo => /is_sboolP ebo. subst. - simpl in *. *) destruct (i == yl) eqn:evar. all: move: evar => /eqP evar. - * subst. rewrite Fv.setP_eq in ei. + * exfalso. subst. rewrite Fv.setP_eq in ei. clear - ei hbo. destruct (vtype yl). all: discriminate. * rewrite Fv.setP_neq in ei. 2:{ apply /eqP. eauto. } - destruct yl as [[vty vna] vinfo]. simpl in *. - move: hbo => /is_sboolP ebo. subst. - (* Did we lose information by clearing eset? *) - admit. + rewrite get_set_heap_neq. 2: admit. (* Injectivity *) + eapply hv in ei. rewrite ei. + rewrite coerce_to_choice_type_K. reflexivity. } - - (* destruct hs as [h [[_ [rm rv]] Hs₀]]. - (* we're in the *local* var case (cf eset), can only prove - that the vmaps are related *) - subst. split. - -- simpl. - unfold rel_mem. - intros. - apply rm in H. - rewrite get_set_heap_neq. 2: apply ptr_var_neq. - apply H. - -- simpl. - unfold rel_vmap. - intros. - destruct ((translate_var fn i) == (translate_var fn yl)) eqn:E. - ++ move: E => /eqP E. - assert (hinj : injective (translate_var fn)) by admit. - apply hinj in E. subst. - get_heap_simpl; simpl. - move: eset => /set_varP eset. - apply eset. all: clear eset. - ** intros v'' ev' er. subst. - rewrite Fv.setP_eq in H. noconf H. - unfold truncate_val in trunc. - destruct of_val eqn:ev. 2: discriminate. - simpl in trunc. noconf trunc. - (* assert (to_val v0 = v') by admit. *) (* truncate twice (are the types equal though?) *) - (* subst. rewrite translate_value_to_val. - rewrite coerce_to_choice_type_K. *) - give_up. - ** intros. subst. - rewrite Fv.setP_eq in H. - unfold undef_addr in H. - destruct (vtype yl) eqn:e. all: try noconf H. - discriminate H0. - ++ rewrite get_set_heap_neq. - 2: { - apply /eqP. move: E => /eqP E. assumption. - } - apply rv. rewrite -H. - eapply set_varP. 3: exact eset. - ** intros. subst. - symmetry. - eapply (@Fv.setP_neq _ (evm es₁) _ i). - unshelve apply /eqP. move: E => /eqP E. - assert (injective (translate_var fn)) by admit. - unfold injective in H0. - intro. - epose (H1 yl i). - clearbody e. - subst. apply E. reflexivity. - ** intros. - unfold set_var in eset. - subst. - destruct yl. - destruct v_var. destruct vtype0. - { - - simpl in *. - noconf eset. - symmetry. - eapply (@Fv.setP_neq _ (evm es₁) _ i). - unshelve apply /eqP. move: E => /eqP E. - assert (injective (translate_var fn)) by admit. - unfold injective in H2. - intro. subst. eauto. - } - all: discriminate. *) - (* unfold rel_vmap in *. *) - (* intros. simpl. *) - (* Search set_var. *) - (* unfold set_var in eset. *) - (* destruct (is_sbool (vtype y)). *) - (* --- simpl in eset. *) - (* unfold on_vu in eset. *) - (* noconf eset. *) - (* apply hvmap in H. *) - - (* apply hvmap. *) + admit. + admit. + admit. From 444f7f07fa8996167afdcd71b15c951466946c5b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Fri, 1 Apr 2022 16:16:31 +0200 Subject: [PATCH 071/383] Split translate_truncate in two useful lemmas --- theories/Jasmin/jasmin_translate.v | 44 +++++++++++++++++++----------- 1 file changed, 28 insertions(+), 16 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index a305ed35..a3d2735f 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -693,22 +693,17 @@ Proof. simpl. intuition eauto. Qed. -Lemma translate_truncate : - ∀ (c : typed_code) (ty : stype) v v' p q, - truncate_val ty v = ok v' → - c.π1 = choice_type_of_val v → - ⊢ ⦃ p ⦄ c.π2 ⇓ coerce_to_choice_type _ (translate_value v) ⦃ q ⦄ → - ⊢ ⦃ p ⦄ (truncate_code ty c).π2 ⇓ coerce_to_choice_type _ (translate_value v') ⦃ q ⦄. +Lemma translate_truncate_val : + ∀ ty v v', + truncate_val ty v = ok v' → + truncate_el ty (translate_value v) = + coerce_to_choice_type (encode ty) (translate_value v'). Proof. - intros c ty v v' p q hv e h. - destruct c as [ty' c]. simpl in *. subst. - eapply u_bind. 1: eapply h. - eapply u_ret. intros m hm. - split. 1: assumption. - unfold truncate_val in hv. + intros ty v v' h. + unfold truncate_val in h. destruct of_val as [vx |] eqn:e. 2: discriminate. - simpl in hv. noconf hv. - clear h. destruct ty, v. all: simpl in e. all: try discriminate. + simpl in h. noconf h. + destruct ty, v. all: simpl in e. all: try discriminate. all: try solve [ lazymatch type of e with | match ?t with _ => _ end = _ => destruct t ; discriminate @@ -723,6 +718,22 @@ Proof. rewrite e. reflexivity. Qed. +Lemma translate_truncate_code : + ∀ (c : typed_code) (ty : stype) v v' p q, + truncate_val ty v = ok v' → + c.π1 = choice_type_of_val v → + ⊢ ⦃ p ⦄ c.π2 ⇓ coerce_to_choice_type _ (translate_value v) ⦃ q ⦄ → + ⊢ ⦃ p ⦄ (truncate_code ty c).π2 ⇓ coerce_to_choice_type _ (translate_value v') ⦃ q ⦄. +Proof. + intros c ty v v' p q hv e h. + destruct c as [ty' c]. simpl in *. subst. + eapply u_bind. 1: eapply h. + eapply u_ret. intros m hm. + split. 1: assumption. + rewrite coerce_to_choice_type_K. + apply translate_truncate_val. assumption. +Qed. + Lemma translate_pexpr_type fn s₁ e v : sem_pexpr gd s₁ e = ok v → (translate_pexpr fn e).π1 = choice_type_of_val v. @@ -1061,7 +1072,7 @@ Proof. eapply u_bind. * { eapply u_bind. - - eapply translate_truncate. + - eapply translate_truncate_code. + eassumption. + eapply translate_pexpr_type. eassumption. + eapply translate_pexpr_correct_new. assumption. @@ -1089,7 +1100,8 @@ Proof. * subst. rewrite Fv.setP_eq in ei. noconf ei. rewrite get_set_heap_eq. - (* Should be embedded in the translate_truncate proof *) + eapply translate_truncate_val in trunc. + (* Are we missing one truncation in the goal? *) admit. * rewrite Fv.setP_neq in ei. 2:{ apply /eqP. eauto. } From ac29291e81edc26fd3a141046b20e0d69a660c75 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Fri, 1 Apr 2022 16:23:55 +0200 Subject: [PATCH 072/383] Define translate_of_val --- theories/Jasmin/jasmin_translate.v | 25 ++++++++++++++++++------- 1 file changed, 18 insertions(+), 7 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index a3d2735f..726ad9d5 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -693,16 +693,13 @@ Proof. simpl. intuition eauto. Qed. -Lemma translate_truncate_val : +Lemma translate_of_val : ∀ ty v v', - truncate_val ty v = ok v' → + of_val ty v = ok v' → truncate_el ty (translate_value v) = - coerce_to_choice_type (encode ty) (translate_value v'). + coerce_to_choice_type (encode ty) (translate_value (to_val v')). Proof. - intros ty v v' h. - unfold truncate_val in h. - destruct of_val as [vx |] eqn:e. 2: discriminate. - simpl in h. noconf h. + intros ty v v' e. destruct ty, v. all: simpl in e. all: try discriminate. all: try solve [ lazymatch type of e with @@ -718,6 +715,19 @@ Proof. rewrite e. reflexivity. Qed. +Lemma translate_truncate_val : + ∀ ty v v', + truncate_val ty v = ok v' → + truncate_el ty (translate_value v) = + coerce_to_choice_type (encode ty) (translate_value v'). +Proof. + intros ty v v' h. + unfold truncate_val in h. + destruct of_val as [vx |] eqn:e. 2: discriminate. + simpl in h. noconf h. + apply translate_of_val. assumption. +Qed. + Lemma translate_truncate_code : ∀ (c : typed_code) (ty : stype) v v' p q, truncate_val ty v = ok v' → @@ -1101,6 +1111,7 @@ Proof. rewrite Fv.setP_eq in ei. noconf ei. rewrite get_set_heap_eq. eapply translate_truncate_val in trunc. + eapply translate_of_val in hv₁. (* Are we missing one truncation in the goal? *) admit. * rewrite Fv.setP_neq in ei. From 3ff501a8178c8a769ebbfb117ea4f68ae5d1255e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Fri, 1 Apr 2022 16:32:29 +0200 Subject: [PATCH 073/383] Prove coerce_to_choice_type_translate_value_to_val --- theories/Jasmin/jasmin_translate.v | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 726ad9d5..5635f014 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -805,6 +805,16 @@ Proof with try discriminate; simpl in *. destruct b; noconf H; by rewrite type_of_to_val. Admitted. +Lemma coerce_to_choice_type_translate_value_to_val : + ∀ ty (v : sem_t ty), + coerce_to_choice_type (encode ty) (translate_value (to_val v)) = + embed v. +Proof. + intros ty v. + destruct ty. + all: simpl. all: rewrite coerce_to_choice_type_K. all: reflexivity. +Qed. + Lemma translate_pexpr_correct_new : ∀ fn (e : pexpr) s₁ v, sem_pexpr gd s₁ e = ok v → @@ -843,9 +853,8 @@ Proof. destruct hm as [hm hv]. apply hv in e1. rewrite e1. clear e1. simpl. rewrite coerce_to_choice_type_K. - set (ty := vtype gx) in *. clearbody ty. - destruct ty. - all: simpl. all: rewrite coerce_to_choice_type_K. all: reflexivity. + rewrite coerce_to_choice_type_translate_value_to_val. + reflexivity. Admitted. Lemma translate_pexpr_correct : From 156fe75f738ff85bd70061b573a6b97fccb29a32 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Fri, 1 Apr 2022 16:35:06 +0200 Subject: [PATCH 074/383] State and use injective_translate_var --- theories/Jasmin/jasmin_translate.v | 19 +++++++++++++++++-- 1 file changed, 17 insertions(+), 2 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 5635f014..5540f8a8 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1066,6 +1066,11 @@ Proof. WRONG, should just have coercion in the conclusions, including the value Abort. *) +Lemma injective_translate_var : + ∀ fn, injective (translate_var fn). +Proof. +Admitted. + (* TODO Make fixpoint too! *) Lemma translate_instr_r_correct : ∀ (fn : funname) (i : instr_r) (s₁ s₂ : estate), @@ -1125,7 +1130,12 @@ Proof. admit. * rewrite Fv.setP_neq in ei. 2:{ apply /eqP. eauto. } - rewrite get_set_heap_neq. 2: admit. (* Injectivity *) + rewrite get_set_heap_neq. + 2:{ + apply /eqP. intro e. + apply injective_translate_var in e. + contradiction. + } eapply hv in ei. rewrite ei. rewrite coerce_to_choice_type_K. reflexivity. + intros hbo hyl hset. @@ -1136,7 +1146,12 @@ Proof. clear - ei hbo. destruct (vtype yl). all: discriminate. * rewrite Fv.setP_neq in ei. 2:{ apply /eqP. eauto. } - rewrite get_set_heap_neq. 2: admit. (* Injectivity *) + rewrite get_set_heap_neq. + 2:{ + apply /eqP. intro e. + apply injective_translate_var in e. + contradiction. + } eapply hv in ei. rewrite ei. rewrite coerce_to_choice_type_K. reflexivity. } From 8c9024a046b9f338bf71192e8a82285f33bd8606 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Fri, 1 Apr 2022 16:38:19 +0200 Subject: [PATCH 075/383] translate_gvar_correct --- theories/Jasmin/jasmin_translate.v | 36 ++++++++++++++++++++++++++++++ 1 file changed, 36 insertions(+) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 416d733f..6767f27d 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -693,6 +693,42 @@ Proof. simpl. intuition eauto. Qed. +Lemma translate_gvar_correct (f : funname) (x : gvar) (v : value) vm : + get_gvar gd vm x = ok v -> + ⊢ ⦃ rel_vmap vm f ⦄ + (translate_gvar f x).π2 ⇓ coerce_to_choice_type _ (translate_value v) + ⦃ rel_vmap vm f ⦄. +Proof. + intros. + unfold translate_gvar. + unfold get_gvar in H. + destruct is_lvar. + - simpl in *. + eapply u_get_remember. + intros. + eapply u_ret. + intros h []. + split. + + assumption. + + unfold u_get in H1. + unfold get_var in H. + unfold on_vu in H. destruct Fv.get as [sx | e] eqn:e1. + 2:{ destruct e. all: discriminate. } + noconf H. + apply H0 in e1. subst. + rewrite e1. + clear e1. + simpl. + rewrite coerce_to_choice_type_K. + destruct (vtype (gv x)); + rewrite coerce_to_choice_type_K; reflexivity. + - simpl in *. + destruct get_global; [|discriminate]. + eapply u_ret. + intros. + noconf H. split; [ assumption | reflexivity ]. +Qed. + Lemma translate_truncate : ∀ (c : typed_code) (ty : stype) v v' p q, truncate_val ty v = ok v' → From 64665f844618833379a8f61c6f1248f444167c2e Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Fri, 1 Apr 2022 17:01:10 +0200 Subject: [PATCH 076/383] unary pre and post weaken rules --- theories/Jasmin/jasmin_translate.v | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index fc7b8e57..f966e532 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -693,6 +693,30 @@ Proof. simpl. intuition eauto. Qed. +(* Unary rpre_weaken_rule *) +Lemma upre_weaken_rule : + ∀ A (r : raw_code A) v (p1 p2 : heap -> Prop) q, + ⊢ ⦃ p1 ⦄ r ⇓ v ⦃ q ⦄ → (∀ h : heap, p2 h → p1 h) → ⊢ ⦃ p2 ⦄ r ⇓ v ⦃ q ⦄. +Proof. + intros. + eapply rpre_weaken_rule. + - eapply H. + - intros. apply H0. assumption. +Qed. + +(* Unary rpost_weaken_rule *) +Lemma upost_weaken_rule : + ∀ A (r : raw_code A) v p (q1 q2 : heap -> Prop), + ⊢ ⦃ p ⦄ r ⇓ v ⦃ q1 ⦄ → (∀ h : heap, q1 h → q2 h) → ⊢ ⦃ p ⦄ r ⇓ v ⦃ q2 ⦄. +Proof. + intros. + eapply rpost_weaken_rule. + - eapply H. + - intros [] []. split. + + apply H0. easy. + + easy. +Qed. + Lemma translate_gvar_correct (f : funname) (x : gvar) (v : value) vm : get_gvar gd vm x = ok v -> ⊢ ⦃ rel_vmap vm f ⦄ From 83e962093c6e0dfaa6b6f073bc6c77733958e74d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Fri, 1 Apr 2022 17:08:40 +0200 Subject: [PATCH 077/383] Style --- theories/Jasmin/jasmin_translate.v | 30 ++++++++++++++++-------------- 1 file changed, 16 insertions(+), 14 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index f966e532..57a12d4b 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -695,33 +695,35 @@ Qed. (* Unary rpre_weaken_rule *) Lemma upre_weaken_rule : - ∀ A (r : raw_code A) v (p1 p2 : heap -> Prop) q, - ⊢ ⦃ p1 ⦄ r ⇓ v ⦃ q ⦄ → (∀ h : heap, p2 h → p1 h) → ⊢ ⦃ p2 ⦄ r ⇓ v ⦃ q ⦄. + ∀ A (r : raw_code A) v (p1 p2 : heap → Prop) q, + ⊢ ⦃ p1 ⦄ r ⇓ v ⦃ q ⦄ → + (∀ h, p2 h → p1 h) → + ⊢ ⦃ p2 ⦄ r ⇓ v ⦃ q ⦄. Proof. - intros. + intros A r v p1 p2 q h hp. eapply rpre_weaken_rule. - - eapply H. - - intros. apply H0. assumption. + - eapply h. + - intros. apply hp. assumption. Qed. (* Unary rpost_weaken_rule *) Lemma upost_weaken_rule : - ∀ A (r : raw_code A) v p (q1 q2 : heap -> Prop), - ⊢ ⦃ p ⦄ r ⇓ v ⦃ q1 ⦄ → (∀ h : heap, q1 h → q2 h) → ⊢ ⦃ p ⦄ r ⇓ v ⦃ q2 ⦄. + ∀ A (r : raw_code A) v p (q1 q2 : heap → Prop), + ⊢ ⦃ p ⦄ r ⇓ v ⦃ q1 ⦄ → + (∀ h, q1 h → q2 h) → + ⊢ ⦃ p ⦄ r ⇓ v ⦃ q2 ⦄. Proof. - intros. + intros A r v p q1 q2 h hq. eapply rpost_weaken_rule. - - eapply H. - - intros [] []. split. - + apply H0. easy. - + easy. + - eapply h. + - intros [] []. intuition eauto. Qed. Lemma translate_gvar_correct (f : funname) (x : gvar) (v : value) vm : - get_gvar gd vm x = ok v -> + get_gvar gd vm x = ok v → ⊢ ⦃ rel_vmap vm f ⦄ (translate_gvar f x).π2 ⇓ coerce_to_choice_type _ (translate_value v) - ⦃ rel_vmap vm f ⦄. + ⦃ rel_vmap vm f ⦄. Proof. intros. unfold translate_gvar. From 09d759ec911b8fa3ab249e71795d8e86ef4d7c2f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Fri, 1 Apr 2022 17:43:11 +0200 Subject: [PATCH 078/383] Define translate_write_var --- theories/Jasmin/jasmin_translate.v | 81 ++++++++++++++---------------- 1 file changed, 38 insertions(+), 43 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 57a12d4b..09295408 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -193,17 +193,37 @@ Proof. apply cast_typed_code_K. Qed. -Definition ssprove_write_lval (fn : funname) (l : lval) (tc : typed_code) - : raw_code chUnit +Definition typed_chElement := + pointed_value. + +Definition choice_type_of_val (val : value) : choice_type := + encode (type_of_val val). + +Definition translate_value (v : value) : choice_type_of_val v. +Proof. + destruct v as [b | z | size a | size wd | undef_ty]. + - apply embed. exact b. + - apply embed. exact z. + - apply embed. exact a. + - apply embed. exact wd. + - apply chCanonical. + (* It shouldn't matter which value we pick, because when coercing an undef + value at type ty back to ty via to_{bool,int,word,arr} (defined in + values.v), all of these functions raise an error on Vundef. *) +Defined. + +Definition translate_write_var (fn : funname) (x : var_i) (v : typed_code) := + let l := translate_var fn (v_var x) in + x ← (truncate_code x.(vtype) v).π2 ;; + #put l := x ;; + ret tt. + +Definition translate_write_lval (fn : funname) (l : lval) (v : typed_code) + : raw_code 'unit := match l with | Lnone _ ty => ret tt - | Lvar x => - (* write_var x v s *) - let l := translate_var fn (v_var x) in - let c' := truncate_code x.(vtype) tc in - let c := coerce_typed_code l c' in - (x ← c ;; #put l := x ;; ret tt)%pack + | Lvar x => translate_write_var fn x v | _ => unsupported.π2 (* | Lmem sz x e => *) (* Let vx := get_var (evm s) x >>= to_pointer in *) @@ -237,25 +257,6 @@ Proof. exact [::]. (* TODO *) Defined. *) -Definition typed_chElement := - pointed_value. - -Definition choice_type_of_val (val : value) : choice_type := - encode (type_of_val val). - -Definition translate_value (v : value) : choice_type_of_val v. -Proof. - destruct v as [b | z | size a | size wd | undef_ty]. - - apply embed. exact b. - - apply embed. exact z. - - apply embed. exact a. - - apply embed. exact wd. - - apply chCanonical. - (* It shouldn't matter which value we pick, because when coercing an undef - value at type ty back to ty via to_{bool,int,word,arr} (defined in - values.v), all of these functions raise an error on Vundef. *) -Defined. - Definition translate_gvar (f : funname) (x : gvar) : typed_code := if is_lvar x then (_ ; x ← get (translate_var f x.(gv).(v_var)) ;; ret x) @@ -421,7 +422,7 @@ Proof. (* l :a=_s p *) pose (translate_pexpr fn p) as tr_p. pose (truncate_code s tr_p) as tr_p'. - exact (ssprove_write_lval fn l tr_p'). + exact (translate_write_lval fn l tr_p'). - exact (unsupported.π2). (* Copn *) - (* Cif e c1 c2 *) pose (e' := translate_pexpr fn e). @@ -1151,35 +1152,28 @@ Proof. all: noconf hw. all: assumption. * unfold on_vu in hw. destruct of_val as [| []]. all: noconf hw. assumption. - + simpl. simpl in hw. unfold write_var in hw. + + simpl. unfold translate_write_var. simpl in hw. unfold write_var in hw. destruct set_var eqn:eset. 2: discriminate. simpl in hw. noconf hw. - rewrite coerce_typed_code_K. + simpl. rewrite !bind_assoc. simpl. eapply u_bind. + * eapply translate_pexpr_correct_new. eassumption. * { - eapply u_bind. - - eapply translate_truncate_code. - + eassumption. - + eapply translate_pexpr_type. eassumption. - + eapply translate_pexpr_correct_new. assumption. - - apply u_ret_eq. eauto. - } - * { - simpl. + erewrite translate_pexpr_type. 2: eassumption. clear sem_e tag e. eapply u_put. apply u_ret_eq. intros m' [m [hm e]]. subst. destruct hm as [hm hv]. split. - - simpl. unfold rel_mem. + - unfold rel_mem. intros ptr sz w hrw. rewrite get_set_heap_neq. 2: apply ptr_var_neq. apply hm. assumption. - simpl. unfold rel_vmap. intros i vi ei. - simpl. rewrite coerce_to_choice_type_K. - eapply set_varP. 3: exact eset. all: clear eset. + simpl. rewrite !coerce_to_choice_type_K. + eapply set_varP. 3: exact eset. (* all: clear eset. *) + intros v₁ hv₁ eyl. subst. destruct (i == yl) eqn:evar. all: move: evar => /eqP evar. @@ -1188,7 +1182,8 @@ Proof. rewrite get_set_heap_eq. eapply translate_truncate_val in trunc. eapply translate_of_val in hv₁. - (* Are we missing one truncation in the goal? *) + rewrite trunc. + (* Did I lose info? Like sty = type_of_val v' *) admit. * rewrite Fv.setP_neq in ei. 2:{ apply /eqP. eauto. } From 67345e664fb38ef7da242bc0adc67a474143b48c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Fri, 1 Apr 2022 17:47:12 +0200 Subject: [PATCH 079/383] Prove write_lval case of translate_instr_r_correct --- theories/Jasmin/jasmin_translate.v | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 09295408..ddb7d488 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1134,6 +1134,18 @@ Lemma injective_translate_var : Proof. Admitted. +Lemma truncate_val_type : + ∀ ty v v', + truncate_val ty v = ok v' → + type_of_val v' = ty. +Proof. + intros ty v v' e. + unfold truncate_val in e. + destruct of_val eqn:ev. 2: discriminate. + simpl in e. noconf e. + apply type_of_to_val. +Qed. + (* TODO Make fixpoint too! *) Lemma translate_instr_r_correct : ∀ (fn : funname) (i : instr_r) (s₁ s₂ : estate), @@ -1180,11 +1192,11 @@ Proof. * subst. rewrite Fv.setP_eq in ei. noconf ei. rewrite get_set_heap_eq. + apply truncate_val_type in trunc as ety. subst. eapply translate_truncate_val in trunc. eapply translate_of_val in hv₁. - rewrite trunc. - (* Did I lose info? Like sty = type_of_val v' *) - admit. + rewrite trunc. rewrite coerce_to_choice_type_K. + rewrite hv₁. apply coerce_to_choice_type_translate_value_to_val. * rewrite Fv.setP_neq in ei. 2:{ apply /eqP. eauto. } rewrite get_set_heap_neq. From 521f82dafba06f5b2f03df6f8c838b1bd57c5cb2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Fri, 1 Apr 2022 17:49:22 +0200 Subject: [PATCH 080/383] Move truncate_val_type up --- theories/Jasmin/jasmin_translate.v | 36 +++++++++++++++--------------- 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index ddb7d488..4ee3efa8 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -22,6 +22,12 @@ Set Bullet Behavior "Strict Subproofs". Set Default Goal Selector "!". Set Primitive Projections. +Derive NoConfusion for result. +Derive NoConfusion for value. +Derive NoConfusion for wsize. +Derive NoConfusion for CoqWord.word.word. +Derive EqDec for wsize. + Section Translation. Context `{asmop : asmOp}. @@ -88,6 +94,18 @@ Definition typed_code := #[local] Definition unsupported : typed_code := ('unit ; assert false). +Lemma truncate_val_type : + ∀ ty v v', + truncate_val ty v = ok v' → + type_of_val v' = ty. +Proof. + intros ty v v' e. + unfold truncate_val in e. + destruct of_val eqn:ev. 2: discriminate. + simpl in e. noconf e. + apply type_of_to_val. +Qed. + (* from pkg_invariants *) Definition cast_ct_val {t t' : choice_type} (e : t = t') (v : t) : t'. Proof. @@ -593,12 +611,6 @@ Proof. apply cast_ct_val_K. Qed. -Derive NoConfusion for result. -Derive NoConfusion for value. -Derive NoConfusion for wsize. -Derive NoConfusion for CoqWord.word.word. -Derive EqDec for wsize. - (* Unary judgment concluding on evaluation of program *) Definition eval_jdg {A : choiceType} @@ -1134,18 +1146,6 @@ Lemma injective_translate_var : Proof. Admitted. -Lemma truncate_val_type : - ∀ ty v v', - truncate_val ty v = ok v' → - type_of_val v' = ty. -Proof. - intros ty v v' e. - unfold truncate_val in e. - destruct of_val eqn:ev. 2: discriminate. - simpl in e. noconf e. - apply type_of_to_val. -Qed. - (* TODO Make fixpoint too! *) Lemma translate_instr_r_correct : ∀ (fn : funname) (i : instr_r) (s₁ s₂ : estate), From 3fbcd4dfa7f09fae2e2fa4032b3c5f0846cd8e6e Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Fri, 1 Apr 2022 20:17:21 +0200 Subject: [PATCH 081/383] progress on array case of translate_pexpr_correct restated `translate_gvar_correct` --- theories/Jasmin/jasmin_translate.v | 90 ++++++++++++++++++++++++++++-- 1 file changed, 85 insertions(+), 5 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index f966e532..6fb5eb04 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -717,11 +717,11 @@ Proof. + easy. Qed. -Lemma translate_gvar_correct (f : funname) (x : gvar) (v : value) vm : - get_gvar gd vm x = ok v -> - ⊢ ⦃ rel_vmap vm f ⦄ +Lemma translate_gvar_correct (f : funname) (x : gvar) (v : value) s : + get_gvar gd (evm s) x = ok v -> + ⊢ ⦃ rel_estate s f ⦄ (translate_gvar f x).π2 ⇓ coerce_to_choice_type _ (translate_value v) - ⦃ rel_vmap vm f ⦄. + ⦃ rel_estate s f ⦄. Proof. intros. unfold translate_gvar. @@ -865,6 +865,51 @@ Proof with try discriminate; simpl in *. destruct b; noconf H; by rewrite type_of_to_val. Admitted. +Lemma mapM_nil {eT aT bT} f l : @mapM eT aT bT f l = ok [::] -> l = [::]. +Proof. + induction l; intros. + - reflexivity. + - simpl in H. + destruct f. 2: discriminate. + destruct mapM; discriminate. +Qed. + +Lemma chArray_get_correct (len : BinNums.positive) (a : WArray.array len) (z z0 : Z) ws aa s : + to_int z0 = ok z -> + WArray.get aa ws a z = ok s -> + chArray_get ws (translate_value (Varr a)) (translate_value z0) (mk_scale aa ws) = translate_value (Vword s). +Proof. + Search WArray.get. + intros. + destruct to_int. 2: discriminate. + noconf H. + simpl in *. + unfold WArray.get in H0. + unfold read in H0. + destruct is_align. 2: discriminate. + simpl in H0. + destruct mapM eqn:E. 2: discriminate. + simpl in H0. + noconf H0. + unfold chArray_get. + f_equal. + revert l E. + apply ziota_ind. + - simpl. + intros. + noconf E. reflexivity. + - intros. + destruct l0. + { apply mapM_nil in E. discriminate. } + apply mapM_cons in E as []. + simpl. + rewrite (H0 l0). 2: assumption. + apply f_equal2. 2: reflexivity. + + (* What remains to prove should perhaps be a lemma like `chArray_get8_correct` *) + + Admitted. + Lemma coerce_to_choice_type_translate_value_to_val : ∀ ty (v : sem_t ty), coerce_to_choice_type (encode ty) (translate_value (to_val v)) = @@ -911,10 +956,45 @@ Proof. intros m [hm e]. unfold u_get in e. subst. split. 1: auto. destruct hm as [hm hv]. - apply hv in e1. rewrite e1. clear e1. + apply hv in e1. rewrite e1. simpl. rewrite coerce_to_choice_type_K. rewrite coerce_to_choice_type_translate_value_to_val. reflexivity. + + simpl. + rewrite h1. + apply u_ret. auto. + - simpl in *. + destruct get_gvar eqn:E00. 2: discriminate. + destruct v0. all: try discriminate. + destruct sem_pexpr eqn:E. 2: discriminate. + simpl in h1. + destruct to_int eqn:E0. 2: discriminate. + simpl in h1. + destruct WArray.get eqn:E2. 2: discriminate. + simpl in h1. noconf h1. + rewrite coerce_to_choice_type_K. + apply IHe in E as E3. + eapply u_bind. + + apply translate_gvar_correct. + eassumption. + + rewrite !bind_assoc. + eapply u_bind. + * apply E3. + * eapply u_ret. + intros. split; [assumption|]. + apply translate_pexpr_type with (fn:=fn) in E as typ. + rewrite typ. + rewrite coerce_to_choice_type_K. + destruct v0. all: try discriminate. + ** rewrite !coerce_to_choice_type_K. + assert ((translate_gvar fn x).π1 = encode (sarr len)). + *** admit. (* this should be provable (`translate_gvar_type`) *) + *** rewrite H0. + rewrite !coerce_to_choice_type_K. + simpl. + apply (chArray_get_correct _ _ _ _ _ _ _ E0 E2). (* TODO: prove this lemma *) + ** destruct t. all: discriminate. + - Admitted. Lemma translate_pexpr_correct : From 59e37b30e651a85c914948b2ecdda11c706573e7 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Sat, 2 Apr 2022 17:00:12 +0200 Subject: [PATCH 082/383] proved `chArray_get_correct` proved general connection between chArray and WArray (`fold_get`) --- theories/Jasmin/jasmin_translate.v | 148 +++++++++++++++++++++++------ 1 file changed, 121 insertions(+), 27 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 9da6251f..00efbce7 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -59,6 +59,103 @@ Definition embed {t} : sem_t t → encode t := | sword n => λ x, x end. +Lemma elementsNIn : + ∀ (T : Type) (k : Z) (v : T) (m : Mz.Map.t T), Mz.get m k = None -> ~ List.In (k, v) (Mz.elements m). +Proof. + intros S k v m H contra. + apply Mz.elementsIn in contra. + rewrite H in contra. + discriminate. +Qed. + +Lemma In_rcons {A} x y (l : seq A) : + List.In x (rcons l y) -> y = x \/ List.In x l. +Proof. + induction l; intros; simpl in *; intuition subst. +Qed. + +Lemma NIn_rcons {A} x y (l : seq A) : + ~ List.In x (rcons l y) -> y <> x /\ ~ List.In x l. +Proof. + induction l; intros; simpl in *; intuition subst. +Qed. + +Lemma foldl_In_uniq {S : eqType} (k : Mz.K.t) (v : S) (data : seq (Mz.K.t * S)) : + List.In (k, v) data -> + @uniq Mz.K.t [seq i.1 | i <- data] -> + foldl (λ (a : {fmap Mz.K.t → S}) (kv : Mz.K.t * S), setm a kv.1 kv.2) emptym data k = Some v. +Proof. + intros. + replace data with (rev (rev data)) in * by apply revK. + set (data' := rev data) in *. + induction data'. + - easy. + - rewrite rev_cons. + rewrite rev_cons in H. + apply In_rcons in H. + rewrite foldl_rcons. + destruct H. + + subst. simpl. + rewrite setmE. + rewrite eq_refl. + reflexivity. + + rewrite rev_cons in H0. + rewrite map_rcons in H0. + rewrite rcons_uniq in H0. + move: H0 => /andP [H1 H2]. + move: H1 => /in_map H3. + assert (negb (@eq_op Z_ordType k a.1)). { + apply /eqP => contra; case: H3; exists (a.1, v); by move: contra <-. }. + rewrite setmE. + rewrite <- negbK. + rewrite H0. + simpl. + apply IHdata'; assumption. +Qed. + +Lemma foldl_NIn {S : eqType} (k : Mz.K.t) (data : seq (Mz.K.t * S)) : + (forall w, ~ List.In (k, w) data) -> + foldl (λ (a : {fmap Mz.K.t → S}) (kv : Mz.K.t * S), setm a kv.1 kv.2) emptym data k = None. +Proof. + intros. + replace data with (rev (rev data)) in * by apply revK. + set (data' := rev data) in *. + induction data'. + - easy. + - rewrite rev_cons. + rewrite rev_cons in H. + specialize (H a.2) as H0. + rewrite foldl_rcons. + apply NIn_rcons in H0 as [H1]. + assert (negb (@eq_op Z_ordType k a.1)). { + apply /eqP => contra. apply H1. move: contra ->. apply surjective_pairing. } + rewrite setmE. + rewrite <- negbK. + rewrite H2. + simpl. + apply IHdata'. + intros. + specialize (H w). + apply NIn_rcons in H. easy. +Qed. + +Lemma fold_get {S : eqType} (data : Mz.Map.t S) i : + Mz.fold (λ k v m, setm m k v) data emptym i = Mz.get data i. +Proof. + rewrite Mz.foldP. + destruct Mz.get eqn:E. + - set (kv := (i, s)). + replace i with kv.1 in * by reflexivity. + replace s with kv.2 in * by reflexivity. + apply Mz.elementsIn in E. subst kv. + eapply foldl_In_uniq. + + assumption. + + apply Mz.elementsU. + - assert (forall v, ~ List.In (i, v) (Mz.elements data)). + + intros. apply elementsNIn with (v:=v) in E. assumption. + + apply foldl_NIn. assumption. +Qed. + Definition unembed {t : stype} : encode t → sem_t t := match t return encode t → sem_t t with | sbool => λ x, x @@ -290,7 +387,7 @@ Definition chArray_get ws (a : 'array) ptr scale := (* Jasmin fails if ptr is not aligned; we may not need it. *) (* if negb (is_align ptr sz) then chCanonical ws else *) let f k := - match a (scale * ptr + k)%Z with + match a (ptr * scale + k)%Z with | None => chCanonical ('word U8) | Some x => x end @@ -889,41 +986,37 @@ Proof. destruct mapM; discriminate. Qed. -Lemma chArray_get_correct (len : BinNums.positive) (a : WArray.array len) (z z0 : Z) ws aa s : - to_int z0 = ok z -> +Lemma chArray_get_correct (len : BinNums.positive) (a : WArray.array len) (z : Z) ws aa s : WArray.get aa ws a z = ok s -> - chArray_get ws (translate_value (Varr a)) (translate_value z0) (mk_scale aa ws) = translate_value (Vword s). + chArray_get ws (translate_value (Varr a)) z (mk_scale aa ws) = translate_value (Vword s). Proof. - Search WArray.get. - intros. - destruct to_int. 2: discriminate. - noconf H. + intros H. simpl in *. - unfold WArray.get in H0. - unfold read in H0. + unfold WArray.get, read in H. destruct is_align. 2: discriminate. - simpl in H0. + simpl in H. destruct mapM eqn:E. 2: discriminate. - simpl in H0. - noconf H0. + noconf H. unfold chArray_get. f_equal. revert l E. apply ziota_ind. - - simpl. - intros. - noconf E. reflexivity. - - intros. + - intros l E. noconf E. reflexivity. + - intros i l E IH l0 H. destruct l0. - { apply mapM_nil in E. discriminate. } - apply mapM_cons in E as []. + { apply mapM_nil in H. discriminate. } + apply mapM_cons in H as [H H0]. simpl. - rewrite (H0 l0). 2: assumption. + rewrite (IH l0). 2: assumption. apply f_equal2. 2: reflexivity. - - (* What remains to prove should perhaps be a lemma like `chArray_get8_correct` *) - - Admitted. + unfold WArray.get8 in H. + destruct WArray.in_bound. 2: discriminate. + destruct WArray.is_init. 2: discriminate. + noconf H. + unfold odflt, oapp. + rewrite <- fold_get. + reflexivity. +Qed. Lemma coerce_to_choice_type_translate_value_to_val : ∀ ty (v : sem_t ty), @@ -986,7 +1079,7 @@ Proof. destruct to_int eqn:E0. 2: discriminate. simpl in h1. destruct WArray.get eqn:E2. 2: discriminate. - simpl in h1. noconf h1. + noconf h1. rewrite coerce_to_choice_type_K. apply IHe in E as E3. eapply u_bind. @@ -1005,9 +1098,10 @@ Proof. assert ((translate_gvar fn x).π1 = encode (sarr len)). *** admit. (* this should be provable (`translate_gvar_type`) *) *** rewrite H0. + noconf E0. rewrite !coerce_to_choice_type_K. - simpl. - apply (chArray_get_correct _ _ _ _ _ _ _ E0 E2). (* TODO: prove this lemma *) + apply chArray_get_correct. + assumption. ** destruct t. all: discriminate. - Admitted. From 611c8870184196430b5b77673ba727291cddd156 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Sat, 2 Apr 2022 18:35:22 +0200 Subject: [PATCH 083/383] simplify and prove `admit` --- theories/Jasmin/jasmin_translate.v | 27 ++++++++++++++++++--------- 1 file changed, 18 insertions(+), 9 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 00efbce7..6a3524d2 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -829,6 +829,17 @@ Proof. - intros [] []. intuition eauto. Qed. +Lemma translate_gvar_type fn vm v x : + get_gvar gd vm x = ok v -> + (translate_gvar fn x).π1 = encode (type_of_val v). +Proof. + intros H. + apply type_of_get_gvar in H. + rewrite H. + unfold translate_gvar. + now destruct is_lvar. +Qed. + Lemma translate_gvar_correct (f : funname) (x : gvar) (v : value) s : get_gvar gd (evm s) x = ok v -> ⊢ ⦃ rel_estate s f ⦄ @@ -1094,15 +1105,13 @@ Proof. rewrite typ. rewrite coerce_to_choice_type_K. destruct v0. all: try discriminate. - ** rewrite !coerce_to_choice_type_K. - assert ((translate_gvar fn x).π1 = encode (sarr len)). - *** admit. (* this should be provable (`translate_gvar_type`) *) - *** rewrite H0. - noconf E0. - rewrite !coerce_to_choice_type_K. - apply chArray_get_correct. - assumption. - ** destruct t. all: discriminate. + 2: { destruct t. all: discriminate. } + rewrite !coerce_to_choice_type_K. + rewrite (translate_gvar_type _ (evm s1) (Varr a)); [|assumption]. + rewrite !coerce_to_choice_type_K. + apply chArray_get_correct. + noconf E0. + assumption. - Admitted. From f659f81499511e0c874541933795c732dc3bafc8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Mon, 4 Apr 2022 11:03:45 +0200 Subject: [PATCH 084/383] Fix build and style --- theories/Jasmin/jasmin_translate.v | 47 ++++++++++++++++++------------ 1 file changed, 29 insertions(+), 18 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 6a3524d2..582a67a3 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -60,7 +60,9 @@ Definition embed {t} : sem_t t → encode t := end. Lemma elementsNIn : - ∀ (T : Type) (k : Z) (v : T) (m : Mz.Map.t T), Mz.get m k = None -> ~ List.In (k, v) (Mz.elements m). + ∀ (T : Type) (k : Z) (v : T) (m : Mz.Map.t T), + Mz.get m k = None → + ~ List.In (k, v) (Mz.elements m). Proof. intros S k v m H contra. apply Mz.elementsIn in contra. @@ -69,20 +71,23 @@ Proof. Qed. Lemma In_rcons {A} x y (l : seq A) : - List.In x (rcons l y) -> y = x \/ List.In x l. + List.In x (rcons l y) → + y = x ∨ List.In x l. Proof. - induction l; intros; simpl in *; intuition subst. + intro h. + induction l in h |- *. all: simpl in *. all: intuition subst. Qed. Lemma NIn_rcons {A} x y (l : seq A) : - ~ List.In x (rcons l y) -> y <> x /\ ~ List.In x l. + ~ List.In x (rcons l y) → + y ≠ x ∧ ~ List.In x l. Proof. induction l; intros; simpl in *; intuition subst. Qed. Lemma foldl_In_uniq {S : eqType} (k : Mz.K.t) (v : S) (data : seq (Mz.K.t * S)) : - List.In (k, v) data -> - @uniq Mz.K.t [seq i.1 | i <- data] -> + List.In (k, v) data → + @uniq Mz.K.t [seq i.1 | i <- data] → foldl (λ (a : {fmap Mz.K.t → S}) (kv : Mz.K.t * S), setm a kv.1 kv.2) emptym data k = Some v. Proof. intros. @@ -105,7 +110,8 @@ Proof. move: H0 => /andP [H1 H2]. move: H1 => /in_map H3. assert (negb (@eq_op Z_ordType k a.1)). { - apply /eqP => contra; case: H3; exists (a.1, v); by move: contra <-. }. + apply /eqP => contra; case: H3; exists (a.1, v); by move: contra <-. + } rewrite setmE. rewrite <- negbK. rewrite H0. @@ -114,7 +120,7 @@ Proof. Qed. Lemma foldl_NIn {S : eqType} (k : Mz.K.t) (data : seq (Mz.K.t * S)) : - (forall w, ~ List.In (k, w) data) -> + (∀ w, ~ List.In (k, w) data) → foldl (λ (a : {fmap Mz.K.t → S}) (kv : Mz.K.t * S), setm a kv.1 kv.2) emptym data k = None. Proof. intros. @@ -830,7 +836,7 @@ Proof. Qed. Lemma translate_gvar_type fn vm v x : - get_gvar gd vm x = ok v -> + get_gvar gd vm x = ok v → (translate_gvar fn x).π1 = encode (type_of_val v). Proof. intros H. @@ -841,12 +847,12 @@ Proof. Qed. Lemma translate_gvar_correct (f : funname) (x : gvar) (v : value) s : - get_gvar gd (evm s) x = ok v -> + get_gvar gd (evm s) x = ok v → ⊢ ⦃ rel_estate s f ⦄ - (translate_gvar f x).π2 ⇓ coerce_to_choice_type _ (translate_value v) + (translate_gvar f x).π2 ⇓ coerce_to_choice_type _ (translate_value v) ⦃ rel_estate s f ⦄. Proof. - intros. + intros H. unfold translate_gvar. unfold get_gvar in H. destruct is_lvar. @@ -870,10 +876,12 @@ Proof. destruct (vtype (gv x)); rewrite coerce_to_choice_type_K; reflexivity. - simpl in *. - destruct get_global; [|discriminate]. + destruct get_global. 2: discriminate. eapply u_ret. intros. - noconf H. split; [ assumption | reflexivity ]. + noconf H. split. + + assumption. + + reflexivity. Qed. Lemma translate_of_val : @@ -988,17 +996,20 @@ Proof with try discriminate; simpl in *. destruct b; noconf H; by rewrite type_of_to_val. Admitted. -Lemma mapM_nil {eT aT bT} f l : @mapM eT aT bT f l = ok [::] -> l = [::]. +Lemma mapM_nil {eT aT bT} f l : + @mapM eT aT bT f l = ok [::] → + l = [::]. Proof. - induction l; intros. + intro H. + induction l in H |- *. - reflexivity. - simpl in H. destruct f. 2: discriminate. - destruct mapM; discriminate. + destruct mapM. all: discriminate. Qed. Lemma chArray_get_correct (len : BinNums.positive) (a : WArray.array len) (z : Z) ws aa s : - WArray.get aa ws a z = ok s -> + WArray.get aa ws a z = ok s → chArray_get ws (translate_value (Varr a)) z (mk_scale aa ws) = translate_value (Vword s). Proof. intros H. From 46c41426248dd4db5eab38970bd71545ec12f4c5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Mon, 4 Apr 2022 11:57:10 +0200 Subject: [PATCH 085/383] Define translate_get_var and use it in translate_gvar --- theories/Jasmin/jasmin_translate.v | 165 ++++++++++++----------------- 1 file changed, 66 insertions(+), 99 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 582a67a3..ba963165 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -339,20 +339,26 @@ Definition translate_write_var (fn : funname) (x : var_i) (v : typed_code) := #put l := x ;; ret tt. +Definition translate_get_var (f : funname) (x : var) : raw_code (encode x.(vtype)) := + x ← get (translate_var f x) ;; ret x. + Definition translate_write_lval (fn : funname) (l : lval) (v : typed_code) : raw_code 'unit := match l with | Lnone _ ty => ret tt | Lvar x => translate_write_var fn x v + | Lmem sz x e => + vx ← translate_get_var fn x ;; (* Missing to pointer *) + unsupported.π2 (* TODO *) | _ => unsupported.π2 - (* | Lmem sz x e => *) - (* Let vx := get_var (evm s) x >>= to_pointer in *) - (* Let ve := sem_pexpr s e >>= to_pointer in *) - (* let p := (vx + ve)%R in (* should we add the size of value, i.e vx + sz * se *) *) - (* Let w := to_word sz v in *) - (* Let m := write s.(emem) p w in *) - (* ok {| emem := m; evm := s.(evm) |} *) + (* | Lmem sz x e => + Let vx := get_var (evm s) x >>= to_pointer in + Let ve := sem_pexpr s e >>= to_pointer in + let p := (vx + ve)%R in (* should we add the size of value, i.e vx + sz * se *) + Let w := to_word sz v in + Let m := write s.(emem) p w in + ok {| emem := m; evm := s.(evm) |} *) (* | Laset aa ws x i => *) (* Let (n,t) := s.[x] in *) (* Let i := sem_pexpr s i >>= to_int in *) @@ -378,16 +384,15 @@ Proof. exact [::]. (* TODO *) Defined. *) -Definition translate_gvar (f : funname) (x : gvar) : typed_code := +Definition translate_gvar (f : funname) (x : gvar) : raw_code (encode x.(gv).(vtype)) := if is_lvar x - then (_ ; x ← get (translate_var f x.(gv).(v_var)) ;; ret x) - else ( - encode (vtype x.(gv)) ; + then translate_get_var f x.(gv).(v_var) + else match get_global gd x.(gv).(v_var) with | Ok v => ret (coerce_to_choice_type _ (translate_value v)) | _ => ret (chCanonical _) end - ). + . Definition chArray_get ws (a : 'array) ptr scale := (* Jasmin fails if ptr is not aligned; we may not need it. *) @@ -427,10 +432,10 @@ Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code := (* Parr_init only gets produced by ArrayInit() in jasmin source. *) (* The EC export asserts false on it. *) totc 'array (ret emptym) - | Pvar v => translate_gvar fn v + | Pvar v => totc _ (translate_gvar fn v) | Pget aa ws x e => totc ('word ws) ( - arr ← (translate_gvar fn x).π2 ;; (* Performs the lookup in gd *) + arr ← translate_gvar fn x ;; (* Performs the lookup in gd *) let a := coerce_to_choice_type 'array arr in i ← (truncate_code sint (translate_pexpr fn e)).π2 ;; (* to_int *) let scale := mk_scale aa ws in @@ -438,7 +443,7 @@ Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code := ) | Psub aa ws len x e => totc 'array ( - arr ← (translate_gvar fn x).π2 ;; (* Performs the lookup in gd *) + arr ← translate_gvar fn x ;; (* Performs the lookup in gd *) let a := coerce_to_choice_type 'array arr in i ← (truncate_code sint (translate_pexpr fn e)).π2 ;; (* to_int *) let scale := mk_scale aa ws in @@ -835,53 +840,51 @@ Proof. - intros [] []. intuition eauto. Qed. -Lemma translate_gvar_type fn vm v x : - get_gvar gd vm x = ok v → - (translate_gvar fn x).π1 = encode (type_of_val v). +Lemma coerce_to_choice_type_translate_value_to_val : + ∀ ty (v : sem_t ty), + coerce_to_choice_type (encode ty) (translate_value (to_val v)) = + embed v. Proof. - intros H. - apply type_of_get_gvar in H. - rewrite H. - unfold translate_gvar. - now destruct is_lvar. + intros ty v. + destruct ty. + all: simpl. all: rewrite coerce_to_choice_type_K. all: reflexivity. +Qed. + +Lemma translate_get_var_correct : + ∀ fn x s v, + get_var (evm s) x = ok v → + ⊢ ⦃ rel_estate s fn ⦄ + translate_get_var fn x ⇓ coerce_to_choice_type _ (translate_value v) + ⦃ rel_estate s fn ⦄. +Proof. + intros fn x s v ev. + unfold translate_get_var. + eapply u_get_remember. intros vx. + eapply u_ret. intros m [hm hx]. + split. 1: assumption. + unfold u_get in hx. unfold get_var in ev. + eapply on_vuP. 3: exact ev. 2: discriminate. + intros sx esx esv. + eapply hm in esx. subst. + rewrite coerce_to_choice_type_translate_value_to_val. + rewrite esx. rewrite coerce_to_choice_type_K. reflexivity. Qed. Lemma translate_gvar_correct (f : funname) (x : gvar) (v : value) s : get_gvar gd (evm s) x = ok v → ⊢ ⦃ rel_estate s f ⦄ - (translate_gvar f x).π2 ⇓ coerce_to_choice_type _ (translate_value v) + translate_gvar f x ⇓ coerce_to_choice_type _ (translate_value v) ⦃ rel_estate s f ⦄. Proof. - intros H. + intros ev. unfold translate_gvar. - unfold get_gvar in H. + unfold get_gvar in ev. destruct is_lvar. - - simpl in *. - eapply u_get_remember. - intros. - eapply u_ret. - intros h []. - split. - + assumption. - + unfold u_get in H1. - unfold get_var in H. - unfold on_vu in H. destruct Fv.get as [sx | e] eqn:e1. - 2:{ destruct e. all: discriminate. } - noconf H. - apply H0 in e1. subst. - rewrite e1. - clear e1. - simpl. - rewrite coerce_to_choice_type_K. - destruct (vtype (gv x)); - rewrite coerce_to_choice_type_K; reflexivity. - - simpl in *. - destruct get_global. 2: discriminate. - eapply u_ret. - intros. - noconf H. split. - + assumption. - + reflexivity. + - apply translate_get_var_correct. assumption. + - rewrite ev. + apply u_ret. intros m hm. + split. 1: assumption. + reflexivity. Qed. Lemma translate_of_val : @@ -947,7 +950,7 @@ Proof with try discriminate; simpl in *. unfold choice_type_of_val. rewrite H. unfold translate_gvar. - destruct is_lvar; reflexivity. + reflexivity. - simpl in H. destruct get_gvar... + destruct v0... @@ -1040,16 +1043,6 @@ Proof. reflexivity. Qed. -Lemma coerce_to_choice_type_translate_value_to_val : - ∀ ty (v : sem_t ty), - coerce_to_choice_type (encode ty) (translate_value (to_val v)) = - embed v. -Proof. - intros ty v. - destruct ty. - all: simpl. all: rewrite coerce_to_choice_type_K. all: reflexivity. -Qed. - Lemma translate_pexpr_correct_new : ∀ fn (e : pexpr) s₁ v, sem_pexpr gd s₁ e = ok v → @@ -1118,11 +1111,11 @@ Proof. destruct v0. all: try discriminate. 2: { destruct t. all: discriminate. } rewrite !coerce_to_choice_type_K. - rewrite (translate_gvar_type _ (evm s1) (Varr a)); [|assumption]. + eapply type_of_get_gvar in E00 as ety. + rewrite <- ety. rewrite !coerce_to_choice_type_K. - apply chArray_get_correct. noconf E0. - assumption. + apply chArray_get_correct. assumption. - Admitted. @@ -1260,8 +1253,7 @@ Proof. (* massage the hypotheses into something more usable *) simpl in h1. - pose proof on_arr_gvarP as p. - unshelve eapply (p _ _ _ _ _ _ _ _ h1). clear p h1. + eapply on_arr_gvarP. 2: exact h1. clear h1. intros n ar evty hgd h. simpl in h. simpl. eapply rbindP. 2: exact h. clear h. simpl. intros z h1 h2. @@ -1270,37 +1262,12 @@ Proof. eapply rbindP. 2: exact h2. clear h2. simpl. intros w ha ew. noconf ew. - unfold get_gvar in hgd. - - unfold to_int in ev'. destruct v'. all: try discriminate. - 2:{ destruct t. all: discriminate. } - noconf ev'. - specialize IHe with (1 := hv'). - specialize IHe with (ty := sint) (vv := z). - forward IHe. 1: reflexivity. - - (* TW: It would be nice to conclude here that e is translated to an 'int - Is there any way to know it though? - *) - - (* Now the actual proof should begin. Instead, here is some mindless mess - following my nose along the structure of the goal. *) - unfold translate_gvar. unfold translate_var. - destruct is_lvar eqn:hlvar. - + simpl. - eapply u_get_remember. - rewrite evty. simpl. intros arr. - rewrite bind_assoc. - eapply u_bind. - * give_up. - * simpl. eapply u_ret. - give_up. - + simpl. rewrite hgd. - simpl. rewrite bind_assoc. - eapply u_bind. - * give_up. - * simpl. eapply u_ret. - give_up. + rewrite bind_assoc. + eapply u_bind. + 1:{ eapply translate_gvar_correct. eassumption. } + rewrite !bind_assoc. + eapply u_bind. + all: admit. - Admitted. From 8b2caf249485b632de0e305ce33e0a5f2bef8f9e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Mon, 4 Apr 2022 12:05:55 +0200 Subject: [PATCH 086/383] Define translate_to_pointer --- theories/Jasmin/jasmin_translate.v | 3 +++ 1 file changed, 3 insertions(+) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index ba963165..2b40d2f3 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -259,6 +259,9 @@ Definition truncate_el {t : choice_type} (s : stype) : t → encode s := λ w, truncate_chWord n w end. +Definition translate_to_pointer {t : choice_type} (c : t) : 'word Uptr := + truncate_el (sword Uptr) c. + Definition truncate_code (s : stype) (c : typed_code) : typed_code := (encode s ; x ← c.π2 ;; ret (truncate_el s x)). From 65924faeca465ebbb3dde4b2289b68b37f440e86 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Mon, 4 Apr 2022 12:24:15 +0200 Subject: [PATCH 087/383] Progress with translate_write_lval --- theories/Jasmin/jasmin_translate.v | 72 ++++++++++++++++-------------- 1 file changed, 39 insertions(+), 33 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 2b40d2f3..25bc3366 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -345,37 +345,6 @@ Definition translate_write_var (fn : funname) (x : var_i) (v : typed_code) := Definition translate_get_var (f : funname) (x : var) : raw_code (encode x.(vtype)) := x ← get (translate_var f x) ;; ret x. -Definition translate_write_lval (fn : funname) (l : lval) (v : typed_code) - : raw_code 'unit - := - match l with - | Lnone _ ty => ret tt - | Lvar x => translate_write_var fn x v - | Lmem sz x e => - vx ← translate_get_var fn x ;; (* Missing to pointer *) - unsupported.π2 (* TODO *) - | _ => unsupported.π2 - (* | Lmem sz x e => - Let vx := get_var (evm s) x >>= to_pointer in - Let ve := sem_pexpr s e >>= to_pointer in - let p := (vx + ve)%R in (* should we add the size of value, i.e vx + sz * se *) - Let w := to_word sz v in - Let m := write s.(emem) p w in - ok {| emem := m; evm := s.(evm) |} *) - (* | Laset aa ws x i => *) - (* Let (n,t) := s.[x] in *) - (* Let i := sem_pexpr s i >>= to_int in *) - (* Let v := to_word ws v in *) - (* Let t := WArray.set t aa i v in *) - (* write_var x (@to_val (sarr n) t) s *) - (* | Lasub aa ws len x i => *) - (* Let (n,t) := s.[x] in *) - (* Let i := sem_pexpr s i >>= to_int in *) - (* Let t' := to_arr (Z.to_pos (arr_size ws len)) v in *) - (* Let t := @WArray.set_sub n aa ws len t i t' in *) - (* write_var x (@to_val (sarr n) t) s *) - end. - (* TW: We can remove it right? *) Fixpoint satisfies_globs (globs : glob_decls) : heap * heap → Prop. Proof. @@ -394,8 +363,7 @@ Definition translate_gvar (f : funname) (x : gvar) : raw_code (encode x.(gv).(vt match get_global gd x.(gv).(v_var) with | Ok v => ret (coerce_to_choice_type _ (translate_value v)) | _ => ret (chCanonical _) - end - . + end. Definition chArray_get ws (a : 'array) ptr scale := (* Jasmin fails if ptr is not aligned; we may not need it. *) @@ -531,6 +499,44 @@ Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code := (* pose (vs' := fold (fun x => y ← x ;; unembed y) f vs). *) +Definition translate_write_lval (fn : funname) (l : lval) (v : typed_code) + : raw_code 'unit + := + match l with + | Lnone _ ty => ret tt + | Lvar x => translate_write_var fn x v + | Lmem sz x e => + vx' ← translate_get_var fn x ;; + let vx : word _ := translate_to_pointer vx' in + ve' ← (translate_pexpr fn e).π2 ;; + let ve := translate_to_pointer ve' in + let p := (vx + ve)%R in (* should we add the size of value, i.e vx + sz * se *) (* Is it from us or them? *) + v ← v.π2 ;; + let w := truncate_chWord sz v in + (* Need translate_write *) + unsupported.π2 (* TODO *) + | _ => unsupported.π2 + (* | Lmem sz x e => + Let vx := get_var (evm s) x >>= to_pointer in + Let ve := sem_pexpr s e >>= to_pointer in + let p := (vx + ve)%R in (* should we add the size of value, i.e vx + sz * se *) + Let w := to_word sz v in + Let m := write s.(emem) p w in + ok {| emem := m; evm := s.(evm) |} *) + (* | Laset aa ws x i => *) + (* Let (n,t) := s.[x] in *) + (* Let i := sem_pexpr s i >>= to_int in *) + (* Let v := to_word ws v in *) + (* Let t := WArray.set t aa i v in *) + (* write_var x (@to_val (sarr n) t) s *) + (* | Lasub aa ws len x i => *) + (* Let (n,t) := s.[x] in *) + (* Let i := sem_pexpr s i >>= to_int in *) + (* Let t' := to_arr (Z.to_pos (arr_size ws len)) v in *) + (* Let t := @WArray.set_sub n aa ws len t i t' in *) + (* write_var x (@to_val (sarr n) t) s *) + end. + Definition instr_d (i : instr) : instr_r := match i with MkI _ i => i end. From 599b65845d60bfeaa51c0c7b98a57cfe3356e8b2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Mon, 4 Apr 2022 13:14:15 +0200 Subject: [PATCH 088/383] Admit translate_write --- theories/Jasmin/jasmin_translate.v | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 25bc3366..3ab898c2 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -499,6 +499,10 @@ Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code := (* pose (vs' := fold (fun x => y ← x ;; unembed y) f vs). *) +Definition translate_write {n} (p : word Uptr) (w : word n) : raw_code 'unit := + (* For now we do not worry about alignment *) + unsupported.π2. (* Do we really have to slice the word into 8bit parts? *) + Definition translate_write_lval (fn : funname) (l : lval) (v : typed_code) : raw_code 'unit := @@ -513,8 +517,7 @@ Definition translate_write_lval (fn : funname) (l : lval) (v : typed_code) let p := (vx + ve)%R in (* should we add the size of value, i.e vx + sz * se *) (* Is it from us or them? *) v ← v.π2 ;; let w := truncate_chWord sz v in - (* Need translate_write *) - unsupported.π2 (* TODO *) + translate_write p w | _ => unsupported.π2 (* | Lmem sz x e => Let vx := get_var (evm s) x >>= to_pointer in From 9fd8086bd064a16bd585e71001946a439f2510e6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Mon, 4 Apr 2022 13:37:30 +0200 Subject: [PATCH 089/383] Define useful jbind tactic (better name wanted) --- theories/Jasmin/jasmin_translate.v | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 3ab898c2..02c63808 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1319,6 +1319,11 @@ Lemma injective_translate_var : Proof. Admitted. +Ltac jbind h x hx := + eapply rbindP ; [| exact h ] ; + clear h ; intros x hx h ; + cbn beta in h. + (* TODO Make fixpoint too! *) Lemma translate_instr_r_correct : ∀ (fn : funname) (i : instr_r) (s₁ s₂ : estate), @@ -1397,7 +1402,18 @@ Proof. eapply hv in ei. rewrite ei. rewrite coerce_to_choice_type_K. reflexivity. } - + admit. + + simpl. simpl in hw. + jbind hw vx hvx. jbind hvx vx' hvx'. jbind hw ve hve. + jbind hve ve' hve'. jbind hw w hw'. jbind hw m hm. + noconf hw. + eapply u_get_remember. intros tv. + eapply u_bind. (* 2: eapply translate_pexpr_correct_new. *) + (* The condition on translate_pexpr_correct_new is too strict and cannot + accomodate for the added u_get in the pre. + Perhaps its pre and post should be an invariant that entails + rel_estate. + *) + all: admit. + admit. + admit. - admit. From bd6737b7a7a180ec85ec39b5e1f8578f34717236 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Mon, 4 Apr 2022 13:50:50 +0200 Subject: [PATCH 090/383] Make translate_get_var_correct and co more lax --- theories/Jasmin/jasmin_translate.v | 46 ++++++++++++++++-------------- 1 file changed, 24 insertions(+), 22 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 02c63808..623e784b 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -863,13 +863,14 @@ Proof. Qed. Lemma translate_get_var_correct : - ∀ fn x s v, + ∀ fn x s v (cond : heap → Prop), get_var (evm s) x = ok v → - ⊢ ⦃ rel_estate s fn ⦄ + (∀ m, cond m → rel_estate s fn m) → + ⊢ ⦃ cond ⦄ translate_get_var fn x ⇓ coerce_to_choice_type _ (translate_value v) - ⦃ rel_estate s fn ⦄. + ⦃ cond ⦄. Proof. - intros fn x s v ev. + intros fn x s v cond ev hcond. unfold translate_get_var. eapply u_get_remember. intros vx. eapply u_ret. intros m [hm hx]. @@ -877,22 +878,23 @@ Proof. unfold u_get in hx. unfold get_var in ev. eapply on_vuP. 3: exact ev. 2: discriminate. intros sx esx esv. - eapply hm in esx. subst. + eapply hcond in hm. eapply hm in esx. subst. rewrite coerce_to_choice_type_translate_value_to_val. rewrite esx. rewrite coerce_to_choice_type_K. reflexivity. Qed. -Lemma translate_gvar_correct (f : funname) (x : gvar) (v : value) s : +Lemma translate_gvar_correct (f : funname) (x : gvar) (v : value) s (cond : heap → Prop) : get_gvar gd (evm s) x = ok v → - ⊢ ⦃ rel_estate s f ⦄ + (∀ m, cond m → rel_estate s f m) → + ⊢ ⦃ cond ⦄ translate_gvar f x ⇓ coerce_to_choice_type _ (translate_value v) - ⦃ rel_estate s f ⦄. + ⦃ cond ⦄. Proof. - intros ev. + intros ev hcond. unfold translate_gvar. unfold get_gvar in ev. destruct is_lvar. - - apply translate_get_var_correct. assumption. + - eapply translate_get_var_correct. all: eassumption. - rewrite ev. apply u_ret. intros m hm. split. 1: assumption. @@ -1056,15 +1058,16 @@ Proof. Qed. Lemma translate_pexpr_correct_new : - ∀ fn (e : pexpr) s₁ v, + ∀ fn (e : pexpr) s₁ v (cond : heap → Prop), sem_pexpr gd s₁ e = ok v → - ⊢ ⦃ rel_estate s₁ fn ⦄ + (∀ m, cond m → rel_estate s₁ fn m) → + ⊢ ⦃ cond ⦄ (translate_pexpr fn e).π2 ⇓ coerce_to_choice_type _ (translate_value v) - ⦃ rel_estate s₁ fn ⦄. + ⦃ cond ⦄. Proof. - intros fn e s1 v h1. - induction e as [z|b| |x|aa ws x e| | | | | | ] in s1, v, h1 |- *. + intros fn e s1 v cond h1 hcond. + induction e as [z|b| |x|aa ws x e| | | | | | ] in s1, v, h1, cond, hcond |- *. - simpl in h1. noconf h1. rewrite coerce_to_choice_type_K. apply u_ret_eq. auto. @@ -1089,8 +1092,8 @@ Proof. eapply u_get_remember. simpl. intro v. apply u_ret. intros m [hm e]. unfold u_get in e. subst. - split. 1: auto. - destruct hm as [hm hv]. + split. 1: assumption. + apply hcond in hm. destruct hm as [hm hv]. apply hv in e1. rewrite e1. simpl. rewrite coerce_to_choice_type_K. rewrite coerce_to_choice_type_translate_value_to_val. @@ -1108,10 +1111,9 @@ Proof. destruct WArray.get eqn:E2. 2: discriminate. noconf h1. rewrite coerce_to_choice_type_K. - apply IHe in E as E3. + eapply IHe in E as E3. 2: exact hcond. eapply u_bind. - + apply translate_gvar_correct. - eassumption. + + eapply translate_gvar_correct. all: eassumption. + rewrite !bind_assoc. eapply u_bind. * apply E3. @@ -1276,7 +1278,7 @@ Proof. noconf ew. rewrite bind_assoc. eapply u_bind. - 1:{ eapply translate_gvar_correct. eassumption. } + 1:{ eapply translate_gvar_correct. 1: eassumption. 1: auto. } rewrite !bind_assoc. eapply u_bind. all: admit. @@ -1347,7 +1349,7 @@ Proof. simpl in hw. noconf hw. simpl. rewrite !bind_assoc. simpl. eapply u_bind. - * eapply translate_pexpr_correct_new. eassumption. + * eapply translate_pexpr_correct_new. all: eauto. * { erewrite translate_pexpr_type. 2: eassumption. clear sem_e tag e. From ecb95cfb29d2de206e1b3428e47ca9a14bd93a7f Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Mon, 4 Apr 2022 13:57:30 +0200 Subject: [PATCH 091/383] attempt at translate `Pload` and some simplifications --- theories/Jasmin/jasmin_translate.v | 37 ++++++++++++++++++++++++------ 1 file changed, 30 insertions(+), 7 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 02c63808..3250dc1e 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -42,6 +42,11 @@ Notation gd := (p_globs P). Notation " 'array " := (chMap 'int ('word U8)) (at level 2) : package_scope. Notation " 'array " := (chMap 'int ('word U8)) (in custom pack_type at level 2). +Notation " 'mem " := (chMap ('word Uptr) ('word U8)) (at level 2) : package_scope. +Notation " 'mem " := (chMap ('word Uptr) ('word U8)) (in custom pack_type at level 2). + +Parameter mem_index : nat. +Definition mem_loc : Location := ('mem ; mem_index). Definition encode (t : stype) : choice_type := match t with @@ -154,12 +159,13 @@ Proof. replace i with kv.1 in * by reflexivity. replace s with kv.2 in * by reflexivity. apply Mz.elementsIn in E. subst kv. - eapply foldl_In_uniq. + apply foldl_In_uniq. + assumption. + apply Mz.elementsU. - - assert (forall v, ~ List.In (i, v) (Mz.elements data)). - + intros. apply elementsNIn with (v:=v) in E. assumption. - + apply foldl_NIn. assumption. + - apply foldl_NIn. + intros. + apply elementsNIn. + assumption. Qed. Definition unembed {t : stype} : encode t → sem_t t := @@ -369,7 +375,7 @@ Definition chArray_get ws (a : 'array) ptr scale := (* Jasmin fails if ptr is not aligned; we may not need it. *) (* if negb (is_align ptr sz) then chCanonical ws else *) let f k := - match a (ptr * scale + k)%Z with + match a (ptr * scale + k)%Z with (* BSH: maybe abstract this matchee with chArray_get8? *) | None => chCanonical ('word U8) | Some x => x end @@ -394,6 +400,20 @@ Definition chArray_get_sub ws len (a : 'array) ptr scale := Definition totc (ty : choice_type) (c : raw_code ty) : typed_code := (ty ; c). +Definition chRead ptr ws : typed_code := + (* memory as array *) + totc ('word ws) + (mem ← get mem_loc ;; + let f k := + match mem (ptr + (wrepr Uptr k))%R with + | None => chCanonical ('word U8) + | Some x => x + end + in + let l := map f (ziota 0 (wsize_size ws)) in + ret (Jasmin.memory_model.LE.decode ws l) + ). + (* Following sem_pexpr *) Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code := match e with @@ -421,8 +441,11 @@ Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code := ret (chArray_get_sub ws len a i scale) ) | Pload sz x e => - totc ('word sz) ( - ret (chCanonical _) (* TODO *) + totc ('word sz) ( + w ← translate_get_var fn x ;; + let w1 := truncate_el (sword Uptr) w in + w2 ← (truncate_code (sword Uptr) (translate_pexpr fn e)).π2 ;; + (truncate_code (sword sz) (chRead (wpmaddwd w1 w2) sz)).π2 (* BSH: i wish to write w1 + w2 instead of wpmaddwd, but it does not typecheck? *) ) | Papp1 o e => totc _ ( From b89ebe29393471e312c25fa13eb2d67c9c555241 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Mon, 4 Apr 2022 14:00:31 +0200 Subject: [PATCH 092/383] Reach translate_write case in proof --- theories/Jasmin/jasmin_translate.v | 23 +++++++++++++++-------- 1 file changed, 15 insertions(+), 8 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index e7330a37..89e207d9 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1432,13 +1432,20 @@ Proof. jbind hve ve' hve'. jbind hw w hw'. jbind hw m hm. noconf hw. eapply u_get_remember. intros tv. - eapply u_bind. (* 2: eapply translate_pexpr_correct_new. *) - (* The condition on translate_pexpr_correct_new is too strict and cannot - accomodate for the added u_get in the pre. - Perhaps its pre and post should be an invariant that entails - rel_estate. - *) - all: admit. + eapply u_bind. + 1:{ + eapply translate_pexpr_correct_new. + - eassumption. + - intros ? []. assumption. + } + rewrite bind_assoc. + eapply u_bind. + 1:{ + eapply translate_pexpr_correct_new. + - eassumption. + - intros ? []. assumption. + } + simpl. admit. + admit. + admit. - admit. @@ -1466,7 +1473,7 @@ Proof. (* all: shelve_unifiable. *) intros H. set (Pfun := - λ (m : mem) (fn : funname) (va : seq value) (m' : mem) (vr : seq value), + λ (m : mem) (fn : funname) (va : seq value) (m' : mem) (vr : seq value), ∀ f, let sp := translate_prog p in let dom := lchtuple [seq choice_type_of_val i | i <- va] in From 5354b271857054424d55eb48ffadac252243091b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Mon, 4 Apr 2022 14:04:47 +0200 Subject: [PATCH 093/383] chRead --- theories/Jasmin/jasmin_translate.v | 35 ++++++++++++------------------ 1 file changed, 14 insertions(+), 21 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 89e207d9..099a0ac5 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -400,19 +400,17 @@ Definition chArray_get_sub ws len (a : 'array) ptr scale := Definition totc (ty : choice_type) (c : raw_code ty) : typed_code := (ty ; c). -Definition chRead ptr ws : typed_code := +Definition chRead ptr ws : raw_code ('word ws) := (* memory as array *) - totc ('word ws) - (mem ← get mem_loc ;; - let f k := - match mem (ptr + (wrepr Uptr k))%R with - | None => chCanonical ('word U8) - | Some x => x - end - in - let l := map f (ziota 0 (wsize_size ws)) in - ret (Jasmin.memory_model.LE.decode ws l) - ). + mem ← get mem_loc ;; + let f k := + match mem (ptr + (wrepr Uptr k))%R with + | None => chCanonical ('word U8) + | Some x => x + end + in + let l := map f (ziota 0 (wsize_size ws)) in + ret (Jasmin.memory_model.LE.decode ws l). (* Following sem_pexpr *) Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code := @@ -441,11 +439,12 @@ Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code := ret (chArray_get_sub ws len a i scale) ) | Pload sz x e => - totc ('word sz) ( + totc ('word sz) ( w ← translate_get_var fn x ;; - let w1 := truncate_el (sword Uptr) w in + let w1 : word _ := truncate_el (sword Uptr) w in w2 ← (truncate_code (sword Uptr) (translate_pexpr fn e)).π2 ;; - (truncate_code (sword sz) (chRead (wpmaddwd w1 w2) sz)).π2 (* BSH: i wish to write w1 + w2 instead of wpmaddwd, but it does not typecheck? *) + ww ← chRead (w1 + w2)%R sz ;; + ret (truncate_el (sword sz) ww) ) | Papp1 o e => totc _ ( @@ -499,12 +498,6 @@ Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code := exact (a ← arr ;; ptr ← i ;; ret (chArray_get ws a ptr scale)). *) - (* | Pload sz x e => *) - (* Let w1 := get_var s.(evm) x >>= to_pointer in *) - (* Let w2 := sem_pexpr s e >>= to_pointer in *) - (* Let w := read s.(emem) (w1 + w2)%R sz in *) - (* ok (@to_val (sword sz) w) *) - (* | PappN op es => *) (* Let vs := mapM (sem_pexpr s) es in *) (* sem_opN op vs *) From d70571075b1e451e1ec3535e8fcbe610b684763a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Mon, 4 Apr 2022 14:40:09 +0200 Subject: [PATCH 094/383] Start on Laset case of write_lval --- theories/Jasmin/jasmin_translate.v | 44 ++++++++++++++++-------------- 1 file changed, 24 insertions(+), 20 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 099a0ac5..24b013df 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -534,26 +534,30 @@ Definition translate_write_lval (fn : funname) (l : lval) (v : typed_code) v ← v.π2 ;; let w := truncate_chWord sz v in translate_write p w - | _ => unsupported.π2 - (* | Lmem sz x e => - Let vx := get_var (evm s) x >>= to_pointer in - Let ve := sem_pexpr s e >>= to_pointer in - let p := (vx + ve)%R in (* should we add the size of value, i.e vx + sz * se *) - Let w := to_word sz v in - Let m := write s.(emem) p w in - ok {| emem := m; evm := s.(evm) |} *) - (* | Laset aa ws x i => *) - (* Let (n,t) := s.[x] in *) - (* Let i := sem_pexpr s i >>= to_int in *) - (* Let v := to_word ws v in *) - (* Let t := WArray.set t aa i v in *) - (* write_var x (@to_val (sarr n) t) s *) - (* | Lasub aa ws len x i => *) - (* Let (n,t) := s.[x] in *) - (* Let i := sem_pexpr s i >>= to_int in *) - (* Let t' := to_arr (Z.to_pos (arr_size ws len)) v in *) - (* Let t := @WArray.set_sub n aa ws len t i t' in *) - (* write_var x (@to_val (sarr n) t) s *) + | Laset aa ws x i => + (* Let (n,t) := s.[x] in is a notation calling on_arr_varr on get_var *) + (* We just cast it since we do not track lengths *) + t' ← translate_get_var fn x ;; + let t := coerce_to_choice_type 'array t' in + i ← (truncate_code sint (translate_pexpr fn i)).π2 ;; (* to_int *) + v ← v.π2 ;; + let v := truncate_chWord ws v in + (* let t := setm t i v in *) (* WArray.set also calls write *) + unsupported.π2 + | Lasub aa ws len x i => + unsupported.π2 + (* | Laset aa ws x i => + Let (n,t) := s.[x] in + Let i := sem_pexpr s i >>= to_int in + Let v := to_word ws v in + Let t := WArray.set t aa i v in + write_var x (@to_val (sarr n) t) s *) + (* | Lasub aa ws len x i => + Let (n,t) := s.[x] in + Let i := sem_pexpr s i >>= to_int in + Let t' := to_arr (Z.to_pos (arr_size ws len)) v in + Let t := @WArray.set_sub n aa ws len t i t' in + write_var x (@to_val (sarr n) t) s *) end. Definition instr_d (i : instr) : instr_r := From 3a3a6e4b06dbdfccda553ab8a96fdef7ac41eddd Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Mon, 4 Apr 2022 15:29:15 +0200 Subject: [PATCH 095/383] temporary fix of `rel_mem` --- theories/Jasmin/jasmin_translate.v | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 099a0ac5..39d68a31 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -691,10 +691,10 @@ Definition translate_ptr (ptr : pointer) : Location := ('word U8 ; (5 ^ Z.to_nat (wunsigned ptr))%nat). Definition rel_mem (m : mem) (h : heap) := - ∀ ptr sz v, - read m ptr sz = ok v → + ∀ ptr v, + read m ptr U8 = ok v → get_heap h (translate_ptr ptr) = - coerce_to_choice_type _ (translate_value (@to_val (sword sz) v)). + coerce_to_choice_type _ (translate_value (@to_val (sword U8) v)). #[local] Open Scope vmap_scope. From d54e99bd5260f7121050e808c2491e40c5016e6f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Mon, 4 Apr 2022 15:37:06 +0200 Subject: [PATCH 096/383] Barely start on Lasub --- theories/Jasmin/jasmin_translate.v | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 24b013df..3efb254b 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -545,6 +545,11 @@ Definition translate_write_lval (fn : funname) (l : lval) (v : typed_code) (* let t := setm t i v in *) (* WArray.set also calls write *) unsupported.π2 | Lasub aa ws len x i => + (* Same observation as Laset *) + t' ← translate_get_var fn x ;; + let t := coerce_to_choice_type 'array t' in + (* Again, we ignore the length *) + (* Let t' := to_arr (Z.to_pos (arr_size ws len)) v in *) unsupported.π2 (* | Laset aa ws x i => Let (n,t) := s.[x] in From a02ccfed655f3e6c4ff981ba9565c9f97fbeb305 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Mon, 4 Apr 2022 15:46:32 +0200 Subject: [PATCH 097/383] alternative `rel_mem` --- theories/Jasmin/jasmin_translate.v | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 247b7a2b..d7001f45 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -701,9 +701,12 @@ Definition translate_ptr (ptr : pointer) : Location := Definition rel_mem (m : mem) (h : heap) := ∀ ptr v, + (* mem as array model: *) read m ptr U8 = ok v → - get_heap h (translate_ptr ptr) = - coerce_to_choice_type _ (translate_value (@to_val (sword U8) v)). + (get_heap h mem_loc) ptr = Some v. + (* mem as locations model: *) + (* get_heap h (translate_ptr ptr) = *) + (* coerce_to_choice_type _ (translate_value (@to_val (sword U8) v)). *) #[local] Open Scope vmap_scope. @@ -1384,9 +1387,10 @@ Proof. destruct hm as [hm hv]. split. - unfold rel_mem. - intros ptr sz w hrw. - rewrite get_set_heap_neq. 2: apply ptr_var_neq. - apply hm. assumption. + admit. + (* intros ptr sz w hrw. *) + (* rewrite get_set_heap_neq. 2: apply ptr_var_neq. *) + (* apply hm. assumption. *) - simpl. unfold rel_vmap. intros i vi ei. simpl. rewrite !coerce_to_choice_type_K. From 7e4175cccda87dee73bc23d24d7fda6240a51386 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Mon, 4 Apr 2022 15:54:36 +0200 Subject: [PATCH 098/383] Keep just one translate_pexpr_correct --- theories/Jasmin/jasmin_translate.v | 160 +---------------------------- 1 file changed, 4 insertions(+), 156 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index d7001f45..133c8d6a 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1085,7 +1085,7 @@ Proof. reflexivity. Qed. -Lemma translate_pexpr_correct_new : +Lemma translate_pexpr_correct : ∀ fn (e : pexpr) s₁ v (cond : heap → Prop), sem_pexpr gd s₁ e = ok v → (∀ m, cond m → rel_estate s₁ fn m) → @@ -1161,158 +1161,6 @@ Proof. - Admitted. -Lemma translate_pexpr_correct : - ∀ fn (e : pexpr) s₁ v ty v' ty', - sem_pexpr gd s₁ e = ok v → - truncate_val ty v = ok v' → - ⊢ ⦃ rel_estate s₁ fn ⦄ - coerce_typed_code ty' (truncate_code ty (translate_pexpr fn e)) ⇓ - coerce_to_choice_type ty' (translate_value v') - ⦃ rel_estate s₁ fn ⦄. -Proof. - intros fn e s₁ v ty v' ty' h1 h2. - unfold truncate_code. - assert (e2 : ty = type_of_val v'). - { unfold truncate_val in h2. destruct of_val eqn:ev. 2: discriminate. - simpl in h2. noconf h2. - symmetry. apply type_of_to_val. - } - subst. - destruct (ty' == encode (type_of_val v')) eqn:e1. - 2:{ - rewrite coerce_typed_code_neq. - 2:{ move: e1 => /eqP e1. congruence. } - rewrite coerce_to_choice_type_neq. - 2:{ - move: e1 => /eqP e1. intros ?. subst. - apply e1. - unfold choice_type_of_val. reflexivity. - } - apply u_ret_eq. auto. - } - pose proof e1 as e2. move: e2 => /eqP e2. subst. - rewrite coerce_typed_code_K. rewrite coerce_to_choice_type_K. clear e1. - unfold truncate_val in h2. destruct of_val as [vv|] eqn:ev. 2: discriminate. - simpl in h2. symmetry in h2. noconf h2. - lazymatch goal with - | h : _ = to_val _ |- _ => rename h into h2 - end. - rewrite h2. - set (ty := type_of_val v') in *. clearbody ty. subst. - (* Now we can actually look at the pexpr *) - induction e as [z|b| |x|aa ws x e| | | | | | ] in v, s₁, h1, ty, vv, ev |- *. - - simpl. simpl in h1. noconf h1. - apply of_vint in ev as es. subst. - simpl. rewrite coerce_to_choice_type_K. - simpl in ev. noconf ev. - apply u_ret_eq. auto. - - simpl. simpl in h1. noconf h1. - apply of_vbool in ev as es. - destruct es as [es _]. subst. - simpl. rewrite coerce_to_choice_type_K. - simpl in ev. noconf ev. - apply u_ret_eq. auto. - - simpl. simpl in h1. noconf h1. - apply of_varr in ev as es. - move: es => /values.subtypeE es. - destruct es as [m [es hm]]. subst. - simpl. rewrite coerce_to_choice_type_K. - simpl in ev. apply WArray.cast_empty_ok in ev. subst. - simpl. rewrite Mz.foldP. simpl. - apply u_ret_eq. auto. - - simpl. simpl in h1. - apply type_of_get_gvar in h1 as es. - unfold translate_gvar. unfold translate_var. - unfold get_gvar in h1. - destruct is_lvar eqn:hlvar. - + destruct x as [gx gs]. simpl in *. - unfold is_lvar in hlvar. simpl in hlvar. move: hlvar => /eqP hlvar. subst. - unfold get_var in h1. - unfold on_vu in h1. destruct Fv.get as [sx | e] eqn:e1. - 2:{ destruct e. all: discriminate. } - noconf h1. - eapply u_get_remember. simpl. intro vx. - apply u_ret. intros m [[hmem hvmap] h]. - apply hvmap in e1. unfold u_get in h. - rewrite h in e1. clear h. subst. - split. - 1:{ split. all: assumption. } - rewrite coerce_to_choice_type_K. - clear - ev. set (ty' := vtype gx) in *. clearbody ty'. clear - ev. - pose proof (type_of_to_val sx) as ety. - destruct ty. - * simpl. simpl in ev. - unfold to_bool in ev. destruct to_val eqn:esx. all: try discriminate. - 2:{ destruct t. all: discriminate. } - noconf ev. subst. - rewrite coerce_to_choice_type_K. - simpl. noconf esx. reflexivity. - * simpl. simpl in ev. - unfold to_int in ev. destruct to_val eqn:esx. all: try discriminate. - 2:{ destruct t. all: discriminate. } - noconf ev. subst. - rewrite coerce_to_choice_type_K. - simpl. noconf esx. reflexivity. - * simpl. simpl in ev. - unfold to_arr in ev. destruct to_val eqn:esx. all: try discriminate. - subst. - rewrite coerce_to_choice_type_K. - simpl. noconf esx. - unfold WArray.cast in ev. destruct (_ <=? _)%Z. 2: discriminate. - noconf ev. simpl. reflexivity. - * simpl. simpl in ev. - unfold to_word in ev. destruct to_val eqn:esx. all: try discriminate. - 2:{ destruct t. all: discriminate. } - subst. simpl. noconf esx. rewrite ev. reflexivity. - + simpl. rewrite h1. simpl. - apply u_ret. intros m hm. - split. 1: auto. - rewrite -es. rewrite coerce_to_choice_type_K. - clear - ev. - destruct ty. - * simpl. simpl in ev. - unfold to_bool in ev. destruct v eqn:e. all: try discriminate. - 2:{ destruct t. all: discriminate. } - noconf ev. subst. - rewrite coerce_to_choice_type_K. reflexivity. - * simpl. simpl in ev. - unfold to_int in ev. destruct v eqn:e. all: try discriminate. - 2:{ destruct t. all: discriminate. } - noconf ev. subst. - rewrite coerce_to_choice_type_K. - reflexivity. - * simpl. simpl in ev. - unfold to_arr in ev. destruct v eqn:e. all: try discriminate. - rewrite coerce_to_choice_type_K. - simpl. subst. - unfold WArray.cast in ev. destruct (_ <=? _)%Z. 2: discriminate. - noconf ev. simpl. reflexivity. - * simpl. simpl in ev. - unfold to_word in ev. destruct v eqn:e. all: try discriminate. - 2:{ destruct t. all: discriminate. } - subst. simpl. rewrite ev. reflexivity. - - (* array access *) - - (* massage the hypotheses into something more usable *) - simpl in h1. - eapply on_arr_gvarP. 2: exact h1. clear h1. - intros n ar evty hgd h. simpl in h. simpl. - eapply rbindP. 2: exact h. - clear h. simpl. intros z h1 h2. - eapply rbindP. 2: exact h1. - clear h1. intros v' hv' ev'. - eapply rbindP. 2: exact h2. - clear h2. simpl. intros w ha ew. - noconf ew. - rewrite bind_assoc. - eapply u_bind. - 1:{ eapply translate_gvar_correct. 1: eassumption. 1: auto. } - rewrite !bind_assoc. - eapply u_bind. - all: admit. - - -Admitted. - Lemma ptr_var_neq (ptr : pointer) (fn : funname) (v : var) : translate_ptr ptr != translate_var fn v. Proof. @@ -1377,7 +1225,7 @@ Proof. simpl in hw. noconf hw. simpl. rewrite !bind_assoc. simpl. eapply u_bind. - * eapply translate_pexpr_correct_new. all: eauto. + * eapply translate_pexpr_correct. all: eauto. * { erewrite translate_pexpr_type. 2: eassumption. clear sem_e tag e. @@ -1440,14 +1288,14 @@ Proof. eapply u_get_remember. intros tv. eapply u_bind. 1:{ - eapply translate_pexpr_correct_new. + eapply translate_pexpr_correct. - eassumption. - intros ? []. assumption. } rewrite bind_assoc. eapply u_bind. 1:{ - eapply translate_pexpr_correct_new. + eapply translate_pexpr_correct. - eassumption. - intros ? []. assumption. } From ab5d37359725d54b99ab553f7bd014e6c6a4a034 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Mon, 4 Apr 2022 16:17:13 +0200 Subject: [PATCH 099/383] Use jbind whenever --- theories/Jasmin/jasmin_translate.v | 64 +++++++++++++----------------- 1 file changed, 27 insertions(+), 37 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 133c8d6a..06530175 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -40,6 +40,13 @@ Context (P : uprog). Notation gd := (p_globs P). +(* Tactic to deal with Let _ := _ in _ = ok _ in assumption h *) +(* x and hx are introduced names for the value and its property *) +Ltac jbind h x hx := + eapply rbindP ; [| exact h ] ; + clear h ; intros x hx h ; + cbn beta in h. + Notation " 'array " := (chMap 'int ('word U8)) (at level 2) : package_scope. Notation " 'array " := (chMap 'int ('word U8)) (in custom pack_type at level 2). Notation " 'mem " := (chMap ('word Uptr) ('word U8)) (at level 2) : package_scope. @@ -210,8 +217,7 @@ Lemma truncate_val_type : Proof. intros ty v v' e. unfold truncate_val in e. - destruct of_val eqn:ev. 2: discriminate. - simpl in e. noconf e. + jbind e x ev. noconf e. apply type_of_to_val. Qed. @@ -959,8 +965,7 @@ Lemma translate_truncate_val : Proof. intros ty v v' h. unfold truncate_val in h. - destruct of_val as [vx |] eqn:e. 2: discriminate. - simpl in h. noconf h. + jbind h vx e. noconf h. apply translate_of_val. assumption. Qed. @@ -1045,12 +1050,11 @@ Lemma mapM_nil {eT aT bT} f l : @mapM eT aT bT f l = ok [::] → l = [::]. Proof. - intro H. - induction l in H |- *. + intro h. + induction l in h |- *. - reflexivity. - - simpl in H. - destruct f. 2: discriminate. - destruct mapM. all: discriminate. + - simpl in h. + jbind h y hy. jbind h ys hys. noconf h. Qed. Lemma chArray_get_correct (len : BinNums.positive) (a : WArray.array len) (z : Z) ws aa s : @@ -1062,8 +1066,7 @@ Proof. unfold WArray.get, read in H. destruct is_align. 2: discriminate. simpl in H. - destruct mapM eqn:E. 2: discriminate. - noconf H. + jbind H l E. noconf H. unfold chArray_get. f_equal. revert l E. @@ -1130,33 +1133,26 @@ Proof. rewrite h1. apply u_ret. auto. - simpl in *. - destruct get_gvar eqn:E00. 2: discriminate. - destruct v0. all: try discriminate. - destruct sem_pexpr eqn:E. 2: discriminate. - simpl in h1. - destruct to_int eqn:E0. 2: discriminate. - simpl in h1. - destruct WArray.get eqn:E2. 2: discriminate. - noconf h1. + jbind h1 nt ent. destruct nt. all: try discriminate. + jbind h1 i ei. jbind ei i' ei'. + jbind h1 w ew. noconf h1. rewrite coerce_to_choice_type_K. - eapply IHe in E as E3. 2: exact hcond. eapply u_bind. + eapply translate_gvar_correct. all: eassumption. + rewrite !bind_assoc. eapply u_bind. - * apply E3. + * eapply IHe. all: eassumption. * eapply u_ret. - intros. split; [assumption|]. - apply translate_pexpr_type with (fn:=fn) in E as typ. - rewrite typ. + intros m hm. + split. 1: assumption. + erewrite translate_pexpr_type. 2: eassumption. rewrite coerce_to_choice_type_K. - destruct v0. all: try discriminate. - 2: { destruct t. all: discriminate. } + eapply type_of_get_gvar in ent as ety. rewrite <- ety. rewrite !coerce_to_choice_type_K. - eapply type_of_get_gvar in E00 as ety. - rewrite <- ety. - rewrite !coerce_to_choice_type_K. - noconf E0. + destruct i'. all: try discriminate. + 2:{ destruct t. all: discriminate. } + simpl in ei. noconf ei. + rewrite coerce_to_choice_type_K. apply chArray_get_correct. assumption. - Admitted. @@ -1197,11 +1193,6 @@ Lemma injective_translate_var : Proof. Admitted. -Ltac jbind h x hx := - eapply rbindP ; [| exact h ] ; - clear h ; intros x hx h ; - cbn beta in h. - (* TODO Make fixpoint too! *) Lemma translate_instr_r_correct : ∀ (fn : funname) (i : instr_r) (s₁ s₂ : estate), @@ -1221,8 +1212,7 @@ Proof. * unfold on_vu in hw. destruct of_val as [| []]. all: noconf hw. assumption. + simpl. unfold translate_write_var. simpl in hw. unfold write_var in hw. - destruct set_var eqn:eset. 2: discriminate. - simpl in hw. noconf hw. + jbind hw vm eset. noconf hw. simpl. rewrite !bind_assoc. simpl. eapply u_bind. * eapply translate_pexpr_correct. all: eauto. From 55d604f382338c2fef57e509800ca6da6814b499 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Mon, 4 Apr 2022 16:26:58 +0200 Subject: [PATCH 100/383] Draft Pif case --- theories/Jasmin/jasmin_translate.v | 20 +++++++++++++++++++- 1 file changed, 19 insertions(+), 1 deletion(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 06530175..43b6205b 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1154,7 +1154,25 @@ Proof. simpl in ei. noconf ei. rewrite coerce_to_choice_type_K. apply chArray_get_correct. assumption. - - + - (* Psub *) admit. + - (* Pload *) admit. + - (* Papp1 *) admit. + - (* Papp2 *) admit. + - (* PappN TODO *) admit. + - (* Pif *) + simpl in h1. jbind h1 b eb. jbind eb b' eb'. + jbind h1 v1 ev1. jbind ev1 v1' ev1'. + jbind h1 v2 ev2. jbind ev2 v2' ev2'. + noconf h1. + simpl. rewrite bind_assoc. + eapply u_bind. + 1:{ eapply IHe1. all: eauto. } + simpl. erewrite translate_pexpr_type. 2: eassumption. + rewrite coerce_to_choice_type_K. + (* We can't always destruct b' etc. as for destruct i' above + we need a lemma, probably similar to translate_of_val or + translate_truncate_val but specialised to to_bool, to_int etc. + *) Admitted. Lemma ptr_var_neq (ptr : pointer) (fn : funname) (v : var) : From e756844707f948e707b40ee57b1d43142b9d50bf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Mon, 4 Apr 2022 16:42:48 +0200 Subject: [PATCH 101/383] Define translate_to_bool and to_int --- theories/Jasmin/jasmin_translate.v | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 43b6205b..7a6f82e6 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -969,6 +969,30 @@ Proof. apply translate_of_val. assumption. Qed. +Lemma translate_to_bool : + ∀ v b, + to_bool v = ok b → + coerce_to_choice_type 'bool (translate_value v) = b. +Proof. + intros v b e. + destruct v as [| | | | t]. all: try discriminate. + 2:{ destruct t. all: discriminate. } + simpl in e. noconf e. + rewrite coerce_to_choice_type_K. reflexivity. +Qed. + +Lemma translate_to_int : + ∀ v z, + to_int v = ok z → + coerce_to_choice_type 'int (translate_value v) = z. +Proof. + intros v z e. + destruct v as [| | | | t]. all: try discriminate. + 2:{ destruct t. all: discriminate. } + simpl in e. noconf e. + rewrite coerce_to_choice_type_K. reflexivity. +Qed. + Lemma translate_truncate_code : ∀ (c : typed_code) (ty : stype) v v' p q, truncate_val ty v = ok v' → From ec8d18c1c549702343eddb186f0033ea90fc43ba Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Mon, 4 Apr 2022 17:02:26 +0200 Subject: [PATCH 102/383] begin Papp1 case of `pexpr_correct` --- theories/Jasmin/jasmin_translate.v | 23 ++++++++++++++++++++++- 1 file changed, 22 insertions(+), 1 deletion(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 7a6f82e6..ef687161 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1180,7 +1180,28 @@ Proof. apply chArray_get_correct. assumption. - (* Psub *) admit. - (* Pload *) admit. - - (* Papp1 *) admit. + - (* Papp1 *) + simpl in *. + jbind h1 v' h2. + rewrite bind_assoc. simpl. + eapply u_bind. + + eapply IHe; eauto. + + apply u_ret. + intros. + split. 1: assumption. + unfold sem_sop1 in h1. + jbind h1 v'' h3. + noconf h1. + rewrite coerce_to_choice_type_translate_value_to_val. + f_equal. f_equal. + Search truncate_el. + apply translate_pexpr_type with (fn:=fn) in h2. + rewrite h2. + rewrite !coerce_to_choice_type_K. + erewrite translate_of_val. + 2: exact h3. + rewrite coerce_to_choice_type_translate_value_to_val. + admit. (* prove unembed is inverse to embed *) - (* Papp2 *) admit. - (* PappN TODO *) admit. - (* Pif *) From d13cb24bf54eceb4d8227a227c98db8589d96ae0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Mon, 4 Apr 2022 17:04:41 +0200 Subject: [PATCH 103/383] Use translate_to_bool in Pif case --- theories/Jasmin/jasmin_translate.v | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index ef687161..2d6d4974 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1173,10 +1173,7 @@ Proof. rewrite coerce_to_choice_type_K. eapply type_of_get_gvar in ent as ety. rewrite <- ety. rewrite !coerce_to_choice_type_K. - destruct i'. all: try discriminate. - 2:{ destruct t. all: discriminate. } - simpl in ei. noconf ei. - rewrite coerce_to_choice_type_K. + erewrite translate_to_int. 2: eassumption. apply chArray_get_correct. assumption. - (* Psub *) admit. - (* Pload *) admit. @@ -1214,10 +1211,14 @@ Proof. 1:{ eapply IHe1. all: eauto. } simpl. erewrite translate_pexpr_type. 2: eassumption. rewrite coerce_to_choice_type_K. - (* We can't always destruct b' etc. as for destruct i' above - we need a lemma, probably similar to translate_of_val or - translate_truncate_val but specialised to to_bool, to_int etc. - *) + erewrite translate_to_bool. 2: eassumption. + destruct b. + + eapply u_bind. + 1:{ eapply IHe2. all: eauto. } + simpl. eapply u_ret. intros m hm. + split. 1: assumption. + admit. + + admit. Admitted. Lemma ptr_var_neq (ptr : pointer) (fn : funname) (v : var) : From 1dcee2a0953df92c869646b9e301ece0a999ebcf Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Mon, 4 Apr 2022 17:05:03 +0200 Subject: [PATCH 104/383] remove search --- theories/Jasmin/jasmin_translate.v | 1 - 1 file changed, 1 deletion(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index ef687161..bc1b1486 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1194,7 +1194,6 @@ Proof. noconf h1. rewrite coerce_to_choice_type_translate_value_to_val. f_equal. f_equal. - Search truncate_el. apply translate_pexpr_type with (fn:=fn) in h2. rewrite h2. rewrite !coerce_to_choice_type_K. From 41b2c46801ccbbbe1220fc0d2743fa48a65c5a88 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Mon, 4 Apr 2022 17:58:17 +0200 Subject: [PATCH 105/383] Complete Pif case --- theories/Jasmin/jasmin_translate.v | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 7853e325..844551cb 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1216,8 +1216,16 @@ Proof. 1:{ eapply IHe2. all: eauto. } simpl. eapply u_ret. intros m hm. split. 1: assumption. - admit. - + admit. + erewrite translate_pexpr_type. 2: eassumption. + rewrite coerce_to_choice_type_K. + apply translate_truncate_val. assumption. + + eapply u_bind. + 1:{ eapply IHe3. all: eauto. } + simpl. eapply u_ret. intros m hm. + split. 1: assumption. + erewrite translate_pexpr_type. 2: eassumption. + rewrite coerce_to_choice_type_K. + apply translate_truncate_val. assumption. Admitted. Lemma ptr_var_neq (ptr : pointer) (fn : funname) (v : var) : From eda3b777b376a225c4f819c3f91dc668e8a7ec1f Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Mon, 4 Apr 2022 19:17:59 +0200 Subject: [PATCH 106/383] proved op1 case of `pexpr_correct` --- theories/Jasmin/jasmin_translate.v | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 7853e325..36990fc9 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1190,14 +1190,16 @@ Proof. jbind h1 v'' h3. noconf h1. rewrite coerce_to_choice_type_translate_value_to_val. - f_equal. f_equal. apply translate_pexpr_type with (fn:=fn) in h2. rewrite h2. rewrite !coerce_to_choice_type_K. erewrite translate_of_val. 2: exact h3. rewrite coerce_to_choice_type_translate_value_to_val. - admit. (* prove unembed is inverse to embed *) + destruct op. + all: try reflexivity. + destruct o. + all: try reflexivity. - (* Papp2 *) admit. - (* PappN TODO *) admit. - (* Pif *) From 175b802aae4a2c54bedb0075fbfdfbf83fd6101c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Tue, 5 Apr 2022 08:23:40 +0200 Subject: [PATCH 107/383] Remove outdated comment --- theories/Jasmin/jasmin_translate.v | 17 ----------------- 1 file changed, 17 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index a0565661..6865708c 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1244,23 +1244,6 @@ Admitted. Notation coe_cht := coerce_to_choice_type. Notation coe_tyc := coerce_typed_code. -(* TODO MOVE *) -(* Lemma u_coerce_typed_code : - ∀ (c : typed_code) (ty : choice_type) (v : ty) p q, - ⊢ ⦃ p ⦄ c.π2 ⇓ coerce_to_choice_type c.π1 v ⦃ q ⦄ → - ⊢ ⦃ p ⦄ coerce_typed_code ty c ⇓ v ⦃ q ⦄. -Proof. - intros c ty v p q h. - destruct c as [ty' c]. simpl in h. - destruct (ty' == ty) eqn:e. - all: move: e => /eqP e. - - subst. rewrite coerce_typed_code_K. rewrite coerce_to_choice_type_K in h. - assumption. - - rewrite coerce_typed_code_neq. 2: assumption. - rewrite coerce_to_choice_type_neq in h. 2: eauto. - WRONG, should just have coercion in the conclusions, including the value -Abort. *) - Lemma injective_translate_var : ∀ fn, injective (translate_var fn). Proof. From 33600876ff221d7785298d80fc9f0e5d29a0bcef Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Tue, 5 Apr 2022 08:32:25 +0200 Subject: [PATCH 108/383] factor out sop1_unembed_embed --- theories/Jasmin/jasmin_translate.v | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 6865708c..061c1410 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1112,6 +1112,15 @@ Proof. reflexivity. Qed. +Lemma sop1_unembed_embed op v : + sem_sop1_typed op (unembed (embed v)) = sem_sop1_typed op v. +Proof. + destruct op. + all: try reflexivity. + destruct o. + all: try reflexivity. +Qed. + Lemma translate_pexpr_correct : ∀ fn (e : pexpr) s₁ v (cond : heap → Prop), sem_pexpr gd s₁ e = ok v → @@ -1196,10 +1205,8 @@ Proof. erewrite translate_of_val. 2: exact h3. rewrite coerce_to_choice_type_translate_value_to_val. - destruct op. - all: try reflexivity. - destruct o. - all: try reflexivity. + f_equal. + apply sop1_unembed_embed. - (* Papp2 *) admit. - (* PappN TODO *) admit. - (* Pif *) From 43a7786dfd76f0ba3779c0d53e9f295425ddc57f Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Tue, 5 Apr 2022 08:50:33 +0200 Subject: [PATCH 109/383] correctness of Papp2 follows the same schema as Papp1 --- theories/Jasmin/jasmin_translate.v | 42 +++++++++++++++++++++++++++++- 1 file changed, 41 insertions(+), 1 deletion(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 061c1410..3d374a6b 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1121,6 +1121,16 @@ Proof. all: try reflexivity. Qed. +Lemma sop2_unembed_embed op v1 v2 : + sem_sop2_typed op (unembed (embed v1)) (unembed (embed v2)) = sem_sop2_typed op v1 v2. +Proof. + destruct op. + all: try reflexivity. + all: try destruct o. + all: try destruct c. + all: try reflexivity. +Qed. + Lemma translate_pexpr_correct : ∀ fn (e : pexpr) s₁ v (cond : heap → Prop), sem_pexpr gd s₁ e = ok v → @@ -1207,7 +1217,37 @@ Proof. rewrite coerce_to_choice_type_translate_value_to_val. f_equal. apply sop1_unembed_embed. - - (* Papp2 *) admit. + - (* Papp2 *) + simpl in *. + jbind h1 v' h2. + jbind h1 v'' h3. + rewrite bind_assoc. simpl. + eapply u_bind. + 1: eapply IHe1; eauto. + rewrite bind_assoc. simpl. + eapply u_bind. + 1: eapply IHe2; eauto. + apply u_ret. + intuition subst. + unfold sem_sop2 in h1. + jbind h1 v''' h4. + jbind h1 v'''' h5. + jbind h1 v''''' h6. + noconf h1. + rewrite coerce_to_choice_type_translate_value_to_val. + apply translate_pexpr_type with (fn:=fn) in h2. + apply translate_pexpr_type with (fn:=fn) in h3. + rewrite h2 h3. + rewrite !coerce_to_choice_type_K. + erewrite translate_of_val. + 2: exact h4. + erewrite translate_of_val. + 2: exact h5. + rewrite coerce_to_choice_type_translate_value_to_val. + rewrite coerce_to_choice_type_translate_value_to_val. + rewrite sop2_unembed_embed. + rewrite h6. + reflexivity. - (* PappN TODO *) admit. - (* Pif *) simpl in h1. jbind h1 b eb. jbind eb b' eb'. From af94e44b3cb9dbb418602bc33377d2a3b9551e05 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Tue, 5 Apr 2022 09:30:45 +0200 Subject: [PATCH 110/383] Barely more robust sop1_unembed_embed --- theories/Jasmin/jasmin_translate.v | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 3d374a6b..310051c7 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1115,20 +1115,19 @@ Qed. Lemma sop1_unembed_embed op v : sem_sop1_typed op (unembed (embed v)) = sem_sop1_typed op v. Proof. - destruct op. - all: try reflexivity. - destruct o. - all: try reflexivity. + destruct op as [| | | | | | o]. 1-6: reflexivity. + destruct o. all: reflexivity. Qed. Lemma sop2_unembed_embed op v1 v2 : - sem_sop2_typed op (unembed (embed v1)) (unembed (embed v2)) = sem_sop2_typed op v1 v2. + sem_sop2_typed op (unembed (embed v1)) (unembed (embed v2)) = + sem_sop2_typed op v1 v2. Proof. destruct op. all: try reflexivity. all: try destruct o. all: try destruct c. - all: try reflexivity. + all: reflexivity. Qed. Lemma translate_pexpr_correct : From e2644eb4a0983371339ed6549ff13819015c6737 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Tue, 5 Apr 2022 11:20:00 +0200 Subject: [PATCH 111/383] Update statement of translate_prog_correct --- theories/Jasmin/jasmin_translate.v | 112 +++++++++++------------------ 1 file changed, 42 insertions(+), 70 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 310051c7..d01b06ed 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1410,9 +1410,9 @@ Theorem translate_prog_correct (p : expr.uprog) (fn : funname) m va m' vr f : let cod := lchtuple (map choice_type_of_val vr) in get_fundef_ssp sp fn dom cod = Some f → (* satisfies_globs (p_globs p) (translate_mem m, translate_mem m') -> *) - ⊢ ⦃ satisfies_globs (p_globs p) ⦄ - f (translate_values va) ≈ ret (translate_values vr) - ⦃ λ '(v1, s1) '(v2,s2), v1 = v2 ⦄. + ⊢ ⦃ λ m, True ⦄ + f (translate_values va) ⇓ translate_values vr + ⦃ λ m, True ⦄. Proof. (* intros H H1 H2 H3 H4. *) (* unshelve eapply sem_call_Ind. *) @@ -1424,105 +1424,77 @@ Proof. let sp := translate_prog p in let dom := lchtuple [seq choice_type_of_val i | i <- va] in let cod := lchtuple [seq choice_type_of_val i | i <- vr] in - get_fundef_ssp sp fn dom cod = Some f -> + get_fundef_ssp sp fn dom cod = Some f → (* satisfies_globs (p_globs p) (translate_mem m, translate_mem m') → *) - ⊢ ⦃ satisfies_globs (p_globs p) ⦄ - f (translate_values va) ≈ - ret (translate_values vr) - ⦃ λ '(v1, _) '(v2, _), v1 = v2 ⦄ + ⊢ ⦃ λ m, True ⦄ + f (translate_values va) ⇓ translate_values vr + ⦃ λ m, True ⦄ ). set (Pi_r := λ (s1 : estate) (i : instr_r) (s2 : estate), - ⊢ ⦃ λ '(h1,h2), False ⦄ - translate_instr_r fn i ≈ ret tt - ⦃ λ '(v1, _) '(v2, _), True ⦄ + ⊢ ⦃ rel_estate s1 fn ⦄ + translate_instr_r fn i ⇓ tt + ⦃ rel_estate s2 fn ⦄ ). set (Pi := λ s1 i s2, (Pi_r s1 (instr_d i) s2)). set (Pc := λ (s1 : estate) (c : cmd) (s2 : estate), - ⊢ ⦃ λ '(h1,h2), False ⦄ translate_cmd fn c ≈ ret tt ⦃ λ '(v1, _) '(v2, _), True ⦄ + ⊢ ⦃ rel_estate s1 fn ⦄ translate_cmd fn c ⇓ tt ⦃ rel_estate s2 fn ⦄ ). (* FIXME *) set (Pfor := λ (v : var_i) (ls : seq Z) (s1 : estate) (c : cmd) (s2 : estate), - ⊢ ⦃ λ '(h1,h2), False ⦄ - (* ssprove_for *) translate_cmd fn c ≈ - ret tt - ⦃ λ '(v1, _) '(v2, _), True ⦄ + ⊢ ⦃ rel_estate s1 fn ⦄ + (* ssprove_for *) translate_cmd fn c ⇓ tt + ⦃ rel_estate s2 fn ⦄ ). unshelve eapply (@sem_call_Ind _ _ _ _ Pc Pi_r Pi Pfor Pfun _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H). - red. intros. - red. unfold translate_cmd. simpl. + red. unfold translate_cmd. admit. - red. intros. red. unfold translate_cmd. simpl. admit. - red. intros. apply H1. - - red. intros. - red. - unfold translate_instr_r. - destruct x. - + simpl. admit. - + simpl. - eapply r_transL. - * eapply r_bind with (mid := eq). - -- instantiate (1 := ret (coerce_to_choice_type _ - (translate_value v'))). - (* by eapply translate_pexpr_sound. *) - admit. (* by H0: sem_pexpr e = ok v *) - -- intros. - eapply rpre_hypothesis_rule. - intros ? ? E. - noconf E. - eapply rpre_weaken_rule. - 1: refine (rreflexivity_rule _). - simpl. - intros. by intuition subst. - * simpl. - eapply r_put_lhs with (pre := (λ '(_, _), False)). - apply r_ret. - intros. - admit. - + admit. - + admit. - + admit. - - red. intros. + - red. intros s₁ s₂ x tag ty e v v' he hv hw. red. - unfold translate_instr_r. - admit. + eapply translate_instr_r_correct. + (* Do we have to apply this lemma for each instance, seems wrong *) + econstructor. all: eauto. + (* Problem between p.(p_globs) and gd, this lemma should probably be + out of the section. + *) + all: admit. - red. intros. - red. - unfold translate_instr_r. - admit. + red. eapply translate_instr_r_correct. + econstructor. admit. - red. intros. - red. - unfold translate_instr_r. - admit. + red. eapply translate_instr_r_correct. + econstructor. + (* Two uprogs too *) + all: admit. - red. intros. - red. - unfold translate_instr_r. - admit. + red. eapply translate_instr_r_correct. + econstructor. + all: admit. - red. intros. - red. - unfold translate_instr_r. - admit. + red. eapply translate_instr_r_correct. + econstructor. + all: admit. - red. intros. - red. - unfold translate_instr_r. - admit. + red. eapply translate_instr_r_correct. + econstructor. all: admit. - red. intros. - red. - unfold translate_instr_r. - admit. + red. eapply translate_instr_r_correct. + econstructor. all: admit. + - admit. - red. intros. red. - unfold translate_cmd. admit. - red. intros. - red. - unfold translate_instr_r. - admit. + red. eapply translate_instr_r_correct. + econstructor. all: admit. - red. intros. unfold Pfun. intros. unfold get_fundef_ssp in H7. From d6cb06060862ef3e1cfcdad3464ddaf9397dd5d9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Tue, 5 Apr 2022 11:25:32 +0200 Subject: [PATCH 112/383] Move unary judgment out of section --- theories/Jasmin/jasmin_translate.v | 242 ++++++++++++++--------------- 1 file changed, 121 insertions(+), 121 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index d01b06ed..6d488066 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -28,6 +28,127 @@ Derive NoConfusion for wsize. Derive NoConfusion for CoqWord.word.word. Derive EqDec for wsize. +(* Unary judgment concluding on evaluation of program *) + +Definition eval_jdg {A : choiceType} + (pre : heap → Prop) (post : heap → Prop) + (c : raw_code A) (v : A) := + ⊢ ⦃ λ '(h₀, h₁), pre h₀ ⦄ + c ≈ ret v + ⦃ λ '(a₀, h₀) '(a₁, h₁), post h₀ ∧ a₀ = a₁ ∧ a₁ = v ⦄. + +Notation "⊢ ⦃ pre ⦄ c ⇓ v ⦃ post ⦄" := + (eval_jdg pre post c v) + (format "⊢ ⦃ pre ⦄ '/ ' '[' c ']' '/' ⇓ '/ ' '[' v ']' '/' ⦃ post ⦄") + : package_scope. + +Lemma u_ret : + ∀ {A : choiceType} (v v' : A) (p q : heap → Prop), + (∀ hp, p hp → q hp ∧ v = v') → + ⊢ ⦃ p ⦄ ret v ⇓ v' ⦃ q ⦄. +Proof. + intros A v v' p q h. + unfold eval_jdg. + apply r_ret. + intros hp hp' hhp. + specialize (h hp). + intuition eauto. +Qed. + +Lemma u_ret_eq : + ∀ {A : choiceType} (v : A) (p q : heap → Prop), + (∀ hp, p hp → q hp) → + ⊢ ⦃ p ⦄ ret v ⇓ v ⦃ q ⦄. +Proof. + intros A v p q h. + apply u_ret. intuition eauto. +Qed. + +Lemma u_bind : + ∀ {A B : choiceType} m f v₁ v₂ (p q r : heap → Prop), + ⊢ ⦃ p ⦄ m ⇓ v₁ ⦃ q ⦄ → + ⊢ ⦃ q ⦄ f v₁ ⇓ v₂ ⦃ r ⦄ → + ⊢ ⦃ p ⦄ @bind A B m f ⇓ v₂ ⦃ r ⦄. +Proof. + intros A B m f v₁ v₂ p q r hm hf. + unfold eval_jdg. + change (ret v₂) with (ret v₁ ;; ret v₂). + eapply r_bind. + - exact hm. + - intros a₀ a₁. + eapply rpre_hypothesis_rule. + intuition subst. + eapply rpre_weaken_rule. + 1: apply hf. + simpl. intuition subst. assumption. +Qed. + +(* Unary variant of set_lhs *) +Definition u_set_pre (ℓ : Location) (v : ℓ) (pre : heap → Prop): heap → Prop := + λ m, ∃ m', pre m' ∧ m = set_heap m' ℓ v. + +Lemma u_put : + ∀ {A : choiceType} (ℓ : Location) (v : ℓ) (r : raw_code A) (v' : A) p q, + ⊢ ⦃ u_set_pre ℓ v p ⦄ r ⇓ v' ⦃ q ⦄ → + ⊢ ⦃ p ⦄ #put ℓ := v ;; r ⇓ v' ⦃ q ⦄. +Proof. + intros A ℓ v r v' p q h. + eapply r_put_lhs with (pre := λ '(_,_), _). + eapply rpre_weaken_rule. 1: eapply h. + intros m₀ m₁ hm. simpl. + destruct hm as [m' hm]. + exists m'. exact hm. +Qed. + +(* Unary variant of inv_conj (⋊) *) +Definition u_pre_conj (p q : heap → Prop) : heap → Prop := + λ m, p m ∧ q m. + +Notation "p ≪ q" := + (u_pre_conj p q) (at level 19, left associativity) : package_scope. + +(* Unary variant of rem_lhs *) +Definition u_get (ℓ : Location) (v : ℓ) : heap → Prop := + λ m, get_heap m ℓ = v. + +Lemma u_get_remember : + ∀ (A : choiceType) (ℓ : Location) (k : ℓ → raw_code A) (v : A) p q, + (∀ x, ⊢ ⦃ p ≪ u_get ℓ x ⦄ k x ⇓ v ⦃ q ⦄) → + ⊢ ⦃ p ⦄ x ← get ℓ ;; k x ⇓ v ⦃ q ⦄. +Proof. + intros A ℓ k v p q h. + eapply r_get_remember_lhs with (pre := λ '(_,_), _). + intro x. + eapply rpre_weaken_rule. 1: eapply h. + simpl. intuition eauto. +Qed. + +(* Unary rpre_weaken_rule *) +Lemma upre_weaken_rule : + ∀ A (r : raw_code A) v (p1 p2 : heap → Prop) q, + ⊢ ⦃ p1 ⦄ r ⇓ v ⦃ q ⦄ → + (∀ h, p2 h → p1 h) → + ⊢ ⦃ p2 ⦄ r ⇓ v ⦃ q ⦄. +Proof. + intros A r v p1 p2 q h hp. + eapply rpre_weaken_rule. + - eapply h. + - intros. apply hp. assumption. +Qed. + +(* Unary rpost_weaken_rule *) +Lemma upost_weaken_rule : + ∀ A (r : raw_code A) v p (q1 q2 : heap → Prop), + ⊢ ⦃ p ⦄ r ⇓ v ⦃ q1 ⦄ → + (∀ h, q1 h → q2 h) → + ⊢ ⦃ p ⦄ r ⇓ v ⦃ q2 ⦄. +Proof. + intros A r v p q1 q2 h hq. + eapply rpost_weaken_rule. + - eapply h. + - intros [] []. intuition eauto. +Qed. + Section Translation. Context `{asmop : asmOp}. @@ -765,127 +886,6 @@ Proof. apply cast_ct_val_K. Qed. -(* Unary judgment concluding on evaluation of program *) - -Definition eval_jdg {A : choiceType} - (pre : heap → Prop) (post : heap → Prop) - (c : raw_code A) (v : A) := - ⊢ ⦃ λ '(h₀, h₁), pre h₀ ⦄ - c ≈ ret v - ⦃ λ '(a₀, h₀) '(a₁, h₁), post h₀ ∧ a₀ = a₁ ∧ a₁ = v ⦄. - -Notation "⊢ ⦃ pre ⦄ c ⇓ v ⦃ post ⦄" := - (eval_jdg pre post c v) - (format "⊢ ⦃ pre ⦄ '/ ' '[' c ']' '/' ⇓ '/ ' '[' v ']' '/' ⦃ post ⦄") - : package_scope. - -Lemma u_ret : - ∀ {A : choiceType} (v v' : A) (p q : heap → Prop), - (∀ hp, p hp → q hp ∧ v = v') → - ⊢ ⦃ p ⦄ ret v ⇓ v' ⦃ q ⦄. -Proof. - intros A v v' p q h. - unfold eval_jdg. - apply r_ret. - intros hp hp' hhp. - specialize (h hp). - intuition eauto. -Qed. - -Lemma u_ret_eq : - ∀ {A : choiceType} (v : A) (p q : heap → Prop), - (∀ hp, p hp → q hp) → - ⊢ ⦃ p ⦄ ret v ⇓ v ⦃ q ⦄. -Proof. - intros A v p q h. - apply u_ret. intuition eauto. -Qed. - -Lemma u_bind : - ∀ {A B : choiceType} m f v₁ v₂ (p q r : heap → Prop), - ⊢ ⦃ p ⦄ m ⇓ v₁ ⦃ q ⦄ → - ⊢ ⦃ q ⦄ f v₁ ⇓ v₂ ⦃ r ⦄ → - ⊢ ⦃ p ⦄ @bind A B m f ⇓ v₂ ⦃ r ⦄. -Proof. - intros A B m f v₁ v₂ p q r hm hf. - unfold eval_jdg. - change (ret v₂) with (ret v₁ ;; ret v₂). - eapply r_bind. - - exact hm. - - intros a₀ a₁. - eapply rpre_hypothesis_rule. - intuition subst. - eapply rpre_weaken_rule. - 1: apply hf. - simpl. intuition subst. assumption. -Qed. - -(* Unary variant of set_lhs *) -Definition u_set_pre (ℓ : Location) (v : ℓ) (pre : heap → Prop): heap → Prop := - λ m, ∃ m', pre m' ∧ m = set_heap m' ℓ v. - -Lemma u_put : - ∀ {A : choiceType} (ℓ : Location) (v : ℓ) (r : raw_code A) (v' : A) p q, - ⊢ ⦃ u_set_pre ℓ v p ⦄ r ⇓ v' ⦃ q ⦄ → - ⊢ ⦃ p ⦄ #put ℓ := v ;; r ⇓ v' ⦃ q ⦄. -Proof. - intros A ℓ v r v' p q h. - eapply r_put_lhs with (pre := λ '(_,_), _). - eapply rpre_weaken_rule. 1: eapply h. - intros m₀ m₁ hm. simpl. - destruct hm as [m' hm]. - exists m'. exact hm. -Qed. - -(* Unary variant of inv_conj (⋊) *) -Definition u_pre_conj (p q : heap → Prop) : heap → Prop := - λ m, p m ∧ q m. - -Notation "p ≪ q" := - (u_pre_conj p q) (at level 19, left associativity) : package_scope. - -(* Unary variant of rem_lhs *) -Definition u_get (ℓ : Location) (v : ℓ) : heap → Prop := - λ m, get_heap m ℓ = v. - -Lemma u_get_remember : - ∀ (A : choiceType) (ℓ : Location) (k : ℓ → raw_code A) (v : A) p q, - (∀ x, ⊢ ⦃ p ≪ u_get ℓ x ⦄ k x ⇓ v ⦃ q ⦄) → - ⊢ ⦃ p ⦄ x ← get ℓ ;; k x ⇓ v ⦃ q ⦄. -Proof. - intros A ℓ k v p q h. - eapply r_get_remember_lhs with (pre := λ '(_,_), _). - intro x. - eapply rpre_weaken_rule. 1: eapply h. - simpl. intuition eauto. -Qed. - -(* Unary rpre_weaken_rule *) -Lemma upre_weaken_rule : - ∀ A (r : raw_code A) v (p1 p2 : heap → Prop) q, - ⊢ ⦃ p1 ⦄ r ⇓ v ⦃ q ⦄ → - (∀ h, p2 h → p1 h) → - ⊢ ⦃ p2 ⦄ r ⇓ v ⦃ q ⦄. -Proof. - intros A r v p1 p2 q h hp. - eapply rpre_weaken_rule. - - eapply h. - - intros. apply hp. assumption. -Qed. - -(* Unary rpost_weaken_rule *) -Lemma upost_weaken_rule : - ∀ A (r : raw_code A) v p (q1 q2 : heap → Prop), - ⊢ ⦃ p ⦄ r ⇓ v ⦃ q1 ⦄ → - (∀ h, q1 h → q2 h) → - ⊢ ⦃ p ⦄ r ⇓ v ⦃ q2 ⦄. -Proof. - intros A r v p q1 q2 h hq. - eapply rpost_weaken_rule. - - eapply h. - - intros [] []. intuition eauto. -Qed. - Lemma coerce_to_choice_type_translate_value_to_val : ∀ ty (v : sem_t ty), coerce_to_choice_type (encode ty) (translate_value (to_val v)) = From be1fe1cf8fb87cf59113915bab39c4bae1426b16 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Tue, 5 Apr 2022 11:42:57 +0200 Subject: [PATCH 113/383] Fix translate_prog_correct --- theories/Jasmin/jasmin_translate.v | 51 ++++++++++++------------------ 1 file changed, 20 insertions(+), 31 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 6d488066..333af62d 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -766,13 +766,6 @@ Proof. - exact [interface]. Defined. -Definition ssprove_prog := seq (funname * fdef). - -Definition translate_prog (p : uprog) : ssprove_prog := - (* let globs := collect_globs (p_globs p) in *) - let fds := map translate_fundef (p_funcs p) in - fds. - Fixpoint lchtuple (ts : seq choice_type) : choice_type := match ts with | [::] => 'unit @@ -1403,25 +1396,26 @@ Proof. - admit. Admitted. -Theorem translate_prog_correct (p : expr.uprog) (fn : funname) m va m' vr f : - sem.sem_call p m fn va m' vr → - let sp := (translate_prog p) in +Definition ssprove_prog := seq (funname * fdef). + +Definition translate_prog : ssprove_prog := + map translate_fundef P.(p_funcs). + +Theorem translate_prog_correct (fn : funname) m va m' vr f : + sem.sem_call P m fn va m' vr → + let sp := translate_prog in let dom := lchtuple (map choice_type_of_val va) in let cod := lchtuple (map choice_type_of_val vr) in get_fundef_ssp sp fn dom cod = Some f → - (* satisfies_globs (p_globs p) (translate_mem m, translate_mem m') -> *) ⊢ ⦃ λ m, True ⦄ f (translate_values va) ⇓ translate_values vr ⦃ λ m, True ⦄. Proof. - (* intros H H1 H2 H3 H4. *) - (* unshelve eapply sem_call_Ind. *) - (* all: shelve_unifiable. *) intros H. set (Pfun := λ (m : mem) (fn : funname) (va : seq value) (m' : mem) (vr : seq value), ∀ f, - let sp := translate_prog p in + let sp := translate_prog in let dom := lchtuple [seq choice_type_of_val i | i <- va] in let cod := lchtuple [seq choice_type_of_val i | i <- vr] in get_fundef_ssp sp fn dom cod = Some f → @@ -1461,44 +1455,39 @@ Proof. red. eapply translate_instr_r_correct. (* Do we have to apply this lemma for each instance, seems wrong *) - econstructor. all: eauto. - (* Problem between p.(p_globs) and gd, this lemma should probably be - out of the section. - *) - all: admit. + econstructor. all: eassumption. - red. intros. red. eapply translate_instr_r_correct. - econstructor. admit. + econstructor. assumption. - red. intros. red. eapply translate_instr_r_correct. econstructor. - (* Two uprogs too *) - all: admit. + all: assumption. - red. intros. red. eapply translate_instr_r_correct. - econstructor. - all: admit. + econstructor ; assumption. (* backtrack to select the right constructor *) - red. intros. red. eapply translate_instr_r_correct. econstructor. - all: admit. + all: eassumption. - red. intros. red. eapply translate_instr_r_correct. - econstructor. all: admit. + econstructor ; eassumption. (* backtrack *) - red. intros. red. eapply translate_instr_r_correct. - econstructor. all: admit. - - admit. + econstructor. all: eassumption. + - red. intros. red. + admit. - red. intros. red. admit. - red. intros. red. eapply translate_instr_r_correct. - econstructor. all: admit. + econstructor. all: eassumption. - red. intros. unfold Pfun. intros. unfold get_fundef_ssp in H7. admit. Admitted. -End Translation. +End Translation. \ No newline at end of file From 46cd71d71b6482dbb6ea3e69b127df3c92d14762 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Tue, 5 Apr 2022 11:51:31 +0200 Subject: [PATCH 114/383] State mem_loc_translate_var_neq --- theories/Jasmin/jasmin_translate.v | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 333af62d..1e22e19b 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -173,7 +173,7 @@ Notation " 'array " := (chMap 'int ('word U8)) (in custom pack_type at level 2). Notation " 'mem " := (chMap ('word Uptr) ('word U8)) (at level 2) : package_scope. Notation " 'mem " := (chMap ('word Uptr) ('word U8)) (in custom pack_type at level 2). -Parameter mem_index : nat. +Definition mem_index : nat := 0. Definition mem_loc : Location := ('mem ; mem_index). Definition encode (t : stype) : choice_type := @@ -1288,6 +1288,12 @@ Lemma injective_translate_var : Proof. Admitted. +Lemma mem_loc_translate_var_neq : + ∀ fn x, + mem_loc != translate_var fn x. +Proof. +Admitted. + (* TODO Make fixpoint too! *) Lemma translate_instr_r_correct : ∀ (fn : funname) (i : instr_r) (s₁ s₂ : estate), @@ -1320,10 +1326,9 @@ Proof. destruct hm as [hm hv]. split. - unfold rel_mem. - admit. - (* intros ptr sz w hrw. *) - (* rewrite get_set_heap_neq. 2: apply ptr_var_neq. *) - (* apply hm. assumption. *) + intros ptr byte hr. + rewrite get_set_heap_neq. 2: apply mem_loc_translate_var_neq. + apply hm. assumption. - simpl. unfold rel_vmap. intros i vi ei. simpl. rewrite !coerce_to_choice_type_K. From f4f289d34c5c8e2403052b05e919a65f6aeb7b9b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Tue, 5 Apr 2022 12:15:08 +0200 Subject: [PATCH 115/383] Small progress on Psub case --- theories/Jasmin/jasmin_translate.v | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 1e22e19b..14aa9085 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1186,7 +1186,23 @@ Proof. rewrite !coerce_to_choice_type_K. erewrite translate_to_int. 2: eassumption. apply chArray_get_correct. assumption. - - (* Psub *) admit. + - (* Psub *) + simpl. simpl in h1. + jbind h1 nt hnt. destruct nt. all: try discriminate. + jbind h1 i hi. jbind hi i' hi'. jbind h1 t ht. noconf h1. + eapply u_bind. + 1:{ eapply translate_gvar_correct. all: eauto. } + rewrite bind_assoc. simpl. + eapply u_bind. + 1:{ eapply IHe. all: eauto. } + eapply u_ret. intros m hm. + split. 1: assumption. + rewrite coerce_to_choice_type_K. + erewrite translate_pexpr_type. 2: eassumption. + rewrite coerce_to_choice_type_K. + erewrite translate_to_int. 2: eassumption. + (* Should we have a chArray_get_sub lemma involving Warray.get_sub? *) + admit. - (* Pload *) admit. - (* Papp1 *) simpl in *. From 4edffb6ecf2f87647debd8d15e543292b1c5074c Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Tue, 5 Apr 2022 12:22:50 +0200 Subject: [PATCH 116/383] change `pexpr_type` to use `jbind` --- theories/Jasmin/jasmin_translate.v | 77 ++++++++++++++---------------- 1 file changed, 37 insertions(+), 40 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 14aa9085..ee3513cb 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1016,51 +1016,48 @@ Proof with try discriminate; simpl in *. unfold translate_gvar. reflexivity. - simpl in H. - destruct get_gvar... - + destruct v0... - destruct sem_pexpr... - destruct v0... - * destruct WArray.get... - noconf H. - reflexivity. - * destruct t... - - destruct get_gvar... - destruct v0... - destruct sem_pexpr... - destruct v0... - * destruct WArray.get_sub... - noconf H. - reflexivity. - * destruct t... - - destruct get_var... - destruct to_pointer... - destruct sem_pexpr... - destruct to_pointer... - destruct read... - noconf H. reflexivity. - - destruct sem_pexpr... - apply sem_sop1I in H as []. - rewrite H0. + jbind H x h1. + destruct x. all: try discriminate. + jbind H x h2. + jbind H y h3. + noconf H. + reflexivity. + - jbind H x h1. + destruct x. all: try discriminate. + jbind H x h2. + jbind H y h3. + noconf H. + reflexivity. + - jbind H x h1. + jbind H y h2. + jbind H z h3. + noconf H. + reflexivity. + - jbind H x h1. + jbind H y h2. + noconf H. + unfold choice_type_of_val. + rewrite type_of_to_val. + reflexivity. + - jbind H v1 h1. + jbind H v2 h2. + jbind H v3 h3. + jbind H v4 h4. + jbind H v5 h5. + noconf H. unfold choice_type_of_val. rewrite type_of_to_val. reflexivity. - - destruct (sem_pexpr _ _ e1)... - destruct sem_pexpr... - apply sem_sop2I in H as [? [? [? []]]]. - unfold choice_type_of_val. subst. - by rewrite type_of_to_val. - admit. - - destruct (sem_pexpr _ _ e1)... - destruct to_bool... - destruct (sem_pexpr _ _ e2)... - destruct truncate_val eqn:E... - destruct sem_pexpr... - destruct (truncate_val s v3) eqn:E2... - unfold truncate_val in *. - repeat destruct of_val... - noconf E. noconf E2. + - jbind H v1 h1. + jbind H v2 h2. + jbind H v3 h3. + noconf H. + jbind h2 v4 h4. + jbind h3 v5 h5. unfold choice_type_of_val. - destruct b; noconf H; by rewrite type_of_to_val. + destruct v1. + all: erewrite truncate_val_type. 1,3: reflexivity. 1,2: eassumption. Admitted. Lemma mapM_nil {eT aT bT} f l : From 60a61b1020ea149fbd0a792ad4b180ae71eeaaa0 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Tue, 5 Apr 2022 12:24:33 +0200 Subject: [PATCH 117/383] small fix --- theories/Jasmin/jasmin_translate.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index ee3513cb..4b214381 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1005,7 +1005,7 @@ Qed. Lemma translate_pexpr_type fn s₁ e v : sem_pexpr gd s₁ e = ok v → (translate_pexpr fn e).π1 = choice_type_of_val v. -Proof with try discriminate; simpl in *. +Proof. intros. revert v H. destruct e; intros; simpl in *. From 2196c883a2ffab1fa6e4c173f7f593973f9368cb Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Tue, 5 Apr 2022 12:30:00 +0200 Subject: [PATCH 118/383] simplify `Psub` case --- theories/Jasmin/jasmin_translate.v | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 4b214381..ee251094 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1189,7 +1189,7 @@ Proof. jbind h1 i hi. jbind hi i' hi'. jbind h1 t ht. noconf h1. eapply u_bind. 1:{ eapply translate_gvar_correct. all: eauto. } - rewrite bind_assoc. simpl. + rewrite bind_assoc. eapply u_bind. 1:{ eapply IHe. all: eauto. } eapply u_ret. intros m hm. @@ -1198,6 +1198,8 @@ Proof. erewrite translate_pexpr_type. 2: eassumption. rewrite coerce_to_choice_type_K. erewrite translate_to_int. 2: eassumption. + apply type_of_get_gvar in hnt. rewrite <- hnt. + rewrite !coerce_to_choice_type_K. (* Should we have a chArray_get_sub lemma involving Warray.get_sub? *) admit. - (* Pload *) admit. From ee54c52417c17a0355a9dc69689da7d705b15fca Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Tue, 5 Apr 2022 14:55:38 +0200 Subject: [PATCH 119/383] Define translate_to_word and attack Pload case --- theories/Jasmin/jasmin_translate.v | 52 +++++++++++++++++++++++++++++- 1 file changed, 51 insertions(+), 1 deletion(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index ee251094..b96d3181 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -962,6 +962,27 @@ Proof. apply translate_of_val. assumption. Qed. +Lemma translate_truncate_word : + ∀ sz sz' (w : word sz) (w' : word sz'), + truncate_word sz' w = ok w' → + truncate_chWord sz' (@embed (sword _) w) = w'. +Proof. + intros sz sz' w w' h. + simpl. rewrite h. reflexivity. +Qed. + +Lemma translate_to_word : + ∀ sz v w, + to_word sz v = ok w → + truncate_chWord sz (translate_value v) = w. +Proof. + intros sz v w h. + destruct v as [| | | sz' w' | []]. all: try discriminate. + simpl in h. + unfold translate_value. + apply translate_truncate_word. assumption. +Qed. + Lemma translate_to_bool : ∀ v b, to_bool v = ok b → @@ -1202,7 +1223,36 @@ Proof. rewrite !coerce_to_choice_type_K. (* Should we have a chArray_get_sub lemma involving Warray.get_sub? *) admit. - - (* Pload *) admit. + - (* Pload *) + simpl in h1. jbind h1 w1 hw1. jbind hw1 vx hvx. + jbind h1 w2 hw2. jbind hw2 v2 hv2. jbind h1 w hw. noconf h1. + simpl. + eapply u_get_remember. simpl. intros x'. + rewrite bind_assoc. + eapply u_bind. + 1:{ + eapply IHe. 1: eassumption. + intros ? []. eauto. + } + simpl. + eapply u_get_remember. intros mem. + eapply u_ret. unfold u_get. intros m [[hm e1] e2]. + split. 1: assumption. + subst. + rewrite coerce_to_choice_type_K. + erewrite translate_pexpr_type. 2: eassumption. + rewrite coerce_to_choice_type_K. + erewrite translate_to_word. 2: eassumption. + (* eapply translate_to_word in hw1 as e1. *) + eapply hcond in hm. destruct hm as [hmm hvm]. + (* It feels like I shouldn't have to unfold get_var + and that somehow translate_get_var_correct should be of help here. + One possibility is to extract a lemma from it. + *) + (* unfold get_var in hvx. + eapply on_vuP. 3: exact hvx. + erewrite hvm. 2: eassumption. *) + admit. - (* Papp1 *) simpl in *. jbind h1 v' h2. From 9575012e6d90a8ac0cb7a4176cc7a086ad00545d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Tue, 5 Apr 2022 15:30:24 +0200 Subject: [PATCH 120/383] Factor get_var_get_heap out of translate_get_var_correct --- theories/Jasmin/jasmin_translate.v | 26 ++++++++++++++++++++------ 1 file changed, 20 insertions(+), 6 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index b96d3181..76375568 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -889,6 +889,22 @@ Proof. all: simpl. all: rewrite coerce_to_choice_type_K. all: reflexivity. Qed. +Lemma get_var_get_heap : + ∀ fn x s v m, + get_var (evm s) x = ok v → + rel_estate s fn m → + get_heap m (translate_var fn x) = + coerce_to_choice_type _ (translate_value v). +Proof. + intros fn x s v m ev hm. + unfold get_var in ev. + eapply on_vuP. 3: exact ev. 2: discriminate. + intros sx esx esv. + eapply hm in esx. subst. + rewrite coerce_to_choice_type_translate_value_to_val. + rewrite esx. rewrite coerce_to_choice_type_K. reflexivity. +Qed. + Lemma translate_get_var_correct : ∀ fn x s v (cond : heap → Prop), get_var (evm s) x = ok v → @@ -902,12 +918,10 @@ Proof. eapply u_get_remember. intros vx. eapply u_ret. intros m [hm hx]. split. 1: assumption. - unfold u_get in hx. unfold get_var in ev. - eapply on_vuP. 3: exact ev. 2: discriminate. - intros sx esx esv. - eapply hcond in hm. eapply hm in esx. subst. - rewrite coerce_to_choice_type_translate_value_to_val. - rewrite esx. rewrite coerce_to_choice_type_K. reflexivity. + unfold u_get in hx. subst. + eapply get_var_get_heap. + - eassumption. + - eapply hcond. assumption. Qed. Lemma translate_gvar_correct (f : funname) (x : gvar) (v : value) s (cond : heap → Prop) : From 31c1769782126e816c6af74ea46d806ed7bb8ac3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Tue, 5 Apr 2022 15:46:48 +0200 Subject: [PATCH 121/383] Massage Pload case a bit more --- theories/Jasmin/jasmin_translate.v | 14 +++++--------- 1 file changed, 5 insertions(+), 9 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 76375568..9169ec60 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1257,15 +1257,11 @@ Proof. erewrite translate_pexpr_type. 2: eassumption. rewrite coerce_to_choice_type_K. erewrite translate_to_word. 2: eassumption. - (* eapply translate_to_word in hw1 as e1. *) - eapply hcond in hm. destruct hm as [hmm hvm]. - (* It feels like I shouldn't have to unfold get_var - and that somehow translate_get_var_correct should be of help here. - One possibility is to extract a lemma from it. - *) - (* unfold get_var in hvx. - eapply on_vuP. 3: exact hvx. - erewrite hvm. 2: eassumption. *) + eapply hcond in hm. + erewrite get_var_get_heap. 2-3: eassumption. + simpl. erewrite <- type_of_get_var. 2: eassumption. + rewrite coerce_to_choice_type_K. + eapply translate_to_word in hw1 as e1. rewrite e1. clear e1. admit. - (* Papp1 *) simpl in *. From 8349138c611847a821882a2c81ac3ca9c1cfe79d Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Tue, 5 Apr 2022 15:51:01 +0200 Subject: [PATCH 122/383] proof of `Psub` case also changed `chArray_get_sub` slightly (see comment) --- theories/Jasmin/jasmin_translate.v | 76 ++++++++++++++++++++++++++++-- 1 file changed, 71 insertions(+), 5 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 9169ec60..1bfdb63f 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -296,6 +296,44 @@ Proof. assumption. Qed. +Lemma fold_set {S : eqType} (data : Mz.Map.t S) k v : + setm (Mz.fold (λ (k : Mz.Map.key) (v : S) (m : {fmap Z → S}), setm m k v) data emptym) k v = + Mz.fold (λ (k : Mz.Map.key) (v : S) (m : {fmap Z → S}), setm m k v) (Mz.set data k v) emptym. +Proof. + apply eq_fmap. + intros x. + rewrite fold_get. + rewrite setmE Mz.setP. + rewrite eq_sym. + destruct (k == x) eqn:E. + - move: E => /eqP->. rewrite eq_refl. reflexivity. + - move: E => /eqP E. + assert (H : (@eq_op Mz.K.t k x) = false). (* BSH: why is this so painful? *) + { apply /eqP. assumption. } + rewrite H. + rewrite fold_get. + reflexivity. +Qed. + +Lemma fold_rem {S : eqType} (data : Mz.Map.t S) k : + remm (Mz.fold (λ (k : Mz.Map.key) (v : S) (m : {fmap Z → S}), setm m k v) data emptym) k = + Mz.fold (λ (k : Mz.Map.key) (v : S) (m : {fmap Z → S}), setm m k v) (Mz.remove data k) emptym. +Proof. + apply eq_fmap. + intros x. + rewrite fold_get. + rewrite remmE Mz.removeP. + rewrite eq_sym. + destruct (k == x) eqn:E. + - move: E => /eqP->. rewrite eq_refl. reflexivity. + - move: E => /eqP E. + assert (H : (@eq_op Mz.K.t k x) = false). (* BSH: why is this so painful? *) + { apply /eqP. assumption. } + rewrite H. + rewrite fold_get. + reflexivity. +Qed. + Definition unembed {t : stype} : encode t → sem_t t := match t return encode t → sem_t t with | sbool => λ x, x @@ -516,9 +554,9 @@ Definition chArray_get_sub ws len (a : 'array) ptr scale := if (0 <=? start)%Z (* && (start + size <=? ) *) then ( foldr (λ (i : Z) (data : 'array), - match assoc a (start + i)%Z with + match a (start + i)%Z with | Some w => setm data i w - | None => data + | None => remm data i (* BSH: this should maybe not be done; I added it to simplify the proof of equivalence *) end ) emptym (ziota 0 size) ) @@ -1137,6 +1175,34 @@ Proof. reflexivity. Qed. +Lemma chArray_get_sub_correct (lena len : BinNums.positive) a aa sz i t : + WArray.get_sub aa sz len a i = ok t -> + chArray_get_sub sz len (translate_value (@Varr lena a)) i (mk_scale aa sz) = translate_value (Varr t). +Proof. + intros H. + unfold WArray.get_sub in H. + destruct (_ && _) eqn:E. 2: discriminate. + noconf H. + unfold chArray_get_sub. + unfold WArray.get_sub_data. + move: E => /andP []-> h2. + rewrite <- !foldl_rev. + apply ziota_ind. + - reflexivity. + - intros. + rewrite rev_cons. + rewrite !foldl_rcons. + rewrite H0. + rewrite fold_get. + destruct (Mz.get (WArray.arr_data a) (i * mk_scale aa sz + i0)%Z) eqn:E. + + rewrite E. + rewrite fold_set. + reflexivity. + + rewrite E. + rewrite fold_rem. + reflexivity. +Qed. + Lemma sop1_unembed_embed op v : sem_sop1_typed op (unembed (embed v)) = sem_sop1_typed op v. Proof. @@ -1235,8 +1301,8 @@ Proof. erewrite translate_to_int. 2: eassumption. apply type_of_get_gvar in hnt. rewrite <- hnt. rewrite !coerce_to_choice_type_K. - (* Should we have a chArray_get_sub lemma involving Warray.get_sub? *) - admit. + apply chArray_get_sub_correct. + assumption. - (* Pload *) simpl in h1. jbind h1 w1 hw1. jbind hw1 vx hvx. jbind h1 w2 hw2. jbind hw2 v2 hv2. jbind h1 w hw. noconf h1. @@ -1570,4 +1636,4 @@ Proof. admit. Admitted. -End Translation. \ No newline at end of file +End Translation. From c9d060845dc7f3b97839e83dcd94748fef545183 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Tue, 5 Apr 2022 15:59:11 +0200 Subject: [PATCH 123/383] Factor read_mem out of chRead to obtain more principled Pload goal --- theories/Jasmin/jasmin_translate.v | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 1bfdb63f..828d7806 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -565,17 +565,20 @@ Definition chArray_get_sub ws len (a : 'array) ptr scale := Definition totc (ty : choice_type) (c : raw_code ty) : typed_code := (ty ; c). -Definition chRead ptr ws : raw_code ('word ws) := - (* memory as array *) - mem ← get mem_loc ;; +Definition read_mem (m : 'mem) ptr ws : 'word ws := let f k := - match mem (ptr + (wrepr Uptr k))%R with + match m (ptr + (wrepr Uptr k))%R with | None => chCanonical ('word U8) | Some x => x end in let l := map f (ziota 0 (wsize_size ws)) in - ret (Jasmin.memory_model.LE.decode ws l). + Jasmin.memory_model.LE.decode ws l. + +Definition chRead ptr ws : raw_code ('word ws) := + (* memory as array *) + mem ← get mem_loc ;; + ret (read_mem mem ptr ws). (* Following sem_pexpr *) Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code := From c6d14a20e51ec2c0750dd7e0e46b19f32e40e071 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Tue, 5 Apr 2022 16:09:14 +0200 Subject: [PATCH 124/383] Define eq_op_MzK to simplify fold_set and fold_rem --- theories/Jasmin/jasmin_translate.v | 38 ++++++++++++++++-------------- 1 file changed, 20 insertions(+), 18 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 828d7806..959c7a10 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -296,42 +296,44 @@ Proof. assumption. Qed. +Lemma eq_op_MzK : + ∀ (k x : Z_ordType), + @eq_op Mz.K.t k x = (k == x). +Proof. + intros k x. + destruct (k == x) eqn: e. + - apply /eqP. move: e => /eqP. auto. + - apply /eqP. move: e => /eqP. auto. +Qed. + Lemma fold_set {S : eqType} (data : Mz.Map.t S) k v : setm (Mz.fold (λ (k : Mz.Map.key) (v : S) (m : {fmap Z → S}), setm m k v) data emptym) k v = - Mz.fold (λ (k : Mz.Map.key) (v : S) (m : {fmap Z → S}), setm m k v) (Mz.set data k v) emptym. + Mz.fold (λ (k : Mz.Map.key) (v : S) (m : {fmap Z → S}), setm m k v) (Mz.set data k v) emptym. Proof. apply eq_fmap. intros x. rewrite fold_get. rewrite setmE Mz.setP. rewrite eq_sym. - destruct (k == x) eqn:E. - - move: E => /eqP->. rewrite eq_refl. reflexivity. - - move: E => /eqP E. - assert (H : (@eq_op Mz.K.t k x) = false). (* BSH: why is this so painful? *) - { apply /eqP. assumption. } - rewrite H. - rewrite fold_get. - reflexivity. + rewrite eq_op_MzK. + destruct (k == x). + - reflexivity. + - rewrite fold_get. reflexivity. Qed. Lemma fold_rem {S : eqType} (data : Mz.Map.t S) k : remm (Mz.fold (λ (k : Mz.Map.key) (v : S) (m : {fmap Z → S}), setm m k v) data emptym) k = - Mz.fold (λ (k : Mz.Map.key) (v : S) (m : {fmap Z → S}), setm m k v) (Mz.remove data k) emptym. + Mz.fold (λ (k : Mz.Map.key) (v : S) (m : {fmap Z → S}), setm m k v) (Mz.remove data k) emptym. Proof. apply eq_fmap. intros x. rewrite fold_get. rewrite remmE Mz.removeP. rewrite eq_sym. - destruct (k == x) eqn:E. - - move: E => /eqP->. rewrite eq_refl. reflexivity. - - move: E => /eqP E. - assert (H : (@eq_op Mz.K.t k x) = false). (* BSH: why is this so painful? *) - { apply /eqP. assumption. } - rewrite H. - rewrite fold_get. - reflexivity. + rewrite eq_op_MzK. + destruct (k == x). + - reflexivity. + - rewrite fold_get. reflexivity. Qed. Definition unembed {t : stype} : encode t → sem_t t := From 4a5bb6c995b9418f6985a216989f59dde7701272 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Tue, 5 Apr 2022 16:34:15 +0200 Subject: [PATCH 125/383] Prove translate_read --- theories/Jasmin/jasmin_translate.v | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 959c7a10..b90a1d91 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -871,6 +871,25 @@ Definition rel_mem (m : mem) (h : heap) := (* get_heap h (translate_ptr ptr) = *) (* coerce_to_choice_type _ (translate_value (@to_val (sword U8) v)). *) +Lemma translate_read : + ∀ s ptr sz w m, + rel_mem s m → + read s ptr sz = ok w → + read_mem (get_heap m mem_loc) ptr sz = w. +Proof. + intros s ptr sz w m hm h. + rewrite readE in h. + jbind h _u eb. apply assertP in eb. + jbind h l hl. noconf h. + unfold read_mem. f_equal. + revert l hl. apply ziota_ind. + - simpl. intros l h. noconf h. reflexivity. + - simpl. intros i l' hi ih l h. + jbind h y hy. jbind h ys hys. noconf h. + erewrite ih. 2: exact hys. + eapply hm in hy. rewrite hy. reflexivity. +Qed. + #[local] Open Scope vmap_scope. Definition rel_vmap (vm : vmap) (fn : funname) (h : heap) := @@ -881,6 +900,16 @@ Definition rel_vmap (vm : vmap) (fn : funname) (h : heap) := Definition rel_estate (s : estate) (fn : funname) (h : heap) := rel_mem s.(emem) h ∧ rel_vmap s.(evm) fn h. +Lemma translate_read_estate : + ∀ fn s ptr sz w m, + rel_estate s fn m → + read (emem s) ptr sz = ok w → + read_mem (get_heap m mem_loc) ptr sz = w. +Proof. + intros fn s ptr sz w m [] h. + eapply translate_read. all: eassumption. +Qed. + Lemma coerce_cast_code (ty vty : choice_type) (v : vty) : ret (coerce_to_choice_type ty v) = coerce_typed_code ty (vty ; ret v). Proof. From b97d79ada7d441ceb057ca4848d2430962e7323f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Tue, 5 Apr 2022 16:36:44 +0200 Subject: [PATCH 126/383] Fix Pload case and prove it correct --- theories/Jasmin/jasmin_translate.v | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index b90a1d91..e068d83c 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -613,8 +613,7 @@ Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code := w ← translate_get_var fn x ;; let w1 : word _ := truncate_el (sword Uptr) w in w2 ← (truncate_code (sword Uptr) (translate_pexpr fn e)).π2 ;; - ww ← chRead (w1 + w2)%R sz ;; - ret (truncate_el (sword sz) ww) + chRead (w1 + w2)%R sz ) | Papp1 o e => totc _ ( @@ -1362,7 +1361,7 @@ Proof. simpl. erewrite <- type_of_get_var. 2: eassumption. rewrite coerce_to_choice_type_K. eapply translate_to_word in hw1 as e1. rewrite e1. clear e1. - admit. + eapply translate_read_estate. all: eassumption. - (* Papp1 *) simpl in *. jbind h1 v' h2. From dd6254e9788b1c49890692bc9ead93863195c62c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Tue, 5 Apr 2022 16:58:59 +0200 Subject: [PATCH 127/383] translate_cmd cases of translate_prog --- theories/Jasmin/jasmin_translate.v | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index e068d83c..2aae72af 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1622,12 +1622,14 @@ Proof. ⦃ rel_estate s2 fn ⦄ ). unshelve eapply (@sem_call_Ind _ _ _ _ Pc Pi_r Pi Pfor Pfun _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H). + - red. intros s. + red. simpl. + eapply u_ret_eq. auto. - red. intros. - red. unfold translate_cmd. - admit. - - red. intros. - red. unfold translate_cmd. simpl. - admit. + red. simpl. + eapply u_bind. + + (* eapply translate_instr_correct. *) admit. + + eassumption. - red. intros. apply H1. - red. intros s₁ s₂ x tag ty e v v' he hv hw. From 2e7a23da528cce233010cf669612eaad56c8e724 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Wed, 6 Apr 2022 11:12:27 +0200 Subject: [PATCH 128/383] Define write_mem and translate_write --- theories/Jasmin/jasmin_translate.v | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 2aae72af..cf2edfcb 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -582,6 +582,16 @@ Definition chRead ptr ws : raw_code ('word ws) := mem ← get mem_loc ;; ret (read_mem mem ptr ws). +(* Behaviour of write from Jasmin *) +Definition write_mem {sz} (m : 'mem) (ptr : word Uptr) (w : word sz) : 'mem := + (* For now we do not worry about alignment *) + foldr (λ (k : Z) (m' : 'mem), + setm m' (ptr + (wrepr Uptr k))%R (LE.wread8 w k) + ) m (ziota 0 (wsize_size sz)). + +Definition translate_write {sz} (p : word Uptr) (w : word sz) : raw_code 'unit := + m ← get mem_loc ;; #put mem_loc := write_mem m p w ;; ret tt. + (* Following sem_pexpr *) Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code := match e with @@ -684,10 +694,6 @@ Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code := (* pose (vs' := fold (fun x => y ← x ;; unembed y) f vs). *) -Definition translate_write {n} (p : word Uptr) (w : word n) : raw_code 'unit := - (* For now we do not worry about alignment *) - unsupported.π2. (* Do we really have to slice the word into 8bit parts? *) - Definition translate_write_lval (fn : funname) (l : lval) (v : typed_code) : raw_code 'unit := From a166157b8509a25355ebb197cbe16b02d1d31286 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Wed, 6 Apr 2022 11:31:06 +0200 Subject: [PATCH 129/383] State and start translate_write_mem_correct --- theories/Jasmin/jasmin_translate.v | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index cf2edfcb..387b01b8 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -895,6 +895,27 @@ Proof. eapply hm in hy. rewrite hy. reflexivity. Qed. +Lemma translate_write_mem_correct : + ∀ sz cm cm' ptr w m, + write cm ptr (sz := sz) w = ok cm' → + rel_mem cm m → + rel_mem cm' (set_heap m mem_loc (write_mem (get_heap m mem_loc) ptr w)). +Proof. + intros sz cm cm' ptr w m hw hr. + intros ptr' v ev. + rewrite get_set_heap_eq. + unfold write in hw. destruct is_align eqn:eal. 2: discriminate. + simpl in hw. + unfold write_mem. + revert cm cm' hw hr v ev. apply ziota_ind. + - simpl. intros cm cm' hw hr v ev. + noconf hw. apply hr. assumption. + - simpl. intros i l hi ih cm cm' hw hr v ev. + jbind hw acc hacc. + rewrite setmE. + (* Maybe should prove stuff like writeP_eq/neq or write_read8 *) +Abort. + #[local] Open Scope vmap_scope. Definition rel_vmap (vm : vmap) (fn : funname) (h : heap) := From c99040def48f9435bc34923286196f8251f08592 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Wed, 6 Apr 2022 11:50:50 +0200 Subject: [PATCH 130/383] State write_read_mem8, is it correct? --- theories/Jasmin/jasmin_translate.v | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 387b01b8..2525f423 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -895,6 +895,33 @@ Proof. eapply hm in hy. rewrite hy. reflexivity. Qed. +Lemma write_read_mem8 : + ∀ m p ws w p', + read_mem (write_mem (sz := ws) m p w) p' U8 = + (let i := sub p' p in + if (0 <=? i)%Z && (i Date: Wed, 6 Apr 2022 15:16:46 +0200 Subject: [PATCH 131/383] progress on `write_read8` - change to consistently use `foldr` over `foldl` (makes induction more natural) - prove `get_read8` --- theories/Jasmin/jasmin_translate.v | 123 ++++++++++++++++------------- 1 file changed, 67 insertions(+), 56 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 2525f423..c1cce9bd 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -203,44 +203,22 @@ Proof. discriminate. Qed. -Lemma In_rcons {A} x y (l : seq A) : - List.In x (rcons l y) → - y = x ∨ List.In x l. -Proof. - intro h. - induction l in h |- *. all: simpl in *. all: intuition subst. -Qed. - -Lemma NIn_rcons {A} x y (l : seq A) : - ~ List.In x (rcons l y) → - y ≠ x ∧ ~ List.In x l. -Proof. - induction l; intros; simpl in *; intuition subst. -Qed. - Lemma foldl_In_uniq {S : eqType} (k : Mz.K.t) (v : S) (data : seq (Mz.K.t * S)) : List.In (k, v) data → @uniq Mz.K.t [seq i.1 | i <- data] → - foldl (λ (a : {fmap Mz.K.t → S}) (kv : Mz.K.t * S), setm a kv.1 kv.2) emptym data k = Some v. + foldr (λ (kv : Mz.K.t * S) (a : {fmap Mz.K.t → S}), setm a kv.1 kv.2) emptym data k = Some v. Proof. intros. - replace data with (rev (rev data)) in * by apply revK. - set (data' := rev data) in *. - induction data'. + induction data. - easy. - - rewrite rev_cons. - rewrite rev_cons in H. - apply In_rcons in H. - rewrite foldl_rcons. + - simpl in H. + simpl. destruct H. + subst. simpl. rewrite setmE. rewrite eq_refl. reflexivity. - + rewrite rev_cons in H0. - rewrite map_rcons in H0. - rewrite rcons_uniq in H0. - move: H0 => /andP [H1 H2]. + + move: H0 => /andP [H1 H2]. move: H1 => /in_map H3. assert (negb (@eq_op Z_ordType k a.1)). { apply /eqP => contra; case: H3; exists (a.1, v); by move: contra <-. @@ -249,49 +227,55 @@ Proof. rewrite <- negbK. rewrite H0. simpl. - apply IHdata'; assumption. + apply IHdata; assumption. Qed. Lemma foldl_NIn {S : eqType} (k : Mz.K.t) (data : seq (Mz.K.t * S)) : (∀ w, ~ List.In (k, w) data) → - foldl (λ (a : {fmap Mz.K.t → S}) (kv : Mz.K.t * S), setm a kv.1 kv.2) emptym data k = None. + foldr (λ (kv : Mz.K.t * S) (a : {fmap Mz.K.t → S}), setm a kv.1 kv.2) emptym data k = None. Proof. intros. - replace data with (rev (rev data)) in * by apply revK. - set (data' := rev data) in *. - induction data'. + induction data. - easy. - - rewrite rev_cons. - rewrite rev_cons in H. - specialize (H a.2) as H0. - rewrite foldl_rcons. - apply NIn_rcons in H0 as [H1]. + - specialize (H a.2) as H0. + simpl. apply List.not_in_cons in H0 as [H0 H1]. assert (negb (@eq_op Z_ordType k a.1)). { - apply /eqP => contra. apply H1. move: contra ->. apply surjective_pairing. } + apply /eqP => contra. apply H0. move: contra ->. symmetry. apply surjective_pairing. } rewrite setmE. rewrite <- negbK. rewrite H2. simpl. - apply IHdata'. + apply IHdata. intros. specialize (H w). - apply NIn_rcons in H. easy. + apply List.not_in_cons in H. easy. +Qed. + +Lemma rev_list_rev {S} : + forall l : seq S, List.rev l = rev l. +Proof. + induction l; intuition subst; simpl. + rewrite rev_cons. rewrite IHl. rewrite <- cats1. reflexivity. Qed. Lemma fold_get {S : eqType} (data : Mz.Map.t S) i : Mz.fold (λ k v m, setm m k v) data emptym i = Mz.get data i. Proof. rewrite Mz.foldP. + replace (Mz.elements data) with (rev (rev (Mz.elements data))). 2: by rewrite revK. + rewrite foldl_rev. destruct Mz.get eqn:E. - set (kv := (i, s)). replace i with kv.1 in * by reflexivity. replace s with kv.2 in * by reflexivity. apply Mz.elementsIn in E. subst kv. apply foldl_In_uniq. - + assumption. - + apply Mz.elementsU. + + rewrite <- rev_list_rev. apply -> List.in_rev. assumption. + + rewrite map_rev. rewrite rev_uniq. apply Mz.elementsU. - apply foldl_NIn. intros. + rewrite <- rev_list_rev. + rewrite <- List.in_rev. apply elementsNIn. assumption. Qed. @@ -895,6 +879,23 @@ Proof. eapply hm in hy. rewrite hy. reflexivity. Qed. +Lemma get_mem_read8 : + ∀ m p, + read_mem m p U8 = + match m p with + | Some w => w + | None => chCanonical _ + end. +Proof. + intros. + unfold read_mem. + simpl. + rewrite <- addE. + rewrite add_0. + destruct (m p) eqn:E. + all: rewrite E; rewrite <- LE.encode8E; apply LE.decodeK. +Qed. + Lemma write_read_mem8 : ∀ m p ws w p', read_mem (write_mem (sz := ws) m p w) p' U8 = @@ -905,21 +906,31 @@ Lemma write_read_mem8 : ). Proof. intros m p ws w p'. - unfold read_mem, write_mem. + unfold write_mem. + rewrite -in_ziota. + unfold wsize_size. apply ziota_ind. - - simpl. destruct getm eqn:e. - + destruct (_ : bool) eqn:eb. - * give_up. (* Lost the connection to w? *) - * reflexivity. - + destruct (_ : bool) eqn:eb. - * admit. - * reflexivity. - - simpl. intros i l ei ih. - rewrite <- ih. f_equal. f_equal. - rewrite setmE. - destruct (_ == _) eqn:eb. - + give_up. - + reflexivity. + - reflexivity. + - intros. + rewrite (@in_cons ssrZ.Z_eqType). + destruct (@eq_op ssrZ.Z_eqType (sub p' p) i) eqn:eb. + + simpl. + move: eb => /eqP eb. + rewrite <- addE. + rewrite get_mem_read8. + rewrite setmE. + destruct (@eq_op _ p' (add p i)) eqn:E. + * rewrite E. rewrite eb. + reflexivity. + * rewrite E. + move: E => /eqP E. + rewrite <- eb in E. + rewrite add_sub in E. + contradiction. + + rewrite Bool.orb_false_l. + simpl. + eapply eq_trans. 2: apply H0. + admit. Abort. Lemma translate_write_mem_correct : From 06b347f21a11cdf846084da246e81b2b52814b59 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Wed, 6 Apr 2022 17:22:34 +0200 Subject: [PATCH 132/383] Nits --- theories/Jasmin/jasmin_translate.v | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index c1cce9bd..e3109169 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -252,7 +252,7 @@ Proof. Qed. Lemma rev_list_rev {S} : - forall l : seq S, List.rev l = rev l. + ∀ (l : seq S), List.rev l = rev l. Proof. induction l; intuition subst; simpl. rewrite rev_cons. rewrite IHl. rewrite <- cats1. reflexivity. @@ -882,20 +882,20 @@ Qed. Lemma get_mem_read8 : ∀ m p, read_mem m p U8 = - match m p with - | Some w => w - | None => chCanonical _ - end. + match m p with + | Some w => w + | None => chCanonical _ + end. Proof. - intros. - unfold read_mem. - simpl. + intros m p. + unfold read_mem. simpl. rewrite <- addE. rewrite add_0. destruct (m p) eqn:E. all: rewrite E; rewrite <- LE.encode8E; apply LE.decodeK. Qed. +(* Copy of write_read8 (probably not true without alignment stuff) *) Lemma write_read_mem8 : ∀ m p ws w p', read_mem (write_mem (sz := ws) m p w) p' U8 = @@ -951,6 +951,7 @@ Proof. - simpl. intros i l hi ih cm cm' hw hr v ev. jbind hw acc hacc. rewrite setmE. + destruct (_ == _) eqn:eb. (* Maybe should prove stuff like writeP_eq/neq or write_read8 *) Abort. From b42617ebc4f6854f63c2cb12f8990dac7a157b26 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Wed, 6 Apr 2022 17:23:02 +0200 Subject: [PATCH 133/383] prove `write_read_mem8` --- theories/Jasmin/jasmin_translate.v | 19 +++++++++++++++++-- 1 file changed, 17 insertions(+), 2 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index e3109169..8248c43a 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -905,6 +905,7 @@ Lemma write_read_mem8 : else read_mem m p' U8 ). Proof. + (* BSH: this proof is more messy that it has to be *) intros m p ws w p'. unfold write_mem. rewrite -in_ziota. @@ -930,8 +931,22 @@ Proof. + rewrite Bool.orb_false_l. simpl. eapply eq_trans. 2: apply H0. - admit. -Abort. + unfold read_mem . + simpl. + rewrite <- !LE.encode8E. + rewrite !LE.decodeK. + rewrite <- !addE. + rewrite add_0. + rewrite setmE. + destruct (p' == add p i) eqn:E. + * move: E => /eqP E. + move: eb => /eqP eb. + rewrite E in eb. + rewrite sub_add in eb. 2: { destruct ws; unfold wsize_size; micromega.Lia.lia. } + contradiction. + * rewrite E. + reflexivity. +Qed. Lemma translate_write_mem_correct : ∀ sz cm cm' ptr w m, From b4a3d9305a529f00fd52b3b80812ea2e969b4d43 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Wed, 6 Apr 2022 17:45:52 +0200 Subject: [PATCH 134/383] Progress (?) with translate_write_mem_correct --- theories/Jasmin/jasmin_translate.v | 26 +++++++++++++++----------- 1 file changed, 15 insertions(+), 11 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 8248c43a..1e0f2d62 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -957,17 +957,21 @@ Proof. intros sz cm cm' ptr w m hw hr. intros ptr' v ev. rewrite get_set_heap_eq. - unfold write in hw. destruct is_align eqn:eal. 2: discriminate. - simpl in hw. - unfold write_mem. - revert cm cm' hw hr v ev. apply ziota_ind. - - simpl. intros cm cm' hw hr v ev. - noconf hw. apply hr. assumption. - - simpl. intros i l hi ih cm cm' hw hr v ev. - jbind hw acc hacc. - rewrite setmE. - destruct (_ == _) eqn:eb. - (* Maybe should prove stuff like writeP_eq/neq or write_read8 *) + + erewrite write_read8 in ev. 2: exact hw. + simpl in ev. + + pose proof (write_read_mem8 (get_heap m mem_loc) ptr sz w ptr') as h. + rewrite get_mem_read8 in h. + destruct getm eqn:e. + 2:{ + (* Is there a contradiction here? *) + admit. + } + subst. simpl. + destruct (_ : bool) eqn:eb. + - noconf ev. reflexivity. + - apply hr in ev. rewrite get_mem_read8. rewrite ev. reflexivity. Abort. #[local] Open Scope vmap_scope. From de2ecf9e4bfca7023c1a1ab9a07d8cc916c453dc Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Wed, 6 Apr 2022 20:54:19 +0200 Subject: [PATCH 135/383] prove `translate_write_mem_correct` and change read/write lemmas --- theories/Jasmin/jasmin_translate.v | 94 +++++++++++++----------------- 1 file changed, 42 insertions(+), 52 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 1e0f2d62..ec075821 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -895,57 +895,54 @@ Proof. all: rewrite E; rewrite <- LE.encode8E; apply LE.decodeK. Qed. -(* Copy of write_read8 (probably not true without alignment stuff) *) -Lemma write_read_mem8 : - ∀ m p ws w p', - read_mem (write_mem (sz := ws) m p w) p' U8 = - (let i := sub p' p in - if (0 <=? i)%Z && (i /eqP eb. - rewrite <- addE. - rewrite get_mem_read8. + + move: eb => /eqP <-. rewrite setmE. - destruct (@eq_op _ p' (add p i)) eqn:E. - * rewrite E. rewrite eb. - reflexivity. - * rewrite E. - move: E => /eqP E. - rewrite <- eb in E. - rewrite add_sub in E. - contradiction. - + rewrite Bool.orb_false_l. - simpl. - eapply eq_trans. 2: apply H0. - unfold read_mem . - simpl. - rewrite <- !LE.encode8E. - rewrite !LE.decodeK. - rewrite <- !addE. - rewrite add_0. + rewrite add_sub. + rewrite !eq_refl. + reflexivity. + + rewrite eb. + move: eb => /eqP. rewrite setmE. destruct (p' == add p i) eqn:E. - * move: E => /eqP E. - move: eb => /eqP eb. + * rewrite E. + move: E => /eqP E eb. rewrite E in eb. rewrite sub_add in eb. 2: { destruct ws; unfold wsize_size; micromega.Lia.lia. } contradiction. - * rewrite E. - reflexivity. + * rewrite E. intros. apply Ih. +Qed. + +(* Copy of write_read8 (probably not true without alignment stuff) *) +(* BSH: i don't know if we need this any more (see write_mem_get) *) +Lemma write_read_mem8 : + ∀ m p ws w p', + read_mem (write_mem (sz := ws) m p w) p' U8 = + (let i := sub p' p in + if (0 <=? i)%Z && (i Date: Thu, 7 Apr 2022 10:56:06 +0200 Subject: [PATCH 136/383] Prove translate_write_estate --- theories/Jasmin/jasmin_translate.v | 58 ++++++++++++++++++------------ 1 file changed, 36 insertions(+), 22 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index ec075821..913d69bd 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -897,37 +897,37 @@ Qed. Lemma write_mem_get ws m p (w : word ws) p' : write_mem m p w p' = - if (0 <=? sub p' p)%Z && (sub p' p /eqP <-. rewrite setmE. rewrite add_sub. rewrite !eq_refl. reflexivity. - + rewrite eb. - move: eb => /eqP. + + move: eb => /eqP. rewrite setmE. destruct (p' == add p i) eqn:E. * rewrite E. move: E => /eqP E eb. rewrite E in eb. - rewrite sub_add in eb. 2: { destruct ws; unfold wsize_size; micromega.Lia.lia. } + rewrite sub_add in eb. + 2:{ destruct ws. all: unfold wsize_size. all: micromega.Lia.lia. } contradiction. * rewrite E. intros. apply Ih. Qed. -(* Copy of write_read8 (probably not true without alignment stuff) *) +(* Copy of write_read8 *) (* BSH: i don't know if we need this any more (see write_mem_get) *) Lemma write_read_mem8 : ∀ m p ws w p', @@ -942,7 +942,8 @@ Proof. simpl. rewrite !get_mem_read8. rewrite write_mem_get. - destruct (_ : bool) eqn:eb; reflexivity. + destruct (_ : bool) eqn:eb. + all: reflexivity. Qed. Lemma translate_write_mem_correct : @@ -954,12 +955,10 @@ Proof. intros sz cm cm' ptr w m hw hr. intros ptr' v ev. rewrite get_set_heap_eq. - rewrite write_mem_get. - - erewrite write_read8 in ev. 2: exact hw. simpl in ev. - - destruct (_ : bool) eqn:eb. + erewrite write_read8 in ev. 2: exact hw. + simpl in ev. + destruct (_ : bool). - noconf ev. reflexivity. - apply hr. assumption. Qed. @@ -984,6 +983,27 @@ Proof. eapply translate_read. all: eassumption. Qed. +Lemma mem_loc_translate_var_neq : + ∀ fn x, + mem_loc != translate_var fn x. +Proof. +Admitted. + +Lemma translate_write_estate : + ∀ fn sz s cm ptr w m, + write s.(emem) ptr (sz := sz) w = ok cm → + rel_estate s fn m → + rel_estate {| emem := cm ; evm := s.(evm) |} fn (set_heap m mem_loc (write_mem (get_heap m mem_loc) ptr w)). +Proof. + intros fn sz s cm ptr w m hw [hrm hvm]. + split. + - simpl. eapply translate_write_mem_correct. all: eassumption. + - simpl. intros i v ev. + rewrite get_set_heap_neq. + 2:{ rewrite eq_sym. apply mem_loc_translate_var_neq. } + apply hvm. assumption. +Qed. + Lemma coerce_cast_code (ty vty : choice_type) (v : vty) : ret (coerce_to_choice_type ty v) = coerce_typed_code ty (vty ; ret v). Proof. @@ -1537,12 +1557,6 @@ Lemma injective_translate_var : Proof. Admitted. -Lemma mem_loc_translate_var_neq : - ∀ fn x, - mem_loc != translate_var fn x. -Proof. -Admitted. - (* TODO Make fixpoint too! *) Lemma translate_instr_r_correct : ∀ (fn : funname) (i : instr_r) (s₁ s₂ : estate), From e1b0331218fbae240bb1a08e79a230ba6af07451 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 7 Apr 2022 11:32:01 +0200 Subject: [PATCH 137/383] Prove translate_write_correct and progress with translate_instr_r_correct --- theories/Jasmin/jasmin_translate.v | 32 +++++++++++++++++++++++++++++- 1 file changed, 31 insertions(+), 1 deletion(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 913d69bd..78ebf2c1 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1557,6 +1557,24 @@ Lemma injective_translate_var : Proof. Admitted. +Lemma translate_write_correct : + ∀ fn sz s p (w : word sz) cm (cond : heap → Prop), + write s.(emem) p w = ok cm → + (∀ m, cond m → rel_estate s fn m) → + ⊢ ⦃ cond ⦄ translate_write p w ⇓ tt ⦃ rel_estate {| emem := cm ; evm := s.(evm) |} fn ⦄. +Proof. + intros fn sz s p w cm cond h hcond. + unfold translate_write. + eapply u_get_remember. intros m. + eapply u_put. + eapply u_ret_eq. + intros ? [m' [[h1 h2] ?]]. subst. + unfold u_get in h2. subst. + eapply translate_write_estate. + - assumption. + - apply hcond. assumption. +Qed. + (* TODO Make fixpoint too! *) Lemma translate_instr_r_correct : ∀ (fn : funname) (i : instr_r) (s₁ s₂ : estate), @@ -1652,7 +1670,19 @@ Proof. - eassumption. - intros ? []. assumption. } - simpl. admit. + simpl. + eapply translate_write_correct. 2:{ intros ? []. auto. } + erewrite translate_pexpr_type. 2: eassumption. + erewrite translate_pexpr_type. 2: eassumption. + rewrite !coerce_to_choice_type_K. + erewrite translate_truncate_val. 2: eassumption. + eapply truncate_val_type in trunc as ety. subst. + rewrite coerce_to_choice_type_K. + eapply translate_to_word in hw' as ew. rewrite ew. clear ew. + unfold translate_to_pointer. simpl. + eapply translate_to_word in hve as ew. rewrite ew. clear ew. + simpl in tv. (* Missing something on tv to conclude *) + admit. + admit. + admit. - admit. From 4c0710e053d403cea6cfc02097feddb147d91b6c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 7 Apr 2022 11:58:50 +0200 Subject: [PATCH 138/383] Lmem case of translate_instr_r_correct --- theories/Jasmin/jasmin_translate.v | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 78ebf2c1..bb730657 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1559,20 +1559,18 @@ Admitted. Lemma translate_write_correct : ∀ fn sz s p (w : word sz) cm (cond : heap → Prop), - write s.(emem) p w = ok cm → - (∀ m, cond m → rel_estate s fn m) → + (∀ m, cond m → write s.(emem) p w = ok cm ∧ rel_estate s fn m) → ⊢ ⦃ cond ⦄ translate_write p w ⇓ tt ⦃ rel_estate {| emem := cm ; evm := s.(evm) |} fn ⦄. Proof. - intros fn sz s p w cm cond h hcond. + intros fn sz s p w cm cond h. unfold translate_write. eapply u_get_remember. intros m. eapply u_put. eapply u_ret_eq. intros ? [m' [[h1 h2] ?]]. subst. unfold u_get in h2. subst. - eapply translate_write_estate. - - assumption. - - apply hcond. assumption. + eapply h in h1. destruct h1. + eapply translate_write_estate. all: assumption. Qed. (* TODO Make fixpoint too! *) @@ -1671,7 +1669,9 @@ Proof. - intros ? []. assumption. } simpl. - eapply translate_write_correct. 2:{ intros ? []. auto. } + eapply translate_write_correct. intros m' [hm' em']. + unfold u_get in em'. subst. + split. 2: assumption. erewrite translate_pexpr_type. 2: eassumption. erewrite translate_pexpr_type. 2: eassumption. rewrite !coerce_to_choice_type_K. @@ -1681,8 +1681,11 @@ Proof. eapply translate_to_word in hw' as ew. rewrite ew. clear ew. unfold translate_to_pointer. simpl. eapply translate_to_word in hve as ew. rewrite ew. clear ew. - simpl in tv. (* Missing something on tv to conclude *) - admit. + erewrite get_var_get_heap. 2,3: eassumption. + simpl. erewrite <- type_of_get_var. 2: eassumption. + rewrite coerce_to_choice_type_K. + eapply translate_to_word in hvx as ew. rewrite ew. clear ew. + assumption. + admit. + admit. - admit. From b66ee80cfbec4b8ae28cc46e5f8692475fd9dc15 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 7 Apr 2022 16:17:16 +0200 Subject: [PATCH 139/383] Define chArray_write --- theories/Jasmin/jasmin_translate.v | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index bb730657..a64cec10 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -551,6 +551,7 @@ Definition chArray_get_sub ws len (a : 'array) ptr scale := Definition totc (ty : choice_type) (c : raw_code ty) : typed_code := (ty ; c). +(* Almost chArray_get but with a different key type *) Definition read_mem (m : 'mem) ptr ws : 'word ws := let f k := match m (ptr + (wrepr Uptr k))%R with @@ -566,7 +567,14 @@ Definition chRead ptr ws : raw_code ('word ws) := mem ← get mem_loc ;; ret (read_mem mem ptr ws). -(* Behaviour of write from Jasmin *) +(* Jasmin's write on 'array *) +Definition chArray_write {sz} (a : 'array) ptr scale (w : word sz) : 'array := + (* For now we do not worry about alignment *) + foldr (λ (k : Z) (a' : 'array), + setm a' (ptr * scale + k)%Z (LE.wread8 w k) + ) a (ziota 0 (wsize_size sz)). + +(* Jasmin's write on 'mem *) Definition write_mem {sz} (m : 'mem) (ptr : word Uptr) (w : word sz) : 'mem := (* For now we do not worry about alignment *) foldr (λ (k : Z) (m' : 'mem), From 6e3d62d9331dafb004df0f1e4fcce2f578149fed Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 7 Apr 2022 16:31:14 +0200 Subject: [PATCH 140/383] Lasub case of translate_write_lval --- theories/Jasmin/jasmin_translate.v | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index a64cec10..4fbc54d2 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -568,12 +568,16 @@ Definition chRead ptr ws : raw_code ('word ws) := ret (read_mem mem ptr ws). (* Jasmin's write on 'array *) -Definition chArray_write {sz} (a : 'array) ptr scale (w : word sz) : 'array := +Definition chArray_write {sz} (a : 'array) ptr (w : word sz) : 'array := (* For now we do not worry about alignment *) foldr (λ (k : Z) (a' : 'array), - setm a' (ptr * scale + k)%Z (LE.wread8 w k) + setm a' (ptr + k)%Z (LE.wread8 w k) ) a (ziota 0 (wsize_size sz)). +(* From WArray.set *) +Definition chArray_set {ws} (a : 'array) (aa : arr_access) (p : Z) (w : word ws) := + chArray_write a (p * mk_scale aa ws)%Z w. + (* Jasmin's write on 'mem *) Definition write_mem {sz} (m : 'mem) (ptr : word Uptr) (w : word sz) : 'mem := (* For now we do not worry about alignment *) @@ -709,8 +713,8 @@ Definition translate_write_lval (fn : funname) (l : lval) (v : typed_code) i ← (truncate_code sint (translate_pexpr fn i)).π2 ;; (* to_int *) v ← v.π2 ;; let v := truncate_chWord ws v in - (* let t := setm t i v in *) (* WArray.set also calls write *) - unsupported.π2 + let t := chArray_set t aa i v in + translate_write_var fn x (totc _ (ret t)) | Lasub aa ws len x i => (* Same observation as Laset *) t' ← translate_get_var fn x ;; @@ -718,12 +722,7 @@ Definition translate_write_lval (fn : funname) (l : lval) (v : typed_code) (* Again, we ignore the length *) (* Let t' := to_arr (Z.to_pos (arr_size ws len)) v in *) unsupported.π2 - (* | Laset aa ws x i => - Let (n,t) := s.[x] in - Let i := sem_pexpr s i >>= to_int in - Let v := to_word ws v in - Let t := WArray.set t aa i v in - write_var x (@to_val (sarr n) t) s *) + (* | Lasub aa ws len x i => Let (n,t) := s.[x] in Let i := sem_pexpr s i >>= to_int in From 6af3db3c60c6fca0269afa9dfeaacc3b6aa79c41 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 7 Apr 2022 16:38:34 +0200 Subject: [PATCH 141/383] Start Lasub case of translate_instr_r_correct --- theories/Jasmin/jasmin_translate.v | 24 +++++++++++++++++++++++- 1 file changed, 23 insertions(+), 1 deletion(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 4fbc54d2..a3e5e7e4 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1693,7 +1693,29 @@ Proof. rewrite coerce_to_choice_type_K. eapply translate_to_word in hvx as ew. rewrite ew. clear ew. assumption. - + admit. + + simpl. simpl in hw. + jbind hw nt hnt. destruct nt. all: try discriminate. + jbind hw i hi. jbind hi i' hi'. + jbind hw w ew. jbind hw t ht. + eapply u_get_remember. simpl. intros vx. + rewrite !bind_assoc. simpl. + eapply u_bind. + 1:{ + eapply translate_pexpr_correct. + - eassumption. + - intros ? []. assumption. + } + rewrite !bind_assoc. + eapply u_bind. + 1:{ + eapply translate_pexpr_correct. + - eassumption. + - intros ? []. assumption. + } + simpl. + (* TODO Lemma needed, will also use above *) + (* eapply translate_write_var_correct. *) + admit. + admit. - admit. - admit. From ed2ca4de13a1e4af53df16f2334fe46b998dd40a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 7 Apr 2022 17:41:37 +0200 Subject: [PATCH 142/383] More on *Laset* case Previous commits are ill-named. --- theories/Jasmin/jasmin_translate.v | 67 +++++++++++++++++++++++++++--- 1 file changed, 62 insertions(+), 5 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index a3e5e7e4..4639547c 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1590,7 +1590,7 @@ Lemma translate_instr_r_correct : Proof. intros fn i s₁ s₂ h. induction h as [es₁ es₂ y tag sty e v v' sem_e trunc hw | | | | | | |]. - - simpl. destruct y as [ | yl | | | ] eqn:case_lval. + - simpl. destruct y as [ | yl | | aa ws x ei | ] eqn:case_lval. + simpl. apply u_ret_eq. intros hp hr. simpl in hw. unfold write_none in hw. destruct is_sbool eqn:eb. @@ -1697,6 +1697,8 @@ Proof. jbind hw nt hnt. destruct nt. all: try discriminate. jbind hw i hi. jbind hi i' hi'. jbind hw w ew. jbind hw t ht. + unfold write_var in hw. jbind hw vm hvm. + noconf hw. eapply u_get_remember. simpl. intros vx. rewrite !bind_assoc. simpl. eapply u_bind. @@ -1712,10 +1714,65 @@ Proof. - eassumption. - intros ? []. assumption. } - simpl. - (* TODO Lemma needed, will also use above *) - (* eapply translate_write_var_correct. *) - admit. + simpl. unfold translate_write_var. simpl. + eapply u_put. + eapply u_ret_eq. + intros ? [m [[[hr hv] hm] ?]]. subst. + unfold u_get in hm. subst. + split. + * intros ptr byte hby. + rewrite get_set_heap_neq. 2: eapply mem_loc_translate_var_neq. + apply hr. assumption. + * { + simpl. intros j vj ej. + simpl. rewrite coerce_to_choice_type_K. + eapply set_varP. 3: exact hvm. + - intros v₁ hv₁ eyl. subst. + destruct (j == x) eqn:evar. + all: move: evar => /eqP evar. + + subst. rewrite Fv.setP_eq in ej. noconf ej. + rewrite get_set_heap_eq. + apply truncate_val_type in trunc as ety. subst. + erewrite translate_pexpr_type. 2: eassumption. + erewrite translate_pexpr_type. 2: eassumption. + rewrite !coerce_to_choice_type_K. + eapply translate_truncate_val in trunc. + rewrite trunc. rewrite coerce_to_choice_type_K. + eapply translate_to_word in ew. rewrite ew. + erewrite translate_to_int. 2: eassumption. + (* Need a lemma relating WArray.set and chArray_set probably *) + (* eapply translate_of_val in hv₁. + rewrite hv₁. apply coerce_to_choice_type_translate_value_to_val. *) + admit. + + rewrite Fv.setP_neq in ej. + 2:{ apply /eqP. eauto. } + rewrite get_set_heap_neq. + 2:{ + apply /eqP. intro ee. + apply injective_translate_var in ee. + contradiction. + } + eapply hv in ej. rewrite ej. + rewrite coerce_to_choice_type_K. reflexivity. + - intros hbo hyl hset. + subst. + destruct (j == x) eqn:evar. + all: move: evar => /eqP evar. + 1:{ + exfalso. subst. rewrite Fv.setP_eq in ej. + clear - ej hbo. destruct (vtype x). all: discriminate. + } + rewrite Fv.setP_neq in ej. + 2:{ apply /eqP. eauto. } + rewrite get_set_heap_neq. + 2:{ + apply /eqP. intro ee. + apply injective_translate_var in ee. + contradiction. + } + eapply hv in ej. rewrite ej. + rewrite coerce_to_choice_type_K. reflexivity. + } + admit. - admit. - admit. From b0023de2004061d1a917916769d576a35f44ee9b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Mon, 11 Apr 2022 11:16:08 +0200 Subject: [PATCH 143/383] State chArray_write_correct --- theories/Jasmin/jasmin_translate.v | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 4639547c..e7586cef 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1338,6 +1338,32 @@ Proof. reflexivity. Qed. +Lemma chArray_write_correct : + ∀ ws len (a : WArray.array len) i (w : word ws) t, + write a i w = ok t → + chArray_write (translate_value (Varr a)) i w = translate_value (Varr t). +Proof. + intros ws len a i w t h. + unfold write in h. + jbind h _u eb. apply assertP in eb. + unfold chArray_write. + revert a t h. eapply ziota_ind. + - simpl. intros a t e. noconf e. reflexivity. + - simpl. intros k l hk ih a t h. + jbind h acc hacc. + eapply ih in h. rewrite <- h. +Abort. + +Lemma chArray_set_correct : + ∀ ws len (a : WArray.array len) aa i (w : word ws) t, + WArray.set a aa i w = ok t → + chArray_set (translate_value (Varr a)) aa i w = translate_value (Varr t). +Proof. + intros ws len a aa i w t h. + unfold WArray.set in h. + unfold chArray_set. +Abort. + Lemma sop1_unembed_embed op v : sem_sop1_typed op (unembed (embed v)) = sem_sop1_typed op v. Proof. From 923dcd7600f2db044a4e8f6bbd3694487d3a8501 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Mon, 11 Apr 2022 11:44:41 +0200 Subject: [PATCH 144/383] Complete Laset case up to chArray_set_correct --- theories/Jasmin/jasmin_translate.v | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index e7586cef..dd210cc0 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1362,7 +1362,7 @@ Proof. intros ws len a aa i w t h. unfold WArray.set in h. unfold chArray_set. -Abort. +Admitted. Lemma sop1_unembed_embed op v : sem_sop1_typed op (unembed (embed v)) = sem_sop1_typed op v. @@ -1766,10 +1766,16 @@ Proof. rewrite trunc. rewrite coerce_to_choice_type_K. eapply translate_to_word in ew. rewrite ew. erewrite translate_to_int. 2: eassumption. - (* Need a lemma relating WArray.set and chArray_set probably *) - (* eapply translate_of_val in hv₁. - rewrite hv₁. apply coerce_to_choice_type_translate_value_to_val. *) - admit. + erewrite get_var_get_heap. + 2: eassumption. + 2:{ split. all: assumption. } + eapply translate_of_val in hv₁. (* simpl in hv₁. *) + rewrite coerce_to_choice_type_translate_value_to_val in hv₁. + rewrite <- hv₁. f_equal. + Opaque translate_value. simpl. Transparent translate_value. + eapply type_of_get_var in hnt as ety. simpl in ety. + rewrite -ety. rewrite !coerce_to_choice_type_K. + apply chArray_set_correct. assumption. + rewrite Fv.setP_neq in ej. 2:{ apply /eqP. eauto. } rewrite get_set_heap_neq. From e82e3773bb4f718c71a8011563e538d819fef894 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Mon, 11 Apr 2022 11:54:49 +0200 Subject: [PATCH 145/383] Progress in chArray_write_correct --- theories/Jasmin/jasmin_translate.v | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index dd210cc0..75c77953 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1352,7 +1352,15 @@ Proof. - simpl. intros k l hk ih a t h. jbind h acc hacc. eapply ih in h. rewrite <- h. -Abort. + apply eq_fmap. intros z. + rewrite setmE. + eapply WArray.set8P with (p' := z) in hacc as e. + rewrite eq_sym in e. rewrite WArray.addE in e. + rewrite eq_op_MzK in e. + destruct (_ == _)%Z eqn: ez. + + admit. + + admit. +Admitted. Lemma chArray_set_correct : ∀ ws len (a : WArray.array len) aa i (w : word ws) t, @@ -1362,7 +1370,8 @@ Proof. intros ws len a aa i w t h. unfold WArray.set in h. unfold chArray_set. -Admitted. + apply chArray_write_correct. assumption. +Qed. Lemma sop1_unembed_embed op v : sem_sop1_typed op (unembed (embed v)) = sem_sop1_typed op v. From b65175b913cacc9ac43453e69740cf41eebba01d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Mon, 11 Apr 2022 12:22:34 +0200 Subject: [PATCH 146/383] More on chArray_write_correct, still not proved --- theories/Jasmin/jasmin_translate.v | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 75c77953..a1e0104e 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1351,14 +1351,17 @@ Proof. - simpl. intros a t e. noconf e. reflexivity. - simpl. intros k l hk ih a t h. jbind h acc hacc. - eapply ih in h. rewrite <- h. + eapply ih in h. (* rewrite <- h. *) apply eq_fmap. intros z. rewrite setmE. eapply WArray.set8P with (p' := z) in hacc as e. - rewrite eq_sym in e. rewrite WArray.addE in e. - rewrite eq_op_MzK in e. + rewrite eq_sym in e. rewrite WArray.addE in e. rewrite eq_op_MzK in e. destruct (_ == _)%Z eqn: ez. - + admit. + + unfold WArray.get8 in e. + jbind e _u1 eb1. jbind e _u2 eb2. + unfold odflt, oapp in e. rewrite <- fold_get in e. simpl in e. + noconf e. + admit. + admit. Admitted. From 8945c4e666179569e7bd7d8f785f8ef5ea9dfcaf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Mon, 11 Apr 2022 15:49:14 +0200 Subject: [PATCH 147/383] State and prove chArray_write_get --- theories/Jasmin/jasmin_translate.v | 31 ++++++++++++++++++++++++++++-- 1 file changed, 29 insertions(+), 2 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index a1e0104e..518289fb 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1338,6 +1338,33 @@ Proof. reflexivity. Qed. +(* Like write_mem_get *) +Lemma chArray_write_get : + ∀ ws (a : 'array) (w : word ws) (i j : Z), + chArray_write a i w j = + if (0 <=? j - i)%Z && (j - i /eqP eb. subst. + rewrite setmE. + replace (i + (j - i))%Z with j by micromega.Lia.lia. + rewrite eq_refl. + reflexivity. + + simpl. move: eb => /eqP eb. + rewrite setmE. + destruct (_ == _) eqn: e. + 1:{ move: e => /eqP e. subst. micromega.Lia.lia. } + apply ih. +Qed. + Lemma chArray_write_correct : ∀ ws len (a : WArray.array len) i (w : word ws) t, write a i w = ok t → @@ -1352,7 +1379,7 @@ Proof. - simpl. intros k l hk ih a t h. jbind h acc hacc. eapply ih in h. (* rewrite <- h. *) - apply eq_fmap. intros z. + apply eq_fmap. intros z. (* Should I go for a chArray_write_get or something like for write_mem? *) rewrite setmE. eapply WArray.set8P with (p' := z) in hacc as e. rewrite eq_sym in e. rewrite WArray.addE in e. rewrite eq_op_MzK in e. @@ -1360,7 +1387,7 @@ Proof. + unfold WArray.get8 in e. jbind e _u1 eb1. jbind e _u2 eb2. unfold odflt, oapp in e. rewrite <- fold_get in e. simpl in e. - noconf e. + noconf e. rewrite <- h. admit. + admit. Admitted. From 5cd80655466ca2626a6a2a4bdc3a37f32149a4b4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Mon, 11 Apr 2022 16:07:52 +0200 Subject: [PATCH 148/383] Define embed_array to simplify goals --- theories/Jasmin/jasmin_translate.v | 30 ++++++++++-------------------- 1 file changed, 10 insertions(+), 20 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 518289fb..4bded78c 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -184,11 +184,14 @@ Definition encode (t : stype) : choice_type := | sword n => 'word n end. +Definition embed_array {len} (a : WArray.array len) : 'array := + Mz.fold (λ k v m, setm m k v) a.(WArray.arr_data) emptym. + Definition embed {t} : sem_t t → encode t := match t with | sbool => λ x, x | sint => λ x, x - | sarr n => λ x, Mz.fold (λ k v m, setm m k v) x.(WArray.arr_data) emptym + | sarr n => embed_array | sword n => λ x, x end. @@ -1371,25 +1374,12 @@ Lemma chArray_write_correct : chArray_write (translate_value (Varr a)) i w = translate_value (Varr t). Proof. intros ws len a i w t h. - unfold write in h. - jbind h _u eb. apply assertP in eb. - unfold chArray_write. - revert a t h. eapply ziota_ind. - - simpl. intros a t e. noconf e. reflexivity. - - simpl. intros k l hk ih a t h. - jbind h acc hacc. - eapply ih in h. (* rewrite <- h. *) - apply eq_fmap. intros z. (* Should I go for a chArray_write_get or something like for write_mem? *) - rewrite setmE. - eapply WArray.set8P with (p' := z) in hacc as e. - rewrite eq_sym in e. rewrite WArray.addE in e. rewrite eq_op_MzK in e. - destruct (_ == _)%Z eqn: ez. - + unfold WArray.get8 in e. - jbind e _u1 eb1. jbind e _u2 eb2. - unfold odflt, oapp in e. rewrite <- fold_get in e. simpl in e. - noconf e. rewrite <- h. - admit. - + admit. + apply eq_fmap. intro z. + rewrite chArray_write_get. + eapply write_read8 with (k := z) in h as e. simpl in e. + destruct (_ : bool) eqn: eb. + - simpl. admit. + - simpl. admit. Admitted. Lemma chArray_set_correct : From f50c81aefec8536230c558d715fb2b72b1299eeb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Mon, 11 Apr 2022 16:27:00 +0200 Subject: [PATCH 149/383] Restate fold_get/set/rem on embed_array --- theories/Jasmin/jasmin_translate.v | 33 ++++++++++++++++++++++++++++-- 1 file changed, 31 insertions(+), 2 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 4bded78c..c81b719e 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -198,7 +198,7 @@ Definition embed {t} : sem_t t → encode t := Lemma elementsNIn : ∀ (T : Type) (k : Z) (v : T) (m : Mz.Map.t T), Mz.get m k = None → - ~ List.In (k, v) (Mz.elements m). + ¬ List.In (k, v) (Mz.elements m). Proof. intros S k v m H contra. apply Mz.elementsIn in contra. @@ -234,7 +234,7 @@ Proof. Qed. Lemma foldl_NIn {S : eqType} (k : Mz.K.t) (data : seq (Mz.K.t * S)) : - (∀ w, ~ List.In (k, w) data) → + (∀ w, ¬ List.In (k, w) data) → foldr (λ (kv : Mz.K.t * S) (a : {fmap Mz.K.t → S}), setm a kv.1 kv.2) emptym data k = None. Proof. intros. @@ -283,6 +283,15 @@ Proof. assumption. Qed. +Lemma embed_array_get : + ∀ len (a : WArray.array len) (k : Z), + embed_array a k = Mz.get a.(WArray.arr_data) k. +Proof. + intros len a k. + unfold embed_array. + rewrite fold_get. reflexivity. +Qed. + Lemma eq_op_MzK : ∀ (k x : Z_ordType), @eq_op Mz.K.t k x = (k == x). @@ -308,6 +317,16 @@ Proof. - rewrite fold_get. reflexivity. Qed. +Lemma embed_array_set : + ∀ len (a : WArray.array len) (k : Z) v, + setm (embed_array a) k v = + embed_array (WArray.Build_array len (Mz.set a.(WArray.arr_data) k v)). +Proof. + intros len a k v. + unfold embed_array. + rewrite fold_set. reflexivity. +Qed. + Lemma fold_rem {S : eqType} (data : Mz.Map.t S) k : remm (Mz.fold (λ (k : Mz.Map.key) (v : S) (m : {fmap Z → S}), setm m k v) data emptym) k = Mz.fold (λ (k : Mz.Map.key) (v : S) (m : {fmap Z → S}), setm m k v) (Mz.remove data k) emptym. @@ -323,6 +342,16 @@ Proof. - rewrite fold_get. reflexivity. Qed. +Lemma embed_array_rem : + ∀ len (a : WArray.array len) (k : Z), + remm (embed_array a) k = + embed_array (WArray.Build_array len (Mz.remove a.(WArray.arr_data) k)). +Proof. + intros len a k. + unfold embed_array. + rewrite fold_rem. reflexivity. +Qed. + Definition unembed {t : stype} : encode t → sem_t t := match t return encode t → sem_t t with | sbool => λ x, x From 53c8342d0de210eb07373313f6981af2df91681e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Mon, 11 Apr 2022 16:57:08 +0200 Subject: [PATCH 150/383] Fail at proving embed_read8 --- theories/Jasmin/jasmin_translate.v | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index c81b719e..d77e5674 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1397,6 +1397,21 @@ Proof. apply ih. Qed. +Lemma embed_read8 : + ∀ len (a : WArray.array len) (z : Z) v, + read a z U8 = ok v → + embed_array a z = Some v. +Proof. + intros len a z v h. + unfold read in h. jbind h _u hb. jbind h l hl. noconf h. + simpl in hl. jbind hl y hy. noconf hl. + unfold WArray.get8 in hy. jbind hy _u1 hb1. jbind hy _u2 hb2. noconf hy. + unfold odflt, oapp. rewrite <- embed_array_get. rewrite add_0. + destruct getm eqn:e. + - admit. + - admit. +Abort. + Lemma chArray_write_correct : ∀ ws len (a : WArray.array len) i (w : word ws) t, write a i w = ok t → From cfdb2b7442789753c2413b45e572128be52cbb14 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Tue, 12 Apr 2022 15:06:26 +0200 Subject: [PATCH 151/383] Fix and prove embed_read8 --- theories/Jasmin/jasmin_translate.v | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index d77e5674..b01fefcc 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1316,7 +1316,7 @@ Lemma chArray_get_correct (len : BinNums.positive) (a : WArray.array len) (z : Z chArray_get ws (translate_value (Varr a)) z (mk_scale aa ws) = translate_value (Vword s). Proof. intros H. - simpl in *. + simpl. unfold WArray.get, read in H. destruct is_align. 2: discriminate. simpl in H. @@ -1400,17 +1400,18 @@ Qed. Lemma embed_read8 : ∀ len (a : WArray.array len) (z : Z) v, read a z U8 = ok v → - embed_array a z = Some v. + chArray_get U8 (embed_array a) z 1 = translate_value (Vword v). Proof. intros len a z v h. unfold read in h. jbind h _u hb. jbind h l hl. noconf h. simpl in hl. jbind hl y hy. noconf hl. unfold WArray.get8 in hy. jbind hy _u1 hb1. jbind hy _u2 hb2. noconf hy. unfold odflt, oapp. rewrite <- embed_array_get. rewrite add_0. - destruct getm eqn:e. - - admit. - - admit. -Abort. + simpl. + unfold chArray_get. simpl. + replace (z * 1 + 0)%Z with z by micromega.Lia.lia. + reflexivity. +Qed. Lemma chArray_write_correct : ∀ ws len (a : WArray.array len) i (w : word ws) t, From 13d85fb369f8247f32a283253e8c404316428563 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Tue, 12 Apr 2022 15:16:57 +0200 Subject: [PATCH 152/383] array_ext is not provable it seems --- theories/Jasmin/jasmin_translate.v | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index b01fefcc..6390ba83 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1413,6 +1413,21 @@ Proof. reflexivity. Qed. +Lemma array_ext : + ∀ (u v : 'array), + (∀ k, chArray_get U8 u k 1 = chArray_get U8 v k 1) → + u = v. +Proof. + intros u v e. + apply eq_fmap. intro k. + specialize (e k). unfold chArray_get in e. + apply LE.decode_inj in e. 2,3: reflexivity. + simpl in e. + replace (k * 1 + 0)%Z with k in e by micromega.Lia.lia. + destruct getm, getm. all: noconf e. + (* They might differ on keys where one returns 0 and the other None *) +Abort. + Lemma chArray_write_correct : ∀ ws len (a : WArray.array len) i (w : word ws) t, write a i w = ok t → From a57222845d3c2c06d2516a975f022736053131e9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Tue, 12 Apr 2022 15:31:11 +0200 Subject: [PATCH 153/383] Fail to prove chArray_write_correct using extensional equality --- theories/Jasmin/jasmin_translate.v | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 6390ba83..ca83168c 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1428,6 +1428,30 @@ Proof. (* They might differ on keys where one returns 0 and the other None *) Abort. +Definition array_get8_eq (u v : 'array) := + ∀ k, chArray_get U8 u k 1 = chArray_get U8 v k 1. + +Notation "u =⁸ v" := (array_get8_eq u v) (at level 80). + +Lemma chArray_write_correct : + ∀ ws len (a : WArray.array len) i (w : word ws) t, + write a i w = ok t → + chArray_write (translate_value (Varr a)) i w =⁸ translate_value (Varr t). +Proof. + intros ws len a i w t h. + intro z. + eapply write_read8 with (k := z) in h as e. simpl in e. + unfold chArray_get. simpl. + replace (z * 1 + 0)%Z with z by micromega.Lia.lia. + rewrite chArray_write_get. + destruct (_ : bool) eqn: eb. + - simpl. eapply embed_read8 in e. simpl in e. + rewrite -e. unfold chArray_get. simpl. + replace (z * 1 + 0)%Z with z by micromega.Lia.lia. + admit. + - admit. +Abort. + Lemma chArray_write_correct : ∀ ws len (a : WArray.array len) i (w : word ws) t, write a i w = ok t → From 47e4b649c1bbfb43dbded08414d0dff364a634fa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Tue, 12 Apr 2022 16:28:38 +0200 Subject: [PATCH 154/383] Define cast_typed_raw_function and get_fundef_ssp --- theories/Jasmin/jasmin_translate.v | 35 ++++++++++++++++++++++-------- 1 file changed, 26 insertions(+), 9 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index ca83168c..637124cf 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -827,8 +827,7 @@ Proof. destruct fd. destruct _f. split. 1: exact f. constructor. - - exists chUnit. exists chUnit. - intros u. + - exists 'unit, 'unit. intros _. (* TODO: store function arguments in their locations *) exact (translate_cmd f f_body). (* TODO: read return values from their locations *) @@ -844,12 +843,25 @@ Fixpoint lchtuple (ts : seq choice_type) : choice_type := | t1 :: ts => t1 × (lchtuple ts) end. -Definition get_fundef_ssp (sp : seq (funname * fdef)) (fn : funname) (dom cod : choice_type) : - option (dom → raw_code cod). +(* Apply cast_fun or return default value, like lookup_op *) +Equations? cast_typed_raw_function {dom cod : choice_type} (rf : typed_raw_function) : dom → raw_code cod := + cast_typed_raw_function rf with inspect ((dom == rf.π1) && (cod == rf.π2.π1)) := { + | @exist true e => pkg_composition.cast_fun _ _ rf.π2.π2 ; + | @exist false e => λ _, ret (chCanonical _) + }. Proof. - exact None. (* TODO *) + all: symmetry in e. + all: move: e => /andP [/eqP e1 /eqP e2]. + all: eauto. Defined. +Definition get_fundef_ssp (sp : seq (funname * fdef)) (fn : funname) (dom cod : choice_type) : + option (dom → raw_code cod) := + match assoc sp fn with + | Some fd => Some (cast_typed_raw_function fd.(ffun)) + | None => None + end. + Lemma eq_rect_r_K : ∀ (A : eqType) (x : A) (P : A → Type) h e, @eq_rect_r A x P h x e = h. @@ -1719,7 +1731,10 @@ Proof. eapply translate_write_estate. all: assumption. Qed. -(* TODO Make fixpoint too! *) +(* TODO Make fixpoint too! +Another option is to inline it all in translate_prog_correct +which given the goals is probably the way things are intended. +*) Lemma translate_instr_r_correct : ∀ (fn : funname) (i : instr_r) (s₁ s₂ : estate), sem_i P s₁ i s₂ → @@ -2018,9 +2033,11 @@ Proof. - red. intros. red. eapply translate_instr_r_correct. econstructor. all: eassumption. - - red. intros. - unfold Pfun. intros. - unfold get_fundef_ssp in H7. + - red. intros m1 m2 gn g vs vs' s1 vm2 vrs vrs'. + intros hg hvs ?????. + unfold Pfun. intros f' hf'. + (* Maybe have a dedicated lemma linking to hg? *) + unfold get_fundef_ssp in hf'. admit. Admitted. From f59616cbc9b7fdcbfea25db0230d8343b3faceaa Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Thu, 14 Apr 2022 14:44:18 +0200 Subject: [PATCH 155/383] prove `chArray_write_correct` - added several auxiliary lemmas on get/set/folds - note that `chWrite` has both a `foldl` and `foldr` version --- theories/Jasmin/jasmin_translate.v | 234 +++++++++++++++++++++-------- 1 file changed, 169 insertions(+), 65 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 637124cf..09280a81 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -7,6 +7,7 @@ From extructures Require Import ord fset fmap. From Jasmin Require Import expr_facts. From Coq Require Import Utf8. +From CoqWord Require Import ssrZ. From Crypt Require Import Prelude Package. Import PackageNotation. @@ -554,15 +555,30 @@ Definition translate_gvar (f : funname) (x : gvar) : raw_code (encode x.(gv).(vt | _ => ret (chCanonical _) end. +Definition chArray_get8 (a : 'array) ptr := + match a ptr with + | None => chCanonical ('word U8) + | Some x => x + end. + +Lemma chArray_get8_correct len (a : WArray.array len) s ptr : + WArray.get8 a ptr = ok s -> + chArray_get8 (embed_array a) ptr = translate_value (Vword s). +Proof. + intros H. simpl. + unfold WArray.get8 in H. + jbind H x Hx. + jbind H y Hy. + noconf H. + unfold chArray_get8, odflt, oapp, embed_array. + rewrite fold_get. + reflexivity. +Qed. + Definition chArray_get ws (a : 'array) ptr scale := (* Jasmin fails if ptr is not aligned; we may not need it. *) (* if negb (is_align ptr sz) then chCanonical ws else *) - let f k := - match a (ptr * scale + k)%Z with (* BSH: maybe abstract this matchee with chArray_get8? *) - | None => chCanonical ('word U8) - | Some x => x - end - in + let f k := chArray_get8 a (ptr * scale + k)%Z in let l := map f (ziota 0 (wsize_size ws)) in Jasmin.memory_model.LE.decode ws l. @@ -599,13 +615,133 @@ Definition chRead ptr ws : raw_code ('word ws) := mem ← get mem_loc ;; ret (read_mem mem ptr ws). +Definition chArray_set8 (a : 'array) ptr w := + setm a ptr w. + +Lemma chArray_set8_correct {len} (a : WArray.array len) ptr w s : + WArray.set8 a ptr w = ok s + -> chArray_set8 (embed_array a) ptr w = embed_array s. +Proof. + intros H. simpl. + unfold WArray.set8 in H. + jbind H x Hx. + noconf H. + unfold chArray_set8, embed_array. + simpl. + rewrite <- fold_set. + reflexivity. +Qed. + (* Jasmin's write on 'array *) Definition chArray_write {sz} (a : 'array) ptr (w : word sz) : 'array := (* For now we do not worry about alignment *) foldr (λ (k : Z) (a' : 'array), - setm a' (ptr + k)%Z (LE.wread8 w k) + chArray_set8 a' (ptr + k)%Z (LE.wread8 w k) ) a (ziota 0 (wsize_size sz)). +Definition chArray_write_foldl {sz} (a : 'array) ptr (w : word sz) : 'array := + foldl (λ (a' : 'array) (k : Z), + chArray_set8 a' (ptr + k)%Z (LE.wread8 w k) + ) a (ziota 0 (wsize_size sz)). + +Lemma foldr_set_not_eq {K : ordType} {K' : eqType} {V : eqType} m f g (k : K) (v : V) (l : seq K') : + (forall k', k' \in l -> k <> f k') -> + setm (foldr (λ k m, setm m (f k) (g k)) m l) k v = foldr (λ k m, setm m (f k) (g k)) (setm m k v) l. +Proof. + intros. + apply eq_fmap. + intros z. revert z. + induction l. + - reflexivity. + - simpl. + intros. + assert (k <> f a). + { apply H. unfold in_mem. simpl. rewrite eq_refl. auto. } + rewrite !setmE. + destruct (_ == _) eqn:E. + + move: E => /eqP. intros. subst. + assert (k == f a = false). + { apply /eqP. assumption. } + rewrite H1. rewrite <- IHl. + { + rewrite setmE. + rewrite eq_refl. + reflexivity. + } + intros. apply H. + rewrite in_cons. + rewrite H2. + rewrite Bool.orb_true_r. auto. + + + destruct (_ == f a). 1: reflexivity. + rewrite <- IHl. + { rewrite setmE. + rewrite E. + reflexivity. + } + intros. + apply H. + rewrite in_cons. + rewrite H1. + rewrite Bool.orb_true_r. auto. +Qed. + +Lemma foldl_set_not_eq {K : ordType} {K' : eqType} {V : eqType} m f g (k : K) (v : V) (l : seq K') : + (forall k', k' \in l -> k <> f k') -> + setm (foldl (λ m k, setm m (f k) (g k)) m l) k v = foldl (λ m k, setm m (f k) (g k)) (setm m k v) l. +Proof. + intros. + rewrite <- revK. + rewrite !foldl_rev. + apply foldr_set_not_eq. + intros. + rewrite <- rev_list_rev in H0. + move: H0 => /InP H0. + apply List.in_rev in H0. + apply H. + apply /InP. assumption. +Qed. + +Lemma foldl_foldr_setm + {K : ordType} {K' : eqType} {V : eqType} m (f : K' -> K) (g : K' -> V) (l : seq K') : + uniq [seq f i | i <- l] -> + foldl (λ m k, setm m (f k) (g k)) m l = foldr (λ k m, setm m (f k) (g k)) m l. +Proof. + intros. + induction l. + - reflexivity. + - simpl. + rewrite <- foldl_set_not_eq. + 1: rewrite IHl. + 1: reflexivity. + { intros. simpl in H. move: H => /andP. easy. }. + { intros. simpl in H. move: H => /andP [] H _. + clear -H0 H. + induction l. + { simpl in *. inversion H0. } + { simpl in *. rewrite in_cons in H0. + rewrite notin_cons in H. + move: H => /andP [] H1 H2. + move: H0 => /orP [/eqP -> | H0 ]. + { apply /eqP. assumption. } + { apply IHl; assumption. } } } +Qed. + +Lemma chArray_write_aux {sz} (a : 'array) ptr (w : word sz) : + chArray_write a ptr w = chArray_write_foldl a ptr w. +Proof. + unfold chArray_write_foldl, chArray_write, chArray_set8. + rewrite foldl_foldr_setm. 1: reflexivity. + rewrite map_inj_uniq. + - unfold ziota. + rewrite map_inj_uniq. + + apply iota_uniq. + + intros n m H. + micromega.Lia.lia. + - intros n m H. + micromega.Lia.lia. +Qed. + (* From WArray.set *) Definition chArray_set {ws} (a : 'array) (aa : arr_access) (p : Z) (w : word ws) := chArray_write a (p * mk_scale aa ws)%Z w. @@ -1345,13 +1481,33 @@ Proof. simpl. rewrite (IH l0). 2: assumption. apply f_equal2. 2: reflexivity. - unfold WArray.get8 in H. - destruct WArray.in_bound. 2: discriminate. - destruct WArray.is_init. 2: discriminate. + apply chArray_get8_correct. + assumption. +Qed. + +Lemma chArray_write_correct : + ∀ ws len (a : WArray.array len) i (w : word ws) t, + write a i w = ok t → + chArray_write (translate_value (Varr a)) i w = translate_value (Varr t). +Proof. + intros. + unfold write in H. + jbind H x Hx. + rewrite chArray_write_aux. + unfold chArray_write_foldl. + revert a H. + apply ziota_ind. + - intros. + simpl in *. noconf H. - unfold odflt, oapp. - rewrite <- fold_get. reflexivity. + - intros. + simpl in *. + jbind H1 y Hy. + apply chArray_set8_correct in Hy. + rewrite Hy. + eapply H0. + assumption. Qed. Lemma chArray_get_sub_correct (lena len : BinNums.positive) a aa sz i t : @@ -1398,6 +1554,7 @@ Proof. rewrite (@in_cons ssrZ.Z_eqType). destruct (_ == _) eqn:eb. + simpl. move: eb => /eqP eb. subst. + unfold chArray_set8. rewrite setmE. replace (i + (j - i))%Z with j by micromega.Lia.lia. rewrite eq_refl. @@ -1425,59 +1582,6 @@ Proof. reflexivity. Qed. -Lemma array_ext : - ∀ (u v : 'array), - (∀ k, chArray_get U8 u k 1 = chArray_get U8 v k 1) → - u = v. -Proof. - intros u v e. - apply eq_fmap. intro k. - specialize (e k). unfold chArray_get in e. - apply LE.decode_inj in e. 2,3: reflexivity. - simpl in e. - replace (k * 1 + 0)%Z with k in e by micromega.Lia.lia. - destruct getm, getm. all: noconf e. - (* They might differ on keys where one returns 0 and the other None *) -Abort. - -Definition array_get8_eq (u v : 'array) := - ∀ k, chArray_get U8 u k 1 = chArray_get U8 v k 1. - -Notation "u =⁸ v" := (array_get8_eq u v) (at level 80). - -Lemma chArray_write_correct : - ∀ ws len (a : WArray.array len) i (w : word ws) t, - write a i w = ok t → - chArray_write (translate_value (Varr a)) i w =⁸ translate_value (Varr t). -Proof. - intros ws len a i w t h. - intro z. - eapply write_read8 with (k := z) in h as e. simpl in e. - unfold chArray_get. simpl. - replace (z * 1 + 0)%Z with z by micromega.Lia.lia. - rewrite chArray_write_get. - destruct (_ : bool) eqn: eb. - - simpl. eapply embed_read8 in e. simpl in e. - rewrite -e. unfold chArray_get. simpl. - replace (z * 1 + 0)%Z with z by micromega.Lia.lia. - admit. - - admit. -Abort. - -Lemma chArray_write_correct : - ∀ ws len (a : WArray.array len) i (w : word ws) t, - write a i w = ok t → - chArray_write (translate_value (Varr a)) i w = translate_value (Varr t). -Proof. - intros ws len a i w t h. - apply eq_fmap. intro z. - rewrite chArray_write_get. - eapply write_read8 with (k := z) in h as e. simpl in e. - destruct (_ : bool) eqn: eb. - - simpl. admit. - - simpl. admit. -Admitted. - Lemma chArray_set_correct : ∀ ws len (a : WArray.array len) aa i (w : word ws) t, WArray.set a aa i w = ok t → From fb37d72299ae35ea330901b042917738031c2561 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Fri, 15 Apr 2022 10:54:44 +0200 Subject: [PATCH 156/383] add `chSeq` to `choice_type` - also added some comments to structure proofs in `choice_type` --- theories/Crypt/choice_type.v | 96 ++++++++++++++++++------ theories/Crypt/package/pkg_heap.v | 1 + theories/Crypt/package/pkg_interpreter.v | 5 ++ 3 files changed, 80 insertions(+), 22 deletions(-) diff --git a/theories/Crypt/choice_type.v b/theories/Crypt/choice_type.v index 5c48f8b1..b65bf9a9 100644 --- a/theories/Crypt/choice_type.v +++ b/theories/Crypt/choice_type.v @@ -45,7 +45,9 @@ Inductive choice_type := | chMap (A B : choice_type) | chOption (A : choice_type) | chFin (n : positive) -| chWord (nbits : wsize). +| chWord (nbits : wsize) +| chSeq (A : choice_type) +. Derive NoConfusion NoConfusionHom for choice_type. @@ -63,6 +65,7 @@ Fixpoint chElement_ordType (U : choice_type) : ordType := | chOption U => option_ordType (chElement_ordType U) | chFin n => [ordType of ordinal n.(pos) ] | chWord nbits => word_ordType nbits + | chSeq U => seq_ordType (chElement_ordType U) end. Fixpoint chElement (U : choice_type) : choiceType := @@ -76,6 +79,7 @@ Fixpoint chElement (U : choice_type) : choiceType := | chOption U => option_choiceType (chElement U) | chFin n => [choiceType of ordinal n.(pos) ] | chWord nbits => word_choiceType nbits + | chSeq U => seq_choiceType (chElement U) end. Coercion chElement : choice_type >-> choiceType. @@ -92,6 +96,7 @@ Coercion chElement : choice_type >-> choiceType. | chOption A => None | chFin n => _ | chWord nbits => word0 + | chSeq A => [::] end. Next Obligation. eapply fmap_of_fmap. apply emptym. @@ -125,6 +130,7 @@ Section choice_typeTypes. | chOption a, chOption a' => choice_type_test a a' | chFin n, chFin n' => n == n' | chWord nbits, chWord nbits' => nbits == nbits' + | chSeq a, chSeq b => choice_type_test a b | _ , _ => false end. @@ -134,34 +140,44 @@ Section choice_typeTypes. Lemma choice_type_eqP : Equality.axiom choice_type_eq. Proof. move=> x y. - induction x as [ | | | | x1 ih1 x2 ih2 | x1 ih1 x2 ih2 | x1 ih1 | x1 | x1 ] + induction x as [ | | | | x1 ih1 x2 ih2 | x1 ih1 x2 ih2 | x1 ih1 | x1 | x1 | x1 ih1 ] in y |- *. - all: destruct y as [ | | | | y1 y2 | y1 y2 | y1 | y1 | y1 ]. + all: destruct y as [ | | | | y1 y2 | y1 y2 | y1 | y1 | y1 | y1 ]. all: simpl. all: try solve [ right ; discriminate ]. all: try solve [ left ; reflexivity ]. + (* chProd *) - destruct (ih1 y1), (ih2 y2). all: simpl. all: subst. all: try solve [ right ; congruence ]. left. reflexivity. + (* chMap *) - destruct (ih1 y1), (ih2 y2). all: simpl. all: subst. all: try solve [ right ; congruence ]. left. reflexivity. + (* chOption *) - destruct (ih1 y1). all: subst. + left. reflexivity. + right. congruence. + (* chFin *) - destruct (x1 == y1) eqn:e. + move: e => /eqP e. subst. left. reflexivity. + move: e => /eqP e. right. intro h. apply e. inversion h. reflexivity. + (* chWord *) - destruct (x1 == y1) eqn:e. + move: e => /eqP e. subst. left. reflexivity. + move: e => /eqP e. right. intro h. apply e. inversion h. reflexivity. + (* chSeq *) + - destruct (ih1 y1). + all: subst. + + left. reflexivity. + + right. congruence. Qed. Lemma choice_type_refl : @@ -217,24 +233,35 @@ Section choice_typeTypes. | chOption _, chMap _ _ => false | chOption u, chOption w => choice_type_lt u w | chOption _, _ => true - | chFin n, chUnit => false - | chFin n, chBool => false - | chFin n, chNat => false - | chFin n, chInt => false - | chFin n, chProd _ _ => false - | chFin n, chMap _ _ => false - | chFin n, chOption _ => false + | chFin _, chUnit => false + | chFin _, chBool => false + | chFin _, chNat => false + | chFin _, chInt => false + | chFin _, chProd _ _ => false + | chFin _, chMap _ _ => false + | chFin _, chOption _ => false | chFin n, chFin n' => n < n' - | chFin n, _ => true - | chWord n, chUnit => false - | chWord n, chBool => false - | chWord n, chNat => false - | chWord n, chInt => false - | chWord n, chProd _ _ => false - | chWord n, chMap _ _ => false - | chWord n, chOption _ => false - | chWord n, chFin _ => false + | chFin _, _ => true + | chWord _, chUnit => false + | chWord _, chBool => false + | chWord _, chNat => false + | chWord _, chInt => false + | chWord _, chProd _ _ => false + | chWord _, chMap _ _ => false + | chWord _, chOption _ => false + | chWord _, chFin _ => false | chWord n, chWord n' => (n < n')%CMP + | chWord _, _ => true + | chSeq _, chUnit => false + | chSeq _, chBool => false + | chSeq _, chNat => false + | chSeq _, chInt => false + | chSeq _, chProd _ _ => false + | chSeq _, chMap _ _ => false + | chSeq _, chOption _ => false + | chSeq _, chFin _ => false + | chSeq _, chWord _ => false + | chSeq u, chSeq w => choice_type_lt u w end. Definition choice_type_leq (t1 t2 : choice_type) := @@ -243,16 +270,21 @@ Section choice_typeTypes. Lemma choice_type_lt_transitive : transitive (T:=choice_type) choice_type_lt. Proof. intros v u w h1 h2. - induction u as [ | | | | u1 ih1 u2 ih2 | u1 ih1 u2 ih2 | u ih | u | u ] + induction u as [ | | | | u1 ih1 u2 ih2 | u1 ih1 u2 ih2 | u ih | u | u | u ih ] in v, w, h1, h2 |- *. + (* chUnit *) - destruct w. all: try auto. destruct v. all: discriminate. + (* chNat *) - destruct w. all: try auto. all: destruct v. all: discriminate. + (* chInt *) - destruct w. all: try auto. all: destruct v. all: discriminate. + (* chBool *) - destruct w. all: try auto. all: destruct v. all: discriminate. + (* chProd *) - destruct v. all: try discriminate. all: destruct w. all: try discriminate. all: try reflexivity. cbn in *. @@ -268,6 +300,7 @@ Section choice_typeTypes. apply/andP. subst. split. * apply/eqP. reflexivity. * eapply ih2. all: eauto. + (* chMap *) - destruct v. all: try discriminate. all: destruct w. all: try discriminate. all: try reflexivity. simpl in *. @@ -283,25 +316,33 @@ Section choice_typeTypes. apply/andP. subst. split. * apply/eqP. reflexivity. * eapply ih2. all: eauto. + (* chOption *) - destruct v. all: try discriminate. all: destruct w. all: try reflexivity. all: try discriminate. simpl in *. eapply ih. all: eauto. + (* chFin *) - destruct v. all: try discriminate. all: destruct w; try discriminate; auto. simpl in *. eapply ltn_trans. all: eauto. + (* chWord *) - destruct v. all: try discriminate. all: destruct w; try discriminate; auto. simpl in *. eapply cmp_lt_trans. all: eauto. + (* chSeq *) + - destruct v. all: try discriminate. + all: destruct w. all: try reflexivity. all: try discriminate. + simpl in *. + eapply ih. all: eauto. Qed. Lemma choice_type_lt_areflexive : ∀ x, ~~ choice_type_lt x x. Proof. intros x. - induction x as [ | | | | x1 ih1 x2 ih2 | x1 ih1 x2 ih2 | x ih | x | x] in |- *. + induction x as [ | | | | x1 ih1 x2 ih2 | x1 ih1 x2 ih2 | x ih | x | x | x ih ] in |- *. all: intuition; simpl. - simpl. apply/norP. split. @@ -323,9 +364,10 @@ Section choice_typeTypes. ~~ (choice_type_test x y) ==> (choice_type_lt x y || choice_type_lt y x). Proof. intros x y. - induction x as [ | | | | x1 ih1 x2 ih2| x1 ih1 x2 ih2| x ih| x | x] + induction x as [ | | | | x1 ih1 x2 ih2| x1 ih1 x2 ih2| x ih| x | x | x ih ] in y |- *. all: try solve [ destruct y ; intuition ; reflexivity ]. + (* chProd *) - destruct y. all: try (intuition; reflexivity). cbn. specialize (ih1 y1). specialize (ih2 y2). @@ -361,6 +403,7 @@ Section choice_typeTypes. destruct ih1. +++ left. apply/orP. left. assumption. +++ right. apply/orP. left. assumption. + (* chMap *) - destruct y. all: try (intuition; reflexivity). cbn. specialize (ih1 y1). specialize (ih2 y2). @@ -396,11 +439,13 @@ Section choice_typeTypes. destruct ih1. +++ left. apply/orP. left. assumption. +++ right. apply/orP. left. assumption. + (* chFin *) - destruct y. all: try (intuition; reflexivity). unfold choice_type_lt. unfold choice_type_test. rewrite -neq_ltn. apply /implyP. auto. + (* chWord *) - destruct y. all: try (intuition; reflexivity). unfold choice_type_lt. unfold choice_type_test. @@ -515,6 +560,7 @@ Section choice_typeTypes. | chOption u => GenTree.Node 3 [:: encode u] | chFin n => GenTree.Node 4 [:: GenTree.Leaf (pos n)] | chWord n => GenTree.Node 5 [:: GenTree.Leaf (wsize_log2 n)] + | chSeq u => GenTree.Node 6 [:: encode u] end. Fixpoint decode (t : GenTree.tree nat) : option choice_type := @@ -540,6 +586,11 @@ Section choice_typeTypes. end | GenTree.Node 4 [:: GenTree.Leaf (S n)] => Some (chFin (mkpos (S n))) | GenTree.Node 5 [:: GenTree.Leaf n] => Some (chWord (nth U8 wsizes n)) + | GenTree.Node 6 [:: l] => + match decode l with + | Some l => Some (chSeq l) + | _ => None + end | _ => None end. @@ -557,6 +608,7 @@ Section choice_typeTypes. + cbn. repeat f_equal. apply eq_irrelevance. - repeat f_equal. unfold wsizes. destruct nbits; reflexivity. + - rewrite IHt. reflexivity. Qed. Definition choice_type_choiceMixin := PcanChoiceMixin codeK. diff --git a/theories/Crypt/package/pkg_heap.v b/theories/Crypt/package/pkg_heap.v index 47749c7a..ed5b5d94 100644 --- a/theories/Crypt/package/pkg_heap.v +++ b/theories/Crypt/package/pkg_heap.v @@ -67,6 +67,7 @@ Proof. - exact None. - exact (fintype.Ordinal n.(cond_pos)). - exact word0. + - exact [::]. Defined. Definition heap := { h : raw_heap | valid_heap h }. diff --git a/theories/Crypt/package/pkg_interpreter.v b/theories/Crypt/package/pkg_interpreter.v index 184243db..2a768e98 100644 --- a/theories/Crypt/package/pkg_interpreter.v +++ b/theories/Crypt/package/pkg_interpreter.v @@ -151,6 +151,11 @@ Section Interpreter. end | chFin n => Some ((seed + 1)%N, _) | chWord n => Some ((seed + 1)%N, _) + | chSeq A => + match sampler A seed with + | Some (seed', x) => Some (seed', [:: x]) + | _ => None + end end. Next Obligation. eapply Ordinal. From ac1ed93151f3135efddf945ecb9e64348a1e9c6d Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Fri, 15 Apr 2022 11:00:02 +0200 Subject: [PATCH 157/383] rename `chSeq` to `chList` --- theories/Crypt/choice_type.v | 38 ++++++++++++------------ theories/Crypt/package/pkg_interpreter.v | 2 +- 2 files changed, 20 insertions(+), 20 deletions(-) diff --git a/theories/Crypt/choice_type.v b/theories/Crypt/choice_type.v index b65bf9a9..ca3a07e9 100644 --- a/theories/Crypt/choice_type.v +++ b/theories/Crypt/choice_type.v @@ -46,7 +46,7 @@ Inductive choice_type := | chOption (A : choice_type) | chFin (n : positive) | chWord (nbits : wsize) -| chSeq (A : choice_type) +| chList (A : choice_type) . Derive NoConfusion NoConfusionHom for choice_type. @@ -65,7 +65,7 @@ Fixpoint chElement_ordType (U : choice_type) : ordType := | chOption U => option_ordType (chElement_ordType U) | chFin n => [ordType of ordinal n.(pos) ] | chWord nbits => word_ordType nbits - | chSeq U => seq_ordType (chElement_ordType U) + | chList U => seq_ordType (chElement_ordType U) end. Fixpoint chElement (U : choice_type) : choiceType := @@ -79,7 +79,7 @@ Fixpoint chElement (U : choice_type) : choiceType := | chOption U => option_choiceType (chElement U) | chFin n => [choiceType of ordinal n.(pos) ] | chWord nbits => word_choiceType nbits - | chSeq U => seq_choiceType (chElement U) + | chList U => seq_choiceType (chElement U) end. Coercion chElement : choice_type >-> choiceType. @@ -96,7 +96,7 @@ Coercion chElement : choice_type >-> choiceType. | chOption A => None | chFin n => _ | chWord nbits => word0 - | chSeq A => [::] + | chList A => [::] end. Next Obligation. eapply fmap_of_fmap. apply emptym. @@ -130,7 +130,7 @@ Section choice_typeTypes. | chOption a, chOption a' => choice_type_test a a' | chFin n, chFin n' => n == n' | chWord nbits, chWord nbits' => nbits == nbits' - | chSeq a, chSeq b => choice_type_test a b + | chList a, chList b => choice_type_test a b | _ , _ => false end. @@ -173,7 +173,7 @@ Section choice_typeTypes. + move: e => /eqP e. subst. left. reflexivity. + move: e => /eqP e. right. intro h. apply e. inversion h. reflexivity. - (* chSeq *) + (* chList *) - destruct (ih1 y1). all: subst. + left. reflexivity. @@ -252,16 +252,16 @@ Section choice_typeTypes. | chWord _, chFin _ => false | chWord n, chWord n' => (n < n')%CMP | chWord _, _ => true - | chSeq _, chUnit => false - | chSeq _, chBool => false - | chSeq _, chNat => false - | chSeq _, chInt => false - | chSeq _, chProd _ _ => false - | chSeq _, chMap _ _ => false - | chSeq _, chOption _ => false - | chSeq _, chFin _ => false - | chSeq _, chWord _ => false - | chSeq u, chSeq w => choice_type_lt u w + | chList _, chUnit => false + | chList _, chBool => false + | chList _, chNat => false + | chList _, chInt => false + | chList _, chProd _ _ => false + | chList _, chMap _ _ => false + | chList _, chOption _ => false + | chList _, chFin _ => false + | chList _, chWord _ => false + | chList u, chList w => choice_type_lt u w end. Definition choice_type_leq (t1 t2 : choice_type) := @@ -331,7 +331,7 @@ Section choice_typeTypes. all: destruct w; try discriminate; auto. simpl in *. eapply cmp_lt_trans. all: eauto. - (* chSeq *) + (* chList *) - destruct v. all: try discriminate. all: destruct w. all: try reflexivity. all: try discriminate. simpl in *. @@ -560,7 +560,7 @@ Section choice_typeTypes. | chOption u => GenTree.Node 3 [:: encode u] | chFin n => GenTree.Node 4 [:: GenTree.Leaf (pos n)] | chWord n => GenTree.Node 5 [:: GenTree.Leaf (wsize_log2 n)] - | chSeq u => GenTree.Node 6 [:: encode u] + | chList u => GenTree.Node 6 [:: encode u] end. Fixpoint decode (t : GenTree.tree nat) : option choice_type := @@ -588,7 +588,7 @@ Section choice_typeTypes. | GenTree.Node 5 [:: GenTree.Leaf n] => Some (chWord (nth U8 wsizes n)) | GenTree.Node 6 [:: l] => match decode l with - | Some l => Some (chSeq l) + | Some l => Some (chList l) | _ => None end | _ => None diff --git a/theories/Crypt/package/pkg_interpreter.v b/theories/Crypt/package/pkg_interpreter.v index 2a768e98..f3e33624 100644 --- a/theories/Crypt/package/pkg_interpreter.v +++ b/theories/Crypt/package/pkg_interpreter.v @@ -151,7 +151,7 @@ Section Interpreter. end | chFin n => Some ((seed + 1)%N, _) | chWord n => Some ((seed + 1)%N, _) - | chSeq A => + | chList A => match sampler A seed with | Some (seed', x) => Some (seed', [:: x]) | _ => None From 01d12a62731c6c4246ad80cb9c03b13798bb79e7 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Fri, 15 Apr 2022 14:06:00 +0200 Subject: [PATCH 158/383] (wip) attempt at defining `appN` --- theories/Jasmin/jasmin_translate.v | 79 +++++++++++++++++++++++++++--- 1 file changed, 71 insertions(+), 8 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 09280a81..9df643f0 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -756,6 +756,72 @@ Definition write_mem {sz} (m : 'mem) (ptr : word Uptr) (w : word sz) : 'mem := Definition translate_write {sz} (p : word Uptr) (w : word sz) : raw_code 'unit := m ← get mem_loc ;; #put mem_loc := write_mem m p w ;; ret tt. +Fixpoint lchtuple (ts : seq choice_type) : choice_type := + match ts with + | [::] => 'unit + | [:: t1 ] => t1 + | t1 :: ts => t1 × (lchtuple ts) + end. + +Lemma lchtuple_cons_cons a b l : + (lchtuple (a :: b :: l)) = (a × lchtuple (b :: l)). +Proof. + reflexivity. +Qed. + +Lemma sem_prod_cons_cons a b l S : + (sem_prod (a :: b :: l) S) = (sem_t a -> sem_prod (b :: l) S). +Proof. + reflexivity. +Qed. + +Fixpoint bind_list (ts : list stype) (cs : list typed_code) {struct ts} : raw_code (lchtuple ([seq encode t | t <- ts])). + refine + (match ts with + | [::] => + match cs with + | _ => _ + end + | t :: ts' => + _ + end). + - exact (ret (chCanonical chUnit)). + - destruct ts' as [|t' ts''] eqn:E. + + exact (ret (chCanonical _)). + + destruct cs as [|c cs]. + * exact (ret (chCanonical _)). + * eapply bind. + ** exact ((truncate_code t c).π2). + ** intros. + eapply bind. + *** exact (bind_list ts' cs). + *** intros. + cbn -[lchtuple]. + rewrite lchtuple_cons_cons. + rewrite <- map_cons. + rewrite <- E. + exact (ret (X, X0)). +Defined. + +Fixpoint ch_app_sopn {S} (ts : seq.seq stype) (op : sem_prod ts (exec (sem_t S))) (vs : lchtuple ([seq encode t | t <- ts])) {struct ts} : encode S. + destruct ts as [|t ts']. + - exact (chCanonical _). + - destruct ts' as [|t' ts''] eqn:E. + + simpl in *. + destruct (op (unembed vs)). + * exact (embed s). + * exact (chCanonical _). + + rewrite sem_prod_cons_cons in op. + destruct vs. + apply unembed in s. + apply op in s. + apply ch_app_sopn with (ts:=ts'). + * rewrite E. + exact s. + * rewrite E. + exact s0. +Defined. + (* Following sem_pexpr *) Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code := match e with @@ -807,7 +873,11 @@ Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code := | _ => chCanonical _ end ) - | PappN op es => unsupported + | PappN op es => + totc _ ( + vs ← bind_list (type_of_opN op).1 [seq translate_pexpr fn e | e <- es] ;; + ret (ch_app_sopn (type_of_opN op).1 (sem_opN_typed op) vs) + ) | Pif t eb e1 e2 => totc _ ( b ← (truncate_code sbool (translate_pexpr fn eb)).π2 ;; (* to_bool *) @@ -972,13 +1042,6 @@ Proof. - exact [interface]. Defined. -Fixpoint lchtuple (ts : seq choice_type) : choice_type := - match ts with - | [::] => 'unit - | [:: t1 ] => t1 - | t1 :: ts => t1 × (lchtuple ts) - end. - (* Apply cast_fun or return default value, like lookup_op *) Equations? cast_typed_raw_function {dom cod : choice_type} (rf : typed_raw_function) : dom → raw_code cod := cast_typed_raw_function rf with inspect ((dom == rf.π1) && (cod == rf.π2.π1)) := { From fd4be4a835d081f81986927f4a2aaafed245bebf Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Thu, 21 Apr 2022 16:50:10 +0200 Subject: [PATCH 159/383] fix bind_list (also added comment that it truncates) --- theories/Jasmin/jasmin_translate.v | 19 ++++++++----------- 1 file changed, 8 insertions(+), 11 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 9df643f0..dae56d44 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -775,23 +775,20 @@ Proof. reflexivity. Qed. +(* truncate and bind list of code *) Fixpoint bind_list (ts : list stype) (cs : list typed_code) {struct ts} : raw_code (lchtuple ([seq encode t | t <- ts])). - refine - (match ts with - | [::] => - match cs with - | _ => _ - end - | t :: ts' => - _ - end). + destruct ts as [|t ts']. - exact (ret (chCanonical chUnit)). - destruct ts' as [|t' ts''] eqn:E. - + exact (ret (chCanonical _)). + destruct cs as [|c cs]. * exact (ret (chCanonical _)). * eapply bind. - ** exact ((truncate_code t c).π2). + ** exact (truncate_code t c).π2. + ** intros. exact (ret X). + + destruct cs as [|c cs]. + * exact (ret (chCanonical _)). + * eapply bind. + ** exact (truncate_code t c).π2. ** intros. eapply bind. *** exact (bind_list ts' cs). From 7707c459d1d72774c11e4511f4f78a9f250d6a34 Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Fri, 22 Apr 2022 09:00:36 +0200 Subject: [PATCH 160/383] delete ocaml compiler generated files --- theories/Jasmin/examples/print_vname.cmi | Bin 592 -> 0 bytes theories/Jasmin/examples/print_vname.cmo | Bin 556 -> 0 bytes 2 files changed, 0 insertions(+), 0 deletions(-) delete mode 100644 theories/Jasmin/examples/print_vname.cmi delete mode 100644 theories/Jasmin/examples/print_vname.cmo diff --git a/theories/Jasmin/examples/print_vname.cmi b/theories/Jasmin/examples/print_vname.cmi deleted file mode 100644 index fef7128756afd1ed22d1f5a9ebbcf945e7bebc88..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 592 zcmZ=x%*`>hw6ydzFtTWwx@;c<1H%R&RtMr9AZ}Tp9Z-~+R}x>AmzbNnV8a6K0tAH7;~{BziFKo7}&z1$pU-@pSbOwPVB4h{=h)Epcf zAbwyB0lM7?i1z^T^aUuMm|#%ATq(RdZYJADCF9MHtT)VCus|2$`1ttJZKFceEV*_4kY>fq^t=B7Bx1G zcTT@+T-0r@am^yzW5EI)nEss1;*tplqUS!SMx044J0^C*pY!U5S4d6(hPJWM1OvSs zhQlf)o4$c zy%T>~vN2dFDFn5@PF>QtU;#9qCKw!&iB)qV!Z diff --git a/theories/Jasmin/examples/print_vname.cmo b/theories/Jasmin/examples/print_vname.cmo deleted file mode 100644 index 7161344efb9609b08cae5c8e3d0e58d98b3e7ec9..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 556 zcmZ=x%*`>hw6yd$FtT7^U}y*d5`sXi3B+1J%m~HYKpLa~1Vn&X5r|=Y0U%omh?9X> z1BjV`SR05z;Qjyq|G9v)J($P9APl5IW?Dk|EmN261B%Q5a-D(rD-fUI02!klP?VWh z5?_{=n422FP_SUZ#7TO=B`GXOC<3)CPUnP6~8CRWWcC2^~>kwnqbz*oEr7O+@OFeqTI z6kZ)SlkKCD@#aU?8|E!oVBrjmb)chCi}Dh4+`xh9lvtdZTs* Date: Fri, 22 Apr 2022 09:03:53 +0200 Subject: [PATCH 161/383] add xor jasmin translation example --- theories/Jasmin/examples/xor/xor.cprog | 93 +++++++++++++++ theories/Jasmin/examples/xor/xor.jazz | 6 + theories/Jasmin/examples/xor/xor.v | 150 +++++++++++++++++++++++++ 3 files changed, 249 insertions(+) create mode 100644 theories/Jasmin/examples/xor/xor.cprog create mode 100644 theories/Jasmin/examples/xor/xor.jazz create mode 100644 theories/Jasmin/examples/xor/xor.v diff --git a/theories/Jasmin/examples/xor/xor.cprog b/theories/Jasmin/examples/xor/xor.cprog new file mode 100644 index 00000000..d6157109 --- /dev/null +++ b/theories/Jasmin/examples/xor/xor.cprog @@ -0,0 +1,93 @@ + {Jasmin.Expr.p_funcs = + [(Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH, + {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH; + f_tyin = + [Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = x.131}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)}; + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = y.132}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)}]; + f_body = + [Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = r.133}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = x.131}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}; + gs = Jasmin.Expr.Slocal})); + Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = r.133}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Papp2 (Jasmin.Expr.Olxor Jasmin.Wsize.U64, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = r.133}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = y.132}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)}; + gs = Jasmin.Expr.Slocal})))]; + f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = r.133}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}]; + f_extra = ()})]; + p_globs = []; p_extra = ()} diff --git a/theories/Jasmin/examples/xor/xor.jazz b/theories/Jasmin/examples/xor/xor.jazz new file mode 100644 index 00000000..c7b9a8ce --- /dev/null +++ b/theories/Jasmin/examples/xor/xor.jazz @@ -0,0 +1,6 @@ +export fn xor(reg u64 x, reg u64 y) -> reg u64 { + reg u64 r; + r = x; + r ^= y; + return r; +} diff --git a/theories/Jasmin/examples/xor/xor.v b/theories/Jasmin/examples/xor/xor.v new file mode 100644 index 00000000..a049587d --- /dev/null +++ b/theories/Jasmin/examples/xor/xor.v @@ -0,0 +1,150 @@ +Set Warnings "-notation-overridden,-ambiguous-paths". +From mathcomp Require Import all_ssreflect all_algebra reals distr realsum + fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool ssrnum + eqtype choice seq. +Set Warnings "notation-overridden,ambiguous-paths". + +Require Import List. +From Jasmin Require Import expr. +(* From Jasmin Require Import x86_extra. *) +From JasminSSProve Require Import jasmin_translate. +From Crypt Require Import Prelude Package. + +Import ListNotations. +Local Open Scope string. + +Context `{asmop : asmOp}. + +Context {T} {pT : progT T}. + +Context {pd : PointerData}. + +Context (P : uprog). + +Context (f : funname). + +Definition xor := + {| p_funcs := + [(xO xH, + {| f_info := xI xH; + f_tyin := + [sword U64; + sword U64]; + f_params := + [{| v_var := + {| vtype := sword U64; + vname := "x.131" |}; + v_info := + xO + (xO xH) |}; + {| v_var := + {| vtype := sword U64; + vname := "y.132" |}; + v_info := + xI + (xO xH) |}]; + f_body := + [MkI + (xO + (xI + (xO xH))) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "r.133" |}; + v_info := + xO + (xO + (xI xH)) |}) + (AT_none) (sword U64) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "x.131" |}; + v_info := + xI + (xI + (xO xH)) |}; + gs := Slocal |})); + MkI + (xO + (xI xH)) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "r.133" |}; + v_info := + xI + (xO + (xO xH)) |}) + (AT_none) (sword U64) + (Papp2 (Olxor U64) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "r.133" |}; + v_info := + xO + (xO + (xO xH)) |}; + gs := Slocal |}) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "y.132" |}; + v_info := + xI + (xI xH) |}; + gs := Slocal |})))]; + f_tyout := [sword U64]; + f_res := + [{| v_var := + {| vtype := sword U64; + vname := "r.133" |}; + v_info := + xI + (xO + (xI xH)) |}]; + f_extra := tt |})]; + p_globs := []; p_extra := tt |} +. + + +Import PackageNotation. +Notation coe_cht := coerce_to_choice_type. +Notation coe_tyc := coerce_typed_code. +Notation " 'array " := (chMap 'int ('word U8)) (at level 2) : package_scope. +Notation " 'array " := (chMap 'int ('word U8)) (in custom pack_type at level 2). +Notation " 'mem " := (chMap ('word Uptr) ('word U8)) (at level 2) : package_scope. +Notation " 'mem " := (chMap ('word Uptr) ('word U8)) (in custom pack_type at level 2). +Notation " ⸨ ws ⸩ a .[ ptr * scale ] " := (chArray_get ws a ptr scale) + (format " ⸨ ws ⸩ a .[ ptr * scale ] "). +Notation " a [ w / p ] " := + (chArray_set a AAscale p w) + (at level 99, no associativity, + format " a [ w / p ] "). + +Definition tr_xor := translate_prog xor. + +Eval cbn in tr_xor. +Goal tr_xor = tr_xor. + unfold tr_xor at 2. + unfold translate_prog, translate_fundef. + unfold translate_cmd. + simpl. + unfold translate_var. simpl. + set (x := ('word U64; nat_of_fun_ident 2%positive "x.131")). + set (r := ('word U64; nat_of_fun_ident 2%positive "r.133")). + set (y := ('word U64; nat_of_fun_ident 2%positive "y.132")). + (* does nothing; too many binders? *) + (* repeat setoid_rewrite zero_extend_u. *) From f40ba53387fa4d8d5a6b2662e00173c59920f931 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Sat, 23 Apr 2022 11:57:06 +0200 Subject: [PATCH 162/383] prove `translate_pexpr_correct` important changes: - the translation of `app_sopn` binds to a list instead of a tuple - the translation of `app_sopn` does not truncate when it binds, but when it applies the operations - the translation of `app_sopn` uses axiom of choice, since it needs a `choiceType` of `list typed_chElement` (i think, though, that it can proven to be a `choiceType` without axioms) other notes: - the proof `app_sopn_list_correct` is *very* slow (~10min on my machine), since it needs to destruct on the list of values and list of input types of the operations. - I kept variants `bind_list_to_tuple` in here if we need it for something else. I also kept attempts and correctness proofs about these constructions. It can all safely be deleted. --- theories/Jasmin/jasmin_translate.v | 464 ++++++++++++++++++++++++++--- 1 file changed, 415 insertions(+), 49 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index dae56d44..3d856a1b 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -775,32 +775,60 @@ Proof. reflexivity. Qed. -(* truncate and bind list of code *) -Fixpoint bind_list (ts : list stype) (cs : list typed_code) {struct ts} : raw_code (lchtuple ([seq encode t | t <- ts])). - destruct ts as [|t ts']. - - exact (ret (chCanonical chUnit)). - - destruct ts' as [|t' ts''] eqn:E. - + destruct cs as [|c cs]. - * exact (ret (chCanonical _)). - * eapply bind. - ** exact (truncate_code t c).π2. - ** intros. exact (ret X). - + destruct cs as [|c cs]. - * exact (ret (chCanonical _)). - * eapply bind. - ** exact (truncate_code t c).π2. +Lemma sem_prod_cons a l S : + (sem_prod (a :: l) S) = (sem_t a -> sem_prod l S). +Proof. + reflexivity. +Qed. + +Definition to_typed_chElement {t : choice_type} (v : t) : typed_chElement := (t ; v). + +Fixpoint bind_list (cs : list typed_code) {struct cs} : raw_code ([choiceType of list typed_chElement]) := + match cs with + | [::] => ret [::] + | c :: cs => + v ← c.π2 ;; + vs ← bind_list cs ;; + ret (to_typed_chElement v :: vs) + end. + +(* bind list of code to tuple *) +Fixpoint bind_list_to_tuple (cs : list typed_code) {struct cs} : raw_code (lchtuple ([seq c.π1 | c <- cs])). + destruct cs as [|c cs']. + - exact (ret (chCanonical _)). + - destruct cs' as [|c' cs''] eqn:E. + + exact c.π2. + + eapply bind. + * exact c.π2. + * intros. + eapply bind. + ** exact (bind_list_to_tuple cs'). ** intros. - eapply bind. - *** exact (bind_list ts' cs). - *** intros. - cbn -[lchtuple]. - rewrite lchtuple_cons_cons. - rewrite <- map_cons. - rewrite <- E. - exact (ret (X, X0)). + cbn -[lchtuple typed_code]. + rewrite lchtuple_cons_cons. + rewrite <- map_cons. + fold typed_code. (* i don't know when this got unfolded *) + rewrite <- E. + exact (ret (X, X0)). Defined. -Fixpoint ch_app_sopn {S} (ts : seq.seq stype) (op : sem_prod ts (exec (sem_t S))) (vs : lchtuple ([seq encode t | t <- ts])) {struct ts} : encode S. +Fixpoint bind_and_truncate_list_to_tuple (ts : list stype) (cs : list typed_code) : raw_code (lchtuple ([seq encode t | t <- ts])) := + match cs with + | [::] => ret (chCanonical _) + | c :: cs' => match ts with + | [::] => ret (chCanonical _) + | t :: ts' => match ts' with + | [::] => v ← (truncate_code t c).π2 ;; + ret v + | t' :: ts'' => + v ← (truncate_code t c).π2 ;; + vs ← bind_and_truncate_list_to_tuple (t' :: ts'') cs' ;; + ret (v, vs) + end + end + end. + +Fixpoint app_sopn_truncated_tuple {S} (ts : seq.seq stype) (op : sem_prod ts (exec (sem_t S))) (vs : lchtuple ([seq encode t | t <- ts])) {struct ts} : encode S. destruct ts as [|t ts']. - exact (chCanonical _). - destruct ts' as [|t' ts''] eqn:E. @@ -812,13 +840,48 @@ Fixpoint ch_app_sopn {S} (ts : seq.seq stype) (op : sem_prod ts (exec (sem_t S)) destruct vs. apply unembed in s. apply op in s. - apply ch_app_sopn with (ts:=ts'). + apply app_sopn_truncated_tuple with (ts:=ts'). * rewrite E. exact s. * rewrite E. exact s0. Defined. +Fixpoint type_of_values vs : choice_type := + match vs with + | [::] => 'unit + | [:: v ] => choice_type_of_val v + | hd :: tl => choice_type_of_val hd × type_of_values tl + end. + +(* lchtuple (map choice_type_of_val vs) *) +Definition translate_values (vs : seq value) : + lchtuple (map choice_type_of_val vs). +Proof. + induction vs as [| v vs tr_vs]. + - exact tt. + - destruct vs as [| v' vs']. + + exact (translate_value v). + + exact (translate_value v, tr_vs). +Defined. + +Fixpoint app_sopn_list {S} (ts : list stype) := + match ts as ts0 return (sem_prod ts0 (exec (sem_t S)) → [choiceType of list typed_chElement] → encode S) with + | [::] => λ (o : exec (sem_t S)) (vs : list typed_chElement), + match vs with + | [::] => match o with + | Ok o => embed o + | _ => chCanonical _ + end + | _ :: _ => chCanonical _ + end + | t :: ts0 => λ (o : sem_t t → sem_prod ts0 (exec (sem_t S))) (vs : list typed_chElement), + match vs with + | [::] => chCanonical _ + | v :: vs0 => app_sopn_list ts0 (o (unembed (truncate_el t v.π2))) vs0 + end + end. + (* Following sem_pexpr *) Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code := match e with @@ -871,9 +934,14 @@ Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code := end ) | PappN op es => + (* note that this is sligtly different from Papp2 and Papp1, in that + we don't truncate when we bind, but when we apply (in app_sopn_list). + This made the proof easier, but is also more faithful(maybe?) to + how it is done in jasmin. Maybe we should change Papp1/2. + *) totc _ ( - vs ← bind_list (type_of_opN op).1 [seq translate_pexpr fn e | e <- es] ;; - ret (ch_app_sopn (type_of_opN op).1 (sem_opN_typed op) vs) + vs ← bind_list [seq translate_pexpr fn e | e <- es] ;; + ret (app_sopn_list (type_of_opN op).1 (sem_opN_typed op) vs) ) | Pif t eb e1 e2 => totc _ ( @@ -1076,25 +1144,6 @@ Proof. all: simpl ; rewrite eq_rect_r_K ; reflexivity. Qed. -Fixpoint type_of_values vs : choice_type := - match vs with - | [::] => 'unit - | [:: v ] => choice_type_of_val v - | hd :: tl => choice_type_of_val hd × type_of_values tl - end. - -(* lchtuple (map choice_type_of_val vs) *) - -Definition translate_values (vs : seq value) : - lchtuple (map choice_type_of_val vs). -Proof. - induction vs as [| v vs tr_vs]. - - exact tt. - - destruct vs as [| v' vs']. - + exact (translate_value v). - + exact (translate_value v, tr_vs). -Defined. - Definition translate_ptr (ptr : pointer) : Location := ('word U8 ; (5 ^ Z.to_nat (wunsigned ptr))%nat). @@ -1389,6 +1438,171 @@ Proof. apply translate_of_val. assumption. Qed. +Fixpoint list_to_chtuple (vs : values) : lchtuple [seq choice_type_of_val v | v <- vs]. + destruct vs as [|v vs']. + - exact (chCanonical chUnit). + - destruct vs' as [|v' vs''] eqn:E. + + exact (translate_value v). + + split. + * exact (translate_value v). + * rewrite <- E. exact (list_to_chtuple vs'). +Defined. + +Lemma mapM2_cons {A B E R} e (f : A -> B -> result E R) v1 v2 v3 l1 l2 l3 : + mapM2 e f (v1 :: l1) (v2 :: l2) = ok (v3 :: l3) -> + mapM2 e f l1 l2 = ok l3. +Proof. + intros. + jbind H v Hv. + jbind H v' Hv'. + noconf H. + destruct l1, l2, l3; auto. +Qed. + +Lemma bind_list_to_tuple_cons_cons c1 c2 cs : + bind_list_to_tuple (c1 :: c2 :: cs) = + (v ← c1.π2 ;; + vs ← bind_list_to_tuple (c2 :: cs) ;; + ret (v, vs)). +Proof. + reflexivity. +Qed. + +Lemma list_to_chtuple_cons_cons v1 v2 vs : + list_to_chtuple (v1 :: v2 :: vs) = + (translate_value v1, list_to_chtuple (v2 :: vs)). +Proof. + reflexivity. +Qed. + +Lemma bind_list_correct cond cs vs : + [seq c.π1 | c <- cs] = [seq choice_type_of_val v | v <- vs] -> + List.Forall2 (λ c v, ⊢ ⦃ cond ⦄ c.π2 ⇓ coerce_to_choice_type _ (translate_value v) ⦃ cond ⦄) cs vs -> + ⊢ ⦃ cond ⦄ bind_list cs ⇓ [seq to_typed_chElement (translate_value v) | v <- vs ] ⦃ cond ⦄. +Proof. + revert vs. + induction cs; intros. + - destruct vs. + 2: inversion H. + apply u_ret. + intros; auto. + - simpl. + destruct vs. + 1: inversion H0. + inversion H0; subst. + inversion H; subst. + eapply u_bind. + 1: eassumption. + eapply u_bind. + + apply IHcs; eassumption. + + apply u_ret. + intros; split; auto. + simpl. + rewrite H2. + rewrite coerce_to_choice_type_K. + reflexivity. +Qed. + +Lemma bind_list_to_tuple_correct cond cs vs : + [seq c.π1 | c <- cs] = [seq choice_type_of_val v | v <- vs] -> + List.Forall2 (λ c v, ⊢ ⦃ cond ⦄ c.π2 ⇓ coerce_to_choice_type _ (translate_value v) ⦃ cond ⦄) cs vs -> + ⊢ ⦃ cond ⦄ bind_list_to_tuple cs ⇓ coerce_to_choice_type _ (list_to_chtuple vs) ⦃ cond ⦄. +Proof. + revert vs. + induction cs as [| c1 cs]; intros. + - simpl. + inversion H0; subst. + rewrite coerce_to_choice_type_K. + apply u_ret. + intros; auto. + - destruct cs as [|c2 cs'] eqn:Ec. + + simpl. + inversion H0; subst. + inversion H5. + exact H3. + + destruct vs as [|v1 vs]. + 1: discriminate. + destruct vs as [|v2 vs'] eqn:Ev. + 1: discriminate. + rewrite bind_list_to_tuple_cons_cons. + rewrite list_to_chtuple_cons_cons. + rewrite <- Ev, <- Ec in H0. + rewrite <- Ev, <- Ec in H. + inversion H0. + inversion H. + rewrite Ev Ec in H9. + rewrite Ev Ec in H6. + eapply u_bind. + * exact H4. + * eapply u_bind. + ** eapply IHcs. + 1: eassumption. + 1: eassumption. + ** + eapply u_ret. + intros; split; auto. + Admitted. + +Lemma bind_and_truncate_list_to_tuple_correct cond ts cs vs vs' : + mapM2 ErrType truncate_val ts vs = ok vs' -> + [seq c.π1 | c <- cs] = [seq choice_type_of_val v | v <- vs] -> + List.Forall2 (λ c v, ⊢ ⦃ cond ⦄ c.π2 ⇓ coerce_to_choice_type _ (translate_value v) ⦃ cond ⦄) cs vs -> + ⊢ ⦃ cond ⦄ bind_and_truncate_list_to_tuple ts cs ⇓ coerce_to_choice_type _ (list_to_chtuple vs') ⦃ cond ⦄. +Proof. + intros. + revert ts H. + revert vs vs' H0 H1. + induction cs; intros. + - inversion H1; subst. + destruct ts. 2: discriminate. + inversion H; subst. + simpl. + rewrite coerce_to_choice_type_K. + apply u_ret. + intros; split; auto. + - inversion H1; subst. + destruct ts. 1: discriminate. + destruct ts eqn:E. + + simpl. + rewrite bind_assoc. + eapply u_bind. + * exact H4. + * apply u_ret. + intros; split; auto. + jbind H x Hx. + inversion H. + destruct l'. 2: discriminate. + simpl in H. + noconf H. + simpl. + inversion H0. + rewrite H3. + rewrite coerce_to_choice_type_K. + apply translate_truncate_val. + assumption. + + destruct vs'. + { jbind H w Hw. + jbind H w' Hw'. + discriminate. } + cbn -[coerce_to_choice_type lchtuple list_to_chtuple]. + rewrite bind_assoc. + eapply u_bind. 1: exact H4. + cbn -[coerce_to_choice_type lchtuple list_to_chtuple]. + eapply u_bind. + * eapply IHcs with (ts:=s0 :: l). + ** inversion H0. + eassumption. + ** assumption. + ** + eapply mapM2_cons. + exact H. + * apply u_ret. + intros; split; auto. + inversion H0. + rewrite H5. + rewrite coerce_to_choice_type_K. + Admitted. + Lemma translate_truncate_word : ∀ sz sz' (w : word sz) (w' : word sz'), truncate_word sz' w = ok w' → @@ -1496,7 +1710,12 @@ Proof. unfold choice_type_of_val. rewrite type_of_to_val. reflexivity. - - admit. + - jbind H v1 h1. + jbind H v2 h2. + noconf H. + unfold choice_type_of_val. + rewrite type_of_to_val. + reflexivity. - jbind H v1 h1. jbind H v2 h2. jbind H v3 h3. @@ -1506,7 +1725,7 @@ Proof. unfold choice_type_of_val. destruct v1. all: erewrite truncate_val_type. 1,3: reflexivity. 1,2: eassumption. -Admitted. +Qed. Lemma mapM_nil {eT aT bT} f l : @mapM eT aT bT f l = ok [::] → @@ -1671,6 +1890,115 @@ Proof. all: reflexivity. Qed. +Lemma translate_pexprs_types fn s1 es vs : + mapM (sem_pexpr gd s1) es = ok vs -> + [seq (translate_pexpr fn e).π1 | e <- es] = [seq choice_type_of_val v | v <- vs]. +Proof. + revert vs. induction es; intros. + - destruct vs. 2: discriminate. + reflexivity. + - inversion H. + jbind H1 v Hv. + jbind H1 vs' Hvs'. + noconf H1. + simpl. + erewrite IHes by eassumption. + erewrite translate_pexpr_type by eassumption. + reflexivity. +Qed. + +(* jbind with fresh names *) +Ltac jbind_fresh h := + eapply rbindP ; [| exact h ] ; + let x := fresh in + let hx := fresh in + clear h ; intros x hx h ; + cbn beta in h. + +Lemma app_sopn_list_correct (op : opN) (v : sem_t (type_of_opN op).2) (vs : values) : + app_sopn (type_of_opN op).1 (sem_opN_typed op) vs = ok v -> + app_sopn_list (type_of_opN op).1 (sem_opN_typed op) [seq to_typed_chElement (translate_value v) | v <- vs] = + embed v. +Proof. + intros; destruct op. + - simpl in *. + destruct vs. + + destruct w, p; try discriminate; simpl in *. + all: inversion H; reflexivity. + + destruct w, p; try discriminate. + Ltac solve_opn vs H := + repeat (destruct vs; [repeat jbind_fresh H; discriminate|]); + destruct vs; [|repeat jbind_fresh H; discriminate]; + repeat jbind_fresh H; + simpl; + inversion H; + erewrite !translate_to_int by eassumption; + reflexivity. + * solve_opn vs H. + * solve_opn vs H. + * solve_opn vs H. + * solve_opn vs H. + * solve_opn vs H. + * solve_opn vs H. + * solve_opn vs H. + * solve_opn vs H. + * solve_opn vs H. + * solve_opn vs H. + * solve_opn vs H. + * solve_opn vs H. + * solve_opn vs H. + * solve_opn vs H. + * solve_opn vs H. + * solve_opn vs H. + * solve_opn vs H. + * solve_opn vs H. + * solve_opn vs H. + * solve_opn vs H. + * solve_opn vs H. + * solve_opn vs H. + (* U128 and PE1 !!very slow!! *) + * destruct vs. 1: jbind_fresh H; discriminate. + repeat (destruct vs; [repeat jbind_fresh H; discriminate|]). + destruct vs. 2: repeat jbind_fresh H; discriminate. + repeat jbind_fresh H. + inversion H. + simpl. + erewrite !translate_to_int by eassumption. + reflexivity. + * solve_opn vs H. + * solve_opn vs H. + * solve_opn vs H. + * solve_opn vs H. + * solve_opn vs H. + * solve_opn vs H. + * solve_opn vs H. + (* U256 and PE1 !!very slow!! *) + * repeat (destruct vs; [repeat jbind_fresh H; discriminate|]). + destruct vs. 2: repeat jbind_fresh H; discriminate. + repeat jbind_fresh H. + inversion H. + simpl. + erewrite !translate_to_int by eassumption. + reflexivity. + * solve_opn vs H. + * solve_opn vs H. + * solve_opn vs H. + * solve_opn vs H. + * solve_opn vs H. + * solve_opn vs H. + * solve_opn vs H. + - simpl in *. + repeat (destruct vs; [repeat jbind_fresh H; discriminate|]). + destruct vs. 2: repeat jbind_fresh H; discriminate. + repeat jbind_fresh H. + inversion H. + destruct (cf_tbl c) as [[] []]. + all: simpl in *; erewrite translate_to_bool; [|eassumption]; try reflexivity. + all: erewrite translate_to_bool; [|eassumption]; try reflexivity. + all: erewrite translate_to_bool; [|eassumption]; try reflexivity. +Time Qed. +(* Finished transaction in 309.626 secs (301.602u,4.741s) (successful) *) + Lemma translate_pexpr_correct : ∀ fn (e : pexpr) s₁ v (cond : heap → Prop), sem_pexpr gd s₁ e = ok v → @@ -1831,7 +2159,45 @@ Proof. rewrite sop2_unembed_embed. rewrite h6. reflexivity. - - (* PappN TODO *) admit. + - (* PappN *) + simpl in *. + jbind h1 v' h2. + jbind h1 v'' h3. + noconf h1. + (* jbind h3 v''' h4. *) + eapply u_bind. + + eapply bind_list_correct with (vs := v'). + * rewrite <- map_comp. + unfold comp. + eapply translate_pexprs_types. + eassumption. + (* this should maybe be a lemma or the condition in bind_list_correct should be rewrote to match H *) + * clear -h2 H hcond. + revert v' h2 H. + induction es; intros. + ** inversion h2. + constructor. + ** inversion h2. + jbind H1 x Hx. + jbind H1 y Hy. + noconf H1. + constructor. + *** eapply H. + 1: apply mem_head. + 1: eassumption. + assumption. + *** eapply IHes. + 1: assumption. + intros. + eapply H. + { rewrite in_cons. rewrite H0. by apply /orP; right. } + 1: eassumption. + assumption. + + apply u_ret. + intros; split; auto. + rewrite coerce_to_choice_type_translate_value_to_val. + apply app_sopn_list_correct. + assumption. - (* Pif *) simpl in h1. jbind h1 b eb. jbind eb b' eb'. jbind h1 v1 ev1. jbind ev1 v1' ev1'. @@ -1858,7 +2224,7 @@ Proof. erewrite translate_pexpr_type. 2: eassumption. rewrite coerce_to_choice_type_K. apply translate_truncate_val. assumption. -Admitted. +Qed. Lemma ptr_var_neq (ptr : pointer) (fn : funname) (v : var) : translate_ptr ptr != translate_var fn v. From 042ce1c01011e645e5aa92d0bf1fbc56d22dbacb Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Sat, 23 Apr 2022 12:11:09 +0200 Subject: [PATCH 163/383] remove `bind_list_to_tuple` definitions and lemmas --- theories/Jasmin/jasmin_translate.v | 210 ----------------------------- 1 file changed, 210 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 3d856a1b..c4be1ea5 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -763,24 +763,6 @@ Fixpoint lchtuple (ts : seq choice_type) : choice_type := | t1 :: ts => t1 × (lchtuple ts) end. -Lemma lchtuple_cons_cons a b l : - (lchtuple (a :: b :: l)) = (a × lchtuple (b :: l)). -Proof. - reflexivity. -Qed. - -Lemma sem_prod_cons_cons a b l S : - (sem_prod (a :: b :: l) S) = (sem_t a -> sem_prod (b :: l) S). -Proof. - reflexivity. -Qed. - -Lemma sem_prod_cons a l S : - (sem_prod (a :: l) S) = (sem_t a -> sem_prod l S). -Proof. - reflexivity. -Qed. - Definition to_typed_chElement {t : choice_type} (v : t) : typed_chElement := (t ; v). Fixpoint bind_list (cs : list typed_code) {struct cs} : raw_code ([choiceType of list typed_chElement]) := @@ -792,61 +774,6 @@ Fixpoint bind_list (cs : list typed_code) {struct cs} : raw_code ([choiceType of ret (to_typed_chElement v :: vs) end. -(* bind list of code to tuple *) -Fixpoint bind_list_to_tuple (cs : list typed_code) {struct cs} : raw_code (lchtuple ([seq c.π1 | c <- cs])). - destruct cs as [|c cs']. - - exact (ret (chCanonical _)). - - destruct cs' as [|c' cs''] eqn:E. - + exact c.π2. - + eapply bind. - * exact c.π2. - * intros. - eapply bind. - ** exact (bind_list_to_tuple cs'). - ** intros. - cbn -[lchtuple typed_code]. - rewrite lchtuple_cons_cons. - rewrite <- map_cons. - fold typed_code. (* i don't know when this got unfolded *) - rewrite <- E. - exact (ret (X, X0)). -Defined. - -Fixpoint bind_and_truncate_list_to_tuple (ts : list stype) (cs : list typed_code) : raw_code (lchtuple ([seq encode t | t <- ts])) := - match cs with - | [::] => ret (chCanonical _) - | c :: cs' => match ts with - | [::] => ret (chCanonical _) - | t :: ts' => match ts' with - | [::] => v ← (truncate_code t c).π2 ;; - ret v - | t' :: ts'' => - v ← (truncate_code t c).π2 ;; - vs ← bind_and_truncate_list_to_tuple (t' :: ts'') cs' ;; - ret (v, vs) - end - end - end. - -Fixpoint app_sopn_truncated_tuple {S} (ts : seq.seq stype) (op : sem_prod ts (exec (sem_t S))) (vs : lchtuple ([seq encode t | t <- ts])) {struct ts} : encode S. - destruct ts as [|t ts']. - - exact (chCanonical _). - - destruct ts' as [|t' ts''] eqn:E. - + simpl in *. - destruct (op (unembed vs)). - * exact (embed s). - * exact (chCanonical _). - + rewrite sem_prod_cons_cons in op. - destruct vs. - apply unembed in s. - apply op in s. - apply app_sopn_truncated_tuple with (ts:=ts'). - * rewrite E. - exact s. - * rewrite E. - exact s0. -Defined. - Fixpoint type_of_values vs : choice_type := match vs with | [::] => 'unit @@ -1438,43 +1365,6 @@ Proof. apply translate_of_val. assumption. Qed. -Fixpoint list_to_chtuple (vs : values) : lchtuple [seq choice_type_of_val v | v <- vs]. - destruct vs as [|v vs']. - - exact (chCanonical chUnit). - - destruct vs' as [|v' vs''] eqn:E. - + exact (translate_value v). - + split. - * exact (translate_value v). - * rewrite <- E. exact (list_to_chtuple vs'). -Defined. - -Lemma mapM2_cons {A B E R} e (f : A -> B -> result E R) v1 v2 v3 l1 l2 l3 : - mapM2 e f (v1 :: l1) (v2 :: l2) = ok (v3 :: l3) -> - mapM2 e f l1 l2 = ok l3. -Proof. - intros. - jbind H v Hv. - jbind H v' Hv'. - noconf H. - destruct l1, l2, l3; auto. -Qed. - -Lemma bind_list_to_tuple_cons_cons c1 c2 cs : - bind_list_to_tuple (c1 :: c2 :: cs) = - (v ← c1.π2 ;; - vs ← bind_list_to_tuple (c2 :: cs) ;; - ret (v, vs)). -Proof. - reflexivity. -Qed. - -Lemma list_to_chtuple_cons_cons v1 v2 vs : - list_to_chtuple (v1 :: v2 :: vs) = - (translate_value v1, list_to_chtuple (v2 :: vs)). -Proof. - reflexivity. -Qed. - Lemma bind_list_correct cond cs vs : [seq c.π1 | c <- cs] = [seq choice_type_of_val v | v <- vs] -> List.Forall2 (λ c v, ⊢ ⦃ cond ⦄ c.π2 ⇓ coerce_to_choice_type _ (translate_value v) ⦃ cond ⦄) cs vs -> @@ -1503,106 +1393,6 @@ Proof. reflexivity. Qed. -Lemma bind_list_to_tuple_correct cond cs vs : - [seq c.π1 | c <- cs] = [seq choice_type_of_val v | v <- vs] -> - List.Forall2 (λ c v, ⊢ ⦃ cond ⦄ c.π2 ⇓ coerce_to_choice_type _ (translate_value v) ⦃ cond ⦄) cs vs -> - ⊢ ⦃ cond ⦄ bind_list_to_tuple cs ⇓ coerce_to_choice_type _ (list_to_chtuple vs) ⦃ cond ⦄. -Proof. - revert vs. - induction cs as [| c1 cs]; intros. - - simpl. - inversion H0; subst. - rewrite coerce_to_choice_type_K. - apply u_ret. - intros; auto. - - destruct cs as [|c2 cs'] eqn:Ec. - + simpl. - inversion H0; subst. - inversion H5. - exact H3. - + destruct vs as [|v1 vs]. - 1: discriminate. - destruct vs as [|v2 vs'] eqn:Ev. - 1: discriminate. - rewrite bind_list_to_tuple_cons_cons. - rewrite list_to_chtuple_cons_cons. - rewrite <- Ev, <- Ec in H0. - rewrite <- Ev, <- Ec in H. - inversion H0. - inversion H. - rewrite Ev Ec in H9. - rewrite Ev Ec in H6. - eapply u_bind. - * exact H4. - * eapply u_bind. - ** eapply IHcs. - 1: eassumption. - 1: eassumption. - ** - eapply u_ret. - intros; split; auto. - Admitted. - -Lemma bind_and_truncate_list_to_tuple_correct cond ts cs vs vs' : - mapM2 ErrType truncate_val ts vs = ok vs' -> - [seq c.π1 | c <- cs] = [seq choice_type_of_val v | v <- vs] -> - List.Forall2 (λ c v, ⊢ ⦃ cond ⦄ c.π2 ⇓ coerce_to_choice_type _ (translate_value v) ⦃ cond ⦄) cs vs -> - ⊢ ⦃ cond ⦄ bind_and_truncate_list_to_tuple ts cs ⇓ coerce_to_choice_type _ (list_to_chtuple vs') ⦃ cond ⦄. -Proof. - intros. - revert ts H. - revert vs vs' H0 H1. - induction cs; intros. - - inversion H1; subst. - destruct ts. 2: discriminate. - inversion H; subst. - simpl. - rewrite coerce_to_choice_type_K. - apply u_ret. - intros; split; auto. - - inversion H1; subst. - destruct ts. 1: discriminate. - destruct ts eqn:E. - + simpl. - rewrite bind_assoc. - eapply u_bind. - * exact H4. - * apply u_ret. - intros; split; auto. - jbind H x Hx. - inversion H. - destruct l'. 2: discriminate. - simpl in H. - noconf H. - simpl. - inversion H0. - rewrite H3. - rewrite coerce_to_choice_type_K. - apply translate_truncate_val. - assumption. - + destruct vs'. - { jbind H w Hw. - jbind H w' Hw'. - discriminate. } - cbn -[coerce_to_choice_type lchtuple list_to_chtuple]. - rewrite bind_assoc. - eapply u_bind. 1: exact H4. - cbn -[coerce_to_choice_type lchtuple list_to_chtuple]. - eapply u_bind. - * eapply IHcs with (ts:=s0 :: l). - ** inversion H0. - eassumption. - ** assumption. - ** - eapply mapM2_cons. - exact H. - * apply u_ret. - intros; split; auto. - inversion H0. - rewrite H5. - rewrite coerce_to_choice_type_K. - Admitted. - Lemma translate_truncate_word : ∀ sz sz' (w : word sz) (w' : word sz'), truncate_word sz' w = ok w' → From a1e9d59bc93c4ede1a9e859738bd55690b6a61b7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Mon, 25 Apr 2022 17:45:32 +0200 Subject: [PATCH 164/383] Style + fix build --- theories/Jasmin/jasmin_translate.v | 51 ++++++++++++++++-------------- 1 file changed, 28 insertions(+), 23 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index c4be1ea5..9f46d7df 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -562,7 +562,7 @@ Definition chArray_get8 (a : 'array) ptr := end. Lemma chArray_get8_correct len (a : WArray.array len) s ptr : - WArray.get8 a ptr = ok s -> + WArray.get8 a ptr = ok s → chArray_get8 (embed_array a) ptr = translate_value (Vword s). Proof. intros H. simpl. @@ -619,8 +619,8 @@ Definition chArray_set8 (a : 'array) ptr w := setm a ptr w. Lemma chArray_set8_correct {len} (a : WArray.array len) ptr w s : - WArray.set8 a ptr w = ok s - -> chArray_set8 (embed_array a) ptr w = embed_array s. + WArray.set8 a ptr w = ok s → + chArray_set8 (embed_array a) ptr w = embed_array s. Proof. intros H. simpl. unfold WArray.set8 in H. @@ -687,24 +687,24 @@ Proof. Qed. Lemma foldl_set_not_eq {K : ordType} {K' : eqType} {V : eqType} m f g (k : K) (v : V) (l : seq K') : - (forall k', k' \in l -> k <> f k') -> + (∀ k', k' \in l -> k ≠ f k') → setm (foldl (λ m k, setm m (f k) (g k)) m l) k v = foldl (λ m k, setm m (f k) (g k)) (setm m k v) l. Proof. - intros. + intros h. rewrite <- revK. rewrite !foldl_rev. apply foldr_set_not_eq. - intros. - rewrite <- rev_list_rev in H0. - move: H0 => /InP H0. - apply List.in_rev in H0. - apply H. + intros k' hk'. + rewrite <- rev_list_rev in hk'. + move: hk' => /InP hk'. + apply List.in_rev in hk'. + apply h. apply /InP. assumption. Qed. Lemma foldl_foldr_setm - {K : ordType} {K' : eqType} {V : eqType} m (f : K' -> K) (g : K' -> V) (l : seq K') : - uniq [seq f i | i <- l] -> + {K : ordType} {K' : eqType} {V : eqType} m (f : K' → K) (g : K' → V) (l : seq K') : + uniq [seq f i | i <- l] → foldl (λ m k, setm m (f k) (g k)) m l = foldr (λ k m, setm m (f k) (g k)) m l. Proof. intros. @@ -714,7 +714,7 @@ Proof. rewrite <- foldl_set_not_eq. 1: rewrite IHl. 1: reflexivity. - { intros. simpl in H. move: H => /andP. easy. }. + { intros. simpl in H. move: H => /andP. easy. } { intros. simpl in H. move: H => /andP [] H _. clear -H0 H. induction l. @@ -793,16 +793,21 @@ Proof. Defined. Fixpoint app_sopn_list {S} (ts : list stype) := - match ts as ts0 return (sem_prod ts0 (exec (sem_t S)) → [choiceType of list typed_chElement] → encode S) with - | [::] => λ (o : exec (sem_t S)) (vs : list typed_chElement), + match ts as ts0 + return (sem_prod ts0 (exec (sem_t S)) → [choiceType of list typed_chElement] → encode S) + with + | [::] => + λ (o : exec (sem_t S)) (vs : list typed_chElement), match vs with - | [::] => match o with - | Ok o => embed o - | _ => chCanonical _ - end + | [::] => + match o with + | Ok o => embed o + | _ => chCanonical _ + end | _ :: _ => chCanonical _ end - | t :: ts0 => λ (o : sem_t t → sem_prod ts0 (exec (sem_t S))) (vs : list typed_chElement), + | t :: ts0 => + λ (o : sem_t t → sem_prod ts0 (exec (sem_t S))) (vs : list typed_chElement), match vs with | [::] => chCanonical _ | v :: vs0 => app_sopn_list ts0 (o (unembed (truncate_el t v.π2))) vs0 @@ -1366,8 +1371,8 @@ Proof. Qed. Lemma bind_list_correct cond cs vs : - [seq c.π1 | c <- cs] = [seq choice_type_of_val v | v <- vs] -> - List.Forall2 (λ c v, ⊢ ⦃ cond ⦄ c.π2 ⇓ coerce_to_choice_type _ (translate_value v) ⦃ cond ⦄) cs vs -> + [seq c.π1 | c <- cs] = [seq choice_type_of_val v | v <- vs] → + List.Forall2 (λ c v, ⊢ ⦃ cond ⦄ c.π2 ⇓ coerce_to_choice_type _ (translate_value v) ⦃ cond ⦄) cs vs → ⊢ ⦃ cond ⦄ bind_list cs ⇓ [seq to_typed_chElement (translate_value v) | v <- vs ] ⦃ cond ⦄. Proof. revert vs. @@ -1681,7 +1686,7 @@ Proof. Qed. Lemma translate_pexprs_types fn s1 es vs : - mapM (sem_pexpr gd s1) es = ok vs -> + mapM (sem_pexpr gd s1) es = ok vs → [seq (translate_pexpr fn e).π1 | e <- es] = [seq choice_type_of_val v | v <- vs]. Proof. revert vs. induction es; intros. From 63d8fd7b66571b2cb890e97b505051a26e42a536 Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Mon, 25 Apr 2022 11:44:46 +0200 Subject: [PATCH 165/383] Move deriving import to avoid conflicting instances for Z_choiceType --- theories/Crypt/choice_type.v | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/theories/Crypt/choice_type.v b/theories/Crypt/choice_type.v index ca3a07e9..721c4249 100644 --- a/theories/Crypt/choice_type.v +++ b/theories/Crypt/choice_type.v @@ -9,6 +9,12 @@ From Coq Require Import Utf8 Lia. From Relational Require Import OrderEnrichedCategory OrderEnrichedRelativeMonadExamples GenericRulesSimple. + +(* !!! Import before mathcomp, to avoid overriding instances !!! *) +(* specifically, importing after mathcomp results in conflicting instances for + Z_choiceType. *) +From deriving Require Import deriving. + Set Warnings "-ambiguous-paths,-notation-overridden,-notation-incompatible-format". From mathcomp Require Import ssrnat ssreflect ssrfun ssrbool ssrnum eqtype choice reals distr realsum seq all_algebra fintype. @@ -17,7 +23,6 @@ From Jasmin Require Import utils word. Set Warnings "ambiguous-paths,notation-overridden,notation-incompatible-format". From Crypt Require Import Prelude Axioms. From extructures Require Import ord fset fmap. -From deriving Require Import deriving. From Mon Require Import SPropBase. Require Equations.Prop.DepElim. From Equations Require Import Equations. From cf7073a8e419e9f1ccf74566a237f7c70ff46efc Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Mon, 25 Apr 2022 17:24:25 +0200 Subject: [PATCH 166/383] pass the signatures of preceding translated functions through the translation Procedure calls need to know at which type they happen, so we pass around a typing environment in the translation of instructions. This environment is built from the translation of a program by projecting the translated functions to their input- and output-types. --- theories/Jasmin/jasmin_translate.v | 74 +++++++++++++++++++++--------- 1 file changed, 52 insertions(+), 22 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 9f46d7df..99027f88 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -969,8 +969,8 @@ Definition translate_write_lval (fn : funname) (l : lval) (v : typed_code) Definition instr_d (i : instr) : instr_r := match i with MkI _ i => i end. -Fixpoint translate_instr_r (fn : funname) (i : instr_r) {struct i} : raw_code 'unit -with translate_instr (fn : funname) (i : instr) {struct i} : raw_code 'unit. +Fixpoint translate_instr_r (prog_exports : {fmap funname -> opsig}) (fn : funname) (i : instr_r) {struct i} : raw_code 'unit +with translate_instr (prog_exports : {fmap funname -> opsig}) (fn : funname) (i : instr) {struct i} : raw_code 'unit. Proof. (* translate_instr_r *) { @@ -978,10 +978,11 @@ Proof. (fix translate_cmd (fn : funname) (c : cmd) : raw_code 'unit := match c with | [::] => ret tt - | i :: c => translate_instr fn i ;; translate_cmd fn c + | i :: c => translate_instr prog_exports fn i ;; + translate_cmd fn c end)). - destruct i as [ | | e c1 c2 | | | ]. + destruct i as [ | | e c1 c2 | | | ii xs f args ]. - (* Cassgn *) (* l :a=_s p *) pose (translate_pexpr fn p) as tr_p. @@ -996,11 +997,31 @@ Proof. exact (b ← rb ;; if b then c1' else c2'). - exact (unsupported.π2). (* Cfor *) - exact (unsupported.π2). (* Cwhile *) - - (* Ccall i l f l0 *) + - (* Ccall ii xs f args *) (* translate arguments *) - pose (map (translate_pexpr fn) l0) as tr_l0. + pose (map (translate_pexpr f) args) as tr_args. (* "perform" the call via `opr` *) (* probably we'd look up the function signature in the current ambient program *) + destruct (prog_exports f) as [f_sg|]. + 2: { + (* The function `fn` wasn't found in the exports. This should mean that + the Jasmin semantics also failed at `sem_call` where + `get_fundef (p_funcs P) fn = Some f` is expected. *) + exact (unsupported.π2). + } + (* evaluate arguments *) + pose f_sg.2.1 as ts_in. + pose (map (fun x => x.π1) tr_args) as ts_args. + + pose (bind_list' tr_args) as es. + apply (bind es). + intros vs. + (* truncate arguments *) + + (* TODO: store function arguments in their locations *) + (* opr o vs ;; *) + + (* apply (opr o). *) (* write_lvals the result of the call into lvals `l` *) @@ -1008,35 +1029,37 @@ Proof. } (* translate_instr *) { - exact (translate_instr_r fn (instr_d i)). + exact (translate_instr_r prog_exports fn (instr_d i)). } Defined. -Fixpoint translate_cmd (fn : funname) (c : cmd) : raw_code 'unit := +Fixpoint translate_cmd (prog_exports : {fmap funname -> opsig}) (fn : funname) (c : cmd) : raw_code 'unit := match c with | [::] => ret tt - | i :: c => translate_instr fn i ;; translate_cmd fn c + | i :: c => translate_instr prog_exports fn i ;; translate_cmd prog_exports fn c end. Record fdef := { ffun : typed_raw_function ; locs : {fset Location} ; imp : Interface ; - exp : Interface + ty_in : choice_type ; + ty_out : choice_type ; }. -Definition translate_fundef (fd : _ufun_decl (* extra_fun_t *)) : funname * fdef. +Definition translate_fundef (prog_exports : {fmap funname -> opsig}) + (fd : _ufun_decl (* extra_fun_t *)) : funname * fdef. Proof. destruct fd. destruct _f. split. 1: exact f. constructor. - exists 'unit, 'unit. intros _. - (* TODO: store function arguments in their locations *) - exact (translate_cmd f f_body). - (* TODO: read return values from their locations *) + exact (translate_cmd prog_exports f f_body). + (* TODO: store return values in their locations *) - exact fset0. - exact [interface]. - - exact [interface]. + - exact 'unit. + - exact 'unit. Defined. (* Apply cast_fun or return default value, like lookup_op *) @@ -2061,13 +2084,13 @@ Another option is to inline it all in translate_prog_correct which given the goals is probably the way things are intended. *) Lemma translate_instr_r_correct : - ∀ (fn : funname) (i : instr_r) (s₁ s₂ : estate), + ∀ (prog_exports : {fmap funname -> opsig}) (fn : funname) (i : instr_r) (s₁ s₂ : estate), sem_i P s₁ i s₂ → ⊢ ⦃ rel_estate s₁ fn ⦄ - translate_instr_r fn i ⇓ tt + translate_instr_r prog_exports fn i ⇓ tt ⦃ rel_estate s₂ fn ⦄. Proof. - intros fn i s₁ s₂ h. + intros prog_exports fn i s₁ s₂ h. induction h as [es₁ es₂ y tag sty e v v' sem_e trunc hw | | | | | | |]. - simpl. destruct y as [ | yl | | aa ws x ei | ] eqn:case_lval. + simpl. apply u_ret_eq. intros hp hr. @@ -2270,8 +2293,14 @@ Admitted. Definition ssprove_prog := seq (funname * fdef). +Definition exports_of_prog (p : ssprove_prog) : {fmap funname -> opsig} := + foldl (λ m f, setm m f.1 (nat_of_pos f.1, (ty_in f.2, ty_out f.2))) + emptym p. + Definition translate_prog : ssprove_prog := - map translate_fundef P.(p_funcs). + foldl (λ p f, let f' := translate_fundef (exports_of_prog p) f in + f' :: p) + [::] P.(p_funcs). Theorem translate_prog_correct (fn : funname) m va m' vr f : sem.sem_call P m fn va m' vr → @@ -2296,22 +2325,23 @@ Proof. f (translate_values va) ⇓ translate_values vr ⦃ λ m, True ⦄ ). + set (ep := exports_of_prog translate_prog). set (Pi_r := λ (s1 : estate) (i : instr_r) (s2 : estate), ⊢ ⦃ rel_estate s1 fn ⦄ - translate_instr_r fn i ⇓ tt + translate_instr_r ep fn i ⇓ tt ⦃ rel_estate s2 fn ⦄ ). set (Pi := λ s1 i s2, (Pi_r s1 (instr_d i) s2)). set (Pc := λ (s1 : estate) (c : cmd) (s2 : estate), - ⊢ ⦃ rel_estate s1 fn ⦄ translate_cmd fn c ⇓ tt ⦃ rel_estate s2 fn ⦄ + ⊢ ⦃ rel_estate s1 fn ⦄ translate_cmd ep fn c ⇓ tt ⦃ rel_estate s2 fn ⦄ ). (* FIXME *) set (Pfor := λ (v : var_i) (ls : seq Z) (s1 : estate) (c : cmd) (s2 : estate), ⊢ ⦃ rel_estate s1 fn ⦄ - (* ssprove_for *) translate_cmd fn c ⇓ tt + (* ssprove_for *) translate_cmd ep fn c ⇓ tt ⦃ rel_estate s2 fn ⦄ ). unshelve eapply (@sem_call_Ind _ _ _ _ Pc Pi_r Pi Pfor Pfun _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H). From 09ff0feec4898edcb2273aa633571187912b9a8d Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Mon, 25 Apr 2022 17:33:54 +0200 Subject: [PATCH 167/383] Alt. definition of bind_list with corrected computational behaviour --- theories/Jasmin/jasmin_translate.v | 76 +++++++++++++++++++++++++++++- 1 file changed, 75 insertions(+), 1 deletion(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 99027f88..7d54d4bf 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -813,6 +813,62 @@ Fixpoint app_sopn_list {S} (ts : list stype) := | v :: vs0 => app_sopn_list ts0 (o (unembed (truncate_el t v.π2))) vs0 end end. +Section bind_list_alt. + Definition bind_typed_list (cs : list typed_code) + : raw_code (lchtuple ([seq tc.π1 | tc <- cs])). + Proof. + induction cs as [| c cs bind_cs]. + - exact (ret tt). + - destruct cs as [|c' cs']. + + exact c.π2. + + exact ( vs ← bind_cs ;; + v ← c.π2 ;; + ret (v, vs) ). + Defined. + + Definition bind_list_truncate (l : list (stype * typed_code)) + : raw_code (lchtuple ([seq encode ttc.1 | ttc <- l])). + Proof. + induction l as [| [t c] tcs bind_tcs]. + - exact (ret tt). + - destruct tcs as [| [t' c'] tcs']. + + pose (truncate_code t c) as c'. + exact c'.π2. + + exact ( vs ← bind_tcs ;; + v ← (truncate_code t c).π2 ;; + ret (v, vs) ). + Defined. + + Lemma map_fst {A B C} (xs : seq A) (ys : seq B) (f : A -> C) (H : size xs = size ys) + : [seq f xy.1 | xy <- zip xs ys] = [seq f x | x <- xs]. + Proof. + set (f' := fun xy => f (fst xy)). + assert ([seq f' i | i <- zip xs ys] = map f (unzip1 (zip xs ys))) as mc by apply map_comp. + rewrite mc. + rewrite unzip1_zip. + 1: reflexivity. + now rewrite H. + Qed. + + Definition bind_list_trunc_aux (ts : list stype) (cs : list typed_code) + (H : size ts = size cs) + : raw_code (lchtuple ([seq encode t | t <- ts])). + Proof. + erewrite <- map_fst. + 1: exact (bind_list_truncate (zip ts cs)). + assumption. + Defined. + + Definition bind_list' (ts : list stype) (cs : list typed_code) + : raw_code (lchtuple ([seq encode t | t <- ts])). + Proof. + destruct (size ts == size cs) eqn:e. + - eapply bind_list_trunc_aux. + apply: eqP e. + - exact (ret (chCanonical _)). + Defined. + +End bind_list_alt. (* Following sem_pexpr *) Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code := @@ -1013,7 +1069,7 @@ Proof. pose f_sg.2.1 as ts_in. pose (map (fun x => x.π1) tr_args) as ts_args. - pose (bind_list' tr_args) as es. + pose (bind_typed_list tr_args) as es. apply (bind es). intros vs. (* truncate arguments *) @@ -1306,6 +1362,24 @@ Proof. all: simpl. all: rewrite coerce_to_choice_type_K. all: reflexivity. Qed. + +Section bind_list_test. + (* Quick test to see that the definition-via-tactics of bind_list' computes + as expected. *) + Definition cs : list typed_code := + [:: ('bool; (ret false)) ; ('bool; (ret true)) ; ('nat; (ret 666)) ; ('int; ret 42%Z)]. + Definition ts := [:: sbool; sbool; sint; sint]. + Goal bind_list' ts cs = bind_list' ts cs. + unfold bind_list' at 2. + unfold bind_list_trunc_aux. + simpl. + rewrite !coerce_to_choice_type_K. + simp coerce_to_choice_type. + cbn. + Abort. +End bind_list_test. + + Lemma get_var_get_heap : ∀ fn x s v m, get_var (evm s) x = ok v → From 11f0a6c6518dfb942e61de1db5dba5f6e97c3ffe Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Mon, 25 Apr 2022 21:19:58 +0200 Subject: [PATCH 168/383] Nits --- theories/Jasmin/jasmin_translate.v | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 7d54d4bf..93911899 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -813,7 +813,9 @@ Fixpoint app_sopn_list {S} (ts : list stype) := | v :: vs0 => app_sopn_list ts0 (o (unembed (truncate_el t v.π2))) vs0 end end. + Section bind_list_alt. + Definition bind_typed_list (cs : list typed_code) : raw_code (lchtuple ([seq tc.π1 | tc <- cs])). Proof. @@ -1067,7 +1069,7 @@ Proof. } (* evaluate arguments *) pose f_sg.2.1 as ts_in. - pose (map (fun x => x.π1) tr_args) as ts_args. + pose (map (λ x, x.π1) tr_args) as ts_args. pose (bind_typed_list tr_args) as es. apply (bind es). @@ -1364,6 +1366,7 @@ Qed. Section bind_list_test. + (* Quick test to see that the definition-via-tactics of bind_list' computes as expected. *) Definition cs : list typed_code := From a4740492ec62a1f03fbcdfc17e43cfdb378fc89f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Tue, 26 Apr 2022 10:09:58 +0200 Subject: [PATCH 169/383] Prove app_sopn_nil_ok_size to avoid countless discriminates --- theories/Jasmin/jasmin_translate.v | 38 +++++++++++++++++++++++------- 1 file changed, 30 insertions(+), 8 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 93911899..fe4854ff 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1810,16 +1810,38 @@ Ltac jbind_fresh h := clear h ; intros x hx h ; cbn beta in h. -Lemma app_sopn_list_correct (op : opN) (v : sem_t (type_of_opN op).2) (vs : values) : - app_sopn (type_of_opN op).1 (sem_opN_typed op) vs = ok v -> - app_sopn_list (type_of_opN op).1 (sem_opN_typed op) [seq to_typed_chElement (translate_value v) | v <- vs] = - embed v. +Lemma app_sopn_nil_ok_size : + ∀ T ts (f : sem_prod ts (exec T)) vs v, + app_sopn ts f vs = ok v → + size ts = size vs. Proof. - intros; destruct op. + intros A ts f vs v h. + induction ts as [| t ts ih] in f, vs, v, h |- *. + - destruct vs. 2: discriminate. + reflexivity. + - destruct vs as [| v' vs]. 1: discriminate. + simpl in *. + jbind h v1 hv. + f_equal. eapply ih. eassumption. +Qed. + +Lemma app_sopn_list_correct (op : opN) (v : sem_t (type_of_opN op).2) (vs : values) : + app_sopn (type_of_opN op).1 (sem_opN_typed op) vs = ok v → + app_sopn_list + (type_of_opN op).1 + (sem_opN_typed op) + [seq to_typed_chElement (translate_value v) | v <- vs] + = + embed v. +Proof. + intro H. + destruct op as [w p | c]. - simpl in *. - destruct vs. - + destruct w, p; try discriminate; simpl in *. - all: inversion H; reflexivity. + destruct vs as [| v' vs]. + + apply app_sopn_nil_ok_size in H as hl. + simpl in hl. rewrite size_nseq in hl. rewrite hl. simpl. + rewrite hl in H. simpl in H. unfold curry in H. noconf H. + reflexivity. + destruct w, p; try discriminate. Ltac solve_opn vs H := repeat (destruct vs; [repeat jbind_fresh H; discriminate|]); From d7d56c8f88f86f1536de475a2dc2488aaba4be70 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Tue, 26 Apr 2022 10:33:50 +0200 Subject: [PATCH 170/383] Much more concise and fast proof of app_sopn_list_correct --- theories/Jasmin/jasmin_translate.v | 79 ++++-------------------------- 1 file changed, 10 insertions(+), 69 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index fe4854ff..0fefdd45 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1837,73 +1837,15 @@ Proof. intro H. destruct op as [w p | c]. - simpl in *. - destruct vs as [| v' vs]. - + apply app_sopn_nil_ok_size in H as hl. - simpl in hl. rewrite size_nseq in hl. rewrite hl. simpl. - rewrite hl in H. simpl in H. unfold curry in H. noconf H. - reflexivity. - + destruct w, p; try discriminate. - Ltac solve_opn vs H := - repeat (destruct vs; [repeat jbind_fresh H; discriminate|]); - destruct vs; [|repeat jbind_fresh H; discriminate]; - repeat jbind_fresh H; - simpl; - inversion H; - erewrite !translate_to_int by eassumption; - reflexivity. - * solve_opn vs H. - * solve_opn vs H. - * solve_opn vs H. - * solve_opn vs H. - * solve_opn vs H. - * solve_opn vs H. - * solve_opn vs H. - * solve_opn vs H. - * solve_opn vs H. - * solve_opn vs H. - * solve_opn vs H. - * solve_opn vs H. - * solve_opn vs H. - * solve_opn vs H. - * solve_opn vs H. - * solve_opn vs H. - * solve_opn vs H. - * solve_opn vs H. - * solve_opn vs H. - * solve_opn vs H. - * solve_opn vs H. - * solve_opn vs H. - (* U128 and PE1 !!very slow!! *) - * destruct vs. 1: jbind_fresh H; discriminate. - repeat (destruct vs; [repeat jbind_fresh H; discriminate|]). - destruct vs. 2: repeat jbind_fresh H; discriminate. - repeat jbind_fresh H. - inversion H. - simpl. - erewrite !translate_to_int by eassumption. - reflexivity. - * solve_opn vs H. - * solve_opn vs H. - * solve_opn vs H. - * solve_opn vs H. - * solve_opn vs H. - * solve_opn vs H. - * solve_opn vs H. - (* U256 and PE1 !!very slow!! *) - * repeat (destruct vs; [repeat jbind_fresh H; discriminate|]). - destruct vs. 2: repeat jbind_fresh H; discriminate. - repeat jbind_fresh H. - inversion H. - simpl. - erewrite !translate_to_int by eassumption. - reflexivity. - * solve_opn vs H. - * solve_opn vs H. - * solve_opn vs H. - * solve_opn vs H. - * solve_opn vs H. - * solve_opn vs H. - * solve_opn vs H. + apply app_sopn_nil_ok_size in H as hl. + rewrite size_nseq in hl. rewrite hl. + rewrite hl in H. + set (f := curry _ _) in *. clearbody f. + induction vs as [| v' vs ih] in v, w, f, H |- *. + + simpl in *. rewrite H. reflexivity. + + simpl in *. jbind H v1 hv1. + eapply ih. eapply translate_to_int in hv1. + rewrite hv1. assumption. - simpl in *. repeat (destruct vs; [repeat jbind_fresh H; discriminate|]). destruct vs. 2: repeat jbind_fresh H; discriminate. @@ -1913,8 +1855,7 @@ Proof. all: simpl in *; erewrite translate_to_bool; [|eassumption]; try reflexivity. all: erewrite translate_to_bool; [|eassumption]; try reflexivity. all: erewrite translate_to_bool; [|eassumption]; try reflexivity. -Time Qed. -(* Finished transaction in 309.626 secs (301.602u,4.741s) (successful) *) +Qed. Lemma translate_pexpr_correct : ∀ fn (e : pexpr) s₁ v (cond : heap → Prop), From f4518a5aaa60f0d0d830f75210d1b47eac5e2e28 Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Wed, 27 Apr 2022 13:59:21 +0200 Subject: [PATCH 171/383] translate funcall (wip) --- theories/Jasmin/jasmin_translate.v | 131 ++++++++++++++++++++++++----- 1 file changed, 108 insertions(+), 23 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 0fefdd45..a31b9210 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -763,6 +763,27 @@ Fixpoint lchtuple (ts : seq choice_type) : choice_type := | t1 :: ts => t1 × (lchtuple ts) end. +(* Unpack `t : lchtuple stys` into a list `xs` s.t. `nth i xs = (nth i sty, t.i)`. *) +Definition coerce_chtuple_to_list (ty : choice_type) (stys : seq stype) (t : ty) + : list typed_chElement. +Proof. + pose (lchtuple (map encode stys)) as ty'. + destruct (ty == ty') eqn:E. + 2: exact [::]. + move: E. move /eqP => E. + subst. unfold ty' in t. clear ty'. + move: t. induction stys. + - move => _. exact [::]. + - intros. + destruct stys in IHstys, t |- *. + + simpl in *. apply cons. 2: exact [::]. + econstructor. exact t. + + destruct t as [t1 ts]. + pose (IHstys ts) as tl. + pose ((encode a; t1) : typed_chElement) as hd. + exact (hd :: tl). +Defined. + Definition to_typed_chElement {t : choice_type} (v : t) : typed_chElement := (t ; v). Fixpoint bind_list (cs : list typed_code) {struct cs} : raw_code ([choiceType of list typed_chElement]) := @@ -1056,34 +1077,52 @@ Proof. - exact (unsupported.π2). (* Cfor *) - exact (unsupported.π2). (* Cwhile *) - (* Ccall ii xs f args *) - (* translate arguments *) + (* Translate arguments. *) pose (map (translate_pexpr f) args) as tr_args. - (* "perform" the call via `opr` *) - (* probably we'd look up the function signature in the current ambient program *) + + (* We need some typing about the translated and original f, let's look it + up. *) destruct (prog_exports f) as [f_sg|]. 2: { - (* The function `fn` wasn't found in the exports. This should mean that + (* The function `f` wasn't found in the exports. This should mean that the Jasmin semantics also failed at `sem_call` where - `get_fundef (p_funcs P) fn = Some f` is expected. *) + `get_fundef (p_funcs P) f = Some f'` is expected. *) exact (unsupported.π2). } - (* evaluate arguments *) - pose f_sg.2.1 as ts_in. - pose (map (λ x, x.π1) tr_args) as ts_args. - - pose (bind_typed_list tr_args) as es. - apply (bind es). - intros vs. - (* truncate arguments *) - - (* TODO: store function arguments in their locations *) - (* opr o vs ;; *) - - (* apply (opr o). *) - - (* write_lvals the result of the call into lvals `l` *) - - exact (unsupported.π2). + destruct (get_fundef (p_funcs P) f) eqn:E. + 2: exact (unsupported.π2). + + (* Evaluate & truncate arguments according to the Jasmin typing of `f`. *) + (* Note that in Ecall we do not need to truncate, as sem_call does not + enforce any relation between the types of the function and the + arguments. But we need the types to match. sem_call, however, does + truncate as soon as the type of `f` is looked up. *) + pose (bind_list' _f.(f_tyin) tr_args) as vargs'. + (* pose (bind_list [seq translate_pexpr fn e | e <- args]) as vargs'. *) + (* Bind the values. *) + apply (bind vargs'). intros vargs. + (* Now "perform" the call via `opr`. *) + apply (opr f_sg). + + exact (coerce_to_choice_type (chsrc f_sg) vargs). + + intros vs. + + (* Unpack `vs : tgt f_sg` into a list in order to write `xs`. *) + pose (f_tyout _f) as f_tyout. + apply (coerce_chtuple_to_list _ f_tyout) in vs. + pose (zip f_tyout vs) as vs_f. + + (* We coerce than truncating here. The truncation should happen in + sem_call; the coercion should never fail on well-translated + functions. Presumably these results just got truncated in sem_call, + so we could also truncate instead of coercing if convenient. *) + pose (map (λ '(ty,c), + let ty' := encode ty in + (ty'; ret (coerce_to_choice_type ty' c.π2)) : typed_code) vs_f) + as vres'. + (* pose (map (λ '(ty,c), (truncate_code ty (totc c.π1 (ret c.π2)))) l0) as vres'. *) + + pose (map (λ '(x,v), translate_write_lval fn x v) (zip xs vres')) as vres''. + exact (foldl (λ c k, c ;; k) (ret tt) vres''). } (* translate_instr *) { @@ -1111,7 +1150,53 @@ Proof. destruct fd. destruct _f. split. 1: exact f. constructor. - - exists 'unit, 'unit. intros _. + - pose (lchtuple (map encode f_tyin)) as tyin'. + pose (lchtuple (map encode f_tyout)) as tyout'. + exists tyin', tyout'. intros vargs'. + + (* TODO: need a version of coerce_chtuple_to_list that truncates instead *) + apply (coerce_chtuple_to_list _ f_tyin) in vargs'. + + + pose ( + map (λ '(x,v), translate_write_var f x v) + (zip f_params + (map + (λ '(c, t), + let c' := totc (ret c) in + truncate_code t c') + (zip vargs' f_tyin))) + ) as cargs. + + + pose ( + map (λ '(x,v), translate_write_var f x v) + (zip f_params + (map + (λ '(c, t), + let c' := translate_pexpr f c in + truncate_code t c') + (zip vargs' f_tyin))) + ) as cargs. + pose (foldl (λ c k, c ;; k) (ret tt) cargs) as cargs'. + apply (bind cargs') => _. + + apply (opr f_sg). + + + pose f_sg.2.1 as ts_in. + pose (map (λ x, x.π1) tr_args) as ts_args. + + + (* TODO: store function arguments in their locations *) + (* opr o vs ;; *) + + (* apply (opr o). *) + + (* write_lvals the result of the call into lvals `l` *) + + exact (unsupported.π2). + exact (translate_cmd prog_exports f f_body). (* TODO: store return values in their locations *) - exact fset0. From 0edc48bd053a40aa5b27e07b68819af43a8ffa7a Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Wed, 27 Apr 2022 14:24:28 +0200 Subject: [PATCH 172/383] translate fundef (wip) --- theories/Jasmin/jasmin_translate.v | 25 +++++++------------------ 1 file changed, 7 insertions(+), 18 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index a31b9210..ad7c064f 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1163,29 +1163,16 @@ Proof. (zip f_params (map (λ '(c, t), - let c' := totc (ret c) in + let c' := totc c.π1 (ret c.π2) in truncate_code t c') (zip vargs' f_tyin))) ) as cargs. - - pose ( - map (λ '(x,v), translate_write_var f x v) - (zip f_params - (map - (λ '(c, t), - let c' := translate_pexpr f c in - truncate_code t c') - (zip vargs' f_tyin))) - ) as cargs. pose (foldl (λ c k, c ;; k) (ret tt) cargs) as cargs'. apply (bind cargs') => _. - apply (opr f_sg). - - - pose f_sg.2.1 as ts_in. - pose (map (λ x, x.π1) tr_args) as ts_args. + (* pose f_sg.2.1 as ts_in. *) + (* pose (map (λ x, x.π1) tr_args) as ts_args. *) (* TODO: store function arguments in their locations *) @@ -1195,10 +1182,12 @@ Proof. (* write_lvals the result of the call into lvals `l` *) - exact (unsupported.π2). - exact (translate_cmd prog_exports f f_body). + pose (translate_cmd prog_exports f f_body) as body. + apply (bind body) => _. (* TODO: store return values in their locations *) + + exact (ret (chCanonical _)). - exact fset0. - exact [interface]. - exact 'unit. From a47e95f553ec52df9f2639ab2e902b50371c08af Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Wed, 27 Apr 2022 15:07:03 +0200 Subject: [PATCH 173/383] define the function part of translate_fundef --- theories/Jasmin/jasmin_translate.v | 60 ++++++++++++------------------ 1 file changed, 24 insertions(+), 36 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index ad7c064f..038cf030 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1111,8 +1111,8 @@ Proof. apply (coerce_chtuple_to_list _ f_tyout) in vs. pose (zip f_tyout vs) as vs_f. - (* We coerce than truncating here. The truncation should happen in - sem_call; the coercion should never fail on well-translated + (* We coerce rather than truncating here. The truncation should happen + in sem_call; the coercion should never fail on well-translated functions. Presumably these results just got truncated in sem_call, so we could also truncate instead of coercing if convenient. *) pose (map (λ '(ty,c), @@ -1140,10 +1140,11 @@ Record fdef := { ffun : typed_raw_function ; locs : {fset Location} ; imp : Interface ; - ty_in : choice_type ; - ty_out : choice_type ; }. +#[local] Definition ty_in fd := (ffun fd).π1. +#[local] Definition ty_out fd := ((ffun fd).π2).π1. + Definition translate_fundef (prog_exports : {fmap funname -> opsig}) (fd : _ufun_decl (* extra_fun_t *)) : funname * fdef. Proof. @@ -1154,44 +1155,31 @@ Proof. pose (lchtuple (map encode f_tyout)) as tyout'. exists tyin', tyout'. intros vargs'. - (* TODO: need a version of coerce_chtuple_to_list that truncates instead *) + (* NB: We coerce rather than truncating here, i.e. we expect the arguments + provided to us to be of the correct type. This differs slightly from + Jasmin where the truncation is performed in `sem_call`. However, as + explained in the translation of `Ccall` in `translate_instr_r`, we need + the types of the arguments to match the function in order to write the + function application, so we truncate at the caller side. We thus expect + the arguments to already be of the type `f_tyin` prescribed by the + function `f`. *) apply (coerce_chtuple_to_list _ f_tyin) in vargs'. + (* Write the arguments to their locations. *) + pose (map (λ '(x, (ty; v)), translate_write_var f x (totc ty (ret v))) + (zip f_params vargs')) + as cargs. + apply (foldl (λ c k, c ;; k) (ret tt)) in cargs. + apply (bind cargs) => _. - pose ( - map (λ '(x,v), translate_write_var f x v) - (zip f_params - (map - (λ '(c, t), - let c' := totc c.π1 (ret c.π2) in - truncate_code t c') - (zip vargs' f_tyin))) - ) as cargs. - - pose (foldl (λ c k, c ;; k) (ret tt) cargs) as cargs'. - apply (bind cargs') => _. - - (* pose f_sg.2.1 as ts_in. *) - (* pose (map (λ x, x.π1) tr_args) as ts_args. *) - - - (* TODO: store function arguments in their locations *) - (* opr o vs ;; *) - - (* apply (opr o). *) - - (* write_lvals the result of the call into lvals `l` *) - - - pose (translate_cmd prog_exports f f_body) as body. - apply (bind body) => _. - (* TODO: store return values in their locations *) + (* Perform the function body. *) + apply (bind (translate_cmd prog_exports f f_body)) => _. - exact (ret (chCanonical _)). + (* Look up the results in their locations and return them. *) + pose (map (λ x, totc _ (translate_get_var f (v_var x))) f_res) as cres. + exact (bind_list' f_tyout cres). - exact fset0. - exact [interface]. - - exact 'unit. - - exact 'unit. Defined. (* Apply cast_fun or return default value, like lookup_op *) From e4430402a4adbdda4d66a3e37b499abef23c8e03 Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Wed, 27 Apr 2022 16:21:51 +0200 Subject: [PATCH 174/383] simplify the output of the jasmin/xor example --- theories/Jasmin/examples/xor/xor.v | 62 +++++++++++++++++++++++++----- 1 file changed, 53 insertions(+), 9 deletions(-) diff --git a/theories/Jasmin/examples/xor/xor.v b/theories/Jasmin/examples/xor/xor.v index a049587d..60e643f8 100644 --- a/theories/Jasmin/examples/xor/xor.v +++ b/theories/Jasmin/examples/xor/xor.v @@ -134,17 +134,61 @@ Notation " a [ w / p ] " := (at level 99, no associativity, format " a [ w / p ] "). + +From Equations Require Import Equations. +Set Equations With UIP. +Set Equations Transparent. + Definition tr_xor := translate_prog xor. +Definition f_xor : 'word U64 × 'word U64 -> raw_code ('word U64). +Proof. + pose tr_xor. unfold tr_xor in s. unfold translate_prog in s. + simpl in s. + destruct s eqn:E. + - unfold s in E. discriminate. + - pose (ffun p.2).π2.π2. + simpl in r. + unfold s in E. + noconf E. + (* simpl in r. *) + exact r. +Defined. + +Lemma eq_rect_K : + forall (A : eqType) (x : A) (P : A -> Type) h e, + @eq_rect A x P h x e = h. +Proof. + intros A x P' h e. + replace e with (@erefl A x) by apply eq_irrelevance. + reflexivity. +Qed. + Eval cbn in tr_xor. -Goal tr_xor = tr_xor. - unfold tr_xor at 2. - unfold translate_prog, translate_fundef. - unfold translate_cmd. +Goal forall w, f_xor w = f_xor w. + intros [w1 w2]. + unfold f_xor at 2. + unfold apply_noConfusion. simpl. + unfold translate_write_var. simpl. unfold translate_var. simpl. - set (x := ('word U64; nat_of_fun_ident 2%positive "x.131")). - set (r := ('word U64; nat_of_fun_ident 2%positive "r.133")). - set (y := ('word U64; nat_of_fun_ident 2%positive "y.132")). - (* does nothing; too many binders? *) - (* repeat setoid_rewrite zero_extend_u. *) + set (fn := 2%positive). + set (x := ('word U64; nat_of_fun_ident fn "x.131")). + set (r := ('word U64; nat_of_fun_ident fn "r.133")). + set (y := ('word U64; nat_of_fun_ident fn "y.132")). + set (r_ := {| vtype := sword64; vname := "r.133" |}). + set (x_ := {| v_var := {| vtype := sword64; vname := "x.131" |}; + v_info := (fn~0)%positive |}). + set (y_ := {| v_var := {| vtype := sword64; vname := "y.132" |}; + v_info := (fn~1)%positive |}). + + unfold coerce_chtuple_to_list; simpl. + rewrite eq_rect_r_K. + simpl. + fold x y. + + unfold bind_list'. simpl. + unfold bind_list_trunc_aux. simpl. + rewrite eq_rect_K. + time repeat setoid_rewrite (@zero_extend_u U64). + unfold translate_var. simpl. fold r. From d301567f531005e124f63ac3c7af611c26171a5a Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Wed, 27 Apr 2022 17:46:41 +0200 Subject: [PATCH 175/383] prettify the add1 and bigadd examples --- theories/Jasmin/examples/add1/add1.v | 88 +++++++++++++++---- theories/Jasmin/examples/bigadd/bigadd.v | 102 ++++++++++++++++++++++- 2 files changed, 171 insertions(+), 19 deletions(-) diff --git a/theories/Jasmin/examples/add1/add1.v b/theories/Jasmin/examples/add1/add1.v index 95c8bf85..2bf8f613 100644 --- a/theories/Jasmin/examples/add1/add1.v +++ b/theories/Jasmin/examples/add1/add1.v @@ -1,24 +1,29 @@ +Set Warnings "-notation-overridden,-ambiguous-paths". +From mathcomp Require Import all_ssreflect all_algebra reals distr realsum + fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool ssrnum + eqtype choice seq. +Set Warnings "notation-overridden,ambiguous-paths". + Require Import List. From Jasmin Require Import expr. -From Jasmin Require Import x86_extra. +(* From Jasmin Require Import x86_extra. *) +From JasminSSProve Require Import jasmin_translate. +From Crypt Require Import Prelude Package. Import ListNotations. Local Open Scope string. -Definition add1 := - {| p_funcs := - [(xO xH, - {| f_info := xI xH; - f_tyin := [sword U64]; - f_params := - [{| v_var := - {| vtype := sword U64; - vname := "arg.130" |}; - v_info := - xO - (xO xH) |}]; - f_body := - [MkI +Context `{asmop : asmOp}. + +Context {T} {pT : progT T}. + +Context {pd : PointerData}. + +Context (P : uprog). + +Context (f : funname). + +Definition add1_body := [MkI (xO (xO (xO xH))) @@ -70,7 +75,22 @@ Definition add1 := (xI xH) |}; gs := Slocal |}) (Papp1 (Oword_of_int U64) - (Pconst (Zpos xH)))))]; + (Pconst (Zpos xH)))))]. + +Definition add1 := + {| p_funcs := + [(xO xH, + {| f_info := xI xH; + f_tyin := [sword U64]; + f_params := + [{| v_var := + {| vtype := sword U64; + vname := "arg.130" |}; + v_info := + xO + (xO xH) |}]; + f_body := + add1_body; f_tyout := [sword U64]; f_res := [{| v_var := @@ -82,4 +102,38 @@ Definition add1 := (xO xH)) |}]; f_extra := tt |})]; p_globs := []; p_extra := tt |} -. \ No newline at end of file +. + + +Import PackageNotation. +Notation coe_cht := coerce_to_choice_type. +Notation coe_tyc := coerce_typed_code. +Notation " 'array " := (chMap 'int ('word U8)) (at level 2) : package_scope. +Notation " 'array " := (chMap 'int ('word U8)) (in custom pack_type at level 2). +Notation " 'mem " := (chMap ('word Uptr) ('word U8)) (at level 2) : package_scope. +Notation " 'mem " := (chMap ('word Uptr) ('word U8)) (in custom pack_type at level 2). +Notation " ⸨ ws ⸩ a .[ ptr * scale ] " := (chArray_get ws a ptr scale) + (format " ⸨ ws ⸩ a .[ ptr * scale ] "). +Notation " a [ w / p ] " := + (chArray_set a AAscale p w) + (at level 99, no associativity, + format " a [ w / p ] "). + +Import GroupScope GRing.Theory. +Local Open Scope ring_scope. +From extructures Require Import fmap. + +Definition body_tr := + translate_cmd P emptym xH add1_body. +Eval cbn in body_tr. +Goal body_tr = body_tr. + unfold body_tr at 2. + unfold translate_cmd. + simpl. + unfold translate_var. simpl. + set (arg := ('word U64; nat_of_fun_ident 1%positive "arg.130")). + set (z := ('word U64; nat_of_fun_ident 1%positive "z.131")). + rewrite !coerce_to_choice_type_K. + repeat setoid_rewrite zero_extend_u. + unfold wsize_size. + unfold wrepr. simpl. unfold nat63; unfold nat31; unfold nat15; unfold nat7. diff --git a/theories/Jasmin/examples/bigadd/bigadd.v b/theories/Jasmin/examples/bigadd/bigadd.v index f1767d6a..abd6c35e 100644 --- a/theories/Jasmin/examples/bigadd/bigadd.v +++ b/theories/Jasmin/examples/bigadd/bigadd.v @@ -1,10 +1,28 @@ +Set Warnings "-notation-overridden,-ambiguous-paths". +From mathcomp Require Import all_ssreflect all_algebra reals distr realsum + fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool ssrnum + eqtype choice seq. +Set Warnings "notation-overridden,ambiguous-paths". + Require Import List. From Jasmin Require Import expr. -From Jasmin Require Import x86_extra. +(* From Jasmin Require Import x86_extra. *) +From JasminSSProve Require Import jasmin_translate. +From Crypt Require Import Prelude Package. Import ListNotations. Local Open Scope string. +Context `{asmop : asmOp}. + +Context {T} {pT : progT T}. + +Context {pd : PointerData}. + +Context (P : uprog). + +Context (f : funname). + Definition bigadd := {| p_funcs := [(xO xH, @@ -440,4 +458,84 @@ Definition bigadd := (xO xH)))) |}]; f_extra := tt |})]; p_globs := []; p_extra := tt |} -. \ No newline at end of file +. + + +Import PackageNotation. +Notation coe_cht := coerce_to_choice_type. +Notation coe_tyc := coerce_typed_code. +Notation " 'array " := (chMap 'int ('word U8)) (at level 2) : package_scope. +Notation " 'array " := (chMap 'int ('word U8)) (in custom pack_type at level 2). +Notation " 'mem " := (chMap ('word Uptr) ('word U8)) (at level 2) : package_scope. +Notation " 'mem " := (chMap ('word Uptr) ('word U8)) (in custom pack_type at level 2). +Notation " ⸨ ws ⸩ a .[ ptr * scale ] " := (chArray_get ws a ptr scale) + (format " ⸨ ws ⸩ a .[ ptr * scale ] "). +Notation " a [ w / p ] " := + (chArray_set a AAscale p w) + (at level 99, no associativity, + format " a [ w / p ] "). + + +From Equations Require Import Equations. +Set Equations With UIP. +Set Equations Transparent. + +Definition tr_bigadd := translate_prog bigadd. +Definition f_bigadd : ('array * 'array) -> raw_code 'array. +Proof. + pose tr_bigadd. unfold tr_bigadd in s. unfold translate_prog in s. + simpl in s. + destruct s eqn:E. + - unfold s in E. discriminate. + - pose (ffun p.2).π2.π2. + simpl in r. + unfold s in E. + noconf E. + (* simpl in r. *) + exact r. +Defined. + +Lemma eq_rect_K : + forall (A : eqType) (x : A) (P : A -> Type) h e, + @eq_rect A x P h x e = h. +Proof. + intros A x P' h e. + replace e with (@erefl A x) by apply eq_irrelevance. + reflexivity. +Qed. + +Eval cbn in tr_bigadd. +Goal forall aa, f_bigadd aa = f_bigadd aa. + + intros [a1 a2]. + unfold f_bigadd at 2. + unfold apply_noConfusion. + simpl. + unfold translate_write_var. simpl. + unfold translate_var. simpl. + set (TODO := ('unit; distr.dnull)). + set (array32 := sarr 32%positive). + set (fn := 2%positive). + set (x := ('array; nat_of_fun_ident fn "x.140")). + set (xr := ('word U64; nat_of_fun_ident fn "xr.143")). + set (y := ('array; nat_of_fun_ident fn "y.141")). + set (yr := ('word U64; nat_of_fun_ident fn "yr.144")). + set (x_ := {| v_var := {| vtype := array32; vname := "x.140" |}; + v_info := (fn~0)%positive |}). + set (y_ := {| v_var := {| vtype := array32; vname := "y.141" |}; + v_info := (fn~1)%positive |}). + + unfold coerce_chtuple_to_list; simpl. + rewrite eq_rect_r_K. + simpl. + fold x y. + + unfold bind_list'. simpl. + unfold bind_list_trunc_aux. simpl. + rewrite eq_rect_K. + time repeat setoid_rewrite (@zero_extend_u U64). + unfold translate_var. simpl. + set (res := ('array; nat_of_fun_ident fn "res.142")). + unfold wsize_size. + rewrite !coerce_to_choice_type_K. + (* Strangely, some instances of coe_cht don't get simplified away here. *) From 138def070881c0b87a517e16984a7b22a280f8d7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 28 Apr 2022 17:13:22 +0200 Subject: [PATCH 176/383] Define translation of for --- theories/Jasmin/jasmin_translate.v | 45 ++++++++++++++++++++++++------ 1 file changed, 36 insertions(+), 9 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 038cf030..51878c49 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1048,20 +1048,38 @@ Definition translate_write_lval (fn : funname) (l : lval) (v : typed_code) Definition instr_d (i : instr) : instr_r := match i with MkI _ i => i end. +(* Note c is translated from cmd, in the case ws = [], sem_for does not + guarantee it is well-formed. + Also note, it feels odd to get a var_i when I should translate before calling. + The problem comes from translate_write_var which expects var_i instead of + Location. +*) +Fixpoint translate_for fn (i : var_i) (ws : seq Z) (c : raw_code 'unit) : raw_code 'unit := + match ws with + | [::] => ret tt + | w :: ws => + translate_write_var fn i (totc _ (ret (translate_value w))) ;; + c ;; + translate_for fn i ws c + end. + Fixpoint translate_instr_r (prog_exports : {fmap funname -> opsig}) (fn : funname) (i : instr_r) {struct i} : raw_code 'unit with translate_instr (prog_exports : {fmap funname -> opsig}) (fn : funname) (i : instr) {struct i} : raw_code 'unit. Proof. (* translate_instr_r *) { pose proof (translate_cmd := - (fix translate_cmd (fn : funname) (c : cmd) : raw_code 'unit := - match c with - | [::] => ret tt - | i :: c => translate_instr prog_exports fn i ;; - translate_cmd fn c - end)). - - destruct i as [ | | e c1 c2 | | | ii xs f args ]. + (fix translate_cmd (fn : funname) (c : cmd) : raw_code 'unit := + match c with + | [::] => ret tt + | i :: c => + translate_instr prog_exports fn i ;; + translate_cmd fn c + end + ) + ). + + destruct i as [ | | e c1 c2 | i [[d lo] hi] c | | ii xs f args ]. - (* Cassgn *) (* l :a=_s p *) pose (translate_pexpr fn p) as tr_p. @@ -1074,7 +1092,16 @@ Proof. pose (c2' := translate_cmd fn c2). pose (rb := coerce_typed_code 'bool e'). exact (b ← rb ;; if b then c1' else c2'). - - exact (unsupported.π2). (* Cfor *) + - (* Cfor i (d, lo, hi) c *) + (* pose (iᵗ := translate_var fn i). *) (* Weird not to do it *) + pose (loᵗ := coerce_typed_code 'int (translate_pexpr fn lo)). + pose (hiᵗ := coerce_typed_code 'int (translate_pexpr fn hi)). + pose (cᵗ := translate_cmd fn c). + exact ( + vlo ← loᵗ ;; + vhi ← hiᵗ ;; + translate_for fn i (wrange d vlo vhi) cᵗ + ). - exact (unsupported.π2). (* Cwhile *) - (* Ccall ii xs f args *) (* Translate arguments. *) From c6aa2cd91d6b81b0b571919b472f0c30debed2f0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 28 Apr 2022 17:14:01 +0200 Subject: [PATCH 177/383] Silence warning --- theories/Jasmin/jasmin_translate.v | 2 ++ 1 file changed, 2 insertions(+) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 51878c49..3ce2f022 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -7,7 +7,9 @@ From extructures Require Import ord fset fmap. From Jasmin Require Import expr_facts. From Coq Require Import Utf8. +Set Warnings "-ambiguous-paths,-notation-overridden,-notation-incompatible-format". From CoqWord Require Import ssrZ. +Set Warnings "ambiguous-paths,notation-overridden,notation-incompatible-format". From Crypt Require Import Prelude Package. Import PackageNotation. From 49599b94eb5875b085554b82e27e8ee9e4052e10 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 28 Apr 2022 17:53:33 +0200 Subject: [PATCH 178/383] Start massaging the for proof --- theories/Jasmin/jasmin_translate.v | 46 ++++++++++++++++++++++++++---- 1 file changed, 41 insertions(+), 5 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 3ce2f022..eaa5883a 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1159,12 +1159,19 @@ Proof. } Defined. -Fixpoint translate_cmd (prog_exports : {fmap funname -> opsig}) (fn : funname) (c : cmd) : raw_code 'unit := +(* Trick to have it expand to the same as the translate_cmd above *) +Section TranslateCMD. + +Context (prog_exports : {fmap funname -> opsig}). + +Fixpoint translate_cmd (fn : funname) (c : cmd) : raw_code 'unit := match c with | [::] => ret tt - | i :: c => translate_instr prog_exports fn i ;; translate_cmd prog_exports fn c + | i :: c => translate_instr prog_exports fn i ;; translate_cmd fn c end. +End TranslateCMD. + Record fdef := { ffun : typed_raw_function ; locs : {fset Location} ; @@ -2508,10 +2515,39 @@ Proof. - red. intros. red. eapply translate_instr_r_correct. econstructor ; eassumption. (* backtrack *) - - red. intros. - red. eapply translate_instr_r_correct. - econstructor. all: eassumption. + - red. intros s1 s2 i d lo hi c vlo vhi hlo hhi hfor ihfor. + red. simpl. + lazymatch goal with + | |- context [ translate_for _ _ _ (?f ?fn ?c) ] => + change (f fn c) with (translate_cmd ep fn c) + end. + eapply u_bind. + 1:{ + (* Make a lemma for all this stuff? *) + eapply translate_pexpr_correct with (fn := fn) in hlo as h. 2: eauto. + simpl in h. + eapply translate_pexpr_type with (fn := fn) in hlo. + unfold choice_type_of_val in hlo. simpl in hlo. + destruct (translate_pexpr) as [? exp] eqn:e. simpl in *. subst. + rewrite coerce_to_choice_type_K in h. + rewrite coerce_typed_code_K. eassumption. + } + eapply u_bind. + 1:{ + (* Make a lemma for all this stuff? *) + eapply translate_pexpr_correct with (fn := fn) in hhi as h. 2: eauto. + simpl in h. + eapply translate_pexpr_type with (fn := fn) in hhi. + unfold choice_type_of_val in hhi. simpl in hhi. + destruct (translate_pexpr) as [? exp] eqn:e. simpl in *. subst. + rewrite coerce_to_choice_type_K in h. + rewrite coerce_typed_code_K. eassumption. + } + red in ihfor. + (* apply ihfor. *) + admit. - red. intros. red. + (* Pfor is wrong indeed *) admit. - red. intros. red. From 465d2abf92dccfa431c39a609beeed3876079dad Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 28 Apr 2022 18:00:33 +0200 Subject: [PATCH 179/383] Big chunk of the for proof --- theories/Jasmin/jasmin_translate.v | 21 ++++++++++----------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index eaa5883a..36ee5f32 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -2475,11 +2475,10 @@ Proof. λ (s1 : estate) (c : cmd) (s2 : estate), ⊢ ⦃ rel_estate s1 fn ⦄ translate_cmd ep fn c ⇓ tt ⦃ rel_estate s2 fn ⦄ ). - (* FIXME *) set (Pfor := - λ (v : var_i) (ls : seq Z) (s1 : estate) (c : cmd) (s2 : estate), + λ (v : var_i) (ws : seq Z) (s1 : estate) (c : cmd) (s2 : estate), ⊢ ⦃ rel_estate s1 fn ⦄ - (* ssprove_for *) translate_cmd ep fn c ⇓ tt + translate_for fn v ws (translate_cmd ep fn c) ⇓ tt ⦃ rel_estate s2 fn ⦄ ). unshelve eapply (@sem_call_Ind _ _ _ _ Pc Pi_r Pi Pfor Pfun _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H). @@ -2543,15 +2542,15 @@ Proof. rewrite coerce_to_choice_type_K in h. rewrite coerce_typed_code_K. eassumption. } - red in ihfor. - (* apply ihfor. *) - admit. + apply ihfor. - red. intros. red. - (* Pfor is wrong indeed *) - admit. - - red. intros. - red. - admit. + simpl. apply u_ret_eq. auto. + - red. intros s1 s1' s2 s3 i w ws c hw hc ihc hfor ihfor. + red. simpl. + eapply u_put. + eapply u_bind. + 1:{ red in ihc. (* Use write_var info, don't remember why no lemma *) admit. } + apply ihfor. - red. intros. red. eapply translate_instr_r_correct. econstructor. all: eassumption. From f1a261c1cbb6db1d5cadf1a26dbff1ec3357a4d0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Fri, 29 Apr 2022 09:04:57 +0200 Subject: [PATCH 180/383] Complete for proof --- theories/Jasmin/jasmin_translate.v | 51 ++++++++++++++++++++++++++++-- 1 file changed, 48 insertions(+), 3 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 36ee5f32..ebf1353b 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -127,7 +127,7 @@ Proof. Qed. (* Unary rpre_weaken_rule *) -Lemma upre_weaken_rule : +Lemma u_pre_weaken_rule : ∀ A (r : raw_code A) v (p1 p2 : heap → Prop) q, ⊢ ⦃ p1 ⦄ r ⇓ v ⦃ q ⦄ → (∀ h, p2 h → p1 h) → @@ -140,7 +140,7 @@ Proof. Qed. (* Unary rpost_weaken_rule *) -Lemma upost_weaken_rule : +Lemma u_post_weaken_rule : ∀ A (r : raw_code A) v p (q1 q2 : heap → Prop), ⊢ ⦃ p ⦄ r ⇓ v ⦃ q1 ⦄ → (∀ h, q1 h → q2 h) → @@ -2549,7 +2549,52 @@ Proof. red. simpl. eapply u_put. eapply u_bind. - 1:{ red in ihc. (* Use write_var info, don't remember why no lemma *) admit. } + 1:{ + red in ihc. eapply u_pre_weaken_rule. + 1: eapply ihc. + intros ? [me [hme ?]]. subst. + (* TODO translate_write_var_estate like translate_write_estate? *) + unfold write_var in hw. jbind hw vm hvm. noconf hw. + destruct hme as [h1 h2]. split. all: simpl. + - intros ptr v er. + eapply h1 in er. + rewrite get_set_heap_neq. 2: apply mem_loc_translate_var_neq. + assumption. + - intros vi v ev. + eapply set_varP. 3: exact hvm. + + intros v₁ hv₁ eyl. subst. + destruct (vi == i) eqn:evar. + all: move: evar => /eqP evar. + * subst. rewrite Fv.setP_eq in ev. noconf ev. + rewrite get_set_heap_eq. rewrite coerce_to_choice_type_K. + eapply translate_of_val in hv₁ as e. + rewrite e. apply coerce_to_choice_type_translate_value_to_val. + * rewrite Fv.setP_neq in ev. + 2:{ apply /eqP. eauto. } + rewrite get_set_heap_neq. + 2:{ + apply /eqP. intro ee. + apply injective_translate_var in ee. + contradiction. + } + eapply h2 in ev. assumption. + + intros hbo hyl hset. subst. + destruct (vi == i) eqn:evar. + all: move: evar => /eqP evar. + 1:{ + exfalso. subst. rewrite Fv.setP_eq in ev. + clear - ev hbo. destruct (vtype i). all: discriminate. + } + rewrite Fv.setP_neq in ev. + 2:{ apply /eqP. eauto. } + rewrite get_set_heap_neq. + 2:{ + apply /eqP. intro ee. + apply injective_translate_var in ee. + contradiction. + } + eapply h2 in ev. assumption. + } apply ihfor. - red. intros. red. eapply translate_instr_r_correct. From 13f3315c13296a4b498bb6d88f3b42f4b7a53227 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Fri, 29 Apr 2022 11:48:58 +0200 Subject: [PATCH 181/383] sem_Ind_cons case of translate_prog_correct --- theories/Jasmin/jasmin_translate.v | 17 ++++++++++++++--- 1 file changed, 14 insertions(+), 3 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index ebf1353b..c0512b31 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1159,6 +1159,15 @@ Proof. } Defined. +(* translate_instr is blocked because it is a fixpoint *) +Lemma translate_instr_unfold : + ∀ ep fn i, + translate_instr ep fn i = translate_instr_r ep fn (instr_d i). +Proof. + intros ep fn i. + destruct i. reflexivity. +Qed. + (* Trick to have it expand to the same as the translate_cmd above *) Section TranslateCMD. @@ -2482,13 +2491,15 @@ Proof. ⦃ rel_estate s2 fn ⦄ ). unshelve eapply (@sem_call_Ind _ _ _ _ Pc Pi_r Pi Pfor Pfun _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H). - - red. intros s. + - (* nil *) + red. intros s. red. simpl. eapply u_ret_eq. auto. - - red. intros. + - (* cons *) + red. intros s1 s2 s3 i c hi ihi hc ihc. red. simpl. eapply u_bind. - + (* eapply translate_instr_correct. *) admit. + + rewrite translate_instr_unfold. eapply ihi. + eassumption. - red. intros. apply H1. From 840c2e9a1e66ed423347efed054f9edf13c3244d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Fri, 29 Apr 2022 13:45:37 +0200 Subject: [PATCH 182/383] Remove translate_instr_r_correct and inline it + proof for if --- theories/Jasmin/jasmin_translate.v | 480 +++++++++++++++-------------- 1 file changed, 255 insertions(+), 225 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index c0512b31..4f5f3569 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -2226,198 +2226,181 @@ Proof. eapply translate_write_estate. all: assumption. Qed. -(* TODO Make fixpoint too! -Another option is to inline it all in translate_prog_correct -which given the goals is probably the way things are intended. -*) -Lemma translate_instr_r_correct : - ∀ (prog_exports : {fmap funname -> opsig}) (fn : funname) (i : instr_r) (s₁ s₂ : estate), - sem_i P s₁ i s₂ → - ⊢ ⦃ rel_estate s₁ fn ⦄ - translate_instr_r prog_exports fn i ⇓ tt - ⦃ rel_estate s₂ fn ⦄. -Proof. - intros prog_exports fn i s₁ s₂ h. - induction h as [es₁ es₂ y tag sty e v v' sem_e trunc hw | | | | | | |]. - - simpl. destruct y as [ | yl | | aa ws x ei | ] eqn:case_lval. - + simpl. apply u_ret_eq. intros hp hr. - simpl in hw. unfold write_none in hw. - destruct is_sbool eqn:eb. - * unfold on_vu in hw. destruct of_val as [| []]. - all: noconf hw. all: assumption. - * unfold on_vu in hw. destruct of_val as [| []]. - all: noconf hw. assumption. - + simpl. unfold translate_write_var. simpl in hw. unfold write_var in hw. - jbind hw vm eset. noconf hw. - simpl. rewrite !bind_assoc. simpl. - eapply u_bind. - * eapply translate_pexpr_correct. all: eauto. +Lemma translate_write_lval_correct : + ∀ es₁ es₂ fn y sty e v v', + sem_pexpr gd es₁ e = ok v → + truncate_val sty v = ok v' → + write_lval gd y v' es₁ = ok es₂ → + ⊢ ⦃ rel_estate es₁ fn ⦄ + translate_write_lval fn y (truncate_code sty (translate_pexpr fn e)) + ⇓ tt + ⦃ rel_estate es₂ fn ⦄. +Proof. + intros es₁ es₂ fn y sty e v v' sem_e trunc hw. + destruct y as [ | yl | | aa ws x ei | ] eqn:case_lval. + - simpl. apply u_ret_eq. + intros hp hr. + simpl in hw. unfold write_none in hw. + destruct is_sbool eqn:eb. + + unfold on_vu in hw. destruct of_val as [| []]. + all: noconf hw. all: assumption. + + unfold on_vu in hw. destruct of_val as [| []]. + all: noconf hw. assumption. + - simpl. unfold translate_write_var. simpl in hw. unfold write_var in hw. + jbind hw vm eset. noconf hw. + simpl. rewrite !bind_assoc. simpl. + eapply u_bind. + 1:{ eapply translate_pexpr_correct. all: eauto. } + erewrite translate_pexpr_type. 2: eassumption. + clear sem_e e. + eapply u_put. + apply u_ret_eq. + intros m' [m [hm e]]. subst. + destruct hm as [hm hv]. + split. + + unfold rel_mem. + intros ptr byte hr. + rewrite get_set_heap_neq. 2: apply mem_loc_translate_var_neq. + apply hm. assumption. + + simpl. unfold rel_vmap. + intros i vi ei. + simpl. rewrite !coerce_to_choice_type_K. + eapply set_varP. 3: exact eset. * { - erewrite translate_pexpr_type. 2: eassumption. - clear sem_e tag e. - eapply u_put. - apply u_ret_eq. - intros m' [m [hm e]]. subst. - destruct hm as [hm hv]. - split. - - unfold rel_mem. - intros ptr byte hr. - rewrite get_set_heap_neq. 2: apply mem_loc_translate_var_neq. - apply hm. assumption. - - simpl. unfold rel_vmap. - intros i vi ei. - simpl. rewrite !coerce_to_choice_type_K. - eapply set_varP. 3: exact eset. (* all: clear eset. *) - + intros v₁ hv₁ eyl. subst. - destruct (i == yl) eqn:evar. - all: move: evar => /eqP evar. - * subst. - rewrite Fv.setP_eq in ei. noconf ei. - rewrite get_set_heap_eq. - apply truncate_val_type in trunc as ety. subst. - eapply translate_truncate_val in trunc. - eapply translate_of_val in hv₁. - rewrite trunc. rewrite coerce_to_choice_type_K. - rewrite hv₁. apply coerce_to_choice_type_translate_value_to_val. - * rewrite Fv.setP_neq in ei. - 2:{ apply /eqP. eauto. } - rewrite get_set_heap_neq. - 2:{ - apply /eqP. intro e. - apply injective_translate_var in e. - contradiction. - } - eapply hv in ei. rewrite ei. - rewrite coerce_to_choice_type_K. reflexivity. - + intros hbo hyl hset. - subst. - destruct (i == yl) eqn:evar. - all: move: evar => /eqP evar. - * exfalso. subst. rewrite Fv.setP_eq in ei. - clear - ei hbo. destruct (vtype yl). all: discriminate. - * rewrite Fv.setP_neq in ei. - 2:{ apply /eqP. eauto. } - rewrite get_set_heap_neq. - 2:{ - apply /eqP. intro e. - apply injective_translate_var in e. - contradiction. - } - eapply hv in ei. rewrite ei. - rewrite coerce_to_choice_type_K. reflexivity. - } - + simpl. simpl in hw. - jbind hw vx hvx. jbind hvx vx' hvx'. jbind hw ve hve. - jbind hve ve' hve'. jbind hw w hw'. jbind hw m hm. - noconf hw. - eapply u_get_remember. intros tv. - eapply u_bind. - 1:{ - eapply translate_pexpr_correct. - - eassumption. - - intros ? []. assumption. - } - rewrite bind_assoc. - eapply u_bind. - 1:{ - eapply translate_pexpr_correct. - - eassumption. - - intros ? []. assumption. - } - simpl. - eapply translate_write_correct. intros m' [hm' em']. - unfold u_get in em'. subst. - split. 2: assumption. - erewrite translate_pexpr_type. 2: eassumption. - erewrite translate_pexpr_type. 2: eassumption. - rewrite !coerce_to_choice_type_K. - erewrite translate_truncate_val. 2: eassumption. - eapply truncate_val_type in trunc as ety. subst. - rewrite coerce_to_choice_type_K. - eapply translate_to_word in hw' as ew. rewrite ew. clear ew. - unfold translate_to_pointer. simpl. - eapply translate_to_word in hve as ew. rewrite ew. clear ew. - erewrite get_var_get_heap. 2,3: eassumption. - simpl. erewrite <- type_of_get_var. 2: eassumption. - rewrite coerce_to_choice_type_K. - eapply translate_to_word in hvx as ew. rewrite ew. clear ew. - assumption. - + simpl. simpl in hw. - jbind hw nt hnt. destruct nt. all: try discriminate. - jbind hw i hi. jbind hi i' hi'. - jbind hw w ew. jbind hw t ht. - unfold write_var in hw. jbind hw vm hvm. - noconf hw. - eapply u_get_remember. simpl. intros vx. - rewrite !bind_assoc. simpl. - eapply u_bind. - 1:{ - eapply translate_pexpr_correct. - - eassumption. - - intros ? []. assumption. - } - rewrite !bind_assoc. - eapply u_bind. - 1:{ - eapply translate_pexpr_correct. - - eassumption. - - intros ? []. assumption. + intros v₁ hv₁ eyl. subst. + destruct (i == yl) eqn:evar. + all: move: evar => /eqP evar. + - subst. + rewrite Fv.setP_eq in ei. noconf ei. + rewrite get_set_heap_eq. + apply truncate_val_type in trunc as ety. subst. + eapply translate_truncate_val in trunc. + eapply translate_of_val in hv₁. + rewrite trunc. rewrite coerce_to_choice_type_K. + rewrite hv₁. apply coerce_to_choice_type_translate_value_to_val. + - rewrite Fv.setP_neq in ei. + 2:{ apply /eqP. eauto. } + rewrite get_set_heap_neq. + 2:{ + apply /eqP. intro e. + apply injective_translate_var in e. + contradiction. + } + eapply hv in ei. rewrite ei. + rewrite coerce_to_choice_type_K. reflexivity. } - simpl. unfold translate_write_var. simpl. - eapply u_put. - eapply u_ret_eq. - intros ? [m [[[hr hv] hm] ?]]. subst. - unfold u_get in hm. subst. - split. - * intros ptr byte hby. - rewrite get_set_heap_neq. 2: eapply mem_loc_translate_var_neq. - apply hr. assumption. * { - simpl. intros j vj ej. - simpl. rewrite coerce_to_choice_type_K. - eapply set_varP. 3: exact hvm. - - intros v₁ hv₁ eyl. subst. - destruct (j == x) eqn:evar. - all: move: evar => /eqP evar. - + subst. rewrite Fv.setP_eq in ej. noconf ej. - rewrite get_set_heap_eq. - apply truncate_val_type in trunc as ety. subst. - erewrite translate_pexpr_type. 2: eassumption. - erewrite translate_pexpr_type. 2: eassumption. - rewrite !coerce_to_choice_type_K. - eapply translate_truncate_val in trunc. - rewrite trunc. rewrite coerce_to_choice_type_K. - eapply translate_to_word in ew. rewrite ew. - erewrite translate_to_int. 2: eassumption. - erewrite get_var_get_heap. - 2: eassumption. - 2:{ split. all: assumption. } - eapply translate_of_val in hv₁. (* simpl in hv₁. *) - rewrite coerce_to_choice_type_translate_value_to_val in hv₁. - rewrite <- hv₁. f_equal. - Opaque translate_value. simpl. Transparent translate_value. - eapply type_of_get_var in hnt as ety. simpl in ety. - rewrite -ety. rewrite !coerce_to_choice_type_K. - apply chArray_set_correct. assumption. - + rewrite Fv.setP_neq in ej. - 2:{ apply /eqP. eauto. } - rewrite get_set_heap_neq. - 2:{ - apply /eqP. intro ee. - apply injective_translate_var in ee. - contradiction. - } - eapply hv in ej. rewrite ej. - rewrite coerce_to_choice_type_K. reflexivity. - - intros hbo hyl hset. - subst. - destruct (j == x) eqn:evar. - all: move: evar => /eqP evar. - 1:{ - exfalso. subst. rewrite Fv.setP_eq in ej. - clear - ej hbo. destruct (vtype x). all: discriminate. + intros hbo hyl hset. + subst. + destruct (i == yl) eqn:evar. + all: move: evar => /eqP evar. + - exfalso. subst. rewrite Fv.setP_eq in ei. + clear - ei hbo. destruct (vtype yl). all: discriminate. + - rewrite Fv.setP_neq in ei. + 2:{ apply /eqP. eauto. } + rewrite get_set_heap_neq. + 2:{ + apply /eqP. intro e. + apply injective_translate_var in e. + contradiction. } - rewrite Fv.setP_neq in ej. + eapply hv in ei. rewrite ei. + rewrite coerce_to_choice_type_K. reflexivity. + } + - simpl. simpl in hw. + jbind hw vx hvx. jbind hvx vx' hvx'. jbind hw ve hve. + jbind hve ve' hve'. jbind hw w hw'. jbind hw m hm. + noconf hw. + eapply u_get_remember. intros tv. + eapply u_bind. + 1:{ + eapply translate_pexpr_correct. + - eassumption. + - intros ? []. assumption. + } + rewrite bind_assoc. + eapply u_bind. + 1:{ + eapply translate_pexpr_correct. + - eassumption. + - intros ? []. assumption. + } + simpl. + eapply translate_write_correct. intros m' [hm' em']. + unfold u_get in em'. subst. + split. 2: assumption. + erewrite translate_pexpr_type. 2: eassumption. + erewrite translate_pexpr_type. 2: eassumption. + rewrite !coerce_to_choice_type_K. + erewrite translate_truncate_val. 2: eassumption. + eapply truncate_val_type in trunc as ety. subst. + rewrite coerce_to_choice_type_K. + eapply translate_to_word in hw' as ew. rewrite ew. clear ew. + unfold translate_to_pointer. simpl. + eapply translate_to_word in hve as ew. rewrite ew. clear ew. + erewrite get_var_get_heap. 2,3: eassumption. + simpl. erewrite <- type_of_get_var. 2: eassumption. + rewrite coerce_to_choice_type_K. + eapply translate_to_word in hvx as ew. rewrite ew. clear ew. + assumption. + - simpl. simpl in hw. + jbind hw nt hnt. destruct nt. all: try discriminate. + jbind hw i hi. jbind hi i' hi'. + jbind hw w ew. jbind hw t ht. + unfold write_var in hw. jbind hw vm hvm. + noconf hw. + eapply u_get_remember. simpl. intros vx. + rewrite !bind_assoc. simpl. + eapply u_bind. + 1:{ + eapply translate_pexpr_correct. + - eassumption. + - intros ? []. assumption. + } + rewrite !bind_assoc. + eapply u_bind. + 1:{ + eapply translate_pexpr_correct. + - eassumption. + - intros ? []. assumption. + } + simpl. unfold translate_write_var. simpl. + eapply u_put. + eapply u_ret_eq. + intros ? [m [[[hr hv] hm] ?]]. subst. + unfold u_get in hm. subst. + split. + + intros ptr byte hby. + rewrite get_set_heap_neq. 2: eapply mem_loc_translate_var_neq. + apply hr. assumption. + + simpl. intros j vj ej. + simpl. rewrite coerce_to_choice_type_K. + eapply set_varP. 3: exact hvm. + * { + intros v₁ hv₁ eyl. subst. + destruct (j == x) eqn:evar. + all: move: evar => /eqP evar. + - subst. rewrite Fv.setP_eq in ej. noconf ej. + rewrite get_set_heap_eq. + apply truncate_val_type in trunc as ety. subst. + erewrite translate_pexpr_type. 2: eassumption. + erewrite translate_pexpr_type. 2: eassumption. + rewrite !coerce_to_choice_type_K. + eapply translate_truncate_val in trunc. + rewrite trunc. rewrite coerce_to_choice_type_K. + eapply translate_to_word in ew. rewrite ew. + erewrite translate_to_int. 2: eassumption. + erewrite get_var_get_heap. + 2: eassumption. + 2:{ split. all: assumption. } + eapply translate_of_val in hv₁. (* simpl in hv₁. *) + rewrite coerce_to_choice_type_translate_value_to_val in hv₁. + rewrite <- hv₁. f_equal. + Opaque translate_value. simpl. Transparent translate_value. + eapply type_of_get_var in hnt as ety. simpl in ety. + rewrite -ety. rewrite !coerce_to_choice_type_K. + apply chArray_set_correct. assumption. + - rewrite Fv.setP_neq in ej. 2:{ apply /eqP. eauto. } rewrite get_set_heap_neq. 2:{ @@ -2428,13 +2411,24 @@ Proof. eapply hv in ej. rewrite ej. rewrite coerce_to_choice_type_K. reflexivity. } - + admit. - - admit. - - admit. - - admit. - - admit. - - admit. - - admit. + * intros hbo hyl hset. + subst. + destruct (j == x) eqn:evar. + all: move: evar => /eqP evar. + 1:{ + exfalso. subst. rewrite Fv.setP_eq in ej. + clear - ej hbo. destruct (vtype x). all: discriminate. + } + rewrite Fv.setP_neq in ej. + 2:{ apply /eqP. eauto. } + rewrite get_set_heap_neq. + 2:{ + apply /eqP. intro ee. + apply injective_translate_var in ee. + contradiction. + } + eapply hv in ej. rewrite ej. + rewrite coerce_to_choice_type_K. reflexivity. - admit. Admitted. @@ -2501,31 +2495,65 @@ Proof. eapply u_bind. + rewrite translate_instr_unfold. eapply ihi. + eassumption. - - red. intros. - apply H1. - - red. intros s₁ s₂ x tag ty e v v' he hv hw. - red. - eapply translate_instr_r_correct. - (* Do we have to apply this lemma for each instance, seems wrong *) - econstructor. all: eassumption. - - red. intros. - red. eapply translate_instr_r_correct. - econstructor. assumption. - - red. intros. - red. eapply translate_instr_r_correct. - econstructor. - all: assumption. - - red. intros. - red. eapply translate_instr_r_correct. - econstructor ; assumption. (* backtrack to select the right constructor *) - - red. intros. - red. eapply translate_instr_r_correct. - econstructor. - all: eassumption. - - red. intros. - red. eapply translate_instr_r_correct. - econstructor ; eassumption. (* backtrack *) - - red. intros s1 s2 i d lo hi c vlo vhi hlo hhi hfor ihfor. + - (* mkI *) + red. intros ii i s1 s2 hi ihi. + apply ihi. + - (* assgn *) + red. intros s₁ s₂ x tag ty e v v' he hv hw. + red. simpl. eapply translate_write_lval_correct. all: eauto. + - (* opn *) + red. intros s1 s2 tag o xs es ho. + red. simpl. admit. + - (* if_true *) + red. intros s1 s2 e c1 c2 he hc1 ihc1. + red. simpl. + lazymatch goal with + | |- context [ if _ then ?f ?fn ?c else _ ] => + change (f fn c) with (translate_cmd ep fn c) + end. + eapply u_bind. + 1:{ + (* Make a lemma for all this stuff? *) + eapply translate_pexpr_correct with (fn := fn) in he as h. 2: eauto. + simpl in h. + eapply translate_pexpr_type with (fn := fn) in he. + unfold choice_type_of_val in he. simpl in he. + destruct (translate_pexpr) as [? exp] eqn:?. simpl in *. subst. + rewrite coerce_to_choice_type_K in h. + rewrite coerce_typed_code_K. eassumption. + } + simpl. eapply ihc1. + - (* if_false *) + red. intros s1 s2 e c1 c2 he hc2 ihc2. + red. simpl. + (* lazymatch goal with + | |- context [ if _ then _ else (?f ?fn ?c) ] => + change (f fn c) with (translate_cmd ep fn c) + end. *) + eapply u_bind. + 1:{ + (* Make a lemma for all this stuff? *) + eapply translate_pexpr_correct with (fn := fn) in he as h. 2: eauto. + simpl in h. + eapply translate_pexpr_type with (fn := fn) in he. + unfold choice_type_of_val in he. simpl in he. + destruct (translate_pexpr) as [? exp] eqn:?. simpl in *. subst. + rewrite coerce_to_choice_type_K in h. + rewrite coerce_typed_code_K. eassumption. + } + simpl. eapply ihc2. + - (* while_true *) + red. intros s1 s2 s3 s4 a c e c' hc ihc he hc' ihc' h ih. + red in ih. simpl in ih. + (* TODO Lemma to draw a contradiction from ih *) + admit. + - (* while_false *) + red. intros s1 s2 a c e c' hc ihc he. + red. simpl. + (* We could replace while by an if to solve this case *) + give_up. + - (* for *) + red. intros s1 s2 i d lo hi c vlo vhi hlo hhi hfor ihfor. red. simpl. lazymatch goal with | |- context [ translate_for _ _ _ (?f ?fn ?c) ] => @@ -2554,9 +2582,11 @@ Proof. rewrite coerce_typed_code_K. eassumption. } apply ihfor. - - red. intros. red. + - (* for_nil *) + red. intros. red. simpl. apply u_ret_eq. auto. - - red. intros s1 s1' s2 s3 i w ws c hw hc ihc hfor ihfor. + - (* for_cons *) + red. intros s1 s1' s2 s3 i w ws c hw hc ihc hfor ihfor. red. simpl. eapply u_put. eapply u_bind. @@ -2607,9 +2637,9 @@ Proof. eapply h2 in ev. assumption. } apply ihfor. - - red. intros. - red. eapply translate_instr_r_correct. - econstructor. all: eassumption. + - (* call *) + red. intros s1 m2 s2 ii xs gn args vargs vs hargs hvs ihvs hw. + red. simpl. admit. - red. intros m1 m2 gn g vs vs' s1 vm2 vrs vrs'. intros hg hvs ?????. unfold Pfun. intros f' hf'. From 5b30298d058425a895e9612bf3ddd53f0cad4c36 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Fri, 29 Apr 2022 15:16:44 +0200 Subject: [PATCH 183/383] Factorise proofs into translate_pexpr_correct_cast --- theories/Jasmin/jasmin_translate.v | 62 +++++++++++------------------- 1 file changed, 22 insertions(+), 40 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 4f5f3569..0620d836 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -2191,6 +2191,24 @@ Proof. apply translate_truncate_val. assumption. Qed. +Corollary translate_pexpr_correct_cast : + ∀ fn (e : pexpr) s₁ v (cond : heap → Prop), + sem_pexpr gd s₁ e = ok v → + (∀ m, cond m → rel_estate s₁ fn m) → + ⊢ ⦃ cond ⦄ + coerce_typed_code _ (translate_pexpr fn e) ⇓ + translate_value v + ⦃ cond ⦄. +Proof. + intros fn e s v cond he hcond. + eapply translate_pexpr_correct with (fn := fn) in he as h. 2: exact hcond. + eapply translate_pexpr_type with (fn := fn) in he. + unfold choice_type_of_val in he. + destruct (translate_pexpr) as [? exp] eqn:?. simpl in *. subst. + rewrite coerce_to_choice_type_K in h. + rewrite coerce_typed_code_K. assumption. +Qed. + Lemma ptr_var_neq (ptr : pointer) (fn : funname) (v : var) : translate_ptr ptr != translate_var fn v. Proof. @@ -2512,16 +2530,7 @@ Proof. change (f fn c) with (translate_cmd ep fn c) end. eapply u_bind. - 1:{ - (* Make a lemma for all this stuff? *) - eapply translate_pexpr_correct with (fn := fn) in he as h. 2: eauto. - simpl in h. - eapply translate_pexpr_type with (fn := fn) in he. - unfold choice_type_of_val in he. simpl in he. - destruct (translate_pexpr) as [? exp] eqn:?. simpl in *. subst. - rewrite coerce_to_choice_type_K in h. - rewrite coerce_typed_code_K. eassumption. - } + 1:{ eapply translate_pexpr_correct_cast in he. all: eauto. } simpl. eapply ihc1. - (* if_false *) red. intros s1 s2 e c1 c2 he hc2 ihc2. @@ -2531,16 +2540,7 @@ Proof. change (f fn c) with (translate_cmd ep fn c) end. *) eapply u_bind. - 1:{ - (* Make a lemma for all this stuff? *) - eapply translate_pexpr_correct with (fn := fn) in he as h. 2: eauto. - simpl in h. - eapply translate_pexpr_type with (fn := fn) in he. - unfold choice_type_of_val in he. simpl in he. - destruct (translate_pexpr) as [? exp] eqn:?. simpl in *. subst. - rewrite coerce_to_choice_type_K in h. - rewrite coerce_typed_code_K. eassumption. - } + 1:{ eapply translate_pexpr_correct_cast in he. all: eauto. } simpl. eapply ihc2. - (* while_true *) red. intros s1 s2 s3 s4 a c e c' hc ihc he hc' ihc' h ih. @@ -2560,27 +2560,9 @@ Proof. change (f fn c) with (translate_cmd ep fn c) end. eapply u_bind. - 1:{ - (* Make a lemma for all this stuff? *) - eapply translate_pexpr_correct with (fn := fn) in hlo as h. 2: eauto. - simpl in h. - eapply translate_pexpr_type with (fn := fn) in hlo. - unfold choice_type_of_val in hlo. simpl in hlo. - destruct (translate_pexpr) as [? exp] eqn:e. simpl in *. subst. - rewrite coerce_to_choice_type_K in h. - rewrite coerce_typed_code_K. eassumption. - } + 1:{ eapply translate_pexpr_correct_cast in hlo. all: eauto. } eapply u_bind. - 1:{ - (* Make a lemma for all this stuff? *) - eapply translate_pexpr_correct with (fn := fn) in hhi as h. 2: eauto. - simpl in h. - eapply translate_pexpr_type with (fn := fn) in hhi. - unfold choice_type_of_val in hhi. simpl in hhi. - destruct (translate_pexpr) as [? exp] eqn:e. simpl in *. subst. - rewrite coerce_to_choice_type_K in h. - rewrite coerce_typed_code_K. eassumption. - } + 1:{ eapply translate_pexpr_correct_cast in hhi. all: eauto. } apply ihfor. - (* for_nil *) red. intros. red. From 720dc2f0fbf445beb58fea5f56a4b35b30818b3d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Fri, 29 Apr 2022 15:27:35 +0200 Subject: [PATCH 184/383] Prove translate_write_var_estate --- theories/Jasmin/jasmin_translate.v | 92 +++++++++++++++++------------- 1 file changed, 51 insertions(+), 41 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 0620d836..1d3fa03e 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -2274,6 +2274,7 @@ Proof. eapply u_put. apply u_ret_eq. intros m' [m [hm e]]. subst. + (* TODO Apply translate_write_var_estate instead of unfolding write_var *) destruct hm as [hm hv]. split. + unfold rel_mem. @@ -2450,6 +2451,55 @@ Proof. - admit. Admitted. +Lemma translate_write_var_estate : + ∀ fn i v s1 s2 m, + write_var i v s1 = ok s2 → + rel_estate s1 fn m → + rel_estate s2 fn (set_heap m (translate_var fn i) (truncate_el i.(vtype) (translate_value v))). +Proof. + intros fn i v s1 s2 m hw [h1 h2]. + unfold write_var in hw. jbind hw vm hvm. noconf hw. + split. all: simpl. + - intros ptr v' er. + eapply h1 in er. + rewrite get_set_heap_neq. 2: apply mem_loc_translate_var_neq. + assumption. + - intros vi v' ev. + eapply set_varP. 3: exact hvm. + + intros v₁ hv₁ eyl. subst. + destruct (vi == i) eqn:evar. + all: move: evar => /eqP evar. + * subst. rewrite Fv.setP_eq in ev. noconf ev. + rewrite get_set_heap_eq. rewrite coerce_to_choice_type_K. + eapply translate_of_val in hv₁ as e. + rewrite e. apply coerce_to_choice_type_translate_value_to_val. + * rewrite Fv.setP_neq in ev. + 2:{ apply /eqP. eauto. } + rewrite get_set_heap_neq. + 2:{ + apply /eqP. intro ee. + apply injective_translate_var in ee. + contradiction. + } + eapply h2 in ev. assumption. + + intros hbo hyl hset. subst. + destruct (vi == i) eqn:evar. + all: move: evar => /eqP evar. + 1:{ + exfalso. subst. rewrite Fv.setP_eq in ev. + clear - ev hbo. destruct (vtype i). all: discriminate. + } + rewrite Fv.setP_neq in ev. + 2:{ apply /eqP. eauto. } + rewrite get_set_heap_neq. + 2:{ + apply /eqP. intro ee. + apply injective_translate_var in ee. + contradiction. + } + eapply h2 in ev. assumption. +Qed. + Definition ssprove_prog := seq (funname * fdef). Definition exports_of_prog (p : ssprove_prog) : {fmap funname -> opsig} := @@ -2576,47 +2626,7 @@ Proof. red in ihc. eapply u_pre_weaken_rule. 1: eapply ihc. intros ? [me [hme ?]]. subst. - (* TODO translate_write_var_estate like translate_write_estate? *) - unfold write_var in hw. jbind hw vm hvm. noconf hw. - destruct hme as [h1 h2]. split. all: simpl. - - intros ptr v er. - eapply h1 in er. - rewrite get_set_heap_neq. 2: apply mem_loc_translate_var_neq. - assumption. - - intros vi v ev. - eapply set_varP. 3: exact hvm. - + intros v₁ hv₁ eyl. subst. - destruct (vi == i) eqn:evar. - all: move: evar => /eqP evar. - * subst. rewrite Fv.setP_eq in ev. noconf ev. - rewrite get_set_heap_eq. rewrite coerce_to_choice_type_K. - eapply translate_of_val in hv₁ as e. - rewrite e. apply coerce_to_choice_type_translate_value_to_val. - * rewrite Fv.setP_neq in ev. - 2:{ apply /eqP. eauto. } - rewrite get_set_heap_neq. - 2:{ - apply /eqP. intro ee. - apply injective_translate_var in ee. - contradiction. - } - eapply h2 in ev. assumption. - + intros hbo hyl hset. subst. - destruct (vi == i) eqn:evar. - all: move: evar => /eqP evar. - 1:{ - exfalso. subst. rewrite Fv.setP_eq in ev. - clear - ev hbo. destruct (vtype i). all: discriminate. - } - rewrite Fv.setP_neq in ev. - 2:{ apply /eqP. eauto. } - rewrite get_set_heap_neq. - 2:{ - apply /eqP. intro ee. - apply injective_translate_var in ee. - contradiction. - } - eapply h2 in ev. assumption. + eapply translate_write_var_estate. all: eassumption. } apply ihfor. - (* call *) From 4e99f5dfff24877b30d1aaded89e491c5a03f952 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Fri, 29 Apr 2022 15:33:21 +0200 Subject: [PATCH 185/383] Use translate_write_var_estate to simplify other goal --- theories/Jasmin/jasmin_translate.v | 158 ++++++++++------------------- 1 file changed, 55 insertions(+), 103 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 1d3fa03e..81762498 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -2244,6 +2244,55 @@ Proof. eapply translate_write_estate. all: assumption. Qed. +Lemma translate_write_var_estate : + ∀ fn i v s1 s2 m, + write_var i v s1 = ok s2 → + rel_estate s1 fn m → + rel_estate s2 fn (set_heap m (translate_var fn i) (truncate_el i.(vtype) (translate_value v))). +Proof. + intros fn i v s1 s2 m hw [h1 h2]. + unfold write_var in hw. jbind hw vm hvm. noconf hw. + split. all: simpl. + - intros ptr v' er. + eapply h1 in er. + rewrite get_set_heap_neq. 2: apply mem_loc_translate_var_neq. + assumption. + - intros vi v' ev. + eapply set_varP. 3: exact hvm. + + intros v₁ hv₁ eyl. subst. + destruct (vi == i) eqn:evar. + all: move: evar => /eqP evar. + * subst. rewrite Fv.setP_eq in ev. noconf ev. + rewrite get_set_heap_eq. rewrite coerce_to_choice_type_K. + eapply translate_of_val in hv₁ as e. + rewrite e. apply coerce_to_choice_type_translate_value_to_val. + * rewrite Fv.setP_neq in ev. + 2:{ apply /eqP. eauto. } + rewrite get_set_heap_neq. + 2:{ + apply /eqP. intro ee. + apply injective_translate_var in ee. + contradiction. + } + eapply h2 in ev. assumption. + + intros hbo hyl hset. subst. + destruct (vi == i) eqn:evar. + all: move: evar => /eqP evar. + 1:{ + exfalso. subst. rewrite Fv.setP_eq in ev. + clear - ev hbo. destruct (vtype i). all: discriminate. + } + rewrite Fv.setP_neq in ev. + 2:{ apply /eqP. eauto. } + rewrite get_set_heap_neq. + 2:{ + apply /eqP. intro ee. + apply injective_translate_var in ee. + contradiction. + } + eapply h2 in ev. assumption. +Qed. + Lemma translate_write_lval_correct : ∀ es₁ es₂ fn y sty e v v', sem_pexpr gd es₁ e = ok v → @@ -2264,8 +2313,7 @@ Proof. all: noconf hw. all: assumption. + unfold on_vu in hw. destruct of_val as [| []]. all: noconf hw. assumption. - - simpl. unfold translate_write_var. simpl in hw. unfold write_var in hw. - jbind hw vm eset. noconf hw. + - simpl. unfold translate_write_var. simpl in hw. simpl. rewrite !bind_assoc. simpl. eapply u_bind. 1:{ eapply translate_pexpr_correct. all: eauto. } @@ -2274,58 +2322,11 @@ Proof. eapply u_put. apply u_ret_eq. intros m' [m [hm e]]. subst. - (* TODO Apply translate_write_var_estate instead of unfolding write_var *) - destruct hm as [hm hv]. - split. - + unfold rel_mem. - intros ptr byte hr. - rewrite get_set_heap_neq. 2: apply mem_loc_translate_var_neq. - apply hm. assumption. - + simpl. unfold rel_vmap. - intros i vi ei. - simpl. rewrite !coerce_to_choice_type_K. - eapply set_varP. 3: exact eset. - * { - intros v₁ hv₁ eyl. subst. - destruct (i == yl) eqn:evar. - all: move: evar => /eqP evar. - - subst. - rewrite Fv.setP_eq in ei. noconf ei. - rewrite get_set_heap_eq. - apply truncate_val_type in trunc as ety. subst. - eapply translate_truncate_val in trunc. - eapply translate_of_val in hv₁. - rewrite trunc. rewrite coerce_to_choice_type_K. - rewrite hv₁. apply coerce_to_choice_type_translate_value_to_val. - - rewrite Fv.setP_neq in ei. - 2:{ apply /eqP. eauto. } - rewrite get_set_heap_neq. - 2:{ - apply /eqP. intro e. - apply injective_translate_var in e. - contradiction. - } - eapply hv in ei. rewrite ei. - rewrite coerce_to_choice_type_K. reflexivity. - } - * { - intros hbo hyl hset. - subst. - destruct (i == yl) eqn:evar. - all: move: evar => /eqP evar. - - exfalso. subst. rewrite Fv.setP_eq in ei. - clear - ei hbo. destruct (vtype yl). all: discriminate. - - rewrite Fv.setP_neq in ei. - 2:{ apply /eqP. eauto. } - rewrite get_set_heap_neq. - 2:{ - apply /eqP. intro e. - apply injective_translate_var in e. - contradiction. - } - eapply hv in ei. rewrite ei. - rewrite coerce_to_choice_type_K. reflexivity. - } + rewrite coerce_to_choice_type_K. + apply truncate_val_type in trunc as ety. subst. + eapply translate_truncate_val in trunc. + rewrite trunc. rewrite coerce_to_choice_type_K. + eapply translate_write_var_estate. all: eassumption. - simpl. simpl in hw. jbind hw vx hvx. jbind hvx vx' hvx'. jbind hw ve hve. jbind hve ve' hve'. jbind hw w hw'. jbind hw m hm. @@ -2451,55 +2452,6 @@ Proof. - admit. Admitted. -Lemma translate_write_var_estate : - ∀ fn i v s1 s2 m, - write_var i v s1 = ok s2 → - rel_estate s1 fn m → - rel_estate s2 fn (set_heap m (translate_var fn i) (truncate_el i.(vtype) (translate_value v))). -Proof. - intros fn i v s1 s2 m hw [h1 h2]. - unfold write_var in hw. jbind hw vm hvm. noconf hw. - split. all: simpl. - - intros ptr v' er. - eapply h1 in er. - rewrite get_set_heap_neq. 2: apply mem_loc_translate_var_neq. - assumption. - - intros vi v' ev. - eapply set_varP. 3: exact hvm. - + intros v₁ hv₁ eyl. subst. - destruct (vi == i) eqn:evar. - all: move: evar => /eqP evar. - * subst. rewrite Fv.setP_eq in ev. noconf ev. - rewrite get_set_heap_eq. rewrite coerce_to_choice_type_K. - eapply translate_of_val in hv₁ as e. - rewrite e. apply coerce_to_choice_type_translate_value_to_val. - * rewrite Fv.setP_neq in ev. - 2:{ apply /eqP. eauto. } - rewrite get_set_heap_neq. - 2:{ - apply /eqP. intro ee. - apply injective_translate_var in ee. - contradiction. - } - eapply h2 in ev. assumption. - + intros hbo hyl hset. subst. - destruct (vi == i) eqn:evar. - all: move: evar => /eqP evar. - 1:{ - exfalso. subst. rewrite Fv.setP_eq in ev. - clear - ev hbo. destruct (vtype i). all: discriminate. - } - rewrite Fv.setP_neq in ev. - 2:{ apply /eqP. eauto. } - rewrite get_set_heap_neq. - 2:{ - apply /eqP. intro ee. - apply injective_translate_var in ee. - contradiction. - } - eapply h2 in ev. assumption. -Qed. - Definition ssprove_prog := seq (funname * fdef). Definition exports_of_prog (p : ssprove_prog) : {fmap funname -> opsig} := From 9be3afcbaa4d38c4d327a023b5fb6aa3bed67b8d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Fri, 29 Apr 2022 15:45:00 +0200 Subject: [PATCH 186/383] Further simplification using translate_write_var_estate --- theories/Jasmin/jasmin_translate.v | 80 +++++++----------------------- 1 file changed, 17 insertions(+), 63 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 81762498..58712403 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -2367,8 +2367,6 @@ Proof. jbind hw nt hnt. destruct nt. all: try discriminate. jbind hw i hi. jbind hi i' hi'. jbind hw w ew. jbind hw t ht. - unfold write_var in hw. jbind hw vm hvm. - noconf hw. eapply u_get_remember. simpl. intros vx. rewrite !bind_assoc. simpl. eapply u_bind. @@ -2387,68 +2385,24 @@ Proof. simpl. unfold translate_write_var. simpl. eapply u_put. eapply u_ret_eq. - intros ? [m [[[hr hv] hm] ?]]. subst. + intros ? [m [[hs hm] ?]]. subst. unfold u_get in hm. subst. - split. - + intros ptr byte hby. - rewrite get_set_heap_neq. 2: eapply mem_loc_translate_var_neq. - apply hr. assumption. - + simpl. intros j vj ej. - simpl. rewrite coerce_to_choice_type_K. - eapply set_varP. 3: exact hvm. - * { - intros v₁ hv₁ eyl. subst. - destruct (j == x) eqn:evar. - all: move: evar => /eqP evar. - - subst. rewrite Fv.setP_eq in ej. noconf ej. - rewrite get_set_heap_eq. - apply truncate_val_type in trunc as ety. subst. - erewrite translate_pexpr_type. 2: eassumption. - erewrite translate_pexpr_type. 2: eassumption. - rewrite !coerce_to_choice_type_K. - eapply translate_truncate_val in trunc. - rewrite trunc. rewrite coerce_to_choice_type_K. - eapply translate_to_word in ew. rewrite ew. - erewrite translate_to_int. 2: eassumption. - erewrite get_var_get_heap. - 2: eassumption. - 2:{ split. all: assumption. } - eapply translate_of_val in hv₁. (* simpl in hv₁. *) - rewrite coerce_to_choice_type_translate_value_to_val in hv₁. - rewrite <- hv₁. f_equal. - Opaque translate_value. simpl. Transparent translate_value. - eapply type_of_get_var in hnt as ety. simpl in ety. - rewrite -ety. rewrite !coerce_to_choice_type_K. - apply chArray_set_correct. assumption. - - rewrite Fv.setP_neq in ej. - 2:{ apply /eqP. eauto. } - rewrite get_set_heap_neq. - 2:{ - apply /eqP. intro ee. - apply injective_translate_var in ee. - contradiction. - } - eapply hv in ej. rewrite ej. - rewrite coerce_to_choice_type_K. reflexivity. - } - * intros hbo hyl hset. - subst. - destruct (j == x) eqn:evar. - all: move: evar => /eqP evar. - 1:{ - exfalso. subst. rewrite Fv.setP_eq in ej. - clear - ej hbo. destruct (vtype x). all: discriminate. - } - rewrite Fv.setP_neq in ej. - 2:{ apply /eqP. eauto. } - rewrite get_set_heap_neq. - 2:{ - apply /eqP. intro ee. - apply injective_translate_var in ee. - contradiction. - } - eapply hv in ej. rewrite ej. - rewrite coerce_to_choice_type_K. reflexivity. + apply truncate_val_type in trunc as ety. subst. + erewrite translate_pexpr_type. 2: eassumption. + erewrite translate_pexpr_type. 2: eassumption. + rewrite !coerce_to_choice_type_K. + eapply translate_truncate_val in trunc. + rewrite trunc. rewrite coerce_to_choice_type_K. + eapply translate_to_word in ew. rewrite ew. + erewrite translate_to_int. 2: eassumption. + erewrite get_var_get_heap. 2,3: eassumption. + Opaque translate_value. simpl. Transparent translate_value. + eapply type_of_get_var in hnt as ety. simpl in ety. + apply (f_equal encode) in ety. simpl in ety. + rewrite -ety. rewrite !coerce_to_choice_type_K. + erewrite chArray_set_correct. 2: eassumption. + eapply translate_write_var_estate in hs. 2: eassumption. + assumption. - admit. Admitted. From 923615128d507e5ddbd1fc30616e4942a5d21cf0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Fri, 29 Apr 2022 15:56:31 +0200 Subject: [PATCH 187/383] Define translate_instr directly (instead of using exact) --- theories/Jasmin/jasmin_translate.v | 175 ++++++++++++++--------------- 1 file changed, 85 insertions(+), 90 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 58712403..198c04ae 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1066,97 +1066,92 @@ Fixpoint translate_for fn (i : var_i) (ws : seq Z) (c : raw_code 'unit) : raw_co end. Fixpoint translate_instr_r (prog_exports : {fmap funname -> opsig}) (fn : funname) (i : instr_r) {struct i} : raw_code 'unit -with translate_instr (prog_exports : {fmap funname -> opsig}) (fn : funname) (i : instr) {struct i} : raw_code 'unit. -Proof. - (* translate_instr_r *) - { - pose proof (translate_cmd := - (fix translate_cmd (fn : funname) (c : cmd) : raw_code 'unit := - match c with - | [::] => ret tt - | i :: c => - translate_instr prog_exports fn i ;; - translate_cmd fn c - end - ) - ). - destruct i as [ | | e c1 c2 | i [[d lo] hi] c | | ii xs f args ]. - - (* Cassgn *) - (* l :a=_s p *) - pose (translate_pexpr fn p) as tr_p. - pose (truncate_code s tr_p) as tr_p'. - exact (translate_write_lval fn l tr_p'). - - exact (unsupported.π2). (* Copn *) - - (* Cif e c1 c2 *) - pose (e' := translate_pexpr fn e). - pose (c1' := translate_cmd fn c1). - pose (c2' := translate_cmd fn c2). - pose (rb := coerce_typed_code 'bool e'). - exact (b ← rb ;; if b then c1' else c2'). - - (* Cfor i (d, lo, hi) c *) - (* pose (iᵗ := translate_var fn i). *) (* Weird not to do it *) - pose (loᵗ := coerce_typed_code 'int (translate_pexpr fn lo)). - pose (hiᵗ := coerce_typed_code 'int (translate_pexpr fn hi)). - pose (cᵗ := translate_cmd fn c). - exact ( - vlo ← loᵗ ;; - vhi ← hiᵗ ;; - translate_for fn i (wrange d vlo vhi) cᵗ - ). - - exact (unsupported.π2). (* Cwhile *) - - (* Ccall ii xs f args *) - (* Translate arguments. *) - pose (map (translate_pexpr f) args) as tr_args. - - (* We need some typing about the translated and original f, let's look it - up. *) - destruct (prog_exports f) as [f_sg|]. - 2: { - (* The function `f` wasn't found in the exports. This should mean that - the Jasmin semantics also failed at `sem_call` where - `get_fundef (p_funcs P) f = Some f'` is expected. *) - exact (unsupported.π2). - } - destruct (get_fundef (p_funcs P) f) eqn:E. - 2: exact (unsupported.π2). - - (* Evaluate & truncate arguments according to the Jasmin typing of `f`. *) - (* Note that in Ecall we do not need to truncate, as sem_call does not - enforce any relation between the types of the function and the - arguments. But we need the types to match. sem_call, however, does - truncate as soon as the type of `f` is looked up. *) - pose (bind_list' _f.(f_tyin) tr_args) as vargs'. - (* pose (bind_list [seq translate_pexpr fn e | e <- args]) as vargs'. *) - (* Bind the values. *) - apply (bind vargs'). intros vargs. - (* Now "perform" the call via `opr`. *) - apply (opr f_sg). - + exact (coerce_to_choice_type (chsrc f_sg) vargs). - + intros vs. - - (* Unpack `vs : tgt f_sg` into a list in order to write `xs`. *) - pose (f_tyout _f) as f_tyout. - apply (coerce_chtuple_to_list _ f_tyout) in vs. - pose (zip f_tyout vs) as vs_f. - - (* We coerce rather than truncating here. The truncation should happen - in sem_call; the coercion should never fail on well-translated - functions. Presumably these results just got truncated in sem_call, - so we could also truncate instead of coercing if convenient. *) - pose (map (λ '(ty,c), - let ty' := encode ty in - (ty'; ret (coerce_to_choice_type ty' c.π2)) : typed_code) vs_f) - as vres'. - (* pose (map (λ '(ty,c), (truncate_code ty (totc c.π1 (ret c.π2)))) l0) as vres'. *) - - pose (map (λ '(x,v), translate_write_lval fn x v) (zip xs vres')) as vres''. - exact (foldl (λ c k, c ;; k) (ret tt) vres''). - } - (* translate_instr *) - { - exact (translate_instr_r prog_exports fn (instr_d i)). - } +with translate_instr (prog_exports : {fmap funname -> opsig}) (fn : funname) (i : instr) {struct i} : raw_code 'unit := + translate_instr_r prog_exports fn (instr_d i). +Proof. + pose proof (translate_cmd := + (fix translate_cmd (fn : funname) (c : cmd) : raw_code 'unit := + match c with + | [::] => ret tt + | i :: c => + translate_instr prog_exports fn i ;; + translate_cmd fn c + end + ) + ). + + destruct i as [ | | e c1 c2 | i [[d lo] hi] c | | ii xs f args ]. + - (* Cassgn *) + (* l :a=_s p *) + pose (translate_pexpr fn p) as tr_p. + pose (truncate_code s tr_p) as tr_p'. + exact (translate_write_lval fn l tr_p'). + - exact (unsupported.π2). (* Copn *) + - (* Cif e c1 c2 *) + pose (e' := translate_pexpr fn e). + pose (c1' := translate_cmd fn c1). + pose (c2' := translate_cmd fn c2). + pose (rb := coerce_typed_code 'bool e'). + exact (b ← rb ;; if b then c1' else c2'). + - (* Cfor i (d, lo, hi) c *) + (* pose (iᵗ := translate_var fn i). *) (* Weird not to do it *) + pose (loᵗ := coerce_typed_code 'int (translate_pexpr fn lo)). + pose (hiᵗ := coerce_typed_code 'int (translate_pexpr fn hi)). + pose (cᵗ := translate_cmd fn c). + exact ( + vlo ← loᵗ ;; + vhi ← hiᵗ ;; + translate_for fn i (wrange d vlo vhi) cᵗ + ). + - exact (unsupported.π2). (* Cwhile *) + - (* Ccall ii xs f args *) + (* Translate arguments. *) + pose (map (translate_pexpr f) args) as tr_args. + + (* We need some typing about the translated and original f, let's look it + up. *) + destruct (prog_exports f) as [f_sg|]. + 2: { + (* The function `f` wasn't found in the exports. This should mean that + the Jasmin semantics also failed at `sem_call` where + `get_fundef (p_funcs P) f = Some f'` is expected. *) + exact (unsupported.π2). + } + destruct (get_fundef (p_funcs P) f) eqn:E. + 2: exact (unsupported.π2). + + (* Evaluate & truncate arguments according to the Jasmin typing of `f`. *) + (* Note that in Ecall we do not need to truncate, as sem_call does not + enforce any relation between the types of the function and the + arguments. But we need the types to match. sem_call, however, does + truncate as soon as the type of `f` is looked up. *) + pose (bind_list' _f.(f_tyin) tr_args) as vargs'. + (* pose (bind_list [seq translate_pexpr fn e | e <- args]) as vargs'. *) + (* Bind the values. *) + apply (bind vargs'). intros vargs. + (* Now "perform" the call via `opr`. *) + apply (opr f_sg). + + exact (coerce_to_choice_type (chsrc f_sg) vargs). + + intros vs. + + (* Unpack `vs : tgt f_sg` into a list in order to write `xs`. *) + pose (f_tyout _f) as f_tyout. + apply (coerce_chtuple_to_list _ f_tyout) in vs. + pose (zip f_tyout vs) as vs_f. + + (* We coerce rather than truncating here. The truncation should happen + in sem_call; the coercion should never fail on well-translated + functions. Presumably these results just got truncated in sem_call, + so we could also truncate instead of coercing if convenient. *) + pose (map (λ '(ty,c), + let ty' := encode ty in + (ty'; ret (coerce_to_choice_type ty' c.π2)) : typed_code) vs_f) + as vres'. + (* pose (map (λ '(ty,c), (truncate_code ty (totc c.π1 (ret c.π2)))) l0) as vres'. *) + + pose (map (λ '(x,v), translate_write_lval fn x v) (zip xs vres')) as vres''. + exact (foldl (λ c k, c ;; k) (ret tt) vres''). Defined. (* translate_instr is blocked because it is a fixpoint *) From a6a59068b1c06784934ad8195dc264a36eb7019e Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Mon, 2 May 2022 10:42:36 +0200 Subject: [PATCH 188/383] change `write_lval` input to `typed_chElement` generalized correctness theorem of `write_lval` --- theories/Jasmin/jasmin_translate.v | 137 +++++++++++++++++------------ 1 file changed, 83 insertions(+), 54 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 198c04ae..e1636e15 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -528,10 +528,9 @@ Proof. values.v), all of these functions raise an error on Vundef. *) Defined. -Definition translate_write_var (fn : funname) (x : var_i) (v : typed_code) := +Definition translate_write_var (fn : funname) (x : var_i) (v : typed_chElement) := let l := translate_var fn (v_var x) in - x ← (truncate_code x.(vtype) v).π2 ;; - #put l := x ;; + #put l := truncate_el x.(vtype) v.π2 ;; ret tt. Definition translate_get_var (f : funname) (x : var) : raw_code (encode x.(vtype)) := @@ -895,6 +894,9 @@ Section bind_list_alt. End bind_list_alt. +Notation totce := to_typed_chElement. + + (* Following sem_pexpr *) Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code := match e with @@ -1006,7 +1008,7 @@ Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code := (* pose (vs' := fold (fun x => y ← x ;; unembed y) f vs). *) -Definition translate_write_lval (fn : funname) (l : lval) (v : typed_code) +Definition translate_write_lval (fn : funname) (l : lval) (v : typed_chElement) : raw_code 'unit := match l with @@ -1018,8 +1020,7 @@ Definition translate_write_lval (fn : funname) (l : lval) (v : typed_code) ve' ← (translate_pexpr fn e).π2 ;; let ve := translate_to_pointer ve' in let p := (vx + ve)%R in (* should we add the size of value, i.e vx + sz * se *) (* Is it from us or them? *) - v ← v.π2 ;; - let w := truncate_chWord sz v in + let w := truncate_chWord sz v.π2 in translate_write p w | Laset aa ws x i => (* Let (n,t) := s.[x] in is a notation calling on_arr_varr on get_var *) @@ -1027,10 +1028,9 @@ Definition translate_write_lval (fn : funname) (l : lval) (v : typed_code) t' ← translate_get_var fn x ;; let t := coerce_to_choice_type 'array t' in i ← (truncate_code sint (translate_pexpr fn i)).π2 ;; (* to_int *) - v ← v.π2 ;; - let v := truncate_chWord ws v in + let v := truncate_chWord ws v.π2 in let t := chArray_set t aa i v in - translate_write_var fn x (totc _ (ret t)) + translate_write_var fn x (totce t) | Lasub aa ws len x i => (* Same observation as Laset *) t' ← translate_get_var fn x ;; @@ -1060,10 +1060,46 @@ Fixpoint translate_for fn (i : var_i) (ws : seq Z) (c : raw_code 'unit) : raw_co match ws with | [::] => ret tt | w :: ws => - translate_write_var fn i (totc _ (ret (translate_value w))) ;; + translate_write_var fn i (totce (translate_value w)) ;; c ;; translate_for fn i ws c end. +(* sem_i *) +(* Fixpoint translate_instr_r (fn : funname) (i : instr_r) {struct i} : raw_code 'unit *) +(* with translate_instr (fn : funname) (i : instr) {struct i} : raw_code 'unit. *) +(* Proof. *) +(* (* translate_instr_r *) *) +(* { *) +(* pose proof (translate_cmd := *) +(* (fix translate_cmd (fn : funname) (c : cmd) : raw_code 'unit := *) +(* match c with *) +(* | [::] => ret tt *) +(* | i :: c => translate_instr fn i ;; translate_cmd fn c *) +(* end)). *) + +(* destruct i as [ | | e c1 c2 | | | ]. *) +(* - (* Cassgn *) *) +(* (* l :a=_s p *) *) +(* pose (translate_pexpr fn p) as tr_p. *) +(* pose (truncate_code s tr_p) as tr_p'. *) +(* eapply bind. 1: exact tr_p'.π2. intros. *) +(* exact (translate_write_lval fn l (totce X)). *) +(* - exact (unsupported.π2). (* Copn *) *) +(* - (* Cif e c1 c2 *) *) +(* pose (e' := translate_pexpr fn e). *) +(* pose (c1' := translate_cmd fn c1). *) +(* pose (c2' := translate_cmd fn c2). *) +(* pose (rb := coerce_typed_code 'bool e'). *) +(* exact (b ← rb ;; if b then c1' else c2'). *) +(* - exact (unsupported.π2). (* Cfor *) *) +(* - exact (unsupported.π2). (* Cwhile *) *) +(* - (* Ccall i l f l0 *) *) +(* (* translate arguments *) *) +(* pose (map (translate_pexpr fn) l0) as tr_l0. *) +(* (* "perform" the call via `opr` *) *) +(* (* probably we'd look up the function signature in the current ambient program *) *) + +(* (* write_lvals the result of the call into lvals `l` *) *) Fixpoint translate_instr_r (prog_exports : {fmap funname -> opsig}) (fn : funname) (i : instr_r) {struct i} : raw_code 'unit @@ -1085,8 +1121,9 @@ Proof. - (* Cassgn *) (* l :a=_s p *) pose (translate_pexpr fn p) as tr_p. - pose (truncate_code s tr_p) as tr_p'. - exact (translate_write_lval fn l tr_p'). + eapply bind. 1: exact (tr_p.π2). + intros v. pose (truncate_el s v) as tr_v. + exact (translate_write_lval fn l (totce tr_v)). - exact (unsupported.π2). (* Copn *) - (* Cif e c1 c2 *) pose (e' := translate_pexpr fn e). @@ -1146,7 +1183,7 @@ Proof. so we could also truncate instead of coercing if convenient. *) pose (map (λ '(ty,c), let ty' := encode ty in - (ty'; ret (coerce_to_choice_type ty' c.π2)) : typed_code) vs_f) + (totce (coerce_to_choice_type ty' c.π2)) : typed_chElement) vs_f) as vres'. (* pose (map (λ '(ty,c), (truncate_code ty (totc c.π1 (ret c.π2)))) l0) as vres'. *) @@ -1206,7 +1243,7 @@ Proof. apply (coerce_chtuple_to_list _ f_tyin) in vargs'. (* Write the arguments to their locations. *) - pose (map (λ '(x, (ty; v)), translate_write_var f x (totc ty (ret v))) + pose (map (λ '(x, (ty; v)), translate_write_var f x (totce v)) (zip f_params vargs')) as cargs. apply (foldl (λ c k, c ;; k) (ret tt)) in cargs. @@ -1466,19 +1503,25 @@ Proof. all: simpl. all: rewrite coerce_to_choice_type_K. all: reflexivity. Qed. +Lemma totce_coerce t (tv : choice_type) (v : tv) : + t = tv -> totce (coerce_to_choice_type t v) = totce v. +Proof. + intros. rewrite H. rewrite coerce_to_choice_type_K. + reflexivity. +Qed. Section bind_list_test. (* Quick test to see that the definition-via-tactics of bind_list' computes as expected. *) Definition cs : list typed_code := - [:: ('bool; (ret false)) ; ('bool; (ret true)) ; ('nat; (ret 666)) ; ('int; ret 42%Z)]. + [:: ('bool; (ret false)) ; ('bool; (ret true)) ; ('nat; (ret 666))]. Definition ts := [:: sbool; sbool; sint; sint]. Goal bind_list' ts cs = bind_list' ts cs. unfold bind_list' at 2. unfold bind_list_trunc_aux. simpl. - rewrite !coerce_to_choice_type_K. + (* rewrite !coerce_to_choice_type_K. *) simp coerce_to_choice_type. cbn. Abort. @@ -1572,6 +1615,19 @@ Proof. apply translate_of_val. assumption. Qed. +Lemma totce_truncate_translate : + ∀ ty v v', + truncate_val ty v = ok v' -> + totce (truncate_el ty (translate_value v)) = totce (translate_value v'). +Proof. + intros ty v v' h. + erewrite translate_truncate_val by eassumption. + apply totce_coerce. + unfold choice_type_of_val. + erewrite truncate_val_type by eassumption. + reflexivity. +Qed. + Lemma bind_list_correct cond cs vs : [seq c.π1 | c <- cs] = [seq choice_type_of_val v | v <- vs] → List.Forall2 (λ c v, ⊢ ⦃ cond ⦄ c.π2 ⇓ coerce_to_choice_type _ (translate_value v) ⦃ cond ⦄) cs vs → @@ -2289,16 +2345,14 @@ Proof. Qed. Lemma translate_write_lval_correct : - ∀ es₁ es₂ fn y sty e v v', - sem_pexpr gd es₁ e = ok v → - truncate_val sty v = ok v' → - write_lval gd y v' es₁ = ok es₂ → + ∀ es₁ es₂ fn y v, + write_lval gd y v es₁ = ok es₂ → ⊢ ⦃ rel_estate es₁ fn ⦄ - translate_write_lval fn y (truncate_code sty (translate_pexpr fn e)) + translate_write_lval fn y (totce (translate_value v)) ⇓ tt ⦃ rel_estate es₂ fn ⦄. Proof. - intros es₁ es₂ fn y sty e v v' sem_e trunc hw. + intros es₁ es₂ fn y v hw. destruct y as [ | yl | | aa ws x ei | ] eqn:case_lval. - simpl. apply u_ret_eq. intros hp hr. @@ -2309,18 +2363,10 @@ Proof. + unfold on_vu in hw. destruct of_val as [| []]. all: noconf hw. assumption. - simpl. unfold translate_write_var. simpl in hw. - simpl. rewrite !bind_assoc. simpl. - eapply u_bind. - 1:{ eapply translate_pexpr_correct. all: eauto. } - erewrite translate_pexpr_type. 2: eassumption. - clear sem_e e. + simpl. eapply u_put. apply u_ret_eq. intros m' [m [hm e]]. subst. - rewrite coerce_to_choice_type_K. - apply truncate_val_type in trunc as ety. subst. - eapply translate_truncate_val in trunc. - rewrite trunc. rewrite coerce_to_choice_type_K. eapply translate_write_var_estate. all: eassumption. - simpl. simpl in hw. jbind hw vx hvx. jbind hvx vx' hvx'. jbind hw ve hve. @@ -2333,23 +2379,12 @@ Proof. - eassumption. - intros ? []. assumption. } - rewrite bind_assoc. - eapply u_bind. - 1:{ - eapply translate_pexpr_correct. - - eassumption. - - intros ? []. assumption. - } simpl. eapply translate_write_correct. intros m' [hm' em']. unfold u_get in em'. subst. split. 2: assumption. erewrite translate_pexpr_type. 2: eassumption. - erewrite translate_pexpr_type. 2: eassumption. rewrite !coerce_to_choice_type_K. - erewrite translate_truncate_val. 2: eassumption. - eapply truncate_val_type in trunc as ety. subst. - rewrite coerce_to_choice_type_K. eapply translate_to_word in hw' as ew. rewrite ew. clear ew. unfold translate_to_pointer. simpl. eapply translate_to_word in hve as ew. rewrite ew. clear ew. @@ -2370,24 +2405,13 @@ Proof. - eassumption. - intros ? []. assumption. } - rewrite !bind_assoc. - eapply u_bind. - 1:{ - eapply translate_pexpr_correct. - - eassumption. - - intros ? []. assumption. - } simpl. unfold translate_write_var. simpl. eapply u_put. eapply u_ret_eq. intros ? [m [[hs hm] ?]]. subst. unfold u_get in hm. subst. - apply truncate_val_type in trunc as ety. subst. - erewrite translate_pexpr_type. 2: eassumption. erewrite translate_pexpr_type. 2: eassumption. rewrite !coerce_to_choice_type_K. - eapply translate_truncate_val in trunc. - rewrite trunc. rewrite coerce_to_choice_type_K. eapply translate_to_word in ew. rewrite ew. erewrite translate_to_int. 2: eassumption. erewrite get_var_get_heap. 2,3: eassumption. @@ -2469,7 +2493,12 @@ Proof. apply ihi. - (* assgn *) red. intros s₁ s₂ x tag ty e v v' he hv hw. - red. simpl. eapply translate_write_lval_correct. all: eauto. + red. simpl. + eapply u_bind. 1: eapply translate_pexpr_correct. 1: eassumption. 1: easy. + erewrite translate_pexpr_type by eassumption. + rewrite coerce_to_choice_type_K. + erewrite totce_truncate_translate by eassumption. + eapply translate_write_lval_correct. all: eauto. - (* opn *) red. intros s1 s2 tag o xs es ho. red. simpl. admit. From 275e5ffca78d41a3dabbd2f1bc6c8cd444680c96 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Mon, 2 May 2022 11:46:18 +0200 Subject: [PATCH 189/383] nits --- theories/Jasmin/jasmin_translate.v | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index e1636e15..716aea03 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1504,9 +1504,11 @@ Proof. Qed. Lemma totce_coerce t (tv : choice_type) (v : tv) : - t = tv -> totce (coerce_to_choice_type t v) = totce v. + t = tv → + totce (coerce_to_choice_type t v) = totce v. Proof. - intros. rewrite H. rewrite coerce_to_choice_type_K. + intro e. + rewrite e. rewrite coerce_to_choice_type_K. reflexivity. Qed. @@ -1617,7 +1619,7 @@ Qed. Lemma totce_truncate_translate : ∀ ty v v', - truncate_val ty v = ok v' -> + truncate_val ty v = ok v' → totce (truncate_el ty (translate_value v)) = totce (translate_value v'). Proof. intros ty v v' h. @@ -2494,7 +2496,8 @@ Proof. - (* assgn *) red. intros s₁ s₂ x tag ty e v v' he hv hw. red. simpl. - eapply u_bind. 1: eapply translate_pexpr_correct. 1: eassumption. 1: easy. + eapply u_bind. + 1:{ eapply translate_pexpr_correct. all: eauto. } erewrite translate_pexpr_type by eassumption. rewrite coerce_to_choice_type_K. erewrite totce_truncate_translate by eassumption. From 0ed875775a8c635c02ac49522a2093fb66fa1632 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Tue, 3 May 2022 14:15:15 +0200 Subject: [PATCH 190/383] several addition, mainly to prove `app_sopn_list_tuple_correct` --- theories/Jasmin/jasmin_translate.v | 327 ++++++++++++++++++++++++++++- 1 file changed, 319 insertions(+), 8 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index e1636e15..a776a87b 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -360,14 +360,9 @@ Definition unembed {t : stype} : encode t → sem_t t := | sbool => λ x, x | sint => λ x, x | sarr n => λ x, - match - foldr - (λ kv m, Let m' := m in WArray.set m' AAscale kv.1 kv.2) - (Ok _ (WArray.empty _)) x - with - | Ok ar => ar - | _ => WArray.empty _ - end + foldr (λ kv m, {| WArray.arr_data := Mz.set m.(WArray.arr_data) kv.1 kv.2 |}) (WArray.empty _) x + (* (λ kv m, Let m' := m in WArray.set8 m' kv.1 kv.2) *) + (* (Ok _ (WArray.empty _)) x *) | sword n => λ x, x end. @@ -1101,6 +1096,63 @@ Fixpoint translate_for fn (i : var_i) (ws : seq Z) (c : raw_code 'unit) : raw_co (* (* write_lvals the result of the call into lvals `l` *) *) +Definition embed_ot {t} : sem_ot t → encode t := + match t with + | sbool => λ x, x (* BSH: I'm not sure this will be correct? In jasmin this is an Option bool, perhaps because you don't have to specify all output flags *) + | sint => λ x, x + | sarr n => embed_array + | sword n => λ x, x + end. + +Fixpoint embed_tuple {ts} : sem_tuple ts -> lchtuple [seq encode t | t <- ts] := + match ts as ts0 return sem_tuple ts0 -> lchtuple [seq encode t | t <- ts0] with + | [::] => λ (_ : unit), tt + | t' :: ts' => let rec := @embed_tuple ts' in + match ts' as ts'0 return + (sem_tuple ts'0 -> lchtuple [seq encode t | t <- ts'0]) -> + sem_tuple (t'::ts'0) -> lchtuple [seq encode t | t <- (t'::ts'0)] with + | [::] => λ _ (v : sem_ot t'), embed_ot v + | t'' :: ts'' => λ rec (p : (sem_ot t') * (sem_tuple (t''::ts''))), (embed_ot p.1, rec p.2) + end rec + end. + +Fixpoint app_sopn_list_tuple {ts_out : list stype} (ts_in : list stype) := + match ts_in as ts0 return (sem_prod ts0 (exec (sem_tuple ts_out))) → [choiceType of list typed_chElement] → lchtuple ([seq encode t | t <- ts_out]) with + | [::] => + λ (o : exec (sem_tuple ts_out)) (vs : list typed_chElement), + match vs with + | [::] => + match o with + | Ok o => embed_tuple o + | _ => chCanonical _ + end + | _ :: _ => chCanonical _ + end + | t :: ts0 => + λ (o : sem_t t → sem_prod ts0 (exec (sem_tuple ts_out))) (vs : list typed_chElement), + match vs with + | [::] => chCanonical _ + | v :: vs0 => app_sopn_list_tuple ts0 (o (unembed (truncate_el t v.π2))) vs0 + end + end. + +(* list_ltuple *) +Fixpoint list_lchtuple {ts} : lchtuple ([seq encode t | t <- ts]) -> [choiceType of list typed_chElement] := + match ts as ts0 return lchtuple ([seq encode t | t <- ts0]) -> [choiceType of list typed_chElement] with + | [::] => λ _, [::] + | t' :: ts' => let rec := @list_lchtuple ts' in + match ts' as ts'0 return + (lchtuple ([seq encode t | t <- ts'0]) -> [choiceType of list typed_chElement]) + -> lchtuple [seq encode t | t <- (t'::ts'0)] -> [choiceType of list typed_chElement] with + | [::] => λ _ (v : encode t'), [:: totce v] + | t'' :: ts'' => λ rec (p : (encode t') × (lchtuple [seq encode t | t <- (t''::ts'')])), totce p.1 :: rec p.2 + end rec + end. + +(* corresponds to exec_sopn *) +Definition translate_exec_sopn (o : sopn) (vs : seq typed_chElement) := + list_lchtuple (app_sopn_list_tuple _ (sopn_sem o) vs). + Fixpoint translate_instr_r (prog_exports : {fmap funname -> opsig}) (fn : funname) (i : instr_r) {struct i} : raw_code 'unit with translate_instr (prog_exports : {fmap funname -> opsig}) (fn : funname) (i : instr) {struct i} : raw_code 'unit := @@ -1983,6 +2035,265 @@ Proof. f_equal. eapply ih. eassumption. Qed. +Definition WArray_ext_eq {len} (a b : WArray.array len) := + forall i, Mz.get a.(WArray.arr_data) i = Mz.get b.(WArray.arr_data) i. + +Notation "a =e b" := (WArray_ext_eq a b) (at level 90). +Notation "(=e)" := WArray_ext_eq (only parsing). + +Instance WArray_ext_eq_equiv {len} : Equivalence (@WArray_ext_eq len). +Proof. + split. + - intros x. + unfold WArray_ext_eq. + intros. + reflexivity. + - intros x y H. + unfold WArray_ext_eq. + intros. + rewrite H. + reflexivity. + - intros x y z H1 H2. + unfold WArray_ext_eq. + intros. + rewrite H1. + rewrite H2. + reflexivity. +Qed. + +Lemma embed_unembed {t} (a : encode t) : + embed (unembed a) = a. +Proof. + destruct t; try reflexivity. + apply eq_fmap. + intros x. + unfold embed, embed_array, unembed. + rewrite fold_get. + simpl in *. + destruct a. + cbn. + induction fmval; intros; simpl in *. + - rewrite Mz.get0. reflexivity. + - rewrite Mz.setP. + rewrite eq_sym. + destruct (_ == _)%B eqn:E. + + move: E => /eqP ->. + rewrite eq_refl. + reflexivity. + + destruct (@eq_op (Ord.eqType Z_ordType) _ _)%B eqn:E2. + { move: E2 E => /eqP ->. rewrite eq_refl. easy. } + apply IHfmval. + eapply path_sorted. + eassumption. +Qed. + +Lemma unembed_embed {len} (a : sem_t (sarr len)) : + unembed (embed a) =e a. +Proof. + intros x. + rewrite <- embed_array_get. + change (embed_array (unembed (embed a))) with (embed (unembed (embed a))). + rewrite embed_unembed. + unfold embed, embed_array. + rewrite fold_get. + reflexivity. +Qed. + +Instance unembed_embed_Proper {len} : Proper ((=e) ==> (=e)) (λ (a : sem_t (sarr len)), unembed (embed a)). +Proof. + intros x y H. + rewrite !unembed_embed. + assumption. +Qed. + +Instance WArray_get8_Proper {len} : Proper ((=e) ==> eq ==> eq) (@WArray.get8 len). + intros a b H ? ? Hi. + unfold WArray.get8, WArray.in_bound, WArray.is_init. + rewrite H Hi. + reflexivity. +Qed. + +Instance WArray_get_Proper {len ws} : Proper ((=e) ==> eq ==> eq) (@WArray.get len AAscale ws). +Proof. + intros a b H i j Hij. + unfold WArray.get, read. + rewrite Hij. + destruct is_align. 2: reflexivity. + simpl. f_equal. + apply eq_mapM. intros. + rewrite H. + reflexivity. +Qed. + +(* this should be moved to the jasmin repo *) +Lemma in_rcons_r {S : eqType} (a : S) l : + a \in rcons l a. +Proof. + induction l. + - apply mem_head. + - simpl. + rewrite in_cons IHl. + by apply /orP; right. +Qed. + +Lemma in_rcons_l {S : eqType} (a b : S) l : + a \in l -> a \in rcons l b. +Proof. + induction l. + - easy. + - intros. + rewrite in_cons in H. + move: H => /orP []. + + move=> /eqP ->. + rewrite rcons_cons. + rewrite in_cons. + by apply /orP; left. + + move=> H. + rewrite rcons_cons. + rewrite in_cons. + apply /orP; right. + apply IHl; assumption. +Qed. + +Lemma foldM_rcons eT (aT: eqType) bT (f: aT -> bT -> result eT bT) (a:aT) (b:bT) (l:list aT) : + foldM f b (rcons l a) = Let b' := foldM f b l in f a b'. +Proof. + revert a b. + induction l; intros. + - simpl; destruct (f a b); reflexivity. + - simpl. + destruct (f a b). + + simpl. rewrite IHl. reflexivity. + + reflexivity. +Qed. + +Lemma eq_foldM eT (aT: eqType) bT (f1 f2: aT -> bT -> result eT bT) (b:bT) (l:list aT) : + (forall a b, a \in l -> f1 a b = f2 a b) -> + foldM f1 b l = foldM f2 b l. +Proof. + replace l with (rev (rev l)) by (apply revK). + set (l' := rev l). + induction l'; intros. + - reflexivity. + - rewrite rev_cons. + rewrite !foldM_rcons. + rewrite IHl'. + + destruct (foldM f2 b (rev l')). 2: reflexivity. + apply H. + rewrite rev_cons. + apply in_rcons_r. + + intros. apply H. + rewrite rev_cons. + apply in_rcons_l. + assumption. +Qed. + +Instance WArray_copy_Proper {ws p} : Proper ((=e) ==> eq) (@WArray.copy ws p). +Proof. + intros a b H. + unfold WArray.copy, WArray.fcopy. + apply eq_foldM. + intros. + rewrite H. + reflexivity. +Qed. + +Lemma app_sopn_list_tuple_correct o vs vs' : + app_sopn _ (sopn_sem o) vs = ok vs' → + app_sopn_list_tuple + _ + (sopn_sem o) + [seq to_typed_chElement (translate_value v) | v <- vs] + = + embed_tuple vs'. +Proof. + intro H. + destruct o as [ ws p | | | | | ]. + - apply app_sopn_nil_ok_size in H as Hs. + simpl in Hs. + destruct vs. 1: inversion Hs. + destruct vs. 2: inversion Hs. + cbn -[wsize_size app_sopn_list_tuple]. + cbn [app_sopn_list_tuple]. + + jbind H vs'' Hv''. + simpl in H. + unfold sopn_sem in H. + + cbn -[wsize_size WArray.copy unembed truncate_el]. + erewrite translate_of_val by eassumption. + rewrite coerce_to_choice_type_K. + rewrite translate_value_to_val. + rewrite eq_rect_r_K. + cbn -[wsize_size ziota] in H. + rewrite unembed_embed. + rewrite H. + reflexivity. + - simpl; destruct map; reflexivity. + - apply app_sopn_nil_ok_size in H as Hs. + simpl in Hs. + destruct vs. 1: inversion Hs. + destruct vs. 1: inversion Hs. + destruct vs. 2: inversion Hs. + + simpl in *. + jbind H v' Hv'. + jbind H v'' Hv''. + erewrite translate_to_word by eassumption. + erewrite translate_to_word by eassumption. + + unfold sopn_sem in H. + simpl in H. + noconf H. + + reflexivity. + - apply app_sopn_nil_ok_size in H as Hs. + simpl in Hs. + destruct vs. 1: inversion Hs. + destruct vs. 1: inversion Hs. + destruct vs. 1: inversion Hs. + destruct vs. 2: inversion Hs. + + simpl in *. + jbind H v' Hv'. + jbind H v'' Hv''. + jbind H v''' Hv'''. + erewrite translate_to_word by eassumption. + erewrite translate_to_word by eassumption. + erewrite translate_to_bool by eassumption. + + unfold sopn_sem in H. + simpl in H. + noconf H. + + reflexivity. + - apply app_sopn_nil_ok_size in H as Hs. + simpl in Hs. + destruct vs. 1: inversion Hs. + destruct vs. 1: inversion Hs. + destruct vs. 1: inversion Hs. + destruct vs. 2: inversion Hs. + + simpl in *. + jbind H v' Hv'. + jbind H v'' Hv''. + jbind H v''' Hv'''. + erewrite translate_to_word by eassumption. + erewrite translate_to_word by eassumption. + erewrite translate_to_bool by eassumption. + + unfold sopn_sem in H. + simpl in H. + noconf H. + + reflexivity. + - apply app_sopn_nil_ok_size in H as Hs. + simpl in Hs. + simpl in *. + destruct asmop. + simpl in *. + Admitted. + Lemma app_sopn_list_correct (op : opN) (v : sem_t (type_of_opN op).2) (vs : values) : app_sopn (type_of_opN op).1 (sem_opN_typed op) vs = ok v → app_sopn_list From d6796e2a736973f363cc0c70367aa9365f7f4a1d Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Tue, 3 May 2022 14:20:55 +0200 Subject: [PATCH 191/383] added comments --- theories/Jasmin/jasmin_translate.v | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 70facc3d..7e95f3a6 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1104,6 +1104,7 @@ Definition embed_ot {t} : sem_ot t → encode t := | sword n => λ x, x end. +(* takes a tuple of jasmin values and embeds each component *) Fixpoint embed_tuple {ts} : sem_tuple ts -> lchtuple [seq encode t | t <- ts] := match ts as ts0 return sem_tuple ts0 -> lchtuple [seq encode t | t <- ts0] with | [::] => λ (_ : unit), tt @@ -1116,6 +1117,11 @@ Fixpoint embed_tuple {ts} : sem_tuple ts -> lchtuple [seq encode t | t <- ts] := end rec end. +(* this correcsponds to app_sopn, in the case where applied function can have several return values, + as opposed to app_sopn_list which is used in the case where there is only one return value + (e.g. in expressions). In jasmin they manage to only have one function (app_sopn) for these two + use cases; i'm unsure if we can do the same + *) Fixpoint app_sopn_list_tuple {ts_out : list stype} (ts_in : list stype) := match ts_in as ts0 return (sem_prod ts0 (exec (sem_tuple ts_out))) → [choiceType of list typed_chElement] → lchtuple ([seq encode t | t <- ts_out]) with | [::] => From 5187318fadd0f022df3c78d35fbb7e77c158173f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Tue, 3 May 2022 14:42:57 +0200 Subject: [PATCH 192/383] Nits --- theories/Jasmin/jasmin_translate.v | 108 +++++++++++++++++------------ 1 file changed, 62 insertions(+), 46 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 7e95f3a6..1d1b1379 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -360,7 +360,9 @@ Definition unembed {t : stype} : encode t → sem_t t := | sbool => λ x, x | sint => λ x, x | sarr n => λ x, - foldr (λ kv m, {| WArray.arr_data := Mz.set m.(WArray.arr_data) kv.1 kv.2 |}) (WArray.empty _) x + foldr (λ kv m, + {| WArray.arr_data := Mz.set m.(WArray.arr_data) kv.1 kv.2 |} + ) (WArray.empty _) x (* (λ kv m, Let m' := m in WArray.set8 m' kv.1 kv.2) *) (* (Ok _ (WArray.empty _)) x *) | sword n => λ x, x @@ -1105,16 +1107,21 @@ Definition embed_ot {t} : sem_ot t → encode t := end. (* takes a tuple of jasmin values and embeds each component *) -Fixpoint embed_tuple {ts} : sem_tuple ts -> lchtuple [seq encode t | t <- ts] := - match ts as ts0 return sem_tuple ts0 -> lchtuple [seq encode t | t <- ts0] with +Fixpoint embed_tuple {ts} : sem_tuple ts → lchtuple [seq encode t | t <- ts] := + match ts as ts0 + return sem_tuple ts0 -> lchtuple [seq encode t | t <- ts0] + with | [::] => λ (_ : unit), tt - | t' :: ts' => let rec := @embed_tuple ts' in - match ts' as ts'0 return - (sem_tuple ts'0 -> lchtuple [seq encode t | t <- ts'0]) -> - sem_tuple (t'::ts'0) -> lchtuple [seq encode t | t <- (t'::ts'0)] with - | [::] => λ _ (v : sem_ot t'), embed_ot v - | t'' :: ts'' => λ rec (p : (sem_ot t') * (sem_tuple (t''::ts''))), (embed_ot p.1, rec p.2) - end rec + | t' :: ts' => + let rec := @embed_tuple ts' in + match ts' as ts'0 + return + (sem_tuple ts'0 -> lchtuple [seq encode t | t <- ts'0]) → + sem_tuple (t'::ts'0) -> lchtuple [seq encode t | t <- (t'::ts'0)] + with + | [::] => λ _ (v : sem_ot t'), embed_ot v + | t'' :: ts'' => λ rec (p : (sem_ot t') * (sem_tuple (t''::ts''))), (embed_ot p.1, rec p.2) + end rec end. (* this correcsponds to app_sopn, in the case where applied function can have several return values, @@ -1123,16 +1130,17 @@ Fixpoint embed_tuple {ts} : sem_tuple ts -> lchtuple [seq encode t | t <- ts] := use cases; i'm unsure if we can do the same *) Fixpoint app_sopn_list_tuple {ts_out : list stype} (ts_in : list stype) := - match ts_in as ts0 return (sem_prod ts0 (exec (sem_tuple ts_out))) → [choiceType of list typed_chElement] → lchtuple ([seq encode t | t <- ts_out]) with + match ts_in as ts0 + return + (sem_prod ts0 (exec (sem_tuple ts_out))) → + [choiceType of list typed_chElement] → + lchtuple ([seq encode t | t <- ts_out]) + with | [::] => λ (o : exec (sem_tuple ts_out)) (vs : list typed_chElement), - match vs with - | [::] => - match o with - | Ok o => embed_tuple o - | _ => chCanonical _ - end - | _ :: _ => chCanonical _ + match vs, o with + | [::], Ok o => embed_tuple o + | _, _ => chCanonical _ end | t :: ts0 => λ (o : sem_t t → sem_prod ts0 (exec (sem_tuple ts_out))) (vs : list typed_chElement), @@ -1143,16 +1151,25 @@ Fixpoint app_sopn_list_tuple {ts_out : list stype} (ts_in : list stype) := end. (* list_ltuple *) -Fixpoint list_lchtuple {ts} : lchtuple ([seq encode t | t <- ts]) -> [choiceType of list typed_chElement] := - match ts as ts0 return lchtuple ([seq encode t | t <- ts0]) -> [choiceType of list typed_chElement] with +Fixpoint list_lchtuple {ts} : lchtuple ([seq encode t | t <- ts]) → [choiceType of list typed_chElement] := + match ts as ts0 + return + lchtuple ([seq encode t | t <- ts0]) → + [choiceType of list typed_chElement] + with | [::] => λ _, [::] - | t' :: ts' => let rec := @list_lchtuple ts' in - match ts' as ts'0 return - (lchtuple ([seq encode t | t <- ts'0]) -> [choiceType of list typed_chElement]) - -> lchtuple [seq encode t | t <- (t'::ts'0)] -> [choiceType of list typed_chElement] with - | [::] => λ _ (v : encode t'), [:: totce v] - | t'' :: ts'' => λ rec (p : (encode t') × (lchtuple [seq encode t | t <- (t''::ts'')])), totce p.1 :: rec p.2 - end rec + | t' :: ts' => + let rec := @list_lchtuple ts' in + match ts' as ts'0 + return + (lchtuple ([seq encode t | t <- ts'0]) → + [choiceType of list typed_chElement]) → + lchtuple [seq encode t | t <- (t'::ts'0)] → + [choiceType of list typed_chElement] + with + | [::] => λ _ (v : encode t'), [:: totce v] + | t'' :: ts'' => λ rec (p : (encode t') × (lchtuple [seq encode t | t <- (t''::ts'')])), totce p.1 :: rec p.2 + end rec end. (* corresponds to exec_sopn *) @@ -2044,10 +2061,10 @@ Proof. Qed. Definition WArray_ext_eq {len} (a b : WArray.array len) := - forall i, Mz.get a.(WArray.arr_data) i = Mz.get b.(WArray.arr_data) i. + ∀ i, Mz.get a.(WArray.arr_data) i = Mz.get b.(WArray.arr_data) i. -Notation "a =e b" := (WArray_ext_eq a b) (at level 90). -Notation "(=e)" := WArray_ext_eq (only parsing). +Notation "a =ₑ b" := (WArray_ext_eq a b) (at level 90). +Notation "(=ₑ)" := WArray_ext_eq (only parsing). Instance WArray_ext_eq_equiv {len} : Equivalence (@WArray_ext_eq len). Proof. @@ -2072,7 +2089,7 @@ Qed. Lemma embed_unembed {t} (a : encode t) : embed (unembed a) = a. Proof. - destruct t; try reflexivity. + destruct t. 1,2,4: reflexivity. apply eq_fmap. intros x. unfold embed, embed_array, unembed. @@ -2096,7 +2113,7 @@ Proof. Qed. Lemma unembed_embed {len} (a : sem_t (sarr len)) : - unembed (embed a) =e a. + unembed (embed a) =ₑ a. Proof. intros x. rewrite <- embed_array_get. @@ -2107,21 +2124,21 @@ Proof. reflexivity. Qed. -Instance unembed_embed_Proper {len} : Proper ((=e) ==> (=e)) (λ (a : sem_t (sarr len)), unembed (embed a)). +Instance unembed_embed_Proper {len} : Proper ((=ₑ) ==> (=ₑ)) (λ (a : sem_t (sarr len)), unembed (embed a)). Proof. intros x y H. rewrite !unembed_embed. assumption. Qed. -Instance WArray_get8_Proper {len} : Proper ((=e) ==> eq ==> eq) (@WArray.get8 len). +Instance WArray_get8_Proper {len} : Proper ((=ₑ) ==> eq ==> eq) (@WArray.get8 len). intros a b H ? ? Hi. unfold WArray.get8, WArray.in_bound, WArray.is_init. rewrite H Hi. reflexivity. Qed. -Instance WArray_get_Proper {len ws} : Proper ((=e) ==> eq ==> eq) (@WArray.get len AAscale ws). +Instance WArray_get_Proper {len ws} : Proper ((=ₑ) ==> eq ==> eq) (@WArray.get len AAscale ws). Proof. intros a b H i j Hij. unfold WArray.get, read. @@ -2145,7 +2162,7 @@ Proof. Qed. Lemma in_rcons_l {S : eqType} (a b : S) l : - a \in l -> a \in rcons l b. + a \in l → a \in rcons l b. Proof. induction l. - easy. @@ -2163,20 +2180,19 @@ Proof. apply IHl; assumption. Qed. -Lemma foldM_rcons eT (aT: eqType) bT (f: aT -> bT -> result eT bT) (a:aT) (b:bT) (l:list aT) : +Lemma foldM_rcons eT (aT: eqType) bT (f: aT → bT → result eT bT) (a:aT) (b:bT) (l:list aT) : foldM f b (rcons l a) = Let b' := foldM f b l in f a b'. Proof. - revert a b. - induction l; intros. - - simpl; destruct (f a b); reflexivity. + induction l as [| c l ih] in a, b |- *. + - simpl. destruct (f a b). all: reflexivity. - simpl. - destruct (f a b). - + simpl. rewrite IHl. reflexivity. + destruct (f c b). + + simpl. rewrite ih. reflexivity. + reflexivity. Qed. -Lemma eq_foldM eT (aT: eqType) bT (f1 f2: aT -> bT -> result eT bT) (b:bT) (l:list aT) : - (forall a b, a \in l -> f1 a b = f2 a b) -> +Lemma eq_foldM eT (aT: eqType) bT (f1 f2: aT → bT → result eT bT) (b:bT) (l:list aT) : + (∀ a b, a \in l → f1 a b = f2 a b) → foldM f1 b l = foldM f2 b l. Proof. replace l with (rev (rev l)) by (apply revK). @@ -2196,7 +2212,7 @@ Proof. assumption. Qed. -Instance WArray_copy_Proper {ws p} : Proper ((=e) ==> eq) (@WArray.copy ws p). +Instance WArray_copy_Proper {ws p} : Proper ((=ₑ) ==> eq) (@WArray.copy ws p). Proof. intros a b H. unfold WArray.copy, WArray.fcopy. @@ -2300,7 +2316,7 @@ Proof. simpl in *. destruct asmop. simpl in *. - Admitted. +Admitted. Lemma app_sopn_list_correct (op : opN) (v : sem_t (type_of_opN op).2) (vs : values) : app_sopn (type_of_opN op).1 (sem_opN_typed op) vs = ok v → From f52fb947e14520b9a7abc386a532f2dc7dfae5a3 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Tue, 3 May 2022 14:50:06 +0200 Subject: [PATCH 193/383] implement `Copn` case of translate_instr --- theories/Jasmin/jasmin_translate.v | 27 +++++++++++++++++++-------- 1 file changed, 19 insertions(+), 8 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 7e95f3a6..dd4dd3f4 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1159,6 +1159,16 @@ Fixpoint list_lchtuple {ts} : lchtuple ([seq encode t | t <- ts]) -> [choiceType Definition translate_exec_sopn (o : sopn) (vs : seq typed_chElement) := list_lchtuple (app_sopn_list_tuple _ (sopn_sem o) vs). +Fixpoint translate_write_lvals (fn : funname) (ls : lvals) (vs : list typed_chElement) := + match ls with + | [::] => ret tt + | l :: ls => match vs with + | [::] => ret tt + | v :: vs => translate_write_lval fn l v ;; + translate_write_lvals fn ls vs + end + end. + Fixpoint translate_instr_r (prog_exports : {fmap funname -> opsig}) (fn : funname) (i : instr_r) {struct i} : raw_code 'unit with translate_instr (prog_exports : {fmap funname -> opsig}) (fn : funname) (i : instr) {struct i} : raw_code 'unit := @@ -1175,14 +1185,19 @@ Proof. ) ). - destruct i as [ | | e c1 c2 | i [[d lo] hi] c | | ii xs f args ]. + destruct i as [ | ls _ o es | e c1 c2 | i [[d lo] hi] c | | ii xs f args ]. - (* Cassgn *) (* l :a=_s p *) pose (translate_pexpr fn p) as tr_p. eapply bind. 1: exact (tr_p.π2). intros v. pose (truncate_el s v) as tr_v. exact (translate_write_lval fn l (totce tr_v)). - - exact (unsupported.π2). (* Copn *) + - (* Copn *) + pose (cs := [seq (translate_pexpr fn e) | e <- es]). + pose (vs := bind_list cs). + eapply bind. 1: exact vs. intros bvs. + pose (out := translate_exec_sopn o bvs). + exact (translate_write_lvals fn ls out). (* BSH: I'm not sure if the outputs should be truncated? *) - (* Cif e c1 c2 *) pose (e' := translate_pexpr fn e). pose (c1' := translate_cmd fn c1). @@ -2295,12 +2310,8 @@ Proof. noconf H. reflexivity. - - apply app_sopn_nil_ok_size in H as Hs. - simpl in Hs. - simpl in *. - destruct asmop. - simpl in *. - Admitted. + (* assume this case is correct wrt to the chosen set of assemnly operations *) + - Admitted. Lemma app_sopn_list_correct (op : opN) (v : sem_t (type_of_opN op).2) (vs : values) : app_sopn (type_of_opN op).1 (sem_opN_typed op) vs = ok v → From 844986b54aaf04032c3aaeda23dd0506750ed12f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Tue, 3 May 2022 15:11:23 +0200 Subject: [PATCH 194/383] Define handled_program --- theories/Jasmin/jasmin_translate.v | 37 +++++++++++++++++++++++++++--- 1 file changed, 34 insertions(+), 3 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 74a5fbbc..a93e2afc 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -2778,9 +2778,40 @@ Definition exports_of_prog (p : ssprove_prog) : {fmap funname -> opsig} := emptym p. Definition translate_prog : ssprove_prog := - foldl (λ p f, let f' := translate_fundef (exports_of_prog p) f in - f' :: p) - [::] P.(p_funcs). + foldl (λ p f, + let f' := translate_fundef (exports_of_prog p) f in + f' :: p + ) [::] P.(p_funcs). + +(** Handled programs + + This predicate eliminates programs that are currently not supported by the + translation. This is mainly used to disallow while loops. +*) + +Fixpoint handled_instr (i : instr) := + match i with + | MkI ii i => handled_instr_r i + end + +with handled_instr_r (i : instr_r) := + match i with + | Cassgn l tag sty e => true + | Copn l tag o es => true + | Cif e c₁ c₂ => List.forallb handled_instr c₁ && List.forallb handled_instr c₂ + | Cfor i r c => List.forallb handled_instr c + | Cwhile al cb e c => false + | Ccall ii l fn es => true + end. + +Definition handled_cmd (c : cmd) := + List.forallb handled_instr c. + +Definition handled_fundecl (f : _ufun_decl) := + handled_cmd f.2.(f_body). + +Definition handled_program := + List.forallb handled_fundecl P.(p_funcs). Theorem translate_prog_correct (fn : funname) m va m' vr f : sem.sem_call P m fn va m' vr → From 9939cbd37c8f1308778b238327455c69eb183cec Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Tue, 3 May 2022 15:24:56 +0200 Subject: [PATCH 195/383] Use handled_program to deal with while case --- theories/Jasmin/jasmin_translate.v | 52 ++++++++++++++++-------------- 1 file changed, 27 insertions(+), 25 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index a93e2afc..e105261f 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -2814,6 +2814,7 @@ Definition handled_program := List.forallb handled_fundecl P.(p_funcs). Theorem translate_prog_correct (fn : funname) m va m' vr f : + handled_program → sem.sem_call P m fn va m' vr → let sp := translate_prog in let dom := lchtuple (map choice_type_of_val va) in @@ -2823,15 +2824,15 @@ Theorem translate_prog_correct (fn : funname) m va m' vr f : f (translate_values va) ⇓ translate_values vr ⦃ λ m, True ⦄. Proof. - intros H. + intros hP H. set (Pfun := λ (m : mem) (fn : funname) (va : seq value) (m' : mem) (vr : seq value), ∀ f, + handled_program → let sp := translate_prog in let dom := lchtuple [seq choice_type_of_val i | i <- va] in let cod := lchtuple [seq choice_type_of_val i | i <- vr] in get_fundef_ssp sp fn dom cod = Some f → - (* satisfies_globs (p_globs p) (translate_mem m, translate_mem m') → *) ⊢ ⦃ λ m, True ⦄ f (translate_values va) ⇓ translate_values vr ⦃ λ m, True ⦄ @@ -2839,17 +2840,20 @@ Proof. set (ep := exports_of_prog translate_prog). set (Pi_r := λ (s1 : estate) (i : instr_r) (s2 : estate), + handled_instr_r i → ⊢ ⦃ rel_estate s1 fn ⦄ translate_instr_r ep fn i ⇓ tt ⦃ rel_estate s2 fn ⦄ ). - set (Pi := λ s1 i s2, (Pi_r s1 (instr_d i) s2)). + set (Pi := λ s1 i s2, Pi_r s1 (instr_d i) s2). set (Pc := λ (s1 : estate) (c : cmd) (s2 : estate), + handled_cmd c → ⊢ ⦃ rel_estate s1 fn ⦄ translate_cmd ep fn c ⇓ tt ⦃ rel_estate s2 fn ⦄ ). set (Pfor := λ (v : var_i) (ws : seq Z) (s1 : estate) (c : cmd) (s2 : estate), + handled_cmd c → ⊢ ⦃ rel_estate s1 fn ⦄ translate_for fn v ws (translate_cmd ep fn c) ⇓ tt ⦃ rel_estate s2 fn ⦄ @@ -2857,20 +2861,21 @@ Proof. unshelve eapply (@sem_call_Ind _ _ _ _ Pc Pi_r Pi Pfor Pfun _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H). - (* nil *) red. intros s. - red. simpl. + red. simpl. intros _. eapply u_ret_eq. auto. - (* cons *) red. intros s1 s2 s3 i c hi ihi hc ihc. - red. simpl. + red. simpl. move /andP => [hdi hdc]. eapply u_bind. + rewrite translate_instr_unfold. eapply ihi. - + eassumption. + destruct i. apply hdi. + + apply ihc. assumption. - (* mkI *) red. intros ii i s1 s2 hi ihi. apply ihi. - (* assgn *) red. intros s₁ s₂ x tag ty e v v' he hv hw. - red. simpl. + red. simpl. intros _. eapply u_bind. 1:{ eapply translate_pexpr_correct. all: eauto. } erewrite translate_pexpr_type by eassumption. @@ -2882,37 +2887,33 @@ Proof. red. simpl. admit. - (* if_true *) red. intros s1 s2 e c1 c2 he hc1 ihc1. - red. simpl. + red. simpl. move /andP => [hdc1 hdc2]. lazymatch goal with | |- context [ if _ then ?f ?fn ?c else _ ] => change (f fn c) with (translate_cmd ep fn c) end. eapply u_bind. 1:{ eapply translate_pexpr_correct_cast in he. all: eauto. } - simpl. eapply ihc1. + simpl. apply ihc1. assumption. - (* if_false *) red. intros s1 s2 e c1 c2 he hc2 ihc2. - red. simpl. + red. simpl. move /andP => [hdc1 hdc2]. (* lazymatch goal with | |- context [ if _ then _ else (?f ?fn ?c) ] => change (f fn c) with (translate_cmd ep fn c) end. *) eapply u_bind. 1:{ eapply translate_pexpr_correct_cast in he. all: eauto. } - simpl. eapply ihc2. + simpl. apply ihc2. assumption. - (* while_true *) red. intros s1 s2 s3 s4 a c e c' hc ihc he hc' ihc' h ih. - red in ih. simpl in ih. - (* TODO Lemma to draw a contradiction from ih *) - admit. + red. simpl. discriminate. - (* while_false *) red. intros s1 s2 a c e c' hc ihc he. - red. simpl. - (* We could replace while by an if to solve this case *) - give_up. + red. simpl. discriminate. - (* for *) red. intros s1 s2 i d lo hi c vlo vhi hlo hhi hfor ihfor. - red. simpl. + red. simpl. intros hdc. lazymatch goal with | |- context [ translate_for _ _ _ (?f ?fn ?c) ] => change (f fn c) with (translate_cmd ep fn c) @@ -2921,28 +2922,29 @@ Proof. 1:{ eapply translate_pexpr_correct_cast in hlo. all: eauto. } eapply u_bind. 1:{ eapply translate_pexpr_correct_cast in hhi. all: eauto. } - apply ihfor. + apply ihfor. assumption. - (* for_nil *) - red. intros. red. + red. intros. red. intros hdc. simpl. apply u_ret_eq. auto. - (* for_cons *) red. intros s1 s1' s2 s3 i w ws c hw hc ihc hfor ihfor. - red. simpl. + red. simpl. intros hdc. eapply u_put. eapply u_bind. 1:{ red in ihc. eapply u_pre_weaken_rule. - 1: eapply ihc. + 1: eapply ihc. 1: assumption. intros ? [me [hme ?]]. subst. eapply translate_write_var_estate. all: eassumption. } - apply ihfor. + apply ihfor. assumption. - (* call *) red. intros s1 m2 s2 ii xs gn args vargs vs hargs hvs ihvs hw. - red. simpl. admit. + red. simpl. intros _. + admit. - red. intros m1 m2 gn g vs vs' s1 vm2 vrs vrs'. intros hg hvs ?????. - unfold Pfun. intros f' hf'. + unfold Pfun. intros f' hdp hf'. (* Maybe have a dedicated lemma linking to hg? *) unfold get_fundef_ssp in hf'. admit. From 26fb5138b0f473749c83d10f6204893aae9aead0 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Tue, 3 May 2022 18:25:05 +0200 Subject: [PATCH 196/383] prove `opn`; only admitted lemma `app_sopn_list_tuple_correct` --- theories/Jasmin/jasmin_translate.v | 139 ++++++++++++++++++++++++++--- 1 file changed, 129 insertions(+), 10 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 74a5fbbc..689a4ae4 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1100,7 +1100,11 @@ Fixpoint translate_for fn (i : var_i) (ws : seq Z) (c : raw_code 'unit) : raw_co Definition embed_ot {t} : sem_ot t → encode t := match t with - | sbool => λ x, x (* BSH: I'm not sure this will be correct? In jasmin this is an Option bool, perhaps because you don't have to specify all output flags *) + (* BSH: I'm not sure this will be correct? In jasmin this is an Option bool, perhaps because you don't have to specify all output flags *) + | sbool => λ x, match x with + | Some b => b + | None => false + end | sint => λ x, x | sarr n => embed_array | sword n => λ x, x @@ -1176,16 +1180,28 @@ Fixpoint list_lchtuple {ts} : lchtuple ([seq encode t | t <- ts]) → [choiceTyp Definition translate_exec_sopn (o : sopn) (vs : seq typed_chElement) := list_lchtuple (app_sopn_list_tuple _ (sopn_sem o) vs). -Fixpoint translate_write_lvals (fn : funname) (ls : lvals) (vs : list typed_chElement) := - match ls with - | [::] => ret tt - | l :: ls => match vs with - | [::] => ret tt - | v :: vs => translate_write_lval fn l v ;; - translate_write_lvals fn ls vs - end +Fixpoint foldl2 {A B R} (f : R -> A -> B -> R) (la : seq A) (lb : seq B) r := + match la with + | [::] => r + | a :: la0 => match lb with + | [::] => r + | b :: lb0 => foldl2 f la0 lb0 (f r a b) + end + end. + +Fixpoint foldr2 {A B R} (f : A -> B -> R -> R) (la : seq A) (lb : seq B) r := + match la with + | [::] => r + | a :: la0 => match lb with + | [::] => r + | b :: lb0 => f a b (foldr2 f la0 lb0 r) + end end. +Definition translate_write_lvals fn ls vs := + (* foldl2 (λ c l v, translate_write_lval fn l v ;; c) ls vs (ret tt). *) + foldr2 (λ l v c, translate_write_lval fn l v ;; c) ls vs (ret tt). + Fixpoint translate_instr_r (prog_exports : {fmap funname -> opsig}) (fn : funname) (i : instr_r) {struct i} : raw_code 'unit with translate_instr (prog_exports : {fmap funname -> opsig}) (fn : funname) (i : instr) {struct i} : raw_code 'unit := @@ -2329,6 +2345,46 @@ Proof. (* assume this case is correct wrt to the chosen set of assemnly operations *) - Admitted. +Lemma list_tuple_cons_cons {t1 t2 : stype} {ts : seq stype} (p : sem_tuple (t1 :: t2 :: ts)) : + list_ltuple p = (oto_val p.1) :: (list_ltuple (p.2 : sem_tuple (t2 :: ts))). +Proof. reflexivity. Qed. + +Lemma embed_tuple_cons_cons {t1 t2 : stype} {ts : seq stype} (p : sem_tuple (t1 :: t2 :: ts)) : + embed_tuple p = (embed_ot p.1, embed_tuple (p.2 : sem_tuple (t2 :: ts))). +Proof. reflexivity. Qed. + +Lemma list_lchtuple_cons_cons {t1 t2 : stype} {ts : seq stype} (p1 : encode t1) (p2 : lchtuple [seq encode t | t <- (t2 :: ts)]) : + list_lchtuple ((p1, p2) : lchtuple [seq encode t | t <- (t1 :: t2 :: ts)]) = (totce p1) :: (list_lchtuple p2). +Proof. reflexivity. Qed. + +Lemma translate_exec_sopn_correct (o : sopn) (ins outs : values) : + exec_sopn o ins = ok outs -> + translate_exec_sopn o [seq totce (translate_value v) | v <- ins] = [seq totce (translate_value v) | v <- outs]. +Proof. + intros. + unfold translate_exec_sopn. + jbind H vs Hvs. + noconf H. + erewrite app_sopn_list_tuple_correct by eassumption. + clear Hvs. + induction tout. + - reflexivity. + - destruct l. + + destruct a; destruct vs; reflexivity. + + rewrite list_tuple_cons_cons. + rewrite embed_tuple_cons_cons. + rewrite list_lchtuple_cons_cons. + rewrite map_cons. + rewrite IHl. + f_equal. + destruct vs; simpl. + destruct a. + * destruct s0; reflexivity. + * reflexivity. + * reflexivity. + * reflexivity. +Qed. + Lemma app_sopn_list_correct (op : opN) (v : sem_t (type_of_opN op).2) (vs : values) : app_sopn (type_of_opN op).1 (sem_opN_typed op) vs = ok v → app_sopn_list @@ -2771,6 +2827,37 @@ Proof. - admit. Admitted. +Lemma translate_write_lvals_cons fn l ls v vs : + translate_write_lvals fn (l :: ls) (v :: vs) = (translate_write_lval fn l v ;; translate_write_lvals fn ls vs). +Proof. reflexivity. Qed. + +Lemma translate_write_lvals_correct fn s1 ls vs s2 : + write_lvals gd s1 ls vs = ok s2 -> + ⊢ ⦃ rel_estate s1 fn ⦄ + translate_write_lvals fn ls [seq totce (translate_value v) | v <- vs] + ⇓ + tt + ⦃ rel_estate s2 fn ⦄. +Proof. + intros. + revert s1 vs H. + induction ls as [| l ls]; intros s1 vs H. + - destruct vs. 2: discriminate. + noconf H. + apply u_ret_eq. + easy. + - destruct vs. 1: inversion H. + inversion H. + jbind H1 s3 Hs3. + rewrite map_cons. + rewrite translate_write_lvals_cons. + eapply u_bind. + + eapply translate_write_lval_correct. + eassumption. + + apply IHls. + assumption. +Qed. + Definition ssprove_prog := seq (funname * fdef). Definition exports_of_prog (p : ssprove_prog) : {fmap funname -> opsig} := @@ -2848,7 +2935,39 @@ Proof. eapply translate_write_lval_correct. all: eauto. - (* opn *) red. intros s1 s2 tag o xs es ho. - red. simpl. admit. + red. simpl. + jbind ho vs hv. + jbind hv vs' hv'. + eapply u_bind. + + eapply bind_list_correct. + * rewrite <- map_comp. unfold comp. + eapply translate_pexprs_types. + eassumption. + * clear -vs' hv'. + revert vs' hv'. + induction es; intros vs hvs. + ** destruct vs. + *** constructor. + *** inversion hvs. + ** destruct vs. + *** inversion hvs. + jbind H0 vs' hvs'. + jbind H0 vs'' hvs''. + noconf H0. + *** inversion hvs. + jbind H0 vs' hvs'. + jbind H0 vs'' hvs''. + noconf H0. + rewrite map_cons. + constructor. + **** eapply translate_pexpr_correct. + 1: eassumption. + easy. + **** eapply IHes. + assumption. + + erewrite translate_exec_sopn_correct by eassumption. + apply translate_write_lvals_correct. + assumption. - (* if_true *) red. intros s1 s2 e c1 c2 he hc1 ihc1. red. simpl. From b91861e1b6dde2de0128b85f0f15e34bcfd6178c Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Tue, 3 May 2022 18:34:49 +0200 Subject: [PATCH 197/383] fix build --- theories/Jasmin/jasmin_translate.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 126ae331..1c9cb1d2 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -2970,7 +2970,7 @@ Proof. erewrite totce_truncate_translate by eassumption. eapply translate_write_lval_correct. all: eauto. - (* opn *) - red. intros s1 s2 tag o xs es ho. + red. intros s1 s2 tag o xs es ho _. red. simpl. jbind ho vs hv. jbind hv vs' hv'. From 23af57538b8d111548f22c4071bfc78e37102a0f Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Tue, 3 May 2022 20:33:41 +0200 Subject: [PATCH 198/383] refactor proof of `opn` --- theories/Jasmin/jasmin_translate.v | 50 +++++++++++++++++------------- 1 file changed, 28 insertions(+), 22 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 1c9cb1d2..f93515a6 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -2644,6 +2644,32 @@ Proof. apply translate_truncate_val. assumption. Qed. +Lemma translate_pexprs_correct fn s vs es : + sem_pexprs gd s es = ok vs -> + List.Forall2 (λ c v, ⊢ ⦃ rel_estate s fn ⦄ c.π2 ⇓ coerce_to_choice_type _ (translate_value v) ⦃ rel_estate s fn ⦄) [seq translate_pexpr fn e | e <- es] vs. +Proof. + revert vs. induction es; intros vs hvs. + - destruct vs. + + constructor. + + inversion hvs. + - destruct vs. + + inversion hvs. + jbind H0 vs' hvs'. + jbind H0 vs'' hvs''. + noconf H0. + + inversion hvs. + jbind H0 vs' hvs'. + jbind H0 vs'' hvs''. + noconf H0. + rewrite map_cons. + constructor. + * eapply translate_pexpr_correct. + 1: eassumption. + easy. + * eapply IHes. + assumption. +Qed. + Corollary translate_pexpr_correct_cast : ∀ fn (e : pexpr) s₁ v (cond : heap → Prop), sem_pexpr gd s₁ e = ok v → @@ -2979,28 +3005,8 @@ Proof. * rewrite <- map_comp. unfold comp. eapply translate_pexprs_types. eassumption. - * clear -vs' hv'. - revert vs' hv'. - induction es; intros vs hvs. - ** destruct vs. - *** constructor. - *** inversion hvs. - ** destruct vs. - *** inversion hvs. - jbind H0 vs' hvs'. - jbind H0 vs'' hvs''. - noconf H0. - *** inversion hvs. - jbind H0 vs' hvs'. - jbind H0 vs'' hvs''. - noconf H0. - rewrite map_cons. - constructor. - **** eapply translate_pexpr_correct. - 1: eassumption. - easy. - **** eapply IHes. - assumption. + * apply translate_pexprs_correct. + assumption. + erewrite translate_exec_sopn_correct by eassumption. apply translate_write_lvals_correct. assumption. From b341a195893ca61417f565e7bd434b99672c7a8c Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Tue, 3 May 2022 23:39:18 +0200 Subject: [PATCH 199/383] added `asmop_correct` to context and begun proving it for x86 --- theories/Jasmin/jasmin_translate.v | 91 +++++++++++++++++++++++++----- 1 file changed, 78 insertions(+), 13 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index f93515a6..e451430d 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -152,6 +152,13 @@ Proof. - intros [] []. intuition eauto. Qed. +(* Tactic to deal with Let _ := _ in _ = ok _ in assumption h *) +(* x and hx are introduced names for the value and its property *) +Ltac jbind h x hx := + eapply rbindP ; [| exact h ] ; + clear h ; intros x hx h ; + cbn beta in h. + Section Translation. Context `{asmop : asmOp}. @@ -164,13 +171,6 @@ Context (P : uprog). Notation gd := (p_globs P). -(* Tactic to deal with Let _ := _ in _ = ok _ in assumption h *) -(* x and hx are introduced names for the value and its property *) -Ltac jbind h x hx := - eapply rbindP ; [| exact h ] ; - clear h ; intros x hx h ; - cbn beta in h. - Notation " 'array " := (chMap 'int ('word U8)) (at level 2) : package_scope. Notation " 'array " := (chMap 'int ('word U8)) (in custom pack_type at level 2). Notation " 'mem " := (chMap ('word Uptr) ('word U8)) (at level 2) : package_scope. @@ -2097,7 +2097,7 @@ Definition WArray_ext_eq {len} (a b : WArray.array len) := Notation "a =ₑ b" := (WArray_ext_eq a b) (at level 90). Notation "(=ₑ)" := WArray_ext_eq (only parsing). -Instance WArray_ext_eq_equiv {len} : Equivalence (@WArray_ext_eq len). +Global Instance WArray_ext_eq_equiv {len} : Equivalence (@WArray_ext_eq len). Proof. split. - intros x. @@ -2155,21 +2155,21 @@ Proof. reflexivity. Qed. -Instance unembed_embed_Proper {len} : Proper ((=ₑ) ==> (=ₑ)) (λ (a : sem_t (sarr len)), unembed (embed a)). +Global Instance unembed_embed_Proper {len} : Proper ((=ₑ) ==> (=ₑ)) (λ (a : sem_t (sarr len)), unembed (embed a)). Proof. intros x y H. rewrite !unembed_embed. assumption. Qed. -Instance WArray_get8_Proper {len} : Proper ((=ₑ) ==> eq ==> eq) (@WArray.get8 len). +Global Instance WArray_get8_Proper {len} : Proper ((=ₑ) ==> eq ==> eq) (@WArray.get8 len). intros a b H ? ? Hi. unfold WArray.get8, WArray.in_bound, WArray.is_init. rewrite H Hi. reflexivity. Qed. -Instance WArray_get_Proper {len ws} : Proper ((=ₑ) ==> eq ==> eq) (@WArray.get len AAscale ws). +Global Instance WArray_get_Proper {len ws} : Proper ((=ₑ) ==> eq ==> eq) (@WArray.get len AAscale ws). Proof. intros a b H i j Hij. unfold WArray.get, read. @@ -2243,7 +2243,7 @@ Proof. assumption. Qed. -Instance WArray_copy_Proper {ws p} : Proper ((=ₑ) ==> eq) (@WArray.copy ws p). +Global Instance WArray_copy_Proper {ws p} : Proper ((=ₑ) ==> eq) (@WArray.copy ws p). Proof. intros a b H. unfold WArray.copy, WArray.fcopy. @@ -2253,6 +2253,9 @@ Proof. reflexivity. Qed. +Context `{ asmop_correct : forall o vs vs', app_sopn (tin (asm_op_instr o)) (sopn_sem (Oasm o)) vs = ok vs' + -> app_sopn_list_tuple (tin (asm_op_instr o)) (sopn_sem (Oasm o)) [seq totce (translate_value v) | v <- vs] = embed_tuple vs' }. + Lemma app_sopn_list_tuple_correct o vs vs' : app_sopn _ (sopn_sem o) vs = ok vs' → app_sopn_list_tuple @@ -2343,7 +2346,9 @@ Proof. reflexivity. (* assume this case is correct wrt to the chosen set of assemnly operations *) - - Admitted. + - apply asmop_correct. + assumption. +Qed. Lemma list_tuple_cons_cons {t1 t2 : stype} {ts : seq stype} (p : sem_tuple (t1 :: t2 :: ts)) : list_ltuple p = (oto_val p.1) :: (list_ltuple (p.2 : sem_tuple (t2 :: ts))). @@ -3076,3 +3081,63 @@ Proof. Admitted. End Translation. + +From Jasmin Require Import x86_instr_decl x86_extra x86_gen x86_linear_sem. +Import arch_decl. + +(* jbind with fresh names *) +Ltac jbind_fresh h := + eapply rbindP ; [| exact h ] ; + let x := fresh in + let hx := fresh in + clear h ; intros x hx h ; + cbn beta in h. + +Ltac solve_opn_intro vs H Hs := + repeat (destruct vs; [progress inversion Hs|]); + destruct vs; [|inversion Hs]; + simpl in *; + repeat jbind_fresh H; + noconf H. + +Ltac solve_opn_word vs H Hs := solve_opn_intro vs H Hs; + try (erewrite translate_to_word by eassumption); + reflexivity. + +Ltac solve_opn_inv vs H Hs := solve_opn_intro vs H Hs; + repeat match goal with + | b : bool |- _ => destruct b + | H : check_size_8_64 _ = _ |- _ => noconf H + | H : check_size_16_64 _ = _ |- _ => noconf H + | H : check_size_32_64 _ = _ |- _ => noconf H + | H : id_semi _ _ = _ |- _ => noconf H + | H : id_semi _ _ _ = _ |- _ => noconf H + | H : id_semi _ _ _ _ = _ |- _ => noconf H + | H : type_error = ok _ |- _ => discriminate + | H : ok _ = ok _ |- _ => noconf H + | _ => progress erewrite ?translate_to_word, ?translate_to_bool by eassumption + end; try reflexivity. + +Lemma x86_correct : + (∀ (o : asm_op_t) (vs : values) (vs' : sem_tuple (tout (sopn.get_instr_desc (Oasm o)))), + app_sopn (tin (asm_op_instr o)) (sopn_sem (Oasm o)) vs = ok vs' + → app_sopn_list_tuple (tin (asm_op_instr o)) (sopn_sem (Oasm o)) [seq to_typed_chElement (translate_value v) | v <- vs] = embed_tuple vs') . +Proof. + intros. + apply app_sopn_nil_ok_size in H as Hs. + simpl in Hs. + destruct o. + - destruct a. + destruct o. + + destruct x. + * destruct w, w0; solve_opn_inv vs H Hs. + * destruct w, w0, w1; solve_opn_inv vs H Hs. + * destruct w, w0, w1; solve_opn_inv vs H Hs. + * destruct w, w0; solve_opn_inv vs H Hs. + * destruct w, w0; solve_opn_inv vs H Hs. + * destruct w, w0; solve_opn_inv vs H Hs. + * destruct w, w0; solve_opn_inv vs H Hs. + * destruct w, w0; solve_opn_inv vs H Hs. + * destruct w, w0; solve_opn_inv vs H Hs. + * destruct w, w0; solve_opn_inv vs H Hs. + * Admitted. From dada9d42ded8636cbbc5618fbc3b9149fc30db70 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Wed, 4 May 2022 11:05:30 +0200 Subject: [PATCH 200/383] Style --- theories/Jasmin/jasmin_translate.v | 185 ++++++++++++++++------------- 1 file changed, 102 insertions(+), 83 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index e451430d..9649a55c 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1101,10 +1101,11 @@ Fixpoint translate_for fn (i : var_i) (ws : seq Z) (c : raw_code 'unit) : raw_co Definition embed_ot {t} : sem_ot t → encode t := match t with (* BSH: I'm not sure this will be correct? In jasmin this is an Option bool, perhaps because you don't have to specify all output flags *) - | sbool => λ x, match x with - | Some b => b - | None => false - end + | sbool => λ x, + match x with + | Some b => b + | None => false + end | sint => λ x, x | sarr n => embed_array | sword n => λ x, x @@ -1180,22 +1181,24 @@ Fixpoint list_lchtuple {ts} : lchtuple ([seq encode t | t <- ts]) → [choiceTyp Definition translate_exec_sopn (o : sopn) (vs : seq typed_chElement) := list_lchtuple (app_sopn_list_tuple _ (sopn_sem o) vs). -Fixpoint foldl2 {A B R} (f : R -> A -> B -> R) (la : seq A) (lb : seq B) r := +Fixpoint foldl2 {A B R} (f : R → A → B → R) (la : seq A) (lb : seq B) r := match la with | [::] => r - | a :: la0 => match lb with - | [::] => r - | b :: lb0 => foldl2 f la0 lb0 (f r a b) - end + | a :: la' => + match lb with + | [::] => r + | b :: lb' => foldl2 f la' lb' (f r a b) + end end. -Fixpoint foldr2 {A B R} (f : A -> B -> R -> R) (la : seq A) (lb : seq B) r := +Fixpoint foldr2 {A B R} (f : A → B → R → R) (la : seq A) (lb : seq B) r := match la with | [::] => r - | a :: la0 => match lb with - | [::] => r - | b :: lb0 => f a b (foldr2 f la0 lb0 r) - end + | a :: la' => + match lb with + | [::] => r + | b :: lb' => f a b (foldr2 f la' lb' r) + end end. Definition translate_write_lvals fn ls vs := @@ -2097,7 +2100,7 @@ Definition WArray_ext_eq {len} (a b : WArray.array len) := Notation "a =ₑ b" := (WArray_ext_eq a b) (at level 90). Notation "(=ₑ)" := WArray_ext_eq (only parsing). -Global Instance WArray_ext_eq_equiv {len} : Equivalence (@WArray_ext_eq len). +#[export] Instance WArray_ext_eq_equiv {len} : Equivalence (@WArray_ext_eq len). Proof. split. - intros x. @@ -2155,21 +2158,21 @@ Proof. reflexivity. Qed. -Global Instance unembed_embed_Proper {len} : Proper ((=ₑ) ==> (=ₑ)) (λ (a : sem_t (sarr len)), unembed (embed a)). +#[export] Instance unembed_embed_Proper {len} : Proper ((=ₑ) ==> (=ₑ)) (λ (a : sem_t (sarr len)), unembed (embed a)). Proof. intros x y H. rewrite !unembed_embed. assumption. Qed. -Global Instance WArray_get8_Proper {len} : Proper ((=ₑ) ==> eq ==> eq) (@WArray.get8 len). +#[export] Instance WArray_get8_Proper {len} : Proper ((=ₑ) ==> eq ==> eq) (@WArray.get8 len). intros a b H ? ? Hi. unfold WArray.get8, WArray.in_bound, WArray.is_init. rewrite H Hi. reflexivity. Qed. -Global Instance WArray_get_Proper {len ws} : Proper ((=ₑ) ==> eq ==> eq) (@WArray.get len AAscale ws). +#[export] Instance WArray_get_Proper {len ws} : Proper ((=ₑ) ==> eq ==> eq) (@WArray.get len AAscale ws). Proof. intros a b H i j Hij. unfold WArray.get, read. @@ -2243,7 +2246,7 @@ Proof. assumption. Qed. -Global Instance WArray_copy_Proper {ws p} : Proper ((=ₑ) ==> eq) (@WArray.copy ws p). +#[export] Instance WArray_copy_Proper {ws p} : Proper ((=ₑ) ==> eq) (@WArray.copy ws p). Proof. intros a b H. unfold WArray.copy, WArray.fcopy. @@ -2253,8 +2256,16 @@ Proof. reflexivity. Qed. -Context `{ asmop_correct : forall o vs vs', app_sopn (tin (asm_op_instr o)) (sopn_sem (Oasm o)) vs = ok vs' - -> app_sopn_list_tuple (tin (asm_op_instr o)) (sopn_sem (Oasm o)) [seq totce (translate_value v) | v <- vs] = embed_tuple vs' }. +Context { + asmop_correct : + ∀ o vs vs', + app_sopn (tin (asm_op_instr o)) (sopn_sem (Oasm o)) vs = ok vs' → + app_sopn_list_tuple + (tin (asm_op_instr o)) + (sopn_sem (Oasm o)) + [seq totce (translate_value v) | v <- vs] + = embed_tuple vs' +}. Lemma app_sopn_list_tuple_correct o vs vs' : app_sopn _ (sopn_sem o) vs = ok vs' → @@ -2345,7 +2356,7 @@ Proof. noconf H. reflexivity. - (* assume this case is correct wrt to the chosen set of assemnly operations *) + - apply asmop_correct. assumption. Qed. @@ -2363,10 +2374,11 @@ Lemma list_lchtuple_cons_cons {t1 t2 : stype} {ts : seq stype} (p1 : encode t1) Proof. reflexivity. Qed. Lemma translate_exec_sopn_correct (o : sopn) (ins outs : values) : - exec_sopn o ins = ok outs -> - translate_exec_sopn o [seq totce (translate_value v) | v <- ins] = [seq totce (translate_value v) | v <- outs]. + exec_sopn o ins = ok outs → + translate_exec_sopn o [seq totce (translate_value v) | v <- ins] = + [seq totce (translate_value v) | v <- outs]. Proof. - intros. + intros H. unfold translate_exec_sopn. jbind H vs Hvs. noconf H. @@ -2382,12 +2394,9 @@ Proof. rewrite map_cons. rewrite IHl. f_equal. - destruct vs; simpl. - destruct a. - * destruct s0; reflexivity. - * reflexivity. - * reflexivity. - * reflexivity. + destruct vs as [e es]. simpl. + destruct a. 2-4: reflexivity. + destruct e. all: reflexivity. Qed. Lemma app_sopn_list_correct (op : opN) (v : sem_t (type_of_opN op).2) (vs : values) : @@ -2650,27 +2659,32 @@ Proof. Qed. Lemma translate_pexprs_correct fn s vs es : - sem_pexprs gd s es = ok vs -> - List.Forall2 (λ c v, ⊢ ⦃ rel_estate s fn ⦄ c.π2 ⇓ coerce_to_choice_type _ (translate_value v) ⦃ rel_estate s fn ⦄) [seq translate_pexpr fn e | e <- es] vs. -Proof. - revert vs. induction es; intros vs hvs. + sem_pexprs gd s es = ok vs → + List.Forall2 (λ c v, + ⊢ ⦃ rel_estate s fn ⦄ + c.π2 + ⇓ coerce_to_choice_type _ (translate_value v) + ⦃ rel_estate s fn ⦄ + ) [seq translate_pexpr fn e | e <- es] vs. +Proof. + intro hvs. + induction es in vs, hvs |- *. - destruct vs. + constructor. + inversion hvs. - destruct vs. - + inversion hvs. - jbind H0 vs' hvs'. - jbind H0 vs'' hvs''. - noconf H0. - + inversion hvs. - jbind H0 vs' hvs'. - jbind H0 vs'' hvs''. - noconf H0. + + simpl in hvs. + jbind hvs vs' hvs'. + jbind hvs vs'' hvs''. + noconf hvs. + + simpl in hvs. + jbind hvs vs' hvs'. + jbind hvs vs'' hvs''. + noconf hvs. rewrite map_cons. constructor. - * eapply translate_pexpr_correct. - 1: eassumption. - easy. + * eapply translate_pexpr_correct. 1: eassumption. + auto. * eapply IHes. assumption. Qed. @@ -2863,23 +2877,20 @@ Lemma translate_write_lvals_cons fn l ls v vs : Proof. reflexivity. Qed. Lemma translate_write_lvals_correct fn s1 ls vs s2 : - write_lvals gd s1 ls vs = ok s2 -> + write_lvals gd s1 ls vs = ok s2 → ⊢ ⦃ rel_estate s1 fn ⦄ - translate_write_lvals fn ls [seq totce (translate_value v) | v <- vs] - ⇓ - tt + translate_write_lvals fn ls [seq totce (translate_value v) | v <- vs] + ⇓ tt ⦃ rel_estate s2 fn ⦄. Proof. - intros. - revert s1 vs H. - induction ls as [| l ls]; intros s1 vs H. + intros h. + induction ls as [| l ls] in s1, vs, h |- *. - destruct vs. 2: discriminate. - noconf H. - apply u_ret_eq. - easy. - - destruct vs. 1: inversion H. - inversion H. - jbind H1 s3 Hs3. + noconf h. + apply u_ret_eq. auto. + - destruct vs. 1: noconf h. + simpl in h. + jbind h s3 Hs3. rewrite map_cons. rewrite translate_write_lvals_cons. eapply u_bind. @@ -3100,36 +3111,43 @@ Ltac solve_opn_intro vs H Hs := repeat jbind_fresh H; noconf H. -Ltac solve_opn_word vs H Hs := solve_opn_intro vs H Hs; - try (erewrite translate_to_word by eassumption); - reflexivity. - -Ltac solve_opn_inv vs H Hs := solve_opn_intro vs H Hs; - repeat match goal with - | b : bool |- _ => destruct b - | H : check_size_8_64 _ = _ |- _ => noconf H - | H : check_size_16_64 _ = _ |- _ => noconf H - | H : check_size_32_64 _ = _ |- _ => noconf H - | H : id_semi _ _ = _ |- _ => noconf H - | H : id_semi _ _ _ = _ |- _ => noconf H - | H : id_semi _ _ _ _ = _ |- _ => noconf H - | H : type_error = ok _ |- _ => discriminate - | H : ok _ = ok _ |- _ => noconf H - | _ => progress erewrite ?translate_to_word, ?translate_to_bool by eassumption - end; try reflexivity. +Ltac solve_opn_word vs H Hs := + solve_opn_intro vs H Hs; + try (erewrite translate_to_word by eassumption); + reflexivity. + +Ltac solve_opn_inv vs H Hs := + solve_opn_intro vs H Hs; + repeat match goal with + | b : bool |- _ => destruct b + | H : check_size_8_64 _ = _ |- _ => noconf H + | H : check_size_16_64 _ = _ |- _ => noconf H + | H : check_size_32_64 _ = _ |- _ => noconf H + | H : id_semi _ _ = _ |- _ => noconf H + | H : id_semi _ _ _ = _ |- _ => noconf H + | H : id_semi _ _ _ _ = _ |- _ => noconf H + | H : type_error = ok _ |- _ => discriminate + | H : ok _ = ok _ |- _ => noconf H + | _ => progress erewrite ?translate_to_word, ?translate_to_bool by eassumption + end; try reflexivity. Lemma x86_correct : - (∀ (o : asm_op_t) (vs : values) (vs' : sem_tuple (tout (sopn.get_instr_desc (Oasm o)))), - app_sopn (tin (asm_op_instr o)) (sopn_sem (Oasm o)) vs = ok vs' - → app_sopn_list_tuple (tin (asm_op_instr o)) (sopn_sem (Oasm o)) [seq to_typed_chElement (translate_value v) | v <- vs] = embed_tuple vs') . -Proof. - intros. + ∀ (o : asm_op_t) (vs : values) (vs' : sem_tuple (tout (sopn.get_instr_desc (Oasm o)))), + app_sopn (tin (asm_op_instr o)) (sopn_sem (Oasm o)) vs = ok vs' → + app_sopn_list_tuple + (tin (asm_op_instr o)) + (sopn_sem (Oasm o)) + [seq to_typed_chElement (translate_value v) | v <- vs] + = embed_tuple vs'. +Proof. + intros o vs vs' H. apply app_sopn_nil_ok_size in H as Hs. simpl in Hs. destruct o. - destruct a. destruct o. - + destruct x. +(* Clearly this isn't the way we want to go. *) +(* + destruct x. * destruct w, w0; solve_opn_inv vs H Hs. * destruct w, w0, w1; solve_opn_inv vs H Hs. * destruct w, w0, w1; solve_opn_inv vs H Hs. @@ -3140,4 +3158,5 @@ Proof. * destruct w, w0; solve_opn_inv vs H Hs. * destruct w, w0; solve_opn_inv vs H Hs. * destruct w, w0; solve_opn_inv vs H Hs. - * Admitted. + * *) +Admitted. From efcb15ecd3cbcb0a2e491a42ad40c09c3857856d Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Wed, 4 May 2022 19:34:12 +0200 Subject: [PATCH 201/383] generalized translation of `app_sopn` and proved it correct - proved x86 semantics correct wrt our translation (see bottom of `jasmin_translate.v`) - unified the definition of `app_sopn_list` and `app_sopn_list_tuple` in `tr_app_sopn` --- theories/Jasmin/jasmin_translate.v | 391 +++++++++++------------------ 1 file changed, 153 insertions(+), 238 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 9649a55c..22297352 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -811,25 +811,25 @@ Proof. + exact (translate_value v, tr_vs). Defined. -Fixpoint app_sopn_list {S} (ts : list stype) := +Fixpoint tr_app_sopn {R} {S : R} (dec : R -> Type) (enc : R -> Type) (can : enc S) (emb : dec S -> enc S) (ts : list stype) := match ts as ts0 - return (sem_prod ts0 (exec (sem_t S)) → [choiceType of list typed_chElement] → encode S) + return (sem_prod ts0 (exec (dec S)) → [choiceType of list typed_chElement] → enc S) with | [::] => - λ (o : exec (sem_t S)) (vs : list typed_chElement), + λ (o : exec (dec S)) (vs : list typed_chElement), match vs with | [::] => match o with - | Ok o => embed o - | _ => chCanonical _ + | Ok o => emb o + | _ => can end - | _ :: _ => chCanonical _ + | _ :: _ => can end | t :: ts0 => - λ (o : sem_t t → sem_prod ts0 (exec (sem_t S))) (vs : list typed_chElement), + λ (o : sem_t t → sem_prod ts0 (exec (dec S))) (vs : list typed_chElement), match vs with - | [::] => chCanonical _ - | v :: vs0 => app_sopn_list ts0 (o (unembed (truncate_el t v.π2))) vs0 + | [::] => can + | v :: vs0 => tr_app_sopn dec enc can emb ts0 (o (unembed (truncate_el t v.π2))) vs0 end end. @@ -893,6 +893,41 @@ End bind_list_alt. Notation totce := to_typed_chElement. +Definition embed_ot {t} : sem_ot t → encode t := + match t with + (* BSH: I'm not sure this will be correct? In jasmin this is an Option bool, perhaps because you don't have to specify all output flags *) + | sbool => λ x, + match x with + | Some b => b + | None => false + end + | sint => λ x, x + | sarr n => embed_array + | sword n => λ x, x + end. + +(* takes a tuple of jasmin values and embeds each component *) +Fixpoint embed_tuple {ts} : sem_tuple ts → lchtuple [seq encode t | t <- ts] := + match ts as ts0 + return sem_tuple ts0 -> lchtuple [seq encode t | t <- ts0] + with + | [::] => λ (_ : unit), tt + | t' :: ts' => + let rec := @embed_tuple ts' in + match ts' as ts'0 + return + (sem_tuple ts'0 -> lchtuple [seq encode t | t <- ts'0]) → + sem_tuple (t'::ts'0) -> lchtuple [seq encode t | t <- (t'::ts'0)] + with + | [::] => λ _ (v : sem_ot t'), embed_ot v + | t'' :: ts'' => λ rec (p : (sem_ot t') * (sem_tuple (t''::ts''))), (embed_ot p.1, rec p.2) + end rec + end. + +(* tr_app_sopn specialized to when there is only one return value *) +Definition tr_app_sopn_single {S} := tr_app_sopn sem_t encode (chCanonical (encode S)) embed. +(* tr_app_sopn specialized to when there is several return values *) +Definition tr_app_sopn_tuple {ts_out} := tr_app_sopn sem_tuple (λ ts, lchtuple [seq encode t | t <- ts]) (chCanonical (lchtuple [seq encode t | t <- ts_out])) embed_tuple. (* Following sem_pexpr *) Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code := @@ -953,7 +988,7 @@ Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code := *) totc _ ( vs ← bind_list [seq translate_pexpr fn e | e <- es] ;; - ret (app_sopn_list (type_of_opN op).1 (sem_opN_typed op) vs) + ret (tr_app_sopn_single (type_of_opN op).1 (sem_opN_typed op) vs) ) | Pif t eb e1 e2 => totc _ ( @@ -1098,63 +1133,6 @@ Fixpoint translate_for fn (i : var_i) (ws : seq Z) (c : raw_code 'unit) : raw_co (* (* write_lvals the result of the call into lvals `l` *) *) -Definition embed_ot {t} : sem_ot t → encode t := - match t with - (* BSH: I'm not sure this will be correct? In jasmin this is an Option bool, perhaps because you don't have to specify all output flags *) - | sbool => λ x, - match x with - | Some b => b - | None => false - end - | sint => λ x, x - | sarr n => embed_array - | sword n => λ x, x - end. - -(* takes a tuple of jasmin values and embeds each component *) -Fixpoint embed_tuple {ts} : sem_tuple ts → lchtuple [seq encode t | t <- ts] := - match ts as ts0 - return sem_tuple ts0 -> lchtuple [seq encode t | t <- ts0] - with - | [::] => λ (_ : unit), tt - | t' :: ts' => - let rec := @embed_tuple ts' in - match ts' as ts'0 - return - (sem_tuple ts'0 -> lchtuple [seq encode t | t <- ts'0]) → - sem_tuple (t'::ts'0) -> lchtuple [seq encode t | t <- (t'::ts'0)] - with - | [::] => λ _ (v : sem_ot t'), embed_ot v - | t'' :: ts'' => λ rec (p : (sem_ot t') * (sem_tuple (t''::ts''))), (embed_ot p.1, rec p.2) - end rec - end. - -(* this correcsponds to app_sopn, in the case where applied function can have several return values, - as opposed to app_sopn_list which is used in the case where there is only one return value - (e.g. in expressions). In jasmin they manage to only have one function (app_sopn) for these two - use cases; i'm unsure if we can do the same - *) -Fixpoint app_sopn_list_tuple {ts_out : list stype} (ts_in : list stype) := - match ts_in as ts0 - return - (sem_prod ts0 (exec (sem_tuple ts_out))) → - [choiceType of list typed_chElement] → - lchtuple ([seq encode t | t <- ts_out]) - with - | [::] => - λ (o : exec (sem_tuple ts_out)) (vs : list typed_chElement), - match vs, o with - | [::], Ok o => embed_tuple o - | _, _ => chCanonical _ - end - | t :: ts0 => - λ (o : sem_t t → sem_prod ts0 (exec (sem_tuple ts_out))) (vs : list typed_chElement), - match vs with - | [::] => chCanonical _ - | v :: vs0 => app_sopn_list_tuple ts0 (o (unembed (truncate_el t v.π2))) vs0 - end - end. - (* list_ltuple *) Fixpoint list_lchtuple {ts} : lchtuple ([seq encode t | t <- ts]) → [choiceType of list typed_chElement] := match ts as ts0 @@ -1179,7 +1157,7 @@ Fixpoint list_lchtuple {ts} : lchtuple ([seq encode t | t <- ts]) → [choiceTyp (* corresponds to exec_sopn *) Definition translate_exec_sopn (o : sopn) (vs : seq typed_chElement) := - list_lchtuple (app_sopn_list_tuple _ (sopn_sem o) vs). + list_lchtuple (tr_app_sopn_tuple _ (sopn_sem o) vs). Fixpoint foldl2 {A B R} (f : R → A → B → R) (la : seq A) (lb : seq B) r := match la with @@ -2146,7 +2124,7 @@ Proof. eassumption. Qed. -Lemma unembed_embed {len} (a : sem_t (sarr len)) : +Lemma unembed_embed_sarr {len} (a : sem_t (sarr len)) : unembed (embed a) =ₑ a. Proof. intros x. @@ -2158,10 +2136,25 @@ Proof. reflexivity. Qed. +Lemma unembed_embed t a : + match t as t0 return sem_t t0 -> Prop with + | sbool => λ a, unembed (embed a) = a + | sint => λ a, unembed (embed a) = a + | sarr p => λ a, unembed (embed a) =ₑ a + | sword s => λ a, unembed (embed a) = a + end a. +Proof. + destruct t. + - reflexivity. + - reflexivity. + - apply unembed_embed_sarr. + - reflexivity. +Qed. + #[export] Instance unembed_embed_Proper {len} : Proper ((=ₑ) ==> (=ₑ)) (λ (a : sem_t (sarr len)), unembed (embed a)). Proof. intros x y H. - rewrite !unembed_embed. + rewrite !(unembed_embed (sarr len)). assumption. Qed. @@ -2256,122 +2249,82 @@ Proof. reflexivity. Qed. -Context { - asmop_correct : - ∀ o vs vs', - app_sopn (tin (asm_op_instr o)) (sopn_sem (Oasm o)) vs = ok vs' → - app_sopn_list_tuple - (tin (asm_op_instr o)) - (sopn_sem (Oasm o)) - [seq totce (translate_value v) | v <- vs] - = embed_tuple vs' -}. - -Lemma app_sopn_list_tuple_correct o vs vs' : - app_sopn _ (sopn_sem o) vs = ok vs' → - app_sopn_list_tuple - _ - (sopn_sem o) - [seq to_typed_chElement (translate_value v) | v <- vs] - = - embed_tuple vs'. -Proof. - intro H. - destruct o as [ ws p | | | | | ]. - - apply app_sopn_nil_ok_size in H as Hs. - simpl in Hs. - destruct vs. 1: inversion Hs. - destruct vs. 2: inversion Hs. - cbn -[wsize_size app_sopn_list_tuple]. - cbn [app_sopn_list_tuple]. - - jbind H vs'' Hv''. - simpl in H. - unfold sopn_sem in H. +(* BSH: I don't think these are necessary anymore *) +Lemma list_tuple_cons_cons {t1 t2 : stype} {ts : seq stype} (p : sem_tuple (t1 :: t2 :: ts)) : + list_ltuple p = (oto_val p.1) :: (list_ltuple (p.2 : sem_tuple (t2 :: ts))). +Proof. reflexivity. Qed. - cbn -[wsize_size WArray.copy unembed truncate_el]. - erewrite translate_of_val by eassumption. - rewrite coerce_to_choice_type_K. - rewrite translate_value_to_val. - rewrite eq_rect_r_K. - cbn -[wsize_size ziota] in H. - rewrite unembed_embed. - rewrite H. - reflexivity. - - simpl; destruct map; reflexivity. - - apply app_sopn_nil_ok_size in H as Hs. - simpl in Hs. - destruct vs. 1: inversion Hs. - destruct vs. 1: inversion Hs. - destruct vs. 2: inversion Hs. +Lemma embed_tuple_cons_cons {t1 t2 : stype} {ts : seq stype} (p : sem_tuple (t1 :: t2 :: ts)) : + embed_tuple p = (embed_ot p.1, embed_tuple (p.2 : sem_tuple (t2 :: ts))). +Proof. reflexivity. Qed. - simpl in *. - jbind H v' Hv'. - jbind H v'' Hv''. - erewrite translate_to_word by eassumption. - erewrite translate_to_word by eassumption. +Lemma list_lchtuple_cons_cons {t1 t2 : stype} {ts : seq stype} (p1 : encode t1) (p2 : lchtuple [seq encode t | t <- (t2 :: ts)]) : + list_lchtuple ((p1, p2) : lchtuple [seq encode t | t <- (t1 :: t2 :: ts)]) = (totce p1) :: (list_lchtuple p2). +Proof. reflexivity. Qed. - unfold sopn_sem in H. - simpl in H. - noconf H. +Lemma app_sopn_cons {rT} t ts v vs sem : + @app_sopn rT (t :: ts) sem (v :: vs) = Let v' := of_val t v in @app_sopn rT ts (sem v') vs. +Proof. reflexivity. Qed. - reflexivity. - - apply app_sopn_nil_ok_size in H as Hs. - simpl in Hs. - destruct vs. 1: inversion Hs. - destruct vs. 1: inversion Hs. - destruct vs. 1: inversion Hs. - destruct vs. 2: inversion Hs. +Lemma sem_prod_cons t ts S : + sem_prod (t :: ts) S = (sem_t t -> sem_prod ts S). +Proof. reflexivity. Qed. - simpl in *. - jbind H v' Hv'. - jbind H v'' Hv''. - jbind H v''' Hv'''. - erewrite translate_to_word by eassumption. - erewrite translate_to_word by eassumption. - erewrite translate_to_bool by eassumption. +Inductive sem_correct {R S} (enc : (R -> Type)) : forall (ts : (seq stype)), (sem_prod ts (exec (enc S))) -> Prop := +| sem_nil s : sem_correct enc [::] s +| sem_cons t ts s : (forall v, (s (unembed (embed v)) = s v)) -> (forall v, sem_correct enc ts (s v)) -> sem_correct enc (t :: ts) s. - unfold sopn_sem in H. +Lemma tr_app_sopn_correct {R S} (enc dec : R -> Type) (can : dec S) emb ts vs vs' (s : sem_prod ts (exec (enc S))) : + sem_correct enc ts s -> + app_sopn ts s vs = ok vs' → + tr_app_sopn enc dec can emb ts s [seq to_typed_chElement (translate_value v) | v <- vs] + = emb vs'. +Proof. + intros s_correct H. + induction ts as [|t ts'] in s, vs, vs', s_correct, H |- *. + - destruct vs. 2: discriminate. + destruct s. 2: discriminate. + noconf H. reflexivity. + - destruct vs. 1: discriminate. simpl in H. - noconf H. - - reflexivity. - - apply app_sopn_nil_ok_size in H as Hs. - simpl in Hs. - destruct vs. 1: inversion Hs. - destruct vs. 1: inversion Hs. - destruct vs. 1: inversion Hs. - destruct vs. 2: inversion Hs. - - simpl in *. jbind H v' Hv'. - jbind H v'' Hv''. - jbind H v''' Hv'''. - erewrite translate_to_word by eassumption. - erewrite translate_to_word by eassumption. - erewrite translate_to_bool by eassumption. - - unfold sopn_sem in H. - simpl in H. - noconf H. - - reflexivity. - - - apply asmop_correct. + simpl in *. + specialize (IHts' vs vs' (s v')). + inversion s_correct. + apply Eqdep.EqdepTheory.inj_pairT2 in H3. + subst. + erewrite translate_of_val by eassumption. + rewrite coerce_to_choice_type_translate_value_to_val. + rewrite H2. + apply IHts'. + 1: apply H4. assumption. Qed. -Lemma list_tuple_cons_cons {t1 t2 : stype} {ts : seq stype} (p : sem_tuple (t1 :: t2 :: ts)) : - list_ltuple p = (oto_val p.1) :: (list_ltuple (p.2 : sem_tuple (t2 :: ts))). -Proof. reflexivity. Qed. +Context `{asm_correct : forall o, sem_correct sem_tuple (tin (get_instr_desc (Oasm o))) (sopn_sem (Oasm o))}. -Lemma embed_tuple_cons_cons {t1 t2 : stype} {ts : seq stype} (p : sem_tuple (t1 :: t2 :: ts)) : - embed_tuple p = (embed_ot p.1, embed_tuple (p.2 : sem_tuple (t2 :: ts))). -Proof. reflexivity. Qed. - -Lemma list_lchtuple_cons_cons {t1 t2 : stype} {ts : seq stype} (p1 : encode t1) (p2 : lchtuple [seq encode t | t <- (t2 :: ts)]) : - list_lchtuple ((p1, p2) : lchtuple [seq encode t | t <- (t1 :: t2 :: ts)]) = (totce p1) :: (list_lchtuple p2). -Proof. reflexivity. Qed. +Lemma app_sopn_list_tuple_correct o vs vs' : + app_sopn _ (sopn_sem o) vs = ok vs' → + tr_app_sopn_tuple _ (sopn_sem o) [seq to_typed_chElement (translate_value v) | v <- vs] + = + embed_tuple vs'. +Proof. + intros. + unfold tr_app_sopn_tuple. + erewrite tr_app_sopn_correct. + - reflexivity. + - destruct o. + + repeat constructor. + cbn -[wsize_size WArray.copy unembed embed truncate_el] in *; intros. + rewrite (unembed_embed (sarr _)). + reflexivity. + + repeat constructor. + + repeat constructor. + + repeat constructor. + + repeat constructor. + + apply asm_correct. + - assumption. +Qed. Lemma translate_exec_sopn_correct (o : sopn) (ins outs : values) : exec_sopn o ins = ok outs → @@ -2399,9 +2352,9 @@ Proof. destruct e. all: reflexivity. Qed. -Lemma app_sopn_list_correct (op : opN) (v : sem_t (type_of_opN op).2) (vs : values) : +Lemma tr_app_sopn_single_correct (op : opN) (v : sem_t (type_of_opN op).2) (vs : values) : app_sopn (type_of_opN op).1 (sem_opN_typed op) vs = ok v → - app_sopn_list + tr_app_sopn_single (type_of_opN op).1 (sem_opN_typed op) [seq to_typed_chElement (translate_value v) | v <- vs] @@ -2409,6 +2362,7 @@ Lemma app_sopn_list_correct (op : opN) (v : sem_t (type_of_opN op).2) (vs : valu embed v. Proof. intro H. + unfold tr_app_sopn_single. destruct op as [w p | c]. - simpl in *. apply app_sopn_nil_ok_size in H as hl. @@ -2628,7 +2582,7 @@ Proof. + apply u_ret. intros; split; auto. rewrite coerce_to_choice_type_translate_value_to_val. - apply app_sopn_list_correct. + apply tr_app_sopn_single_correct. assumption. - (* Pif *) simpl in h1. jbind h1 b eb. jbind eb b' eb'. @@ -3096,67 +3050,28 @@ End Translation. From Jasmin Require Import x86_instr_decl x86_extra x86_gen x86_linear_sem. Import arch_decl. -(* jbind with fresh names *) -Ltac jbind_fresh h := - eapply rbindP ; [| exact h ] ; - let x := fresh in - let hx := fresh in - clear h ; intros x hx h ; - cbn beta in h. - -Ltac solve_opn_intro vs H Hs := - repeat (destruct vs; [progress inversion Hs|]); - destruct vs; [|inversion Hs]; - simpl in *; - repeat jbind_fresh H; - noconf H. - -Ltac solve_opn_word vs H Hs := - solve_opn_intro vs H Hs; - try (erewrite translate_to_word by eassumption); - reflexivity. - -Ltac solve_opn_inv vs H Hs := - solve_opn_intro vs H Hs; - repeat match goal with - | b : bool |- _ => destruct b - | H : check_size_8_64 _ = _ |- _ => noconf H - | H : check_size_16_64 _ = _ |- _ => noconf H - | H : check_size_32_64 _ = _ |- _ => noconf H - | H : id_semi _ _ = _ |- _ => noconf H - | H : id_semi _ _ _ = _ |- _ => noconf H - | H : id_semi _ _ _ _ = _ |- _ => noconf H - | H : type_error = ok _ |- _ => discriminate - | H : ok _ = ok _ |- _ => noconf H - | _ => progress erewrite ?translate_to_word, ?translate_to_bool by eassumption - end; try reflexivity. - -Lemma x86_correct : - ∀ (o : asm_op_t) (vs : values) (vs' : sem_tuple (tout (sopn.get_instr_desc (Oasm o)))), - app_sopn (tin (asm_op_instr o)) (sopn_sem (Oasm o)) vs = ok vs' → - app_sopn_list_tuple - (tin (asm_op_instr o)) - (sopn_sem (Oasm o)) - [seq to_typed_chElement (translate_value v) | v <- vs] - = embed_tuple vs'. -Proof. - intros o vs vs' H. - apply app_sopn_nil_ok_size in H as Hs. - simpl in Hs. +(* this is a stupid proof, since the only thing it does, is that it realizes all assembly instructions are defined on words + FIXME: do better +*) +Lemma x86_correct : ∀ (o : asm_op_t), sem_correct sem_tuple (tin (sopn.get_instr_desc (Oasm o))) (sopn_sem (Oasm o)). +Proof. + intros. + simpl. destruct o. - destruct a. destruct o. -(* Clearly this isn't the way we want to go. *) -(* + destruct x. - * destruct w, w0; solve_opn_inv vs H Hs. - * destruct w, w0, w1; solve_opn_inv vs H Hs. - * destruct w, w0, w1; solve_opn_inv vs H Hs. - * destruct w, w0; solve_opn_inv vs H Hs. - * destruct w, w0; solve_opn_inv vs H Hs. - * destruct w, w0; solve_opn_inv vs H Hs. - * destruct w, w0; solve_opn_inv vs H Hs. - * destruct w, w0; solve_opn_inv vs H Hs. - * destruct w, w0; solve_opn_inv vs H Hs. - * destruct w, w0; solve_opn_inv vs H Hs. - * *) -Admitted. +(* + destruct x; *) +(* repeat match goal with *) +(* | w : wsize |- _ => destruct w *) +(* end; repeat constructor. *) +(* + destruct x; *) +(* repeat match goal with *) +(* | w : wsize |- _ => destruct w *) +(* end; repeat constructor. *) +(* - destruct e; *) +(* repeat match goal with *) +(* | w : wsize |- _ => destruct w *) +(* end; repeat constructor. *) +(* Qed. *) + (* admitted for efficiency (the proof takes approx ~30 to execute) *) +Admitted From bc78fb188e2c8611542cd6d775495a071e2931f9 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Thu, 5 May 2022 09:42:33 +0200 Subject: [PATCH 202/383] simplify subproof of `tr_app_sopn_single_correct` --- theories/Jasmin/jasmin_translate.v | 13 ++++--------- 1 file changed, 4 insertions(+), 9 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 22297352..a75deed7 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -2374,15 +2374,10 @@ Proof. + simpl in *. jbind H v1 hv1. eapply ih. eapply translate_to_int in hv1. rewrite hv1. assumption. - - simpl in *. - repeat (destruct vs; [repeat jbind_fresh H; discriminate|]). - destruct vs. 2: repeat jbind_fresh H; discriminate. - repeat jbind_fresh H. - inversion H. - destruct (cf_tbl c) as [[] []]. - all: simpl in *; erewrite translate_to_bool; [|eassumption]; try reflexivity. - all: erewrite translate_to_bool; [|eassumption]; try reflexivity. - all: erewrite translate_to_bool; [|eassumption]; try reflexivity. + - erewrite tr_app_sopn_correct. + + reflexivity. + + repeat constructor. + + assumption. Qed. Lemma translate_pexpr_correct : From 7bfeaa1f1e7a00f6507b47a71c9681fbcd8250b3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 5 May 2022 10:25:42 +0200 Subject: [PATCH 203/383] Simplify tr_app_sopn_correct + style --- theories/Jasmin/jasmin_translate.v | 64 +++++++++++++++--------------- 1 file changed, 33 insertions(+), 31 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index a75deed7..8f05db77 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -811,9 +811,9 @@ Proof. + exact (translate_value v, tr_vs). Defined. -Fixpoint tr_app_sopn {R} {S : R} (dec : R -> Type) (enc : R -> Type) (can : enc S) (emb : dec S -> enc S) (ts : list stype) := - match ts as ts0 - return (sem_prod ts0 (exec (dec S)) → [choiceType of list typed_chElement] → enc S) +Fixpoint tr_app_sopn {R} {S : R} (dec : R → Type) (enc : R → Type) (can : enc S) (emb : dec S → enc S) (ts : list stype) := + match ts as ts' + return (sem_prod ts' (exec (dec S)) → [choiceType of list typed_chElement] → enc S) with | [::] => λ (o : exec (dec S)) (vs : list typed_chElement), @@ -825,11 +825,11 @@ Fixpoint tr_app_sopn {R} {S : R} (dec : R -> Type) (enc : R -> Type) (can : enc end | _ :: _ => can end - | t :: ts0 => - λ (o : sem_t t → sem_prod ts0 (exec (dec S))) (vs : list typed_chElement), + | t :: ts' => + λ (o : sem_t t → sem_prod ts' (exec (dec S))) (vs : list typed_chElement), match vs with | [::] => can - | v :: vs0 => tr_app_sopn dec enc can emb ts0 (o (unembed (truncate_el t v.π2))) vs0 + | v :: vs' => tr_app_sopn dec enc can emb ts' (o (unembed (truncate_el t v.π2))) vs' end end. @@ -925,9 +925,15 @@ Fixpoint embed_tuple {ts} : sem_tuple ts → lchtuple [seq encode t | t <- ts] : end. (* tr_app_sopn specialized to when there is only one return value *) -Definition tr_app_sopn_single {S} := tr_app_sopn sem_t encode (chCanonical (encode S)) embed. +Definition tr_app_sopn_single {S} := + tr_app_sopn sem_t encode (chCanonical (encode S)) embed. + (* tr_app_sopn specialized to when there is several return values *) -Definition tr_app_sopn_tuple {ts_out} := tr_app_sopn sem_tuple (λ ts, lchtuple [seq encode t | t <- ts]) (chCanonical (lchtuple [seq encode t | t <- ts_out])) embed_tuple. +Definition tr_app_sopn_tuple {ts_out} := + tr_app_sopn sem_tuple + (λ ts, lchtuple [seq encode t | t <- ts]) + (chCanonical (lchtuple [seq encode t | t <- ts_out])) + embed_tuple. (* Following sem_pexpr *) Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code := @@ -2263,45 +2269,41 @@ Lemma list_lchtuple_cons_cons {t1 t2 : stype} {ts : seq stype} (p1 : encode t1) Proof. reflexivity. Qed. Lemma app_sopn_cons {rT} t ts v vs sem : - @app_sopn rT (t :: ts) sem (v :: vs) = Let v' := of_val t v in @app_sopn rT ts (sem v') vs. + @app_sopn rT (t :: ts) sem (v :: vs) = + Let v' := of_val t v in @app_sopn rT ts (sem v') vs. Proof. reflexivity. Qed. Lemma sem_prod_cons t ts S : - sem_prod (t :: ts) S = (sem_t t -> sem_prod ts S). + sem_prod (t :: ts) S = (sem_t t → sem_prod ts S). Proof. reflexivity. Qed. -Inductive sem_correct {R S} (enc : (R -> Type)) : forall (ts : (seq stype)), (sem_prod ts (exec (enc S))) -> Prop := +Inductive sem_correct {R S} (enc : (R → Type)) : ∀ (ts : seq stype), (sem_prod ts (exec (enc S))) → Prop := | sem_nil s : sem_correct enc [::] s -| sem_cons t ts s : (forall v, (s (unembed (embed v)) = s v)) -> (forall v, sem_correct enc ts (s v)) -> sem_correct enc (t :: ts) s. +| sem_cons t ts s : (∀ v, (s (unembed (embed v)) = s v)) → (∀ v, sem_correct enc ts (s v)) → sem_correct enc (t :: ts) s. -Lemma tr_app_sopn_correct {R S} (enc dec : R -> Type) (can : dec S) emb ts vs vs' (s : sem_prod ts (exec (enc S))) : - sem_correct enc ts s -> +Lemma tr_app_sopn_correct {R S} (enc dec : R → Type) (can : dec S) emb ts vs vs' (s : sem_prod ts (exec (enc S))) : + sem_correct enc ts s → app_sopn ts s vs = ok vs' → tr_app_sopn enc dec can emb ts s [seq to_typed_chElement (translate_value v) | v <- vs] = emb vs'. Proof. - intros s_correct H. - induction ts as [|t ts'] in s, vs, vs', s_correct, H |- *. + intros hs H. + induction hs as [s | t ts s es hs ih] in vs, vs', H |- *. - destruct vs. 2: discriminate. - destruct s. 2: discriminate. - noconf H. reflexivity. - - destruct vs. 1: discriminate. - simpl in H. - jbind H v' Hv'. - simpl in *. - specialize (IHts' vs vs' (s v')). - inversion s_correct. - apply Eqdep.EqdepTheory.inj_pairT2 in H3. - subst. - erewrite translate_of_val by eassumption. + simpl in *. subst. + reflexivity. + - simpl in *. + destruct vs as [| v₀ vs]. 1: discriminate. + jbind H v' hv'. + eapply ih in H. + simpl. + erewrite translate_of_val. 2: eassumption. rewrite coerce_to_choice_type_translate_value_to_val. - rewrite H2. - apply IHts'. - 1: apply H4. + rewrite es. assumption. Qed. -Context `{asm_correct : forall o, sem_correct sem_tuple (tin (get_instr_desc (Oasm o))) (sopn_sem (Oasm o))}. +Context `{asm_correct : ∀ o, sem_correct sem_tuple (tin (get_instr_desc (Oasm o))) (sopn_sem (Oasm o))}. Lemma app_sopn_list_tuple_correct o vs vs' : app_sopn _ (sopn_sem o) vs = ok vs' → From b4327b6b880ba529b4eb6d0d353d69af6f9cb0df Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 5 May 2022 10:55:30 +0200 Subject: [PATCH 204/383] Fix build --- theories/Jasmin/jasmin_translate.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 8f05db77..6e1b2bc0 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -3071,4 +3071,4 @@ Proof. (* end; repeat constructor. *) (* Qed. *) (* admitted for efficiency (the proof takes approx ~30 to execute) *) -Admitted +Admitted. From 3a01ee70ddd46be8eebf4f8c055e4c57691db011 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 5 May 2022 10:55:54 +0200 Subject: [PATCH 205/383] Define chArray_set_sub and complete translation of write_lval --- theories/Jasmin/jasmin_translate.v | 29 +++++++++++++++++------------ 1 file changed, 17 insertions(+), 12 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 6e1b2bc0..e79b4d73 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -744,6 +744,17 @@ Qed. Definition chArray_set {ws} (a : 'array) (aa : arr_access) (p : Z) (w : word ws) := chArray_write a (p * mk_scale aa ws)%Z w. +(* WArray.set_sub *) +Definition chArray_set_sub (ws : wsize) (len : BinNums.positive) (aa : arr_access) (a : 'array) (p : Z) (b : 'array) : 'array := + let size := arr_size ws len in + let start := (p * mk_scale aa ws)%Z in + foldr (λ i data, + match b i with + | Some w => setm data (start + i)%Z w + | None => remm data (start + i)%Z + end + ) a (ziota 0 size). + (* Jasmin's write on 'mem *) Definition write_mem {sz} (m : 'mem) (ptr : word Uptr) (w : word sz) : 'mem := (* For now we do not worry about alignment *) @@ -1071,18 +1082,12 @@ Definition translate_write_lval (fn : funname) (l : lval) (v : typed_chElement) translate_write_var fn x (totce t) | Lasub aa ws len x i => (* Same observation as Laset *) - t' ← translate_get_var fn x ;; - let t := coerce_to_choice_type 'array t' in - (* Again, we ignore the length *) - (* Let t' := to_arr (Z.to_pos (arr_size ws len)) v in *) - unsupported.π2 - - (* | Lasub aa ws len x i => - Let (n,t) := s.[x] in - Let i := sem_pexpr s i >>= to_int in - Let t' := to_arr (Z.to_pos (arr_size ws len)) v in - Let t := @WArray.set_sub n aa ws len t i t' in - write_var x (@to_val (sarr n) t) s *) + t ← translate_get_var fn x ;; + let t := coerce_to_choice_type 'array t in + i ← (truncate_code sint (translate_pexpr fn i)).π2 ;; (* to_int *) + let t' := truncate_el (sarr (Z.to_pos (arr_size ws len))) v.π2 in + let t := chArray_set_sub ws len aa t i t' in + translate_write_var fn x (totce t) end. Definition instr_d (i : instr) : instr_r := From 76fc6b659d994d648d1f355c86cc6df2854d21f3 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Thu, 5 May 2022 11:04:46 +0200 Subject: [PATCH 206/383] simplify `tr_app_sopn` --- theories/Jasmin/jasmin_translate.v | 41 +++++++++++++++--------------- 1 file changed, 20 insertions(+), 21 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index e79b4d73..2f0be11c 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -822,12 +822,12 @@ Proof. + exact (translate_value v, tr_vs). Defined. -Fixpoint tr_app_sopn {R} {S : R} (dec : R → Type) (enc : R → Type) (can : enc S) (emb : dec S → enc S) (ts : list stype) := +Fixpoint tr_app_sopn {S R} (can : R) (emb : S → R) (ts : list stype) := match ts as ts' - return (sem_prod ts' (exec (dec S)) → [choiceType of list typed_chElement] → enc S) + return (sem_prod ts' (exec S) → [choiceType of list typed_chElement] → R) with | [::] => - λ (o : exec (dec S)) (vs : list typed_chElement), + λ (o : exec S) (vs : list typed_chElement), match vs with | [::] => match o with @@ -837,10 +837,10 @@ Fixpoint tr_app_sopn {R} {S : R} (dec : R → Type) (enc : R → Type) (can : en | _ :: _ => can end | t :: ts' => - λ (o : sem_t t → sem_prod ts' (exec (dec S))) (vs : list typed_chElement), + λ (o : sem_t t → sem_prod ts' (exec S)) (vs : list typed_chElement), match vs with | [::] => can - | v :: vs' => tr_app_sopn dec enc can emb ts' (o (unembed (truncate_el t v.π2))) vs' + | v :: vs' => tr_app_sopn can emb ts' (o (unembed (truncate_el t v.π2))) vs' end end. @@ -917,8 +917,10 @@ Definition embed_ot {t} : sem_ot t → encode t := | sword n => λ x, x end. +Definition encode_tuple (ts : list stype) : choice_type := lchtuple [seq encode t | t <- ts]. + (* takes a tuple of jasmin values and embeds each component *) -Fixpoint embed_tuple {ts} : sem_tuple ts → lchtuple [seq encode t | t <- ts] := +Fixpoint embed_tuple {ts} : sem_tuple ts → encode_tuple ts := match ts as ts0 return sem_tuple ts0 -> lchtuple [seq encode t | t <- ts0] with @@ -936,15 +938,12 @@ Fixpoint embed_tuple {ts} : sem_tuple ts → lchtuple [seq encode t | t <- ts] : end. (* tr_app_sopn specialized to when there is only one return value *) -Definition tr_app_sopn_single {S} := - tr_app_sopn sem_t encode (chCanonical (encode S)) embed. +Definition tr_app_sopn_single {t} := + tr_app_sopn (chCanonical (encode t)) embed. (* tr_app_sopn specialized to when there is several return values *) -Definition tr_app_sopn_tuple {ts_out} := - tr_app_sopn sem_tuple - (λ ts, lchtuple [seq encode t | t <- ts]) - (chCanonical (lchtuple [seq encode t | t <- ts_out])) - embed_tuple. +Definition tr_app_sopn_tuple {ts} := + tr_app_sopn (chCanonical (encode_tuple ts)) embed_tuple. (* Following sem_pexpr *) Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code := @@ -2282,14 +2281,14 @@ Lemma sem_prod_cons t ts S : sem_prod (t :: ts) S = (sem_t t → sem_prod ts S). Proof. reflexivity. Qed. -Inductive sem_correct {R S} (enc : (R → Type)) : ∀ (ts : seq stype), (sem_prod ts (exec (enc S))) → Prop := -| sem_nil s : sem_correct enc [::] s -| sem_cons t ts s : (∀ v, (s (unembed (embed v)) = s v)) → (∀ v, sem_correct enc ts (s v)) → sem_correct enc (t :: ts) s. +Inductive sem_correct {R} : ∀ (ts : seq stype), (sem_prod ts (exec R)) → Prop := +| sem_nil s : sem_correct [::] s +| sem_cons t ts s : (∀ v, (s (unembed (embed v)) = s v)) → (∀ v, sem_correct ts (s v)) → sem_correct (t :: ts) s. -Lemma tr_app_sopn_correct {R S} (enc dec : R → Type) (can : dec S) emb ts vs vs' (s : sem_prod ts (exec (enc S))) : - sem_correct enc ts s → +Lemma tr_app_sopn_correct {R S} (can : S) emb ts vs vs' (s : sem_prod ts (exec R)) : + sem_correct ts s → app_sopn ts s vs = ok vs' → - tr_app_sopn enc dec can emb ts s [seq to_typed_chElement (translate_value v) | v <- vs] + tr_app_sopn can emb ts s [seq to_typed_chElement (translate_value v) | v <- vs] = emb vs'. Proof. intros hs H. @@ -2308,7 +2307,7 @@ Proof. assumption. Qed. -Context `{asm_correct : ∀ o, sem_correct sem_tuple (tin (get_instr_desc (Oasm o))) (sopn_sem (Oasm o))}. +Context `{asm_correct : ∀ o, sem_correct (tin (get_instr_desc (Oasm o))) (sopn_sem (Oasm o))}. Lemma app_sopn_list_tuple_correct o vs vs' : app_sopn _ (sopn_sem o) vs = ok vs' → @@ -3055,7 +3054,7 @@ Import arch_decl. (* this is a stupid proof, since the only thing it does, is that it realizes all assembly instructions are defined on words FIXME: do better *) -Lemma x86_correct : ∀ (o : asm_op_t), sem_correct sem_tuple (tin (sopn.get_instr_desc (Oasm o))) (sopn_sem (Oasm o)). +Lemma x86_correct : ∀ (o : asm_op_t), sem_correct (tin (sopn.get_instr_desc (Oasm o))) (sopn_sem (Oasm o)). Proof. intros. simpl. From 0a71e6432b3db8bf7343f5c3d601402195c7709e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 5 May 2022 11:10:42 +0200 Subject: [PATCH 207/383] Prove chArray_set_sub_correct --- theories/Jasmin/jasmin_translate.v | 29 ++++++++++++++++++++++++++++- 1 file changed, 28 insertions(+), 1 deletion(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 2f0be11c..0118483c 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1942,7 +1942,7 @@ Proof. Qed. Lemma chArray_get_sub_correct (lena len : BinNums.positive) a aa sz i t : - WArray.get_sub aa sz len a i = ok t -> + WArray.get_sub aa sz len a i = ok t → chArray_get_sub sz len (translate_value (@Varr lena a)) i (mk_scale aa sz) = translate_value (Varr t). Proof. intros H. @@ -1969,6 +1969,33 @@ Proof. reflexivity. Qed. +Lemma chArray_set_sub_correct : + ∀ ws (lena len : BinNums.positive) a aa b p t, + @WArray.set_sub lena aa ws len a p b = ok t → + chArray_set_sub ws len aa (translate_value (Varr a)) p (translate_value (Varr b)) + = translate_value (Varr t). +Proof. + intros ws lena len a aa b p t e. + unfold WArray.set_sub in e. + destruct (_ : bool) eqn:eb. 2: discriminate. + noconf e. + unfold chArray_set_sub. unfold WArray.set_sub_data. + move: eb => /andP [e1 e2]. + rewrite <- !foldl_rev. + apply ziota_ind. + - reflexivity. + - intros i l hi ih. + rewrite rev_cons. + rewrite !foldl_rcons. + rewrite ih. + rewrite fold_get. + destruct Mz.get eqn:e. + + rewrite fold_set. + reflexivity. + + rewrite fold_rem. + reflexivity. +Qed. + (* Like write_mem_get *) Lemma chArray_write_get : ∀ ws (a : 'array) (w : word ws) (i j : Z), From 5f04aa23870473908ad41b7e61d8a834a8dd0567 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 5 May 2022 11:11:18 +0200 Subject: [PATCH 208/383] Nit --- theories/Jasmin/jasmin_translate.v | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 0118483c..3c79f395 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -917,7 +917,8 @@ Definition embed_ot {t} : sem_ot t → encode t := | sword n => λ x, x end. -Definition encode_tuple (ts : list stype) : choice_type := lchtuple [seq encode t | t <- ts]. +Definition encode_tuple (ts : list stype) : choice_type := + lchtuple [seq encode t | t <- ts]. (* takes a tuple of jasmin values and embeds each component *) Fixpoint embed_tuple {ts} : sem_tuple ts → encode_tuple ts := From a37c1957e2442b0ad930c40407f2ca186438e9b0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 5 May 2022 11:22:06 +0200 Subject: [PATCH 209/383] Prove translate_to_arr --- theories/Jasmin/jasmin_translate.v | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 3c79f395..5ef25c23 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1801,6 +1801,19 @@ Proof. rewrite coerce_to_choice_type_K. reflexivity. Qed. +Lemma translate_to_arr : + ∀ len v a, + to_arr len v = ok a → + coerce_to_choice_type 'array (translate_value v) = translate_value (Varr a). +Proof. + intros len v a e. + destruct v as [| | len' t' | |]. all: try discriminate. + simpl in e. unfold WArray.cast in e. + destruct (_ : bool) eqn:eb. 2: discriminate. + noconf e. simpl. + rewrite coerce_to_choice_type_K. reflexivity. +Qed. + Lemma translate_truncate_code : ∀ (c : typed_code) (ty : stype) v v' p q, truncate_val ty v = ok v' → From 119ca368079d06481c4edec8d7d48ea98ac0ea5c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 5 May 2022 11:24:05 +0200 Subject: [PATCH 210/383] Complete translate_write_lval_correct (Lasub case) --- theories/Jasmin/jasmin_translate.v | 32 ++++++++++++++++++++++++++++-- 1 file changed, 30 insertions(+), 2 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 5ef25c23..627d3707 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -2865,8 +2865,36 @@ Proof. erewrite chArray_set_correct. 2: eassumption. eapply translate_write_var_estate in hs. 2: eassumption. assumption. - - admit. -Admitted. + - simpl. simpl in hw. + jbind hw nt hnt. destruct nt. all: try discriminate. + jbind hw i hi. jbind hi i' hi'. + jbind hw t' ht'. jbind hw t ht. + eapply u_get_remember. simpl. intros vx. + rewrite !bind_assoc. simpl. + eapply u_bind. + 1:{ + eapply translate_pexpr_correct. + - eassumption. + - intros ? []. assumption. + } + unfold translate_write_var. simpl. + eapply u_put. + eapply u_ret_eq. + intros ? [m [[hs hm] ?]]. subst. + unfold u_get in hm. subst. + erewrite translate_pexpr_type. 2: eassumption. + rewrite !coerce_to_choice_type_K. + erewrite translate_to_int. 2: eassumption. + erewrite translate_to_arr. 2: eassumption. + erewrite get_var_get_heap. 2,3: eassumption. + Opaque translate_value. simpl. Transparent translate_value. + eapply type_of_get_var in hnt as ety. simpl in ety. + apply (f_equal encode) in ety. simpl in ety. + rewrite -ety. rewrite !coerce_to_choice_type_K. + erewrite chArray_set_sub_correct. 2: eassumption. + eapply translate_write_var_estate in hs. 2: eassumption. + assumption. +Qed. Lemma translate_write_lvals_cons fn l ls v vs : translate_write_lvals fn (l :: ls) (v :: vs) = (translate_write_lval fn l v ;; translate_write_lvals fn ls vs). From 03a154cee46c4f13cf82eefcb182094fe4b424d4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 5 May 2022 12:13:53 +0200 Subject: [PATCH 211/383] Slightly improve x86_correct --- theories/Jasmin/jasmin_translate.v | 66 +++++++++++++++++++++++------- 1 file changed, 51 insertions(+), 15 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 627d3707..aa4eb3e5 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -3120,24 +3120,60 @@ End Translation. From Jasmin Require Import x86_instr_decl x86_extra x86_gen x86_linear_sem. Import arch_decl. +Lemma id_tin_instr_desc : + ∀ (a : asm_op_msb_t), + id_tin (instr_desc a) = id_tin (x86_instr_desc a.2). +Proof. + intros [[ws|] a]. + - simpl. destruct (_ == _). all: reflexivity. + - reflexivity. +Qed. + +Definition cast_sem_prod_dom {ts tr} ts' (f : sem_prod ts tr) (e : ts = ts') : + sem_prod ts' tr. +Proof. + subst. exact f. +Defined. + +Lemma cast_sem_prod_dom_K : + ∀ ts tr f e, + @cast_sem_prod_dom ts tr ts f e = f. +Proof. + intros ts tr f e. + assert (e = erefl). + { apply eq_irrelevance. } + subst. reflexivity. +Qed. + +Lemma sem_correct_rewrite : + ∀ R ts ts' f e, + sem_correct ts' (cast_sem_prod_dom ts' f e) → + @sem_correct R ts f. +Proof. + intros R ts ts' f e h. + subst. rewrite cast_sem_prod_dom_K in h. + assumption. +Qed. + (* this is a stupid proof, since the only thing it does, is that it realizes all assembly instructions are defined on words FIXME: do better *) -Lemma x86_correct : ∀ (o : asm_op_t), sem_correct (tin (sopn.get_instr_desc (Oasm o))) (sopn_sem (Oasm o)). -Proof. - intros. - simpl. - destruct o. - - destruct a. - destruct o. -(* + destruct x; *) -(* repeat match goal with *) -(* | w : wsize |- _ => destruct w *) -(* end; repeat constructor. *) -(* + destruct x; *) -(* repeat match goal with *) -(* | w : wsize |- _ => destruct w *) -(* end; repeat constructor. *) +Lemma x86_correct : + ∀ (o : asm_op_t), + sem_correct (tin (sopn.get_instr_desc (Oasm o))) (sopn_sem (Oasm o)). +Proof. + intros o. + simpl. destruct o as [a | e]. + - Opaque instr_desc. simpl. + pose proof (id_tin_instr_desc a) as e. + eapply sem_correct_rewrite with (e := e). + destruct a as [o x]. simpl in *. + destruct x. + all: + repeat match goal with + | w : wsize |- _ => destruct w + end ; repeat constructor. + Transparent instr_desc. (* - destruct e; *) (* repeat match goal with *) (* | w : wsize |- _ => destruct w *) From 57a665c0e6c8cc293ff8e96cb2ef7c51da615ee8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 5 May 2022 12:16:09 +0200 Subject: [PATCH 212/383] Uncomment x86_correct --- theories/Jasmin/jasmin_translate.v | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index aa4eb3e5..6d988667 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -3174,10 +3174,8 @@ Proof. | w : wsize |- _ => destruct w end ; repeat constructor. Transparent instr_desc. -(* - destruct e; *) -(* repeat match goal with *) -(* | w : wsize |- _ => destruct w *) -(* end; repeat constructor. *) -(* Qed. *) - (* admitted for efficiency (the proof takes approx ~30 to execute) *) -Admitted. + - destruct e ; + repeat match goal with + | w : wsize |- _ => destruct w + end ; repeat constructor. +Qed. \ No newline at end of file From 836e654139f1ddb7d10ac226ab306cfc9281c4d6 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Thu, 5 May 2022 13:55:11 +0200 Subject: [PATCH 213/383] simplify proof of `x86_correct` --- theories/Jasmin/jasmin_translate.v | 38 ++++++++++++++++++++---------- 1 file changed, 25 insertions(+), 13 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 6d988667..6797edf4 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -3155,9 +3155,25 @@ Proof. assumption. Qed. -(* this is a stupid proof, since the only thing it does, is that it realizes all assembly instructions are defined on words - FIXME: do better -*) +Lemma no_arr_correct {R} ts s : List.Forall (λ t, forall len, t != sarr len) ts -> @sem_correct R ts s. +Proof. + intros. + induction ts as [|t ts ih]. + - constructor. + - constructor. + + intros. + pose proof unembed_embed t v. + destruct t. + 1,2,4: rewrite H0; reflexivity. + inversion H. + specialize (H3 p). + move: H3 => /eqP. + contradiction. + + intros. apply ih. + inversion H. + assumption. +Qed. + Lemma x86_correct : ∀ (o : asm_op_t), sem_correct (tin (sopn.get_instr_desc (Oasm o))) (sopn_sem (Oasm o)). @@ -3168,14 +3184,10 @@ Proof. pose proof (id_tin_instr_desc a) as e. eapply sem_correct_rewrite with (e := e). destruct a as [o x]. simpl in *. - destruct x. - all: - repeat match goal with - | w : wsize |- _ => destruct w - end ; repeat constructor. + eapply no_arr_correct. + destruct x; simpl. + all: repeat constructor. Transparent instr_desc. - - destruct e ; - repeat match goal with - | w : wsize |- _ => destruct w - end ; repeat constructor. -Qed. \ No newline at end of file + - destruct e; simpl; repeat constructor. + destruct w; repeat constructor. +Qed. From 5de06db375724cfa45f748f1508ca6308caa03e2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 5 May 2022 14:28:30 +0200 Subject: [PATCH 214/383] Simplify no_arr_correct --- theories/Jasmin/jasmin_translate.v | 36 ++++++++++++++---------------- 1 file changed, 17 insertions(+), 19 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 6797edf4..05c6551d 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -2710,8 +2710,8 @@ Proof. unfold translate_var. unfold nat_of_fun_ident. apply /eqP. intro e. - noconf e. - apply (f_equal (λ n, n %% 3)) in H0. + noconf e. rename H0 into e. + apply (f_equal (λ n, n %% 3)) in e. Admitted. Notation coe_cht := coerce_to_choice_type. @@ -3155,23 +3155,21 @@ Proof. assumption. Qed. -Lemma no_arr_correct {R} ts s : List.Forall (λ t, forall len, t != sarr len) ts -> @sem_correct R ts s. +Lemma no_arr_correct {R} ts s : + List.Forall (λ t, ∀ len, t != sarr len) ts → + @sem_correct R ts s. Proof. - intros. - induction ts as [|t ts ih]. + intros h. + induction h as [| t ts ht h ih]. - constructor. - constructor. - + intros. - pose proof unembed_embed t v. - destruct t. - 1,2,4: rewrite H0; reflexivity. - inversion H. - specialize (H3 p). - move: H3 => /eqP. - contradiction. - + intros. apply ih. - inversion H. - assumption. + + intros v. + pose proof unembed_embed t v as e. + destruct t as [| | len |]. + 1,2,4: rewrite e ; reflexivity. + specialize (ht len). move: ht => /eqP. contradiction. + + intros v. + apply ih. Qed. Lemma x86_correct : @@ -3185,9 +3183,9 @@ Proof. eapply sem_correct_rewrite with (e := e). destruct a as [o x]. simpl in *. eapply no_arr_correct. - destruct x; simpl. + destruct x ; simpl. all: repeat constructor. Transparent instr_desc. - - destruct e; simpl; repeat constructor. - destruct w; repeat constructor. + - destruct e ; simpl ; repeat constructor. + destruct w ; repeat constructor. Qed. From b89a628310adc574f7bd271a7d0af755cb6700f2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 5 May 2022 15:14:56 +0200 Subject: [PATCH 215/383] Progress with ptr_var_neq --- theories/Jasmin/jasmin_translate.v | 52 +++++++++++++++++++++++++++++- 1 file changed, 51 insertions(+), 1 deletion(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 05c6551d..61204c50 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -2703,6 +2703,52 @@ Proof. rewrite coerce_typed_code_K. assumption. Qed. +Lemma Mpowmodn : + ∀ d n, + n ≠ 0 → + d ^ n %% d = 0. +Proof. + intros d n hn. + destruct n as [| n]. 1: contradiction. + simpl. apply modnMr. +Qed. + +Lemma nat_of_pos_nonzero : + ∀ p, + nat_of_pos p ≠ 0. +Proof. + intros p. induction p as [p ih | p ih |]. + - simpl. micromega.Lia.lia. + - simpl. rewrite NatTrec.doubleE. + move => /eqP. rewrite double_eq0. move /eqP. assumption. + - simpl. micromega.Lia.lia. +Qed. + +(* Lemma mod1n : + ∀ d, + d ≠ 1 → + 1 %% d = 1. +Proof. + intros d hd. + unfold modn. + induction d as [| d ih]. + - apply modn0. + - + +Lemma powmodn_eq0 : + ∀ k n d, + k ^ n = 0 %[mod d] → + k = 0 %[mod d]. +Proof. + intros k n d e. + rewrite mod0n in e. rewrite mod0n. + induction n as [| n ih] in k, d, e |- *. + - simpl in e. + destruct d as [| d]. + 1:{ rewrite modn0 in e. discriminate. } + + - *) + Lemma ptr_var_neq (ptr : pointer) (fn : funname) (v : var) : translate_ptr ptr != translate_var fn v. Proof. @@ -2712,6 +2758,9 @@ Proof. apply /eqP. intro e. noconf e. rename H0 into e. apply (f_equal (λ n, n %% 3)) in e. + rewrite -modnMm in e. rewrite Mpowmodn in e. 2: apply nat_of_pos_nonzero. + rewrite mul0n in e. + (* modnXm: ∀ m n a : nat, expn (a %% n) m = expn a m %[mod n] *) Admitted. Notation coe_cht := coerce_to_choice_type. @@ -3107,7 +3156,8 @@ Proof. red. intros s1 m2 s2 ii xs gn args vargs vs hargs hvs ihvs hw. red. simpl. intros _. admit. - - red. intros m1 m2 gn g vs vs' s1 vm2 vrs vrs'. + - (* proc *) + red. intros m1 m2 gn g vs vs' s1 vm2 vrs vrs'. intros hg hvs ?????. unfold Pfun. intros f' hdp hf'. (* Maybe have a dedicated lemma linking to hg? *) From ee41b51bac5bf6de45c3c7aa8ce6305acebaa7e6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 5 May 2022 16:12:56 +0200 Subject: [PATCH 216/383] Prove ptr_var_neq --- theories/Jasmin/jasmin_translate.v | 44 ++++++++++++------------------ 1 file changed, 17 insertions(+), 27 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 61204c50..b244f52c 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -2703,6 +2703,16 @@ Proof. rewrite coerce_typed_code_K. assumption. Qed. +Lemma Natpow_expn : + ∀ (n m : nat), + (n ^ m)%nat = expn n m. +Proof. + intros n m. + induction m as [| m ih] in n |- *. + - cbn. reflexivity. + - simpl. rewrite expnS. rewrite -ih. reflexivity. +Qed. + Lemma Mpowmodn : ∀ d n, n ≠ 0 → @@ -2724,31 +2734,6 @@ Proof. - simpl. micromega.Lia.lia. Qed. -(* Lemma mod1n : - ∀ d, - d ≠ 1 → - 1 %% d = 1. -Proof. - intros d hd. - unfold modn. - induction d as [| d ih]. - - apply modn0. - - - -Lemma powmodn_eq0 : - ∀ k n d, - k ^ n = 0 %[mod d] → - k = 0 %[mod d]. -Proof. - intros k n d e. - rewrite mod0n in e. rewrite mod0n. - induction n as [| n ih] in k, d, e |- *. - - simpl in e. - destruct d as [| d]. - 1:{ rewrite modn0 in e. discriminate. } - - - *) - Lemma ptr_var_neq (ptr : pointer) (fn : funname) (v : var) : translate_ptr ptr != translate_var fn v. Proof. @@ -2760,8 +2745,13 @@ Proof. apply (f_equal (λ n, n %% 3)) in e. rewrite -modnMm in e. rewrite Mpowmodn in e. 2: apply nat_of_pos_nonzero. rewrite mul0n in e. - (* modnXm: ∀ m n a : nat, expn (a %% n) m = expn a m %[mod n] *) -Admitted. + move: e => /eqP e. rewrite eqn_mod_dvd in e. 2: auto. + rewrite subn0 in e. + rewrite Natpow_expn in e. rewrite Euclid_dvdX in e. 2: auto. + move: e => /andP [e _]. + rewrite dvdn_prime2 in e. 2,3: auto. + move: e => /eqP e. micromega.Lia.lia. +Qed. Notation coe_cht := coerce_to_choice_type. Notation coe_tyc := coerce_typed_code. From d5701800d35b99c6db77fe87a5244a21052680b8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 5 May 2022 16:18:06 +0200 Subject: [PATCH 217/383] injective_translate_var does not hold! --- theories/Jasmin/jasmin_translate.v | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index b244f52c..4931d6b1 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -2759,6 +2759,12 @@ Notation coe_tyc := coerce_typed_code. Lemma injective_translate_var : ∀ fn, injective (translate_var fn). Proof. + intros fn u v e. + unfold translate_var in e. + destruct u as [uty u], v as [vty v]. + simpl in e. noconf e. + f_equal. + (* We need injectivity of encode which is not true for sarr! *) Admitted. Lemma translate_write_correct : From 30f645ce1c43a676934aa78922c00f4f68b0a905 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Thu, 5 May 2022 16:21:02 +0200 Subject: [PATCH 218/383] rewriting in `bigadd` example --- theories/Jasmin/examples/bigadd/bigadd.v | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) diff --git a/theories/Jasmin/examples/bigadd/bigadd.v b/theories/Jasmin/examples/bigadd/bigadd.v index abd6c35e..33c0c976 100644 --- a/theories/Jasmin/examples/bigadd/bigadd.v +++ b/theories/Jasmin/examples/bigadd/bigadd.v @@ -512,14 +512,22 @@ Goal forall aa, f_bigadd aa = f_bigadd aa. unfold apply_noConfusion. simpl. unfold translate_write_var. simpl. + unfold translate_instr. simpl. + Opaque translate_for. + (* unfold translate_for. simpl. *) + rewrite !coerce_typed_code_K. + simpl. unfold translate_var. simpl. - set (TODO := ('unit; distr.dnull)). + (* set (TODO := ('unit; distr.dnull)). *) set (array32 := sarr 32%positive). set (fn := 2%positive). set (x := ('array; nat_of_fun_ident fn "x.140")). set (xr := ('word U64; nat_of_fun_ident fn "xr.143")). set (y := ('array; nat_of_fun_ident fn "y.141")). set (yr := ('word U64; nat_of_fun_ident fn "yr.144")). + set (cf := ('bool; nat_of_fun_ident fn "cf.145")). + set (i := ('int; nat_of_fun_ident fn "i.146")). + set (x_ := {| v_var := {| vtype := array32; vname := "x.140" |}; v_info := (fn~0)%positive |}). set (y_ := {| v_var := {| vtype := array32; vname := "y.141" |}; @@ -533,9 +541,14 @@ Goal forall aa, f_bigadd aa = f_bigadd aa. unfold bind_list'. simpl. unfold bind_list_trunc_aux. simpl. rewrite eq_rect_K. - time repeat setoid_rewrite (@zero_extend_u U64). + unfold translate_var. simpl. set (res := ('array; nat_of_fun_ident fn "res.142")). + + time repeat setoid_rewrite (@zero_extend_u U64). unfold wsize_size. rewrite !coerce_to_choice_type_K. + setoid_rewrite coerce_to_choice_type_K. + setoid_rewrite coerce_to_choice_type_K. + (* Strangely, some instances of coe_cht don't get simplified away here. *) From 5e4b216d58a189d7e2e255810e6e37d88644b243 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 5 May 2022 16:23:41 +0200 Subject: [PATCH 219/383] Prove mem_loc_translate_var_neq --- theories/Jasmin/jasmin_translate.v | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 4931d6b1..da076184 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1533,7 +1533,12 @@ Lemma mem_loc_translate_var_neq : ∀ fn x, mem_loc != translate_var fn x. Proof. -Admitted. + intros fn x. + unfold mem_loc, translate_var. + apply /eqP. intro e. + destruct x as [ty i]. simpl in e. noconf e. + destruct ty. all: discriminate. +Qed. Lemma translate_write_estate : ∀ fn sz s cm ptr w m, From 97d915d6f41c875afa4f6c7e4d2f1964f2a44c52 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 5 May 2022 17:22:05 +0200 Subject: [PATCH 220/383] nat_of_fun_ident might not be injective either --- theories/Jasmin/jasmin_translate.v | 104 +++++++++++++++++++++++++++++ 1 file changed, 104 insertions(+) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index da076184..08dc6281 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -2761,6 +2761,109 @@ Qed. Notation coe_cht := coerce_to_choice_type. Notation coe_tyc := coerce_typed_code. +Lemma injective_mulnl : + ∀ n x y, + 0 < n → + (n * x)%nat = (n * y)%nat → + x = y. +Proof. + intros n x y hn e. + apply (f_equal (λ m, m %/ n)) in e. + rewrite !mulKn in e. 2,3: assumption. + assumption. +Qed. + +Lemma nonzero_lt : + ∀ n, + n ≠ 0 → + 0 < n. +Proof. + intros n h. + destruct n. 1: contradiction. + auto. +Qed. + +Lemma pow_nonzero : + ∀ k n, + k ≠ 0 → + (k ^ n)%nat ≠ 0. +Proof. + intros k n hk. + induction n as [| n ih]. + - simpl. discriminate. + - simpl. micromega.Lia.lia. +Qed. + +Lemma injective_pow : + ∀ k n m, + 1 < k → + (k ^ n)%nat = (k ^ m)%nat → + n = m. +Proof. + intros k n m hk e. + induction n as [| n ih] in m, e |- *. + - simpl in e. destruct m as [| m]. + 2:{ + move: hk => /ltP hk. + simpl in e. exfalso. + assert ((k ^ m)%nat ≠ 0). + { apply pow_nonzero. micromega.Lia.lia. } + micromega.Lia.lia. + } + reflexivity. + - simpl in e. + destruct m as [| m]. + 1:{ + move: hk => /ltP hk. + simpl in e. exfalso. + assert ((k ^ n)%nat ≠ 0). + { apply pow_nonzero. micromega.Lia.lia. } + micromega.Lia.lia. + } + f_equal. apply ih. + simpl in e. apply injective_mulnl in e. 2: auto. + assumption. +Qed. + +Lemma nat_of_ident_pos : + ∀ x, (0 < nat_of_ident x)%coq_nat. +Proof. + intros x. induction x as [| a s ih]. + - auto. + - simpl. + rewrite -mulP. rewrite -plusE. + micromega.Lia.lia. +Qed. + +Lemma injective_nat_of_ident : + ∀ x y, + nat_of_ident x = nat_of_ident y → + x = y. +Proof. + intros x y e. + destruct x as [| a x], y as [| b y]. all: simpl in e. + - reflexivity. + - rewrite -mulP in e. rewrite -plusE in e. + pose proof (nat_of_ident_pos y). + micromega.Lia.lia. + - rewrite -mulP in e. rewrite -plusE in e. + pose proof (nat_of_ident_pos x). + micromega.Lia.lia. + - give_up. (* Not true is it? *) +Abort. + +Lemma injective_nat_of_fun_ident : + ∀ fn x y, + nat_of_fun_ident fn x = nat_of_fun_ident fn y → + x = y. +Proof. + intros fn x y e. + unfold nat_of_fun_ident in e. + apply injective_mulnl in e. + 2:{ apply nonzero_lt. apply pow_nonzero. micromega.Lia.lia. } + apply injective_pow in e. 2: auto. +Abort. + Lemma injective_translate_var : ∀ fn, injective (translate_var fn). Proof. @@ -2770,6 +2873,7 @@ Proof. simpl in e. noconf e. f_equal. (* We need injectivity of encode which is not true for sarr! *) + (* injective_nat_of_fun_ident might not be true either *) Admitted. Lemma translate_write_correct : From 11dd86f85d0967d63adea2645cd4d126114b8ca6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 5 May 2022 17:26:19 +0200 Subject: [PATCH 221/383] Fix up injective_nat_of_ident --- theories/Jasmin/jasmin_translate.v | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 08dc6281..dfa96bb4 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -2841,7 +2841,9 @@ Lemma injective_nat_of_ident : x = y. Proof. intros x y e. - destruct x as [| a x], y as [| b y]. all: simpl in e. + induction x as [| a x] in y, e |- *. + all: destruct y as [| b y]. + all: simpl in e. - reflexivity. - rewrite -mulP in e. rewrite -plusE in e. pose proof (nat_of_ident_pos y). @@ -2849,8 +2851,8 @@ Proof. - rewrite -mulP in e. rewrite -plusE in e. pose proof (nat_of_ident_pos x). micromega.Lia.lia. - - give_up. (* Not true is it? *) -Abort. + - (* Have to prove Ascii.nat_of_ascii is below 256 *) +Admitted. Lemma injective_nat_of_fun_ident : ∀ fn x y, @@ -2862,7 +2864,8 @@ Proof. apply injective_mulnl in e. 2:{ apply nonzero_lt. apply pow_nonzero. micromega.Lia.lia. } apply injective_pow in e. 2: auto. -Abort. + apply injective_nat_of_ident. assumption. +Qed. Lemma injective_translate_var : ∀ fn, injective (translate_var fn). @@ -2872,8 +2875,9 @@ Proof. destruct u as [uty u], v as [vty v]. simpl in e. noconf e. f_equal. - (* We need injectivity of encode which is not true for sarr! *) - (* injective_nat_of_fun_ident might not be true either *) + - (* We need injectivity of encode which is not true for sarr! *) + give_up. + - eapply injective_nat_of_fun_ident. eassumption. Admitted. Lemma translate_write_correct : From fecde6ede435bee76a745c48f28c6af2655c0de7 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Thu, 5 May 2022 18:05:26 +0200 Subject: [PATCH 222/383] prove `injective_nat_of_ident` --- theories/Jasmin/jasmin_translate.v | 24 ++++++++++++++++++++++-- 1 file changed, 22 insertions(+), 2 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index dfa96bb4..99c2469a 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -2851,8 +2851,28 @@ Proof. - rewrite -mulP in e. rewrite -plusE in e. pose proof (nat_of_ident_pos x). micromega.Lia.lia. - - (* Have to prove Ascii.nat_of_ascii is below 256 *) -Admitted. + - (* BSH: there is a more principled way of doing this, but this'll do for now *) + apply (f_equal (λ a, Nat.modulo a 256)) in e as xy_eq. + rewrite -Nat.add_mod_idemp_l in xy_eq. 2: micromega.Lia.lia. + rewrite -Nat.mul_mod_idemp_l in xy_eq. 2: micromega.Lia.lia. + rewrite Nat.mod_same in xy_eq. 2: micromega.Lia.lia. + rewrite Nat.mul_0_l in xy_eq. + rewrite Nat.mod_0_l in xy_eq. 2: micromega.Lia.lia. + rewrite Nat.add_0_l in xy_eq. + rewrite -Nat.add_mod_idemp_l in xy_eq. 2: micromega.Lia.lia. + rewrite -Nat.mul_mod_idemp_l in xy_eq. 2: micromega.Lia.lia. + rewrite Nat.mod_same in xy_eq. 2: micromega.Lia.lia. + rewrite Nat.mul_0_l in xy_eq. + rewrite Nat.mod_0_l in xy_eq. 2: micromega.Lia.lia. + rewrite Nat.add_0_l in xy_eq. + rewrite !Nat.mod_small in xy_eq. 2,3: apply Ascii.nat_ascii_bounded. + apply OrderedTypeEx.String_as_OT.nat_of_ascii_inverse in xy_eq. + subst. f_equal. + apply IHx. + rewrite -!addP in e. + rewrite -!mulP in e. + micromega.Lia.lia. +Qed. Lemma injective_nat_of_fun_ident : ∀ fn x y, From b7e576460da05d4022cc1395a99ed129e90dfe91 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Thu, 5 May 2022 18:15:07 +0200 Subject: [PATCH 223/383] use coq stdlib --- theories/Jasmin/jasmin_translate.v | 69 +----------------------------- 1 file changed, 2 insertions(+), 67 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 99c2469a..a1443396 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -2761,70 +2761,6 @@ Qed. Notation coe_cht := coerce_to_choice_type. Notation coe_tyc := coerce_typed_code. -Lemma injective_mulnl : - ∀ n x y, - 0 < n → - (n * x)%nat = (n * y)%nat → - x = y. -Proof. - intros n x y hn e. - apply (f_equal (λ m, m %/ n)) in e. - rewrite !mulKn in e. 2,3: assumption. - assumption. -Qed. - -Lemma nonzero_lt : - ∀ n, - n ≠ 0 → - 0 < n. -Proof. - intros n h. - destruct n. 1: contradiction. - auto. -Qed. - -Lemma pow_nonzero : - ∀ k n, - k ≠ 0 → - (k ^ n)%nat ≠ 0. -Proof. - intros k n hk. - induction n as [| n ih]. - - simpl. discriminate. - - simpl. micromega.Lia.lia. -Qed. - -Lemma injective_pow : - ∀ k n m, - 1 < k → - (k ^ n)%nat = (k ^ m)%nat → - n = m. -Proof. - intros k n m hk e. - induction n as [| n ih] in m, e |- *. - - simpl in e. destruct m as [| m]. - 2:{ - move: hk => /ltP hk. - simpl in e. exfalso. - assert ((k ^ m)%nat ≠ 0). - { apply pow_nonzero. micromega.Lia.lia. } - micromega.Lia.lia. - } - reflexivity. - - simpl in e. - destruct m as [| m]. - 1:{ - move: hk => /ltP hk. - simpl in e. exfalso. - assert ((k ^ n)%nat ≠ 0). - { apply pow_nonzero. micromega.Lia.lia. } - micromega.Lia.lia. - } - f_equal. apply ih. - simpl in e. apply injective_mulnl in e. 2: auto. - assumption. -Qed. - Lemma nat_of_ident_pos : ∀ x, (0 < nat_of_ident x)%coq_nat. Proof. @@ -2881,9 +2817,8 @@ Lemma injective_nat_of_fun_ident : Proof. intros fn x y e. unfold nat_of_fun_ident in e. - apply injective_mulnl in e. - 2:{ apply nonzero_lt. apply pow_nonzero. micromega.Lia.lia. } - apply injective_pow in e. 2: auto. + apply Nat.mul_cancel_l in e. 2: apply Nat.pow_nonzero; auto. + eapply Nat.pow_inj_r in e. 2: auto. apply injective_nat_of_ident. assumption. Qed. From 4f5b682f4a083b45174a896dda5740ee99c9d450 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Fri, 6 May 2022 15:05:03 +0200 Subject: [PATCH 224/383] modify `translate_var` and prove `injective_translate_var` --- theories/Jasmin/jasmin_translate.v | 115 +++++++++++++++++++++++++---- 1 file changed, 102 insertions(+), 13 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index a1443396..ab256d88 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -378,8 +378,17 @@ Fixpoint nat_of_ident (id : Ident.ident) : nat := Definition nat_of_fun_ident (f : funname) (id : Ident.ident) : nat := 3^(nat_of_pos f) * 2^(nat_of_ident id). +Definition nat_of_stype t : nat := + match t with + | sarr len => 5 ^ ((Pos.to_nat len).+1) + | _ => 5 ^ 1 + end. + +Definition nat_of_fun_var (f : funname) (x : var) : nat := + (nat_of_stype x.(vtype) * (nat_of_fun_ident f x.(vname)))%coq_nat. + Definition translate_var (f : funname) (x : var) : Location := - (encode x.(vtype) ; nat_of_fun_ident f x.(vname)). + (encode x.(vtype) ; nat_of_fun_var f x). Definition typed_code := ∑ (a : choice_type), raw_code a. @@ -1394,8 +1403,11 @@ Proof. all: simpl ; rewrite eq_rect_r_K ; reflexivity. Qed. +Definition nat_of_ptr (ptr : pointer) := + (7 ^ Z.to_nat (wunsigned ptr))%nat. + Definition translate_ptr (ptr : pointer) : Location := - ('word U8 ; (5 ^ Z.to_nat (wunsigned ptr))%nat). + ('word U8 ; nat_of_ptr ptr). Definition rel_mem (m : mem) (h : heap) := ∀ ptr v, @@ -2739,17 +2751,19 @@ Proof. - simpl. micromega.Lia.lia. Qed. -Lemma ptr_var_neq (ptr : pointer) (fn : funname) (v : var) : - translate_ptr ptr != translate_var fn v. +Lemma ptr_var_nat_neq (ptr : pointer) (fn : funname) (v : var) : + nat_of_ptr ptr != nat_of_fun_var fn v. Proof. - unfold translate_ptr. - unfold translate_var. - unfold nat_of_fun_ident. + unfold nat_of_ptr. + unfold nat_of_fun_var. apply /eqP. intro e. - noconf e. rename H0 into e. apply (f_equal (λ n, n %% 3)) in e. - rewrite -modnMm in e. rewrite Mpowmodn in e. 2: apply nat_of_pos_nonzero. + rewrite -modnMm in e. + rewrite -(modnMm (3 ^ _)) in e. + rewrite Mpowmodn in e. 2: apply nat_of_pos_nonzero. rewrite mul0n in e. + rewrite mod0n in e. + rewrite muln0 in e. move: e => /eqP e. rewrite eqn_mod_dvd in e. 2: auto. rewrite subn0 in e. rewrite Natpow_expn in e. rewrite Euclid_dvdX in e. 2: auto. @@ -2758,6 +2772,17 @@ Proof. move: e => /eqP e. micromega.Lia.lia. Qed. +Lemma ptr_var_neq (ptr : pointer) (fn : funname) (v : var) : + translate_ptr ptr != translate_var fn v. +Proof. + unfold translate_ptr. + unfold translate_var. + unfold nat_of_fun_ident. + apply /eqP. intro e. + noconf e. + move: (ptr_var_nat_neq ptr fn v) => /eqP; contradiction. +Qed. + Notation coe_cht := coerce_to_choice_type. Notation coe_tyc := coerce_typed_code. @@ -2822,6 +2847,61 @@ Proof. apply injective_nat_of_ident. assumption. Qed. +Lemma coprime_mul_inj a b c d : + coprime a d -> coprime a b -> coprime c b -> coprime c d -> (a * b = c * d)%nat -> a = c /\ b = d. +Proof. + intros ad ab cb cd e. + move: e => /eqP. rewrite eqn_dvd. move=> /andP [d1 d2]. + rewrite Gauss_dvd in d1. 2: assumption. + rewrite Gauss_dvd in d2. 2: assumption. + move: d1 d2 => /andP [d11 d12] /andP [d21 d22]. + rewrite Gauss_dvdl in d11. 2: assumption. + rewrite Gauss_dvdr in d12. 2: rewrite coprime_sym; assumption. + rewrite Gauss_dvdl in d21. 2: assumption. + rewrite Gauss_dvdr in d22. 2: rewrite coprime_sym; assumption. + split. + - apply /eqP. rewrite eqn_dvd. by apply /andP. + - apply /eqP. rewrite eqn_dvd. by apply /andP. +Qed. + +Lemma coprime_nat_of_stype_nat_of_fun_ident t fn v : + coprime (nat_of_stype t) (nat_of_fun_ident fn v). +Proof. + unfold nat_of_fun_ident. + unfold nat_of_stype. + rewrite coprimeMr. + apply /andP. + destruct t. + - rewrite !Natpow_expn. + rewrite !coprime_pexpl. + 2,3: auto. + rewrite !coprime_pexpr. + 2: apply /ltP; apply nat_of_ident_pos. + 2: apply /ltP; pose proof nat_of_pos_nonzero fn; micromega.Lia.lia. + auto. + - rewrite !Natpow_expn. + rewrite !coprime_pexpl. + 2,3: auto. + rewrite !coprime_pexpr. + 2: apply /ltP; apply nat_of_ident_pos. + 2: apply /ltP; pose proof nat_of_pos_nonzero fn; micromega.Lia.lia. + auto. + - rewrite !Natpow_expn. + rewrite !coprime_pexpl. + 2,3: auto. + rewrite !coprime_pexpr. + 2: apply /ltP; apply nat_of_ident_pos. + 2: apply /ltP; pose proof nat_of_pos_nonzero fn; micromega.Lia.lia. + auto. + - rewrite !Natpow_expn. + rewrite !coprime_pexpl. + 2,3: auto. + rewrite !coprime_pexpr. + 2: apply /ltP; apply nat_of_ident_pos. + 2: apply /ltP; pose proof nat_of_pos_nonzero fn; micromega.Lia.lia. + auto. +Qed. + Lemma injective_translate_var : ∀ fn, injective (translate_var fn). Proof. @@ -2829,11 +2909,20 @@ Proof. unfold translate_var in e. destruct u as [uty u], v as [vty v]. simpl in e. noconf e. + unfold nat_of_fun_var in H0. + simpl in H0. + apply coprime_mul_inj in H0 as [e1 e2]. + 2,3,4,5: apply coprime_nat_of_stype_nat_of_fun_ident. f_equal. - - (* We need injectivity of encode which is not true for sarr! *) - give_up. - - eapply injective_nat_of_fun_ident. eassumption. -Admitted. + - destruct uty, vty; auto; try discriminate. + + apply Nat.pow_inj_r in e1. 2: auto. + apply succn_inj in e1. + apply Pos2Nat.inj in e1. + subst; reflexivity. + + noconf H. reflexivity. + - eapply injective_nat_of_fun_ident. + eassumption. +Qed. Lemma translate_write_correct : ∀ fn sz s p (w : word sz) cm (cond : heap → Prop), From 4a69b7b39e3d8065415534e9c6cfaf77c67a68bc Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Fri, 6 May 2022 20:49:21 +0200 Subject: [PATCH 225/383] added some notation and automation for program simplification --- theories/Jasmin/examples/bigadd/bigadd.v | 95 ++++++++++-------------- 1 file changed, 40 insertions(+), 55 deletions(-) diff --git a/theories/Jasmin/examples/bigadd/bigadd.v b/theories/Jasmin/examples/bigadd/bigadd.v index 33c0c976..9cbbc3ec 100644 --- a/theories/Jasmin/examples/bigadd/bigadd.v +++ b/theories/Jasmin/examples/bigadd/bigadd.v @@ -475,25 +475,16 @@ Notation " a [ w / p ] " := (at level 99, no associativity, format " a [ w / p ] "). - From Equations Require Import Equations. Set Equations With UIP. Set Equations Transparent. -Definition tr_bigadd := translate_prog bigadd. -Definition f_bigadd : ('array * 'array) -> raw_code 'array. -Proof. - pose tr_bigadd. unfold tr_bigadd in s. unfold translate_prog in s. - simpl in s. - destruct s eqn:E. - - unfold s in E. discriminate. - - pose (ffun p.2).π2.π2. - simpl in r. - unfold s in E. - noconf E. - (* simpl in r. *) - exact r. -Defined. +From extructures Require Import ord fset fmap. + +Definition empty_ufun_decl := (1%positive, {| f_info := 1%positive; f_tyin := [::]; f_params := [::]; f_body := [::]; f_tyout := [::]; f_res := [::]; f_extra := tt |}) : _ufun_decl. +Definition translate_simple_prog P := translate_fundef P emptym (List.nth_default empty_ufun_decl P.(p_funcs) 0). + +Definition fn_bigadd := Eval simpl in ((ffun (translate_simple_prog bigadd).2).π2).π2. Lemma eq_rect_K : forall (A : eqType) (x : A) (P : A -> Type) h e, @@ -504,51 +495,45 @@ Proof. reflexivity. Qed. -Eval cbn in tr_bigadd. -Goal forall aa, f_bigadd aa = f_bigadd aa. +From CoqWord Require Import word. - intros [a1 a2]. - unfold f_bigadd at 2. - unfold apply_noConfusion. - simpl. - unfold translate_write_var. simpl. - unfold translate_instr. simpl. - Opaque translate_for. - (* unfold translate_for. simpl. *) - rewrite !coerce_typed_code_K. - simpl. - unfold translate_var. simpl. - (* set (TODO := ('unit; distr.dnull)). *) - set (array32 := sarr 32%positive). - set (fn := 2%positive). - set (x := ('array; nat_of_fun_ident fn "x.140")). - set (xr := ('word U64; nat_of_fun_ident fn "xr.143")). - set (y := ('array; nat_of_fun_ident fn "y.141")). - set (yr := ('word U64; nat_of_fun_ident fn "yr.144")). - set (cf := ('bool; nat_of_fun_ident fn "cf.145")). - set (i := ('int; nat_of_fun_ident fn "i.146")). +Notation "$ i" := (_ ; nat_of_fun_ident _ i) (at level 99, + format "$ i"). - set (x_ := {| v_var := {| vtype := array32; vname := "x.140" |}; - v_info := (fn~0)%positive |}). - set (y_ := {| v_var := {| vtype := array32; vname := "y.141" |}; - v_info := (fn~1)%positive |}). +Notation "$$ i" := ({| v_var := {| vtype := _; vname := i |}; v_info := _ |}) + (at level 99, + format "$$ i"). - unfold coerce_chtuple_to_list; simpl. - rewrite eq_rect_r_K. - simpl. - fold x y. +Notation "'for var ∈ seq" := (translate_for _ ($$var) seq) + (at level 99). - unfold bind_list'. simpl. - unfold bind_list_trunc_aux. simpl. - rewrite eq_rect_K. +Ltac prog_unfold := unfold translate_write_var, translate_instr, translate_var, coerce_chtuple_to_list, bind_list', bind_list_trunc_aux, wsize_size. +Hint Rewrite coerce_typed_code_K eq_rect_K eq_rect_r_K : prog_rewrite. - unfold translate_var. simpl. - set (res := ('array; nat_of_fun_ident fn "res.142")). +Opaque translate_for. +Ltac simpl_fun := + repeat (match goal with + | _ => progress autorewrite with prog_rewrite + | _ => prog_unfold; simpl + | [ |- context[nat_of_fun_ident ?fn _] ] => set (f_name := fn) in * + end). + +Goal forall aa goal, fn_bigadd aa = goal. + intros [a1 a2] goal. + unfold fn_bigadd. + simpl_fun. + + (* BSH: the setoid_rewrites takes forever if we do not 'set' these names first *) + set (array32 := sarr 32%positive). + set (x := $"x.140"). + set (xr := $"xr.143"). + set (y := $"y.141"). + set (yr := $"yr.144"). + set (cf := $"cf.145"). + set (i := $"i.146"). + set (res := $"res.142"). - time repeat setoid_rewrite (@zero_extend_u U64). - unfold wsize_size. - rewrite !coerce_to_choice_type_K. setoid_rewrite coerce_to_choice_type_K. setoid_rewrite coerce_to_choice_type_K. - - (* Strangely, some instances of coe_cht don't get simplified away here. *) + time repeat setoid_rewrite (@zero_extend_u U64). +Admitted. From fdc6172c20ee3d4999c603b3935f4e3aec942388 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Fri, 6 May 2022 20:50:51 +0200 Subject: [PATCH 226/383] remove nop in tactic --- theories/Jasmin/examples/bigadd/bigadd.v | 1 - 1 file changed, 1 deletion(-) diff --git a/theories/Jasmin/examples/bigadd/bigadd.v b/theories/Jasmin/examples/bigadd/bigadd.v index 9cbbc3ec..7717422a 100644 --- a/theories/Jasmin/examples/bigadd/bigadd.v +++ b/theories/Jasmin/examples/bigadd/bigadd.v @@ -515,7 +515,6 @@ Ltac simpl_fun := repeat (match goal with | _ => progress autorewrite with prog_rewrite | _ => prog_unfold; simpl - | [ |- context[nat_of_fun_ident ?fn _] ] => set (f_name := fn) in * end). Goal forall aa goal, fn_bigadd aa = goal. From 4002c7b2f32969b3c4008612476045aa49723f1a Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Sat, 7 May 2022 14:00:39 +0100 Subject: [PATCH 227/383] fun with funs --- theories/Crypt/choice_type.v | 78 +++++++ theories/Jasmin/jasmin_translate.v | 318 ++++++++++++++++++++--------- 2 files changed, 303 insertions(+), 93 deletions(-) diff --git a/theories/Crypt/choice_type.v b/theories/Crypt/choice_type.v index 721c4249..71ad7347 100644 --- a/theories/Crypt/choice_type.v +++ b/theories/Crypt/choice_type.v @@ -54,6 +54,84 @@ Inductive choice_type := | chList (A : choice_type) . +Module ind_rec. + Inductive Ud : Set → Type := + | unit_d : Ud unit + | nat_d : Ud nat + | sig_d : forall A (a : Ud A) (B : A → Set) (b : forall (x:A), Ud (B x)), + Ud (sigT B) + . + Record U : Type := mk_U {El : Set ; univ : Ud El}. + + Definition chNat := mk_U nat nat_d. + Definition chSig (a : U) (b : El a -> U) : U. + unshelve econstructor. + - exact (sigT (fun x : El a => El (b x))). + - eapply (sig_d (El a) (univ a) + (λ x : El a, El (b x)) + (λ x, univ (b x))). + Defined. + Derive NoConfusion for Ud. + Fail Derive NoConfusionHom for Ud. + Definition U_choice_type := boolp.choice_of_Type U. + + Canonical choice_type_choiceType := + U_choice_type. + + Axiom choice_type_leq : U -> U -> bool. + Axiom choice_type_leqP : Ord.axioms choice_type_leq. + Definition choice_type_ordMixin := OrdMixin choice_type_leqP. + Canonical choice_type_ordType := + Eval hnf in OrdType U choice_type_ordMixin. + + +Definition word_ordMixin nbits := [ ordMixin of word nbits by <: ]. +Canonical word_ordType nbits := Eval hnf in OrdType (word nbits) (word_ordMixin nbits). + +Fixpoint chElement_ordType A (a : Ud A) : ordType := + match a with + | unit_d => unit_ordType + | nat_d => nat_ordType + | _ => unit_ordType + (* | chUnit => unit_ordType *) + (* | chNat => nat_ordType *) + (* | chInt => Z_ordType *) + (* | chBool => bool_ordType *) + (* | chProd U1 U2 => prod_ordType (chElement_ordType U1) (chElement_ordType U2) *) + (* | chMap U1 U2 => fmap_ordType (chElement_ordType U1) (chElement_ordType U2) *) + (* | chOption U => option_ordType (chElement_ordType U) *) + (* | chFin n => [ordType of ordinal n.(pos) ] *) + (* | chWord nbits => word_ordType nbits *) + (* | chList U => seq_ordType (chElement_ordType U) *) + end. +Search (choiceType -> choiceType). + +Eval compute in (@order.Order.SigmaOrder.le + _ _ order.Order.NatOrder.porderType + (fun _ => order.Order.BoolOrder.porderType) + (42; true) (42; true) + ). + +Search (order.Order.POrder.type ?t). + +Fixpoint chElement (U : choice_type) : choiceType := + match U with + | chUnit => unit_choiceType + | chNat => nat_choiceType + | chInt => Z_choiceType + | chBool => bool_choiceType + | chProd U1 U2 => prod_choiceType (chElement U1) (chElement U2) + | chMap U1 U2 => fmap_choiceType (chElement_ordType U1) (chElement U2) + | chOption U => option_choiceType (chElement U) + | chFin n => [choiceType of ordinal n.(pos) ] + | chWord nbits => word_choiceType nbits + | chList U => seq_choiceType (chElement U) + end. + +Coercion chElement : choice_type >-> choiceType. + +End ind_rec. + Derive NoConfusion NoConfusionHom for choice_type. Definition word_ordMixin nbits := [ ordMixin of word nbits by <: ]. diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index e105261f..eb4fa5f5 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1186,23 +1186,62 @@ Fixpoint translate_write_lvals (fn : funname) (ls : lvals) (vs : list typed_chEl end end. -Fixpoint translate_instr_r (prog_exports : {fmap funname -> opsig}) (fn : funname) (i : instr_r) {struct i} : raw_code 'unit +Definition fdefs := + (* ∀ fn fdef, get_fundef (p_funcs P) fn = Some fdef -> raw_code 'unit. *) + list (funname * + ([choiceType of seq typed_chElement] -> raw_code [choiceType of seq typed_chElement])). + +Definition trunc_list := + (λ tys (vs : seq typed_chElement), + [seq let '(ty, v) := ty_v in totce (truncate_el ty v.π2) | ty_v <- zip tys vs]). + +Definition set_up_funcall (fn : funname) (tr_f_body : fdefs) + (vargs : [choiceType of seq typed_chElement]) + : raw_code [choiceType of list typed_chElement]. +Proof. + (* sem_call *) + destruct (get_fundef (p_funcs P) fn) as [[]|] eqn:E ; [ | exact (ret [::])]. + apply (trunc_list f_tyin) in vargs. + pose (map (λ '(x, (ty; v)), translate_write_var fn x (totce v)) + (zip f_params vargs)) + as cargs. + apply (foldl (λ c k, c ;; k) (ret tt)) in cargs. + apply (bind cargs) => _. + (* Perform the function body. *) + destruct (assoc tr_f_body fn) as [tr_f|]. 2: exact (ret [::]). + (* apply (bind (tr_f_body _ _ E)) => _. *) + (* pose (tr_f_body _ _ E) as tr_f. *) + apply (bind (tr_f vargs)) => _. + (* Look up the results in their locations and coerce them. *) + pose (map (λ x, totc _ (translate_get_var fn (v_var x))) f_res) as cres. + pose (bind_list cres) as vs. + eapply bind. 1: exact vs. + intros vres. clear cres vs. + apply (trunc_list f_tyout) in vres. + exact (ret vres). +Defined. + +Fixpoint translate_instr_r + (tr_f_body : fdefs) + (fn : funname) (i : instr_r) {struct i} + : raw_code 'unit -with translate_instr (prog_exports : {fmap funname -> opsig}) (fn : funname) (i : instr) {struct i} : raw_code 'unit := - translate_instr_r prog_exports fn (instr_d i). +with translate_instr (tr_f_body : fdefs) + (fn : funname) (i : instr) {struct i} : raw_code 'unit := + translate_instr_r tr_f_body fn (instr_d i). Proof. pose proof (translate_cmd := (fix translate_cmd (fn : funname) (c : cmd) : raw_code 'unit := match c with | [::] => ret tt | i :: c => - translate_instr prog_exports fn i ;; + translate_instr tr_f_body fn i ;; translate_cmd fn c end ) ). - destruct i as [ | ls _ o es | e c1 c2 | i [[d lo] hi] c | | ii xs f args ]. + destruct i as [ | ls _ o es | e c1 c2 | i [[d lo] hi] c | | ii xs gn args ]. - (* Cassgn *) (* l :a=_s p *) pose (translate_pexpr fn p) as tr_p. @@ -1233,54 +1272,68 @@ Proof. ). - exact (unsupported.π2). (* Cwhile *) - (* Ccall ii xs f args *) + rename fn into fn_ambient. rename gn into fn. (* Translate arguments. *) - pose (map (translate_pexpr f) args) as tr_args. - - (* We need some typing about the translated and original f, let's look it - up. *) - destruct (prog_exports f) as [f_sg|]. - 2: { - (* The function `f` wasn't found in the exports. This should mean that - the Jasmin semantics also failed at `sem_call` where - `get_fundef (p_funcs P) f = Some f'` is expected. *) - exact (unsupported.π2). - } - destruct (get_fundef (p_funcs P) f) eqn:E. - 2: exact (unsupported.π2). - - (* Evaluate & truncate arguments according to the Jasmin typing of `f`. *) - (* Note that in Ecall we do not need to truncate, as sem_call does not - enforce any relation between the types of the function and the - arguments. But we need the types to match. sem_call, however, does - truncate as soon as the type of `f` is looked up. *) - pose (bind_list' _f.(f_tyin) tr_args) as vargs'. - (* pose (bind_list [seq translate_pexpr fn e | e <- args]) as vargs'. *) - (* Bind the values. *) - apply (bind vargs'). intros vargs. - (* Now "perform" the call via `opr`. *) - apply (opr f_sg). - + exact (coerce_to_choice_type (chsrc f_sg) vargs). - + intros vs. - - (* Unpack `vs : tgt f_sg` into a list in order to write `xs`. *) - pose (f_tyout _f) as f_tyout. - apply (coerce_chtuple_to_list _ f_tyout) in vs. - pose (zip f_tyout vs) as vs_f. - - (* We coerce rather than truncating here. The truncation should happen - in sem_call; the coercion should never fail on well-translated - functions. Presumably these results just got truncated in sem_call, - so we could also truncate instead of coercing if convenient. *) - pose (map (λ '(ty,c), - let ty' := encode ty in - (totce (coerce_to_choice_type ty' c.π2)) : typed_chElement) vs_f) - as vres'. - (* pose (map (λ '(ty,c), (truncate_code ty (totc c.π1 (ret c.π2)))) l0) as vres'. *) - - pose (map (λ '(x,v), translate_write_lval fn x v) (zip xs vres')) as vres''. - exact (foldl (λ c k, c ;; k) (ret tt) vres''). + pose (cs := [seq (translate_pexpr fn_ambient e) | e <- args]). + pose (vs := bind_list cs). + eapply bind. 1: exact vs. + intros vargs. clear cs vs. + + apply (bind (set_up_funcall fn tr_f_body vargs)) => vres. + + pose (map (λ '(x, (ty; v)), translate_write_lval fn_ambient x (totce v)) + (zip xs vres)) + as cres. + apply (foldl (λ c k, c ;; k) (ret tt)) in cres. + exact cres. Defined. +(* + Questions to answer for the translation of functions and function calls: + - When does argument truncation happen? + - What does each function get translated to? + + Idea 0: translate the function body each time it gets called. + This doesn't work if we look up the body in a dictionary à la `get_fundef`. If we try to apply `translate_cmd` to the result of a function call, + we have no guarantee this will terminate. + + Idea 1: + - Each jasmin function gets translated into a typed_raw_function + - The translation of a jasmin instruction is parametrised by a dictionary associating to each function name such a typed_raw_function. + - Each function call can then look up the translated function. + + The problem with this approach is that Jasmin functions don't expect their arguments to be of the right type. + Instead, they perform a truncation on the callee side. + To emulate this behaviour we would have to allow the application of a function to arguments of the wrong type. + This won't work with a `typed_raw_function = ∑ S T : choice_type, S → raw_code T` , as the arguments have to match the function type. + + A workaround would be to pack the arguments into a list of `typed_chElement`, i.e. `list (∑ t : choice_type, t)`, + but this type is too large to live inside `choice_type`. + Instead, we could translate each jasmin function to a "large" `Typed_Raw_Function = Π S T : choiceType, S → raw_code T`, + or more precisely `Π S T : list stype, [seq encode s | s <- S] → raw_code [seq encode t | t <- T]`, + or equivalently `list (Σ s : stype, encode s) → list (Σ t : stype, encode t)`. + + As a result, the translated functions do not fit `typed_raw_function`, + cannot directly be described by an `opsig`, + and thus can't be wrapped in a `raw_package`. + Question: Could we generalise the definition of `raw_package` to allow `Typed_Raw_Functions`? + + Instead of modifying `raw_package`, we could add Σ-types to `choice_type`. + This could be done using Paulin-Mohring's trick for representing inductive-recursive definitions in Coq. + As a first test we could use `boolp.choice_of_Type` to get the choice structure on the universe. + The `ordType` structure could come from `order.Order.SigmaOrder.le`. + Question: Do we rely on the computational properties of the choice structure of `choice_universe`? + + Idea 2: + - Each Jasmin function gets translated to a `'unit raw_code` corresponding to its body. + - translate_instr takes a map from funnames to translated fun bodies. + - There is an additional wrapper function + `set_up_funcall : funname → (args : seq value) → (f_tyin : seq stype) -> (f_tr_body : 'unit raw_code) -> 'unit raw_code` + that does the work of truncating, and storing the function arguments as well as the returned results into their locations. + - the main theorem then talks not about running the translation of a function, but instead about set_up_funcall + + *) + (* translate_instr is blocked because it is a fixpoint *) Lemma translate_instr_unfold : ∀ ep fn i, @@ -1293,12 +1346,12 @@ Qed. (* Trick to have it expand to the same as the translate_cmd above *) Section TranslateCMD. -Context (prog_exports : {fmap funname -> opsig}). +Context (tr_f_body : fdefs). Fixpoint translate_cmd (fn : funname) (c : cmd) : raw_code 'unit := match c with | [::] => ret tt - | i :: c => translate_instr prog_exports fn i ;; translate_cmd fn c + | i :: c => translate_instr tr_f_body fn i ;; translate_cmd fn c end. End TranslateCMD. @@ -1312,7 +1365,8 @@ Record fdef := { #[local] Definition ty_in fd := (ffun fd).π1. #[local] Definition ty_out fd := ((ffun fd).π2).π1. -Definition translate_fundef (prog_exports : {fmap funname -> opsig}) +Definition translate_fundef + (tr_f_body : fdefs) (fd : _ufun_decl (* extra_fun_t *)) : funname * fdef. Proof. destruct fd. destruct _f. @@ -1340,7 +1394,7 @@ Proof. apply (bind cargs) => _. (* Perform the function body. *) - apply (bind (translate_cmd prog_exports f f_body)) => _. + apply (bind (translate_cmd tr_f_body f f_body)) => _. (* Look up the results in their locations and return them. *) pose (map (λ x, totc _ (translate_get_var f (v_var x))) f_res) as cres. @@ -2771,17 +2825,31 @@ Proof. - admit. Admitted. -Definition ssprove_prog := seq (funname * fdef). -Definition exports_of_prog (p : ssprove_prog) : {fmap funname -> opsig} := - foldl (λ m f, setm m f.1 (nat_of_pos f.1, (ty_in f.2, ty_out f.2))) - emptym p. +Definition ssprove_prog := fdefs. + +Definition translate_prog : ssprove_prog. +Proof. + destruct P. + induction p_funcs. + - exact [::]. + - unfold ssprove_prog. + apply cons. 2: exact IHp_funcs. + pose a.1 as fn. + split. 1: exact fn. + exact (set_up_funcall fn IHp_funcs). +Defined. -Definition translate_prog : ssprove_prog := - foldl (λ p f, - let f' := translate_fundef (exports_of_prog p) f in - f' :: p - ) [::] P.(p_funcs). +Definition translate_prog' := + let fix translate_funs (fs : seq _ufun_decl) : ssprove_prog := + match fs with + [::] => [::] + | f :: fs' => + let tr_fs' := translate_funs fs' in + let fn := f.1 in + (fn, set_up_funcall fn tr_fs') :: tr_fs' + end in + translate_funs (p_funcs P). (** Handled programs @@ -2813,49 +2881,48 @@ Definition handled_fundecl (f : _ufun_decl) := Definition handled_program := List.forallb handled_fundecl P.(p_funcs). -Theorem translate_prog_correct (fn : funname) m va m' vr f : +Definition Pfun (fn : funname) m va m' vr := + forall f, handled_program → - sem.sem_call P m fn va m' vr → let sp := translate_prog in let dom := lchtuple (map choice_type_of_val va) in let cod := lchtuple (map choice_type_of_val vr) in - get_fundef_ssp sp fn dom cod = Some f → - ⊢ ⦃ λ m, True ⦄ - f (translate_values va) ⇓ translate_values vr - ⦃ λ m, True ⦄. + (* get_fundef_ssp sp fn dom cod = Some f → *) + assoc sp fn = Some f → + ⊢ ⦃ rel_mem m ⦄ + set_up_funcall fn sp [seq totce (translate_value v) | v <- va] + (* f [seq totce (translate_value v) | v <- va] *) + ⇓ [seq totce (translate_value v) | v <- vr] + ⦃ rel_mem m' ⦄. + +Theorem translate_prog_correct (fn : funname) m va m' vr : + sem.sem_call P m fn va m' vr → + Pfun fn m va m' vr. Proof. - intros hP H. + intros H hP. set (Pfun := λ (m : mem) (fn : funname) (va : seq value) (m' : mem) (vr : seq value), - ∀ f, - handled_program → - let sp := translate_prog in - let dom := lchtuple [seq choice_type_of_val i | i <- va] in - let cod := lchtuple [seq choice_type_of_val i | i <- vr] in - get_fundef_ssp sp fn dom cod = Some f → - ⊢ ⦃ λ m, True ⦄ - f (translate_values va) ⇓ translate_values vr - ⦃ λ m, True ⦄ + Pfun fn m va m' vr ). - set (ep := exports_of_prog translate_prog). + set (SP := translate_prog). set (Pi_r := λ (s1 : estate) (i : instr_r) (s2 : estate), handled_instr_r i → ⊢ ⦃ rel_estate s1 fn ⦄ - translate_instr_r ep fn i ⇓ tt + translate_instr_r SP fn i ⇓ tt ⦃ rel_estate s2 fn ⦄ ). set (Pi := λ s1 i s2, Pi_r s1 (instr_d i) s2). set (Pc := λ (s1 : estate) (c : cmd) (s2 : estate), handled_cmd c → - ⊢ ⦃ rel_estate s1 fn ⦄ translate_cmd ep fn c ⇓ tt ⦃ rel_estate s2 fn ⦄ + ⊢ ⦃ rel_estate s1 fn ⦄ translate_cmd SP fn c ⇓ tt ⦃ rel_estate s2 fn ⦄ ). set (Pfor := λ (v : var_i) (ws : seq Z) (s1 : estate) (c : cmd) (s2 : estate), handled_cmd c → ⊢ ⦃ rel_estate s1 fn ⦄ - translate_for fn v ws (translate_cmd ep fn c) ⇓ tt + translate_for fn v ws (translate_cmd SP fn c) ⇓ tt ⦃ rel_estate s2 fn ⦄ ). unshelve eapply (@sem_call_Ind _ _ _ _ Pc Pi_r Pi Pfor Pfun _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H). @@ -2890,7 +2957,7 @@ Proof. red. simpl. move /andP => [hdc1 hdc2]. lazymatch goal with | |- context [ if _ then ?f ?fn ?c else _ ] => - change (f fn c) with (translate_cmd ep fn c) + change (f fn c) with (translate_cmd SP fn c) end. eapply u_bind. 1:{ eapply translate_pexpr_correct_cast in he. all: eauto. } @@ -2900,7 +2967,7 @@ Proof. red. simpl. move /andP => [hdc1 hdc2]. (* lazymatch goal with | |- context [ if _ then _ else (?f ?fn ?c) ] => - change (f fn c) with (translate_cmd ep fn c) + change (f fn c) with (translate_cmd SP fn c) end. *) eapply u_bind. 1:{ eapply translate_pexpr_correct_cast in he. all: eauto. } @@ -2916,7 +2983,7 @@ Proof. red. simpl. intros hdc. lazymatch goal with | |- context [ translate_for _ _ _ (?f ?fn ?c) ] => - change (f fn c) with (translate_cmd ep fn c) + change (f fn c) with (translate_cmd SP fn c) end. eapply u_bind. 1:{ eapply translate_pexpr_correct_cast in hlo. all: eauto. } @@ -2939,15 +3006,80 @@ Proof. } apply ihfor. assumption. - (* call *) - red. intros s1 m2 s2 ii xs gn args vargs vs hargs hvs ihvs hw. + clear -pT. + red. + intros s1 m2 s2 ii xs gn args vargs vres hargs hgn ihgn hwr_vres. + unfold Pfun in ihgn. + unfold Translation.Pfun in ihgn. red. simpl. intros _. - admit. - - red. intros m1 m2 gn g vs vs' s1 vm2 vrs vrs'. + eapply u_bind. + + eapply bind_list_correct with (vs := vargs). + * rewrite <- map_comp. + unfold comp. + eapply translate_pexprs_types. + exact hargs. + (* this should maybe be a lemma or the condition in bind_list_correct should be rewrote to match H *) + * (* clear -h2 H hcond. *) + (* revert v' h2 H. *) + clear hgn ihgn. + revert vargs hargs. + induction args; intros. + ** inversion hargs. + constructor. + ** inversion hargs as [H1]. + jbind H1 x Hx. + jbind H1 y Hy. + noconf H1. + constructor. + *** eapply translate_pexpr_correct. + 1: eassumption. + easy. + *** simpl. eapply IHargs. + 1: assumption. + + simpl. + (* unfold Pfun, Translation.Pfun in ihgn. *) + eapply u_bind. + * simpl. + unshelve eapply u_pre_weaken_rule with (p1 := (rel_mem (emem s1))). + 2: move => h Hh; apply Hh. + unfold SP. unfold SP in Pi_r. clear SP. + (* destruct hgn as [_m1 _m2 _gn _g _vargs _vargs' _s1 _vm2 _vres _vres' get_g _hvargs *) + (* _hwr_vargs _hbody _h_get_res _h_trunc_res]. *) + eapply ihgn. + 1: give_up. + instantiate (1 := set_up_funcall gn translate_prog). + give_up. + * (* should be similar to Copn, by appealing to correctness of write_lvals. *) + simpl. + admit. + - unfold sem_Ind_proc. red. intros m1 m2 gn g vs vs' s1 vm2 vrs vrs'. intros hg hvs ?????. - unfold Pfun. intros f' hdp hf'. - (* Maybe have a dedicated lemma linking to hg? *) - unfold get_fundef_ssp in hf'. - admit. + unfold Pfun, Translation.Pfun. intros hp hf. + destruct H. + unfold set_up_funcall. + rewrite hg. + destruct g eqn:E. + rewrite -E in hg hvs H0 H1 H2 H3 H4. + destruct (assoc SP gn) as [SP_gn|] eqn:E'. + 2: { move => E''. unfold SP in E'. rewrite E' in E''. discriminate. } + rewrite E'. move => E''. noconf E''. + set (cargs := map (λ '(x, (ty; v)), translate_write_var gn x (totce v)) + (zip f_params + [seq (let + '(ty, v) := ty_v in totce (truncate_el ty v.π2)) + | ty_v <- zip f_tyin + [seq totce (translate_value v) + | v <- vs']])) + . + eapply u_bind with (v₁ := tt) ; [unfold cargs|]; clear cargs. + 1: { idtac. + instantiate (1 := rel_estate s1 gn). + admit. + } + eapply u_bind with (* (v₁ := [seq totce (translate_value v) | v <- vrs']) *) + (q := rel_estate s1 gn). + + give_up. + + give_up. Admitted. End Translation. From 0917e208bb147f0c47b2f51d1c9c383ddf5a5b5a Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Sat, 7 May 2022 14:01:48 +0100 Subject: [PATCH 228/383] revert experiment to add dependent pairs to choice_type --- theories/Crypt/choice_type.v | 78 ------------------------------------ 1 file changed, 78 deletions(-) diff --git a/theories/Crypt/choice_type.v b/theories/Crypt/choice_type.v index 71ad7347..721c4249 100644 --- a/theories/Crypt/choice_type.v +++ b/theories/Crypt/choice_type.v @@ -54,84 +54,6 @@ Inductive choice_type := | chList (A : choice_type) . -Module ind_rec. - Inductive Ud : Set → Type := - | unit_d : Ud unit - | nat_d : Ud nat - | sig_d : forall A (a : Ud A) (B : A → Set) (b : forall (x:A), Ud (B x)), - Ud (sigT B) - . - Record U : Type := mk_U {El : Set ; univ : Ud El}. - - Definition chNat := mk_U nat nat_d. - Definition chSig (a : U) (b : El a -> U) : U. - unshelve econstructor. - - exact (sigT (fun x : El a => El (b x))). - - eapply (sig_d (El a) (univ a) - (λ x : El a, El (b x)) - (λ x, univ (b x))). - Defined. - Derive NoConfusion for Ud. - Fail Derive NoConfusionHom for Ud. - Definition U_choice_type := boolp.choice_of_Type U. - - Canonical choice_type_choiceType := - U_choice_type. - - Axiom choice_type_leq : U -> U -> bool. - Axiom choice_type_leqP : Ord.axioms choice_type_leq. - Definition choice_type_ordMixin := OrdMixin choice_type_leqP. - Canonical choice_type_ordType := - Eval hnf in OrdType U choice_type_ordMixin. - - -Definition word_ordMixin nbits := [ ordMixin of word nbits by <: ]. -Canonical word_ordType nbits := Eval hnf in OrdType (word nbits) (word_ordMixin nbits). - -Fixpoint chElement_ordType A (a : Ud A) : ordType := - match a with - | unit_d => unit_ordType - | nat_d => nat_ordType - | _ => unit_ordType - (* | chUnit => unit_ordType *) - (* | chNat => nat_ordType *) - (* | chInt => Z_ordType *) - (* | chBool => bool_ordType *) - (* | chProd U1 U2 => prod_ordType (chElement_ordType U1) (chElement_ordType U2) *) - (* | chMap U1 U2 => fmap_ordType (chElement_ordType U1) (chElement_ordType U2) *) - (* | chOption U => option_ordType (chElement_ordType U) *) - (* | chFin n => [ordType of ordinal n.(pos) ] *) - (* | chWord nbits => word_ordType nbits *) - (* | chList U => seq_ordType (chElement_ordType U) *) - end. -Search (choiceType -> choiceType). - -Eval compute in (@order.Order.SigmaOrder.le - _ _ order.Order.NatOrder.porderType - (fun _ => order.Order.BoolOrder.porderType) - (42; true) (42; true) - ). - -Search (order.Order.POrder.type ?t). - -Fixpoint chElement (U : choice_type) : choiceType := - match U with - | chUnit => unit_choiceType - | chNat => nat_choiceType - | chInt => Z_choiceType - | chBool => bool_choiceType - | chProd U1 U2 => prod_choiceType (chElement U1) (chElement U2) - | chMap U1 U2 => fmap_choiceType (chElement_ordType U1) (chElement U2) - | chOption U => option_choiceType (chElement U) - | chFin n => [choiceType of ordinal n.(pos) ] - | chWord nbits => word_choiceType nbits - | chList U => seq_choiceType (chElement U) - end. - -Coercion chElement : choice_type >-> choiceType. - -End ind_rec. - Derive NoConfusion NoConfusionHom for choice_type. Definition word_ordMixin nbits := [ ordMixin of word nbits by <: ]. From 150a74a76918388c062cd5c8088c28855c1b3793 Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Mon, 9 May 2022 10:11:20 +0100 Subject: [PATCH 229/383] move translate_instr down to right before translate_prog --- theories/Jasmin/jasmin_translate.v | 471 ++++++++++++++--------------- 1 file changed, 235 insertions(+), 236 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 3197bb3b..23c908b1 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1189,10 +1189,6 @@ Fixpoint foldl2 {A B R} (f : R → A → B → R) (la : seq A) (lb : seq B) r := end end. -Definition fdefs := - (* ∀ fn fdef, get_fundef (p_funcs P) fn = Some fdef -> raw_code 'unit. *) - list (funname * - ([choiceType of seq typed_chElement] -> raw_code [choiceType of seq typed_chElement])). Fixpoint foldr2 {A B R} (f : A → B → R → R) (la : seq A) (lb : seq B) r := match la with | [::] => r @@ -1207,238 +1203,6 @@ Definition translate_write_lvals fn ls vs := (* foldl2 (λ c l v, translate_write_lval fn l v ;; c) ls vs (ret tt). *) foldr2 (λ l v c, translate_write_lval fn l v ;; c) ls vs (ret tt). - -Definition trunc_list := - (λ tys (vs : seq typed_chElement), - [seq let '(ty, v) := ty_v in totce (truncate_el ty v.π2) | ty_v <- zip tys vs]). - -Definition set_up_funcall (fn : funname) (tr_f_body : fdefs) - (vargs : [choiceType of seq typed_chElement]) - : raw_code [choiceType of list typed_chElement]. -Proof. - (* sem_call *) - destruct (get_fundef (p_funcs P) fn) as [[]|] eqn:E ; [ | exact (ret [::])]. - apply (trunc_list f_tyin) in vargs. - pose (map (λ '(x, (ty; v)), translate_write_var fn x (totce v)) - (zip f_params vargs)) - as cargs. - apply (foldl (λ c k, c ;; k) (ret tt)) in cargs. - apply (bind cargs) => _. - (* Perform the function body. *) - destruct (assoc tr_f_body fn) as [tr_f|]. 2: exact (ret [::]). - (* apply (bind (tr_f_body _ _ E)) => _. *) - (* pose (tr_f_body _ _ E) as tr_f. *) - apply (bind (tr_f vargs)) => _. - (* Look up the results in their locations and coerce them. *) - pose (map (λ x, totc _ (translate_get_var fn (v_var x))) f_res) as cres. - pose (bind_list cres) as vs. - eapply bind. 1: exact vs. - intros vres. clear cres vs. - apply (trunc_list f_tyout) in vres. - exact (ret vres). -Defined. - -Fixpoint translate_instr_r - (tr_f_body : fdefs) - (fn : funname) (i : instr_r) {struct i} - : raw_code 'unit - -with translate_instr (tr_f_body : fdefs) - (fn : funname) (i : instr) {struct i} : raw_code 'unit := - translate_instr_r tr_f_body fn (instr_d i). -Proof. - pose proof (translate_cmd := - (fix translate_cmd (fn : funname) (c : cmd) : raw_code 'unit := - match c with - | [::] => ret tt - | i :: c => - translate_instr tr_f_body fn i ;; - translate_cmd fn c - end - ) - ). - - destruct i as [ | ls _ o es | e c1 c2 | i [[d lo] hi] c | | ii xs gn args ]. - - (* Cassgn *) - (* l :a=_s p *) - pose (translate_pexpr fn p) as tr_p. - eapply bind. 1: exact (tr_p.π2). - intros v. pose (truncate_el s v) as tr_v. - exact (translate_write_lval fn l (totce tr_v)). - - (* Copn *) - pose (cs := [seq (translate_pexpr fn e) | e <- es]). - pose (vs := bind_list cs). - eapply bind. 1: exact vs. intros bvs. - pose (out := translate_exec_sopn o bvs). - exact (translate_write_lvals fn ls out). (* BSH: I'm not sure if the outputs should be truncated? *) - - (* Cif e c1 c2 *) - pose (e' := translate_pexpr fn e). - pose (c1' := translate_cmd fn c1). - pose (c2' := translate_cmd fn c2). - pose (rb := coerce_typed_code 'bool e'). - exact (b ← rb ;; if b then c1' else c2'). - - (* Cfor i (d, lo, hi) c *) - (* pose (iᵗ := translate_var fn i). *) (* Weird not to do it *) - pose (loᵗ := coerce_typed_code 'int (translate_pexpr fn lo)). - pose (hiᵗ := coerce_typed_code 'int (translate_pexpr fn hi)). - pose (cᵗ := translate_cmd fn c). - exact ( - vlo ← loᵗ ;; - vhi ← hiᵗ ;; - translate_for fn i (wrange d vlo vhi) cᵗ - ). - - exact (unsupported.π2). (* Cwhile *) - - (* Ccall ii xs f args *) - rename fn into fn_ambient. rename gn into fn. - (* Translate arguments. *) - pose (cs := [seq (translate_pexpr fn_ambient e) | e <- args]). - pose (vs := bind_list cs). - eapply bind. 1: exact vs. - intros vargs. clear cs vs. - - apply (bind (set_up_funcall fn tr_f_body vargs)) => vres. - - pose (map (λ '(x, (ty; v)), translate_write_lval fn_ambient x (totce v)) - (zip xs vres)) - as cres. - apply (foldl (λ c k, c ;; k) (ret tt)) in cres. - exact cres. -Defined. - -(* - Questions to answer for the translation of functions and function calls: - - When does argument truncation happen? - - What does each function get translated to? - - Idea 0: translate the function body each time it gets called. - This doesn't work if we look up the body in a dictionary à la `get_fundef`. If we try to apply `translate_cmd` to the result of a function call, - we have no guarantee this will terminate. - - Idea 1: - - Each jasmin function gets translated into a typed_raw_function - - The translation of a jasmin instruction is parametrised by a dictionary associating to each function name such a typed_raw_function. - - Each function call can then look up the translated function. - - The problem with this approach is that Jasmin functions don't expect their arguments to be of the right type. - Instead, they perform a truncation on the callee side. - To emulate this behaviour we would have to allow the application of a function to arguments of the wrong type. - This won't work with a `typed_raw_function = ∑ S T : choice_type, S → raw_code T` , as the arguments have to match the function type. - - A workaround would be to pack the arguments into a list of `typed_chElement`, i.e. `list (∑ t : choice_type, t)`, - but this type is too large to live inside `choice_type`. - Instead, we could translate each jasmin function to a "large" `Typed_Raw_Function = Π S T : choiceType, S → raw_code T`, - or more precisely `Π S T : list stype, [seq encode s | s <- S] → raw_code [seq encode t | t <- T]`, - or equivalently `list (Σ s : stype, encode s) → list (Σ t : stype, encode t)`. - - As a result, the translated functions do not fit `typed_raw_function`, - cannot directly be described by an `opsig`, - and thus can't be wrapped in a `raw_package`. - Question: Could we generalise the definition of `raw_package` to allow `Typed_Raw_Functions`? - - Instead of modifying `raw_package`, we could add Σ-types to `choice_type`. - This could be done using Paulin-Mohring's trick for representing inductive-recursive definitions in Coq. - As a first test we could use `boolp.choice_of_Type` to get the choice structure on the universe. - The `ordType` structure could come from `order.Order.SigmaOrder.le`. - Question: Do we rely on the computational properties of the choice structure of `choice_universe`? - - Idea 2: - - Each Jasmin function gets translated to a `'unit raw_code` corresponding to its body. - - translate_instr takes a map from funnames to translated fun bodies. - - There is an additional wrapper function - `set_up_funcall : funname → (args : seq value) → (f_tyin : seq stype) -> (f_tr_body : 'unit raw_code) -> 'unit raw_code` - that does the work of truncating, and storing the function arguments as well as the returned results into their locations. - - the main theorem then talks not about running the translation of a function, but instead about set_up_funcall - - *) - -(* translate_instr is blocked because it is a fixpoint *) -Lemma translate_instr_unfold : - ∀ ep fn i, - translate_instr ep fn i = translate_instr_r ep fn (instr_d i). -Proof. - intros ep fn i. - destruct i. reflexivity. -Qed. - -(* Trick to have it expand to the same as the translate_cmd above *) -Section TranslateCMD. - -Context (tr_f_body : fdefs). - -Fixpoint translate_cmd (fn : funname) (c : cmd) : raw_code 'unit := - match c with - | [::] => ret tt - | i :: c => translate_instr tr_f_body fn i ;; translate_cmd fn c - end. - -End TranslateCMD. - -Record fdef := { - ffun : typed_raw_function ; - locs : {fset Location} ; - imp : Interface ; -}. - -#[local] Definition ty_in fd := (ffun fd).π1. -#[local] Definition ty_out fd := ((ffun fd).π2).π1. - -Definition translate_fundef - (tr_f_body : fdefs) - (fd : _ufun_decl (* extra_fun_t *)) : funname * fdef. -Proof. - destruct fd. destruct _f. - split. 1: exact f. - constructor. - - pose (lchtuple (map encode f_tyin)) as tyin'. - pose (lchtuple (map encode f_tyout)) as tyout'. - exists tyin', tyout'. intros vargs'. - - (* NB: We coerce rather than truncating here, i.e. we expect the arguments - provided to us to be of the correct type. This differs slightly from - Jasmin where the truncation is performed in `sem_call`. However, as - explained in the translation of `Ccall` in `translate_instr_r`, we need - the types of the arguments to match the function in order to write the - function application, so we truncate at the caller side. We thus expect - the arguments to already be of the type `f_tyin` prescribed by the - function `f`. *) - apply (coerce_chtuple_to_list _ f_tyin) in vargs'. - - (* Write the arguments to their locations. *) - pose (map (λ '(x, (ty; v)), translate_write_var f x (totce v)) - (zip f_params vargs')) - as cargs. - apply (foldl (λ c k, c ;; k) (ret tt)) in cargs. - apply (bind cargs) => _. - - (* Perform the function body. *) - apply (bind (translate_cmd tr_f_body f f_body)) => _. - - (* Look up the results in their locations and return them. *) - pose (map (λ x, totc _ (translate_get_var f (v_var x))) f_res) as cres. - exact (bind_list' f_tyout cres). - - exact fset0. - - exact [interface]. -Defined. - -(* Apply cast_fun or return default value, like lookup_op *) -Equations? cast_typed_raw_function {dom cod : choice_type} (rf : typed_raw_function) : dom → raw_code cod := - cast_typed_raw_function rf with inspect ((dom == rf.π1) && (cod == rf.π2.π1)) := { - | @exist true e => pkg_composition.cast_fun _ _ rf.π2.π2 ; - | @exist false e => λ _, ret (chCanonical _) - }. -Proof. - all: symmetry in e. - all: move: e => /andP [/eqP e1 /eqP e2]. - all: eauto. -Defined. - -Definition get_fundef_ssp (sp : seq (funname * fdef)) (fn : funname) (dom cod : choice_type) : - option (dom → raw_code cod) := - match assoc sp fn with - | Some fd => Some (cast_typed_raw_function fd.(ffun)) - | None => None - end. - Lemma eq_rect_r_K : ∀ (A : eqType) (x : A) (P : A → Type) h e, @eq_rect_r A x P h x e = h. @@ -3180,6 +2944,241 @@ Proof. assumption. Qed. +Definition fdefs := + (* ∀ fn fdef, get_fundef (p_funcs P) fn = Some fdef -> raw_code 'unit. *) + list (funname * + ([choiceType of seq typed_chElement] -> raw_code [choiceType of seq typed_chElement])). + +Definition trunc_list := + (λ tys (vs : seq typed_chElement), + [seq let '(ty, v) := ty_v in totce (truncate_el ty v.π2) | ty_v <- zip tys vs]). + +Definition set_up_funcall (fn : funname) (tr_f_body : fdefs) + (vargs : [choiceType of seq typed_chElement]) + : raw_code [choiceType of list typed_chElement]. +Proof. + (* sem_call *) + destruct (get_fundef (p_funcs P) fn) as [[]|] eqn:E ; [ | exact (ret [::])]. + apply (trunc_list f_tyin) in vargs. + pose (map (λ '(x, (ty; v)), translate_write_var fn x (totce v)) + (zip f_params vargs)) + as cargs. + apply (foldl (λ c k, c ;; k) (ret tt)) in cargs. + apply (bind cargs) => _. + (* Perform the function body. *) + destruct (assoc tr_f_body fn) as [tr_f|]. 2: exact (ret [::]). + (* apply (bind (tr_f_body _ _ E)) => _. *) + (* pose (tr_f_body _ _ E) as tr_f. *) + apply (bind (tr_f vargs)) => _. + (* Look up the results in their locations and coerce them. *) + pose (map (λ x, totc _ (translate_get_var fn (v_var x))) f_res) as cres. + pose (bind_list cres) as vs. + eapply bind. 1: exact vs. + intros vres. clear cres vs. + apply (trunc_list f_tyout) in vres. + exact (ret vres). +Defined. + +Fixpoint translate_instr_r + (tr_f_body : fdefs) + (fn : funname) (i : instr_r) {struct i} + : raw_code 'unit + +with translate_instr (tr_f_body : fdefs) + (fn : funname) (i : instr) {struct i} : raw_code 'unit := + translate_instr_r tr_f_body fn (instr_d i). +Proof. + pose proof (translate_cmd := + (fix translate_cmd (fn : funname) (c : cmd) : raw_code 'unit := + match c with + | [::] => ret tt + | i :: c => + translate_instr tr_f_body fn i ;; + translate_cmd fn c + end + ) + ). + + destruct i as [ | ls _ o es | e c1 c2 | i [[d lo] hi] c | | ii xs gn args ]. + - (* Cassgn *) + (* l :a=_s p *) + pose (translate_pexpr fn p) as tr_p. + eapply bind. 1: exact (tr_p.π2). + intros v. pose (truncate_el s v) as tr_v. + exact (translate_write_lval fn l (totce tr_v)). + - (* Copn *) + pose (cs := [seq (translate_pexpr fn e) | e <- es]). + pose (vs := bind_list cs). + eapply bind. 1: exact vs. intros bvs. + pose (out := translate_exec_sopn o bvs). + exact (translate_write_lvals fn ls out). (* BSH: I'm not sure if the outputs should be truncated? *) + - (* Cif e c1 c2 *) + pose (e' := translate_pexpr fn e). + pose (c1' := translate_cmd fn c1). + pose (c2' := translate_cmd fn c2). + pose (rb := coerce_typed_code 'bool e'). + exact (b ← rb ;; if b then c1' else c2'). + - (* Cfor i (d, lo, hi) c *) + (* pose (iᵗ := translate_var fn i). *) (* Weird not to do it *) + pose (loᵗ := coerce_typed_code 'int (translate_pexpr fn lo)). + pose (hiᵗ := coerce_typed_code 'int (translate_pexpr fn hi)). + pose (cᵗ := translate_cmd fn c). + exact ( + vlo ← loᵗ ;; + vhi ← hiᵗ ;; + translate_for fn i (wrange d vlo vhi) cᵗ + ). + - exact (unsupported.π2). (* Cwhile *) + - (* Ccall ii xs f args *) + rename fn into fn_ambient. rename gn into fn. + (* Translate arguments. *) + pose (cs := [seq (translate_pexpr fn_ambient e) | e <- args]). + pose (vs := bind_list cs). + eapply bind. 1: exact vs. + intros vargs. clear cs vs. + + apply (bind (set_up_funcall fn tr_f_body vargs)) => vres. + + pose (map (λ '(x, (ty; v)), translate_write_lval fn_ambient x (totce v)) + (zip xs vres)) + as cres. + apply (foldl (λ c k, c ;; k) (ret tt)) in cres. + exact cres. +Defined. + +(* + Questions to answer for the translation of functions and function calls: + - When does argument truncation happen? + - What does each function get translated to? + + Idea 0: translate the function body each time it gets called. + This doesn't work if we look up the body in a dictionary à la `get_fundef`. If we try to apply `translate_cmd` to the result of a function call, + we have no guarantee this will terminate. + + Idea 1: + - Each jasmin function gets translated into a typed_raw_function + - The translation of a jasmin instruction is parametrised by a dictionary associating to each function name such a typed_raw_function. + - Each function call can then look up the translated function. + + The problem with this approach is that Jasmin functions don't expect their arguments to be of the right type. + Instead, they perform a truncation on the callee side. + To emulate this behaviour we would have to allow the application of a function to arguments of the wrong type. + This won't work with a `typed_raw_function = ∑ S T : choice_type, S → raw_code T` , as the arguments have to match the function type. + + A workaround would be to pack the arguments into a list of `typed_chElement`, i.e. `list (∑ t : choice_type, t)`, + but this type is too large to live inside `choice_type`. + Instead, we could translate each jasmin function to a "large" `Typed_Raw_Function = Π S T : choiceType, S → raw_code T`, + or more precisely `Π S T : list stype, [seq encode s | s <- S] → raw_code [seq encode t | t <- T]`, + or equivalently `list (Σ s : stype, encode s) → list (Σ t : stype, encode t)`. + + As a result, the translated functions do not fit `typed_raw_function`, + cannot directly be described by an `opsig`, + and thus can't be wrapped in a `raw_package`. + Question: Could we generalise the definition of `raw_package` to allow `Typed_Raw_Functions`? + + Instead of modifying `raw_package`, we could add Σ-types to `choice_type`. + This could be done using Paulin-Mohring's trick for representing inductive-recursive definitions in Coq. + As a first test we could use `boolp.choice_of_Type` to get the choice structure on the universe. + The `ordType` structure could come from `order.Order.SigmaOrder.le`. + Question: Do we rely on the computational properties of the choice structure of `choice_universe`? + + Idea 2: + - Each Jasmin function gets translated to a `'unit raw_code` corresponding to its body. + - translate_instr takes a map from funnames to translated fun bodies. + - There is an additional wrapper function + `set_up_funcall : funname → (args : seq value) → (f_tyin : seq stype) -> (f_tr_body : 'unit raw_code) -> 'unit raw_code` + that does the work of truncating, and storing the function arguments as well as the returned results into their locations. + - the main theorem then talks not about running the translation of a function, but instead about set_up_funcall + + *) + +(* translate_instr is blocked because it is a fixpoint *) +Lemma translate_instr_unfold : + ∀ ep fn i, + translate_instr ep fn i = translate_instr_r ep fn (instr_d i). +Proof. + intros ep fn i. + destruct i. reflexivity. +Qed. + +(* Trick to have it expand to the same as the translate_cmd above *) +Section TranslateCMD. + +Context (tr_f_body : fdefs). + +Fixpoint translate_cmd (fn : funname) (c : cmd) : raw_code 'unit := + match c with + | [::] => ret tt + | i :: c => translate_instr tr_f_body fn i ;; translate_cmd fn c + end. + +End TranslateCMD. + +Record fdef := { + ffun : typed_raw_function ; + locs : {fset Location} ; + imp : Interface ; +}. + +#[local] Definition ty_in fd := (ffun fd).π1. +#[local] Definition ty_out fd := ((ffun fd).π2).π1. + +Definition translate_fundef + (tr_f_body : fdefs) + (fd : _ufun_decl (* extra_fun_t *)) : funname * fdef. +Proof. + destruct fd. destruct _f. + split. 1: exact f. + constructor. + - pose (lchtuple (map encode f_tyin)) as tyin'. + pose (lchtuple (map encode f_tyout)) as tyout'. + exists tyin', tyout'. intros vargs'. + + (* NB: We coerce rather than truncating here, i.e. we expect the arguments + provided to us to be of the correct type. This differs slightly from + Jasmin where the truncation is performed in `sem_call`. However, as + explained in the translation of `Ccall` in `translate_instr_r`, we need + the types of the arguments to match the function in order to write the + function application, so we truncate at the caller side. We thus expect + the arguments to already be of the type `f_tyin` prescribed by the + function `f`. *) + apply (coerce_chtuple_to_list _ f_tyin) in vargs'. + + (* Write the arguments to their locations. *) + pose (map (λ '(x, (ty; v)), translate_write_var f x (totce v)) + (zip f_params vargs')) + as cargs. + apply (foldl (λ c k, c ;; k) (ret tt)) in cargs. + apply (bind cargs) => _. + + (* Perform the function body. *) + apply (bind (translate_cmd tr_f_body f f_body)) => _. + + (* Look up the results in their locations and return them. *) + pose (map (λ x, totc _ (translate_get_var f (v_var x))) f_res) as cres. + exact (bind_list' f_tyout cres). + - exact fset0. + - exact [interface]. +Defined. + +(* Apply cast_fun or return default value, like lookup_op *) +Equations? cast_typed_raw_function {dom cod : choice_type} (rf : typed_raw_function) : dom → raw_code cod := + cast_typed_raw_function rf with inspect ((dom == rf.π1) && (cod == rf.π2.π1)) := { + | @exist true e => pkg_composition.cast_fun _ _ rf.π2.π2 ; + | @exist false e => λ _, ret (chCanonical _) + }. +Proof. + all: symmetry in e. + all: move: e => /andP [/eqP e1 /eqP e2]. + all: eauto. +Defined. + +Definition get_fundef_ssp (sp : seq (funname * fdef)) (fn : funname) (dom cod : choice_type) : + option (dom → raw_code cod) := + match assoc sp fn with + | Some fd => Some (cast_typed_raw_function fd.(ffun)) + | None => None + end. Definition ssprove_prog := fdefs. From 0dca6cef9ac88f1056880e37a964e9e133954f6b Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Mon, 9 May 2022 19:09:57 +0100 Subject: [PATCH 230/383] break `Translate` section in two when P changes, translate fdef bodies as 'unit --- theories/Jasmin/jasmin_translate.v | 183 +++++++++++++++++++++-------- 1 file changed, 133 insertions(+), 50 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 23c908b1..effe50d0 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -2946,30 +2946,27 @@ Qed. Definition fdefs := (* ∀ fn fdef, get_fundef (p_funcs P) fn = Some fdef -> raw_code 'unit. *) - list (funname * - ([choiceType of seq typed_chElement] -> raw_code [choiceType of seq typed_chElement])). + list (funname * (raw_code 'unit)). Definition trunc_list := (λ tys (vs : seq typed_chElement), [seq let '(ty, v) := ty_v in totce (truncate_el ty v.π2) | ty_v <- zip tys vs]). -Definition set_up_funcall (fn : funname) (tr_f_body : fdefs) +Definition translate_call (fn : funname) (tr_f_body : fdefs) (vargs : [choiceType of seq typed_chElement]) : raw_code [choiceType of list typed_chElement]. Proof. (* sem_call *) destruct (get_fundef (p_funcs P) fn) as [[]|] eqn:E ; [ | exact (ret [::])]. apply (trunc_list f_tyin) in vargs. - pose (map (λ '(x, (ty; v)), translate_write_var fn x (totce v)) - (zip f_params vargs)) + pose (translate_write_lvals fn [seq Lvar x | x <- f_params] vargs) as cargs. - apply (foldl (λ c k, c ;; k) (ret tt)) in cargs. apply (bind cargs) => _. (* Perform the function body. *) destruct (assoc tr_f_body fn) as [tr_f|]. 2: exact (ret [::]). (* apply (bind (tr_f_body _ _ E)) => _. *) (* pose (tr_f_body _ _ E) as tr_f. *) - apply (bind (tr_f vargs)) => _. + apply (bind tr_f) => u. (* Look up the results in their locations and coerce them. *) pose (map (λ x, totc _ (translate_get_var fn (v_var x))) f_res) as cres. pose (bind_list cres) as vs. @@ -3030,19 +3027,15 @@ Proof. ). - exact (unsupported.π2). (* Cwhile *) - (* Ccall ii xs f args *) - rename fn into fn_ambient. rename gn into fn. + rename fn into fn_ambient. (* Translate arguments. *) pose (cs := [seq (translate_pexpr fn_ambient e) | e <- args]). - pose (vs := bind_list cs). - eapply bind. 1: exact vs. - intros vargs. clear cs vs. + eapply bind. 1: exact (bind_list cs). + intros vargs. clear cs. - apply (bind (set_up_funcall fn tr_f_body vargs)) => vres. + apply (bind (translate_call gn tr_f_body vargs)) => vres. - pose (map (λ '(x, (ty; v)), translate_write_lval fn_ambient x (totce v)) - (zip xs vres)) - as cres. - apply (foldl (λ c k, c ;; k) (ret tt)) in cres. + pose (translate_write_lvals fn_ambient xs vres) as cres. exact cres. Defined. @@ -3086,9 +3079,9 @@ Defined. - Each Jasmin function gets translated to a `'unit raw_code` corresponding to its body. - translate_instr takes a map from funnames to translated fun bodies. - There is an additional wrapper function - `set_up_funcall : funname → (args : seq value) → (f_tyin : seq stype) -> (f_tr_body : 'unit raw_code) -> 'unit raw_code` + `translate_call : funname → (args : seq value) → (f_tyin : seq stype) -> (f_tr_body : 'unit raw_code) -> 'unit raw_code` that does the work of truncating, and storing the function arguments as well as the returned results into their locations. - - the main theorem then talks not about running the translation of a function, but instead about set_up_funcall + - the main theorem then talks not about running the translation of a function, but instead about translate_call *) @@ -3114,6 +3107,15 @@ Fixpoint translate_cmd (fn : funname) (c : cmd) : raw_code 'unit := End TranslateCMD. +End Translation. + +Section Translation. +Context `{asmop : asmOp}. + +Context {T} {pT : progT T}. + +Context {pd : PointerData}. + Record fdef := { ffun : typed_raw_function ; locs : {fset Location} ; @@ -3123,7 +3125,9 @@ Record fdef := { #[local] Definition ty_in fd := (ffun fd).π1. #[local] Definition ty_out fd := ((ffun fd).π2).π1. -Definition translate_fundef +Notation totce := to_typed_chElement. + +Definition translate_fundef (P : uprog) (tr_f_body : fdefs) (fd : _ufun_decl (* extra_fun_t *)) : funname * fdef. Proof. @@ -3152,7 +3156,7 @@ Proof. apply (bind cargs) => _. (* Perform the function body. *) - apply (bind (translate_cmd tr_f_body f f_body)) => _. + apply (bind (translate_cmd P tr_f_body f f_body)) => _. (* Look up the results in their locations and return them. *) pose (map (λ x, totc _ (translate_get_var f (v_var x))) f_res) as cres. @@ -3182,28 +3186,71 @@ Definition get_fundef_ssp (sp : seq (funname * fdef)) (fn : funname) (dom cod : Definition ssprove_prog := fdefs. -Definition translate_prog : ssprove_prog. +Definition translate_prog (prog : uprog) : ssprove_prog. Proof. - destruct P. + destruct prog. induction p_funcs. - exact [::]. - unfold ssprove_prog. apply cons. 2: exact IHp_funcs. pose a.1 as fn. split. 1: exact fn. - exact (set_up_funcall fn IHp_funcs). + destruct a. destruct _f. + exact (translate_cmd (Build__prog p_funcs p_globs p_extra) IHp_funcs fn f_body). Defined. -Definition translate_prog' := +Definition translate_funs (P : uprog) := let fix translate_funs (fs : seq _ufun_decl) : ssprove_prog := match fs with [::] => [::] | f :: fs' => let tr_fs' := translate_funs fs' in let fn := f.1 in - (fn, set_up_funcall fn tr_fs') :: tr_fs' - end in - translate_funs (p_funcs P). + (fn, (translate_cmd P tr_fs' fn (f_body f.2))) :: tr_fs' + end + in translate_funs. + +Definition translate_prog' P := + translate_funs P (p_funcs P). + +Lemma tr_prog_inv P fn f : + get_fundef (p_funcs P) fn = Some f -> + ∑ fs', + assoc (translate_prog' P) fn = + let tr_fs' := translate_funs P fs' in + Some (translate_cmd P tr_fs' fn (f_body f)). +Proof. + unfold translate_prog'. + induction (p_funcs P) as [|[gn g] fs' ih_fs']. + - move => //. + - simpl in *. + move => h //. + destruct (fn == gn) eqn:e. + + move /eqP in e. subst. + noconf h. + exists fs'. reflexivity. + + now apply ih_fs'. +Qed. + +(* Lemma translate_prog_inv (prog : uprog) (fn : funname) f : assoc (translate_prog' prog) fn = Some f -> ∑ (prog' : uprog), f = translate_call fn (translate_prog' prog'). *) +(* Proof. *) +(* destruct prog. induction p_funcs. *) +(* - move => // []. *) +(* - move => h //. *) +(* destruct (fn == a.1) eqn:Efn. *) +(* + simpl in h. *) +(* rewrite Efn in h. *) +(* noconf h. *) +(* exists (Build__prog p_funcs p_globs p_extra). *) +(* move /eqP in Efn. subst. *) +(* reflexivity. *) +(* + apply IHp_funcs. *) +(* simpl in h. *) +(* rewrite Efn in h. *) +(* rewrite -h. *) +(* reflexivity. *) +(* Qed. *) + (** Handled programs @@ -3232,24 +3279,24 @@ Definition handled_cmd (c : cmd) := Definition handled_fundecl (f : _ufun_decl) := handled_cmd f.2.(f_body). -Definition handled_program := +Definition handled_program (P : uprog) := List.forallb handled_fundecl P.(p_funcs). Definition Pfun (fn : funname) m va m' vr := - forall f, - handled_program → - let sp := translate_prog in - let dom := lchtuple (map choice_type_of_val va) in - let cod := lchtuple (map choice_type_of_val vr) in + forall (P : uprog), + handled_program P → + let sp := translate_prog' P in + (* let dom := lchtuple (map choice_type_of_val va) in *) + (* let cod := lchtuple (map choice_type_of_val vr) in *) (* get_fundef_ssp sp fn dom cod = Some f → *) - assoc sp fn = Some f → + (* assoc sp fn = Some f → *) ⊢ ⦃ rel_mem m ⦄ - set_up_funcall fn sp [seq totce (translate_value v) | v <- va] + translate_call P fn sp [seq totce (translate_value v) | v <- va] (* f [seq totce (translate_value v) | v <- va] *) ⇓ [seq totce (translate_value v) | v <- vr] ⦃ rel_mem m' ⦄. -Theorem translate_prog_correct (fn : funname) m va m' vr : +Theorem translate_prog_correct P (fn : funname) m va m' vr : sem.sem_call P m fn va m' vr → Pfun fn m va m' vr. Proof. @@ -3258,25 +3305,25 @@ Proof. λ (m : mem) (fn : funname) (va : seq value) (m' : mem) (vr : seq value), Pfun fn m va m' vr ). - set (SP := translate_prog). + set (SP := translate_prog' P). set (Pi_r := λ (s1 : estate) (i : instr_r) (s2 : estate), handled_instr_r i → ⊢ ⦃ rel_estate s1 fn ⦄ - translate_instr_r SP fn i ⇓ tt + translate_instr_r P SP fn i ⇓ tt ⦃ rel_estate s2 fn ⦄ ). set (Pi := λ s1 i s2, Pi_r s1 (instr_d i) s2). set (Pc := λ (s1 : estate) (c : cmd) (s2 : estate), handled_cmd c → - ⊢ ⦃ rel_estate s1 fn ⦄ translate_cmd SP fn c ⇓ tt ⦃ rel_estate s2 fn ⦄ + ⊢ ⦃ rel_estate s1 fn ⦄ translate_cmd P SP fn c ⇓ tt ⦃ rel_estate s2 fn ⦄ ). set (Pfor := λ (v : var_i) (ws : seq Z) (s1 : estate) (c : cmd) (s2 : estate), handled_cmd c → ⊢ ⦃ rel_estate s1 fn ⦄ - translate_for fn v ws (translate_cmd SP fn c) ⇓ tt + translate_for fn v ws (translate_cmd P SP fn c) ⇓ tt ⦃ rel_estate s2 fn ⦄ ). unshelve eapply (@sem_call_Ind _ _ _ _ Pc Pi_r Pi Pfor Pfun _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H). @@ -3413,7 +3460,43 @@ Proof. (* _hwr_vargs _hbody _h_get_res _h_trunc_res]. *) eapply ihgn. 1: give_up. - instantiate (1 := set_up_funcall gn translate_prog). + instantiate (1 := translate_call gn (translate_prog' P)). + + + destruct hgn. + set (SP := translate_prog' P). + rename fn0 into gn. + destruct (assoc SP gn) as [SP_gn|] eqn:E'. + 2: { rename H into E''. unfold SP in E'. + +assert ( +forall (P : uprog) fn f, +get_fundef (p_funcs P) fn = Some f +-> +∑ prog' : uprog, + ∑ tl : uprog, p_funcs prog' ++ p_funcs tl = p_funcs P /\ + assoc (translate_prog' prog') fn = + Some (translate_call fn (translate_prog' prog'))) + by admit. + + pose (X _ _ _ E'') as h_tr_g. + destruct h_tr_g as [prog' [tl [e' asc]]]. + assert (forall (K : eqType) V l l' (k : K) (v : V), + assoc l k = Some v -> + assoc (l ++ l') k = Some v). + { pose (assoc_cat). + admit. } + assert + (assoc (translate_prog' P) gn = + Some (translate_call gn (translate_prog' prog'))). + { unfold translate_prog'. rewrite -e'. + admit. } + rewrite H5 in E'. noconf E'. + } + + rewrite -E'. + unfold SP_gn in E'. + pose (translate_prog_inv P gn (translate_call gn SP) E'). give_up. * (* should be similar to Copn, by appealing to correctness of write_lvals. *) simpl. @@ -3421,22 +3504,22 @@ Proof. - (* proc *) unfold sem_Ind_proc. red. intros m1 m2 gn g vs vs' s1 vm2 vrs vrs'. intros hg hvs ?????. - unfold Pfun, Translation.Pfun. intros hp hf. + unfold Pfun, Translation.Pfun. intros tr_g hp. destruct H. - unfold set_up_funcall. + unfold translate_call. rewrite hg. destruct g eqn:E. rewrite -E in hg hvs H0 H1 H2 H3 H4. destruct (assoc SP gn) as [SP_gn|] eqn:E'. 2: { move => E''. unfold SP in E'. rewrite E' in E''. discriminate. } rewrite E'. move => E''. noconf E''. - set (cargs := map (λ '(x, (ty; v)), translate_write_var gn x (totce v)) - (zip f_params - [seq (let - '(ty, v) := ty_v in totce (truncate_el ty v.π2)) - | ty_v <- zip f_tyin - [seq totce (translate_value v) - | v <- vs']])) + pose E' as e. unfold SP in e. + pose (translate_prog_inv _ _ _ e) as h_tr_g. + destruct h_tr_g as [p' e_tr_g]. + set (cargs := [seq (let '(x, (ty; v)) := pat in translate_write_var gn x (totce v)) + | pat <- zip f_params + (trunc_list f_tyin + [seq totce (translate_value v) | v <- vs'])]) . eapply u_bind with (v₁ := tt) ; [unfold cargs|]; clear cargs. 1: { idtac. From afa668018bfff4ae1ed29cf11321471a250ec17a Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Tue, 10 May 2022 17:39:25 +0100 Subject: [PATCH 231/383] unbreak the build --- theories/Jasmin/jasmin_translate.v | 150 +++++++++++++++-------------- 1 file changed, 80 insertions(+), 70 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index effe50d0..6f744b93 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -2944,22 +2944,25 @@ Proof. assumption. Qed. -Definition fdefs := - (* ∀ fn fdef, get_fundef (p_funcs P) fn = Some fdef -> raw_code 'unit. *) - list (funname * (raw_code 'unit)). - Definition trunc_list := (λ tys (vs : seq typed_chElement), [seq let '(ty, v) := ty_v in totce (truncate_el ty v.π2) | ty_v <- zip tys vs]). +Definition fdefs := + (* ∀ fn fdef, get_fundef (p_funcs P) fn = Some fdef -> raw_code 'unit. *) + list (funname * (raw_code 'unit)). + Definition translate_call (fn : funname) (tr_f_body : fdefs) (vargs : [choiceType of seq typed_chElement]) : raw_code [choiceType of list typed_chElement]. Proof. (* sem_call *) - destruct (get_fundef (p_funcs P) fn) as [[]|] eqn:E ; [ | exact (ret [::])]. - apply (trunc_list f_tyin) in vargs. - pose (translate_write_lvals fn [seq Lvar x | x <- f_params] vargs) + destruct (get_fundef (p_funcs P) fn) + as [f|] + (* eqn:E *) + ; [ | exact (ret [::])]. + apply (trunc_list (f_tyin f)) in vargs. + pose (translate_write_lvals fn [seq Lvar x | x <- (f_params f)] vargs) as cargs. apply (bind cargs) => _. (* Perform the function body. *) @@ -2968,11 +2971,11 @@ Proof. (* pose (tr_f_body _ _ E) as tr_f. *) apply (bind tr_f) => u. (* Look up the results in their locations and coerce them. *) - pose (map (λ x, totc _ (translate_get_var fn (v_var x))) f_res) as cres. + pose (map (λ x, totc _ (translate_get_var fn (v_var x))) (f_res f)) as cres. pose (bind_list cres) as vs. eapply bind. 1: exact vs. intros vres. clear cres vs. - apply (trunc_list f_tyout) in vres. + apply (trunc_list (f_tyout f)) in vres. exact (ret vres). Defined. @@ -3348,6 +3351,7 @@ Proof. 1:{ eapply translate_pexpr_correct. all: eauto. } erewrite translate_pexpr_type by eassumption. rewrite coerce_to_choice_type_K. + cbn. erewrite totce_truncate_translate by eassumption. eapply translate_write_lval_correct. all: eauto. - (* opn *) @@ -3368,9 +3372,10 @@ Proof. - (* if_true *) red. intros s1 s2 e c1 c2 he hc1 ihc1. red. simpl. move /andP => [hdc1 hdc2]. + unfold translate_instr_r. lazymatch goal with | |- context [ if _ then ?f ?fn ?c else _ ] => - change (f fn c) with (translate_cmd SP fn c) + change (f fn c) with (translate_cmd P SP fn c) end. eapply u_bind. 1:{ eapply translate_pexpr_correct_cast in he. all: eauto. } @@ -3394,9 +3399,10 @@ Proof. - (* for *) red. intros s1 s2 i d lo hi c vlo vhi hlo hhi hfor ihfor. red. simpl. intros hdc. + unfold translate_instr_r. lazymatch goal with | |- context [ translate_for _ _ _ (?f ?fn ?c) ] => - change (f fn c) with (translate_cmd SP fn c) + change (f fn c) with (translate_cmd P SP fn c) end. eapply u_bind. 1:{ eapply translate_pexpr_correct_cast in hlo. all: eauto. } @@ -3460,76 +3466,80 @@ Proof. (* _hwr_vargs _hbody _h_get_res _h_trunc_res]. *) eapply ihgn. 1: give_up. - instantiate (1 := translate_call gn (translate_prog' P)). - - - destruct hgn. - set (SP := translate_prog' P). - rename fn0 into gn. - destruct (assoc SP gn) as [SP_gn|] eqn:E'. - 2: { rename H into E''. unfold SP in E'. - -assert ( -forall (P : uprog) fn f, -get_fundef (p_funcs P) fn = Some f --> -∑ prog' : uprog, - ∑ tl : uprog, p_funcs prog' ++ p_funcs tl = p_funcs P /\ - assoc (translate_prog' prog') fn = - Some (translate_call fn (translate_prog' prog'))) - by admit. - - pose (X _ _ _ E'') as h_tr_g. - destruct h_tr_g as [prog' [tl [e' asc]]]. - assert (forall (K : eqType) V l l' (k : K) (v : V), - assoc l k = Some v -> - assoc (l ++ l') k = Some v). - { pose (assoc_cat). - admit. } - assert - (assoc (translate_prog' P) gn = - Some (translate_call gn (translate_prog' prog'))). - { unfold translate_prog'. rewrite -e'. - admit. } - rewrite H5 in E'. noconf E'. - } - - rewrite -E'. - unfold SP_gn in E'. - pose (translate_prog_inv P gn (translate_call gn SP) E'). - give_up. +(* instantiate (1 := translate_call gn (translate_prog' P)). *) + + +(* destruct hgn. *) +(* set (SP := translate_prog' P). *) +(* rename fn0 into gn. *) +(* destruct (assoc SP gn) as [SP_gn|] eqn:E'. *) +(* 2: { rename H into E''. unfold SP in E'. *) + +(* assert ( *) +(* forall (P : uprog) fn f, *) +(* get_fundef (p_funcs P) fn = Some f *) +(* -> *) +(* ∑ prog' : uprog, *) +(* ∑ tl : uprog, p_funcs prog' ++ p_funcs tl = p_funcs P /\ *) +(* assoc (translate_prog' prog') fn = *) +(* Some (translate_call fn (translate_prog' prog'))) *) +(* by admit. *) + +(* pose (X _ _ _ E'') as h_tr_g. *) +(* destruct h_tr_g as [prog' [tl [e' asc]]]. *) +(* assert (forall (K : eqType) V l l' (k : K) (v : V), *) +(* assoc l k = Some v -> *) +(* assoc (l ++ l') k = Some v). *) +(* { pose (assoc_cat). *) +(* admit. } *) +(* assert *) +(* (assoc (translate_prog' P) gn = *) +(* Some (translate_call gn (translate_prog' prog'))). *) +(* { unfold translate_prog'. rewrite -e'. *) +(* admit. } *) +(* rewrite H5 in E'. noconf E'. *) +(* } *) + +(* rewrite -E'. *) +(* unfold SP_gn in E'. *) +(* pose (translate_prog_inv P gn (translate_call gn SP) E'). *) +(* give_up. *) * (* should be similar to Copn, by appealing to correctness of write_lvals. *) simpl. admit. - (* proc *) unfold sem_Ind_proc. red. intros m1 m2 gn g vs vs' s1 vm2 vrs vrs'. intros hg hvs ?????. - unfold Pfun, Translation.Pfun. intros tr_g hp. + unfold Pfun, Translation.Pfun. intros P' hp. destruct H. unfold translate_call. - rewrite hg. - destruct g eqn:E. - rewrite -E in hg hvs H0 H1 H2 H3 H4. - destruct (assoc SP gn) as [SP_gn|] eqn:E'. - 2: { move => E''. unfold SP in E'. rewrite E' in E''. discriminate. } - rewrite E'. move => E''. noconf E''. - pose E' as e. unfold SP in e. - pose (translate_prog_inv _ _ _ e) as h_tr_g. - destruct h_tr_g as [p' e_tr_g]. - set (cargs := [seq (let '(x, (ty; v)) := pat in translate_write_var gn x (totce v)) - | pat <- zip f_params - (trunc_list f_tyin - [seq totce (translate_value v) | v <- vs'])]) - . - eapply u_bind with (v₁ := tt) ; [unfold cargs|]; clear cargs. + (* rewrite hg. *) + destruct (get_fundef (p_funcs P') gn) as [g'|] eqn:E. + 2: give_up. + + destruct (tr_prog_inv _ _ _ E) as [fs' E'']. + rewrite E''. + simpl. + + eapply u_bind with (v₁ := tt). 1: { idtac. - instantiate (1 := rel_estate s1 gn). + instantiate (1 := rel_mem m1). admit. } - eapply u_bind with (* (v₁ := [seq totce (translate_value v) | v <- vrs']) *) - (q := rel_estate s1 gn). - + give_up. - + give_up. + eapply u_bind. + + assert (g = g') as eg by give_up. subst. + assert (P = P') as eP by give_up. subst. + assert (fn = gn) as en by give_up. subst. + assert (fs' = p_funcs P') as efs by give_up. subst. + unfold Pc, SP, translate_prog' in H2. + give_up. + + eapply u_bind. + * eapply bind_list_correct. + -- inversion H3. + admit. + -- admit. + * inversion H4. + admit. Admitted. End Translation. From 9e55c90720171a66a2decf71a6bc6c7d5522ad33 Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Wed, 11 May 2022 18:49:24 +0100 Subject: [PATCH 232/383] ltac2 code for Jasmin variables in examples, factor out example utils --- _CoqProject | 1 + theories/Jasmin/examples/bigadd/bigadd.v | 9 + .../three_functions/three_functions.cprog | 203 ++++++++++++ .../three_functions/three_functions.jazz | 18 ++ .../three_functions/three_functions.v | 288 ++++++++++++++++++ .../two_functions/two_functions.cprog | 102 +++++++ .../examples/two_functions/two_functions.jazz | 11 + .../examples/two_functions/two_functions.v | 233 ++++++++++++++ theories/Jasmin/jasmin_utils.v | 164 ++++++++++ 9 files changed, 1029 insertions(+) create mode 100644 theories/Jasmin/examples/three_functions/three_functions.cprog create mode 100644 theories/Jasmin/examples/three_functions/three_functions.jazz create mode 100644 theories/Jasmin/examples/three_functions/three_functions.v create mode 100644 theories/Jasmin/examples/two_functions/two_functions.cprog create mode 100644 theories/Jasmin/examples/two_functions/two_functions.jazz create mode 100644 theories/Jasmin/examples/two_functions/two_functions.v create mode 100644 theories/Jasmin/jasmin_utils.v diff --git a/_CoqProject b/_CoqProject index 9cdb5e76..ceb2d3bf 100644 --- a/_CoqProject +++ b/_CoqProject @@ -79,6 +79,7 @@ theories/Crypt/rules/UniformStateProb.v # Jasmin theories/Jasmin/jasmin_translate.v +theories/Jasmin/jasmin_utils.v # Examples theories/Crypt/examples/package_usage_example.v diff --git a/theories/Jasmin/examples/bigadd/bigadd.v b/theories/Jasmin/examples/bigadd/bigadd.v index 28644308..301d67b8 100644 --- a/theories/Jasmin/examples/bigadd/bigadd.v +++ b/theories/Jasmin/examples/bigadd/bigadd.v @@ -535,4 +535,13 @@ Goal forall aa goal, fn_bigadd aa = goal. setoid_rewrite coerce_to_choice_type_K. setoid_rewrite coerce_to_choice_type_K. time repeat setoid_rewrite (@zero_extend_u U64). + + (* For comparison: unfold the for loop *) + Transparent translate_for. + unfold translate_for. + simpl_fun. + subst i. + set (i := $"i.146"). + setoid_rewrite coerce_to_choice_type_K. + Admitted. diff --git a/theories/Jasmin/examples/three_functions/three_functions.cprog b/theories/Jasmin/examples/three_functions/three_functions.cprog new file mode 100644 index 00000000..d3ec96b6 --- /dev/null +++ b/theories/Jasmin/examples/three_functions/three_functions.cprog @@ -0,0 +1,203 @@ + {Jasmin.Expr.p_funcs = + [(Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH, + {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH; + f_tyin = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = z.139}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)}]; + f_body = + [Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = z.139}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Papp2 + (Jasmin.Expr.Oadd (Jasmin.Expr.Op_w Jasmin.Wsize.U64), + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = z.139}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U64, + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))))))); + Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH), + Jasmin.Expr.Ccall (Jasmin.Expr.DoNotInline, + [Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = res_z.140}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}], + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH), + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = z.139}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)}; + gs = Jasmin.Expr.Slocal}]))]; + f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = res_z.140}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}]; + f_extra = ()}); + (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH), + {Jasmin.Expr.f_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)); + f_tyin = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = y.141}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}]; + f_body = + [Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)), + Jasmin.Expr.Ccall (Jasmin.Expr.DoNotInline, + [Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = res_y.142}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}], + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = y.141}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}; + gs = Jasmin.Expr.Slocal}]))]; + f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = res_y.142}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}]; + f_extra = ()}); + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), + {Jasmin.Expr.f_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))); + f_tyin = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = x.143}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}]; + f_body = + [Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = res_x.144}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Papp2 + (Jasmin.Expr.Oadd (Jasmin.Expr.Op_w Jasmin.Wsize.U64), + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = x.143}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U64, + Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos Jasmin.BinNums.Coq_xH)))))]; + f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = res_x.144}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}]; + f_extra = ()})]; + p_globs = []; p_extra = ()} diff --git a/theories/Jasmin/examples/three_functions/three_functions.jazz b/theories/Jasmin/examples/three_functions/three_functions.jazz new file mode 100644 index 00000000..f2fe9611 --- /dev/null +++ b/theories/Jasmin/examples/three_functions/three_functions.jazz @@ -0,0 +1,18 @@ +fn f (reg u64 x) -> reg u64 { + reg u64 res_x; + res_x = x+1; + return res_x; +} + +fn g (reg u64 y) -> reg u64 { + reg u64 res_y; + res_y = f(y); + return res_y; +} + +fn h (reg u64 z) -> reg u64 { + reg u64 res_z; + z += 42; + res_z = g(z); + return res_z; +} diff --git a/theories/Jasmin/examples/three_functions/three_functions.v b/theories/Jasmin/examples/three_functions/three_functions.v new file mode 100644 index 00000000..0ef2835c --- /dev/null +++ b/theories/Jasmin/examples/three_functions/three_functions.v @@ -0,0 +1,288 @@ +Set Warnings "-notation-overridden,-ambiguous-paths". +From mathcomp Require Import all_ssreflect all_algebra reals distr realsum + fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool ssrnum + eqtype choice seq. +Set Warnings "notation-overridden,ambiguous-paths". + +Require Import List. +From Jasmin Require Import expr. +From CoqWord Require Import word. +(* From Jasmin Require Import x86_extra. *) +From JasminSSProve Require Import jasmin_translate jasmin_utils. +From Crypt Require Import Prelude Package. + +Import ListNotations. +Import Jasmin_notations. +Import PackageNotation. + +Local Open Scope string. + +Context `{asmop : asmOp}. + +Context {T} {pT : progT T}. + +Context {pd : PointerData}. + +Context (P : uprog). + +Context (f : funname). + +Definition three_functions := + {| p_funcs := + [(xO xH, + {| f_info := xI xH; + f_tyin := [sword U64]; + f_params := + [{| v_var := + {| vtype := sword U64; + vname := "z.139" |}; + v_info := + xO + (xO xH) |}]; + f_body := + [MkI + (xI + (xO + (xO xH))) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "z.139" |}; + v_info := + xI + (xI + (xO xH)) |}) + (AT_none) (sword U64) + (Papp2 + (Oadd (Op_w U64)) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "z.139" |}; + v_info := + xO + (xI + (xO xH)) |}; + gs := Slocal |}) + (Papp1 (Oword_of_int U64) + (Pconst + (Zpos + (xO + (xI + (xO + (xI + (xO xH)))))))))); + MkI + (xI + (xO xH)) + (Ccall (DoNotInline) + ([Lvar + {| v_var := + {| vtype := + sword U64; + vname := "res_z.140" |}; + v_info := + xO + (xO + (xO xH)) |}]) + (xI + (xI xH)) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "z.139" |}; + v_info := + xO + (xI xH) |}; + gs := Slocal |}]))]; + f_tyout := [sword U64]; + f_res := + [{| v_var := + {| vtype := sword U64; + vname := "res_z.140" |}; + v_info := + xO + (xO + (xI xH)) |}]; + f_extra := tt |}); + (xI (xI xH), + {| f_info := + xI + (xO (xI xH)); + f_tyin := [sword U64]; + f_params := + [{| v_var := + {| vtype := sword U64; + vname := "y.141" |}; + v_info := + xO + (xI + (xI xH)) |}]; + f_body := + [MkI + (xI + (xI + (xI xH))) + (Ccall (DoNotInline) + ([Lvar + {| v_var := + {| vtype := + sword U64; + vname := "res_y.142" |}; + v_info := + xO + (xI + (xO + (xO xH))) |}]) + (xI + (xO + (xO + (xO xH)))) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "y.141" |}; + v_info := + xO + (xO + (xO + (xO xH))) |}; + gs := Slocal |}]))]; + f_tyout := [sword U64]; + f_res := + [{| v_var := + {| vtype := sword U64; + vname := "res_y.142" |}; + v_info := + xI + (xI + (xO + (xO xH))) |}]; + f_extra := tt |}); + (xI + (xO + (xO (xO xH))), + {| f_info := + xO + (xO + (xI + (xO xH))); + f_tyin := [sword U64]; + f_params := + [{| v_var := + {| vtype := sword U64; + vname := "x.143" |}; + v_info := + xI + (xO + (xI + (xO xH))) |}]; + f_body := + [MkI + (xO + (xI + (xI + (xO xH)))) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "res_x.144" |}; + v_info := + xO + (xO + (xO + (xI xH))) |}) + (AT_none) (sword U64) + (Papp2 + (Oadd (Op_w U64)) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "x.143" |}; + v_info := + xI + (xI + (xI + (xO xH))) |}; + gs := Slocal |}) + (Papp1 (Oword_of_int U64) + (Pconst (Zpos xH)))))]; + f_tyout := [sword U64]; + f_res := + [{| v_var := + {| vtype := sword U64; + vname := "res_x.144" |}; + v_info := + xI + (xO + (xO + (xI xH))) |}]; + f_extra := tt |})]; + p_globs := []; p_extra := tt |} +. + + + + +Definition tr_P := Eval simpl in tr_p three_functions. +Definition default_prog' := (1%positive, (ret tt)). +Definition default_call := (1%positive, fun (x : [choiceType of seq typed_chElement]) => ret x). +Definition get_tr sp n := List.nth_default default_call sp n. +Definition tr_f := Eval simpl in (get_tr tr_P 2). +Definition tr_g := Eval simpl in (get_tr tr_P 1). +Definition tr_h := Eval simpl in (get_tr tr_P 0). + + +Opaque translate_for. + +Goal forall goal v, tr_f.2 [('word U64; v)] = goal . + intros goal v. + unfold tr_f. + unfold get_tr. unfold tr_P. unfold translate_prog'. + unfold get_tr , tr_p. + simpl_fun. + + repeat setjvars. + + repeat setoid_rewrite coerce_to_choice_type_K. + repeat setoid_rewrite (@zero_extend_u U64). + +Admitted. + +Goal forall goal v, tr_g.2 [v] = goal. + intros goal v. + unfold tr_g. + unfold get_tr. unfold tr_P. + simpl_fun. + + repeat setjvars. + + repeat setoid_rewrite coerce_to_choice_type_K. + repeat setoid_rewrite (@zero_extend_u U64). + +Admitted. + +Goal forall goal v, tr_h.2 [v] = goal. + intros goal v. + unfold tr_h. + unfold get_tr. unfold tr_P. + simpl_fun. + + repeat setjvars. + + repeat setoid_rewrite coerce_to_choice_type_K. + repeat setoid_rewrite (@zero_extend_u U64). + +Admitted. diff --git a/theories/Jasmin/examples/two_functions/two_functions.cprog b/theories/Jasmin/examples/two_functions/two_functions.cprog new file mode 100644 index 00000000..9d08d447 --- /dev/null +++ b/theories/Jasmin/examples/two_functions/two_functions.cprog @@ -0,0 +1,102 @@ + {Jasmin.Expr.p_funcs = + [(Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH, + {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH; + f_tyin = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = y.134}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)}]; + f_body = + [Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH), + Jasmin.Expr.Ccall (Jasmin.Expr.DoNotInline, + [Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = res_y.135}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}], + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH), + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = y.134}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)}; + gs = Jasmin.Expr.Slocal}]))]; + f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = res_y.135}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}]; + f_extra = ()}); + (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH), + {Jasmin.Expr.f_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)); + f_tyin = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = x.136}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}]; + f_body = + [Jasmin.Expr.MkI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = res_x.137}; + v_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Papp2 + (Jasmin.Expr.Oadd (Jasmin.Expr.Op_w Jasmin.Wsize.U64), + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = x.136}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U64, + Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos Jasmin.BinNums.Coq_xH)))))]; + f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = res_x.137}; + v_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}]; + f_extra = ()})]; + p_globs = []; p_extra = ()} diff --git a/theories/Jasmin/examples/two_functions/two_functions.jazz b/theories/Jasmin/examples/two_functions/two_functions.jazz new file mode 100644 index 00000000..52a08250 --- /dev/null +++ b/theories/Jasmin/examples/two_functions/two_functions.jazz @@ -0,0 +1,11 @@ +fn f (reg u64 x) -> reg u64 { + reg u64 res_x; + res_x = x+1; + return res_x; +} + +fn g (reg u64 y) -> reg u64 { + reg u64 res_y; + res_y = f(y); + return res_y; +} \ No newline at end of file diff --git a/theories/Jasmin/examples/two_functions/two_functions.v b/theories/Jasmin/examples/two_functions/two_functions.v new file mode 100644 index 00000000..cf2cd2cb --- /dev/null +++ b/theories/Jasmin/examples/two_functions/two_functions.v @@ -0,0 +1,233 @@ +Set Warnings "-notation-overridden,-ambiguous-paths". +From mathcomp Require Import all_ssreflect all_algebra reals distr realsum + fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool ssrnum + eqtype choice seq. +Set Warnings "notation-overridden,ambiguous-paths". + +Require Import List. +From Jasmin Require Import expr. +(* From Jasmin Require Import x86_extra. *) +From JasminSSProve Require Import jasmin_translate. +From Crypt Require Import Prelude Package. + +Import ListNotations. +Local Open Scope string. + +Context `{asmop : asmOp}. + +Context {T} {pT : progT T}. + +Context {pd : PointerData}. + +Context (P : uprog). + +Context (f : funname). + +Definition two_functions := + {| p_funcs := + [(xO xH, + {| f_info := xI xH; + f_tyin := [sword U64]; + f_params := + [{| v_var := + {| vtype := sword U64; + vname := "y.134" |}; + v_info := + xO + (xO xH) |}]; + f_body := + [MkI + (xI + (xO xH)) + (Ccall (DoNotInline) + ([Lvar + {| v_var := + {| vtype := + sword U64; + vname := "res_y.135" |}; + v_info := + xO + (xO + (xO xH)) |}]) + (xI + (xI xH)) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "y.134" |}; + v_info := + xO + (xI xH) |}; + gs := Slocal |}]))]; + f_tyout := [sword U64]; + f_res := + [{| v_var := + {| vtype := sword U64; + vname := "res_y.135" |}; + v_info := + xI + (xO + (xO xH)) |}]; + f_extra := tt |}); + (xI (xI xH), + {| f_info := + xO + (xI (xO xH)); + f_tyin := [sword U64]; + f_params := + [{| v_var := + {| vtype := sword U64; + vname := "x.136" |}; + v_info := + xI + (xI + (xO xH)) |}]; + f_body := + [MkI + (xO + (xO + (xI xH))) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "res_x.137" |}; + v_info := + xO + (xI + (xI xH)) |}) + (AT_none) (sword U64) + (Papp2 + (Oadd (Op_w U64)) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "x.136" |}; + v_info := + xI + (xO + (xI xH)) |}; + gs := Slocal |}) + (Papp1 (Oword_of_int U64) + (Pconst (Zpos xH)))))]; + f_tyout := [sword U64]; + f_res := + [{| v_var := + {| vtype := sword U64; + vname := "res_x.137" |}; + v_info := + xI + (xI + (xI xH)) |}]; + f_extra := tt |})]; + p_globs := []; p_extra := tt |} +. + + +Import PackageNotation. +Notation coe_cht := coerce_to_choice_type. +Notation coe_tyc := coerce_typed_code. +Notation " 'array " := (chMap 'int ('word U8)) (at level 2) : package_scope. +Notation " 'array " := (chMap 'int ('word U8)) (in custom pack_type at level 2). +Notation " 'mem " := (chMap ('word Uptr) ('word U8)) (at level 2) : package_scope. +Notation " 'mem " := (chMap ('word Uptr) ('word U8)) (in custom pack_type at level 2). +Notation " ⸨ ws ⸩ a .[ ptr * scale ] " := (chArray_get ws a ptr scale) + (format " ⸨ ws ⸩ a .[ ptr * scale ] "). +Notation " a [ w / p ] " := + (chArray_set a AAscale p w) + (at level 99, no associativity, + format " a [ w / p ] "). + +From Equations Require Import Equations. +Set Equations With UIP. +Set Equations Transparent. + +From extructures Require Import ord fset fmap. + +Definition tr_P := Eval simpl in tr_p two_functions. +Definition default_prog' := (1%positive, (ret tt)). +Definition default_call := (1%positive, fun (x : [choiceType of seq typed_chElement]) => ret x). +Definition get_tr sp n := List.nth_default default_call sp n. +Definition tr_f := Eval simpl in (get_tr tr_P 1). +Definition tr_g := Eval simpl in (get_tr tr_P 0). + + +Lemma eq_rect_K : + forall (A : eqType) (x : A) (P : A -> Type) h e, + @eq_rect A x P h x e = h. +Proof. + intros A x P' h e. + replace e with (@erefl A x) by apply eq_irrelevance. + reflexivity. +Qed. + +From CoqWord Require Import word. + +Notation "$ i" := (_ ; nat_of_fun_var _ {| vtype := _; vname := i |}) + (at level 99, format "$ i"). + +Notation "$$ i" := ({| v_var := {| vtype := _; vname := i |}; v_info := _ |}) + (at level 99, + format "$$ i"). + +Notation "'for var ∈ seq" := (translate_for _ ($$var) seq) + (at level 99). + +Ltac prog_unfold := unfold get_tr, translate_prog', tr_p, translate_prog, + translate_call, + translate_write_lvals, translate_write_var, translate_instr, + translate_var, + coerce_chtuple_to_list, bind_list', bind_list_trunc_aux, + wsize_size, trunc_list, + List.nth_default. +Hint Rewrite coerce_typed_code_K eq_rect_K eq_rect_r_K : prog_rewrite. + +Opaque translate_for. +Ltac simpl_fun := + repeat (match goal with + | _ => progress autorewrite with prog_rewrite + | _ => prog_unfold; simpl + end). + +Goal forall goal v, tr_g.2 [v] = goal. + intros goal v. + unfold tr_g. + unfold get_tr. unfold tr_P. + simpl_fun. + + (* BSH: the setoid_rewrites takes forever if we do not 'set' these names first *) + set (array32 := sarr 32%positive). + set (x := $"x.136"). + try set (res_x := $"res_x.137"). + try set (y := $"y.134"). + try set (yy := $$"y.134"). + try set (res_y := $"res_y.135"). + + repeat setoid_rewrite coerce_to_choice_type_K. + repeat setoid_rewrite (@zero_extend_u U64). + +Admitted. + + +Goal forall goal v, tr_f.2 [('word U64; v)] = goal . + intros goal v. + unfold tr_f. + unfold get_tr. unfold tr_P. unfold translate_prog'. + simpl_fun. + + (* BSH: the setoid_rewrites takes forever if we do not 'set' these names first *) + set (array32 := sarr 32%positive). + set (x := $"x.136"). + try set (res_x := $"res_x.137"). + try set (y := $"y.134"). + try set (res_y := $"res_y.135"). + + repeat setoid_rewrite (@zero_extend_u U64). + repeat setoid_rewrite coerce_to_choice_type_K. + +Admitted. diff --git a/theories/Jasmin/jasmin_utils.v b/theories/Jasmin/jasmin_utils.v new file mode 100644 index 00000000..b489eb29 --- /dev/null +++ b/theories/Jasmin/jasmin_utils.v @@ -0,0 +1,164 @@ +(* TODO: only needed to define eq_rect_K; move that to jasmin_translate. *) +Set Warnings "-notation-overridden,-ambiguous-paths". +From mathcomp Require Import all_ssreflect all_algebra reals distr realsum + fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool ssrnum + eqtype choice seq. +Set Warnings "notation-overridden,ambiguous-paths". + + +Lemma eq_rect_K : + forall (A : eqType) (x : A) (P : A -> Type) h e, + @eq_rect A x P h x e = h. +Proof. + intros A x P' h e. + replace e with (@erefl A x) by apply eq_irrelevance. + reflexivity. +Qed. + + + + +From Coq Require String Ascii. + +From Jasmin Require Import expr. + +From Crypt Require Import Prelude Package. +From JasminSSProve Require Import jasmin_translate. + +From Ltac2 Require Ltac2 Printf. +From Ltac2 Require String Char Fresh Ident. + + +Module Jasmin_notations. + + Notation coe_cht := coerce_to_choice_type. + Notation coe_tyc := coerce_typed_code. + Import PackageNotation. + + Notation " 'array " := (chMap 'int ('word U8)) (at level 2) : package_scope. + Notation " 'array " := (chMap 'int ('word U8)) (in custom pack_type at level 2). + Notation " 'mem " := (chMap ('word Uptr) ('word U8)) (at level 2) : package_scope. + Notation " 'mem " := (chMap ('word Uptr) ('word U8)) (in custom pack_type at level 2). + Notation " ⸨ ws ⸩ a .[ ptr * scale ] " := (chArray_get ws a ptr scale) + (format " ⸨ ws ⸩ a .[ ptr * scale ] "). + Notation " a [ w / p ] " := + (chArray_set a AAscale p w) + (at level 99, no associativity, + format " a [ w / p ] "). + + Notation "$$ i" := (_ ; nat_of_fun_var _ {| vtype := _; vname := i |}) + (at level 99, format "$$ i"). + + Notation "$$$ i" := ({| v_var := {| vtype := _; vname := i |}; v_info := _ |}) + (at level 99, + format "$$$ i"). + + Notation "'for var ∈ seq" := (translate_for _ ($$$var) seq) + (at level 99). +End Jasmin_notations. + +Module jtac. + +Import Jasmin_notations. + +Import Ltac2.Ltac2 Ltac2.Printf. + +Ltac2 rec ltac_int_of_pos (p : constr) : int := + let res := + lazy_match! p with + | xH => 1 + | xO ?p' => Int.mul 2 (ltac_int_of_pos p') + | xI ?p' => Int.add (Int.mul 2 (ltac_int_of_pos p')) 1 + end in + if Int.lt res 0 + then Control.throw (Out_of_bounds (Some (fprintf "ltac_int_of_pos: value is too large: %t" p))) + else res. + +Ltac2 ltac_int_of_Z (z : constr) : int := + lazy_match! z with + | Z0 => 0 + | Zpos ?p => ltac_int_of_pos p + | Zneg ?p => Int.sub 0 (ltac_int_of_pos p) + end. + +Ltac2 ltac_char_of_ascii (c : constr) : char := + let c := constr:(Z.of_nat (Ascii.nat_of_ascii $c)) in + let c := eval cbv in $c in + Char.of_int (ltac_int_of_Z c). + +Ltac2 ltac_string_of_string (s : constr) : string := + let s := eval cbv in $s in + let rec ltac_copy_to_string (s : constr) (out : string) (i : int) : unit := + lazy_match! s with + | EmptyString => () + | String ?c ?s => String.set out i (ltac_char_of_ascii c) ; + ltac_copy_to_string s out (Int.add i 1) + end + in + let len := constr:(Z.of_nat (String.length $s)) in + let len := eval cbv in $len in + let out := String.make (ltac_int_of_Z len) (Char.of_int 0) in + ltac_copy_to_string s out 0 ; + out. + +Ltac2 base_length (s : string) : int := + let full_stop := 46 in + let n := String.length s in + let rec f i len_ext := + if Int.equal i 0 + then None + else + let i := Int.sub i 1 in + let c := String.get s i in + let len_ext := Int.add 1 len_ext in + if Int.equal full_stop (Char.to_int c) + then Some len_ext + else f i len_ext + in + match f n 0 with + | None => n + | Some l => Int.sub n l end. + +Ltac2 basename (s : string) : string := + let len := base_length s in + if Int.equal len 0 then s else + let s' := String.make len (Char.of_int 0) in + let rec cp i := + if Int.equal i 0 then () else + let i := Int.sub i 1 in + String.set s' i (String.get s i) ; cp i + in cp len ; + s'. + +Ltac2 setjvars () := + lazy_match! goal with + | [ |- context [ $$ ?i ] ] => + let s := basename (ltac_string_of_string i) in + match Ident.of_string s with + | None => Control.throw (Tactic_failure (Some (fprintf "Not a valid ident: %s (was: %t)" s i))) + | Some id => + let x := Fresh.fresh (Fresh.Free.of_goal ()) id in + set ($x := $$ $i) + end + end. + +End jtac. + +Ltac setjvars := ltac2:(jtac.setjvars ()). + +Ltac prog_unfold := unfold translate_prog', translate_prog, + translate_call, + translate_write_lvals, translate_write_var, translate_instr, + translate_var, + coerce_chtuple_to_list, bind_list', bind_list_trunc_aux, + wsize_size, trunc_list, + List.nth_default. + + +Hint Rewrite coerce_typed_code_K eq_rect_K eq_rect_r_K : prog_rewrite. + +Ltac simpl_fun := + repeat (match goal with + | _ => progress autorewrite with prog_rewrite + | _ => prog_unfold; simpl + end). From 25fa5cabd443cddc86ee8f8e3134a971ba91ef86 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 12 May 2022 11:09:24 +0200 Subject: [PATCH 233/383] Nits --- theories/Jasmin/jasmin_translate.v | 57 +++++++++++++++++------------- 1 file changed, 32 insertions(+), 25 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 6f744b93..0ae3c5e9 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -2598,7 +2598,7 @@ Proof. unfold nat_of_fun_ident. apply /eqP. intro e. noconf e. - move: (ptr_var_nat_neq ptr fn v) => /eqP; contradiction. + move: (ptr_var_nat_neq ptr fn v) => /eqP. contradiction. Qed. Notation coe_cht := coerce_to_choice_type. @@ -2660,13 +2660,18 @@ Lemma injective_nat_of_fun_ident : Proof. intros fn x y e. unfold nat_of_fun_ident in e. - apply Nat.mul_cancel_l in e. 2: apply Nat.pow_nonzero; auto. + apply Nat.mul_cancel_l in e. 2: apply Nat.pow_nonzero ; auto. eapply Nat.pow_inj_r in e. 2: auto. apply injective_nat_of_ident. assumption. Qed. Lemma coprime_mul_inj a b c d : - coprime a d -> coprime a b -> coprime c b -> coprime c d -> (a * b = c * d)%nat -> a = c /\ b = d. + coprime a d → + coprime a b → + coprime c b → + coprime c d → + (a * b = c * d)%nat → + a = c ∧ b = d. Proof. intros ad ab cb cd e. move: e => /eqP. rewrite eqn_dvd. move=> /andP [d1 d2]. @@ -2949,7 +2954,7 @@ Definition trunc_list := [seq let '(ty, v) := ty_v in totce (truncate_el ty v.π2) | ty_v <- zip tys vs]). Definition fdefs := - (* ∀ fn fdef, get_fundef (p_funcs P) fn = Some fdef -> raw_code 'unit. *) + (* ∀ fn fdef, get_fundef (p_funcs P) fn = Some fdef → raw_code 'unit. *) list (funname * (raw_code 'unit)). Definition translate_call (fn : funname) (tr_f_body : fdefs) @@ -3113,6 +3118,7 @@ End TranslateCMD. End Translation. Section Translation. + Context `{asmop : asmOp}. Context {T} {pT : progT T}. @@ -3204,20 +3210,21 @@ Defined. Definition translate_funs (P : uprog) := let fix translate_funs (fs : seq _ufun_decl) : ssprove_prog := - match fs with - [::] => [::] - | f :: fs' => - let tr_fs' := translate_funs fs' in - let fn := f.1 in - (fn, (translate_cmd P tr_fs' fn (f_body f.2))) :: tr_fs' - end - in translate_funs. + match fs with + | [::] => [::] + | f :: fs' => + let tr_fs' := translate_funs fs' in + let fn := f.1 in + (fn, (translate_cmd P tr_fs' fn (f_body f.2))) :: tr_fs' + end + in + translate_funs. Definition translate_prog' P := translate_funs P (p_funcs P). Lemma tr_prog_inv P fn f : - get_fundef (p_funcs P) fn = Some f -> + get_fundef (p_funcs P) fn = Some f → ∑ fs', assoc (translate_prog' P) fn = let tr_fs' := translate_funs P fs' in @@ -3286,18 +3293,18 @@ Definition handled_program (P : uprog) := List.forallb handled_fundecl P.(p_funcs). Definition Pfun (fn : funname) m va m' vr := - forall (P : uprog), - handled_program P → - let sp := translate_prog' P in - (* let dom := lchtuple (map choice_type_of_val va) in *) - (* let cod := lchtuple (map choice_type_of_val vr) in *) - (* get_fundef_ssp sp fn dom cod = Some f → *) - (* assoc sp fn = Some f → *) - ⊢ ⦃ rel_mem m ⦄ - translate_call P fn sp [seq totce (translate_value v) | v <- va] - (* f [seq totce (translate_value v) | v <- va] *) - ⇓ [seq totce (translate_value v) | v <- vr] - ⦃ rel_mem m' ⦄. + ∀ (P : uprog), + handled_program P → + let sp := translate_prog' P in + (* let dom := lchtuple (map choice_type_of_val va) in *) + (* let cod := lchtuple (map choice_type_of_val vr) in *) + (* get_fundef_ssp sp fn dom cod = Some f → *) + (* assoc sp fn = Some f → *) + ⊢ ⦃ rel_mem m ⦄ + translate_call P fn sp [seq totce (translate_value v) | v <- va] + (* f [seq totce (translate_value v) | v <- va] *) + ⇓ [seq totce (translate_value v) | v <- vr] + ⦃ rel_mem m' ⦄. Theorem translate_prog_correct P (fn : funname) m va m' vr : sem.sem_call P m fn va m' vr → From 2a3cf4b32b1611db3f6cddc6636490dbc196d6bf Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Thu, 12 May 2022 16:37:51 +0100 Subject: [PATCH 234/383] Start using Proof using --- theories/Jasmin/jasmin_translate.v | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 0ae3c5e9..cda72d40 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -24,6 +24,7 @@ Unset Printing Implicit Defensive. Set Bullet Behavior "Strict Subproofs". Set Default Goal Selector "!". Set Primitive Projections. +Set Default Proof Using "Type". Derive NoConfusion for result. Derive NoConfusion for value. @@ -2190,7 +2191,7 @@ Lemma app_sopn_list_tuple_correct o vs vs' : tr_app_sopn_tuple _ (sopn_sem o) [seq to_typed_chElement (translate_value v) | v <- vs] = embed_tuple vs'. -Proof. +Proof using asm_correct. intros. unfold tr_app_sopn_tuple. erewrite tr_app_sopn_correct. @@ -2212,7 +2213,7 @@ Lemma translate_exec_sopn_correct (o : sopn) (ins outs : values) : exec_sopn o ins = ok outs → translate_exec_sopn o [seq totce (translate_value v) | v <- ins] = [seq totce (translate_value v) | v <- outs]. -Proof. +Proof using asm_correct. intros H. unfold translate_exec_sopn. jbind H vs Hvs. @@ -2960,7 +2961,7 @@ Definition fdefs := Definition translate_call (fn : funname) (tr_f_body : fdefs) (vargs : [choiceType of seq typed_chElement]) : raw_code [choiceType of list typed_chElement]. -Proof. +Proof using P asm_op asmop pd. (* sem_call *) destruct (get_fundef (p_funcs P) fn) as [f|] @@ -2992,7 +2993,7 @@ Fixpoint translate_instr_r with translate_instr (tr_f_body : fdefs) (fn : funname) (i : instr) {struct i} : raw_code 'unit := translate_instr_r tr_f_body fn (instr_d i). -Proof. +Proof using P asm_op asmop pd. pose proof (translate_cmd := (fix translate_cmd (fn : funname) (c : cmd) : raw_code 'unit := match c with @@ -3139,7 +3140,7 @@ Notation totce := to_typed_chElement. Definition translate_fundef (P : uprog) (tr_f_body : fdefs) (fd : _ufun_decl (* extra_fun_t *)) : funname * fdef. -Proof. +Proof using asm_op asmop pd. destruct fd. destruct _f. split. 1: exact f. constructor. From 97f268cca2bf23210ea65feee0f07af16c8d32a8 Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Thu, 12 May 2022 18:16:41 +0100 Subject: [PATCH 235/383] refactor: section variables only as needed, notation module --- .../three_functions/three_functions.v | 2 +- theories/Jasmin/jasmin_translate.v | 430 ++++++++++-------- theories/Jasmin/jasmin_utils.v | 36 +- 3 files changed, 242 insertions(+), 226 deletions(-) diff --git a/theories/Jasmin/examples/three_functions/three_functions.v b/theories/Jasmin/examples/three_functions/three_functions.v index 0ef2835c..60dcb921 100644 --- a/theories/Jasmin/examples/three_functions/three_functions.v +++ b/theories/Jasmin/examples/three_functions/three_functions.v @@ -12,7 +12,7 @@ From JasminSSProve Require Import jasmin_translate jasmin_utils. From Crypt Require Import Prelude Package. Import ListNotations. -Import Jasmin_notations. +Import JasminNotation JasminCodeNotation. Import PackageNotation. Local Open Scope string. diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index cda72d40..5dbb597e 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -153,42 +153,21 @@ Proof. - intros [] []. intuition eauto. Qed. -(* Tactic to deal with Let _ := _ in _ = ok _ in assumption h *) -(* x and hx are introduced names for the value and its property *) -Ltac jbind h x hx := - eapply rbindP ; [| exact h ] ; - clear h ; intros x hx h ; - cbn beta in h. - -Section Translation. +Definition typed_chElement := pointed_value. -Context `{asmop : asmOp}. - -Context {T} {pT : progT T}. - -Context {pd : PointerData}. - -Context (P : uprog). - -Notation gd := (p_globs P). - -Notation " 'array " := (chMap 'int ('word U8)) (at level 2) : package_scope. -Notation " 'array " := (chMap 'int ('word U8)) (in custom pack_type at level 2). -Notation " 'mem " := (chMap ('word Uptr) ('word U8)) (at level 2) : package_scope. -Notation " 'mem " := (chMap ('word Uptr) ('word U8)) (in custom pack_type at level 2). +Definition to_typed_chElement {t : choice_type} (v : t) : typed_chElement := (t ; v). -Definition mem_index : nat := 0. -Definition mem_loc : Location := ('mem ; mem_index). +Definition typed_code := ∑ (a : choice_type), raw_code a. Definition encode (t : stype) : choice_type := match t with | sbool => 'bool | sint => 'int - | sarr n => 'array + | sarr n => (chMap 'int ('word U8)) | sword n => 'word n end. -Definition embed_array {len} (a : WArray.array len) : 'array := +Definition embed_array {len} (a : WArray.array len) : (chMap 'int ('word U8)) := Mz.fold (λ k v m, setm m k v) a.(WArray.arr_data) emptym. Definition embed {t} : sem_t t → encode t := @@ -199,6 +178,118 @@ Definition embed {t} : sem_t t → encode t := | sword n => λ x, x end. +(* from pkg_invariants *) +Definition cast_ct_val {t t' : choice_type} (e : t = t') (v : t) : t'. +Proof. + subst. auto. +Defined. + +Lemma cast_ct_val_K : + ∀ t e v, + @cast_ct_val t t e v = v. +Proof. + intros t e v. + assert (e = erefl). + { apply eq_irrelevance. } + subst. reflexivity. +Qed. + +Equations? coerce_to_choice_type (t : choice_type) {tv : choice_type} (v : tv) : t := + @coerce_to_choice_type t tv v with inspect (tv == t) := { + | @exist true e => cast_ct_val _ v + | @exist false e => chCanonical t + }. +Proof. + symmetry in e. + move: e => /eqP e. subst. reflexivity. +Qed. + +Definition cast_typed_code (t' : choice_type) (c : typed_code) (e : c.π1 = t') : + raw_code t'. +Proof. + subst. exact (projT2 c). +Defined. + +Lemma cast_typed_code_K : + ∀ t c e, + @cast_typed_code t (t ; c) e = c. +Proof. + intros t c e. + assert (e = erefl). + { apply eq_irrelevance. } + subst. reflexivity. +Qed. + +Equations? coerce_typed_code (ty : choice_type) (tc : typed_code) : raw_code ty := + @coerce_typed_code ty tc with inspect (tc.π1 == ty) := { + | @exist true e => @cast_typed_code ty tc _ + | @exist false e => ret (chCanonical ty) + }. +Proof. + symmetry in e. + move: e => /eqP e. subst. reflexivity. +Qed. + +Lemma coerce_typed_code_neq : + ∀ (ty ty' : choice_type) c, + ty ≠ ty' → + coerce_typed_code ty' (ty ; c) = ret (chCanonical _). +Proof. + intros ty ty' c ne. + funelim (coerce_typed_code ty' (ty ; c)). + 1:{ + clear - e ne. symmetry in e. move: e => /eqP e. simpl in e. contradiction. + } + symmetry. assumption. +Qed. + +Lemma coerce_typed_code_K : + ∀ (ty : choice_type) c, + coerce_typed_code ty (ty ; c) = c. +Proof. + intros ty c. + funelim (coerce_typed_code ty (ty ; c)). + 2:{ + clear - e. symmetry in e. move: e => /eqP e. simpl in e. contradiction. + } + rewrite <- Heqcall. + apply cast_typed_code_K. +Qed. + +Definition choice_type_of_val (val : value) : choice_type := + encode (type_of_val val). + +(* Tactic to deal with Let _ := _ in _ = ok _ in assumption h *) +(* x and hx are introduced names for the value and its property *) +Ltac jbind h x hx := + eapply rbindP ; [| exact h ] ; + clear h ; intros x hx h ; + cbn beta in h. + +Module JasminNotation. + Notation " 'array " := (chMap 'int ('word U8)) (at level 2) : package_scope. + Notation " 'array " := (chMap 'int ('word U8)) (in custom pack_type at level 2). + Notation " 'mem " := (chMap ('word Uptr) ('word U8)) (at level 2) : package_scope. + Notation " 'mem " := (chMap ('word Uptr) ('word U8)) (in custom pack_type at level 2). + Notation totce := to_typed_chElement. + Notation coe_cht := coerce_to_choice_type. + Notation coe_tyc := coerce_typed_code. + +End JasminNotation. + +Import JasminNotation. + +Section Translation. + +Context `{asmop : asmOp}. + +Context {pd : PointerData}. + +Context (gd : glob_decls). + +Definition mem_index : nat := 0. +Definition mem_loc : Location := ('mem ; mem_index). + Lemma elementsNIn : ∀ (T : Type) (k : Z) (v : T) (m : Mz.Map.t T), Mz.get m k = None → @@ -391,9 +482,6 @@ Definition nat_of_fun_var (f : funname) (x : var) : nat := Definition translate_var (f : funname) (x : var) : Location := (encode x.(vtype) ; nat_of_fun_var f x). -Definition typed_code := - ∑ (a : choice_type), raw_code a. - #[local] Definition unsupported : typed_code := ('unit ; assert false). @@ -408,32 +496,6 @@ Proof. apply type_of_to_val. Qed. -(* from pkg_invariants *) -Definition cast_ct_val {t t' : choice_type} (e : t = t') (v : t) : t'. -Proof. - subst. auto. -Defined. - -Lemma cast_ct_val_K : - ∀ t e v, - @cast_ct_val t t e v = v. -Proof. - intros t e v. - assert (e = erefl). - { apply eq_irrelevance. } - subst. reflexivity. -Qed. - -Equations? coerce_to_choice_type (t : choice_type) {tv : choice_type} (v : tv) : t := - @coerce_to_choice_type t tv v with inspect (tv == t) := { - | @exist true e => cast_ct_val _ v - | @exist false e => chCanonical t - }. -Proof. - symmetry in e. - move: e => /eqP e. subst. reflexivity. -Qed. - Definition truncate_chWord {t : choice_type} (n : wsize) : t → 'word n := match t with | chWord m => @@ -464,64 +526,6 @@ Definition translate_to_pointer {t : choice_type} (c : t) : 'word Uptr := Definition truncate_code (s : stype) (c : typed_code) : typed_code := (encode s ; x ← c.π2 ;; ret (truncate_el s x)). -Definition cast_typed_code (t' : choice_type) (c : typed_code) (e : c.π1 = t') : - raw_code t'. -Proof. - subst. exact (projT2 c). -Defined. - -Lemma cast_typed_code_K : - ∀ t c e, - @cast_typed_code t (t ; c) e = c. -Proof. - intros t c e. - assert (e = erefl). - { apply eq_irrelevance. } - subst. reflexivity. -Qed. - -Equations? coerce_typed_code (ty : choice_type) (tc : typed_code) : raw_code ty := - @coerce_typed_code ty tc with inspect (tc.π1 == ty) := { - | @exist true e => @cast_typed_code ty tc _ - | @exist false e => ret (chCanonical ty) - }. -Proof. - symmetry in e. - move: e => /eqP e. subst. reflexivity. -Qed. - -Lemma coerce_typed_code_neq : - ∀ (ty ty' : choice_type) c, - ty ≠ ty' → - coerce_typed_code ty' (ty ; c) = ret (chCanonical _). -Proof. - intros ty ty' c ne. - funelim (coerce_typed_code ty' (ty ; c)). - 1:{ - clear - e ne. symmetry in e. move: e => /eqP e. simpl in e. contradiction. - } - symmetry. assumption. -Qed. - -Lemma coerce_typed_code_K : - ∀ (ty : choice_type) c, - coerce_typed_code ty (ty ; c) = c. -Proof. - intros ty c. - funelim (coerce_typed_code ty (ty ; c)). - 2:{ - clear - e. symmetry in e. move: e => /eqP e. simpl in e. contradiction. - } - rewrite <- Heqcall. - apply cast_typed_code_K. -Qed. - -Definition typed_chElement := - pointed_value. - -Definition choice_type_of_val (val : value) : choice_type := - encode (type_of_val val). - Definition translate_value (v : value) : choice_type_of_val v. Proof. destruct v as [b | z | size a | size wd | undef_ty]. @@ -803,8 +807,6 @@ Proof. exact (hd :: tl). Defined. -Definition to_typed_chElement {t : choice_type} (v : t) : typed_chElement := (t ; v). - Fixpoint bind_list (cs : list typed_code) {struct cs} : raw_code ([choiceType of list typed_chElement]) := match cs with | [::] => ret [::] @@ -912,8 +914,6 @@ Section bind_list_alt. End bind_list_alt. -Notation totce := to_typed_chElement. - Definition embed_ot {t} : sem_ot t → encode t := match t with (* BSH: I'm not sure this will be correct? In jasmin this is an Option bool, perhaps because you don't have to specify all output flags *) @@ -1100,9 +1100,6 @@ Definition translate_write_lval (fn : funname) (l : lval) (v : typed_chElement) translate_write_var fn x (totce t) end. -Definition instr_d (i : instr) : instr_r := - match i with MkI _ i => i end. - (* Note c is translated from cmd, in the case ws = [], sem_for does not guarantee it is well-formed. Also note, it feels odd to get a var_i when I should translate before calling. @@ -1204,6 +1201,15 @@ Definition translate_write_lvals fn ls vs := (* foldl2 (λ c l v, translate_write_lval fn l v ;; c) ls vs (ret tt). *) foldr2 (λ l v c, translate_write_lval fn l v ;; c) ls vs (ret tt). +Lemma eq_rect_K : + forall (A : eqType) (x : A) (P : A -> Type) h e, + @eq_rect A x P h x e = h. +Proof. + intros A x P' h e. + replace e with (@erefl A x) by apply eq_irrelevance. + reflexivity. +Qed. + Lemma eq_rect_r_K : ∀ (A : eqType) (x : A) (P : A → Type) h e, @eq_rect_r A x P h x e = h. @@ -2602,9 +2608,6 @@ Proof. move: (ptr_var_nat_neq ptr fn v) => /eqP. contradiction. Qed. -Notation coe_cht := coerce_to_choice_type. -Notation coe_tyc := coerce_typed_code. - Lemma nat_of_ident_pos : ∀ x, (0 < nat_of_ident x)%coq_nat. Proof. @@ -2950,6 +2953,19 @@ Proof. assumption. Qed. +End Translation. + +Section Translation. + +Context `{asmop : asmOp}. + +Context {pd : PointerData}. + +Context (P : uprog). + +Definition instr_d (i : instr) : instr_r := + match i with MkI _ i => i end. + Definition trunc_list := (λ tys (vs : seq typed_chElement), [seq let '(ty, v) := ty_v in totce (truncate_el ty v.π2) | ty_v <- zip tys vs]). @@ -2958,31 +2974,38 @@ Definition fdefs := (* ∀ fn fdef, get_fundef (p_funcs P) fn = Some fdef → raw_code 'unit. *) list (funname * (raw_code 'unit)). -Definition translate_call (fn : funname) (tr_f_body : fdefs) - (vargs : [choiceType of seq typed_chElement]) + +Definition translate_call_body (fn : funname) (tr_f_body : raw_code 'unit) + (vargs' : [choiceType of seq typed_chElement]) : raw_code [choiceType of list typed_chElement]. Proof using P asm_op asmop pd. (* sem_call *) - destruct (get_fundef (p_funcs P) fn) - as [f|] - (* eqn:E *) - ; [ | exact (ret [::])]. - apply (trunc_list (f_tyin f)) in vargs. - pose (translate_write_lvals fn [seq Lvar x | x <- (f_params f)] vargs) - as cargs. - apply (bind cargs) => _. + refine (match (get_fundef (p_funcs P) fn) with + | Some f => _ + | None => ret [::] end). + pose (trunc_list (f_tyin f) vargs') as vargs. + apply (bind + (translate_write_lvals (p_globs P) fn [seq Lvar x | x <- (f_params f)] vargs)) => _. (* Perform the function body. *) - destruct (assoc tr_f_body fn) as [tr_f|]. 2: exact (ret [::]). (* apply (bind (tr_f_body _ _ E)) => _. *) (* pose (tr_f_body _ _ E) as tr_f. *) - apply (bind tr_f) => u. - (* Look up the results in their locations and coerce them. *) - pose (map (λ x, totc _ (translate_get_var fn (v_var x))) (f_res f)) as cres. - pose (bind_list cres) as vs. - eapply bind. 1: exact vs. - intros vres. clear cres vs. - apply (trunc_list (f_tyout f)) in vres. - exact (ret vres). + apply (bind tr_f_body) => _. + eapply bind. + - (* Look up the results in their locations... *) + exact (bind_list [seq totc _ (translate_get_var fn (v_var x)) | x <- f_res f]). + - intros vres. + (* ...and coerce them to the codomain of f. *) + pose (trunc_list (f_tyout f) vres) as vres'. + exact (ret vres'). +Defined. + +Definition translate_call (fn : funname) (tr_f_body : fdefs) + (vargs : [choiceType of seq typed_chElement]) + : raw_code [choiceType of list typed_chElement]. +Proof using P asm_op asmop pd. + refine (match assoc tr_f_body fn with + | Some tr_f => _ | None => ret [::] end). + exact (translate_call_body fn tr_f vargs). Defined. Fixpoint translate_instr_r @@ -2991,7 +3014,7 @@ Fixpoint translate_instr_r : raw_code 'unit with translate_instr (tr_f_body : fdefs) - (fn : funname) (i : instr) {struct i} : raw_code 'unit := + (fn : funname) (i : instr) {struct i} : raw_code 'unit := translate_instr_r tr_f_body fn (instr_d i). Proof using P asm_op asmop pd. pose proof (translate_cmd := @@ -3008,26 +3031,26 @@ Proof using P asm_op asmop pd. destruct i as [ | ls _ o es | e c1 c2 | i [[d lo] hi] c | | ii xs gn args ]. - (* Cassgn *) (* l :a=_s p *) - pose (translate_pexpr fn p) as tr_p. + pose (translate_pexpr (p_globs P) fn p) as tr_p. eapply bind. 1: exact (tr_p.π2). intros v. pose (truncate_el s v) as tr_v. - exact (translate_write_lval fn l (totce tr_v)). + exact (translate_write_lval (p_globs P) fn l (totce tr_v)). - (* Copn *) - pose (cs := [seq (translate_pexpr fn e) | e <- es]). + pose (cs := [seq (translate_pexpr (p_globs P) fn e) | e <- es]). pose (vs := bind_list cs). eapply bind. 1: exact vs. intros bvs. pose (out := translate_exec_sopn o bvs). - exact (translate_write_lvals fn ls out). (* BSH: I'm not sure if the outputs should be truncated? *) + exact (translate_write_lvals (p_globs P) fn ls out). (* BSH: I'm not sure if the outputs should be truncated? *) - (* Cif e c1 c2 *) - pose (e' := translate_pexpr fn e). + pose (e' := translate_pexpr (p_globs P) fn e). pose (c1' := translate_cmd fn c1). pose (c2' := translate_cmd fn c2). pose (rb := coerce_typed_code 'bool e'). exact (b ← rb ;; if b then c1' else c2'). - (* Cfor i (d, lo, hi) c *) (* pose (iᵗ := translate_var fn i). *) (* Weird not to do it *) - pose (loᵗ := coerce_typed_code 'int (translate_pexpr fn lo)). - pose (hiᵗ := coerce_typed_code 'int (translate_pexpr fn hi)). + pose (loᵗ := coerce_typed_code 'int (translate_pexpr (p_globs P) fn lo)). + pose (hiᵗ := coerce_typed_code 'int (translate_pexpr (p_globs P) fn hi)). pose (cᵗ := translate_cmd fn c). exact ( vlo ← loᵗ ;; @@ -3038,13 +3061,13 @@ Proof using P asm_op asmop pd. - (* Ccall ii xs f args *) rename fn into fn_ambient. (* Translate arguments. *) - pose (cs := [seq (translate_pexpr fn_ambient e) | e <- args]). + pose (cs := [seq (translate_pexpr (p_globs P) fn_ambient e) | e <- args]). eapply bind. 1: exact (bind_list cs). intros vargs. clear cs. apply (bind (translate_call gn tr_f_body vargs)) => vres. - pose (translate_write_lvals fn_ambient xs vres) as cres. + pose (translate_write_lvals (p_globs P) fn_ambient xs vres) as cres. exact cres. Defined. @@ -3116,15 +3139,6 @@ Fixpoint translate_cmd (fn : funname) (c : cmd) : raw_code 'unit := End TranslateCMD. -End Translation. - -Section Translation. - -Context `{asmop : asmOp}. - -Context {T} {pT : progT T}. - -Context {pd : PointerData}. Record fdef := { ffun : typed_raw_function ; @@ -3135,12 +3149,10 @@ Record fdef := { #[local] Definition ty_in fd := (ffun fd).π1. #[local] Definition ty_out fd := ((ffun fd).π2).π1. -Notation totce := to_typed_chElement. - -Definition translate_fundef (P : uprog) +Definition translate_fundef (tr_f_body : fdefs) (fd : _ufun_decl (* extra_fun_t *)) : funname * fdef. -Proof using asm_op asmop pd. +Proof using P asm_op asmop pd. destruct fd. destruct _f. split. 1: exact f. constructor. @@ -3166,7 +3178,7 @@ Proof using asm_op asmop pd. apply (bind cargs) => _. (* Perform the function body. *) - apply (bind (translate_cmd P tr_f_body f f_body)) => _. + apply (bind (translate_cmd tr_f_body f f_body)) => _. (* Look up the results in their locations and return them. *) pose (map (λ x, totc _ (translate_get_var f (v_var x))) f_res) as cres. @@ -3194,10 +3206,18 @@ Definition get_fundef_ssp (sp : seq (funname * fdef)) (fn : funname) (dom cod : | None => None end. -Definition ssprove_prog := fdefs. +End Translation. -Definition translate_prog (prog : uprog) : ssprove_prog. -Proof. +Section Translation. + +Context `{asmop : asmOp}. + +Context {pd : PointerData}. + +Definition ssprove_prog := seq (funname * ([choiceType of seq typed_chElement] → raw_code [choiceType of list typed_chElement])). + +Definition translate_prog (prog : uprog) : fdefs. +Proof using asm_op asmop pd. destruct prog. induction p_funcs. - exact [::]. @@ -3209,8 +3229,35 @@ Proof. exact (translate_cmd (Build__prog p_funcs p_globs p_extra) IHp_funcs fn f_body). Defined. +Definition tr_p (prog : uprog) : ssprove_prog. +Proof using asm_op asmop pd. + pose (fs := translate_prog prog). + induction fs as [|f fs ?]. +- constructor 1. +- constructor 2. + 2: assumption. + exact (f.1, translate_call prog f.1 (f::fs)). +Defined. + +(* Definition translate_funs (P : uprog) := *) +(* let fix translate_funs (fs : seq _ufun_decl) : fdefs := *) +(* match fs with *) +(* [::] => [::] *) +(* | f :: fs' => *) +(* let tr_fs' := translate_funs fs' in *) +(* let fn := f.1 in *) +(* (fn, *) +(* let tr_body := translate_cmd P tr_fs' fn (f_body f.2) in *) +(* translate_call P fn ((fn, tr_body) :: tr_fs') *) +(* ) :: tr_fs' *) +(* end *) +(* in translate_funs. *) + +(* Definition translate_prog' P := *) +(* translate_funs P (p_funcs P). *) + Definition translate_funs (P : uprog) := - let fix translate_funs (fs : seq _ufun_decl) : ssprove_prog := + let fix translate_funs (fs : seq _ufun_decl) : fdefs := match fs with | [::] => [::] | f :: fs' => @@ -3293,28 +3340,21 @@ Definition handled_fundecl (f : _ufun_decl) := Definition handled_program (P : uprog) := List.forallb handled_fundecl P.(p_funcs). -Definition Pfun (fn : funname) m va m' vr := - ∀ (P : uprog), +Definition Pfun (P : uprog) (fn : funname) m va m' vr := handled_program P → - let sp := translate_prog' P in - (* let dom := lchtuple (map choice_type_of_val va) in *) - (* let cod := lchtuple (map choice_type_of_val vr) in *) - (* get_fundef_ssp sp fn dom cod = Some f → *) - (* assoc sp fn = Some f → *) ⊢ ⦃ rel_mem m ⦄ - translate_call P fn sp [seq totce (translate_value v) | v <- va] - (* f [seq totce (translate_value v) | v <- va] *) + translate_call P fn (translate_prog' P) [seq totce (translate_value v) | v <- va] ⇓ [seq totce (translate_value v) | v <- vr] ⦃ rel_mem m' ⦄. Theorem translate_prog_correct P (fn : funname) m va m' vr : sem.sem_call P m fn va m' vr → - Pfun fn m va m' vr. + Pfun P fn m va m' vr. Proof. intros H hP. set (Pfun := λ (m : mem) (fn : funname) (va : seq value) (m' : mem) (vr : seq value), - Pfun fn m va m' vr + Pfun P fn m va m' vr ). set (SP := translate_prog' P). set (Pi_r := @@ -3433,7 +3473,7 @@ Proof. } apply ihfor. assumption. - (* call *) - clear -pT. + clear. red. intros s1 m2 s2 ii xs gn args vargs vres hargs hgn ihgn hwr_vres. unfold Pfun in ihgn. @@ -3518,15 +3558,19 @@ Proof. - (* proc *) unfold sem_Ind_proc. red. intros m1 m2 gn g vs vs' s1 vm2 vrs vrs'. intros hg hvs ?????. - unfold Pfun, Translation.Pfun. intros P' hp. + unfold Pfun, Translation.Pfun. intros hp. destruct H. - unfold translate_call. + unfold translate_prog', translate_call. + (* rewrite hg. *) - destruct (get_fundef (p_funcs P') gn) as [g'|] eqn:E. - 2: give_up. + (* destruct (get_fundef (p_funcs P) gn) as [g'|] eqn:E. *) + (* 2: { inversion hg. } *) - destruct (tr_prog_inv _ _ _ E) as [fs' E'']. + destruct (tr_prog_inv _ _ _ hg) as [fs' E'']. + unfold translate_prog' in E''. rewrite E''. + unfold translate_call_body. + rewrite hg. simpl. eapply u_bind with (v₁ := tt). @@ -3534,12 +3578,12 @@ Proof. instantiate (1 := rel_mem m1). admit. } - eapply u_bind. - + assert (g = g') as eg by give_up. subst. - assert (P = P') as eP by give_up. subst. - assert (fn = gn) as en by give_up. subst. - assert (fs' = p_funcs P') as efs by give_up. subst. - unfold Pc, SP, translate_prog' in H2. + eapply u_bind with (v₁ := tt) (q := rel_mem m2). + + unfold Pc, SP, translate_prog' in H2. + assert (handled_cmd (f_body g)) as h_gbody. + { inversion hp. + give_up. } + apply H2 in h_gbody. give_up. + eapply u_bind. * eapply bind_list_correct. diff --git a/theories/Jasmin/jasmin_utils.v b/theories/Jasmin/jasmin_utils.v index b489eb29..a5412919 100644 --- a/theories/Jasmin/jasmin_utils.v +++ b/theories/Jasmin/jasmin_utils.v @@ -1,23 +1,3 @@ -(* TODO: only needed to define eq_rect_K; move that to jasmin_translate. *) -Set Warnings "-notation-overridden,-ambiguous-paths". -From mathcomp Require Import all_ssreflect all_algebra reals distr realsum - fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool ssrnum - eqtype choice seq. -Set Warnings "notation-overridden,ambiguous-paths". - - -Lemma eq_rect_K : - forall (A : eqType) (x : A) (P : A -> Type) h e, - @eq_rect A x P h x e = h. -Proof. - intros A x P' h e. - replace e with (@erefl A x) by apply eq_irrelevance. - reflexivity. -Qed. - - - - From Coq Require String Ascii. From Jasmin Require Import expr. @@ -29,16 +9,8 @@ From Ltac2 Require Ltac2 Printf. From Ltac2 Require String Char Fresh Ident. -Module Jasmin_notations. - - Notation coe_cht := coerce_to_choice_type. - Notation coe_tyc := coerce_typed_code. - Import PackageNotation. +Module JasminCodeNotation. - Notation " 'array " := (chMap 'int ('word U8)) (at level 2) : package_scope. - Notation " 'array " := (chMap 'int ('word U8)) (in custom pack_type at level 2). - Notation " 'mem " := (chMap ('word Uptr) ('word U8)) (at level 2) : package_scope. - Notation " 'mem " := (chMap ('word Uptr) ('word U8)) (in custom pack_type at level 2). Notation " ⸨ ws ⸩ a .[ ptr * scale ] " := (chArray_get ws a ptr scale) (format " ⸨ ws ⸩ a .[ ptr * scale ] "). Notation " a [ w / p ] " := @@ -55,11 +27,11 @@ Module Jasmin_notations. Notation "'for var ∈ seq" := (translate_for _ ($$$var) seq) (at level 99). -End Jasmin_notations. +End JasminCodeNotation. Module jtac. -Import Jasmin_notations. +Import JasminNotation JasminCodeNotation. Import Ltac2.Ltac2 Ltac2.Printf. @@ -147,7 +119,7 @@ End jtac. Ltac setjvars := ltac2:(jtac.setjvars ()). Ltac prog_unfold := unfold translate_prog', translate_prog, - translate_call, + translate_call, translate_call_body, translate_write_lvals, translate_write_var, translate_instr, translate_var, coerce_chtuple_to_list, bind_list', bind_list_trunc_aux, From cb4149c3998e102d7bc51c3ad5904ae00e313799 Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Fri, 13 May 2022 02:23:02 +0100 Subject: [PATCH 236/383] prove call correct up to "stack safety", finally a good tr_prog inversion lemma --- theories/Jasmin/jasmin_translate.v | 262 +++++++++++++++++------------ 1 file changed, 155 insertions(+), 107 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 5dbb597e..96dbc16f 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -2985,14 +2985,16 @@ Proof using P asm_op asmop pd. | None => ret [::] end). pose (trunc_list (f_tyin f) vargs') as vargs. apply (bind - (translate_write_lvals (p_globs P) fn [seq Lvar x | x <- (f_params f)] vargs)) => _. + (translate_write_lvals (p_globs P) fn + [seq Lvar x | x <- (f_params f)] vargs)) => _. (* Perform the function body. *) (* apply (bind (tr_f_body _ _ E)) => _. *) (* pose (tr_f_body _ _ E) as tr_f. *) apply (bind tr_f_body) => _. eapply bind. - (* Look up the results in their locations... *) - exact (bind_list [seq totc _ (translate_get_var fn (v_var x)) | x <- f_res f]). + exact (bind_list [seq totc _ (translate_get_var fn (v_var x)) + | x <- f_res f]). - intros vres. (* ...and coerce them to the codomain of f. *) pose (trunc_list (f_tyout f) vres) as vres'. @@ -3239,76 +3241,68 @@ Proof using asm_op asmop pd. exact (f.1, translate_call prog f.1 (f::fs)). Defined. -(* Definition translate_funs (P : uprog) := *) -(* let fix translate_funs (fs : seq _ufun_decl) : fdefs := *) -(* match fs with *) -(* [::] => [::] *) -(* | f :: fs' => *) -(* let tr_fs' := translate_funs fs' in *) -(* let fn := f.1 in *) -(* (fn, *) -(* let tr_body := translate_cmd P tr_fs' fn (f_body f.2) in *) -(* translate_call P fn ((fn, tr_body) :: tr_fs') *) -(* ) :: tr_fs' *) -(* end *) -(* in translate_funs. *) - -(* Definition translate_prog' P := *) -(* translate_funs P (p_funcs P). *) - -Definition translate_funs (P : uprog) := - let fix translate_funs (fs : seq _ufun_decl) : fdefs := +(* PGH: TODO: do we need an ambient funname? *) +Definition translate_funs (P : uprog) : seq _ufun_decl → fdefs * ssprove_prog := + let fix translate_funs (fs : seq _ufun_decl) : fdefs * ssprove_prog := match fs with - | [::] => [::] + | [::] => ([::], [::]) | f :: fs' => - let tr_fs' := translate_funs fs' in + (* let '(tr_fs', tr_p') := translate_funs fs' in *) + let tr_tl := translate_funs fs' in + let '(tr_fs', tr_p') := (tr_tl.1, tr_tl.2) in let fn := f.1 in - (fn, (translate_cmd P tr_fs' fn (f_body f.2))) :: tr_fs' + let tr_body := translate_cmd P tr_fs' fn (f_body f.2) in + let tr_fs := (fn, tr_body) :: tr_fs' in + (* let tr_p := (fn, translate_call P fn tr_fs) :: tr_p' in *) + let tr_p := (fn, translate_call_body P fn tr_body) :: tr_p' in + (tr_fs, tr_p) end - in - translate_funs. + in translate_funs. Definition translate_prog' P := translate_funs P (p_funcs P). Lemma tr_prog_inv P fn f : get_fundef (p_funcs P) fn = Some f → - ∑ fs', - assoc (translate_prog' P) fn = - let tr_fs' := translate_funs P fs' in - Some (translate_cmd P tr_fs' fn (f_body f)). + ∑ fs' l, + p_funcs P = l ++ (fn, f) :: fs' /\ + assoc (translate_prog' P).1 fn = + Some (translate_cmd P (translate_funs P fs').1 fn (f_body f)) + /\ + assoc (translate_prog' P).2 fn = + let tr_fs' := translate_funs P ((fn, f) :: fs') in + Some (translate_call P fn tr_fs'.1). Proof. unfold translate_prog'. induction (p_funcs P) as [|[gn g] fs' ih_fs']. - move => //. - simpl in *. move => h //. - destruct (fn == gn) eqn:e. + destruct (gn == fn) eqn:e. + move /eqP in e. subst. + destruct (fn == fn) eqn:E. + 2: { move /eqP in E. exfalso. apply E. reflexivity. } noconf h. - exists fs'. reflexivity. - + now apply ih_fs'. + exists fs'. + exists [::]. + simpl. + unfold translate_call. simpl. rewrite E. + intuition auto. + + assert (fn == gn = false). + { apply /eqP. move => H. symmetry in H. revert H. + move /eqP in e. apply e. + } + rewrite H. + rewrite H in h. + specialize (ih_fs' h). + destruct ih_fs' as [fs'0 [l0 [ihl iha]]]. + rewrite ihl. + exists fs'0. exists ((gn, g) :: l0). + split. + * easy. + * subst. easy. Qed. -(* Lemma translate_prog_inv (prog : uprog) (fn : funname) f : assoc (translate_prog' prog) fn = Some f -> ∑ (prog' : uprog), f = translate_call fn (translate_prog' prog'). *) -(* Proof. *) -(* destruct prog. induction p_funcs. *) -(* - move => // []. *) -(* - move => h //. *) -(* destruct (fn == a.1) eqn:Efn. *) -(* + simpl in h. *) -(* rewrite Efn in h. *) -(* noconf h. *) -(* exists (Build__prog p_funcs p_globs p_extra). *) -(* move /eqP in Efn. subst. *) -(* reflexivity. *) -(* + apply IHp_funcs. *) -(* simpl in h. *) -(* rewrite Efn in h. *) -(* rewrite -h. *) -(* reflexivity. *) -(* Qed. *) - (** Handled programs @@ -3343,10 +3337,22 @@ Definition handled_program (P : uprog) := Definition Pfun (P : uprog) (fn : funname) m va m' vr := handled_program P → ⊢ ⦃ rel_mem m ⦄ - translate_call P fn (translate_prog' P) [seq totce (translate_value v) | v <- va] + (* translate_call P fn (translate_prog' P) [seq totce (translate_value v) | v <- va] *) + match assoc (translate_prog' P).2 fn with + | None => ret [::] + | Some f => f [seq totce (translate_value v) | v <- va] + end ⇓ [seq totce (translate_value v) | v <- vr] ⦃ rel_mem m' ⦄. +Fact smcget P s1 gn vargs m2 vres : + (sem_call P (emem s1) gn vargs m2 vres + → ∃ f, get_fundef (p_funcs P) gn = Some f ). +Proof. intros. + inversion H. + exists f. easy. +Qed. + Theorem translate_prog_correct P (fn : funname) m va m' vr : sem.sem_call P m fn va m' vr → Pfun P fn m va m' vr. @@ -3356,7 +3362,7 @@ Proof. λ (m : mem) (fn : funname) (va : seq value) (m' : mem) (vr : seq value), Pfun P fn m va m' vr ). - set (SP := translate_prog' P). + set (SP := (translate_prog' P).1). set (Pi_r := λ (s1 : estate) (i : instr_r) (s2 : estate), handled_instr_r i → @@ -3473,7 +3479,6 @@ Proof. } apply ihfor. assumption. - (* call *) - clear. red. intros s1 m2 s2 ii xs gn args vargs vres hargs hgn ihgn hwr_vres. unfold Pfun in ihgn. @@ -3504,87 +3509,130 @@ Proof. *** simpl. eapply IHargs. 1: assumption. + simpl. - (* unfold Pfun, Translation.Pfun in ihgn. *) eapply u_bind. * simpl. unshelve eapply u_pre_weaken_rule with (p1 := (rel_mem (emem s1))). 2: move => h Hh; apply Hh. - unfold SP. unfold SP in Pi_r. clear SP. + unfold SP. unfold SP in Pi_r, Pc, Pfor. clear SP. (* destruct hgn as [_m1 _m2 _gn _g _vargs _vargs' _s1 _vm2 _vres _vres' get_g _hvargs *) (* _hwr_vargs _hbody _h_get_res _h_trunc_res]. *) + + specialize (ihgn hP). + + destruct (smcget _ _ _ _ _ _ hgn) as [f hf]. + destruct (tr_prog_inv _ _ _ hf) as [fs' [l [hl [ef ep]]]]. + simpl in ep. + rewrite ep in ihgn. + unfold translate_prog'. + rewrite hl. + + (* it's not the case that + (translate_funs P (l ++ fs')).1 = (translate_funs P fs').1 + but we should be able to show that... *) + assert (translate_call P gn (translate_funs P (l ++ ((gn,f) :: fs'))).1 + = translate_call P gn (translate_funs P ((gn,f) :: fs')).1) + as H0. + { + clear -ef ep hl hf. + unfold translate_prog' in ep, ef. + rewrite hl in ep, ef. + unfold translate_call. + simpl in *. + rewrite ef. + destruct (gn == gn) eqn:E. + 2: { move /eqP in E. exfalso. apply E. reflexivity. } + reflexivity. + } + rewrite H0. eapply ihgn. - 1: give_up. -(* instantiate (1 := translate_call gn (translate_prog' P)). *) - - -(* destruct hgn. *) -(* set (SP := translate_prog' P). *) -(* rename fn0 into gn. *) -(* destruct (assoc SP gn) as [SP_gn|] eqn:E'. *) -(* 2: { rename H into E''. unfold SP in E'. *) - -(* assert ( *) -(* forall (P : uprog) fn f, *) -(* get_fundef (p_funcs P) fn = Some f *) -(* -> *) -(* ∑ prog' : uprog, *) -(* ∑ tl : uprog, p_funcs prog' ++ p_funcs tl = p_funcs P /\ *) -(* assoc (translate_prog' prog') fn = *) -(* Some (translate_call fn (translate_prog' prog'))) *) -(* by admit. *) - -(* pose (X _ _ _ E'') as h_tr_g. *) -(* destruct h_tr_g as [prog' [tl [e' asc]]]. *) -(* assert (forall (K : eqType) V l l' (k : K) (v : V), *) -(* assoc l k = Some v -> *) -(* assoc (l ++ l') k = Some v). *) -(* { pose (assoc_cat). *) -(* admit. } *) -(* assert *) -(* (assoc (translate_prog' P) gn = *) -(* Some (translate_call gn (translate_prog' prog'))). *) -(* { unfold translate_prog'. rewrite -e'. *) -(* admit. } *) -(* rewrite H5 in E'. noconf E'. *) -(* } *) - -(* rewrite -E'. *) -(* unfold SP_gn in E'. *) -(* pose (translate_prog_inv P gn (translate_call gn SP) E'). *) -(* give_up. *) - * (* should be similar to Copn, by appealing to correctness of write_lvals. *) - simpl. - admit. + * (* Should be similar to Copn, by appealing to correctness of + write_lvals, expect that we also need to restore `evm s1`. *) + clear ihgn. + + unshelve eapply u_pre_weaken_rule with + (p1 := (rel_estate {| emem := m2; evm := evm s1 |} fn)). + -- eapply translate_write_lvals_correct. + exact hwr_vres. + -- intros h hm. unfold rel_estate. split; try easy. + simpl. unfold rel_vmap. + give_up. - (* proc *) + rename fn into fn_ambient. unfold sem_Ind_proc. red. intros m1 m2 gn g vs vs' s1 vm2 vrs vrs'. intros hg hvs ?????. unfold Pfun, Translation.Pfun. intros hp. - destruct H. + (* destruct H. *) unfold translate_prog', translate_call. (* rewrite hg. *) (* destruct (get_fundef (p_funcs P) gn) as [g'|] eqn:E. *) (* 2: { inversion hg. } *) - destruct (tr_prog_inv _ _ _ hg) as [fs' E'']. - unfold translate_prog' in E''. - rewrite E''. - unfold translate_call_body. + destruct (tr_prog_inv _ _ _ hg) as [fs' [l [hl [ef ep]]]]. + unfold translate_prog' in ep. + rewrite ep. + unfold translate_call, translate_call_body. rewrite hg. simpl. + destruct (gn == gn) eqn:E. + 2: { move /eqP in E. exfalso. apply E. reflexivity. } eapply u_bind with (v₁ := tt). 1: { idtac. - instantiate (1 := rel_mem m1). - admit. + (* eapply translate_write_lvals_correct. *) + instantiate (1 := rel_estate s1 fn_ambient). + Fail eapply translate_write_lvals_correct. + give_up. } eapply u_bind with (v₁ := tt) (q := rel_mem m2). + unfold Pc, SP, translate_prog' in H2. assert (handled_cmd (f_body g)) as h_gbody. { inversion hp. give_up. } - apply H2 in h_gbody. + specialize (H2 h_gbody). + rewrite hl in H2. + + (* maybe something similar to the prove of + assert (translate_call P gn (translate_funs P (l ++ ((gn,f) :: fs'))).1 + = translate_call P gn (translate_funs P ((gn,f) :: fs')).1) + *) + assert (translate_cmd P (translate_funs P (l ++ ((gn,g) :: fs'))).1 fn_ambient (f_body g) + = translate_cmd P (translate_funs P ((gn,g) :: fs')).1 fn_ambient (f_body g)) + as htr. + { + clear -ef ep hl hg. + unfold translate_prog' in ep, ef. + rewrite hl in ep, ef. + unfold translate_cmd. + unfold translate_instr. + simpl in *. + unfold translate_call, translate_call_body. + simpl. + destruct g. simpl. + destruct f_body. + - reflexivity. + - simpl. + destruct i. destruct i0 eqn:case_i. + + admit. + + admit. + + admit. + + admit. + + admit. + + simpl. + + rewrite -hl. + + rewrite -ef. + destruct (gn == gn) eqn:E. + 2: { move /eqP in E. exfalso. apply E. reflexivity. } + simpl. + admit. + } + rewrite htr in H2. + (* PGH: something about the funnames in H2 and the goal is fishy. *) + subst. give_up. + + eapply u_bind. * eapply bind_list_correct. -- inversion H3. From f41eb643a344e5b244794ae64d501ff8c7a942eb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Fri, 13 May 2022 13:22:33 +0200 Subject: [PATCH 237/383] Nits --- theories/Jasmin/jasmin_translate.v | 176 ++++++++++++++++------------- 1 file changed, 96 insertions(+), 80 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 96dbc16f..92892cb0 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -153,11 +153,14 @@ Proof. - intros [] []. intuition eauto. Qed. -Definition typed_chElement := pointed_value. +Definition typed_chElement := + pointed_value. -Definition to_typed_chElement {t : choice_type} (v : t) : typed_chElement := (t ; v). +Definition to_typed_chElement {t : choice_type} (v : t) : typed_chElement := + (t ; v). -Definition typed_code := ∑ (a : choice_type), raw_code a. +Definition typed_code := + ∑ (a : choice_type), raw_code a. Definition encode (t : stype) : choice_type := match t with @@ -1202,7 +1205,7 @@ Definition translate_write_lvals fn ls vs := foldr2 (λ l v c, translate_write_lval fn l v ;; c) ls vs (ret tt). Lemma eq_rect_K : - forall (A : eqType) (x : A) (P : A -> Type) h e, + ∀ (A : eqType) (x : A) (P : A -> Type) h e, @eq_rect A x P h x e = h. Proof. intros A x P' h e. @@ -2442,27 +2445,29 @@ Proof. eapply translate_pexprs_types. eassumption. (* this should maybe be a lemma or the condition in bind_list_correct should be rewrote to match H *) - * clear -h2 H hcond. + * { + clear -h2 H hcond. revert v' h2 H. induction es; intros. - ** inversion h2. - constructor. - ** inversion h2. - jbind H1 x Hx. - jbind H1 y Hy. - noconf H1. - constructor. - *** eapply H. - 1: apply mem_head. - 1: eassumption. - assumption. - *** eapply IHes. - 1: assumption. - intros. - eapply H. - { rewrite in_cons. rewrite H0. by apply /orP; right. } - 1: eassumption. - assumption. + - inversion h2. + constructor. + - inversion h2. + jbind H1 x Hx. + jbind H1 y Hy. + noconf H1. + constructor. + + eapply H. + 1: apply mem_head. + 1: eassumption. + assumption. + + eapply IHes. + 1: assumption. + intros. + eapply H. + { rewrite in_cons. rewrite H0. by apply /orP; right. } + 1: eassumption. + assumption. + } + apply u_ret. intros; split; auto. rewrite coerce_to_choice_type_translate_value_to_val. @@ -2980,9 +2985,11 @@ Definition translate_call_body (fn : funname) (tr_f_body : raw_code 'unit) : raw_code [choiceType of list typed_chElement]. Proof using P asm_op asmop pd. (* sem_call *) - refine (match (get_fundef (p_funcs P) fn) with - | Some f => _ - | None => ret [::] end). + refine + match (get_fundef (p_funcs P) fn) with + | Some f => _ + | None => ret [::] + end. pose (trunc_list (f_tyin f) vargs') as vargs. apply (bind (translate_write_lvals (p_globs P) fn @@ -3235,10 +3242,10 @@ Definition tr_p (prog : uprog) : ssprove_prog. Proof using asm_op asmop pd. pose (fs := translate_prog prog). induction fs as [|f fs ?]. -- constructor 1. -- constructor 2. - 2: assumption. - exact (f.1, translate_call prog f.1 (f::fs)). + - constructor 1. + - constructor 2. + 2: assumption. + exact (f.1, translate_call prog f.1 (f::fs)). Defined. (* PGH: TODO: do we need an ambient funname? *) @@ -3265,13 +3272,12 @@ Definition translate_prog' P := Lemma tr_prog_inv P fn f : get_fundef (p_funcs P) fn = Some f → ∑ fs' l, - p_funcs P = l ++ (fn, f) :: fs' /\ - assoc (translate_prog' P).1 fn = - Some (translate_cmd P (translate_funs P fs').1 fn (f_body f)) - /\ - assoc (translate_prog' P).2 fn = - let tr_fs' := translate_funs P ((fn, f) :: fs') in - Some (translate_call P fn tr_fs'.1). + p_funcs P = l ++ (fn, f) :: fs' ∧ + assoc (translate_prog' P).1 fn = + Some (translate_cmd P (translate_funs P fs').1 fn (f_body f)) ∧ + assoc (translate_prog' P).2 fn = + let tr_fs' := translate_funs P ((fn, f) :: fs') in + Some (translate_call P fn tr_fs'.1). Proof. unfold translate_prog'. induction (p_funcs P) as [|[gn g] fs' ih_fs']. @@ -3346,11 +3352,12 @@ Definition Pfun (P : uprog) (fn : funname) m va m' vr := ⦃ rel_mem m' ⦄. Fact smcget P s1 gn vargs m2 vres : - (sem_call P (emem s1) gn vargs m2 vres - → ∃ f, get_fundef (p_funcs P) gn = Some f ). -Proof. intros. - inversion H. - exists f. easy. + sem_call P (emem s1) gn vargs m2 vres → + ∃ f, get_fundef (p_funcs P) gn = Some f. +Proof. + intros h. + inversion h. + exists f. assumption. Qed. Theorem translate_prog_correct P (fn : funname) m va m' vr : @@ -3360,7 +3367,7 @@ Proof. intros H hP. set (Pfun := λ (m : mem) (fn : funname) (va : seq value) (m' : mem) (vr : seq value), - Pfun P fn m va m' vr + Pfun P fn m va m' vr ). set (SP := (translate_prog' P).1). set (Pi_r := @@ -3491,28 +3498,30 @@ Proof. eapply translate_pexprs_types. exact hargs. (* this should maybe be a lemma or the condition in bind_list_correct should be rewrote to match H *) - * (* clear -h2 H hcond. *) + * { + (* clear -h2 H hcond. *) (* revert v' h2 H. *) clear hgn ihgn. revert vargs hargs. induction args; intros. - ** inversion hargs. - constructor. - ** inversion hargs as [H1]. - jbind H1 x Hx. - jbind H1 y Hy. - noconf H1. - constructor. - *** eapply translate_pexpr_correct. - 1: eassumption. - easy. - *** simpl. eapply IHargs. - 1: assumption. + - inversion hargs. + constructor. + - inversion hargs as [H1]. + jbind H1 x Hx. + jbind H1 y Hy. + noconf H1. + constructor. + + eapply translate_pexpr_correct. + 1: eassumption. + auto. + + simpl. eapply IHargs. + assumption. + } + simpl. eapply u_bind. * simpl. unshelve eapply u_pre_weaken_rule with (p1 := (rel_mem (emem s1))). - 2: move => h Hh; apply Hh. + 2:{ move => h Hh. apply Hh. } unfold SP. unfold SP in Pi_r, Pc, Pfor. clear SP. (* destruct hgn as [_m1 _m2 _gn _g _vargs _vargs' _s1 _vm2 _vres _vres' get_g _hvargs *) (* _hwr_vargs _hbody _h_get_res _h_trunc_res]. *) @@ -3529,9 +3538,10 @@ Proof. (* it's not the case that (translate_funs P (l ++ fs')).1 = (translate_funs P fs').1 but we should be able to show that... *) - assert (translate_call P gn (translate_funs P (l ++ ((gn,f) :: fs'))).1 - = translate_call P gn (translate_funs P ((gn,f) :: fs')).1) - as H0. + assert (H0 : + translate_call P gn (translate_funs P (l ++ ((gn,f) :: fs'))).1 = + translate_call P gn (translate_funs P ((gn,f) :: fs')).1 + ). { clear -ef ep hl hf. unfold translate_prog' in ep, ef. @@ -3542,20 +3552,22 @@ Proof. destruct (gn == gn) eqn:E. 2: { move /eqP in E. exfalso. apply E. reflexivity. } reflexivity. - } + } rewrite H0. eapply ihgn. - * (* Should be similar to Copn, by appealing to correctness of + * { + (* Should be similar to Copn, by appealing to correctness of write_lvals, expect that we also need to restore `evm s1`. *) clear ihgn. unshelve eapply u_pre_weaken_rule with (p1 := (rel_estate {| emem := m2; evm := evm s1 |} fn)). - -- eapply translate_write_lvals_correct. - exact hwr_vres. - -- intros h hm. unfold rel_estate. split; try easy. - simpl. unfold rel_vmap. - give_up. + - eapply translate_write_lvals_correct. + exact hwr_vres. + - intros h hm. unfold rel_estate. split; try easy. + simpl. unfold rel_vmap. + give_up. + } - (* proc *) rename fn into fn_ambient. unfold sem_Ind_proc. red. intros m1 m2 gn g vs vs' s1 vm2 vrs vrs'. @@ -3588,7 +3600,8 @@ Proof. + unfold Pc, SP, translate_prog' in H2. assert (handled_cmd (f_body g)) as h_gbody. { inversion hp. - give_up. } + give_up. + } specialize (H2 h_gbody). rewrite hl in H2. @@ -3596,9 +3609,10 @@ Proof. assert (translate_call P gn (translate_funs P (l ++ ((gn,f) :: fs'))).1 = translate_call P gn (translate_funs P ((gn,f) :: fs')).1) *) - assert (translate_cmd P (translate_funs P (l ++ ((gn,g) :: fs'))).1 fn_ambient (f_body g) - = translate_cmd P (translate_funs P ((gn,g) :: fs')).1 fn_ambient (f_body g)) - as htr. + assert (htr : + translate_cmd P (translate_funs P (l ++ ((gn,g) :: fs'))).1 fn_ambient (f_body g) = + translate_cmd P (translate_funs P ((gn,g) :: fs')).1 fn_ambient (f_body g) + ). { clear -ef ep hl hg. unfold translate_prog' in ep, ef. @@ -3622,11 +3636,11 @@ Proof. rewrite -hl. - rewrite -ef. - destruct (gn == gn) eqn:E. - 2: { move /eqP in E. exfalso. apply E. reflexivity. } - simpl. - admit. + rewrite -ef. + destruct (gn == gn) eqn:E. + 2: { move /eqP in E. exfalso. apply E. reflexivity. } + simpl. + admit. } rewrite htr in H2. (* PGH: something about the funnames in H2 and the goal is fishy. *) @@ -3634,10 +3648,12 @@ Proof. give_up. + eapply u_bind. - * eapply bind_list_correct. - -- inversion H3. - admit. - -- admit. + * { + eapply bind_list_correct. + - inversion H3. + admit. + - admit. + } * inversion H4. admit. Admitted. From 6e95f1c07cb6d539d170b2b7c971eab929da683e Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Fri, 13 May 2022 16:38:13 +0100 Subject: [PATCH 238/383] clean up main theorem (statement & proof) --- .../three_functions/three_functions.v | 8 +- theories/Jasmin/jasmin_translate.v | 227 ++++++++---------- 2 files changed, 106 insertions(+), 129 deletions(-) diff --git a/theories/Jasmin/examples/three_functions/three_functions.v b/theories/Jasmin/examples/three_functions/three_functions.v index 60dcb921..d51c2f8c 100644 --- a/theories/Jasmin/examples/three_functions/three_functions.v +++ b/theories/Jasmin/examples/three_functions/three_functions.v @@ -236,13 +236,13 @@ Definition three_functions := -Definition tr_P := Eval simpl in tr_p three_functions. +Definition tr_P := Eval simpl in translate_prog' three_functions. Definition default_prog' := (1%positive, (ret tt)). Definition default_call := (1%positive, fun (x : [choiceType of seq typed_chElement]) => ret x). Definition get_tr sp n := List.nth_default default_call sp n. -Definition tr_f := Eval simpl in (get_tr tr_P 2). -Definition tr_g := Eval simpl in (get_tr tr_P 1). -Definition tr_h := Eval simpl in (get_tr tr_P 0). +Definition tr_f := Eval simpl in (get_tr tr_P.2 2). +Definition tr_g := Eval simpl in (get_tr tr_P.2 1). +Definition tr_h := Eval simpl in (get_tr tr_P.2 0). Opaque translate_for. diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 92892cb0..92ed6507 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -2532,6 +2532,34 @@ Proof. assumption. Qed. +Corollary bind_list_pexpr_correct (cond : heap → Prop) (es : pexprs) (vs : list value) + (s1 : estate) (fn : funname) + (hc : ∀ m : heap, cond m → rel_estate s1 fn m) + (h : sem_pexprs gd s1 es = ok vs) + : ⊢ ⦃ cond ⦄ bind_list [seq translate_pexpr fn e | e <- es] ⇓ + [seq totce (translate_value v) | v <- vs] ⦃ cond ⦄. +Proof. + eapply bind_list_correct with (vs := vs). + * rewrite <- map_comp. + unfold comp. + eapply translate_pexprs_types. + exact h. + * revert vs h. + induction es; intros. + ** inversion h. + constructor. + ** inversion h as [H1]. + jbind H1 x Hx. + jbind H1 y Hy. + noconf H1. + constructor. + *** eapply translate_pexpr_correct. + 1: eassumption. + easy. + *** simpl. eapply IHes. + 1: assumption. +Qed. + Corollary translate_pexpr_correct_cast : ∀ fn (e : pexpr) s₁ v (cond : heap → Prop), sem_pexpr gd s₁ e = ok v → @@ -3269,7 +3297,7 @@ Definition translate_funs (P : uprog) : seq _ufun_decl → fdefs * ssprove_prog Definition translate_prog' P := translate_funs P (p_funcs P). -Lemma tr_prog_inv P fn f : +Lemma tr_prog_inv {P fn f} : get_fundef (p_funcs P) fn = Some f → ∑ fs' l, p_funcs P = l ++ (fn, f) :: fs' ∧ @@ -3284,29 +3312,20 @@ Proof. - move => //. - simpl in *. move => h //. - destruct (gn == fn) eqn:e. + destruct (fn == gn) eqn:e. + move /eqP in e. subst. - destruct (fn == fn) eqn:E. - 2: { move /eqP in E. exfalso. apply E. reflexivity. } noconf h. exists fs'. exists [::]. simpl. - unfold translate_call. simpl. rewrite E. - intuition auto. - + assert (fn == gn = false). - { apply /eqP. move => H. symmetry in H. revert H. - move /eqP in e. apply e. - } - rewrite H. - rewrite H in h. - specialize (ih_fs' h). + unfold translate_call. simpl. + assert (E : gn == gn) by now apply /eqP. + rewrite E. easy. + + specialize (ih_fs' h). destruct ih_fs' as [fs'0 [l0 [ihl iha]]]. rewrite ihl. exists fs'0. exists ((gn, g) :: l0). - split. - * easy. - * subst. easy. + subst. split; easy. Qed. @@ -3340,26 +3359,45 @@ Definition handled_fundecl (f : _ufun_decl) := Definition handled_program (P : uprog) := List.forallb handled_fundecl P.(p_funcs). +Fact sem_call_get_some {P m1 gn vargs m2 vres} : + (sem_call P m1 gn vargs m2 vres + → ∃ f, get_fundef (p_funcs P) gn = Some f ). +Proof. intros H. inversion H. exists f. easy. +Qed. + +Definition chfun := [choiceType of seq typed_chElement] + → raw_code [choiceType of seq typed_chElement]. + +Definition get_translated_fun P fn : chfun := + match assoc (translate_prog' P).2 fn with + | Some f => f + | None => λ _, ret [::] + end. + +Lemma translate_call_head {P gn fs' f} : + assoc (translate_prog' P).1 gn = + Some (translate_cmd P (translate_funs P fs').1 gn (f_body f)) + → + translate_call P gn (translate_funs P (p_funcs P)).1 + = translate_call P gn (translate_funs P ((gn,f) :: fs')).1. +Proof. + intros ef. + unfold translate_call at 1. + rewrite ef. + simpl. + unfold translate_call, assoc at 1. + assert (E : gn == gn) by now apply /eqP. + now rewrite E. +Qed. + Definition Pfun (P : uprog) (fn : funname) m va m' vr := handled_program P → ⊢ ⦃ rel_mem m ⦄ (* translate_call P fn (translate_prog' P) [seq totce (translate_value v) | v <- va] *) - match assoc (translate_prog' P).2 fn with - | None => ret [::] - | Some f => f [seq totce (translate_value v) | v <- va] - end + get_translated_fun P fn [seq totce (translate_value v) | v <- va] ⇓ [seq totce (translate_value v) | v <- vr] ⦃ rel_mem m' ⦄. -Fact smcget P s1 gn vargs m2 vres : - sem_call P (emem s1) gn vargs m2 vres → - ∃ f, get_fundef (p_funcs P) gn = Some f. -Proof. - intros h. - inversion h. - exists f. assumption. -Qed. - Theorem translate_prog_correct P (fn : funname) m va m' vr : sem.sem_call P m fn va m' vr → Pfun P fn m va m' vr. @@ -3421,12 +3459,7 @@ Proof. jbind ho vs hv. jbind hv vs' hv'. eapply u_bind. - + eapply bind_list_correct. - * rewrite <- map_comp. unfold comp. - eapply translate_pexprs_types. - eassumption. - * apply translate_pexprs_correct. - assumption. + + eapply bind_list_pexpr_correct. 2: eassumption. easy. + erewrite translate_exec_sopn_correct by eassumption. apply translate_write_lvals_correct. assumption. @@ -3488,107 +3521,49 @@ Proof. - (* call *) red. intros s1 m2 s2 ii xs gn args vargs vres hargs hgn ihgn hwr_vres. - unfold Pfun in ihgn. - unfold Translation.Pfun in ihgn. - red. simpl. intros _. + unfold Pfun, Translation.Pfun, get_translated_fun in ihgn. + red. simpl. intros _. unfold translate_instr_r. eapply u_bind. - + eapply bind_list_correct with (vs := vargs). - * rewrite <- map_comp. - unfold comp. - eapply translate_pexprs_types. - exact hargs. - (* this should maybe be a lemma or the condition in bind_list_correct should be rewrote to match H *) - * { - (* clear -h2 H hcond. *) - (* revert v' h2 H. *) - clear hgn ihgn. - revert vargs hargs. - induction args; intros. - - inversion hargs. - constructor. - - inversion hargs as [H1]. - jbind H1 x Hx. - jbind H1 y Hy. - noconf H1. - constructor. - + eapply translate_pexpr_correct. - 1: eassumption. - auto. - + simpl. eapply IHargs. - assumption. - } - + simpl. - eapply u_bind. - * simpl. - unshelve eapply u_pre_weaken_rule with (p1 := (rel_mem (emem s1))). - 2:{ move => h Hh. apply Hh. } - unfold SP. unfold SP in Pi_r, Pc, Pfor. clear SP. - (* destruct hgn as [_m1 _m2 _gn _g _vargs _vargs' _s1 _vm2 _vres _vres' get_g _hvargs *) - (* _hwr_vargs _hbody _h_get_res _h_trunc_res]. *) - - specialize (ihgn hP). - - destruct (smcget _ _ _ _ _ _ hgn) as [f hf]. - destruct (tr_prog_inv _ _ _ hf) as [fs' [l [hl [ef ep]]]]. - simpl in ep. - rewrite ep in ihgn. - unfold translate_prog'. - rewrite hl. - - (* it's not the case that - (translate_funs P (l ++ fs')).1 = (translate_funs P fs').1 - but we should be able to show that... *) - assert (H0 : - translate_call P gn (translate_funs P (l ++ ((gn,f) :: fs'))).1 = - translate_call P gn (translate_funs P ((gn,f) :: fs')).1 - ). - { - clear -ef ep hl hf. - unfold translate_prog' in ep, ef. - rewrite hl in ep, ef. - unfold translate_call. - simpl in *. - rewrite ef. - destruct (gn == gn) eqn:E. - 2: { move /eqP in E. exfalso. apply E. reflexivity. } - reflexivity. - } - rewrite H0. - eapply ihgn. - * { - (* Should be similar to Copn, by appealing to correctness of - write_lvals, expect that we also need to restore `evm s1`. *) - clear ihgn. - - unshelve eapply u_pre_weaken_rule with - (p1 := (rel_estate {| emem := m2; evm := evm s1 |} fn)). - - eapply translate_write_lvals_correct. - exact hwr_vres. - - intros h hm. unfold rel_estate. split; try easy. - simpl. unfold rel_vmap. - give_up. - } + 1: eapply bind_list_pexpr_correct; try eassumption; easy. + eapply u_bind with (v₁ := [seq totce (translate_value v) | v <- vres]) + (q := rel_mem m2). + * unshelve eapply u_pre_weaken_rule with (p1 := (rel_mem (emem s1))). + 2: move => h Hh; apply Hh. + unfold SP in *. clear SP. + specialize (ihgn hP). + unfold translate_prog'. + destruct (sem_call_get_some hgn) as [f hf]. + destruct (tr_prog_inv hf) as [fs' [l [hl [ef ep]]]]. + simpl in ep. + rewrite ep in ihgn. + pose (translate_call_head ef) as hc. + rewrite hc. + apply ihgn. + * (* Should be similar to Copn, by appealing to correctness of + write_lvals, expect that we also need to restore `evm s1`. *) + clear ihgn. + unshelve eapply u_pre_weaken_rule with + (p1 := (rel_estate {| emem := m2; evm := evm s1 |} fn)). + -- eapply translate_write_lvals_correct. + exact hwr_vres. + -- intros h hm. unfold rel_estate. split; try easy. + simpl. unfold rel_vmap. + give_up. - (* proc *) rename fn into fn_ambient. unfold sem_Ind_proc. red. intros m1 m2 gn g vs vs' s1 vm2 vrs vrs'. intros hg hvs ?????. - unfold Pfun, Translation.Pfun. intros hp. - (* destruct H. *) - unfold translate_prog', translate_call. - - (* rewrite hg. *) - (* destruct (get_fundef (p_funcs P) gn) as [g'|] eqn:E. *) - (* 2: { inversion hg. } *) + unfold Translation.Pfun. intros hp. - destruct (tr_prog_inv _ _ _ hg) as [fs' [l [hl [ef ep]]]]. + unfold get_translated_fun. + destruct (tr_prog_inv hg) as [fs' [l [hl [ef ep]]]]. unfold translate_prog' in ep. rewrite ep. unfold translate_call, translate_call_body. rewrite hg. simpl. - destruct (gn == gn) eqn:E. - 2: { move /eqP in E. exfalso. apply E. reflexivity. } - + assert (E : gn == gn) by now apply /eqP. + rewrite E; clear E. eapply u_bind with (v₁ := tt). 1: { idtac. (* eapply translate_write_lvals_correct. *) @@ -3608,6 +3583,8 @@ Proof. (* maybe something similar to the prove of assert (translate_call P gn (translate_funs P (l ++ ((gn,f) :: fs'))).1 = translate_call P gn (translate_funs P ((gn,f) :: fs')).1) + + just need to push the (translate_funs ...) in until they get to a funcall? *) assert (htr : translate_cmd P (translate_funs P (l ++ ((gn,g) :: fs'))).1 fn_ambient (f_body g) = From ed06ae0ea84715fcfff5dfb5a577c622bc624bf1 Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Fri, 13 May 2022 19:08:49 +0100 Subject: [PATCH 239/383] generalise over the funname during the induction in the main thm --- theories/Jasmin/jasmin_translate.v | 138 +++++++++++++++-------------- 1 file changed, 73 insertions(+), 65 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 92ed6507..5c37bf3f 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -3003,21 +3003,23 @@ Definition trunc_list := (λ tys (vs : seq typed_chElement), [seq let '(ty, v) := ty_v in totce (truncate_el ty v.π2) | ty_v <- zip tys vs]). +(* The type of translated function *bodies* *) Definition fdefs := (* ∀ fn fdef, get_fundef (p_funcs P) fn = Some fdef → raw_code 'unit. *) list (funname * (raw_code 'unit)). +Definition tchlist := [choiceType of seq typed_chElement]. + +(* The type of translated function "calls" *) +Definition trfun := tchlist → raw_code tchlist. Definition translate_call_body (fn : funname) (tr_f_body : raw_code 'unit) - (vargs' : [choiceType of seq typed_chElement]) - : raw_code [choiceType of list typed_chElement]. + : trfun. Proof using P asm_op asmop pd. (* sem_call *) - refine - match (get_fundef (p_funcs P) fn) with - | Some f => _ - | None => ret [::] - end. + refine (λ vargs', match (get_fundef (p_funcs P) fn) with + | Some f => _ + | None => ret [::] end). pose (trunc_list (f_tyin f) vargs') as vargs. apply (bind (translate_write_lvals (p_globs P) fn @@ -3036,11 +3038,9 @@ Proof using P asm_op asmop pd. exact (ret vres'). Defined. -Definition translate_call (fn : funname) (tr_f_body : fdefs) - (vargs : [choiceType of seq typed_chElement]) - : raw_code [choiceType of list typed_chElement]. +Definition translate_call (fn : funname) (tr_f_body : fdefs) : trfun. Proof using P asm_op asmop pd. - refine (match assoc tr_f_body fn with + refine (λ vargs, match assoc tr_f_body fn with | Some tr_f => _ | None => ret [::] end). exact (translate_call_body fn tr_f vargs). Defined. @@ -3177,15 +3177,16 @@ Fixpoint translate_cmd (fn : funname) (c : cmd) : raw_code 'unit := End TranslateCMD. +(* PGH: CURRENTLY UNUSED. Keeping this around for when we want to package + functions into packages, as we'll have to bundle the arguments and results + into tuples. *) Record fdef := { ffun : typed_raw_function ; locs : {fset Location} ; imp : Interface ; }. - #[local] Definition ty_in fd := (ffun fd).π1. #[local] Definition ty_out fd := ((ffun fd).π2).π1. - Definition translate_fundef (tr_f_body : fdefs) (fd : _ufun_decl (* extra_fun_t *)) : funname * fdef. @@ -3251,7 +3252,7 @@ Context `{asmop : asmOp}. Context {pd : PointerData}. -Definition ssprove_prog := seq (funname * ([choiceType of seq typed_chElement] → raw_code [choiceType of list typed_chElement])). +Definition ssprove_prog := seq (funname * trfun). Definition translate_prog (prog : uprog) : fdefs. Proof using asm_op asmop pd. @@ -3365,10 +3366,7 @@ Fact sem_call_get_some {P m1 gn vargs m2 vres} : Proof. intros H. inversion H. exists f. easy. Qed. -Definition chfun := [choiceType of seq typed_chElement] - → raw_code [choiceType of seq typed_chElement]. - -Definition get_translated_fun P fn : chfun := +Definition get_translated_fun P fn : trfun := match assoc (translate_prog' P).2 fn with | Some f => f | None => λ _, ret [::] @@ -3398,19 +3396,18 @@ Definition Pfun (P : uprog) (fn : funname) m va m' vr := ⇓ [seq totce (translate_value v) | v <- vr] ⦃ rel_mem m' ⦄. -Theorem translate_prog_correct P (fn : funname) m va m' vr : - sem.sem_call P m fn va m' vr → - Pfun P fn m va m' vr. +Theorem translate_prog_correct P m vargs m' vres : + ∀ fn, sem.sem_call P m fn vargs m' vres → + Pfun P fn m vargs m' vres. Proof. - intros H hP. - set (Pfun := - λ (m : mem) (fn : funname) (va : seq value) (m' : mem) (vr : seq value), - Pfun P fn m va m' vr - ). + intros fn H hP. + set (Pfun := λ (m : mem) (fn : funname) (va : seq value) (m' : mem) (vr : seq value), + Pfun P fn m va m' vr + ). set (SP := (translate_prog' P).1). set (Pi_r := λ (s1 : estate) (i : instr_r) (s2 : estate), - handled_instr_r i → + ∀ fn, handled_instr_r i → ⊢ ⦃ rel_estate s1 fn ⦄ translate_instr_r P SP fn i ⇓ tt ⦃ rel_estate s2 fn ⦄ @@ -3418,12 +3415,12 @@ Proof. set (Pi := λ s1 i s2, Pi_r s1 (instr_d i) s2). set (Pc := λ (s1 : estate) (c : cmd) (s2 : estate), - handled_cmd c → + ∀ fn, handled_cmd c → ⊢ ⦃ rel_estate s1 fn ⦄ translate_cmd P SP fn c ⇓ tt ⦃ rel_estate s2 fn ⦄ ). set (Pfor := λ (v : var_i) (ws : seq Z) (s1 : estate) (c : cmd) (s2 : estate), - handled_cmd c → + ∀ fn, handled_cmd c → ⊢ ⦃ rel_estate s1 fn ⦄ translate_for fn v ws (translate_cmd P SP fn c) ⇓ tt ⦃ rel_estate s2 fn ⦄ @@ -3431,10 +3428,10 @@ Proof. unshelve eapply (@sem_call_Ind _ _ _ _ Pc Pi_r Pi Pfor Pfun _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H). - (* nil *) red. intros s. - red. simpl. intros _. + red. simpl. intros fn' _. eapply u_ret_eq. auto. - (* cons *) - red. intros s1 s2 s3 i c hi ihi hc ihc. + red. intros s1 s2 s3 i c hi ihi hc ihc fn'. red. simpl. move /andP => [hdi hdc]. eapply u_bind. + rewrite translate_instr_unfold. eapply ihi. @@ -3445,7 +3442,7 @@ Proof. apply ihi. - (* assgn *) red. intros s₁ s₂ x tag ty e v v' he hv hw. - red. simpl. intros _. + red. simpl. intros fn' _. eapply u_bind. 1:{ eapply translate_pexpr_correct. all: eauto. } erewrite translate_pexpr_type by eassumption. @@ -3454,7 +3451,7 @@ Proof. erewrite totce_truncate_translate by eassumption. eapply translate_write_lval_correct. all: eauto. - (* opn *) - red. intros s1 s2 tag o xs es ho _. + red. intros s1 s2 tag o xs es ho fn' _. red. simpl. jbind ho vs hv. jbind hv vs' hv'. @@ -3464,7 +3461,7 @@ Proof. apply translate_write_lvals_correct. assumption. - (* if_true *) - red. intros s1 s2 e c1 c2 he hc1 ihc1. + red. intros s1 s2 e c1 c2 he hc1 ihc1 fn'. red. simpl. move /andP => [hdc1 hdc2]. unfold translate_instr_r. lazymatch goal with @@ -3475,7 +3472,7 @@ Proof. 1:{ eapply translate_pexpr_correct_cast in he. all: eauto. } simpl. apply ihc1. assumption. - (* if_false *) - red. intros s1 s2 e c1 c2 he hc2 ihc2. + red. intros s1 s2 e c1 c2 he hc2 ihc2 fn'. red. simpl. move /andP => [hdc1 hdc2]. (* lazymatch goal with | |- context [ if _ then _ else (?f ?fn ?c) ] => @@ -3491,7 +3488,7 @@ Proof. red. intros s1 s2 a c e c' hc ihc he. red. simpl. discriminate. - (* for *) - red. intros s1 s2 i d lo hi c vlo vhi hlo hhi hfor ihfor. + red. intros s1 s2 i d lo hi c vlo vhi hlo hhi hfor ihfor fn'. red. simpl. intros hdc. unfold translate_instr_r. lazymatch goal with @@ -3504,10 +3501,10 @@ Proof. 1:{ eapply translate_pexpr_correct_cast in hhi. all: eauto. } apply ihfor. assumption. - (* for_nil *) - red. intros. red. intros hdc. + red. intros. red. intros hdc fn'. simpl. apply u_ret_eq. auto. - (* for_cons *) - red. intros s1 s1' s2 s3 i w ws c hw hc ihc hfor ihfor. + red. intros s1 s1' s2 s3 i w ws c hw hc ihc hfor ihfor fn'. red. simpl. intros hdc. eapply u_put. eapply u_bind. @@ -3520,7 +3517,8 @@ Proof. apply ihfor. assumption. - (* call *) red. - intros s1 m2 s2 ii xs gn args vargs vres hargs hgn ihgn hwr_vres. + clear H vargs vres. + intros s1 m2 s2 ii xs gn args vargs vres hargs hgn ihgn hwr_vres fn'. unfold Pfun, Translation.Pfun, get_translated_fun in ihgn. red. simpl. intros _. unfold translate_instr_r. eapply u_bind. @@ -3543,7 +3541,7 @@ Proof. write_lvals, expect that we also need to restore `evm s1`. *) clear ihgn. unshelve eapply u_pre_weaken_rule with - (p1 := (rel_estate {| emem := m2; evm := evm s1 |} fn)). + (p1 := (rel_estate {| emem := m2; evm := evm s1 |} fn')). -- eapply translate_write_lvals_correct. exact hwr_vres. -- intros h hm. unfold rel_estate. split; try easy. @@ -3551,34 +3549,48 @@ Proof. give_up. - (* proc *) rename fn into fn_ambient. - unfold sem_Ind_proc. red. intros m1 m2 gn g vs vs' s1 vm2 vrs vrs'. - intros hg hvs ?????. + rename vargs into vargs_amb. rename vres into vres_amb. + unfold sem_Ind_proc. red. intros m1 m2 gn g vargs vargs' s1 vm2 vres vres'. + intros hg hvars hwr hbody ihbody hget htrunc. unfold Translation.Pfun. intros hp. unfold get_translated_fun. destruct (tr_prog_inv hg) as [fs' [l [hl [ef ep]]]]. unfold translate_prog' in ep. rewrite ep. - unfold translate_call, translate_call_body. - rewrite hg. + unfold translate_call. simpl. assert (E : gn == gn) by now apply /eqP. rewrite E; clear E. - eapply u_bind with (v₁ := tt). - 1: { idtac. + unfold translate_call_body. + rewrite hg. + eapply u_bind with (v₁ := tt) (q := rel_estate s1 gn). + 1: { (* eapply translate_write_lvals_correct. *) - instantiate (1 := rel_estate s1 fn_ambient). Fail eapply translate_write_lvals_correct. give_up. } eapply u_bind with (v₁ := tt) (q := rel_mem m2). - + unfold Pc, SP, translate_prog' in H2. - assert (handled_cmd (f_body g)) as h_gbody. - { inversion hp. - give_up. + + unfold Pc, SP, translate_prog' in ihbody. + assert (handled_cmd (f_body g)) as hpbody. + { + clear -hg hp. + pose (gd := (gn, g)). + unfold handled_program. + pose (hh := (List.forallb_forall handled_fundecl (p_funcs P)).1 hp gd). + destruct g. + apply hh. simpl. + now apply (assoc_mem' hg). } - specialize (H2 h_gbody). - rewrite hl in H2. + (* PGH (Fri 13 May 19:02:28 BST 2022): + Generalized the different Pc, Pi, ... to allow variation of the funname. + This should allow us to use the induction hypothesis on a different function, + gn in this case. + *) + specialize (ihbody gn hpbody). clear hpbody. + rewrite hl in ihbody. + (* TODO: strengthen post condition to + rel_estate {| emem := m2; evm := vm2 |} gn *) (* maybe something similar to the prove of assert (translate_call P gn (translate_funs P (l ++ ((gn,f) :: fs'))).1 @@ -3586,10 +3598,8 @@ Proof. just need to push the (translate_funs ...) in until they get to a funcall? *) - assert (htr : - translate_cmd P (translate_funs P (l ++ ((gn,g) :: fs'))).1 fn_ambient (f_body g) = - translate_cmd P (translate_funs P ((gn,g) :: fs')).1 fn_ambient (f_body g) - ). + assert (htr : translate_cmd P (translate_funs P (l ++ ((gn,g) :: fs'))).1 gn (f_body g) + = translate_cmd P (translate_funs P ((gn,g) :: fs')).1 gn (f_body g)). { clear -ef ep hl hg. unfold translate_prog' in ep, ef. @@ -3619,19 +3629,17 @@ Proof. simpl. admit. } - rewrite htr in H2. + rewrite htr in ihbody. (* PGH: something about the funnames in H2 and the goal is fishy. *) subst. give_up. + eapply u_bind. - * { - eapply bind_list_correct. - - inversion H3. - admit. - - admit. - } - * inversion H4. + * eapply bind_list_correct. + -- inversion hget. + admit. + -- admit. + * inversion htrunc. admit. Admitted. From b4f394f134a76749a02a9ebdd2c55b6320a4868e Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Sun, 15 May 2022 12:46:10 +0100 Subject: [PATCH 240/383] nits --- theories/Crypt/examples/AsymScheme.v | 8 ++++---- theories/Crypt/examples/ElGamal.v | 23 ++++++++++------------- 2 files changed, 14 insertions(+), 17 deletions(-) diff --git a/theories/Crypt/examples/AsymScheme.v b/theories/Crypt/examples/AsymScheme.v index 5c6ef172..139ecb8b 100644 --- a/theories/Crypt/examples/AsymScheme.v +++ b/theories/Crypt/examples/AsymScheme.v @@ -307,8 +307,8 @@ Module AsymmetricScheme (π : AsymmetricSchemeParams) #def #[challenge_id] (mL_mR : 'plain × 'plain) : 'cipher { count ← get counter_loc ;; - #put counter_loc := (count + 1)%N;; #assert (count == 0)%N ;; + #put counter_loc := (count + 1)%N;; '(pk, sk) ← KeyGen ;; #put pk_loc := pk ;; #put sk_loc := sk ;; @@ -334,8 +334,8 @@ Module AsymmetricScheme (π : AsymmetricSchemeParams) #def #[challenge_id] (mL_mR : 'plain × 'plain) : 'cipher { count ← get counter_loc ;; - #put counter_loc := (count + 1)%N;; #assert (count == 0)%N ;; + #put counter_loc := (count + 1)%N;; '(pk, sk) ← KeyGen ;; #put pk_loc := pk ;; #put sk_loc := sk ;; @@ -387,8 +387,8 @@ Module AsymmetricScheme (π : AsymmetricSchemeParams) #def #[challenge_id'] (m : 'plain) : 'cipher { count ← get counter_loc ;; - #put counter_loc := (count + 1)%N;; #assert (count == 0)%N ;; + #put counter_loc := (count + 1)%N;; '(pk, sk) ← KeyGen ;; #put pk_loc := pk ;; #put sk_loc := sk ;; @@ -415,8 +415,8 @@ Module AsymmetricScheme (π : AsymmetricSchemeParams) #def #[challenge_id'] (m : 'plain) : 'cipher { count ← get counter_loc ;; - #put counter_loc := (count + 1)%N;; #assert (count == 0)%N ;; + #put counter_loc := (count + 1)%N;; '(pk, sk) ← KeyGen ;; #put pk_loc := pk ;; #put sk_loc := sk ;; diff --git a/theories/Crypt/examples/ElGamal.v b/theories/Crypt/examples/ElGamal.v index 4c15a32e..8e8bbaf1 100644 --- a/theories/Crypt/examples/ElGamal.v +++ b/theories/Crypt/examples/ElGamal.v @@ -141,6 +141,7 @@ Module MyAlg <: AsymmetricSchemeAlgorithms MyParam. Definition i_sk := #|SecKey|. Definition i_bool := 2. + (** Key Generation algorithm *) Definition KeyGen {L : {fset Location}} : code L [interface] (chPubKey × chSecKey) := @@ -259,8 +260,8 @@ Definition Aux : { #import {sig #[10] : 'unit → 'pubkey × 'cipher } as query ;; count ← get counter_loc ;; - #put counter_loc := (count + 1)%N ;; #assert (count == 0)%N ;; + #put counter_loc := (count + 1)%N ;; '(pk, c) ← query Datatypes.tt ;; @ret chCipher (fto ((otf c).1 , (otf m) * ((otf c).2))) } @@ -277,8 +278,8 @@ Proof. - eapply rpost_weaken_rule. 1: eapply rreflexivity_rule. move => [a1 h1] [a2 h2] [Heqa Heqh]. intuition auto. - ssprove_sync_eq. intro count. - ssprove_sync_eq. ssprove_sync_eq. move => /eqP e. subst. + ssprove_sync_eq. ssprove_sync_eq. intro a. ssprove_swap_lhs 0%N. ssprove_sync_eq. @@ -389,13 +390,9 @@ Proof. cbn. intros [? ?] [? ?] e. inversion e. intuition auto. - ssprove_sync_eq. intro count. ssprove_sync_eq. - destruct count. - 2:{ - cbn. eapply rpost_weaken_rule. 1: eapply rreflexivity_rule. - cbn. intros [? ?] [? ?] e. inversion e. intuition auto. - } - simpl. - ssprove_sync_eq. intro a. + intros h. + ssprove_sync_eq. + ssprove_sync_eq. intros a. ssprove_swap_rhs 1%N. ssprove_swap_rhs 0%N. ssprove_sync_eq. @@ -410,10 +407,10 @@ Proof. simpl. intros x. unfold f'. set (z := ch2prod x). clearbody z. clear x. destruct z as [x y]. simpl. - eapply r_ret. intros s ? e. subst. - intuition auto. - rewrite !otf_fto. simpl. - reflexivity. + rewrite !otf_fto. + eapply r_ret. + intros s ? e. + subst. simpl. easy. Qed. Theorem ElGamal_OT : From 3c65813ff394e791f523ca9c8f1b1e0c33effe7c Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Mon, 16 May 2022 14:02:20 +0200 Subject: [PATCH 241/383] factor out translate_write_var_correct and _vars_ as separate lemmas --- theories/Jasmin/jasmin_translate.v | 60 +++++++++++++++++++++++++----- 1 file changed, 51 insertions(+), 9 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 5c37bf3f..804bea02 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1204,6 +1204,9 @@ Definition translate_write_lvals fn ls vs := (* foldl2 (λ c l v, translate_write_lval fn l v ;; c) ls vs (ret tt). *) foldr2 (λ l v c, translate_write_lval fn l v ;; c) ls vs (ret tt). +Definition translate_write_vars fn xs vs := + foldr2 (λ x v c, translate_write_var fn x v ;; c) xs vs (ret tt). + Lemma eq_rect_K : ∀ (A : eqType) (x : A) (P : A -> Type) h e, @eq_rect A x P h x e = h. @@ -2849,6 +2852,23 @@ Proof. eapply h2 in ev. assumption. Qed. +Lemma translate_write_var_correct : + ∀ es₁ es₂ fn y v, + write_var y v es₁ = ok es₂ → + ⊢ ⦃ rel_estate es₁ fn ⦄ + translate_write_var fn y (totce (translate_value v)) + ⇓ tt + ⦃ rel_estate es₂ fn ⦄. +Proof. + intros es₁ es₂ fn y v hw. + simpl. unfold translate_write_var. simpl in hw. + simpl. + eapply u_put. + apply u_ret_eq. + intros m' [m [hm e]]. subst. + eapply translate_write_var_estate. all: eassumption. +Qed. + Lemma translate_write_lval_correct : ∀ es₁ es₂ fn y v, write_lval gd y v es₁ = ok es₂ → @@ -2867,12 +2887,7 @@ Proof. all: noconf hw. all: assumption. + unfold on_vu in hw. destruct of_val as [| []]. all: noconf hw. assumption. - - simpl. unfold translate_write_var. simpl in hw. - simpl. - eapply u_put. - apply u_ret_eq. - intros m' [m [hm e]]. subst. - eapply translate_write_var_estate. all: eassumption. + - now eapply translate_write_var_correct. - simpl. simpl in hw. jbind hw vx hvx. jbind hvx vx' hvx'. jbind hw ve hve. jbind hve ve' hve'. jbind hw w hw'. jbind hw m hm. @@ -2986,6 +3001,35 @@ Proof. assumption. Qed. +Lemma translate_write_vars_cons fn l ls v vs : + translate_write_vars fn (l :: ls) (v :: vs) = (translate_write_var fn l v ;; translate_write_vars fn ls vs). +Proof. reflexivity. Qed. + +Lemma translate_write_vars_correct fn s1 ls vs s2 : + write_vars ls vs s1 = ok s2 → + ⊢ ⦃ rel_estate s1 fn ⦄ + translate_write_vars fn ls [seq totce (translate_value v) | v <- vs] + ⇓ tt + ⦃ rel_estate s2 fn ⦄. +Proof. + intros h. + induction ls as [| l ls] in s1, vs, h |- *. + - destruct vs. 2: discriminate. + noconf h. + apply u_ret_eq. auto. + - destruct vs. 1: noconf h. + simpl in h. + jbind h s3 Hs3. + rewrite map_cons. + rewrite translate_write_vars_cons. + eapply u_bind. + + simpl. + eapply translate_write_var_correct. + eassumption. + + apply IHls. + assumption. +Qed. + End Translation. Section Translation. @@ -3021,9 +3065,7 @@ Proof using P asm_op asmop pd. | Some f => _ | None => ret [::] end). pose (trunc_list (f_tyin f) vargs') as vargs. - apply (bind - (translate_write_lvals (p_globs P) fn - [seq Lvar x | x <- (f_params f)] vargs)) => _. + apply (bind (translate_write_vars fn (f_params f) vargs)) => _. (* Perform the function body. *) (* apply (bind (tr_f_body _ _ E)) => _. *) (* pose (tr_f_body _ _ E) as tr_f. *) From 30ff96f09a9ff4af8bf48247ed916447f1be1808 Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Mon, 16 May 2022 14:03:56 +0200 Subject: [PATCH 242/383] wip: correctness of proc. reading from the empty heap is problematic --- theories/Jasmin/jasmin_translate.v | 43 +++++++++++++++++++++++++++--- 1 file changed, 40 insertions(+), 3 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 804bea02..b9df5414 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -3608,9 +3608,46 @@ Proof. rewrite hg. eapply u_bind with (v₁ := tt) (q := rel_estate s1 gn). 1: { - (* eapply translate_write_lvals_correct. *) - Fail eapply translate_write_lvals_correct. - give_up. + (* PGH: `translate_write_vars_correct` expects some `rel_estate` + as pre, but we only have `rel_mem m1`. + We strengthen the precondition, and show that + `rel_mem m1 => rel_estate (Estate m1 vmap0)` + *) + unshelve eapply u_pre_weaken_rule. + - exact (rel_estate (Estate m1 vmap0) gn). + - simpl. + assert + (Htr : (trunc_list (f_tyin g) + [seq totce (translate_value v) | v <- vargs']) + = [seq totce (translate_value v) | v <- vargs]) + by admit. + rewrite Htr. + now eapply translate_write_vars_correct. + - intros h hmem. + unfold rel_estate, rel_vmap. + split; auto. intros i v hvm. + rewrite coerce_to_choice_type_K. + simpl in hvm. + unfold vmap0 in hvm. + rewrite Fv.get0 in hvm. + (* We're reading an undefined address, and getting an `ok v`; + surely we can invert and exfalso on that. *) + unfold undef_addr in hvm. + (* It's not going to work on arrays. This is dumb. + Why did they define it like that? Is this really a + good spec for a memory model? *) + unfold translate_var. + destruct (vtype i); unfold undef_error in hvm; + try now inversion hvm. + noconf hvm. simpl. + (* Seems like we're forced to prove that h is the empty heap. + Maybe backtrack and think about an alternative to showing the + implication between the preconditions. Or convince Jasmin dev + to change their definition. *) + assert (hh : h = empty_heap) by give_up. + rewrite hh. + rewrite get_empty_heap. + simpl. easy. } eapply u_bind with (v₁ := tt) (q := rel_mem m2). + unfold Pc, SP, translate_prog' in ihbody. From 7b7dac527f294e4b16eaa499a1314f6066715e6a Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Mon, 16 May 2022 17:49:47 +0200 Subject: [PATCH 243/383] strengthen IH in main thm, by adding global rel_estate (broken) --- theories/Jasmin/jasmin_translate.v | 151 +++++++++++++++++++---------- 1 file changed, 101 insertions(+), 50 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index b9df5414..fa8d411a 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1362,6 +1362,17 @@ Definition rel_vmap (vm : vmap) (fn : funname) (h : heap) := Definition rel_estate (s : estate) (fn : funname) (h : heap) := rel_mem s.(emem) h ∧ rel_vmap s.(evm) fn h. +Definition rel_estate_global (s : estate) (h : heap) := + forall fn, rel_estate s fn h. + +Fact rel_estate_commute h s : + rel_estate_global s h <-> (rel_mem s.(emem) h ∧ forall fn, rel_vmap s.(evm) fn h). +Proof. + unfold rel_estate_global, rel_estate. intuition auto. + - now destruct (H 1%positive). + - now destruct (H fn). +Qed. + Lemma translate_read_estate : ∀ fn s ptr sz w m, rel_estate s fn m → @@ -1384,12 +1395,15 @@ Proof. Qed. Lemma translate_write_estate : - ∀ fn sz s cm ptr w m, + ∀ sz s cm ptr w m, write s.(emem) ptr (sz := sz) w = ok cm → - rel_estate s fn m → - rel_estate {| emem := cm ; evm := s.(evm) |} fn (set_heap m mem_loc (write_mem (get_heap m mem_loc) ptr w)). + rel_estate_global s m → + rel_estate_global {| emem := cm ; evm := s.(evm) |} + (set_heap m mem_loc (write_mem (get_heap m mem_loc) ptr w)). Proof. - intros fn sz s cm ptr w m hw [hrm hvm]. + intros sz s cm ptr w m hw hrm_hvm. + unfold rel_estate_global in hrm_hvm. + apply rel_estate_commute in hrm_hvm as [hrm hvm]. split. - simpl. eapply translate_write_mem_correct. all: eassumption. - simpl. intros i v ev. @@ -1495,7 +1509,7 @@ Qed. Lemma translate_get_var_correct : ∀ fn x s v (cond : heap → Prop), get_var (evm s) x = ok v → - (∀ m, cond m → rel_estate s fn m) → + (∀ m, cond m → rel_estate_global s m) → ⊢ ⦃ cond ⦄ translate_get_var fn x ⇓ coerce_to_choice_type _ (translate_value v) ⦃ cond ⦄. @@ -1513,7 +1527,7 @@ Qed. Lemma translate_gvar_correct (f : funname) (x : gvar) (v : value) s (cond : heap → Prop) : get_gvar gd (evm s) x = ok v → - (∀ m, cond m → rel_estate s f m) → + (∀ m, cond m → rel_estate_global s m) → ⊢ ⦃ cond ⦄ translate_gvar f x ⇓ coerce_to_choice_type _ (translate_value v) ⦃ cond ⦄. @@ -2278,7 +2292,7 @@ Qed. Lemma translate_pexpr_correct : ∀ fn (e : pexpr) s₁ v (cond : heap → Prop), sem_pexpr gd s₁ e = ok v → - (∀ m, cond m → rel_estate s₁ fn m) → + (∀ m, cond m → rel_estate_global s₁ m) → ⊢ ⦃ cond ⦄ (translate_pexpr fn e).π2 ⇓ coerce_to_choice_type _ (translate_value v) @@ -2311,8 +2325,8 @@ Proof. intro v. apply u_ret. intros m [hm e]. unfold u_get in e. subst. split. 1: assumption. - apply hcond in hm. destruct hm as [hm hv]. - apply hv in e1. rewrite e1. + apply hcond in hm. apply rel_estate_commute in hm as [hm hv]. + eapply hv in e1. rewrite e1. simpl. rewrite coerce_to_choice_type_K. rewrite coerce_to_choice_type_translate_value_to_val. reflexivity. @@ -2378,11 +2392,13 @@ Proof. rewrite coerce_to_choice_type_K. erewrite translate_to_word. 2: eassumption. eapply hcond in hm. - erewrite get_var_get_heap. 2-3: eassumption. + apply rel_estate_commute in hm as [hm hv]. + erewrite get_var_get_heap. + 2-3: unfold rel_estate; eauto. simpl. erewrite <- type_of_get_var. 2: eassumption. rewrite coerce_to_choice_type_K. eapply translate_to_word in hw1 as e1. rewrite e1. clear e1. - eapply translate_read_estate. all: eassumption. + eapply translate_read_estate. all: unfold rel_estate; eauto. - (* Papp1 *) simpl in *. jbind h1 v' h2. @@ -2502,15 +2518,16 @@ Proof. erewrite translate_pexpr_type. 2: eassumption. rewrite coerce_to_choice_type_K. apply translate_truncate_val. assumption. + Unshelve. all: exact fn. Qed. Lemma translate_pexprs_correct fn s vs es : sem_pexprs gd s es = ok vs → List.Forall2 (λ c v, - ⊢ ⦃ rel_estate s fn ⦄ + ⊢ ⦃ rel_estate_global s ⦄ c.π2 ⇓ coerce_to_choice_type _ (translate_value v) - ⦃ rel_estate s fn ⦄ + ⦃ rel_estate_global s ⦄ ) [seq translate_pexpr fn e | e <- es] vs. Proof. intro hvs. @@ -2537,7 +2554,7 @@ Qed. Corollary bind_list_pexpr_correct (cond : heap → Prop) (es : pexprs) (vs : list value) (s1 : estate) (fn : funname) - (hc : ∀ m : heap, cond m → rel_estate s1 fn m) + (hc : ∀ m : heap, cond m → rel_estate_global s1 m) (h : sem_pexprs gd s1 es = ok vs) : ⊢ ⦃ cond ⦄ bind_list [seq translate_pexpr fn e | e <- es] ⇓ [seq totce (translate_value v) | v <- vs] ⦃ cond ⦄. @@ -2566,7 +2583,7 @@ Qed. Corollary translate_pexpr_correct_cast : ∀ fn (e : pexpr) s₁ v (cond : heap → Prop), sem_pexpr gd s₁ e = ok v → - (∀ m, cond m → rel_estate s₁ fn m) → + (∀ m, cond m → rel_estate_global s₁ m) → ⊢ ⦃ cond ⦄ coerce_typed_code _ (translate_pexpr fn e) ⇓ translate_value v @@ -2788,11 +2805,11 @@ Proof. Qed. Lemma translate_write_correct : - ∀ fn sz s p (w : word sz) cm (cond : heap → Prop), - (∀ m, cond m → write s.(emem) p w = ok cm ∧ rel_estate s fn m) → - ⊢ ⦃ cond ⦄ translate_write p w ⇓ tt ⦃ rel_estate {| emem := cm ; evm := s.(evm) |} fn ⦄. + ∀ sz s p (w : word sz) cm (cond : heap → Prop), + (∀ m, cond m → write s.(emem) p w = ok cm ∧ rel_estate_global s m) → + ⊢ ⦃ cond ⦄ translate_write p w ⇓ tt ⦃ rel_estate_global {| emem := cm ; evm := s.(evm) |} ⦄. Proof. - intros fn sz s p w cm cond h. + intros sz s p w cm cond h. unfold translate_write. eapply u_get_remember. intros m. eapply u_put. @@ -2806,17 +2823,20 @@ Qed. Lemma translate_write_var_estate : ∀ fn i v s1 s2 m, write_var i v s1 = ok s2 → - rel_estate s1 fn m → - rel_estate s2 fn (set_heap m (translate_var fn i) (truncate_el i.(vtype) (translate_value v))). + rel_estate_global s1 m → + rel_estate_global s2 (set_heap m (translate_var fn i) (truncate_el i.(vtype) (translate_value v))). Proof. - intros fn i v s1 s2 m hw [h1 h2]. + intros fn i v s1 s2 m hw H. unfold write_var in hw. jbind hw vm hvm. noconf hw. split. all: simpl. - - intros ptr v' er. + - intros ptr v' er. destruct (H fn) as [h1 h2]. eapply h1 in er. rewrite get_set_heap_neq. 2: apply mem_loc_translate_var_neq. assumption. - - intros vi v' ev. + - destruct (fn == fn0) eqn:efn. + { destruct (H fn) as [h1 h2]. + move : efn => /eqP efn. subst. + intros vi v' ev. eapply set_varP. 3: exact hvm. + intros v₁ hv₁ eyl. subst. destruct (vi == i) eqn:evar. @@ -2850,7 +2870,32 @@ Proof. contradiction. } eapply h2 in ev. assumption. -Qed. + } + { + intros vi v' ev. + rewrite get_set_heap_neq. + + destruct (H fn0) as [h1 h2]. + apply h2. + + eapply set_varP; eauto. + * intros. + destruct (vi == i) eqn:evar. + all: move: evar => /eqP evar. + - eapply translate_of_val in H0 as e. + + eapply set_varP. 3: exact hvm. + + intros v₁ hv₁ eyl. subst. + destruct (vi == i) eqn:evar. + all: move: evar => /eqP evar. + * subst. rewrite Fv.setP_eq in ev. noconf ev. + rewrite get_set_heap_neq. + 2: admit. + eapply translate_of_val in hv₁ as e. + destruct (H fn0) as [h1 h2]. + unfold rel_vmap in h2. + apply h2. + admit. +Admitted. Lemma translate_write_var_correct : ∀ es₁ es₂ fn y v, @@ -3001,19 +3046,19 @@ Proof. assumption. Qed. -Lemma translate_write_vars_cons fn l ls v vs : - translate_write_vars fn (l :: ls) (v :: vs) = (translate_write_var fn l v ;; translate_write_vars fn ls vs). +Lemma translate_write_vars_cons fn x xs v vs : + translate_write_vars fn (x :: xs) (v :: vs) = (translate_write_var fn x v ;; translate_write_vars fn xs vs). Proof. reflexivity. Qed. -Lemma translate_write_vars_correct fn s1 ls vs s2 : - write_vars ls vs s1 = ok s2 → +Lemma translate_write_vars_correct fn s1 xs vs s2 : + write_vars xs vs s1 = ok s2 → ⊢ ⦃ rel_estate s1 fn ⦄ - translate_write_vars fn ls [seq totce (translate_value v) | v <- vs] + translate_write_vars fn xs [seq totce (translate_value v) | v <- vs] ⇓ tt ⦃ rel_estate s2 fn ⦄. Proof. intros h. - induction ls as [| l ls] in s1, vs, h |- *. + induction xs as [| x xs] in s1, vs, h |- *. - destruct vs. 2: discriminate. noconf h. apply u_ret_eq. auto. @@ -3026,7 +3071,7 @@ Proof. + simpl. eapply translate_write_var_correct. eassumption. - + apply IHls. + + apply IHxs. assumption. Qed. @@ -3432,11 +3477,12 @@ Qed. Definition Pfun (P : uprog) (fn : funname) m va m' vr := handled_program P → - ⊢ ⦃ rel_mem m ⦄ + forall vm fn_ambient, + ⊢ ⦃ rel_estate {| emem := m; evm := vm |} fn_ambient ⦄ (* translate_call P fn (translate_prog' P) [seq totce (translate_value v) | v <- va] *) get_translated_fun P fn [seq totce (translate_value v) | v <- va] ⇓ [seq totce (translate_value v) | v <- vr] - ⦃ rel_mem m' ⦄. + ⦃ rel_estate {| emem := m'; evm := vm |} fn_ambient ⦄. Theorem translate_prog_correct P m vargs m' vres : ∀ fn, sem.sem_call P m fn vargs m' vres → @@ -3564,31 +3610,33 @@ Proof. unfold Pfun, Translation.Pfun, get_translated_fun in ihgn. red. simpl. intros _. unfold translate_instr_r. eapply u_bind. + (* evaluation of arguments *) 1: eapply bind_list_pexpr_correct; try eassumption; easy. + eapply u_bind with (v₁ := [seq totce (translate_value v) | v <- vres]) - (q := rel_mem m2). - * unshelve eapply u_pre_weaken_rule with (p1 := (rel_mem (emem s1))). - 2: move => h Hh; apply Hh. + (q := rel_estate {| emem := m2; evm := evm s1 |} fn'). + (* execution of the procedure call *) + * (* unshelve eapply u_pre_weaken_rule with (p1 := (rel_mem (emem s1))). *) + (* 2: move => h Hh; apply Hh. *) unfold SP in *. clear SP. - specialize (ihgn hP). + specialize (ihgn hP (evm s1) fn'). unfold translate_prog'. destruct (sem_call_get_some hgn) as [f hf]. destruct (tr_prog_inv hf) as [fs' [l [hl [ef ep]]]]. simpl in ep. + assert (hs1 : s1 = {| emem := emem s1; evm := evm s1 |}). + { clear. destruct s1. reflexivity. } + rewrite -hs1 in ihgn. rewrite ep in ihgn. pose (translate_call_head ef) as hc. rewrite hc. apply ihgn. + + (* write results *) * (* Should be similar to Copn, by appealing to correctness of write_lvals, expect that we also need to restore `evm s1`. *) clear ihgn. - unshelve eapply u_pre_weaken_rule with - (p1 := (rel_estate {| emem := m2; evm := evm s1 |} fn')). - -- eapply translate_write_lvals_correct. - exact hwr_vres. - -- intros h hm. unfold rel_estate. split; try easy. - simpl. unfold rel_vmap. - give_up. + now eapply translate_write_lvals_correct. - (* proc *) rename fn into fn_ambient. rename vargs into vargs_amb. rename vres into vres_amb. @@ -3606,7 +3654,8 @@ Proof. rewrite E; clear E. unfold translate_call_body. rewrite hg. - eapply u_bind with (v₁ := tt) (q := rel_estate s1 gn). + intros VM FN_AMB. + eapply u_bind with (v₁ := tt) (q := rel_estate s1 FN_AMB). 1: { (* PGH: `translate_write_vars_correct` expects some `rel_estate` as pre, but we only have `rel_mem m1`. @@ -3624,10 +3673,10 @@ Proof. rewrite Htr. now eapply translate_write_vars_correct. - intros h hmem. - unfold rel_estate, rel_vmap. - split; auto. intros i v hvm. + split; auto. simpl. + unfold rel_vmap. + intros i v hvm. rewrite coerce_to_choice_type_K. - simpl in hvm. unfold vmap0 in hvm. rewrite Fv.get0 in hvm. (* We're reading an undefined address, and getting an `ok v`; @@ -3649,7 +3698,9 @@ Proof. rewrite get_empty_heap. simpl. easy. } - eapply u_bind with (v₁ := tt) (q := rel_mem m2). + eapply u_bind with (v₁ := tt) + (q := rel_estate {| emem := m2; evm := vm2 |} gn) + (* (q := rel_mem m2) *). + unfold Pc, SP, translate_prog' in ihbody. assert (handled_cmd (f_body g)) as hpbody. { From 3558ae7998638ae278037ae19d208d83277d5606 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Mon, 16 May 2022 17:53:05 +0200 Subject: [PATCH 244/383] minor fix --- theories/Jasmin/jasmin_translate.v | 26 ++++++-------------------- 1 file changed, 6 insertions(+), 20 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index fa8d411a..55f5db40 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -2871,30 +2871,16 @@ Proof. } eapply h2 in ev. assumption. } + { intros vi v' ev. rewrite get_set_heap_neq. - + destruct (H fn0) as [h1 h2]. - apply h2. - - eapply set_varP; eauto. - * intros. - destruct (vi == i) eqn:evar. - all: move: evar => /eqP evar. - - eapply translate_of_val in H0 as e. - eapply set_varP. 3: exact hvm. - + intros v₁ hv₁ eyl. subst. - destruct (vi == i) eqn:evar. - all: move: evar => /eqP evar. - * subst. rewrite Fv.setP_eq in ev. noconf ev. - rewrite get_set_heap_neq. - 2: admit. - eapply translate_of_val in hv₁ as e. - destruct (H fn0) as [h1 h2]. - unfold rel_vmap in h2. - apply h2. - admit. + + rewrite coerce_to_choice_type_K. + erewrite (_ : rel_vmap _ _ _). + 2: eassumption. + rewrite coerce_to_choice_type_K. reflexivity. + + admit. Admitted. Lemma translate_write_var_correct : From 1eedd589808ca943cfcc646e2a6f79b94c6dcabb Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Tue, 17 May 2022 13:32:32 +0200 Subject: [PATCH 245/383] Revert "minor fix" This reverts commit 3558ae7998638ae278037ae19d208d83277d5606. --- theories/Jasmin/jasmin_translate.v | 26 ++++++++++++++++++++------ 1 file changed, 20 insertions(+), 6 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 55f5db40..fa8d411a 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -2871,16 +2871,30 @@ Proof. } eapply h2 in ev. assumption. } - { intros vi v' ev. rewrite get_set_heap_neq. + + destruct (H fn0) as [h1 h2]. + apply h2. + + eapply set_varP; eauto. + * intros. + destruct (vi == i) eqn:evar. + all: move: evar => /eqP evar. + - eapply translate_of_val in H0 as e. - + rewrite coerce_to_choice_type_K. - erewrite (_ : rel_vmap _ _ _). - 2: eassumption. - rewrite coerce_to_choice_type_K. reflexivity. - + admit. + eapply set_varP. 3: exact hvm. + + intros v₁ hv₁ eyl. subst. + destruct (vi == i) eqn:evar. + all: move: evar => /eqP evar. + * subst. rewrite Fv.setP_eq in ev. noconf ev. + rewrite get_set_heap_neq. + 2: admit. + eapply translate_of_val in hv₁ as e. + destruct (H fn0) as [h1 h2]. + unfold rel_vmap in h2. + apply h2. + admit. Admitted. Lemma translate_write_var_correct : From b18255faa8974b3bb6066750e85821be971bdb7f Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Tue, 17 May 2022 13:32:36 +0200 Subject: [PATCH 246/383] Revert "strengthen IH in main thm, by adding global rel_estate (broken)" This reverts commit 7b7dac527f294e4b16eaa499a1314f6066715e6a. --- theories/Jasmin/jasmin_translate.v | 151 ++++++++++------------------- 1 file changed, 50 insertions(+), 101 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index fa8d411a..b9df5414 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1362,17 +1362,6 @@ Definition rel_vmap (vm : vmap) (fn : funname) (h : heap) := Definition rel_estate (s : estate) (fn : funname) (h : heap) := rel_mem s.(emem) h ∧ rel_vmap s.(evm) fn h. -Definition rel_estate_global (s : estate) (h : heap) := - forall fn, rel_estate s fn h. - -Fact rel_estate_commute h s : - rel_estate_global s h <-> (rel_mem s.(emem) h ∧ forall fn, rel_vmap s.(evm) fn h). -Proof. - unfold rel_estate_global, rel_estate. intuition auto. - - now destruct (H 1%positive). - - now destruct (H fn). -Qed. - Lemma translate_read_estate : ∀ fn s ptr sz w m, rel_estate s fn m → @@ -1395,15 +1384,12 @@ Proof. Qed. Lemma translate_write_estate : - ∀ sz s cm ptr w m, + ∀ fn sz s cm ptr w m, write s.(emem) ptr (sz := sz) w = ok cm → - rel_estate_global s m → - rel_estate_global {| emem := cm ; evm := s.(evm) |} - (set_heap m mem_loc (write_mem (get_heap m mem_loc) ptr w)). + rel_estate s fn m → + rel_estate {| emem := cm ; evm := s.(evm) |} fn (set_heap m mem_loc (write_mem (get_heap m mem_loc) ptr w)). Proof. - intros sz s cm ptr w m hw hrm_hvm. - unfold rel_estate_global in hrm_hvm. - apply rel_estate_commute in hrm_hvm as [hrm hvm]. + intros fn sz s cm ptr w m hw [hrm hvm]. split. - simpl. eapply translate_write_mem_correct. all: eassumption. - simpl. intros i v ev. @@ -1509,7 +1495,7 @@ Qed. Lemma translate_get_var_correct : ∀ fn x s v (cond : heap → Prop), get_var (evm s) x = ok v → - (∀ m, cond m → rel_estate_global s m) → + (∀ m, cond m → rel_estate s fn m) → ⊢ ⦃ cond ⦄ translate_get_var fn x ⇓ coerce_to_choice_type _ (translate_value v) ⦃ cond ⦄. @@ -1527,7 +1513,7 @@ Qed. Lemma translate_gvar_correct (f : funname) (x : gvar) (v : value) s (cond : heap → Prop) : get_gvar gd (evm s) x = ok v → - (∀ m, cond m → rel_estate_global s m) → + (∀ m, cond m → rel_estate s f m) → ⊢ ⦃ cond ⦄ translate_gvar f x ⇓ coerce_to_choice_type _ (translate_value v) ⦃ cond ⦄. @@ -2292,7 +2278,7 @@ Qed. Lemma translate_pexpr_correct : ∀ fn (e : pexpr) s₁ v (cond : heap → Prop), sem_pexpr gd s₁ e = ok v → - (∀ m, cond m → rel_estate_global s₁ m) → + (∀ m, cond m → rel_estate s₁ fn m) → ⊢ ⦃ cond ⦄ (translate_pexpr fn e).π2 ⇓ coerce_to_choice_type _ (translate_value v) @@ -2325,8 +2311,8 @@ Proof. intro v. apply u_ret. intros m [hm e]. unfold u_get in e. subst. split. 1: assumption. - apply hcond in hm. apply rel_estate_commute in hm as [hm hv]. - eapply hv in e1. rewrite e1. + apply hcond in hm. destruct hm as [hm hv]. + apply hv in e1. rewrite e1. simpl. rewrite coerce_to_choice_type_K. rewrite coerce_to_choice_type_translate_value_to_val. reflexivity. @@ -2392,13 +2378,11 @@ Proof. rewrite coerce_to_choice_type_K. erewrite translate_to_word. 2: eassumption. eapply hcond in hm. - apply rel_estate_commute in hm as [hm hv]. - erewrite get_var_get_heap. - 2-3: unfold rel_estate; eauto. + erewrite get_var_get_heap. 2-3: eassumption. simpl. erewrite <- type_of_get_var. 2: eassumption. rewrite coerce_to_choice_type_K. eapply translate_to_word in hw1 as e1. rewrite e1. clear e1. - eapply translate_read_estate. all: unfold rel_estate; eauto. + eapply translate_read_estate. all: eassumption. - (* Papp1 *) simpl in *. jbind h1 v' h2. @@ -2518,16 +2502,15 @@ Proof. erewrite translate_pexpr_type. 2: eassumption. rewrite coerce_to_choice_type_K. apply translate_truncate_val. assumption. - Unshelve. all: exact fn. Qed. Lemma translate_pexprs_correct fn s vs es : sem_pexprs gd s es = ok vs → List.Forall2 (λ c v, - ⊢ ⦃ rel_estate_global s ⦄ + ⊢ ⦃ rel_estate s fn ⦄ c.π2 ⇓ coerce_to_choice_type _ (translate_value v) - ⦃ rel_estate_global s ⦄ + ⦃ rel_estate s fn ⦄ ) [seq translate_pexpr fn e | e <- es] vs. Proof. intro hvs. @@ -2554,7 +2537,7 @@ Qed. Corollary bind_list_pexpr_correct (cond : heap → Prop) (es : pexprs) (vs : list value) (s1 : estate) (fn : funname) - (hc : ∀ m : heap, cond m → rel_estate_global s1 m) + (hc : ∀ m : heap, cond m → rel_estate s1 fn m) (h : sem_pexprs gd s1 es = ok vs) : ⊢ ⦃ cond ⦄ bind_list [seq translate_pexpr fn e | e <- es] ⇓ [seq totce (translate_value v) | v <- vs] ⦃ cond ⦄. @@ -2583,7 +2566,7 @@ Qed. Corollary translate_pexpr_correct_cast : ∀ fn (e : pexpr) s₁ v (cond : heap → Prop), sem_pexpr gd s₁ e = ok v → - (∀ m, cond m → rel_estate_global s₁ m) → + (∀ m, cond m → rel_estate s₁ fn m) → ⊢ ⦃ cond ⦄ coerce_typed_code _ (translate_pexpr fn e) ⇓ translate_value v @@ -2805,11 +2788,11 @@ Proof. Qed. Lemma translate_write_correct : - ∀ sz s p (w : word sz) cm (cond : heap → Prop), - (∀ m, cond m → write s.(emem) p w = ok cm ∧ rel_estate_global s m) → - ⊢ ⦃ cond ⦄ translate_write p w ⇓ tt ⦃ rel_estate_global {| emem := cm ; evm := s.(evm) |} ⦄. + ∀ fn sz s p (w : word sz) cm (cond : heap → Prop), + (∀ m, cond m → write s.(emem) p w = ok cm ∧ rel_estate s fn m) → + ⊢ ⦃ cond ⦄ translate_write p w ⇓ tt ⦃ rel_estate {| emem := cm ; evm := s.(evm) |} fn ⦄. Proof. - intros sz s p w cm cond h. + intros fn sz s p w cm cond h. unfold translate_write. eapply u_get_remember. intros m. eapply u_put. @@ -2823,20 +2806,17 @@ Qed. Lemma translate_write_var_estate : ∀ fn i v s1 s2 m, write_var i v s1 = ok s2 → - rel_estate_global s1 m → - rel_estate_global s2 (set_heap m (translate_var fn i) (truncate_el i.(vtype) (translate_value v))). + rel_estate s1 fn m → + rel_estate s2 fn (set_heap m (translate_var fn i) (truncate_el i.(vtype) (translate_value v))). Proof. - intros fn i v s1 s2 m hw H. + intros fn i v s1 s2 m hw [h1 h2]. unfold write_var in hw. jbind hw vm hvm. noconf hw. split. all: simpl. - - intros ptr v' er. destruct (H fn) as [h1 h2]. + - intros ptr v' er. eapply h1 in er. rewrite get_set_heap_neq. 2: apply mem_loc_translate_var_neq. assumption. - - destruct (fn == fn0) eqn:efn. - { destruct (H fn) as [h1 h2]. - move : efn => /eqP efn. subst. - intros vi v' ev. + - intros vi v' ev. eapply set_varP. 3: exact hvm. + intros v₁ hv₁ eyl. subst. destruct (vi == i) eqn:evar. @@ -2870,32 +2850,7 @@ Proof. contradiction. } eapply h2 in ev. assumption. - } - { - intros vi v' ev. - rewrite get_set_heap_neq. - + destruct (H fn0) as [h1 h2]. - apply h2. - - eapply set_varP; eauto. - * intros. - destruct (vi == i) eqn:evar. - all: move: evar => /eqP evar. - - eapply translate_of_val in H0 as e. - - eapply set_varP. 3: exact hvm. - + intros v₁ hv₁ eyl. subst. - destruct (vi == i) eqn:evar. - all: move: evar => /eqP evar. - * subst. rewrite Fv.setP_eq in ev. noconf ev. - rewrite get_set_heap_neq. - 2: admit. - eapply translate_of_val in hv₁ as e. - destruct (H fn0) as [h1 h2]. - unfold rel_vmap in h2. - apply h2. - admit. -Admitted. +Qed. Lemma translate_write_var_correct : ∀ es₁ es₂ fn y v, @@ -3046,19 +3001,19 @@ Proof. assumption. Qed. -Lemma translate_write_vars_cons fn x xs v vs : - translate_write_vars fn (x :: xs) (v :: vs) = (translate_write_var fn x v ;; translate_write_vars fn xs vs). +Lemma translate_write_vars_cons fn l ls v vs : + translate_write_vars fn (l :: ls) (v :: vs) = (translate_write_var fn l v ;; translate_write_vars fn ls vs). Proof. reflexivity. Qed. -Lemma translate_write_vars_correct fn s1 xs vs s2 : - write_vars xs vs s1 = ok s2 → +Lemma translate_write_vars_correct fn s1 ls vs s2 : + write_vars ls vs s1 = ok s2 → ⊢ ⦃ rel_estate s1 fn ⦄ - translate_write_vars fn xs [seq totce (translate_value v) | v <- vs] + translate_write_vars fn ls [seq totce (translate_value v) | v <- vs] ⇓ tt ⦃ rel_estate s2 fn ⦄. Proof. intros h. - induction xs as [| x xs] in s1, vs, h |- *. + induction ls as [| l ls] in s1, vs, h |- *. - destruct vs. 2: discriminate. noconf h. apply u_ret_eq. auto. @@ -3071,7 +3026,7 @@ Proof. + simpl. eapply translate_write_var_correct. eassumption. - + apply IHxs. + + apply IHls. assumption. Qed. @@ -3477,12 +3432,11 @@ Qed. Definition Pfun (P : uprog) (fn : funname) m va m' vr := handled_program P → - forall vm fn_ambient, - ⊢ ⦃ rel_estate {| emem := m; evm := vm |} fn_ambient ⦄ + ⊢ ⦃ rel_mem m ⦄ (* translate_call P fn (translate_prog' P) [seq totce (translate_value v) | v <- va] *) get_translated_fun P fn [seq totce (translate_value v) | v <- va] ⇓ [seq totce (translate_value v) | v <- vr] - ⦃ rel_estate {| emem := m'; evm := vm |} fn_ambient ⦄. + ⦃ rel_mem m' ⦄. Theorem translate_prog_correct P m vargs m' vres : ∀ fn, sem.sem_call P m fn vargs m' vres → @@ -3610,33 +3564,31 @@ Proof. unfold Pfun, Translation.Pfun, get_translated_fun in ihgn. red. simpl. intros _. unfold translate_instr_r. eapply u_bind. - (* evaluation of arguments *) 1: eapply bind_list_pexpr_correct; try eassumption; easy. - eapply u_bind with (v₁ := [seq totce (translate_value v) | v <- vres]) - (q := rel_estate {| emem := m2; evm := evm s1 |} fn'). - (* execution of the procedure call *) - * (* unshelve eapply u_pre_weaken_rule with (p1 := (rel_mem (emem s1))). *) - (* 2: move => h Hh; apply Hh. *) + (q := rel_mem m2). + * unshelve eapply u_pre_weaken_rule with (p1 := (rel_mem (emem s1))). + 2: move => h Hh; apply Hh. unfold SP in *. clear SP. - specialize (ihgn hP (evm s1) fn'). + specialize (ihgn hP). unfold translate_prog'. destruct (sem_call_get_some hgn) as [f hf]. destruct (tr_prog_inv hf) as [fs' [l [hl [ef ep]]]]. simpl in ep. - assert (hs1 : s1 = {| emem := emem s1; evm := evm s1 |}). - { clear. destruct s1. reflexivity. } - rewrite -hs1 in ihgn. rewrite ep in ihgn. pose (translate_call_head ef) as hc. rewrite hc. apply ihgn. - - (* write results *) * (* Should be similar to Copn, by appealing to correctness of write_lvals, expect that we also need to restore `evm s1`. *) clear ihgn. - now eapply translate_write_lvals_correct. + unshelve eapply u_pre_weaken_rule with + (p1 := (rel_estate {| emem := m2; evm := evm s1 |} fn')). + -- eapply translate_write_lvals_correct. + exact hwr_vres. + -- intros h hm. unfold rel_estate. split; try easy. + simpl. unfold rel_vmap. + give_up. - (* proc *) rename fn into fn_ambient. rename vargs into vargs_amb. rename vres into vres_amb. @@ -3654,8 +3606,7 @@ Proof. rewrite E; clear E. unfold translate_call_body. rewrite hg. - intros VM FN_AMB. - eapply u_bind with (v₁ := tt) (q := rel_estate s1 FN_AMB). + eapply u_bind with (v₁ := tt) (q := rel_estate s1 gn). 1: { (* PGH: `translate_write_vars_correct` expects some `rel_estate` as pre, but we only have `rel_mem m1`. @@ -3673,10 +3624,10 @@ Proof. rewrite Htr. now eapply translate_write_vars_correct. - intros h hmem. - split; auto. simpl. - unfold rel_vmap. - intros i v hvm. + unfold rel_estate, rel_vmap. + split; auto. intros i v hvm. rewrite coerce_to_choice_type_K. + simpl in hvm. unfold vmap0 in hvm. rewrite Fv.get0 in hvm. (* We're reading an undefined address, and getting an `ok v`; @@ -3698,9 +3649,7 @@ Proof. rewrite get_empty_heap. simpl. easy. } - eapply u_bind with (v₁ := tt) - (q := rel_estate {| emem := m2; evm := vm2 |} gn) - (* (q := rel_mem m2) *). + eapply u_bind with (v₁ := tt) (q := rel_mem m2). + unfold Pc, SP, translate_prog' in ihbody. assert (handled_cmd (f_body g)) as hpbody. { From c7e9ab5ff3ac7ee3c74fec0d56a0bb077fa7d5c2 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Tue, 24 May 2022 18:01:01 +0200 Subject: [PATCH 247/383] small example of correctness proof --- theories/Jasmin/examples/xor/xor.v | 92 ++++++++++++++++++++++-------- 1 file changed, 67 insertions(+), 25 deletions(-) diff --git a/theories/Jasmin/examples/xor/xor.v b/theories/Jasmin/examples/xor/xor.v index 60e643f8..d4415b7a 100644 --- a/theories/Jasmin/examples/xor/xor.v +++ b/theories/Jasmin/examples/xor/xor.v @@ -6,22 +6,22 @@ Set Warnings "notation-overridden,ambiguous-paths". Require Import List. From Jasmin Require Import expr. -(* From Jasmin Require Import x86_extra. *) +From Jasmin Require Import x86_extra. From JasminSSProve Require Import jasmin_translate. From Crypt Require Import Prelude Package. Import ListNotations. Local Open Scope string. -Context `{asmop : asmOp}. +(* Context `{asmop : asmOp}. *) -Context {T} {pT : progT T}. +(* Context {T} {pT : progT T}. *) -Context {pd : PointerData}. +(* Context {pd : PointerData}. *) -Context (P : uprog). +(* Context (P : uprog). *) -Context (f : funname). +(* Context (f : funname). *) Definition xor := {| p_funcs := @@ -163,32 +163,74 @@ Proof. reflexivity. Qed. - Eval cbn in tr_xor. -Goal forall w, f_xor w = f_xor w. - intros [w1 w2]. - unfold f_xor at 2. + +Lemma injective_translate_var2 : + forall fn x y, x != y -> translate_var fn x != translate_var fn y. +Proof. + intros. + apply /negP. + intros contra. + move: contra => /eqP contra. + eapply injective_translate_var in contra. + move: H => /eqP. easy. + exact xor. + apply x86_correct. + Unshelve. + 2: exact progUnit. +Qed. + +Lemma f_xor_correct : forall w1 w2, ⊢ ⦃ fun _ => True ⦄ f_xor (w1, w2) ⇓ wxor w1 w2 ⦃ fun _ => True ⦄. +Proof. + (* preprocessing *) + unfold f_xor at 1. unfold apply_noConfusion. simpl. unfold translate_write_var. simpl. - unfold translate_var. simpl. - set (fn := 2%positive). - set (x := ('word U64; nat_of_fun_ident fn "x.131")). - set (r := ('word U64; nat_of_fun_ident fn "r.133")). - set (y := ('word U64; nat_of_fun_ident fn "y.132")). - set (r_ := {| vtype := sword64; vname := "r.133" |}). - set (x_ := {| v_var := {| vtype := sword64; vname := "x.131" |}; - v_info := (fn~0)%positive |}). - set (y_ := {| v_var := {| vtype := sword64; vname := "y.132" |}; - v_info := (fn~1)%positive |}). - unfold coerce_chtuple_to_list; simpl. rewrite eq_rect_r_K. simpl. - fold x y. - unfold bind_list'. simpl. unfold bind_list_trunc_aux. simpl. rewrite eq_rect_K. - time repeat setoid_rewrite (@zero_extend_u U64). - unfold translate_var. simpl. fold r. + set (fn := 2%positive). + set (x := translate_var fn {| vtype := sword64; vname := "x.131" |}). + set (r := translate_var fn {| vtype := sword64; vname := "r.133" |}). + set (y := translate_var fn {| vtype := sword64; vname := "y.132" |}). + + (* proof *) + intros. + rewrite !zero_extend_u. + eapply u_put. + eapply u_put. + eapply u_get_remember. + intros. + apply u_put. + apply u_get_remember; intros. + apply u_get_remember; intros. + apply u_put. + apply u_get_remember; intros. + apply u_ret. + intros. + rewrite !zero_extend_u. + split. easy. + repeat destruct H. + rewrite !zero_extend_u in H1. + rewrite !zero_extend_u in H4. + subst. + unfold u_get in *. + rewrite get_set_heap_eq in H0. + rewrite get_set_heap_eq in H3. + erewrite <- get_heap_set_heap in H5. + erewrite <- get_heap_set_heap in H2. + rewrite get_set_heap_eq in H2. + rewrite get_set_heap_eq in H5. + rewrite H2. + rewrite H5. + rewrite <- H3 in H0. + easy. + apply injective_translate_var2. + reflexivity. + apply injective_translate_var2. + reflexivity. +Qed. From 8d4580dc7a7500f4f327c268ffc5c89590ba8416 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Wed, 25 May 2022 09:15:16 +0200 Subject: [PATCH 248/383] prove call case of `prog_correct` --- theories/Jasmin/jasmin_translate.v | 46 +++++++++++++++--------------- 1 file changed, 23 insertions(+), 23 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index b9df5414..e8ffe7bf 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -3431,12 +3431,13 @@ Proof. Qed. Definition Pfun (P : uprog) (fn : funname) m va m' vr := - handled_program P → - ⊢ ⦃ rel_mem m ⦄ + handled_program P → + forall (pre post : heap -> Prop), (forall h, pre h -> rel_mem m h) -> (forall h, post h -> rel_mem m' h) -> + ⊢ ⦃ pre ⦄ (* translate_call P fn (translate_prog' P) [seq totce (translate_value v) | v <- va] *) get_translated_fun P fn [seq totce (translate_value v) | v <- va] ⇓ [seq totce (translate_value v) | v <- vr] - ⦃ rel_mem m' ⦄. + ⦃ post ⦄. Theorem translate_prog_correct P m vargs m' vres : ∀ fn, sem.sem_call P m fn vargs m' vres → @@ -3449,7 +3450,7 @@ Proof. set (SP := (translate_prog' P).1). set (Pi_r := λ (s1 : estate) (i : instr_r) (s2 : estate), - ∀ fn, handled_instr_r i → + handled_instr_r i → ⊢ ⦃ rel_estate s1 fn ⦄ translate_instr_r P SP fn i ⇓ tt ⦃ rel_estate s2 fn ⦄ @@ -3457,12 +3458,12 @@ Proof. set (Pi := λ s1 i s2, Pi_r s1 (instr_d i) s2). set (Pc := λ (s1 : estate) (c : cmd) (s2 : estate), - ∀ fn, handled_cmd c → + handled_cmd c → ⊢ ⦃ rel_estate s1 fn ⦄ translate_cmd P SP fn c ⇓ tt ⦃ rel_estate s2 fn ⦄ ). set (Pfor := λ (v : var_i) (ws : seq Z) (s1 : estate) (c : cmd) (s2 : estate), - ∀ fn, handled_cmd c → + handled_cmd c → ⊢ ⦃ rel_estate s1 fn ⦄ translate_for fn v ws (translate_cmd P SP fn c) ⇓ tt ⦃ rel_estate s2 fn ⦄ @@ -3470,10 +3471,10 @@ Proof. unshelve eapply (@sem_call_Ind _ _ _ _ Pc Pi_r Pi Pfor Pfun _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H). - (* nil *) red. intros s. - red. simpl. intros fn' _. + red. simpl. intros _. eapply u_ret_eq. auto. - (* cons *) - red. intros s1 s2 s3 i c hi ihi hc ihc fn'. + red. intros s1 s2 s3 i c hi ihi hc ihc. red. simpl. move /andP => [hdi hdc]. eapply u_bind. + rewrite translate_instr_unfold. eapply ihi. @@ -3484,7 +3485,7 @@ Proof. apply ihi. - (* assgn *) red. intros s₁ s₂ x tag ty e v v' he hv hw. - red. simpl. intros fn' _. + red. simpl. intros _. eapply u_bind. 1:{ eapply translate_pexpr_correct. all: eauto. } erewrite translate_pexpr_type by eassumption. @@ -3493,7 +3494,7 @@ Proof. erewrite totce_truncate_translate by eassumption. eapply translate_write_lval_correct. all: eauto. - (* opn *) - red. intros s1 s2 tag o xs es ho fn' _. + red. intros s1 s2 tag o xs es ho _. red. simpl. jbind ho vs hv. jbind hv vs' hv'. @@ -3503,7 +3504,7 @@ Proof. apply translate_write_lvals_correct. assumption. - (* if_true *) - red. intros s1 s2 e c1 c2 he hc1 ihc1 fn'. + red. intros s1 s2 e c1 c2 he hc1 ihc1. red. simpl. move /andP => [hdc1 hdc2]. unfold translate_instr_r. lazymatch goal with @@ -3514,7 +3515,7 @@ Proof. 1:{ eapply translate_pexpr_correct_cast in he. all: eauto. } simpl. apply ihc1. assumption. - (* if_false *) - red. intros s1 s2 e c1 c2 he hc2 ihc2 fn'. + red. intros s1 s2 e c1 c2 he hc2 ihc2. red. simpl. move /andP => [hdc1 hdc2]. (* lazymatch goal with | |- context [ if _ then _ else (?f ?fn ?c) ] => @@ -3530,7 +3531,7 @@ Proof. red. intros s1 s2 a c e c' hc ihc he. red. simpl. discriminate. - (* for *) - red. intros s1 s2 i d lo hi c vlo vhi hlo hhi hfor ihfor fn'. + red. intros s1 s2 i d lo hi c vlo vhi hlo hhi hfor ihfor. red. simpl. intros hdc. unfold translate_instr_r. lazymatch goal with @@ -3543,10 +3544,10 @@ Proof. 1:{ eapply translate_pexpr_correct_cast in hhi. all: eauto. } apply ihfor. assumption. - (* for_nil *) - red. intros. red. intros hdc fn'. + red. intros. red. intros hdc. simpl. apply u_ret_eq. auto. - (* for_cons *) - red. intros s1 s1' s2 s3 i w ws c hw hc ihc hfor ihfor fn'. + red. intros s1 s1' s2 s3 i w ws c hw hc ihc hfor ihfor. red. simpl. intros hdc. eapply u_put. eapply u_bind. @@ -3560,14 +3561,15 @@ Proof. - (* call *) red. clear H vargs vres. - intros s1 m2 s2 ii xs gn args vargs vres hargs hgn ihgn hwr_vres fn'. + intros s1 m2 s2 ii xs gn args vargs vres hargs hgn ihgn hwr_vres. unfold Pfun, Translation.Pfun, get_translated_fun in ihgn. red. simpl. intros _. unfold translate_instr_r. eapply u_bind. 1: eapply bind_list_pexpr_correct; try eassumption; easy. eapply u_bind with (v₁ := [seq totce (translate_value v) | v <- vres]) - (q := rel_mem m2). - * unshelve eapply u_pre_weaken_rule with (p1 := (rel_mem (emem s1))). + (q := rel_estate {| emem := m2 ; evm := evm s1 |} fn). + * + unshelve eapply u_pre_weaken_rule with (p1 := fun h => (rel_mem (emem s1) h)). 2: move => h Hh; apply Hh. unfold SP in *. clear SP. specialize (ihgn hP). @@ -3578,17 +3580,15 @@ Proof. rewrite ep in ihgn. pose (translate_call_head ef) as hc. rewrite hc. - apply ihgn. + apply ihgn. 1: easy. intros. apply H. * (* Should be similar to Copn, by appealing to correctness of write_lvals, expect that we also need to restore `evm s1`. *) clear ihgn. unshelve eapply u_pre_weaken_rule with - (p1 := (rel_estate {| emem := m2; evm := evm s1 |} fn')). + (p1 := (rel_estate {| emem := m2; evm := evm s1 |} fn)). -- eapply translate_write_lvals_correct. exact hwr_vres. - -- intros h hm. unfold rel_estate. split; try easy. - simpl. unfold rel_vmap. - give_up. + -- easy. - (* proc *) rename fn into fn_ambient. rename vargs into vargs_amb. rename vres into vres_amb. From b08ff9710e8c42252c3a69779026599a35432563 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Wed, 25 May 2022 09:21:25 +0200 Subject: [PATCH 249/383] Revert "prove call case of `prog_correct`" This reverts commit 8d4580dc7a7500f4f327c268ffc5c89590ba8416. --- theories/Jasmin/jasmin_translate.v | 46 +++++++++++++++--------------- 1 file changed, 23 insertions(+), 23 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index e8ffe7bf..b9df5414 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -3431,13 +3431,12 @@ Proof. Qed. Definition Pfun (P : uprog) (fn : funname) m va m' vr := - handled_program P → - forall (pre post : heap -> Prop), (forall h, pre h -> rel_mem m h) -> (forall h, post h -> rel_mem m' h) -> - ⊢ ⦃ pre ⦄ + handled_program P → + ⊢ ⦃ rel_mem m ⦄ (* translate_call P fn (translate_prog' P) [seq totce (translate_value v) | v <- va] *) get_translated_fun P fn [seq totce (translate_value v) | v <- va] ⇓ [seq totce (translate_value v) | v <- vr] - ⦃ post ⦄. + ⦃ rel_mem m' ⦄. Theorem translate_prog_correct P m vargs m' vres : ∀ fn, sem.sem_call P m fn vargs m' vres → @@ -3450,7 +3449,7 @@ Proof. set (SP := (translate_prog' P).1). set (Pi_r := λ (s1 : estate) (i : instr_r) (s2 : estate), - handled_instr_r i → + ∀ fn, handled_instr_r i → ⊢ ⦃ rel_estate s1 fn ⦄ translate_instr_r P SP fn i ⇓ tt ⦃ rel_estate s2 fn ⦄ @@ -3458,12 +3457,12 @@ Proof. set (Pi := λ s1 i s2, Pi_r s1 (instr_d i) s2). set (Pc := λ (s1 : estate) (c : cmd) (s2 : estate), - handled_cmd c → + ∀ fn, handled_cmd c → ⊢ ⦃ rel_estate s1 fn ⦄ translate_cmd P SP fn c ⇓ tt ⦃ rel_estate s2 fn ⦄ ). set (Pfor := λ (v : var_i) (ws : seq Z) (s1 : estate) (c : cmd) (s2 : estate), - handled_cmd c → + ∀ fn, handled_cmd c → ⊢ ⦃ rel_estate s1 fn ⦄ translate_for fn v ws (translate_cmd P SP fn c) ⇓ tt ⦃ rel_estate s2 fn ⦄ @@ -3471,10 +3470,10 @@ Proof. unshelve eapply (@sem_call_Ind _ _ _ _ Pc Pi_r Pi Pfor Pfun _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H). - (* nil *) red. intros s. - red. simpl. intros _. + red. simpl. intros fn' _. eapply u_ret_eq. auto. - (* cons *) - red. intros s1 s2 s3 i c hi ihi hc ihc. + red. intros s1 s2 s3 i c hi ihi hc ihc fn'. red. simpl. move /andP => [hdi hdc]. eapply u_bind. + rewrite translate_instr_unfold. eapply ihi. @@ -3485,7 +3484,7 @@ Proof. apply ihi. - (* assgn *) red. intros s₁ s₂ x tag ty e v v' he hv hw. - red. simpl. intros _. + red. simpl. intros fn' _. eapply u_bind. 1:{ eapply translate_pexpr_correct. all: eauto. } erewrite translate_pexpr_type by eassumption. @@ -3494,7 +3493,7 @@ Proof. erewrite totce_truncate_translate by eassumption. eapply translate_write_lval_correct. all: eauto. - (* opn *) - red. intros s1 s2 tag o xs es ho _. + red. intros s1 s2 tag o xs es ho fn' _. red. simpl. jbind ho vs hv. jbind hv vs' hv'. @@ -3504,7 +3503,7 @@ Proof. apply translate_write_lvals_correct. assumption. - (* if_true *) - red. intros s1 s2 e c1 c2 he hc1 ihc1. + red. intros s1 s2 e c1 c2 he hc1 ihc1 fn'. red. simpl. move /andP => [hdc1 hdc2]. unfold translate_instr_r. lazymatch goal with @@ -3515,7 +3514,7 @@ Proof. 1:{ eapply translate_pexpr_correct_cast in he. all: eauto. } simpl. apply ihc1. assumption. - (* if_false *) - red. intros s1 s2 e c1 c2 he hc2 ihc2. + red. intros s1 s2 e c1 c2 he hc2 ihc2 fn'. red. simpl. move /andP => [hdc1 hdc2]. (* lazymatch goal with | |- context [ if _ then _ else (?f ?fn ?c) ] => @@ -3531,7 +3530,7 @@ Proof. red. intros s1 s2 a c e c' hc ihc he. red. simpl. discriminate. - (* for *) - red. intros s1 s2 i d lo hi c vlo vhi hlo hhi hfor ihfor. + red. intros s1 s2 i d lo hi c vlo vhi hlo hhi hfor ihfor fn'. red. simpl. intros hdc. unfold translate_instr_r. lazymatch goal with @@ -3544,10 +3543,10 @@ Proof. 1:{ eapply translate_pexpr_correct_cast in hhi. all: eauto. } apply ihfor. assumption. - (* for_nil *) - red. intros. red. intros hdc. + red. intros. red. intros hdc fn'. simpl. apply u_ret_eq. auto. - (* for_cons *) - red. intros s1 s1' s2 s3 i w ws c hw hc ihc hfor ihfor. + red. intros s1 s1' s2 s3 i w ws c hw hc ihc hfor ihfor fn'. red. simpl. intros hdc. eapply u_put. eapply u_bind. @@ -3561,15 +3560,14 @@ Proof. - (* call *) red. clear H vargs vres. - intros s1 m2 s2 ii xs gn args vargs vres hargs hgn ihgn hwr_vres. + intros s1 m2 s2 ii xs gn args vargs vres hargs hgn ihgn hwr_vres fn'. unfold Pfun, Translation.Pfun, get_translated_fun in ihgn. red. simpl. intros _. unfold translate_instr_r. eapply u_bind. 1: eapply bind_list_pexpr_correct; try eassumption; easy. eapply u_bind with (v₁ := [seq totce (translate_value v) | v <- vres]) - (q := rel_estate {| emem := m2 ; evm := evm s1 |} fn). - * - unshelve eapply u_pre_weaken_rule with (p1 := fun h => (rel_mem (emem s1) h)). + (q := rel_mem m2). + * unshelve eapply u_pre_weaken_rule with (p1 := (rel_mem (emem s1))). 2: move => h Hh; apply Hh. unfold SP in *. clear SP. specialize (ihgn hP). @@ -3580,15 +3578,17 @@ Proof. rewrite ep in ihgn. pose (translate_call_head ef) as hc. rewrite hc. - apply ihgn. 1: easy. intros. apply H. + apply ihgn. * (* Should be similar to Copn, by appealing to correctness of write_lvals, expect that we also need to restore `evm s1`. *) clear ihgn. unshelve eapply u_pre_weaken_rule with - (p1 := (rel_estate {| emem := m2; evm := evm s1 |} fn)). + (p1 := (rel_estate {| emem := m2; evm := evm s1 |} fn')). -- eapply translate_write_lvals_correct. exact hwr_vres. - -- easy. + -- intros h hm. unfold rel_estate. split; try easy. + simpl. unfold rel_vmap. + give_up. - (* proc *) rename fn into fn_ambient. rename vargs into vargs_amb. rename vres into vres_amb. From 704d660e10a5fefeb101331ab3243a4c968647d5 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Tue, 31 May 2022 14:53:22 +0200 Subject: [PATCH 250/383] more injectivity --- theories/Jasmin/jasmin_translate.v | 110 +++++++++++++++++++++++++++++ 1 file changed, 110 insertions(+) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index b9df5414..dc56ad37 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -2612,6 +2612,58 @@ Proof. - simpl. micromega.Lia.lia. Qed. +Lemma injective_nat_of_pos : + forall p1 p2, nat_of_pos p1 = nat_of_pos p2 -> p1 = p2. +Proof. + intros p1. induction p1 as [p1 ih | p1 ih |]; intros. + - destruct p2. + + inversion H. + f_equal. apply ih. + apply double_inj. + rewrite -!NatTrec.doubleE. + assumption. + + inversion H. + rewrite !NatTrec.doubleE in H1. + apply f_equal with (f:=odd) in H1. + simpl in H1. + rewrite !odd_double in H1. + easy. + + inversion H. + move: H1 => /eqP. + rewrite NatTrec.doubleE double_eq0 => /eqP H1. + apply nat_of_pos_nonzero in H1 as []. + - destruct p2. + + inversion H. + rewrite !NatTrec.doubleE in H1. + apply f_equal with (f:=odd) in H1. + simpl in H1. + rewrite !odd_double in H1. + easy. + + inversion H. + f_equal. apply ih. + apply double_inj. + rewrite -!NatTrec.doubleE. + assumption. + + inversion H. + rewrite !NatTrec.doubleE in H1. + apply f_equal with (f:=odd) in H1. + simpl in H1. + rewrite !odd_double in H1. + easy. + - destruct p2. + + inversion H. + move: H1 => /eqP. + rewrite eq_sym NatTrec.doubleE double_eq0 => /eqP H1. + apply nat_of_pos_nonzero in H1 as []. + + inversion H. + rewrite !NatTrec.doubleE in H1. + apply f_equal with (f:=odd) in H1. + simpl in H1. + rewrite !odd_double in H1. + easy. + + reflexivity. +Qed. + Lemma ptr_var_nat_neq (ptr : pointer) (fn : funname) (v : var) : nat_of_ptr ptr != nat_of_fun_var fn v. Proof. @@ -2765,6 +2817,50 @@ Proof. auto. Qed. +Lemma nat_of_pos_pos : forall p, (0 < nat_of_pos p)%coq_nat. +Proof. + intros. pose proof nat_of_pos_nonzero p. micromega.Lia.lia. +Qed. + +Lemma injective_nat_of_fun_ident2 : + ∀ fn gn x y, + nat_of_fun_ident fn x = nat_of_fun_ident gn y → + fn = gn /\ x = y. +Proof. + intros fn gn x y e. + unfold nat_of_fun_ident in e. + apply coprime_mul_inj in e as [fn_gn x_y]. + - apply Nat.pow_inj_r in fn_gn; [|micromega.Lia.lia]. + apply Nat.pow_inj_r in x_y; [|micromega.Lia.lia]. + split. + + apply injective_nat_of_pos. assumption. + + apply injective_nat_of_ident. assumption. + - rewrite !Natpow_expn. + rewrite !coprime_pexpl. + 2: apply /ltP; apply nat_of_pos_pos. + rewrite !coprime_pexpr. + 2: apply /ltP; apply nat_of_ident_pos. + reflexivity. + - rewrite !Natpow_expn. + rewrite !coprime_pexpl. + 2: apply /ltP; apply nat_of_pos_pos. + rewrite !coprime_pexpr. + 2: apply /ltP; apply nat_of_ident_pos. + reflexivity. + - rewrite !Natpow_expn. + rewrite !coprime_pexpl. + 2: apply /ltP; apply nat_of_pos_pos. + rewrite !coprime_pexpr. + 2: apply /ltP; apply nat_of_ident_pos. + reflexivity. + - rewrite !Natpow_expn. + rewrite !coprime_pexpl. + 2: apply /ltP; apply nat_of_pos_pos. + rewrite !coprime_pexpr. + 2: apply /ltP; apply nat_of_ident_pos. + reflexivity. +Qed. + Lemma injective_translate_var : ∀ fn, injective (translate_var fn). Proof. @@ -2787,6 +2883,20 @@ Proof. eassumption. Qed. +Lemma injective_translate_var2 : + forall fn gn v1 v2, fn != gn -> translate_var fn v1 != translate_var gn v2. +Proof. + intros. + apply /eqP => contra. + unfold translate_var in contra. + noconf contra. + unfold nat_of_fun_var in H1. + apply coprime_mul_inj in H1 as [e1 e2]. + 2,3,4,5: apply coprime_nat_of_stype_nat_of_fun_ident. + apply injective_nat_of_fun_ident2 in e2 as [fn_gn _]. + move: H => /eqP; easy. +Qed. + Lemma translate_write_correct : ∀ fn sz s p (w : word sz) cm (cond : heap → Prop), (∀ m, cond m → write s.(emem) p w = ok cm ∧ rel_estate s fn m) → From ac4a3358c6e6d03402a08c23c0cb92fe8f172297 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Fri, 3 Jun 2022 11:42:27 +0200 Subject: [PATCH 251/383] Style --- theories/Jasmin/jasmin_translate.v | 116 +++++++++++++++++------------ 1 file changed, 68 insertions(+), 48 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index dc56ad37..d0770af2 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -2535,32 +2535,34 @@ Proof. assumption. Qed. -Corollary bind_list_pexpr_correct (cond : heap → Prop) (es : pexprs) (vs : list value) +Corollary bind_list_pexpr_correct + (cond : heap → Prop) (es : pexprs) (vs : list value) (s1 : estate) (fn : funname) (hc : ∀ m : heap, cond m → rel_estate s1 fn m) - (h : sem_pexprs gd s1 es = ok vs) - : ⊢ ⦃ cond ⦄ bind_list [seq translate_pexpr fn e | e <- es] ⇓ - [seq totce (translate_value v) | v <- vs] ⦃ cond ⦄. + (h : sem_pexprs gd s1 es = ok vs) : + ⊢ ⦃ cond ⦄ + bind_list [seq translate_pexpr fn e | e <- es] ⇓ + [seq totce (translate_value v) | v <- vs] + ⦃ cond ⦄. Proof. eapply bind_list_correct with (vs := vs). - * rewrite <- map_comp. + - rewrite <- map_comp. unfold comp. eapply translate_pexprs_types. exact h. - * revert vs h. + - revert vs h. induction es; intros. - ** inversion h. - constructor. - ** inversion h as [H1]. - jbind H1 x Hx. - jbind H1 y Hy. - noconf H1. - constructor. - *** eapply translate_pexpr_correct. - 1: eassumption. - easy. - *** simpl. eapply IHes. - 1: assumption. + + inversion h. + constructor. + + inversion h as [H1]. + jbind H1 x Hx. + jbind H1 y Hy. + noconf H1. + constructor. + * eapply translate_pexpr_correct. + all: eassumption. + * simpl. eapply IHes. + assumption. Qed. Corollary translate_pexpr_correct_cast : @@ -2613,7 +2615,9 @@ Proof. Qed. Lemma injective_nat_of_pos : - forall p1 p2, nat_of_pos p1 = nat_of_pos p2 -> p1 = p2. + ∀ p1 p2, + nat_of_pos p1 = nat_of_pos p2 → + p1 = p2. Proof. intros p1. induction p1 as [p1 ih | p1 ih |]; intros. - destruct p2. @@ -2817,9 +2821,11 @@ Proof. auto. Qed. -Lemma nat_of_pos_pos : forall p, (0 < nat_of_pos p)%coq_nat. +Lemma nat_of_pos_pos : + ∀ p, (0 < nat_of_pos p)%coq_nat. Proof. - intros. pose proof nat_of_pos_nonzero p. micromega.Lia.lia. + intros p. + pose proof (nat_of_pos_nonzero p). micromega.Lia.lia. Qed. Lemma injective_nat_of_fun_ident2 : @@ -2884,7 +2890,9 @@ Proof. Qed. Lemma injective_translate_var2 : - forall fn gn v1 v2, fn != gn -> translate_var fn v1 != translate_var gn v2. + ∀ fn gn v1 v2, + fn != gn → + translate_var fn v1 != translate_var gn v2. Proof. intros. apply /eqP => contra. @@ -2892,9 +2900,9 @@ Proof. noconf contra. unfold nat_of_fun_var in H1. apply coprime_mul_inj in H1 as [e1 e2]. - 2,3,4,5: apply coprime_nat_of_stype_nat_of_fun_ident. + 2-5: apply coprime_nat_of_stype_nat_of_fun_ident. apply injective_nat_of_fun_ident2 in e2 as [fn_gn _]. - move: H => /eqP; easy. + move: H => /eqP. easy. Qed. Lemma translate_write_correct : @@ -3112,8 +3120,11 @@ Proof. Qed. Lemma translate_write_vars_cons fn l ls v vs : - translate_write_vars fn (l :: ls) (v :: vs) = (translate_write_var fn l v ;; translate_write_vars fn ls vs). -Proof. reflexivity. Qed. + translate_write_vars fn (l :: ls) (v :: vs) = + (translate_write_var fn l v ;; translate_write_vars fn ls vs). +Proof. + reflexivity. +Qed. Lemma translate_write_vars_correct fn s1 ls vs s2 : write_vars ls vs s1 = ok s2 → @@ -3165,15 +3176,18 @@ Definition fdefs := Definition tchlist := [choiceType of seq typed_chElement]. (* The type of translated function "calls" *) -Definition trfun := tchlist → raw_code tchlist. +Definition trfun := + tchlist → raw_code tchlist. -Definition translate_call_body (fn : funname) (tr_f_body : raw_code 'unit) - : trfun. +Definition translate_call_body (fn : funname) (tr_f_body : raw_code 'unit) : + trfun. Proof using P asm_op asmop pd. (* sem_call *) - refine (λ vargs', match (get_fundef (p_funcs P) fn) with - | Some f => _ - | None => ret [::] end). + refine (λ vargs', + match (get_fundef (p_funcs P) fn) with + | Some f => _ + | None => ret [::] end + ). pose (trunc_list (f_tyin f) vargs') as vargs. apply (bind (translate_write_vars fn (f_params f) vargs)) => _. (* Perform the function body. *) @@ -3513,9 +3527,10 @@ Definition handled_program (P : uprog) := List.forallb handled_fundecl P.(p_funcs). Fact sem_call_get_some {P m1 gn vargs m2 vres} : - (sem_call P m1 gn vargs m2 vres - → ∃ f, get_fundef (p_funcs P) gn = Some f ). -Proof. intros H. inversion H. exists f. easy. + sem_call P m1 gn vargs m2 vres → + ∃ f, get_fundef (p_funcs P) gn = Some f. +Proof. + intros H. inversion H. eexists. eassumption. Qed. Definition get_translated_fun P fn : trfun := @@ -3549,8 +3564,9 @@ Definition Pfun (P : uprog) (fn : funname) m va m' vr := ⦃ rel_mem m' ⦄. Theorem translate_prog_correct P m vargs m' vres : - ∀ fn, sem.sem_call P m fn vargs m' vres → - Pfun P fn m vargs m' vres. + ∀ fn, + sem.sem_call P m fn vargs m' vres → + Pfun P fn m vargs m' vres. Proof. intros fn H hP. set (Pfun := λ (m : mem) (fn : funname) (va : seq value) (m' : mem) (vr : seq value), @@ -3559,23 +3575,26 @@ Proof. set (SP := (translate_prog' P).1). set (Pi_r := λ (s1 : estate) (i : instr_r) (s2 : estate), - ∀ fn, handled_instr_r i → - ⊢ ⦃ rel_estate s1 fn ⦄ - translate_instr_r P SP fn i ⇓ tt - ⦃ rel_estate s2 fn ⦄ + ∀ fn, + handled_instr_r i → + ⊢ ⦃ rel_estate s1 fn ⦄ + translate_instr_r P SP fn i ⇓ tt + ⦃ rel_estate s2 fn ⦄ ). set (Pi := λ s1 i s2, Pi_r s1 (instr_d i) s2). set (Pc := λ (s1 : estate) (c : cmd) (s2 : estate), - ∀ fn, handled_cmd c → - ⊢ ⦃ rel_estate s1 fn ⦄ translate_cmd P SP fn c ⇓ tt ⦃ rel_estate s2 fn ⦄ + ∀ fn, + handled_cmd c → + ⊢ ⦃ rel_estate s1 fn ⦄ translate_cmd P SP fn c ⇓ tt ⦃ rel_estate s2 fn ⦄ ). set (Pfor := λ (v : var_i) (ws : seq Z) (s1 : estate) (c : cmd) (s2 : estate), - ∀ fn, handled_cmd c → - ⊢ ⦃ rel_estate s1 fn ⦄ - translate_for fn v ws (translate_cmd P SP fn c) ⇓ tt - ⦃ rel_estate s2 fn ⦄ + ∀ fn, + handled_cmd c → + ⊢ ⦃ rel_estate s1 fn ⦄ + translate_for fn v ws (translate_cmd P SP fn c) ⇓ tt + ⦃ rel_estate s2 fn ⦄ ). unshelve eapply (@sem_call_Ind _ _ _ _ Pc Pi_r Pi Pfor Pfun _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H). - (* nil *) @@ -3608,7 +3627,8 @@ Proof. jbind ho vs hv. jbind hv vs' hv'. eapply u_bind. - + eapply bind_list_pexpr_correct. 2: eassumption. easy. + + eapply bind_list_pexpr_correct. 2: eassumption. + easy. + erewrite translate_exec_sopn_correct by eassumption. apply translate_write_lvals_correct. assumption. From e4270b0f35622deb777074083c47a9be9802fb22 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Wed, 8 Jun 2022 15:56:21 +0200 Subject: [PATCH 252/383] Added sum types --- theories/Crypt/choice_type.v | 100 +++++++++++++++++++++-- theories/Crypt/package/pkg_heap.v | 1 + theories/Crypt/package/pkg_interpreter.v | 24 ++++++ 3 files changed, 119 insertions(+), 6 deletions(-) diff --git a/theories/Crypt/choice_type.v b/theories/Crypt/choice_type.v index 721c4249..f36484d4 100644 --- a/theories/Crypt/choice_type.v +++ b/theories/Crypt/choice_type.v @@ -52,7 +52,7 @@ Inductive choice_type := | chFin (n : positive) | chWord (nbits : wsize) | chList (A : choice_type) -. +| chSum (A B : choice_type). Derive NoConfusion NoConfusionHom for choice_type. @@ -71,6 +71,7 @@ Fixpoint chElement_ordType (U : choice_type) : ordType := | chFin n => [ordType of ordinal n.(pos) ] | chWord nbits => word_ordType nbits | chList U => seq_ordType (chElement_ordType U) + | chSum U1 U2 => sum_ordType (chElement_ordType U1) (chElement_ordType U2) end. Fixpoint chElement (U : choice_type) : choiceType := @@ -85,6 +86,7 @@ Fixpoint chElement (U : choice_type) : choiceType := | chFin n => [choiceType of ordinal n.(pos) ] | chWord nbits => word_choiceType nbits | chList U => seq_choiceType (chElement U) + | chSum U1 U2 => sum_choiceType (chElement U1) (chElement U2) end. Coercion chElement : choice_type >-> choiceType. @@ -102,6 +104,7 @@ Coercion chElement : choice_type >-> choiceType. | chFin n => _ | chWord nbits => word0 | chList A => [::] + | chSum A B => inl (chCanonical A) (* TODO: better default *) end. Next Obligation. eapply fmap_of_fmap. apply emptym. @@ -136,6 +139,7 @@ Section choice_typeTypes. | chFin n, chFin n' => n == n' | chWord nbits, chWord nbits' => nbits == nbits' | chList a, chList b => choice_type_test a b + | chSum a b, chSum a' b' => choice_type_test a a' && choice_type_test b b' | _ , _ => false end. @@ -145,9 +149,9 @@ Section choice_typeTypes. Lemma choice_type_eqP : Equality.axiom choice_type_eq. Proof. move=> x y. - induction x as [ | | | | x1 ih1 x2 ih2 | x1 ih1 x2 ih2 | x1 ih1 | x1 | x1 | x1 ih1 ] + induction x as [ | | | | x1 ih1 x2 ih2 | x1 ih1 x2 ih2 | x1 ih1 | x1 | x1 | x1 ih1 | x1 ih1 x2 ih2 ] in y |- *. - all: destruct y as [ | | | | y1 y2 | y1 y2 | y1 | y1 | y1 | y1 ]. + all: destruct y as [ | | | | y1 y2 | y1 y2 | y1 | y1 | y1 | y1 | y1 y2 ]. all: simpl. all: try solve [ right ; discriminate ]. all: try solve [ left ; reflexivity ]. @@ -183,6 +187,12 @@ Section choice_typeTypes. all: subst. + left. reflexivity. + right. congruence. + (* chSum *) + - destruct (ih1 y1), (ih2 y2). + all: simpl. + all: subst. + all: try solve [right ; congruence]. + left. reflexivity. Qed. Lemma choice_type_refl : @@ -267,6 +277,20 @@ Section choice_typeTypes. | chList _, chFin _ => false | chList _, chWord _ => false | chList u, chList w => choice_type_lt u w + | chList _, _ => true + | chSum _ _, chUnit => false + | chSum _ _, chBool => false + | chSum _ _, chNat => false + | chSum _ _, chInt => false + | chSum _ _, chProd _ _ => false + | chSum _ _, chMap _ _ => false + | chSum _ _, chOption _ => false + | chSum _ _, chFin _ => false + | chSum _ _, chWord _ => false + | chSum _ _, chList _ => false + | chSum u1 u2, chSum w1 w2 => + (choice_type_lt u1 w1) || + (choice_type_test u1 w1 && choice_type_lt u2 w2) end. Definition choice_type_leq (t1 t2 : choice_type) := @@ -275,7 +299,7 @@ Section choice_typeTypes. Lemma choice_type_lt_transitive : transitive (T:=choice_type) choice_type_lt. Proof. intros v u w h1 h2. - induction u as [ | | | | u1 ih1 u2 ih2 | u1 ih1 u2 ih2 | u ih | u | u | u ih ] + induction u as [ | | | | u1 ih1 u2 ih2 | u1 ih1 u2 ih2 | u ih | u | u | u ih | u1 ih1 u2 ih2 ] in v, w, h1, h2 |- *. (* chUnit *) - destruct w. all: try auto. @@ -341,13 +365,29 @@ Section choice_typeTypes. all: destruct w. all: try reflexivity. all: try discriminate. simpl in *. eapply ih. all: eauto. + (* chSum *) + - destruct v. all: try discriminate. + all: destruct w. all: try discriminate. all: try reflexivity. + simpl in *. + move: h1 => /orP h1. + move: h2 => /orP h2. + apply/orP. + destruct h1 as [h1|h1], h2 as [h2|h2]. + + left. eapply ih1. all: eauto. + + left. move: h2 => /andP [/eqP e h2]. subst. auto. + + left. move: h1 => /andP [/eqP e h1]. subst. auto. + + right. move: h1 => /andP [/eqP e1 h1]. + move: h2 => /andP [/eqP e2 h2]. + apply/andP. subst. split. + * apply/eqP. reflexivity. + * eapply ih2. all: eauto. Qed. Lemma choice_type_lt_areflexive : ∀ x, ~~ choice_type_lt x x. Proof. intros x. - induction x as [ | | | | x1 ih1 x2 ih2 | x1 ih1 x2 ih2 | x ih | x | x | x ih ] in |- *. + induction x as [ | | | | x1 ih1 x2 ih2 | x1 ih1 x2 ih2 | x ih | x | x | x ih | x1 ih1 x2 ih2] in |- *. all: intuition; simpl. - simpl. apply/norP. split. @@ -362,6 +402,11 @@ Section choice_typeTypes. - rewrite ltnn. auto. - rewrite cmp_nlt_le. apply cmp_le_refl. + - simpl. + apply/norP. split. + + apply ih1. + + apply/nandP. + right. apply ih2. Qed. Lemma choice_type_lt_total_holds : @@ -369,7 +414,7 @@ Section choice_typeTypes. ~~ (choice_type_test x y) ==> (choice_type_lt x y || choice_type_lt y x). Proof. intros x y. - induction x as [ | | | | x1 ih1 x2 ih2| x1 ih1 x2 ih2| x ih| x | x | x ih ] + induction x as [ | | | | x1 ih1 x2 ih2| x1 ih1 x2 ih2| x ih| x | x | x ih | x1 ih1 x2 ih2] in y |- *. all: try solve [ destruct y ; intuition ; reflexivity ]. (* chProd *) @@ -460,6 +505,42 @@ Section choice_typeTypes. + by move: E H => /cmp_eq -> /negP. + left. by apply /eqP. + right. unfold cmp_lt. rewrite cmp_sym. by move: E => ->. + (* chSum *) + - destruct y. all: try (intuition; reflexivity). + cbn. + specialize (ih1 y1). specialize (ih2 y2). + apply/implyP. + move /nandP => H. + apply/orP. + destruct (choice_type_test x1 y1) eqn:Heq. + + destruct H. 1: discriminate. + move: ih2. move /implyP => ih2. + specialize (ih2 H). + move: ih2. move /orP => ih2. + destruct ih2. + * left. apply/orP. right. apply/andP. split. + all: intuition auto. + * right. apply/orP. right. apply/andP. intuition. + move: Heq. move /eqP => Heq. rewrite Heq. apply/eqP. reflexivity. + + destruct H. + * move: ih1. move /implyP => ih1. + specialize (ih1 H). + move: ih1. move /orP => ih1. + destruct ih1. + -- left. apply/orP. left. assumption. + -- right. apply/orP. left. assumption. + * move: ih2. move /implyP => ih2. + specialize (ih2 H). + move: ih2. move /orP => ih2. + destruct ih2. + --- simpl in ih1. move: ih1. move /orP => ih1. + destruct ih1. + +++ left. apply/orP. left. assumption. + +++ right. apply/orP. left. assumption. + --- simpl in ih1. move: ih1. move /orP => ih1. + destruct ih1. + +++ left. apply/orP. left. assumption. + +++ right. apply/orP. left. assumption. Qed. Lemma choice_type_lt_asymmetric : @@ -566,6 +647,7 @@ Section choice_typeTypes. | chFin n => GenTree.Node 4 [:: GenTree.Leaf (pos n)] | chWord n => GenTree.Node 5 [:: GenTree.Leaf (wsize_log2 n)] | chList u => GenTree.Node 6 [:: encode u] + | chSum l r => GenTree.Node 7 [:: encode l ; encode r] end. Fixpoint decode (t : GenTree.tree nat) : option choice_type := @@ -596,6 +678,11 @@ Section choice_typeTypes. | Some l => Some (chList l) | _ => None end + | GenTree.Node 7 [:: l ; r] => + match decode l, decode r with + | Some l, Some r => Some (chSum l r) + | _, _ => None + end | _ => None end. @@ -614,6 +701,7 @@ Section choice_typeTypes. - repeat f_equal. unfold wsizes. destruct nbits; reflexivity. - rewrite IHt. reflexivity. + - rewrite IHt1. rewrite IHt2. reflexivity. Qed. Definition choice_type_choiceMixin := PcanChoiceMixin codeK. diff --git a/theories/Crypt/package/pkg_heap.v b/theories/Crypt/package/pkg_heap.v index ed5b5d94..ecec943c 100644 --- a/theories/Crypt/package/pkg_heap.v +++ b/theories/Crypt/package/pkg_heap.v @@ -68,6 +68,7 @@ Proof. - exact (fintype.Ordinal n.(cond_pos)). - exact word0. - exact [::]. + - exact (inl IHa1). Defined. Definition heap := { h : raw_heap | valid_heap h }. diff --git a/theories/Crypt/package/pkg_interpreter.v b/theories/Crypt/package/pkg_interpreter.v index f3e33624..ec031639 100644 --- a/theories/Crypt/package/pkg_interpreter.v +++ b/theories/Crypt/package/pkg_interpreter.v @@ -41,12 +41,15 @@ Section Interpreter. nat_ch_aux (NSProd a b) (l1 × l2) (Some v1, Some v2) := Some (v1, v2) ; nat_ch_aux (NSProd a b) (l1 × l2) _ := None ; } ; + nat_ch_aux (NSNat n) 'word u := Some _ ; nat_ch_aux _ _ := None. Proof. - eapply @Ordinal. instantiate (1 := n %% n'). apply ltn_pmod. apply cond_pos0. + - apply wrepr. + apply (BinInt.Z.of_nat n). Defined. Definition nat_ch (x : option NatState) (l : choice_type) : option (Value l) := @@ -71,6 +74,7 @@ Section Interpreter. | _ => None end ; ch_nat 'option l None := Some (NSOption None) ; + ch_nat 'word u x := Some (NSNat (BinInt.Z.to_nat (word.wunsigned x))) ; ch_nat _ _ := None. Lemma ch_nat_ch l v: @@ -97,6 +101,13 @@ Section Interpreter. rewrite modn_small. 2: assumption. done. + - simp ch_nat. simpl. simp nat_ch_aux. + f_equal. + unfold nat_ch_aux_obligation_2. + rewrite @Znat.Z2Nat.id. + + rewrite wrepr_unsigned. + reflexivity. + + apply (@wunsigned_range u). Qed. Definition new_state @@ -156,6 +167,19 @@ Section Interpreter. | Some (seed', x) => Some (seed', [:: x]) | _ => None end + | chSum A B => + let '(seed', b) := ((seed + 1)%nat, Nat.even seed) in + if b + then + match sampler A seed' with + | Some (seed'' , x) => Some (seed'', inl x) + | _ => None + end + else + match sampler B seed' with + | Some (seed'' , y) => Some (seed'', inr y) + | _ => None + end end. Next Obligation. eapply Ordinal. From 9cda9f99dcce71dc4652b8163123e5f895b2df5a Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Tue, 28 Jun 2022 13:00:43 +0200 Subject: [PATCH 253/383] Added auto or eauto to intuition --- theories/Crypt/choice_type.v | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/theories/Crypt/choice_type.v b/theories/Crypt/choice_type.v index f36484d4..39c97eb1 100644 --- a/theories/Crypt/choice_type.v +++ b/theories/Crypt/choice_type.v @@ -104,7 +104,7 @@ Coercion chElement : choice_type >-> choiceType. | chFin n => _ | chWord nbits => word0 | chList A => [::] - | chSum A B => inl (chCanonical A) (* TODO: better default *) + | chSum A B => inl (chCanonical A) end. Next Obligation. eapply fmap_of_fmap. apply emptym. @@ -388,7 +388,7 @@ Section choice_typeTypes. Proof. intros x. induction x as [ | | | | x1 ih1 x2 ih2 | x1 ih1 x2 ih2 | x ih | x | x | x ih | x1 ih1 x2 ih2] in |- *. - all: intuition; simpl. + all: intuition auto; simpl. - simpl. apply/norP. split. + apply ih1. @@ -416,9 +416,9 @@ Section choice_typeTypes. intros x y. induction x as [ | | | | x1 ih1 x2 ih2| x1 ih1 x2 ih2| x ih| x | x | x ih | x1 ih1 x2 ih2] in y |- *. - all: try solve [ destruct y ; intuition ; reflexivity ]. + all: try solve [ destruct y ; intuition eauto ; reflexivity ]. (* chProd *) - - destruct y. all: try (intuition; reflexivity). + - destruct y. all: try (intuition auto; reflexivity). cbn. specialize (ih1 y1). specialize (ih2 y2). apply/implyP. @@ -432,7 +432,7 @@ Section choice_typeTypes. destruct ih2. * left. apply/orP. right. apply/andP. split. all: intuition auto. - * right. apply/orP. right. apply/andP. intuition. + * right. apply/orP. right. apply/andP. intuition auto. move: Heq. move /eqP => Heq. rewrite Heq. apply/eqP. reflexivity. + destruct H. * move: ih1. move /implyP => ih1. @@ -454,7 +454,7 @@ Section choice_typeTypes. +++ left. apply/orP. left. assumption. +++ right. apply/orP. left. assumption. (* chMap *) - - destruct y. all: try (intuition; reflexivity). + - destruct y. all: try (intuition auto; reflexivity). cbn. specialize (ih1 y1). specialize (ih2 y2). apply/implyP. @@ -468,7 +468,7 @@ Section choice_typeTypes. destruct ih2. * left. apply/orP. right. apply/andP. split. all: intuition auto. - * right. apply/orP. right. apply/andP. intuition. + * right. apply/orP. right. apply/andP. intuition auto. move: Heq. move /eqP => Heq. rewrite Heq. apply/eqP. reflexivity. + destruct H. * move: ih1. move /implyP => ih1. @@ -490,13 +490,13 @@ Section choice_typeTypes. +++ left. apply/orP. left. assumption. +++ right. apply/orP. left. assumption. (* chFin *) - - destruct y. all: try (intuition; reflexivity). + - destruct y. all: try (intuition auto; reflexivity). unfold choice_type_lt. unfold choice_type_test. rewrite -neq_ltn. apply /implyP. auto. (* chWord *) - - destruct y. all: try (intuition; reflexivity). + - destruct y. all: try (intuition auto; reflexivity). unfold choice_type_lt. unfold choice_type_test. apply /implyP. @@ -506,7 +506,7 @@ Section choice_typeTypes. + left. by apply /eqP. + right. unfold cmp_lt. rewrite cmp_sym. by move: E => ->. (* chSum *) - - destruct y. all: try (intuition; reflexivity). + - destruct y. all: try (intuition auto; reflexivity). cbn. specialize (ih1 y1). specialize (ih2 y2). apply/implyP. @@ -520,7 +520,7 @@ Section choice_typeTypes. destruct ih2. * left. apply/orP. right. apply/andP. split. all: intuition auto. - * right. apply/orP. right. apply/andP. intuition. + * right. apply/orP. right. apply/andP. intuition auto. move: Heq. move /eqP => Heq. rewrite Heq. apply/eqP. reflexivity. + destruct H. * move: ih1. move /implyP => ih1. @@ -550,7 +550,7 @@ Section choice_typeTypes. intros x y. apply /implyP. move => H. destruct (~~ choice_type_lt y x) eqn:Heq. - - intuition. + - intuition auto. - move: Heq. move /negP /negP => Heq. pose (choice_type_lt_areflexive x) as Harefl. move: Harefl. apply /implyP. rewrite implyNb. @@ -578,14 +578,14 @@ Section choice_typeTypes. Proof. intros x y. destruct (choice_type_eq x y) eqn:H. - - intuition. + - apply/orP. intuition auto. - apply/orP. left. unfold choice_type_eq in H. pose (choice_type_lt_total_holds x y). move: i. move /implyP => i. apply i. apply/negP. - intuition. move: H0. rewrite H. intuition. + intuition auto. move: H0. rewrite H. intuition auto. Qed. Lemma choice_type_leqP : Ord.axioms choice_type_leq. From be91124db082e998f493854fedcb17e5e358ecb8 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Tue, 28 Jun 2022 13:25:27 +0200 Subject: [PATCH 254/383] Added sum / coproduct notation --- theories/Crypt/package/pkg_notation.v | 2 ++ 1 file changed, 2 insertions(+) diff --git a/theories/Crypt/package/pkg_notation.v b/theories/Crypt/package/pkg_notation.v index 44584245..9d565839 100644 --- a/theories/Crypt/package/pkg_notation.v +++ b/theories/Crypt/package/pkg_notation.v @@ -136,6 +136,7 @@ Module PackageNotation. (in custom pack_type at level 2, format "{map x → y }"). Notation " x × y " := (chProd x y) (in custom pack_type at level 2). + Notation " x ∐ y " := (chSum x y) (in custom pack_type at level 2). Notation "( x )" := x (in custom pack_type, x at level 2). @@ -157,6 +158,7 @@ Module PackageNotation. (at level 80, format "{map x → y }") : package_scope. *) Notation " x × y " := (chProd x y) (at level 80) : package_scope. + Notation " x ∐ y " := (chSum x y) (at level 80) : package_scope. Notation "[ 'interface' ]" := (fset [::]) From e4aed6083e7b6d6e262c18714a32eb22fb172bf5 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Tue, 28 Jun 2022 12:50:37 +0200 Subject: [PATCH 255/383] prefix order and disjointness --- theories/Jasmin/jasmin_translate.v | 346 +++++++++++++++++++++++++++++ 1 file changed, 346 insertions(+) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index d0770af2..6eec330d 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -32,6 +32,352 @@ Derive NoConfusion for wsize. Derive NoConfusion for CoqWord.word.word. Derive EqDec for wsize. +Local Open Scope positive_scope. + +Notation p_id := BinNums.positive. + +Lemma nat_of_pos_nonzero : + ∀ p, + nat_of_pos p ≠ 0%nat. +Proof. + intros p. induction p as [p ih | p ih |]. + - simpl. micromega.Lia.lia. + - simpl. rewrite NatTrec.doubleE. + move => /eqP. rewrite double_eq0. move /eqP. assumption. + - simpl. micromega.Lia.lia. +Qed. + +Lemma injective_nat_of_pos : + forall p1 p2, nat_of_pos p1 = nat_of_pos p2 -> p1 = p2. +Proof. + intros p1. induction p1 as [p1 ih | p1 ih |]; intros. + - destruct p2. + + inversion H. + f_equal. apply ih. + apply double_inj. + rewrite -!NatTrec.doubleE. + assumption. + + inversion H. + rewrite !NatTrec.doubleE in H1. + apply f_equal with (f:=odd) in H1. + simpl in H1. + rewrite !odd_double in H1. + easy. + + inversion H. + move: H1 => /eqP. + rewrite NatTrec.doubleE double_eq0 => /eqP H1. + apply nat_of_pos_nonzero in H1 as []. + - destruct p2. + + inversion H. + rewrite !NatTrec.doubleE in H1. + apply f_equal with (f:=odd) in H1. + simpl in H1. + rewrite !odd_double in H1. + easy. + + inversion H. + f_equal. apply ih. + apply double_inj. + rewrite -!NatTrec.doubleE. + assumption. + + inversion H. + rewrite !NatTrec.doubleE in H1. + apply f_equal with (f:=odd) in H1. + simpl in H1. + rewrite !odd_double in H1. + easy. + - destruct p2. + + inversion H. + move: H1 => /eqP. + rewrite eq_sym NatTrec.doubleE double_eq0 => /eqP H1. + apply nat_of_pos_nonzero in H1 as []. + + inversion H. + rewrite !NatTrec.doubleE in H1. + apply f_equal with (f:=odd) in H1. + simpl in H1. + rewrite !odd_double in H1. + easy. + + reflexivity. +Qed. + +Definition nat_of_p_id : p_id -> nat := nat_of_pos. +Definition nat_of_p_id_nonzero : forall p, nat_of_p_id p <> 0%nat := nat_of_pos_nonzero. +Definition nat_of_p_id_injective : injective nat_of_p_id := injective_nat_of_pos. + +Inductive preceq : p_id -> p_id -> Prop := +| preceqEq : forall i, preceq i i +| preceqI : forall i1 i2, preceq i1 i2 -> preceq i1 i2~1 +| preceqO : forall i1 i2, preceq i1 i2 -> preceq i1 i2~0. +Infix "⪯" := preceq (at level 70). + +Definition prec i1 i2 := i1 ⪯ i2 /\ i1 <> i2. +Infix "≺" := prec (at level 70). + +Instance preceq_trans : Transitive preceq. +Proof. + intros i1 i2 i3 hi1 hi2. + induction hi2. + - assumption. + - constructor. + apply IHhi2. + assumption. + - constructor. + apply IHhi2. + assumption. +Qed. + +Instance preceq_refl : Reflexive preceq. +Proof. + intros i. induction i; constructor; assumption. +Qed. + +Lemma preceq_size : + forall i j, i ⪯ j -> Pos.size i <= Pos.size j. +Proof. + intros i j h. + induction h. + - reflexivity. + - simpl; micromega.Lia.lia. + - simpl; micromega.Lia.lia. +Qed. + +Lemma preceq_I : + forall i, i ⪯ i~1. +Proof. + intros. constructor. reflexivity. +Qed. + +Lemma preceq_O : + forall i, i ⪯ i~0. +Proof. + intros. constructor. reflexivity. +Qed. + +Lemma xO_neq : + forall i, i~0 <> i. +Proof. + induction i; congruence. +Qed. + +Lemma xI_neq : + forall i, i~1 <> i. +Proof. + induction i; congruence. +Qed. + +Lemma precneq_O : + forall i, ~ i~0 ⪯ i. +Proof. + intros i contra. + apply preceq_size in contra. + simpl in contra. + micromega.Lia.lia. +Qed. + +Lemma precneq_I : + forall i, ~ i~1 ⪯ i. +Proof. + intros i contra. + apply preceq_size in contra. + simpl in contra. + micromega.Lia.lia. +Qed. + +Lemma size_1 : + forall i, Pos.size i = 1 -> i = 1. +Proof. + intros i h. + induction i. + - simpl in *. + micromega.Lia.lia. + - simpl in *. + micromega.Lia.lia. + - reflexivity. +Qed. + +Lemma preceq_size_eq_eq : + forall i j, Pos.size i = Pos.size j -> i ⪯ j -> i = j. +Proof. + intros i j; revert i; induction j; intros i hsize hprec. + - simpl in *. + inversion hprec; subst. + + reflexivity. + + destruct i. + * simpl in *. + apply Pos.succ_inj in hsize. + apply IHj in hsize. + 1: subst; auto. + etransitivity. + 1: eapply preceq_I. + assumption. + * simpl in *. + apply Pos.succ_inj in hsize. + apply IHj in hsize. + 1: subst; auto. + 1: apply precneq_O in H1; easy. + etransitivity. + 1: eapply preceq_O. + assumption. + * simpl in hsize. + micromega.Lia.lia. + - simpl in *. + inversion hprec; subst. + + reflexivity. + + destruct i. + * simpl in *. + apply Pos.succ_inj in hsize. + apply IHj in hsize. + 1: subst; auto. + 1: apply precneq_I in H1; easy. + etransitivity. + 1: eapply preceq_I. + assumption. + * simpl in *. + apply Pos.succ_inj in hsize. + apply IHj in hsize. + 1: subst; auto. + etransitivity. + 1: eapply preceq_O. + assumption. + * simpl in hsize. + micromega.Lia.lia. + - simpl in hsize. + apply size_1. + assumption. +Qed. + +Instance preceq_antisym : Antisymmetric _ _ preceq. +Proof. + intros i1 i2 h1 h2. + apply preceq_size in h1 as hsize1. + apply preceq_size in h2 as hsize2. + apply preceq_size_eq_eq. + 1: micromega.Lia.lia. + assumption. +Qed. + +Lemma preceq_prefix : forall i1 i2 i3, i1 ⪯ i3 -> i2 ⪯ i3 -> i1 ⪯ i2 \/ i2 ⪯ i1. +Proof. + intros i1 i2 i3. revert i1 i2. + induction i3; intros. + - inversion H; subst. + + right. assumption. + + inversion H0; subst. + * left; assumption. + * apply IHi3; assumption. + - inversion H; subst. + + right. assumption. + + inversion H0; subst. + * left; assumption. + * apply IHi3; assumption. + - inversion H; subst. + inversion H0; subst. + left; constructor. +Qed. + +Definition fresh_id i := + (i~0, i~1). + +Lemma prec_neq p fp : p ≺ fp -> p <> fp. +Proof. unfold prec. easy. Qed. + +Instance prec_trans : Transitive prec. +Proof. + intros i1 i2 i3. + intros [hpre1 hneq1] [hpre2 hneq2]. + split. + - etransitivity; eauto. + - intro contra; subst. + apply hneq2. + apply antisymmetry; assumption. +Qed. + +Lemma fresh1 i : i ≺ (fresh_id i).1. +Proof. + simpl; split. + - apply preceq_O. + - apply nesym. apply xO_neq. +Qed. + +Lemma fresh2 i : i ≺ (fresh_id i).2. +Proof. + simpl; split. + - apply preceq_I. + - apply nesym. apply xI_neq. +Qed. + +Lemma preceq_prec_trans : forall p1 p2 p3, p1 ⪯ p2 -> p2 ≺ p3 -> p1 ≺ p3. +Proof. + intros p1 p2 p3 h1 [h2 h3]. + split. + - etransitivity; eauto. + - intros contra; subst. + apply h3. apply antisymmetry; assumption. +Qed. + +Lemma prec_preceq_trans : forall p1 p2 p3, p1 ≺ p2 -> p2 ⪯ p3 -> p1 ≺ p3. +Proof. + intros p1 p2 p3 [h1 h2] h3. + split. + - etransitivity; eauto. + - intros contra; subst. + apply h2. apply antisymmetry; assumption. +Qed. + +Lemma fresh1_weak s_id : s_id ⪯ s_id~0. +Proof. apply fresh1. Qed. + +Lemma fresh2_weak s_id : s_id ⪯ s_id~1. +Proof. apply fresh2. Qed. + +Definition disj i1 i2 := + forall i3, i1 ⪯ i3 -> ~ i2 ⪯ i3. + +Instance disj_sym : Symmetric disj. +Proof. + intros i1 i2 hi1 i3 hi2. + intros contra. + apply hi1 in contra. + contradiction. +Qed. + +Lemma fresh_disj i : + disj (fresh_id i).1 (fresh_id i).2. +Proof. + intros i' h contra. + simpl in *. + pose proof preceq_prefix i~0 i~1 i' h contra. + destruct H. + - inversion H; subst. + eapply precneq_O; eassumption. + - inversion H; subst. + eapply precneq_I; eassumption. +Qed. + +Lemma disj_prec_l : forall id1 id2 id3, id1 ⪯ id2 -> disj id1 id3 -> disj id2 id3. +Proof. + intros id1 id2 id3 hpre hdisj. + intros id' hprec. + apply hdisj. + etransitivity; eauto. +Qed. + +Lemma disj_prec_r : forall id1 id2 id3, id1 ⪯ id2 -> disj id3 id1 -> disj id3 id2. +Proof. + intros id1 id2 id3 hpre hdisj. + apply disj_sym. + eapply disj_prec_l; eauto. + apply disj_sym; assumption. +Qed. + +Lemma disj_prec : forall id1 id2 id3 id4, id1 ⪯ id2 -> id3 ⪯ id4 -> disj id1 id3 -> disj id2 id4. +Proof. + intros. + eapply disj_prec_l; eauto. + eapply disj_prec_r; eauto. +Qed. + +Hint Resolve fresh1 fresh2 valid_prec fresh1_weak fresh2_weak preceq_refl preceq_trans prec_trans : prefix. + (* Unary judgment concluding on evaluation of program *) Definition eval_jdg {A : choiceType} From 01dde496b43bd8b9c317ef48bdd53356c73c5eeb Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Tue, 28 Jun 2022 12:52:00 +0200 Subject: [PATCH 256/383] fix --- theories/Jasmin/jasmin_translate.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 6eec330d..3cb7f42c 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -376,7 +376,7 @@ Proof. eapply disj_prec_r; eauto. Qed. -Hint Resolve fresh1 fresh2 valid_prec fresh1_weak fresh2_weak preceq_refl preceq_trans prec_trans : prefix. +Hint Resolve fresh1 fresh2 fresh1_weak fresh2_weak preceq_refl preceq_trans prec_trans : prefix. (* Unary judgment concluding on evaluation of program *) From 5f1774e99d110f8e7226e3a99773500481d87ee9 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Wed, 29 Jun 2022 13:12:05 +0200 Subject: [PATCH 257/383] new translation --- theories/Jasmin/jasmin_translate.v | 328 +++++++++++++---------------- 1 file changed, 145 insertions(+), 183 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 3cb7f42c..0e03ce49 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -815,21 +815,21 @@ Fixpoint nat_of_ident (id : Ident.ident) : nat := | String a s => 256 * nat_of_ident s + (Ascii.nat_of_ascii a) end. -(* injection *) -Definition nat_of_fun_ident (f : funname) (id : Ident.ident) : nat := - 3^(nat_of_pos f) * 2^(nat_of_ident id). - Definition nat_of_stype t : nat := match t with | sarr len => 5 ^ ((Pos.to_nat len).+1) | _ => 5 ^ 1 end. -Definition nat_of_fun_var (f : funname) (x : var) : nat := - (nat_of_stype x.(vtype) * (nat_of_fun_ident f x.(vname)))%coq_nat. +(* injection *) +Definition nat_of_p_id_ident (p : p_id) (id : Ident.ident) : nat := + 3^(nat_of_p_id p) * 2^(nat_of_ident id). -Definition translate_var (f : funname) (x : var) : Location := - (encode x.(vtype) ; nat_of_fun_var f x). +Definition nat_of_p_id_var (p : p_id) (x : var) : nat := + (nat_of_stype x.(vtype) * (nat_of_p_id_ident p x.(vname)))%coq_nat. + +Definition translate_var (p : p_id) (x : var) : Location := + (encode x.(vtype) ; nat_of_p_id_var p x). #[local] Definition unsupported : typed_code := ('unit ; assert false). @@ -888,13 +888,13 @@ Proof. values.v), all of these functions raise an error on Vundef. *) Defined. -Definition translate_write_var (fn : funname) (x : var_i) (v : typed_chElement) := - let l := translate_var fn (v_var x) in +Definition translate_write_var (p : p_id) (x : var_i) (v : typed_chElement) := + let l := translate_var p (v_var x) in #put l := truncate_el x.(vtype) v.π2 ;; ret tt. -Definition translate_get_var (f : funname) (x : var) : raw_code (encode x.(vtype)) := - x ← get (translate_var f x) ;; ret x. +Definition translate_get_var (p : p_id) (x : var) : raw_code (encode x.(vtype)) := + x ← get (translate_var p x) ;; ret x. (* TW: We can remove it right? *) Fixpoint satisfies_globs (globs : glob_decls) : heap * heap → Prop. @@ -907,9 +907,9 @@ Proof. exact [::]. (* TODO *) Defined. *) -Definition translate_gvar (f : funname) (x : gvar) : raw_code (encode x.(gv).(vtype)) := +Definition translate_gvar (p : p_id) (x : gvar) : raw_code (encode x.(gv).(vtype)) := if is_lvar x - then translate_get_var f x.(gv).(v_var) + then translate_get_var p x.(gv).(v_var) else match get_global gd x.(gv).(v_var) with | Ok v => ret (coerce_to_choice_type _ (translate_value v)) @@ -1306,7 +1306,7 @@ Definition tr_app_sopn_tuple {ts} := tr_app_sopn (chCanonical (encode_tuple ts)) embed_tuple. (* Following sem_pexpr *) -Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code := +Fixpoint translate_pexpr (p : p_id) (e : pexpr) {struct e} : typed_code := match e with | Pconst z => totc 'int (@ret 'int z) (* Why do we need to give 'int twice? *) | Pbool b => totc 'bool (ret b) @@ -1314,28 +1314,28 @@ Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code := (* Parr_init only gets produced by ArrayInit() in jasmin source. *) (* The EC export asserts false on it. *) totc 'array (ret emptym) - | Pvar v => totc _ (translate_gvar fn v) + | Pvar v => totc _ (translate_gvar p v) | Pget aa ws x e => totc ('word ws) ( - arr ← translate_gvar fn x ;; (* Performs the lookup in gd *) + arr ← translate_gvar p x ;; (* Performs the lookup in gd *) let a := coerce_to_choice_type 'array arr in - i ← (truncate_code sint (translate_pexpr fn e)).π2 ;; (* to_int *) + i ← (truncate_code sint (translate_pexpr p e)).π2 ;; (* to_int *) let scale := mk_scale aa ws in ret (chArray_get ws a i scale) ) | Psub aa ws len x e => totc 'array ( - arr ← translate_gvar fn x ;; (* Performs the lookup in gd *) + arr ← translate_gvar p x ;; (* Performs the lookup in gd *) let a := coerce_to_choice_type 'array arr in - i ← (truncate_code sint (translate_pexpr fn e)).π2 ;; (* to_int *) + i ← (truncate_code sint (translate_pexpr p e)).π2 ;; (* to_int *) let scale := mk_scale aa ws in ret (chArray_get_sub ws len a i scale) ) | Pload sz x e => totc ('word sz) ( - w ← translate_get_var fn x ;; + w ← translate_get_var p x ;; let w1 : word _ := truncate_el (sword Uptr) w in - w2 ← (truncate_code (sword Uptr) (translate_pexpr fn e)).π2 ;; + w2 ← (truncate_code (sword Uptr) (translate_pexpr p e)).π2 ;; chRead (w1 + w2)%R sz ) | Papp1 o e => @@ -1343,14 +1343,14 @@ Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code := (* We truncate and call sem_sop1_typed instead of calling sem_sop1 which does the truncation and then calls sem_sop1_typed. *) - x ← (truncate_code (type_of_op1 o).1 (translate_pexpr fn e)).π2 ;; + x ← (truncate_code (type_of_op1 o).1 (translate_pexpr p e)).π2 ;; ret (embed (sem_sop1_typed o (unembed x))) ) | Papp2 o e1 e2 => totc _ ( (* Same here *) - r1 ← (truncate_code (type_of_op2 o).1.1 (translate_pexpr fn e1)).π2 ;; - r2 ← (truncate_code (type_of_op2 o).1.2 (translate_pexpr fn e2)).π2 ;; + r1 ← (truncate_code (type_of_op2 o).1.1 (translate_pexpr p e1)).π2 ;; + r2 ← (truncate_code (type_of_op2 o).1.2 (translate_pexpr p e2)).π2 ;; ret match sem_sop2_typed o (unembed r1) (unembed r2) with | Ok y => embed y | _ => chCanonical _ @@ -1363,15 +1363,15 @@ Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code := how it is done in jasmin. Maybe we should change Papp1/2. *) totc _ ( - vs ← bind_list [seq translate_pexpr fn e | e <- es] ;; + vs ← bind_list [seq translate_pexpr p e | e <- es] ;; ret (tr_app_sopn_single (type_of_opN op).1 (sem_opN_typed op) vs) ) | Pif t eb e1 e2 => totc _ ( - b ← (truncate_code sbool (translate_pexpr fn eb)).π2 ;; (* to_bool *) + b ← (truncate_code sbool (translate_pexpr p eb)).π2 ;; (* to_bool *) if b - then (truncate_code t (translate_pexpr fn e1)).π2 - else (truncate_code t (translate_pexpr fn e2)).π2 + then (truncate_code t (translate_pexpr p e1)).π2 + else (truncate_code t (translate_pexpr p e2)).π2 ) end. @@ -1382,12 +1382,12 @@ Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code := error unless (val = Varr n t). We obtain (n: positive) and (t: array n). *) (* Let (n, t) := gd, s.[x] in *) - pose (x' := translate_gvar fn x). + pose (x' := translate_gvar p x). pose (arr := y ← x'.π2 ;; @ret _ (coerce_to_choice_type 'array y)). (* Evaluate the indexing expression `e` and coerce it to Z. *) (* Let i := sem_pexpr s e >>= to_int in *) - pose (i := coerce_typed_code 'int (translate_pexpr fn e)). + pose (i := coerce_typed_code 'int (translate_pexpr p e)). (* The actual array look-up, where WArray.get aa ws t i = CoreMem.read t a (i * (mk_scale aa ws)) ws @@ -1402,7 +1402,7 @@ Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code := (* | PappN op es => *) (* Let vs := mapM (sem_pexpr s) es in *) (* sem_opN op vs *) - (* pose (vs := map (translate_pexpr fn) l). + (* pose (vs := map (translate_pexpr p) l). pose proof (sem_opN_typed o) as f. simpl in f. *) (* Fixpoint app_sopn T ts : sem_prod ts (exec T) → values → exec T := *) @@ -1416,16 +1416,16 @@ Fixpoint translate_pexpr (fn : funname) (e : pexpr) {struct e} : typed_code := (* pose (vs' := fold (fun x => y ← x ;; unembed y) f vs). *) -Definition translate_write_lval (fn : funname) (l : lval) (v : typed_chElement) +Definition translate_write_lval (p : p_id) (l : lval) (v : typed_chElement) : raw_code 'unit := match l with | Lnone _ ty => ret tt - | Lvar x => translate_write_var fn x v + | Lvar x => translate_write_var p x v | Lmem sz x e => - vx' ← translate_get_var fn x ;; + vx' ← translate_get_var p x ;; let vx : word _ := translate_to_pointer vx' in - ve' ← (translate_pexpr fn e).π2 ;; + ve' ← (translate_pexpr p e).π2 ;; let ve := translate_to_pointer ve' in let p := (vx + ve)%R in (* should we add the size of value, i.e vx + sz * se *) (* Is it from us or them? *) let w := truncate_chWord sz v.π2 in @@ -1433,72 +1433,32 @@ Definition translate_write_lval (fn : funname) (l : lval) (v : typed_chElement) | Laset aa ws x i => (* Let (n,t) := s.[x] in is a notation calling on_arr_varr on get_var *) (* We just cast it since we do not track lengths *) - t' ← translate_get_var fn x ;; + t' ← translate_get_var p x ;; let t := coerce_to_choice_type 'array t' in - i ← (truncate_code sint (translate_pexpr fn i)).π2 ;; (* to_int *) + i ← (truncate_code sint (translate_pexpr p i)).π2 ;; (* to_int *) let v := truncate_chWord ws v.π2 in let t := chArray_set t aa i v in - translate_write_var fn x (totce t) + translate_write_var p x (totce t) | Lasub aa ws len x i => (* Same observation as Laset *) - t ← translate_get_var fn x ;; + t ← translate_get_var p x ;; let t := coerce_to_choice_type 'array t in - i ← (truncate_code sint (translate_pexpr fn i)).π2 ;; (* to_int *) + i ← (truncate_code sint (translate_pexpr p i)).π2 ;; (* to_int *) let t' := truncate_el (sarr (Z.to_pos (arr_size ws len))) v.π2 in let t := chArray_set_sub ws len aa t i t' in - translate_write_var fn x (totce t) + translate_write_var p x (totce t) end. -(* Note c is translated from cmd, in the case ws = [], sem_for does not - guarantee it is well-formed. - Also note, it feels odd to get a var_i when I should translate before calling. - The problem comes from translate_write_var which expects var_i instead of - Location. -*) -Fixpoint translate_for fn (i : var_i) (ws : seq Z) (c : raw_code 'unit) : raw_code 'unit := +(* the argument to c is its (valid) sub id, the return is the resulting (valid) sub id *) +Fixpoint translate_for (v : var_i) (ws : seq Z) (i : p_id) (c : p_id -> p_id * raw_code 'unit) (sid : p_id) : raw_code 'unit := match ws with | [::] => ret tt | w :: ws => - translate_write_var fn i (totce (translate_value w)) ;; - c ;; - translate_for fn i ws c + let (sid', c') := c sid in + translate_write_var i v (totce (translate_value w)) ;; + c' ;; + translate_for v ws i c sid' end. -(* sem_i *) -(* Fixpoint translate_instr_r (fn : funname) (i : instr_r) {struct i} : raw_code 'unit *) -(* with translate_instr (fn : funname) (i : instr) {struct i} : raw_code 'unit. *) -(* Proof. *) -(* (* translate_instr_r *) *) -(* { *) -(* pose proof (translate_cmd := *) -(* (fix translate_cmd (fn : funname) (c : cmd) : raw_code 'unit := *) -(* match c with *) -(* | [::] => ret tt *) -(* | i :: c => translate_instr fn i ;; translate_cmd fn c *) -(* end)). *) - -(* destruct i as [ | | e c1 c2 | | | ]. *) -(* - (* Cassgn *) *) -(* (* l :a=_s p *) *) -(* pose (translate_pexpr fn p) as tr_p. *) -(* pose (truncate_code s tr_p) as tr_p'. *) -(* eapply bind. 1: exact tr_p'.π2. intros. *) -(* exact (translate_write_lval fn l (totce X)). *) -(* - exact (unsupported.π2). (* Copn *) *) -(* - (* Cif e c1 c2 *) *) -(* pose (e' := translate_pexpr fn e). *) -(* pose (c1' := translate_cmd fn c1). *) -(* pose (c2' := translate_cmd fn c2). *) -(* pose (rb := coerce_typed_code 'bool e'). *) -(* exact (b ← rb ;; if b then c1' else c2'). *) -(* - exact (unsupported.π2). (* Cfor *) *) -(* - exact (unsupported.π2). (* Cwhile *) *) -(* - (* Ccall i l f l0 *) *) -(* (* translate arguments *) *) -(* pose (map (translate_pexpr fn) l0) as tr_l0. *) -(* (* "perform" the call via `opr` *) *) -(* (* probably we'd look up the function signature in the current ambient program *) *) - -(* (* write_lvals the result of the call into lvals `l` *) *) (* list_ltuple *) Fixpoint list_lchtuple {ts} : lchtuple ([seq encode t | t <- ts]) → [choiceType of list typed_chElement] := @@ -1546,12 +1506,12 @@ Fixpoint foldr2 {A B R} (f : A → B → R → R) (la : seq A) (lb : seq B) r := end end. -Definition translate_write_lvals fn ls vs := - (* foldl2 (λ c l v, translate_write_lval fn l v ;; c) ls vs (ret tt). *) - foldr2 (λ l v c, translate_write_lval fn l v ;; c) ls vs (ret tt). +Definition translate_write_lvals p ls vs := + (* foldl2 (λ c l v, translate_write_lval p l v ;; c) ls vs (ret tt). *) + foldr2 (λ l v c, translate_write_lval p l v ;; c) ls vs (ret tt). -Definition translate_write_vars fn xs vs := - foldr2 (λ x v c, translate_write_var fn x v ;; c) xs vs (ret tt). +Definition translate_write_vars p xs vs := + foldr2 (λ x v c, translate_write_var p x v ;; c) xs vs (ret tt). Lemma eq_rect_K : ∀ (A : eqType) (x : A) (P : A -> Type) h e, @@ -3516,33 +3476,32 @@ Definition trunc_list := (* The type of translated function *bodies* *) Definition fdefs := - (* ∀ fn fdef, get_fundef (p_funcs P) fn = Some fdef → raw_code 'unit. *) - list (funname * (raw_code 'unit)). + (* ∀ p fdef, get_fundef (p_funcs P) p = Some fdef → raw_code 'unit. *) + list (funname * (p_id -> raw_code 'unit)). Definition tchlist := [choiceType of seq typed_chElement]. (* The type of translated function "calls" *) Definition trfun := - tchlist → raw_code tchlist. + p_id -> tchlist → raw_code tchlist. -Definition translate_call_body (fn : funname) (tr_f_body : raw_code 'unit) : - trfun. +Definition translate_call_body + (fn : funname) (tr_f_body : p_id -> raw_code 'unit) : trfun. Proof using P asm_op asmop pd. (* sem_call *) - refine (λ vargs', - match (get_fundef (p_funcs P) fn) with - | Some f => _ - | None => ret [::] end - ). + refine (λ sid vargs', + match (get_fundef (p_funcs P) fn) with + | Some f => _ + | None => ret [::] end). pose (trunc_list (f_tyin f) vargs') as vargs. - apply (bind (translate_write_vars fn (f_params f) vargs)) => _. + apply (bind (translate_write_vars sid (f_params f) vargs)) => _. (* Perform the function body. *) (* apply (bind (tr_f_body _ _ E)) => _. *) (* pose (tr_f_body _ _ E) as tr_f. *) - apply (bind tr_f_body) => _. + apply (bind (tr_f_body sid)) => _. eapply bind. - (* Look up the results in their locations... *) - exact (bind_list [seq totc _ (translate_get_var fn (v_var x)) + exact (bind_list [seq totc _ (translate_get_var sid (v_var x)) | x <- f_res f]). - intros vres. (* ...and coerce them to the codomain of f. *) @@ -3552,74 +3511,76 @@ Defined. Definition translate_call (fn : funname) (tr_f_body : fdefs) : trfun. Proof using P asm_op asmop pd. - refine (λ vargs, match assoc tr_f_body fn with + refine (λ sid vargs, match assoc tr_f_body fn with | Some tr_f => _ | None => ret [::] end). - exact (translate_call_body fn tr_f vargs). + exact (translate_call_body fn tr_f sid vargs). Defined. Fixpoint translate_instr_r (tr_f_body : fdefs) - (fn : funname) (i : instr_r) {struct i} - : raw_code 'unit + (i : instr_r) (id : p_id) (sid : p_id) {struct i} + : p_id * raw_code 'unit with translate_instr (tr_f_body : fdefs) - (fn : funname) (i : instr) {struct i} : raw_code 'unit := - translate_instr_r tr_f_body fn (instr_d i). + (i : instr) (id : p_id) (sid : p_id) {struct i} : p_id * raw_code 'unit := + translate_instr_r tr_f_body (instr_d i) id sid. Proof using P asm_op asmop pd. pose proof (translate_cmd := - (fix translate_cmd (fn : funname) (c : cmd) : raw_code 'unit := + (fix translate_cmd (tr_f_body : fdefs) (c : cmd) (id : p_id) (sid : p_id) : p_id * raw_code 'unit := match c with - | [::] => ret tt + | [::] => (sid, ret tt) | i :: c => - translate_instr tr_f_body fn i ;; - translate_cmd fn c + let (sid', i') := translate_instr tr_f_body i id sid in + let (sid'', c') := translate_cmd tr_f_body c id sid' in + (sid'', i' ;; c') end ) - ). - - destruct i as [ | ls _ o es | e c1 c2 | i [[d lo] hi] c | | ii xs gn args ]. - - (* Cassgn *) - (* l :a=_s p *) - pose (translate_pexpr (p_globs P) fn p) as tr_p. - eapply bind. 1: exact (tr_p.π2). - intros v. pose (truncate_el s v) as tr_v. - exact (translate_write_lval (p_globs P) fn l (totce tr_v)). - - (* Copn *) - pose (cs := [seq (translate_pexpr (p_globs P) fn e) | e <- es]). - pose (vs := bind_list cs). - eapply bind. 1: exact vs. intros bvs. - pose (out := translate_exec_sopn o bvs). - exact (translate_write_lvals (p_globs P) fn ls out). (* BSH: I'm not sure if the outputs should be truncated? *) - - (* Cif e c1 c2 *) - pose (e' := translate_pexpr (p_globs P) fn e). - pose (c1' := translate_cmd fn c1). - pose (c2' := translate_cmd fn c2). - pose (rb := coerce_typed_code 'bool e'). - exact (b ← rb ;; if b then c1' else c2'). - - (* Cfor i (d, lo, hi) c *) - (* pose (iᵗ := translate_var fn i). *) (* Weird not to do it *) - pose (loᵗ := coerce_typed_code 'int (translate_pexpr (p_globs P) fn lo)). - pose (hiᵗ := coerce_typed_code 'int (translate_pexpr (p_globs P) fn hi)). - pose (cᵗ := translate_cmd fn c). - exact ( - vlo ← loᵗ ;; - vhi ← hiᵗ ;; - translate_for fn i (wrange d vlo vhi) cᵗ - ). - - exact (unsupported.π2). (* Cwhile *) - - (* Ccall ii xs f args *) - rename fn into fn_ambient. - (* Translate arguments. *) - pose (cs := [seq (translate_pexpr (p_globs P) fn_ambient e) | e <- args]). - eapply bind. 1: exact (bind_list cs). - intros vargs. clear cs. - - apply (bind (translate_call gn tr_f_body vargs)) => vres. - - pose (translate_write_lvals (p_globs P) fn_ambient xs vres) as cres. - exact cres. + ). + refine + match i with + | Cassgn l _ s e => + let tr_p := translate_pexpr (p_globs P) id e in + (sid, + v ← tr_p.π2 ;; + (translate_write_lval (p_globs P) id l (totce (truncate_el s v))) + ) + | Copn ls _ o es => + let cs := [seq (translate_pexpr (p_globs P) id e) | e <- es] in + let vs := bind_list cs in + + (sid, + bvs ← vs ;; + translate_write_lvals (p_globs P) id ls (translate_exec_sopn o bvs) + ) + | Cif e c1 c2 => + let (sid', c1') := translate_cmd tr_f_body c1 id sid in + let (sid'', c2') := translate_cmd tr_f_body c2 id sid' in + let e' := translate_pexpr (p_globs P) id e in + let rb := coerce_typed_code 'bool e' in + (sid'', + b ← rb ;; if b then c1' else c2' + ) + | Cfor i r c => + let '(d, lo, hi) := r in + let (sid', fresh) := fresh_id sid in + let loᵗ := coerce_typed_code 'int (translate_pexpr (p_globs P) id lo) in + let hiᵗ := coerce_typed_code 'int (translate_pexpr (p_globs P) id hi) in + let cᵗ := translate_cmd tr_f_body c id in + (sid', + vlo ← loᵗ ;; + vhi ← hiᵗ ;; + translate_for i (wrange d vlo vhi) id cᵗ fresh) + | Ccall ii xs f args => + let (sid', fresh) := fresh_id sid in + let cs := [seq (translate_pexpr (p_globs P) id e) | e <- args] in + (sid', + vargs ← bind_list cs ;; + vres ← translate_call f tr_f_body fresh vargs ;; + translate_write_lvals (p_globs P) id xs vres + ) + | _ => (sid, unsupported.π2) + end. Defined. - (* Questions to answer for the translation of functions and function calls: - When does argument truncation happen? @@ -3658,9 +3619,9 @@ Defined. Idea 2: - Each Jasmin function gets translated to a `'unit raw_code` corresponding to its body. - - translate_instr takes a map from funnames to translated fun bodies. + - translate_instr takes a map from p_ids to translated fun bodies. - There is an additional wrapper function - `translate_call : funname → (args : seq value) → (f_tyin : seq stype) -> (f_tr_body : 'unit raw_code) -> 'unit raw_code` + `translate_call : p_id → (args : seq value) → (f_tyin : seq stype) -> (f_tr_body : 'unit raw_code) -> 'unit raw_code` that does the work of truncating, and storing the function arguments as well as the returned results into their locations. - the main theorem then talks not about running the translation of a function, but instead about translate_call @@ -3668,27 +3629,27 @@ Defined. (* translate_instr is blocked because it is a fixpoint *) Lemma translate_instr_unfold : - ∀ ep fn i, - translate_instr ep fn i = translate_instr_r ep fn (instr_d i). + ∀ ep i st, + translate_instr ep i st = translate_instr_r ep (instr_d i) st. Proof. - intros ep fn i. + intros ep i st. destruct i. reflexivity. Qed. (* Trick to have it expand to the same as the translate_cmd above *) Section TranslateCMD. -Context (tr_f_body : fdefs). - -Fixpoint translate_cmd (fn : funname) (c : cmd) : raw_code 'unit := +Fixpoint translate_cmd (tr_f_body : fdefs) (c : cmd) (id : p_id) (sid : p_id) : p_id * raw_code 'unit := match c with - | [::] => ret tt - | i :: c => translate_instr tr_f_body fn i ;; translate_cmd fn c + | [::] => (sid, ret tt) + | i :: c => + let (sid', i') := translate_instr tr_f_body i id sid in + let (sid'', c') := translate_cmd tr_f_body c id sid' in + (sid'', i' ;; c') end. End TranslateCMD. - (* PGH: CURRENTLY UNUSED. Keeping this around for when we want to package functions into packages, as we'll have to bundle the arguments and results into tuples. *) @@ -3701,6 +3662,7 @@ Record fdef := { #[local] Definition ty_out fd := ((ffun fd).π2).π1. Definition translate_fundef (tr_f_body : fdefs) + (p : p_id) (fd : _ufun_decl (* extra_fun_t *)) : funname * fdef. Proof using P asm_op asmop pd. destruct fd. destruct _f. @@ -3721,14 +3683,14 @@ Proof using P asm_op asmop pd. apply (coerce_chtuple_to_list _ f_tyin) in vargs'. (* Write the arguments to their locations. *) - pose (map (λ '(x, (ty; v)), translate_write_var f x (totce v)) + pose (map (λ '(x, (ty; v)), translate_write_var p x (totce v)) (zip f_params vargs')) as cargs. apply (foldl (λ c k, c ;; k) (ret tt)) in cargs. apply (bind cargs) => _. (* Perform the function body. *) - apply (bind (translate_cmd tr_f_body f f_body)) => _. + apply (bind (translate_cmd tr_f_body f_body p p).2) => _. (* Look up the results in their locations and return them. *) pose (map (λ x, totc _ (translate_get_var f (v_var x))) f_res) as cres. @@ -3771,12 +3733,13 @@ Proof using asm_op asmop pd. destruct prog. induction p_funcs. - exact [::]. - - unfold ssprove_prog. + - unfold fdefs. unfold ssprove_prog. apply cons. 2: exact IHp_funcs. pose a.1 as fn. split. 1: exact fn. destruct a. destruct _f. - exact (translate_cmd (Build__prog p_funcs p_globs p_extra) IHp_funcs fn f_body). + intros s_id. + exact (translate_cmd (Build__prog p_funcs p_globs p_extra) IHp_funcs f_body s_id s_id).2. Defined. Definition tr_p (prog : uprog) : ssprove_prog. @@ -3796,13 +3759,12 @@ Definition translate_funs (P : uprog) : seq _ufun_decl → fdefs * ssprove_prog | [::] => ([::], [::]) | f :: fs' => (* let '(tr_fs', tr_p') := translate_funs fs' in *) - let tr_tl := translate_funs fs' in - let '(tr_fs', tr_p') := (tr_tl.1, tr_tl.2) in - let fn := f.1 in - let tr_body := translate_cmd P tr_fs' fn (f_body f.2) in - let tr_fs := (fn, tr_body) :: tr_fs' in + (* let '(tr_fs', tr_p') := translate_funs fs' in *) + let '(fn, f_extra) := f in + let tr_body := fun sid => (translate_cmd P (translate_funs fs').1 (f_body f_extra) sid sid).2 in + let tr_fs := (fn, tr_body) :: (translate_funs fs').1 in (* let tr_p := (fn, translate_call P fn tr_fs) :: tr_p' in *) - let tr_p := (fn, translate_call_body P fn tr_body) :: tr_p' in + let tr_p := (fn, translate_call_body P fn tr_body) :: (translate_funs fs').2 in (tr_fs, tr_p) end in translate_funs. @@ -3882,12 +3844,12 @@ Qed. Definition get_translated_fun P fn : trfun := match assoc (translate_prog' P).2 fn with | Some f => f - | None => λ _, ret [::] + | None => λ _ _, ret [::] end. Lemma translate_call_head {P gn fs' f} : assoc (translate_prog' P).1 gn = - Some (translate_cmd P (translate_funs P fs').1 gn (f_body f)) + Some (fun sid => (translate_cmd P (translate_funs P fs').1 (f_body f) sid sid).2) → translate_call P gn (translate_funs P (p_funcs P)).1 = translate_call P gn (translate_funs P ((gn,f) :: fs')).1. From 780cc9636911ce3bd32c0b5e3c782cfb1277a65c Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Wed, 29 Jun 2022 13:28:50 +0200 Subject: [PATCH 258/383] more order/disj --- theories/Jasmin/jasmin_translate.v | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 0e03ce49..0afc0e8b 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -280,6 +280,15 @@ Definition fresh_id i := Lemma prec_neq p fp : p ≺ fp -> p <> fp. Proof. unfold prec. easy. Qed. +Lemma prec_precneq i1 i2 : i1 ≺ i2 -> ~ i2 ⪯ i1. +Proof. + intros H contra. + eapply prec_neq. + 1: exact H. + apply antisymmetry; auto. + apply H. +Qed. + Instance prec_trans : Transitive prec. Proof. intros i1 i2 i3. @@ -332,6 +341,14 @@ Proof. apply fresh2. Qed. Definition disj i1 i2 := forall i3, i1 ⪯ i3 -> ~ i2 ⪯ i3. +Lemma disj_antirefl i : ~ disj i i. +Proof. + intros contra. + unfold disj in contra. + specialize (contra i ltac:(reflexivity)). + apply contra. reflexivity. +Qed. + Instance disj_sym : Symmetric disj. Proof. intros i1 i2 hi1 i3 hi2. From 85143f1225719787b73abe118835cfa1241c964d Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Wed, 29 Jun 2022 13:31:31 +0200 Subject: [PATCH 259/383] move injectivity lemmas up --- theories/Jasmin/jasmin_translate.v | 585 +++++++++++++---------------- 1 file changed, 264 insertions(+), 321 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 0afc0e8b..88b403de 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -848,6 +848,238 @@ Definition nat_of_p_id_var (p : p_id) (x : var) : nat := Definition translate_var (p : p_id) (x : var) : Location := (encode x.(vtype) ; nat_of_p_id_var p x). +Lemma Natpow_expn : + ∀ (n m : nat), + (n ^ m)%nat = expn n m. +Proof. + intros n m. + induction m as [| m ih] in n |- *. + - cbn. reflexivity. + - simpl. rewrite expnS. rewrite -ih. reflexivity. +Qed. + +Lemma Mpowmodn : + ∀ d n, + n ≠ 0%nat → + d ^ n %% d = 0%nat. +Proof. + intros d n hn. + destruct n as [| n]. 1: contradiction. + simpl. apply modnMr. +Qed. + +Lemma nat_of_ident_pos : + ∀ x, (0 < nat_of_ident x)%coq_nat. +Proof. + intros x. induction x as [| a s ih]. + - auto. + - simpl. + rewrite -mulP. rewrite -plusE. + micromega.Lia.lia. +Qed. + +Lemma injective_nat_of_ident : + ∀ x y, + nat_of_ident x = nat_of_ident y → + x = y. +Proof. + intros x y e. + induction x as [| a x] in y, e |- *. + all: destruct y as [| b y]. + all: simpl in e. + - reflexivity. + - rewrite -mulP in e. rewrite -plusE in e. + pose proof (nat_of_ident_pos y). + micromega.Lia.lia. + - rewrite -mulP in e. rewrite -plusE in e. + pose proof (nat_of_ident_pos x). + micromega.Lia.lia. + - (* BSH: there is a more principled way of doing this, but this'll do for now *) + apply (f_equal (λ a, Nat.modulo a 256)) in e as xy_eq. + rewrite -Nat.add_mod_idemp_l in xy_eq. 2: micromega.Lia.lia. + rewrite -Nat.mul_mod_idemp_l in xy_eq. 2: micromega.Lia.lia. + rewrite Nat.mod_same in xy_eq. 2: micromega.Lia.lia. + rewrite Nat.mul_0_l in xy_eq. + rewrite Nat.mod_0_l in xy_eq. 2: micromega.Lia.lia. + rewrite Nat.add_0_l in xy_eq. + rewrite -Nat.add_mod_idemp_l in xy_eq. 2: micromega.Lia.lia. + rewrite -Nat.mul_mod_idemp_l in xy_eq. 2: micromega.Lia.lia. + rewrite Nat.mod_same in xy_eq. 2: micromega.Lia.lia. + rewrite Nat.mul_0_l in xy_eq. + rewrite Nat.mod_0_l in xy_eq. 2: micromega.Lia.lia. + rewrite Nat.add_0_l in xy_eq. + rewrite !Nat.mod_small in xy_eq. 2,3: apply Ascii.nat_ascii_bounded. + apply OrderedTypeEx.String_as_OT.nat_of_ascii_inverse in xy_eq. + subst. f_equal. + apply IHx. + rewrite -!addP in e. + rewrite -!mulP in e. + micromega.Lia.lia. +Qed. + +Lemma injective_nat_of_p_id_ident : + ∀ p x y, + nat_of_p_id_ident p x = nat_of_p_id_ident p y → + x = y. +Proof. + intros p x y e. + unfold nat_of_p_id_ident in e. + apply Nat.mul_cancel_l in e. 2: apply Nat.pow_nonzero ; auto. + eapply Nat.pow_inj_r in e. 2: auto. + apply injective_nat_of_ident. assumption. +Qed. + +Lemma coprime_mul_inj a b c d : + coprime a d → + coprime a b → + coprime c b → + coprime c d → + (a * b = c * d)%nat → + a = c ∧ b = d. +Proof. + intros ad ab cb cd e. + move: e => /eqP. rewrite eqn_dvd. move=> /andP [d1 d2]. + rewrite Gauss_dvd in d1. 2: assumption. + rewrite Gauss_dvd in d2. 2: assumption. + move: d1 d2 => /andP [d11 d12] /andP [d21 d22]. + rewrite Gauss_dvdl in d11. 2: assumption. + rewrite Gauss_dvdr in d12. 2: rewrite coprime_sym; assumption. + rewrite Gauss_dvdl in d21. 2: assumption. + rewrite Gauss_dvdr in d22. 2: rewrite coprime_sym; assumption. + split. + - apply /eqP. rewrite eqn_dvd. by apply /andP. + - apply /eqP. rewrite eqn_dvd. by apply /andP. +Qed. + +Lemma coprime_nat_of_stype_nat_of_fun_ident t p v : + coprime (nat_of_stype t) (nat_of_p_id_ident p v). +Proof. + unfold nat_of_p_id_ident. + unfold nat_of_stype. + rewrite coprimeMr. + apply /andP. + destruct t. + - rewrite !Natpow_expn. + rewrite !coprime_pexpl. + 2,3: auto. + rewrite !coprime_pexpr. + 2: apply /ltP; apply nat_of_ident_pos. + 2: apply /ltP; pose proof nat_of_p_id_nonzero p; micromega.Lia.lia. + auto. + - rewrite !Natpow_expn. + rewrite !coprime_pexpl. + 2,3: auto. + rewrite !coprime_pexpr. + 2: apply /ltP; apply nat_of_ident_pos. + 2: apply /ltP; pose proof nat_of_p_id_nonzero p; micromega.Lia.lia. + auto. + - rewrite !Natpow_expn. + rewrite !coprime_pexpl. + 2,3: auto. + rewrite !coprime_pexpr. + 2: apply /ltP; apply nat_of_ident_pos. + 2: apply /ltP; pose proof nat_of_p_id_nonzero p; micromega.Lia.lia. + auto. + - rewrite !Natpow_expn. + rewrite !coprime_pexpl. + 2,3: auto. + rewrite !coprime_pexpr. + 2: apply /ltP; apply nat_of_ident_pos. + 2: apply /ltP; pose proof nat_of_p_id_nonzero p; micromega.Lia.lia. + auto. +Qed. + +Lemma nat_of_p_id_pos : forall p, (0 < nat_of_p_id p)%coq_nat. +Proof. + intros. pose proof nat_of_p_id_nonzero p. micromega.Lia.lia. +Qed. + +Lemma injective_nat_of_p_id_ident2 : + ∀ p1 p2 x y, + nat_of_p_id_ident p1 x = nat_of_p_id_ident p2 y → + p1 = p2 /\ x = y. +Proof. + intros p gn x y e. + unfold nat_of_p_id_ident in e. + apply coprime_mul_inj in e as [p1_p2 x_y]. + - apply Nat.pow_inj_r in p1_p2; [|micromega.Lia.lia]. + apply Nat.pow_inj_r in x_y; [|micromega.Lia.lia]. + split. + + apply injective_nat_of_pos. assumption. + + apply injective_nat_of_ident. assumption. + - rewrite !Natpow_expn. + rewrite !coprime_pexpl. + 2: apply /ltP; apply nat_of_p_id_pos. + rewrite !coprime_pexpr. + 2: apply /ltP; apply nat_of_ident_pos. + reflexivity. + - rewrite !Natpow_expn. + rewrite !coprime_pexpl. + 2: apply /ltP; apply nat_of_p_id_pos. + rewrite !coprime_pexpr. + 2: apply /ltP; apply nat_of_ident_pos. + reflexivity. + - rewrite !Natpow_expn. + rewrite !coprime_pexpl. + 2: apply /ltP; apply nat_of_p_id_pos. + rewrite !coprime_pexpr. + 2: apply /ltP; apply nat_of_ident_pos. + reflexivity. + - rewrite !Natpow_expn. + rewrite !coprime_pexpl. + 2: apply /ltP; apply nat_of_p_id_pos. + rewrite !coprime_pexpr. + 2: apply /ltP; apply nat_of_ident_pos. + reflexivity. +Qed. + +Lemma injective_translate_var : + ∀ p, injective (translate_var p). +Proof. + intros p u v e. + unfold translate_var in e. + destruct u as [uty u], v as [vty v]. + simpl in e. noconf e. + unfold nat_of_p_id_var in H0. + simpl in H0. + apply coprime_mul_inj in H0 as [e1 e2]. + 2,3,4,5: apply coprime_nat_of_stype_nat_of_fun_ident. + f_equal. + - destruct uty, vty; auto; try discriminate. + + apply Nat.pow_inj_r in e1. 2: auto. + apply succn_inj in e1. + apply Pos2Nat.inj in e1. + subst; reflexivity. + + noconf H. reflexivity. + - eapply injective_nat_of_p_id_ident. + eassumption. +Qed. + +Lemma injective_translate_var2 : + forall (p1 p2 : p_id) v1 v2, p1 <> p2 -> translate_var p1 v1 != translate_var p2 v2. +Proof. + intros. + apply /eqP => contra. + unfold translate_var in contra. + noconf contra. + unfold nat_of_p_id_var in H1. + apply coprime_mul_inj in H1 as [e1 e2]. + 2,3,4,5: apply coprime_nat_of_stype_nat_of_fun_ident. + apply injective_nat_of_p_id_ident2 in e2 as [p_gn _]. + easy. +Qed. + +Lemma mem_loc_translate_var_neq : + ∀ p x, + mem_loc != translate_var p x. +Proof. + intros p x. + unfold mem_loc, translate_var. + apply /eqP. intro e. + destruct x as [ty i]. simpl in e. noconf e. + destruct ty. all: discriminate. +Qed. + #[local] Definition unsupported : typed_code := ('unit ; assert false). @@ -1563,6 +1795,38 @@ Definition nat_of_ptr (ptr : pointer) := Definition translate_ptr (ptr : pointer) : Location := ('word U8 ; nat_of_ptr ptr). +Lemma ptr_var_nat_neq (ptr : pointer) (p : p_id) (v : var) : + nat_of_ptr ptr != nat_of_p_id_var p v. +Proof. + unfold nat_of_ptr. + unfold nat_of_p_id_var. + apply /eqP. intro e. + apply (f_equal (λ n, n %% 3)) in e. + rewrite -modnMm in e. + rewrite -(modnMm (3 ^ _)) in e. + rewrite Mpowmodn in e. 2: apply nat_of_p_id_nonzero. + rewrite mul0n in e. + rewrite mod0n in e. + rewrite muln0 in e. + move: e => /eqP e. rewrite eqn_mod_dvd in e. 2: auto. + rewrite subn0 in e. + rewrite Natpow_expn in e. rewrite Euclid_dvdX in e. 2: auto. + move: e => /andP [e _]. + rewrite dvdn_prime2 in e. 2,3: auto. + move: e => /eqP e. micromega.Lia.lia. +Qed. + +Lemma ptr_var_neq (ptr : pointer) (p : p_id) (v : var) : + translate_ptr ptr != translate_var p v. +Proof. + unfold translate_ptr. + unfold translate_var. + unfold nat_of_p_id_ident. + apply /eqP. intro e. + noconf e. + move: (ptr_var_nat_neq ptr p v) => /eqP. contradiction. +Qed. + Definition rel_mem (m : mem) (h : heap) := ∀ ptr v, (* mem as array model: *) @@ -2906,327 +3170,6 @@ Proof. rewrite coerce_typed_code_K. assumption. Qed. -Lemma Natpow_expn : - ∀ (n m : nat), - (n ^ m)%nat = expn n m. -Proof. - intros n m. - induction m as [| m ih] in n |- *. - - cbn. reflexivity. - - simpl. rewrite expnS. rewrite -ih. reflexivity. -Qed. - -Lemma Mpowmodn : - ∀ d n, - n ≠ 0 → - d ^ n %% d = 0. -Proof. - intros d n hn. - destruct n as [| n]. 1: contradiction. - simpl. apply modnMr. -Qed. - -Lemma nat_of_pos_nonzero : - ∀ p, - nat_of_pos p ≠ 0. -Proof. - intros p. induction p as [p ih | p ih |]. - - simpl. micromega.Lia.lia. - - simpl. rewrite NatTrec.doubleE. - move => /eqP. rewrite double_eq0. move /eqP. assumption. - - simpl. micromega.Lia.lia. -Qed. - -Lemma injective_nat_of_pos : - ∀ p1 p2, - nat_of_pos p1 = nat_of_pos p2 → - p1 = p2. -Proof. - intros p1. induction p1 as [p1 ih | p1 ih |]; intros. - - destruct p2. - + inversion H. - f_equal. apply ih. - apply double_inj. - rewrite -!NatTrec.doubleE. - assumption. - + inversion H. - rewrite !NatTrec.doubleE in H1. - apply f_equal with (f:=odd) in H1. - simpl in H1. - rewrite !odd_double in H1. - easy. - + inversion H. - move: H1 => /eqP. - rewrite NatTrec.doubleE double_eq0 => /eqP H1. - apply nat_of_pos_nonzero in H1 as []. - - destruct p2. - + inversion H. - rewrite !NatTrec.doubleE in H1. - apply f_equal with (f:=odd) in H1. - simpl in H1. - rewrite !odd_double in H1. - easy. - + inversion H. - f_equal. apply ih. - apply double_inj. - rewrite -!NatTrec.doubleE. - assumption. - + inversion H. - rewrite !NatTrec.doubleE in H1. - apply f_equal with (f:=odd) in H1. - simpl in H1. - rewrite !odd_double in H1. - easy. - - destruct p2. - + inversion H. - move: H1 => /eqP. - rewrite eq_sym NatTrec.doubleE double_eq0 => /eqP H1. - apply nat_of_pos_nonzero in H1 as []. - + inversion H. - rewrite !NatTrec.doubleE in H1. - apply f_equal with (f:=odd) in H1. - simpl in H1. - rewrite !odd_double in H1. - easy. - + reflexivity. -Qed. - -Lemma ptr_var_nat_neq (ptr : pointer) (fn : funname) (v : var) : - nat_of_ptr ptr != nat_of_fun_var fn v. -Proof. - unfold nat_of_ptr. - unfold nat_of_fun_var. - apply /eqP. intro e. - apply (f_equal (λ n, n %% 3)) in e. - rewrite -modnMm in e. - rewrite -(modnMm (3 ^ _)) in e. - rewrite Mpowmodn in e. 2: apply nat_of_pos_nonzero. - rewrite mul0n in e. - rewrite mod0n in e. - rewrite muln0 in e. - move: e => /eqP e. rewrite eqn_mod_dvd in e. 2: auto. - rewrite subn0 in e. - rewrite Natpow_expn in e. rewrite Euclid_dvdX in e. 2: auto. - move: e => /andP [e _]. - rewrite dvdn_prime2 in e. 2,3: auto. - move: e => /eqP e. micromega.Lia.lia. -Qed. - -Lemma ptr_var_neq (ptr : pointer) (fn : funname) (v : var) : - translate_ptr ptr != translate_var fn v. -Proof. - unfold translate_ptr. - unfold translate_var. - unfold nat_of_fun_ident. - apply /eqP. intro e. - noconf e. - move: (ptr_var_nat_neq ptr fn v) => /eqP. contradiction. -Qed. - -Lemma nat_of_ident_pos : - ∀ x, (0 < nat_of_ident x)%coq_nat. -Proof. - intros x. induction x as [| a s ih]. - - auto. - - simpl. - rewrite -mulP. rewrite -plusE. - micromega.Lia.lia. -Qed. - -Lemma injective_nat_of_ident : - ∀ x y, - nat_of_ident x = nat_of_ident y → - x = y. -Proof. - intros x y e. - induction x as [| a x] in y, e |- *. - all: destruct y as [| b y]. - all: simpl in e. - - reflexivity. - - rewrite -mulP in e. rewrite -plusE in e. - pose proof (nat_of_ident_pos y). - micromega.Lia.lia. - - rewrite -mulP in e. rewrite -plusE in e. - pose proof (nat_of_ident_pos x). - micromega.Lia.lia. - - (* BSH: there is a more principled way of doing this, but this'll do for now *) - apply (f_equal (λ a, Nat.modulo a 256)) in e as xy_eq. - rewrite -Nat.add_mod_idemp_l in xy_eq. 2: micromega.Lia.lia. - rewrite -Nat.mul_mod_idemp_l in xy_eq. 2: micromega.Lia.lia. - rewrite Nat.mod_same in xy_eq. 2: micromega.Lia.lia. - rewrite Nat.mul_0_l in xy_eq. - rewrite Nat.mod_0_l in xy_eq. 2: micromega.Lia.lia. - rewrite Nat.add_0_l in xy_eq. - rewrite -Nat.add_mod_idemp_l in xy_eq. 2: micromega.Lia.lia. - rewrite -Nat.mul_mod_idemp_l in xy_eq. 2: micromega.Lia.lia. - rewrite Nat.mod_same in xy_eq. 2: micromega.Lia.lia. - rewrite Nat.mul_0_l in xy_eq. - rewrite Nat.mod_0_l in xy_eq. 2: micromega.Lia.lia. - rewrite Nat.add_0_l in xy_eq. - rewrite !Nat.mod_small in xy_eq. 2,3: apply Ascii.nat_ascii_bounded. - apply OrderedTypeEx.String_as_OT.nat_of_ascii_inverse in xy_eq. - subst. f_equal. - apply IHx. - rewrite -!addP in e. - rewrite -!mulP in e. - micromega.Lia.lia. -Qed. - -Lemma injective_nat_of_fun_ident : - ∀ fn x y, - nat_of_fun_ident fn x = nat_of_fun_ident fn y → - x = y. -Proof. - intros fn x y e. - unfold nat_of_fun_ident in e. - apply Nat.mul_cancel_l in e. 2: apply Nat.pow_nonzero ; auto. - eapply Nat.pow_inj_r in e. 2: auto. - apply injective_nat_of_ident. assumption. -Qed. - -Lemma coprime_mul_inj a b c d : - coprime a d → - coprime a b → - coprime c b → - coprime c d → - (a * b = c * d)%nat → - a = c ∧ b = d. -Proof. - intros ad ab cb cd e. - move: e => /eqP. rewrite eqn_dvd. move=> /andP [d1 d2]. - rewrite Gauss_dvd in d1. 2: assumption. - rewrite Gauss_dvd in d2. 2: assumption. - move: d1 d2 => /andP [d11 d12] /andP [d21 d22]. - rewrite Gauss_dvdl in d11. 2: assumption. - rewrite Gauss_dvdr in d12. 2: rewrite coprime_sym; assumption. - rewrite Gauss_dvdl in d21. 2: assumption. - rewrite Gauss_dvdr in d22. 2: rewrite coprime_sym; assumption. - split. - - apply /eqP. rewrite eqn_dvd. by apply /andP. - - apply /eqP. rewrite eqn_dvd. by apply /andP. -Qed. - -Lemma coprime_nat_of_stype_nat_of_fun_ident t fn v : - coprime (nat_of_stype t) (nat_of_fun_ident fn v). -Proof. - unfold nat_of_fun_ident. - unfold nat_of_stype. - rewrite coprimeMr. - apply /andP. - destruct t. - - rewrite !Natpow_expn. - rewrite !coprime_pexpl. - 2,3: auto. - rewrite !coprime_pexpr. - 2: apply /ltP; apply nat_of_ident_pos. - 2: apply /ltP; pose proof nat_of_pos_nonzero fn; micromega.Lia.lia. - auto. - - rewrite !Natpow_expn. - rewrite !coprime_pexpl. - 2,3: auto. - rewrite !coprime_pexpr. - 2: apply /ltP; apply nat_of_ident_pos. - 2: apply /ltP; pose proof nat_of_pos_nonzero fn; micromega.Lia.lia. - auto. - - rewrite !Natpow_expn. - rewrite !coprime_pexpl. - 2,3: auto. - rewrite !coprime_pexpr. - 2: apply /ltP; apply nat_of_ident_pos. - 2: apply /ltP; pose proof nat_of_pos_nonzero fn; micromega.Lia.lia. - auto. - - rewrite !Natpow_expn. - rewrite !coprime_pexpl. - 2,3: auto. - rewrite !coprime_pexpr. - 2: apply /ltP; apply nat_of_ident_pos. - 2: apply /ltP; pose proof nat_of_pos_nonzero fn; micromega.Lia.lia. - auto. -Qed. - -Lemma nat_of_pos_pos : - ∀ p, (0 < nat_of_pos p)%coq_nat. -Proof. - intros p. - pose proof (nat_of_pos_nonzero p). micromega.Lia.lia. -Qed. - -Lemma injective_nat_of_fun_ident2 : - ∀ fn gn x y, - nat_of_fun_ident fn x = nat_of_fun_ident gn y → - fn = gn /\ x = y. -Proof. - intros fn gn x y e. - unfold nat_of_fun_ident in e. - apply coprime_mul_inj in e as [fn_gn x_y]. - - apply Nat.pow_inj_r in fn_gn; [|micromega.Lia.lia]. - apply Nat.pow_inj_r in x_y; [|micromega.Lia.lia]. - split. - + apply injective_nat_of_pos. assumption. - + apply injective_nat_of_ident. assumption. - - rewrite !Natpow_expn. - rewrite !coprime_pexpl. - 2: apply /ltP; apply nat_of_pos_pos. - rewrite !coprime_pexpr. - 2: apply /ltP; apply nat_of_ident_pos. - reflexivity. - - rewrite !Natpow_expn. - rewrite !coprime_pexpl. - 2: apply /ltP; apply nat_of_pos_pos. - rewrite !coprime_pexpr. - 2: apply /ltP; apply nat_of_ident_pos. - reflexivity. - - rewrite !Natpow_expn. - rewrite !coprime_pexpl. - 2: apply /ltP; apply nat_of_pos_pos. - rewrite !coprime_pexpr. - 2: apply /ltP; apply nat_of_ident_pos. - reflexivity. - - rewrite !Natpow_expn. - rewrite !coprime_pexpl. - 2: apply /ltP; apply nat_of_pos_pos. - rewrite !coprime_pexpr. - 2: apply /ltP; apply nat_of_ident_pos. - reflexivity. -Qed. - -Lemma injective_translate_var : - ∀ fn, injective (translate_var fn). -Proof. - intros fn u v e. - unfold translate_var in e. - destruct u as [uty u], v as [vty v]. - simpl in e. noconf e. - unfold nat_of_fun_var in H0. - simpl in H0. - apply coprime_mul_inj in H0 as [e1 e2]. - 2,3,4,5: apply coprime_nat_of_stype_nat_of_fun_ident. - f_equal. - - destruct uty, vty; auto; try discriminate. - + apply Nat.pow_inj_r in e1. 2: auto. - apply succn_inj in e1. - apply Pos2Nat.inj in e1. - subst; reflexivity. - + noconf H. reflexivity. - - eapply injective_nat_of_fun_ident. - eassumption. -Qed. - -Lemma injective_translate_var2 : - ∀ fn gn v1 v2, - fn != gn → - translate_var fn v1 != translate_var gn v2. -Proof. - intros. - apply /eqP => contra. - unfold translate_var in contra. - noconf contra. - unfold nat_of_fun_var in H1. - apply coprime_mul_inj in H1 as [e1 e2]. - 2-5: apply coprime_nat_of_stype_nat_of_fun_ident. - apply injective_nat_of_fun_ident2 in e2 as [fn_gn _]. - move: H => /eqP. easy. -Qed. Lemma translate_write_correct : ∀ fn sz s p (w : word sz) cm (cond : heap → Prop), From 3ca406ad2bdf1d45d09f8b767dbe926bec2ef811 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Wed, 29 Jun 2022 13:37:16 +0200 Subject: [PATCH 260/383] change `rel_estate` and reprove lemmas --- theories/Jasmin/jasmin_translate.v | 835 +++++++++++++++++++++++------ 1 file changed, 665 insertions(+), 170 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 88b403de..5c31ce51 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1941,48 +1941,523 @@ Qed. #[local] Open Scope vmap_scope. -Definition rel_vmap (vm : vmap) (fn : funname) (h : heap) := +Definition rel_vmap (vm : vmap) (p : p_id) (h : heap) := ∀ (i : var) v, vm.[i] = ok v → - get_heap h (translate_var fn i) = coerce_to_choice_type _ (embed v). + get_heap h (translate_var p i) = coerce_to_choice_type _ (embed v). -Definition rel_estate (s : estate) (fn : funname) (h : heap) := - rel_mem s.(emem) h ∧ rel_vmap s.(evm) fn h. +Lemma rel_vmap_set_heap_neq vm m_id m_id' i v h : + m_id <> m_id' -> rel_vmap vm m_id h -> rel_vmap vm m_id (set_heap h (translate_var m_id' i) v). +Proof. + intros hneq hrel i' v' H. + rewrite get_set_heap_neq. + 1: apply hrel; auto. + apply injective_translate_var2. + assumption. +Qed. -Lemma translate_read_estate : - ∀ fn s ptr sz w m, - rel_estate s fn m → - read (emem s) ptr sz = ok w → - read_mem (get_heap m mem_loc) ptr sz = w. +(* empty stack/valid *) +Definition empty_stack stack h : Prop := forall i, get_heap h (translate_var stack i) = chCanonical _. + +Lemma coerce_to_choice_type_K : + ∀ (t : choice_type) (v : t), + coerce_to_choice_type t v = v. Proof. - intros fn s ptr sz w m [] h. - eapply translate_read. all: eassumption. + intros t v. + funelim (coerce_to_choice_type t v). + 2:{ clear - e. rewrite eqxx in e. discriminate. } + rewrite <- Heqcall. + apply cast_ct_val_K. Qed. -Lemma mem_loc_translate_var_neq : - ∀ fn x, - mem_loc != translate_var fn x. +Lemma empty_stack_spec m_id : + forall h, empty_stack m_id h -> rel_vmap vmap0 m_id h. Proof. - intros fn x. - unfold mem_loc, translate_var. - apply /eqP. intro e. - destruct x as [ty i]. simpl in e. noconf e. - destruct ty. all: discriminate. + intros h emp i v hv. + rewrite coerce_to_choice_type_K. + rewrite Fv.get0 in hv. + rewrite emp. + unfold translate_var. + destruct (vtype i); now inversion hv. +Qed. + +Definition valid (sid : p_id) (h : heap) := + forall i, sid ≺ i -> empty_stack i h. + +Lemma valid_prec : forall id1 id2 m, id1 ⪯ id2 -> valid id1 m -> valid id2 m. +Proof. + intros id1 id2 m hpre hvalid. + intros id' hprec. + apply hvalid. + eapply preceq_prec_trans; eauto. +Qed. + +Lemma valid_set_heap_disj m_id s_id i v h : + valid m_id h -> disj m_id s_id -> valid m_id (set_heap h (translate_var s_id i) v). +Proof. + intros hvalid hdisj s_id' hpre i'. + rewrite get_set_heap_neq. + 1: apply hvalid; assumption. + apply injective_translate_var2. + intros contra; subst. + eapply disj_antirefl. + eapply disj_prec_l. + 1: eapply hpre. + assumption. +Qed. + +Lemma valid_set_heap_prec m_id s_id i v h : + valid s_id h -> m_id ⪯ s_id -> valid s_id (set_heap h (translate_var m_id i) v). +Proof. + intros hvalid hpre s_id' hpre' i'. + rewrite get_set_heap_neq. + 1: apply hvalid; auto. + apply injective_translate_var2. + apply nesym. + apply prec_neq. + eapply preceq_prec_trans; eauto. +Qed. + +Hint Resolve valid_prec : prefix. + +(* stack *) +Definition stack_frame := (vmap * p_id * p_id * list p_id)%type. + +Definition stack := list stack_frame. + +Definition stack_cons s_id (stf : stack_frame) : stack_frame := + (stf.1.1.1, stf.1.1.2, s_id, stf.1.2 :: stf.2). +Notation "s_id ⊔ stf" := (stack_cons s_id stf) (at level 60). + +Inductive valid_stack : stack -> heap -> Prop := +| valid_stack_nil : forall h, valid_stack [::] h +| valid_stack_new : forall st vm m_id s_id h, + valid_stack st h -> + rel_vmap vm m_id h -> + m_id ⪯ s_id -> + valid s_id h -> + (forall stf, List.In stf st -> disj m_id stf.1.2 /\ forall s_id', List.In s_id' stf.2 -> disj m_id s_id') -> + valid_stack ((vm, m_id, s_id, [::]) :: st) h +| valid_stack_sub : forall st vm m_id s_id s_id' s_st h, + valid_stack ((vm, m_id, s_id, s_st) :: st) h -> + m_id ⪯ s_id' -> + valid s_id' h -> + ~ List.In s_id' s_st -> + disj s_id s_id' -> + (forall s_id'', List.In s_id'' s_st -> disj s_id' s_id'') -> + valid_stack ((vm, m_id, s_id', s_id :: s_st) :: st) h. + +Lemma valid_stack_single vm m_id s_id s_st h : + rel_vmap vm m_id h -> + m_id ⪯ s_id -> + valid s_id h -> + ~ List.In s_id s_st -> + List.NoDup s_st -> + (forall s_id', List.In s_id' s_st -> valid s_id' h) -> + (forall s_id', List.In s_id' s_st -> m_id ⪯ s_id') -> + (forall s_id', List.In s_id' s_st -> disj s_id s_id') -> + (forall s_id' s_id'', List.In s_id' s_st -> List.In s_id'' s_st -> s_id' <> s_id'' -> disj s_id' s_id'') -> + valid_stack [::(vm, m_id, s_id, s_st)] h. +Proof. + revert s_id. + induction s_st; intros s_id hrel hpre1 hvalid hnin hnodup hvalid2 hpre2 hdisj1 hdisj2. + - constructor; auto. + + constructor. + - constructor; auto. + + eapply IHs_st; auto. + * eapply hpre2; left; auto. + * eapply hvalid2; left; auto. + * inversion hnodup; auto. + * inversion hnodup; auto. + * intros s_id' s_in'. + apply hvalid2; right; auto. + * intros s_id' s_in'. + apply hpre2; right; auto. + * intros s_id' s_in'. + apply hdisj2. + ** left; auto. + ** right; auto. + ** inversion hnodup; subst. + intros contra; subst. + easy. + * intros s_id' s_id'' s_in' s_in'' s_neq. + apply hdisj2. + ** right; auto. + ** right; auto. + ** assumption. + + intros contra. + apply hnin. + right; auto. + + apply disj_sym. + apply hdisj1. + left; auto. + + intros s_id' s_in'. + apply hdisj1. + right; auto. +Qed. + +Lemma valid_stack_cons vm m_id s_id s_st st h : + valid_stack st h -> + rel_vmap vm m_id h -> + m_id ⪯ s_id -> + (forall stf, List.In stf st -> disj m_id stf.1.2 /\ forall s_id', List.In s_id' stf.2 -> disj m_id s_id') -> + valid s_id h -> + ~ List.In s_id s_st -> + List.NoDup s_st -> + (forall s_id', List.In s_id' s_st -> valid s_id' h) -> + (forall s_id', List.In s_id' s_st -> m_id ⪯ s_id') -> + (forall s_id', List.In s_id' s_st -> disj s_id s_id') -> + (forall s_id' s_id'', List.In s_id' s_st -> List.In s_id'' s_st -> s_id' <> s_id'' -> disj s_id' s_id'') -> + valid_stack ((vm, m_id, s_id, s_st) :: st) h. +Proof. + revert vm m_id s_id st h. + intros vm m_id s_id st h hvs hrel hpre hdisj1 hvalid1 hnin hnodup hvalid2 hpre2 hdisj2 hdisj3. + revert s_id hpre hvalid1 hnin hdisj2. induction s_st. + - constructor; auto. + - constructor; auto. + + eapply IHs_st. + * inversion hnodup; auto. + * intros s_id' s_in'. + apply hvalid2; right; auto. + * intros s_id' s_in'. + apply hpre2; right; auto. + * intros s_id' s_id'' s_in' s_in'' s_neq. + eapply hdisj3. + ** right; auto. + ** right; auto. + ** assumption. + * apply hpre2. + left; auto. + * apply hvalid2. + left; auto. + * inversion hnodup. + auto. + * + intros s_id' s_in'. + apply hdisj3. + ** left; auto. + ** right; auto. + ** inversion hnodup; subst. + intros contra; subst. + auto. + + intros contra. + apply hnin. + right; auto. + + apply disj_sym. + apply hdisj2. + left; auto. + + intros s_id' s_in'. + apply hdisj2. + right; auto. +Qed. + +Lemma valid_stack_valid_stack vm m_id s_id s_st st h : valid_stack ((vm, m_id, s_id, s_st) :: st) h -> valid_stack st h. +Proof. + revert vm m_id s_id. + induction s_st; intros. + - inversion H; assumption. + - inversion H. + eapply IHs_st. + eassumption. +Qed. + +Lemma valid_stack_rel_vmap vm m_id s_id s_st st h : valid_stack ((vm, m_id, s_id, s_st) :: st) h -> rel_vmap vm m_id h. +Proof. + revert vm m_id s_id. + induction s_st; intros. + - inversion H; assumption. + - inversion H. + eapply IHs_st. + eassumption. +Qed. + +Lemma valid_stack_disj vm m_id s_id s_st st h : + valid_stack ((vm, m_id, s_id, s_st) :: st) h -> + (forall stf, List.In stf st -> disj m_id stf.1.2 /\ forall s_id', List.In s_id' stf.2 -> disj m_id s_id'). + revert vm m_id s_id. + induction s_st; intros vm m_id s_id H. + - inversion H. + assumption. + - inversion H. + eapply IHs_st. + eassumption. +Qed. + +Ltac split_and := + repeat lazymatch goal with + | |- _ /\ _ => split + end. + +Lemma invert_valid_stack st vm m_id s_id s_st h : + valid_stack ((vm, m_id, s_id, s_st) :: st) h -> + valid_stack st h + /\ rel_vmap vm m_id h + /\ m_id ⪯ s_id + /\ (forall stf, List.In stf st -> disj m_id stf.1.2 /\ forall s_id', List.In s_id' stf.2 -> disj m_id s_id') + /\ valid s_id h + /\ ~ List.In s_id s_st + /\ List.NoDup s_st + /\ (forall s_id', List.In s_id' s_st -> valid s_id' h) + /\ (forall s_id', List.In s_id' s_st -> m_id ⪯ s_id') + /\ (forall s_id', List.In s_id' s_st -> disj s_id s_id') + /\ (forall s_id' s_id'', List.In s_id' s_st -> List.In s_id'' s_st -> s_id' <> s_id'' -> disj s_id' s_id''). +Proof. + intros H. + split_and; subst; auto. + - eapply valid_stack_valid_stack; eassumption. + - eapply valid_stack_rel_vmap; eassumption. + - inversion H; auto. + - revert s_id H. + induction s_st. + + intros. + inversion H; subst. + eapply H10; eauto. + + intros s_id H stf. + inversion H; subst. + eapply IHs_st; eauto. + - inversion H; auto. + - inversion H; subst; auto. + intros [contra|contra]; subst. + + eapply disj_antirefl; eauto. + + easy. + - revert s_id H. induction s_st. + + constructor. + + constructor. + * inversion H; subst; auto. + inversion H6; subst; auto. + intros [contra|contra]; subst. + ** eapply disj_antirefl; eauto. + ** eapply disj_antirefl. + eapply H17. + assumption. + * eapply IHs_st. + inversion H; eauto. + - revert s_id H. induction s_st. + + easy. + + intros s_id hvalid s_id' [|s_in']; subst. + * inversion hvalid; subst. + inversion H5; auto. + * eapply IHs_st. + ** inversion hvalid; eassumption. + ** assumption. + - revert s_id H. induction s_st. + + easy. + + intros s_id hvalid s_id' [|s_in']; subst. + * inversion hvalid; subst. + inversion H5; auto. + * eapply IHs_st. + ** inversion hvalid; eassumption. + ** assumption. + - inversion H; subst; auto. + + easy. + + intros s_id' [|s_in']; subst; auto. + inversion H; subst; auto. + apply disj_sym; auto. + - revert s_id H. induction s_st. + + easy. + + intros s_id hvalid s_id' s_id'' [|s_in'] [|s_in''] hneq; subst; auto. + * easy. + * inversion hvalid; subst; auto. + inversion H5; subst; auto. + ** easy. + ** destruct s_in'' as [|s_in'']; subst; auto. + apply disj_sym; auto. + * inversion hvalid; subst; auto. + inversion H5; subst; auto. + ** easy. + ** destruct s_in' as [|s_in']; subst; auto. + apply disj_sym; auto. + * inversion hvalid; subst. + eapply IHs_st; eauto. +Qed. + +Ltac invert_stack st hst hevm hpre hdisj hvalid hnin hnodup hvalid1 hpre1 hdisj1 hdisj2 := + apply invert_valid_stack in st as [hst [hevm [hpre [hdisj [hvalid [hnin [hnodup [hvalid1 [hpre1 [hdisj1 hdisj2]]]]]]]]]]. + +Lemma valid_stack_pop stf st : + ∀ h, valid_stack (stf :: st) h -> + valid_stack st h. +Proof. + intros h H. + destruct stf as [[[? ?] ?] ?]. + eapply valid_stack_valid_stack; eassumption. +Qed. + +Lemma valid_stack_push_sub vm m_id s_id s_st st : + ∀ h, valid_stack ((vm, m_id, s_id, s_st) :: st) h -> + valid_stack ((vm, m_id, s_id~1, s_id~0 :: s_st) :: st) h. +Proof. + intros h vst. + invert_stack vst hst hevm hpre hdisj hvalid hnin hnodup hvalid1 hpre1 hdisj1 hdisj2. + constructor; eauto with prefix. + - eapply valid_stack_cons; eauto with prefix. + + intros contra. + eapply disj_antirefl. + eapply disj_prec_l. + 1: eapply fresh1. + eapply hdisj1. + assumption. + + intros s_id' s_in'. + eapply disj_prec_l. + 1: eapply fresh1. + apply hdisj1. + assumption. + - intros contra. + eapply disj_antirefl. + eapply disj_prec_l. + 1: eapply fresh2. + eapply hdisj1. + assumption. + - apply fresh_disj. + - intros s_id' s_in'. + eapply disj_prec_l. + 1: eapply fresh2. + apply hdisj1. + assumption. +Qed. + +Lemma valid_stack_pop_sub vm m_id s_id s_id' s_st st : + ∀ h, valid_stack ((vm, m_id, s_id', s_id :: s_st) :: st) h -> + valid_stack ((vm, m_id, s_id, s_st) :: st) h. +Proof. + intros h vst. + inversion vst. + assumption. +Qed. + +Lemma valid_stack_push vm m_id s_id s_st st : + ∀ h, valid_stack ((vm, m_id, s_id, s_st) :: st) h -> + valid_stack ((vmap0, s_id~1, s_id~1, [::]) :: ((vm, m_id, s_id~0, s_st) :: st)) h. +Proof. + intros h vst. + assert (vst2:=vst). + invert_stack vst2 hst hevm hpre hdisj hvalid hnin hnodup hvalid1 hpre1 hdisj1 hdisj2; auto. + eapply valid_stack_push_sub in vst. + eapply valid_stack_pop_sub in vst. + constructor; eauto with prefix. + - eapply empty_stack_spec. + eapply hvalid. + apply fresh2. + - intros stf [|stf_in]; subst; split. + + apply disj_sym. apply fresh_disj. + + intros s_id' s_in'. + eapply disj_prec_l. + 1: apply fresh2. + eapply hdisj1. + assumption. + + eapply disj_prec_l. + 1: etransitivity. + 1: eapply hpre. + 1: eapply fresh2. + eapply (proj1 (hdisj stf stf_in)). + + intros s_id' s_in'. + eapply disj_prec_l. + 1: etransitivity. + 1: eapply hpre. + 1: eapply fresh2. + eapply hdisj; eauto. +Qed. + +Lemma valid_stack_set_glob ptr sz (w : word sz) st m : + valid_stack st m -> + valid_stack st (set_heap m mem_loc (write_mem (get_heap m mem_loc) ptr w)). +Proof. + intros val. + induction val; auto. + - constructor; auto. + - constructor; auto. + + intros v hv ev. + rewrite get_set_heap_neq. + 2:{ rewrite eq_sym. apply mem_loc_translate_var_neq. } + apply H. assumption. + + intros i' hpre v. + rewrite get_set_heap_neq. + 2:{ rewrite eq_sym. apply mem_loc_translate_var_neq. } + apply H1. + assumption. + - constructor; auto. + intros i' hpre v. + rewrite get_set_heap_neq. + 2:{ rewrite eq_sym. apply mem_loc_translate_var_neq. } + apply H0. + assumption. +Qed. + +Lemma valid_stack_set_heap i v vm m_id s_id s_st st m : + valid_stack ((vm, m_id, s_id, s_st) :: st) m -> + valid_stack st (set_heap m (translate_var m_id i) v). +Proof. + intros vs. + invert_stack vs hst hevm hpre hdisj hvalid hnin hnodup hvalid1 hpre1 hdisj1 hdisj2. + induction hst as [ + |st vm' m_id' s_id' h hst IH hevm' hpre' hvalid' hdisj' + |st vm' m_id' s_id' s_id'' s_st' h hst IH hpre' hvalid' hnin' hdisj1' hdisj2']. + - constructor. + - constructor; auto. + + eapply IH; auto; simpl. + intros stf stf_in. + apply hdisj. + right; auto. + + apply rel_vmap_set_heap_neq; auto. + intros contra; subst. + eapply disj_antirefl. + eapply disj_prec_r. + 1: eapply hpre'. + apply disj_sym. + specialize (hdisj (vm', m_id, s_id', [::]) ltac:(left;auto)). + easy. + + apply valid_set_heap_disj; auto. + apply disj_sym. + specialize (hdisj (vm', m_id', s_id', [::]) ltac:(left;auto)). + easy. + - constructor; auto. + + eapply IH; auto. + intros stf [|stf_in]; subst; split. + * eapply hdisj. + 1: left; auto. + left; auto. + * intros s_id''' s_in'''. + eapply hdisj. + 1: left; auto. + right; auto. + * specialize (hdisj stf ltac:(right;auto)). + easy. + * intros s_id''' s_in'''. + eapply hdisj. + 1: right; eauto. + assumption. + + eapply valid_set_heap_disj; auto. + eapply disj_sym . + specialize (hdisj (vm', m_id', s_id'', s_id' :: s_st') ltac:(left;auto)). + easy. +Qed. + +Definition rel_estate (s : estate) (m_id : p_id) (s_id : p_id) (s_st : list p_id) (st : stack) (h : heap) := + rel_mem s.(emem) h /\ valid_stack ((s.(evm), m_id, s_id, s_st) :: st) h. + +Lemma translate_read_estate : + ∀ s ptr sz w m_id s_id s_st c_stack m, + rel_estate s m_id s_id s_st c_stack m → + read (emem s) ptr sz = ok w → + read_mem (get_heap m mem_loc) ptr sz = w. +Proof. + intros s ptr sz w m m_id s_id s_st c_stack rel h. + eapply translate_read. 2: eassumption. + apply rel. Qed. Lemma translate_write_estate : - ∀ fn sz s cm ptr w m, + ∀ sz s cm ptr w m_id s_id s_st st m, write s.(emem) ptr (sz := sz) w = ok cm → - rel_estate s fn m → - rel_estate {| emem := cm ; evm := s.(evm) |} fn (set_heap m mem_loc (write_mem (get_heap m mem_loc) ptr w)). + rel_estate s m_id s_id s_st st m → + rel_estate {| emem := cm ; evm := s.(evm) |} m_id s_id s_st st (set_heap m mem_loc (write_mem (get_heap m mem_loc) ptr w)). Proof. - intros fn sz s cm ptr w m hw [hrm hvm]. + intros sz s cm ptr w m_id s_id s_st st m hw [hmem hstack]. split. - simpl. eapply translate_write_mem_correct. all: eassumption. - - simpl. intros i v ev. - rewrite get_set_heap_neq. - 2:{ rewrite eq_sym. apply mem_loc_translate_var_neq. } - apply hvm. assumption. + - simpl. + apply valid_stack_set_glob. + assumption. Qed. Lemma coerce_cast_code (ty vty : choice_type) (v : vty) : @@ -2015,17 +2490,6 @@ Proof. symmetry. assumption. Qed. -Lemma coerce_to_choice_type_K : - ∀ (t : choice_type) (v : t), - coerce_to_choice_type t v = v. -Proof. - intros t v. - funelim (coerce_to_choice_type t v). - 2:{ clear - e. rewrite eqxx in e. discriminate. } - rewrite <- Heqcall. - apply cast_ct_val_K. -Qed. - Lemma coerce_to_choice_type_translate_value_to_val : ∀ ty (v : sem_t ty), coerce_to_choice_type (encode ty) (translate_value (to_val v)) = @@ -2045,49 +2509,31 @@ Proof. reflexivity. Qed. -Section bind_list_test. - - (* Quick test to see that the definition-via-tactics of bind_list' computes - as expected. *) - Definition cs : list typed_code := - [:: ('bool; (ret false)) ; ('bool; (ret true)) ; ('nat; (ret 666))]. - Definition ts := [:: sbool; sbool; sint; sint]. - Goal bind_list' ts cs = bind_list' ts cs. - unfold bind_list' at 2. - unfold bind_list_trunc_aux. - simpl. - (* rewrite !coerce_to_choice_type_K. *) - simp coerce_to_choice_type. - cbn. - Abort. -End bind_list_test. - - Lemma get_var_get_heap : - ∀ fn x s v m, + ∀ x s v m_id m, get_var (evm s) x = ok v → - rel_estate s fn m → - get_heap m (translate_var fn x) = + rel_vmap (evm s) m_id m → + get_heap m (translate_var m_id x) = coerce_to_choice_type _ (translate_value v). Proof. - intros fn x s v m ev hm. + intros x s v m c_stack ev hevm. unfold get_var in ev. eapply on_vuP. 3: exact ev. 2: discriminate. intros sx esx esv. - eapply hm in esx. subst. + eapply hevm in esx. subst. rewrite coerce_to_choice_type_translate_value_to_val. rewrite esx. rewrite coerce_to_choice_type_K. reflexivity. Qed. Lemma translate_get_var_correct : - ∀ fn x s v (cond : heap → Prop), + ∀ x s v m_id s_id s_st st (cond : heap → Prop), get_var (evm s) x = ok v → - (∀ m, cond m → rel_estate s fn m) → + (∀ m, cond m → rel_estate s m_id s_id s_st st m) → ⊢ ⦃ cond ⦄ - translate_get_var fn x ⇓ coerce_to_choice_type _ (translate_value v) + translate_get_var m_id x ⇓ coerce_to_choice_type _ (translate_value v) ⦃ cond ⦄. Proof. - intros fn x s v cond ev hcond. + intros x s v m_id s_id s_st st cond ev hcond. unfold translate_get_var. eapply u_get_remember. intros vx. eapply u_ret. intros m [hm hx]. @@ -2095,14 +2541,16 @@ Proof. unfold u_get in hx. subst. eapply get_var_get_heap. - eassumption. - - eapply hcond. assumption. + - apply hcond in hm as [_ hst]. + invert_stack hst hst hevm hpre hdisj hvalid hnin hnodup hvalid1 hpre1 hdisj1 hdisj2. + assumption. Qed. -Lemma translate_gvar_correct (f : funname) (x : gvar) (v : value) s (cond : heap → Prop) : +Lemma translate_gvar_correct (x : gvar) (v : value) s (cond : heap → Prop) m_id s_id s_st st : get_gvar gd (evm s) x = ok v → - (∀ m, cond m → rel_estate s f m) → + (∀ m, cond m → rel_estate s m_id s_id s_st st m) → ⊢ ⦃ cond ⦄ - translate_gvar f x ⇓ coerce_to_choice_type _ (translate_value v) + translate_gvar m_id x ⇓ coerce_to_choice_type _ (translate_value v) ⦃ cond ⦄. Proof. intros ev hcond. @@ -2265,9 +2713,9 @@ Proof. apply translate_truncate_val. assumption. Qed. -Lemma translate_pexpr_type fn s₁ e v : +Lemma translate_pexpr_type p s₁ e v : sem_pexpr gd s₁ e = ok v → - (translate_pexpr fn e).π1 = choice_type_of_val v. + (translate_pexpr p e).π1 = choice_type_of_val v. Proof. intros. revert v H. @@ -2518,9 +2966,9 @@ Proof. all: reflexivity. Qed. -Lemma translate_pexprs_types fn s1 es vs : +Lemma translate_pexprs_types p s1 es vs : mapM (sem_pexpr gd s1) es = ok vs → - [seq (translate_pexpr fn e).π1 | e <- es] = [seq choice_type_of_val v | v <- vs]. + [seq (translate_pexpr p e).π1 | e <- es] = [seq choice_type_of_val v | v <- vs]. Proof. revert vs. induction es; intros. - destruct vs. 2: discriminate. @@ -2863,15 +3311,15 @@ Proof. Qed. Lemma translate_pexpr_correct : - ∀ fn (e : pexpr) s₁ v (cond : heap → Prop), + ∀ (e : pexpr) s₁ v (cond : heap → Prop) m_id s_id s_st st, sem_pexpr gd s₁ e = ok v → - (∀ m, cond m → rel_estate s₁ fn m) → + (∀ m, cond m → rel_estate s₁ m_id s_id s_st st m) → ⊢ ⦃ cond ⦄ - (translate_pexpr fn e).π2 ⇓ + (translate_pexpr m_id e).π2 ⇓ coerce_to_choice_type _ (translate_value v) ⦃ cond ⦄. Proof. - intros fn e s1 v cond h1 hcond. + intros e s1 v cond m_id s_id s_st st h1 hcond. induction e as [z|b| |x|aa ws x e| | | | | | ] in s1, v, h1, cond, hcond |- *. - simpl in h1. noconf h1. rewrite coerce_to_choice_type_K. @@ -2898,8 +3346,10 @@ Proof. intro v. apply u_ret. intros m [hm e]. unfold u_get in e. subst. split. 1: assumption. - apply hcond in hm. destruct hm as [hm hv]. - apply hv in e1. rewrite e1. + apply hcond in hm. + destruct hm as [hm hst]. + invert_stack hst hst hevm hpre hdisj hvalid hnin hnodup hvalid1 hpre1 hdisj1 hdisj2. + apply hevm in e1. rewrite e1. simpl. rewrite coerce_to_choice_type_K. rewrite coerce_to_choice_type_translate_value_to_val. reflexivity. @@ -2908,7 +3358,7 @@ Proof. apply u_ret. auto. - simpl in *. jbind h1 nt ent. destruct nt. all: try discriminate. - jbind h1 i ei. jbind ei i' ei'. + jbind h1 j ej. jbind ej j' ej'. jbind h1 w ew. noconf h1. rewrite coerce_to_choice_type_K. eapply u_bind. @@ -2928,7 +3378,7 @@ Proof. - (* Psub *) simpl. simpl in h1. jbind h1 nt hnt. destruct nt. all: try discriminate. - jbind h1 i hi. jbind hi i' hi'. jbind h1 t ht. noconf h1. + jbind h1 j hj. jbind hj j' hj'. jbind h1 t ht. noconf h1. eapply u_bind. 1:{ eapply translate_gvar_correct. all: eauto. } rewrite bind_assoc. @@ -2965,6 +3415,9 @@ Proof. rewrite coerce_to_choice_type_K. erewrite translate_to_word. 2: eassumption. eapply hcond in hm. + assert (hm2:=hm). + destruct hm2 as [hm2 hst]. + invert_stack hst hst hevm hpre hdisj hvalid hnin hnodup hvalid1 hpre1 hdisj1 hdisj2. erewrite get_var_get_heap. 2-3: eassumption. simpl. erewrite <- type_of_get_var. 2: eassumption. rewrite coerce_to_choice_type_K. @@ -2983,7 +3436,7 @@ Proof. jbind h1 v'' h3. noconf h1. rewrite coerce_to_choice_type_translate_value_to_val. - apply translate_pexpr_type with (fn:=fn) in h2. + apply translate_pexpr_type with (p:=m_id) in h2. rewrite h2. rewrite !coerce_to_choice_type_K. erewrite translate_of_val. @@ -3009,8 +3462,8 @@ Proof. jbind h1 v''''' h6. noconf h1. rewrite coerce_to_choice_type_translate_value_to_val. - apply translate_pexpr_type with (fn:=fn) in h2. - apply translate_pexpr_type with (fn:=fn) in h3. + apply translate_pexpr_type with (p:=m_id) in h2. + apply translate_pexpr_type with (p:=m_id) in h3. rewrite h2 h3. rewrite !coerce_to_choice_type_K. erewrite translate_of_val. @@ -3091,14 +3544,14 @@ Proof. apply translate_truncate_val. assumption. Qed. -Lemma translate_pexprs_correct fn s vs es : +Lemma translate_pexprs_correct s m_id s_id s_st st vs es : sem_pexprs gd s es = ok vs → List.Forall2 (λ c v, - ⊢ ⦃ rel_estate s fn ⦄ + ⊢ ⦃ rel_estate s m_id s_id s_st st ⦄ c.π2 ⇓ coerce_to_choice_type _ (translate_value v) - ⦃ rel_estate s fn ⦄ - ) [seq translate_pexpr fn e | e <- es] vs. + ⦃ rel_estate s m_id s_id s_st st ⦄ + ) [seq translate_pexpr m_id e | e <- es] vs. Proof. intro hvs. induction es in vs, hvs |- *. @@ -3117,20 +3570,20 @@ Proof. rewrite map_cons. constructor. * eapply translate_pexpr_correct. 1: eassumption. - auto. + eauto. * eapply IHes. assumption. Qed. Corollary bind_list_pexpr_correct (cond : heap → Prop) (es : pexprs) (vs : list value) - (s1 : estate) (fn : funname) - (hc : ∀ m : heap, cond m → rel_estate s1 fn m) + (s1 : estate) m_id s_id s_st st + (hc : ∀ m : heap, cond m → rel_estate s1 m_id s_id s_st st m) (h : sem_pexprs gd s1 es = ok vs) : ⊢ ⦃ cond ⦄ - bind_list [seq translate_pexpr fn e | e <- es] ⇓ + bind_list [seq translate_pexpr m_id e | e <- es] ⇓ [seq totce (translate_value v) | v <- vs] - ⦃ cond ⦄. + ⦃ cond ⦄. Proof. eapply bind_list_correct with (vs := vs). - rewrite <- map_comp. @@ -3153,17 +3606,17 @@ Proof. Qed. Corollary translate_pexpr_correct_cast : - ∀ fn (e : pexpr) s₁ v (cond : heap → Prop), + ∀ (e : pexpr) s₁ v m_id s_id s_st st (cond : heap → Prop), sem_pexpr gd s₁ e = ok v → - (∀ m, cond m → rel_estate s₁ fn m) → + (∀ m, cond m → rel_estate s₁ m_id s_id s_st st m) → ⊢ ⦃ cond ⦄ - coerce_typed_code _ (translate_pexpr fn e) ⇓ + coerce_typed_code _ (translate_pexpr m_id e) ⇓ translate_value v ⦃ cond ⦄. Proof. - intros fn e s v cond he hcond. - eapply translate_pexpr_correct with (fn := fn) in he as h. 2: exact hcond. - eapply translate_pexpr_type with (fn := fn) in he. + intros e s v m_id s_id s_st st cond he hcond. + eapply translate_pexpr_correct in he as h. 2: exact hcond. + eapply translate_pexpr_type with (p := m_id) in he. unfold choice_type_of_val in he. destruct (translate_pexpr) as [? exp] eqn:?. simpl in *. subst. rewrite coerce_to_choice_type_K in h. @@ -3172,11 +3625,11 @@ Qed. Lemma translate_write_correct : - ∀ fn sz s p (w : word sz) cm (cond : heap → Prop), - (∀ m, cond m → write s.(emem) p w = ok cm ∧ rel_estate s fn m) → - ⊢ ⦃ cond ⦄ translate_write p w ⇓ tt ⦃ rel_estate {| emem := cm ; evm := s.(evm) |} fn ⦄. + ∀ sz s ptr (w : word sz) cm m_id s_id s_st st (cond : heap → Prop), + (∀ m, cond m → write s.(emem) ptr w = ok cm ∧ rel_estate s m_id s_id s_st st m) → + ⊢ ⦃ cond ⦄ translate_write ptr w ⇓ tt ⦃ rel_estate {| emem := cm ; evm := s.(evm) |} m_id s_id s_st st ⦄. Proof. - intros fn sz s p w cm cond h. + intros sz s ptr w cm m_id s_id s_st st cond h. unfold translate_write. eapply u_get_remember. intros m. eapply u_put. @@ -3187,27 +3640,25 @@ Proof. eapply translate_write_estate. all: assumption. Qed. -Lemma translate_write_var_estate : - ∀ fn i v s1 s2 m, - write_var i v s1 = ok s2 → - rel_estate s1 fn m → - rel_estate s2 fn (set_heap m (translate_var fn i) (truncate_el i.(vtype) (translate_value v))). +Lemma valid_stack_set_var i v vm s m_id s_id s_st st m : + valid_stack ((s.(evm), m_id, s_id, s_st) :: st) m -> + set_var (evm s) i v = ok vm -> + valid_stack ((vm, m_id, s_id, s_st) :: st) (set_heap m (translate_var m_id i) (truncate_el (vtype i) (translate_value v))). Proof. - intros fn i v s1 s2 m hw [h1 h2]. - unfold write_var in hw. jbind hw vm hvm. noconf hw. - split. all: simpl. - - intros ptr v' er. - eapply h1 in er. - rewrite get_set_heap_neq. 2: apply mem_loc_translate_var_neq. - assumption. - - intros vi v' ev. - eapply set_varP. 3: exact hvm. - + intros v₁ hv₁ eyl. subst. - destruct (vi == i) eqn:evar. + intros vs hsv. + assert (vs':=vs). + invert_stack vs hst hevm hpre hdisj hvalid hnin hnodup hvalid1 hpre1 hdisj1 hdisj2. + eapply set_varP. 3: exact hsv. + - intros v1 hv1 eyl; subst. + eapply valid_stack_cons; eauto. + + eapply valid_stack_set_heap. + eassumption. + + intros vi vt ev. + destruct (vi == i) eqn:evar. all: move: evar => /eqP evar. * subst. rewrite Fv.setP_eq in ev. noconf ev. rewrite get_set_heap_eq. rewrite coerce_to_choice_type_K. - eapply translate_of_val in hv₁ as e. + eapply translate_of_val in hv1 as e. rewrite e. apply coerce_to_choice_type_translate_value_to_val. * rewrite Fv.setP_neq in ev. 2:{ apply /eqP. eauto. } @@ -3217,8 +3668,17 @@ Proof. apply injective_translate_var in ee. contradiction. } - eapply h2 in ev. assumption. - + intros hbo hyl hset. subst. + eapply hevm in ev. assumption. + + eapply valid_set_heap_prec; auto. + + intros s_id' s_in'. + eapply valid_set_heap_prec. + 1: apply hvalid1; auto. + apply hpre1. assumption. + - intros hbo hyl hset; subst. + eapply valid_stack_cons; auto. + + eapply valid_stack_set_heap. + eassumption. + + intros vi vt ev. destruct (vi == i) eqn:evar. all: move: evar => /eqP evar. 1:{ @@ -3233,18 +3693,40 @@ Proof. apply injective_translate_var in ee. contradiction. } - eapply h2 in ev. assumption. + eapply hevm in ev. assumption. + + eapply valid_set_heap_prec; auto. + + intros s_id' s_in'. + eapply valid_set_heap_prec. + 1: apply hvalid1; auto. + apply hpre1. assumption. +Qed. + +Lemma translate_write_var_estate : + ∀ i v s1 s2 m_id s_id s_st st m, + write_var i v s1 = ok s2 → + rel_estate s1 m_id s_id s_st st m → + rel_estate s2 m_id s_id s_st st (set_heap m (translate_var m_id i) (truncate_el i.(vtype) (translate_value v))). +Proof using asm_correct gd. + intros i v s1 s2 m_id s_id s_st st m hw [hmem hst]. + unfold write_var in hw. jbind hw vm hvm. noconf hw. + all: simpl. + split. + - intros ptr v' er. + eapply hmem in er. + rewrite get_set_heap_neq. 2: apply mem_loc_translate_var_neq. + assumption. + - eapply valid_stack_set_var; eauto. Qed. Lemma translate_write_var_correct : - ∀ es₁ es₂ fn y v, + ∀ es₁ es₂ m_id s_id s_st st y v, write_var y v es₁ = ok es₂ → - ⊢ ⦃ rel_estate es₁ fn ⦄ - translate_write_var fn y (totce (translate_value v)) + ⊢ ⦃ rel_estate es₁ m_id s_id s_st st ⦄ + translate_write_var m_id y (totce (translate_value v)) ⇓ tt - ⦃ rel_estate es₂ fn ⦄. -Proof. - intros es₁ es₂ fn y v hw. + ⦃ rel_estate es₂ m_id s_id s_st st ⦄. +Proof using asm_correct gd. + intros es₁ es₂ m_id s_id s_st st y v hw. simpl. unfold translate_write_var. simpl in hw. simpl. eapply u_put. @@ -3254,14 +3736,14 @@ Proof. Qed. Lemma translate_write_lval_correct : - ∀ es₁ es₂ fn y v, + ∀ es₁ es₂ m_id s_id s_st st y v, write_lval gd y v es₁ = ok es₂ → - ⊢ ⦃ rel_estate es₁ fn ⦄ - translate_write_lval fn y (totce (translate_value v)) + ⊢ ⦃ rel_estate es₁ m_id s_id s_st st ⦄ + translate_write_lval m_id y (totce (translate_value v)) ⇓ tt - ⦃ rel_estate es₂ fn ⦄. -Proof. - intros es₁ es₂ fn y v hw. + ⦃ rel_estate es₂ m_id s_id s_st st ⦄. +Proof using asm_correct. + intros es₁ es₂ m_id s_id s_st st y v hw. destruct y as [ | yl | | aa ws x ei | ] eqn:case_lval. - simpl. apply u_ret_eq. intros hp hr. @@ -3281,7 +3763,7 @@ Proof. 1:{ eapply translate_pexpr_correct. - eassumption. - - intros ? []. assumption. + - intros ? []. eassumption. } simpl. eapply translate_write_correct. intros m' [hm' em']. @@ -3292,7 +3774,9 @@ Proof. eapply translate_to_word in hw' as ew. rewrite ew. clear ew. unfold translate_to_pointer. simpl. eapply translate_to_word in hve as ew. rewrite ew. clear ew. - erewrite get_var_get_heap. 2,3: eassumption. + erewrite get_var_get_heap. + 3: eapply invert_valid_stack; apply hm'. + 2: eassumption. simpl. erewrite <- type_of_get_var. 2: eassumption. rewrite coerce_to_choice_type_K. eapply translate_to_word in hvx as ew. rewrite ew. clear ew. @@ -3307,7 +3791,7 @@ Proof. 1:{ eapply translate_pexpr_correct. - eassumption. - - intros ? []. assumption. + - intros ? []. eassumption. } simpl. unfold translate_write_var. simpl. eapply u_put. @@ -3318,13 +3802,16 @@ Proof. rewrite !coerce_to_choice_type_K. eapply translate_to_word in ew. rewrite ew. erewrite translate_to_int. 2: eassumption. - erewrite get_var_get_heap. 2,3: eassumption. + erewrite get_var_get_heap. + 3: eapply invert_valid_stack; apply hs. + 2: eassumption. Opaque translate_value. simpl. Transparent translate_value. eapply type_of_get_var in hnt as ety. simpl in ety. apply (f_equal encode) in ety. simpl in ety. rewrite -ety. rewrite !coerce_to_choice_type_K. erewrite chArray_set_correct. 2: eassumption. - eapply translate_write_var_estate in hs. 2: eassumption. + eapply translate_write_var_estate in hs. + 2: eassumption. assumption. - simpl. simpl in hw. jbind hw nt hnt. destruct nt. all: try discriminate. @@ -3336,7 +3823,7 @@ Proof. 1:{ eapply translate_pexpr_correct. - eassumption. - - intros ? []. assumption. + - intros ? []. eassumption. } unfold translate_write_var. simpl. eapply u_put. @@ -3347,27 +3834,30 @@ Proof. rewrite !coerce_to_choice_type_K. erewrite translate_to_int. 2: eassumption. erewrite translate_to_arr. 2: eassumption. - erewrite get_var_get_heap. 2,3: eassumption. + erewrite get_var_get_heap. + 3: eapply invert_valid_stack; apply hs. + 2: eassumption. Opaque translate_value. simpl. Transparent translate_value. eapply type_of_get_var in hnt as ety. simpl in ety. apply (f_equal encode) in ety. simpl in ety. rewrite -ety. rewrite !coerce_to_choice_type_K. erewrite chArray_set_sub_correct. 2: eassumption. - eapply translate_write_var_estate in hs. 2: eassumption. + eapply translate_write_var_estate in hs. + 2: eassumption. assumption. Qed. -Lemma translate_write_lvals_cons fn l ls v vs : - translate_write_lvals fn (l :: ls) (v :: vs) = (translate_write_lval fn l v ;; translate_write_lvals fn ls vs). +Lemma translate_write_lvals_cons p l ls v vs : + translate_write_lvals p (l :: ls) (v :: vs) = (translate_write_lval p l v ;; translate_write_lvals p ls vs). Proof. reflexivity. Qed. -Lemma translate_write_lvals_correct fn s1 ls vs s2 : +Lemma translate_write_lvals_correct m_id s_id s_st st s1 ls vs s2 : write_lvals gd s1 ls vs = ok s2 → - ⊢ ⦃ rel_estate s1 fn ⦄ - translate_write_lvals fn ls [seq totce (translate_value v) | v <- vs] + ⊢ ⦃ rel_estate s1 m_id s_id s_st st ⦄ + translate_write_lvals m_id ls [seq totce (translate_value v) | v <- vs] ⇓ tt - ⦃ rel_estate s2 fn ⦄. -Proof. + ⦃ rel_estate s2 m_id s_id s_st st ⦄. +Proof using asm_correct. intros h. induction ls as [| l ls] in s1, vs, h |- *. - destruct vs. 2: discriminate. @@ -3380,25 +3870,25 @@ Proof. rewrite translate_write_lvals_cons. eapply u_bind. + eapply translate_write_lval_correct. - eassumption. + all: eassumption. + apply IHls. assumption. Qed. -Lemma translate_write_vars_cons fn l ls v vs : - translate_write_vars fn (l :: ls) (v :: vs) = - (translate_write_var fn l v ;; translate_write_vars fn ls vs). +Lemma translate_write_vars_cons p l ls v vs : + translate_write_vars p (l :: ls) (v :: vs) = + (translate_write_var p l v ;; translate_write_vars p ls vs). Proof. reflexivity. Qed. -Lemma translate_write_vars_correct fn s1 ls vs s2 : +Lemma translate_write_vars_correct m_id s_id s_st st s1 ls vs s2 : write_vars ls vs s1 = ok s2 → - ⊢ ⦃ rel_estate s1 fn ⦄ - translate_write_vars fn ls [seq totce (translate_value v) | v <- vs] + ⊢ ⦃ rel_estate s1 m_id s_id s_st st ⦄ + translate_write_vars m_id ls [seq totce (translate_value v) | v <- vs] ⇓ tt - ⦃ rel_estate s2 fn ⦄. -Proof. + ⦃ rel_estate s2 m_id s_id s_st st ⦄. +Proof using asm_correct gd. intros h. induction ls as [| l ls] in s1, vs, h |- *. - destruct vs. 2: discriminate. @@ -3412,7 +3902,7 @@ Proof. eapply u_bind. + simpl. eapply translate_write_var_correct. - eassumption. + all: eassumption. + apply IHls. assumption. Qed. @@ -3736,34 +4226,38 @@ Lemma tr_prog_inv {P fn f} : get_fundef (p_funcs P) fn = Some f → ∑ fs' l, p_funcs P = l ++ (fn, f) :: fs' ∧ - assoc (translate_prog' P).1 fn = - Some (translate_cmd P (translate_funs P fs').1 fn (f_body f)) ∧ - assoc (translate_prog' P).2 fn = - let tr_fs' := translate_funs P ((fn, f) :: fs') in - Some (translate_call P fn tr_fs'.1). + assoc (translate_prog' P).1 fn = Some (fun sid => (translate_cmd P (translate_funs P fs').1 (f_body f) sid sid).2) /\ + assoc (translate_prog' P).2 fn = Some (translate_call P fn (translate_funs P ((fn, f) :: fs')).1). Proof. unfold translate_prog'. induction (p_funcs P) as [|[gn g] fs' ih_fs']. - move => //. - - simpl in *. + - (* simpl in *. *) move => h //. + simpl in h. destruct (fn == gn) eqn:e. - + move /eqP in e. subst. + + move /eqP in e. + subst. noconf h. exists fs'. exists [::]. + (* exists (fun p => (translate_cmd P (translate_funs P fs').1 p (f_body f) p p)). *) + simpl. + destruct (translate_funs P fs') as [f_body f_prog] eqn:E2. simpl. unfold translate_call. simpl. assert (E : gn == gn) by now apply /eqP. rewrite E. easy. + specialize (ih_fs' h). - destruct ih_fs' as [fs'0 [l0 [ihl iha]]]. + simpl. + destruct (translate_funs P fs') as [fdefs ctrrogs] eqn:E2. + destruct ih_fs' as [fs'0 [l0 [ihl [iha ihb]]]]. simpl. + rewrite e. rewrite ihl. exists fs'0. exists ((gn, g) :: l0). - subst. split; easy. + subst. split; [|split]; try easy. Qed. - (** Handled programs This predicate eliminates programs that are currently not supported by the @@ -3818,6 +4312,7 @@ Proof. unfold translate_call at 1. rewrite ef. simpl. + destruct (translate_funs P fs'). simpl. unfold translate_call, assoc at 1. assert (E : gn == gn) by now apply /eqP. now rewrite E. From b406c6107a4f26c7230de733af84241165325630 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Wed, 29 Jun 2022 13:42:11 +0200 Subject: [PATCH 261/383] refactor main proof and main statement to new relation --- theories/Jasmin/jasmin_translate.v | 567 ++++++++++++++++++++--------- 1 file changed, 399 insertions(+), 168 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 5c31ce51..22c790dd 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -4318,232 +4318,463 @@ Proof. now rewrite E. Qed. -Definition Pfun (P : uprog) (fn : funname) m va m' vr := - handled_program P → - ⊢ ⦃ rel_mem m ⦄ +Context `{asm_correct : ∀ o, sem_correct (tin (get_instr_desc (Oasm o))) (sopn_sem (Oasm o))}. +Context (gd : glob_decls). + +Lemma translate_instr_r_if P SP e c1 c2 id sid : + translate_instr_r P SP (Cif e c1 c2) id sid = + let (sid', c1') := translate_cmd P SP c1 id sid in + let (sid'', c2') := translate_cmd P SP c2 id sid' in + let e' := translate_pexpr (p_globs P) id e in + let rb := coe_tyc 'bool e' in (sid'', b ← rb ;; + if b + then c1' + else c2'). +Proof. reflexivity. Qed. + +Lemma translate_instr_r_for P SP i r c id sid : + translate_instr_r P SP (Cfor i r c) id sid = + let '(d, lo, hi) := r in + let (sid', fresh) := fresh_id sid in + let loᵗ := coe_tyc 'int (translate_pexpr (p_globs P) id lo) in + let hiᵗ := coe_tyc 'int (translate_pexpr (p_globs P) id hi) in + let cᵗ := translate_cmd P SP c id in (sid', vlo ← loᵗ ;; + vhi ← hiᵗ ;; + translate_for i (wrange d vlo vhi) id cᵗ fresh). +Proof. reflexivity. Qed. + +Ltac invert_stack st hst hevm hpre hdisj hvalid hnin hnodup hvalid1 hpre1 hdisj1 hdisj2 := apply invert_valid_stack in st as [hst [hevm [hpre [hdisj [hvalid [hnin [hnodup [hvalid1 [hpre1 [hdisj1 hdisj2]]]]]]]]]]. + +Lemma valid_stack_prec vm m_id s_id1 s_id2 s_st st h : + s_id1 ⪯ s_id2 -> + valid_stack ((vm, m_id, s_id1, s_st) :: st) h -> + valid_stack ((vm, m_id, s_id2, s_st) :: st) h. +Proof. + intros hpre12 vst. + invert_stack vst hst hevm hpre hdisj hvalid hnin hnodup hvalid1 hpre1 hdisj1 hdisj2. + eapply valid_stack_cons; eauto with prefix. + - eapply valid_prec; eauto. + - intros contra. + eapply disj_antirefl. + eapply disj_prec_r. + 1: eapply hpre12. + apply disj_sym. + apply hdisj1. + assumption. + - intros s_id' s_in'. + eapply disj_prec_l. + 1: eapply hpre12. + apply hdisj1. + assumption. +Qed. + +Lemma rel_estate_prec : forall h s m_id s_id1 s_id2 s_st st, + s_id1 ⪯ s_id2 -> + rel_estate s m_id s_id1 s_st st h -> + rel_estate s m_id s_id2 s_st st h. +Proof. + intros h s m_id s_id1 s_id2 s_st st hpre12 [hmem hstack]; split; auto. + eapply valid_stack_prec; eauto. +Qed. + +Lemma rel_estate_pop_sub s m_id s_id s_id' s_st st : + ∀ h, rel_estate s m_id s_id (s_id' :: s_st) st h → rel_estate s m_id s_id' s_st st h. +Proof. + intros h [hmem hstack]. + split. + - assumption. + - eapply valid_stack_pop_sub; eassumption. +Qed. + +Lemma rel_estate_pop m vm vm' m_id m_id' s_id s_id' s_st s_st' st : + ∀ h, rel_estate {| emem := m ; evm := vm |} m_id s_id s_st ((vm',m_id',s_id',s_st') :: st) h → + rel_estate {| emem := m ; evm := vm' |} m_id' s_id' s_st' st h. +Proof. + intros h [hmem hstack]. + split. + - assumption. + - eapply valid_stack_pop; eassumption. +Qed. + +Lemma rel_estate_push_sub s m_id s_id s_st st : + ∀ h : heap, rel_estate s m_id s_id s_st st h → + rel_estate s m_id s_id~1 (s_id~0 :: s_st) st h. +Proof. + intros h [hmem hstack]; split. + - assumption. + - eapply valid_stack_push_sub; eassumption. +Qed. + +Lemma rel_estate_push m vm m_id s_id s_st st : + ∀ h : heap, rel_estate {| emem := m ; evm := vm |} m_id s_id s_st st h → + rel_estate {| emem := m ; evm := vmap0 |} s_id~1 s_id~1 [::] ((vm, m_id, s_id~0, s_st) :: st) h. +Proof. + intros h [hmem hstack]; split. + - assumption. + - eapply valid_stack_push; eassumption. +Qed. + +Lemma translate_cmd_preceq P SP c m_id s_id : + let (s_id', _) := translate_cmd P SP c m_id s_id in s_id ⪯ s_id'. +Proof. + revert s_id. + set (Pr := fun (i : instr_r) => + forall s_id, let (s_id', _) := translate_instr_r P SP i m_id s_id in + s_id ⪯ s_id'). + set (Pi := fun (i : instr) => + Pr (instr_d i)). + set (Pc := fun (c : cmd) => + forall s_id, + let (s_id', _) := translate_cmd P SP c m_id s_id in + s_id ⪯ s_id'). + eapply cmd_rect with + (Pr0 := Pr) + (Pi0 := Pi) + (Pc0 := Pc); + try easy + . + - intros s_id. + simpl; reflexivity. + - intros i c0 ihi ihc s_id. + simpl. + rewrite translate_instr_unfold. + specialize (ihi s_id). + destruct translate_instr_r as [s_id' ?]. + specialize (ihc s_id'). + destruct translate_cmd. + etransitivity; eauto. + - intros x tg ty e i; simpl; reflexivity. + - intros xs t o es i; simpl; reflexivity. + - intros e c1 c2 ihc1 ihc2 s_id. + rewrite translate_instr_r_if. + specialize (ihc1 s_id). + destruct translate_cmd as [s_id' ?]. + specialize (ihc2 s_id'). + destruct translate_cmd as [s_id'' ?]. + simpl. + etransitivity; eauto. + - intros v dir lo hi c' ihc s_id. + rewrite translate_instr_r_for. + simpl. + apply fresh1. + - intros a c1 e c2 ihc1 ihc2 s_id. + simpl; reflexivity. + - intros i xs f es st'. + simpl. + apply fresh1. +Qed. + +Lemma translate_instr_r_preceq P SP i id s_id : + let (s_id', _) := translate_instr_r P SP i id s_id in s_id ⪯ s_id'. +Proof. + revert s_id. + set (Pr := fun (i : instr_r) => + forall s_id, let (s_id', _) := translate_instr_r P SP i id s_id in + s_id ⪯ s_id'). + set (Pi := fun (i : instr) => + Pr (instr_d i)). + set (Pc := fun (c : cmd) => + forall s_id, + let (s_id', _) := translate_cmd P SP c id s_id in + s_id ⪯ s_id'). + eapply instr_r_Rect with + (Pr0 := Pr) + (Pi0 := Pi) + (Pc0 := Pc); + try easy + . + - intros s_id. + simpl; reflexivity. + - intros i' c0 ihi ihc s_id. + simpl. + rewrite translate_instr_unfold. + specialize (ihi s_id). + destruct translate_instr_r as [s_id' ?]. + specialize (ihc s_id'). + destruct translate_cmd. + etransitivity; eauto. + - intros x tg ty e i'; simpl; reflexivity. + - intros xs t o es i'; simpl; reflexivity. + - intros e c1 c2 ihc1 ihc2 s_id. + rewrite translate_instr_r_if. + specialize (ihc1 s_id). + destruct translate_cmd as [s_id' ?]. + specialize (ihc2 s_id'). + destruct translate_cmd as [s_id'' ?]. + simpl. + etransitivity; eauto. + - intros v dir lo hi c' ihc s_id. + rewrite translate_instr_r_for. + simpl. + apply fresh1. + - intros a c1 e c2 ihc1 ihc2 s_id. + simpl; reflexivity. + - intros i' xs f es st'. + simpl. + apply fresh1. +Qed. + +Lemma translate_instr_r_pres P SP c s m_id s_id s_st st h : + let (s_id', _) := translate_instr_r P SP c m_id s_id in + rel_estate s m_id s_id s_st st h -> rel_estate s m_id s_id' s_st st h. +Proof. + pose proof translate_instr_r_preceq P SP c m_id s_id. + destruct translate_instr_r as [s_id' ?]. + apply rel_estate_prec; assumption. +Qed. + +Lemma translate_cmd_pres P SP c s m_id s_id s_st st h : + let (s_id', _) := translate_cmd P SP c m_id s_id in + rel_estate s m_id s_id s_st st h -> rel_estate s m_id s_id' s_st st h. +Proof. + pose proof translate_cmd_preceq P SP c m_id s_id. + destruct translate_cmd as [s_id' ?]. + apply rel_estate_prec; assumption. +Qed. + +Definition Pfun (P : uprog) (fn : funname) m va m' vr vm m_id s_id s_st st := + ⊢ ⦃ rel_estate {| emem := m; evm := vmap0 |} s_id~1 s_id~1 [::] ((vm, m_id, s_id~0, s_st) :: st) ⦄ (* translate_call P fn (translate_prog' P) [seq totce (translate_value v) | v <- va] *) - get_translated_fun P fn [seq totce (translate_value v) | v <- va] + get_translated_fun P fn s_id~1 [seq totce (translate_value v) | v <- va] ⇓ [seq totce (translate_value v) | v <- vr] - ⦃ rel_mem m' ⦄. + ⦃ rel_estate {| emem := m' ; evm := vm |} m_id s_id s_st st ⦄. Theorem translate_prog_correct P m vargs m' vres : ∀ fn, sem.sem_call P m fn vargs m' vres → - Pfun P fn m vargs m' vres. -Proof. + handled_program P -> + ∀ vm m_id s_id s_st st, + Pfun P fn m vargs m' vres vm m_id s_id s_st st. +Proof using asm_correct. intros fn H hP. - set (Pfun := λ (m : mem) (fn : funname) (va : seq value) (m' : mem) (vr : seq value), - Pfun P fn m va m' vr + set (Pfun := λ(m : mem) (fn : funname) (va : seq value) (m' : mem) (vr : seq value), + handled_program P -> forall vm m_id s_id s_st st, Pfun P fn m va m' vr vm m_id s_id s_st st ). set (SP := (translate_prog' P).1). set (Pi_r := - λ (s1 : estate) (i : instr_r) (s2 : estate), - ∀ fn, - handled_instr_r i → - ⊢ ⦃ rel_estate s1 fn ⦄ - translate_instr_r P SP fn i ⇓ tt - ⦃ rel_estate s2 fn ⦄ - ). + λ (s1 : estate) (i : instr_r) (s2 : estate), + ∀ m_id s_id s_st st, + handled_instr_r i → + let (s_id', i') := translate_instr_r P SP i m_id s_id in + ⊢ ⦃ rel_estate s1 m_id s_id s_st st ⦄ + i' ⇓ tt + ⦃ rel_estate s2 m_id s_id' s_st st ⦄). set (Pi := λ s1 i s2, Pi_r s1 (instr_d i) s2). set (Pc := - λ (s1 : estate) (c : cmd) (s2 : estate), - ∀ fn, - handled_cmd c → - ⊢ ⦃ rel_estate s1 fn ⦄ translate_cmd P SP fn c ⇓ tt ⦃ rel_estate s2 fn ⦄ - ). + λ (s1 : estate) (c : cmd) (s2 : estate), + ∀ m_id s_id s_st st, + handled_cmd c → + let (s_id', c') := translate_cmd P SP c m_id s_id in + ⊢ ⦃ rel_estate s1 m_id s_id s_st st ⦄ + c' ⇓ tt + ⦃ rel_estate s2 m_id s_id' s_st st ⦄). set (Pfor := λ (v : var_i) (ws : seq Z) (s1 : estate) (c : cmd) (s2 : estate), - ∀ fn, - handled_cmd c → - ⊢ ⦃ rel_estate s1 fn ⦄ - translate_for fn v ws (translate_cmd P SP fn c) ⇓ tt - ⦃ rel_estate s2 fn ⦄ + ∀ m_id s_id s_id' s_st st, + handled_cmd c → + s_id~1 ⪯ s_id' -> + exists s_id'', + ⊢ ⦃ rel_estate s1 m_id s_id' (s_id~0 :: s_st) st ⦄ + translate_for v ws m_id (translate_cmd P SP c m_id) s_id' ⇓ tt + ⦃ rel_estate s2 m_id s_id'' (s_id~0 :: s_st) st ⦄ ). unshelve eapply (@sem_call_Ind _ _ _ _ Pc Pi_r Pi Pfor Pfun _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H). - (* nil *) - red. intros s. - red. simpl. intros fn' _. - eapply u_ret_eq. auto. + intros s m_id s_id s_st st _. simpl. + eapply u_ret_eq. + intros h preh. auto. - (* cons *) - red. intros s1 s2 s3 i c hi ihi hc ihc fn'. - red. simpl. move /andP => [hdi hdc]. - eapply u_bind. - + rewrite translate_instr_unfold. eapply ihi. - destruct i. apply hdi. - + apply ihc. assumption. + red. + intros s1 s2 s3 i c hi ihi hc ihc m_id s_id s_st st hp. (* sp fp ctr h fp_prec. *) + inversion hp. + move: H1 => /andP [hdi hdc]. + unfold Pi in ihi. unfold Pi_r in ihi. + simpl. + rewrite translate_instr_unfold. + pose proof translate_instr_r_preceq P SP (instr_d i) m_id s_id. + specialize (ihi m_id s_id). + pose proof (translate_instr_r_pres P SP (instr_d i) s1 m_id s_id). + destruct translate_instr_r as [s_id' i'] eqn:E. + unfold Pc in ihc. + specialize (ihc m_id s_id'). + pose proof (translate_cmd_preceq P SP c m_id s_id'). + pose proof (translate_cmd_pres P SP c s1 m_id s_id'). + destruct translate_cmd as [s_id'' c'] eqn:Ec. + split. + + eapply u_bind. + * eapply ihi. + 1: destruct i; apply hdi. + * eapply ihc. + 1: assumption. - (* mkI *) red. intros ii i s1 s2 hi ihi. apply ihi. - (* assgn *) - red. intros s₁ s₂ x tag ty e v v' he hv hw. - red. simpl. intros fn' _. + red. intros s₁ s₂ x tag ty e v v' he hv hw m_id s_id s_st st hp. eapply u_bind. 1:{ eapply translate_pexpr_correct. all: eauto. } erewrite translate_pexpr_type by eassumption. rewrite coerce_to_choice_type_K. - cbn. erewrite totce_truncate_translate by eassumption. - eapply translate_write_lval_correct. all: eauto. + eapply u_post_weaken_rule. + 1: eapply u_pre_weaken_rule. + 1: eapply translate_write_lval_correct. all: eauto. - (* opn *) - red. intros s1 s2 tag o xs es ho fn' _. - red. simpl. + red. + (* easy. *) + intros s1 s2 tag o xs es ho m_id s_id s_st st hp. jbind ho vs hv. jbind hv vs' hv'. eapply u_bind. + eapply bind_list_pexpr_correct. 2: eassumption. - easy. + eauto. + erewrite translate_exec_sopn_correct by eassumption. - apply translate_write_lvals_correct. - assumption. + eapply u_post_weaken_rule. + 1: apply translate_write_lvals_correct. + all: eauto. - (* if_true *) - red. intros s1 s2 e c1 c2 he hc1 ihc1 fn'. - red. simpl. move /andP => [hdc1 hdc2]. - unfold translate_instr_r. - lazymatch goal with - | |- context [ if _ then ?f ?fn ?c else _ ] => - change (f fn c) with (translate_cmd P SP fn c) - end. - eapply u_bind. - 1:{ eapply translate_pexpr_correct_cast in he. all: eauto. } - simpl. apply ihc1. assumption. + intros s1 s2 e c1 c2 he hc1 ihc1 m_id s_id s_st st hp. + inversion hp. + move: H1 => /andP [hdc1 hdc2]. + rewrite translate_instr_r_if. + simpl. + unfold Pc in ihc1. + specialize (ihc1 m_id s_id s_st st). + pose proof translate_cmd_pres P SP c1 s1 m_id s_id s_st st. + destruct (translate_cmd P SP c1 m_id s_id) as [s_id'' c1'] eqn:E1. + pose proof translate_cmd_pres P SP c2 s2 m_id s_id'' s_st st. + destruct (translate_cmd P SP c2 m_id s_id'') as [s_id''' c2'] eqn:E2. + split. + + eapply u_bind. + 1:{ eapply translate_pexpr_correct_cast in he. all: eauto. } + eapply u_post_weaken_rule. + 1: eapply ihc1. + 1: eapply hdc1. + 1: assumption. - (* if_false *) - red. intros s1 s2 e c1 c2 he hc2 ihc2 fn'. - red. simpl. move /andP => [hdc1 hdc2]. - (* lazymatch goal with - | |- context [ if _ then _ else (?f ?fn ?c) ] => - change (f fn c) with (translate_cmd SP fn c) - end. *) + (* easy. *) + intros s1 s2 e c1 c2 he hc2 ihc2 m_id s_id s_st st hp. + inversion hp. + move: H1 => /andP [hdc1 hdc2]. + rewrite translate_instr_r_if. + simpl. + unfold Pc in ihc2. + pose proof translate_cmd_pres P SP c1 s1 m_id s_id s_st st. + destruct (translate_cmd P SP c1 m_id s_id) as [s_id'' c1'] eqn:E1. + specialize (ihc2 m_id s_id'' s_st st). + destruct (translate_cmd P SP c2 m_id s_id'') as [s_id''' c2'] eqn:E2. eapply u_bind. 1:{ eapply translate_pexpr_correct_cast in he. all: eauto. } - simpl. apply ihc2. assumption. + eapply u_pre_weaken_rule. + 1: eapply u_post_weaken_rule. + 1: eapply ihc2. + 1: assumption. + 1: { intros h rel. eapply rel_estate_prec. 1:reflexivity. 1: eassumption. } + assumption. - (* while_true *) - red. intros s1 s2 s3 s4 a c e c' hc ihc he hc' ihc' h ih. - red. simpl. discriminate. + easy. - (* while_false *) - red. intros s1 s2 a c e c' hc ihc he. - red. simpl. discriminate. + easy. - (* for *) - red. intros s1 s2 i d lo hi c vlo vhi hlo hhi hfor ihfor fn'. - red. simpl. intros hdc. - unfold translate_instr_r. - lazymatch goal with - | |- context [ translate_for _ _ _ (?f ?fn ?c) ] => - change (f fn c) with (translate_cmd P SP fn c) - end. + intros s s2 i d lo hi c vlo vhi hlo hhi hfor ihfor m_id s_id s_st st hp. + rewrite translate_instr_r_for. eapply u_bind. 1:{ eapply translate_pexpr_correct_cast in hlo. all: eauto. } eapply u_bind. 1:{ eapply translate_pexpr_correct_cast in hhi. all: eauto. } - apply ihfor. assumption. + unfold Pfor in ihfor. + simpl in ihfor. + specialize (ihfor m_id s_id s_id~1 s_st st ltac:(apply hp) ltac:(reflexivity)). + destruct ihfor as [s_id'']. + eapply u_pre_weaken_rule. + 1: eapply u_post_weaken_rule. + 1: exact H0. + 1: apply rel_estate_pop_sub. + apply rel_estate_push_sub. - (* for_nil *) - red. intros. red. intros hdc fn'. - simpl. apply u_ret_eq. auto. + intros s i c m_id s_id s_id' s_st st hdc hpre. + simpl. + exists s_id'. + apply u_ret_eq. + easy. - (* for_cons *) - red. intros s1 s1' s2 s3 i w ws c hw hc ihc hfor ihfor fn'. - red. simpl. intros hdc. + intros s1 s1' s2 s3 i w ws c hw hc ihc hfor ihfor m_id s_id s_id' s_st st hdc hpre. + simpl. + specialize (ihc m_id s_id' (s_id~0 :: s_st) st hdc). + pose proof translate_cmd_preceq P SP c m_id s_id'. + destruct translate_cmd as [s_id'' c'] eqn:E. + specialize (ihfor m_id s_id s_id'' s_st st hdc ltac:(etransitivity;eauto)) as [s_id''' ihfor]. + exists s_id'''. eapply u_put. - eapply u_bind. - 1:{ - red in ihc. eapply u_pre_weaken_rule. - 1: eapply ihc. 1: assumption. + eapply u_pre_weaken_rule. + 2: { intros ? [me [hme ?]]. subst. - eapply translate_write_var_estate. all: eassumption. + eapply translate_write_var_estate. all: try eassumption. } - apply ihfor. assumption. + eapply u_bind. + 1: eapply ihc. + eapply ihfor. - (* call *) - red. - clear H vargs vres. - intros s1 m2 s2 ii xs gn args vargs vres hargs hgn ihgn hwr_vres fn'. + intros s1 m2 s2 ii xs gn args vargs' vres' hargs hgn ihgn hwr_vres m_id s_id s_st st hdi. unfold Pfun, Translation.Pfun, get_translated_fun in ihgn. - red. simpl. intros _. unfold translate_instr_r. + simpl. eapply u_bind. - 1: eapply bind_list_pexpr_correct; try eassumption; easy. - eapply u_bind with (v₁ := [seq totce (translate_value v) | v <- vres]) - (q := rel_mem m2). - * unshelve eapply u_pre_weaken_rule with (p1 := (rel_mem (emem s1))). - 2: move => h Hh; apply Hh. - unfold SP in *. clear SP. - specialize (ihgn hP). - unfold translate_prog'. - destruct (sem_call_get_some hgn) as [f hf]. + 1: eapply bind_list_pexpr_correct with (s_id0:=s_id) (s_st0:=s_st) (st0:=st); try eassumption; easy. + eapply u_bind with (v₁ := [seq totce (translate_value v) | v <- vres']). + 1: specialize (ihgn hP (evm s1) m_id s_id s_st st). + 1: eapply u_pre_weaken_rule. + * destruct (sem_call_get_some hgn) as [f hf]. destruct (tr_prog_inv hf) as [fs' [l [hl [ef ep]]]]. simpl in ep. rewrite ep in ihgn. pose (translate_call_head ef) as hc. rewrite hc. - apply ihgn. - * (* Should be similar to Copn, by appealing to correctness of - write_lvals, expect that we also need to restore `evm s1`. *) - clear ihgn. - unshelve eapply u_pre_weaken_rule with - (p1 := (rel_estate {| emem := m2; evm := evm s1 |} fn')). + eapply ihgn. + * eapply rel_estate_push. + * eapply u_pre_weaken_rule. -- eapply translate_write_lvals_correct. + 1:assumption. exact hwr_vres. - -- intros h hm. unfold rel_estate. split; try easy. - simpl. unfold rel_vmap. - give_up. + -- intros h. eapply rel_estate_prec. + apply fresh1. - (* proc *) - rename fn into fn_ambient. - rename vargs into vargs_amb. rename vres into vres_amb. - unfold sem_Ind_proc. red. intros m1 m2 gn g vargs vargs' s1 vm2 vres vres'. + intros m1 m2 gn g vargs' vargs'' s1 vm2 vres' vres''. intros hg hvars hwr hbody ihbody hget htrunc. - unfold Translation.Pfun. intros hp. - + intros hp vm m_id s_id s_st st. + unfold Translation.Pfun. unfold get_translated_fun. - destruct (tr_prog_inv hg) as [fs' [l [hl [ef ep]]]]. - unfold translate_prog' in ep. + destruct (tr_prog_inv hg) as [fs' [l [hl ]]]. + unfold Pc, SP, translate_prog' in ihbody. + unfold translate_prog' in *. + rewrite hl in ihbody. + rewrite hl. + destruct H0 as [ef ep]. + rewrite hl in ef. + rewrite hl in ep. + subst SP. rewrite ep. unfold translate_call. simpl. + destruct (translate_funs P fs') as [tr_fs' tsp'] eqn:Efuns. + simpl. assert (E : gn == gn) by now apply /eqP. rewrite E; clear E. unfold translate_call_body. rewrite hg. - eapply u_bind with (v₁ := tt) (q := rel_estate s1 gn). + eapply u_bind. 1: { - (* PGH: `translate_write_vars_correct` expects some `rel_estate` - as pre, but we only have `rel_mem m1`. - We strengthen the precondition, and show that - `rel_mem m1 => rel_estate (Estate m1 vmap0)` - *) - unshelve eapply u_pre_weaken_rule. - - exact (rel_estate (Estate m1 vmap0) gn). - - simpl. - assert - (Htr : (trunc_list (f_tyin g) - [seq totce (translate_value v) | v <- vargs']) - = [seq totce (translate_value v) | v <- vargs]) - by admit. - rewrite Htr. - now eapply translate_write_vars_correct. - - intros h hmem. - unfold rel_estate, rel_vmap. - split; auto. intros i v hvm. - rewrite coerce_to_choice_type_K. - simpl in hvm. - unfold vmap0 in hvm. - rewrite Fv.get0 in hvm. - (* We're reading an undefined address, and getting an `ok v`; - surely we can invert and exfalso on that. *) - unfold undef_addr in hvm. - (* It's not going to work on arrays. This is dumb. - Why did they define it like that? Is this really a - good spec for a memory model? *) - unfold translate_var. - destruct (vtype i); unfold undef_error in hvm; - try now inversion hvm. - noconf hvm. simpl. - (* Seems like we're forced to prove that h is the empty heap. - Maybe backtrack and think about an alternative to showing the - implication between the preconditions. Or convince Jasmin dev - to change their definition. *) - assert (hh : h = empty_heap) by give_up. - rewrite hh. - rewrite get_empty_heap. - simpl. easy. + 1: { + assert + (Htr : (trunc_list (f_tyin g) + [seq totce (translate_value v) | v <- vargs'']) + = [seq totce (translate_value v) | v <- vargs']) + by admit. + rewrite Htr. + eapply translate_write_vars_correct; try eassumption. + } } - eapply u_bind with (v₁ := tt) (q := rel_mem m2). - + unfold Pc, SP, translate_prog' in ihbody. + eapply u_bind with (v₁ := tt). + + unfold Pc, translate_prog' in ihbody. assert (handled_cmd (f_body g)) as hpbody. { clear -hg hp. @@ -4559,23 +4790,22 @@ Proof. This should allow us to use the induction hypothesis on a different function, gn in this case. *) - specialize (ihbody gn hpbody). clear hpbody. - rewrite hl in ihbody. - (* TODO: strengthen post condition to - rel_estate {| emem := m2; evm := vm2 |} gn *) - + specialize (ihbody s_id~1 s_id~1 s_st st hpbody). clear hpbody. + simpl in ihbody. (* maybe something similar to the prove of assert (translate_call P gn (translate_funs P (l ++ ((gn,f) :: fs'))).1 = translate_call P gn (translate_funs P ((gn,f) :: fs')).1) just need to push the (translate_funs ...) in until they get to a funcall? *) - assert (htr : translate_cmd P (translate_funs P (l ++ ((gn,g) :: fs'))).1 gn (f_body g) - = translate_cmd P (translate_funs P ((gn,g) :: fs')).1 gn (f_body g)). + (* assert (htr : translate_cmd P (translate_funs P (l ++ ((gn,g) :: fs'))).1 (f_body g) s_id~1 s_id~1 *) + (* = translate_cmd P (translate_funs P ((gn,g) :: fs')).1 (f_body g) s_id~1 s_id~1). *) + unfold f_body in *. + assert (htr : translate_cmd P (translate_funs P (l ++ ((gn,g) :: fs'))).1 (f_body g) s_id~1 s_id~1 + = translate_cmd P (translate_funs P fs').1 (f_body g) s_id~1 s_id~1). { clear -ef ep hl hg. unfold translate_prog' in ep, ef. - rewrite hl in ep, ef. unfold translate_cmd. unfold translate_instr. simpl in *. @@ -4594,14 +4824,15 @@ Proof. + simpl. rewrite -hl. - - rewrite -ef. - destruct (gn == gn) eqn:E. - 2: { move /eqP in E. exfalso. apply E. reflexivity. } - simpl. admit. + (* rewrite -ef. *) + (* destruct (gn == gn) eqn:E. *) + (* 2: { move /eqP in E. exfalso. apply E. reflexivity. } *) + (* simpl. *) + (* admit. *) } rewrite htr in ihbody. + simpl in ihbody. (* PGH: something about the funnames in H2 and the goal is fishy. *) subst. give_up. From 0adf651feeb6461a55dfd8754c0c396ad06c249b Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Wed, 29 Jun 2022 13:48:45 +0200 Subject: [PATCH 262/383] examples --- theories/Jasmin/examples/bigadd/bigadd.v | 20 ++++++++++++------- .../three_functions/three_functions.v | 13 +++++++----- .../examples/two_functions/two_functions.v | 14 ++++++------- theories/Jasmin/jasmin_utils.v | 2 +- 4 files changed, 29 insertions(+), 20 deletions(-) diff --git a/theories/Jasmin/examples/bigadd/bigadd.v b/theories/Jasmin/examples/bigadd/bigadd.v index 301d67b8..5537492e 100644 --- a/theories/Jasmin/examples/bigadd/bigadd.v +++ b/theories/Jasmin/examples/bigadd/bigadd.v @@ -460,7 +460,6 @@ Definition bigadd := p_globs := []; p_extra := tt |} . - Import PackageNotation. Notation coe_cht := coerce_to_choice_type. Notation coe_tyc := coerce_typed_code. @@ -482,7 +481,7 @@ Set Equations Transparent. From extructures Require Import ord fset fmap. Definition empty_ufun_decl := (1%positive, {| f_info := 1%positive; f_tyin := [::]; f_params := [::]; f_body := [::]; f_tyout := [::]; f_res := [::]; f_extra := tt |}) : _ufun_decl. -Definition translate_simple_prog P := translate_fundef P emptym (List.nth_default empty_ufun_decl P.(p_funcs) 0). +Definition translate_simple_prog P := translate_fundef P emptym 1%positive (List.nth_default empty_ufun_decl P.(p_funcs) 0). Definition fn_bigadd := Eval simpl in ((ffun (translate_simple_prog bigadd).2).π2).π2. @@ -497,7 +496,7 @@ Qed. From CoqWord Require Import word. -Notation "$ i" := (_ ; nat_of_fun_var _ {| vtype := _; vname := i |}) +Notation "$ i" := (_ ; nat_of_p_id_var _ {| vtype := _; vname := i |}) (at level 99, format "$ i"). Notation "$$ i" := ({| v_var := {| vtype := _; vname := i |}; v_info := _ |}) @@ -530,11 +529,13 @@ Goal forall aa goal, fn_bigadd aa = goal. set (yr := $"yr.144"). set (cf := $"cf.145"). set (i := $"i.146"). - set (res := $"res.142"). - setoid_rewrite coerce_to_choice_type_K. - setoid_rewrite coerce_to_choice_type_K. - time repeat setoid_rewrite (@zero_extend_u U64). + (* this hangs *) + (* set (res := $"res.142"). *) + + (* setoid_rewrite coerce_to_choice_type_K. *) + (* setoid_rewrite coerce_to_choice_type_K. *) + (* time repeat setoid_rewrite (@zero_extend_u U64). *) (* For comparison: unfold the for loop *) Transparent translate_for. @@ -543,5 +544,10 @@ Goal forall aa goal, fn_bigadd aa = goal. subst i. set (i := $"i.146"). setoid_rewrite coerce_to_choice_type_K. + setoid_rewrite coerce_to_choice_type_K. + time repeat setoid_rewrite (@zero_extend_u U64). + + (* this still hangs *) + (* set (res := $"res.142"). *) Admitted. diff --git a/theories/Jasmin/examples/three_functions/three_functions.v b/theories/Jasmin/examples/three_functions/three_functions.v index d51c2f8c..0465456a 100644 --- a/theories/Jasmin/examples/three_functions/three_functions.v +++ b/theories/Jasmin/examples/three_functions/three_functions.v @@ -237,8 +237,8 @@ Definition three_functions := Definition tr_P := Eval simpl in translate_prog' three_functions. -Definition default_prog' := (1%positive, (ret tt)). -Definition default_call := (1%positive, fun (x : [choiceType of seq typed_chElement]) => ret x). +Definition default_prog' := (1%positive, fun s_id : p_id => (ret tt)). +Definition default_call := (1%positive, fun (s_id : p_id) (x : [choiceType of seq typed_chElement]) => ret x). Definition get_tr sp n := List.nth_default default_call sp n. Definition tr_f := Eval simpl in (get_tr tr_P.2 2). Definition tr_g := Eval simpl in (get_tr tr_P.2 1). @@ -247,7 +247,7 @@ Definition tr_h := Eval simpl in (get_tr tr_P.2 0). Opaque translate_for. -Goal forall goal v, tr_f.2 [('word U64; v)] = goal . +Goal forall goal v, tr_f.2 1%positive [('word U64; v)] = goal . intros goal v. unfold tr_f. unfold get_tr. unfold tr_P. unfold translate_prog'. @@ -261,7 +261,7 @@ Goal forall goal v, tr_f.2 [('word U64; v)] = goal . Admitted. -Goal forall goal v, tr_g.2 [v] = goal. +Goal forall goal v, tr_g.2 1%positive [v] = goal. intros goal v. unfold tr_g. unfold get_tr. unfold tr_P. @@ -274,10 +274,13 @@ Goal forall goal v, tr_g.2 [v] = goal. Admitted. -Goal forall goal v, tr_h.2 [v] = goal. +Goal forall goal v, tr_h.2 1%positive [v] = goal. intros goal v. unfold tr_h. unfold get_tr. unfold tr_P. + simpl. + unfold translate_call_body. + simpl. simpl_fun. repeat setjvars. diff --git a/theories/Jasmin/examples/two_functions/two_functions.v b/theories/Jasmin/examples/two_functions/two_functions.v index cf2cd2cb..3ba813c5 100644 --- a/theories/Jasmin/examples/two_functions/two_functions.v +++ b/theories/Jasmin/examples/two_functions/two_functions.v @@ -150,13 +150,12 @@ Set Equations Transparent. From extructures Require Import ord fset fmap. Definition tr_P := Eval simpl in tr_p two_functions. -Definition default_prog' := (1%positive, (ret tt)). -Definition default_call := (1%positive, fun (x : [choiceType of seq typed_chElement]) => ret x). +Definition default_prog' := (1%positive, fun s_id : p_id => (ret tt)). +Definition default_call := (1%positive, fun (s_id : p_id) (x : [choiceType of seq typed_chElement]) => ret x). Definition get_tr sp n := List.nth_default default_call sp n. Definition tr_f := Eval simpl in (get_tr tr_P 1). Definition tr_g := Eval simpl in (get_tr tr_P 0). - Lemma eq_rect_K : forall (A : eqType) (x : A) (P : A -> Type) h e, @eq_rect A x P h x e = h. @@ -168,7 +167,7 @@ Qed. From CoqWord Require Import word. -Notation "$ i" := (_ ; nat_of_fun_var _ {| vtype := _; vname := i |}) +Notation "$ i" := (_ ; nat_of_p_id_var _ {| vtype := _; vname := i |}) (at level 99, format "$ i"). Notation "$$ i" := ({| v_var := {| vtype := _; vname := i |}; v_info := _ |}) @@ -179,7 +178,7 @@ Notation "'for var ∈ seq" := (translate_for _ ($$var) seq) (at level 99). Ltac prog_unfold := unfold get_tr, translate_prog', tr_p, translate_prog, - translate_call, + translate_call, translate_call_body, translate_write_lvals, translate_write_var, translate_instr, translate_var, coerce_chtuple_to_list, bind_list', bind_list_trunc_aux, @@ -194,11 +193,12 @@ Ltac simpl_fun := | _ => prog_unfold; simpl end). -Goal forall goal v, tr_g.2 [v] = goal. +Goal forall goal v, tr_g.2 1%positive [v] = goal. intros goal v. unfold tr_g. unfold get_tr. unfold tr_P. simpl_fun. + simpl. (* BSH: the setoid_rewrites takes forever if we do not 'set' these names first *) set (array32 := sarr 32%positive). @@ -214,7 +214,7 @@ Goal forall goal v, tr_g.2 [v] = goal. Admitted. -Goal forall goal v, tr_f.2 [('word U64; v)] = goal . +Goal forall goal v, tr_f.2 1%positive [('word U64; v)] = goal . intros goal v. unfold tr_f. unfold get_tr. unfold tr_P. unfold translate_prog'. diff --git a/theories/Jasmin/jasmin_utils.v b/theories/Jasmin/jasmin_utils.v index a5412919..5d91a381 100644 --- a/theories/Jasmin/jasmin_utils.v +++ b/theories/Jasmin/jasmin_utils.v @@ -18,7 +18,7 @@ Module JasminCodeNotation. (at level 99, no associativity, format " a [ w / p ] "). - Notation "$$ i" := (_ ; nat_of_fun_var _ {| vtype := _; vname := i |}) + Notation "$$ i" := (_ ; nat_of_p_id_var _ {| vtype := _; vname := i |}) (at level 99, format "$$ i"). Notation "$$$ i" := ({| v_var := {| vtype := _; vname := i |}; v_info := _ |}) From 05f6d7918abb19284509a6e7a2217a12fc56efd2 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Wed, 29 Jun 2022 16:19:27 +0200 Subject: [PATCH 263/383] removed simple admits, only remaining is nontrivial --- theories/Jasmin/jasmin_translate.v | 194 ++++++++++++++++++----------- 1 file changed, 119 insertions(+), 75 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 22c790dd..fe672743 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -4533,11 +4533,76 @@ Proof. Qed. Definition Pfun (P : uprog) (fn : funname) m va m' vr vm m_id s_id s_st st := - ⊢ ⦃ rel_estate {| emem := m; evm := vmap0 |} s_id~1 s_id~1 [::] ((vm, m_id, s_id~0, s_st) :: st) ⦄ + ⊢ ⦃ rel_estate {| emem := m; evm := vm |} m_id s_id s_st st ⦄ (* translate_call P fn (translate_prog' P) [seq totce (translate_value v) | v <- va] *) get_translated_fun P fn s_id~1 [seq totce (translate_value v) | v <- va] ⇓ [seq totce (translate_value v) | v <- vr] - ⦃ rel_estate {| emem := m' ; evm := vm |} m_id s_id s_st st ⦄. + ⦃ rel_estate {| emem := m' ; evm := vm |} m_id s_id~0 s_st st ⦄. + +Lemma hget_lemma (l : seq var_i) vm vres : + mapM (λ x : var_i, get_var vm x) l = ok vres -> + [seq encode (vtype (v_var x)) | x <- l] = [seq choice_type_of_val v | v <- vres]. +Proof. + revert vres vm. + induction l; intros. + - inversion H; reflexivity. + - inversion H. + jbind H1 v Hv. + jbind H1 v' Hv'. + noconf H1. + simpl. + unfold choice_type_of_val. + erewrite type_of_get_var by eassumption. + erewrite IHl by eassumption. + reflexivity. +Qed. + +Lemma hget_lemma2 l m vm vres m_id s_id s_st st : + mapM (λ x : var_i, get_var vm x) l = ok vres -> + List.Forall2 + (λ (c : ∑ a : choice_type, raw_code a) (v : value), + ⊢ ⦃ rel_estate {| emem := m; evm := vm |} m_id s_id s_st st ⦄ + c.π2 ⇓ coe_cht c.π1 (translate_value v) + ⦃ rel_estate {| emem := m; evm := vm |} m_id s_id s_st st ⦄) + [seq totc (encode (vtype (v_var x))) (translate_get_var m_id x) | x <- l] vres. +Proof. + revert m vm vres m_id s_id s_st st. + induction l; intros. + - inversion H. constructor. + - inversion H. + jbind H1 v Hv. + jbind H1 v' Hv'. + noconf H1. + constructor. + + simpl. + eapply translate_get_var_correct; eauto. + simpl. assumption. + + eapply IHl. assumption. +Qed. + +Lemma htrunc_lemma1 l vargs vargs': + mapM2 ErrType truncate_val l vargs' = ok vargs + -> (trunc_list l [seq totce (translate_value v) | v <- vargs']) = [seq totce (translate_value v) | v <- vargs]. +Proof. + revert vargs vargs'. + induction l; intros. + - destruct vargs'. + + inversion H; reflexivity. + + inversion H. + - destruct vargs'. + + inversion H. + + inversion H. + jbind H1 v' Hv'. + jbind H1 v'' Hv''. + noconf H1. + simpl. + unfold trunc_list. + simpl. + erewrite totce_truncate_translate by eassumption. + f_equal. + apply IHl. + assumption. +Qed. Theorem translate_prog_correct P m vargs m' vres : ∀ fn, @@ -4566,7 +4631,7 @@ Proof using asm_correct. handled_cmd c → let (s_id', c') := translate_cmd P SP c m_id s_id in ⊢ ⦃ rel_estate s1 m_id s_id s_st st ⦄ - c' ⇓ tt + c' ⇓ tt ⦃ rel_estate s2 m_id s_id' s_st st ⦄). set (Pfor := λ (v : var_i) (ws : seq Z) (s1 : estate) (c : cmd) (s2 : estate), @@ -4628,7 +4693,8 @@ Proof using asm_correct. eapply u_bind. + eapply bind_list_pexpr_correct. 2: eassumption. eauto. - + erewrite translate_exec_sopn_correct by eassumption. + + unshelve erewrite translate_exec_sopn_correct by eassumption. + 1: assumption. eapply u_post_weaken_rule. 1: apply translate_write_lvals_correct. all: eauto. @@ -4730,13 +4796,10 @@ Proof using asm_correct. pose (translate_call_head ef) as hc. rewrite hc. eapply ihgn. - * eapply rel_estate_push. - * eapply u_pre_weaken_rule. - -- eapply translate_write_lvals_correct. - 1:assumption. - exact hwr_vres. - -- intros h. eapply rel_estate_prec. - apply fresh1. + * easy. + * eapply translate_write_lvals_correct. + 1:assumption. + exact hwr_vres. - (* proc *) intros m1 m2 gn g vargs' vargs'' s1 vm2 vres' vres''. intros hg hvars hwr hbody ihbody hget htrunc. @@ -4763,35 +4826,41 @@ Proof using asm_correct. rewrite hg. eapply u_bind. 1: { - 1: { - assert - (Htr : (trunc_list (f_tyin g) - [seq totce (translate_value v) | v <- vargs'']) - = [seq totce (translate_value v) | v <- vargs']) - by admit. - rewrite Htr. - eapply translate_write_vars_correct; try eassumption. - } + erewrite htrunc_lemma1 by eassumption. + eapply u_pre_weaken_rule. + 1: eapply translate_write_vars_correct; eassumption. + eapply rel_estate_push. + } + assert (handled_cmd (f_body g)) as hpbody. + { + clear -hg hp. + pose (gd := (gn, g)). + unfold handled_program. + pose (hh := (List.forallb_forall handled_fundecl (p_funcs P)).1 hp gd). + destruct g. + apply hh. simpl. + now apply (assoc_mem' hg). } + specialize (ihbody s_id~1 s_id~1 [::] ((vm, m_id, s_id~0, s_st) :: st) hpbody). clear hpbody. + assert (htr : translate_cmd P (translate_funs P (l ++ ((gn,g) :: fs'))).1 (f_body g) s_id~1 s_id~1 + = translate_cmd P (translate_funs P fs').1 (f_body g) s_id~1 s_id~1). + { admit. } + rewrite htr in ihbody. + rewrite Efuns in ihbody. + destruct (translate_cmd P tr_fs' (f_body g) s_id~1 s_id~1) as [s_id' c'] eqn:E. + rewrite E in ihbody. + rewrite E. + simpl. + eapply u_bind with (v₁ := tt). - + unfold Pc, translate_prog' in ihbody. - assert (handled_cmd (f_body g)) as hpbody. - { - clear -hg hp. - pose (gd := (gn, g)). - unfold handled_program. - pose (hh := (List.forallb_forall handled_fundecl (p_funcs P)).1 hp gd). - destruct g. - apply hh. simpl. - now apply (assoc_mem' hg). - } + + (* unfold Pc, translate_prog' in ihbody. *) + (* PGH (Fri 13 May 19:02:28 BST 2022): Generalized the different Pc, Pi, ... to allow variation of the funname. This should allow us to use the induction hypothesis on a different function, gn in this case. *) - specialize (ihbody s_id~1 s_id~1 s_st st hpbody). clear hpbody. - simpl in ihbody. + (* simpl in ihbody. *) (* maybe something similar to the prove of assert (translate_call P gn (translate_funs P (l ++ ((gn,f) :: fs'))).1 = translate_call P gn (translate_funs P ((gn,f) :: fs')).1) @@ -4800,50 +4869,25 @@ Proof using asm_correct. *) (* assert (htr : translate_cmd P (translate_funs P (l ++ ((gn,g) :: fs'))).1 (f_body g) s_id~1 s_id~1 *) (* = translate_cmd P (translate_funs P ((gn,g) :: fs')).1 (f_body g) s_id~1 s_id~1). *) - unfold f_body in *. - assert (htr : translate_cmd P (translate_funs P (l ++ ((gn,g) :: fs'))).1 (f_body g) s_id~1 s_id~1 - = translate_cmd P (translate_funs P fs').1 (f_body g) s_id~1 s_id~1). - { - clear -ef ep hl hg. - unfold translate_prog' in ep, ef. - unfold translate_cmd. - unfold translate_instr. - simpl in *. - unfold translate_call, translate_call_body. - simpl. - destruct g. simpl. - destruct f_body. - - reflexivity. - - simpl. - destruct i. destruct i0 eqn:case_i. - + admit. - + admit. - + admit. - + admit. - + admit. - + simpl. - - rewrite -hl. - admit. - (* rewrite -ef. *) - (* destruct (gn == gn) eqn:E. *) - (* 2: { move /eqP in E. exfalso. apply E. reflexivity. } *) - (* simpl. *) - (* admit. *) - } - rewrite htr in ihbody. - simpl in ihbody. - (* PGH: something about the funnames in H2 and the goal is fishy. *) - subst. - give_up. - + eapply u_pre_weaken_rule. + * eapply ihbody. + * easy. + eapply u_bind. * eapply bind_list_correct. - -- inversion hget. - admit. - -- admit. - * inversion htrunc. - admit. + -- rewrite <- map_comp. + unfold comp. + simpl. + eapply hget_lemma; eassumption. + -- eapply hget_lemma2. + assumption. + * clear -htrunc. + eapply u_ret. + split. + 1: eapply rel_estate_pop. + 1: eassumption. + eapply htrunc_lemma1. + eassumption. + - assumption. Admitted. End Translation. From 05010d64ab3d5c5dc4e134894a52936d6ef39c8c Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Fri, 1 Jul 2022 22:05:07 +0200 Subject: [PATCH 264/383] finished proof of `translate_prog_correct` `handled_program` now also checks that: 1: all function calls are to previously defined functions 2: no function name is used twice this should be true of all compiled jasmin programs --- theories/Jasmin/jasmin_translate.v | 388 ++++++++++++++++++++++++----- 1 file changed, 328 insertions(+), 60 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index fe672743..2ca64d25 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1699,14 +1699,14 @@ Definition translate_write_lval (p : p_id) (l : lval) (v : typed_chElement) end. (* the argument to c is its (valid) sub id, the return is the resulting (valid) sub id *) -Fixpoint translate_for (v : var_i) (ws : seq Z) (i : p_id) (c : p_id -> p_id * raw_code 'unit) (sid : p_id) : raw_code 'unit := +Fixpoint translate_for (v : var_i) (ws : seq Z) (m_id : p_id) (c : p_id -> p_id * raw_code 'unit) (s_id : p_id) : raw_code 'unit := match ws with | [::] => ret tt | w :: ws => - let (sid', c') := c sid in - translate_write_var i v (totce (translate_value w)) ;; + let (s_id', c') := c s_id in + translate_write_var m_id v (totce (translate_value w)) ;; c' ;; - translate_for v ws i c sid' + translate_for v ws m_id c s_id' end. (* list_ltuple *) @@ -3968,67 +3968,67 @@ Defined. Fixpoint translate_instr_r (tr_f_body : fdefs) - (i : instr_r) (id : p_id) (sid : p_id) {struct i} + (i : instr_r) (m_id : p_id) (s_id : p_id) {struct i} : p_id * raw_code 'unit with translate_instr (tr_f_body : fdefs) - (i : instr) (id : p_id) (sid : p_id) {struct i} : p_id * raw_code 'unit := - translate_instr_r tr_f_body (instr_d i) id sid. + (i : instr) (m_id : p_id) (s_id : p_id) {struct i} : p_id * raw_code 'unit := + translate_instr_r tr_f_body (instr_d i) m_id s_id. Proof using P asm_op asmop pd. pose proof (translate_cmd := - (fix translate_cmd (tr_f_body : fdefs) (c : cmd) (id : p_id) (sid : p_id) : p_id * raw_code 'unit := + (fix translate_cmd (tr_f_body : fdefs) (c : cmd) (m_id : p_id) (s_id : p_id) : p_id * raw_code 'unit := match c with - | [::] => (sid, ret tt) + | [::] => (s_id, ret tt) | i :: c => - let (sid', i') := translate_instr tr_f_body i id sid in - let (sid'', c') := translate_cmd tr_f_body c id sid' in - (sid'', i' ;; c') + let (s_id', i') := translate_instr tr_f_body i m_id s_id in + let (s_id'', c') := translate_cmd tr_f_body c m_id s_id' in + (s_id'', i' ;; c') end ) ). refine match i with | Cassgn l _ s e => - let tr_p := translate_pexpr (p_globs P) id e in - (sid, + let tr_p := translate_pexpr (p_globs P) m_id e in + (s_id, v ← tr_p.π2 ;; - (translate_write_lval (p_globs P) id l (totce (truncate_el s v))) + (translate_write_lval (p_globs P) m_id l (totce (truncate_el s v))) ) | Copn ls _ o es => - let cs := [seq (translate_pexpr (p_globs P) id e) | e <- es] in + let cs := [seq (translate_pexpr (p_globs P) m_id e) | e <- es] in let vs := bind_list cs in - (sid, + (s_id, bvs ← vs ;; - translate_write_lvals (p_globs P) id ls (translate_exec_sopn o bvs) + translate_write_lvals (p_globs P) m_id ls (translate_exec_sopn o bvs) ) | Cif e c1 c2 => - let (sid', c1') := translate_cmd tr_f_body c1 id sid in - let (sid'', c2') := translate_cmd tr_f_body c2 id sid' in - let e' := translate_pexpr (p_globs P) id e in + let (s_id', c1') := translate_cmd tr_f_body c1 m_id s_id in + let (s_id'', c2') := translate_cmd tr_f_body c2 m_id s_id' in + let e' := translate_pexpr (p_globs P) m_id e in let rb := coerce_typed_code 'bool e' in - (sid'', + (s_id'', b ← rb ;; if b then c1' else c2' ) | Cfor i r c => let '(d, lo, hi) := r in - let (sid', fresh) := fresh_id sid in - let loᵗ := coerce_typed_code 'int (translate_pexpr (p_globs P) id lo) in - let hiᵗ := coerce_typed_code 'int (translate_pexpr (p_globs P) id hi) in - let cᵗ := translate_cmd tr_f_body c id in - (sid', + let (s_id', fresh) := fresh_id s_id in + let loᵗ := coerce_typed_code 'int (translate_pexpr (p_globs P) m_id lo) in + let hiᵗ := coerce_typed_code 'int (translate_pexpr (p_globs P) m_id hi) in + let cᵗ := translate_cmd tr_f_body c m_id in + (s_id', vlo ← loᵗ ;; vhi ← hiᵗ ;; - translate_for i (wrange d vlo vhi) id cᵗ fresh) + translate_for i (wrange d vlo vhi) m_id cᵗ fresh) | Ccall ii xs f args => - let (sid', fresh) := fresh_id sid in - let cs := [seq (translate_pexpr (p_globs P) id e) | e <- args] in - (sid', + let (s_id', fresh) := fresh_id s_id in + let cs := [seq (translate_pexpr (p_globs P) m_id e) | e <- args] in + (s_id', vargs ← bind_list cs ;; vres ← translate_call f tr_f_body fresh vargs ;; - translate_write_lvals (p_globs P) id xs vres + translate_write_lvals (p_globs P) m_id xs vres ) - | _ => (sid, unsupported.π2) + | _ => (s_id, unsupported.π2) end. Defined. (* @@ -4262,8 +4262,51 @@ Qed. This predicate eliminates programs that are currently not supported by the translation. This is mainly used to disallow while loops. + It also checks programs for acyclicity and correct ordering. *) +Fixpoint instr_r_fs + (i : instr_r) (fs : seq _ufun_decl) {struct i} + : bool +with instr_fs (i : instr) (fs : seq _ufun_decl) {struct i} + : bool := + instr_r_fs (instr_d i) fs. +Proof. + pose proof (cmd_fs := + (fix cmd_fs (c : cmd) (fs : seq _ufun_decl) : bool := + match c with + | [::] => true + | i :: c => + cmd_fs c fs && instr_fs i fs + end + )). + refine + match i with + | Cassgn l _ s e => + true + | Copn ls _ o es => + true + | Cif e c1 c2 => + cmd_fs c1 fs && cmd_fs c2 fs + | Cfor i r c => + cmd_fs c fs + | Cwhile _ c1 _ c2 => cmd_fs c1 fs && cmd_fs c2 fs + | Ccall ii xs f args => + f \in [seq p.1 | p <- fs] + end. +Defined. + +Section CmdFS. + +Fixpoint cmd_fs (c : cmd) (fs : seq _ufun_decl) : bool := + match c with + | [::] => true + | i :: c => + cmd_fs c fs && instr_fs i fs + end. + +End CmdFS. + Fixpoint handled_instr (i : instr) := match i with | MkI ii i => handled_instr_r i @@ -4285,8 +4328,50 @@ Definition handled_cmd (c : cmd) := Definition handled_fundecl (f : _ufun_decl) := handled_cmd f.2.(f_body). +(* FIXME: bad naming *) +Lemma lemma3 suf pre : + (foldr (fun f '(b, l) => if b then (cmd_fs f.2.(f_body) l, f :: l) else (false, f :: l)) (true, [::]) (suf ++ pre)).1 -> + (foldr (fun f '(b, l) => if b then (cmd_fs f.2.(f_body) l, f :: l) else (false, f :: l)) (true, [::]) pre).1. +Proof. + intros H. + induction suf. + - easy. + - simpl in *. + apply IHsuf. + destruct foldr. + destruct b. + + easy. + + easy. +Qed. + +(* FIXME: bad naming *) +Lemma lemma4 pre : + (foldr (fun f '(b, l) => if b then (cmd_fs f.2.(f_body) l, f :: l) else (false, f :: l)) (true, [::]) pre).2 = pre. +Proof. + induction pre. + - reflexivity. + - simpl. + destruct foldr. + destruct b; simpl in *; congruence. +Qed. + +(* FIXME: bad naming *) +Lemma lemma2 g gn (pre suf : list _ufun_decl) : + (foldr (fun f '(b, l) => if b then (cmd_fs f.2.(f_body) l, f :: l) else (false, f :: l)) (true, [::]) (suf ++ (gn,g) :: pre)).1 -> + cmd_fs g.(f_body) pre. +Proof. + intros. + eapply lemma3 in H. + simpl in H. + pose proof lemma4 pre. + destruct foldr. + destruct b; simpl in *; congruence. +Qed. + Definition handled_program (P : uprog) := - List.forallb handled_fundecl P.(p_funcs). + List.forallb handled_fundecl P.(p_funcs) && + (foldr (fun f '(b, l) => if b then (cmd_fs f.2.(f_body) l, f :: l) else (false, f :: l)) (true, [::]) P.(p_funcs)).1 && + uniq [seq p.1 | p <- P.(p_funcs)]. Fact sem_call_get_some {P m1 gn vargs m2 vres} : sem_call P m1 gn vargs m2 vres → @@ -4557,6 +4642,7 @@ Proof. reflexivity. Qed. +(* FIXME: bad naming *) Lemma hget_lemma2 l m vm vres m_id s_id s_st st : mapM (λ x : var_i, get_var vm x) l = ok vres -> List.Forall2 @@ -4580,6 +4666,7 @@ Proof. + eapply IHl. assumption. Qed. +(* FIXME: bad naming *) Lemma htrunc_lemma1 l vargs vargs': mapM2 ErrType truncate_val l vargs' = ok vargs -> (trunc_list l [seq totce (translate_value v) | v <- vargs']) = [seq totce (translate_value v) | v <- vargs]. @@ -4604,13 +4691,198 @@ Proof. assumption. Qed. +Lemma translate_for_ext v l m_id s_id c c' : + (forall s_id, c s_id = c' s_id) -> + translate_for v l m_id c s_id = translate_for v l m_id c' s_id. +Proof. + revert s_id. + induction l; intros s_id hext. + - reflexivity. + - simpl. + rewrite hext. + destruct c'. + rewrite IHl; auto. +Qed. + +(* FIXME: bad naming *) +Lemma lemma1 P pre c suf m_id : + uniq [seq p.1 | p <- suf ++ pre] -> + forall s_id, + cmd_fs c pre -> + translate_cmd P (translate_funs P (suf ++ pre)).1 c m_id s_id + = translate_cmd P (translate_funs P pre).1 c m_id s_id. +Proof. + intros huniq. + set (Pr := fun (i : instr_r) => + forall s_id, + instr_r_fs i pre -> + translate_instr_r P (translate_funs P (suf ++ pre)).1 i m_id s_id + = translate_instr_r P (translate_funs P pre).1 i m_id s_id). + set (Pi := fun (i : instr) => + Pr (instr_d i)). + set (Pc := fun (c : cmd) => + forall s_id, + cmd_fs c pre -> + translate_cmd P (translate_funs P (suf ++ pre)).1 c m_id s_id + = translate_cmd P (translate_funs P pre).1 c m_id s_id). + eapply cmd_rect with + (Pr0 := Pr) + (Pi0 := Pi) + (Pc0 := Pc); + try easy + . + - intros i c' ihi ihc s_id' hpre. + unfold Pc. + simpl. + unfold Pi in ihi. + red in ihi. + rewrite !translate_instr_unfold. + simpl in hpre. + move: hpre => /andP [hi hc]. + rewrite ihi. + 2: destruct i; auto. + destruct translate_instr_r as [s_id'' i']. + rewrite ihc; auto. + - intros e c1 c2 ihc1 ihc2 s_id' hpre. + rewrite !translate_instr_r_if. + simpl in hpre. + fold cmd_fs in hpre. + move: hpre => /andP [hc1 hc2]. + rewrite ihc1; auto. + destruct translate_cmd as [s_id'' c']. + rewrite ihc2; auto. + - intros v d lo hi c' ihc s_id hpre. + simpl in hpre. + fold cmd_fs in hpre. + rewrite !translate_instr_r_for. + red in ihc. + simpl. + f_equal. + f_equal. + apply functional_extensionality. + intros lb. + f_equal. + apply functional_extensionality. + intros ub. + erewrite translate_for_ext; eauto. + - intros i lvals f es s_id hpre. + simpl in hpre. + unfold translate_instr_r. + simpl. + f_equal. + unfold translate_call. + symmetry; destruct assoc eqn:E. + + assert (H2 : exists r', assoc pre f = Some r'). + * clear -E. + induction pre. 1: discriminate. + destruct a. + simpl in *. + destruct (f == s). + ** eexists. reflexivity. + ** apply IHpre; auto. + * destruct H2 as [r']. + assert (assoc (translate_funs P (suf ++ pre)).1 f = Some r). + ** eapply mem_uniq_assoc. + *** clear -E. + induction suf. + **** induction pre. + ***** discriminate. + ***** + destruct a. + simpl in *. + destruct (f==s) eqn:E2. + ****** + move: E2 => /eqP ->. left. noconf E. + reflexivity. + ****** right. + apply IHpre. assumption. + **** destruct a. + simpl. + right. + assumption. + *** clear -huniq. + induction suf. + **** induction pre. + ***** easy. + ***** destruct a. + simpl in *. + move: huniq => /andP [huniq1 huniq2]. + apply /andP; split. + ****** clear -huniq1. induction pre. + ******* easy. + ******* destruct a. + Check [eqType of BinNums.positive]. + simpl in huniq1. + pose proof notin_cons [eqType of BinNums.positive] p [seq p.1 | p <- pre] s. + rewrite H in huniq1. + move: huniq1 => /andP [huniq11 huniq12]. + simpl. + pose proof notin_cons [eqType of BinNums.positive] p [seq p.1 | p <- (translate_funs P pre).1] s. + rewrite H0. + apply /andP. + split; auto. + ****** apply IHpre. assumption. + **** destruct a. + simpl in *. + move: huniq => /andP [huniq1 huniq2]. + apply /andP. + split. + ****** clear -huniq1. induction suf. + ******* induction pre. + ******** easy. + ******** destruct a. + simpl in *. + pose proof notin_cons [eqType of BinNums.positive] p [seq p.1 | p <- pre] s. + rewrite H in huniq1. + move: huniq1 => /andP [huniq11 huniq12]. + simpl. + pose proof notin_cons [eqType of BinNums.positive] p [seq p.1 | p <- (translate_funs P pre).1] s. + rewrite H0. + apply /andP. + split; auto. + ******* + destruct a. + simpl in *. + pose proof notin_cons [eqType of BinNums.positive] p [seq p.1 | p <- suf ++ pre] s. + rewrite H in huniq1. + move: huniq1 => /andP [huniq11 huniq12]. + pose proof notin_cons [eqType of BinNums.positive] p [seq p.1 | p <- (translate_funs P (suf ++ pre)).1] s. + rewrite H0. + apply /andP. + split; auto. + ****** apply IHsuf; auto. + ** rewrite H0. reflexivity. + + exfalso. + assert (H2 : assoc pre f = None). + * clear -E. + induction pre. + ** reflexivity. + ** simpl in *. + destruct a. + simpl in *. + destruct (f == p). + *** discriminate. + *** apply IHpre; auto. + * clear -H2 hpre. + induction pre. + ** easy. + ** destruct a. + simpl in *. + rewrite in_cons in hpre. + destruct (f == s). + *** simpl in *. + discriminate. + *** simpl in *. + apply IHpre; auto. +Qed. + Theorem translate_prog_correct P m vargs m' vres : ∀ fn, sem.sem_call P m fn vargs m' vres → handled_program P -> ∀ vm m_id s_id s_st st, Pfun P fn m vargs m' vres vm m_id s_id s_st st. -Proof using asm_correct. +Proof using gd asm_correct. intros fn H hP. set (Pfun := λ(m : mem) (fn : funname) (va : seq value) (m' : mem) (vr : seq value), handled_program P -> forall vm m_id s_id s_st st, Pfun P fn m va m' vr vm m_id s_id s_st st @@ -4835,16 +5107,30 @@ Proof using asm_correct. { clear -hg hp. pose (gd := (gn, g)). - unfold handled_program. - pose (hh := (List.forallb_forall handled_fundecl (p_funcs P)).1 hp gd). + unfold handled_program in *. + move: hp => /andP [] /andP [] hp1 hp2 hp3. + pose (hh := (List.forallb_forall handled_fundecl (p_funcs P)).1 hp1 gd). destruct g. apply hh. simpl. now apply (assoc_mem' hg). } specialize (ihbody s_id~1 s_id~1 [::] ((vm, m_id, s_id~0, s_st) :: st) hpbody). clear hpbody. + assert ((l ++ (gn,g) :: fs') = ((l ++ [:: (gn,g)]) ++ fs')) by (rewrite <- List.app_assoc; reflexivity). assert (htr : translate_cmd P (translate_funs P (l ++ ((gn,g) :: fs'))).1 (f_body g) s_id~1 s_id~1 = translate_cmd P (translate_funs P fs').1 (f_body g) s_id~1 s_id~1). - { admit. } + { rewrite H0. + eapply lemma1. + { clear -hp hl H0. + unfold handled_program in *. + move: hp => /andP [] /andP [_ _]. + now rewrite hl H0. + } + clear -hp hl. + move: hp => /andP [] /andP [_ hp2 _]. + rewrite hl in hp2. + eapply lemma2. + eassumption. + } rewrite htr in ihbody. rewrite Efuns in ihbody. destruct (translate_cmd P tr_fs' (f_body g) s_id~1 s_id~1) as [s_id' c'] eqn:E. @@ -4853,32 +5139,14 @@ Proof using asm_correct. simpl. eapply u_bind with (v₁ := tt). - + (* unfold Pc, translate_prog' in ihbody. *) - - (* PGH (Fri 13 May 19:02:28 BST 2022): - Generalized the different Pc, Pi, ... to allow variation of the funname. - This should allow us to use the induction hypothesis on a different function, - gn in this case. - *) - (* simpl in ihbody. *) - (* maybe something similar to the prove of - assert (translate_call P gn (translate_funs P (l ++ ((gn,f) :: fs'))).1 - = translate_call P gn (translate_funs P ((gn,f) :: fs')).1) - - just need to push the (translate_funs ...) in until they get to a funcall? - *) - (* assert (htr : translate_cmd P (translate_funs P (l ++ ((gn,g) :: fs'))).1 (f_body g) s_id~1 s_id~1 *) - (* = translate_cmd P (translate_funs P ((gn,g) :: fs')).1 (f_body g) s_id~1 s_id~1). *) - eapply u_pre_weaken_rule. - * eapply ihbody. - * easy. + + eapply ihbody. + eapply u_bind. * eapply bind_list_correct. - -- rewrite <- map_comp. + ** rewrite <- map_comp. unfold comp. simpl. eapply hget_lemma; eassumption. - -- eapply hget_lemma2. + ** eapply hget_lemma2. assumption. * clear -htrunc. eapply u_ret. @@ -4888,7 +5156,7 @@ Proof using asm_correct. eapply htrunc_lemma1. eassumption. - assumption. -Admitted. +Qed. End Translation. From 5e2680d36649a28ef8998d0cf3130c0e173dc637 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Tue, 5 Jul 2022 14:45:44 +0200 Subject: [PATCH 265/383] modified `xor.v` to use new simplification --- theories/Jasmin/examples/xor/xor.v | 135 +++++++++++++---------------- 1 file changed, 60 insertions(+), 75 deletions(-) diff --git a/theories/Jasmin/examples/xor/xor.v b/theories/Jasmin/examples/xor/xor.v index d4415b7a..9eb4d3b6 100644 --- a/theories/Jasmin/examples/xor/xor.v +++ b/theories/Jasmin/examples/xor/xor.v @@ -6,22 +6,26 @@ Set Warnings "notation-overridden,ambiguous-paths". Require Import List. From Jasmin Require Import expr. -From Jasmin Require Import x86_extra. -From JasminSSProve Require Import jasmin_translate. -From Crypt Require Import Prelude Package. +From CoqWord Require Import word. +(* From Jasmin Require Import x86_extra. *) +From JasminSSProve Require Import jasmin_translate jasmin_utils. +From Crypt Require Import Prelude Package pkg_user_util. Import ListNotations. +Import JasminNotation JasminCodeNotation. +Import PackageNotation. + Local Open Scope string. -(* Context `{asmop : asmOp}. *) +Context `{asmop : asmOp}. -(* Context {T} {pT : progT T}. *) +Context {T} {pT : progT T}. -(* Context {pd : PointerData}. *) +Context {pd : PointerData}. -(* Context (P : uprog). *) +Context (P : uprog). -(* Context (f : funname). *) +Context (f : funname). Definition xor := {| p_funcs := @@ -119,40 +123,26 @@ Definition xor := p_globs := []; p_extra := tt |} . +Definition tr_P := Eval simpl in translate_prog' xor. +Definition default_prog' := (1%positive, fun s_id : p_id => (ret tt)). +Definition default_call := (1%positive, fun (s_id : p_id) (x : [choiceType of seq typed_chElement]) => ret x). +Definition get_tr sp n := List.nth_default default_call sp n. +Definition tr_xor := Eval simpl in (get_tr tr_P.2 0). -Import PackageNotation. -Notation coe_cht := coerce_to_choice_type. -Notation coe_tyc := coerce_typed_code. -Notation " 'array " := (chMap 'int ('word U8)) (at level 2) : package_scope. -Notation " 'array " := (chMap 'int ('word U8)) (in custom pack_type at level 2). -Notation " 'mem " := (chMap ('word Uptr) ('word U8)) (at level 2) : package_scope. -Notation " 'mem " := (chMap ('word Uptr) ('word U8)) (in custom pack_type at level 2). -Notation " ⸨ ws ⸩ a .[ ptr * scale ] " := (chArray_get ws a ptr scale) - (format " ⸨ ws ⸩ a .[ ptr * scale ] "). -Notation " a [ w / p ] " := - (chArray_set a AAscale p w) - (at level 99, no associativity, - format " a [ w / p ] "). - - -From Equations Require Import Equations. -Set Equations With UIP. -Set Equations Transparent. - -Definition tr_xor := translate_prog xor. -Definition f_xor : 'word U64 × 'word U64 -> raw_code ('word U64). -Proof. - pose tr_xor. unfold tr_xor in s. unfold translate_prog in s. - simpl in s. - destruct s eqn:E. - - unfold s in E. discriminate. - - pose (ffun p.2).π2.π2. - simpl in r. - unfold s in E. - noconf E. - (* simpl in r. *) - exact r. -Defined. +Opaque translate_for. + +Goal forall goal w1 w2, tr_xor.2 1%positive [('word U64; w1); ('word U64; w2)] = goal . + intros goal. + unfold tr_xor. + unfold get_tr. + simpl_fun. + + repeat setjvars. + + repeat setoid_rewrite coerce_to_choice_type_K. + repeat setoid_rewrite (@zero_extend_u U64). + +Admitted. Lemma eq_rect_K : forall (A : eqType) (x : A) (P : A -> Type) h e, @@ -163,49 +153,44 @@ Proof. reflexivity. Qed. -Eval cbn in tr_xor. - -Lemma injective_translate_var2 : - forall fn x y, x != y -> translate_var fn x != translate_var fn y. -Proof. - intros. - apply /negP. - intros contra. - move: contra => /eqP contra. - eapply injective_translate_var in contra. - move: H => /eqP. easy. - exact xor. - apply x86_correct. - Unshelve. - 2: exact progUnit. -Qed. - -Lemma f_xor_correct : forall w1 w2, ⊢ ⦃ fun _ => True ⦄ f_xor (w1, w2) ⇓ wxor w1 w2 ⦃ fun _ => True ⦄. +(* Lemma injective_translate_var2 : *) +(* forall fn x y, x != y -> translate_var fn x != translate_var fn y. *) +(* Proof. *) +(* intros. *) +(* apply /negP. *) +(* intros contra. *) +(* move: contra => /eqP contra. *) +(* eapply injective_translate_var in contra. *) +(* move: H => /eqP. easy. *) +(* exact xor. *) +(* apply x86_correct. *) +(* Unshelve. *) +(* 2: exact progUnit. *) +(* Qed. *) + +Lemma f_xor_correct : forall w1 w2, ⊢ ⦃ fun _ => True ⦄ tr_xor.2 1%positive [('word U64; w1); ('word U64; w2)] ⇓ [('word U64; wxor w1 w2)] ⦃ fun _ => True ⦄. Proof. (* preprocessing *) - unfold f_xor at 1. - unfold apply_noConfusion. - simpl. - unfold translate_write_var. simpl. - unfold coerce_chtuple_to_list; simpl. - rewrite eq_rect_r_K. - simpl. - unfold bind_list'. simpl. - unfold bind_list_trunc_aux. simpl. - rewrite eq_rect_K. - set (fn := 2%positive). - set (x := translate_var fn {| vtype := sword64; vname := "x.131" |}). - set (r := translate_var fn {| vtype := sword64; vname := "r.133" |}). - set (y := translate_var fn {| vtype := sword64; vname := "y.132" |}). + intros w1 w2. + (* unfold tr_xor. *) + (* unfold get_tr. *) + simpl_fun. + repeat setjvars. + + repeat setoid_rewrite coerce_to_choice_type_K. + repeat setoid_rewrite (@zero_extend_u U64). (* proof *) intros. - rewrite !zero_extend_u. + + (* ssprove_swap_aux 1. *) + (* ssprove_swap_lhs 3. *) eapply u_put. eapply u_put. eapply u_get_remember. intros. - apply u_put. + (* eapply u_pre_weaken_rule. *) + (* eapply u_put. *) apply u_get_remember; intros. apply u_get_remember; intros. apply u_put. From a1ab460f4adc4af57a1e60834e257789358fc0b2 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Wed, 6 Jul 2022 09:47:54 +0200 Subject: [PATCH 266/383] simplify notation and `xor` example --- theories/Jasmin/examples/xor/xor.v | 63 ++++++++++++------------------ theories/Jasmin/jasmin_translate.v | 15 +++++++ theories/Jasmin/jasmin_utils.v | 3 +- 3 files changed, 41 insertions(+), 40 deletions(-) diff --git a/theories/Jasmin/examples/xor/xor.v b/theories/Jasmin/examples/xor/xor.v index 9eb4d3b6..746a7ac4 100644 --- a/theories/Jasmin/examples/xor/xor.v +++ b/theories/Jasmin/examples/xor/xor.v @@ -168,54 +168,41 @@ Qed. (* 2: exact progUnit. *) (* Qed. *) +Hint Resolve injective_translate_var2 : ssprove_swap. + +(* #[export] Hint Extern 9 (⊢ ⦃ _ ⦄ _ ← cmd (cmd_put ?ℓ ?v) ;; _ ← cmd (cmd_get ?ℓ') ;; _ ≈ _ ⦃ _ ⦄) => *) +(* apply (r_put_get_swap' ℓ ℓ' v) *) +(* : ssprove_swap. *) +(* #[export] Hint Extern 10 (⊢ ⦃ _ ⦄ _ ← cmd _ ;; _ ← cmd (cmd_sample _) ;; _ ≈ _ ⦃ _ ⦄) => *) +Ltac neq_loc_auto ::= eapply injective_translate_var3; auto. + (* shelve. *) + (* repeat match goal with *) + (* | |- translate_var _ _ != translate_var _ _ => eapply injective_translate_var3; auto *) + (* end. *) +Import ListNotations. Lemma f_xor_correct : forall w1 w2, ⊢ ⦃ fun _ => True ⦄ tr_xor.2 1%positive [('word U64; w1); ('word U64; w2)] ⇓ [('word U64; wxor w1 w2)] ⦃ fun _ => True ⦄. Proof. (* preprocessing *) intros w1 w2. - (* unfold tr_xor. *) - (* unfold get_tr. *) simpl_fun. repeat setjvars. repeat setoid_rewrite coerce_to_choice_type_K. repeat setoid_rewrite (@zero_extend_u U64). - - (* proof *) intros. - (* ssprove_swap_aux 1. *) - (* ssprove_swap_lhs 3. *) - eapply u_put. - eapply u_put. - eapply u_get_remember. - intros. - (* eapply u_pre_weaken_rule. *) - (* eapply u_put. *) - apply u_get_remember; intros. - apply u_get_remember; intros. - apply u_put. - apply u_get_remember; intros. - apply u_ret. - intros. - rewrite !zero_extend_u. - split. easy. - repeat destruct H. - rewrite !zero_extend_u in H1. - rewrite !zero_extend_u in H4. - subst. - unfold u_get in *. - rewrite get_set_heap_eq in H0. - rewrite get_set_heap_eq in H3. - erewrite <- get_heap_set_heap in H5. - erewrite <- get_heap_set_heap in H2. - rewrite get_set_heap_eq in H2. - rewrite get_set_heap_eq in H5. - rewrite H2. - rewrite H5. - rewrite <- H3 in H0. + (* proof *) + ssprove_swap_lhs 1%nat. + ssprove_contract_put_get_lhs. + ssprove_swap_seq_lhs [:: 1 ; 0 ; 2 ; 1]. + ssprove_contract_put_get_lhs. + ssprove_swap_seq_lhs [:: 1 ; 0 ; 2 ; 1]. + ssprove_contract_put_get_lhs. + ssprove_swap_seq_lhs [:: 0 ; 2 ; 1 ]. + ssprove_contract_put_lhs. + ssprove_swap_seq_lhs [:: 2 ; 1 ]. + ssprove_contract_put_get_lhs. + repeat eapply u_put. + eapply u_ret_eq. easy. - apply injective_translate_var2. - reflexivity. - apply injective_translate_var2. - reflexivity. Qed. diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 2ca64d25..2e08ed07 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1069,6 +1069,21 @@ Proof. easy. Qed. +Lemma injective_translate_var3 : + forall (p1 p2 : p_id) v1 v2, vname v1 != vname v2 -> translate_var p1 v1 != translate_var p2 v2. +Proof. + intros. + apply /eqP => contra. + unfold translate_var in contra. + noconf contra. + unfold nat_of_p_id_var in H1. + apply coprime_mul_inj in H1 as [e1 e2]. + 2,3,4,5: apply coprime_nat_of_stype_nat_of_fun_ident. + apply injective_nat_of_p_id_ident2 in e2 as [p_gn ?]. + move: H => /eqP contra. + easy. +Qed. + Lemma mem_loc_translate_var_neq : ∀ p x, mem_loc != translate_var p x. diff --git a/theories/Jasmin/jasmin_utils.v b/theories/Jasmin/jasmin_utils.v index 5d91a381..8d78f1d8 100644 --- a/theories/Jasmin/jasmin_utils.v +++ b/theories/Jasmin/jasmin_utils.v @@ -18,7 +18,7 @@ Module JasminCodeNotation. (at level 99, no associativity, format " a [ w / p ] "). - Notation "$$ i" := (_ ; nat_of_p_id_var _ {| vtype := _; vname := i |}) + Notation "$$ i" := (translate_var _ {| vtype := _; vname := i |}) (at level 99, format "$$ i"). Notation "$$$ i" := ({| v_var := {| vtype := _; vname := i |}; v_info := _ |}) @@ -121,7 +121,6 @@ Ltac setjvars := ltac2:(jtac.setjvars ()). Ltac prog_unfold := unfold translate_prog', translate_prog, translate_call, translate_call_body, translate_write_lvals, translate_write_var, translate_instr, - translate_var, coerce_chtuple_to_list, bind_list', bind_list_trunc_aux, wsize_size, trunc_list, List.nth_default. From 501cf9e03bd886101c222b3fae4b181bcc04f1ac Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Wed, 6 Jul 2022 10:54:44 +0200 Subject: [PATCH 267/383] fix `xor.v` --- theories/Jasmin/examples/xor/xor.v | 45 ++++-------------------------- 1 file changed, 6 insertions(+), 39 deletions(-) diff --git a/theories/Jasmin/examples/xor/xor.v b/theories/Jasmin/examples/xor/xor.v index 746a7ac4..a25bd248 100644 --- a/theories/Jasmin/examples/xor/xor.v +++ b/theories/Jasmin/examples/xor/xor.v @@ -144,41 +144,8 @@ Goal forall goal w1 w2, tr_xor.2 1%positive [('word U64; w1); ('word U64; w2)] = Admitted. -Lemma eq_rect_K : - forall (A : eqType) (x : A) (P : A -> Type) h e, - @eq_rect A x P h x e = h. -Proof. - intros A x P' h e. - replace e with (@erefl A x) by apply eq_irrelevance. - reflexivity. -Qed. - -(* Lemma injective_translate_var2 : *) -(* forall fn x y, x != y -> translate_var fn x != translate_var fn y. *) -(* Proof. *) -(* intros. *) -(* apply /negP. *) -(* intros contra. *) -(* move: contra => /eqP contra. *) -(* eapply injective_translate_var in contra. *) -(* move: H => /eqP. easy. *) -(* exact xor. *) -(* apply x86_correct. *) -(* Unshelve. *) -(* 2: exact progUnit. *) -(* Qed. *) - -Hint Resolve injective_translate_var2 : ssprove_swap. - -(* #[export] Hint Extern 9 (⊢ ⦃ _ ⦄ _ ← cmd (cmd_put ?ℓ ?v) ;; _ ← cmd (cmd_get ?ℓ') ;; _ ≈ _ ⦃ _ ⦄) => *) -(* apply (r_put_get_swap' ℓ ℓ' v) *) -(* : ssprove_swap. *) -(* #[export] Hint Extern 10 (⊢ ⦃ _ ⦄ _ ← cmd _ ;; _ ← cmd (cmd_sample _) ;; _ ≈ _ ⦃ _ ⦄) => *) Ltac neq_loc_auto ::= eapply injective_translate_var3; auto. - (* shelve. *) - (* repeat match goal with *) - (* | |- translate_var _ _ != translate_var _ _ => eapply injective_translate_var3; auto *) - (* end. *) + Import ListNotations. Lemma f_xor_correct : forall w1 w2, ⊢ ⦃ fun _ => True ⦄ tr_xor.2 1%positive [('word U64; w1); ('word U64; w2)] ⇓ [('word U64; wxor w1 w2)] ⦃ fun _ => True ⦄. Proof. @@ -187,12 +154,11 @@ Proof. simpl_fun. repeat setjvars. - repeat setoid_rewrite coerce_to_choice_type_K. - repeat setoid_rewrite (@zero_extend_u U64). - intros. + (* this makes Qed hang *) + (* repeat setoid_rewrite (@zero_extend_u U64). *) (* proof *) - ssprove_swap_lhs 1%nat. + ssprove_swap_lhs 1. ssprove_contract_put_get_lhs. ssprove_swap_seq_lhs [:: 1 ; 0 ; 2 ; 1]. ssprove_contract_put_get_lhs. @@ -203,6 +169,7 @@ Proof. ssprove_swap_seq_lhs [:: 2 ; 1 ]. ssprove_contract_put_get_lhs. repeat eapply u_put. - eapply u_ret_eq. + eapply u_ret. + rewrite !zero_extend_u. easy. Qed. From 29a4cdb3384391ff6924f976a3d3e2be9cdfec92 Mon Sep 17 00:00:00 2001 From: bshvass Date: Thu, 18 Aug 2022 17:33:18 +0200 Subject: [PATCH 268/383] update to jasmin main --- theories/Jasmin/jasmin_translate.v | 71 +++++++++++++++++------------- theories/Mon/FiniteProbabilities.v | 6 +-- 2 files changed, 43 insertions(+), 34 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 2e08ed07..8fb1be83 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -653,6 +653,8 @@ Context {pd : PointerData}. Context (gd : glob_decls). +Context `{sc_sem : syscall_sem }. + Definition mem_index : nat := 0. Definition mem_loc : Location := ('mem ; mem_index). @@ -2465,7 +2467,7 @@ Lemma translate_write_estate : ∀ sz s cm ptr w m_id s_id s_st st m, write s.(emem) ptr (sz := sz) w = ok cm → rel_estate s m_id s_id s_st st m → - rel_estate {| emem := cm ; evm := s.(evm) |} m_id s_id s_st st (set_heap m mem_loc (write_mem (get_heap m mem_loc) ptr w)). + rel_estate {| escs := s.(escs) ; emem := cm ; evm := s.(evm) |} m_id s_id s_st st (set_heap m mem_loc (write_mem (get_heap m mem_loc) ptr w)). Proof. intros sz s cm ptr w m_id s_id s_st st m hw [hmem hstack]. split. @@ -3515,14 +3517,15 @@ Proof. noconf H1. constructor. + eapply H. - 1: apply mem_head. + 1: now constructor. 1: eassumption. assumption. + eapply IHes. 1: assumption. intros. eapply H. - { rewrite in_cons. rewrite H0. by apply /orP; right. } + { apply List.in_cons. assumption. } + (* { rewrite in_cons. rewrite H0. by apply /orP; right. } *) 1: eassumption. assumption. } @@ -3642,7 +3645,7 @@ Qed. Lemma translate_write_correct : ∀ sz s ptr (w : word sz) cm m_id s_id s_st st (cond : heap → Prop), (∀ m, cond m → write s.(emem) ptr w = ok cm ∧ rel_estate s m_id s_id s_st st m) → - ⊢ ⦃ cond ⦄ translate_write ptr w ⇓ tt ⦃ rel_estate {| emem := cm ; evm := s.(evm) |} m_id s_id s_st st ⦄. + ⊢ ⦃ cond ⦄ translate_write ptr w ⇓ tt ⦃ rel_estate {| escs := s.(escs) ; emem := cm ; evm := s.(evm) |} m_id s_id s_st st ⦄. Proof. intros sz s ptr w cm m_id s_id s_st st cond h. unfold translate_write. @@ -4301,6 +4304,8 @@ Proof. true | Copn ls _ o es => true + | Csyscall ls sc es => + true | Cif e c1 c2 => cmd_fs c1 fs && cmd_fs c2 fs | Cfor i r c => @@ -4331,6 +4336,7 @@ with handled_instr_r (i : instr_r) := match i with | Cassgn l tag sty e => true | Copn l tag o es => true + | Csyscall _ _ _ => false | Cif e c₁ c₂ => List.forallb handled_instr c₁ && List.forallb handled_instr c₂ | Cfor i r c => List.forallb handled_instr c | Cwhile al cb e c => false @@ -4387,12 +4393,12 @@ Definition handled_program (P : uprog) := List.forallb handled_fundecl P.(p_funcs) && (foldr (fun f '(b, l) => if b then (cmd_fs f.2.(f_body) l, f :: l) else (false, f :: l)) (true, [::]) P.(p_funcs)).1 && uniq [seq p.1 | p <- P.(p_funcs)]. +Context `{sc_sem : syscall_sem }. -Fact sem_call_get_some {P m1 gn vargs m2 vres} : - sem_call P m1 gn vargs m2 vres → - ∃ f, get_fundef (p_funcs P) gn = Some f. -Proof. - intros H. inversion H. eexists. eassumption. +Fact sem_call_get_some {P m1 scs1 gn vargs m2 scs2 vres} : + (sem_call P scs1 m1 gn vargs scs2 m2 vres → + ∃ f, get_fundef (p_funcs P) gn = Some f ). +Proof. intros H. inversion H. exists f. easy. Qed. Definition get_translated_fun P fn : trfun := @@ -4486,9 +4492,9 @@ Proof. - eapply valid_stack_pop_sub; eassumption. Qed. -Lemma rel_estate_pop m vm vm' m_id m_id' s_id s_id' s_st s_st' st : - ∀ h, rel_estate {| emem := m ; evm := vm |} m_id s_id s_st ((vm',m_id',s_id',s_st') :: st) h → - rel_estate {| emem := m ; evm := vm' |} m_id' s_id' s_st' st h. +Lemma rel_estate_pop scs m vm vm' m_id m_id' s_id s_id' s_st s_st' st : + ∀ h, rel_estate {| escs := scs ; emem := m ; evm := vm |} m_id s_id s_st ((vm',m_id',s_id',s_st') :: st) h → + rel_estate {| escs := scs ; emem := m ; evm := vm' |} m_id' s_id' s_st' st h. Proof. intros h [hmem hstack]. split. @@ -4505,9 +4511,9 @@ Proof. - eapply valid_stack_push_sub; eassumption. Qed. -Lemma rel_estate_push m vm m_id s_id s_st st : - ∀ h : heap, rel_estate {| emem := m ; evm := vm |} m_id s_id s_st st h → - rel_estate {| emem := m ; evm := vmap0 |} s_id~1 s_id~1 [::] ((vm, m_id, s_id~0, s_st) :: st) h. +Lemma rel_estate_push m vm scs m_id s_id s_st st : + ∀ h : heap, rel_estate {| escs := scs ; emem := m ; evm := vm |} m_id s_id s_st st h → + rel_estate {| escs := scs ; emem := m ; evm := vmap0 |} s_id~1 s_id~1 [::] ((vm, m_id, s_id~0, s_st) :: st) h. Proof. intros h [hmem hstack]; split. - assumption. @@ -4545,6 +4551,7 @@ Proof. etransitivity; eauto. - intros x tg ty e i; simpl; reflexivity. - intros xs t o es i; simpl; reflexivity. + - intros xs o es i; simpl; reflexivity. - intros e c1 c2 ihc1 ihc2 s_id. rewrite translate_instr_r_if. specialize (ihc1 s_id). @@ -4595,6 +4602,7 @@ Proof. etransitivity; eauto. - intros x tg ty e i'; simpl; reflexivity. - intros xs t o es i'; simpl; reflexivity. + - intros xs o es i'; simpl; reflexivity. - intros e c1 c2 ihc1 ihc2 s_id. rewrite translate_instr_r_if. specialize (ihc1 s_id). @@ -4632,12 +4640,12 @@ Proof. apply rel_estate_prec; assumption. Qed. -Definition Pfun (P : uprog) (fn : funname) m va m' vr vm m_id s_id s_st st := - ⊢ ⦃ rel_estate {| emem := m; evm := vm |} m_id s_id s_st st ⦄ +Definition Pfun (P : uprog) (fn : funname) scs m va scs' m' vr vm m_id s_id s_st st := + ⊢ ⦃ rel_estate {| escs := scs ; emem := m; evm := vm |} m_id s_id s_st st ⦄ (* translate_call P fn (translate_prog' P) [seq totce (translate_value v) | v <- va] *) get_translated_fun P fn s_id~1 [seq totce (translate_value v) | v <- va] ⇓ [seq totce (translate_value v) | v <- vr] - ⦃ rel_estate {| emem := m' ; evm := vm |} m_id s_id~0 s_st st ⦄. + ⦃ rel_estate {| escs := scs' ; emem := m' ; evm := vm |} m_id s_id~0 s_st st ⦄. Lemma hget_lemma (l : seq var_i) vm vres : mapM (λ x : var_i, get_var vm x) l = ok vres -> @@ -4658,13 +4666,13 @@ Proof. Qed. (* FIXME: bad naming *) -Lemma hget_lemma2 l m vm vres m_id s_id s_st st : +Lemma hget_lemma2 l scs m vm vres m_id s_id s_st st : mapM (λ x : var_i, get_var vm x) l = ok vres -> List.Forall2 (λ (c : ∑ a : choice_type, raw_code a) (v : value), - ⊢ ⦃ rel_estate {| emem := m; evm := vm |} m_id s_id s_st st ⦄ + ⊢ ⦃ rel_estate {| escs := scs ; emem := m; evm := vm |} m_id s_id s_st st ⦄ c.π2 ⇓ coe_cht c.π1 (translate_value v) - ⦃ rel_estate {| emem := m; evm := vm |} m_id s_id s_st st ⦄) + ⦃ rel_estate {| escs := scs ; emem := m; evm := vm |} m_id s_id s_st st ⦄) [seq totc (encode (vtype (v_var x))) (translate_get_var m_id x) | x <- l] vres. Proof. revert m vm vres m_id s_id s_st st. @@ -4891,16 +4899,16 @@ Proof. apply IHpre; auto. Qed. -Theorem translate_prog_correct P m vargs m' vres : +Theorem translate_prog_correct P scs m vargs scs' m' vres : ∀ fn, - sem.sem_call P m fn vargs m' vres → + sem.sem_call P scs m fn vargs scs' m' vres → handled_program P -> ∀ vm m_id s_id s_st st, - Pfun P fn m vargs m' vres vm m_id s_id s_st st. + Pfun P fn scs m vargs scs' m' vres vm m_id s_id s_st st. Proof using gd asm_correct. intros fn H hP. - set (Pfun := λ(m : mem) (fn : funname) (va : seq value) (m' : mem) (vr : seq value), - handled_program P -> forall vm m_id s_id s_st st, Pfun P fn m va m' vr vm m_id s_id s_st st + set (Pfun := λ (scs : syscall_state_t) (m : mem) (fn : funname) (va : seq value) (scs' : syscall_state_t) (m' : mem) (vr : seq value), + handled_program P -> forall vm m_id s_id s_st st, Pfun P fn scs m va scs' m' vr vm m_id s_id s_st st ). set (SP := (translate_prog' P).1). set (Pi_r := @@ -4930,7 +4938,7 @@ Proof using gd asm_correct. translate_for v ws m_id (translate_cmd P SP c m_id) s_id' ⇓ tt ⦃ rel_estate s2 m_id s_id'' (s_id~0 :: s_st) st ⦄ ). - unshelve eapply (@sem_call_Ind _ _ _ _ Pc Pi_r Pi Pfor Pfun _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H). + unshelve eapply (@sem_call_Ind _ _ _ _ _ _ Pc Pi_r Pi Pfor Pfun _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H). - (* nil *) intros s m_id s_id s_st st _. simpl. eapply u_ret_eq. @@ -4985,6 +4993,8 @@ Proof using gd asm_correct. eapply u_post_weaken_rule. 1: apply translate_write_lvals_correct. all: eauto. + - (* sys_call *) + easy. - (* if_true *) intros s1 s2 e c1 c2 he hc1 ihc1 m_id s_id s_st st hp. inversion hp. @@ -5005,7 +5015,6 @@ Proof using gd asm_correct. 1: eapply hdc1. 1: assumption. - (* if_false *) - (* easy. *) intros s1 s2 e c1 c2 he hc2 ihc2 m_id s_id s_st st hp. inversion hp. move: H1 => /andP [hdc1 hdc2]. @@ -5068,7 +5077,7 @@ Proof using gd asm_correct. 1: eapply ihc. eapply ihfor. - (* call *) - intros s1 m2 s2 ii xs gn args vargs' vres' hargs hgn ihgn hwr_vres m_id s_id s_st st hdi. + intros s1 scs1 m2 s2 ii xs gn args vargs' vres' hargs hgn ihgn hwr_vres m_id s_id s_st st hdi. unfold Pfun, Translation.Pfun, get_translated_fun in ihgn. simpl. eapply u_bind. @@ -5088,7 +5097,7 @@ Proof using gd asm_correct. 1:assumption. exact hwr_vres. - (* proc *) - intros m1 m2 gn g vargs' vargs'' s1 vm2 vres' vres''. + intros scs1 m1 scs2 m2 gn g vargs' vargs'' s1 vm2 vres' vres''. intros hg hvars hwr hbody ihbody hget htrunc. intros hp vm m_id s_id s_st st. unfold Translation.Pfun. @@ -5175,7 +5184,7 @@ Qed. End Translation. -From Jasmin Require Import x86_instr_decl x86_extra x86_gen x86_linear_sem. +From Jasmin Require Import x86_instr_decl x86_extra (* x86_gen *) (* x86_linear_sem *). Import arch_decl. Lemma id_tin_instr_desc : diff --git a/theories/Mon/FiniteProbabilities.v b/theories/Mon/FiniteProbabilities.v index c0fdb857..6dab741c 100644 --- a/theories/Mon/FiniteProbabilities.v +++ b/theories/Mon/FiniteProbabilities.v @@ -52,7 +52,7 @@ Section FinProb. #[program] Definition addI (x y : I) : I := ⦑ (x∙1 + y∙1) / 2%:~R ⦒. Next Obligation. - intros x y. simpl. + simpl. rewrite divr_ge0 ?Bool.andb_true_l ?ler0n ?addr_ge0 //. rewrite ler_pdivr_mulr. rewrite mul1r [2%:~R]/(1+1) ler_add //. @@ -81,7 +81,7 @@ Section FinProb. #[program] Definition barycentric_sum (p:I) (x y: I) : I := ⦑ p∙1 * x∙1 + (1-p∙1) * y∙1 ⦒. Next Obligation. - intros p x y. simpl. + simpl. set p' : I := negI p; change (1-p∙1) with p'∙1. rewrite addr_ge0 ?mulr_ge0 //. have: (1 = p∙1*1 + (1 - p∙1)*1) by rewrite !mulr1 addrA [_+1]addrC addrK. @@ -92,7 +92,7 @@ Section FinProb. #[program] Definition wopProb (p:ProbS) : WI (ProbAr p) := ⦑ fun f => barycentric_sum p (f true) (f false) ⦒. Next Obligation. - intros p ? ? H. + intros ? ? H. rewrite /Irel /=. rewrite ler_add // ler_pmul //; try by apply H. by rewrite (I_ge0 (negI p)). From 959a906b15d35e07e9473359f1a3a43605c48a9b Mon Sep 17 00:00:00 2001 From: bshvass Date: Mon, 19 Sep 2022 08:12:38 +0200 Subject: [PATCH 269/383] fix compilation --- theories/Crypt/choice_type.v | 2 +- .../Crypt/examples/package_usage_example.v | 2 +- theories/Crypt/package/pkg_heap.v | 2 +- theories/Crypt/package/pkg_rhl.v | 2 +- theories/Jasmin/jasmin_translate.v | 119 +++++++++--------- theories/Mon/FiniteProbabilities.v | 6 +- theories/Mon/SPropMonadicStructures.v | 4 - theories/Relational/Rel.v | 1 - 8 files changed, 63 insertions(+), 75 deletions(-) diff --git a/theories/Crypt/choice_type.v b/theories/Crypt/choice_type.v index 39c97eb1..98e65df7 100644 --- a/theories/Crypt/choice_type.v +++ b/theories/Crypt/choice_type.v @@ -18,7 +18,7 @@ From deriving Require Import deriving. Set Warnings "-ambiguous-paths,-notation-overridden,-notation-incompatible-format". From mathcomp Require Import ssrnat ssreflect ssrfun ssrbool ssrnum eqtype choice reals distr realsum seq all_algebra fintype. -From CoqWord Require Import word ssrZ. +From mathcomp.word Require Import word ssrZ. From Jasmin Require Import utils word. Set Warnings "ambiguous-paths,notation-overridden,notation-incompatible-format". From Crypt Require Import Prelude Axioms. diff --git a/theories/Crypt/examples/package_usage_example.v b/theories/Crypt/examples/package_usage_example.v index 152c03ac..875f9499 100644 --- a/theories/Crypt/examples/package_usage_example.v +++ b/theories/Crypt/examples/package_usage_example.v @@ -117,7 +117,7 @@ Definition sig := {sig #[0] : 'nat → 'nat }. } ; #def #[2] (_ : 'unit) : 'option ('fin 2) { #put ('nat ; 0) := 0 ;; - ret (Some (gfin 1)) + ret (Some (gfin 2)) } ; #def #[3] (m : {map 'nat → 'nat}) : 'option 'nat { ret (getm m 0) diff --git a/theories/Crypt/package/pkg_heap.v b/theories/Crypt/package/pkg_heap.v index ecec943c..2af8ac39 100644 --- a/theories/Crypt/package/pkg_heap.v +++ b/theories/Crypt/package/pkg_heap.v @@ -20,7 +20,7 @@ From Crypt Require Import Prelude Axioms ChoiceAsOrd SubDistr Couplings pkg_tactics pkg_composition. Require Import Equations.Prop.DepElim. From Equations Require Import Equations. -From CoqWord Require Import word. +From mathcomp.word Require Import word. (* Must come after importing Equations.Equations, who knows why. *) From Crypt Require Import FreeProbProg. diff --git a/theories/Crypt/package/pkg_rhl.v b/theories/Crypt/package/pkg_rhl.v index d04b2de4..38dc5949 100644 --- a/theories/Crypt/package/pkg_rhl.v +++ b/theories/Crypt/package/pkg_rhl.v @@ -2366,7 +2366,7 @@ Proof. eapply r_transR. - unfold fail. eapply rswap_cmd_eq with (c₀ := cmd_sample _) (c₁ := c). - eapply rsamplerC'_cmd with (c0 := c). + eapply rsamplerC'_cmd with (c := c). - simpl. unfold fail. eapply from_sem_jdg. intros [s₀ s₁]. hnf. intro P. hnf. intros [hpre hpost]. simpl. diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 8fb1be83..5eb767c4 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1,5 +1,6 @@ Set Warnings "-ambiguous-paths,-notation-overridden,-notation-incompatible-format". From mathcomp Require Import all_ssreflect all_algebra. +From mathcomp.word Require Import ssrZ word. From Jasmin Require Import expr compiler_util values sem. Set Warnings "ambiguous-paths,notation-overridden,notation-incompatible-format". @@ -8,7 +9,6 @@ From Jasmin Require Import expr_facts. From Coq Require Import Utf8. Set Warnings "-ambiguous-paths,-notation-overridden,-notation-incompatible-format". -From CoqWord Require Import ssrZ. Set Warnings "ambiguous-paths,notation-overridden,notation-incompatible-format". From Crypt Require Import Prelude Package. @@ -29,7 +29,7 @@ Set Default Proof Using "Type". Derive NoConfusion for result. Derive NoConfusion for value. Derive NoConfusion for wsize. -Derive NoConfusion for CoqWord.word.word. +(* Derive NoConfusion for (word wsize). *) Derive EqDec for wsize. Local Open Scope positive_scope. @@ -1845,7 +1845,7 @@ Proof. Qed. Definition rel_mem (m : mem) (h : heap) := - ∀ ptr v, + ∀ (ptr : pointer) (v : (word U8)), (* mem as array model: *) read m ptr U8 = ok v → (get_heap h mem_loc) ptr = Some v. @@ -1959,7 +1959,7 @@ Qed. #[local] Open Scope vmap_scope. Definition rel_vmap (vm : vmap) (p : p_id) (h : heap) := - ∀ (i : var) v, + ∀ (i : var) (v : sem_t (vtype i)), vm.[i] = ok v → get_heap h (translate_var p i) = coerce_to_choice_type _ (embed v). @@ -2064,24 +2064,27 @@ Inductive valid_stack : stack -> heap -> Prop := (forall s_id'', List.In s_id'' s_st -> disj s_id' s_id'') -> valid_stack ((vm, m_id, s_id', s_id :: s_st) :: st) h. +Definition valid_stack_frame '(vm, m_id, s_id, s_st) (h : heap) := + rel_vmap vm m_id h /\ + m_id ⪯ s_id /\ + valid s_id h /\ + ~ List.In s_id s_st /\ + List.NoDup s_st /\ + (forall s_id', List.In s_id' s_st -> valid s_id' h) /\ + (forall s_id', List.In s_id' s_st -> m_id ⪯ s_id') /\ + (forall s_id', List.In s_id' s_st -> disj s_id s_id') /\ + (forall s_id' s_id'', List.In s_id' s_st -> List.In s_id'' s_st -> s_id' <> s_id'' -> disj s_id' s_id''). + Lemma valid_stack_single vm m_id s_id s_st h : - rel_vmap vm m_id h -> - m_id ⪯ s_id -> - valid s_id h -> - ~ List.In s_id s_st -> - List.NoDup s_st -> - (forall s_id', List.In s_id' s_st -> valid s_id' h) -> - (forall s_id', List.In s_id' s_st -> m_id ⪯ s_id') -> - (forall s_id', List.In s_id' s_st -> disj s_id s_id') -> - (forall s_id' s_id'', List.In s_id' s_st -> List.In s_id'' s_st -> s_id' <> s_id'' -> disj s_id' s_id'') -> + valid_stack_frame (vm, m_id, s_id, s_st) h -> valid_stack [::(vm, m_id, s_id, s_st)] h. Proof. revert s_id. - induction s_st; intros s_id hrel hpre1 hvalid hnin hnodup hvalid2 hpre2 hdisj1 hdisj2. + induction s_st; intros s_id [hrel [hpre1 [hvalid [hnin [hnodup [hvalid2 [hpre2 [hdisj1 hdisj2]]]]]]]]. - constructor; auto. + constructor. - constructor; auto. - + eapply IHs_st; auto. + + eapply IHs_st; repeat split; auto. * eapply hpre2; left; auto. * eapply hvalid2; left; auto. * inversion hnodup; auto. @@ -2115,21 +2118,13 @@ Qed. Lemma valid_stack_cons vm m_id s_id s_st st h : valid_stack st h -> - rel_vmap vm m_id h -> - m_id ⪯ s_id -> (forall stf, List.In stf st -> disj m_id stf.1.2 /\ forall s_id', List.In s_id' stf.2 -> disj m_id s_id') -> - valid s_id h -> - ~ List.In s_id s_st -> - List.NoDup s_st -> - (forall s_id', List.In s_id' s_st -> valid s_id' h) -> - (forall s_id', List.In s_id' s_st -> m_id ⪯ s_id') -> - (forall s_id', List.In s_id' s_st -> disj s_id s_id') -> - (forall s_id' s_id'', List.In s_id' s_st -> List.In s_id'' s_st -> s_id' <> s_id'' -> disj s_id' s_id'') -> + valid_stack_frame (vm, m_id, s_id, s_st) h -> valid_stack ((vm, m_id, s_id, s_st) :: st) h. Proof. revert vm m_id s_id st h. - intros vm m_id s_id st h hvs hrel hpre hdisj1 hvalid1 hnin hnodup hvalid2 hpre2 hdisj2 hdisj3. - revert s_id hpre hvalid1 hnin hdisj2. induction s_st. + intros vm m_id s_id st h hvs hdisj1 [hrel [hpre1 [hvalid1 [hnin [hnodup [hvalid2 [hpre2 [hdisj2 hdisj3]]]]]]]]. + revert s_id hpre1 hvalid1 hnin hdisj2. induction s_st. - constructor; auto. - constructor; auto. + eapply IHs_st. @@ -2208,22 +2203,12 @@ Ltac split_and := Lemma invert_valid_stack st vm m_id s_id s_st h : valid_stack ((vm, m_id, s_id, s_st) :: st) h -> valid_stack st h - /\ rel_vmap vm m_id h - /\ m_id ⪯ s_id /\ (forall stf, List.In stf st -> disj m_id stf.1.2 /\ forall s_id', List.In s_id' stf.2 -> disj m_id s_id') - /\ valid s_id h - /\ ~ List.In s_id s_st - /\ List.NoDup s_st - /\ (forall s_id', List.In s_id' s_st -> valid s_id' h) - /\ (forall s_id', List.In s_id' s_st -> m_id ⪯ s_id') - /\ (forall s_id', List.In s_id' s_st -> disj s_id s_id') - /\ (forall s_id' s_id'', List.In s_id' s_st -> List.In s_id'' s_st -> s_id' <> s_id'' -> disj s_id' s_id''). + /\ valid_stack_frame (vm, m_id, s_id, s_st) h. Proof. - intros H. + intros H. unfold valid_stack_frame. split_and; subst; auto. - eapply valid_stack_valid_stack; eassumption. - - eapply valid_stack_rel_vmap; eassumption. - - inversion H; auto. - revert s_id H. induction s_st. + intros. @@ -2232,6 +2217,8 @@ Proof. + intros s_id H stf. inversion H; subst. eapply IHs_st; eauto. + - eapply valid_stack_rel_vmap; eassumption. + - inversion H; auto. - inversion H; auto. - inversion H; subst; auto. intros [contra|contra]; subst. @@ -2288,8 +2275,8 @@ Proof. eapply IHs_st; eauto. Qed. -Ltac invert_stack st hst hevm hpre hdisj hvalid hnin hnodup hvalid1 hpre1 hdisj1 hdisj2 := - apply invert_valid_stack in st as [hst [hevm [hpre [hdisj [hvalid [hnin [hnodup [hvalid1 [hpre1 [hdisj1 hdisj2]]]]]]]]]]. +Ltac invert_stack st hst hdisj hevm hpre hvalid hnin hnodup hvalid1 hpre1 hdisj1 hdisj2 := + apply invert_valid_stack in st as [hst [hdisj [hevm [hpre [hvalid [hnin [hnodup [hvalid1 [hpre1 [hdisj1 hdisj2]]]]]]]]]]. Lemma valid_stack_pop stf st : ∀ h, valid_stack (stf :: st) h -> @@ -2305,9 +2292,9 @@ Lemma valid_stack_push_sub vm m_id s_id s_st st : valid_stack ((vm, m_id, s_id~1, s_id~0 :: s_st) :: st) h. Proof. intros h vst. - invert_stack vst hst hevm hpre hdisj hvalid hnin hnodup hvalid1 hpre1 hdisj1 hdisj2. + invert_stack vst hst hdisj hevm hpre hvalid hnin hnodup hvalid1 hpre1 hdisj1 hdisj2; auto. constructor; eauto with prefix. - - eapply valid_stack_cons; eauto with prefix. + - eapply valid_stack_cons; unfold valid_stack_frame; split_and; eauto with prefix. + intros contra. eapply disj_antirefl. eapply disj_prec_l. @@ -2348,7 +2335,7 @@ Lemma valid_stack_push vm m_id s_id s_st st : Proof. intros h vst. assert (vst2:=vst). - invert_stack vst2 hst hevm hpre hdisj hvalid hnin hnodup hvalid1 hpre1 hdisj1 hdisj2; auto. + invert_stack vst2 hst hdisj hevm hpre hvalid hnin hnodup hvalid1 hpre1 hdisj1 hdisj2; auto. eapply valid_stack_push_sub in vst. eapply valid_stack_pop_sub in vst. constructor; eauto with prefix. @@ -2405,7 +2392,7 @@ Lemma valid_stack_set_heap i v vm m_id s_id s_st st m : valid_stack st (set_heap m (translate_var m_id i) v). Proof. intros vs. - invert_stack vs hst hevm hpre hdisj hvalid hnin hnodup hvalid1 hpre1 hdisj1 hdisj2. + invert_stack vs hst hdisj hevm hpre hvalid hnin hnodup hvalid1 hpre1 hdisj1 hdisj2; auto. induction hst as [ |st vm' m_id' s_id' h hst IH hevm' hpre' hvalid' hdisj' |st vm' m_id' s_id' s_id'' s_st' h hst IH hpre' hvalid' hnin' hdisj1' hdisj2']. @@ -2559,8 +2546,7 @@ Proof. eapply get_var_get_heap. - eassumption. - apply hcond in hm as [_ hst]. - invert_stack hst hst hevm hpre hdisj hvalid hnin hnodup hvalid1 hpre1 hdisj1 hdisj2. - assumption. + invert_stack hst hst hdisj hevm hpre hvalid hnin hnodup hvalid1 hpre1 hdisj1 hdisj2; auto. Qed. Lemma translate_gvar_correct (x : gvar) (v : value) s (cond : heap → Prop) m_id s_id s_st st : @@ -3365,7 +3351,7 @@ Proof. split. 1: assumption. apply hcond in hm. destruct hm as [hm hst]. - invert_stack hst hst hevm hpre hdisj hvalid hnin hnodup hvalid1 hpre1 hdisj1 hdisj2. + invert_stack hst hst hdisj hevm hpre hvalid hnin hnodup hvalid1 hpre1 hdisj1 hdisj2; auto. apply hevm in e1. rewrite e1. simpl. rewrite coerce_to_choice_type_K. rewrite coerce_to_choice_type_translate_value_to_val. @@ -3434,7 +3420,7 @@ Proof. eapply hcond in hm. assert (hm2:=hm). destruct hm2 as [hm2 hst]. - invert_stack hst hst hevm hpre hdisj hvalid hnin hnodup hvalid1 hpre1 hdisj1 hdisj2. + invert_stack hst hst hdisj hevm hpre hvalid hnin hnodup hvalid1 hpre1 hdisj1 hdisj2; auto. erewrite get_var_get_heap. 2-3: eassumption. simpl. erewrite <- type_of_get_var. 2: eassumption. rewrite coerce_to_choice_type_K. @@ -3665,10 +3651,10 @@ Lemma valid_stack_set_var i v vm s m_id s_id s_st st m : Proof. intros vs hsv. assert (vs':=vs). - invert_stack vs hst hevm hpre hdisj hvalid hnin hnodup hvalid1 hpre1 hdisj1 hdisj2. + invert_stack vs hst hdisj hevm hpre hvalid hnin hnodup hvalid1 hpre1 hdisj1 hdisj2; auto. eapply set_varP. 3: exact hsv. - intros v1 hv1 eyl; subst. - eapply valid_stack_cons; eauto. + eapply valid_stack_cons; unfold valid_stack_frame; split_and; eauto. + eapply valid_stack_set_heap. eassumption. + intros vi vt ev. @@ -3693,7 +3679,7 @@ Proof. 1: apply hvalid1; auto. apply hpre1. assumption. - intros hbo hyl hset; subst. - eapply valid_stack_cons; auto. + eapply valid_stack_cons; unfold valid_stack_frame; split_and; auto. + eapply valid_stack_set_heap. eassumption. + intros vi vt ev. @@ -4449,7 +4435,14 @@ Lemma translate_instr_r_for P SP i r c id sid : translate_for i (wrange d vlo vhi) id cᵗ fresh). Proof. reflexivity. Qed. -Ltac invert_stack st hst hevm hpre hdisj hvalid hnin hnodup hvalid1 hpre1 hdisj1 hdisj2 := apply invert_valid_stack in st as [hst [hevm [hpre [hdisj [hvalid [hnin [hnodup [hvalid1 [hpre1 [hdisj1 hdisj2]]]]]]]]]]. + +Ltac invert_stack st hst hdisj hevm hpre hvalid hnin hnodup hvalid1 hpre1 hdisj1 hdisj2 := + apply invert_valid_stack in st as [hst [hdisj [hevm [hpre [hvalid [hnin [hnodup [hvalid1 [hpre1 [hdisj1 hdisj2]]]]]]]]]]. + +Ltac split_and := + repeat lazymatch goal with + | |- _ /\ _ => split + end. Lemma valid_stack_prec vm m_id s_id1 s_id2 s_st st h : s_id1 ⪯ s_id2 -> @@ -4458,7 +4451,7 @@ Lemma valid_stack_prec vm m_id s_id1 s_id2 s_st st h : Proof. intros hpre12 vst. invert_stack vst hst hevm hpre hdisj hvalid hnin hnodup hvalid1 hpre1 hdisj1 hdisj2. - eapply valid_stack_cons; eauto with prefix. + eapply valid_stack_cons; unfold valid_stack_frame; split_and; eauto with prefix. - eapply valid_prec; eauto. - intros contra. eapply disj_antirefl. @@ -4534,9 +4527,9 @@ Proof. let (s_id', _) := translate_cmd P SP c m_id s_id in s_id ⪯ s_id'). eapply cmd_rect with - (Pr0 := Pr) - (Pi0 := Pi) - (Pc0 := Pc); + (Pr := Pr) + (Pi := Pi) + (Pc := Pc); try easy . - intros s_id. @@ -4585,9 +4578,9 @@ Proof. let (s_id', _) := translate_cmd P SP c id s_id in s_id ⪯ s_id'). eapply instr_r_Rect with - (Pr0 := Pr) - (Pi0 := Pi) - (Pc0 := Pc); + (Pr := Pr) + (Pi := Pi) + (Pc := Pc); try easy . - intros s_id. @@ -4749,9 +4742,9 @@ Proof. translate_cmd P (translate_funs P (suf ++ pre)).1 c m_id s_id = translate_cmd P (translate_funs P pre).1 c m_id s_id). eapply cmd_rect with - (Pr0 := Pr) - (Pi0 := Pi) - (Pc0 := Pc); + (Pr := Pr) + (Pi := Pi) + (Pc := Pc); try easy . - intros i c' ihi ihc s_id' hpre. @@ -5081,7 +5074,7 @@ Proof using gd asm_correct. unfold Pfun, Translation.Pfun, get_translated_fun in ihgn. simpl. eapply u_bind. - 1: eapply bind_list_pexpr_correct with (s_id0:=s_id) (s_st0:=s_st) (st0:=st); try eassumption; easy. + 1: eapply bind_list_pexpr_correct with (s_id:=s_id) (s_st:=s_st) (st:=st); try eassumption; easy. eapply u_bind with (v₁ := [seq totce (translate_value v) | v <- vres']). 1: specialize (ihgn hP (evm s1) m_id s_id s_st st). 1: eapply u_pre_weaken_rule. diff --git a/theories/Mon/FiniteProbabilities.v b/theories/Mon/FiniteProbabilities.v index 6dab741c..9f20964f 100644 --- a/theories/Mon/FiniteProbabilities.v +++ b/theories/Mon/FiniteProbabilities.v @@ -52,7 +52,7 @@ Section FinProb. #[program] Definition addI (x y : I) : I := ⦑ (x∙1 + y∙1) / 2%:~R ⦒. Next Obligation. - simpl. + intros x y. simpl. rewrite divr_ge0 ?Bool.andb_true_l ?ler0n ?addr_ge0 //. rewrite ler_pdivr_mulr. rewrite mul1r [2%:~R]/(1+1) ler_add //. @@ -81,7 +81,7 @@ Section FinProb. #[program] Definition barycentric_sum (p:I) (x y: I) : I := ⦑ p∙1 * x∙1 + (1-p∙1) * y∙1 ⦒. Next Obligation. - simpl. + simpl. intros p x y. set p' : I := negI p; change (1-p∙1) with p'∙1. rewrite addr_ge0 ?mulr_ge0 //. have: (1 = p∙1*1 + (1 - p∙1)*1) by rewrite !mulr1 addrA [_+1]addrC addrK. @@ -92,7 +92,7 @@ Section FinProb. #[program] Definition wopProb (p:ProbS) : WI (ProbAr p) := ⦑ fun f => barycentric_sum p (f true) (f false) ⦒. Next Obligation. - intros ? ? H. + intros p ? ? H. rewrite /Irel /=. rewrite ler_add // ler_pmul //; try by apply H. by rewrite (I_ge0 (negI p)). diff --git a/theories/Mon/SPropMonadicStructures.v b/theories/Mon/SPropMonadicStructures.v index 6b56cf7f..b24e069b 100644 --- a/theories/Mon/SPropMonadicStructures.v +++ b/theories/Mon/SPropMonadicStructures.v @@ -130,10 +130,6 @@ Section DiscreteMonad. Import SPropNotations. Program Definition DiscreteMonad (M:Monad) : OrderedMonad := @mkOrderedMonad M (fun A x y => x = y) _ _. - Next Obligation. - constructor. by cbv. - cbv. move=> *. etransitivity ; by eassumption. - Qed. Next Obligation. compute. move=> x y Exy x0 y0 pe_x0y0. rewrite Exy. apply functional_extensionality in pe_x0y0. diff --git a/theories/Relational/Rel.v b/theories/Relational/Rel.v index 83e124ea..ae2f0578 100644 --- a/theories/Relational/Rel.v +++ b/theories/Relational/Rel.v @@ -145,7 +145,6 @@ Section RelCat. Program Definition RelCat := mkCategory Rel arrRel (fun _ _ f1 f2 => f1 = f2) _ idRel (fun _ _ _ f g => compRel g f) _ _ _ _. - Next Obligation. cbv ; intuition. induction H. induction H0=> //. Qed. Definition rel_one : Rel := ⦑unit, unit| fun _ _ => unit⦒. Definition to_rel_one X : RelCat⦅X;rel_one⦆ := From 3b6e28e03c7f4e8fc4ad98bbaf4155d59f2f18c5 Mon Sep 17 00:00:00 2001 From: bshvass Date: Tue, 27 Sep 2022 13:37:09 +0200 Subject: [PATCH 270/383] upgrade deextraction script from `sed` to `perl` - added some documentation on deextraction - fixed issues introduced by new jasmin version --- theories/Jasmin/examples/deextract.pl | 30 +++++++++++++++++++++++++++ theories/Jasmin/examples/gen_ast.sh | 25 ++++++++++++---------- 2 files changed, 44 insertions(+), 11 deletions(-) create mode 100755 theories/Jasmin/examples/deextract.pl mode change 100644 => 100755 theories/Jasmin/examples/gen_ast.sh diff --git a/theories/Jasmin/examples/deextract.pl b/theories/Jasmin/examples/deextract.pl new file mode 100755 index 00000000..293f8b5a --- /dev/null +++ b/theories/Jasmin/examples/deextract.pl @@ -0,0 +1,30 @@ +#!/usr/bin/perl +use Regexp::Common; + +my $string = <>; + +# change easy stuff (remove names added by extraction, quote strings, etc.) +$string =~ s/Jasmin\.[[:graph:]]*\.//g ; +$string =~ s/Coq_//g ; +$string =~ s/=/:=/g ; +$string =~ s/{/{| /g ; +$string =~ s/}/ |}/g ; +$string =~ s/v_info :=[ \t\n]*[^{}]*{[^}]*}/v_info := dummy_var_info/g ; +$string =~ s/(MkI[^(]*\()\(([^()]*(\([^)]*\))*)*\)/$1dummy_instr_info/g ; +$string =~ s/([[:alnum:]]*\.[[:alnum:]]*)/"$1"/g ; +$string =~ s/\(\)/tt/g ; + +# curry functions +# pattern which matches balanced expression with either () {} or "" +my $bal = qr/$RE{balanced}{-parens=>'(){}""'}/; + +# pattern which matches an alnum (function) followed by a tuple, e.g. f (a, b) +my $pat = qr/([[:alnum:]][ \n\t]*\(([^()]|($bal))*),([ \n\t]*)(([^(),]|($bal))*)\)/; + +# propagate the final parenthesis of the tuple down and parenthesise: +# f (a, b, c) -> f (a, b) (c) -> f (a) (b) (c) +while ( $string =~ m/$pat/g ) { + $string =~ s/$pat/$1\)$5\($6\)/g; +} + +print($string); diff --git a/theories/Jasmin/examples/gen_ast.sh b/theories/Jasmin/examples/gen_ast.sh old mode 100644 new mode 100755 index 4eda692f..b5b1d8f8 --- a/theories/Jasmin/examples/gen_ast.sh +++ b/theories/Jasmin/examples/gen_ast.sh @@ -4,6 +4,10 @@ # JASMINC=... ./gen_ast.sh foo.jazz JASMINC=${JASMINC:-$(which jasminc.byte)} +# use this variable to e.g. include paths +# e.g.: ./gen_ast.sh aes '-I AES:../examples' +OPTS=${2} +echo $OPTS echo "open Format let print_vname (fmt : formatter) (t : Obj.t) = @@ -15,8 +19,6 @@ ocamlc -c print_vname.ml name=$(basename "${1}" .jazz) echo $name -mkdir $name - echo -n "Require Import List. From Jasmin Require Import expr. From Jasmin Require Import x86_extra. @@ -24,22 +26,23 @@ From Jasmin Require Import x86_extra. Import ListNotations. Local Open Scope string. -Definition ${name} :=" > $name/$name.v +Definition ${name} :=" > $name.v (ocamldebug $JASMINC < $name/$name.cprog +) > $name.cprog -sed -i '9,$!d;$d' $name/$name.cprog +# delete all but the 12 first lines and then delete the last line +sed -i '12,$!d;$d' $name.cprog -sed 's/Jasmin\.[[:graph:]]*\.//g; s/Coq_//g ; s/=/:=/g ; s/{/{| /g ; s/}/ |}/g ; s/[[:graph:]]*\.[[:graph:]]*/"&"/g ; s/()/tt/g ;/./{H;$!d}; x ; :rename_balanced ; s/(\([^(),@]*\))/<<\1>>/g ; t rename_balanced ; :rename_pairs1 ; s/\([{([|,;][ \t\n]*([^(),]*\),/\1%/g; t rename_pairs1 ; :rename_pairs ; s/\([{([|,;][ \t\n]*\)(\([^(),]*\))/\1<<\2>>/g; t rename_balanced ; :rename_curries1 ; s/\([^{([|,;][ \t\n]*([^()]*\),/\1@/g; t rename_curries1; :rename_curries ; s/\([^{([|,;][ \t\n]*\)(\([^(),]*\))/\1++\2##/g; t rename_balanced; :uncurry ; s/\([^{([|,;][ \t\n]*++[^(),]*\)@\([ \t\n]*\)/\1##\2++/g ; t uncurry s/\([^{([|][ \t\n]*++[^(),]*\)@\([ \t\n]*\)/\1##\2++/g ; t uncurry ; s/<>/)/g ; s/##/)/g ; s/++/(/g ; s/%/,/g ; s/@/,/g' $name/$name.cprog >> $name/$name.v +perl -0777 deextract.pl $name.cprog >> $name.v -echo -n "." >> $name/$name.v +echo -n "." >> $name.v From 468a41fa79990a351d588c4db2ae3278630fa582 Mon Sep 17 00:00:00 2001 From: bshvass Date: Tue, 27 Sep 2022 13:38:34 +0200 Subject: [PATCH 271/383] regenerated examples - also added `aes` example (note that deextraction does not work here yet) --- .../Jasmin/examples/{add1 => }/add1.cprog | 61 +- theories/Jasmin/examples/{add1 => }/add1.jazz | 0 theories/Jasmin/examples/add1.v | 66 + theories/Jasmin/examples/add1/add1.v | 139 - theories/Jasmin/examples/aes.cprog | 2493 +++++++++++++++++ theories/Jasmin/examples/aes.jazz | 20 + theories/Jasmin/examples/aes.jinc | 124 + theories/Jasmin/examples/aes.v | 1672 +++++++++++ .../Jasmin/examples/{bigadd => }/bigadd.cprog | 347 +-- .../Jasmin/examples/{bigadd => }/bigadd.jazz | 0 theories/Jasmin/examples/bigadd.v | 310 ++ theories/Jasmin/examples/bigadd/bigadd.v | 553 ---- theories/Jasmin/examples/ex.cprog | 120 + theories/Jasmin/examples/{ex => }/ex.jazz | 0 theories/Jasmin/examples/ex.v | 96 + theories/Jasmin/examples/ex/ex.cprog | 122 - theories/Jasmin/examples/ex/ex.v | 131 - theories/Jasmin/examples/int_add.cprog | 173 ++ .../{int_operations => }/int_add.jazz | 0 theories/Jasmin/examples/int_add.v | 121 + theories/Jasmin/examples/int_incr.cprog | 141 + .../{int_operations => }/int_incr.jazz | 0 theories/Jasmin/examples/int_incr.v | 98 + .../int_operations/int_intr_wrapper.c | 5 - theories/Jasmin/examples/int_reg.cprog | 46 + .../{int_operations => }/int_reg.jazz | 0 theories/Jasmin/examples/int_reg.v | 38 + theories/Jasmin/examples/int_shift.cprog | 120 + .../{int_operations => }/int_shift.jazz | 0 theories/Jasmin/examples/int_shift.v | 87 + theories/Jasmin/examples/liveness_bork.cprog | 86 + .../{int_operations => }/liveness_bork.jazz | 0 theories/Jasmin/examples/liveness_bork.v | 65 + .../{matrix_product => }/matrix_product.cprog | 1309 ++++----- .../{matrix_product => }/matrix_product.jazz | 0 .../{matrix_product => }/matrix_product.v | 1074 ++----- .../Jasmin/examples/{retz => }/retz.cprog | 24 +- theories/Jasmin/examples/{retz => }/retz.jazz | 0 theories/Jasmin/examples/{retz => }/retz.v | 22 +- .../examples/{test_for => }/test_for.cprog | 69 +- .../examples/{test_for => }/test_for.jazz | 0 .../Jasmin/examples/{test_for => }/test_for.v | 50 +- .../test_inline_var.cprog | 249 +- .../test_inline_var.jazz | 0 .../{test_inline_var => }/test_inline_var.v | 199 +- .../{test_shift => }/test_shift.cprog | 33 +- .../examples/{test_shift => }/test_shift.jazz | 0 .../examples/{test_shift => }/test_shift.v | 28 +- .../three_functions.cprog | 179 +- .../three_functions.jazz | 0 theories/Jasmin/examples/three_functions.v | 147 + .../three_functions/three_functions.v | 291 -- theories/Jasmin/examples/two_functions.cprog | 109 + .../{two_functions => }/two_functions.jazz | 0 theories/Jasmin/examples/two_functions.v | 83 + .../two_functions/two_functions.cprog | 102 - .../examples/two_functions/two_functions.v | 233 -- theories/Jasmin/examples/u64_incr.cprog | 93 + .../{int_operations => }/u64_incr.jazz | 0 theories/Jasmin/examples/u64_incr.v | 74 + theories/Jasmin/examples/{xor => }/xor.cprog | 74 +- theories/Jasmin/examples/{xor => }/xor.jazz | 0 theories/Jasmin/examples/xor.v | 77 + theories/Jasmin/examples/xor/xor.v | 175 -- 64 files changed, 7863 insertions(+), 4065 deletions(-) rename theories/Jasmin/examples/{add1 => }/add1.cprog (53%) rename theories/Jasmin/examples/{add1 => }/add1.jazz (100%) create mode 100644 theories/Jasmin/examples/add1.v delete mode 100644 theories/Jasmin/examples/add1/add1.v create mode 100644 theories/Jasmin/examples/aes.cprog create mode 100644 theories/Jasmin/examples/aes.jazz create mode 100644 theories/Jasmin/examples/aes.jinc create mode 100644 theories/Jasmin/examples/aes.v rename theories/Jasmin/examples/{bigadd => }/bigadd.cprog (55%) rename theories/Jasmin/examples/{bigadd => }/bigadd.jazz (100%) create mode 100644 theories/Jasmin/examples/bigadd.v delete mode 100644 theories/Jasmin/examples/bigadd/bigadd.v create mode 100644 theories/Jasmin/examples/ex.cprog rename theories/Jasmin/examples/{ex => }/ex.jazz (100%) create mode 100644 theories/Jasmin/examples/ex.v delete mode 100644 theories/Jasmin/examples/ex/ex.cprog delete mode 100644 theories/Jasmin/examples/ex/ex.v create mode 100644 theories/Jasmin/examples/int_add.cprog rename theories/Jasmin/examples/{int_operations => }/int_add.jazz (100%) create mode 100644 theories/Jasmin/examples/int_add.v create mode 100644 theories/Jasmin/examples/int_incr.cprog rename theories/Jasmin/examples/{int_operations => }/int_incr.jazz (100%) create mode 100644 theories/Jasmin/examples/int_incr.v delete mode 100644 theories/Jasmin/examples/int_operations/int_intr_wrapper.c create mode 100644 theories/Jasmin/examples/int_reg.cprog rename theories/Jasmin/examples/{int_operations => }/int_reg.jazz (100%) create mode 100644 theories/Jasmin/examples/int_reg.v create mode 100644 theories/Jasmin/examples/int_shift.cprog rename theories/Jasmin/examples/{int_operations => }/int_shift.jazz (100%) create mode 100644 theories/Jasmin/examples/int_shift.v create mode 100644 theories/Jasmin/examples/liveness_bork.cprog rename theories/Jasmin/examples/{int_operations => }/liveness_bork.jazz (100%) create mode 100644 theories/Jasmin/examples/liveness_bork.v rename theories/Jasmin/examples/{matrix_product => }/matrix_product.cprog (61%) rename theories/Jasmin/examples/{matrix_product => }/matrix_product.jazz (100%) rename theories/Jasmin/examples/{matrix_product => }/matrix_product.v (58%) rename theories/Jasmin/examples/{retz => }/retz.cprog (52%) rename theories/Jasmin/examples/{retz => }/retz.jazz (100%) rename theories/Jasmin/examples/{retz => }/retz.v (65%) rename theories/Jasmin/examples/{test_for => }/test_for.cprog (51%) rename theories/Jasmin/examples/{test_for => }/test_for.jazz (100%) rename theories/Jasmin/examples/{test_for => }/test_for.v (59%) rename theories/Jasmin/examples/{test_inline_var => }/test_inline_var.cprog (50%) rename theories/Jasmin/examples/{test_inline_var => }/test_inline_var.jazz (100%) rename theories/Jasmin/examples/{test_inline_var => }/test_inline_var.v (50%) rename theories/Jasmin/examples/{test_shift => }/test_shift.cprog (61%) rename theories/Jasmin/examples/{test_shift => }/test_shift.jazz (100%) rename theories/Jasmin/examples/{test_shift => }/test_shift.v (69%) rename theories/Jasmin/examples/{three_functions => }/three_functions.cprog (50%) rename theories/Jasmin/examples/{three_functions => }/three_functions.jazz (100%) create mode 100644 theories/Jasmin/examples/three_functions.v delete mode 100644 theories/Jasmin/examples/three_functions/three_functions.v create mode 100644 theories/Jasmin/examples/two_functions.cprog rename theories/Jasmin/examples/{two_functions => }/two_functions.jazz (100%) create mode 100644 theories/Jasmin/examples/two_functions.v delete mode 100644 theories/Jasmin/examples/two_functions/two_functions.cprog delete mode 100644 theories/Jasmin/examples/two_functions/two_functions.v create mode 100644 theories/Jasmin/examples/u64_incr.cprog rename theories/Jasmin/examples/{int_operations => }/u64_incr.jazz (100%) create mode 100644 theories/Jasmin/examples/u64_incr.v rename theories/Jasmin/examples/{xor => }/xor.cprog (52%) rename theories/Jasmin/examples/{xor => }/xor.jazz (100%) create mode 100644 theories/Jasmin/examples/xor.v delete mode 100644 theories/Jasmin/examples/xor/xor.v diff --git a/theories/Jasmin/examples/add1/add1.cprog b/theories/Jasmin/examples/add1.cprog similarity index 53% rename from theories/Jasmin/examples/add1/add1.cprog rename to theories/Jasmin/examples/add1.cprog index 27d0ccab..0bc34613 100644 --- a/theories/Jasmin/examples/add1/add1.cprog +++ b/theories/Jasmin/examples/add1.cprog @@ -1,53 +1,58 @@ {Jasmin.Expr.p_funcs = - [(Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH, - {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH; + [(Jasmin.BinNums.Coq_xH, + {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH; f_tyin = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; f_params = [{Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = arg.130}; + vname = arg.141}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)}]; + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; f_body = [Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)), + (({Jasmin.Location.uid_loc = 2; + base_loc = + {Jasmin.Location.loc_fname = "add1.jazz"; loc_start = (4, 0); + loc_end = (4, 9); loc_bchar = 52; loc_echar = 61}; + stack_loc = []}, + []), Jasmin.Expr.Cassgn (Jasmin.Expr.Lvar {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = z.131}; + vname = z.142}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}, + {Jasmin.Location.loc_fname = "add1.jazz"; loc_start = (4, 0); + loc_end = (4, 1); loc_bchar = 52; loc_echar = 53}}, Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = arg.130}; + vname = arg.141}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}; + {Jasmin.Location.loc_fname = "add1.jazz"; loc_start = (4, 5); + loc_end = (4, 8); loc_bchar = 57; loc_echar = 60}}; gs = Jasmin.Expr.Slocal})); Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH), + (({Jasmin.Location.uid_loc = 3; + base_loc = + {Jasmin.Location.loc_fname = "add1.jazz"; loc_start = (5, 0); + loc_end = (5, 7); loc_bchar = 62; loc_echar = 69}; + stack_loc = []}, + []), Jasmin.Expr.Cassgn (Jasmin.Expr.Lvar {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = z.131}; + vname = z.142}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)}, + {Jasmin.Location.loc_fname = "add1.jazz"; loc_start = (5, 0); + loc_end = (5, 1); loc_bchar = 62; loc_echar = 63}}, Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, Jasmin.Expr.Papp2 (Jasmin.Expr.Oadd (Jasmin.Expr.Op_w Jasmin.Wsize.U64), @@ -56,10 +61,11 @@ {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = z.131}; + vname = z.142}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)}; + {Jasmin.Location.loc_fname = "add1.jazz"; + loc_start = (5, 0); loc_end = (5, 1); loc_bchar = 62; + loc_echar = 63}}; gs = Jasmin.Expr.Slocal}, Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U64, Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos Jasmin.BinNums.Coq_xH)))))]; @@ -67,10 +73,9 @@ f_res = [{Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = z.131}; + vname = z.142}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}]; + {Jasmin.Location.loc_fname = "add1.jazz"; loc_start = (6, 7); + loc_end = (6, 8); loc_bchar = 77; loc_echar = 78}}]; f_extra = ()})]; p_globs = []; p_extra = ()} diff --git a/theories/Jasmin/examples/add1/add1.jazz b/theories/Jasmin/examples/add1.jazz similarity index 100% rename from theories/Jasmin/examples/add1/add1.jazz rename to theories/Jasmin/examples/add1.jazz diff --git a/theories/Jasmin/examples/add1.v b/theories/Jasmin/examples/add1.v new file mode 100644 index 00000000..8ba3b221 --- /dev/null +++ b/theories/Jasmin/examples/add1.v @@ -0,0 +1,66 @@ +Require Import List. +From Jasmin Require Import expr. +From Jasmin Require Import x86_extra. + +Import ListNotations. +Local Open Scope string. + +Definition add1 := {| p_funcs := + [(xH, + {| f_info := xO xH; + f_tyin := [sword U64]; + f_params := + [{| v_var := + {| vtype := sword U64; + vname := "arg.141" |}; + v_info := dummy_var_info |}]; + f_body := + [MkI + (dummy_instr_info) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "z.142" |}; + v_info := dummy_var_info |}) + (AT_none) (sword U64) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "arg.141" |}; + v_info := dummy_var_info |}; + gs := Slocal |})); + MkI + (dummy_instr_info) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "z.142" |}; + v_info := dummy_var_info |}) + (AT_none) (sword U64) + (Papp2 + (Oadd (Op_w U64)) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "z.142" |}; + v_info := dummy_var_info |}; + gs := Slocal |}) + (Papp1 (Oword_of_int U64) + (Pconst (Zpos xH)))))]; + f_tyout := [sword U64]; + f_res := + [{| v_var := + {| vtype := sword U64; + vname := "z.142" |}; + v_info := dummy_var_info |}]; + f_extra := tt |})]; + p_globs := []; p_extra := tt |} +. \ No newline at end of file diff --git a/theories/Jasmin/examples/add1/add1.v b/theories/Jasmin/examples/add1/add1.v deleted file mode 100644 index 2bf8f613..00000000 --- a/theories/Jasmin/examples/add1/add1.v +++ /dev/null @@ -1,139 +0,0 @@ -Set Warnings "-notation-overridden,-ambiguous-paths". -From mathcomp Require Import all_ssreflect all_algebra reals distr realsum - fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool ssrnum - eqtype choice seq. -Set Warnings "notation-overridden,ambiguous-paths". - -Require Import List. -From Jasmin Require Import expr. -(* From Jasmin Require Import x86_extra. *) -From JasminSSProve Require Import jasmin_translate. -From Crypt Require Import Prelude Package. - -Import ListNotations. -Local Open Scope string. - -Context `{asmop : asmOp}. - -Context {T} {pT : progT T}. - -Context {pd : PointerData}. - -Context (P : uprog). - -Context (f : funname). - -Definition add1_body := [MkI - (xO - (xO - (xO xH))) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "z.131" |}; - v_info := - xO - (xI - (xO xH)) |}) - (AT_none) (sword U64) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "arg.130" |}; - v_info := - xI - (xO - (xO xH)) |}; - gs := Slocal |})); - MkI - (xI - (xO xH)) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "z.131" |}; - v_info := - xI - (xI xH) |}) - (AT_none) (sword U64) - (Papp2 - (Oadd (Op_w U64)) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "z.131" |}; - v_info := - xO - (xI xH) |}; - gs := Slocal |}) - (Papp1 (Oword_of_int U64) - (Pconst (Zpos xH)))))]. - -Definition add1 := - {| p_funcs := - [(xO xH, - {| f_info := xI xH; - f_tyin := [sword U64]; - f_params := - [{| v_var := - {| vtype := sword U64; - vname := "arg.130" |}; - v_info := - xO - (xO xH) |}]; - f_body := - add1_body; - f_tyout := [sword U64]; - f_res := - [{| v_var := - {| vtype := sword U64; - vname := "z.131" |}; - v_info := - xI - (xI - (xO xH)) |}]; - f_extra := tt |})]; - p_globs := []; p_extra := tt |} -. - - -Import PackageNotation. -Notation coe_cht := coerce_to_choice_type. -Notation coe_tyc := coerce_typed_code. -Notation " 'array " := (chMap 'int ('word U8)) (at level 2) : package_scope. -Notation " 'array " := (chMap 'int ('word U8)) (in custom pack_type at level 2). -Notation " 'mem " := (chMap ('word Uptr) ('word U8)) (at level 2) : package_scope. -Notation " 'mem " := (chMap ('word Uptr) ('word U8)) (in custom pack_type at level 2). -Notation " ⸨ ws ⸩ a .[ ptr * scale ] " := (chArray_get ws a ptr scale) - (format " ⸨ ws ⸩ a .[ ptr * scale ] "). -Notation " a [ w / p ] " := - (chArray_set a AAscale p w) - (at level 99, no associativity, - format " a [ w / p ] "). - -Import GroupScope GRing.Theory. -Local Open Scope ring_scope. -From extructures Require Import fmap. - -Definition body_tr := - translate_cmd P emptym xH add1_body. -Eval cbn in body_tr. -Goal body_tr = body_tr. - unfold body_tr at 2. - unfold translate_cmd. - simpl. - unfold translate_var. simpl. - set (arg := ('word U64; nat_of_fun_ident 1%positive "arg.130")). - set (z := ('word U64; nat_of_fun_ident 1%positive "z.131")). - rewrite !coerce_to_choice_type_K. - repeat setoid_rewrite zero_extend_u. - unfold wsize_size. - unfold wrepr. simpl. unfold nat63; unfold nat31; unfold nat15; unfold nat7. diff --git a/theories/Jasmin/examples/aes.cprog b/theories/Jasmin/examples/aes.cprog new file mode 100644 index 00000000..f269b824 --- /dev/null +++ b/theories/Jasmin/examples/aes.cprog @@ -0,0 +1,2493 @@ + {Jasmin.Expr.p_funcs = + [(Jasmin.BinNums.Coq_xH, + {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH; + f_tyin = + [Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = key.280}; + v_info = + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}; + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = in.281}; + v_info = + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; + f_body = + [Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 42; + base_loc = + {Jasmin.Location.loc_fname = "aes.jazz"; loc_start = (18, 3); + loc_end = (18, 24); loc_bchar = 396; loc_echar = 417}; + stack_loc = []}, + []), + Jasmin.Expr.Ccall (Jasmin.Expr.InlineFun, + [Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = out.282}; + v_info = + {Jasmin.Location.loc_fname = "aes.jazz"; loc_start = (18, 3); + loc_end = (18, 6); loc_bchar = 396; loc_echar = 399}}], + Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH, + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = key.280}; + v_info = + {Jasmin.Location.loc_fname = "aes.jazz"; + loc_start = (18, 16); loc_end = (18, 19); loc_bchar = 409; + loc_echar = 412}}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = in.281}; + v_info = + {Jasmin.Location.loc_fname = "aes.jazz"; + loc_start = (18, 20); loc_end = (18, 22); loc_bchar = 413; + loc_echar = 415}}; + gs = Jasmin.Expr.Slocal}]))]; + f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = out.282}; + v_info = + {Jasmin.Location.loc_fname = "aes.jazz"; loc_start = (19, 10); + loc_end = (19, 13); loc_bchar = 428; loc_echar = 431}}]; + f_extra = ()}); + (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH), + {Jasmin.Expr.f_info = + Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH); + f_tyin = + [Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = key.283}; + v_info = + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}; + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = in.284}; + v_info = + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; + f_body = + [Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 41; + base_loc = + {Jasmin.Location.loc_fname = "aes.jazz"; loc_start = (11, 3); + loc_end = (11, 21); loc_bchar = 276; loc_echar = 294}; + stack_loc = []}, + []), + Jasmin.Expr.Ccall (Jasmin.Expr.InlineFun, + [Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = out.285}; + v_info = + {Jasmin.Location.loc_fname = "aes.jazz"; loc_start = (11, 3); + loc_end = (11, 6); loc_bchar = 276; loc_echar = 279}}], + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH), + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = key.283}; + v_info = + {Jasmin.Location.loc_fname = "aes.jazz"; + loc_start = (11, 13); loc_end = (11, 16); loc_bchar = 286; + loc_echar = 289}}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = in.284}; + v_info = + {Jasmin.Location.loc_fname = "aes.jazz"; + loc_start = (11, 17); loc_end = (11, 19); loc_bchar = 290; + loc_echar = 292}}; + gs = Jasmin.Expr.Slocal}]))]; + f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = out.285}; + v_info = + {Jasmin.Location.loc_fname = "aes.jazz"; loc_start = (12, 10); + loc_end = (12, 13); loc_bchar = 305; loc_echar = 308}}]; + f_extra = ()}); + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH, + {Jasmin.Expr.f_info = + Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH); + f_tyin = + [Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = key.286}; + v_info = + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}; + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = in.287}; + v_info = + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; + f_body = + [Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 39; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (121, 2); loc_end = (121, 31); loc_bchar = 2902; + loc_echar = 2931}; + stack_loc = []}, + []), + Jasmin.Expr.Ccall (Jasmin.Expr.InlineFun, + [Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))); + vname = rkeys.289}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (121, 2); loc_end = (121, 7); loc_bchar = 2902; + loc_echar = 2907}}], + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)), + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = key.286}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (121, 26); loc_end = (121, 29); + loc_bchar = 2926; loc_echar = 2929}}; + gs = Jasmin.Expr.Slocal}])); + Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 40; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (122, 2); loc_end = (122, 35); loc_bchar = 2934; + loc_echar = 2967}; + stack_loc = []}, + []), + Jasmin.Expr.Ccall (Jasmin.Expr.InlineFun, + [Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = out.288}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (122, 2); loc_end = (122, 5); loc_bchar = 2934; + loc_echar = 2937}}], + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)), + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))); + vname = rkeys.289}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (122, 24); loc_end = (122, 29); + loc_bchar = 2956; loc_echar = 2961}}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = in.287}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (122, 31); loc_end = (122, 33); + loc_bchar = 2963; loc_echar = 2965}}; + gs = Jasmin.Expr.Slocal}]))]; + f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = out.288}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (123, 9); loc_end = (123, 12); loc_bchar = 2977; + loc_echar = 2980}}]; + f_extra = ()}); + (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH), + {Jasmin.Expr.f_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)); + f_tyin = + [Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = key.290}; + v_info = + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}; + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = in.291}; + v_info = + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; + f_body = + [Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 37; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (111, 2); loc_end = (111, 27); loc_bchar = 2727; + loc_echar = 2752}; + stack_loc = []}, + []), + Jasmin.Expr.Ccall (Jasmin.Expr.InlineFun, + [Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))); + vname = rkeys.293}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (111, 2); loc_end = (111, 7); loc_bchar = 2727; + loc_echar = 2732}}], + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)), + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = key.290}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (111, 22); loc_end = (111, 25); + loc_bchar = 2747; loc_echar = 2750}}; + gs = Jasmin.Expr.Slocal}])); + Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 38; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (112, 2); loc_end = (112, 32); loc_bchar = 2755; + loc_echar = 2785}; + stack_loc = []}, + []), + Jasmin.Expr.Ccall (Jasmin.Expr.InlineFun, + [Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = out.292}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (112, 2); loc_end = (112, 5); loc_bchar = 2755; + loc_echar = 2758}}], + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)), + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))); + vname = rkeys.293}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (112, 21); loc_end = (112, 26); + loc_bchar = 2774; loc_echar = 2779}}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = in.291}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (112, 28); loc_end = (112, 30); + loc_bchar = 2781; loc_echar = 2783}}; + gs = Jasmin.Expr.Slocal}]))]; + f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = out.292}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (113, 9); loc_end = (113, 12); loc_bchar = 2795; + loc_echar = 2798}}]; + f_extra = ()}); + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)), + {Jasmin.Expr.f_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)); + f_tyin = + [Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))); + Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))); + vname = rkeys.294}; + v_info = + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}; + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = in.295}; + v_info = + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; + f_body = + [Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 31; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (93, 2); loc_end = (93, 13); loc_bchar = 2274; + loc_echar = 2285}; + stack_loc = []}, + []), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = state.296}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (93, 2); loc_end = (93, 7); loc_bchar = 2274; + loc_echar = 2279}}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U128, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = in.295}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (93, 10); loc_end = (93, 12); loc_bchar = 2282; + loc_echar = 2284}}; + gs = Jasmin.Expr.Slocal})); + Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 32; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (94, 2); loc_end = (94, 17); loc_bchar = 2288; + loc_echar = 2303}; + stack_loc = []}, + []), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = rk.297}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (94, 2); loc_end = (94, 4); loc_bchar = 2288; + loc_echar = 2290}}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U128, + Jasmin.Expr.Pget (Jasmin.Warray_.AAscale, Jasmin.Wsize.U128, + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))); + vname = rkeys.294}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (94, 7); loc_end = (94, 12); loc_bchar = 2293; + loc_echar = 2298}}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))); + Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 33; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (95, 2); loc_end = (95, 32); loc_bchar = 2306; + loc_echar = 2336}; + stack_loc = []}, + []), + Jasmin.Expr.Ccall (Jasmin.Expr.InlineFun, + [Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = state.296}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (95, 2); loc_end = (95, 7); loc_bchar = 2306; + loc_echar = 2311}}], + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)), + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = state.296}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (95, 22); loc_end = (95, 27); loc_bchar = 2326; + loc_echar = 2331}}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = rk.297}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (95, 28); loc_end = (95, 30); loc_bchar = 2332; + loc_echar = 2334}}; + gs = Jasmin.Expr.Slocal}])); + Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 35; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (96, 2); loc_end = (98, 3); loc_bchar = 2340; + loc_echar = 2411}; + stack_loc = []}, + []), + Jasmin.Expr.Cfor + ({Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = round.298}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (96, 6); loc_end = (96, 11); loc_bchar = 2344; + loc_echar = 2349}}, + ((Jasmin.Expr.DownTo, Jasmin.Expr.Pconst Jasmin.BinNums.Z0), + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), + [Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 34; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (97, 4); loc_end = (97, 41); loc_bchar = 2370; + loc_echar = 2407}; + stack_loc = []}, + []), + Jasmin.Expr.Copn + ([Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = state.296}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (97, 4); loc_end = (97, 9); loc_bchar = 2370; + loc_echar = 2375}}], + Jasmin.Expr.AT_keep, + Jasmin.Sopn.Oasm (Jasmin.Arch_extra.BaseOp (None, )), + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = state.296}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (97, 20); loc_end = (97, 25); + loc_bchar = 2386; loc_echar = 2391}}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Pget (Jasmin.Warray_.AAscale, Jasmin.Wsize.U128, + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + Jasmin.BinNums.Coq_xH))))))); + vname = rkeys.294}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (97, 27); loc_end = (97, 32); + loc_bchar = 2393; loc_echar = 2398}}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = round.298}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (97, 33); loc_end = (97, 38); + loc_bchar = 2399; loc_echar = 2404}}; + gs = Jasmin.Expr.Slocal})]))])); + Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 36; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (99, 2); loc_end = (99, 39); loc_bchar = 2414; + loc_echar = 2451}; + stack_loc = []}, + []), + Jasmin.Expr.Copn + ([Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = state.296}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (99, 2); loc_end = (99, 7); loc_bchar = 2414; + loc_echar = 2419}}], + Jasmin.Expr.AT_keep, + Jasmin.Sopn.Oasm (Jasmin.Arch_extra.BaseOp (None, )), + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = state.296}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (99, 22); loc_end = (99, 27); loc_bchar = 2434; + loc_echar = 2439}}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Pget (Jasmin.Warray_.AAscale, Jasmin.Wsize.U128, + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))); + vname = rkeys.294}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (99, 29); loc_end = (99, 34); loc_bchar = 2441; + loc_echar = 2446}}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pconst Jasmin.BinNums.Z0)]))]; + f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = state.296}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (100, 9); loc_end = (100, 14); loc_bchar = 2461; + loc_echar = 2466}}]; + f_extra = ()}); + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)), + {Jasmin.Expr.f_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)); + f_tyin = + [Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = state.299}; + v_info = + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}; + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = rk.300}; + v_info = + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; + f_body = + [Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 30; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (85, 3); loc_end = (85, 22); loc_bchar = 2105; + loc_echar = 2124}; + stack_loc = []}, + []), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = state.299}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (85, 3); loc_end = (85, 8); loc_bchar = 2105; + loc_echar = 2110}}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U128, + Jasmin.Expr.Papp2 (Jasmin.Expr.Olxor Jasmin.Wsize.U128, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = state.299}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (85, 11); loc_end = (85, 16); loc_bchar = 2113; + loc_echar = 2118}}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = rk.300}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (85, 19); loc_end = (85, 21); loc_bchar = 2121; + loc_echar = 2123}}; + gs = Jasmin.Expr.Slocal})))]; + f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = state.299}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (86, 10); loc_end = (86, 15); loc_bchar = 2135; + loc_echar = 2140}}]; + f_extra = ()}); + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)), + {Jasmin.Expr.f_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))); + f_tyin = + [Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))); + Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))); + vname = rkeys.301}; + v_info = + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}; + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = in.302}; + v_info = + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; + f_body = + [Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 25; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (75, 2); loc_end = (75, 13); loc_bchar = 1869; + loc_echar = 1880}; + stack_loc = []}, + []), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = state.303}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (75, 2); loc_end = (75, 7); loc_bchar = 1869; + loc_echar = 1874}}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U128, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = in.302}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (75, 10); loc_end = (75, 12); loc_bchar = 1877; + loc_echar = 1879}}; + gs = Jasmin.Expr.Slocal})); + Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 26; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (76, 2); loc_end = (76, 20); loc_bchar = 1883; + loc_echar = 1901}; + stack_loc = []}, + []), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = state.303}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (76, 2); loc_end = (76, 7); loc_bchar = 1883; + loc_echar = 1888}}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U128, + Jasmin.Expr.Papp2 (Jasmin.Expr.Olxor Jasmin.Wsize.U128, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = state.303}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (76, 2); loc_end = (76, 7); loc_bchar = 1883; + loc_echar = 1888}}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pget (Jasmin.Warray_.AAscale, Jasmin.Wsize.U128, + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))); + vname = rkeys.301}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (76, 11); loc_end = (76, 16); loc_bchar = 1892; + loc_echar = 1897}}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pconst Jasmin.BinNums.Z0)))); + Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 28; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (77, 2); loc_end = (79, 3); loc_bchar = 1905; + loc_echar = 1973}; + stack_loc = []}, + []), + Jasmin.Expr.Cfor + ({Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = round.304}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (77, 6); loc_end = (77, 11); loc_bchar = 1909; + loc_echar = 1914}}, + ((Jasmin.Expr.UpTo, + Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos Jasmin.BinNums.Coq_xH)), + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), + [Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 27; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (78, 4); loc_end = (78, 41); loc_bchar = 1932; + loc_echar = 1969}; + stack_loc = []}, + []), + Jasmin.Expr.Copn + ([Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = state.303}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (78, 4); loc_end = (78, 9); loc_bchar = 1932; + loc_echar = 1937}}], + Jasmin.Expr.AT_keep, + Jasmin.Sopn.Oasm (Jasmin.Arch_extra.BaseOp (None, )), + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = state.303}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (78, 20); loc_end = (78, 25); + loc_bchar = 1948; loc_echar = 1953}}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Pget (Jasmin.Warray_.AAscale, Jasmin.Wsize.U128, + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + Jasmin.BinNums.Coq_xH))))))); + vname = rkeys.301}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (78, 27); loc_end = (78, 32); + loc_bchar = 1955; loc_echar = 1960}}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = round.304}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (78, 33); loc_end = (78, 38); + loc_bchar = 1961; loc_echar = 1966}}; + gs = Jasmin.Expr.Slocal})]))])); + Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 29; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (80, 2); loc_end = (80, 40); loc_bchar = 1976; + loc_echar = 2014}; + stack_loc = []}, + []), + Jasmin.Expr.Copn + ([Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = state.303}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (80, 2); loc_end = (80, 7); loc_bchar = 1976; + loc_echar = 1981}}], + Jasmin.Expr.AT_keep, + Jasmin.Sopn.Oasm (Jasmin.Arch_extra.BaseOp (None, )), + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = state.303}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (80, 22); loc_end = (80, 27); loc_bchar = 1996; + loc_echar = 2001}}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Pget (Jasmin.Warray_.AAscale, Jasmin.Wsize.U128, + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))); + vname = rkeys.301}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (80, 29); loc_end = (80, 34); loc_bchar = 2003; + loc_echar = 2008}}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))]))]; + f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = state.303}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (81, 9); loc_end = (81, 14); loc_bchar = 2024; + loc_echar = 2029}}]; + f_extra = ()}); + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)), + {Jasmin.Expr.f_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))); + f_tyin = [Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = key.305}; + v_info = + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; + f_body = + [Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 17; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (58, 2); loc_end = (58, 17); loc_bchar = 1487; + loc_echar = 1502}; + stack_loc = []}, + []), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Laset (Jasmin.Warray_.AAscale, Jasmin.Wsize.U128, + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))); + vname = rkeys.306}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (58, 2); loc_end = (58, 7); loc_bchar = 1487; + loc_echar = 1492}}, + Jasmin.Expr.Pconst Jasmin.BinNums.Z0), + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U128, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = key.305}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (58, 13); loc_end = (58, 16); loc_bchar = 1498; + loc_echar = 1501}}; + gs = Jasmin.Expr.Slocal})); + Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 18; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (59, 2); loc_end = (59, 25); loc_bchar = 1505; + loc_echar = 1528}; + stack_loc = []}, + []), + Jasmin.Expr.Copn + ([Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = temp2.307}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (59, 2); loc_end = (59, 7); loc_bchar = 1505; + loc_echar = 1510}}], + Jasmin.Expr.AT_keep, + Jasmin.Sopn.Oasm (Jasmin.Arch_extra.ExtOp ), [])); + Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 24; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (60, 2); loc_end = (68, 3); loc_bchar = 1531; + loc_echar = 1732}; + stack_loc = []}, + []), + Jasmin.Expr.Cfor + ({Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = round.308}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (60, 6); loc_end = (60, 11); loc_bchar = 1535; + loc_echar = 1540}}, + ((Jasmin.Expr.UpTo, + Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos Jasmin.BinNums.Coq_xH)), + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), + [Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 19; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (61, 4); loc_end = (61, 23); loc_bchar = 1557; + loc_echar = 1576}; + stack_loc = []}, + []), + Jasmin.Expr.Ccall (Jasmin.Expr.InlineFun, + [Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = rcon.309}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (61, 4); loc_end = (61, 8); loc_bchar = 1557; + loc_echar = 1561}}], + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = round.308}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (61, 16); loc_end = (61, 21); + loc_bchar = 1569; loc_echar = 1574}}; + gs = Jasmin.Expr.Slocal}])); + Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 20; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (62, 4); loc_end = (62, 48); loc_bchar = 1581; + loc_echar = 1625}; + stack_loc = []}, + []), + Jasmin.Expr.Ccall (Jasmin.Expr.InlineFun, + [Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = key.305}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (62, 5); loc_end = (62, 8); loc_bchar = 1582; + loc_echar = 1585}}; + Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = temp2.307}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (62, 10); loc_end = (62, 15); + loc_bchar = 1587; loc_echar = 1592}}], + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = rcon.309}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (62, 30); loc_end = (62, 34); + loc_bchar = 1607; loc_echar = 1611}}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = key.305}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (62, 36); loc_end = (62, 39); + loc_bchar = 1613; loc_echar = 1616}}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = temp2.307}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (62, 41); loc_end = (62, 46); + loc_bchar = 1618; loc_echar = 1623}}; + gs = Jasmin.Expr.Slocal}])); + Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 23; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (63, 4); loc_end = (67, 5); loc_bchar = 1630; + loc_echar = 1728}; + stack_loc = []}, + []), + Jasmin.Expr.Cif + (Jasmin.Expr.Papp2 (Jasmin.Expr.Oneq Jasmin.Expr.Op_int, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = round.308}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (63, 8); loc_end = (63, 13); + loc_bchar = 1634; loc_echar = 1639}}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), + [Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 21; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (64, 6); loc_end = (64, 34); + loc_bchar = 1655; loc_echar = 1683}; + stack_loc = []}, + []), + Jasmin.Expr.Copn + ([Jasmin.Expr.Laset (Jasmin.Warray_.AAscale, + Jasmin.Wsize.U128, + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + Jasmin.BinNums.Coq_xH))))))); + vname = rkeys.306}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (64, 6); loc_end = (64, 11); + loc_bchar = 1655; loc_echar = 1660}}, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = round.308}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (64, 12); loc_end = (64, 17); + loc_bchar = 1661; loc_echar = 1666}}; + gs = Jasmin.Expr.Slocal})], + Jasmin.Expr.AT_keep, + Jasmin.Sopn.Oasm (Jasmin.Arch_extra.BaseOp (None, )), + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = key.305}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (64, 29); loc_end = (64, 32); + loc_bchar = 1678; loc_echar = 1681}}; + gs = Jasmin.Expr.Slocal}]))], + [Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 22; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (66, 6); loc_end = (66, 25); + loc_bchar = 1703; loc_echar = 1722}; + stack_loc = []}, + []), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Laset (Jasmin.Warray_.AAscale, + Jasmin.Wsize.U128, + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + Jasmin.BinNums.Coq_xH))))))); + vname = rkeys.306}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (66, 6); loc_end = (66, 11); + loc_bchar = 1703; loc_echar = 1708}}, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = round.308}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (66, 12); loc_end = (66, 17); + loc_bchar = 1709; loc_echar = 1714}}; + gs = Jasmin.Expr.Slocal}), + Jasmin.Expr.AT_none, + Jasmin.Type.Coq_sword Jasmin.Wsize.U128, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = key.305}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (66, 21); loc_end = (66, 24); + loc_bchar = 1718; loc_echar = 1721}}; + gs = Jasmin.Expr.Slocal}))]))]))]; + f_tyout = + [Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))))]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))); + vname = rkeys.306}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (69, 9); loc_end = (69, 14); loc_bchar = 1745; + loc_echar = 1750}}]; + f_extra = ()}); + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)), + {Jasmin.Expr.f_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))); + f_tyin = [Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = key.310}; + v_info = + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; + f_body = + [Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 11; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (44, 2); loc_end = (44, 17); loc_bchar = 1167; + loc_echar = 1182}; + stack_loc = []}, + []), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Laset (Jasmin.Warray_.AAscale, Jasmin.Wsize.U128, + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))); + vname = rkeys.311}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (44, 2); loc_end = (44, 7); loc_bchar = 1167; + loc_echar = 1172}}, + Jasmin.Expr.Pconst Jasmin.BinNums.Z0), + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U128, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = key.310}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (44, 13); loc_end = (44, 16); loc_bchar = 1178; + loc_echar = 1181}}; + gs = Jasmin.Expr.Slocal})); + Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 12; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (45, 2); loc_end = (45, 25); loc_bchar = 1185; + loc_echar = 1208}; + stack_loc = []}, + []), + Jasmin.Expr.Copn + ([Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = temp2.312}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (45, 2); loc_end = (45, 7); loc_bchar = 1185; + loc_echar = 1190}}], + Jasmin.Expr.AT_keep, + Jasmin.Sopn.Oasm (Jasmin.Arch_extra.ExtOp ), [])); + Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 16; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (46, 2); loc_end = (50, 3); loc_bchar = 1211; + loc_echar = 1333}; + stack_loc = []}, + []), + Jasmin.Expr.Cfor + ({Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = round.313}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (46, 6); loc_end = (46, 11); loc_bchar = 1215; + loc_echar = 1220}}, + ((Jasmin.Expr.UpTo, + Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos Jasmin.BinNums.Coq_xH)), + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), + [Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 13; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (47, 4); loc_end = (47, 23); loc_bchar = 1237; + loc_echar = 1256}; + stack_loc = []}, + []), + Jasmin.Expr.Ccall (Jasmin.Expr.InlineFun, + [Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = rcon.314}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (47, 4); loc_end = (47, 8); loc_bchar = 1237; + loc_echar = 1241}}], + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = round.313}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (47, 16); loc_end = (47, 21); + loc_bchar = 1249; loc_echar = 1254}}; + gs = Jasmin.Expr.Slocal}])); + Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 14; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (48, 4); loc_end = (48, 48); loc_bchar = 1261; + loc_echar = 1305}; + stack_loc = []}, + []), + Jasmin.Expr.Ccall (Jasmin.Expr.InlineFun, + [Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = key.310}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (48, 5); loc_end = (48, 8); loc_bchar = 1262; + loc_echar = 1265}}; + Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = temp2.312}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (48, 10); loc_end = (48, 15); + loc_bchar = 1267; loc_echar = 1272}}], + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = rcon.314}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (48, 30); loc_end = (48, 34); + loc_bchar = 1287; loc_echar = 1291}}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = key.310}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (48, 36); loc_end = (48, 39); + loc_bchar = 1293; loc_echar = 1296}}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = temp2.312}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (48, 41); loc_end = (48, 46); + loc_bchar = 1298; loc_echar = 1303}}; + gs = Jasmin.Expr.Slocal}])); + Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 15; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (49, 4); loc_end = (49, 23); loc_bchar = 1310; + loc_echar = 1329}; + stack_loc = []}, + []), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Laset (Jasmin.Warray_.AAscale, Jasmin.Wsize.U128, + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))); + vname = rkeys.311}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (49, 4); loc_end = (49, 9); loc_bchar = 1310; + loc_echar = 1315}}, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = round.313}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (49, 10); loc_end = (49, 15); + loc_bchar = 1316; loc_echar = 1321}}; + gs = Jasmin.Expr.Slocal}), + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U128, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = key.310}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (49, 19); loc_end = (49, 22); + loc_bchar = 1325; loc_echar = 1328}}; + gs = Jasmin.Expr.Slocal}))]))]; + f_tyout = + [Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))))]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sarr + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))); + vname = rkeys.311}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (51, 9); loc_end = (51, 14); loc_bchar = 1346; + loc_echar = 1351}}]; + f_extra = ()}); + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), + {Jasmin.Expr.f_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))); + f_tyin = + [Jasmin.Type.Coq_sint; Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = rcon.315}; + v_info = + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}; + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = rkey.316}; + v_info = + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}; + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = temp2.317}; + v_info = + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; + f_body = + [Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 9; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (35, 2); loc_end = (35, 40); loc_bchar = 932; + loc_echar = 970}; + stack_loc = []}, + []), + Jasmin.Expr.Copn + ([Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = temp1.318}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (35, 2); loc_end = (35, 7); loc_bchar = 932; + loc_echar = 937}}], + Jasmin.Expr.AT_keep, + Jasmin.Sopn.Oasm (Jasmin.Arch_extra.BaseOp (None, )), + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = rkey.316}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (35, 28); loc_end = (35, 32); loc_bchar = 958; + loc_echar = 962}}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U8, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = rcon.315}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (35, 34); loc_end = (35, 38); loc_bchar = 964; + loc_echar = 968}}; + gs = Jasmin.Expr.Slocal})])); + Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 10; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (36, 2); loc_end = (36, 48); loc_bchar = 973; + loc_echar = 1019}; + stack_loc = []}, + []), + Jasmin.Expr.Ccall (Jasmin.Expr.InlineFun, + [Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = rkey.316}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (36, 2); loc_end = (36, 6); loc_bchar = 973; + loc_echar = 977}}; + Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = temp2.317}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (36, 8); loc_end = (36, 13); loc_bchar = 979; + loc_echar = 984}}], + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = rkey.316}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (36, 28); loc_end = (36, 32); loc_bchar = 999; + loc_echar = 1003}}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = temp1.318}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (36, 34); loc_end = (36, 39); loc_bchar = 1005; + loc_echar = 1010}}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = temp2.317}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (36, 41); loc_end = (36, 46); loc_bchar = 1012; + loc_echar = 1017}}; + gs = Jasmin.Expr.Slocal}]))]; + f_tyout = + [Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = rkey.316}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (37, 9); loc_end = (37, 13); loc_bchar = 1029; + loc_echar = 1033}}; + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = temp2.317}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (37, 15); loc_end = (37, 20); loc_bchar = 1035; + loc_echar = 1040}}]; + f_extra = ()}); + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), + {Jasmin.Expr.f_info = + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))); + f_tyin = + [Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = rkey.319}; + v_info = + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}; + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = temp1.320}; + v_info = + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}; + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = temp2.321}; + v_info = + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; + f_body = + [Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 3; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (23, 2); loc_end = (23, 42); loc_bchar = 588; + loc_echar = 628}; + stack_loc = []}, + []), + Jasmin.Expr.Copn + ([Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = temp1.320}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (23, 2); loc_end = (23, 7); loc_bchar = 588; + loc_echar = 593}}], + Jasmin.Expr.AT_keep, + Jasmin.Sopn.Oasm (Jasmin.Arch_extra.BaseOp (None, )), + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = temp1.320}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (23, 19); loc_end = (23, 24); loc_bchar = 605; + loc_echar = 610}}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.PappN + (Jasmin.Expr.Opack (Jasmin.Wsize.U8, Jasmin.Wsize.PE2), + [Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)); + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)); + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)); + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))])])); + Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 4; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (24, 2); loc_end = (24, 48); loc_bchar = 631; + loc_echar = 677}; + stack_loc = []}, + []), + Jasmin.Expr.Copn + ([Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = temp2.321}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (24, 2); loc_end = (24, 7); loc_bchar = 631; + loc_echar = 636}}], + Jasmin.Expr.AT_keep, + Jasmin.Sopn.Oasm (Jasmin.Arch_extra.BaseOp (None, )), + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = temp2.321}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (24, 19); loc_end = (24, 24); loc_bchar = 648; + loc_echar = 653}}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = rkey.319}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (24, 26); loc_end = (24, 30); loc_bchar = 655; + loc_echar = 659}}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.PappN + (Jasmin.Expr.Opack (Jasmin.Wsize.U8, Jasmin.Wsize.PE2), + [Jasmin.Expr.Pconst Jasmin.BinNums.Z0; + Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos Jasmin.BinNums.Coq_xH); + Jasmin.Expr.Pconst Jasmin.BinNums.Z0; + Jasmin.Expr.Pconst Jasmin.BinNums.Z0])])); + Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 5; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (25, 2); loc_end = (25, 16); loc_bchar = 680; + loc_echar = 694}; + stack_loc = []}, + []), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = rkey.319}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (25, 2); loc_end = (25, 6); loc_bchar = 680; + loc_echar = 684}}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U128, + Jasmin.Expr.Papp2 (Jasmin.Expr.Olxor Jasmin.Wsize.U128, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = rkey.319}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (25, 2); loc_end = (25, 6); loc_bchar = 680; + loc_echar = 684}}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = temp2.321}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (25, 10); loc_end = (25, 15); loc_bchar = 688; + loc_echar = 693}}; + gs = Jasmin.Expr.Slocal}))); + Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 6; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (26, 2); loc_end = (26, 48); loc_bchar = 697; + loc_echar = 743}; + stack_loc = []}, + []), + Jasmin.Expr.Copn + ([Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = temp2.321}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (26, 2); loc_end = (26, 7); loc_bchar = 697; + loc_echar = 702}}], + Jasmin.Expr.AT_keep, + Jasmin.Sopn.Oasm (Jasmin.Arch_extra.BaseOp (None, )), + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = temp2.321}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (26, 19); loc_end = (26, 24); loc_bchar = 714; + loc_echar = 719}}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = rkey.319}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (26, 26); loc_end = (26, 30); loc_bchar = 721; + loc_echar = 725}}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.PappN + (Jasmin.Expr.Opack (Jasmin.Wsize.U8, Jasmin.Wsize.PE2), + [Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)); + Jasmin.Expr.Pconst Jasmin.BinNums.Z0; + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)); + Jasmin.Expr.Pconst Jasmin.BinNums.Z0])])); + Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 7; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (27, 2); loc_end = (27, 16); loc_bchar = 746; + loc_echar = 760}; + stack_loc = []}, + []), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = rkey.319}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (27, 2); loc_end = (27, 6); loc_bchar = 746; + loc_echar = 750}}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U128, + Jasmin.Expr.Papp2 (Jasmin.Expr.Olxor Jasmin.Wsize.U128, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = rkey.319}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (27, 2); loc_end = (27, 6); loc_bchar = 746; + loc_echar = 750}}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = temp2.321}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (27, 10); loc_end = (27, 15); loc_bchar = 754; + loc_echar = 759}}; + gs = Jasmin.Expr.Slocal}))); + Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 8; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (28, 2); loc_end = (28, 16); loc_bchar = 764; + loc_echar = 778}; + stack_loc = []}, + []), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = rkey.319}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (28, 2); loc_end = (28, 6); loc_bchar = 764; + loc_echar = 768}}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U128, + Jasmin.Expr.Papp2 (Jasmin.Expr.Olxor Jasmin.Wsize.U128, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = rkey.319}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (28, 2); loc_end = (28, 6); loc_bchar = 764; + loc_echar = 768}}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = temp1.320}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (28, 10); loc_end = (28, 15); loc_bchar = 772; + loc_echar = 777}}; + gs = Jasmin.Expr.Slocal})))]; + f_tyout = + [Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = rkey.319}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (29, 9); loc_end = (29, 13); loc_bchar = 788; + loc_echar = 792}}; + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; + vname = temp2.321}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (29, 15); loc_end = (29, 20); loc_bchar = 794; + loc_echar = 799}}]; + f_extra = ()}); + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), + {Jasmin.Expr.f_info = + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))); + f_tyin = [Jasmin.Type.Coq_sint]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = i.322}; + v_info = + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; + f_body = + [Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 2; + base_loc = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (8, 2); loc_end = (17, 30); loc_bchar = 223; + loc_echar = 462}; + stack_loc = []}, + []), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = c.323}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (8, 2); loc_end = (8, 3); loc_bchar = 223; + loc_echar = 224}}, + Jasmin.Expr.AT_inline, Jasmin.Type.Coq_sint, + Jasmin.Expr.Pif (Jasmin.Type.Coq_sint, + Jasmin.Expr.Papp2 (Jasmin.Expr.Oeq Jasmin.Expr.Op_int, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = i.322}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (8, 8); loc_end = (8, 9); loc_bchar = 229; + loc_echar = 230}}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos Jasmin.BinNums.Coq_xH)), + Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos Jasmin.BinNums.Coq_xH), + Jasmin.Expr.Pif (Jasmin.Type.Coq_sint, + Jasmin.Expr.Papp2 (Jasmin.Expr.Oeq Jasmin.Expr.Op_int, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = i.322}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (9, 8); loc_end = (9, 9); loc_bchar = 251; + loc_echar = 252}}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)), + Jasmin.Expr.Pif (Jasmin.Type.Coq_sint, + Jasmin.Expr.Papp2 (Jasmin.Expr.Oeq Jasmin.Expr.Op_int, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = i.322}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (10, 8); loc_end = (10, 9); loc_bchar = 273; + loc_echar = 274}}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))), + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), + Jasmin.Expr.Pif (Jasmin.Type.Coq_sint, + Jasmin.Expr.Papp2 (Jasmin.Expr.Oeq Jasmin.Expr.Op_int, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = i.322}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (11, 8); loc_end = (11, 9); + loc_bchar = 295; loc_echar = 296}}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))), + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))), + Jasmin.Expr.Pif (Jasmin.Type.Coq_sint, + Jasmin.Expr.Papp2 (Jasmin.Expr.Oeq Jasmin.Expr.Op_int, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = i.322}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (12, 8); loc_end = (12, 9); + loc_bchar = 317; loc_echar = 318}}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))), + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), + Jasmin.Expr.Pif (Jasmin.Type.Coq_sint, + Jasmin.Expr.Papp2 (Jasmin.Expr.Oeq Jasmin.Expr.Op_int, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = i.322}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (13, 8); loc_end = (13, 9); + loc_bchar = 340; loc_echar = 341}}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))), + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))), + Jasmin.Expr.Pif (Jasmin.Type.Coq_sint, + Jasmin.Expr.Papp2 (Jasmin.Expr.Oeq Jasmin.Expr.Op_int, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = i.322}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (14, 8); loc_end = (14, 9); + loc_bchar = 363; loc_echar = 364}}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))), + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))), + Jasmin.Expr.Pif (Jasmin.Type.Coq_sint, + Jasmin.Expr.Papp2 (Jasmin.Expr.Oeq Jasmin.Expr.Op_int, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = i.322}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (15, 8); loc_end = (15, 9); + loc_bchar = 393; loc_echar = 394}}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + Jasmin.BinNums.Coq_xH)))))))), + Jasmin.Expr.Pif (Jasmin.Type.Coq_sint, + Jasmin.Expr.Papp2 (Jasmin.Expr.Oeq Jasmin.Expr.Op_int, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = i.322}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (16, 8); loc_end = (16, 9); + loc_bchar = 417; loc_echar = 418}}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))), + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))))))))))))))]; + f_tyout = [Jasmin.Type.Coq_sint]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = c.323}; + v_info = + {Jasmin.Location.loc_fname = + "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; + loc_start = (18, 10); loc_end = (18, 11); loc_bchar = 473; + loc_echar = 474}}]; + f_extra = ()})]; + p_globs = []; p_extra = ()} diff --git a/theories/Jasmin/examples/aes.jazz b/theories/Jasmin/examples/aes.jazz new file mode 100644 index 00000000..08cf1c30 --- /dev/null +++ b/theories/Jasmin/examples/aes.jazz @@ -0,0 +1,20 @@ +from AES require "aes.jinc" + +/* We typically pack all functions that may be used + by other jasmin programs in jinc files. + Then we create jazz files just for entry-point + specific code */ + +export +fn aes_jazz(reg u128 key, reg u128 in) -> reg u128 { + reg u128 out; + out = aes(key,in); + return out; +} + +export +fn invaes_jazz(reg u128 key, reg u128 in) -> reg u128 { + reg u128 out; + out = invaes(key,in); + return out; +} diff --git a/theories/Jasmin/examples/aes.jinc b/theories/Jasmin/examples/aes.jinc new file mode 100644 index 00000000..30e8742c --- /dev/null +++ b/theories/Jasmin/examples/aes.jinc @@ -0,0 +1,124 @@ +/* Jasmin implementation of AES using AES-NI */ +/* This can be reused without change wherever + AES-NI is needed to compute vanilla AES or + its inverse */ + +inline fn RCON (inline int i) -> inline int { + inline int c; + c = (i == 1) ? 1 : + ((i == 2) ? 2 : + ((i == 3) ? 4 : + ((i == 4) ? 8 : + ((i == 5) ? 16 : + ((i == 6) ? 32 : + ((i == 7) ? 64 : + ((i == 8) ? 128 : + ((i == 9) ? 27 : + /* i == 10 */ 54)))))))); + return c; +} + +inline fn key_combine(reg u128 rkey, reg u128 temp1, reg u128 temp2) + -> reg u128, reg u128 { + temp1 = #VPSHUFD(temp1, (4u2)[3,3,3,3]); + temp2 = #VSHUFPS(temp2, rkey, (4u2)[0,1,0,0]); + rkey ^= temp2; + temp2 = #VSHUFPS(temp2, rkey, (4u2)[2,0,3,0]); + rkey ^= temp2; + rkey ^= temp1; + return rkey, temp2; +} + +inline fn key_expand(inline int rcon, reg u128 rkey, reg u128 temp2) + -> reg u128, reg u128 { + reg u128 temp1; + temp1 = #VAESKEYGENASSIST(rkey, rcon); + rkey, temp2 = key_combine(rkey, temp1, temp2); + return rkey, temp2; +} + +inline fn keys_expand(reg u128 key) -> reg u128[11] { + reg u128[11] rkeys; + reg u128 temp2; + inline int round, rcon; + rkeys[0] = key; + temp2 = #set0_128(); + for round = 1 to 11 { + rcon = RCON(round); + (key, temp2) = key_expand(rcon, key, temp2); + rkeys[round] = key; + } + return rkeys; +} + +inline fn keys_expand_inv(reg u128 key) -> reg u128[11] { + reg u128[11] rkeys; + reg u128 temp2; + inline int round, rcon; + rkeys[0] = key; + temp2 = #set0_128(); + for round = 1 to 11 { + rcon = RCON(round); + (key, temp2) = key_expand(rcon, key, temp2); + if (round != 10) { + rkeys[round] = #AESIMC(key); + } else { + rkeys[round] = key; + } + } + return rkeys; +} + +inline fn aes_rounds (reg u128[11] rkeys, reg u128 in) -> reg u128 { + reg u128 state; + inline int round; + state = in; + state ^= rkeys[0]; + for round = 1 to 10 { + state = #AESENC(state, rkeys[round]); + } + state = #AESENCLAST(state, rkeys[10]); + return state; +} + +inline fn AddRoundKey(reg u128 state, stack u128 rk) -> reg u128 { + state = state ^ rk; + return state; +} + +inline fn invaes_rounds (reg u128[11] rkeys, reg u128 in) -> reg u128 { + reg u128 state; + inline int round; + stack u128 rk; + state = in; + rk = rkeys[10]; + state = AddRoundKey(state,rk); + for round = 9 downto 0 { + state = #AESDEC(state, rkeys[round]); + } + state = #AESDECLAST(state, rkeys[0]); + return state; +} + +/* Functions typically called from other Jasmin programs. + Note they always compute key expansion, and this may + not be a good in terms of performance. */ +inline +fn aes(reg u128 key, reg u128 in) -> reg u128 { + reg u128 out; + reg u128[11] rkeys; + + rkeys = keys_expand(key); + out = aes_rounds(rkeys, in); + return out; +} + +inline +fn invaes(reg u128 key, reg u128 in) -> reg u128 { + reg u128 out; + reg u128[11] rkeys; + + rkeys = keys_expand_inv(key); + out = invaes_rounds(rkeys, in); + return out; +} diff --git a/theories/Jasmin/examples/aes.v b/theories/Jasmin/examples/aes.v new file mode 100644 index 00000000..2c9b775c --- /dev/null +++ b/theories/Jasmin/examples/aes.v @@ -0,0 +1,1672 @@ +Require Import List. +From Jasmin Require Import expr. +From Jasmin Require Import x86_extra. + +Import ListNotations. +Local Open Scope string. + +Definition aes := {| p_funcs := + [(xH, + {| f_info := xO xH; + f_tyin := + [sword U128; + sword U128]; + f_params := + [{| v_var := + {| vtype := sword U128; + vname := "key.280" |}; + v_info := dummy_var_info |}; + {| v_var := + {| vtype := sword U128; + vname := "in.281" |}; + v_info := dummy_var_info |}]; + f_body := + [MkI + (dummy_instr_info) + (Ccall (InlineFun) + ([Lvar + {| v_var := + {| vtype := + sword U128; + vname := "out.282" |}; + v_info := dummy_var_info |}]) + (xI xH) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "key.280" |}; + v_info := dummy_var_info |}; + gs := Slocal |}; + Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "in.281" |}; + v_info := dummy_var_info |}; + gs := Slocal |}]))]; + f_tyout := [sword U128]; + f_res := + [{| v_var := + {| vtype := sword U128; + vname := "out.282" |}; + v_info := dummy_var_info |}]; + f_extra := tt |}); + (xO (xO xH), + {| f_info := + xI (xO xH); + f_tyin := + [sword U128; + sword U128]; + f_params := + [{| v_var := + {| vtype := sword U128; + vname := "key.283" |}; + v_info := dummy_var_info |}; + {| v_var := + {| vtype := sword U128; + vname := "in.284" |}; + v_info := dummy_var_info |}]; + f_body := + [MkI + (dummy_instr_info) + (Ccall (InlineFun) + ([Lvar + {| v_var := + {| vtype := + sword U128; + vname := "out.285" |}; + v_info := dummy_var_info |}]) + (xO + (xI xH)) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "key.283" |}; + v_info := dummy_var_info |}; + gs := Slocal |}; + Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "in.284" |}; + v_info := dummy_var_info |}; + gs := Slocal |}]))]; + f_tyout := [sword U128]; + f_res := + [{| v_var := + {| vtype := sword U128; + vname := "out.285" |}; + v_info := dummy_var_info |}]; + f_extra := tt |}); + (xI xH, + {| f_info := + xI (xI xH); + f_tyin := + [sword U128; + sword U128]; + f_params := + [{| v_var := + {| vtype := sword U128; + vname := "key.286" |}; + v_info := dummy_var_info |}; + {| v_var := + {| vtype := sword U128; + vname := "in.287" |}; + v_info := dummy_var_info |}]; + f_body := + [MkI + (dummy_instr_info) + (Ccall (InlineFun) + ([Lvar + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xI + (xI + (xO xH))))))); + vname := "rkeys.289" |}; + v_info := dummy_var_info |}]) + (xI + (xO + (xO xH))) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "key.286" |}; + v_info := dummy_var_info |}; + gs := Slocal |}])); + MkI + (dummy_instr_info) + (Ccall (InlineFun) + ([Lvar + {| v_var := + {| vtype := + sword U128; + vname := "out.288" |}; + v_info := dummy_var_info |}]) + (xO + (xO + (xO xH))) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xI + (xI + (xO xH))))))); + vname := "rkeys.289" |}; + v_info := dummy_var_info |}; + gs := Slocal |}; + Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "in.287" |}; + v_info := dummy_var_info |}; + gs := Slocal |}]))]; + f_tyout := [sword U128]; + f_res := + [{| v_var := + {| vtype := sword U128; + vname := "out.288" |}; + v_info := dummy_var_info |}]; + f_extra := tt |}); + (xO (xI xH), + {| f_info := + xO + (xI (xO xH)); + f_tyin := + [sword U128; + sword U128]; + f_params := + [{| v_var := + {| vtype := sword U128; + vname := "key.290" |}; + v_info := dummy_var_info |}; + {| v_var := + {| vtype := sword U128; + vname := "in.291" |}; + v_info := dummy_var_info |}]; + f_body := + [MkI + (dummy_instr_info) + (Ccall (InlineFun) + ([Lvar + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xI + (xI + (xO xH))))))); + vname := "rkeys.293" |}; + v_info := dummy_var_info |}]) + (xO + (xO + (xI xH))) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "key.290" |}; + v_info := dummy_var_info |}; + gs := Slocal |}])); + MkI + (dummy_instr_info) + (Ccall (InlineFun) + ([Lvar + {| v_var := + {| vtype := + sword U128; + vname := "out.292" |}; + v_info := dummy_var_info |}]) + (xI + (xI + (xO xH))) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xI + (xI + (xO xH))))))); + vname := "rkeys.293" |}; + v_info := dummy_var_info |}; + gs := Slocal |}; + Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "in.291" |}; + v_info := dummy_var_info |}; + gs := Slocal |}]))]; + f_tyout := [sword U128]; + f_res := + [{| v_var := + {| vtype := sword U128; + vname := "out.292" |}; + v_info := dummy_var_info |}]; + f_extra := tt |}); + (xO + (xO (xO xH)), + {| f_info := + xI + (xO (xI xH)); + f_tyin := + [sarr + (xO + (xO + (xO + (xO + (xI + (xI + (xO xH))))))); + sword U128]; + f_params := + [{| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xI + (xI + (xO xH))))))); + vname := "rkeys.294" |}; + v_info := dummy_var_info |}; + {| v_var := + {| vtype := sword U128; + vname := "in.295" |}; + v_info := dummy_var_info |}]; + f_body := + [MkI + (dummy_instr_info) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U128; + vname := "state.296" |}; + v_info := dummy_var_info |}) + (AT_none) (sword U128) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "in.295" |}; + v_info := dummy_var_info |}; + gs := Slocal |})); + MkI + (dummy_instr_info) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U128; + vname := "rk.297" |}; + v_info := dummy_var_info |}) + (AT_none) (sword U128) + (Pget (AAscale) (U128) + ({| gv := + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xI + (xI + (xO xH))))))); + vname := "rkeys.294" |}; + v_info := dummy_var_info |}; + gs := Slocal |}) + (Pconst + (Zpos + (xO + (xI + (xO xH))))))); + MkI + (dummy_instr_info) + (Ccall (InlineFun) + ([Lvar + {| v_var := + {| vtype := + sword U128; + vname := "state.296" |}; + v_info := dummy_var_info |}]) + (xO + (xI + (xI xH))) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "state.296" |}; + v_info := dummy_var_info |}; + gs := Slocal |}; + Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "rk.297" |}; + v_info := dummy_var_info |}; + gs := Slocal |}])); + MkI + (dummy_instr_info) + (Cfor + ({| v_var := + {| vtype := sint; + vname := "round.298" |}; + v_info := dummy_var_info |}) + (((DownTo, Pconst Z0), + Pconst + (Zpos + (xI + (xO + (xO xH)))))) + ([MkI + (dummy_instr_info) + (Copn + ([Lvar + {| v_var := + {| vtype := + sword U128; + vname := "state.296" |}; + v_info := dummy_var_info |}]) + (AT_keep) + (Oasm (BaseOp (None) ())) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "state.296" |}; + v_info := dummy_var_info |}; + gs := Slocal |}; + Pget (AAscale) (U128) + ({| gv := + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xI + (xI + (xO + xH))))))); + vname := "rkeys.294" |}; + v_info := dummy_var_info |}; + gs := Slocal |}) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "round.298" |}; + v_info := dummy_var_info |}; + gs := Slocal |})]))])); + MkI + (dummy_instr_info) + (Copn + ([Lvar + {| v_var := + {| vtype := + sword U128; + vname := "state.296" |}; + v_info := dummy_var_info |}]) + (AT_keep) + (Oasm (BaseOp (None) ())) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "state.296" |}; + v_info := dummy_var_info |}; + gs := Slocal |}; + Pget (AAscale) (U128) + ({| gv := + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xI + (xI + (xO xH))))))); + vname := "rkeys.294" |}; + v_info := dummy_var_info |}; + gs := Slocal |}) + (Pconst Z0)]))]; + f_tyout := [sword U128]; + f_res := + [{| v_var := + {| vtype := sword U128; + vname := "state.296" |}; + v_info := dummy_var_info |}]; + f_extra := tt |}); + (xO + (xI (xI xH)), + {| f_info := + xI + (xI (xI xH)); + f_tyin := + [sword U128; + sword U128]; + f_params := + [{| v_var := + {| vtype := sword U128; + vname := "state.299" |}; + v_info := dummy_var_info |}; + {| v_var := + {| vtype := sword U128; + vname := "rk.300" |}; + v_info := dummy_var_info |}]; + f_body := + [MkI + (dummy_instr_info) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U128; + vname := "state.299" |}; + v_info := dummy_var_info |}) + (AT_none) (sword U128) + (Papp2 (Olxor U128) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "state.299" |}; + v_info := dummy_var_info |}; + gs := Slocal |}) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "rk.300" |}; + v_info := dummy_var_info |}; + gs := Slocal |})))]; + f_tyout := [sword U128]; + f_res := + [{| v_var := + {| vtype := sword U128; + vname := "state.299" |}; + v_info := dummy_var_info |}]; + f_extra := tt |}); + (xI + (xI (xO xH)), + {| f_info := + xO + (xO + (xO + (xO xH))); + f_tyin := + [sarr + (xO + (xO + (xO + (xO + (xI + (xI + (xO xH))))))); + sword U128]; + f_params := + [{| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xI + (xI + (xO xH))))))); + vname := "rkeys.301" |}; + v_info := dummy_var_info |}; + {| v_var := + {| vtype := sword U128; + vname := "in.302" |}; + v_info := dummy_var_info |}]; + f_body := + [MkI + (dummy_instr_info) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U128; + vname := "state.303" |}; + v_info := dummy_var_info |}) + (AT_none) (sword U128) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "in.302" |}; + v_info := dummy_var_info |}; + gs := Slocal |})); + MkI + (dummy_instr_info) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U128; + vname := "state.303" |}; + v_info := dummy_var_info |}) + (AT_none) (sword U128) + (Papp2 (Olxor U128) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "state.303" |}; + v_info := dummy_var_info |}; + gs := Slocal |}) + (Pget (AAscale) (U128) + ({| gv := + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xI + (xI + (xO xH))))))); + vname := "rkeys.301" |}; + v_info := dummy_var_info |}; + gs := Slocal |}) + (Pconst Z0)))); + MkI + (dummy_instr_info) + (Cfor + ({| v_var := + {| vtype := sint; + vname := "round.304" |}; + v_info := dummy_var_info |}) + (((UpTo, + Pconst (Zpos xH)), + Pconst + (Zpos + (xO + (xI + (xO xH)))))) + ([MkI + (dummy_instr_info) + (Copn + ([Lvar + {| v_var := + {| vtype := + sword U128; + vname := "state.303" |}; + v_info := dummy_var_info |}]) + (AT_keep) + (Oasm (BaseOp (None) ())) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "state.303" |}; + v_info := dummy_var_info |}; + gs := Slocal |}; + Pget (AAscale) (U128) + ({| gv := + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xI + (xI + (xO + xH))))))); + vname := "rkeys.301" |}; + v_info := dummy_var_info |}; + gs := Slocal |}) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "round.304" |}; + v_info := dummy_var_info |}; + gs := Slocal |})]))])); + MkI + (dummy_instr_info) + (Copn + ([Lvar + {| v_var := + {| vtype := + sword U128; + vname := "state.303" |}; + v_info := dummy_var_info |}]) + (AT_keep) + (Oasm (BaseOp (None) ())) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "state.303" |}; + v_info := dummy_var_info |}; + gs := Slocal |}; + Pget (AAscale) (U128) + ({| gv := + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xI + (xI + (xO xH))))))); + vname := "rkeys.301" |}; + v_info := dummy_var_info |}; + gs := Slocal |}) + (Pconst + (Zpos + (xO + (xI + (xO xH)))))]))]; + f_tyout := [sword U128]; + f_res := + [{| v_var := + {| vtype := sword U128; + vname := "state.303" |}; + v_info := dummy_var_info |}]; + f_extra := tt |}); + (xI + (xO (xO xH)), + {| f_info := + xI + (xO + (xO + (xO xH))); + f_tyin := [sword U128]; + f_params := + [{| v_var := + {| vtype := sword U128; + vname := "key.305" |}; + v_info := dummy_var_info |}]; + f_body := + [MkI + (dummy_instr_info) + (Cassgn + (Laset (AAscale) (U128) + ({| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xI + (xI + (xO xH))))))); + vname := "rkeys.306" |}; + v_info := dummy_var_info |}) + (Pconst Z0)) + (AT_none) (sword U128) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "key.305" |}; + v_info := dummy_var_info |}; + gs := Slocal |})); + MkI + (dummy_instr_info) + (Copn + ([Lvar + {| v_var := + {| vtype := + sword U128; + vname := "temp2.307" |}; + v_info := dummy_var_info |}]) + (AT_keep) + (Oasm (ExtOp )) ([])); + MkI + (dummy_instr_info) + (Cfor + ({| v_var := + {| vtype := sint; + vname := "round.308" |}; + v_info := dummy_var_info |}) + (((UpTo, + Pconst (Zpos xH)), + Pconst + (Zpos + (xI + (xI + (xO xH)))))) + ([MkI + (dummy_instr_info) + (Ccall (InlineFun) + ([Lvar + {| v_var := + {| vtype := sint; + vname := "rcon.309" |}; + v_info := dummy_var_info |}]) + (xI + (xI + (xO + (xO xH)))) + ([Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "round.308" |}; + v_info := dummy_var_info |}; + gs := Slocal |}])); + MkI + (dummy_instr_info) + (Ccall (InlineFun) + ([Lvar + {| v_var := + {| vtype := + sword U128; + vname := "key.305" |}; + v_info := dummy_var_info |}; + Lvar + {| v_var := + {| vtype := + sword U128; + vname := "temp2.307" |}; + v_info := dummy_var_info |}]) + (xO + (xI + (xO + (xO xH)))) + ([Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "rcon.309" |}; + v_info := dummy_var_info |}; + gs := Slocal |}; + Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "key.305" |}; + v_info := dummy_var_info |}; + gs := Slocal |}; + Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "temp2.307" |}; + v_info := dummy_var_info |}; + gs := Slocal |}])); + MkI + (dummy_instr_info) + (Cif + (Papp2 (Oneq Op_int) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "round.308" |}; + v_info := dummy_var_info |}; + gs := Slocal |}) + (Pconst + (Zpos + (xO + (xI + (xO xH)))))) + ([MkI + (dummy_instr_info) + (Copn + ([Laset (AAscale) + (U128) + ({| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xI + (xI + (xO + xH))))))); + vname := "rkeys.306" |}; + v_info := dummy_var_info |}) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "round.308" |}; + v_info := dummy_var_info |}; + gs := Slocal |})]) + (AT_keep) + (Oasm (BaseOp (None) ())) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "key.305" |}; + v_info := dummy_var_info |}; + gs := Slocal |}]))]) + ([MkI + (dummy_instr_info) + (Cassgn + (Laset (AAscale) + (U128) + ({| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xI + (xI + (xO + xH))))))); + vname := "rkeys.306" |}; + v_info := dummy_var_info |}) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "round.308" |}; + v_info := dummy_var_info |}; + gs := Slocal |})) + (AT_none) + (sword U128) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "key.305" |}; + v_info := dummy_var_info |}; + gs := Slocal |}))]))]))]; + f_tyout := + [sarr + (xO + (xO + (xO + (xO + (xI + (xI + (xO xH)))))))]; + f_res := + [{| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xI + (xI + (xO xH))))))); + vname := "rkeys.306" |}; + v_info := dummy_var_info |}]; + f_extra := tt |}); + (xO + (xO (xI xH)), + {| f_info := + xO + (xO + (xI + (xO xH))); + f_tyin := [sword U128]; + f_params := + [{| v_var := + {| vtype := sword U128; + vname := "key.310" |}; + v_info := dummy_var_info |}]; + f_body := + [MkI + (dummy_instr_info) + (Cassgn + (Laset (AAscale) (U128) + ({| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xI + (xI + (xO xH))))))); + vname := "rkeys.311" |}; + v_info := dummy_var_info |}) + (Pconst Z0)) + (AT_none) (sword U128) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "key.310" |}; + v_info := dummy_var_info |}; + gs := Slocal |})); + MkI + (dummy_instr_info) + (Copn + ([Lvar + {| v_var := + {| vtype := + sword U128; + vname := "temp2.312" |}; + v_info := dummy_var_info |}]) + (AT_keep) + (Oasm (ExtOp )) ([])); + MkI + (dummy_instr_info) + (Cfor + ({| v_var := + {| vtype := sint; + vname := "round.313" |}; + v_info := dummy_var_info |}) + (((UpTo, + Pconst (Zpos xH)), + Pconst + (Zpos + (xI + (xI + (xO xH)))))) + ([MkI + (dummy_instr_info) + (Ccall (InlineFun) + ([Lvar + {| v_var := + {| vtype := sint; + vname := "rcon.314" |}; + v_info := dummy_var_info |}]) + (xI + (xI + (xO + (xO xH)))) + ([Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "round.313" |}; + v_info := dummy_var_info |}; + gs := Slocal |}])); + MkI + (dummy_instr_info) + (Ccall (InlineFun) + ([Lvar + {| v_var := + {| vtype := + sword U128; + vname := "key.310" |}; + v_info := dummy_var_info |}; + Lvar + {| v_var := + {| vtype := + sword U128; + vname := "temp2.312" |}; + v_info := dummy_var_info |}]) + (xO + (xI + (xO + (xO xH)))) + ([Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "rcon.314" |}; + v_info := dummy_var_info |}; + gs := Slocal |}; + Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "key.310" |}; + v_info := dummy_var_info |}; + gs := Slocal |}; + Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "temp2.312" |}; + v_info := dummy_var_info |}; + gs := Slocal |}])); + MkI + (dummy_instr_info) + (Cassgn + (Laset (AAscale) (U128) + ({| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xI + (xI + (xO xH))))))); + vname := "rkeys.311" |}; + v_info := dummy_var_info |}) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "round.313" |}; + v_info := dummy_var_info |}; + gs := Slocal |})) + (AT_none) (sword U128) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "key.310" |}; + v_info := dummy_var_info |}; + gs := Slocal |}))]))]; + f_tyout := + [sarr + (xO + (xO + (xO + (xO + (xI + (xI + (xO xH)))))))]; + f_res := + [{| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xI + (xI + (xO xH))))))); + vname := "rkeys.311" |}; + v_info := dummy_var_info |}]; + f_extra := tt |}); + (xO + (xI + (xO (xO xH))), + {| f_info := + xI + (xO + (xI + (xO xH))); + f_tyin := + [sint; sword U128; + sword U128]; + f_params := + [{| v_var := + {| vtype := sint; vname := "rcon.315" |}; + v_info := dummy_var_info |}; + {| v_var := + {| vtype := sword U128; + vname := "rkey.316" |}; + v_info := dummy_var_info |}; + {| v_var := + {| vtype := sword U128; + vname := "temp2.317" |}; + v_info := dummy_var_info |}]; + f_body := + [MkI + (dummy_instr_info) + (Copn + ([Lvar + {| v_var := + {| vtype := + sword U128; + vname := "temp1.318" |}; + v_info := dummy_var_info |}]) + (AT_keep) + (Oasm (BaseOp (None) ())) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "rkey.316" |}; + v_info := dummy_var_info |}; + gs := Slocal |}; + Papp1 (Oword_of_int U8) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "rcon.315" |}; + v_info := dummy_var_info |}; + gs := Slocal |})])); + MkI + (dummy_instr_info) + (Ccall (InlineFun) + ([Lvar + {| v_var := + {| vtype := + sword U128; + vname := "rkey.316" |}; + v_info := dummy_var_info |}; + Lvar + {| v_var := + {| vtype := + sword U128; + vname := "temp2.317" |}; + v_info := dummy_var_info |}]) + (xO + (xI + (xI + (xO xH)))) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "rkey.316" |}; + v_info := dummy_var_info |}; + gs := Slocal |}; + Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "temp1.318" |}; + v_info := dummy_var_info |}; + gs := Slocal |}; + Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "temp2.317" |}; + v_info := dummy_var_info |}; + gs := Slocal |}]))]; + f_tyout := + [sword U128; + sword U128]; + f_res := + [{| v_var := + {| vtype := sword U128; + vname := "rkey.316" |}; + v_info := dummy_var_info |}; + {| v_var := + {| vtype := sword U128; + vname := "temp2.317" |}; + v_info := dummy_var_info |}]; + f_extra := tt |}); + (xO + (xI + (xI (xO xH))), + {| f_info := + xI + (xI + (xI + (xO xH))); + f_tyin := + [sword U128; + sword U128; + sword U128]; + f_params := + [{| v_var := + {| vtype := sword U128; + vname := "rkey.319" |}; + v_info := dummy_var_info |}; + {| v_var := + {| vtype := sword U128; + vname := "temp1.320" |}; + v_info := dummy_var_info |}; + {| v_var := + {| vtype := sword U128; + vname := "temp2.321" |}; + v_info := dummy_var_info |}]; + f_body := + [MkI + (dummy_instr_info) + (Copn + ([Lvar + {| v_var := + {| vtype := + sword U128; + vname := "temp1.320" |}; + v_info := dummy_var_info |}]) + (AT_keep) + (Oasm (BaseOp (None) ())) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "temp1.320" |}; + v_info := dummy_var_info |}; + gs := Slocal |}; + PappN + (Opack (U8) (PE2)) + ([Pconst + (Zpos + (xI xH)); + Pconst + (Zpos + (xI xH)); + Pconst + (Zpos + (xI xH)); + Pconst + (Zpos + (xI xH))])])); + MkI + (dummy_instr_info) + (Copn + ([Lvar + {| v_var := + {| vtype := + sword U128; + vname := "temp2.321" |}; + v_info := dummy_var_info |}]) + (AT_keep) + (Oasm (BaseOp (None) ())) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "temp2.321" |}; + v_info := dummy_var_info |}; + gs := Slocal |}; + Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "rkey.319" |}; + v_info := dummy_var_info |}; + gs := Slocal |}; + PappN + (Opack (U8) (PE2)) + ([Pconst Z0; + Pconst (Zpos xH); + Pconst Z0; + Pconst Z0])])); + MkI + (dummy_instr_info) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U128; + vname := "rkey.319" |}; + v_info := dummy_var_info |}) + (AT_none) (sword U128) + (Papp2 (Olxor U128) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "rkey.319" |}; + v_info := dummy_var_info |}; + gs := Slocal |}) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "temp2.321" |}; + v_info := dummy_var_info |}; + gs := Slocal |}))); + MkI + (dummy_instr_info) + (Copn + ([Lvar + {| v_var := + {| vtype := + sword U128; + vname := "temp2.321" |}; + v_info := dummy_var_info |}]) + (AT_keep) + (Oasm (BaseOp (None) ())) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "temp2.321" |}; + v_info := dummy_var_info |}; + gs := Slocal |}; + Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "rkey.319" |}; + v_info := dummy_var_info |}; + gs := Slocal |}; + PappN + (Opack (U8) (PE2)) + ([Pconst + (Zpos + (xO xH)); + Pconst Z0; + Pconst + (Zpos + (xI xH)); + Pconst Z0])])); + MkI + (dummy_instr_info) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U128; + vname := "rkey.319" |}; + v_info := dummy_var_info |}) + (AT_none) (sword U128) + (Papp2 (Olxor U128) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "rkey.319" |}; + v_info := dummy_var_info |}; + gs := Slocal |}) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "temp2.321" |}; + v_info := dummy_var_info |}; + gs := Slocal |}))); + MkI + (dummy_instr_info) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U128; + vname := "rkey.319" |}; + v_info := dummy_var_info |}) + (AT_none) (sword U128) + (Papp2 (Olxor U128) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "rkey.319" |}; + v_info := dummy_var_info |}; + gs := Slocal |}) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U128; + vname := "temp1.320" |}; + v_info := dummy_var_info |}; + gs := Slocal |})))]; + f_tyout := + [sword U128; + sword U128]; + f_res := + [{| v_var := + {| vtype := sword U128; + vname := "rkey.319" |}; + v_info := dummy_var_info |}; + {| v_var := + {| vtype := sword U128; + vname := "temp2.321" |}; + v_info := dummy_var_info |}]; + f_extra := tt |}); + (xI + (xI + (xO (xO xH))), + {| f_info := + xO + (xO + (xO + (xI xH))); + f_tyin := [sint]; + f_params := + [{| v_var := + {| vtype := sint; vname := "i.322" |}; + v_info := dummy_var_info |}]; + f_body := + [MkI + (dummy_instr_info) + (Cassgn + (Lvar + {| v_var := + {| vtype := sint; vname := "c.323" |}; + v_info := dummy_var_info |}) + (AT_inline) (sint) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "i.322" |}; + v_info := dummy_var_info |}; + gs := Slocal |}) + (Pconst (Zpos xH))) + (Pconst (Zpos xH)) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "i.322" |}; + v_info := dummy_var_info |}; + gs := Slocal |}) + (Pconst + (Zpos + (xO xH)))) + (Pconst + (Zpos + (xO xH))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "i.322" |}; + v_info := dummy_var_info |}; + gs := Slocal |}) + (Pconst + (Zpos + (xI xH)))) + (Pconst + (Zpos + (xO + (xO xH)))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "i.322" |}; + v_info := dummy_var_info |}; + gs := Slocal |}) + (Pconst + (Zpos + (xO + (xO xH))))) + (Pconst + (Zpos + (xO + (xO + (xO xH))))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "i.322" |}; + v_info := dummy_var_info |}; + gs := Slocal |}) + (Pconst + (Zpos + (xI + (xO xH))))) + (Pconst + (Zpos + (xO + (xO + (xO + (xO xH)))))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "i.322" |}; + v_info := dummy_var_info |}; + gs := Slocal |}) + (Pconst + (Zpos + (xO + (xI xH))))) + (Pconst + (Zpos + (xO + (xO + (xO + (xO + (xO xH))))))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "i.322" |}; + v_info := dummy_var_info |}; + gs := Slocal |}) + (Pconst + (Zpos + (xI + (xI xH))))) + (Pconst + (Zpos + (xO + (xO + (xO + (xO + (xO + (xO xH)))))))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "i.322" |}; + v_info := dummy_var_info |}; + gs := Slocal |}) + (Pconst + (Zpos + (xO + (xO + (xO xH)))))) + (Pconst + (Zpos + (xO + (xO + (xO + (xO + (xO + (xO + (xO + xH))))))))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "i.322" |}; + v_info := dummy_var_info |}; + gs := Slocal |}) + (Pconst + (Zpos + (xI + (xO + (xO xH)))))) + (Pconst + (Zpos + (xI + (xI + (xO + (xI xH)))))) + (Pconst + (Zpos + (xO + (xI + (xI + (xO + (xI xH)))))))))))))))))]; + f_tyout := [sint]; + f_res := + [{| v_var := + {| vtype := sint; vname := "c.323" |}; + v_info := dummy_var_info |}]; + f_extra := tt |})]; + p_globs := []; p_extra := tt |} +. \ No newline at end of file diff --git a/theories/Jasmin/examples/bigadd/bigadd.cprog b/theories/Jasmin/examples/bigadd.cprog similarity index 55% rename from theories/Jasmin/examples/bigadd/bigadd.cprog rename to theories/Jasmin/examples/bigadd.cprog index 464b8580..1ffa67f5 100644 --- a/theories/Jasmin/examples/bigadd/bigadd.cprog +++ b/theories/Jasmin/examples/bigadd.cprog @@ -1,6 +1,6 @@ {Jasmin.Expr.p_funcs = - [(Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH, - {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH; + [(Jasmin.BinNums.Coq_xH, + {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH; f_tyin = [Jasmin.Type.Coq_sarr (Jasmin.BinNums.Coq_xO @@ -23,10 +23,10 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))); - vname = x.140}; + vname = x.151}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)}; + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}; {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sarr @@ -35,29 +35,28 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))); - vname = y.141}; + vname = y.152}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)}]; + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; f_body = [Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))), + (({Jasmin.Location.uid_loc = 2; + base_loc = + {Jasmin.Location.loc_fname = "bigadd.jazz"; loc_start = (8, 2); + loc_end = (8, 12); loc_bchar = 123; loc_echar = 133}; + stack_loc = []}, + []), Jasmin.Expr.Cassgn (Jasmin.Expr.Lvar {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = xr.143}; + vname = xr.154}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}, + {Jasmin.Location.loc_fname = "bigadd.jazz"; + loc_start = (8, 2); loc_end = (8, 4); loc_bchar = 123; + loc_echar = 125}}, Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, Jasmin.Expr.Pget (Jasmin.Warray_.AAscale, Jasmin.Wsize.U64, {Jasmin.Expr.gv = @@ -69,33 +68,30 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))); - vname = x.140}; + vname = x.151}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}; + {Jasmin.Location.loc_fname = "bigadd.jazz"; + loc_start = (8, 7); loc_end = (8, 8); loc_bchar = 128; + loc_echar = 129}}; gs = Jasmin.Expr.Slocal}, Jasmin.Expr.Pconst Jasmin.BinNums.Z0))); Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))), + (({Jasmin.Location.uid_loc = 3; + base_loc = + {Jasmin.Location.loc_fname = "bigadd.jazz"; loc_start = (9, 2); + loc_end = (9, 12); loc_bchar = 136; loc_echar = 146}; + stack_loc = []}, + []), Jasmin.Expr.Cassgn (Jasmin.Expr.Lvar {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = yr.144}; + vname = yr.155}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}, + {Jasmin.Location.loc_fname = "bigadd.jazz"; + loc_start = (9, 2); loc_end = (9, 4); loc_bchar = 136; + loc_echar = 138}}, Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, Jasmin.Expr.Pget (Jasmin.Warray_.AAscale, Jasmin.Wsize.U64, {Jasmin.Expr.gv = @@ -107,73 +103,71 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))); - vname = y.141}; + vname = y.152}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}; + {Jasmin.Location.loc_fname = "bigadd.jazz"; + loc_start = (9, 7); loc_end = (9, 8); loc_bchar = 141; + loc_echar = 142}}; gs = Jasmin.Expr.Slocal}, Jasmin.Expr.Pconst Jasmin.BinNums.Z0))); Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))), + (({Jasmin.Location.uid_loc = 4; + base_loc = + {Jasmin.Location.loc_fname = "bigadd.jazz"; + loc_start = (10, 2); loc_end = (10, 15); loc_bchar = 149; + loc_echar = 162}; + stack_loc = []}, + []), Jasmin.Expr.Copn ([Jasmin.Expr.Lvar {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sbool; - vname = cf.145}; + vname = cf.156}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}; + {Jasmin.Location.loc_fname = "bigadd.jazz"; + loc_start = (10, 2); loc_end = (10, 4); loc_bchar = 149; + loc_echar = 151}}; Jasmin.Expr.Lvar {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = xr.143}; + vname = xr.154}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}], - Jasmin.Expr.AT_none, Jasmin.Sopn.Oaddcarry Jasmin.Wsize.U64, + {Jasmin.Location.loc_fname = "bigadd.jazz"; + loc_start = (10, 6); loc_end = (10, 8); loc_bchar = 153; + loc_echar = 155}}], + Jasmin.Expr.AT_keep, Jasmin.Sopn.Oaddcarry Jasmin.Wsize.U64, [Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = xr.143}; + vname = xr.154}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}; + {Jasmin.Location.loc_fname = "bigadd.jazz"; + loc_start = (10, 6); loc_end = (10, 8); loc_bchar = 153; + loc_echar = 155}}; gs = Jasmin.Expr.Slocal}; Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = yr.144}; + vname = yr.155}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}; + {Jasmin.Location.loc_fname = "bigadd.jazz"; + loc_start = (10, 12); loc_end = (10, 14); loc_bchar = 159; + loc_echar = 161}}; gs = Jasmin.Expr.Slocal}; Jasmin.Expr.Pbool false])); Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))), + (({Jasmin.Location.uid_loc = 5; + base_loc = + {Jasmin.Location.loc_fname = "bigadd.jazz"; + loc_start = (12, 2); loc_end = (12, 14); loc_bchar = 166; + loc_echar = 178}; + stack_loc = []}, + []), Jasmin.Expr.Cassgn (Jasmin.Expr.Laset (Jasmin.Warray_.AAscale, Jasmin.Wsize.U64, {Jasmin.Expr.v_var = @@ -184,12 +178,11 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))); - vname = res.142}; + vname = res.153}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}, + {Jasmin.Location.loc_fname = "bigadd.jazz"; + loc_start = (12, 2); loc_end = (12, 5); loc_bchar = 166; + loc_echar = 169}}, Jasmin.Expr.Pconst Jasmin.BinNums.Z0), Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, Jasmin.Expr.Pvar @@ -197,22 +190,27 @@ {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = xr.143}; + vname = xr.154}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}; + {Jasmin.Location.loc_fname = "bigadd.jazz"; + loc_start = (12, 11); loc_end = (12, 13); loc_bchar = 175; + loc_echar = 177}}; gs = Jasmin.Expr.Slocal})); Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH), + (({Jasmin.Location.uid_loc = 10; + base_loc = + {Jasmin.Location.loc_fname = "bigadd.jazz"; + loc_start = (14, 2); loc_end = (20, 3); loc_bchar = 182; + loc_echar = 273}; + stack_loc = []}, + []), Jasmin.Expr.Cfor ({Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = i.146}; + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = i.157}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)}, + {Jasmin.Location.loc_fname = "bigadd.jazz"; + loc_start = (14, 6); loc_end = (14, 7); loc_bchar = 186; + loc_echar = 187}}, ((Jasmin.Expr.UpTo, Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos Jasmin.BinNums.Coq_xH)), Jasmin.Expr.Pconst @@ -220,21 +218,23 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))), [Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), + (({Jasmin.Location.uid_loc = 6; + base_loc = + {Jasmin.Location.loc_fname = "bigadd.jazz"; + loc_start = (15, 4); loc_end = (15, 14); loc_bchar = 203; + loc_echar = 213}; + stack_loc = []}, + []), Jasmin.Expr.Cassgn (Jasmin.Expr.Lvar {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = xr.143}; + vname = xr.154}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}, + {Jasmin.Location.loc_fname = "bigadd.jazz"; + loc_start = (15, 4); loc_end = (15, 6); loc_bchar = 203; + loc_echar = 205}}, Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, Jasmin.Expr.Pget (Jasmin.Warray_.AAscale, Jasmin.Wsize.U64, {Jasmin.Expr.gv = @@ -246,40 +246,40 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))); - vname = x.140}; + vname = x.151}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}; + {Jasmin.Location.loc_fname = "bigadd.jazz"; + loc_start = (15, 9); loc_end = (15, 10); loc_bchar = 208; + loc_echar = 209}}; gs = Jasmin.Expr.Slocal}, Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = i.146}; + vname = i.157}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}; + {Jasmin.Location.loc_fname = "bigadd.jazz"; + loc_start = (15, 11); loc_end = (15, 12); + loc_bchar = 210; loc_echar = 211}}; gs = Jasmin.Expr.Slocal}))); Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), + (({Jasmin.Location.uid_loc = 7; + base_loc = + {Jasmin.Location.loc_fname = "bigadd.jazz"; + loc_start = (16, 4); loc_end = (16, 14); loc_bchar = 218; + loc_echar = 228}; + stack_loc = []}, + []), Jasmin.Expr.Cassgn (Jasmin.Expr.Lvar {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = yr.144}; + vname = yr.155}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}, + {Jasmin.Location.loc_fname = "bigadd.jazz"; + loc_start = (16, 4); loc_end = (16, 6); loc_bchar = 218; + loc_echar = 220}}, Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, Jasmin.Expr.Pget (Jasmin.Warray_.AAscale, Jasmin.Wsize.U64, {Jasmin.Expr.gv = @@ -291,85 +291,89 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))); - vname = y.141}; + vname = y.152}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}; + {Jasmin.Location.loc_fname = "bigadd.jazz"; + loc_start = (16, 9); loc_end = (16, 10); loc_bchar = 223; + loc_echar = 224}}; gs = Jasmin.Expr.Slocal}, Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = i.146}; + vname = i.157}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}; + {Jasmin.Location.loc_fname = "bigadd.jazz"; + loc_start = (16, 11); loc_end = (16, 12); + loc_bchar = 225; loc_echar = 226}}; gs = Jasmin.Expr.Slocal}))); Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)), + (({Jasmin.Location.uid_loc = 8; + base_loc = + {Jasmin.Location.loc_fname = "bigadd.jazz"; + loc_start = (17, 4); loc_end = (17, 22); loc_bchar = 233; + loc_echar = 251}; + stack_loc = []}, + []), Jasmin.Expr.Copn ([Jasmin.Expr.Lvar {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sbool; - vname = cf.145}; + vname = cf.156}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}; + {Jasmin.Location.loc_fname = "bigadd.jazz"; + loc_start = (17, 4); loc_end = (17, 6); loc_bchar = 233; + loc_echar = 235}}; Jasmin.Expr.Lvar {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = xr.143}; + vname = xr.154}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}], - Jasmin.Expr.AT_none, Jasmin.Sopn.Oaddcarry Jasmin.Wsize.U64, + {Jasmin.Location.loc_fname = "bigadd.jazz"; + loc_start = (17, 8); loc_end = (17, 10); loc_bchar = 237; + loc_echar = 239}}], + Jasmin.Expr.AT_keep, Jasmin.Sopn.Oaddcarry Jasmin.Wsize.U64, [Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = xr.143}; + vname = xr.154}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}; + {Jasmin.Location.loc_fname = "bigadd.jazz"; + loc_start = (17, 8); loc_end = (17, 10); + loc_bchar = 237; loc_echar = 239}}; gs = Jasmin.Expr.Slocal}; Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = yr.144}; + vname = yr.155}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}; + {Jasmin.Location.loc_fname = "bigadd.jazz"; + loc_start = (17, 14); loc_end = (17, 16); + loc_bchar = 243; loc_echar = 245}}; gs = Jasmin.Expr.Slocal}; Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sbool; - vname = cf.145}; + vname = cf.156}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}; + {Jasmin.Location.loc_fname = "bigadd.jazz"; + loc_start = (17, 19); loc_end = (17, 21); + loc_bchar = 248; loc_echar = 250}}; gs = Jasmin.Expr.Slocal}])); Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)), + (({Jasmin.Location.uid_loc = 9; + base_loc = + {Jasmin.Location.loc_fname = "bigadd.jazz"; + loc_start = (19, 4); loc_end = (19, 16); loc_bchar = 257; + loc_echar = 269}; + stack_loc = []}, + []), Jasmin.Expr.Cassgn (Jasmin.Expr.Laset (Jasmin.Warray_.AAscale, Jasmin.Wsize.U64, {Jasmin.Expr.v_var = @@ -380,20 +384,20 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))); - vname = res.142}; + vname = res.153}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}, + {Jasmin.Location.loc_fname = "bigadd.jazz"; + loc_start = (19, 4); loc_end = (19, 7); loc_bchar = 257; + loc_echar = 260}}, Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = i.146}; + vname = i.157}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}; + {Jasmin.Location.loc_fname = "bigadd.jazz"; + loc_start = (19, 8); loc_end = (19, 9); + loc_bchar = 261; loc_echar = 262}}; gs = Jasmin.Expr.Slocal}), Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, Jasmin.Expr.Pvar @@ -401,11 +405,11 @@ {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = xr.143}; + vname = xr.154}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}; + {Jasmin.Location.loc_fname = "bigadd.jazz"; + loc_start = (19, 13); loc_end = (19, 15); + loc_bchar = 266; loc_echar = 268}}; gs = Jasmin.Expr.Slocal}))]))]; f_tyout = [Jasmin.Type.Coq_sarr @@ -423,12 +427,9 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))); - vname = res.142}; + vname = res.153}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}]; + {Jasmin.Location.loc_fname = "bigadd.jazz"; loc_start = (21, 9); + loc_end = (21, 12); loc_bchar = 283; loc_echar = 286}}]; f_extra = ()})]; p_globs = []; p_extra = ()} diff --git a/theories/Jasmin/examples/bigadd/bigadd.jazz b/theories/Jasmin/examples/bigadd.jazz similarity index 100% rename from theories/Jasmin/examples/bigadd/bigadd.jazz rename to theories/Jasmin/examples/bigadd.jazz diff --git a/theories/Jasmin/examples/bigadd.v b/theories/Jasmin/examples/bigadd.v new file mode 100644 index 00000000..05cf1f5d --- /dev/null +++ b/theories/Jasmin/examples/bigadd.v @@ -0,0 +1,310 @@ +Require Import List. +From Jasmin Require Import expr. +From Jasmin Require Import x86_extra. + +Import ListNotations. +Local Open Scope string. + +Definition bigadd := {| p_funcs := + [(xH, + {| f_info := xO xH; + f_tyin := + [sarr + (xO + (xO + (xO + (xO + (xO xH))))); + sarr + (xO + (xO + (xO + (xO + (xO xH)))))]; + f_params := + [{| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO xH))))); + vname := "x.151" |}; + v_info := dummy_var_info |}; + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO xH))))); + vname := "y.152" |}; + v_info := dummy_var_info |}]; + f_body := + [MkI + (dummy_instr_info) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "xr.154" |}; + v_info := dummy_var_info |}) + (AT_none) (sword U64) + (Pget (AAscale) (U64) + ({| gv := + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO xH))))); + vname := "x.151" |}; + v_info := dummy_var_info |}; + gs := Slocal |}) + (Pconst Z0))); + MkI + (dummy_instr_info) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "yr.155" |}; + v_info := dummy_var_info |}) + (AT_none) (sword U64) + (Pget (AAscale) (U64) + ({| gv := + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO xH))))); + vname := "y.152" |}; + v_info := dummy_var_info |}; + gs := Slocal |}) + (Pconst Z0))); + MkI + (dummy_instr_info) + (Copn + ([Lvar + {| v_var := + {| vtype := sbool; + vname := "cf.156" |}; + v_info := dummy_var_info |}; + Lvar + {| v_var := + {| vtype := + sword U64; + vname := "xr.154" |}; + v_info := dummy_var_info |}]) + (AT_keep) (Oaddcarry U64) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "xr.154" |}; + v_info := dummy_var_info |}; + gs := Slocal |}; + Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "yr.155" |}; + v_info := dummy_var_info |}; + gs := Slocal |}; + Pbool false])); + MkI + (dummy_instr_info) + (Cassgn + (Laset (AAscale) (U64) + ({| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO xH))))); + vname := "res.153" |}; + v_info := dummy_var_info |}) + (Pconst Z0)) + (AT_none) (sword U64) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "xr.154" |}; + v_info := dummy_var_info |}; + gs := Slocal |})); + MkI + (dummy_instr_info) + (Cfor + ({| v_var := + {| vtype := sint; vname := "i.157" |}; + v_info := dummy_var_info |}) + (((UpTo, + Pconst (Zpos xH)), + Pconst + (Zpos + (xO + (xO xH))))) + ([MkI + (dummy_instr_info) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "xr.154" |}; + v_info := dummy_var_info |}) + (AT_none) (sword U64) + (Pget (AAscale) (U64) + ({| gv := + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO xH))))); + vname := "x.151" |}; + v_info := dummy_var_info |}; + gs := Slocal |}) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "i.157" |}; + v_info := dummy_var_info |}; + gs := Slocal |}))); + MkI + (dummy_instr_info) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "yr.155" |}; + v_info := dummy_var_info |}) + (AT_none) (sword U64) + (Pget (AAscale) (U64) + ({| gv := + {| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO xH))))); + vname := "y.152" |}; + v_info := dummy_var_info |}; + gs := Slocal |}) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "i.157" |}; + v_info := dummy_var_info |}; + gs := Slocal |}))); + MkI + (dummy_instr_info) + (Copn + ([Lvar + {| v_var := + {| vtype := sbool; + vname := "cf.156" |}; + v_info := dummy_var_info |}; + Lvar + {| v_var := + {| vtype := + sword U64; + vname := "xr.154" |}; + v_info := dummy_var_info |}]) + (AT_keep) (Oaddcarry U64) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "xr.154" |}; + v_info := dummy_var_info |}; + gs := Slocal |}; + Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "yr.155" |}; + v_info := dummy_var_info |}; + gs := Slocal |}; + Pvar + {| gv := + {| v_var := + {| vtype := sbool; + vname := "cf.156" |}; + v_info := dummy_var_info |}; + gs := Slocal |}])); + MkI + (dummy_instr_info) + (Cassgn + (Laset (AAscale) (U64) + ({| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO xH))))); + vname := "res.153" |}; + v_info := dummy_var_info |}) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "i.157" |}; + v_info := dummy_var_info |}; + gs := Slocal |})) + (AT_none) (sword U64) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "xr.154" |}; + v_info := dummy_var_info |}; + gs := Slocal |}))]))]; + f_tyout := + [sarr + (xO + (xO + (xO + (xO + (xO xH)))))]; + f_res := + [{| v_var := + {| vtype := + sarr + (xO + (xO + (xO + (xO + (xO xH))))); + vname := "res.153" |}; + v_info := dummy_var_info |}]; + f_extra := tt |})]; + p_globs := []; p_extra := tt |} +. \ No newline at end of file diff --git a/theories/Jasmin/examples/bigadd/bigadd.v b/theories/Jasmin/examples/bigadd/bigadd.v deleted file mode 100644 index 5537492e..00000000 --- a/theories/Jasmin/examples/bigadd/bigadd.v +++ /dev/null @@ -1,553 +0,0 @@ -Set Warnings "-notation-overridden,-ambiguous-paths". -From mathcomp Require Import all_ssreflect all_algebra reals distr realsum - fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool ssrnum - eqtype choice seq. -Set Warnings "notation-overridden,ambiguous-paths". - -Require Import List. -From Jasmin Require Import expr. -(* From Jasmin Require Import x86_extra. *) -From JasminSSProve Require Import jasmin_translate. -From Crypt Require Import Prelude Package. - -Import ListNotations. -Local Open Scope string. - -Context `{asmop : asmOp}. - -Context {T} {pT : progT T}. - -Context {pd : PointerData}. - -Context (P : uprog). - -Context (f : funname). - -Definition bigadd := - {| p_funcs := - [(xO xH, - {| f_info := xI xH; - f_tyin := - [sarr - (xO - (xO - (xO - (xO - (xO xH))))); - sarr - (xO - (xO - (xO - (xO - (xO xH)))))]; - f_params := - [{| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO xH))))); - vname := "x.140" |}; - v_info := - xO - (xO xH) |}; - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO xH))))); - vname := "y.141" |}; - v_info := - xI - (xO xH) |}]; - f_body := - [MkI - (xI - (xO - (xI - (xO - (xO xH))))) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "xr.143" |}; - v_info := - xI - (xI - (xI - (xO - (xO xH)))) |}) - (AT_none) (sword U64) - (Pget (AAscale) (U64) - ({| gv := - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO xH))))); - vname := "x.140" |}; - v_info := - xO - (xI - (xI - (xO - (xO xH)))) |}; - gs := Slocal |}) - (Pconst Z0))); - MkI - (xO - (xI - (xO - (xO - (xO xH))))) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "yr.144" |}; - v_info := - xO - (xO - (xI - (xO - (xO xH)))) |}) - (AT_none) (sword U64) - (Pget (AAscale) (U64) - ({| gv := - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO xH))))); - vname := "y.141" |}; - v_info := - xI - (xI - (xO - (xO - (xO xH)))) |}; - gs := Slocal |}) - (Pconst Z0))); - MkI - (xI - (xO - (xI - (xI xH)))) - (Copn - ([Lvar - {| v_var := - {| vtype := sbool; - vname := "cf.145" |}; - v_info := - xO - (xO - (xO - (xO - (xO xH)))) |}; - Lvar - {| v_var := - {| vtype := - sword U64; - vname := "xr.143" |}; - v_info := - xI - (xO - (xO - (xO - (xO xH)))) |}]) - (AT_none) (Oaddcarry U64) - ([Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "xr.143" |}; - v_info := - xO - (xI - (xI - (xI xH))) |}; - gs := Slocal |}; - Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "yr.144" |}; - v_info := - xI - (xI - (xI - (xI xH))) |}; - gs := Slocal |}; - Pbool false])); - MkI - (xO - (xI - (xO - (xI xH)))) - (Cassgn - (Laset (AAscale) (U64) - ({| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO xH))))); - vname := "res.142" |}; - v_info := - xO - (xO - (xI - (xI xH))) |}) - (Pconst Z0)) - (AT_none) (sword U64) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "xr.143" |}; - v_info := - xI - (xI - (xO - (xI xH))) |}; - gs := Slocal |})); - MkI - (xO - (xI xH)) - (Cfor - ({| v_var := - {| vtype := sint; vname := "i.146" |}; - v_info := - xI - (xI xH) |}) - (((UpTo, - Pconst (Zpos xH)), - Pconst - (Zpos - (xO - (xO xH))))) - ([MkI - (xO - (xI - (xI - (xO xH)))) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "xr.143" |}; - v_info := - xI - (xO - (xO - (xI xH))) |}) - (AT_none) (sword U64) - (Pget (AAscale) (U64) - ({| gv := - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO xH))))); - vname := "x.140" |}; - v_info := - xO - (xO - (xO - (xI xH))) |}; - gs := Slocal |}) - (Pvar - {| gv := - {| v_var := - {| vtype := sint; - vname := "i.146" |}; - v_info := - xI - (xI - (xI - (xO xH))) |}; - gs := Slocal |}))); - MkI - (xO - (xI - (xO - (xO xH)))) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "yr.144" |}; - v_info := - xI - (xO - (xI - (xO xH))) |}) - (AT_none) (sword U64) - (Pget (AAscale) (U64) - ({| gv := - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO xH))))); - vname := "y.141" |}; - v_info := - xO - (xO - (xI - (xO xH))) |}; - gs := Slocal |}) - (Pvar - {| gv := - {| v_var := - {| vtype := sint; - vname := "i.146" |}; - v_info := - xI - (xI - (xO - (xO xH))) |}; - gs := Slocal |}))); - MkI - (xO - (xO - (xI xH))) - (Copn - ([Lvar - {| v_var := - {| vtype := sbool; - vname := "cf.145" |}; - v_info := - xO - (xO - (xO - (xO xH))) |}; - Lvar - {| v_var := - {| vtype := - sword U64; - vname := "xr.143" |}; - v_info := - xI - (xO - (xO - (xO xH))) |}]) - (AT_none) (Oaddcarry U64) - ([Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "xr.143" |}; - v_info := - xI - (xO - (xI xH)) |}; - gs := Slocal |}; - Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "yr.144" |}; - v_info := - xO - (xI - (xI xH)) |}; - gs := Slocal |}; - Pvar - {| gv := - {| v_var := - {| vtype := sbool; - vname := "cf.145" |}; - v_info := - xI - (xI - (xI xH)) |}; - gs := Slocal |}])); - MkI - (xO - (xO - (xO xH))) - (Cassgn - (Laset (AAscale) (U64) - ({| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO xH))))); - vname := "res.142" |}; - v_info := - xI - (xI - (xO xH)) |}) - (Pvar - {| gv := - {| v_var := - {| vtype := sint; - vname := "i.146" |}; - v_info := - xO - (xI - (xO xH)) |}; - gs := Slocal |})) - (AT_none) (sword U64) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "xr.143" |}; - v_info := - xI - (xO - (xO xH)) |}; - gs := Slocal |}))]))]; - f_tyout := - [sarr - (xO - (xO - (xO - (xO - (xO xH)))))]; - f_res := - [{| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO xH))))); - vname := "res.142" |}; - v_info := - xO - (xO - (xO - (xI - (xO xH)))) |}]; - f_extra := tt |})]; - p_globs := []; p_extra := tt |} -. - -Import PackageNotation. -Notation coe_cht := coerce_to_choice_type. -Notation coe_tyc := coerce_typed_code. -Notation " 'array " := (chMap 'int ('word U8)) (at level 2) : package_scope. -Notation " 'array " := (chMap 'int ('word U8)) (in custom pack_type at level 2). -Notation " 'mem " := (chMap ('word Uptr) ('word U8)) (at level 2) : package_scope. -Notation " 'mem " := (chMap ('word Uptr) ('word U8)) (in custom pack_type at level 2). -Notation " ⸨ ws ⸩ a .[ ptr * scale ] " := (chArray_get ws a ptr scale) - (format " ⸨ ws ⸩ a .[ ptr * scale ] "). -Notation " a [ w / p ] " := - (chArray_set a AAscale p w) - (at level 99, no associativity, - format " a [ w / p ] "). - -From Equations Require Import Equations. -Set Equations With UIP. -Set Equations Transparent. - -From extructures Require Import ord fset fmap. - -Definition empty_ufun_decl := (1%positive, {| f_info := 1%positive; f_tyin := [::]; f_params := [::]; f_body := [::]; f_tyout := [::]; f_res := [::]; f_extra := tt |}) : _ufun_decl. -Definition translate_simple_prog P := translate_fundef P emptym 1%positive (List.nth_default empty_ufun_decl P.(p_funcs) 0). - -Definition fn_bigadd := Eval simpl in ((ffun (translate_simple_prog bigadd).2).π2).π2. - -Lemma eq_rect_K : - forall (A : eqType) (x : A) (P : A -> Type) h e, - @eq_rect A x P h x e = h. -Proof. - intros A x P' h e. - replace e with (@erefl A x) by apply eq_irrelevance. - reflexivity. -Qed. - -From CoqWord Require Import word. - -Notation "$ i" := (_ ; nat_of_p_id_var _ {| vtype := _; vname := i |}) - (at level 99, format "$ i"). - -Notation "$$ i" := ({| v_var := {| vtype := _; vname := i |}; v_info := _ |}) - (at level 99, - format "$$ i"). - -Notation "'for var ∈ seq" := (translate_for _ ($$var) seq) - (at level 99). - -Ltac prog_unfold := unfold translate_write_var, translate_instr, translate_var, coerce_chtuple_to_list, bind_list', bind_list_trunc_aux, wsize_size. -Hint Rewrite coerce_typed_code_K eq_rect_K eq_rect_r_K : prog_rewrite. - -Opaque translate_for. -Ltac simpl_fun := - repeat (match goal with - | _ => progress autorewrite with prog_rewrite - | _ => prog_unfold; simpl - end). - -Goal forall aa goal, fn_bigadd aa = goal. - intros [a1 a2] goal. - unfold fn_bigadd. - simpl_fun. - - (* BSH: the setoid_rewrites takes forever if we do not 'set' these names first *) - set (array32 := sarr 32%positive). - set (x := $"x.140"). - set (xr := $"xr.143"). - set (y := $"y.141"). - set (yr := $"yr.144"). - set (cf := $"cf.145"). - set (i := $"i.146"). - - (* this hangs *) - (* set (res := $"res.142"). *) - - (* setoid_rewrite coerce_to_choice_type_K. *) - (* setoid_rewrite coerce_to_choice_type_K. *) - (* time repeat setoid_rewrite (@zero_extend_u U64). *) - - (* For comparison: unfold the for loop *) - Transparent translate_for. - unfold translate_for. - simpl_fun. - subst i. - set (i := $"i.146"). - setoid_rewrite coerce_to_choice_type_K. - setoid_rewrite coerce_to_choice_type_K. - time repeat setoid_rewrite (@zero_extend_u U64). - - (* this still hangs *) - (* set (res := $"res.142"). *) - -Admitted. diff --git a/theories/Jasmin/examples/ex.cprog b/theories/Jasmin/examples/ex.cprog new file mode 100644 index 00000000..bdd765f1 --- /dev/null +++ b/theories/Jasmin/examples/ex.cprog @@ -0,0 +1,120 @@ + {Jasmin.Expr.p_funcs = + [(Jasmin.BinNums.Coq_xH, + {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH; + f_tyin = + [Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = x.144}; + v_info = + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}; + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = y.145}; + v_info = + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; + f_body = + [Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 2; + base_loc = + {Jasmin.Location.loc_fname = "ex.jazz"; loc_start = (5, 2); + loc_end = (5, 13); loc_bchar = 81; loc_echar = 92}; + stack_loc = []}, + []), + Jasmin.Expr.Copn + ([Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sbool; + vname = cf.146}; + v_info = + {Jasmin.Location.loc_fname = "ex.jazz"; loc_start = (5, 2); + loc_end = (5, 4); loc_bchar = 81; loc_echar = 83}}; + Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = x.144}; + v_info = + {Jasmin.Location.loc_fname = "ex.jazz"; loc_start = (5, 6); + loc_end = (5, 7); loc_bchar = 85; loc_echar = 86}}], + Jasmin.Expr.AT_keep, Jasmin.Sopn.Oaddcarry Jasmin.Wsize.U64, + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = x.144}; + v_info = + {Jasmin.Location.loc_fname = "ex.jazz"; loc_start = (5, 6); + loc_end = (5, 7); loc_bchar = 85; loc_echar = 86}}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = y.145}; + v_info = + {Jasmin.Location.loc_fname = "ex.jazz"; loc_start = (5, 11); + loc_end = (5, 12); loc_bchar = 90; loc_echar = 91}}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Pbool false])); + Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 3; + base_loc = + {Jasmin.Location.loc_fname = "ex.jazz"; loc_start = (6, 2); + loc_end = (6, 13); loc_bchar = 95; loc_echar = 106}; + stack_loc = []}, + []), + Jasmin.Expr.Copn + ([Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sbool; + vname = cf.146}; + v_info = + {Jasmin.Location.loc_fname = "ex.jazz"; loc_start = (6, 2); + loc_end = (6, 4); loc_bchar = 95; loc_echar = 97}}; + Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = y.145}; + v_info = + {Jasmin.Location.loc_fname = "ex.jazz"; loc_start = (6, 6); + loc_end = (6, 7); loc_bchar = 99; loc_echar = 100}}], + Jasmin.Expr.AT_keep, Jasmin.Sopn.Oaddcarry Jasmin.Wsize.U64, + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = y.145}; + v_info = + {Jasmin.Location.loc_fname = "ex.jazz"; loc_start = (6, 6); + loc_end = (6, 7); loc_bchar = 99; loc_echar = 100}}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = x.144}; + v_info = + {Jasmin.Location.loc_fname = "ex.jazz"; loc_start = (6, 11); + loc_end = (6, 12); loc_bchar = 104; loc_echar = 105}}; + gs = Jasmin.Expr.Slocal}; + Jasmin.Expr.Pbool false]))]; + f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = y.145}; + v_info = + {Jasmin.Location.loc_fname = "ex.jazz"; loc_start = (8, 9); + loc_end = (8, 10); loc_bchar = 117; loc_echar = 118}}]; + f_extra = ()})]; + p_globs = []; p_extra = ()} diff --git a/theories/Jasmin/examples/ex/ex.jazz b/theories/Jasmin/examples/ex.jazz similarity index 100% rename from theories/Jasmin/examples/ex/ex.jazz rename to theories/Jasmin/examples/ex.jazz diff --git a/theories/Jasmin/examples/ex.v b/theories/Jasmin/examples/ex.v new file mode 100644 index 00000000..6da00c6e --- /dev/null +++ b/theories/Jasmin/examples/ex.v @@ -0,0 +1,96 @@ +Require Import List. +From Jasmin Require Import expr. +From Jasmin Require Import x86_extra. + +Import ListNotations. +Local Open Scope string. + +Definition ex := {| p_funcs := + [(xH, + {| f_info := xO xH; + f_tyin := + [sword U64; + sword U64]; + f_params := + [{| v_var := + {| vtype := sword U64; + vname := "x.144" |}; + v_info := dummy_var_info |}; + {| v_var := + {| vtype := sword U64; + vname := "y.145" |}; + v_info := dummy_var_info |}]; + f_body := + [MkI + (dummy_instr_info) + (Copn + ([Lvar + {| v_var := + {| vtype := sbool; + vname := "cf.146" |}; + v_info := dummy_var_info |}; + Lvar + {| v_var := + {| vtype := + sword U64; + vname := "x.144" |}; + v_info := dummy_var_info |}]) + (AT_keep) (Oaddcarry U64) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "x.144" |}; + v_info := dummy_var_info |}; + gs := Slocal |}; + Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "y.145" |}; + v_info := dummy_var_info |}; + gs := Slocal |}; + Pbool false])); + MkI + (dummy_instr_info) + (Copn + ([Lvar + {| v_var := + {| vtype := sbool; + vname := "cf.146" |}; + v_info := dummy_var_info |}; + Lvar + {| v_var := + {| vtype := + sword U64; + vname := "y.145" |}; + v_info := dummy_var_info |}]) + (AT_keep) (Oaddcarry U64) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "y.145" |}; + v_info := dummy_var_info |}; + gs := Slocal |}; + Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "x.144" |}; + v_info := dummy_var_info |}; + gs := Slocal |}; + Pbool false]))]; + f_tyout := [sword U64]; + f_res := + [{| v_var := + {| vtype := sword U64; + vname := "y.145" |}; + v_info := dummy_var_info |}]; + f_extra := tt |})]; + p_globs := []; p_extra := tt |} +. \ No newline at end of file diff --git a/theories/Jasmin/examples/ex/ex.cprog b/theories/Jasmin/examples/ex/ex.cprog deleted file mode 100644 index 33fb65c1..00000000 --- a/theories/Jasmin/examples/ex/ex.cprog +++ /dev/null @@ -1,122 +0,0 @@ - {Jasmin.Expr.p_funcs = - [(Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH, - {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH; - f_tyin = - [Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; - f_params = - [{Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = x.133}; - v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)}; - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = y.134}; - v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)}]; - f_body = - [Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)), - Jasmin.Expr.Copn - ([Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sbool; - vname = cf.135}; - v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}; - Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = x.133}; - v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}], - Jasmin.Expr.AT_none, Jasmin.Sopn.Oaddcarry Jasmin.Wsize.U64, - [Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = x.133}; - v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}; - gs = Jasmin.Expr.Slocal}; - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = y.134}; - v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}; - gs = Jasmin.Expr.Slocal}; - Jasmin.Expr.Pbool false])); - Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH), - Jasmin.Expr.Copn - ([Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sbool; - vname = cf.135}; - v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}; - Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = y.134}; - v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}], - Jasmin.Expr.AT_none, Jasmin.Sopn.Oaddcarry Jasmin.Wsize.U64, - [Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = y.134}; - v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)}; - gs = Jasmin.Expr.Slocal}; - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = x.133}; - v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}; - gs = Jasmin.Expr.Slocal}; - Jasmin.Expr.Pbool false]))]; - f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; - f_res = - [{Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = y.134}; - v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}]; - f_extra = ()})]; - p_globs = []; p_extra = ()} diff --git a/theories/Jasmin/examples/ex/ex.v b/theories/Jasmin/examples/ex/ex.v deleted file mode 100644 index 00d6edb9..00000000 --- a/theories/Jasmin/examples/ex/ex.v +++ /dev/null @@ -1,131 +0,0 @@ -Require Import List. -From Jasmin Require Import expr. -From Jasmin Require Import x86_extra. - -Import ListNotations. -Local Open Scope string. - -Definition ex := - {| p_funcs := - [(xO xH, - {| f_info := xI xH; - f_tyin := - [sword U64; - sword U64]; - f_params := - [{| v_var := - {| vtype := sword U64; - vname := "x.133" |}; - v_info := - xO - (xO xH) |}; - {| v_var := - {| vtype := sword U64; - vname := "y.134" |}; - v_info := - xI - (xO xH) |}]; - f_body := - [MkI - (xI - (xI - (xO xH))) - (Copn - ([Lvar - {| v_var := - {| vtype := sbool; - vname := "cf.135" |}; - v_info := - xO - (xI - (xI xH)) |}; - Lvar - {| v_var := - {| vtype := - sword U64; - vname := "x.133" |}; - v_info := - xI - (xI - (xI xH)) |}]) - (AT_none) (Oaddcarry U64) - ([Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "x.133" |}; - v_info := - xO - (xO - (xI xH)) |}; - gs := Slocal |}; - Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "y.134" |}; - v_info := - xI - (xO - (xI xH)) |}; - gs := Slocal |}; - Pbool false])); - MkI - (xO - (xI xH)) - (Copn - ([Lvar - {| v_var := - {| vtype := sbool; - vname := "cf.135" |}; - v_info := - xI - (xO - (xO xH)) |}; - Lvar - {| v_var := - {| vtype := - sword U64; - vname := "y.134" |}; - v_info := - xO - (xI - (xO xH)) |}]) - (AT_none) (Oaddcarry U64) - ([Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "y.134" |}; - v_info := - xI - (xI xH) |}; - gs := Slocal |}; - Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "x.133" |}; - v_info := - xO - (xO - (xO xH)) |}; - gs := Slocal |}; - Pbool false]))]; - f_tyout := [sword U64]; - f_res := - [{| v_var := - {| vtype := sword U64; - vname := "y.134" |}; - v_info := - xO - (xO - (xO - (xO xH))) |}]; - f_extra := tt |})]; - p_globs := []; p_extra := tt |} -. \ No newline at end of file diff --git a/theories/Jasmin/examples/int_add.cprog b/theories/Jasmin/examples/int_add.cprog new file mode 100644 index 00000000..a30e666b --- /dev/null +++ b/theories/Jasmin/examples/int_add.cprog @@ -0,0 +1,173 @@ + {Jasmin.Expr.p_funcs = + [(Jasmin.BinNums.Coq_xH, + {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH; + f_tyin = [Jasmin.Type.Coq_sint; Jasmin.Type.Coq_sint]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = n.154}; + v_info = + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}; + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = m.155}; + v_info = + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; + f_body = + [Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 5; + base_loc = + {Jasmin.Location.loc_fname = "int_add.jazz"; + loc_start = (12, 3); loc_end = (14, 4); loc_bchar = 199; + loc_echar = 238}; + stack_loc = []}, + []), + Jasmin.Expr.Cfor + ({Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = i.156}; + v_info = + {Jasmin.Location.loc_fname = "int_add.jazz"; + loc_start = (12, 7); loc_end = (12, 8); loc_bchar = 203; + loc_echar = 204}}, + ((Jasmin.Expr.UpTo, Jasmin.Expr.Pconst Jasmin.BinNums.Z0), + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = n.154}; + v_info = + {Jasmin.Location.loc_fname = "int_add.jazz"; + loc_start = (12, 16); loc_end = (12, 17); loc_bchar = 212; + loc_echar = 213}}; + gs = Jasmin.Expr.Slocal}), + [Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 4; + base_loc = + {Jasmin.Location.loc_fname = "int_add.jazz"; + loc_start = (13, 7); loc_end = (13, 17); loc_bchar = 223; + loc_echar = 233}; + stack_loc = []}, + []), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = m.155}; + v_info = + {Jasmin.Location.loc_fname = "int_add.jazz"; + loc_start = (13, 7); loc_end = (13, 8); loc_bchar = 223; + loc_echar = 224}}, + Jasmin.Expr.AT_inline, Jasmin.Type.Coq_sint, + Jasmin.Expr.Papp2 (Jasmin.Expr.Oadd Jasmin.Expr.Op_int, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = m.155}; + v_info = + {Jasmin.Location.loc_fname = "int_add.jazz"; + loc_start = (13, 11); loc_end = (13, 12); + loc_bchar = 227; loc_echar = 228}}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos Jasmin.BinNums.Coq_xH))))]))]; + f_tyout = [Jasmin.Type.Coq_sint]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = m.155}; + v_info = + {Jasmin.Location.loc_fname = "int_add.jazz"; loc_start = (15, 10); + loc_end = (15, 11); loc_bchar = 249; loc_echar = 250}}]; + f_extra = ()}); + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH, + {Jasmin.Expr.f_info = + Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH); + f_tyin = + [Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = n.157}; + v_info = + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}; + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = m.158}; + v_info = + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; + f_body = + [Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 3; + base_loc = + {Jasmin.Location.loc_fname = "int_add.jazz"; + loc_start = (3, 3); loc_end = (5, 4); loc_bchar = 63; + loc_echar = 102}; + stack_loc = []}, + []), + Jasmin.Expr.Cfor + ({Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = i.159}; + v_info = + {Jasmin.Location.loc_fname = "int_add.jazz"; + loc_start = (3, 7); loc_end = (3, 8); loc_bchar = 67; + loc_echar = 68}}, + ((Jasmin.Expr.UpTo, Jasmin.Expr.Pconst Jasmin.BinNums.Z0), + Jasmin.Expr.Papp1 (Jasmin.Expr.Oint_of_word Jasmin.Wsize.U64, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = n.157}; + v_info = + {Jasmin.Location.loc_fname = "int_add.jazz"; + loc_start = (3, 16); loc_end = (3, 17); loc_bchar = 76; + loc_echar = 77}}; + gs = Jasmin.Expr.Slocal})), + [Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 2; + base_loc = + {Jasmin.Location.loc_fname = "int_add.jazz"; + loc_start = (4, 7); loc_end = (4, 17); loc_bchar = 87; + loc_echar = 97}; + stack_loc = []}, + []), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = m.158}; + v_info = + {Jasmin.Location.loc_fname = "int_add.jazz"; + loc_start = (4, 7); loc_end = (4, 8); loc_bchar = 87; + loc_echar = 88}}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Papp2 + (Jasmin.Expr.Oadd (Jasmin.Expr.Op_w Jasmin.Wsize.U64), + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = m.158}; + v_info = + {Jasmin.Location.loc_fname = "int_add.jazz"; + loc_start = (4, 11); loc_end = (4, 12); loc_bchar = 91; + loc_echar = 92}}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U64, + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos Jasmin.BinNums.Coq_xH)))))]))]; + f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = m.158}; + v_info = + {Jasmin.Location.loc_fname = "int_add.jazz"; loc_start = (6, 10); + loc_end = (6, 11); loc_bchar = 113; loc_echar = 114}}]; + f_extra = ()})]; + p_globs = []; p_extra = ()} diff --git a/theories/Jasmin/examples/int_operations/int_add.jazz b/theories/Jasmin/examples/int_add.jazz similarity index 100% rename from theories/Jasmin/examples/int_operations/int_add.jazz rename to theories/Jasmin/examples/int_add.jazz diff --git a/theories/Jasmin/examples/int_add.v b/theories/Jasmin/examples/int_add.v new file mode 100644 index 00000000..68b7476a --- /dev/null +++ b/theories/Jasmin/examples/int_add.v @@ -0,0 +1,121 @@ +Require Import List. +From Jasmin Require Import expr. +From Jasmin Require Import x86_extra. + +Import ListNotations. +Local Open Scope string. + +Definition int_add := {| p_funcs := + [(xH, + {| f_info := xO xH; + f_tyin := [sint; sint]; + f_params := + [{| v_var := + {| vtype := sint; vname := "n.154" |}; + v_info := dummy_var_info |}; + {| v_var := + {| vtype := sint; vname := "m.155" |}; + v_info := dummy_var_info |}]; + f_body := + [MkI + (dummy_instr_info) + (Cfor + ({| v_var := + {| vtype := sint; vname := "i.156" |}; + v_info := dummy_var_info |}) + (((UpTo, Pconst Z0), + Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "n.154" |}; + v_info := dummy_var_info |}; + gs := Slocal |})) + ([MkI + (dummy_instr_info) + (Cassgn + (Lvar + {| v_var := + {| vtype := sint; + vname := "m.155" |}; + v_info := dummy_var_info |}) + (AT_inline) (sint) + (Papp2 (Oadd Op_int) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "m.155" |}; + v_info := dummy_var_info |}; + gs := Slocal |}) + (Pconst (Zpos xH))))]))]; + f_tyout := [sint]; + f_res := + [{| v_var := + {| vtype := sint; vname := "m.155" |}; + v_info := dummy_var_info |}]; + f_extra := tt |}); + (xI xH, + {| f_info := + xO (xO xH); + f_tyin := + [sword U64; + sword U64]; + f_params := + [{| v_var := + {| vtype := sword U64; + vname := "n.157" |}; + v_info := dummy_var_info |}; + {| v_var := + {| vtype := sword U64; + vname := "m.158" |}; + v_info := dummy_var_info |}]; + f_body := + [MkI + (dummy_instr_info) + (Cfor + ({| v_var := + {| vtype := sint; vname := "i.159" |}; + v_info := dummy_var_info |}) + (((UpTo, Pconst Z0), + Papp1 (Oint_of_word U64) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "n.157" |}; + v_info := dummy_var_info |}; + gs := Slocal |}))) + ([MkI + (dummy_instr_info) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "m.158" |}; + v_info := dummy_var_info |}) + (AT_none) (sword U64) + (Papp2 + (Oadd (Op_w U64)) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "m.158" |}; + v_info := dummy_var_info |}; + gs := Slocal |}) + (Papp1 (Oword_of_int U64) + (Pconst + (Zpos xH)))))]))]; + f_tyout := [sword U64]; + f_res := + [{| v_var := + {| vtype := sword U64; + vname := "m.158" |}; + v_info := dummy_var_info |}]; + f_extra := tt |})]; + p_globs := []; p_extra := tt |} +. \ No newline at end of file diff --git a/theories/Jasmin/examples/int_incr.cprog b/theories/Jasmin/examples/int_incr.cprog new file mode 100644 index 00000000..a66edf22 --- /dev/null +++ b/theories/Jasmin/examples/int_incr.cprog @@ -0,0 +1,141 @@ + {Jasmin.Expr.p_funcs = + [(Jasmin.BinNums.Coq_xH, + {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH; + f_tyin = []; f_params = []; + f_body = + [Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 3; + base_loc = + {Jasmin.Location.loc_fname = "int_incr.jazz"; + loc_start = (11, 2); loc_end = (11, 14); loc_bchar = 167; + loc_echar = 179}; + stack_loc = []}, + []), + Jasmin.Expr.Ccall (Jasmin.Expr.InlineFun, + [Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = x.153}; + v_info = + {Jasmin.Location.loc_fname = "int_incr.jazz"; + loc_start = (11, 2); loc_end = (11, 3); loc_bchar = 167; + loc_echar = 168}}], + Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH, + [Jasmin.Expr.Pconst Jasmin.BinNums.Z0])); + Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 4; + base_loc = + {Jasmin.Location.loc_fname = "int_incr.jazz"; + loc_start = (12, 2); loc_end = (12, 9); loc_bchar = 182; + loc_echar = 189}; + stack_loc = []}, + []), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = xx.154}; + v_info = + {Jasmin.Location.loc_fname = "int_incr.jazz"; + loc_start = (12, 2); loc_end = (12, 4); loc_bchar = 182; + loc_echar = 184}}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = y.152}; + v_info = + {Jasmin.Location.loc_fname = "int_incr.jazz"; + loc_start = (12, 7); loc_end = (12, 8); loc_bchar = 187; + loc_echar = 188}}; + gs = Jasmin.Expr.Slocal})); + Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 5; + base_loc = + {Jasmin.Location.loc_fname = "int_incr.jazz"; + loc_start = (13, 2); loc_end = (13, 15); loc_bchar = 192; + loc_echar = 205}; + stack_loc = []}, + []), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = y.152}; + v_info = + {Jasmin.Location.loc_fname = "int_incr.jazz"; + loc_start = (13, 2); loc_end = (13, 3); loc_bchar = 192; + loc_echar = 193}}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U64, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = x.153}; + v_info = + {Jasmin.Location.loc_fname = "int_incr.jazz"; + loc_start = (13, 12); loc_end = (13, 13); loc_bchar = 202; + loc_echar = 203}}; + gs = Jasmin.Expr.Slocal})))]; + f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = y.152}; + v_info = + {Jasmin.Location.loc_fname = "int_incr.jazz"; loc_start = (14, 9); + loc_end = (14, 10); loc_bchar = 215; loc_echar = 216}}]; + f_extra = ()}); + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH, + {Jasmin.Expr.f_info = + Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH); + f_tyin = [Jasmin.Type.Coq_sint]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = n.155}; + v_info = + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; + f_body = + [Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 2; + base_loc = + {Jasmin.Location.loc_fname = "int_incr.jazz"; + loc_start = (3, 3); loc_end = (3, 13); loc_bchar = 65; + loc_echar = 75}; + stack_loc = []}, + []), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = m.156}; + v_info = + {Jasmin.Location.loc_fname = "int_incr.jazz"; + loc_start = (3, 3); loc_end = (3, 4); loc_bchar = 65; + loc_echar = 66}}, + Jasmin.Expr.AT_inline, Jasmin.Type.Coq_sint, + Jasmin.Expr.Papp2 (Jasmin.Expr.Oadd Jasmin.Expr.Op_int, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = n.155}; + v_info = + {Jasmin.Location.loc_fname = "int_incr.jazz"; + loc_start = (3, 8); loc_end = (3, 9); loc_bchar = 70; + loc_echar = 71}}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos Jasmin.BinNums.Coq_xH))))]; + f_tyout = [Jasmin.Type.Coq_sint]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = m.156}; + v_info = + {Jasmin.Location.loc_fname = "int_incr.jazz"; loc_start = (4, 10); + loc_end = (4, 11); loc_bchar = 86; loc_echar = 87}}]; + f_extra = ()})]; + p_globs = []; p_extra = ()} diff --git a/theories/Jasmin/examples/int_operations/int_incr.jazz b/theories/Jasmin/examples/int_incr.jazz similarity index 100% rename from theories/Jasmin/examples/int_operations/int_incr.jazz rename to theories/Jasmin/examples/int_incr.jazz diff --git a/theories/Jasmin/examples/int_incr.v b/theories/Jasmin/examples/int_incr.v new file mode 100644 index 00000000..d3e22f5f --- /dev/null +++ b/theories/Jasmin/examples/int_incr.v @@ -0,0 +1,98 @@ +Require Import List. +From Jasmin Require Import expr. +From Jasmin Require Import x86_extra. + +Import ListNotations. +Local Open Scope string. + +Definition int_incr := {| p_funcs := + [(xH, + {| f_info := xO xH; + f_tyin := []; f_params := []; + f_body := + [MkI + (dummy_instr_info) + (Ccall (InlineFun) + ([Lvar + {| v_var := + {| vtype := sint; vname := "x.153" |}; + v_info := dummy_var_info |}]) + (xI xH) + ([Pconst Z0])); + MkI + (dummy_instr_info) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "xx.154" |}; + v_info := dummy_var_info |}) + (AT_none) (sword U64) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "y.152" |}; + v_info := dummy_var_info |}; + gs := Slocal |})); + MkI + (dummy_instr_info) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "y.152" |}; + v_info := dummy_var_info |}) + (AT_none) (sword U64) + (Papp1 (Oword_of_int U64) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "x.153" |}; + v_info := dummy_var_info |}; + gs := Slocal |})))]; + f_tyout := [sword U64]; + f_res := + [{| v_var := + {| vtype := sword U64; + vname := "y.152" |}; + v_info := dummy_var_info |}]; + f_extra := tt |}); + (xI xH, + {| f_info := + xO (xO xH); + f_tyin := [sint]; + f_params := + [{| v_var := + {| vtype := sint; vname := "n.155" |}; + v_info := dummy_var_info |}]; + f_body := + [MkI + (dummy_instr_info) + (Cassgn + (Lvar + {| v_var := + {| vtype := sint; vname := "m.156" |}; + v_info := dummy_var_info |}) + (AT_inline) (sint) + (Papp2 (Oadd Op_int) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "n.155" |}; + v_info := dummy_var_info |}; + gs := Slocal |}) + (Pconst (Zpos xH))))]; + f_tyout := [sint]; + f_res := + [{| v_var := + {| vtype := sint; vname := "m.156" |}; + v_info := dummy_var_info |}]; + f_extra := tt |})]; + p_globs := []; p_extra := tt |} +. \ No newline at end of file diff --git a/theories/Jasmin/examples/int_operations/int_intr_wrapper.c b/theories/Jasmin/examples/int_operations/int_intr_wrapper.c deleted file mode 100644 index 745345a2..00000000 --- a/theories/Jasmin/examples/int_operations/int_intr_wrapper.c +++ /dev/null @@ -1,5 +0,0 @@ -extern int f(); - -int main() { - return f(); -} diff --git a/theories/Jasmin/examples/int_reg.cprog b/theories/Jasmin/examples/int_reg.cprog new file mode 100644 index 00000000..b41979ef --- /dev/null +++ b/theories/Jasmin/examples/int_reg.cprog @@ -0,0 +1,46 @@ + {Jasmin.Expr.p_funcs = + [(Jasmin.BinNums.Coq_xH, + {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH; + f_tyin = [Jasmin.Type.Coq_sint]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = k.141}; + v_info = + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; + f_body = + [Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 2; + base_loc = + {Jasmin.Location.loc_fname = "int_reg.jazz"; + loc_start = (3, 3); loc_end = (3, 9); loc_bchar = 49; + loc_echar = 55}; + stack_loc = []}, + []), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = x.142}; + v_info = + {Jasmin.Location.loc_fname = "int_reg.jazz"; + loc_start = (3, 3); loc_end = (3, 4); loc_bchar = 49; + loc_echar = 50}}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sint, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = k.141}; + v_info = + {Jasmin.Location.loc_fname = "int_reg.jazz"; + loc_start = (3, 7); loc_end = (3, 8); loc_bchar = 53; + loc_echar = 54}}; + gs = Jasmin.Expr.Slocal}))]; + f_tyout = [Jasmin.Type.Coq_sint]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = x.142}; + v_info = + {Jasmin.Location.loc_fname = "int_reg.jazz"; loc_start = (4, 10); + loc_end = (4, 11); loc_bchar = 66; loc_echar = 67}}]; + f_extra = ()})]; + p_globs = []; p_extra = ()} diff --git a/theories/Jasmin/examples/int_operations/int_reg.jazz b/theories/Jasmin/examples/int_reg.jazz similarity index 100% rename from theories/Jasmin/examples/int_operations/int_reg.jazz rename to theories/Jasmin/examples/int_reg.jazz diff --git a/theories/Jasmin/examples/int_reg.v b/theories/Jasmin/examples/int_reg.v new file mode 100644 index 00000000..4dbdb397 --- /dev/null +++ b/theories/Jasmin/examples/int_reg.v @@ -0,0 +1,38 @@ +Require Import List. +From Jasmin Require Import expr. +From Jasmin Require Import x86_extra. + +Import ListNotations. +Local Open Scope string. + +Definition int_reg := {| p_funcs := + [(xH, + {| f_info := xO xH; + f_tyin := [sint]; + f_params := + [{| v_var := + {| vtype := sint; vname := "k.141" |}; + v_info := dummy_var_info |}]; + f_body := + [MkI + (dummy_instr_info) + (Cassgn + (Lvar + {| v_var := + {| vtype := sint; vname := "x.142" |}; + v_info := dummy_var_info |}) + (AT_none) (sint) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; vname := "k.141" |}; + v_info := dummy_var_info |}; + gs := Slocal |}))]; + f_tyout := [sint]; + f_res := + [{| v_var := + {| vtype := sint; vname := "x.142" |}; + v_info := dummy_var_info |}]; + f_extra := tt |})]; + p_globs := []; p_extra := tt |} +. \ No newline at end of file diff --git a/theories/Jasmin/examples/int_shift.cprog b/theories/Jasmin/examples/int_shift.cprog new file mode 100644 index 00000000..4ece35fd --- /dev/null +++ b/theories/Jasmin/examples/int_shift.cprog @@ -0,0 +1,120 @@ + {Jasmin.Expr.p_funcs = + [(Jasmin.BinNums.Coq_xH, + {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH; + f_tyin = []; f_params = []; + f_body = + [Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 3; + base_loc = + {Jasmin.Location.loc_fname = "int_shift.jazz"; + loc_start = (10, 2); loc_end = (10, 14); loc_bchar = 155; + loc_echar = 167}; + stack_loc = []}, + []), + Jasmin.Expr.Ccall (Jasmin.Expr.InlineFun, + [Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = x.151}; + v_info = + {Jasmin.Location.loc_fname = "int_shift.jazz"; + loc_start = (10, 2); loc_end = (10, 3); loc_bchar = 155; + loc_echar = 156}}], + Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH, + [Jasmin.Expr.Pconst Jasmin.BinNums.Z0])); + Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 4; + base_loc = + {Jasmin.Location.loc_fname = "int_shift.jazz"; + loc_start = (11, 2); loc_end = (11, 15); loc_bchar = 170; + loc_echar = 183}; + stack_loc = []}, + []), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = y.150}; + v_info = + {Jasmin.Location.loc_fname = "int_shift.jazz"; + loc_start = (11, 2); loc_end = (11, 3); loc_bchar = 170; + loc_echar = 171}}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U64, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = x.151}; + v_info = + {Jasmin.Location.loc_fname = "int_shift.jazz"; + loc_start = (11, 12); loc_end = (11, 13); loc_bchar = 180; + loc_echar = 181}}; + gs = Jasmin.Expr.Slocal})))]; + f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = y.150}; + v_info = + {Jasmin.Location.loc_fname = "int_shift.jazz"; + loc_start = (12, 9); loc_end = (12, 10); loc_bchar = 193; + loc_echar = 194}}]; + f_extra = ()}); + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH, + {Jasmin.Expr.f_info = + Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH); + f_tyin = [Jasmin.Type.Coq_sint]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = n.152}; + v_info = + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; + f_body = + [Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 2; + base_loc = + {Jasmin.Location.loc_fname = "int_shift.jazz"; + loc_start = (3, 3); loc_end = (3, 15); loc_bchar = 65; + loc_echar = 77}; + stack_loc = []}, + []), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = m.153}; + v_info = + {Jasmin.Location.loc_fname = "int_shift.jazz"; + loc_start = (3, 3); loc_end = (3, 4); loc_bchar = 65; + loc_echar = 66}}, + Jasmin.Expr.AT_inline, Jasmin.Type.Coq_sint, + Jasmin.Expr.Papp2 (Jasmin.Expr.Olsl Jasmin.Expr.Op_int, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; + vname = n.152}; + v_info = + {Jasmin.Location.loc_fname = "int_shift.jazz"; + loc_start = (3, 7); loc_end = (3, 8); loc_bchar = 69; + loc_echar = 70}}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))))))]; + f_tyout = [Jasmin.Type.Coq_sint]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = m.153}; + v_info = + {Jasmin.Location.loc_fname = "int_shift.jazz"; + loc_start = (4, 10); loc_end = (4, 11); loc_bchar = 88; + loc_echar = 89}}]; + f_extra = ()})]; + p_globs = []; p_extra = ()} diff --git a/theories/Jasmin/examples/int_operations/int_shift.jazz b/theories/Jasmin/examples/int_shift.jazz similarity index 100% rename from theories/Jasmin/examples/int_operations/int_shift.jazz rename to theories/Jasmin/examples/int_shift.jazz diff --git a/theories/Jasmin/examples/int_shift.v b/theories/Jasmin/examples/int_shift.v new file mode 100644 index 00000000..ca36d57f --- /dev/null +++ b/theories/Jasmin/examples/int_shift.v @@ -0,0 +1,87 @@ +Require Import List. +From Jasmin Require Import expr. +From Jasmin Require Import x86_extra. + +Import ListNotations. +Local Open Scope string. + +Definition int_shift := {| p_funcs := + [(xH, + {| f_info := xO xH; + f_tyin := []; f_params := []; + f_body := + [MkI + (dummy_instr_info) + (Ccall (InlineFun) + ([Lvar + {| v_var := + {| vtype := sint; vname := "x.151" |}; + v_info := dummy_var_info |}]) + (xI xH) + ([Pconst Z0])); + MkI + (dummy_instr_info) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "y.150" |}; + v_info := dummy_var_info |}) + (AT_none) (sword U64) + (Papp1 (Oword_of_int U64) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "x.151" |}; + v_info := dummy_var_info |}; + gs := Slocal |})))]; + f_tyout := [sword U64]; + f_res := + [{| v_var := + {| vtype := sword U64; + vname := "y.150" |}; + v_info := dummy_var_info |}]; + f_extra := tt |}); + (xI xH, + {| f_info := + xO (xO xH); + f_tyin := [sint]; + f_params := + [{| v_var := + {| vtype := sint; vname := "n.152" |}; + v_info := dummy_var_info |}]; + f_body := + [MkI + (dummy_instr_info) + (Cassgn + (Lvar + {| v_var := + {| vtype := sint; vname := "m.153" |}; + v_info := dummy_var_info |}) + (AT_inline) (sint) + (Papp2 (Olsl Op_int) + (Pvar + {| gv := + {| v_var := + {| vtype := sint; + vname := "n.152" |}; + v_info := dummy_var_info |}; + gs := Slocal |}) + (Pconst + (Zpos + (xI + (xO + (xO + (xO + (xO + (xO xH))))))))))]; + f_tyout := [sint]; + f_res := + [{| v_var := + {| vtype := sint; vname := "m.153" |}; + v_info := dummy_var_info |}]; + f_extra := tt |})]; + p_globs := []; p_extra := tt |} +. \ No newline at end of file diff --git a/theories/Jasmin/examples/liveness_bork.cprog b/theories/Jasmin/examples/liveness_bork.cprog new file mode 100644 index 00000000..5e051290 --- /dev/null +++ b/theories/Jasmin/examples/liveness_bork.cprog @@ -0,0 +1,86 @@ + {Jasmin.Expr.p_funcs = + [(Jasmin.BinNums.Coq_xH, + {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH; + f_tyin = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = n.141}; + v_info = + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; + f_body = + [Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 3; + base_loc = + {Jasmin.Location.loc_fname = "liveness_bork.jazz"; + loc_start = (3, 3); loc_end = (5, 4); loc_bchar = 55; + loc_echar = 94}; + stack_loc = []}, + []), + Jasmin.Expr.Cfor + ({Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = i.142}; + v_info = + {Jasmin.Location.loc_fname = "liveness_bork.jazz"; + loc_start = (3, 7); loc_end = (3, 8); loc_bchar = 59; + loc_echar = 60}}, + ((Jasmin.Expr.UpTo, Jasmin.Expr.Pconst Jasmin.BinNums.Z0), + Jasmin.Expr.Papp1 (Jasmin.Expr.Oint_of_word Jasmin.Wsize.U64, + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = n.141}; + v_info = + {Jasmin.Location.loc_fname = "liveness_bork.jazz"; + loc_start = (3, 16); loc_end = (3, 17); loc_bchar = 68; + loc_echar = 69}}; + gs = Jasmin.Expr.Slocal})), + [Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 2; + base_loc = + {Jasmin.Location.loc_fname = "liveness_bork.jazz"; + loc_start = (4, 7); loc_end = (4, 17); loc_bchar = 79; + loc_echar = 89}; + stack_loc = []}, + []), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = n.141}; + v_info = + {Jasmin.Location.loc_fname = "liveness_bork.jazz"; + loc_start = (4, 7); loc_end = (4, 8); loc_bchar = 79; + loc_echar = 80}}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Papp2 + (Jasmin.Expr.Oadd (Jasmin.Expr.Op_w Jasmin.Wsize.U64), + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = n.141}; + v_info = + {Jasmin.Location.loc_fname = "liveness_bork.jazz"; + loc_start = (4, 11); loc_end = (4, 12); loc_bchar = 83; + loc_echar = 84}}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U64, + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos Jasmin.BinNums.Coq_xH)))))]))]; + f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = n.141}; + v_info = + {Jasmin.Location.loc_fname = "liveness_bork.jazz"; + loc_start = (6, 10); loc_end = (6, 11); loc_bchar = 105; + loc_echar = 106}}]; + f_extra = ()})]; + p_globs = []; p_extra = ()} diff --git a/theories/Jasmin/examples/int_operations/liveness_bork.jazz b/theories/Jasmin/examples/liveness_bork.jazz similarity index 100% rename from theories/Jasmin/examples/int_operations/liveness_bork.jazz rename to theories/Jasmin/examples/liveness_bork.jazz diff --git a/theories/Jasmin/examples/liveness_bork.v b/theories/Jasmin/examples/liveness_bork.v new file mode 100644 index 00000000..554fb460 --- /dev/null +++ b/theories/Jasmin/examples/liveness_bork.v @@ -0,0 +1,65 @@ +Require Import List. +From Jasmin Require Import expr. +From Jasmin Require Import x86_extra. + +Import ListNotations. +Local Open Scope string. + +Definition liveness_bork := {| p_funcs := + [(xH, + {| f_info := xO xH; + f_tyin := [sword U64]; + f_params := + [{| v_var := + {| vtype := sword U64; + vname := "n.141" |}; + v_info := dummy_var_info |}]; + f_body := + [MkI + (dummy_instr_info) + (Cfor + ({| v_var := + {| vtype := sint; vname := "i.142" |}; + v_info := dummy_var_info |}) + (((UpTo, Pconst Z0), + Papp1 (Oint_of_word U64) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "n.141" |}; + v_info := dummy_var_info |}; + gs := Slocal |}))) + ([MkI + (dummy_instr_info) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "n.141" |}; + v_info := dummy_var_info |}) + (AT_none) (sword U64) + (Papp2 + (Oadd (Op_w U64)) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "n.141" |}; + v_info := dummy_var_info |}; + gs := Slocal |}) + (Papp1 (Oword_of_int U64) + (Pconst + (Zpos xH)))))]))]; + f_tyout := [sword U64]; + f_res := + [{| v_var := + {| vtype := sword U64; + vname := "n.141" |}; + v_info := dummy_var_info |}]; + f_extra := tt |})]; + p_globs := []; p_extra := tt |} +. \ No newline at end of file diff --git a/theories/Jasmin/examples/matrix_product/matrix_product.cprog b/theories/Jasmin/examples/matrix_product.cprog similarity index 61% rename from theories/Jasmin/examples/matrix_product/matrix_product.cprog rename to theories/Jasmin/examples/matrix_product.cprog index 7a65234e..8d3ab0dd 100644 --- a/theories/Jasmin/examples/matrix_product/matrix_product.cprog +++ b/theories/Jasmin/examples/matrix_product.cprog @@ -1,6 +1,6 @@ {Jasmin.Expr.p_funcs = - [(Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH, - {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH; + [(Jasmin.BinNums.Coq_xH, + {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH; f_tyin = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64; Jasmin.Type.Coq_sword Jasmin.Wsize.U64; @@ -8,36 +8,38 @@ f_params = [{Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = x.191}; + vname = x.218}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)}; + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}; {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = y.192}; + vname = y.219}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)}; + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}; {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = z.193}; + vname = z.220}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)}]; + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; f_body = [Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), + (({Jasmin.Location.uid_loc = 24; + base_loc = + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (68, 2); loc_end = (73, 3); loc_bchar = 1344; + loc_echar = 1458}; + stack_loc = []}, + []), Jasmin.Expr.Cfor ({Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = i.194}; + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = i.221}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}, + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (68, 6); loc_end = (68, 7); loc_bchar = 1348; + loc_echar = 1349}}, ((Jasmin.Expr.UpTo, Jasmin.Expr.Pconst Jasmin.BinNums.Z0), Jasmin.Expr.Papp2 (Jasmin.Expr.Omul Jasmin.Expr.Op_int, Jasmin.Expr.Pconst @@ -51,35 +53,33 @@ (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))), [Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))), + (({Jasmin.Location.uid_loc = 20; + base_loc = + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (69, 4); loc_end = (69, 27); loc_bchar = 1369; + loc_echar = 1392}; + stack_loc = []}, + []), Jasmin.Expr.Cassgn (Jasmin.Expr.Lvar {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = tmp.195}; + vname = tmp.222}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}, + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (69, 4); loc_end = (69, 7); loc_bchar = 1369; + loc_echar = 1372}}, Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, Jasmin.Expr.Pload (Jasmin.Wsize.U64, {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = x.191}; + vname = x.218}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}, + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (69, 16); loc_end = (69, 17); loc_bchar = 1381; + loc_echar = 1382}}, Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U64, Jasmin.Expr.Papp2 (Jasmin.Expr.Omul Jasmin.Expr.Op_int, Jasmin.Expr.Pconst @@ -91,20 +91,20 @@ {Jasmin.Expr.gv = {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = i.194}; + vname = i.221}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (69, 24); loc_end = (69, 25); + loc_bchar = 1389; loc_echar = 1390}}; gs = Jasmin.Expr.Slocal}))))); Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))), + (({Jasmin.Location.uid_loc = 21; + base_loc = + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (70, 4); loc_end = (70, 16); loc_bchar = 1397; + loc_echar = 1409}; + stack_loc = []}, + []), Jasmin.Expr.Cassgn (Jasmin.Expr.Laset (Jasmin.Warray_.AAscale, Jasmin.Wsize.U64, {Jasmin.Expr.v_var = @@ -120,24 +120,20 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); - vname = mx.196}; + vname = mx.223}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}, + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (70, 4); loc_end = (70, 6); loc_bchar = 1397; + loc_echar = 1399}}, Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = i.194}; + vname = i.221}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (70, 7); loc_end = (70, 8); + loc_bchar = 1400; loc_echar = 1401}}; gs = Jasmin.Expr.Slocal}), Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, Jasmin.Expr.Pvar @@ -145,42 +141,40 @@ {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = tmp.195}; + vname = tmp.222}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (70, 12); loc_end = (70, 15); + loc_bchar = 1405; loc_echar = 1408}}; gs = Jasmin.Expr.Slocal})); Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))), + (({Jasmin.Location.uid_loc = 22; + base_loc = + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (71, 4); loc_end = (71, 27); loc_bchar = 1414; + loc_echar = 1437}; + stack_loc = []}, + []), Jasmin.Expr.Cassgn (Jasmin.Expr.Lvar {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = tmp.195}; + vname = tmp.222}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}, + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (71, 4); loc_end = (71, 7); loc_bchar = 1414; + loc_echar = 1417}}, Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, Jasmin.Expr.Pload (Jasmin.Wsize.U64, {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = y.192}; + vname = y.219}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}, + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (71, 16); loc_end = (71, 17); loc_bchar = 1426; + loc_echar = 1427}}, Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U64, Jasmin.Expr.Papp2 (Jasmin.Expr.Omul Jasmin.Expr.Op_int, Jasmin.Expr.Pconst @@ -192,18 +186,20 @@ {Jasmin.Expr.gv = {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = i.194}; + vname = i.221}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (71, 24); loc_end = (71, 25); + loc_bchar = 1434; loc_echar = 1435}}; gs = Jasmin.Expr.Slocal}))))); Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))), + (({Jasmin.Location.uid_loc = 23; + base_loc = + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (72, 4); loc_end = (72, 16); loc_bchar = 1442; + loc_echar = 1454}; + stack_loc = []}, + []), Jasmin.Expr.Cassgn (Jasmin.Expr.Laset (Jasmin.Warray_.AAscale, Jasmin.Wsize.U64, {Jasmin.Expr.v_var = @@ -219,22 +215,20 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); - vname = my.197}; + vname = my.224}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}, + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (72, 4); loc_end = (72, 6); loc_bchar = 1442; + loc_echar = 1444}}, Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = i.194}; + vname = i.221}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (72, 7); loc_end = (72, 8); + loc_bchar = 1445; loc_echar = 1446}}; gs = Jasmin.Expr.Slocal}), Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, Jasmin.Expr.Pvar @@ -242,18 +236,20 @@ {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = tmp.195}; + vname = tmp.222}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (72, 12); loc_end = (72, 15); + loc_bchar = 1450; loc_echar = 1453}}; gs = Jasmin.Expr.Slocal}))])); Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), + (({Jasmin.Location.uid_loc = 25; + base_loc = + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (74, 2); loc_end = (74, 41); loc_bchar = 1461; + loc_echar = 1500}; + stack_loc = []}, + []), Jasmin.Expr.Ccall (Jasmin.Expr.DoNotInline, [Jasmin.Expr.Lvar {Jasmin.Expr.v_var = @@ -269,16 +265,12 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); - vname = mz.198}; + vname = mz.225}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}], - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (74, 2); loc_end = (74, 4); loc_bchar = 1461; + loc_echar = 1463}}], + Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH, [Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = @@ -294,12 +286,11 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); - vname = mx.196}; + vname = mx.223}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (74, 29); loc_end = (74, 31); loc_bchar = 1488; + loc_echar = 1490}}; gs = Jasmin.Expr.Slocal}; Jasmin.Expr.Pvar {Jasmin.Expr.gv = @@ -316,12 +307,11 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); - vname = my.197}; + vname = my.224}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (74, 33); loc_end = (74, 35); loc_bchar = 1492; + loc_echar = 1494}}; gs = Jasmin.Expr.Slocal}; Jasmin.Expr.Pvar {Jasmin.Expr.gv = @@ -338,23 +328,27 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); - vname = mz.198}; + vname = mz.225}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (74, 37); loc_end = (74, 39); loc_bchar = 1496; + loc_echar = 1498}}; gs = Jasmin.Expr.Slocal}])); Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH), + (({Jasmin.Location.uid_loc = 28; + base_loc = + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (75, 2); loc_end = (78, 3); loc_bchar = 1503; + loc_echar = 1572}; + stack_loc = []}, + []), Jasmin.Expr.Cfor ({Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = i.194}; + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = i.221}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}, + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (75, 6); loc_end = (75, 7); loc_bchar = 1507; + loc_echar = 1508}}, ((Jasmin.Expr.UpTo, Jasmin.Expr.Pconst Jasmin.BinNums.Z0), Jasmin.Expr.Papp2 (Jasmin.Expr.Omul Jasmin.Expr.Op_int, Jasmin.Expr.Pconst @@ -368,20 +362,23 @@ (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))), [Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)), + (({Jasmin.Location.uid_loc = 26; + base_loc = + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (76, 4); loc_end = (76, 16); loc_bchar = 1528; + loc_echar = 1540}; + stack_loc = []}, + []), Jasmin.Expr.Cassgn (Jasmin.Expr.Lvar {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = tmp.195}; + vname = tmp.222}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}, + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (76, 4); loc_end = (76, 7); loc_bchar = 1528; + loc_echar = 1531}}, Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, Jasmin.Expr.Pget (Jasmin.Warray_.AAscale, Jasmin.Wsize.U64, {Jasmin.Expr.gv = @@ -398,36 +395,40 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); - vname = mz.198}; + vname = mz.225}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (76, 10); loc_end = (76, 12); + loc_bchar = 1534; loc_echar = 1536}}; gs = Jasmin.Expr.Slocal}, Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = i.194}; + vname = i.221}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (76, 13); loc_end = (76, 14); + loc_bchar = 1537; loc_echar = 1538}}; gs = Jasmin.Expr.Slocal}))); Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)), + (({Jasmin.Location.uid_loc = 27; + base_loc = + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (77, 4); loc_end = (77, 27); loc_bchar = 1545; + loc_echar = 1568}; + stack_loc = []}, + []), Jasmin.Expr.Cassgn (Jasmin.Expr.Lmem (Jasmin.Wsize.U64, {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = z.193}; + vname = z.220}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}, + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (77, 10); loc_end = (77, 11); + loc_bchar = 1551; loc_echar = 1552}}, Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U64, Jasmin.Expr.Papp2 (Jasmin.Expr.Omul Jasmin.Expr.Op_int, Jasmin.Expr.Pconst @@ -439,11 +440,11 @@ {Jasmin.Expr.gv = {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = i.194}; + vname = i.221}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (77, 18); loc_end = (77, 19); + loc_bchar = 1559; loc_echar = 1560}}; gs = Jasmin.Expr.Slocal}))), Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, Jasmin.Expr.Pvar @@ -451,22 +452,16 @@ {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = tmp.195}; + vname = tmp.222}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (77, 23); loc_end = (77, 26); + loc_bchar = 1564; loc_echar = 1567}}; gs = Jasmin.Expr.Slocal}))]))]; f_tyout = []; f_res = []; f_extra = ()}); - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH, {Jasmin.Expr.f_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))); + Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH); f_tyin = [Jasmin.Type.Coq_sarr (Jasmin.BinNums.Coq_xO @@ -511,13 +506,10 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); - vname = m1.199}; + vname = m1.226}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}; + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}; {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sarr @@ -530,13 +522,10 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); - vname = m2.200}; + vname = m2.227}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}; + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}; {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sarr @@ -549,21 +538,19 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); - vname = res.201}; + vname = res.228}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}]; + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; f_body = [Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), + (({Jasmin.Location.uid_loc = 14; + base_loc = + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (49, 2); loc_end = (49, 13); loc_bchar = 924; + loc_echar = 935}; + stack_loc = []}, + []), Jasmin.Expr.Cassgn (Jasmin.Expr.Lvar {Jasmin.Expr.v_var = @@ -579,14 +566,11 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); - vname = pres.202}; + vname = pres.229}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}, + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (49, 2); loc_end = (49, 6); loc_bchar = 924; + loc_echar = 928}}, Jasmin.Expr.AT_none, Jasmin.Type.Coq_sarr (Jasmin.BinNums.Coq_xO @@ -613,22 +597,20 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); - vname = res.201}; + vname = res.228}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (49, 9); loc_end = (49, 12); loc_bchar = 931; + loc_echar = 934}}; gs = Jasmin.Expr.Slocal})); Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), + (({Jasmin.Location.uid_loc = 15; + base_loc = + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (50, 2); loc_end = (50, 28); loc_bchar = 938; + loc_echar = 964}; + stack_loc = []}, + []), Jasmin.Expr.Ccall (Jasmin.Expr.DoNotInline, [Jasmin.Expr.Lvar {Jasmin.Expr.v_var = @@ -644,19 +626,13 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); - vname = m2t.203}; + vname = m2t.230}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}], - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))), + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (50, 2); loc_end = (50, 5); loc_bchar = 938; + loc_echar = 941}}], + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH), [Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = @@ -672,14 +648,11 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); - vname = m2.200}; + vname = m2.227}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (50, 19); loc_end = (50, 21); loc_bchar = 955; + loc_echar = 957}}; gs = Jasmin.Expr.Slocal}; Jasmin.Expr.Pvar {Jasmin.Expr.gv = @@ -696,30 +669,27 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); - vname = m2t.203}; + vname = m2t.230}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (50, 23); loc_end = (50, 26); loc_bchar = 959; + loc_echar = 962}}; gs = Jasmin.Expr.Slocal}])); Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))), + (({Jasmin.Location.uid_loc = 17; + base_loc = + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (51, 2); loc_end = (53, 3); loc_bchar = 967; + loc_echar = 1057}; + stack_loc = []}, + []), Jasmin.Expr.Cfor ({Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = i.204}; + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = i.231}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))}, + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (51, 6); loc_end = (51, 7); loc_bchar = 971; + loc_echar = 972}}, ((Jasmin.Expr.UpTo, Jasmin.Expr.Pconst Jasmin.BinNums.Z0), Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos @@ -727,11 +697,13 @@ (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), [Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))), + (({Jasmin.Location.uid_loc = 16; + base_loc = + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (52, 4); loc_end = (52, 69); loc_bchar = 988; + loc_echar = 1053}; + stack_loc = []}, + []), Jasmin.Expr.Ccall (Jasmin.Expr.DoNotInline, [Jasmin.Expr.Lasub (Jasmin.Warray_.AAscale, Jasmin.Wsize.U64, Jasmin.BinNums.Coq_xO @@ -750,36 +722,29 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); - vname = rest.205}; + vname = rest.232}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))}, + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (52, 4); loc_end = (52, 8); loc_bchar = 988; + loc_echar = 992}}, Jasmin.Expr.Papp2 (Jasmin.Expr.Omul Jasmin.Expr.Op_int, Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = i.204}; + vname = i.231}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (52, 9); loc_end = (52, 10); + loc_bchar = 993; loc_echar = 994}}; gs = Jasmin.Expr.Slocal}, Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))], - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))), + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH), [Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = @@ -795,13 +760,11 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); - vname = m1.199}; + vname = m1.226}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (52, 40); loc_end = (52, 42); + loc_bchar = 1024; loc_echar = 1026}}; gs = Jasmin.Expr.Slocal}; Jasmin.Expr.Psub (Jasmin.Warray_.AAscale, Jasmin.Wsize.U64, Jasmin.BinNums.Coq_xO @@ -821,26 +784,22 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); - vname = m2t.203}; + vname = m2t.230}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (52, 44); loc_end = (52, 47); + loc_bchar = 1028; loc_echar = 1031}}; gs = Jasmin.Expr.Slocal}, Jasmin.Expr.Papp2 (Jasmin.Expr.Omul Jasmin.Expr.Op_int, Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = i.204}; + vname = i.231}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (52, 48); loc_end = (52, 49); + loc_bchar = 1032; loc_echar = 1033}}; gs = Jasmin.Expr.Slocal}, Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos @@ -865,26 +824,22 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); - vname = rest.205}; + vname = rest.232}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (52, 56); loc_end = (52, 60); + loc_bchar = 1040; loc_echar = 1044}}; gs = Jasmin.Expr.Slocal}, Jasmin.Expr.Papp2 (Jasmin.Expr.Omul Jasmin.Expr.Op_int, Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = i.204}; + vname = i.231}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (52, 61); loc_end = (52, 62); + loc_bchar = 1045; loc_echar = 1046}}; gs = Jasmin.Expr.Slocal}, Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos @@ -892,11 +847,13 @@ (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))]))])); Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))), + (({Jasmin.Location.uid_loc = 18; + base_loc = + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (54, 2); loc_end = (54, 13); loc_bchar = 1060; + loc_echar = 1071}; + stack_loc = []}, + []), Jasmin.Expr.Cassgn (Jasmin.Expr.Lvar {Jasmin.Expr.v_var = @@ -912,13 +869,11 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); - vname = res.201}; + vname = res.228}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))}, + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (54, 2); loc_end = (54, 5); loc_bchar = 1060; + loc_echar = 1063}}, Jasmin.Expr.AT_none, Jasmin.Type.Coq_sarr (Jasmin.BinNums.Coq_xO @@ -945,20 +900,20 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); - vname = pres.202}; + vname = pres.229}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (54, 8); loc_end = (54, 12); loc_bchar = 1066; + loc_echar = 1070}}; gs = Jasmin.Expr.Slocal})); Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))), + (({Jasmin.Location.uid_loc = 19; + base_loc = + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (55, 2); loc_end = (55, 30); loc_bchar = 1074; + loc_echar = 1102}; + stack_loc = []}, + []), Jasmin.Expr.Ccall (Jasmin.Expr.DoNotInline, [Jasmin.Expr.Lvar {Jasmin.Expr.v_var = @@ -974,18 +929,13 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); - vname = res.201}; + vname = res.228}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))}], - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))), + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (55, 2); loc_end = (55, 5); loc_bchar = 1074; + loc_echar = 1077}}], + Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH), [Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = @@ -1001,13 +951,11 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); - vname = rest.205}; + vname = rest.232}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (55, 19); loc_end = (55, 23); loc_bchar = 1091; + loc_echar = 1095}}; gs = Jasmin.Expr.Slocal}; Jasmin.Expr.Pvar {Jasmin.Expr.gv = @@ -1024,13 +972,11 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); - vname = res.201}; + vname = res.228}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (55, 25); loc_end = (55, 28); loc_bchar = 1097; + loc_echar = 1100}}; gs = Jasmin.Expr.Slocal}]))]; f_tyout = [Jasmin.Type.Coq_sarr @@ -1056,27 +1002,15 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); - vname = res.201}; + vname = res.228}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}]; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (57, 9); loc_end = (57, 12); loc_bchar = 1113; + loc_echar = 1116}}]; f_extra = ()}); - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))), + (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH), {Jasmin.Expr.f_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))); + Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH); f_tyin = [Jasmin.Type.Coq_sarr (Jasmin.BinNums.Coq_xO @@ -1111,14 +1045,10 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); - vname = m.206}; + vname = m.233}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}; + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}; {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sarr @@ -1131,32 +1061,26 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); - vname = res.207}; + vname = res.234}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}]; + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; f_body = [Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), + (({Jasmin.Location.uid_loc = 13; + base_loc = + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (32, 2); loc_end = (37, 3); loc_bchar = 580; + loc_echar = 673}; + stack_loc = []}, + []), Jasmin.Expr.Cfor ({Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = i.208}; + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = i.235}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}, + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (32, 6); loc_end = (32, 7); loc_bchar = 584; + loc_echar = 585}}, ((Jasmin.Expr.UpTo, Jasmin.Expr.Pconst Jasmin.BinNums.Z0), Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos @@ -1164,23 +1088,21 @@ (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), [Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), + (({Jasmin.Location.uid_loc = 12; + base_loc = + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (33, 4); loc_end = (36, 5); loc_bchar = 601; + loc_echar = 669}; + stack_loc = []}, + []), Jasmin.Expr.Cfor ({Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = j.209}; + vname = j.236}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}, + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (33, 8); loc_end = (33, 9); loc_bchar = 605; + loc_echar = 606}}, ((Jasmin.Expr.UpTo, Jasmin.Expr.Pconst Jasmin.BinNums.Z0), Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos @@ -1188,25 +1110,23 @@ (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), [Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), + (({Jasmin.Location.uid_loc = 10; + base_loc = + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (34, 6); loc_end = (34, 21); + loc_bchar = 624; loc_echar = 639}; + stack_loc = []}, + []), Jasmin.Expr.Cassgn (Jasmin.Expr.Lvar {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = tmp.210}; + vname = tmp.237}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}, + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (34, 6); loc_end = (34, 9); + loc_bchar = 624; loc_echar = 627}}, Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, Jasmin.Expr.Pget (Jasmin.Warray_.AAscale, Jasmin.Wsize.U64, {Jasmin.Expr.gv = @@ -1223,43 +1143,33 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); - vname = m.206}; + vname = m.233}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (34, 12); loc_end = (34, 13); + loc_bchar = 630; loc_echar = 631}}; gs = Jasmin.Expr.Slocal}, Jasmin.Expr.Papp2 (Jasmin.Expr.Oadd Jasmin.Expr.Op_int, Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = j.209}; + vname = j.236}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (34, 14); loc_end = (34, 15); + loc_bchar = 632; loc_echar = 633}}; gs = Jasmin.Expr.Slocal}, Jasmin.Expr.Papp2 (Jasmin.Expr.Omul Jasmin.Expr.Op_int, Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = i.208}; + vname = i.235}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - Jasmin.BinNums.Coq_xH)))))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (34, 16); loc_end = (34, 17); + loc_bchar = 634; loc_echar = 635}}; gs = Jasmin.Expr.Slocal}, Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos @@ -1267,12 +1177,13 @@ (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))))); Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), + (({Jasmin.Location.uid_loc = 11; + base_loc = + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (35, 6); loc_end = (35, 23); + loc_bchar = 646; loc_echar = 663}; + stack_loc = []}, + []), Jasmin.Expr.Cassgn (Jasmin.Expr.Laset (Jasmin.Warray_.AAscale, Jasmin.Wsize.U64, @@ -1289,43 +1200,32 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); - vname = res.207}; + vname = res.234}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}, + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (35, 6); loc_end = (35, 9); + loc_bchar = 646; loc_echar = 649}}, Jasmin.Expr.Papp2 (Jasmin.Expr.Oadd Jasmin.Expr.Op_int, Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = i.208}; + vname = i.235}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - Jasmin.BinNums.Coq_xH)))))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (35, 10); loc_end = (35, 11); + loc_bchar = 650; loc_echar = 651}}; gs = Jasmin.Expr.Slocal}, Jasmin.Expr.Papp2 (Jasmin.Expr.Omul Jasmin.Expr.Op_int, Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = j.209}; + vname = j.236}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - Jasmin.BinNums.Coq_xH)))))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (35, 12); loc_end = (35, 13); + loc_bchar = 652; loc_echar = 653}}; gs = Jasmin.Expr.Slocal}, Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos @@ -1338,14 +1238,11 @@ {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = tmp.210}; + vname = tmp.237}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (35, 19); loc_end = (35, 22); + loc_bchar = 659; loc_echar = 662}}; gs = Jasmin.Expr.Slocal}))]))]))]; f_tyout = [Jasmin.Type.Coq_sarr @@ -1371,27 +1268,16 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); - vname = res.207}; + vname = res.234}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}]; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (39, 9); loc_end = (39, 12); loc_bchar = 684; + loc_echar = 687}}]; f_extra = ()}); - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))), + (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH), {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))); + (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)); f_tyin = [Jasmin.Type.Coq_sarr (Jasmin.BinNums.Coq_xO @@ -1430,14 +1316,10 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); - vname = m.211}; + vname = m.238}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}; + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}; {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sarr @@ -1447,14 +1329,10 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))); - vname = v.212}; + vname = v.239}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}; + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}; {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sarr @@ -1464,32 +1342,26 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))); - vname = res.213}; + vname = res.240}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}]; + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; f_body = [Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), + (({Jasmin.Location.uid_loc = 9; + base_loc = + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (21, 2); loc_end = (24, 3); loc_bchar = 373; + loc_echar = 447}; + stack_loc = []}, + []), Jasmin.Expr.Cfor ({Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = i.214}; + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = i.241}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))}, + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (21, 6); loc_end = (21, 7); loc_bchar = 377; + loc_echar = 378}}, ((Jasmin.Expr.UpTo, Jasmin.Expr.Pconst Jasmin.BinNums.Z0), Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos @@ -1497,31 +1369,26 @@ (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), [Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))), + (({Jasmin.Location.uid_loc = 7; + base_loc = + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (22, 4); loc_end = (22, 35); loc_bchar = 394; + loc_echar = 425}; + stack_loc = []}, + []), Jasmin.Expr.Ccall (Jasmin.Expr.DoNotInline, [Jasmin.Expr.Lvar {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = tmp.215}; + vname = tmp.242}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}], - Jasmin.BinNums.Coq_xO + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (22, 4); loc_end = (22, 7); loc_bchar = 394; + loc_echar = 397}}], + Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))), + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)), [Jasmin.Expr.Psub (Jasmin.Warray_.AAscale, Jasmin.Wsize.U64, Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI @@ -1540,28 +1407,22 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))))))); - vname = m.211}; + vname = m.238}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (22, 22); loc_end = (22, 23); + loc_bchar = 412; loc_echar = 413}}; gs = Jasmin.Expr.Slocal}, Jasmin.Expr.Papp2 (Jasmin.Expr.Omul Jasmin.Expr.Op_int, Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = i.214}; + vname = i.241}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (22, 24); loc_end = (22, 25); + loc_bchar = 414; loc_echar = 415}}; gs = Jasmin.Expr.Slocal}, Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos @@ -1579,22 +1440,20 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))); - vname = v.212}; + vname = v.239}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (22, 32); loc_end = (22, 33); + loc_bchar = 422; loc_echar = 423}}; gs = Jasmin.Expr.Slocal}])); Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))), + (({Jasmin.Location.uid_loc = 8; + base_loc = + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (23, 4); loc_end = (23, 17); loc_bchar = 430; + loc_echar = 443}; + stack_loc = []}, + []), Jasmin.Expr.Cassgn (Jasmin.Expr.Laset (Jasmin.Warray_.AAscale, Jasmin.Wsize.U64, {Jasmin.Expr.v_var = @@ -1606,26 +1465,20 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))); - vname = res.213}; + vname = res.240}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}, + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (23, 4); loc_end = (23, 7); loc_bchar = 430; + loc_echar = 433}}, Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = i.214}; + vname = i.241}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (23, 8); loc_end = (23, 9); + loc_bchar = 434; loc_echar = 435}}; gs = Jasmin.Expr.Slocal}), Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, Jasmin.Expr.Pvar @@ -1633,14 +1486,11 @@ {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = tmp.215}; + vname = tmp.242}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (23, 13); loc_end = (23, 16); + loc_bchar = 439; loc_echar = 442}}; gs = Jasmin.Expr.Slocal}))]))]; f_tyout = [Jasmin.Type.Coq_sarr @@ -1660,28 +1510,17 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))); - vname = res.213}; + vname = res.240}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}]; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (25, 9); loc_end = (25, 12); loc_bchar = 457; + loc_echar = 460}}]; f_extra = ()}); - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))), + (Jasmin.BinNums.Coq_xI + (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)), {Jasmin.Expr.f_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))); + Jasmin.BinNums.Coq_xO + (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)); f_tyin = [Jasmin.Type.Coq_sarr (Jasmin.BinNums.Coq_xO @@ -1707,14 +1546,10 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))); - vname = v1.216}; + vname = v1.243}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}; + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}; {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sarr @@ -1724,55 +1559,47 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))); - vname = v2.217}; + vname = v2.244}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}]; + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; f_body = [Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))), + (({Jasmin.Location.uid_loc = 2; + base_loc = + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (8, 2); loc_end = (8, 10); loc_bchar = 135; + loc_echar = 143}; + stack_loc = []}, + []), Jasmin.Expr.Cassgn (Jasmin.Expr.Lvar {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = res.218}; + vname = res.245}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}, + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (8, 2); loc_end = (8, 5); loc_bchar = 135; + loc_echar = 138}}, Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U64, Jasmin.Expr.Pconst Jasmin.BinNums.Z0))); Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))), + (({Jasmin.Location.uid_loc = 6; + base_loc = + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (9, 2); loc_end = (13, 3); loc_bchar = 146; + loc_echar = 217}; + stack_loc = []}, + []), Jasmin.Expr.Cfor ({Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = i.219}; + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = i.246}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}, + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (9, 6); loc_end = (9, 7); loc_bchar = 150; + loc_echar = 151}}, ((Jasmin.Expr.UpTo, Jasmin.Expr.Pconst Jasmin.BinNums.Z0), Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos @@ -1780,25 +1607,23 @@ (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), [Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))), + (({Jasmin.Location.uid_loc = 3; + base_loc = + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (10, 4); loc_end = (10, 16); loc_bchar = 167; + loc_echar = 179}; + stack_loc = []}, + []), Jasmin.Expr.Cassgn (Jasmin.Expr.Lvar {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = tmp.220}; + vname = tmp.247}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}, + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (10, 4); loc_end = (10, 7); loc_bchar = 167; + loc_echar = 170}}, Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, Jasmin.Expr.Pget (Jasmin.Warray_.AAscale, Jasmin.Wsize.U64, {Jasmin.Expr.gv = @@ -1811,48 +1636,40 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))); - vname = v1.216}; + vname = v1.243}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (10, 10); loc_end = (10, 12); + loc_bchar = 173; loc_echar = 175}}; gs = Jasmin.Expr.Slocal}, Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = i.219}; + vname = i.246}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (10, 13); loc_end = (10, 14); + loc_bchar = 176; loc_echar = 177}}; gs = Jasmin.Expr.Slocal}))); Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))), + (({Jasmin.Location.uid_loc = 4; + base_loc = + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (11, 4); loc_end = (11, 17); loc_bchar = 184; + loc_echar = 197}; + stack_loc = []}, + []), Jasmin.Expr.Cassgn (Jasmin.Expr.Lvar {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = tmp.220}; + vname = tmp.247}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}, + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (11, 4); loc_end = (11, 7); loc_bchar = 184; + loc_echar = 187}}, Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, Jasmin.Expr.Papp2 (Jasmin.Expr.Omul (Jasmin.Expr.Op_w Jasmin.Wsize.U64), @@ -1861,14 +1678,11 @@ {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = tmp.220}; + vname = tmp.247}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (11, 4); loc_end = (11, 7); loc_bchar = 184; + loc_echar = 187}}; gs = Jasmin.Expr.Slocal}, Jasmin.Expr.Pget (Jasmin.Warray_.AAscale, Jasmin.Wsize.U64, {Jasmin.Expr.gv = @@ -1881,48 +1695,40 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))); - vname = v2.217}; + vname = v2.244}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (11, 11); loc_end = (11, 13); + loc_bchar = 191; loc_echar = 193}}; gs = Jasmin.Expr.Slocal}, Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = i.219}; + vname = i.246}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (11, 14); loc_end = (11, 15); + loc_bchar = 194; loc_echar = 195}}; gs = Jasmin.Expr.Slocal})))); Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))), + (({Jasmin.Location.uid_loc = 5; + base_loc = + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (12, 4); loc_end = (12, 15); loc_bchar = 202; + loc_echar = 213}; + stack_loc = []}, + []), Jasmin.Expr.Cassgn (Jasmin.Expr.Lvar {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = res.218}; + vname = res.245}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}, + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (12, 4); loc_end = (12, 7); loc_bchar = 202; + loc_echar = 205}}, Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, Jasmin.Expr.Papp2 (Jasmin.Expr.Oadd (Jasmin.Expr.Op_w Jasmin.Wsize.U64), @@ -1931,40 +1737,31 @@ {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = res.218}; + vname = res.245}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (12, 4); loc_end = (12, 7); loc_bchar = 202; + loc_echar = 205}}; gs = Jasmin.Expr.Slocal}, Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = tmp.220}; + vname = tmp.247}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (12, 11); loc_end = (12, 14); + loc_bchar = 209; loc_echar = 212}}; gs = Jasmin.Expr.Slocal})))]))]; f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; f_res = [{Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = res.218}; + vname = res.245}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))}]; + {Jasmin.Location.loc_fname = "matrix_product.jazz"; + loc_start = (14, 9); loc_end = (14, 12); loc_bchar = 227; + loc_echar = 230}}]; f_extra = ()})]; p_globs = []; p_extra = ()} diff --git a/theories/Jasmin/examples/matrix_product/matrix_product.jazz b/theories/Jasmin/examples/matrix_product.jazz similarity index 100% rename from theories/Jasmin/examples/matrix_product/matrix_product.jazz rename to theories/Jasmin/examples/matrix_product.jazz diff --git a/theories/Jasmin/examples/matrix_product/matrix_product.v b/theories/Jasmin/examples/matrix_product.v similarity index 58% rename from theories/Jasmin/examples/matrix_product/matrix_product.v rename to theories/Jasmin/examples/matrix_product.v index 49acefcc..05d9d33c 100644 --- a/theories/Jasmin/examples/matrix_product/matrix_product.v +++ b/theories/Jasmin/examples/matrix_product.v @@ -5,10 +5,9 @@ From Jasmin Require Import x86_extra. Import ListNotations. Local Open Scope string. -Definition matrix_product := - {| p_funcs := - [(xO xH, - {| f_info := xI xH; +Definition matrix_product := {| p_funcs := + [(xH, + {| f_info := xO xH; f_tyin := [sword U64; sword U64; @@ -16,36 +15,23 @@ Definition matrix_product := f_params := [{| v_var := {| vtype := sword U64; - vname := "x.191" |}; - v_info := - xO - (xO xH) |}; + vname := "x.218" |}; + v_info := dummy_var_info |}; {| v_var := {| vtype := sword U64; - vname := "y.192" |}; - v_info := - xI - (xO xH) |}; + vname := "y.219" |}; + v_info := dummy_var_info |}; {| v_var := {| vtype := sword U64; - vname := "z.193" |}; - v_info := - xO - (xI xH) |}]; + vname := "z.220" |}; + v_info := dummy_var_info |}]; f_body := [MkI - (xI - (xI - (xI - (xO xH)))) + (dummy_instr_info) (Cfor ({| v_var := - {| vtype := sint; vname := "i.194" |}; - v_info := - xO - (xO - (xO - (xI xH))) |}) + {| vtype := sint; vname := "i.221" |}; + v_info := dummy_var_info |}) (((UpTo, Pconst Z0), Papp2 (Omul Op_int) (Pconst @@ -59,35 +45,21 @@ Definition matrix_product := (xI (xO xH))))))) ([MkI - (xI - (xO - (xI - (xO - (xO xH))))) + (dummy_instr_info) (Cassgn (Lvar {| v_var := {| vtype := sword U64; - vname := "tmp.195" |}; - v_info := - xO - (xO - (xO - (xI - (xO xH)))) |}) + vname := "tmp.222" |}; + v_info := dummy_var_info |}) (AT_none) (sword U64) (Pload (U64) ({| v_var := {| vtype := sword U64; - vname := "x.191" |}; - v_info := - xI - (xI - (xI - (xO - (xO xH)))) |}) + vname := "x.218" |}; + v_info := dummy_var_info |}) (Papp1 (Oword_of_int U64) (Papp2 (Omul Op_int) (Pconst @@ -99,20 +71,11 @@ Definition matrix_product := {| gv := {| v_var := {| vtype := sint; - vname := "i.194" |}; - v_info := - xO - (xI - (xI - (xO - (xO xH)))) |}; + vname := "i.221" |}; + v_info := dummy_var_info |}; gs := Slocal |}))))); MkI - (xI - (xO - (xO - (xO - (xO xH))))) + (dummy_instr_info) (Cassgn (Laset (AAscale) (U64) ({| v_var := @@ -128,24 +91,14 @@ Definition matrix_product := (xO (xI xH))))))))); - vname := "mx.196" |}; - v_info := - xO - (xO - (xI - (xO - (xO xH)))) |}) + vname := "mx.223" |}; + v_info := dummy_var_info |}) (Pvar {| gv := {| v_var := {| vtype := sint; - vname := "i.194" |}; - v_info := - xI - (xI - (xO - (xO - (xO xH)))) |}; + vname := "i.221" |}; + v_info := dummy_var_info |}; gs := Slocal |})) (AT_none) (sword U64) (Pvar @@ -153,42 +106,25 @@ Definition matrix_product := {| v_var := {| vtype := sword U64; - vname := "tmp.195" |}; - v_info := - xO - (xI - (xO - (xO - (xO xH)))) |}; + vname := "tmp.222" |}; + v_info := dummy_var_info |}; gs := Slocal |})); MkI - (xI - (xO - (xI - (xI xH)))) + (dummy_instr_info) (Cassgn (Lvar {| v_var := {| vtype := sword U64; - vname := "tmp.195" |}; - v_info := - xO - (xO - (xO - (xO - (xO xH)))) |}) + vname := "tmp.222" |}; + v_info := dummy_var_info |}) (AT_none) (sword U64) (Pload (U64) ({| v_var := {| vtype := sword U64; - vname := "y.192" |}; - v_info := - xI - (xI - (xI - (xI xH))) |}) + vname := "y.219" |}; + v_info := dummy_var_info |}) (Papp1 (Oword_of_int U64) (Papp2 (Omul Op_int) (Pconst @@ -200,18 +136,11 @@ Definition matrix_product := {| gv := {| v_var := {| vtype := sint; - vname := "i.194" |}; - v_info := - xO - (xI - (xI - (xI xH))) |}; + vname := "i.221" |}; + v_info := dummy_var_info |}; gs := Slocal |}))))); MkI - (xI - (xO - (xO - (xI xH)))) + (dummy_instr_info) (Cassgn (Laset (AAscale) (U64) ({| v_var := @@ -227,22 +156,14 @@ Definition matrix_product := (xO (xI xH))))))))); - vname := "my.197" |}; - v_info := - xO - (xO - (xI - (xI xH))) |}) + vname := "my.224" |}; + v_info := dummy_var_info |}) (Pvar {| gv := {| v_var := {| vtype := sint; - vname := "i.194" |}; - v_info := - xI - (xI - (xO - (xI xH))) |}; + vname := "i.221" |}; + v_info := dummy_var_info |}; gs := Slocal |})) (AT_none) (sword U64) (Pvar @@ -250,18 +171,11 @@ Definition matrix_product := {| v_var := {| vtype := sword U64; - vname := "tmp.195" |}; - v_info := - xO - (xI - (xO - (xI xH))) |}; + vname := "tmp.222" |}; + v_info := dummy_var_info |}; gs := Slocal |}))])); MkI - (xI - (xO - (xO - (xO xH)))) + (dummy_instr_info) (Ccall (DoNotInline) ([Lvar {| v_var := @@ -277,16 +191,9 @@ Definition matrix_product := (xO (xI xH))))))))); - vname := "mz.198" |}; - v_info := - xO - (xI - (xI - (xO xH))) |}]) - (xI - (xO - (xI - (xO xH)))) + vname := "mz.225" |}; + v_info := dummy_var_info |}]) + (xI xH) ([Pvar {| gv := {| v_var := @@ -302,12 +209,8 @@ Definition matrix_product := (xO (xI xH))))))))); - vname := "mx.196" |}; - v_info := - xO - (xI - (xO - (xO xH))) |}; + vname := "mx.223" |}; + v_info := dummy_var_info |}; gs := Slocal |}; Pvar {| gv := @@ -324,12 +227,8 @@ Definition matrix_product := (xO (xI xH))))))))); - vname := "my.197" |}; - v_info := - xI - (xI - (xO - (xO xH))) |}; + vname := "my.224" |}; + v_info := dummy_var_info |}; gs := Slocal |}; Pvar {| gv := @@ -346,23 +245,15 @@ Definition matrix_product := (xO (xI xH))))))))); - vname := "mz.198" |}; - v_info := - xO - (xO - (xI - (xO xH))) |}; + vname := "mz.225" |}; + v_info := dummy_var_info |}; gs := Slocal |}])); MkI - (xI - (xI xH)) + (dummy_instr_info) (Cfor ({| v_var := - {| vtype := sint; vname := "i.194" |}; - v_info := - xO - (xO - (xO xH)) |}) + {| vtype := sint; vname := "i.221" |}; + v_info := dummy_var_info |}) (((UpTo, Pconst Z0), Papp2 (Omul Op_int) (Pconst @@ -376,20 +267,14 @@ Definition matrix_product := (xI (xO xH))))))) ([MkI - (xI - (xO - (xI xH))) + (dummy_instr_info) (Cassgn (Lvar {| v_var := {| vtype := sword U64; - vname := "tmp.195" |}; - v_info := - xO - (xO - (xO - (xO xH))) |}) + vname := "tmp.222" |}; + v_info := dummy_var_info |}) (AT_none) (sword U64) (Pget (AAscale) (U64) ({| gv := @@ -406,36 +291,25 @@ Definition matrix_product := (xO (xI xH))))))))); - vname := "mz.198" |}; - v_info := - xI - (xI - (xI xH)) |}; + vname := "mz.225" |}; + v_info := dummy_var_info |}; gs := Slocal |}) (Pvar {| gv := {| v_var := {| vtype := sint; - vname := "i.194" |}; - v_info := - xO - (xI - (xI xH)) |}; + vname := "i.221" |}; + v_info := dummy_var_info |}; gs := Slocal |}))); MkI - (xI - (xO - (xO xH))) + (dummy_instr_info) (Cassgn (Lmem (U64) ({| v_var := {| vtype := sword U64; - vname := "z.193" |}; - v_info := - xO - (xO - (xI xH)) |}) + vname := "z.220" |}; + v_info := dummy_var_info |}) (Papp1 (Oword_of_int U64) (Papp2 (Omul Op_int) (Pconst @@ -447,11 +321,8 @@ Definition matrix_product := {| gv := {| v_var := {| vtype := sint; - vname := "i.194" |}; - v_info := - xI - (xI - (xO xH)) |}; + vname := "i.221" |}; + v_info := dummy_var_info |}; gs := Slocal |})))) (AT_none) (sword U64) (Pvar @@ -459,22 +330,13 @@ Definition matrix_product := {| v_var := {| vtype := sword U64; - vname := "tmp.195" |}; - v_info := - xO - (xI - (xO xH)) |}; + vname := "tmp.222" |}; + v_info := dummy_var_info |}; gs := Slocal |}))]))]; f_tyout := []; f_res := []; f_extra := tt |}); - (xI - (xO - (xI (xO xH))), + (xI xH, {| f_info := - xI - (xO - (xO - (xI - (xO xH)))); + xO (xO xH); f_tyin := [sarr (xO @@ -519,13 +381,8 @@ Definition matrix_product := (xO (xO (xI xH))))))))); - vname := "m1.199" |}; - v_info := - xO - (xI - (xO - (xI - (xO xH)))) |}; + vname := "m1.226" |}; + v_info := dummy_var_info |}; {| v_var := {| vtype := sarr @@ -538,13 +395,8 @@ Definition matrix_product := (xO (xO (xI xH))))))))); - vname := "m2.200" |}; - v_info := - xI - (xI - (xO - (xI - (xO xH)))) |}; + vname := "m2.227" |}; + v_info := dummy_var_info |}; {| v_var := {| vtype := sarr @@ -557,21 +409,11 @@ Definition matrix_product := (xO (xO (xI xH))))))))); - vname := "res.201" |}; - v_info := - xO - (xO - (xI - (xI - (xO xH)))) |}]; + vname := "res.228" |}; + v_info := dummy_var_info |}]; f_body := [MkI - (xO - (xO - (xI - (xO - (xO - (xO xH)))))) + (dummy_instr_info) (Cassgn (Lvar {| v_var := @@ -587,14 +429,8 @@ Definition matrix_product := (xO (xI xH))))))))); - vname := "pres.202" |}; - v_info := - xO - (xI - (xI - (xO - (xO - (xO xH))))) |}) + vname := "pres.229" |}; + v_info := dummy_var_info |}) (AT_none) (sarr (xO @@ -621,22 +457,11 @@ Definition matrix_product := (xO (xI xH))))))))); - vname := "res.201" |}; - v_info := - xI - (xO - (xI - (xO - (xO - (xO xH))))) |}; + vname := "res.228" |}; + v_info := dummy_var_info |}; gs := Slocal |})); MkI - (xO - (xO - (xO - (xO - (xO - (xO xH)))))) + (dummy_instr_info) (Ccall (DoNotInline) ([Lvar {| v_var := @@ -652,19 +477,10 @@ Definition matrix_product := (xO (xI xH))))))))); - vname := "m2t.203" |}; - v_info := - xI - (xI - (xO - (xO - (xO - (xO xH))))) |}]) - (xO - (xO - (xO - (xO - (xI xH))))) + vname := "m2t.230" |}; + v_info := dummy_var_info |}]) + (xI + (xO xH)) ([Pvar {| gv := {| v_var := @@ -680,14 +496,8 @@ Definition matrix_product := (xO (xI xH))))))))); - vname := "m2.200" |}; - v_info := - xI - (xO - (xO - (xO - (xO - (xO xH))))) |}; + vname := "m2.227" |}; + v_info := dummy_var_info |}; gs := Slocal |}; Pvar {| gv := @@ -704,30 +514,15 @@ Definition matrix_product := (xO (xI xH))))))))); - vname := "m2t.203" |}; - v_info := - xO - (xI - (xO - (xO - (xO - (xO xH))))) |}; + vname := "m2t.230" |}; + v_info := dummy_var_info |}; gs := Slocal |}])); MkI - (xI - (xO - (xI - (xO - (xI xH))))) + (dummy_instr_info) (Cfor ({| v_var := - {| vtype := sint; vname := "i.204" |}; - v_info := - xO - (xI - (xI - (xO - (xI xH)))) |}) + {| vtype := sint; vname := "i.231" |}; + v_info := dummy_var_info |}) (((UpTo, Pconst Z0), Pconst (Zpos @@ -735,11 +530,7 @@ Definition matrix_product := (xI (xO xH)))))) ([MkI - (xI - (xI - (xI - (xO - (xI xH))))) + (dummy_instr_info) (Ccall (DoNotInline) ([Lasub (AAscale) (U64) (xO @@ -758,36 +549,23 @@ Definition matrix_product := (xO (xI xH))))))))); - vname := "rest.205" |}; - v_info := - xI - (xI - (xI - (xI - (xI xH)))) |}) + vname := "rest.232" |}; + v_info := dummy_var_info |}) (Papp2 (Omul Op_int) (Pvar {| gv := {| v_var := {| vtype := sint; - vname := "i.204" |}; - v_info := - xO - (xI - (xI - (xI - (xI xH)))) |}; + vname := "i.231" |}; + v_info := dummy_var_info |}; gs := Slocal |}) (Pconst (Zpos (xO (xI (xO xH))))))]) - (xI - (xO - (xI - (xI - (xI xH))))) + (xO + (xI xH)) ([Pvar {| gv := {| v_var := @@ -803,13 +581,8 @@ Definition matrix_product := (xO (xI xH))))))))); - vname := "m1.199" |}; - v_info := - xO - (xO - (xO - (xI - (xI xH)))) |}; + vname := "m1.226" |}; + v_info := dummy_var_info |}; gs := Slocal |}; Psub (AAscale) (U64) (xO @@ -829,26 +602,16 @@ Definition matrix_product := (xO (xI xH))))))))); - vname := "m2t.203" |}; - v_info := - xO - (xI - (xO - (xI - (xI xH)))) |}; + vname := "m2t.230" |}; + v_info := dummy_var_info |}; gs := Slocal |}) (Papp2 (Omul Op_int) (Pvar {| gv := {| v_var := {| vtype := sint; - vname := "i.204" |}; - v_info := - xI - (xO - (xO - (xI - (xI xH)))) |}; + vname := "i.231" |}; + v_info := dummy_var_info |}; gs := Slocal |}) (Pconst (Zpos @@ -873,26 +636,16 @@ Definition matrix_product := (xO (xI xH))))))))); - vname := "rest.205" |}; - v_info := - xO - (xO - (xI - (xI - (xI xH)))) |}; + vname := "rest.232" |}; + v_info := dummy_var_info |}; gs := Slocal |}) (Papp2 (Omul Op_int) (Pvar {| gv := {| v_var := {| vtype := sint; - vname := "i.204" |}; - v_info := - xI - (xI - (xO - (xI - (xI xH)))) |}; + vname := "i.231" |}; + v_info := dummy_var_info |}; gs := Slocal |}) (Pconst (Zpos @@ -900,11 +653,7 @@ Definition matrix_product := (xI (xO xH))))))]))])); MkI - (xO - (xI - (xO - (xO - (xI xH))))) + (dummy_instr_info) (Cassgn (Lvar {| v_var := @@ -920,13 +669,8 @@ Definition matrix_product := (xO (xI xH))))))))); - vname := "res.201" |}; - v_info := - xO - (xO - (xI - (xO - (xI xH)))) |}) + vname := "res.228" |}; + v_info := dummy_var_info |}) (AT_none) (sarr (xO @@ -953,20 +697,11 @@ Definition matrix_product := (xO (xI xH))))))))); - vname := "pres.202" |}; - v_info := - xI - (xI - (xO - (xO - (xI xH)))) |}; + vname := "pres.229" |}; + v_info := dummy_var_info |}; gs := Slocal |})); MkI - (xI - (xO - (xI - (xI - (xO xH))))) + (dummy_instr_info) (Ccall (DoNotInline) ([Lvar {| v_var := @@ -982,18 +717,10 @@ Definition matrix_product := (xO (xI xH))))))))); - vname := "res.201" |}; - v_info := - xI - (xO - (xO - (xO - (xI xH)))) |}]) - (xO - (xO - (xO - (xO - (xI xH))))) + vname := "res.228" |}; + v_info := dummy_var_info |}]) + (xI + (xO xH)) ([Pvar {| gv := {| v_var := @@ -1009,13 +736,8 @@ Definition matrix_product := (xO (xI xH))))))))); - vname := "rest.205" |}; - v_info := - xO - (xI - (xI - (xI - (xO xH)))) |}; + vname := "rest.232" |}; + v_info := dummy_var_info |}; gs := Slocal |}; Pvar {| gv := @@ -1032,13 +754,8 @@ Definition matrix_product := (xO (xI xH))))))))); - vname := "res.201" |}; - v_info := - xI - (xI - (xI - (xI - (xO xH)))) |}; + vname := "res.228" |}; + v_info := dummy_var_info |}; gs := Slocal |}]))]; f_tyout := [sarr @@ -1064,27 +781,12 @@ Definition matrix_product := (xO (xO (xI xH))))))))); - vname := "res.201" |}; - v_info := - xI - (xI - (xI - (xO - (xO - (xO xH))))) |}]; + vname := "res.228" |}; + v_info := dummy_var_info |}]; f_extra := tt |}); - (xO - (xO - (xO - (xO - (xI xH)))), + (xI (xO xH), {| f_info := - xO - (xO - (xO - (xI - (xO - (xO xH))))); + xI (xI xH); f_tyin := [sarr (xO @@ -1119,14 +821,8 @@ Definition matrix_product := (xO (xO (xI xH))))))))); - vname := "m.206" |}; - v_info := - xI - (xO - (xO - (xI - (xO - (xO xH))))) |}; + vname := "m.233" |}; + v_info := dummy_var_info |}; {| v_var := {| vtype := sarr @@ -1139,32 +835,15 @@ Definition matrix_product := (xO (xO (xI xH))))))))); - vname := "res.207" |}; - v_info := - xO - (xI - (xO - (xI - (xO - (xO xH))))) |}]; + vname := "res.234" |}; + v_info := dummy_var_info |}]; f_body := [MkI - (xI - (xI - (xO - (xI - (xO - (xO xH)))))) + (dummy_instr_info) (Cfor ({| v_var := - {| vtype := sint; vname := "i.208" |}; - v_info := - xO - (xO - (xI - (xI - (xO - (xO xH))))) |}) + {| vtype := sint; vname := "i.235" |}; + v_info := dummy_var_info |}) (((UpTo, Pconst Z0), Pconst (Zpos @@ -1172,23 +851,12 @@ Definition matrix_product := (xI (xO xH)))))) ([MkI - (xI - (xO - (xI - (xI - (xO - (xO xH)))))) + (dummy_instr_info) (Cfor ({| v_var := {| vtype := sint; - vname := "j.209" |}; - v_info := - xO - (xI - (xI - (xI - (xO - (xO xH))))) |}) + vname := "j.236" |}; + v_info := dummy_var_info |}) (((UpTo, Pconst Z0), Pconst (Zpos @@ -1196,25 +864,14 @@ Definition matrix_product := (xI (xO xH)))))) ([MkI - (xO - (xO - (xI - (xO - (xI - (xO xH)))))) + (dummy_instr_info) (Cassgn (Lvar {| v_var := {| vtype := sword U64; - vname := "tmp.210" |}; - v_info := - xO - (xO - (xO - (xI - (xI - (xO xH))))) |}) + vname := "tmp.237" |}; + v_info := dummy_var_info |}) (AT_none) (sword U64) (Pget (AAscale) (U64) ({| gv := @@ -1231,43 +888,24 @@ Definition matrix_product := (xO (xI xH))))))))); - vname := "m.206" |}; - v_info := - xI - (xI - (xI - (xO - (xI - (xO xH))))) |}; + vname := "m.233" |}; + v_info := dummy_var_info |}; gs := Slocal |}) (Papp2 (Oadd Op_int) (Pvar {| gv := {| v_var := {| vtype := sint; - vname := "j.209" |}; - v_info := - xO - (xI - (xI - (xO - (xI - (xO xH))))) |}; + vname := "j.236" |}; + v_info := dummy_var_info |}; gs := Slocal |}) (Papp2 (Omul Op_int) (Pvar {| gv := {| v_var := {| vtype := sint; - vname := "i.208" |}; - v_info := - xI - (xO - (xI - (xO - (xI - (xO - xH))))) |}; + vname := "i.235" |}; + v_info := dummy_var_info |}; gs := Slocal |}) (Pconst (Zpos @@ -1275,12 +913,7 @@ Definition matrix_product := (xI (xO xH))))))))); MkI - (xI - (xI - (xI - (xI - (xO - (xO xH)))))) + (dummy_instr_info) (Cassgn (Laset (AAscale) (U64) @@ -1297,43 +930,23 @@ Definition matrix_product := (xO (xI xH))))))))); - vname := "res.207" |}; - v_info := - xI - (xI - (xO - (xO - (xI - (xO xH))))) |}) + vname := "res.234" |}; + v_info := dummy_var_info |}) (Papp2 (Oadd Op_int) (Pvar {| gv := {| v_var := {| vtype := sint; - vname := "i.208" |}; - v_info := - xO - (xI - (xO - (xO - (xI - (xO - xH))))) |}; + vname := "i.235" |}; + v_info := dummy_var_info |}; gs := Slocal |}) (Papp2 (Omul Op_int) (Pvar {| gv := {| v_var := {| vtype := sint; - vname := "j.209" |}; - v_info := - xI - (xO - (xO - (xO - (xI - (xO - xH))))) |}; + vname := "j.236" |}; + v_info := dummy_var_info |}; gs := Slocal |}) (Pconst (Zpos @@ -1346,14 +959,8 @@ Definition matrix_product := {| v_var := {| vtype := sword U64; - vname := "tmp.210" |}; - v_info := - xO - (xO - (xO - (xO - (xI - (xO xH))))) |}; + vname := "tmp.237" |}; + v_info := dummy_var_info |}; gs := Slocal |}))]))]))]; f_tyout := [sarr @@ -1379,27 +986,13 @@ Definition matrix_product := (xO (xO (xI xH))))))))); - vname := "res.207" |}; - v_info := - xI - (xO - (xO - (xI - (xI - (xO xH))))) |}]; + vname := "res.234" |}; + v_info := dummy_var_info |}]; f_extra := tt |}); - (xI - (xO - (xI - (xI - (xI xH)))), + (xO (xI xH), {| f_info := xO - (xI - (xO - (xI - (xI - (xO xH))))); + (xO (xO xH)); f_tyin := [sarr (xO @@ -1438,14 +1031,8 @@ Definition matrix_product := (xO (xO (xI xH))))))))); - vname := "m.211" |}; - v_info := - xI - (xI - (xO - (xI - (xI - (xO xH))))) |}; + vname := "m.238" |}; + v_info := dummy_var_info |}; {| v_var := {| vtype := sarr @@ -1455,14 +1042,8 @@ Definition matrix_product := (xO (xI (xO xH)))))); - vname := "v.212" |}; - v_info := - xO - (xO - (xI - (xI - (xI - (xO xH))))) |}; + vname := "v.239" |}; + v_info := dummy_var_info |}; {| v_var := {| vtype := sarr @@ -1472,32 +1053,15 @@ Definition matrix_product := (xO (xI (xO xH)))))); - vname := "res.213" |}; - v_info := - xI - (xO - (xI - (xI - (xI - (xO xH))))) |}]; + vname := "res.240" |}; + v_info := dummy_var_info |}]; f_body := [MkI - (xO - (xI - (xI - (xI - (xI - (xO xH)))))) + (dummy_instr_info) (Cfor ({| v_var := - {| vtype := sint; vname := "i.214" |}; - v_info := - xI - (xI - (xI - (xI - (xI - (xO xH))))) |}) + {| vtype := sint; vname := "i.241" |}; + v_info := dummy_var_info |}) (((UpTo, Pconst Z0), Pconst (Zpos @@ -1505,31 +1069,17 @@ Definition matrix_product := (xI (xO xH)))))) ([MkI - (xO - (xO - (xI - (xO - (xO - (xI xH)))))) + (dummy_instr_info) (Ccall (DoNotInline) ([Lvar {| v_var := {| vtype := sword U64; - vname := "tmp.215" |}; - v_info := - xI - (xO - (xO - (xI - (xO - (xI xH))))) |}]) - (xO + vname := "tmp.242" |}; + v_info := dummy_var_info |}]) + (xI (xO - (xO - (xI - (xO - (xI xH)))))) + (xO xH))) ([Psub (AAscale) (U64) (xO (xI @@ -1548,28 +1098,16 @@ Definition matrix_product := (xO (xI xH))))))))); - vname := "m.211" |}; - v_info := - xO - (xI - (xI - (xO - (xO - (xI xH))))) |}; + vname := "m.238" |}; + v_info := dummy_var_info |}; gs := Slocal |}) (Papp2 (Omul Op_int) (Pvar {| gv := {| v_var := {| vtype := sint; - vname := "i.214" |}; - v_info := - xI - (xO - (xI - (xO - (xO - (xI xH))))) |}; + vname := "i.241" |}; + v_info := dummy_var_info |}; gs := Slocal |}) (Pconst (Zpos @@ -1587,22 +1125,11 @@ Definition matrix_product := (xO (xI (xO xH)))))); - vname := "v.212" |}; - v_info := - xI - (xI - (xI - (xO - (xO - (xI xH))))) |}; + vname := "v.239" |}; + v_info := dummy_var_info |}; gs := Slocal |}])); MkI - (xO - (xO - (xO - (xO - (xO - (xI xH)))))) + (dummy_instr_info) (Cassgn (Laset (AAscale) (U64) ({| v_var := @@ -1614,26 +1141,14 @@ Definition matrix_product := (xO (xI (xO xH)))))); - vname := "res.213" |}; - v_info := - xI - (xI - (xO - (xO - (xO - (xI xH))))) |}) + vname := "res.240" |}; + v_info := dummy_var_info |}) (Pvar {| gv := {| v_var := {| vtype := sint; - vname := "i.214" |}; - v_info := - xO - (xI - (xO - (xO - (xO - (xI xH))))) |}; + vname := "i.241" |}; + v_info := dummy_var_info |}; gs := Slocal |})) (AT_none) (sword U64) (Pvar @@ -1641,14 +1156,8 @@ Definition matrix_product := {| v_var := {| vtype := sword U64; - vname := "tmp.215" |}; - v_info := - xI - (xO - (xO - (xO - (xO - (xI xH))))) |}; + vname := "tmp.242" |}; + v_info := dummy_var_info |}; gs := Slocal |}))]))]; f_tyout := [sarr @@ -1668,28 +1177,14 @@ Definition matrix_product := (xO (xI (xO xH)))))); - vname := "res.213" |}; - v_info := - xO - (xI - (xO - (xI - (xO - (xI xH))))) |}]; + vname := "res.240" |}; + v_info := dummy_var_info |}]; f_extra := tt |}); - (xO - (xO - (xO - (xI - (xO - (xI xH))))), + (xI + (xO (xO xH)), {| f_info := - xI - (xI - (xO - (xI - (xO - (xI xH))))); + xO + (xI (xO xH)); f_tyin := [sarr (xO @@ -1715,14 +1210,8 @@ Definition matrix_product := (xO (xI (xO xH)))))); - vname := "v1.216" |}; - v_info := - xO - (xO - (xI - (xI - (xO - (xI xH))))) |}; + vname := "v1.243" |}; + v_info := dummy_var_info |}; {| v_var := {| vtype := sarr @@ -1732,55 +1221,27 @@ Definition matrix_product := (xO (xI (xO xH)))))); - vname := "v2.217" |}; - v_info := - xI - (xO - (xI - (xI - (xO - (xI xH))))) |}]; + vname := "v2.244" |}; + v_info := dummy_var_info |}]; f_body := [MkI - (xI - (xO - (xI - (xI - (xI - (xI xH)))))) + (dummy_instr_info) (Cassgn (Lvar {| v_var := {| vtype := sword U64; - vname := "res.218" |}; - v_info := - xO - (xI - (xI - (xI - (xI - (xI xH))))) |}) + vname := "res.245" |}; + v_info := dummy_var_info |}) (AT_none) (sword U64) (Papp1 (Oword_of_int U64) (Pconst Z0))); MkI - (xO - (xI - (xI - (xI - (xO - (xI xH)))))) + (dummy_instr_info) (Cfor ({| v_var := - {| vtype := sint; vname := "i.219" |}; - v_info := - xI - (xI - (xI - (xI - (xO - (xI xH))))) |}) + {| vtype := sint; vname := "i.246" |}; + v_info := dummy_var_info |}) (((UpTo, Pconst Z0), Pconst (Zpos @@ -1788,25 +1249,14 @@ Definition matrix_product := (xI (xO xH)))))) ([MkI - (xI - (xO - (xO - (xI - (xI - (xI xH)))))) + (dummy_instr_info) (Cassgn (Lvar {| v_var := {| vtype := sword U64; - vname := "tmp.220" |}; - v_info := - xO - (xO - (xI - (xI - (xI - (xI xH))))) |}) + vname := "tmp.247" |}; + v_info := dummy_var_info |}) (AT_none) (sword U64) (Pget (AAscale) (U64) ({| gv := @@ -1819,48 +1269,25 @@ Definition matrix_product := (xO (xI (xO xH)))))); - vname := "v1.216" |}; - v_info := - xI - (xI - (xO - (xI - (xI - (xI xH))))) |}; + vname := "v1.243" |}; + v_info := dummy_var_info |}; gs := Slocal |}) (Pvar {| gv := {| v_var := {| vtype := sint; - vname := "i.219" |}; - v_info := - xO - (xI - (xO - (xI - (xI - (xI xH))))) |}; + vname := "i.246" |}; + v_info := dummy_var_info |}; gs := Slocal |}))); MkI - (xO - (xO - (xI - (xO - (xI - (xI xH)))))) + (dummy_instr_info) (Cassgn (Lvar {| v_var := {| vtype := sword U64; - vname := "tmp.220" |}; - v_info := - xO - (xO - (xO - (xI - (xI - (xI xH))))) |}) + vname := "tmp.247" |}; + v_info := dummy_var_info |}) (AT_none) (sword U64) (Papp2 (Omul (Op_w U64)) @@ -1869,14 +1296,8 @@ Definition matrix_product := {| v_var := {| vtype := sword U64; - vname := "tmp.220" |}; - v_info := - xI - (xI - (xI - (xO - (xI - (xI xH))))) |}; + vname := "tmp.247" |}; + v_info := dummy_var_info |}; gs := Slocal |}) (Pget (AAscale) (U64) ({| gv := @@ -1889,48 +1310,25 @@ Definition matrix_product := (xO (xI (xO xH)))))); - vname := "v2.217" |}; - v_info := - xO - (xI - (xI - (xO - (xI - (xI xH))))) |}; + vname := "v2.244" |}; + v_info := dummy_var_info |}; gs := Slocal |}) (Pvar {| gv := {| v_var := {| vtype := sint; - vname := "i.219" |}; - v_info := - xI - (xO - (xI - (xO - (xI - (xI xH))))) |}; + vname := "i.246" |}; + v_info := dummy_var_info |}; gs := Slocal |})))); MkI - (xO - (xO - (xO - (xO - (xI - (xI xH)))))) + (dummy_instr_info) (Cassgn (Lvar {| v_var := {| vtype := sword U64; - vname := "res.218" |}; - v_info := - xI - (xI - (xO - (xO - (xI - (xI xH))))) |}) + vname := "res.245" |}; + v_info := dummy_var_info |}) (AT_none) (sword U64) (Papp2 (Oadd (Op_w U64)) @@ -1939,41 +1337,23 @@ Definition matrix_product := {| v_var := {| vtype := sword U64; - vname := "res.218" |}; - v_info := - xO - (xI - (xO - (xO - (xI - (xI xH))))) |}; + vname := "res.245" |}; + v_info := dummy_var_info |}; gs := Slocal |}) (Pvar {| gv := {| v_var := {| vtype := sword U64; - vname := "tmp.220" |}; - v_info := - xI - (xO - (xO - (xO - (xI - (xI xH))))) |}; + vname := "tmp.247" |}; + v_info := dummy_var_info |}; gs := Slocal |})))]))]; f_tyout := [sword U64]; f_res := [{| v_var := {| vtype := sword U64; - vname := "res.218" |}; - v_info := - xI - (xI - (xI - (xI - (xI - (xI xH))))) |}]; + vname := "res.245" |}; + v_info := dummy_var_info |}]; f_extra := tt |})]; p_globs := []; p_extra := tt |} . \ No newline at end of file diff --git a/theories/Jasmin/examples/retz/retz.cprog b/theories/Jasmin/examples/retz.cprog similarity index 52% rename from theories/Jasmin/examples/retz/retz.cprog rename to theories/Jasmin/examples/retz.cprog index ba185172..e9030039 100644 --- a/theories/Jasmin/examples/retz/retz.cprog +++ b/theories/Jasmin/examples/retz.cprog @@ -1,20 +1,24 @@ {Jasmin.Expr.p_funcs = - [(Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH, - {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH; + [(Jasmin.BinNums.Coq_xH, + {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH; f_tyin = []; f_params = []; f_body = [Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH), + (({Jasmin.Location.uid_loc = 2; + base_loc = + {Jasmin.Location.loc_fname = "retz.jazz"; loc_start = (4, 0); + loc_end = (4, 6); loc_bchar = 41; loc_echar = 47}; + stack_loc = []}, + []), Jasmin.Expr.Cassgn (Jasmin.Expr.Lvar {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = z.128}; + vname = z.139}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)}, + {Jasmin.Location.loc_fname = "retz.jazz"; loc_start = (4, 0); + loc_end = (4, 1); loc_bchar = 41; loc_echar = 42}}, Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U64, Jasmin.Expr.Pconst Jasmin.BinNums.Z0)))]; @@ -22,9 +26,9 @@ f_res = [{Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = z.128}; + vname = z.139}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)}]; + {Jasmin.Location.loc_fname = "retz.jazz"; loc_start = (5, 7); + loc_end = (5, 8); loc_bchar = 55; loc_echar = 56}}]; f_extra = ()})]; p_globs = []; p_extra = ()} diff --git a/theories/Jasmin/examples/retz/retz.jazz b/theories/Jasmin/examples/retz.jazz similarity index 100% rename from theories/Jasmin/examples/retz/retz.jazz rename to theories/Jasmin/examples/retz.jazz diff --git a/theories/Jasmin/examples/retz/retz.v b/theories/Jasmin/examples/retz.v similarity index 65% rename from theories/Jasmin/examples/retz/retz.v rename to theories/Jasmin/examples/retz.v index c81c5463..2b1ff5e7 100644 --- a/theories/Jasmin/examples/retz/retz.v +++ b/theories/Jasmin/examples/retz.v @@ -5,24 +5,20 @@ From Jasmin Require Import x86_extra. Import ListNotations. Local Open Scope string. -Definition retz := - {| p_funcs := - [(xO xH, - {| f_info := xI xH; +Definition retz := {| p_funcs := + [(xH, + {| f_info := xO xH; f_tyin := []; f_params := []; f_body := [MkI - (xO - (xO xH)) + (dummy_instr_info) (Cassgn (Lvar {| v_var := {| vtype := sword U64; - vname := "z.128" |}; - v_info := - xI - (xO xH) |}) + vname := "z.139" |}; + v_info := dummy_var_info |}) (AT_none) (sword U64) (Papp1 (Oword_of_int U64) (Pconst Z0)))]; @@ -30,10 +26,8 @@ Definition retz := f_res := [{| v_var := {| vtype := sword U64; - vname := "z.128" |}; - v_info := - xO - (xI xH) |}]; + vname := "z.139" |}; + v_info := dummy_var_info |}]; f_extra := tt |})]; p_globs := []; p_extra := tt |} . \ No newline at end of file diff --git a/theories/Jasmin/examples/test_for/test_for.cprog b/theories/Jasmin/examples/test_for.cprog similarity index 51% rename from theories/Jasmin/examples/test_for/test_for.cprog rename to theories/Jasmin/examples/test_for.cprog index 21e51ff8..63ac79cb 100644 --- a/theories/Jasmin/examples/test_for/test_for.cprog +++ b/theories/Jasmin/examples/test_for.cprog @@ -1,51 +1,66 @@ {Jasmin.Expr.p_funcs = - [(Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH, - {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH; + [(Jasmin.BinNums.Coq_xH, + {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH; f_tyin = []; f_params = []; f_body = [Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)), + (({Jasmin.Location.uid_loc = 2; + base_loc = + {Jasmin.Location.loc_fname = "test_for.jazz"; + loc_start = (5, 0); loc_end = (5, 6); loc_bchar = 52; + loc_echar = 58}; + stack_loc = []}, + []), Jasmin.Expr.Cassgn (Jasmin.Expr.Lvar {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = r.130}; + vname = r.141}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}, + {Jasmin.Location.loc_fname = "test_for.jazz"; + loc_start = (5, 0); loc_end = (5, 1); loc_bchar = 52; + loc_echar = 53}}, Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U64, Jasmin.Expr.Pconst Jasmin.BinNums.Z0))); Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH), + (({Jasmin.Location.uid_loc = 4; + base_loc = + {Jasmin.Location.loc_fname = "test_for.jazz"; + loc_start = (6, 0); loc_end = (8, 1); loc_bchar = 59; + loc_echar = 89}; + stack_loc = []}, + []), Jasmin.Expr.Cfor ({Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = i.131}; + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = i.142}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)}, + {Jasmin.Location.loc_fname = "test_for.jazz"; + loc_start = (6, 4); loc_end = (6, 5); loc_bchar = 63; + loc_echar = 64}}, ((Jasmin.Expr.DownTo, Jasmin.Expr.Pconst Jasmin.BinNums.Z0), Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))), [Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH), + (({Jasmin.Location.uid_loc = 3; + base_loc = + {Jasmin.Location.loc_fname = "test_for.jazz"; + loc_start = (7, 0); loc_end = (7, 7); loc_bchar = 80; + loc_echar = 87}; + stack_loc = []}, + []), Jasmin.Expr.Cassgn (Jasmin.Expr.Lvar {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = r.130}; + vname = r.141}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}, + {Jasmin.Location.loc_fname = "test_for.jazz"; + loc_start = (7, 0); loc_end = (7, 1); loc_bchar = 80; + loc_echar = 81}}, Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, Jasmin.Expr.Papp2 (Jasmin.Expr.Oadd (Jasmin.Expr.Op_w Jasmin.Wsize.U64), @@ -54,10 +69,11 @@ {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = r.130}; + vname = r.141}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)}; + {Jasmin.Location.loc_fname = "test_for.jazz"; + loc_start = (7, 0); loc_end = (7, 1); loc_bchar = 80; + loc_echar = 81}}; gs = Jasmin.Expr.Slocal}, Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U64, Jasmin.Expr.Pconst @@ -66,10 +82,9 @@ f_res = [{Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = r.130}; + vname = r.141}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}]; + {Jasmin.Location.loc_fname = "test_for.jazz"; loc_start = (9, 7); + loc_end = (9, 8); loc_bchar = 97; loc_echar = 98}}]; f_extra = ()})]; p_globs = []; p_extra = ()} diff --git a/theories/Jasmin/examples/test_for/test_for.jazz b/theories/Jasmin/examples/test_for.jazz similarity index 100% rename from theories/Jasmin/examples/test_for/test_for.jazz rename to theories/Jasmin/examples/test_for.jazz diff --git a/theories/Jasmin/examples/test_for/test_for.v b/theories/Jasmin/examples/test_for.v similarity index 59% rename from theories/Jasmin/examples/test_for/test_for.v rename to theories/Jasmin/examples/test_for.v index dec832f0..5c091bd5 100644 --- a/theories/Jasmin/examples/test_for/test_for.v +++ b/theories/Jasmin/examples/test_for.v @@ -5,55 +5,42 @@ From Jasmin Require Import x86_extra. Import ListNotations. Local Open Scope string. -Definition test_for := - {| p_funcs := - [(xO xH, - {| f_info := xI xH; +Definition test_for := {| p_funcs := + [(xH, + {| f_info := xO xH; f_tyin := []; f_params := []; f_body := [MkI - (xI - (xO - (xO xH))) + (dummy_instr_info) (Cassgn (Lvar {| v_var := {| vtype := sword U64; - vname := "r.130" |}; - v_info := - xO - (xI - (xO xH)) |}) + vname := "r.141" |}; + v_info := dummy_var_info |}) (AT_none) (sword U64) (Papp1 (Oword_of_int U64) (Pconst Z0))); MkI - (xO - (xO xH)) + (dummy_instr_info) (Cfor ({| v_var := - {| vtype := sint; vname := "i.131" |}; - v_info := - xI - (xO xH) |}) + {| vtype := sint; vname := "i.142" |}; + v_info := dummy_var_info |}) (((DownTo, Pconst Z0), Pconst (Zpos (xI xH)))) ([MkI - (xO - (xI xH)) + (dummy_instr_info) (Cassgn (Lvar {| v_var := {| vtype := sword U64; - vname := "r.130" |}; - v_info := - xO - (xO - (xO xH)) |}) + vname := "r.141" |}; + v_info := dummy_var_info |}) (AT_none) (sword U64) (Papp2 (Oadd (Op_w U64)) @@ -62,10 +49,8 @@ Definition test_for := {| v_var := {| vtype := sword U64; - vname := "r.130" |}; - v_info := - xI - (xI xH) |}; + vname := "r.141" |}; + v_info := dummy_var_info |}; gs := Slocal |}) (Papp1 (Oword_of_int U64) (Pconst @@ -74,11 +59,8 @@ Definition test_for := f_res := [{| v_var := {| vtype := sword U64; - vname := "r.130" |}; - v_info := - xI - (xI - (xO xH)) |}]; + vname := "r.141" |}; + v_info := dummy_var_info |}]; f_extra := tt |})]; p_globs := []; p_extra := tt |} . \ No newline at end of file diff --git a/theories/Jasmin/examples/test_inline_var/test_inline_var.cprog b/theories/Jasmin/examples/test_inline_var.cprog similarity index 50% rename from theories/Jasmin/examples/test_inline_var/test_inline_var.cprog rename to theories/Jasmin/examples/test_inline_var.cprog index 490cf63d..8e149b9d 100644 --- a/theories/Jasmin/examples/test_inline_var/test_inline_var.cprog +++ b/theories/Jasmin/examples/test_inline_var.cprog @@ -1,69 +1,74 @@ {Jasmin.Expr.p_funcs = - [(Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH, - {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH; + [(Jasmin.BinNums.Coq_xH, + {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH; f_tyin = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; f_params = [{Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = r1.135}; + vname = r1.150}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)}]; + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; f_body = [Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)), + (({Jasmin.Location.uid_loc = 4; + base_loc = + {Jasmin.Location.loc_fname = "test_inline_var.jazz"; + loc_start = (10, 0); loc_end = (10, 7); loc_bchar = 149; + loc_echar = 156}; + stack_loc = []}, + []), Jasmin.Expr.Cassgn (Jasmin.Expr.Lvar {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = r.136}; + vname = r.151}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}, + {Jasmin.Location.loc_fname = "test_inline_var.jazz"; + loc_start = (10, 0); loc_end = (10, 1); loc_bchar = 149; + loc_echar = 150}}, Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = r1.135}; + vname = r1.150}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}; + {Jasmin.Location.loc_fname = "test_inline_var.jazz"; + loc_start = (10, 4); loc_end = (10, 6); loc_bchar = 153; + loc_echar = 155}}; gs = Jasmin.Expr.Slocal})); Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)), + (({Jasmin.Location.uid_loc = 5; + base_loc = + {Jasmin.Location.loc_fname = "test_inline_var.jazz"; + loc_start = (11, 0); loc_end = (11, 16); loc_bchar = 157; + loc_echar = 173}; + stack_loc = []}, + []), Jasmin.Expr.Ccall (Jasmin.Expr.InlineFun, [Jasmin.Expr.Lvar {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = r.136}; + vname = r.151}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}], - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH), + {Jasmin.Location.loc_fname = "test_inline_var.jazz"; + loc_start = (11, 0); loc_end = (11, 1); loc_bchar = 157; + loc_echar = 158}}], + Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH, [Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = r.136}; + vname = r.151}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}; + {Jasmin.Location.loc_fname = "test_inline_var.jazz"; + loc_start = (11, 10); loc_end = (11, 11); loc_bchar = 167; + loc_echar = 168}}; gs = Jasmin.Expr.Slocal}; Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U64, Jasmin.Expr.Pconst @@ -71,60 +76,68 @@ (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))])); Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)), + (({Jasmin.Location.uid_loc = 6; + base_loc = + {Jasmin.Location.loc_fname = "test_inline_var.jazz"; + loc_start = (12, 0); loc_end = (12, 16); loc_bchar = 174; + loc_echar = 190}; + stack_loc = []}, + []), Jasmin.Expr.Ccall (Jasmin.Expr.InlineFun, [Jasmin.Expr.Lvar {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = r.136}; + vname = r.151}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}], - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH), + {Jasmin.Location.loc_fname = "test_inline_var.jazz"; + loc_start = (12, 0); loc_end = (12, 1); loc_bchar = 174; + loc_echar = 175}}], + Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH, [Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = r.136}; + vname = r.151}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}; + {Jasmin.Location.loc_fname = "test_inline_var.jazz"; + loc_start = (12, 10); loc_end = (12, 11); loc_bchar = 184; + loc_echar = 185}}; gs = Jasmin.Expr.Slocal}; Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U64, Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))])); Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH), + (({Jasmin.Location.uid_loc = 7; + base_loc = + {Jasmin.Location.loc_fname = "test_inline_var.jazz"; + loc_start = (13, 0); loc_end = (13, 16); loc_bchar = 191; + loc_echar = 207}; + stack_loc = []}, + []), Jasmin.Expr.Ccall (Jasmin.Expr.InlineFun, [Jasmin.Expr.Lvar {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = r.136}; + vname = r.151}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}], - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH), + {Jasmin.Location.loc_fname = "test_inline_var.jazz"; + loc_start = (13, 0); loc_end = (13, 1); loc_bchar = 191; + loc_echar = 192}}], + Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH, [Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = r.136}; + vname = r.151}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)}; + {Jasmin.Location.loc_fname = "test_inline_var.jazz"; + loc_start = (13, 10); loc_end = (13, 11); loc_bchar = 201; + loc_echar = 202}}; gs = Jasmin.Expr.Slocal}; Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U64, Jasmin.Expr.Pconst @@ -135,56 +148,50 @@ f_res = [{Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = r.136}; + vname = r.151}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}]; + {Jasmin.Location.loc_fname = "test_inline_var.jazz"; + loc_start = (14, 7); loc_end = (14, 8); loc_bchar = 215; + loc_echar = 216}}]; f_extra = ()}); - (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH), + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH, {Jasmin.Expr.f_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))); + Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH); f_tyin = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64; Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; f_params = [{Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = r.137}; + vname = r.152}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}; + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}; {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = n.138}; + vname = n.153}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}]; + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; f_body = [Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))), + (({Jasmin.Location.uid_loc = 2; + base_loc = + {Jasmin.Location.loc_fname = "test_inline_var.jazz"; + loc_start = (3, 2); loc_end = (3, 12); loc_bchar = 56; + loc_echar = 66}; + stack_loc = []}, + []), Jasmin.Expr.Cassgn (Jasmin.Expr.Lvar {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = r.137}; + vname = r.152}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}, + {Jasmin.Location.loc_fname = "test_inline_var.jazz"; + loc_start = (3, 2); loc_end = (3, 3); loc_bchar = 56; + loc_echar = 57}}, Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, Jasmin.Expr.Papp2 (Jasmin.Expr.Oadd (Jasmin.Expr.Op_w Jasmin.Wsize.U64), @@ -193,41 +200,41 @@ {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = r.137}; + vname = r.152}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}; + {Jasmin.Location.loc_fname = "test_inline_var.jazz"; + loc_start = (3, 6); loc_end = (3, 7); loc_bchar = 60; + loc_echar = 61}}; gs = Jasmin.Expr.Slocal}, Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = n.138}; + vname = n.153}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}; + {Jasmin.Location.loc_fname = "test_inline_var.jazz"; + loc_start = (3, 10); loc_end = (3, 11); loc_bchar = 64; + loc_echar = 65}}; gs = Jasmin.Expr.Slocal}))); Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), + (({Jasmin.Location.uid_loc = 3; + base_loc = + {Jasmin.Location.loc_fname = "test_inline_var.jazz"; + loc_start = (4, 2); loc_end = (4, 18); loc_bchar = 69; + loc_echar = 85}; + stack_loc = []}, + []), Jasmin.Expr.Cassgn (Jasmin.Expr.Lvar {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = r.137}; + vname = r.152}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}, + {Jasmin.Location.loc_fname = "test_inline_var.jazz"; + loc_start = (4, 2); loc_end = (4, 3); loc_bchar = 69; + loc_echar = 70}}, Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, Jasmin.Expr.Papp2 (Jasmin.Expr.Oadd (Jasmin.Expr.Op_w Jasmin.Wsize.U64), @@ -236,12 +243,11 @@ {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = r.137}; + vname = r.152}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}; + {Jasmin.Location.loc_fname = "test_inline_var.jazz"; + loc_start = (4, 6); loc_end = (4, 7); loc_bchar = 73; + loc_echar = 74}}; gs = Jasmin.Expr.Slocal}, Jasmin.Expr.Papp2 (Jasmin.Expr.Oadd (Jasmin.Expr.Op_w Jasmin.Wsize.U64), @@ -250,34 +256,31 @@ {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = n.138}; + vname = n.153}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}; + {Jasmin.Location.loc_fname = "test_inline_var.jazz"; + loc_start = (4, 11); loc_end = (4, 12); loc_bchar = 78; + loc_echar = 79}}; gs = Jasmin.Expr.Slocal}, Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = n.138}; + vname = n.153}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}; + {Jasmin.Location.loc_fname = "test_inline_var.jazz"; + loc_start = (4, 15); loc_end = (4, 16); loc_bchar = 82; + loc_echar = 83}}; gs = Jasmin.Expr.Slocal}))))]; f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; f_res = [{Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = r.137}; + vname = r.152}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}]; + {Jasmin.Location.loc_fname = "test_inline_var.jazz"; + loc_start = (5, 9); loc_end = (5, 10); loc_bchar = 95; + loc_echar = 96}}]; f_extra = ()})]; p_globs = []; p_extra = ()} diff --git a/theories/Jasmin/examples/test_inline_var/test_inline_var.jazz b/theories/Jasmin/examples/test_inline_var.jazz similarity index 100% rename from theories/Jasmin/examples/test_inline_var/test_inline_var.jazz rename to theories/Jasmin/examples/test_inline_var.jazz diff --git a/theories/Jasmin/examples/test_inline_var/test_inline_var.v b/theories/Jasmin/examples/test_inline_var.v similarity index 50% rename from theories/Jasmin/examples/test_inline_var/test_inline_var.v rename to theories/Jasmin/examples/test_inline_var.v index cb8c6fe0..e685449a 100644 --- a/theories/Jasmin/examples/test_inline_var/test_inline_var.v +++ b/theories/Jasmin/examples/test_inline_var.v @@ -5,73 +5,51 @@ From Jasmin Require Import x86_extra. Import ListNotations. Local Open Scope string. -Definition test_inline_var := - {| p_funcs := - [(xO xH, - {| f_info := xI xH; +Definition test_inline_var := {| p_funcs := + [(xH, + {| f_info := xO xH; f_tyin := [sword U64]; f_params := [{| v_var := {| vtype := sword U64; - vname := "r1.135" |}; - v_info := - xO - (xO xH) |}]; + vname := "r1.150" |}; + v_info := dummy_var_info |}]; f_body := [MkI - (xI - (xI - (xI xH))) + (dummy_instr_info) (Cassgn (Lvar {| v_var := {| vtype := sword U64; - vname := "r.136" |}; - v_info := - xI - (xO - (xO - (xO xH))) |}) + vname := "r.151" |}; + v_info := dummy_var_info |}) (AT_none) (sword U64) (Pvar {| gv := {| v_var := {| vtype := sword U64; - vname := "r1.135" |}; - v_info := - xO - (xO - (xO - (xO xH))) |}; + vname := "r1.150" |}; + v_info := dummy_var_info |}; gs := Slocal |})); MkI - (xO - (xO - (xI xH))) + (dummy_instr_info) (Ccall (InlineFun) ([Lvar {| v_var := {| vtype := sword U64; - vname := "r.136" |}; - v_info := - xO - (xI - (xI xH)) |}]) - (xI - (xI xH)) + vname := "r.151" |}; + v_info := dummy_var_info |}]) + (xI xH) ([Pvar {| gv := {| v_var := {| vtype := sword U64; - vname := "r.136" |}; - v_info := - xI - (xO - (xI xH)) |}; + vname := "r.151" |}; + v_info := dummy_var_info |}; gs := Slocal |}; Papp1 (Oword_of_int U64) (Pconst @@ -79,60 +57,44 @@ Definition test_inline_var := (xO (xI xH))))])); MkI - (xI - (xO - (xO xH))) + (dummy_instr_info) (Ccall (InlineFun) ([Lvar {| v_var := {| vtype := sword U64; - vname := "r.136" |}; - v_info := - xI - (xI - (xO xH)) |}]) - (xI - (xI xH)) + vname := "r.151" |}; + v_info := dummy_var_info |}]) + (xI xH) ([Pvar {| gv := {| v_var := {| vtype := sword U64; - vname := "r.136" |}; - v_info := - xO - (xI - (xO xH)) |}; + vname := "r.151" |}; + v_info := dummy_var_info |}; gs := Slocal |}; Papp1 (Oword_of_int U64) (Pconst (Zpos (xI xH)))])); MkI - (xI - (xO xH)) + (dummy_instr_info) (Ccall (InlineFun) ([Lvar {| v_var := {| vtype := sword U64; - vname := "r.136" |}; - v_info := - xO - (xO - (xO xH)) |}]) - (xI - (xI xH)) + vname := "r.151" |}; + v_info := dummy_var_info |}]) + (xI xH) ([Pvar {| gv := {| v_var := {| vtype := sword U64; - vname := "r.136" |}; - v_info := - xO - (xI xH) |}; + vname := "r.151" |}; + v_info := dummy_var_info |}; gs := Slocal |}; Papp1 (Oword_of_int U64) (Pconst @@ -143,56 +105,34 @@ Definition test_inline_var := f_res := [{| v_var := {| vtype := sword U64; - vname := "r.136" |}; - v_info := - xO - (xI - (xO - (xO xH))) |}]; + vname := "r.151" |}; + v_info := dummy_var_info |}]; f_extra := tt |}); - (xI (xI xH), + (xI xH, {| f_info := - xI - (xI - (xO - (xO xH))); + xO (xO xH); f_tyin := [sword U64; sword U64]; f_params := [{| v_var := {| vtype := sword U64; - vname := "r.137" |}; - v_info := - xO - (xO - (xI - (xO xH))) |}; + vname := "r.152" |}; + v_info := dummy_var_info |}; {| v_var := {| vtype := sword U64; - vname := "n.138" |}; - v_info := - xI - (xO - (xI - (xO xH))) |}]; + vname := "n.153" |}; + v_info := dummy_var_info |}]; f_body := [MkI - (xI - (xI - (xO - (xI xH)))) + (dummy_instr_info) (Cassgn (Lvar {| v_var := {| vtype := sword U64; - vname := "r.137" |}; - v_info := - xO - (xI - (xI - (xI xH))) |}) + vname := "r.152" |}; + v_info := dummy_var_info |}) (AT_none) (sword U64) (Papp2 (Oadd (Op_w U64)) @@ -201,41 +141,26 @@ Definition test_inline_var := {| v_var := {| vtype := sword U64; - vname := "r.137" |}; - v_info := - xI - (xO - (xI - (xI xH))) |}; + vname := "r.152" |}; + v_info := dummy_var_info |}; gs := Slocal |}) (Pvar {| gv := {| v_var := {| vtype := sword U64; - vname := "n.138" |}; - v_info := - xO - (xO - (xI - (xI xH))) |}; + vname := "n.153" |}; + v_info := dummy_var_info |}; gs := Slocal |}))); MkI - (xO - (xI - (xI - (xO xH)))) + (dummy_instr_info) (Cassgn (Lvar {| v_var := {| vtype := sword U64; - vname := "r.137" |}; - v_info := - xO - (xI - (xO - (xI xH))) |}) + vname := "r.152" |}; + v_info := dummy_var_info |}) (AT_none) (sword U64) (Papp2 (Oadd (Op_w U64)) @@ -244,12 +169,8 @@ Definition test_inline_var := {| v_var := {| vtype := sword U64; - vname := "r.137" |}; - v_info := - xI - (xO - (xO - (xI xH))) |}; + vname := "r.152" |}; + v_info := dummy_var_info |}; gs := Slocal |}) (Papp2 (Oadd (Op_w U64)) @@ -258,35 +179,23 @@ Definition test_inline_var := {| v_var := {| vtype := sword U64; - vname := "n.138" |}; - v_info := - xO - (xO - (xO - (xI xH))) |}; + vname := "n.153" |}; + v_info := dummy_var_info |}; gs := Slocal |}) (Pvar {| gv := {| v_var := {| vtype := sword U64; - vname := "n.138" |}; - v_info := - xI - (xI - (xI - (xO xH))) |}; + vname := "n.153" |}; + v_info := dummy_var_info |}; gs := Slocal |}))))]; f_tyout := [sword U64]; f_res := [{| v_var := {| vtype := sword U64; - vname := "r.137" |}; - v_info := - xI - (xI - (xI - (xI xH))) |}]; + vname := "r.152" |}; + v_info := dummy_var_info |}]; f_extra := tt |})]; p_globs := []; p_extra := tt |} . \ No newline at end of file diff --git a/theories/Jasmin/examples/test_shift/test_shift.cprog b/theories/Jasmin/examples/test_shift.cprog similarity index 61% rename from theories/Jasmin/examples/test_shift/test_shift.cprog rename to theories/Jasmin/examples/test_shift.cprog index 66921c17..d9e8c511 100644 --- a/theories/Jasmin/examples/test_shift/test_shift.cprog +++ b/theories/Jasmin/examples/test_shift.cprog @@ -1,27 +1,33 @@ {Jasmin.Expr.p_funcs = - [(Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH, - {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH; + [(Jasmin.BinNums.Coq_xH, + {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH; f_tyin = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; f_params = [{Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = a.131}; + vname = a.142}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)}]; + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; f_body = [Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH), + (({Jasmin.Location.uid_loc = 2; + base_loc = + {Jasmin.Location.loc_fname = "test_shift.jazz"; + loc_start = (6, 2); loc_end = (6, 23); loc_bchar = 78; + loc_echar = 99}; + stack_loc = []}, + []), Jasmin.Expr.Cassgn (Jasmin.Expr.Lvar {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = u.132}; + vname = u.143}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)}, + {Jasmin.Location.loc_fname = "test_shift.jazz"; + loc_start = (6, 2); loc_end = (6, 3); loc_bchar = 78; + loc_echar = 79}}, Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U64, Jasmin.Expr.Papp2 (Jasmin.Expr.Osub Jasmin.Expr.Op_int, @@ -38,9 +44,10 @@ f_res = [{Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = u.132}; + vname = u.143}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)}]; + {Jasmin.Location.loc_fname = "test_shift.jazz"; + loc_start = (7, 9); loc_end = (7, 10); loc_bchar = 109; + loc_echar = 110}}]; f_extra = ()})]; p_globs = []; p_extra = ()} diff --git a/theories/Jasmin/examples/test_shift/test_shift.jazz b/theories/Jasmin/examples/test_shift.jazz similarity index 100% rename from theories/Jasmin/examples/test_shift/test_shift.jazz rename to theories/Jasmin/examples/test_shift.jazz diff --git a/theories/Jasmin/examples/test_shift/test_shift.v b/theories/Jasmin/examples/test_shift.v similarity index 69% rename from theories/Jasmin/examples/test_shift/test_shift.v rename to theories/Jasmin/examples/test_shift.v index 0e644534..9281fbd5 100644 --- a/theories/Jasmin/examples/test_shift/test_shift.v +++ b/theories/Jasmin/examples/test_shift.v @@ -5,31 +5,25 @@ From Jasmin Require Import x86_extra. Import ListNotations. Local Open Scope string. -Definition test_shift := - {| p_funcs := - [(xO xH, - {| f_info := xI xH; +Definition test_shift := {| p_funcs := + [(xH, + {| f_info := xO xH; f_tyin := [sword U64]; f_params := [{| v_var := {| vtype := sword U64; - vname := "a.131" |}; - v_info := - xO - (xO xH) |}]; + vname := "a.142" |}; + v_info := dummy_var_info |}]; f_body := [MkI - (xI - (xO xH)) + (dummy_instr_info) (Cassgn (Lvar {| v_var := {| vtype := sword U64; - vname := "u.132" |}; - v_info := - xO - (xI xH) |}) + vname := "u.143" |}; + v_info := dummy_var_info |}) (AT_none) (sword U64) (Papp1 (Oword_of_int U64) (Papp2 (Osub Op_int) @@ -46,10 +40,8 @@ Definition test_shift := f_res := [{| v_var := {| vtype := sword U64; - vname := "u.132" |}; - v_info := - xI - (xI xH) |}]; + vname := "u.143" |}; + v_info := dummy_var_info |}]; f_extra := tt |})]; p_globs := []; p_extra := tt |} . \ No newline at end of file diff --git a/theories/Jasmin/examples/three_functions/three_functions.cprog b/theories/Jasmin/examples/three_functions.cprog similarity index 50% rename from theories/Jasmin/examples/three_functions/three_functions.cprog rename to theories/Jasmin/examples/three_functions.cprog index d3ec96b6..1c863b6a 100644 --- a/theories/Jasmin/examples/three_functions/three_functions.cprog +++ b/theories/Jasmin/examples/three_functions.cprog @@ -1,29 +1,33 @@ {Jasmin.Expr.p_funcs = - [(Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH, - {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH; + [(Jasmin.BinNums.Coq_xH, + {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH; f_tyin = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; f_params = [{Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = z.139}; + vname = z.159}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)}]; + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; f_body = [Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)), + (({Jasmin.Location.uid_loc = 4; + base_loc = + {Jasmin.Location.loc_fname = "three_functions.jazz"; + loc_start = (15, 2); loc_end = (15, 10); loc_bchar = 212; + loc_echar = 220}; + stack_loc = []}, + []), Jasmin.Expr.Cassgn (Jasmin.Expr.Lvar {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = z.139}; + vname = z.159}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}, + {Jasmin.Location.loc_fname = "three_functions.jazz"; + loc_start = (15, 2); loc_end = (15, 3); loc_bchar = 212; + loc_echar = 213}}, Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, Jasmin.Expr.Papp2 (Jasmin.Expr.Oadd (Jasmin.Expr.Op_w Jasmin.Wsize.U64), @@ -32,11 +36,11 @@ {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = z.139}; + vname = z.159}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}; + {Jasmin.Location.loc_fname = "three_functions.jazz"; + loc_start = (15, 2); loc_end = (15, 3); loc_bchar = 212; + loc_echar = 213}}; gs = Jasmin.Expr.Slocal}, Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U64, Jasmin.Expr.Pconst @@ -47,131 +51,128 @@ (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))))))); Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH), + (({Jasmin.Location.uid_loc = 5; + base_loc = + {Jasmin.Location.loc_fname = "three_functions.jazz"; + loc_start = (16, 2); loc_end = (16, 15); loc_bchar = 223; + loc_echar = 236}; + stack_loc = []}, + []), Jasmin.Expr.Ccall (Jasmin.Expr.DoNotInline, [Jasmin.Expr.Lvar {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = res_z.140}; + vname = res_z.160}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}], - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH), + {Jasmin.Location.loc_fname = "three_functions.jazz"; + loc_start = (16, 2); loc_end = (16, 7); loc_bchar = 223; + loc_echar = 228}}], + Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH, [Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = z.139}; + vname = z.159}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)}; + {Jasmin.Location.loc_fname = "three_functions.jazz"; + loc_start = (16, 12); loc_end = (16, 13); loc_bchar = 233; + loc_echar = 234}}; gs = Jasmin.Expr.Slocal}]))]; f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; f_res = [{Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = res_z.140}; + vname = res_z.160}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}]; + {Jasmin.Location.loc_fname = "three_functions.jazz"; + loc_start = (17, 9); loc_end = (17, 14); loc_bchar = 246; + loc_echar = 251}}]; f_extra = ()}); - (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH), + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH, {Jasmin.Expr.f_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)); + Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH); f_tyin = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; f_params = [{Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = y.141}; + vname = y.161}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}]; + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; f_body = [Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)), + (({Jasmin.Location.uid_loc = 3; + base_loc = + {Jasmin.Location.loc_fname = "three_functions.jazz"; + loc_start = (9, 2); loc_end = (9, 15); loc_bchar = 130; + loc_echar = 143}; + stack_loc = []}, + []), Jasmin.Expr.Ccall (Jasmin.Expr.DoNotInline, [Jasmin.Expr.Lvar {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = res_y.142}; + vname = res_y.162}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}], + {Jasmin.Location.loc_fname = "three_functions.jazz"; + loc_start = (9, 2); loc_end = (9, 7); loc_bchar = 130; + loc_echar = 135}}], Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH), [Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = y.141}; + vname = y.161}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}; + {Jasmin.Location.loc_fname = "three_functions.jazz"; + loc_start = (9, 12); loc_end = (9, 13); loc_bchar = 140; + loc_echar = 141}}; gs = Jasmin.Expr.Slocal}]))]; f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; f_res = [{Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = res_y.142}; + vname = res_y.162}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}]; + {Jasmin.Location.loc_fname = "three_functions.jazz"; + loc_start = (10, 9); loc_end = (10, 14); loc_bchar = 153; + loc_echar = 158}}]; f_extra = ()}); - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), + (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH), {Jasmin.Expr.f_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))); + Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH); f_tyin = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; f_params = [{Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = x.143}; + vname = x.163}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}]; + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; f_body = [Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), + (({Jasmin.Location.uid_loc = 2; + base_loc = + {Jasmin.Location.loc_fname = "three_functions.jazz"; + loc_start = (3, 2); loc_end = (3, 14); loc_bchar = 49; + loc_echar = 61}; + stack_loc = []}, + []), Jasmin.Expr.Cassgn (Jasmin.Expr.Lvar {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = res_x.144}; + vname = res_x.164}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}, + {Jasmin.Location.loc_fname = "three_functions.jazz"; + loc_start = (3, 2); loc_end = (3, 7); loc_bchar = 49; + loc_echar = 54}}, Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, Jasmin.Expr.Papp2 (Jasmin.Expr.Oadd (Jasmin.Expr.Op_w Jasmin.Wsize.U64), @@ -180,12 +181,11 @@ {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = x.143}; + vname = x.163}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))}; + {Jasmin.Location.loc_fname = "three_functions.jazz"; + loc_start = (3, 10); loc_end = (3, 11); loc_bchar = 57; + loc_echar = 58}}; gs = Jasmin.Expr.Slocal}, Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U64, Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos Jasmin.BinNums.Coq_xH)))))]; @@ -193,11 +193,10 @@ f_res = [{Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = res_x.144}; + vname = res_x.164}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))}]; + {Jasmin.Location.loc_fname = "three_functions.jazz"; + loc_start = (4, 9); loc_end = (4, 14); loc_bchar = 71; + loc_echar = 76}}]; f_extra = ()})]; p_globs = []; p_extra = ()} diff --git a/theories/Jasmin/examples/three_functions/three_functions.jazz b/theories/Jasmin/examples/three_functions.jazz similarity index 100% rename from theories/Jasmin/examples/three_functions/three_functions.jazz rename to theories/Jasmin/examples/three_functions.jazz diff --git a/theories/Jasmin/examples/three_functions.v b/theories/Jasmin/examples/three_functions.v new file mode 100644 index 00000000..59e3c070 --- /dev/null +++ b/theories/Jasmin/examples/three_functions.v @@ -0,0 +1,147 @@ +Require Import List. +From Jasmin Require Import expr. +From Jasmin Require Import x86_extra. + +Import ListNotations. +Local Open Scope string. + +Definition three_functions := {| p_funcs := + [(xH, + {| f_info := xO xH; + f_tyin := [sword U64]; + f_params := + [{| v_var := + {| vtype := sword U64; + vname := "z.159" |}; + v_info := dummy_var_info |}]; + f_body := + [MkI + (dummy_instr_info) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "z.159" |}; + v_info := dummy_var_info |}) + (AT_none) (sword U64) + (Papp2 + (Oadd (Op_w U64)) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "z.159" |}; + v_info := dummy_var_info |}; + gs := Slocal |}) + (Papp1 (Oword_of_int U64) + (Pconst + (Zpos + (xO + (xI + (xO + (xI + (xO xH)))))))))); + MkI + (dummy_instr_info) + (Ccall (DoNotInline) + ([Lvar + {| v_var := + {| vtype := + sword U64; + vname := res_"z.160" |}; + v_info := dummy_var_info |}]) + (xI xH) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "z.159" |}; + v_info := dummy_var_info |}; + gs := Slocal |}]))]; + f_tyout := [sword U64]; + f_res := + [{| v_var := + {| vtype := sword U64; + vname := res_"z.160" |}; + v_info := dummy_var_info |}]; + f_extra := tt |}); + (xI xH, + {| f_info := + xO (xO xH); + f_tyin := [sword U64]; + f_params := + [{| v_var := + {| vtype := sword U64; + vname := "y.161" |}; + v_info := dummy_var_info |}]; + f_body := + [MkI + (dummy_instr_info) + (Ccall (DoNotInline) + ([Lvar + {| v_var := + {| vtype := + sword U64; + vname := res_"y.162" |}; + v_info := dummy_var_info |}]) + (xI + (xO xH)) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "y.161" |}; + v_info := dummy_var_info |}; + gs := Slocal |}]))]; + f_tyout := [sword U64]; + f_res := + [{| v_var := + {| vtype := sword U64; + vname := res_"y.162" |}; + v_info := dummy_var_info |}]; + f_extra := tt |}); + (xI (xO xH), + {| f_info := + xO (xI xH); + f_tyin := [sword U64]; + f_params := + [{| v_var := + {| vtype := sword U64; + vname := "x.163" |}; + v_info := dummy_var_info |}]; + f_body := + [MkI + (dummy_instr_info) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := res_"x.164" |}; + v_info := dummy_var_info |}) + (AT_none) (sword U64) + (Papp2 + (Oadd (Op_w U64)) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "x.163" |}; + v_info := dummy_var_info |}; + gs := Slocal |}) + (Papp1 (Oword_of_int U64) + (Pconst (Zpos xH)))))]; + f_tyout := [sword U64]; + f_res := + [{| v_var := + {| vtype := sword U64; + vname := res_"x.164" |}; + v_info := dummy_var_info |}]; + f_extra := tt |})]; + p_globs := []; p_extra := tt |} +. \ No newline at end of file diff --git a/theories/Jasmin/examples/three_functions/three_functions.v b/theories/Jasmin/examples/three_functions/three_functions.v deleted file mode 100644 index 0465456a..00000000 --- a/theories/Jasmin/examples/three_functions/three_functions.v +++ /dev/null @@ -1,291 +0,0 @@ -Set Warnings "-notation-overridden,-ambiguous-paths". -From mathcomp Require Import all_ssreflect all_algebra reals distr realsum - fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool ssrnum - eqtype choice seq. -Set Warnings "notation-overridden,ambiguous-paths". - -Require Import List. -From Jasmin Require Import expr. -From CoqWord Require Import word. -(* From Jasmin Require Import x86_extra. *) -From JasminSSProve Require Import jasmin_translate jasmin_utils. -From Crypt Require Import Prelude Package. - -Import ListNotations. -Import JasminNotation JasminCodeNotation. -Import PackageNotation. - -Local Open Scope string. - -Context `{asmop : asmOp}. - -Context {T} {pT : progT T}. - -Context {pd : PointerData}. - -Context (P : uprog). - -Context (f : funname). - -Definition three_functions := - {| p_funcs := - [(xO xH, - {| f_info := xI xH; - f_tyin := [sword U64]; - f_params := - [{| v_var := - {| vtype := sword U64; - vname := "z.139" |}; - v_info := - xO - (xO xH) |}]; - f_body := - [MkI - (xI - (xO - (xO xH))) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "z.139" |}; - v_info := - xI - (xI - (xO xH)) |}) - (AT_none) (sword U64) - (Papp2 - (Oadd (Op_w U64)) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "z.139" |}; - v_info := - xO - (xI - (xO xH)) |}; - gs := Slocal |}) - (Papp1 (Oword_of_int U64) - (Pconst - (Zpos - (xO - (xI - (xO - (xI - (xO xH)))))))))); - MkI - (xI - (xO xH)) - (Ccall (DoNotInline) - ([Lvar - {| v_var := - {| vtype := - sword U64; - vname := "res_z.140" |}; - v_info := - xO - (xO - (xO xH)) |}]) - (xI - (xI xH)) - ([Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "z.139" |}; - v_info := - xO - (xI xH) |}; - gs := Slocal |}]))]; - f_tyout := [sword U64]; - f_res := - [{| v_var := - {| vtype := sword U64; - vname := "res_z.140" |}; - v_info := - xO - (xO - (xI xH)) |}]; - f_extra := tt |}); - (xI (xI xH), - {| f_info := - xI - (xO (xI xH)); - f_tyin := [sword U64]; - f_params := - [{| v_var := - {| vtype := sword U64; - vname := "y.141" |}; - v_info := - xO - (xI - (xI xH)) |}]; - f_body := - [MkI - (xI - (xI - (xI xH))) - (Ccall (DoNotInline) - ([Lvar - {| v_var := - {| vtype := - sword U64; - vname := "res_y.142" |}; - v_info := - xO - (xI - (xO - (xO xH))) |}]) - (xI - (xO - (xO - (xO xH)))) - ([Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "y.141" |}; - v_info := - xO - (xO - (xO - (xO xH))) |}; - gs := Slocal |}]))]; - f_tyout := [sword U64]; - f_res := - [{| v_var := - {| vtype := sword U64; - vname := "res_y.142" |}; - v_info := - xI - (xI - (xO - (xO xH))) |}]; - f_extra := tt |}); - (xI - (xO - (xO (xO xH))), - {| f_info := - xO - (xO - (xI - (xO xH))); - f_tyin := [sword U64]; - f_params := - [{| v_var := - {| vtype := sword U64; - vname := "x.143" |}; - v_info := - xI - (xO - (xI - (xO xH))) |}]; - f_body := - [MkI - (xO - (xI - (xI - (xO xH)))) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "res_x.144" |}; - v_info := - xO - (xO - (xO - (xI xH))) |}) - (AT_none) (sword U64) - (Papp2 - (Oadd (Op_w U64)) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "x.143" |}; - v_info := - xI - (xI - (xI - (xO xH))) |}; - gs := Slocal |}) - (Papp1 (Oword_of_int U64) - (Pconst (Zpos xH)))))]; - f_tyout := [sword U64]; - f_res := - [{| v_var := - {| vtype := sword U64; - vname := "res_x.144" |}; - v_info := - xI - (xO - (xO - (xI xH))) |}]; - f_extra := tt |})]; - p_globs := []; p_extra := tt |} -. - - - - -Definition tr_P := Eval simpl in translate_prog' three_functions. -Definition default_prog' := (1%positive, fun s_id : p_id => (ret tt)). -Definition default_call := (1%positive, fun (s_id : p_id) (x : [choiceType of seq typed_chElement]) => ret x). -Definition get_tr sp n := List.nth_default default_call sp n. -Definition tr_f := Eval simpl in (get_tr tr_P.2 2). -Definition tr_g := Eval simpl in (get_tr tr_P.2 1). -Definition tr_h := Eval simpl in (get_tr tr_P.2 0). - - -Opaque translate_for. - -Goal forall goal v, tr_f.2 1%positive [('word U64; v)] = goal . - intros goal v. - unfold tr_f. - unfold get_tr. unfold tr_P. unfold translate_prog'. - unfold get_tr , tr_p. - simpl_fun. - - repeat setjvars. - - repeat setoid_rewrite coerce_to_choice_type_K. - repeat setoid_rewrite (@zero_extend_u U64). - -Admitted. - -Goal forall goal v, tr_g.2 1%positive [v] = goal. - intros goal v. - unfold tr_g. - unfold get_tr. unfold tr_P. - simpl_fun. - - repeat setjvars. - - repeat setoid_rewrite coerce_to_choice_type_K. - repeat setoid_rewrite (@zero_extend_u U64). - -Admitted. - -Goal forall goal v, tr_h.2 1%positive [v] = goal. - intros goal v. - unfold tr_h. - unfold get_tr. unfold tr_P. - simpl. - unfold translate_call_body. - simpl. - simpl_fun. - - repeat setjvars. - - repeat setoid_rewrite coerce_to_choice_type_K. - repeat setoid_rewrite (@zero_extend_u U64). - -Admitted. diff --git a/theories/Jasmin/examples/two_functions.cprog b/theories/Jasmin/examples/two_functions.cprog new file mode 100644 index 00000000..4188c0fc --- /dev/null +++ b/theories/Jasmin/examples/two_functions.cprog @@ -0,0 +1,109 @@ + {Jasmin.Expr.p_funcs = + [(Jasmin.BinNums.Coq_xH, + {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH; + f_tyin = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = y.150}; + v_info = + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; + f_body = + [Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 3; + base_loc = + {Jasmin.Location.loc_fname = "two_functions.jazz"; + loc_start = (9, 2); loc_end = (9, 15); loc_bchar = 130; + loc_echar = 143}; + stack_loc = []}, + []), + Jasmin.Expr.Ccall (Jasmin.Expr.DoNotInline, + [Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = res_y.151}; + v_info = + {Jasmin.Location.loc_fname = "two_functions.jazz"; + loc_start = (9, 2); loc_end = (9, 7); loc_bchar = 130; + loc_echar = 135}}], + Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH, + [Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = y.150}; + v_info = + {Jasmin.Location.loc_fname = "two_functions.jazz"; + loc_start = (9, 12); loc_end = (9, 13); loc_bchar = 140; + loc_echar = 141}}; + gs = Jasmin.Expr.Slocal}]))]; + f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = res_y.151}; + v_info = + {Jasmin.Location.loc_fname = "two_functions.jazz"; + loc_start = (10, 9); loc_end = (10, 14); loc_bchar = 153; + loc_echar = 158}}]; + f_extra = ()}); + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH, + {Jasmin.Expr.f_info = + Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH); + f_tyin = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = x.152}; + v_info = + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; + f_body = + [Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 2; + base_loc = + {Jasmin.Location.loc_fname = "two_functions.jazz"; + loc_start = (3, 2); loc_end = (3, 14); loc_bchar = 49; + loc_echar = 61}; + stack_loc = []}, + []), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = res_x.153}; + v_info = + {Jasmin.Location.loc_fname = "two_functions.jazz"; + loc_start = (3, 2); loc_end = (3, 7); loc_bchar = 49; + loc_echar = 54}}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Papp2 + (Jasmin.Expr.Oadd (Jasmin.Expr.Op_w Jasmin.Wsize.U64), + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = x.152}; + v_info = + {Jasmin.Location.loc_fname = "two_functions.jazz"; + loc_start = (3, 10); loc_end = (3, 11); loc_bchar = 57; + loc_echar = 58}}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U64, + Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos Jasmin.BinNums.Coq_xH)))))]; + f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = res_x.153}; + v_info = + {Jasmin.Location.loc_fname = "two_functions.jazz"; + loc_start = (4, 9); loc_end = (4, 14); loc_bchar = 71; + loc_echar = 76}}]; + f_extra = ()})]; + p_globs = []; p_extra = ()} diff --git a/theories/Jasmin/examples/two_functions/two_functions.jazz b/theories/Jasmin/examples/two_functions.jazz similarity index 100% rename from theories/Jasmin/examples/two_functions/two_functions.jazz rename to theories/Jasmin/examples/two_functions.jazz diff --git a/theories/Jasmin/examples/two_functions.v b/theories/Jasmin/examples/two_functions.v new file mode 100644 index 00000000..73e6ce4f --- /dev/null +++ b/theories/Jasmin/examples/two_functions.v @@ -0,0 +1,83 @@ +Require Import List. +From Jasmin Require Import expr. +From Jasmin Require Import x86_extra. + +Import ListNotations. +Local Open Scope string. + +Definition two_functions := {| p_funcs := + [(xH, + {| f_info := xO xH; + f_tyin := [sword U64]; + f_params := + [{| v_var := + {| vtype := sword U64; + vname := "y.150" |}; + v_info := dummy_var_info |}]; + f_body := + [MkI + (dummy_instr_info) + (Ccall (DoNotInline) + ([Lvar + {| v_var := + {| vtype := + sword U64; + vname := res_"y.151" |}; + v_info := dummy_var_info |}]) + (xI xH) + ([Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "y.150" |}; + v_info := dummy_var_info |}; + gs := Slocal |}]))]; + f_tyout := [sword U64]; + f_res := + [{| v_var := + {| vtype := sword U64; + vname := res_"y.151" |}; + v_info := dummy_var_info |}]; + f_extra := tt |}); + (xI xH, + {| f_info := + xO (xO xH); + f_tyin := [sword U64]; + f_params := + [{| v_var := + {| vtype := sword U64; + vname := "x.152" |}; + v_info := dummy_var_info |}]; + f_body := + [MkI + (dummy_instr_info) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := res_"x.153" |}; + v_info := dummy_var_info |}) + (AT_none) (sword U64) + (Papp2 + (Oadd (Op_w U64)) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "x.152" |}; + v_info := dummy_var_info |}; + gs := Slocal |}) + (Papp1 (Oword_of_int U64) + (Pconst (Zpos xH)))))]; + f_tyout := [sword U64]; + f_res := + [{| v_var := + {| vtype := sword U64; + vname := res_"x.153" |}; + v_info := dummy_var_info |}]; + f_extra := tt |})]; + p_globs := []; p_extra := tt |} +. \ No newline at end of file diff --git a/theories/Jasmin/examples/two_functions/two_functions.cprog b/theories/Jasmin/examples/two_functions/two_functions.cprog deleted file mode 100644 index 9d08d447..00000000 --- a/theories/Jasmin/examples/two_functions/two_functions.cprog +++ /dev/null @@ -1,102 +0,0 @@ - {Jasmin.Expr.p_funcs = - [(Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH, - {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH; - f_tyin = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; - f_params = - [{Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = y.134}; - v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)}]; - f_body = - [Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH), - Jasmin.Expr.Ccall (Jasmin.Expr.DoNotInline, - [Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = res_y.135}; - v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}], - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH), - [Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = y.134}; - v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)}; - gs = Jasmin.Expr.Slocal}]))]; - f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; - f_res = - [{Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = res_y.135}; - v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}]; - f_extra = ()}); - (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH), - {Jasmin.Expr.f_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)); - f_tyin = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; - f_params = - [{Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = x.136}; - v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}]; - f_body = - [Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)), - Jasmin.Expr.Cassgn - (Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = res_x.137}; - v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}, - Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, - Jasmin.Expr.Papp2 - (Jasmin.Expr.Oadd (Jasmin.Expr.Op_w Jasmin.Wsize.U64), - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = x.136}; - v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}; - gs = Jasmin.Expr.Slocal}, - Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U64, - Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos Jasmin.BinNums.Coq_xH)))))]; - f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; - f_res = - [{Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = res_x.137}; - v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}]; - f_extra = ()})]; - p_globs = []; p_extra = ()} diff --git a/theories/Jasmin/examples/two_functions/two_functions.v b/theories/Jasmin/examples/two_functions/two_functions.v deleted file mode 100644 index 3ba813c5..00000000 --- a/theories/Jasmin/examples/two_functions/two_functions.v +++ /dev/null @@ -1,233 +0,0 @@ -Set Warnings "-notation-overridden,-ambiguous-paths". -From mathcomp Require Import all_ssreflect all_algebra reals distr realsum - fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool ssrnum - eqtype choice seq. -Set Warnings "notation-overridden,ambiguous-paths". - -Require Import List. -From Jasmin Require Import expr. -(* From Jasmin Require Import x86_extra. *) -From JasminSSProve Require Import jasmin_translate. -From Crypt Require Import Prelude Package. - -Import ListNotations. -Local Open Scope string. - -Context `{asmop : asmOp}. - -Context {T} {pT : progT T}. - -Context {pd : PointerData}. - -Context (P : uprog). - -Context (f : funname). - -Definition two_functions := - {| p_funcs := - [(xO xH, - {| f_info := xI xH; - f_tyin := [sword U64]; - f_params := - [{| v_var := - {| vtype := sword U64; - vname := "y.134" |}; - v_info := - xO - (xO xH) |}]; - f_body := - [MkI - (xI - (xO xH)) - (Ccall (DoNotInline) - ([Lvar - {| v_var := - {| vtype := - sword U64; - vname := "res_y.135" |}; - v_info := - xO - (xO - (xO xH)) |}]) - (xI - (xI xH)) - ([Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "y.134" |}; - v_info := - xO - (xI xH) |}; - gs := Slocal |}]))]; - f_tyout := [sword U64]; - f_res := - [{| v_var := - {| vtype := sword U64; - vname := "res_y.135" |}; - v_info := - xI - (xO - (xO xH)) |}]; - f_extra := tt |}); - (xI (xI xH), - {| f_info := - xO - (xI (xO xH)); - f_tyin := [sword U64]; - f_params := - [{| v_var := - {| vtype := sword U64; - vname := "x.136" |}; - v_info := - xI - (xI - (xO xH)) |}]; - f_body := - [MkI - (xO - (xO - (xI xH))) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "res_x.137" |}; - v_info := - xO - (xI - (xI xH)) |}) - (AT_none) (sword U64) - (Papp2 - (Oadd (Op_w U64)) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "x.136" |}; - v_info := - xI - (xO - (xI xH)) |}; - gs := Slocal |}) - (Papp1 (Oword_of_int U64) - (Pconst (Zpos xH)))))]; - f_tyout := [sword U64]; - f_res := - [{| v_var := - {| vtype := sword U64; - vname := "res_x.137" |}; - v_info := - xI - (xI - (xI xH)) |}]; - f_extra := tt |})]; - p_globs := []; p_extra := tt |} -. - - -Import PackageNotation. -Notation coe_cht := coerce_to_choice_type. -Notation coe_tyc := coerce_typed_code. -Notation " 'array " := (chMap 'int ('word U8)) (at level 2) : package_scope. -Notation " 'array " := (chMap 'int ('word U8)) (in custom pack_type at level 2). -Notation " 'mem " := (chMap ('word Uptr) ('word U8)) (at level 2) : package_scope. -Notation " 'mem " := (chMap ('word Uptr) ('word U8)) (in custom pack_type at level 2). -Notation " ⸨ ws ⸩ a .[ ptr * scale ] " := (chArray_get ws a ptr scale) - (format " ⸨ ws ⸩ a .[ ptr * scale ] "). -Notation " a [ w / p ] " := - (chArray_set a AAscale p w) - (at level 99, no associativity, - format " a [ w / p ] "). - -From Equations Require Import Equations. -Set Equations With UIP. -Set Equations Transparent. - -From extructures Require Import ord fset fmap. - -Definition tr_P := Eval simpl in tr_p two_functions. -Definition default_prog' := (1%positive, fun s_id : p_id => (ret tt)). -Definition default_call := (1%positive, fun (s_id : p_id) (x : [choiceType of seq typed_chElement]) => ret x). -Definition get_tr sp n := List.nth_default default_call sp n. -Definition tr_f := Eval simpl in (get_tr tr_P 1). -Definition tr_g := Eval simpl in (get_tr tr_P 0). - -Lemma eq_rect_K : - forall (A : eqType) (x : A) (P : A -> Type) h e, - @eq_rect A x P h x e = h. -Proof. - intros A x P' h e. - replace e with (@erefl A x) by apply eq_irrelevance. - reflexivity. -Qed. - -From CoqWord Require Import word. - -Notation "$ i" := (_ ; nat_of_p_id_var _ {| vtype := _; vname := i |}) - (at level 99, format "$ i"). - -Notation "$$ i" := ({| v_var := {| vtype := _; vname := i |}; v_info := _ |}) - (at level 99, - format "$$ i"). - -Notation "'for var ∈ seq" := (translate_for _ ($$var) seq) - (at level 99). - -Ltac prog_unfold := unfold get_tr, translate_prog', tr_p, translate_prog, - translate_call, translate_call_body, - translate_write_lvals, translate_write_var, translate_instr, - translate_var, - coerce_chtuple_to_list, bind_list', bind_list_trunc_aux, - wsize_size, trunc_list, - List.nth_default. -Hint Rewrite coerce_typed_code_K eq_rect_K eq_rect_r_K : prog_rewrite. - -Opaque translate_for. -Ltac simpl_fun := - repeat (match goal with - | _ => progress autorewrite with prog_rewrite - | _ => prog_unfold; simpl - end). - -Goal forall goal v, tr_g.2 1%positive [v] = goal. - intros goal v. - unfold tr_g. - unfold get_tr. unfold tr_P. - simpl_fun. - simpl. - - (* BSH: the setoid_rewrites takes forever if we do not 'set' these names first *) - set (array32 := sarr 32%positive). - set (x := $"x.136"). - try set (res_x := $"res_x.137"). - try set (y := $"y.134"). - try set (yy := $$"y.134"). - try set (res_y := $"res_y.135"). - - repeat setoid_rewrite coerce_to_choice_type_K. - repeat setoid_rewrite (@zero_extend_u U64). - -Admitted. - - -Goal forall goal v, tr_f.2 1%positive [('word U64; v)] = goal . - intros goal v. - unfold tr_f. - unfold get_tr. unfold tr_P. unfold translate_prog'. - simpl_fun. - - (* BSH: the setoid_rewrites takes forever if we do not 'set' these names first *) - set (array32 := sarr 32%positive). - set (x := $"x.136"). - try set (res_x := $"res_x.137"). - try set (y := $"y.134"). - try set (res_y := $"res_y.135"). - - repeat setoid_rewrite (@zero_extend_u U64). - repeat setoid_rewrite coerce_to_choice_type_K. - -Admitted. diff --git a/theories/Jasmin/examples/u64_incr.cprog b/theories/Jasmin/examples/u64_incr.cprog new file mode 100644 index 00000000..67d68965 --- /dev/null +++ b/theories/Jasmin/examples/u64_incr.cprog @@ -0,0 +1,93 @@ + {Jasmin.Expr.p_funcs = + [(Jasmin.BinNums.Coq_xH, + {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH; + f_tyin = []; f_params = []; + f_body = + [Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 3; + base_loc = + {Jasmin.Location.loc_fname = "u64_incr.jazz"; + loc_start = (9, 2); loc_end = (9, 14); loc_bchar = 128; + loc_echar = 140}; + stack_loc = []}, + []), + Jasmin.Expr.Ccall (Jasmin.Expr.InlineFun, + [Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = x.148}; + v_info = + {Jasmin.Location.loc_fname = "u64_incr.jazz"; + loc_start = (9, 2); loc_end = (9, 3); loc_bchar = 128; + loc_echar = 129}}], + Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH, + [Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U64, + Jasmin.Expr.Pconst Jasmin.BinNums.Z0)]))]; + f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = x.148}; + v_info = + {Jasmin.Location.loc_fname = "u64_incr.jazz"; loc_start = (10, 9); + loc_end = (10, 10); loc_bchar = 150; loc_echar = 151}}]; + f_extra = ()}); + (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH, + {Jasmin.Expr.f_info = + Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH); + f_tyin = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_params = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = n.149}; + v_info = + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; + f_body = + [Jasmin.Expr.MkI + (({Jasmin.Location.uid_loc = 2; + base_loc = + {Jasmin.Location.loc_fname = "u64_incr.jazz"; + loc_start = (3, 3); loc_end = (3, 13); loc_bchar = 56; + loc_echar = 66}; + stack_loc = []}, + []), + Jasmin.Expr.Cassgn + (Jasmin.Expr.Lvar + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = m.150}; + v_info = + {Jasmin.Location.loc_fname = "u64_incr.jazz"; + loc_start = (3, 3); loc_end = (3, 4); loc_bchar = 56; + loc_echar = 57}}, + Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, + Jasmin.Expr.Papp2 + (Jasmin.Expr.Oadd (Jasmin.Expr.Op_w Jasmin.Wsize.U64), + Jasmin.Expr.Pvar + {Jasmin.Expr.gv = + {Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = + Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = n.149}; + v_info = + {Jasmin.Location.loc_fname = "u64_incr.jazz"; + loc_start = (3, 8); loc_end = (3, 9); loc_bchar = 61; + loc_echar = 62}}; + gs = Jasmin.Expr.Slocal}, + Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U64, + Jasmin.Expr.Pconst + (Jasmin.BinNums.Zpos + (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))]; + f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; + f_res = + [{Jasmin.Expr.v_var = + {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; + vname = m.150}; + v_info = + {Jasmin.Location.loc_fname = "u64_incr.jazz"; loc_start = (4, 10); + loc_end = (4, 11); loc_bchar = 77; loc_echar = 78}}]; + f_extra = ()})]; + p_globs = []; p_extra = ()} diff --git a/theories/Jasmin/examples/int_operations/u64_incr.jazz b/theories/Jasmin/examples/u64_incr.jazz similarity index 100% rename from theories/Jasmin/examples/int_operations/u64_incr.jazz rename to theories/Jasmin/examples/u64_incr.jazz diff --git a/theories/Jasmin/examples/u64_incr.v b/theories/Jasmin/examples/u64_incr.v new file mode 100644 index 00000000..e1bfa14a --- /dev/null +++ b/theories/Jasmin/examples/u64_incr.v @@ -0,0 +1,74 @@ +Require Import List. +From Jasmin Require Import expr. +From Jasmin Require Import x86_extra. + +Import ListNotations. +Local Open Scope string. + +Definition u64_incr := {| p_funcs := + [(xH, + {| f_info := xO xH; + f_tyin := []; f_params := []; + f_body := + [MkI + (dummy_instr_info) + (Ccall (InlineFun) + ([Lvar + {| v_var := + {| vtype := + sword U64; + vname := "x.148" |}; + v_info := dummy_var_info |}]) + (xI xH) + ([Papp1 (Oword_of_int U64) + (Pconst Z0)]))]; + f_tyout := [sword U64]; + f_res := + [{| v_var := + {| vtype := sword U64; + vname := "x.148" |}; + v_info := dummy_var_info |}]; + f_extra := tt |}); + (xI xH, + {| f_info := + xO (xO xH); + f_tyin := [sword U64]; + f_params := + [{| v_var := + {| vtype := sword U64; + vname := "n.149" |}; + v_info := dummy_var_info |}]; + f_body := + [MkI + (dummy_instr_info) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "m.150" |}; + v_info := dummy_var_info |}) + (AT_none) (sword U64) + (Papp2 + (Oadd (Op_w U64)) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "n.149" |}; + v_info := dummy_var_info |}; + gs := Slocal |}) + (Papp1 (Oword_of_int U64) + (Pconst + (Zpos + (xO xH))))))]; + f_tyout := [sword U64]; + f_res := + [{| v_var := + {| vtype := sword U64; + vname := "m.150" |}; + v_info := dummy_var_info |}]; + f_extra := tt |})]; + p_globs := []; p_extra := tt |} +. \ No newline at end of file diff --git a/theories/Jasmin/examples/xor/xor.cprog b/theories/Jasmin/examples/xor.cprog similarity index 52% rename from theories/Jasmin/examples/xor/xor.cprog rename to theories/Jasmin/examples/xor.cprog index d6157109..b1351cdf 100644 --- a/theories/Jasmin/examples/xor/xor.cprog +++ b/theories/Jasmin/examples/xor.cprog @@ -1,62 +1,66 @@ {Jasmin.Expr.p_funcs = - [(Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH, - {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH; + [(Jasmin.BinNums.Coq_xH, + {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH; f_tyin = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64; Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; f_params = [{Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = x.131}; + vname = x.143}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)}; + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}; {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = y.132}; + vname = y.144}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)}]; + {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); + loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; f_body = [Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)), + (({Jasmin.Location.uid_loc = 2; + base_loc = + {Jasmin.Location.loc_fname = "xor.jazz"; loc_start = (3, 2); + loc_end = (3, 8); loc_bchar = 64; loc_echar = 70}; + stack_loc = []}, + []), Jasmin.Expr.Cassgn (Jasmin.Expr.Lvar {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = r.133}; + vname = r.145}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}, + {Jasmin.Location.loc_fname = "xor.jazz"; loc_start = (3, 2); + loc_end = (3, 3); loc_bchar = 64; loc_echar = 65}}, Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = x.131}; + vname = x.143}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}; + {Jasmin.Location.loc_fname = "xor.jazz"; loc_start = (3, 6); + loc_end = (3, 7); loc_bchar = 68; loc_echar = 69}}; gs = Jasmin.Expr.Slocal})); Jasmin.Expr.MkI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH), + (({Jasmin.Location.uid_loc = 3; + base_loc = + {Jasmin.Location.loc_fname = "xor.jazz"; loc_start = (4, 2); + loc_end = (4, 9); loc_bchar = 73; loc_echar = 80}; + stack_loc = []}, + []), Jasmin.Expr.Cassgn (Jasmin.Expr.Lvar {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = r.133}; + vname = r.145}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}, + {Jasmin.Location.loc_fname = "xor.jazz"; loc_start = (4, 2); + loc_end = (4, 3); loc_bchar = 73; loc_echar = 74}}, Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, Jasmin.Expr.Papp2 (Jasmin.Expr.Olxor Jasmin.Wsize.U64, Jasmin.Expr.Pvar @@ -64,30 +68,28 @@ {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = r.133}; + vname = r.145}; v_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))}; + {Jasmin.Location.loc_fname = "xor.jazz"; loc_start = (4, 2); + loc_end = (4, 3); loc_bchar = 73; loc_echar = 74}}; gs = Jasmin.Expr.Slocal}, Jasmin.Expr.Pvar {Jasmin.Expr.gv = {Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = y.132}; + vname = y.144}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)}; + {Jasmin.Location.loc_fname = "xor.jazz"; loc_start = (4, 7); + loc_end = (4, 8); loc_bchar = 78; loc_echar = 79}}; gs = Jasmin.Expr.Slocal})))]; f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; f_res = [{Jasmin.Expr.v_var = {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; - vname = r.133}; + vname = r.145}; v_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))}]; + {Jasmin.Location.loc_fname = "xor.jazz"; loc_start = (5, 9); + loc_end = (5, 10); loc_bchar = 90; loc_echar = 91}}]; f_extra = ()})]; p_globs = []; p_extra = ()} diff --git a/theories/Jasmin/examples/xor/xor.jazz b/theories/Jasmin/examples/xor.jazz similarity index 100% rename from theories/Jasmin/examples/xor/xor.jazz rename to theories/Jasmin/examples/xor.jazz diff --git a/theories/Jasmin/examples/xor.v b/theories/Jasmin/examples/xor.v new file mode 100644 index 00000000..badbe633 --- /dev/null +++ b/theories/Jasmin/examples/xor.v @@ -0,0 +1,77 @@ +Require Import List. +From Jasmin Require Import expr. +From Jasmin Require Import x86_extra. + +Import ListNotations. +Local Open Scope string. + +Definition xor := {| p_funcs := + [(xH, + {| f_info := xO xH; + f_tyin := + [sword U64; + sword U64]; + f_params := + [{| v_var := + {| vtype := sword U64; + vname := "x.143" |}; + v_info := dummy_var_info |}; + {| v_var := + {| vtype := sword U64; + vname := "y.144" |}; + v_info := dummy_var_info |}]; + f_body := + [MkI + (dummy_instr_info) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "r.145" |}; + v_info := dummy_var_info |}) + (AT_none) (sword U64) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "x.143" |}; + v_info := dummy_var_info |}; + gs := Slocal |})); + MkI + (dummy_instr_info) + (Cassgn + (Lvar + {| v_var := + {| vtype := + sword U64; + vname := "r.145" |}; + v_info := dummy_var_info |}) + (AT_none) (sword U64) + (Papp2 (Olxor U64) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "r.145" |}; + v_info := dummy_var_info |}; + gs := Slocal |}) + (Pvar + {| gv := + {| v_var := + {| vtype := + sword U64; + vname := "y.144" |}; + v_info := dummy_var_info |}; + gs := Slocal |})))]; + f_tyout := [sword U64]; + f_res := + [{| v_var := + {| vtype := sword U64; + vname := "r.145" |}; + v_info := dummy_var_info |}]; + f_extra := tt |})]; + p_globs := []; p_extra := tt |} +. \ No newline at end of file diff --git a/theories/Jasmin/examples/xor/xor.v b/theories/Jasmin/examples/xor/xor.v deleted file mode 100644 index a25bd248..00000000 --- a/theories/Jasmin/examples/xor/xor.v +++ /dev/null @@ -1,175 +0,0 @@ -Set Warnings "-notation-overridden,-ambiguous-paths". -From mathcomp Require Import all_ssreflect all_algebra reals distr realsum - fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool ssrnum - eqtype choice seq. -Set Warnings "notation-overridden,ambiguous-paths". - -Require Import List. -From Jasmin Require Import expr. -From CoqWord Require Import word. -(* From Jasmin Require Import x86_extra. *) -From JasminSSProve Require Import jasmin_translate jasmin_utils. -From Crypt Require Import Prelude Package pkg_user_util. - -Import ListNotations. -Import JasminNotation JasminCodeNotation. -Import PackageNotation. - -Local Open Scope string. - -Context `{asmop : asmOp}. - -Context {T} {pT : progT T}. - -Context {pd : PointerData}. - -Context (P : uprog). - -Context (f : funname). - -Definition xor := - {| p_funcs := - [(xO xH, - {| f_info := xI xH; - f_tyin := - [sword U64; - sword U64]; - f_params := - [{| v_var := - {| vtype := sword U64; - vname := "x.131" |}; - v_info := - xO - (xO xH) |}; - {| v_var := - {| vtype := sword U64; - vname := "y.132" |}; - v_info := - xI - (xO xH) |}]; - f_body := - [MkI - (xO - (xI - (xO xH))) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "r.133" |}; - v_info := - xO - (xO - (xI xH)) |}) - (AT_none) (sword U64) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "x.131" |}; - v_info := - xI - (xI - (xO xH)) |}; - gs := Slocal |})); - MkI - (xO - (xI xH)) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "r.133" |}; - v_info := - xI - (xO - (xO xH)) |}) - (AT_none) (sword U64) - (Papp2 (Olxor U64) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "r.133" |}; - v_info := - xO - (xO - (xO xH)) |}; - gs := Slocal |}) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "y.132" |}; - v_info := - xI - (xI xH) |}; - gs := Slocal |})))]; - f_tyout := [sword U64]; - f_res := - [{| v_var := - {| vtype := sword U64; - vname := "r.133" |}; - v_info := - xI - (xO - (xI xH)) |}]; - f_extra := tt |})]; - p_globs := []; p_extra := tt |} -. - -Definition tr_P := Eval simpl in translate_prog' xor. -Definition default_prog' := (1%positive, fun s_id : p_id => (ret tt)). -Definition default_call := (1%positive, fun (s_id : p_id) (x : [choiceType of seq typed_chElement]) => ret x). -Definition get_tr sp n := List.nth_default default_call sp n. -Definition tr_xor := Eval simpl in (get_tr tr_P.2 0). - -Opaque translate_for. - -Goal forall goal w1 w2, tr_xor.2 1%positive [('word U64; w1); ('word U64; w2)] = goal . - intros goal. - unfold tr_xor. - unfold get_tr. - simpl_fun. - - repeat setjvars. - - repeat setoid_rewrite coerce_to_choice_type_K. - repeat setoid_rewrite (@zero_extend_u U64). - -Admitted. - -Ltac neq_loc_auto ::= eapply injective_translate_var3; auto. - -Import ListNotations. -Lemma f_xor_correct : forall w1 w2, ⊢ ⦃ fun _ => True ⦄ tr_xor.2 1%positive [('word U64; w1); ('word U64; w2)] ⇓ [('word U64; wxor w1 w2)] ⦃ fun _ => True ⦄. -Proof. - (* preprocessing *) - intros w1 w2. - simpl_fun. - repeat setjvars. - - (* this makes Qed hang *) - (* repeat setoid_rewrite (@zero_extend_u U64). *) - - (* proof *) - ssprove_swap_lhs 1. - ssprove_contract_put_get_lhs. - ssprove_swap_seq_lhs [:: 1 ; 0 ; 2 ; 1]. - ssprove_contract_put_get_lhs. - ssprove_swap_seq_lhs [:: 1 ; 0 ; 2 ; 1]. - ssprove_contract_put_get_lhs. - ssprove_swap_seq_lhs [:: 0 ; 2 ; 1 ]. - ssprove_contract_put_lhs. - ssprove_swap_seq_lhs [:: 2 ; 1 ]. - ssprove_contract_put_get_lhs. - repeat eapply u_put. - eapply u_ret. - rewrite !zero_extend_u. - easy. -Qed. From 607e038b4db699a4c055a91b86dfd4a1208f109b Mon Sep 17 00:00:00 2001 From: bshvass Date: Tue, 27 Sep 2022 14:11:50 +0200 Subject: [PATCH 272/383] minor fix, added test --- theories/Jasmin/examples/deextract.pl | 2 +- theories/Jasmin/examples/gen_and_test.sh | 15 ++ theories/Jasmin/examples/gen_ast.sh | 4 +- theories/Jasmin/examples/identity.v | 165 --------------------- theories/Jasmin/examples/three_functions.v | 12 +- theories/Jasmin/examples/two_functions.v | 8 +- 6 files changed, 29 insertions(+), 177 deletions(-) create mode 100755 theories/Jasmin/examples/gen_and_test.sh delete mode 100644 theories/Jasmin/examples/identity.v diff --git a/theories/Jasmin/examples/deextract.pl b/theories/Jasmin/examples/deextract.pl index 293f8b5a..2baa524b 100755 --- a/theories/Jasmin/examples/deextract.pl +++ b/theories/Jasmin/examples/deextract.pl @@ -11,7 +11,7 @@ $string =~ s/}/ |}/g ; $string =~ s/v_info :=[ \t\n]*[^{}]*{[^}]*}/v_info := dummy_var_info/g ; $string =~ s/(MkI[^(]*\()\(([^()]*(\([^)]*\))*)*\)/$1dummy_instr_info/g ; -$string =~ s/([[:alnum:]]*\.[[:alnum:]]*)/"$1"/g ; +$string =~ s/([[:graph:]]*\.[[:graph:]]*)/"$1"/g ; $string =~ s/\(\)/tt/g ; # curry functions diff --git a/theories/Jasmin/examples/gen_and_test.sh b/theories/Jasmin/examples/gen_and_test.sh new file mode 100755 index 00000000..237084b4 --- /dev/null +++ b/theories/Jasmin/examples/gen_and_test.sh @@ -0,0 +1,15 @@ +#!/bin/bash +# test deextraction of all .jazz in this folder, note that their corresponding .v will be overwritten + +# assuming jasmin is in home directory +for f in *.jazz +do +if [ $f != "aes.jazz" ] +then + JASMINC=~/jasmin/compiler/jasminc.byte ./gen_ast.sh $f + coqc $(basename $f .jazz).v +fi +done + +JASMINC=~/jasmin/compiler/jasminc.byte ./gen_ast.sh aes '-I AES:../examples' +coqc aes.v diff --git a/theories/Jasmin/examples/gen_ast.sh b/theories/Jasmin/examples/gen_ast.sh index b5b1d8f8..3855e607 100755 --- a/theories/Jasmin/examples/gen_ast.sh +++ b/theories/Jasmin/examples/gen_ast.sh @@ -1,8 +1,10 @@ #!/bin/bash +# you might have install the perl module Regexp::Common via cpan + # set path to jasminc.byte on command line by invoking the script with # JASMINC=... ./gen_ast.sh foo.jazz -JASMINC=${JASMINC:-$(which jasminc.byte)} +# JASMINC=${JASMINC:-$(which jasminc.byte)} # use this variable to e.g. include paths # e.g.: ./gen_ast.sh aes '-I AES:../examples' diff --git a/theories/Jasmin/examples/identity.v b/theories/Jasmin/examples/identity.v deleted file mode 100644 index 27e0de24..00000000 --- a/theories/Jasmin/examples/identity.v +++ /dev/null @@ -1,165 +0,0 @@ -(** - - translating simple functions/packages between Jasmin and SSProve - -*) - -From Relational Require Import OrderEnrichedCategory GenericRulesSimple. - -Set Warnings "-notation-overridden,-ambiguous-paths". -From mathcomp Require Import all_ssreflect all_algebra reals distr realsum - fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool ssrnum - eqtype choice seq. -Set Warnings "notation-overridden,ambiguous-paths". - -From Crypt Require Import Axioms chUniverse Package Prelude. - -From extructures Require Import ord fset. - -Import PackageNotation. - -From CoqWord Require Import word. - -Module Type Param. - - (* Parameter nbits : nat. *) - Definition chWord : chUniverse := chWord 64. - -End Param. - -Module Identity (param : Param). - - Import param. - - Notation " 'word " := - chWord - (in custom pack_type at level 2). - - Definition x : Location := (chWord ; 1%N). - - Local Open Scope package_scope. - - Definition IdentityLOC := fset [:: x]. - - (* Definition IdentityCode {L : {fset Location}} (i : chWord) : *) - (* code L [interface] chWord := *) - (* {code *) - (* y ← i ;; *) - (* ret y *) - (* }. *) - - Definition IdentityPackage : - package IdentityLOC - [interface] - [interface val #[10] : 'word → 'word ] := - [package - def #[10] (r : 'word) : 'word - { - put x := r ;; - r ← get x ;; - ret r - } - ]. - -End Identity. - -Require Import List. -From Jasmin Require Import expr. -From Crypt Require Import pkg_core_definition. - -Import ListNotations. - -Local Open Scope positive. -Local Open Scope string. - -Notation jas_prog := expr.prog. (* jasmin program *) - -Definition identity : jas_prog := - {| p_globs := []; - p_funcs := - [(1, - {| - f_iinfo := 2; - f_tyin := [sword U64]; - f_params := [{|v_var := {| - vtype := sword U64; - vname := "x.121" - |}; - v_info := xI xH|}]; - f_body := [MkI - (xO (xO xH)) - (Cassgn - (Lvar - {| v_var := - {| vtype := sword U64; - vname := "x.???" |}; (* fixme *) - v_info := xO (xI xH)|}) - AT_none - (sword U64) - (Pvar - {|v_var := - {| vtype := sword U64; - vname := "x.???" |}; (* fixme *) - v_info := xI (xO xH)|}))]; - f_tyout := [sword U64]; - f_res := [{|v_var := - {| vtype := sword U64; - vname := "x.???"|}; (* fixme *) - v_info := xI (xI xH) |}] - |})] - |}. - -(** original ocaml prog **) - -(* cprog: Jasmin.Expr.prog = *) -(* {Jasmin.Expr.p_globs = []; *) -(* p_funcs = *) -(* [(Jasmin.BinNums.Coq_xH, *) -(* {Jasmin.Expr.f_iinfo = Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH; *) -(* f_tyin = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; *) -(* f_params = *) -(* [{Jasmin.Expr.v_var = *) -(* {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; *) -(* vname = }; *) -(* v_info = Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH}]; *) -(* f_body = *) -(* [Jasmin.Expr.MkI *) -(* (Jasmin.BinNums.Coq_xO *) -(* (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH), *) -(* Jasmin.Expr.Cassgn *) -(* (Jasmin.Expr.Lvar *) -(* {Jasmin.Expr.v_var = *) -(* {Jasmin.Var0.Var.vtype = *) -(* Jasmin.Type.Coq_sword Jasmin.Wsize.U64; *) -(* vname = }; *) -(* v_info = *) -(* Jasmin.BinNums.Coq_xO *) -(* (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)}, *) -(* Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U64, *) -(* Jasmin.Expr.Pvar *) -(* {Jasmin.Expr.v_var = *) -(* {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; *) -(* vname = }; *) -(* v_info = *) -(* Jasmin.BinNums.Coq_xI *) -(* (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)}))]; *) -(* f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U64]; *) -(* f_res = *) -(* [{Jasmin.Expr.v_var = *) -(* {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U64; *) -(* vname = }; *) -(* v_info = *) -(* Jasmin.BinNums.Coq_xI *) -(* (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)}]})]} *) - -(** ec translation *) - -(* module M = { *) -(* proc identity (x:W64.t) : W64.t = { *) -(* var r:W64.t; *) -(* r <- x; *) -(* return (r); *) -(* } *) -(* }. *) - -(* todo: prove that these two have the same semantics *) diff --git a/theories/Jasmin/examples/three_functions.v b/theories/Jasmin/examples/three_functions.v index 59e3c070..340300ca 100644 --- a/theories/Jasmin/examples/three_functions.v +++ b/theories/Jasmin/examples/three_functions.v @@ -50,7 +50,7 @@ Definition three_functions := {| p_funcs := {| v_var := {| vtype := sword U64; - vname := res_"z.160" |}; + vname := "res_z.160" |}; v_info := dummy_var_info |}]) (xI xH) ([Pvar @@ -65,7 +65,7 @@ Definition three_functions := {| p_funcs := f_res := [{| v_var := {| vtype := sword U64; - vname := res_"z.160" |}; + vname := "res_z.160" |}; v_info := dummy_var_info |}]; f_extra := tt |}); (xI xH, @@ -85,7 +85,7 @@ Definition three_functions := {| p_funcs := {| v_var := {| vtype := sword U64; - vname := res_"y.162" |}; + vname := "res_y.162" |}; v_info := dummy_var_info |}]) (xI (xO xH)) @@ -101,7 +101,7 @@ Definition three_functions := {| p_funcs := f_res := [{| v_var := {| vtype := sword U64; - vname := res_"y.162" |}; + vname := "res_y.162" |}; v_info := dummy_var_info |}]; f_extra := tt |}); (xI (xO xH), @@ -121,7 +121,7 @@ Definition three_functions := {| p_funcs := {| v_var := {| vtype := sword U64; - vname := res_"x.164" |}; + vname := "res_x.164" |}; v_info := dummy_var_info |}) (AT_none) (sword U64) (Papp2 @@ -140,7 +140,7 @@ Definition three_functions := {| p_funcs := f_res := [{| v_var := {| vtype := sword U64; - vname := res_"x.164" |}; + vname := "res_x.164" |}; v_info := dummy_var_info |}]; f_extra := tt |})]; p_globs := []; p_extra := tt |} diff --git a/theories/Jasmin/examples/two_functions.v b/theories/Jasmin/examples/two_functions.v index 73e6ce4f..306659e8 100644 --- a/theories/Jasmin/examples/two_functions.v +++ b/theories/Jasmin/examples/two_functions.v @@ -22,7 +22,7 @@ Definition two_functions := {| p_funcs := {| v_var := {| vtype := sword U64; - vname := res_"y.151" |}; + vname := "res_y.151" |}; v_info := dummy_var_info |}]) (xI xH) ([Pvar @@ -37,7 +37,7 @@ Definition two_functions := {| p_funcs := f_res := [{| v_var := {| vtype := sword U64; - vname := res_"y.151" |}; + vname := "res_y.151" |}; v_info := dummy_var_info |}]; f_extra := tt |}); (xI xH, @@ -57,7 +57,7 @@ Definition two_functions := {| p_funcs := {| v_var := {| vtype := sword U64; - vname := res_"x.153" |}; + vname := "res_x.153" |}; v_info := dummy_var_info |}) (AT_none) (sword U64) (Papp2 @@ -76,7 +76,7 @@ Definition two_functions := {| p_funcs := f_res := [{| v_var := {| vtype := sword U64; - vname := res_"x.153" |}; + vname := "res_x.153" |}; v_info := dummy_var_info |}]; f_extra := tt |})]; p_globs := []; p_extra := tt |} From df0467ad40f1ffeccc73724df946dabb95dc8da7 Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Thu, 29 Sep 2022 22:38:59 +0100 Subject: [PATCH 273/383] fix compilation errors Now compiles (for me) with Coq.8.15.2, coq-mathcomp-ssreflect.1.14.0, and jasmin 3d40bc89. --- theories/Crypt/rules/UniformStateProb.v | 4 ++-- theories/Mon/FiniteProbabilities.v | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/theories/Crypt/rules/UniformStateProb.v b/theories/Crypt/rules/UniformStateProb.v index caa9c1b8..b918d168 100644 --- a/theories/Crypt/rules/UniformStateProb.v +++ b/theories/Crypt/rules/UniformStateProb.v @@ -221,12 +221,12 @@ Proof. rewrite ler_pmul2l. * rewrite ler_int. auto. * unfold r. apply mulr_gt0. - -- cbn. rewrite posnum.one_pos_gt0. reflexivity. + -- cbn. exact ltr01. -- rewrite -(@pmulr_rgt0 _ #|F1|%:~R). ++ rewrite -(GRing.mul1r (#|F1|%:~R / #|F1|%:~R)). rewrite GRing.mulrA. rewrite GRing.Theory.mulfK. - ** rewrite posnum.one_pos_gt0. reflexivity. + ** exact ltr01. ** unshelve eapply card_non_zero. auto. ++ eapply fintype0 in w0 as h. destruct #|F1| eqn:e. 1: contradiction. diff --git a/theories/Mon/FiniteProbabilities.v b/theories/Mon/FiniteProbabilities.v index 9f20964f..c0fdb857 100644 --- a/theories/Mon/FiniteProbabilities.v +++ b/theories/Mon/FiniteProbabilities.v @@ -81,7 +81,7 @@ Section FinProb. #[program] Definition barycentric_sum (p:I) (x y: I) : I := ⦑ p∙1 * x∙1 + (1-p∙1) * y∙1 ⦒. Next Obligation. - simpl. intros p x y. + intros p x y. simpl. set p' : I := negI p; change (1-p∙1) with p'∙1. rewrite addr_ge0 ?mulr_ge0 //. have: (1 = p∙1*1 + (1 - p∙1)*1) by rewrite !mulr1 addrA [_+1]addrC addrK. From e7f27b84ddb921e19bd45057433a10e1ab15d785 Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Thu, 29 Sep 2022 22:39:16 +0100 Subject: [PATCH 274/383] fix and silence warnings --- theories/Jasmin/jasmin_translate.v | 19 +++++++++++-------- theories/Jasmin/jasmin_utils.v | 2 +- 2 files changed, 12 insertions(+), 9 deletions(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 5eb767c4..af1c53f9 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -5,11 +5,14 @@ From Jasmin Require Import expr compiler_util values sem. Set Warnings "ambiguous-paths,notation-overridden,notation-incompatible-format". From extructures Require Import ord fset fmap. +Set Warnings "-ambiguous-paths". +(* Silencing the following warning: *) +(* New coercion path [Pbool] : bool >-> pexpr is ambiguous with existing *) +(* [nat_of_bool; Posz; int_to_Z; Pconst] : bool >-> pexpr. *) From Jasmin Require Import expr_facts. +Set Warnings "ambiguous-paths". From Coq Require Import Utf8. -Set Warnings "-ambiguous-paths,-notation-overridden,-notation-incompatible-format". -Set Warnings "ambiguous-paths,notation-overridden,notation-incompatible-format". From Crypt Require Import Prelude Package. Import PackageNotation. @@ -112,7 +115,7 @@ Infix "⪯" := preceq (at level 70). Definition prec i1 i2 := i1 ⪯ i2 /\ i1 <> i2. Infix "≺" := prec (at level 70). -Instance preceq_trans : Transitive preceq. +#[export] Instance preceq_trans : Transitive preceq. Proof. intros i1 i2 i3 hi1 hi2. induction hi2. @@ -125,7 +128,7 @@ Proof. assumption. Qed. -Instance preceq_refl : Reflexive preceq. +#[export] Instance preceq_refl : Reflexive preceq. Proof. intros i. induction i; constructor; assumption. Qed. @@ -245,7 +248,7 @@ Proof. assumption. Qed. -Instance preceq_antisym : Antisymmetric _ _ preceq. +#[export] Instance preceq_antisym : Antisymmetric _ _ preceq. Proof. intros i1 i2 h1 h2. apply preceq_size in h1 as hsize1. @@ -289,7 +292,7 @@ Proof. apply H. Qed. -Instance prec_trans : Transitive prec. +#[export] Instance prec_trans : Transitive prec. Proof. intros i1 i2 i3. intros [hpre1 hneq1] [hpre2 hneq2]. @@ -349,7 +352,7 @@ Proof. apply contra. reflexivity. Qed. -Instance disj_sym : Symmetric disj. +#[export] Instance disj_sym : Symmetric disj. Proof. intros i1 i2 hi1 i3 hi2. intros contra. @@ -393,7 +396,7 @@ Proof. eapply disj_prec_r; eauto. Qed. -Hint Resolve fresh1 fresh2 fresh1_weak fresh2_weak preceq_refl preceq_trans prec_trans : prefix. +#[export] Hint Resolve fresh1 fresh2 fresh1_weak fresh2_weak preceq_refl preceq_trans prec_trans : prefix. (* Unary judgment concluding on evaluation of program *) diff --git a/theories/Jasmin/jasmin_utils.v b/theories/Jasmin/jasmin_utils.v index 8d78f1d8..092c2d70 100644 --- a/theories/Jasmin/jasmin_utils.v +++ b/theories/Jasmin/jasmin_utils.v @@ -126,7 +126,7 @@ Ltac prog_unfold := unfold translate_prog', translate_prog, List.nth_default. -Hint Rewrite coerce_typed_code_K eq_rect_K eq_rect_r_K : prog_rewrite. +#[export] Hint Rewrite coerce_typed_code_K eq_rect_K eq_rect_r_K : prog_rewrite. Ltac simpl_fun := repeat (match goal with From d0cddee3a2b8fdc75dd6c88f8b17d44913d42f2a Mon Sep 17 00:00:00 2001 From: bshvass Date: Fri, 7 Oct 2022 14:40:55 +0200 Subject: [PATCH 275/383] xor example --- theories/Jasmin/examples/xor/xor.v | 573 +++++++++++++++++++++++++++++ theories/Jasmin/jasmin_translate.v | 197 ++++++++-- 2 files changed, 744 insertions(+), 26 deletions(-) create mode 100644 theories/Jasmin/examples/xor/xor.v diff --git a/theories/Jasmin/examples/xor/xor.v b/theories/Jasmin/examples/xor/xor.v new file mode 100644 index 00000000..528885d3 --- /dev/null +++ b/theories/Jasmin/examples/xor/xor.v @@ -0,0 +1,573 @@ +Set Warnings "-notation-overridden,-ambiguous-paths". +From mathcomp Require Import all_ssreflect all_algebra reals distr realsum + fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool ssrnum + eqtype choice seq. +Set Warnings "notation-overridden,ambiguous-paths". + +Require Import List. +From Jasmin Require Import expr. +From Jasmin Require Import x86_extra. +From mathcomp.word Require Import word. +(* From Jasmin Require Import x86_extra. *) +From JasminSSProve Require Import jasmin_translate jasmin_utils. +From Crypt Require Import Prelude Package pkg_user_util. + +Import ListNotations. +Import JasminNotation JasminCodeNotation. +Import PackageNotation. + +Local Open Scope string. + +Context `{asmop : asmOp}. + +Context {T} {pT : progT T}. + +Context {pd : PointerData}. + +Context (P : uprog). + +Context (f : funname). + +Definition xor : uprog. +Proof. + refine {| p_funcs := + [ ( (* xor *) xH, + {| f_info := xO xH + ; f_tyin := [(sword U64); (sword U64)] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "x.143" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U64) + ; vname := "y.144" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := {| vtype := (sword U64) + ; vname := "r.145" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "x.143" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := {| vtype := (sword U64) + ; vname := "r.145" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp2 (Olxor U64) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "r.145" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "y.144" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))) ] + ; f_tyout := [(sword U64)] + ; f_res := + [{| v_var := {| vtype := (sword U64) + ; vname := "r.145" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) ] ; + p_globs := [] ; + p_extra := tt |}. +Defined. + +Definition tr_P := Eval simpl in translate_prog' xor. +Definition default_prog' := (1%positive, fun s_id : p_id => (ret tt)). +Definition default_call := (1%positive, fun (s_id : p_id) (x : [choiceType of seq typed_chElement]) => ret x). +Definition get_tr sp n := List.nth_default default_call sp n. +Definition tr_xor := Eval simpl in (get_tr tr_P.2 0). + +Opaque translate_for. + +Ltac neq_loc_auto ::= eapply injective_translate_var3; auto. + +Lemma f_xor_correct : forall w1 w2, ⊢ ⦃ fun _ => True ⦄ tr_xor.2 1%positive [('word U64; w1); ('word U64; w2)] ⇓ [('word U64; wxor w1 w2)] ⦃ fun _ => True ⦄. +Proof. + (* preprocessing *) + intros w1 w2. + simpl_fun. + repeat setjvars. + + (* this makes Qed hang *) + (* repeat setoid_rewrite (@zero_extend_u U64). *) + + (* proof *) + ssprove_swap_lhs 1. + ssprove_contract_put_get_lhs. + ssprove_swap_seq_lhs [:: 1 ; 0 ; 2 ; 1]. + ssprove_contract_put_get_lhs. + ssprove_swap_seq_lhs [:: 1 ; 0 ; 2 ; 1]. + ssprove_contract_put_get_lhs. + ssprove_swap_seq_lhs [:: 0 ; 2 ; 1 ]. + ssprove_contract_put_lhs. + ssprove_swap_seq_lhs [:: 2 ; 1 ]. + ssprove_contract_put_get_lhs. + repeat eapply u_put. + eapply u_ret. + rewrite !zero_extend_u. + easy. +Qed. + +(* + OTP example +*) + +From Relational Require Import OrderEnrichedCategory GenericRulesSimple. + +Set Warnings "-notation-overridden,-ambiguous-paths,-notation-incompatible-format". +From mathcomp Require Import all_ssreflect all_algebra reals distr + fingroup.fingroup realsum ssrnat ssreflect ssrfun ssrbool ssrnum eqtype choice + seq. +Set Warnings "notation-overridden,ambiguous-paths,notation-incompatible-format". + +From Crypt Require Import Axioms ChoiceAsOrd SubDistr Couplings + UniformDistrLemmas FreeProbProg Theta_dens RulesStateProb UniformStateProb + pkg_composition pkg_rhl Package Prelude. + +From Coq Require Import Utf8 Lia. +From extructures Require Import ord fset fmap. + +From Equations Require Import Equations. +Require Equations.Prop.DepElim. + +Set Equations With UIP. + +Set Bullet Behavior "Strict Subproofs". +Set Default Goal Selector "!". +Set Primitive Projections. + +Import Num.Def. +Import Num.Theory. + +#[local] Open Scope ring_scope. +From mathcomp.word Require Import ssrZ. + +Import GRing Order TotalTheory. +(* We could just use these, but to get the proper size, we copy paste the proofs from ordinals *) +(* Definition word_finMixin n := Eval hnf in CanFinMixin (@ord_of_wordK n). *) +(* Canonical word_finType n := Eval hnf in FinType (n.-word) (word_finMixin n). *) +Section word_fin. + + Variable n : nat. + Notation word := (word n). + + Definition word_enum : seq word := pmap insub (ziota 0 (modulus n)). + + Lemma val_word_enum : map val word_enum = ziota 0 (modulus n). + Proof. + rewrite pmap_filter; last exact: insubK. + by apply/all_filterP/allP=> i; rewrite in_ziota isSome_insub. + Qed. + + Lemma ltzS x y : (x < Z.succ y) = (x <= y). + Proof. + apply/idP. unfold le, lt=>//=. + destruct (Z.leb _ _) eqn:E. + - apply Z.ltb_lt. lia. + - intros contra. + apply Z.ltb_lt in contra. lia. + Qed. + + Lemma ltSz x y : (Z.succ x <= y) = (x < y). + apply/idP. unfold le, lt=>//=. + destruct (Z.ltb _ _) eqn:E. + - apply Z.leb_le. + lia. + - intros contra. + apply Z.leb_le in contra. lia. + Qed. + Lemma addzS x y : (x + Z.succ y) = Z.succ (x + y). + Proof. by unfold add => //=; rewrite Z.add_succ_r. Qed. + + Lemma addSz x y : (Z.succ x + y) = Z.succ (x + y). + Proof. by unfold add => //=; rewrite Z.add_succ_l. Qed. + + Lemma mem_ziota m k i : (i \in ziota m k) = (m <= i < m + k). + Proof. + destruct (Z.leb 0 k) eqn:E. + - move: m. eapply natlike_ind with (x:=k). + + intros m. by rewrite addr0 ltNge andbN. + + intros x Hx Hi m. + rewrite ziotaS_cons; [|assumption]. + apply Z.leb_le in Hx. + by rewrite in_cons Hi addzS addSz ltzS ltSz; case: ltgtP => //= ->; rewrite ler_addl. + + by apply Z.leb_le. + - rewrite ziota_neg. + + rewrite in_nil. + apply/idP. unfold le, lt=>//=. + destruct ((Z.leb m i) && (Z.ltb i (m + k)%R)%Z) eqn:E2=>//=. + unfold add in E2. simpl in E2. lia. + + lia. + Qed. + + Lemma ziota_uniq i j : uniq (ziota i j). + Proof. + unfold ziota. + rewrite map_inj_uniq. + - apply iota_uniq. + - intros x y. lia. + Qed. + + Lemma word_enum_uniq : uniq word_enum. + Proof. by rewrite pmap_sub_uniq ?ziota_uniq. Qed. + + Lemma word_inj : injective (@toword n). + Proof. exact val_inj. Qed. + + Lemma mem_word_enum i : i \in word_enum. + Proof. by rewrite -(mem_map word_inj) val_word_enum mem_ziota add0r; case: i. Qed. + + Definition word_finMixin := + Eval hnf in UniqFinMixin word_enum_uniq mem_word_enum. + Canonical word_finType := Eval hnf in FinType word word_finMixin. + Canonical word_subFinType := Eval hnf in [subFinType of word]. + Canonical finEnum_unlock := Unlockable Finite.EnumDef.enumDef. + + (* can't get `enum` in `val_enum_word` to work without this import *) + From mathcomp Require Import fintype. + + Lemma val_enum_word : map val (enum [finType of word]) = ziota 0 (modulus n). + Proof. by rewrite enumT unlock val_word_enum. Qed. + + Lemma size_enum_word : size (enum [finType of word]) = Z.to_nat (modulus n). + Proof. by rewrite -(size_map val) val_enum_word size_ziota. Qed. + +End word_fin. + +Section word_uniform. + + Definition fin_family_word (i : wsize.wsize) : finType := [finType of chWord i]. + Lemma F_w0_word : + forall i, fin_family_word i. + Proof. + intros i. unfold fin_family_word. cbn. + exists (word1 i). apply isword1. + Qed. + + Definition Uni_W_word : forall i, SDistr (fin_family_word i). + move=> i. apply (@uniform_F (fin_family_word i)). + apply F_w0_word. + Defined. + + Definition uniform_word (i : wsize.wsize) : Op := + existT _ ('word i) (Uni_W_word i). + + #[export] Instance LosslessOp_uniform_word i : LosslessOp (uniform_word i). + Proof. + unfold LosslessOp. + simpl. + unfold r. rewrite psumZ. 2: apply ler0n. + simpl. rewrite GRing.mul1r. + rewrite psum_fin. rewrite cardE. + rewrite size_enum_word. simpl. + rewrite GRing.sumr_const. rewrite cardE. rewrite size_enum_word. + rewrite -normrMn. + rewrite -GRing.Theory.mulr_natr. + rewrite GRing.mulVf. + 2:{ + apply /negP => e. + rewrite intr_eq0 in e. + move: e => /eqP e. + assert (forall p, Pos.to_nat p <> 0%nat). + { intros p. pose proof (Pos2Nat.is_pos p). lia. } + eapply H. injection e. intros ?. + eassumption. + } + rewrite normr1. reflexivity. + Qed. + +End word_uniform. + +Notation "m ⊕ k" := (@wxor _ m k) (at level 70). + +Section wxor. + + Context (n : wsize.wsize). + Notation word := (word n). + + Lemma wxor_involutive : ∀ m k : word, (m ⊕ k) ⊕ k = m. + Proof. + intros m k. + apply/eqP/eq_from_wbit=> i. + by rewrite !wxorE -addbA addbb addbF. + Qed. + + Lemma wxorC : ∀ m k : word, (m ⊕ k) = (k ⊕ m). + Proof. + intros m k. + apply/eqP/eq_from_wbit=> i. + by rewrite !wxorE addbC. + Qed. + + Lemma wxorA : ∀ m k l : word, ((m ⊕ k) ⊕ l) = (m ⊕ (k ⊕ l)). + Proof. + intros m k l. + apply/eqP/eq_from_wbit=> i. + by rewrite !wxorE addbA. + Qed. + +End wxor. + +Section OTP_example. + + Context (n : wsize.wsize). + Notation word := (word n). + + #[local] Open Scope package_scope. + + Definition i1 : nat := 0. + + Definition Enc {L : {fset Location}} (m : word) (k : word) : + code L [interface] ('word n) := + {code + ret (m ⊕ k) + }. + + Notation N := ((2 ^ n).-1.+1). + + #[export] Instance : Positive N. + Proof. red; by rewrite prednK_modulus expn_gt0. Qed. + + #[export] Instance word_pos (i : wsize.wsize) : Positive i. + Proof. by case i. Qed. + + Definition KeyGen {L : {fset Location}} : + code L [interface] ('word n) := + {code + k ← sample uniform N ;; + ret (word_of_ord k) + }. + + Definition dec {L : {fset Location }}(c : word) (k : word) : + code L [interface] 'word n := Enc k c. + + Definition IND_CPA_location : {fset Location} := fset0. + + (* REM: Key is always sampled at the side of the encrypter. *) + (* This assumption is stronger than usual crypto definitions. *) + (* We need control over the key to apply coupling. *) + Notation " 'word " := (chWord n) (in custom pack_type at level 2). + + Definition IND_CPA_real : + package IND_CPA_location + [interface] + [interface #val #[i1] : 'word → 'word ] := + [package + #def #[i1] (m : 'word) : 'word + { + k_val ← sample uniform N ;; + r ← Enc m (word_of_ord k_val) ;; + ret r + } + ]. + + Definition IND_CPA_ideal : + package IND_CPA_location + [interface ] + [interface #val #[i1] : 'word → 'word ] := + [package + #def #[i1] (m : 'word) : 'word + { + m' ← sample uniform N ;; + k_val ← sample uniform N ;; + r ← Enc (word_of_ord m') (word_of_ord k_val) ;; + ret r + } + ]. + + Definition IND_CPA : loc_GamePair [interface #val #[i1] : 'word → 'word ] := + λ b, if b then {locpackage IND_CPA_real } else {locpackage IND_CPA_ideal }. + + #[local] Open Scope ring_scope. + + From Crypt Require Import pkg_distr. + Notation IN := 'I_N. + Coercion word_of_ord : IN >-> word. + + Lemma IND_CPA_ideal_real : + IND_CPA false ≈₀ IND_CPA true. + Proof. + eapply eq_rel_perf_ind_eq. + simplify_eq_rel m. + (* TODO Why doesn't it infer this? *) + eapply r_const_sample_L with (op := uniform _). + 1: exact _. intro m_val. + pose (f := + λ (k : Arit (uniform N)), + ord_of_word ((word_of_ord k) ⊕ m ⊕ (word_of_ord m_val)) + ). + assert (bij_f : bijective f). + { subst f. + exists (λ x, ord_of_word ((word_of_ord x) ⊕ (word_of_ord m_val) ⊕ m)). + - intro x. by rewrite ord_of_wordK !wxor_involutive word_of_ordK. + - intro x. by rewrite ord_of_wordK !wxor_involutive word_of_ordK. + } + eapply r_uniform_bij with (1 := bij_f). intro k_val. + apply r_ret. intros s₀ s₁ e. intuition auto. + subst f. simpl. + rewrite ord_of_wordK. + rewrite !wxorA 2![_ m _]wxorC wxorA wxor_involutive. + by rewrite wxorC. + Qed. + + Theorem unconditional_secrecy : + ∀ LA A, + ValidPackage LA + [interface #val #[i1] : 'word → 'word ] A_export A → + Advantage IND_CPA A = 0. + Proof. + intros LA A vA. + rewrite Advantage_E. eapply IND_CPA_ideal_real. 1: eauto. + all: eapply fdisjoints0. + Qed. + +End OTP_example. + +Section Jasmin_OTP. + + (* Context (n : wsize.wsize). *) + Definition n := U64. + Notation word := (word n). + Notation " 'word " := (chWord n) : package_scope. + Notation " 'word " := (chWord n) (in custom pack_type at level 2) : package_scope. + Notation N := ((2 ^ n).-1.+1). + + Definition id0 : BinNums.positive := 1. + + Definition xor_locs := + [fset + (translate_var id0 {| vtype := sword n ; vname := "x.143" |}) ; + (translate_var id0 {| vtype := sword n ; vname := "y.144" |}) ; + (translate_var id0 {| vtype := sword n ; vname := "r.145" |}) + ]. + + Ltac neq_loc_auto ::= eapply injective_translate_var3; auto. + + #[local] Open Scope package_scope. + + Program Definition JasminEnc (m : 'word n) (k : 'word n) : (* why can't I just use 'word here? *) + code xor_locs [interface] ('word n) := + {code + e ← tr_xor.2 id0 [:: totce m; totce k] ;; + ret (coerce_to_choice_type _ (hd (totce (chCanonical ('word n))) e).π2) + }. + Next Obligation. + unfold xor_locs. unfold n. + repeat constructor; repeat rewrite in_fset in_cons; + repeat match goal with + | [ |- is_true (orb (translate_var ?i1 ?v1 == translate_var ?i1 ?v1) _) ] => + apply/orP; left; by rewrite translate_var_eq + | |- is_true (orb _ _) => apply/orP; right + end. + Defined. + + Program Definition JasminDec {L : {fset Location }}(c : 'word n) (k : 'word n) : + code xor_locs [interface] 'word n := JasminEnc k c. + + Program Definition IND_CPA_jasmin : + package xor_locs + [interface] + [interface #val #[i1] : 'word → 'word ] := + [package + #def #[i1] (m : 'word) : 'word + { + k_val ← sample uniform N ;; + r ← JasminEnc m (word_of_ord k_val) ;; + ret r + } + ]. + + Definition IND_CPA_jasmin_real_game : loc_GamePair [interface #val #[i1] : 'word → 'word ] := + λ b, if b then {locpackage IND_CPA_jasmin } else {locpackage (IND_CPA_real n) }. + Definition IND_CPA_jasmin_ideal_game : loc_GamePair [interface #val #[i1] : 'word → 'word ] := + λ b, if b then {locpackage IND_CPA_jasmin } else {locpackage (IND_CPA_ideal n) }. + + #[local] Open Scope ring_scope. + + From Crypt Require Import pkg_distr. + + Lemma IND_CPA_jasmin_real : + IND_CPA_jasmin_real_game false ≈₀ IND_CPA_jasmin_real_game true. + Proof. + eapply eq_rel_perf_ind_ignore with (L := xor_locs); [apply fsubsetUr|]. + Opaque n. + simplify_eq_rel m. + Transparent n. + + ssprove_sync. + intros x. + + (* note that this simpl chokes if called before ssprove_sync_eq *) + simpl. + ssprove_invariant. + ssprove_swap_seq_rhs [::1%nat]. + ssprove_contract_put_get_rhs. + ssprove_swap_seq_rhs [::0%nat ; 3%nat ; 2%nat ; 1%nat ]. + ssprove_contract_put_get_rhs. + ssprove_swap_seq_rhs [::1%nat ; 0%nat ; 2%nat ; 1%nat ]. + ssprove_contract_put_get_rhs. + ssprove_swap_seq_rhs [::2%nat ; 1%nat ]. + ssprove_contract_put_rhs. + ssprove_swap_seq_rhs [::2%nat ; 1%nat ]. + ssprove_contract_put_get_rhs. + rewrite !zero_extend_u. + + (* why is this not inferred? *) + repeat eapply r_put_rhs. + eapply r_ret. + + intros ? ? ?. + rewrite coerce_to_choice_type_K. + split; [reflexivity|]. + intros l lnin. + repeat destruct H. subst. + rewrite !get_set_heap_neq. + 1: eapply H; assumption. + Admitted. + + Theorem advantage_jas_real : + ∀ LA A, + fdisjoint LA xor_locs -> + ValidPackage LA + [interface #val #[i1] : 'word → 'word ] A_export A → + Advantage IND_CPA_jasmin_real_game A = 0. + Proof. + intros LA A vA HA. + rewrite Advantage_E. + eapply IND_CPA_jasmin_real. 1: eauto. + 1: eapply fdisjoints0. + 1: assumption. + Qed. + + Theorem unconditional_secrecy_jas : + ∀ LA A, + fdisjoint LA xor_locs -> + ValidPackage LA + [interface #val #[i1] : 'word → 'word ] A_export A → + Advantage IND_CPA_jasmin_ideal_game A = 0. + Proof. + intros LA A vA HA. + rewrite Advantage_E. + assert (AdvantageE (IND_CPA_jasmin_ideal_game false) (IND_CPA_jasmin_ideal_game true) A <= 0 + 0). + - rewrite -{2}advantage_jas_real; [|assumption]. + rewrite -unconditional_secrecy. + rewrite !Advantage_E. + (* cbn [IND_CPA_jasmin_real_game IND_CPA IND_CPA_jasmin_ideal_game]. *) + eapply Advantage_triangle. + - rewrite add0r in H. + apply AdvantageE_le_0. + assumption. + Qed. +End Jasmin_OTP. diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index af1c53f9..d818848e 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -839,8 +839,10 @@ Fixpoint nat_of_ident (id : Ident.ident) : nat := Definition nat_of_stype t : nat := match t with - | sarr len => 5 ^ ((Pos.to_nat len).+1) - | _ => 5 ^ 1 + | sbool => 5 + | sint => 7 + | sarr len => 11 ^ (Pos.to_nat len) + | sword ws => 13 ^ ws end. (* injection *) @@ -965,33 +967,29 @@ Proof. apply /andP. destruct t. - rewrite !Natpow_expn. - rewrite !coprime_pexpl. - 2,3: auto. rewrite !coprime_pexpr. - 2: apply /ltP; apply nat_of_ident_pos. - 2: apply /ltP; pose proof nat_of_p_id_nonzero p; micromega.Lia.lia. - auto. + 1: auto. + 1: apply /ltP; apply nat_of_ident_pos. + 1: apply /ltP; pose proof nat_of_p_id_nonzero p; micromega.Lia.lia. - rewrite !Natpow_expn. - rewrite !coprime_pexpl. - 2,3: auto. rewrite !coprime_pexpr. - 2: apply /ltP; apply nat_of_ident_pos. - 2: apply /ltP; pose proof nat_of_p_id_nonzero p; micromega.Lia.lia. - auto. + 1: auto. + 1: apply /ltP; apply nat_of_ident_pos. + 1: apply /ltP; pose proof nat_of_p_id_nonzero p; micromega.Lia.lia. - rewrite !Natpow_expn. rewrite !coprime_pexpl. - 2,3: auto. + 2,3: apply/ltP; micromega.Lia.lia. rewrite !coprime_pexpr. - 2: apply /ltP; apply nat_of_ident_pos. - 2: apply /ltP; pose proof nat_of_p_id_nonzero p; micromega.Lia.lia. - auto. + 1: auto. + 1: apply /ltP; apply nat_of_ident_pos. + 1: apply /ltP; pose proof nat_of_p_id_nonzero p; micromega.Lia.lia. - rewrite !Natpow_expn. rewrite !coprime_pexpl. 2,3: auto. rewrite !coprime_pexpr. - 2: apply /ltP; apply nat_of_ident_pos. - 2: apply /ltP; pose proof nat_of_p_id_nonzero p; micromega.Lia.lia. - auto. + 1: auto. + 1: apply /ltP; apply nat_of_ident_pos. + 1: apply /ltP; pose proof nat_of_p_id_nonzero p; micromega.Lia.lia. Qed. Lemma nat_of_p_id_pos : forall p, (0 < nat_of_p_id p)%coq_nat. @@ -999,10 +997,8 @@ Proof. intros. pose proof nat_of_p_id_nonzero p. micromega.Lia.lia. Qed. -Lemma injective_nat_of_p_id_ident2 : - ∀ p1 p2 x y, - nat_of_p_id_ident p1 x = nat_of_p_id_ident p2 y → - p1 = p2 /\ x = y. +Lemma injective2_nat_of_p_id_ident : + injective2 nat_of_p_id_ident. Proof. intros p gn x y e. unfold nat_of_p_id_ident in e. @@ -1052,7 +1048,7 @@ Proof. f_equal. - destruct uty, vty; auto; try discriminate. + apply Nat.pow_inj_r in e1. 2: auto. - apply succn_inj in e1. + 2: micromega.Lia.lia. apply Pos2Nat.inj in e1. subst; reflexivity. + noconf H. reflexivity. @@ -1070,7 +1066,7 @@ Proof. unfold nat_of_p_id_var in H1. apply coprime_mul_inj in H1 as [e1 e2]. 2,3,4,5: apply coprime_nat_of_stype_nat_of_fun_ident. - apply injective_nat_of_p_id_ident2 in e2 as [p_gn _]. + apply injective2_nat_of_p_id_ident in e2 as [p_gn _]. easy. Qed. @@ -1084,11 +1080,160 @@ Proof. unfold nat_of_p_id_var in H1. apply coprime_mul_inj in H1 as [e1 e2]. 2,3,4,5: apply coprime_nat_of_stype_nat_of_fun_ident. - apply injective_nat_of_p_id_ident2 in e2 as [p_gn ?]. + apply injective2_nat_of_p_id_ident in e2 as [p_gn ?]. move: H => /eqP contra. easy. Qed. +Lemma coprimenn n : (coprime n n) = (n == 1%nat). +Proof. by unfold coprime; rewrite gcdnn. Qed. + +Lemma coprime_neq p q : p != 1%nat -> coprime p q -> p <> q. +Proof. + intros. + move=>contra; subst. + move: H=>/eqP H; apply H; apply/eqP. + by rewrite -coprimenn. +Qed. + +Lemma nat_of_wsize_inj : injective nat_of_wsize. +Proof. intros ws1 ws2. by case ws1; case ws2. Qed. + +Lemma nat_of_stype_injective : injective nat_of_stype. +Proof. + intros s t. + case s; case t; try by []. + - intros p H. + exfalso. + eapply coprime_neq. + 3: eapply H. + + reflexivity. + + unfold nat_of_stype. by rewrite Natpow_expn coprime_expr. + - intros ws H. + exfalso. + eapply coprime_neq. + 3: eapply H. + + reflexivity. + + unfold nat_of_stype. by rewrite Natpow_expn coprime_expr. + - intros l H. + exfalso. + eapply coprime_neq. + 3: eapply H. + + reflexivity. + + unfold nat_of_stype. by rewrite Natpow_expn coprime_expr. + - intros ws H. + exfalso. + eapply coprime_neq. + 3: eapply H. + + reflexivity. + + unfold nat_of_stype. by rewrite Natpow_expn coprime_expr. + - intros l H. + exfalso. + eapply coprime_neq. + 3: eapply H. + + unfold nat_of_stype. apply/eqP. apply nesym. apply Nat.lt_neq. + apply Nat.pow_gt_1. + all: micromega.Lia.lia. + + unfold nat_of_stype. by rewrite Natpow_expn coprime_expl. + - intros l H. + exfalso. + eapply coprime_neq. + 3: eapply H. + + unfold nat_of_stype. apply/eqP. apply nesym. apply Nat.lt_neq. + apply Nat.pow_gt_1. + all: micromega.Lia.lia. + + unfold nat_of_stype. by rewrite Natpow_expn coprime_expl. + - intros l1 l2 H. + destruct (l2 == l1) eqn:E. + + by move: E=>/eqP ->. + + exfalso. + move: E=>/eqP=>contra; apply contra. + eapply Pos2Nat.inj. eapply Nat.pow_inj_r. + 2: eapply H. micromega.Lia.lia. + - intros ws l H. + exfalso. + eapply coprime_neq. + 3: eapply H. + + unfold nat_of_stype. apply/eqP. apply nesym. apply Nat.lt_neq. + apply Nat.pow_gt_1. + all: micromega.Lia.lia. + + unfold nat_of_stype. rewrite !Natpow_expn coprime_expl; auto. + by rewrite coprime_expr. + - intros ws H. + exfalso. + eapply coprime_neq. + 3: eapply H. + + unfold nat_of_stype. apply/eqP. apply nesym. apply Nat.lt_neq. + apply Nat.pow_gt_1. + 1: micromega.Lia.lia. + apply/eqP. by case ws. + + unfold nat_of_stype. by rewrite Natpow_expn coprime_expl. + - intros ws H. + exfalso. + eapply coprime_neq. + 3: eapply H. + + unfold nat_of_stype. apply/eqP. apply nesym. apply Nat.lt_neq. + apply Nat.pow_gt_1. + 1: micromega.Lia.lia. + apply/eqP. by case ws. + + unfold nat_of_stype. by rewrite Natpow_expn coprime_expl. + - intros l ws H. + exfalso. + eapply coprime_neq. + 3: eapply H. + + unfold nat_of_stype. apply/eqP. apply nesym. apply Nat.lt_neq. + apply Nat.pow_gt_1. + 1: micromega.Lia.lia. + apply/eqP. by case ws. + + unfold nat_of_stype. rewrite !Natpow_expn coprime_expl; auto. + by rewrite coprime_expr. + - intros ws1 ws2 H. + destruct (ws2 == ws1) eqn:E. + + by move: E=>/eqP ->. + + exfalso. + move: E=>/eqP=>contra; apply contra. + eapply nat_of_wsize_inj. + eapply Nat.pow_inj_r. + 2: eapply H. micromega.Lia.lia. +Qed. + +Lemma nat_of_p_id_var_injective2 : + injective2 nat_of_p_id_var. +Proof. + intros i1 i2 v1 v2. + unfold nat_of_p_id_var. + intros H. + apply coprime_mul_inj in H as []. + 2,3,4,5: apply coprime_nat_of_stype_nat_of_fun_ident. + apply nat_of_stype_injective in H. + apply injective2_nat_of_p_id_ident in H0 as [? ?]. + destruct v1, v2. simpl in *; subst. + easy. +Qed. + +Lemma translate_var_injective2 : + injective2 translate_var. +Proof. + intros i1 i2 v1 v2. + unfold translate_var. + move=> H. + noconf H. + apply nat_of_p_id_var_injective2 in H0. + assumption. +Qed. + +Lemma translate_var_eq i1 i2 v1 v2 : + (translate_var i1 v1 == translate_var i2 v2) = (i1 == i2) && (v1 == v2). +Proof. + apply/eqP. + destruct (_ && _) eqn:E. + - by move: E=>/andP [] /eqP -> /eqP ->. + - move=>contra. + apply translate_var_injective2 in contra as [? ?]. + subst. + move: E=>/andP []. split; by apply/eqP. +Qed. + Lemma mem_loc_translate_var_neq : ∀ p x, mem_loc != translate_var p x. From 89a09a91fa4af70931b65eb7e30d5ef5f6abb8f4 Mon Sep 17 00:00:00 2001 From: bshvass Date: Fri, 7 Oct 2022 14:43:18 +0200 Subject: [PATCH 276/383] regenerate examples --- theories/Jasmin/examples/add1.v | 121 +- theories/Jasmin/examples/aes.v | 2664 ++++++++------------ theories/Jasmin/examples/bigadd.v | 494 ++-- theories/Jasmin/examples/ex.v | 174 +- theories/Jasmin/examples/gen_and_test.sh | 20 +- theories/Jasmin/examples/int_add.v | 223 +- theories/Jasmin/examples/int_incr.v | 186 +- theories/Jasmin/examples/int_reg.v | 79 +- theories/Jasmin/examples/int_shift.v | 162 +- theories/Jasmin/examples/liveness_bork.v | 121 +- theories/Jasmin/examples/matrix_product.v | 1964 +++++---------- theories/Jasmin/examples/retz.v | 67 +- theories/Jasmin/examples/test_for.v | 119 +- theories/Jasmin/examples/test_inline_var.v | 341 ++- theories/Jasmin/examples/test_shift.v | 88 +- theories/Jasmin/examples/three_functions.v | 262 +- theories/Jasmin/examples/two_functions.v | 155 +- theories/Jasmin/examples/u64_incr.v | 136 +- theories/Jasmin/examples/xor.v | 139 +- 19 files changed, 3006 insertions(+), 4509 deletions(-) diff --git a/theories/Jasmin/examples/add1.v b/theories/Jasmin/examples/add1.v index 8ba3b221..cde41e09 100644 --- a/theories/Jasmin/examples/add1.v +++ b/theories/Jasmin/examples/add1.v @@ -1,66 +1,67 @@ +Set Warnings "-notation-overridden,-ambiguous-paths". +From mathcomp Require Import all_ssreflect all_algebra reals distr realsum + fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool + ssrnum eqtype choice seq. +Set Warnings "notation-overridden,ambiguous-paths". + Require Import List. +Set Warnings "-notation-overridden". From Jasmin Require Import expr. -From Jasmin Require Import x86_extra. +Set Warnings "notation-overridden". +From Jasmin Require Import x86_instr_decl x86_extra. +From JasminSSProve Require Import jasmin_translate. +From Crypt Require Import Prelude Package. Import ListNotations. Local Open Scope string. -Definition add1 := {| p_funcs := - [(xH, - {| f_info := xO xH; - f_tyin := [sword U64]; - f_params := - [{| v_var := - {| vtype := sword U64; - vname := "arg.141" |}; - v_info := dummy_var_info |}]; - f_body := - [MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "z.142" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U64) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "arg.141" |}; - v_info := dummy_var_info |}; - gs := Slocal |})); - MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "z.142" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U64) - (Papp2 - (Oadd (Op_w U64)) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "z.142" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Papp1 (Oword_of_int U64) - (Pconst (Zpos xH)))))]; - f_tyout := [sword U64]; - f_res := - [{| v_var := - {| vtype := sword U64; - vname := "z.142" |}; - v_info := dummy_var_info |}]; - f_extra := tt |})]; - p_globs := []; p_extra := tt |} -. \ No newline at end of file + + + +Definition ssprove_jasmin_prog : uprog. +Proof. + refine {| p_funcs := + [ ( (* add1 *) xH, + {| f_info := xO xH + ; f_tyin := [(sword U64)] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "arg.141" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := {| vtype := (sword U64) + ; vname := "z.142" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "arg.141" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := {| vtype := (sword U64) + ; vname := "z.142" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp2 (Oadd (Op_w U64)) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "z.142" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Papp1 (Oword_of_int U64) (Pconst (Zpos (xH))))))) ] + ; f_tyout := [(sword U64)] + ; f_res := + [{| v_var := {| vtype := (sword U64) + ; vname := "z.142" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) ] ; + p_globs := [] ; + p_extra := tt |}. +Defined. diff --git a/theories/Jasmin/examples/aes.v b/theories/Jasmin/examples/aes.v index 2c9b775c..45e72461 100644 --- a/theories/Jasmin/examples/aes.v +++ b/theories/Jasmin/examples/aes.v @@ -1,1672 +1,1030 @@ +Set Warnings "-notation-overridden,-ambiguous-paths". +From mathcomp Require Import all_ssreflect all_algebra reals distr realsum + fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool + ssrnum eqtype choice seq. +Set Warnings "notation-overridden,ambiguous-paths". + Require Import List. +Set Warnings "-notation-overridden". From Jasmin Require Import expr. -From Jasmin Require Import x86_extra. +Set Warnings "notation-overridden". +From Jasmin Require Import x86_instr_decl x86_extra. +From JasminSSProve Require Import jasmin_translate. +From Crypt Require Import Prelude Package. Import ListNotations. Local Open Scope string. -Definition aes := {| p_funcs := - [(xH, - {| f_info := xO xH; - f_tyin := - [sword U128; - sword U128]; - f_params := - [{| v_var := - {| vtype := sword U128; - vname := "key.280" |}; - v_info := dummy_var_info |}; - {| v_var := - {| vtype := sword U128; - vname := "in.281" |}; - v_info := dummy_var_info |}]; - f_body := - [MkI - (dummy_instr_info) - (Ccall (InlineFun) - ([Lvar - {| v_var := - {| vtype := - sword U128; - vname := "out.282" |}; - v_info := dummy_var_info |}]) - (xI xH) - ([Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "key.280" |}; - v_info := dummy_var_info |}; - gs := Slocal |}; - Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "in.281" |}; - v_info := dummy_var_info |}; - gs := Slocal |}]))]; - f_tyout := [sword U128]; - f_res := - [{| v_var := - {| vtype := sword U128; - vname := "out.282" |}; - v_info := dummy_var_info |}]; - f_extra := tt |}); - (xO (xO xH), - {| f_info := - xI (xO xH); - f_tyin := - [sword U128; - sword U128]; - f_params := - [{| v_var := - {| vtype := sword U128; - vname := "key.283" |}; - v_info := dummy_var_info |}; - {| v_var := - {| vtype := sword U128; - vname := "in.284" |}; - v_info := dummy_var_info |}]; - f_body := - [MkI - (dummy_instr_info) - (Ccall (InlineFun) - ([Lvar - {| v_var := - {| vtype := - sword U128; - vname := "out.285" |}; - v_info := dummy_var_info |}]) - (xO - (xI xH)) - ([Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "key.283" |}; - v_info := dummy_var_info |}; - gs := Slocal |}; - Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "in.284" |}; - v_info := dummy_var_info |}; - gs := Slocal |}]))]; - f_tyout := [sword U128]; - f_res := - [{| v_var := - {| vtype := sword U128; - vname := "out.285" |}; - v_info := dummy_var_info |}]; - f_extra := tt |}); - (xI xH, - {| f_info := - xI (xI xH); - f_tyin := - [sword U128; - sword U128]; - f_params := - [{| v_var := - {| vtype := sword U128; - vname := "key.286" |}; - v_info := dummy_var_info |}; - {| v_var := - {| vtype := sword U128; - vname := "in.287" |}; - v_info := dummy_var_info |}]; - f_body := - [MkI - (dummy_instr_info) - (Ccall (InlineFun) - ([Lvar - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xI - (xI - (xO xH))))))); - vname := "rkeys.289" |}; - v_info := dummy_var_info |}]) - (xI - (xO - (xO xH))) - ([Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "key.286" |}; - v_info := dummy_var_info |}; - gs := Slocal |}])); - MkI - (dummy_instr_info) - (Ccall (InlineFun) - ([Lvar - {| v_var := - {| vtype := - sword U128; - vname := "out.288" |}; - v_info := dummy_var_info |}]) - (xO - (xO - (xO xH))) - ([Pvar - {| gv := - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xI - (xI - (xO xH))))))); - vname := "rkeys.289" |}; - v_info := dummy_var_info |}; - gs := Slocal |}; - Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "in.287" |}; - v_info := dummy_var_info |}; - gs := Slocal |}]))]; - f_tyout := [sword U128]; - f_res := - [{| v_var := - {| vtype := sword U128; - vname := "out.288" |}; - v_info := dummy_var_info |}]; - f_extra := tt |}); - (xO (xI xH), - {| f_info := - xO - (xI (xO xH)); - f_tyin := - [sword U128; - sword U128]; - f_params := - [{| v_var := - {| vtype := sword U128; - vname := "key.290" |}; - v_info := dummy_var_info |}; - {| v_var := - {| vtype := sword U128; - vname := "in.291" |}; - v_info := dummy_var_info |}]; - f_body := - [MkI - (dummy_instr_info) - (Ccall (InlineFun) - ([Lvar - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xI - (xI - (xO xH))))))); - vname := "rkeys.293" |}; - v_info := dummy_var_info |}]) - (xO - (xO - (xI xH))) - ([Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "key.290" |}; - v_info := dummy_var_info |}; - gs := Slocal |}])); - MkI - (dummy_instr_info) - (Ccall (InlineFun) - ([Lvar - {| v_var := - {| vtype := - sword U128; - vname := "out.292" |}; - v_info := dummy_var_info |}]) - (xI - (xI - (xO xH))) - ([Pvar - {| gv := - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xI - (xI - (xO xH))))))); - vname := "rkeys.293" |}; - v_info := dummy_var_info |}; - gs := Slocal |}; - Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "in.291" |}; - v_info := dummy_var_info |}; - gs := Slocal |}]))]; - f_tyout := [sword U128]; - f_res := - [{| v_var := - {| vtype := sword U128; - vname := "out.292" |}; - v_info := dummy_var_info |}]; - f_extra := tt |}); - (xO - (xO (xO xH)), - {| f_info := - xI - (xO (xI xH)); - f_tyin := - [sarr - (xO - (xO - (xO - (xO - (xI - (xI - (xO xH))))))); - sword U128]; - f_params := - [{| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xI - (xI - (xO xH))))))); - vname := "rkeys.294" |}; - v_info := dummy_var_info |}; - {| v_var := - {| vtype := sword U128; - vname := "in.295" |}; - v_info := dummy_var_info |}]; - f_body := - [MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U128; - vname := "state.296" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U128) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "in.295" |}; - v_info := dummy_var_info |}; - gs := Slocal |})); - MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U128; - vname := "rk.297" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U128) - (Pget (AAscale) (U128) - ({| gv := - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xI - (xI - (xO xH))))))); - vname := "rkeys.294" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pconst - (Zpos - (xO - (xI - (xO xH))))))); - MkI - (dummy_instr_info) - (Ccall (InlineFun) - ([Lvar - {| v_var := - {| vtype := - sword U128; - vname := "state.296" |}; - v_info := dummy_var_info |}]) - (xO - (xI - (xI xH))) - ([Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "state.296" |}; - v_info := dummy_var_info |}; - gs := Slocal |}; - Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "rk.297" |}; - v_info := dummy_var_info |}; - gs := Slocal |}])); - MkI - (dummy_instr_info) - (Cfor - ({| v_var := - {| vtype := sint; - vname := "round.298" |}; - v_info := dummy_var_info |}) - (((DownTo, Pconst Z0), - Pconst - (Zpos - (xI - (xO - (xO xH)))))) - ([MkI - (dummy_instr_info) + + + +Definition ssprove_jasmin_prog : uprog. +Proof. + refine {| p_funcs := + [ ( (* RCON *) xI (xI (xO (xO xH))), + {| f_info := xO (xO (xO (xI xH))) + ; f_tyin := [sint] + ; f_params := + [{| v_var := {| vtype := sint + ; vname := "i.322" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := {| vtype := sint + ; vname := "c.323" |} + ; v_info := dummy_var_info |}) + AT_inline (sint) + ((Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.322" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xH)))) + (Pconst (Zpos (xH))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.322" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO xH)))) + (Pconst (Zpos (xO xH))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.322" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xI xH)))) + (Pconst (Zpos (xO (xO xH)))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.322" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO (xO xH))))) + (Pconst (Zpos (xO (xO (xO xH))))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.322" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xI (xO xH))))) + (Pconst (Zpos (xO (xO (xO (xO xH)))))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.322" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO (xI xH))))) + (Pconst (Zpos (xO (xO (xO (xO (xO xH))))))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := + "i.322" |} + ; v_info := + dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xI (xI xH))))) + (Pconst + (Zpos (xO (xO (xO (xO (xO (xO xH)))))))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := + "i.322" |} + ; v_info := + dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO (xO (xO xH)))))) + (Pconst + (Zpos (xO (xO (xO (xO (xO (xO (xO xH))))))))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := + sint + ; vname := + "i.322" |} + ; v_info := + dummy_var_info |} ; gs := Slocal |}) + (Pconst + (Zpos (xI (xO (xO xH)))))) + (Pconst + (Zpos (xI (xI (xO (xI xH)))))) + (Pconst + (Zpos (xO (xI (xI (xO (xI xH)))))))))))))))))) ] + ; f_tyout := [sint] + ; f_res := + [{| v_var := {| vtype := sint + ; vname := "c.323" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* key_combine *) xO (xI (xI (xO xH))), + {| f_info := xI (xI (xI (xO xH))) + ; f_tyin := [(sword U128); (sword U128); (sword U128)] + ; f_params := + [{| v_var := {| vtype := (sword U128) + ; vname := "rkey.319" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "temp1.320" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "temp2.321" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "temp1.320" |} + ; v_info := dummy_var_info |}] + AT_keep + (Oasm (* VPSHUFD_128 *) (BaseOp (None, (VPSHUFD U128)))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp1.320" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (PappN (Opack U8 PE2) + [(Pconst (Zpos (xI xH))); (Pconst (Zpos (xI xH))); + (Pconst (Zpos (xI xH))); (Pconst (Zpos (xI xH)))])]); + MkI InstrInfo.witness (Copn - ([Lvar - {| v_var := - {| vtype := - sword U128; - vname := "state.296" |}; - v_info := dummy_var_info |}]) - (AT_keep) - (Oasm (BaseOp (None) ())) - ([Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "state.296" |}; - v_info := dummy_var_info |}; - gs := Slocal |}; - Pget (AAscale) (U128) - ({| gv := - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xI - (xI - (xO - xH))))))); - vname := "rkeys.294" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pvar - {| gv := + [Lvar {| v_var := - {| vtype := sint; - vname := "round.298" |}; - v_info := dummy_var_info |}; - gs := Slocal |})]))])); - MkI - (dummy_instr_info) - (Copn - ([Lvar - {| v_var := - {| vtype := - sword U128; - vname := "state.296" |}; - v_info := dummy_var_info |}]) - (AT_keep) - (Oasm (BaseOp (None) ())) - ([Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "state.296" |}; - v_info := dummy_var_info |}; - gs := Slocal |}; - Pget (AAscale) (U128) - ({| gv := - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xI - (xI - (xO xH))))))); - vname := "rkeys.294" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pconst Z0)]))]; - f_tyout := [sword U128]; - f_res := - [{| v_var := - {| vtype := sword U128; - vname := "state.296" |}; - v_info := dummy_var_info |}]; - f_extra := tt |}); - (xO - (xI (xI xH)), - {| f_info := - xI - (xI (xI xH)); - f_tyin := - [sword U128; - sword U128]; - f_params := - [{| v_var := - {| vtype := sword U128; - vname := "state.299" |}; - v_info := dummy_var_info |}; - {| v_var := - {| vtype := sword U128; - vname := "rk.300" |}; - v_info := dummy_var_info |}]; - f_body := - [MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U128; - vname := "state.299" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U128) - (Papp2 (Olxor U128) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "state.299" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "rk.300" |}; - v_info := dummy_var_info |}; - gs := Slocal |})))]; - f_tyout := [sword U128]; - f_res := - [{| v_var := - {| vtype := sword U128; - vname := "state.299" |}; - v_info := dummy_var_info |}]; - f_extra := tt |}); - (xI - (xI (xO xH)), - {| f_info := - xO - (xO - (xO - (xO xH))); - f_tyin := - [sarr - (xO - (xO - (xO - (xO - (xI - (xI - (xO xH))))))); - sword U128]; - f_params := - [{| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xI - (xI - (xO xH))))))); - vname := "rkeys.301" |}; - v_info := dummy_var_info |}; - {| v_var := - {| vtype := sword U128; - vname := "in.302" |}; - v_info := dummy_var_info |}]; - f_body := - [MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U128; - vname := "state.303" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U128) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "in.302" |}; - v_info := dummy_var_info |}; - gs := Slocal |})); - MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U128; - vname := "state.303" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U128) - (Papp2 (Olxor U128) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "state.303" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pget (AAscale) (U128) - ({| gv := - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xI - (xI - (xO xH))))))); - vname := "rkeys.301" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pconst Z0)))); - MkI - (dummy_instr_info) - (Cfor - ({| v_var := - {| vtype := sint; - vname := "round.304" |}; - v_info := dummy_var_info |}) - (((UpTo, - Pconst (Zpos xH)), - Pconst - (Zpos - (xO - (xI - (xO xH)))))) - ([MkI - (dummy_instr_info) + {| vtype := (sword U128) + ; vname := "temp2.321" |} + ; v_info := dummy_var_info |}] + AT_keep + (Oasm (* VSHUFPS_128 *) (BaseOp (None, (VSHUFPS U128)))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.321" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.319" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (PappN (Opack U8 PE2) + [(Pconst (Z0)); (Pconst (Zpos (xH))); (Pconst (Z0)); + (Pconst (Z0))])]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.319" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U128)) + ((Papp2 (Olxor U128) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.319" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.321" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness (Copn - ([Lvar - {| v_var := - {| vtype := - sword U128; - vname := "state.303" |}; - v_info := dummy_var_info |}]) - (AT_keep) - (Oasm (BaseOp (None) ())) - ([Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "state.303" |}; - v_info := dummy_var_info |}; - gs := Slocal |}; - Pget (AAscale) (U128) - ({| gv := - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xI - (xI - (xO - xH))))))); - vname := "rkeys.301" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pvar - {| gv := + [Lvar {| v_var := - {| vtype := sint; - vname := "round.304" |}; - v_info := dummy_var_info |}; - gs := Slocal |})]))])); - MkI - (dummy_instr_info) - (Copn - ([Lvar - {| v_var := - {| vtype := - sword U128; - vname := "state.303" |}; - v_info := dummy_var_info |}]) - (AT_keep) - (Oasm (BaseOp (None) ())) - ([Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "state.303" |}; - v_info := dummy_var_info |}; - gs := Slocal |}; - Pget (AAscale) (U128) - ({| gv := - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xI - (xI - (xO xH))))))); - vname := "rkeys.301" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pconst - (Zpos - (xO - (xI - (xO xH)))))]))]; - f_tyout := [sword U128]; - f_res := - [{| v_var := - {| vtype := sword U128; - vname := "state.303" |}; - v_info := dummy_var_info |}]; - f_extra := tt |}); - (xI - (xO (xO xH)), - {| f_info := - xI - (xO - (xO - (xO xH))); - f_tyin := [sword U128]; - f_params := - [{| v_var := - {| vtype := sword U128; - vname := "key.305" |}; - v_info := dummy_var_info |}]; - f_body := - [MkI - (dummy_instr_info) - (Cassgn - (Laset (AAscale) (U128) - ({| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xI - (xI - (xO xH))))))); - vname := "rkeys.306" |}; - v_info := dummy_var_info |}) - (Pconst Z0)) - (AT_none) (sword U128) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "key.305" |}; - v_info := dummy_var_info |}; - gs := Slocal |})); - MkI - (dummy_instr_info) - (Copn - ([Lvar - {| v_var := - {| vtype := - sword U128; - vname := "temp2.307" |}; - v_info := dummy_var_info |}]) - (AT_keep) - (Oasm (ExtOp )) ([])); - MkI - (dummy_instr_info) - (Cfor - ({| v_var := - {| vtype := sint; - vname := "round.308" |}; - v_info := dummy_var_info |}) - (((UpTo, - Pconst (Zpos xH)), - Pconst - (Zpos - (xI - (xI - (xO xH)))))) - ([MkI - (dummy_instr_info) - (Ccall (InlineFun) - ([Lvar - {| v_var := - {| vtype := sint; - vname := "rcon.309" |}; - v_info := dummy_var_info |}]) - (xI - (xI - (xO - (xO xH)))) - ([Pvar - {| gv := - {| v_var := - {| vtype := sint; - vname := "round.308" |}; - v_info := dummy_var_info |}; - gs := Slocal |}])); - MkI - (dummy_instr_info) - (Ccall (InlineFun) - ([Lvar - {| v_var := - {| vtype := - sword U128; - vname := "key.305" |}; - v_info := dummy_var_info |}; - Lvar - {| v_var := - {| vtype := - sword U128; - vname := "temp2.307" |}; - v_info := dummy_var_info |}]) - (xO - (xI - (xO - (xO xH)))) - ([Pvar - {| gv := - {| v_var := - {| vtype := sint; - vname := "rcon.309" |}; - v_info := dummy_var_info |}; - gs := Slocal |}; - Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "key.305" |}; - v_info := dummy_var_info |}; - gs := Slocal |}; - Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "temp2.307" |}; - v_info := dummy_var_info |}; - gs := Slocal |}])); - MkI - (dummy_instr_info) - (Cif - (Papp2 (Oneq Op_int) - (Pvar - {| gv := + {| vtype := (sword U128) + ; vname := "temp2.321" |} + ; v_info := dummy_var_info |}] + AT_keep + (Oasm (* VSHUFPS_128 *) (BaseOp (None, (VSHUFPS U128)))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.321" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.319" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (PappN (Opack U8 PE2) + [(Pconst (Zpos (xO xH))); (Pconst (Z0)); + (Pconst (Zpos (xI xH))); (Pconst (Z0))])]); + MkI InstrInfo.witness + (Cassgn + (Lvar {| v_var := - {| vtype := sint; - vname := "round.308" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pconst - (Zpos - (xO - (xI - (xO xH)))))) - ([MkI - (dummy_instr_info) - (Copn - ([Laset (AAscale) - (U128) - ({| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xI - (xI - (xO - xH))))))); - vname := "rkeys.306" |}; - v_info := dummy_var_info |}) + {| vtype := (sword U128) + ; vname := "rkey.319" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U128)) + ((Papp2 (Olxor U128) (Pvar - {| gv := - {| v_var := - {| vtype := sint; - vname := "round.308" |}; - v_info := dummy_var_info |}; - gs := Slocal |})]) - (AT_keep) - (Oasm (BaseOp (None) ())) - ([Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "key.305" |}; - v_info := dummy_var_info |}; - gs := Slocal |}]))]) - ([MkI - (dummy_instr_info) - (Cassgn - (Laset (AAscale) - (U128) - ({| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xI - (xI - (xO - xH))))))); - vname := "rkeys.306" |}; - v_info := dummy_var_info |}) - (Pvar - {| gv := - {| v_var := - {| vtype := sint; - vname := "round.308" |}; - v_info := dummy_var_info |}; - gs := Slocal |})) - (AT_none) - (sword U128) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "key.305" |}; - v_info := dummy_var_info |}; - gs := Slocal |}))]))]))]; - f_tyout := - [sarr - (xO - (xO - (xO - (xO - (xI - (xI - (xO xH)))))))]; - f_res := - [{| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xI - (xI - (xO xH))))))); - vname := "rkeys.306" |}; - v_info := dummy_var_info |}]; - f_extra := tt |}); - (xO - (xO (xI xH)), - {| f_info := - xO - (xO - (xI - (xO xH))); - f_tyin := [sword U128]; - f_params := - [{| v_var := - {| vtype := sword U128; - vname := "key.310" |}; - v_info := dummy_var_info |}]; - f_body := - [MkI - (dummy_instr_info) - (Cassgn - (Laset (AAscale) (U128) - ({| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xI - (xI - (xO xH))))))); - vname := "rkeys.311" |}; - v_info := dummy_var_info |}) - (Pconst Z0)) - (AT_none) (sword U128) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "key.310" |}; - v_info := dummy_var_info |}; - gs := Slocal |})); - MkI - (dummy_instr_info) - (Copn - ([Lvar - {| v_var := - {| vtype := - sword U128; - vname := "temp2.312" |}; - v_info := dummy_var_info |}]) - (AT_keep) - (Oasm (ExtOp )) ([])); - MkI - (dummy_instr_info) - (Cfor - ({| v_var := - {| vtype := sint; - vname := "round.313" |}; - v_info := dummy_var_info |}) - (((UpTo, - Pconst (Zpos xH)), - Pconst - (Zpos - (xI - (xI - (xO xH)))))) - ([MkI - (dummy_instr_info) - (Ccall (InlineFun) - ([Lvar - {| v_var := - {| vtype := sint; - vname := "rcon.314" |}; - v_info := dummy_var_info |}]) - (xI - (xI - (xO - (xO xH)))) - ([Pvar - {| gv := - {| v_var := - {| vtype := sint; - vname := "round.313" |}; - v_info := dummy_var_info |}; - gs := Slocal |}])); - MkI - (dummy_instr_info) - (Ccall (InlineFun) - ([Lvar - {| v_var := - {| vtype := - sword U128; - vname := "key.310" |}; - v_info := dummy_var_info |}; - Lvar - {| v_var := - {| vtype := - sword U128; - vname := "temp2.312" |}; - v_info := dummy_var_info |}]) - (xO - (xI - (xO - (xO xH)))) - ([Pvar - {| gv := - {| v_var := - {| vtype := sint; - vname := "rcon.314" |}; - v_info := dummy_var_info |}; - gs := Slocal |}; - Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "key.310" |}; - v_info := dummy_var_info |}; - gs := Slocal |}; - Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "temp2.312" |}; - v_info := dummy_var_info |}; - gs := Slocal |}])); - MkI - (dummy_instr_info) + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.319" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.321" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness (Cassgn - (Laset (AAscale) (U128) - ({| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xI - (xI - (xO xH))))))); - vname := "rkeys.311" |}; - v_info := dummy_var_info |}) - (Pvar - {| gv := + (Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.319" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U128)) + ((Papp2 (Olxor U128) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.319" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp1.320" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))) ] + ; f_tyout := [(sword U128); (sword U128)] + ; f_res := + [{| v_var := {| vtype := (sword U128) + ; vname := "rkey.319" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "temp2.321" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* key_expand *) xO (xI (xO (xO xH))), + {| f_info := xI (xO (xI (xO xH))) + ; f_tyin := [sint; (sword U128); (sword U128)] + ; f_params := + [{| v_var := {| vtype := sint + ; vname := "rcon.315" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "rkey.316" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "temp2.317" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Copn + [Lvar {| v_var := - {| vtype := sint; - vname := "round.313" |}; - v_info := dummy_var_info |}; - gs := Slocal |})) - (AT_none) (sword U128) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "key.310" |}; - v_info := dummy_var_info |}; - gs := Slocal |}))]))]; - f_tyout := - [sarr - (xO - (xO - (xO - (xO - (xI - (xI - (xO xH)))))))]; - f_res := - [{| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xI - (xI - (xO xH))))))); - vname := "rkeys.311" |}; - v_info := dummy_var_info |}]; - f_extra := tt |}); - (xO - (xI - (xO (xO xH))), - {| f_info := - xI - (xO - (xI - (xO xH))); - f_tyin := - [sint; sword U128; - sword U128]; - f_params := - [{| v_var := - {| vtype := sint; vname := "rcon.315" |}; - v_info := dummy_var_info |}; - {| v_var := - {| vtype := sword U128; - vname := "rkey.316" |}; - v_info := dummy_var_info |}; - {| v_var := - {| vtype := sword U128; - vname := "temp2.317" |}; - v_info := dummy_var_info |}]; - f_body := - [MkI - (dummy_instr_info) - (Copn - ([Lvar - {| v_var := - {| vtype := - sword U128; - vname := "temp1.318" |}; - v_info := dummy_var_info |}]) - (AT_keep) - (Oasm (BaseOp (None) ())) - ([Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "rkey.316" |}; - v_info := dummy_var_info |}; - gs := Slocal |}; - Papp1 (Oword_of_int U8) - (Pvar - {| gv := - {| v_var := - {| vtype := sint; - vname := "rcon.315" |}; - v_info := dummy_var_info |}; - gs := Slocal |})])); - MkI - (dummy_instr_info) - (Ccall (InlineFun) - ([Lvar - {| v_var := - {| vtype := - sword U128; - vname := "rkey.316" |}; - v_info := dummy_var_info |}; - Lvar - {| v_var := - {| vtype := - sword U128; - vname := "temp2.317" |}; - v_info := dummy_var_info |}]) - (xO - (xI - (xI - (xO xH)))) - ([Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "rkey.316" |}; - v_info := dummy_var_info |}; - gs := Slocal |}; - Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "temp1.318" |}; - v_info := dummy_var_info |}; - gs := Slocal |}; - Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "temp2.317" |}; - v_info := dummy_var_info |}; - gs := Slocal |}]))]; - f_tyout := - [sword U128; - sword U128]; - f_res := - [{| v_var := - {| vtype := sword U128; - vname := "rkey.316" |}; - v_info := dummy_var_info |}; - {| v_var := - {| vtype := sword U128; - vname := "temp2.317" |}; - v_info := dummy_var_info |}]; - f_extra := tt |}); - (xO - (xI - (xI (xO xH))), - {| f_info := - xI - (xI - (xI - (xO xH))); - f_tyin := - [sword U128; - sword U128; - sword U128]; - f_params := - [{| v_var := - {| vtype := sword U128; - vname := "rkey.319" |}; - v_info := dummy_var_info |}; - {| v_var := - {| vtype := sword U128; - vname := "temp1.320" |}; - v_info := dummy_var_info |}; - {| v_var := - {| vtype := sword U128; - vname := "temp2.321" |}; - v_info := dummy_var_info |}]; - f_body := - [MkI - (dummy_instr_info) - (Copn - ([Lvar - {| v_var := - {| vtype := - sword U128; - vname := "temp1.320" |}; - v_info := dummy_var_info |}]) - (AT_keep) - (Oasm (BaseOp (None) ())) - ([Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "temp1.320" |}; - v_info := dummy_var_info |}; - gs := Slocal |}; - PappN - (Opack (U8) (PE2)) - ([Pconst - (Zpos - (xI xH)); - Pconst - (Zpos - (xI xH)); - Pconst - (Zpos - (xI xH)); - Pconst - (Zpos - (xI xH))])])); - MkI - (dummy_instr_info) - (Copn - ([Lvar - {| v_var := - {| vtype := - sword U128; - vname := "temp2.321" |}; - v_info := dummy_var_info |}]) - (AT_keep) - (Oasm (BaseOp (None) ())) - ([Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "temp2.321" |}; - v_info := dummy_var_info |}; - gs := Slocal |}; - Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "rkey.319" |}; - v_info := dummy_var_info |}; - gs := Slocal |}; - PappN - (Opack (U8) (PE2)) - ([Pconst Z0; - Pconst (Zpos xH); - Pconst Z0; - Pconst Z0])])); - MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U128; - vname := "rkey.319" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U128) - (Papp2 (Olxor U128) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "rkey.319" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "temp2.321" |}; - v_info := dummy_var_info |}; - gs := Slocal |}))); - MkI - (dummy_instr_info) - (Copn - ([Lvar - {| v_var := - {| vtype := - sword U128; - vname := "temp2.321" |}; - v_info := dummy_var_info |}]) - (AT_keep) - (Oasm (BaseOp (None) ())) - ([Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "temp2.321" |}; - v_info := dummy_var_info |}; - gs := Slocal |}; - Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "rkey.319" |}; - v_info := dummy_var_info |}; - gs := Slocal |}; - PappN - (Opack (U8) (PE2)) - ([Pconst - (Zpos - (xO xH)); - Pconst Z0; - Pconst - (Zpos - (xI xH)); - Pconst Z0])])); - MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U128; - vname := "rkey.319" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U128) - (Papp2 (Olxor U128) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "rkey.319" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "temp2.321" |}; - v_info := dummy_var_info |}; - gs := Slocal |}))); - MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U128; - vname := "rkey.319" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U128) - (Papp2 (Olxor U128) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "rkey.319" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U128; - vname := "temp1.320" |}; - v_info := dummy_var_info |}; - gs := Slocal |})))]; - f_tyout := - [sword U128; - sword U128]; - f_res := - [{| v_var := - {| vtype := sword U128; - vname := "rkey.319" |}; - v_info := dummy_var_info |}; - {| v_var := - {| vtype := sword U128; - vname := "temp2.321" |}; - v_info := dummy_var_info |}]; - f_extra := tt |}); - (xI - (xI - (xO (xO xH))), - {| f_info := - xO - (xO - (xO - (xI xH))); - f_tyin := [sint]; - f_params := - [{| v_var := - {| vtype := sint; vname := "i.322" |}; - v_info := dummy_var_info |}]; - f_body := - [MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := sint; vname := "c.323" |}; - v_info := dummy_var_info |}) - (AT_inline) (sint) - (Pif (sint) - (Papp2 (Oeq Op_int) - (Pvar - {| gv := - {| v_var := - {| vtype := sint; - vname := "i.322" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pconst (Zpos xH))) - (Pconst (Zpos xH)) - (Pif (sint) - (Papp2 (Oeq Op_int) - (Pvar - {| gv := - {| v_var := - {| vtype := sint; - vname := "i.322" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pconst - (Zpos - (xO xH)))) - (Pconst - (Zpos - (xO xH))) - (Pif (sint) - (Papp2 (Oeq Op_int) - (Pvar - {| gv := - {| v_var := - {| vtype := sint; - vname := "i.322" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pconst - (Zpos - (xI xH)))) - (Pconst - (Zpos - (xO - (xO xH)))) - (Pif (sint) - (Papp2 (Oeq Op_int) - (Pvar - {| gv := + {| vtype := (sword U128) + ; vname := "temp1.318" |} + ; v_info := dummy_var_info |}] + AT_keep + (Oasm (* VAESKEYGENASSIST *) + (BaseOp (None, VAESKEYGENASSIST))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.316" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Papp1 (Oword_of_int U8) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "rcon.315" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))]); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar {| v_var := - {| vtype := sint; - vname := "i.322" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pconst - (Zpos - (xO - (xO xH))))) - (Pconst - (Zpos - (xO - (xO - (xO xH))))) - (Pif (sint) - (Papp2 (Oeq Op_int) - (Pvar - {| gv := + {| vtype := (sword U128) + ; vname := "rkey.316" |} + ; v_info := dummy_var_info |}; + Lvar {| v_var := - {| vtype := sint; - vname := "i.322" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pconst - (Zpos - (xI - (xO xH))))) - (Pconst - (Zpos - (xO - (xO - (xO - (xO xH)))))) - (Pif (sint) - (Papp2 (Oeq Op_int) + {| vtype := (sword U128) + ; vname := "temp2.317" |} + ; v_info := dummy_var_info |}] + (xO (xI (xI (xO xH)))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.316" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); (Pvar - {| gv := - {| v_var := - {| vtype := sint; - vname := "i.322" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pconst - (Zpos - (xO - (xI xH))))) - (Pconst - (Zpos - (xO - (xO - (xO - (xO - (xO xH))))))) - (Pif (sint) - (Papp2 (Oeq Op_int) - (Pvar - {| gv := - {| v_var := - {| vtype := sint; - vname := "i.322" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pconst - (Zpos - (xI - (xI xH))))) - (Pconst - (Zpos - (xO - (xO - (xO - (xO - (xO - (xO xH)))))))) - (Pif (sint) - (Papp2 (Oeq Op_int) + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp1.318" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.317" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sword U128); (sword U128)] + ; f_res := + [{| v_var := {| vtype := (sword U128) + ; vname := "rkey.316" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "temp2.317" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* keys_expand *) xO (xO (xI xH)), + {| f_info := xO (xO (xI (xO xH))) + ; f_tyin := [(sword U128)] + ; f_params := + [{| v_var := {| vtype := (sword U128) + ; vname := "key.310" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Laset AAscale U128 + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.311" |} + ; v_info := dummy_var_info |} + (Pconst (Z0))) + AT_none ((sword U128)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.310" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.312" |} + ; v_info := dummy_var_info |}] + AT_keep (Oasm (* set0_128 *) (ExtOp (Oset0 U128))) []); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "round.313" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Zpos (xH)))), + (Pconst (Zpos (xI (xI (xO xH)))))) + [MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := sint + ; vname := "rcon.314" |} + ; v_info := dummy_var_info |}] + (xI (xI (xO (xO xH)))) + [(Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "round.313" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "key.310" |} + ; v_info := dummy_var_info |}; + Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.312" |} + ; v_info := dummy_var_info |}] + (xO (xI (xO (xO xH)))) + [(Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "rcon.314" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.310" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.312" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Laset AAscale U128 + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.311" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "round.313" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) + AT_none ((sword U128)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.310" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))]) ] + ; f_tyout := [(sarr (xO (xO (xO (xO (xI (xI (xO xH))))))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.311" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* keys_expand_inv *) xI (xO (xO xH)), + {| f_info := xI (xO (xO (xO xH))) + ; f_tyin := [(sword U128)] + ; f_params := + [{| v_var := {| vtype := (sword U128) + ; vname := "key.305" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Laset AAscale U128 + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.306" |} + ; v_info := dummy_var_info |} + (Pconst (Z0))) + AT_none ((sword U128)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.305" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.307" |} + ; v_info := dummy_var_info |}] + AT_keep (Oasm (* set0_128 *) (ExtOp (Oset0 U128))) []); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "round.308" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Zpos (xH)))), + (Pconst (Zpos (xI (xI (xO xH)))))) + [MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := sint + ; vname := "rcon.309" |} + ; v_info := dummy_var_info |}] + (xI (xI (xO (xO xH)))) + [(Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "round.308" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "key.305" |} + ; v_info := dummy_var_info |}; + Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.307" |} + ; v_info := dummy_var_info |}] + (xO (xI (xO (xO xH)))) + [(Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "rcon.309" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.305" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.307" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cif + (Papp2 (Oneq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "round.308" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO (xI (xO xH)))))) + [MkI InstrInfo.witness + (Copn + [Laset AAscale U128 + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.306" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "round.308" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})] + AT_keep + (Oasm (* AESIMC *) (BaseOp (None, AESIMC))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.305" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})])] + [MkI InstrInfo.witness + (Cassgn + (Laset AAscale U128 + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.306" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "round.308" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) + AT_none ((sword U128)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.305" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))])]) ] + ; f_tyout := [(sarr (xO (xO (xO (xO (xI (xI (xO xH))))))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.306" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* aes_rounds *) xI (xI (xO xH)), + {| f_info := xO (xO (xO (xO xH))) + ; f_tyin := + [(sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))); (sword U128)] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.301" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "in.302" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "state.303" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U128)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "in.302" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "state.303" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U128)) + ((Papp2 (Olxor U128) (Pvar - {| gv := - {| v_var := - {| vtype := sint; - vname := "i.322" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pconst - (Zpos - (xO - (xO - (xO xH)))))) - (Pconst - (Zpos - (xO - (xO - (xO - (xO - (xO - (xO - (xO - xH))))))))) - (Pif (sint) - (Papp2 (Oeq Op_int) - (Pvar - {| gv := + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "state.303" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pget AAscale U128 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.301" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pconst (Z0)))))); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "round.304" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Zpos (xH)))), + (Pconst (Zpos (xO (xI (xO xH)))))) + [MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "state.303" |} + ; v_info := dummy_var_info |}] + AT_keep (Oasm (* AESENC *) (BaseOp (None, AESENC))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "state.303" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pget AAscale U128 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.301" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "round.304" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))])]); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "state.303" |} + ; v_info := dummy_var_info |}] + AT_keep (Oasm (* AESENCLAST *) (BaseOp (None, AESENCLAST))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "state.303" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pget AAscale U128 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.301" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pconst (Zpos (xO (xI (xO xH))))))]) ] + ; f_tyout := [(sword U128)] + ; f_res := + [{| v_var := {| vtype := (sword U128) + ; vname := "state.303" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* AddRoundKey *) xO (xI (xI xH)), + {| f_info := xI (xI (xI xH)) + ; f_tyin := [(sword U128); (sword U128)] + ; f_params := + [{| v_var := {| vtype := (sword U128) + ; vname := "state.299" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "rk.300" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "state.299" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U128)) + ((Papp2 (Olxor U128) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "state.299" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "rk.300" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))) ] + ; f_tyout := [(sword U128)] + ; f_res := + [{| v_var := {| vtype := (sword U128) + ; vname := "state.299" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* invaes_rounds *) xO (xO (xO xH)), + {| f_info := xI (xO (xI xH)) + ; f_tyin := + [(sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))); (sword U128)] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.294" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "in.295" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "state.296" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U128)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "in.295" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "rk.297" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U128)) + ((Pget AAscale U128 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.294" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pconst (Zpos (xO (xI (xO xH)))))))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "state.296" |} + ; v_info := dummy_var_info |}] + (xO (xI (xI xH))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "state.296" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "rk.297" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "round.298" |} + ; v_info := dummy_var_info |}) + ((DownTo, (Pconst (Z0))), (Pconst (Zpos (xI (xO (xO xH)))))) + [MkI InstrInfo.witness + (Copn + [Lvar {| v_var := - {| vtype := sint; - vname := "i.322" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pconst - (Zpos - (xI - (xO - (xO xH)))))) - (Pconst - (Zpos - (xI - (xI - (xO - (xI xH)))))) - (Pconst - (Zpos - (xO - (xI - (xI - (xO - (xI xH)))))))))))))))))]; - f_tyout := [sint]; - f_res := - [{| v_var := - {| vtype := sint; vname := "c.323" |}; - v_info := dummy_var_info |}]; - f_extra := tt |})]; - p_globs := []; p_extra := tt |} -. \ No newline at end of file + {| vtype := (sword U128) + ; vname := "state.296" |} + ; v_info := dummy_var_info |}] + AT_keep (Oasm (* AESDEC *) (BaseOp (None, AESDEC))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "state.296" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pget AAscale U128 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.294" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "round.298" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))])]); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "state.296" |} + ; v_info := dummy_var_info |}] + AT_keep (Oasm (* AESDECLAST *) (BaseOp (None, AESDECLAST))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "state.296" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pget AAscale U128 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.294" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pconst (Z0)))]) ] + ; f_tyout := [(sword U128)] + ; f_res := + [{| v_var := {| vtype := (sword U128) + ; vname := "state.296" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* aes *) xO (xI xH), + {| f_info := xO (xI (xO xH)) + ; f_tyin := [(sword U128); (sword U128)] + ; f_params := + [{| v_var := {| vtype := (sword U128) + ; vname := "key.290" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "in.291" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.293" |} + ; v_info := dummy_var_info |}] + (xO (xO (xI xH))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.290" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "out.292" |} + ; v_info := dummy_var_info |}] + (xI (xI (xO xH))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.293" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "in.291" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sword U128)] + ; f_res := + [{| v_var := {| vtype := (sword U128) + ; vname := "out.292" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* invaes *) xI xH, + {| f_info := xI (xI xH) + ; f_tyin := [(sword U128); (sword U128)] + ; f_params := + [{| v_var := {| vtype := (sword U128) + ; vname := "key.286" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "in.287" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.289" |} + ; v_info := dummy_var_info |}] + (xI (xO (xO xH))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.286" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "out.288" |} + ; v_info := dummy_var_info |}] + (xO (xO (xO xH))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.289" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "in.287" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sword U128)] + ; f_res := + [{| v_var := {| vtype := (sword U128) + ; vname := "out.288" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* aes_jazz *) xO (xO xH), + {| f_info := xI (xO xH) + ; f_tyin := [(sword U128); (sword U128)] + ; f_params := + [{| v_var := {| vtype := (sword U128) + ; vname := "key.283" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "in.284" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "out.285" |} + ; v_info := dummy_var_info |}] + (xO (xI xH)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.283" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "in.284" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sword U128)] + ; f_res := + [{| v_var := {| vtype := (sword U128) + ; vname := "out.285" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* invaes_jazz *) xH, + {| f_info := xO xH + ; f_tyin := [(sword U128); (sword U128)] + ; f_params := + [{| v_var := {| vtype := (sword U128) + ; vname := "key.280" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "in.281" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "out.282" |} + ; v_info := dummy_var_info |}] + (xI xH) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.280" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "in.281" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sword U128)] + ; f_res := + [{| v_var := {| vtype := (sword U128) + ; vname := "out.282" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) ] ; + p_globs := [] ; + p_extra := tt |}. +Defined. diff --git a/theories/Jasmin/examples/bigadd.v b/theories/Jasmin/examples/bigadd.v index 05cf1f5d..7e3a009b 100644 --- a/theories/Jasmin/examples/bigadd.v +++ b/theories/Jasmin/examples/bigadd.v @@ -1,310 +1,206 @@ +Set Warnings "-notation-overridden,-ambiguous-paths". +From mathcomp Require Import all_ssreflect all_algebra reals distr realsum + fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool + ssrnum eqtype choice seq. +Set Warnings "notation-overridden,ambiguous-paths". + Require Import List. +Set Warnings "-notation-overridden". From Jasmin Require Import expr. -From Jasmin Require Import x86_extra. +Set Warnings "notation-overridden". +From Jasmin Require Import x86_instr_decl x86_extra. +From JasminSSProve Require Import jasmin_translate. +From Crypt Require Import Prelude Package. Import ListNotations. Local Open Scope string. -Definition bigadd := {| p_funcs := - [(xH, - {| f_info := xO xH; - f_tyin := - [sarr - (xO - (xO - (xO - (xO - (xO xH))))); - sarr - (xO - (xO - (xO - (xO - (xO xH)))))]; - f_params := - [{| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO xH))))); - vname := "x.151" |}; - v_info := dummy_var_info |}; - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO xH))))); - vname := "y.152" |}; - v_info := dummy_var_info |}]; - f_body := - [MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "xr.154" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U64) - (Pget (AAscale) (U64) - ({| gv := - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO xH))))); - vname := "x.151" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pconst Z0))); - MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "yr.155" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U64) - (Pget (AAscale) (U64) - ({| gv := - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO xH))))); - vname := "y.152" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pconst Z0))); - MkI - (dummy_instr_info) - (Copn - ([Lvar - {| v_var := - {| vtype := sbool; - vname := "cf.156" |}; - v_info := dummy_var_info |}; - Lvar - {| v_var := - {| vtype := - sword U64; - vname := "xr.154" |}; - v_info := dummy_var_info |}]) - (AT_keep) (Oaddcarry U64) - ([Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "xr.154" |}; - v_info := dummy_var_info |}; - gs := Slocal |}; - Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "yr.155" |}; - v_info := dummy_var_info |}; - gs := Slocal |}; - Pbool false])); - MkI - (dummy_instr_info) - (Cassgn - (Laset (AAscale) (U64) - ({| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO xH))))); - vname := "res.153" |}; - v_info := dummy_var_info |}) - (Pconst Z0)) - (AT_none) (sword U64) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "xr.154" |}; - v_info := dummy_var_info |}; - gs := Slocal |})); - MkI - (dummy_instr_info) - (Cfor - ({| v_var := - {| vtype := sint; vname := "i.157" |}; - v_info := dummy_var_info |}) - (((UpTo, - Pconst (Zpos xH)), - Pconst - (Zpos - (xO - (xO xH))))) - ([MkI - (dummy_instr_info) + + + +Definition ssprove_jasmin_prog : uprog. +Proof. + refine {| p_funcs := + [ ( (* add_inline *) xH, + {| f_info := xO xH + ; f_tyin := + [(sarr (xO (xO (xO (xO (xO xH)))))); + (sarr (xO (xO (xO (xO (xO xH))))))] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xO xH)))))) + ; vname := "x.151" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xO xH)))))) + ; vname := "y.152" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "xr.154" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U64) - (Pget (AAscale) (U64) - ({| gv := - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO xH))))); - vname := "x.151" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pvar - {| gv := - {| v_var := - {| vtype := sint; - vname := "i.157" |}; - v_info := dummy_var_info |}; - gs := Slocal |}))); - MkI - (dummy_instr_info) + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "xr.154" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO xH)))))) + ; vname := "x.151" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pconst (Z0))))); + MkI InstrInfo.witness (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "yr.155" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U64) - (Pget (AAscale) (U64) - ({| gv := - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO xH))))); - vname := "y.152" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pvar - {| gv := - {| v_var := - {| vtype := sint; - vname := "i.157" |}; - v_info := dummy_var_info |}; - gs := Slocal |}))); - MkI - (dummy_instr_info) + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "yr.155" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO xH)))))) + ; vname := "y.152" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pconst (Z0))))); + MkI InstrInfo.witness (Copn - ([Lvar - {| v_var := - {| vtype := sbool; - vname := "cf.156" |}; - v_info := dummy_var_info |}; - Lvar - {| v_var := - {| vtype := - sword U64; - vname := "xr.154" |}; - v_info := dummy_var_info |}]) - (AT_keep) (Oaddcarry U64) - ([Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "xr.154" |}; - v_info := dummy_var_info |}; - gs := Slocal |}; - Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "yr.155" |}; - v_info := dummy_var_info |}; - gs := Slocal |}; - Pvar - {| gv := - {| v_var := - {| vtype := sbool; - vname := "cf.156" |}; - v_info := dummy_var_info |}; - gs := Slocal |}])); - MkI - (dummy_instr_info) + [Lvar + {| v_var := {| vtype := sbool + ; vname := "cf.156" |} + ; v_info := dummy_var_info |}; + Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "xr.154" |} + ; v_info := dummy_var_info |}] + AT_keep (Oaddcarry (U64)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "xr.154" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "yr.155" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pbool false)]); + MkI InstrInfo.witness (Cassgn - (Laset (AAscale) (U64) - ({| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO xH))))); - vname := "res.153" |}; - v_info := dummy_var_info |}) - (Pvar - {| gv := + (Laset AAscale U64 {| v_var := - {| vtype := sint; - vname := "i.157" |}; - v_info := dummy_var_info |}; - gs := Slocal |})) - (AT_none) (sword U64) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "xr.154" |}; - v_info := dummy_var_info |}; - gs := Slocal |}))]))]; - f_tyout := - [sarr - (xO - (xO - (xO - (xO - (xO xH)))))]; - f_res := - [{| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO xH))))); - vname := "res.153" |}; - v_info := dummy_var_info |}]; - f_extra := tt |})]; - p_globs := []; p_extra := tt |} -. \ No newline at end of file + {| vtype := (sarr (xO (xO (xO (xO (xO xH)))))) + ; vname := "res.153" |} + ; v_info := dummy_var_info |} + (Pconst (Z0))) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "xr.154" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "i.157" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Zpos (xH)))), (Pconst (Zpos (xO (xO xH))))) + [MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "xr.154" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO xH)))))) + ; vname := "x.151" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.157" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "yr.155" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO xH)))))) + ; vname := "y.152" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.157" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := sbool + ; vname := "cf.156" |} + ; v_info := dummy_var_info |}; + Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "xr.154" |} + ; v_info := dummy_var_info |}] + AT_keep (Oaddcarry (U64)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "xr.154" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "yr.155" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := sbool + ; vname := "cf.156" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xO xH)))))) + ; vname := "res.153" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.157" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "xr.154" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))]) ] + ; f_tyout := [(sarr (xO (xO (xO (xO (xO xH))))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xO xH)))))) + ; vname := "res.153" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) ] ; + p_globs := [] ; + p_extra := tt |}. +Defined. diff --git a/theories/Jasmin/examples/ex.v b/theories/Jasmin/examples/ex.v index 6da00c6e..cf52163d 100644 --- a/theories/Jasmin/examples/ex.v +++ b/theories/Jasmin/examples/ex.v @@ -1,96 +1,90 @@ +Set Warnings "-notation-overridden,-ambiguous-paths". +From mathcomp Require Import all_ssreflect all_algebra reals distr realsum + fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool + ssrnum eqtype choice seq. +Set Warnings "notation-overridden,ambiguous-paths". + Require Import List. +Set Warnings "-notation-overridden". From Jasmin Require Import expr. -From Jasmin Require Import x86_extra. +Set Warnings "notation-overridden". +From Jasmin Require Import x86_instr_decl x86_extra. +From JasminSSProve Require Import jasmin_translate. +From Crypt Require Import Prelude Package. Import ListNotations. Local Open Scope string. -Definition ex := {| p_funcs := - [(xH, - {| f_info := xO xH; - f_tyin := - [sword U64; - sword U64]; - f_params := - [{| v_var := - {| vtype := sword U64; - vname := "x.144" |}; - v_info := dummy_var_info |}; - {| v_var := - {| vtype := sword U64; - vname := "y.145" |}; - v_info := dummy_var_info |}]; - f_body := - [MkI - (dummy_instr_info) - (Copn - ([Lvar - {| v_var := - {| vtype := sbool; - vname := "cf.146" |}; - v_info := dummy_var_info |}; - Lvar - {| v_var := - {| vtype := - sword U64; - vname := "x.144" |}; - v_info := dummy_var_info |}]) - (AT_keep) (Oaddcarry U64) - ([Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "x.144" |}; - v_info := dummy_var_info |}; - gs := Slocal |}; - Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "y.145" |}; - v_info := dummy_var_info |}; - gs := Slocal |}; - Pbool false])); - MkI - (dummy_instr_info) - (Copn - ([Lvar - {| v_var := - {| vtype := sbool; - vname := "cf.146" |}; - v_info := dummy_var_info |}; - Lvar - {| v_var := - {| vtype := - sword U64; - vname := "y.145" |}; - v_info := dummy_var_info |}]) - (AT_keep) (Oaddcarry U64) - ([Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "y.145" |}; - v_info := dummy_var_info |}; - gs := Slocal |}; - Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "x.144" |}; - v_info := dummy_var_info |}; - gs := Slocal |}; - Pbool false]))]; - f_tyout := [sword U64]; - f_res := - [{| v_var := - {| vtype := sword U64; - vname := "y.145" |}; - v_info := dummy_var_info |}]; - f_extra := tt |})]; - p_globs := []; p_extra := tt |} -. \ No newline at end of file + + + +Definition ssprove_jasmin_prog : uprog. +Proof. + refine {| p_funcs := + [ ( (* add *) xH, + {| f_info := xO xH + ; f_tyin := [(sword U64); (sword U64)] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "x.144" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U64) + ; vname := "y.145" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := {| vtype := sbool + ; vname := "cf.146" |} + ; v_info := dummy_var_info |}; + Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "x.144" |} + ; v_info := dummy_var_info |}] + AT_keep (Oaddcarry (U64)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "x.144" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "y.145" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pbool false)]); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := {| vtype := sbool + ; vname := "cf.146" |} + ; v_info := dummy_var_info |}; + Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "y.145" |} + ; v_info := dummy_var_info |}] + AT_keep (Oaddcarry (U64)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "y.145" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "x.144" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pbool false)]) ] + ; f_tyout := [(sword U64)] + ; f_res := + [{| v_var := {| vtype := (sword U64) + ; vname := "y.145" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) ] ; + p_globs := [] ; + p_extra := tt |}. +Defined. diff --git a/theories/Jasmin/examples/gen_and_test.sh b/theories/Jasmin/examples/gen_and_test.sh index 237084b4..7f265433 100755 --- a/theories/Jasmin/examples/gen_and_test.sh +++ b/theories/Jasmin/examples/gen_and_test.sh @@ -1,15 +1,19 @@ #!/bin/bash # test deextraction of all .jazz in this folder, note that their corresponding .v will be overwritten +JASMINC=${JASMINC:-$(which jasminc)} + # assuming jasmin is in home directory for f in *.jazz do -if [ $f != "aes.jazz" ] -then - JASMINC=~/jasmin/compiler/jasminc.byte ./gen_ast.sh $f - coqc $(basename $f .jazz).v -fi + echo $f + $JASMINC -I AES:../examples -coq $f > $(basename $f .jazz).v + # JASMINC=~/jasmin/compiler/jasminc.byte ./gen_ast.sh $f + cd ../../.. + coqc -Q theories/Mon Mon \ + -Q theories/Relational Relational \ + -Q theories/Crypt Crypt \ + -Q theories/Jasmin JasminSSProve \ + theories/Jasmin/examples/"$(basename $f .jazz)".v + cd - done - -JASMINC=~/jasmin/compiler/jasminc.byte ./gen_ast.sh aes '-I AES:../examples' -coqc aes.v diff --git a/theories/Jasmin/examples/int_add.v b/theories/Jasmin/examples/int_add.v index 68b7476a..5588f333 100644 --- a/theories/Jasmin/examples/int_add.v +++ b/theories/Jasmin/examples/int_add.v @@ -1,121 +1,114 @@ +Set Warnings "-notation-overridden,-ambiguous-paths". +From mathcomp Require Import all_ssreflect all_algebra reals distr realsum + fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool + ssrnum eqtype choice seq. +Set Warnings "notation-overridden,ambiguous-paths". + Require Import List. +Set Warnings "-notation-overridden". From Jasmin Require Import expr. -From Jasmin Require Import x86_extra. +Set Warnings "notation-overridden". +From Jasmin Require Import x86_instr_decl x86_extra. +From JasminSSProve Require Import jasmin_translate. +From Crypt Require Import Prelude Package. Import ListNotations. Local Open Scope string. -Definition int_add := {| p_funcs := - [(xH, - {| f_info := xO xH; - f_tyin := [sint; sint]; - f_params := - [{| v_var := - {| vtype := sint; vname := "n.154" |}; - v_info := dummy_var_info |}; - {| v_var := - {| vtype := sint; vname := "m.155" |}; - v_info := dummy_var_info |}]; - f_body := - [MkI - (dummy_instr_info) - (Cfor - ({| v_var := - {| vtype := sint; vname := "i.156" |}; - v_info := dummy_var_info |}) - (((UpTo, Pconst Z0), - Pvar - {| gv := - {| v_var := - {| vtype := sint; - vname := "n.154" |}; - v_info := dummy_var_info |}; - gs := Slocal |})) - ([MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := sint; - vname := "m.155" |}; - v_info := dummy_var_info |}) - (AT_inline) (sint) - (Papp2 (Oadd Op_int) - (Pvar - {| gv := - {| v_var := - {| vtype := sint; - vname := "m.155" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pconst (Zpos xH))))]))]; - f_tyout := [sint]; - f_res := - [{| v_var := - {| vtype := sint; vname := "m.155" |}; - v_info := dummy_var_info |}]; - f_extra := tt |}); - (xI xH, - {| f_info := - xO (xO xH); - f_tyin := - [sword U64; - sword U64]; - f_params := - [{| v_var := - {| vtype := sword U64; - vname := "n.157" |}; - v_info := dummy_var_info |}; - {| v_var := - {| vtype := sword U64; - vname := "m.158" |}; - v_info := dummy_var_info |}]; - f_body := - [MkI - (dummy_instr_info) - (Cfor - ({| v_var := - {| vtype := sint; vname := "i.159" |}; - v_info := dummy_var_info |}) - (((UpTo, Pconst Z0), - Papp1 (Oint_of_word U64) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "n.157" |}; - v_info := dummy_var_info |}; - gs := Slocal |}))) - ([MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "m.158" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U64) - (Papp2 - (Oadd (Op_w U64)) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "m.158" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Papp1 (Oword_of_int U64) - (Pconst - (Zpos xH)))))]))]; - f_tyout := [sword U64]; - f_res := - [{| v_var := - {| vtype := sword U64; - vname := "m.158" |}; - v_info := dummy_var_info |}]; - f_extra := tt |})]; - p_globs := []; p_extra := tt |} -. \ No newline at end of file + + + +Definition ssprove_jasmin_prog : uprog. +Proof. + refine {| p_funcs := + [ ( (* odd *) xI xH, + {| f_info := xO (xO xH) + ; f_tyin := [(sword U64); (sword U64)] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "n.157" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U64) + ; vname := "m.158" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "i.159" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Z0))), + (Papp1 (Oint_of_word U64) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "n.157" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))) + [MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "m.158" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp2 (Oadd (Op_w U64)) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "m.158" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Papp1 (Oword_of_int U64) (Pconst (Zpos (xH)))))))]) ] + ; f_tyout := [(sword U64)] + ; f_res := + [{| v_var := {| vtype := (sword U64) + ; vname := "m.158" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* add *) xH, + {| f_info := xO xH + ; f_tyin := [sint; sint] + ; f_params := + [{| v_var := {| vtype := sint + ; vname := "n.154" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := sint + ; vname := "m.155" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "i.156" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Z0))), + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "n.154" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) + [MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := {| vtype := sint + ; vname := "m.155" |} + ; v_info := dummy_var_info |}) + AT_inline (sint) + ((Papp2 (Oadd Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "m.155" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xH))))))]) ] + ; f_tyout := [sint] + ; f_res := + [{| v_var := {| vtype := sint + ; vname := "m.155" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) ] ; + p_globs := [] ; + p_extra := tt |}. +Defined. diff --git a/theories/Jasmin/examples/int_incr.v b/theories/Jasmin/examples/int_incr.v index d3e22f5f..ea01b2a8 100644 --- a/theories/Jasmin/examples/int_incr.v +++ b/theories/Jasmin/examples/int_incr.v @@ -1,98 +1,100 @@ +Set Warnings "-notation-overridden,-ambiguous-paths". +From mathcomp Require Import all_ssreflect all_algebra reals distr realsum + fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool + ssrnum eqtype choice seq. +Set Warnings "notation-overridden,ambiguous-paths". + Require Import List. +Set Warnings "-notation-overridden". From Jasmin Require Import expr. -From Jasmin Require Import x86_extra. +Set Warnings "notation-overridden". +From Jasmin Require Import x86_instr_decl x86_extra. +From JasminSSProve Require Import jasmin_translate. +From Crypt Require Import Prelude Package. Import ListNotations. Local Open Scope string. -Definition int_incr := {| p_funcs := - [(xH, - {| f_info := xO xH; - f_tyin := []; f_params := []; - f_body := - [MkI - (dummy_instr_info) - (Ccall (InlineFun) - ([Lvar - {| v_var := - {| vtype := sint; vname := "x.153" |}; - v_info := dummy_var_info |}]) - (xI xH) - ([Pconst Z0])); - MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "xx.154" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U64) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "y.152" |}; - v_info := dummy_var_info |}; - gs := Slocal |})); - MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "y.152" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U64) - (Papp1 (Oword_of_int U64) - (Pvar - {| gv := - {| v_var := - {| vtype := sint; - vname := "x.153" |}; - v_info := dummy_var_info |}; - gs := Slocal |})))]; - f_tyout := [sword U64]; - f_res := - [{| v_var := - {| vtype := sword U64; - vname := "y.152" |}; - v_info := dummy_var_info |}]; - f_extra := tt |}); - (xI xH, - {| f_info := - xO (xO xH); - f_tyin := [sint]; - f_params := - [{| v_var := - {| vtype := sint; vname := "n.155" |}; - v_info := dummy_var_info |}]; - f_body := - [MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := sint; vname := "m.156" |}; - v_info := dummy_var_info |}) - (AT_inline) (sint) - (Papp2 (Oadd Op_int) - (Pvar - {| gv := - {| v_var := - {| vtype := sint; - vname := "n.155" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pconst (Zpos xH))))]; - f_tyout := [sint]; - f_res := - [{| v_var := - {| vtype := sint; vname := "m.156" |}; - v_info := dummy_var_info |}]; - f_extra := tt |})]; - p_globs := []; p_extra := tt |} -. \ No newline at end of file + + + +Definition ssprove_jasmin_prog : uprog. +Proof. + refine {| p_funcs := + [ ( (* incr *) xI xH, + {| f_info := xO (xO xH) + ; f_tyin := [sint] + ; f_params := + [{| v_var := {| vtype := sint + ; vname := "n.155" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := {| vtype := sint + ; vname := "m.156" |} + ; v_info := dummy_var_info |}) + AT_inline (sint) + ((Papp2 (Oadd Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "n.155" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xH)))))) ] + ; f_tyout := [sint] + ; f_res := + [{| v_var := {| vtype := sint + ; vname := "m.156" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* f *) xH, + {| f_info := xO xH + ; f_tyin := [] + ; f_params := [] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := {| vtype := sint + ; vname := "x.153" |} + ; v_info := dummy_var_info |}] + (xI xH) [(Pconst (Z0))]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "xx.154" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "y.152" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := {| vtype := (sword U64) + ; vname := "y.152" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp1 (Oword_of_int U64) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "x.153" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))) ] + ; f_tyout := [(sword U64)] + ; f_res := + [{| v_var := {| vtype := (sword U64) + ; vname := "y.152" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) ] ; + p_globs := [] ; + p_extra := tt |}. +Defined. diff --git a/theories/Jasmin/examples/int_reg.v b/theories/Jasmin/examples/int_reg.v index 4dbdb397..97698bf1 100644 --- a/theories/Jasmin/examples/int_reg.v +++ b/theories/Jasmin/examples/int_reg.v @@ -1,38 +1,53 @@ +Set Warnings "-notation-overridden,-ambiguous-paths". +From mathcomp Require Import all_ssreflect all_algebra reals distr realsum + fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool + ssrnum eqtype choice seq. +Set Warnings "notation-overridden,ambiguous-paths". + Require Import List. +Set Warnings "-notation-overridden". From Jasmin Require Import expr. -From Jasmin Require Import x86_extra. +Set Warnings "notation-overridden". +From Jasmin Require Import x86_instr_decl x86_extra. +From JasminSSProve Require Import jasmin_translate. +From Crypt Require Import Prelude Package. Import ListNotations. Local Open Scope string. -Definition int_reg := {| p_funcs := - [(xH, - {| f_info := xO xH; - f_tyin := [sint]; - f_params := - [{| v_var := - {| vtype := sint; vname := "k.141" |}; - v_info := dummy_var_info |}]; - f_body := - [MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := sint; vname := "x.142" |}; - v_info := dummy_var_info |}) - (AT_none) (sint) - (Pvar - {| gv := - {| v_var := - {| vtype := sint; vname := "k.141" |}; - v_info := dummy_var_info |}; - gs := Slocal |}))]; - f_tyout := [sint]; - f_res := - [{| v_var := - {| vtype := sint; vname := "x.142" |}; - v_info := dummy_var_info |}]; - f_extra := tt |})]; - p_globs := []; p_extra := tt |} -. \ No newline at end of file + + + +Definition ssprove_jasmin_prog : uprog. +Proof. + refine {| p_funcs := + [ ( (* foo *) xH, + {| f_info := xO xH + ; f_tyin := [sint] + ; f_params := + [{| v_var := {| vtype := sint + ; vname := "k.141" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := {| vtype := sint + ; vname := "x.142" |} + ; v_info := dummy_var_info |}) + AT_none (sint) + ((Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.141" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))) ] + ; f_tyout := [sint] + ; f_res := + [{| v_var := {| vtype := sint + ; vname := "x.142" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) ] ; + p_globs := [] ; + p_extra := tt |}. +Defined. diff --git a/theories/Jasmin/examples/int_shift.v b/theories/Jasmin/examples/int_shift.v index ca36d57f..d1090bbe 100644 --- a/theories/Jasmin/examples/int_shift.v +++ b/theories/Jasmin/examples/int_shift.v @@ -1,87 +1,87 @@ +Set Warnings "-notation-overridden,-ambiguous-paths". +From mathcomp Require Import all_ssreflect all_algebra reals distr realsum + fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool + ssrnum eqtype choice seq. +Set Warnings "notation-overridden,ambiguous-paths". + Require Import List. +Set Warnings "-notation-overridden". From Jasmin Require Import expr. -From Jasmin Require Import x86_extra. +Set Warnings "notation-overridden". +From Jasmin Require Import x86_instr_decl x86_extra. +From JasminSSProve Require Import jasmin_translate. +From Crypt Require Import Prelude Package. Import ListNotations. Local Open Scope string. -Definition int_shift := {| p_funcs := - [(xH, - {| f_info := xO xH; - f_tyin := []; f_params := []; - f_body := - [MkI - (dummy_instr_info) - (Ccall (InlineFun) - ([Lvar - {| v_var := - {| vtype := sint; vname := "x.151" |}; - v_info := dummy_var_info |}]) - (xI xH) - ([Pconst Z0])); - MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "y.150" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U64) - (Papp1 (Oword_of_int U64) - (Pvar - {| gv := - {| v_var := - {| vtype := sint; - vname := "x.151" |}; - v_info := dummy_var_info |}; - gs := Slocal |})))]; - f_tyout := [sword U64]; - f_res := - [{| v_var := - {| vtype := sword U64; - vname := "y.150" |}; - v_info := dummy_var_info |}]; - f_extra := tt |}); - (xI xH, - {| f_info := - xO (xO xH); - f_tyin := [sint]; - f_params := - [{| v_var := - {| vtype := sint; vname := "n.152" |}; - v_info := dummy_var_info |}]; - f_body := - [MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := sint; vname := "m.153" |}; - v_info := dummy_var_info |}) - (AT_inline) (sint) - (Papp2 (Olsl Op_int) - (Pvar - {| gv := - {| v_var := - {| vtype := sint; - vname := "n.152" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pconst - (Zpos - (xI - (xO - (xO - (xO - (xO - (xO xH))))))))))]; - f_tyout := [sint]; - f_res := - [{| v_var := - {| vtype := sint; vname := "m.153" |}; - v_info := dummy_var_info |}]; - f_extra := tt |})]; - p_globs := []; p_extra := tt |} -. \ No newline at end of file + + + +Definition ssprove_jasmin_prog : uprog. +Proof. + refine {| p_funcs := + [ ( (* incr *) xI xH, + {| f_info := xO (xO xH) + ; f_tyin := [sint] + ; f_params := + [{| v_var := {| vtype := sint + ; vname := "n.152" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := {| vtype := sint + ; vname := "m.153" |} + ; v_info := dummy_var_info |}) + AT_inline (sint) + ((Papp2 (Olsl Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "n.152" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xI (xO (xO (xO (xO (xO xH))))))))))) ] + ; f_tyout := [sint] + ; f_res := + [{| v_var := {| vtype := sint + ; vname := "m.153" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* f *) xH, + {| f_info := xO xH + ; f_tyin := [] + ; f_params := [] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := {| vtype := sint + ; vname := "x.151" |} + ; v_info := dummy_var_info |}] + (xI xH) [(Pconst (Z0))]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := {| vtype := (sword U64) + ; vname := "y.150" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp1 (Oword_of_int U64) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "x.151" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))) ] + ; f_tyout := [(sword U64)] + ; f_res := + [{| v_var := {| vtype := (sword U64) + ; vname := "y.150" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) ] ; + p_globs := [] ; + p_extra := tt |}. +Defined. diff --git a/theories/Jasmin/examples/liveness_bork.v b/theories/Jasmin/examples/liveness_bork.v index 554fb460..554bab55 100644 --- a/theories/Jasmin/examples/liveness_bork.v +++ b/theories/Jasmin/examples/liveness_bork.v @@ -1,65 +1,68 @@ +Set Warnings "-notation-overridden,-ambiguous-paths". +From mathcomp Require Import all_ssreflect all_algebra reals distr realsum + fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool + ssrnum eqtype choice seq. +Set Warnings "notation-overridden,ambiguous-paths". + Require Import List. +Set Warnings "-notation-overridden". From Jasmin Require Import expr. -From Jasmin Require Import x86_extra. +Set Warnings "notation-overridden". +From Jasmin Require Import x86_instr_decl x86_extra. +From JasminSSProve Require Import jasmin_translate. +From Crypt Require Import Prelude Package. Import ListNotations. Local Open Scope string. -Definition liveness_bork := {| p_funcs := - [(xH, - {| f_info := xO xH; - f_tyin := [sword U64]; - f_params := - [{| v_var := - {| vtype := sword U64; - vname := "n.141" |}; - v_info := dummy_var_info |}]; - f_body := - [MkI - (dummy_instr_info) - (Cfor - ({| v_var := - {| vtype := sint; vname := "i.142" |}; - v_info := dummy_var_info |}) - (((UpTo, Pconst Z0), - Papp1 (Oint_of_word U64) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "n.141" |}; - v_info := dummy_var_info |}; - gs := Slocal |}))) - ([MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "n.141" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U64) - (Papp2 - (Oadd (Op_w U64)) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "n.141" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Papp1 (Oword_of_int U64) - (Pconst - (Zpos xH)))))]))]; - f_tyout := [sword U64]; - f_res := - [{| v_var := - {| vtype := sword U64; - vname := "n.141" |}; - v_info := dummy_var_info |}]; - f_extra := tt |})]; - p_globs := []; p_extra := tt |} -. \ No newline at end of file + + + +Definition ssprove_jasmin_prog : uprog. +Proof. + refine {| p_funcs := + [ ( (* double *) xH, + {| f_info := xO xH + ; f_tyin := [(sword U64)] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "n.141" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "i.142" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Z0))), + (Papp1 (Oint_of_word U64) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "n.141" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))) + [MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "n.141" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp2 (Oadd (Op_w U64)) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "n.141" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Papp1 (Oword_of_int U64) (Pconst (Zpos (xH)))))))]) ] + ; f_tyout := [(sword U64)] + ; f_res := + [{| v_var := {| vtype := (sword U64) + ; vname := "n.141" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) ] ; + p_globs := [] ; + p_extra := tt |}. +Defined. diff --git a/theories/Jasmin/examples/matrix_product.v b/theories/Jasmin/examples/matrix_product.v index 05d9d33c..a3bd6f8c 100644 --- a/theories/Jasmin/examples/matrix_product.v +++ b/theories/Jasmin/examples/matrix_product.v @@ -1,1359 +1,641 @@ +Set Warnings "-notation-overridden,-ambiguous-paths". +From mathcomp Require Import all_ssreflect all_algebra reals distr realsum + fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool + ssrnum eqtype choice seq. +Set Warnings "notation-overridden,ambiguous-paths". + Require Import List. +Set Warnings "-notation-overridden". From Jasmin Require Import expr. -From Jasmin Require Import x86_extra. +Set Warnings "notation-overridden". +From Jasmin Require Import x86_instr_decl x86_extra. +From JasminSSProve Require Import jasmin_translate. +From Crypt Require Import Prelude Package. Import ListNotations. Local Open Scope string. -Definition matrix_product := {| p_funcs := - [(xH, - {| f_info := xO xH; - f_tyin := - [sword U64; - sword U64; - sword U64]; - f_params := - [{| v_var := - {| vtype := sword U64; - vname := "x.218" |}; - v_info := dummy_var_info |}; - {| v_var := - {| vtype := sword U64; - vname := "y.219" |}; - v_info := dummy_var_info |}; - {| v_var := - {| vtype := sword U64; - vname := "z.220" |}; - v_info := dummy_var_info |}]; - f_body := - [MkI - (dummy_instr_info) - (Cfor - ({| v_var := - {| vtype := sint; vname := "i.221" |}; - v_info := dummy_var_info |}) - (((UpTo, Pconst Z0), - Papp2 (Omul Op_int) - (Pconst - (Zpos - (xO - (xI - (xO xH))))) - (Pconst - (Zpos - (xO - (xI - (xO xH))))))) - ([MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "tmp.222" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U64) - (Pload (U64) - ({| v_var := - {| vtype := - sword U64; - vname := "x.218" |}; - v_info := dummy_var_info |}) - (Papp1 (Oword_of_int U64) - (Papp2 (Omul Op_int) - (Pconst - (Zpos - (xO - (xO - (xO xH))))) - (Pvar - {| gv := - {| v_var := - {| vtype := sint; - vname := "i.221" |}; - v_info := dummy_var_info |}; - gs := Slocal |}))))); - MkI - (dummy_instr_info) - (Cassgn - (Laset (AAscale) (U64) - ({| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI - xH))))))))); - vname := "mx.223" |}; - v_info := dummy_var_info |}) - (Pvar - {| gv := - {| v_var := - {| vtype := sint; - vname := "i.221" |}; - v_info := dummy_var_info |}; - gs := Slocal |})) - (AT_none) (sword U64) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "tmp.222" |}; - v_info := dummy_var_info |}; - gs := Slocal |})); - MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "tmp.222" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U64) - (Pload (U64) - ({| v_var := - {| vtype := - sword U64; - vname := "y.219" |}; - v_info := dummy_var_info |}) - (Papp1 (Oword_of_int U64) - (Papp2 (Omul Op_int) - (Pconst - (Zpos - (xO - (xO - (xO xH))))) - (Pvar - {| gv := - {| v_var := - {| vtype := sint; - vname := "i.221" |}; - v_info := dummy_var_info |}; - gs := Slocal |}))))); - MkI - (dummy_instr_info) + + + +Definition ssprove_jasmin_prog : uprog. +Proof. + refine {| p_funcs := + [ ( (* dot_product *) xI (xO (xO xH)), + {| f_info := xO (xI (xO xH)) + ; f_tyin := + [(sarr (xO (xO (xO (xO (xI (xO xH))))))); + (sarr (xO (xO (xO (xO (xI (xO xH)))))))] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xO xH))))))) + ; vname := "v1.243" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xO xH))))))) + ; vname := "v2.244" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness (Cassgn - (Laset (AAscale) (U64) - ({| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI - xH))))))))); - vname := "my.224" |}; - v_info := dummy_var_info |}) - (Pvar - {| gv := + (Lvar {| v_var := - {| vtype := sint; - vname := "i.221" |}; - v_info := dummy_var_info |}; - gs := Slocal |})) - (AT_none) (sword U64) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "tmp.222" |}; - v_info := dummy_var_info |}; - gs := Slocal |}))])); - MkI - (dummy_instr_info) - (Ccall (DoNotInline) - ([Lvar - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI - xH))))))))); - vname := "mz.225" |}; - v_info := dummy_var_info |}]) - (xI xH) - ([Pvar - {| gv := - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI - xH))))))))); - vname := "mx.223" |}; - v_info := dummy_var_info |}; - gs := Slocal |}; - Pvar - {| gv := - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI - xH))))))))); - vname := "my.224" |}; - v_info := dummy_var_info |}; - gs := Slocal |}; - Pvar - {| gv := - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI - xH))))))))); - vname := "mz.225" |}; - v_info := dummy_var_info |}; - gs := Slocal |}])); - MkI - (dummy_instr_info) - (Cfor - ({| v_var := - {| vtype := sint; vname := "i.221" |}; - v_info := dummy_var_info |}) - (((UpTo, Pconst Z0), - Papp2 (Omul Op_int) - (Pconst - (Zpos - (xO - (xI - (xO xH))))) - (Pconst - (Zpos - (xO - (xI - (xO xH))))))) - ([MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "tmp.222" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U64) - (Pget (AAscale) (U64) - ({| gv := - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI - xH))))))))); - vname := "mz.225" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pvar - {| gv := - {| v_var := - {| vtype := sint; - vname := "i.221" |}; - v_info := dummy_var_info |}; - gs := Slocal |}))); - MkI - (dummy_instr_info) - (Cassgn - (Lmem (U64) - ({| v_var := - {| vtype := - sword U64; - vname := "z.220" |}; - v_info := dummy_var_info |}) - (Papp1 (Oword_of_int U64) - (Papp2 (Omul Op_int) - (Pconst - (Zpos - (xO - (xO - (xO xH))))) - (Pvar - {| gv := - {| v_var := - {| vtype := sint; - vname := "i.221" |}; - v_info := dummy_var_info |}; - gs := Slocal |})))) - (AT_none) (sword U64) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "tmp.222" |}; - v_info := dummy_var_info |}; - gs := Slocal |}))]))]; - f_tyout := []; f_res := []; f_extra := tt |}); - (xI xH, - {| f_info := - xO (xO xH); - f_tyin := - [sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI xH))))))))); - sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI xH))))))))); - sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI xH)))))))))]; - f_params := - [{| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI xH))))))))); - vname := "m1.226" |}; - v_info := dummy_var_info |}; - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI xH))))))))); - vname := "m2.227" |}; - v_info := dummy_var_info |}; - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI xH))))))))); - vname := "res.228" |}; - v_info := dummy_var_info |}]; - f_body := - [MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI - xH))))))))); - vname := "pres.229" |}; - v_info := dummy_var_info |}) - (AT_none) - (sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI xH)))))))))) - (Pvar - {| gv := - {| v_var := + {| vtype := (sword U64) + ; vname := "res.245" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp1 (Oword_of_int U64) (Pconst (Z0))))); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "i.246" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Z0))), (Pconst (Zpos (xO (xI (xO xH)))))) + [MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "tmp.247" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xO xH))))))) + ; vname := "v1.243" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.246" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "tmp.247" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp2 (Omul (Op_w U64)) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "tmp.247" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xO xH))))))) + ; vname := "v2.244" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.246" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "res.245" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp2 (Oadd (Op_w U64)) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "res.245" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "tmp.247" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))))]) ] + ; f_tyout := [(sword U64)] + ; f_res := + [{| v_var := {| vtype := (sword U64) + ; vname := "res.245" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* product_matrix_vector *) xO (xI xH), + {| f_info := xO (xO (xO xH)) + ; f_tyin := + [(sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))); + (sarr (xO (xO (xO (xO (xI (xO xH))))))); + (sarr (xO (xO (xO (xO (xI (xO xH)))))))] + ; f_params := + [{| v_var := {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI - xH))))))))); - vname := "res.228" |}; - v_info := dummy_var_info |}; - gs := Slocal |})); - MkI - (dummy_instr_info) - (Ccall (DoNotInline) - ([Lvar - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI - xH))))))))); - vname := "m2t.230" |}; - v_info := dummy_var_info |}]) - (xI - (xO xH)) - ([Pvar - {| gv := - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI - xH))))))))); - vname := "m2.227" |}; - v_info := dummy_var_info |}; - gs := Slocal |}; - Pvar - {| gv := - {| v_var := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "m.238" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xO xH))))))) + ; vname := "v.239" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xO xH))))))) + ; vname := "res.240" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "i.241" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Z0))), (Pconst (Zpos (xO (xI (xO xH)))))) + [MkI InstrInfo.witness + (Ccall DoNotInline + [Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "tmp.242" |} + ; v_info := dummy_var_info |}] + (xI (xO (xO xH))) + [(Psub AAscale U64 (xO (xI (xO xH))) + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "m.238" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Papp2 (Omul Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.241" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO (xI (xO xH))))))); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xO xH))))))) + ; vname := "v.239" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Laset AAscale U64 + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xO xH))))))) + ; vname := "res.240" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.241" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "tmp.242" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))]) ] + ; f_tyout := [(sarr (xO (xO (xO (xO (xI (xO xH)))))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xO xH))))))) + ; vname := "res.240" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* transpose *) xI (xO xH), + {| f_info := xI (xI xH) + ; f_tyin := + [(sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))); + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH))))))))))] + ; f_params := + [{| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "m.233" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI - xH))))))))); - vname := "m2t.230" |}; - v_info := dummy_var_info |}; - gs := Slocal |}])); - MkI - (dummy_instr_info) - (Cfor - ({| v_var := - {| vtype := sint; vname := "i.231" |}; - v_info := dummy_var_info |}) - (((UpTo, Pconst Z0), - Pconst - (Zpos - (xO - (xI - (xO xH)))))) - ([MkI - (dummy_instr_info) - (Ccall (DoNotInline) - ([Lasub (AAscale) (U64) - (xO - (xI - (xO xH))) - ({| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI - xH))))))))); - vname := "rest.232" |}; - v_info := dummy_var_info |}) - (Papp2 (Omul Op_int) - (Pvar - {| gv := - {| v_var := - {| vtype := sint; - vname := "i.231" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pconst - (Zpos - (xO - (xI - (xO xH))))))]) - (xO - (xI xH)) - ([Pvar - {| gv := - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI - xH))))))))); - vname := "m1.226" |}; - v_info := dummy_var_info |}; - gs := Slocal |}; - Psub (AAscale) (U64) - (xO - (xI - (xO xH))) - ({| gv := - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI - xH))))))))); - vname := "m2t.230" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Papp2 (Omul Op_int) - (Pvar - {| gv := - {| v_var := - {| vtype := sint; - vname := "i.231" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pconst - (Zpos - (xO - (xI - (xO xH)))))); - Psub (AAscale) (U64) - (xO - (xI - (xO xH))) - ({| gv := - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI - xH))))))))); - vname := "rest.232" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Papp2 (Omul Op_int) - (Pvar - {| gv := - {| v_var := - {| vtype := sint; - vname := "i.231" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pconst - (Zpos - (xO - (xI - (xO xH))))))]))])); - MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI - xH))))))))); - vname := "res.228" |}; - v_info := dummy_var_info |}) - (AT_none) - (sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI xH)))))))))) - (Pvar - {| gv := - {| v_var := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "res.234" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "i.235" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Z0))), (Pconst (Zpos (xO (xI (xO xH)))))) + [MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "j.236" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Z0))), + (Pconst (Zpos (xO (xI (xO xH)))))) + [MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "tmp.237" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "m.233" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Papp2 (Oadd Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "j.236" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Papp2 (Omul Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.235" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO (xI (xO xH)))))))))); + MkI InstrInfo.witness + (Cassgn + (Laset AAscale U64 + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "res.234" |} + ; v_info := dummy_var_info |} + (Papp2 (Oadd Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.235" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Papp2 (Omul Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "j.236" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO (xI (xO xH)))))))) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "tmp.237" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))])]) ] + ; f_tyout := [(sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH))))))))))] + ; f_res := + [{| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "res.234" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* product_matrix_matrix *) xI xH, + {| f_info := xO (xO xH) + ; f_tyin := + [(sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))); + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))); + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH))))))))))] + ; f_params := + [{| v_var := {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI - xH))))))))); - vname := "pres.229" |}; - v_info := dummy_var_info |}; - gs := Slocal |})); - MkI - (dummy_instr_info) - (Ccall (DoNotInline) - ([Lvar - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI - xH))))))))); - vname := "res.228" |}; - v_info := dummy_var_info |}]) - (xI - (xO xH)) - ([Pvar - {| gv := - {| v_var := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "m1.226" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI - xH))))))))); - vname := "rest.232" |}; - v_info := dummy_var_info |}; - gs := Slocal |}; - Pvar - {| gv := - {| v_var := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "m2.227" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI - xH))))))))); - vname := "res.228" |}; - v_info := dummy_var_info |}; - gs := Slocal |}]))]; - f_tyout := - [sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI xH)))))))))]; - f_res := - [{| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI xH))))))))); - vname := "res.228" |}; - v_info := dummy_var_info |}]; - f_extra := tt |}); - (xI (xO xH), - {| f_info := - xI (xI xH); - f_tyin := - [sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI xH))))))))); - sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI xH)))))))))]; - f_params := - [{| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI xH))))))))); - vname := "m.233" |}; - v_info := dummy_var_info |}; - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI xH))))))))); - vname := "res.234" |}; - v_info := dummy_var_info |}]; - f_body := - [MkI - (dummy_instr_info) - (Cfor - ({| v_var := - {| vtype := sint; vname := "i.235" |}; - v_info := dummy_var_info |}) - (((UpTo, Pconst Z0), - Pconst - (Zpos - (xO - (xI - (xO xH)))))) - ([MkI - (dummy_instr_info) - (Cfor - ({| v_var := - {| vtype := sint; - vname := "j.236" |}; - v_info := dummy_var_info |}) - (((UpTo, Pconst Z0), - Pconst - (Zpos - (xO - (xI - (xO xH)))))) - ([MkI - (dummy_instr_info) - (Cassgn - (Lvar + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "res.228" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar {| v_var := - {| vtype := - sword U64; - vname := "tmp.237" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U64) - (Pget (AAscale) (U64) - ({| gv := - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI - xH))))))))); - vname := "m.233" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Papp2 (Oadd Op_int) - (Pvar - {| gv := - {| v_var := - {| vtype := sint; - vname := "j.236" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Papp2 (Omul Op_int) - (Pvar - {| gv := - {| v_var := - {| vtype := sint; - vname := "i.235" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pconst - (Zpos - (xO - (xI - (xO xH))))))))); - MkI - (dummy_instr_info) - (Cassgn - (Laset (AAscale) - (U64) - ({| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI - xH))))))))); - vname := "res.234" |}; - v_info := dummy_var_info |}) - (Papp2 (Oadd Op_int) - (Pvar - {| gv := - {| v_var := - {| vtype := sint; - vname := "i.235" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Papp2 (Omul Op_int) - (Pvar - {| gv := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "pres.229" |} + ; v_info := dummy_var_info |}) + AT_none + ((sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH))))))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "res.228" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall DoNotInline + [Lvar + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "m2t.230" |} + ; v_info := dummy_var_info |}] + (xI (xO xH)) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "m2.227" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "m2t.230" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "i.231" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Z0))), (Pconst (Zpos (xO (xI (xO xH)))))) + [MkI InstrInfo.witness + (Ccall DoNotInline + [Lasub AAscale U64 (xO (xI (xO xH))) {| v_var := - {| vtype := sint; - vname := "j.236" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pconst - (Zpos - (xO - (xI - (xO xH)))))))) - (AT_none) (sword U64) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "tmp.237" |}; - v_info := dummy_var_info |}; - gs := Slocal |}))]))]))]; - f_tyout := - [sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI xH)))))))))]; - f_res := - [{| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI xH))))))))); - vname := "res.234" |}; - v_info := dummy_var_info |}]; - f_extra := tt |}); - (xO (xI xH), - {| f_info := - xO - (xO (xO xH)); - f_tyin := - [sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI xH))))))))); - sarr - (xO - (xO - (xO - (xO - (xI - (xO xH)))))); - sarr - (xO - (xO - (xO - (xO - (xI - (xO xH))))))]; - f_params := - [{| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI xH))))))))); - vname := "m.238" |}; - v_info := dummy_var_info |}; - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xI - (xO xH)))))); - vname := "v.239" |}; - v_info := dummy_var_info |}; - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xI - (xO xH)))))); - vname := "res.240" |}; - v_info := dummy_var_info |}]; - f_body := - [MkI - (dummy_instr_info) - (Cfor - ({| v_var := - {| vtype := sint; vname := "i.241" |}; - v_info := dummy_var_info |}) - (((UpTo, Pconst Z0), - Pconst - (Zpos - (xO - (xI - (xO xH)))))) - ([MkI - (dummy_instr_info) - (Ccall (DoNotInline) - ([Lvar - {| v_var := - {| vtype := - sword U64; - vname := "tmp.242" |}; - v_info := dummy_var_info |}]) - (xI - (xO - (xO xH))) - ([Psub (AAscale) (U64) - (xO - (xI - (xO xH))) - ({| gv := - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xO - (xI - (xO - (xO - (xI - xH))))))))); - vname := "m.238" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Papp2 (Omul Op_int) - (Pvar - {| gv := - {| v_var := - {| vtype := sint; - vname := "i.241" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pconst - (Zpos - (xO - (xI - (xO xH)))))); - Pvar - {| gv := - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xI - (xO xH)))))); - vname := "v.239" |}; - v_info := dummy_var_info |}; - gs := Slocal |}])); - MkI - (dummy_instr_info) + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "rest.232" |} + ; v_info := dummy_var_info |} + (Papp2 (Omul Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.231" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO (xI (xO xH))))))] + (xO (xI xH)) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "m1.226" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Psub AAscale U64 (xO (xI (xO xH))) + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "m2t.230" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Papp2 (Omul Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.231" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO (xI (xO xH))))))); + (Psub AAscale U64 (xO (xI (xO xH))) + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "rest.232" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Papp2 (Omul Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.231" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO (xI (xO xH)))))))])]); + MkI InstrInfo.witness (Cassgn - (Laset (AAscale) (U64) - ({| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xI - (xO xH)))))); - vname := "res.240" |}; - v_info := dummy_var_info |}) - (Pvar - {| gv := + (Lvar {| v_var := - {| vtype := sint; - vname := "i.241" |}; - v_info := dummy_var_info |}; - gs := Slocal |})) - (AT_none) (sword U64) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "tmp.242" |}; - v_info := dummy_var_info |}; - gs := Slocal |}))]))]; - f_tyout := - [sarr - (xO - (xO - (xO - (xO - (xI - (xO xH))))))]; - f_res := - [{| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xI - (xO xH)))))); - vname := "res.240" |}; - v_info := dummy_var_info |}]; - f_extra := tt |}); - (xI - (xO (xO xH)), - {| f_info := - xO - (xI (xO xH)); - f_tyin := - [sarr - (xO - (xO - (xO - (xO - (xI - (xO xH)))))); - sarr - (xO - (xO - (xO - (xO - (xI - (xO xH))))))]; - f_params := - [{| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xI - (xO xH)))))); - vname := "v1.243" |}; - v_info := dummy_var_info |}; - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xI - (xO xH)))))); - vname := "v2.244" |}; - v_info := dummy_var_info |}]; - f_body := - [MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "res.245" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U64) - (Papp1 (Oword_of_int U64) - (Pconst Z0))); - MkI - (dummy_instr_info) - (Cfor - ({| v_var := - {| vtype := sint; vname := "i.246" |}; - v_info := dummy_var_info |}) - (((UpTo, Pconst Z0), - Pconst - (Zpos - (xO - (xI - (xO xH)))))) - ([MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "tmp.247" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U64) - (Pget (AAscale) (U64) - ({| gv := - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xI - (xO xH)))))); - vname := "v1.243" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pvar - {| gv := - {| v_var := - {| vtype := sint; - vname := "i.246" |}; - v_info := dummy_var_info |}; - gs := Slocal |}))); - MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "tmp.247" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U64) - (Papp2 - (Omul (Op_w U64)) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "tmp.247" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pget (AAscale) (U64) - ({| gv := - {| v_var := - {| vtype := - sarr - (xO - (xO - (xO - (xO - (xI - (xO xH)))))); - vname := "v2.244" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pvar - {| gv := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "res.228" |} + ; v_info := dummy_var_info |}) + AT_none + ((sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH))))))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "pres.229" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall DoNotInline + [Lvar {| v_var := - {| vtype := sint; - vname := "i.246" |}; - v_info := dummy_var_info |}; - gs := Slocal |})))); - MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "res.245" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U64) - (Papp2 - (Oadd (Op_w U64)) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "res.245" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "tmp.247" |}; - v_info := dummy_var_info |}; - gs := Slocal |})))]))]; - f_tyout := [sword U64]; - f_res := - [{| v_var := - {| vtype := sword U64; - vname := "res.245" |}; - v_info := dummy_var_info |}]; - f_extra := tt |})]; - p_globs := []; p_extra := tt |} -. \ No newline at end of file + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "res.228" |} + ; v_info := dummy_var_info |}] + (xI (xO xH)) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "rest.232" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "res.228" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH))))))))))] + ; f_res := + [{| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "res.228" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* productMM *) xH, + {| f_info := xO xH + ; f_tyin := [(sword U64); (sword U64); (sword U64)] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "x.218" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U64) + ; vname := "y.219" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U64) + ; vname := "z.220" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "i.221" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Z0))), + (Papp2 (Omul Op_int) (Pconst (Zpos (xO (xI (xO xH))))) + (Pconst (Zpos (xO (xI (xO xH))))))) + [MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "tmp.222" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pload U64 + {| v_var := + {| vtype := (sword U64) + ; vname := "x.218" |} + ; v_info := dummy_var_info |} + (Papp1 (Oword_of_int U64) + (Papp2 (Omul Op_int) + (Pconst (Zpos (xO (xO (xO xH))))) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.221" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))))); + MkI InstrInfo.witness + (Cassgn + (Laset AAscale U64 + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "mx.223" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.221" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "tmp.222" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "tmp.222" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pload U64 + {| v_var := + {| vtype := (sword U64) + ; vname := "y.219" |} + ; v_info := dummy_var_info |} + (Papp1 (Oword_of_int U64) + (Papp2 (Omul Op_int) + (Pconst (Zpos (xO (xO (xO xH))))) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.221" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))))); + MkI InstrInfo.witness + (Cassgn + (Laset AAscale U64 + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "my.224" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.221" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "tmp.222" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))]); + MkI InstrInfo.witness + (Ccall DoNotInline + [Lvar + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "mz.225" |} + ; v_info := dummy_var_info |}] + (xI xH) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "mx.223" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "my.224" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "mz.225" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "i.221" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Z0))), + (Papp2 (Omul Op_int) (Pconst (Zpos (xO (xI (xO xH))))) + (Pconst (Zpos (xO (xI (xO xH))))))) + [MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "tmp.222" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "mz.225" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.221" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness + (Cassgn + (Lmem U64 + {| v_var := + {| vtype := (sword U64) + ; vname := "z.220" |} + ; v_info := dummy_var_info |} + (Papp1 (Oword_of_int U64) + (Papp2 (Omul Op_int) + (Pconst (Zpos (xO (xO (xO xH))))) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.221" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "tmp.222" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))]) ] + ; f_tyout := [] + ; f_res := [] + ; f_extra := tt + ; |} ) ] ; + p_globs := [] ; + p_extra := tt |}. +Defined. diff --git a/theories/Jasmin/examples/retz.v b/theories/Jasmin/examples/retz.v index 2b1ff5e7..d03ffe97 100644 --- a/theories/Jasmin/examples/retz.v +++ b/theories/Jasmin/examples/retz.v @@ -1,33 +1,46 @@ +Set Warnings "-notation-overridden,-ambiguous-paths". +From mathcomp Require Import all_ssreflect all_algebra reals distr realsum + fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool + ssrnum eqtype choice seq. +Set Warnings "notation-overridden,ambiguous-paths". + Require Import List. +Set Warnings "-notation-overridden". From Jasmin Require Import expr. -From Jasmin Require Import x86_extra. +Set Warnings "notation-overridden". +From Jasmin Require Import x86_instr_decl x86_extra. +From JasminSSProve Require Import jasmin_translate. +From Crypt Require Import Prelude Package. Import ListNotations. Local Open Scope string. -Definition retz := {| p_funcs := - [(xH, - {| f_info := xO xH; - f_tyin := []; f_params := []; - f_body := - [MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "z.139" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U64) - (Papp1 (Oword_of_int U64) - (Pconst Z0)))]; - f_tyout := [sword U64]; - f_res := - [{| v_var := - {| vtype := sword U64; - vname := "z.139" |}; - v_info := dummy_var_info |}]; - f_extra := tt |})]; - p_globs := []; p_extra := tt |} -. \ No newline at end of file + + + +Definition ssprove_jasmin_prog : uprog. +Proof. + refine {| p_funcs := + [ ( (* zero *) xH, + {| f_info := xO xH + ; f_tyin := [] + ; f_params := [] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := {| vtype := (sword U64) + ; vname := "z.139" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp1 (Oword_of_int U64) (Pconst (Z0))))) ] + ; f_tyout := [(sword U64)] + ; f_res := + [{| v_var := {| vtype := (sword U64) + ; vname := "z.139" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) ] ; + p_globs := [] ; + p_extra := tt |}. +Defined. diff --git a/theories/Jasmin/examples/test_for.v b/theories/Jasmin/examples/test_for.v index 5c091bd5..336e7761 100644 --- a/theories/Jasmin/examples/test_for.v +++ b/theories/Jasmin/examples/test_for.v @@ -1,66 +1,67 @@ +Set Warnings "-notation-overridden,-ambiguous-paths". +From mathcomp Require Import all_ssreflect all_algebra reals distr realsum + fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool + ssrnum eqtype choice seq. +Set Warnings "notation-overridden,ambiguous-paths". + Require Import List. +Set Warnings "-notation-overridden". From Jasmin Require Import expr. -From Jasmin Require Import x86_extra. +Set Warnings "notation-overridden". +From Jasmin Require Import x86_instr_decl x86_extra. +From JasminSSProve Require Import jasmin_translate. +From Crypt Require Import Prelude Package. Import ListNotations. Local Open Scope string. -Definition test_for := {| p_funcs := - [(xH, - {| f_info := xO xH; - f_tyin := []; f_params := []; - f_body := - [MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "r.141" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U64) - (Papp1 (Oword_of_int U64) - (Pconst Z0))); - MkI - (dummy_instr_info) - (Cfor - ({| v_var := - {| vtype := sint; vname := "i.142" |}; - v_info := dummy_var_info |}) - (((DownTo, Pconst Z0), - Pconst - (Zpos - (xI xH)))) - ([MkI - (dummy_instr_info) + + + +Definition ssprove_jasmin_prog : uprog. +Proof. + refine {| p_funcs := + [ ( (* f *) xH, + {| f_info := xO xH + ; f_tyin := [] + ; f_params := [] + ; f_body := + [ MkI InstrInfo.witness (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "r.141" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U64) - (Papp2 - (Oadd (Op_w U64)) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "r.141" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Papp1 (Oword_of_int U64) - (Pconst - (Zpos xH)))))]))]; - f_tyout := [sword U64]; - f_res := - [{| v_var := - {| vtype := sword U64; - vname := "r.141" |}; - v_info := dummy_var_info |}]; - f_extra := tt |})]; - p_globs := []; p_extra := tt |} -. \ No newline at end of file + (Lvar + {| v_var := {| vtype := (sword U64) + ; vname := "r.141" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp1 (Oword_of_int U64) (Pconst (Z0))))); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "i.142" |} + ; v_info := dummy_var_info |}) + ((DownTo, (Pconst (Z0))), (Pconst (Zpos (xI xH)))) + [MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "r.141" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp2 (Oadd (Op_w U64)) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "r.141" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Papp1 (Oword_of_int U64) (Pconst (Zpos (xH)))))))]) ] + ; f_tyout := [(sword U64)] + ; f_res := + [{| v_var := {| vtype := (sword U64) + ; vname := "r.141" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) ] ; + p_globs := [] ; + p_extra := tt |}. +Defined. diff --git a/theories/Jasmin/examples/test_inline_var.v b/theories/Jasmin/examples/test_inline_var.v index e685449a..dc8adc47 100644 --- a/theories/Jasmin/examples/test_inline_var.v +++ b/theories/Jasmin/examples/test_inline_var.v @@ -1,201 +1,152 @@ +Set Warnings "-notation-overridden,-ambiguous-paths". +From mathcomp Require Import all_ssreflect all_algebra reals distr realsum + fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool + ssrnum eqtype choice seq. +Set Warnings "notation-overridden,ambiguous-paths". + Require Import List. +Set Warnings "-notation-overridden". From Jasmin Require Import expr. -From Jasmin Require Import x86_extra. +Set Warnings "notation-overridden". +From Jasmin Require Import x86_instr_decl x86_extra. +From JasminSSProve Require Import jasmin_translate. +From Crypt Require Import Prelude Package. Import ListNotations. Local Open Scope string. -Definition test_inline_var := {| p_funcs := - [(xH, - {| f_info := xO xH; - f_tyin := [sword U64]; - f_params := - [{| v_var := - {| vtype := sword U64; - vname := "r1.150" |}; - v_info := dummy_var_info |}]; - f_body := - [MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "r.151" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U64) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "r1.150" |}; - v_info := dummy_var_info |}; - gs := Slocal |})); - MkI - (dummy_instr_info) - (Ccall (InlineFun) - ([Lvar - {| v_var := - {| vtype := - sword U64; - vname := "r.151" |}; - v_info := dummy_var_info |}]) - (xI xH) - ([Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "r.151" |}; - v_info := dummy_var_info |}; - gs := Slocal |}; - Papp1 (Oword_of_int U64) - (Pconst - (Zpos - (xO - (xI xH))))])); - MkI - (dummy_instr_info) - (Ccall (InlineFun) - ([Lvar - {| v_var := - {| vtype := - sword U64; - vname := "r.151" |}; - v_info := dummy_var_info |}]) - (xI xH) - ([Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "r.151" |}; - v_info := dummy_var_info |}; - gs := Slocal |}; - Papp1 (Oword_of_int U64) - (Pconst - (Zpos - (xI xH)))])); - MkI - (dummy_instr_info) - (Ccall (InlineFun) - ([Lvar - {| v_var := - {| vtype := - sword U64; - vname := "r.151" |}; - v_info := dummy_var_info |}]) - (xI xH) - ([Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "r.151" |}; - v_info := dummy_var_info |}; - gs := Slocal |}; - Papp1 (Oword_of_int U64) - (Pconst - (Zpos - (xI - (xO xH))))]))]; - f_tyout := [sword U64]; - f_res := - [{| v_var := - {| vtype := sword U64; - vname := "r.151" |}; - v_info := dummy_var_info |}]; - f_extra := tt |}); - (xI xH, - {| f_info := - xO (xO xH); - f_tyin := - [sword U64; - sword U64]; - f_params := - [{| v_var := - {| vtype := sword U64; - vname := "r.152" |}; - v_info := dummy_var_info |}; - {| v_var := - {| vtype := sword U64; - vname := "n.153" |}; - v_info := dummy_var_info |}]; - f_body := - [MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "r.152" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U64) - (Papp2 - (Oadd (Op_w U64)) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "r.152" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "n.153" |}; - v_info := dummy_var_info |}; - gs := Slocal |}))); - MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "r.152" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U64) - (Papp2 - (Oadd (Op_w U64)) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "r.152" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Papp2 - (Oadd (Op_w U64)) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "n.153" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "n.153" |}; - v_info := dummy_var_info |}; - gs := Slocal |}))))]; - f_tyout := [sword U64]; - f_res := - [{| v_var := - {| vtype := sword U64; - vname := "r.152" |}; - v_info := dummy_var_info |}]; - f_extra := tt |})]; - p_globs := []; p_extra := tt |} -. \ No newline at end of file + + + +Definition ssprove_jasmin_prog : uprog. +Proof. + refine {| p_funcs := + [ ( (* addn *) xI xH, + {| f_info := xO (xO xH) + ; f_tyin := [(sword U64); (sword U64)] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "r.152" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U64) + ; vname := "n.153" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := {| vtype := (sword U64) + ; vname := "r.152" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp2 (Oadd (Op_w U64)) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "r.152" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "n.153" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := {| vtype := (sword U64) + ; vname := "r.152" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp2 (Oadd (Op_w U64)) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "r.152" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Papp2 (Oadd (Op_w U64)) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "n.153" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "n.153" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))))) ] + ; f_tyout := [(sword U64)] + ; f_res := + [{| v_var := {| vtype := (sword U64) + ; vname := "r.152" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* f *) xH, + {| f_info := xO xH + ; f_tyin := [(sword U64)] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "r1.150" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := {| vtype := (sword U64) + ; vname := "r.151" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "r1.150" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := {| vtype := (sword U64) + ; vname := "r.151" |} + ; v_info := dummy_var_info |}] + (xI xH) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "r.151" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Papp1 (Oword_of_int U64) (Pconst (Zpos (xO (xI xH)))))]); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := {| vtype := (sword U64) + ; vname := "r.151" |} + ; v_info := dummy_var_info |}] + (xI xH) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "r.151" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Papp1 (Oword_of_int U64) (Pconst (Zpos (xI xH))))]); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := {| vtype := (sword U64) + ; vname := "r.151" |} + ; v_info := dummy_var_info |}] + (xI xH) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "r.151" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Papp1 (Oword_of_int U64) (Pconst (Zpos (xI (xO xH)))))]) ] + ; f_tyout := [(sword U64)] + ; f_res := + [{| v_var := {| vtype := (sword U64) + ; vname := "r.151" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) ] ; + p_globs := [] ; + p_extra := tt |}. +Defined. diff --git a/theories/Jasmin/examples/test_shift.v b/theories/Jasmin/examples/test_shift.v index 9281fbd5..6fe6f119 100644 --- a/theories/Jasmin/examples/test_shift.v +++ b/theories/Jasmin/examples/test_shift.v @@ -1,47 +1,53 @@ +Set Warnings "-notation-overridden,-ambiguous-paths". +From mathcomp Require Import all_ssreflect all_algebra reals distr realsum + fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool + ssrnum eqtype choice seq. +Set Warnings "notation-overridden,ambiguous-paths". + Require Import List. +Set Warnings "-notation-overridden". From Jasmin Require Import expr. -From Jasmin Require Import x86_extra. +Set Warnings "notation-overridden". +From Jasmin Require Import x86_instr_decl x86_extra. +From JasminSSProve Require Import jasmin_translate. +From Crypt Require Import Prelude Package. Import ListNotations. Local Open Scope string. -Definition test_shift := {| p_funcs := - [(xH, - {| f_info := xO xH; - f_tyin := [sword U64]; - f_params := - [{| v_var := - {| vtype := sword U64; - vname := "a.142" |}; - v_info := dummy_var_info |}]; - f_body := - [MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "u.143" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U64) - (Papp1 (Oword_of_int U64) - (Papp2 (Osub Op_int) - (Papp2 (Olsl Op_int) - (Pconst (Zpos xH)) - (Pconst - (Zpos - (xO - (xI - (xO - (xO xH))))))) - (Pconst (Zpos xH)))))]; - f_tyout := [sword U64]; - f_res := - [{| v_var := - {| vtype := sword U64; - vname := "u.143" |}; - v_info := dummy_var_info |}]; - f_extra := tt |})]; - p_globs := []; p_extra := tt |} -. \ No newline at end of file + + + +Definition ssprove_jasmin_prog : uprog. +Proof. + refine {| p_funcs := + [ ( (* reduce *) xH, + {| f_info := xO xH + ; f_tyin := [(sword U64)] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "a.142" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := {| vtype := (sword U64) + ; vname := "u.143" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp1 (Oword_of_int U64) + (Papp2 (Osub Op_int) + (Papp2 (Olsl Op_int) (Pconst (Zpos (xH))) + (Pconst (Zpos (xO (xI (xO (xO xH))))))) + (Pconst (Zpos (xH))))))) ] + ; f_tyout := [(sword U64)] + ; f_res := + [{| v_var := {| vtype := (sword U64) + ; vname := "u.143" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) ] ; + p_globs := [] ; + p_extra := tt |}. +Defined. diff --git a/theories/Jasmin/examples/three_functions.v b/theories/Jasmin/examples/three_functions.v index 340300ca..904b4a3e 100644 --- a/theories/Jasmin/examples/three_functions.v +++ b/theories/Jasmin/examples/three_functions.v @@ -1,147 +1,127 @@ +Set Warnings "-notation-overridden,-ambiguous-paths". +From mathcomp Require Import all_ssreflect all_algebra reals distr realsum + fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool + ssrnum eqtype choice seq. +Set Warnings "notation-overridden,ambiguous-paths". + Require Import List. +Set Warnings "-notation-overridden". From Jasmin Require Import expr. -From Jasmin Require Import x86_extra. +Set Warnings "notation-overridden". +From Jasmin Require Import x86_instr_decl x86_extra. +From JasminSSProve Require Import jasmin_translate. +From Crypt Require Import Prelude Package. Import ListNotations. Local Open Scope string. -Definition three_functions := {| p_funcs := - [(xH, - {| f_info := xO xH; - f_tyin := [sword U64]; - f_params := - [{| v_var := - {| vtype := sword U64; - vname := "z.159" |}; - v_info := dummy_var_info |}]; - f_body := - [MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "z.159" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U64) - (Papp2 - (Oadd (Op_w U64)) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "z.159" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Papp1 (Oword_of_int U64) - (Pconst - (Zpos - (xO - (xI - (xO - (xI - (xO xH)))))))))); - MkI - (dummy_instr_info) - (Ccall (DoNotInline) - ([Lvar - {| v_var := - {| vtype := - sword U64; - vname := "res_z.160" |}; - v_info := dummy_var_info |}]) - (xI xH) - ([Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "z.159" |}; - v_info := dummy_var_info |}; - gs := Slocal |}]))]; - f_tyout := [sword U64]; - f_res := - [{| v_var := - {| vtype := sword U64; - vname := "res_z.160" |}; - v_info := dummy_var_info |}]; - f_extra := tt |}); - (xI xH, - {| f_info := - xO (xO xH); - f_tyin := [sword U64]; - f_params := - [{| v_var := - {| vtype := sword U64; - vname := "y.161" |}; - v_info := dummy_var_info |}]; - f_body := - [MkI - (dummy_instr_info) - (Ccall (DoNotInline) - ([Lvar - {| v_var := - {| vtype := - sword U64; - vname := "res_y.162" |}; - v_info := dummy_var_info |}]) - (xI - (xO xH)) - ([Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "y.161" |}; - v_info := dummy_var_info |}; - gs := Slocal |}]))]; - f_tyout := [sword U64]; - f_res := - [{| v_var := - {| vtype := sword U64; - vname := "res_y.162" |}; - v_info := dummy_var_info |}]; - f_extra := tt |}); - (xI (xO xH), - {| f_info := - xO (xI xH); - f_tyin := [sword U64]; - f_params := - [{| v_var := - {| vtype := sword U64; - vname := "x.163" |}; - v_info := dummy_var_info |}]; - f_body := - [MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "res_x.164" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U64) - (Papp2 - (Oadd (Op_w U64)) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "x.163" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Papp1 (Oword_of_int U64) - (Pconst (Zpos xH)))))]; - f_tyout := [sword U64]; - f_res := - [{| v_var := - {| vtype := sword U64; - vname := "res_x.164" |}; - v_info := dummy_var_info |}]; - f_extra := tt |})]; - p_globs := []; p_extra := tt |} -. \ No newline at end of file + + + +Definition ssprove_jasmin_prog : uprog. +Proof. + refine {| p_funcs := + [ ( (* f *) xI (xO xH), + {| f_info := xO (xI xH) + ; f_tyin := [(sword U64)] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "x.163" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "res_x.164" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp2 (Oadd (Op_w U64)) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "x.163" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Papp1 (Oword_of_int U64) (Pconst (Zpos (xH))))))) ] + ; f_tyout := [(sword U64)] + ; f_res := + [{| v_var := {| vtype := (sword U64) + ; vname := "res_x.164" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* g *) xI xH, + {| f_info := xO (xO xH) + ; f_tyin := [(sword U64)] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "y.161" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Ccall DoNotInline + [Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "res_y.162" |} + ; v_info := dummy_var_info |}] + (xI (xO xH)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "y.161" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sword U64)] + ; f_res := + [{| v_var := {| vtype := (sword U64) + ; vname := "res_y.162" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* h *) xH, + {| f_info := xO xH + ; f_tyin := [(sword U64)] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "z.159" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := {| vtype := (sword U64) + ; vname := "z.159" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp2 (Oadd (Op_w U64)) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "z.159" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Papp1 (Oword_of_int U64) + (Pconst (Zpos (xO (xI (xO (xI (xO xH))))))))))); + MkI InstrInfo.witness + (Ccall DoNotInline + [Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "res_z.160" |} + ; v_info := dummy_var_info |}] + (xI xH) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "z.159" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sword U64)] + ; f_res := + [{| v_var := {| vtype := (sword U64) + ; vname := "res_z.160" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) ] ; + p_globs := [] ; + p_extra := tt |}. +Defined. diff --git a/theories/Jasmin/examples/two_functions.v b/theories/Jasmin/examples/two_functions.v index 306659e8..2dde9bf3 100644 --- a/theories/Jasmin/examples/two_functions.v +++ b/theories/Jasmin/examples/two_functions.v @@ -1,83 +1,84 @@ +Set Warnings "-notation-overridden,-ambiguous-paths". +From mathcomp Require Import all_ssreflect all_algebra reals distr realsum + fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool + ssrnum eqtype choice seq. +Set Warnings "notation-overridden,ambiguous-paths". + Require Import List. +Set Warnings "-notation-overridden". From Jasmin Require Import expr. -From Jasmin Require Import x86_extra. +Set Warnings "notation-overridden". +From Jasmin Require Import x86_instr_decl x86_extra. +From JasminSSProve Require Import jasmin_translate. +From Crypt Require Import Prelude Package. Import ListNotations. Local Open Scope string. -Definition two_functions := {| p_funcs := - [(xH, - {| f_info := xO xH; - f_tyin := [sword U64]; - f_params := - [{| v_var := - {| vtype := sword U64; - vname := "y.150" |}; - v_info := dummy_var_info |}]; - f_body := - [MkI - (dummy_instr_info) - (Ccall (DoNotInline) - ([Lvar - {| v_var := - {| vtype := - sword U64; - vname := "res_y.151" |}; - v_info := dummy_var_info |}]) - (xI xH) - ([Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "y.150" |}; - v_info := dummy_var_info |}; - gs := Slocal |}]))]; - f_tyout := [sword U64]; - f_res := - [{| v_var := - {| vtype := sword U64; - vname := "res_y.151" |}; - v_info := dummy_var_info |}]; - f_extra := tt |}); - (xI xH, - {| f_info := - xO (xO xH); - f_tyin := [sword U64]; - f_params := - [{| v_var := - {| vtype := sword U64; - vname := "x.152" |}; - v_info := dummy_var_info |}]; - f_body := - [MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "res_x.153" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U64) - (Papp2 - (Oadd (Op_w U64)) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "x.152" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Papp1 (Oword_of_int U64) - (Pconst (Zpos xH)))))]; - f_tyout := [sword U64]; - f_res := - [{| v_var := - {| vtype := sword U64; - vname := "res_x.153" |}; - v_info := dummy_var_info |}]; - f_extra := tt |})]; - p_globs := []; p_extra := tt |} -. \ No newline at end of file + + + +Definition ssprove_jasmin_prog : uprog. +Proof. + refine {| p_funcs := + [ ( (* f *) xI xH, + {| f_info := xO (xO xH) + ; f_tyin := [(sword U64)] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "x.152" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "res_x.153" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp2 (Oadd (Op_w U64)) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "x.152" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Papp1 (Oword_of_int U64) (Pconst (Zpos (xH))))))) ] + ; f_tyout := [(sword U64)] + ; f_res := + [{| v_var := {| vtype := (sword U64) + ; vname := "res_x.153" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* g *) xH, + {| f_info := xO xH + ; f_tyin := [(sword U64)] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "y.150" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Ccall DoNotInline + [Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "res_y.151" |} + ; v_info := dummy_var_info |}] + (xI xH) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "y.150" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sword U64)] + ; f_res := + [{| v_var := {| vtype := (sword U64) + ; vname := "res_y.151" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) ] ; + p_globs := [] ; + p_extra := tt |}. +Defined. diff --git a/theories/Jasmin/examples/u64_incr.v b/theories/Jasmin/examples/u64_incr.v index e1bfa14a..aca48a31 100644 --- a/theories/Jasmin/examples/u64_incr.v +++ b/theories/Jasmin/examples/u64_incr.v @@ -1,74 +1,74 @@ +Set Warnings "-notation-overridden,-ambiguous-paths". +From mathcomp Require Import all_ssreflect all_algebra reals distr realsum + fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool + ssrnum eqtype choice seq. +Set Warnings "notation-overridden,ambiguous-paths". + Require Import List. +Set Warnings "-notation-overridden". From Jasmin Require Import expr. -From Jasmin Require Import x86_extra. +Set Warnings "notation-overridden". +From Jasmin Require Import x86_instr_decl x86_extra. +From JasminSSProve Require Import jasmin_translate. +From Crypt Require Import Prelude Package. Import ListNotations. Local Open Scope string. -Definition u64_incr := {| p_funcs := - [(xH, - {| f_info := xO xH; - f_tyin := []; f_params := []; - f_body := - [MkI - (dummy_instr_info) - (Ccall (InlineFun) - ([Lvar - {| v_var := - {| vtype := - sword U64; - vname := "x.148" |}; - v_info := dummy_var_info |}]) - (xI xH) - ([Papp1 (Oword_of_int U64) - (Pconst Z0)]))]; - f_tyout := [sword U64]; - f_res := - [{| v_var := - {| vtype := sword U64; - vname := "x.148" |}; - v_info := dummy_var_info |}]; - f_extra := tt |}); - (xI xH, - {| f_info := - xO (xO xH); - f_tyin := [sword U64]; - f_params := - [{| v_var := - {| vtype := sword U64; - vname := "n.149" |}; - v_info := dummy_var_info |}]; - f_body := - [MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "m.150" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U64) - (Papp2 - (Oadd (Op_w U64)) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "n.149" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Papp1 (Oword_of_int U64) - (Pconst - (Zpos - (xO xH))))))]; - f_tyout := [sword U64]; - f_res := - [{| v_var := - {| vtype := sword U64; - vname := "m.150" |}; - v_info := dummy_var_info |}]; - f_extra := tt |})]; - p_globs := []; p_extra := tt |} -. \ No newline at end of file + + + +Definition ssprove_jasmin_prog : uprog. +Proof. + refine {| p_funcs := + [ ( (* incr *) xI xH, + {| f_info := xO (xO xH) + ; f_tyin := [(sword U64)] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "n.149" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := {| vtype := (sword U64) + ; vname := "m.150" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp2 (Oadd (Op_w U64)) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "n.149" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Papp1 (Oword_of_int U64) (Pconst (Zpos (xO xH))))))) ] + ; f_tyout := [(sword U64)] + ; f_res := + [{| v_var := {| vtype := (sword U64) + ; vname := "m.150" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* f *) xH, + {| f_info := xO xH + ; f_tyin := [] + ; f_params := [] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := {| vtype := (sword U64) + ; vname := "x.148" |} + ; v_info := dummy_var_info |}] + (xI xH) [(Papp1 (Oword_of_int U64) (Pconst (Z0)))]) ] + ; f_tyout := [(sword U64)] + ; f_res := + [{| v_var := {| vtype := (sword U64) + ; vname := "x.148" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) ] ; + p_globs := [] ; + p_extra := tt |}. +Defined. diff --git a/theories/Jasmin/examples/xor.v b/theories/Jasmin/examples/xor.v index badbe633..ab18f341 100644 --- a/theories/Jasmin/examples/xor.v +++ b/theories/Jasmin/examples/xor.v @@ -1,77 +1,74 @@ +Set Warnings "-notation-overridden,-ambiguous-paths". +From mathcomp Require Import all_ssreflect all_algebra reals distr realsum + fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool + ssrnum eqtype choice seq. +Set Warnings "notation-overridden,ambiguous-paths". + Require Import List. +Set Warnings "-notation-overridden". From Jasmin Require Import expr. -From Jasmin Require Import x86_extra. +Set Warnings "notation-overridden". +From Jasmin Require Import x86_instr_decl x86_extra. +From JasminSSProve Require Import jasmin_translate. +From Crypt Require Import Prelude Package. Import ListNotations. Local Open Scope string. -Definition xor := {| p_funcs := - [(xH, - {| f_info := xO xH; - f_tyin := - [sword U64; - sword U64]; - f_params := - [{| v_var := - {| vtype := sword U64; - vname := "x.143" |}; - v_info := dummy_var_info |}; - {| v_var := - {| vtype := sword U64; - vname := "y.144" |}; - v_info := dummy_var_info |}]; - f_body := - [MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "r.145" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U64) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "x.143" |}; - v_info := dummy_var_info |}; - gs := Slocal |})); - MkI - (dummy_instr_info) - (Cassgn - (Lvar - {| v_var := - {| vtype := - sword U64; - vname := "r.145" |}; - v_info := dummy_var_info |}) - (AT_none) (sword U64) - (Papp2 (Olxor U64) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "r.145" |}; - v_info := dummy_var_info |}; - gs := Slocal |}) - (Pvar - {| gv := - {| v_var := - {| vtype := - sword U64; - vname := "y.144" |}; - v_info := dummy_var_info |}; - gs := Slocal |})))]; - f_tyout := [sword U64]; - f_res := - [{| v_var := - {| vtype := sword U64; - vname := "r.145" |}; - v_info := dummy_var_info |}]; - f_extra := tt |})]; - p_globs := []; p_extra := tt |} -. \ No newline at end of file + + + +Definition ssprove_jasmin_prog : uprog. +Proof. + refine {| p_funcs := + [ ( (* xor *) xH, + {| f_info := xO xH + ; f_tyin := [(sword U64); (sword U64)] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "x.143" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U64) + ; vname := "y.144" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := {| vtype := (sword U64) + ; vname := "r.145" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "x.143" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := {| vtype := (sword U64) + ; vname := "r.145" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp2 (Olxor U64) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "r.145" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "y.144" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))) ] + ; f_tyout := [(sword U64)] + ; f_res := + [{| v_var := {| vtype := (sword U64) + ; vname := "r.145" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) ] ; + p_globs := [] ; + p_extra := tt |}. +Defined. From bead4e76acbb69b3ecf077cece56cd3fbde501e3 Mon Sep 17 00:00:00 2001 From: bshvass Date: Fri, 7 Oct 2022 15:08:01 +0200 Subject: [PATCH 277/383] update _CoqProject and Makefile --- Makefile | 928 +++++++++++++++++++++++++++++++++++++++++++++++++++- _CoqProject | 21 ++ 2 files changed, 940 insertions(+), 9 deletions(-) diff --git a/Makefile b/Makefile index 99a8fbe2..ac7ef75f 100644 --- a/Makefile +++ b/Makefile @@ -1,14 +1,924 @@ -all: Makefile.coq - $(MAKE) -f Makefile.coq +########################################################################## +## # The Coq Proof Assistant / The Coq Development Team ## +## v # Copyright INRIA, CNRS and contributors ## +## /dev/null 2>/dev/null; echo $$?)) +STDTIME?=command time -f $(TIMEFMT) +else +ifeq (0,$(shell gtime -f "" true >/dev/null 2>/dev/null; echo $$?)) +STDTIME?=gtime -f $(TIMEFMT) +else +STDTIME?=command time +endif +endif +else +STDTIME?=command time -f $(TIMEFMT) +endif + +COQBIN?= +ifneq (,$(COQBIN)) +# add an ending / +COQBIN:=$(COQBIN)/ +endif + +# Coq binaries +COQC ?= "$(COQBIN)coqc" +COQTOP ?= "$(COQBIN)coqtop" +COQCHK ?= "$(COQBIN)coqchk" +COQNATIVE ?= "$(COQBIN)coqnative" +COQDEP ?= "$(COQBIN)coqdep" +COQDOC ?= "$(COQBIN)coqdoc" +COQPP ?= "$(COQBIN)coqpp" +COQMKFILE ?= "$(COQBIN)coq_makefile" +OCAMLLIBDEP ?= "$(COQBIN)ocamllibdep" + +# Timing scripts +COQMAKE_ONE_TIME_FILE ?= "$(COQCORELIB)/tools/make-one-time-file.py" +COQMAKE_BOTH_TIME_FILES ?= "$(COQCORELIB)/tools/make-both-time-files.py" +COQMAKE_BOTH_SINGLE_TIMING_FILES ?= "$(COQCORELIB)/tools/make-both-single-timing-files.py" +BEFORE ?= +AFTER ?= + +# FIXME this should be generated by Coq (modules already linked by Coq) +CAMLDONTLINK=str,unix,dynlink,threads,zarith + +# OCaml binaries +CAMLC ?= "$(OCAMLFIND)" ocamlc -c +CAMLOPTC ?= "$(OCAMLFIND)" opt -c +CAMLLINK ?= "$(OCAMLFIND)" ocamlc -linkpkg -dontlink $(CAMLDONTLINK) +CAMLOPTLINK ?= "$(OCAMLFIND)" opt -linkpkg -dontlink $(CAMLDONTLINK) +CAMLDOC ?= "$(OCAMLFIND)" ocamldoc +CAMLDEP ?= "$(OCAMLFIND)" ocamldep -slash -ml-synonym .mlpack + +# DESTDIR is prepended to all installation paths +DESTDIR ?= + +# Debug builds, typically -g to OCaml, -debug to Coq. +CAMLDEBUG ?= +COQDEBUG ?= + +# Extra packages to be linked in (as in findlib -package) +CAMLPKGS ?= + +# Option for making timing files +TIMING?= +# Option for changing sorting of timing output file +TIMING_SORT_BY ?= auto +# Option for changing the fuzz parameter on the output file +TIMING_FUZZ ?= 0 +# Option for changing whether to use real or user time for timing tables +TIMING_REAL?= +# Option for including the memory column(s) +TIMING_INCLUDE_MEM?= +# Option for sorting by the memory column +TIMING_SORT_BY_MEM?= +# Output file names for timed builds +TIME_OF_BUILD_FILE ?= time-of-build.log +TIME_OF_BUILD_BEFORE_FILE ?= time-of-build-before.log +TIME_OF_BUILD_AFTER_FILE ?= time-of-build-after.log +TIME_OF_PRETTY_BUILD_FILE ?= time-of-build-pretty.log +TIME_OF_PRETTY_BOTH_BUILD_FILE ?= time-of-build-both.log +TIME_OF_PRETTY_BUILD_EXTRA_FILES ?= - # also output to the command line + +TGTS ?= + +# Retro compatibility (DESTDIR is standard on Unix, DSTROOT is not) +ifdef DSTROOT +DESTDIR := $(DSTROOT) +endif + +# Substitution of the path by appending $(DESTDIR) if needed. +# The variable $(COQMF_WINDRIVE) can be needed for Cygwin environments. +windrive_path = $(if $(COQMF_WINDRIVE),$(subst $(COQMF_WINDRIVE),/,$(1)),$(1)) +destination_path = $(if $(DESTDIR),$(DESTDIR)/$(call windrive_path,$(1)),$(1)) + +# Installation paths of libraries and documentation. +COQLIBINSTALL ?= $(call destination_path,$(COQLIB)/user-contrib) +COQDOCINSTALL ?= $(call destination_path,$(DOCDIR)/coq/user-contrib) +COQTOPINSTALL ?= $(call destination_path,$(COQLIB)/toploop) # FIXME: Unused variable? + +########## End of parameters ################################################## +# What follows may be relevant to you only if you need to +# extend this Makefile. If so, look for 'Extension point' here and +# put in Makefile.local double colon rules accordingly. +# E.g. to perform some work after the all target completes you can write +# +# post-all:: +# echo "All done!" +# +# in Makefile.local +# +############################################################################### + + + + +# Flags ####################################################################### +# +# We define a bunch of variables combining the parameters. +# To add additional flags to coq, coqchk or coqdoc, set the +# {COQ,COQCHK,COQDOC}EXTRAFLAGS variable to whatever you want to add. +# To overwrite the default choice and set your own flags entirely, set the +# {COQ,COQCHK,COQDOC}FLAGS variable. + +SHOW := $(if $(VERBOSE),@true "",@echo "") +HIDE := $(if $(VERBOSE),,@) + +TIMER=$(if $(TIMED), $(STDTIME), $(TIMECMD)) + +OPT?= + +# The DYNOBJ and DYNLIB variables are used by "coqdep -dyndep var" in .v.d +ifeq '$(OPT)' '-byte' +USEBYTE:=true +DYNOBJ:=.cma +DYNLIB:=.cma +else +USEBYTE:= +DYNOBJ:=.cmxs +DYNLIB:=.cmxs +endif + +# these variables are meant to be overridden if you want to add *extra* flags +COQEXTRAFLAGS?= +COQCHKEXTRAFLAGS?= +COQDOCEXTRAFLAGS?= + +# Find the last argument of the form "-native-compiler FLAG" +COQUSERNATIVEFLAG:=$(strip \ +$(subst -native-compiler-,,\ +$(lastword \ +$(filter -native-compiler-%,\ +$(subst -native-compiler ,-native-compiler-,\ +$(strip $(COQEXTRAFLAGS))))))) + +COQFILTEREDEXTRAFLAGS:=$(strip \ +$(filter-out -native-compiler-%,\ +$(subst -native-compiler ,-native-compiler-,\ +$(strip $(COQEXTRAFLAGS))))) + +COQACTUALNATIVEFLAG:=$(lastword $(COQMF_COQ_NATIVE_COMPILER_DEFAULT) $(COQMF_COQPROJECTNATIVEFLAG) $(COQUSERNATIVEFLAG)) + +ifeq '$(COQACTUALNATIVEFLAG)' 'yes' + COQNATIVEFLAG="-w" "-deprecated-native-compiler-option" "-native-compiler" "ondemand" + COQDONATIVE="yes" +else +ifeq '$(COQACTUALNATIVEFLAG)' 'ondemand' + COQNATIVEFLAG="-w" "-deprecated-native-compiler-option" "-native-compiler" "ondemand" + COQDONATIVE="no" +else + COQNATIVEFLAG="-w" "-deprecated-native-compiler-option" "-native-compiler" "no" + COQDONATIVE="no" +endif +endif + +# these flags do NOT contain the libraries, to make them easier to overwrite +COQFLAGS?=-q $(OTHERFLAGS) $(COQFILTEREDEXTRAFLAGS) $(COQNATIVEFLAG) +COQCHKFLAGS?=-silent -o $(COQCHKEXTRAFLAGS) +COQDOCFLAGS?=-interpolate -utf8 $(COQDOCEXTRAFLAGS) + +COQDOCLIBS?=$(COQLIBS_NOML) + +# The version of Coq being run and the version of coq_makefile that +# generated this makefile +COQ_VERSION:=$(shell $(COQC) --print-version | cut -d " " -f 1) +COQMAKEFILE_VERSION:=8.15.2 + +# COQ_SRC_SUBDIRS is for user-overriding, usually to add +# `user-contrib/Foo` to the includes, we keep COQCORE_SRC_SUBDIRS for +# Coq's own core libraries, which should be replaced by ocamlfind +# options at some point. +COQ_SRC_SUBDIRS?= +COQSRCLIBS?= $(foreach d,$(COQCORE_SRC_SUBDIRS), -I "$(COQCORELIB)/$(d)") $(foreach d,$(COQ_SRC_SUBDIRS), -I "$(COQLIB)/$(d)") + +CAMLFLAGS+=$(OCAMLLIBS) $(COQSRCLIBS) +# ocamldoc fails with unknown argument otherwise +CAMLDOCFLAGS:=$(filter-out -annot, $(filter-out -bin-annot, $(CAMLFLAGS))) +CAMLFLAGS+=$(OCAMLWARN) + +ifneq (,$(TIMING)) +TIMING_ARG=-time +ifeq (after,$(TIMING)) +TIMING_EXT=after-timing +else +ifeq (before,$(TIMING)) +TIMING_EXT=before-timing +else +TIMING_EXT=timing +endif +endif +else +TIMING_ARG= +endif + +# Files ####################################################################### +# +# We here define a bunch of variables about the files being part of the +# Coq project in order to ease the writing of build target and build rules + +VDFILE := .Makefile.d + +ALLSRCFILES := \ + $(MLGFILES) \ + $(MLFILES) \ + $(MLPACKFILES) \ + $(MLLIBFILES) \ + $(MLIFILES) + +# helpers +vo_to_obj = $(addsuffix .o,\ + $(filter-out Warning: Error:,\ + $(shell $(COQTOP) -q -noinit -batch -quiet -print-mod-uid $(1)))) +strip_dotslash = $(patsubst ./%,%,$(1)) + +# without this we get undefined variables in the expansion for the +# targets of the [deprecated,use-mllib-or-mlpack] rule +with_undef = $(if $(filter-out undefined, $(origin $(1))),$($(1))) + +VO = vo +VOS = vos + +VOFILES = $(VFILES:.v=.$(VO)) +GLOBFILES = $(VFILES:.v=.glob) +HTMLFILES = $(VFILES:.v=.html) +GHTMLFILES = $(VFILES:.v=.g.html) +BEAUTYFILES = $(addsuffix .beautified,$(VFILES)) +TEXFILES = $(VFILES:.v=.tex) +GTEXFILES = $(VFILES:.v=.g.tex) +CMOFILES = \ + $(MLGFILES:.mlg=.cmo) \ + $(MLFILES:.ml=.cmo) \ + $(MLPACKFILES:.mlpack=.cmo) +CMXFILES = $(CMOFILES:.cmo=.cmx) +OFILES = $(CMXFILES:.cmx=.o) +CMAFILES = $(MLLIBFILES:.mllib=.cma) $(MLPACKFILES:.mlpack=.cma) +CMXAFILES = $(CMAFILES:.cma=.cmxa) +CMIFILES = \ + $(CMOFILES:.cmo=.cmi) \ + $(MLIFILES:.mli=.cmi) +# the /if/ is because old _CoqProject did not list a .ml(pack|lib) but just +# a .mlg file +CMXSFILES = \ + $(MLPACKFILES:.mlpack=.cmxs) \ + $(CMXAFILES:.cmxa=.cmxs) \ + $(if $(MLPACKFILES)$(CMXAFILES),,\ + $(MLGFILES:.mlg=.cmxs) $(MLFILES:.ml=.cmxs)) + +# files that are packed into a plugin (no extension) +PACKEDFILES = \ + $(call strip_dotslash, \ + $(foreach lib, \ + $(call strip_dotslash, \ + $(MLPACKFILES:.mlpack=_MLPACK_DEPENDENCIES)),$(call with_undef,$(lib)))) +# files that are archived into a .cma (mllib) +LIBEDFILES = \ + $(call strip_dotslash, \ + $(foreach lib, \ + $(call strip_dotslash, \ + $(MLLIBFILES:.mllib=_MLLIB_DEPENDENCIES)),$(call with_undef,$(lib)))) +CMIFILESTOINSTALL = $(filter-out $(addsuffix .cmi,$(PACKEDFILES)),$(CMIFILES)) +CMOFILESTOINSTALL = $(filter-out $(addsuffix .cmo,$(PACKEDFILES)),$(CMOFILES)) +OBJFILES = $(call vo_to_obj,$(VOFILES)) +ALLNATIVEFILES = \ + $(OBJFILES:.o=.cmi) \ + $(OBJFILES:.o=.cmx) \ + $(OBJFILES:.o=.cmxs) +# trick: wildcard filters out non-existing files, so that `install` doesn't show +# warnings and `clean` doesn't pass to rm a list of files that is too long for +# the shell. +NATIVEFILES = $(wildcard $(ALLNATIVEFILES)) +FILESTOINSTALL = \ + $(VOFILES) \ + $(VFILES) \ + $(GLOBFILES) \ + $(NATIVEFILES) \ + $(CMIFILESTOINSTALL) +BYTEFILESTOINSTALL = \ + $(CMOFILESTOINSTALL) \ + $(CMAFILES) +ifeq '$(HASNATDYNLINK)' 'true' +DO_NATDYNLINK = yes +FILESTOINSTALL += $(CMXSFILES) $(CMXAFILES) $(CMOFILESTOINSTALL:.cmo=.cmx) +else +DO_NATDYNLINK = +endif + +ALLDFILES = $(addsuffix .d,$(ALLSRCFILES)) $(VDFILE) + +# Compilation targets ######################################################### + +all: + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" pre-all + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" real-all + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" post-all +.PHONY: all + +all.timing.diff: + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" pre-all + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" real-all.timing.diff TIME_OF_PRETTY_BUILD_EXTRA_FILES="" + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" post-all +.PHONY: all.timing.diff + +ifeq (0,$(TIMING_REAL)) +TIMING_REAL_ARG := +TIMING_USER_ARG := --user +else +ifeq (1,$(TIMING_REAL)) +TIMING_REAL_ARG := --real +TIMING_USER_ARG := +else +TIMING_REAL_ARG := +TIMING_USER_ARG := +endif +endif + +ifeq (0,$(TIMING_INCLUDE_MEM)) +TIMING_INCLUDE_MEM_ARG := --no-include-mem +else +TIMING_INCLUDE_MEM_ARG := +endif + +ifeq (1,$(TIMING_SORT_BY_MEM)) +TIMING_SORT_BY_MEM_ARG := --sort-by-mem +else +TIMING_SORT_BY_MEM_ARG := +endif + +make-pretty-timed-before:: TIME_OF_BUILD_FILE=$(TIME_OF_BUILD_BEFORE_FILE) +make-pretty-timed-after:: TIME_OF_BUILD_FILE=$(TIME_OF_BUILD_AFTER_FILE) +make-pretty-timed make-pretty-timed-before make-pretty-timed-after:: + $(HIDE)rm -f pretty-timed-success.ok + $(HIDE)($(MAKE) --no-print-directory -f "$(PARENT)" $(TGTS) TIMED=1 2>&1 && touch pretty-timed-success.ok) | tee -a $(TIME_OF_BUILD_FILE) + $(HIDE)rm pretty-timed-success.ok # must not be -f; must fail if the touch failed +print-pretty-timed:: + $(HIDE)$(COQMAKE_ONE_TIME_FILE) $(TIMING_INCLUDE_MEM_ARG) $(TIMING_SORT_BY_MEM_ARG) $(TIMING_REAL_ARG) $(TIME_OF_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) +print-pretty-timed-diff:: + $(HIDE)$(COQMAKE_BOTH_TIME_FILES) --sort-by=$(TIMING_SORT_BY) $(TIMING_INCLUDE_MEM_ARG) $(TIMING_SORT_BY_MEM_ARG) $(TIMING_REAL_ARG) $(TIME_OF_BUILD_AFTER_FILE) $(TIME_OF_BUILD_BEFORE_FILE) $(TIME_OF_PRETTY_BOTH_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) +ifeq (,$(BEFORE)) +print-pretty-single-time-diff:: + @echo 'Error: Usage: $(MAKE) print-pretty-single-time-diff AFTER=path/to/file.v.after-timing BEFORE=path/to/file.v.before-timing' + $(HIDE)false +else +ifeq (,$(AFTER)) +print-pretty-single-time-diff:: + @echo 'Error: Usage: $(MAKE) print-pretty-single-time-diff AFTER=path/to/file.v.after-timing BEFORE=path/to/file.v.before-timing' + $(HIDE)false +else +print-pretty-single-time-diff:: + $(HIDE)$(COQMAKE_BOTH_SINGLE_TIMING_FILES) --fuzz=$(TIMING_FUZZ) --sort-by=$(TIMING_SORT_BY) $(TIMING_USER_ARG) $(AFTER) $(BEFORE) $(TIME_OF_PRETTY_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) +endif +endif +pretty-timed: + $(HIDE)$(MAKE) --no-print-directory -f "$(PARENT)" make-pretty-timed + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" print-pretty-timed +.PHONY: pretty-timed make-pretty-timed make-pretty-timed-before make-pretty-timed-after print-pretty-timed print-pretty-timed-diff print-pretty-single-time-diff + +# Extension points for actions to be performed before/after the all target +pre-all:: + @# Extension point + $(HIDE)if [ "$(COQMAKEFILE_VERSION)" != "$(COQ_VERSION)" ]; then\ + echo "W: This Makefile was generated by Coq $(COQMAKEFILE_VERSION)";\ + echo "W: while the current Coq version is $(COQ_VERSION)";\ + fi +.PHONY: pre-all + +post-all:: + @# Extension point +.PHONY: post-all + +real-all: $(VOFILES) $(if $(USEBYTE),bytefiles,optfiles) +.PHONY: real-all + +real-all.timing.diff: $(VOFILES:.vo=.v.timing.diff) +.PHONY: real-all.timing.diff + +bytefiles: $(CMOFILES) $(CMAFILES) +.PHONY: bytefiles + +optfiles: $(if $(DO_NATDYNLINK),$(CMXSFILES)) +.PHONY: optfiles + +# FIXME, see Ralf's bugreport +# quick is deprecated, now renamed vio +vio: $(VOFILES:.vo=.vio) +.PHONY: vio +quick: vio + $(warning "'make quick' is deprecated, use 'make vio' or consider using 'vos' files") +.PHONY: quick + +vio2vo: + $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) \ + -schedule-vio2vo $(J) $(VOFILES:%.vo=%.vio) +.PHONY: vio2vo + +# quick2vo is undocumented +quick2vo: + $(HIDE)make -j $(J) vio + $(HIDE)VIOFILES=$$(for vofile in $(VOFILES); do \ + viofile="$$(echo "$$vofile" | sed "s/\.vo$$/.vio/")"; \ + if [ "$$vofile" -ot "$$viofile" -o ! -e "$$vofile" ]; then printf "$$viofile "; fi; \ + done); \ + echo "VIO2VO: $$VIOFILES"; \ + if [ -n "$$VIOFILES" ]; then \ + $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) -schedule-vio2vo $(J) $$VIOFILES; \ + fi +.PHONY: quick2vo + +checkproofs: + $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) \ + -schedule-vio-checking $(J) $(VOFILES:%.vo=%.vio) +.PHONY: checkproofs + +vos: $(VOFILES:%.vo=%.vos) +.PHONY: vos + +vok: $(VOFILES:%.vo=%.vok) +.PHONY: vok + +validate: $(VOFILES) + $(TIMER) $(COQCHK) $(COQCHKFLAGS) $(COQLIBS_NOML) $^ +.PHONY: validate + +only: $(TGTS) +.PHONY: only + +# Documentation targets ####################################################### + +html: $(GLOBFILES) $(VFILES) + $(SHOW)'COQDOC -d html $(GAL)' + $(HIDE)mkdir -p html + $(HIDE)$(COQDOC) \ + -toc $(COQDOCFLAGS) -html $(GAL) $(COQDOCLIBS) -d html $(VFILES) + +mlihtml: $(MLIFILES:.mli=.cmi) + $(SHOW)'CAMLDOC -d $@' + $(HIDE)mkdir $@ || rm -rf $@/* + $(HIDE)$(CAMLDOC) -html \ + -d $@ -m A $(CAMLDEBUG) $(CAMLDOCFLAGS) $(MLIFILES) + +all-mli.tex: $(MLIFILES:.mli=.cmi) + $(SHOW)'CAMLDOC -latex $@' + $(HIDE)$(CAMLDOC) -latex \ + -o $@ -m A $(CAMLDEBUG) $(CAMLDOCFLAGS) $(MLIFILES) + +all.ps: $(VFILES) + $(SHOW)'COQDOC -ps $(GAL)' + $(HIDE)$(COQDOC) \ + -toc $(COQDOCFLAGS) -ps $(GAL) $(COQDOCLIBS) \ + -o $@ `$(COQDEP) -sort $(VFILES)` + +all.pdf: $(VFILES) + $(SHOW)'COQDOC -pdf $(GAL)' + $(HIDE)$(COQDOC) \ + -toc $(COQDOCFLAGS) -pdf $(GAL) $(COQDOCLIBS) \ + -o $@ `$(COQDEP) -sort $(VFILES)` + +# FIXME: not quite right, since the output name is different +gallinahtml: GAL=-g +gallinahtml: html + +all-gal.ps: GAL=-g +all-gal.ps: all.ps + +all-gal.pdf: GAL=-g +all-gal.pdf: all.pdf + +# ? +beautify: $(BEAUTYFILES) + for file in $^; do mv $${file%.beautified} $${file%beautified}old && mv $${file} $${file%.beautified}; done + @echo 'Do not do "make clean" until you are sure that everything went well!' + @echo 'If there were a problem, execute "for file in $$(find . -name \*.v.old -print); do mv $${file} $${file%.old}; done" in your shell/' +.PHONY: beautify + +# Installation targets ######################################################## +# +# There rules can be extended in Makefile.local +# Extensions can't assume when they run. install: - $(MAKE) -f Makefile.coq install + $(HIDE)code=0; for f in $(FILESTOINSTALL); do\ + if ! [ -f "$$f" ]; then >&2 echo $$f does not exist; code=1; fi \ + done; exit $$code + $(HIDE)for f in $(FILESTOINSTALL); do\ + df="`$(COQMKFILE) -destination-of "$$f" $(COQLIBS)`";\ + if [ "$$?" != "0" -o -z "$$df" ]; then\ + echo SKIP "$$f" since it has no logical path;\ + else\ + install -d "$(COQLIBINSTALL)/$$df" &&\ + install -m 0644 "$$f" "$(COQLIBINSTALL)/$$df" &&\ + echo INSTALL "$$f" "$(COQLIBINSTALL)/$$df";\ + fi;\ + done + $(HIDE)$(MAKE) install-extra -f "$(SELF)" +install-extra:: + @# Extension point +.PHONY: install install-extra + +install-byte: + $(HIDE)for f in $(BYTEFILESTOINSTALL); do\ + df="`$(COQMKFILE) -destination-of "$$f" $(COQLIBS)`";\ + if [ "$$?" != "0" -o -z "$$df" ]; then\ + echo SKIP "$$f" since it has no logical path;\ + else\ + install -d "$(COQLIBINSTALL)/$$df" &&\ + install -m 0644 "$$f" "$(COQLIBINSTALL)/$$df" &&\ + echo INSTALL "$$f" "$(COQLIBINSTALL)/$$df";\ + fi;\ + done + +install-doc:: html mlihtml + @# Extension point + $(HIDE)install -d "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/html" + $(HIDE)for i in html/*; do \ + dest="$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/$$i";\ + install -m 0644 "$$i" "$$dest";\ + echo INSTALL "$$i" "$$dest";\ + done + $(HIDE)install -d \ + "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/mlihtml" + $(HIDE)for i in mlihtml/*; do \ + dest="$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/$$i";\ + install -m 0644 "$$i" "$$dest";\ + echo INSTALL "$$i" "$$dest";\ + done +.PHONY: install-doc + +uninstall:: + @# Extension point + $(HIDE)for f in $(FILESTOINSTALL); do \ + df="`$(COQMKFILE) -destination-of "$$f" $(COQLIBS)`" &&\ + instf="$(COQLIBINSTALL)/$$df/`basename $$f`" &&\ + rm -f "$$instf" &&\ + echo RM "$$instf" &&\ + (rmdir "$(COQLIBINSTALL)/$$df/" 2>/dev/null || true); \ + done +.PHONY: uninstall + +uninstall-doc:: + @# Extension point + $(SHOW)'RM $(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/html' + $(HIDE)rm -rf "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/html" + $(SHOW)'RM $(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/mlihtml' + $(HIDE)rm -rf "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/mlihtml" + $(HIDE) rmdir "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/" || true +.PHONY: uninstall-doc + +# Cleaning #################################################################### +# +# There rules can be extended in Makefile.local +# Extensions can't assume when they run. + +clean:: + @# Extension point + $(SHOW)'CLEAN' + $(HIDE)rm -f $(CMOFILES) + $(HIDE)rm -f $(CMIFILES) + $(HIDE)rm -f $(CMAFILES) + $(HIDE)rm -f $(CMOFILES:.cmo=.cmx) + $(HIDE)rm -f $(CMXAFILES) + $(HIDE)rm -f $(CMXSFILES) + $(HIDE)rm -f $(CMOFILES:.cmo=.o) + $(HIDE)rm -f $(CMXAFILES:.cmxa=.a) + $(HIDE)rm -f $(MLGFILES:.mlg=.ml) + $(HIDE)rm -f $(ALLDFILES) + $(HIDE)rm -f $(NATIVEFILES) + $(HIDE)find . -name .coq-native -type d -empty -delete + $(HIDE)rm -f $(VOFILES) + $(HIDE)rm -f $(VOFILES:.vo=.vio) + $(HIDE)rm -f $(VOFILES:.vo=.vos) + $(HIDE)rm -f $(VOFILES:.vo=.vok) + $(HIDE)rm -f $(BEAUTYFILES) $(VFILES:=.old) + $(HIDE)rm -f all.ps all-gal.ps all.pdf all-gal.pdf all.glob all-mli.tex + $(HIDE)rm -f $(VFILES:.v=.glob) + $(HIDE)rm -f $(VFILES:.v=.tex) + $(HIDE)rm -f $(VFILES:.v=.g.tex) + $(HIDE)rm -f pretty-timed-success.ok + $(HIDE)rm -rf html mlihtml +.PHONY: clean + +cleanall:: clean + @# Extension point + $(SHOW)'CLEAN *.aux *.timing' + $(HIDE)rm -f $(foreach f,$(VFILES:.v=),$(dir $(f)).$(notdir $(f)).aux) + $(HIDE)rm -f $(TIME_OF_BUILD_FILE) $(TIME_OF_BUILD_BEFORE_FILE) $(TIME_OF_BUILD_AFTER_FILE) $(TIME_OF_PRETTY_BUILD_FILE) $(TIME_OF_PRETTY_BOTH_BUILD_FILE) + $(HIDE)rm -f $(VOFILES:.vo=.v.timing) + $(HIDE)rm -f $(VOFILES:.vo=.v.before-timing) + $(HIDE)rm -f $(VOFILES:.vo=.v.after-timing) + $(HIDE)rm -f $(VOFILES:.vo=.v.timing.diff) + $(HIDE)rm -f .lia.cache .nia.cache +.PHONY: cleanall + +archclean:: + @# Extension point + $(SHOW)'CLEAN *.cmx *.o' + $(HIDE)rm -f $(NATIVEFILES) + $(HIDE)rm -f $(CMOFILES:%.cmo=%.cmx) +.PHONY: archclean + + +# Compilation rules ########################################################### + +$(MLIFILES:.mli=.cmi): %.cmi: %.mli + $(SHOW)'CAMLC -c $<' + $(HIDE)$(TIMER) $(CAMLC) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) $< + +$(MLGFILES:.mlg=.ml): %.ml: %.mlg + $(SHOW)'COQPP $<' + $(HIDE)$(COQPP) $< + +# Stupid hack around a deficient syntax: we cannot concatenate two expansions +$(filter %.cmo, $(MLFILES:.ml=.cmo) $(MLGFILES:.mlg=.cmo)): %.cmo: %.ml + $(SHOW)'CAMLC -c $<' + $(HIDE)$(TIMER) $(CAMLC) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) $< + +# Same hack +$(filter %.cmx, $(MLFILES:.ml=.cmx) $(MLGFILES:.mlg=.cmx)): %.cmx: %.ml + $(SHOW)'CAMLOPT -c $(FOR_PACK) $<' + $(HIDE)$(TIMER) $(CAMLOPTC) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) $(FOR_PACK) $< + + +$(MLLIBFILES:.mllib=.cmxs): %.cmxs: %.cmxa + $(SHOW)'CAMLOPT -shared -o $@' + $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) \ + -linkall -shared -o $@ $< + +$(MLLIBFILES:.mllib=.cma): %.cma: | %.mllib + $(SHOW)'CAMLC -a -o $@' + $(HIDE)$(TIMER) $(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) -a -o $@ $^ + +$(MLLIBFILES:.mllib=.cmxa): %.cmxa: | %.mllib + $(SHOW)'CAMLOPT -a -o $@' + $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) -a -o $@ $^ + + +$(MLPACKFILES:.mlpack=.cmxs): %.cmxs: %.cmxa + $(SHOW)'CAMLOPT -shared -o $@' + $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) \ + -shared -linkall -o $@ $< + +$(MLPACKFILES:.mlpack=.cmxa): %.cmxa: %.cmx + $(SHOW)'CAMLOPT -a -o $@' + $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) -a -o $@ $< + +$(MLPACKFILES:.mlpack=.cma): %.cma: %.cmo | %.mlpack + $(SHOW)'CAMLC -a -o $@' + $(HIDE)$(TIMER) $(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) -a -o $@ $^ + +$(MLPACKFILES:.mlpack=.cmo): %.cmo: | %.mlpack + $(SHOW)'CAMLC -pack -o $@' + $(HIDE)$(TIMER) $(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) -pack -o $@ $^ + +$(MLPACKFILES:.mlpack=.cmx): %.cmx: | %.mlpack + $(SHOW)'CAMLOPT -pack -o $@' + $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) -pack -o $@ $^ + +# This rule is for _CoqProject with no .mllib nor .mlpack +$(filter-out $(MLLIBFILES:.mllib=.cmxs) $(MLPACKFILES:.mlpack=.cmxs) $(addsuffix .cmxs,$(PACKEDFILES)) $(addsuffix .cmxs,$(LIBEDFILES)),$(MLFILES:.ml=.cmxs) $(MLGFILES:.mlg=.cmxs)): %.cmxs: %.cmx + $(SHOW)'[deprecated,use-mllib-or-mlpack] CAMLOPT -shared -o $@' + $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) \ + -shared -o $@ $< + +ifneq (,$(TIMING)) +TIMING_EXTRA = > $<.$(TIMING_EXT) +else +TIMING_EXTRA = +endif + +$(VOFILES): %.vo: %.v | $(VDFILE) + $(SHOW)COQC $< + $(HIDE)$(TIMER) $(COQC) $(COQDEBUG) $(TIMING_ARG) $(COQFLAGS) $(COQLIBS) $< $(TIMING_EXTRA) +ifeq ($(COQDONATIVE), "yes") + $(SHOW)COQNATIVE $@ + $(HIDE)$(COQNATIVE) $(COQLIBS) $@ +endif + +# FIXME ?merge with .vo / .vio ? +$(GLOBFILES): %.glob: %.v + $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< + +$(VFILES:.v=.vio): %.vio: %.v + $(SHOW)COQC -vio $< + $(HIDE)$(TIMER) $(COQC) -vio $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< + +$(VFILES:.v=.vos): %.vos: %.v + $(SHOW)COQC -vos $< + $(HIDE)$(TIMER) $(COQC) -vos $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< + +$(VFILES:.v=.vok): %.vok: %.v + $(SHOW)COQC -vok $< + $(HIDE)$(TIMER) $(COQC) -vok $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< + +$(addsuffix .timing.diff,$(VFILES)): %.timing.diff : %.before-timing %.after-timing + $(SHOW)PYTHON TIMING-DIFF $*.{before,after}-timing + $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" print-pretty-single-time-diff BEFORE=$*.before-timing AFTER=$*.after-timing TIME_OF_PRETTY_BUILD_FILE="$@" + +$(BEAUTYFILES): %.v.beautified: %.v + $(SHOW)'BEAUTIFY $<' + $(HIDE)$(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) -beautify $< + +$(TEXFILES): %.tex: %.v + $(SHOW)'COQDOC -latex $<' + $(HIDE)$(COQDOC) $(COQDOCFLAGS) -latex $< -o $@ + +$(GTEXFILES): %.g.tex: %.v + $(SHOW)'COQDOC -latex -g $<' + $(HIDE)$(COQDOC) $(COQDOCFLAGS) -latex -g $< -o $@ + +$(HTMLFILES): %.html: %.v %.glob + $(SHOW)'COQDOC -html $<' + $(HIDE)$(COQDOC) $(COQDOCFLAGS) -html $< -o $@ + +$(GHTMLFILES): %.g.html: %.v %.glob + $(SHOW)'COQDOC -html -g $<' + $(HIDE)$(COQDOC) $(COQDOCFLAGS) -html -g $< -o $@ + +# Dependency files ############################################################ + +ifndef MAKECMDGOALS + -include $(ALLDFILES) +else + ifneq ($(filter-out archclean clean cleanall printenv make-pretty-timed make-pretty-timed-before make-pretty-timed-after print-pretty-timed print-pretty-timed-diff print-pretty-single-time-diff,$(MAKECMDGOALS)),) + -include $(ALLDFILES) + endif +endif + +.SECONDARY: $(ALLDFILES) + +redir_if_ok = > "$@" || ( RV=$$?; rm -f "$@"; exit $$RV ) + +GENMLFILES:=$(MLGFILES:.mlg=.ml) +$(addsuffix .d,$(ALLSRCFILES)): $(GENMLFILES) + +$(addsuffix .d,$(MLIFILES)): %.mli.d: %.mli + $(SHOW)'CAMLDEP $<' + $(HIDE)$(CAMLDEP) $(OCAMLLIBS) "$<" $(redir_if_ok) + +$(addsuffix .d,$(MLGFILES)): %.mlg.d: %.ml + $(SHOW)'CAMLDEP $<' + $(HIDE)$(CAMLDEP) $(OCAMLLIBS) "$<" $(redir_if_ok) + +$(addsuffix .d,$(MLFILES)): %.ml.d: %.ml + $(SHOW)'CAMLDEP $<' + $(HIDE)$(CAMLDEP) $(OCAMLLIBS) "$<" $(redir_if_ok) + +$(addsuffix .d,$(MLLIBFILES)): %.mllib.d: %.mllib + $(SHOW)'OCAMLLIBDEP $<' + $(HIDE)$(OCAMLLIBDEP) -c $(OCAMLLIBS) "$<" $(redir_if_ok) + +$(addsuffix .d,$(MLPACKFILES)): %.mlpack.d: %.mlpack + $(SHOW)'OCAMLLIBDEP $<' + $(HIDE)$(OCAMLLIBDEP) -c $(OCAMLLIBS) "$<" $(redir_if_ok) + +# If this makefile is created using a _CoqProject we have coqdep get +# options from it. This avoids argument length limits for pathological +# projects. Note that extra options might be on the command line. +VDFILE_FLAGS:=$(if _CoqProject,-f _CoqProject,) $(CMDLINE_COQLIBS) $(CMDLINE_VFILES) + +$(VDFILE): _CoqProject $(VFILES) + $(SHOW)'COQDEP VFILES' + $(HIDE)$(COQDEP) -vos -dyndep var $(VDFILE_FLAGS) $(redir_if_ok) + +# Misc ######################################################################## + +byte: + $(HIDE)$(MAKE) all "OPT:=-byte" -f "$(SELF)" +.PHONY: byte + +opt: + $(HIDE)$(MAKE) all "OPT:=-opt" -f "$(SELF)" +.PHONY: opt + +# This is deprecated. To extend this makefile use +# extension points and Makefile.local +printenv:: + $(warning printenv is deprecated) + $(warning write extensions in Makefile.local or include Makefile.conf) + @echo 'COQLIB = $(COQLIB)' + @echo 'COQCORELIB = $(COQCORELIB)' + @echo 'DOCDIR = $(DOCDIR)' + @echo 'OCAMLFIND = $(OCAMLFIND)' + @echo 'HASNATDYNLINK = $(HASNATDYNLINK)' + @echo 'SRC_SUBDIRS = $(SRC_SUBDIRS)' + @echo 'COQ_SRC_SUBDIRS = $(COQ_SRC_SUBDIRS)' + @echo 'COQCORE_SRC_SUBDIRS = $(COQCORE_SRC_SUBDIRS)' + @echo 'OCAMLFIND = $(OCAMLFIND)' + @echo 'PP = $(PP)' + @echo 'COQFLAGS = $(COQFLAGS)' + @echo 'COQLIB = $(COQLIBS)' + @echo 'COQLIBINSTALL = $(COQLIBINSTALL)' + @echo 'COQDOCINSTALL = $(COQDOCINSTALL)' +.PHONY: printenv + +# Generate a .merlin file. If you need to append directives to this +# file you can extend the merlin-hook target in Makefile.local +.merlin: + $(SHOW)'FILL .merlin' + $(HIDE)echo 'FLG $(COQMF_CAMLFLAGS)' > .merlin + $(HIDE)echo 'B $(COQCORELIB)' >> .merlin + $(HIDE)echo 'S $(COQCORELIB)' >> .merlin + $(HIDE)$(foreach d,$(COQCORE_SRC_SUBDIRS), \ + echo 'B $(COQCORELIB)$(d)' >> .merlin;) + $(HIDE)$(foreach d,$(COQ_SRC_SUBDIRS), \ + echo 'S $(COQLIB)$(d)' >> .merlin;) + $(HIDE)$(foreach d,$(SRC_SUBDIRS), echo 'B $(d)' >> .merlin;) + $(HIDE)$(foreach d,$(SRC_SUBDIRS), echo 'S $(d)' >> .merlin;) + $(HIDE)$(MAKE) merlin-hook -f "$(SELF)" +.PHONY: merlin + +merlin-hook:: + @# Extension point +.PHONY: merlin-hook + +# prints all variables +debug: + $(foreach v,\ + $(sort $(filter-out $(INITIAL_VARS) INITIAL_VARS,\ + $(.VARIABLES))),\ + $(info $(v) = $($(v)))) +.PHONY: debug + +.DEFAULT_GOAL := all + +# Users can create Makefile.local-late to hook into double-colon rules +# or add other needed Makefile code, using defined +# variables if necessary. +-include Makefile.local-late + +# Local Variables: +# mode: makefile-gmake +# End: diff --git a/_CoqProject b/_CoqProject index ceb2d3bf..b8505148 100644 --- a/_CoqProject +++ b/_CoqProject @@ -81,6 +81,27 @@ theories/Crypt/rules/UniformStateProb.v theories/Jasmin/jasmin_translate.v theories/Jasmin/jasmin_utils.v +theories/Jasmin/examples/add1.v +theories/Jasmin/examples/aes.v +theories/Jasmin/examples/bigadd.v +theories/Jasmin/examples/ex.v +theories/Jasmin/examples/int_add.v +theories/Jasmin/examples/int_incr.v +theories/Jasmin/examples/int_reg.v +theories/Jasmin/examples/int_shift.v +theories/Jasmin/examples/liveness_bork.v +theories/Jasmin/examples/matrix_product.v +theories/Jasmin/examples/retz.v +theories/Jasmin/examples/test_for.v +theories/Jasmin/examples/test_inline_var.v +theories/Jasmin/examples/test_shift.v +theories/Jasmin/examples/three_functions.v +theories/Jasmin/examples/two_functions.v +theories/Jasmin/examples/u64_incr.v +theories/Jasmin/examples/xor.v + +theories/Jasmin/examples/xor/xor.v + # Examples theories/Crypt/examples/package_usage_example.v theories/Crypt/examples/interpreter_test.v From 4a97047ac525570884dde33f01d8f2311371408a Mon Sep 17 00:00:00 2001 From: bshvass Date: Thu, 20 Oct 2022 14:24:27 +0200 Subject: [PATCH 278/383] added tactics for removing puts/gets --- theories/Jasmin/jasmin_utils.v | 44 ++++++++++++++++++++++++++++++++++ 1 file changed, 44 insertions(+) diff --git a/theories/Jasmin/jasmin_utils.v b/theories/Jasmin/jasmin_utils.v index 092c2d70..112cc4d0 100644 --- a/theories/Jasmin/jasmin_utils.v +++ b/theories/Jasmin/jasmin_utils.v @@ -133,3 +133,47 @@ Ltac simpl_fun := | _ => progress autorewrite with prog_rewrite | _ => prog_unfold; simpl end). + +Import PackageNotation. + +Ltac swap_first_occ loc := + lazymatch goal with + | |- ⊢ ⦃ _ ⦄ _ ≈ ?c1 ⦃ _ ⦄ => + lazymatch c1 with + | #put _ := _ ;; #put loc := _ ;; _ => ssprove_rswap_cmd_eq_rhs; ssprove_swap_auto + | #put _ := _ ;; _ ← get loc ;; _ => ssprove_rswap_cmd_eq_rhs; ssprove_swap_auto + | _ ← get _ ;; #put loc := _ ;; _ => ssprove_rswap_cmd_eq_rhs; ssprove_swap_auto + | _ ← get _ ;; _ ← get loc ;; _ => ssprove_rswap_cmd_eq_rhs; ssprove_swap_auto + | _ => ssprove_sync_eq ; try intro ; swap_first_occ loc + end + end. + +Ltac swap_loc loc := + eapply r_transL; [ solve [ swap_first_occ loc ] | cmd_bind_simpl ; cbn beta ]. + +Ltac swap_loc_ignore_head loc := + eapply r_transL; [ solve [ ssprove_sync_eq ; try intro ; swap_first_occ loc ] | cmd_bind_simpl ; cbn beta ]. + +Ltac set_at_head loc := + lazymatch goal with + | |- ⊢ ⦃ _ ⦄ ?c1 ≈ _ ⦃ _ ⦄ => + lazymatch c1 with + | #put loc := _ ;; _ => idtac + | _ ← get loc ;; _ => idtac + | _ => swap_loc loc; set_at_head loc + end + end. + +Ltac set_at_snd loc := + lazymatch goal with + | |- ⊢ ⦃ _ ⦄ ?c1 ≈ _ ⦃ _ ⦄ => + lazymatch c1 with + | #put _ := _ ;; #put loc := _ ;; _ => idtac + | #put _ := _ ;; _ ← get loc ;; _ => idtac + | _ ← get _ ;; #put loc := _ ;; _ => idtac + | _ ← get _ ;; _ ← get loc ;; _ => idtac + | _ => swap_loc_ignore_head loc; set_at_snd loc + end + end. + +Ltac clear_loc loc := set_at_head loc; set_at_snd loc; first [ ssprove_contract_put_get_lhs | ssprove_contract_put_lhs ]. From 77eeea9fd82e828b4644769a40a5967a64955eca Mon Sep 17 00:00:00 2001 From: bshvass Date: Mon, 24 Oct 2022 15:01:33 +0200 Subject: [PATCH 279/383] (WIP) init aes examples --- theories/Jasmin/examples/aes/aes.v | 1166 ++++++++++++++++++++++++++++ theories/Jasmin/jasmin_utils.v | 11 + 2 files changed, 1177 insertions(+) create mode 100644 theories/Jasmin/examples/aes/aes.v diff --git a/theories/Jasmin/examples/aes/aes.v b/theories/Jasmin/examples/aes/aes.v new file mode 100644 index 00000000..15da1992 --- /dev/null +++ b/theories/Jasmin/examples/aes/aes.v @@ -0,0 +1,1166 @@ +Set Warnings "-notation-overridden,-ambiguous-paths". +From mathcomp Require Import all_ssreflect all_algebra reals distr realsum + fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool + ssrnum eqtype choice seq. +Set Warnings "notation-overridden,ambiguous-paths". + +Require Import List. +Set Warnings "-notation-overridden". +From Jasmin Require Import expr. +Set Warnings "notation-overridden". +From Jasmin Require Import x86_instr_decl x86_extra. +From JasminSSProve Require Import jasmin_translate. +From Crypt Require Import Prelude Package. + +Import ListNotations. +Local Open Scope string. + +Definition ssprove_jasmin_prog : uprog. +Proof. + refine {| p_funcs := + rev [ ( (* RCON *) xI (xI (xO (xO xH))), + {| f_info := xO (xO (xO (xI xH))) + ; f_tyin := [sint] + ; f_params := + [{| v_var := {| vtype := sint + ; vname := "i.322" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := {| vtype := sint + ; vname := "c.323" |} + ; v_info := dummy_var_info |}) + AT_inline (sint) + ((Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.322" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xH)))) + (Pconst (Zpos (xH))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.322" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO xH)))) + (Pconst (Zpos (xO xH))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.322" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xI xH)))) + (Pconst (Zpos (xO (xO xH)))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.322" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO (xO xH))))) + (Pconst (Zpos (xO (xO (xO xH))))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.322" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xI (xO xH))))) + (Pconst (Zpos (xO (xO (xO (xO xH)))))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.322" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO (xI xH))))) + (Pconst (Zpos (xO (xO (xO (xO (xO xH))))))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := + "i.322" |} + ; v_info := + dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xI (xI xH))))) + (Pconst + (Zpos (xO (xO (xO (xO (xO (xO xH)))))))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := + "i.322" |} + ; v_info := + dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO (xO (xO xH)))))) + (Pconst + (Zpos (xO (xO (xO (xO (xO (xO (xO xH))))))))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := + sint + ; vname := + "i.322" |} + ; v_info := + dummy_var_info |} ; gs := Slocal |}) + (Pconst + (Zpos (xI (xO (xO xH)))))) + (Pconst + (Zpos (xI (xI (xO (xI xH)))))) + (Pconst + (Zpos (xO (xI (xI (xO (xI xH)))))))))))))))))) ] + ; f_tyout := [sint] + ; f_res := + [{| v_var := {| vtype := sint + ; vname := "c.323" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* key_combine *) xO (xI (xI (xO xH))), + {| f_info := xI (xI (xI (xO xH))) + ; f_tyin := [(sword U128); (sword U128); (sword U128)] + ; f_params := + [{| v_var := {| vtype := (sword U128) + ; vname := "rkey.319" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "temp1.320" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "temp2.321" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "temp1.320" |} + ; v_info := dummy_var_info |}] + AT_keep + (Oasm (* VPSHUFD_128 *) (BaseOp (None, (VPSHUFD U128)))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp1.320" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (PappN (Opack U8 PE2) + [(Pconst (Zpos (xI xH))); (Pconst (Zpos (xI xH))); + (Pconst (Zpos (xI xH))); (Pconst (Zpos (xI xH)))])]); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.321" |} + ; v_info := dummy_var_info |}] + AT_keep + (Oasm (* VSHUFPS_128 *) (BaseOp (None, (VSHUFPS U128)))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.321" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.319" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (PappN (Opack U8 PE2) + [(Pconst (Z0)); (Pconst (Zpos (xH))); (Pconst (Z0)); + (Pconst (Z0))])]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.319" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U128)) + ((Papp2 (Olxor U128) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.319" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.321" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.321" |} + ; v_info := dummy_var_info |}] + AT_keep + (Oasm (* VSHUFPS_128 *) (BaseOp (None, (VSHUFPS U128)))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.321" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.319" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (PappN (Opack U8 PE2) + [(Pconst (Zpos (xO xH))); (Pconst (Z0)); + (Pconst (Zpos (xI xH))); (Pconst (Z0))])]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.319" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U128)) + ((Papp2 (Olxor U128) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.319" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.321" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.319" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U128)) + ((Papp2 (Olxor U128) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.319" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp1.320" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))) ] + ; f_tyout := [(sword U128); (sword U128)] + ; f_res := + [{| v_var := {| vtype := (sword U128) + ; vname := "rkey.319" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "temp2.321" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* key_expand *) xO (xI (xO (xO xH))), + {| f_info := xI (xO (xI (xO xH))) + ; f_tyin := [sint; (sword U128); (sword U128)] + ; f_params := + [{| v_var := {| vtype := sint + ; vname := "rcon.315" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "rkey.316" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "temp2.317" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "temp1.318" |} + ; v_info := dummy_var_info |}] + AT_keep + (Oasm (* VAESKEYGENASSIST *) + (BaseOp (None, VAESKEYGENASSIST))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.316" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Papp1 (Oword_of_int U8) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "rcon.315" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))]); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.316" |} + ; v_info := dummy_var_info |}; + Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.317" |} + ; v_info := dummy_var_info |}] + (xO (xI (xI (xO xH)))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.316" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp1.318" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.317" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sword U128); (sword U128)] + ; f_res := + [{| v_var := {| vtype := (sword U128) + ; vname := "rkey.316" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "temp2.317" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* keys_expand *) xO (xO (xI xH)), + {| f_info := xO (xO (xI (xO xH))) + ; f_tyin := [(sword U128)] + ; f_params := + [{| v_var := {| vtype := (sword U128) + ; vname := "key.310" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Laset AAscale U128 + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.311" |} + ; v_info := dummy_var_info |} + (Pconst (Z0))) + AT_none ((sword U128)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.310" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.312" |} + ; v_info := dummy_var_info |}] + AT_keep (Oasm (* set0_128 *) (ExtOp (Oset0 U128))) []); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "round.313" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Zpos (xH)))), + (Pconst (Zpos (xI (xI (xO xH)))))) + [MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := sint + ; vname := "rcon.314" |} + ; v_info := dummy_var_info |}] + (xI (xI (xO (xO xH)))) + [(Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "round.313" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "key.310" |} + ; v_info := dummy_var_info |}; + Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.312" |} + ; v_info := dummy_var_info |}] + (xO (xI (xO (xO xH)))) + [(Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "rcon.314" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.310" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.312" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Laset AAscale U128 + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.311" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "round.313" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) + AT_none ((sword U128)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.310" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))]) ] + ; f_tyout := [(sarr (xO (xO (xO (xO (xI (xI (xO xH))))))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.311" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* keys_expand_inv *) xI (xO (xO xH)), + {| f_info := xI (xO (xO (xO xH))) + ; f_tyin := [(sword U128)] + ; f_params := + [{| v_var := {| vtype := (sword U128) + ; vname := "key.305" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Laset AAscale U128 + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.306" |} + ; v_info := dummy_var_info |} + (Pconst (Z0))) + AT_none ((sword U128)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.305" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.307" |} + ; v_info := dummy_var_info |}] + AT_keep (Oasm (* set0_128 *) (ExtOp (Oset0 U128))) []); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "round.308" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Zpos (xH)))), + (Pconst (Zpos (xI (xI (xO xH)))))) + [MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := sint + ; vname := "rcon.309" |} + ; v_info := dummy_var_info |}] + (xI (xI (xO (xO xH)))) + [(Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "round.308" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "key.305" |} + ; v_info := dummy_var_info |}; + Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.307" |} + ; v_info := dummy_var_info |}] + (xO (xI (xO (xO xH)))) + [(Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "rcon.309" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.305" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.307" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cif + (Papp2 (Oneq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "round.308" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO (xI (xO xH)))))) + [MkI InstrInfo.witness + (Copn + [Laset AAscale U128 + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.306" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "round.308" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})] + AT_keep + (Oasm (* AESIMC *) (BaseOp (None, AESIMC))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.305" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})])] + [MkI InstrInfo.witness + (Cassgn + (Laset AAscale U128 + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.306" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "round.308" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) + AT_none ((sword U128)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.305" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))])]) ] + ; f_tyout := [(sarr (xO (xO (xO (xO (xI (xI (xO xH))))))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.306" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* aes_rounds *) xI (xI (xO xH)), + {| f_info := xO (xO (xO (xO xH))) + ; f_tyin := + [(sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))); (sword U128)] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.301" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "in.302" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "state.303" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U128)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "in.302" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "state.303" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U128)) + ((Papp2 (Olxor U128) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "state.303" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pget AAscale U128 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.301" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pconst (Z0)))))); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "round.304" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Zpos (xH)))), + (Pconst (Zpos (xO (xI (xO xH)))))) + [MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "state.303" |} + ; v_info := dummy_var_info |}] + AT_keep (Oasm (* AESENC *) (BaseOp (None, AESENC))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "state.303" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pget AAscale U128 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.301" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "round.304" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))])]); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "state.303" |} + ; v_info := dummy_var_info |}] + AT_keep (Oasm (* AESENCLAST *) (BaseOp (None, AESENCLAST))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "state.303" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pget AAscale U128 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.301" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pconst (Zpos (xO (xI (xO xH))))))]) ] + ; f_tyout := [(sword U128)] + ; f_res := + [{| v_var := {| vtype := (sword U128) + ; vname := "state.303" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* AddRoundKey *) xO (xI (xI xH)), + {| f_info := xI (xI (xI xH)) + ; f_tyin := [(sword U128); (sword U128)] + ; f_params := + [{| v_var := {| vtype := (sword U128) + ; vname := "state.299" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "rk.300" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "state.299" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U128)) + ((Papp2 (Olxor U128) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "state.299" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "rk.300" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))) ] + ; f_tyout := [(sword U128)] + ; f_res := + [{| v_var := {| vtype := (sword U128) + ; vname := "state.299" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* invaes_rounds *) xO (xO (xO xH)), + {| f_info := xI (xO (xI xH)) + ; f_tyin := + [(sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))); (sword U128)] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.294" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "in.295" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "state.296" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U128)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "in.295" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "rk.297" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U128)) + ((Pget AAscale U128 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.294" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pconst (Zpos (xO (xI (xO xH)))))))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "state.296" |} + ; v_info := dummy_var_info |}] + (xO (xI (xI xH))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "state.296" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "rk.297" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "round.298" |} + ; v_info := dummy_var_info |}) + ((DownTo, (Pconst (Z0))), (Pconst (Zpos (xI (xO (xO xH)))))) + [MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "state.296" |} + ; v_info := dummy_var_info |}] + AT_keep (Oasm (* AESDEC *) (BaseOp (None, AESDEC))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "state.296" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pget AAscale U128 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.294" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "round.298" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))])]); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "state.296" |} + ; v_info := dummy_var_info |}] + AT_keep (Oasm (* AESDECLAST *) (BaseOp (None, AESDECLAST))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "state.296" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pget AAscale U128 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.294" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pconst (Z0)))]) ] + ; f_tyout := [(sword U128)] + ; f_res := + [{| v_var := {| vtype := (sword U128) + ; vname := "state.296" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* aes *) xO (xI xH), + {| f_info := xO (xI (xO xH)) + ; f_tyin := [(sword U128); (sword U128)] + ; f_params := + [{| v_var := {| vtype := (sword U128) + ; vname := "key.290" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "in.291" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.293" |} + ; v_info := dummy_var_info |}] + (xO (xO (xI xH))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.290" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "out.292" |} + ; v_info := dummy_var_info |}] + (xI (xI (xO xH))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.293" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "in.291" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sword U128)] + ; f_res := + [{| v_var := {| vtype := (sword U128) + ; vname := "out.292" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* invaes *) xI xH, + {| f_info := xI (xI xH) + ; f_tyin := [(sword U128); (sword U128)] + ; f_params := + [{| v_var := {| vtype := (sword U128) + ; vname := "key.286" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "in.287" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.289" |} + ; v_info := dummy_var_info |}] + (xI (xO (xO xH))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.286" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "out.288" |} + ; v_info := dummy_var_info |}] + (xO (xO (xO xH))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.289" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "in.287" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sword U128)] + ; f_res := + [{| v_var := {| vtype := (sword U128) + ; vname := "out.288" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* aes_jazz *) xO (xO xH), + {| f_info := xI (xO xH) + ; f_tyin := [(sword U128); (sword U128)] + ; f_params := + [{| v_var := {| vtype := (sword U128) + ; vname := "key.283" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "in.284" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "out.285" |} + ; v_info := dummy_var_info |}] + (xO (xI xH)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.283" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "in.284" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sword U128)] + ; f_res := + [{| v_var := {| vtype := (sword U128) + ; vname := "out.285" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* invaes_jazz *) xH, + {| f_info := xO xH + ; f_tyin := [(sword U128); (sword U128)] + ; f_params := + [{| v_var := {| vtype := (sword U128) + ; vname := "key.280" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "in.281" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "out.282" |} + ; v_info := dummy_var_info |}] + (xI xH) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.280" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "in.281" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sword U128)] + ; f_res := + [{| v_var := {| vtype := (sword U128) + ; vname := "out.282" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) ] ; + p_globs := [] ; + p_extra := tt |}. +Defined. + +Fixpoint list_to_chtuple (l : list typed_chElement) : lchtuple [seq t.π1 | t <- l] := + match l as l0 + return lchtuple [seq t.π1 | t <- l0] + with + | [] => tt + | tc' :: l' => + let rec := @list_to_chtuple l' in + match l' as l'0 + return + lchtuple [seq t.π1 | t <- l'0] -> + lchtuple [seq t.π1 | t <- (tc'::l'0)] + with + | [] => fun _ => tc'.π2 + | tc'' :: l'' => fun rec => (tc'.π2, rec) + end rec + end. + +From JasminSSProve Require Import jasmin_utils. + +Import ListNotations. +Import JasminNotation JasminCodeNotation. +Import PackageNotation. + +Definition get_tr := get_translated_fun ssprove_jasmin_prog. +Definition Jrcon (i : Z) := get_tr (xI (xI (xO (xO xH)))) 1%positive [('int ; i)]. +Definition Jkey_combine rkey temp1 temp2 := get_tr (xO (xI (xI (xO xH)))) 1%positive [('word U128 ; rkey) ; ('word U128 ; temp1) ; ('word U128 ; temp2)]. +Definition Jkey_expand rcon rkey temp2 := get_tr (xO (xI (xO (xO xH)))) 1%positive [ ('int ; rcon) ; ('word U128 ; rkey) ; ('word U128 ; temp2) ]. + +Definition rcon (i : Z) := nth 54%Z [:: 1; 2; 4; 8; 16; 32; 64; 128; 27; 54]%Z ((Z.to_nat i) - 1). + +Lemma rcon_correct : + forall (i : Z), (1 <= i < 10)%Z -> + ⊢ ⦃ fun _ => True ⦄ Jrcon i ⇓ [('int ; rcon i)] ⦃ fun _ => True ⦄. +Proof. + unfold Jrcon, get_tr, get_translated_fun. + intros i H. + simpl_fun. repeat setjvars. + repeat match goal with + | |- context[(?a =? ?b)%Z] => let E := fresh in destruct (a =? b)%Z eqn:E; [rewrite ?Z.eqb_eq in E; subst|] + | |- _ => eapply r_put_lhs with (pre := fun _ => True); ssprove_contract_put_get_lhs; eapply r_put_lhs; rewrite ?coerce_to_choice_type_K; eapply r_ret; easy + | |- _ => simpl; ssprove_contract_put_get_lhs; rewrite !coerce_to_choice_type_K + end. + micromega.Lia.lia. +Qed. +From mathcomp.word Require Import word. + +Infix "^" := wxor. + +(* copy of the easycrypt functional definition *) +Definition key_expand (wn1 : u128) (rcon : u8) : 'word U128 := + let rcon := wpack U32 4 [toword rcon; 0%Z; 0%Z; 0%Z] in + let w0 := subword 0 32 wn1 in + let w1 := subword 1 32 wn1 in + let w2 := subword 2 32 wn1 in + let w3 := subword 3 32 wn1 in + + let tmp := w3 in + let tmp := (rotr tmp 1) ^ rcon in + let w4 := w0 ^ tmp in + let w5 := w1 ^ w4 in + let w6 := w2 ^ w5 in + let w7 := w3 ^ w6 in + wpack U128 4 [toword w4; toword w5; toword w6; toword w7]. + +Ltac neq_loc_auto ::= eapply injective_translate_var3; auto. + +Notation "m ⊕ k" := (@word.wxor _ m k) (at level 70). + +Lemma lsr_word0 {ws1} a : @lsr ws1 word0 a = word0. +Proof. + unfold lsr. + rewrite Z.shiftr_0_l. + apply val_inj. + reflexivity. +Qed. + +Lemma subword_word0 {ws1} a ws2 : @subword ws1 a ws2 word0 = word0. +Proof. + unfold subword. + rewrite lsr_word0. + apply val_inj. + reflexivity. +Qed. + +Lemma wpshufd10 : forall w n, wpshufd1 w 0 n = zero_extend U32 w. +Proof. + unfold wpshufd1. + intros a n. + rewrite subword_word0 Z.mul_0_r wshr0. + change 32%nat with (nat_of_wsize U32). + apply subword0. +Qed. + +(* Lemma wcat_r_zero_extend : *) + (* wcat_r [seq zero_extend a ] *) + +Lemma wpshufd_1280 : forall a, wpshufd_128 a 0 = a. +Proof. + intros a. + unfold wpshufd_128. + rewrite wrepr0. + unfold iota, map. + rewrite !wpshufd10. +Admitted. + +Lemma key_expand_correct rcon rkey temp2 rcon_ : + toword rcon_ = rcon -> + ⊢ ⦃ fun _ => True ⦄ + l ← (Jkey_expand rcon rkey temp2) ;; + ret (nth ('word U128 ; word0) l 0%nat) + ⇓ ('word U128 ; (key_expand rkey rcon_)) + ⦃ fun _ => True ⦄. +Proof. + intros H. + unfold Jkey_expand, get_tr, get_translated_fun. + + simpl_fun. repeat setjvars. + rewrite !zero_extend_u. + rewrite !coerce_to_choice_type_K. + + unfold eval_jdg. + + repeat clear_get. + + unfold sopn_sem. + unfold tr_app_sopn_tuple. + unfold tr_app_sopn_single. + + simpl. + + rewrite !zero_extend_u. + rewrite !coerce_to_choice_type_K. + + repeat eapply u_put. + eapply u_ret. + + split. easy. + Admitted. diff --git a/theories/Jasmin/jasmin_utils.v b/theories/Jasmin/jasmin_utils.v index 112cc4d0..358c7f98 100644 --- a/theories/Jasmin/jasmin_utils.v +++ b/theories/Jasmin/jasmin_utils.v @@ -177,3 +177,14 @@ Ltac set_at_snd loc := end. Ltac clear_loc loc := set_at_head loc; set_at_snd loc; first [ ssprove_contract_put_get_lhs | ssprove_contract_put_lhs ]. + +Ltac clear_get_aux c1 := + lazymatch c1 with + | _ ← get ?loc ;; _ => clear_loc loc + | #put _ := _ ;; ?c2 => clear_get_aux c2 + end. + +Ltac clear_get := + lazymatch goal with + | |- ⊢ ⦃ _ ⦄ ?c1 ≈ _ ⦃ _ ⦄ => clear_get_aux c1 + end. From 98de66bda1840a311b1004152a96f31677675124 Mon Sep 17 00:00:00 2001 From: bshvass Date: Tue, 25 Oct 2022 13:33:17 +0200 Subject: [PATCH 280/383] translated sike434 code with handwritten globs (note the while loop) --- theories/Jasmin/examples/sike434/sike434.v | 7006 ++++++++++++++++++++ 1 file changed, 7006 insertions(+) create mode 100644 theories/Jasmin/examples/sike434/sike434.v diff --git a/theories/Jasmin/examples/sike434/sike434.v b/theories/Jasmin/examples/sike434/sike434.v new file mode 100644 index 00000000..2350a6ac --- /dev/null +++ b/theories/Jasmin/examples/sike434/sike434.v @@ -0,0 +1,7006 @@ +Set Warnings "-notation-overridden,-ambiguous-paths". +From mathcomp Require Import all_ssreflect all_algebra reals distr realsum + fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool + ssrnum eqtype choice seq. +Set Warnings "notation-overridden,ambiguous-paths". + +Require Import List. +Set Warnings "-notation-overridden". +From Jasmin Require Import expr. +Set Warnings "notation-overridden". +From Jasmin Require Import x86_instr_decl x86_extra. +From JasminSSProve Require Import jasmin_translate. +From Crypt Require Import Prelude Package. + +Import ListNotations. +Local Open Scope string. + + + + +Definition ssprove_jasmin_prog : uprog. +Proof. + refine {| p_funcs := + [ ( (* __bn_load *) xI (xO xH), + {| f_info := xO (xI (xI (xO (xI (xI xH))))) + ; f_tyin := [(sword U64)] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "a.1377" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "i.1379" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Z0))), (Pconst (Zpos (xI (xI xH))))) + [MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t.1380" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pload U64 + {| v_var := + {| vtype := (sword U64) + ; vname := "a.1377" |} + ; v_info := dummy_var_info |} + (Papp1 (Oword_of_int U64) + (Papp2 (Omul Op_int) + (Pconst (Zpos (xO (xO (xO xH))))) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1379" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))))); + MkI InstrInfo.witness + (Cassgn + (Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "x.1378" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1379" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t.1380" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))]) ] + ; f_tyout := [(sarr (xO (xO (xO (xI (xI xH))))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "x.1378" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* __bn_store *) xI xH, + {| f_info := xI (xO (xI (xO (xI (xI xH))))) + ; f_tyin := [(sword U64); (sarr (xO (xO (xO (xI (xI xH))))))] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "a.1373" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1374" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "i.1375" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Z0))), (Pconst (Zpos (xI (xI xH))))) + [MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t.1376" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1374" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1375" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness + (Cassgn + (Lmem U64 + {| v_var := + {| vtype := (sword U64) + ; vname := "a.1373" |} + ; v_info := dummy_var_info |} + (Papp1 (Oword_of_int U64) + (Papp2 (Omul Op_int) + (Pconst (Zpos (xO (xO (xO xH))))) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1375" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t.1376" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))]) ] + ; f_tyout := [] + ; f_res := [] + ; f_extra := tt + ; |} ) + ; ( (* _bn2_load_ *) xI (xI (xO (xO (xI (xI xH))))), + {| f_info := xO (xO (xI (xO (xI (xI xH))))) + ; f_tyin := [(sword U64)] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "a.1369" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "i.1371" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Z0))), + (Papp2 (Omul Op_int) (Pconst (Zpos (xO xH))) + (Pconst (Zpos (xI (xI xH)))))) + [MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t.1372" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pload U64 + {| v_var := + {| vtype := (sword U64) + ; vname := "a.1369" |} + ; v_info := dummy_var_info |} + (Papp1 (Oword_of_int U64) + (Papp2 (Omul Op_int) + (Pconst (Zpos (xO (xO (xO xH))))) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1371" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))))); + MkI InstrInfo.witness + (Cassgn + (Laset AAscale U64 + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "x.1370" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1371" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t.1372" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))]) ] + ; f_tyout := [(sarr (xO (xO (xO (xO (xI (xI xH)))))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "x.1370" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* __bn2_store *) xI (xO (xI (xI xH))), + {| f_info := xO (xI (xO (xO (xI (xI xH))))) + ; f_tyin := [(sword U64); (sarr (xO (xO (xO (xO (xI (xI xH)))))))] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "a.1365" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "b.1366" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "i.1367" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Z0))), + (Papp2 (Omul Op_int) (Pconst (Zpos (xO xH))) + (Pconst (Zpos (xI (xI xH)))))) + [MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t.1368" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "b.1366" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1367" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness + (Cassgn + (Lmem U64 + {| v_var := + {| vtype := (sword U64) + ; vname := "a.1365" |} + ; v_info := dummy_var_info |} + (Papp1 (Oword_of_int U64) + (Papp2 (Omul Op_int) + (Pconst (Zpos (xO (xO (xO xH))))) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1367" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t.1368" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))]) ] + ; f_tyout := [] + ; f_res := [] + ; f_extra := tt + ; |} ) + ; ( (* __bn2_unpack *) xO (xO (xO (xO (xI (xI xH))))), + {| f_info := xI (xO (xO (xO (xI (xI xH))))) + ; f_tyin := [(sarr (xO (xO (xO (xO (xI (xI xH)))))))] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "a.1359" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "i.1362" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Z0))), (Pconst (Zpos (xI (xI xH))))) + [MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t1.1363" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "a.1359" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1362" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t2.1364" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "a.1359" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Papp2 (Oadd Op_int) (Pconst (Zpos (xI (xI xH)))) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1362" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))))); + MkI InstrInfo.witness + (Cassgn + (Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "lo.1361" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1362" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t1.1363" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cassgn + (Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "hi.1360" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1362" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t2.1364" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))]) ] + ; f_tyout := + [(sarr (xO (xO (xO (xI (xI xH)))))); + (sarr (xO (xO (xO (xI (xI xH))))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "hi.1360" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "lo.1361" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* __bn_pack2 *) xO (xI (xI (xI (xO (xI xH))))), + {| f_info := xI (xI (xI (xI (xO (xI xH))))) + ; f_tyin := + [(sarr (xO (xO (xO (xI (xI xH)))))); + (sarr (xO (xO (xO (xI (xI xH))))))] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "lo.1354" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "hi.1355" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "i.1357" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Z0))), (Pconst (Zpos (xI (xI xH))))) + [MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t.1358" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "lo.1354" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1357" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness + (Cassgn + (Laset AAscale U64 + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "r.1356" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1357" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t.1358" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))]); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "i.1357" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Z0))), (Pconst (Zpos (xI (xI xH))))) + [MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t.1358" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "hi.1355" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1357" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness + (Cassgn + (Laset AAscale U64 + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "r.1356" |} + ; v_info := dummy_var_info |} + (Papp2 (Oadd Op_int) (Pconst (Zpos (xI (xI xH)))) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1357" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t.1358" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))]) ] + ; f_tyout := [(sarr (xO (xO (xO (xO (xI (xI xH)))))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "r.1356" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* __bn_eq *) xO (xO (xI (xI (xO (xI xH))))), + {| f_info := xI (xO (xI (xI (xO (xI xH))))) + ; f_tyin := + [(sarr (xO (xO (xO (xI (xI xH)))))); + (sarr (xO (xO (xO (xI (xI xH))))))] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1346" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1347" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "res.1348" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp1 (Oword_of_int U64) (Pconst (Z0))))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "are_equal.1349" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp1 (Oword_of_int U64) (Pconst (Zpos (xH)))))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "acc.1350" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp1 (Oword_of_int U64) (Pconst (Z0))))); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "i.1351" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Z0))), (Pconst (Zpos (xI (xI xH))))) + [MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t.1352" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1346" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1351" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t.1352" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp2 (Olxor U64) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t.1352" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1347" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1351" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "acc.1350" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp2 (Olor U64) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "acc.1350" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t.1352" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))))]); + MkI InstrInfo.witness + (Copn + [Lnone dummy_var_info sbool; Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; Lnone dummy_var_info sbool; + Lvar + {| v_var := {| vtype := sbool + ; vname := "zf.1353" |} + ; v_info := dummy_var_info |}; + Lnone dummy_var_info (sword U64)] + AT_keep (Oasm (* AND_64 *) (BaseOp (None, (AND U64)))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "acc.1350" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "acc.1350" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "res.1348" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pif ((sword U64)) + (Pvar + {| gv := {| v_var := + {| vtype := sbool + ; vname := "zf.1353" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "are_equal.1349" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "res.1348" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))) ] + ; f_tyout := [(sword U64)] + ; f_res := + [{| v_var := {| vtype := (sword U64) + ; vname := "res.1348" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* _bn_eq *) xO (xI (xO (xI (xO (xI xH))))), + {| f_info := xI (xI (xO (xI (xO (xI xH))))) + ; f_tyin := + [(sarr (xO (xO (xO (xI (xI xH)))))); + (sarr (xO (xO (xO (xI (xI xH))))))] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1343" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1344" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "r.1345" |} + ; v_info := dummy_var_info |}] + (xO (xO (xI (xI (xO (xI xH)))))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1343" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1344" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sword U64)] + ; f_res := + [{| v_var := {| vtype := (sword U64) + ; vname := "r.1345" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* _bn_eq_ *) xI (xO (xO (xO (xI xH)))), + {| f_info := xI (xO (xO (xI (xO (xI xH))))) + ; f_tyin := + [(sarr (xO (xO (xO (xI (xI xH)))))); + (sarr (xO (xO (xO (xI (xI xH))))))] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_a.1338" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_b.1339" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1341" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_a.1338" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1342" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_b.1339" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall DoNotInline + [Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "r.1340" |} + ; v_info := dummy_var_info |}] + (xO (xI (xO (xI (xO (xI xH)))))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1341" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1342" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "r.1340" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "r.1340" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))) ] + ; f_tyout := [(sword U64)] + ; f_res := + [{| v_var := {| vtype := (sword U64) + ; vname := "r.1340" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* __bn_test0 *) xO (xI (xI (xI (xO xH)))), + {| f_info := xO (xO (xO (xI (xO (xI xH))))) + ; f_tyin := [(sarr (xO (xO (xO (xI (xI xH))))))] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1332" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "res.1333" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp1 (Oword_of_int U64) (Pconst (Z0))))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "is_zero.1334" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp1 (Oword_of_int U64) (Pconst (Zpos (xH)))))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "acc.1335" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1332" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pconst (Z0))))); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "i.1336" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Zpos (xH)))), (Pconst (Zpos (xI (xI xH))))) + [MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "acc.1335" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp2 (Olor U64) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "acc.1335" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1332" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1336" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))))]); + MkI InstrInfo.witness + (Copn + [Lnone dummy_var_info sbool; Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; Lnone dummy_var_info sbool; + Lvar + {| v_var := {| vtype := sbool + ; vname := "zf.1337" |} + ; v_info := dummy_var_info |}; + Lnone dummy_var_info (sword U64)] + AT_keep (Oasm (* AND_64 *) (BaseOp (None, (AND U64)))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "acc.1335" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "acc.1335" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "res.1333" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pif ((sword U64)) + (Pvar + {| gv := {| v_var := + {| vtype := sbool + ; vname := "zf.1337" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "is_zero.1334" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "res.1333" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))) ] + ; f_tyout := [(sword U64)] + ; f_res := + [{| v_var := {| vtype := (sword U64) + ; vname := "res.1333" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* _bn_test0 *) xO (xI (xI (xO (xO (xI xH))))), + {| f_info := xI (xI (xI (xO (xO (xI xH))))) + ; f_tyin := [(sarr (xO (xO (xO (xI (xI xH))))))] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1330" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "r.1331" |} + ; v_info := dummy_var_info |}] + (xO (xI (xI (xI (xO xH))))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1330" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sword U64)] + ; f_res := + [{| v_var := {| vtype := (sword U64) + ; vname := "r.1331" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* __bn_copy *) xI (xI (xO (xI (xO (xO xH))))), + {| f_info := xI (xO (xI (xO (xO (xI xH))))) + ; f_tyin := [(sarr (xO (xO (xO (xI (xI xH))))))] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1326" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "i.1328" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Z0))), (Pconst (Zpos (xI (xI xH))))) + [MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t.1329" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1326" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1328" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness + (Cassgn + (Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1327" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1328" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t.1329" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))]) ] + ; f_tyout := [(sarr (xO (xO (xO (xI (xI xH))))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1327" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* __bn_copy2 *) xI (xO (xO (xI (xI xH)))), + {| f_info := xO (xO (xI (xO (xO (xI xH))))) + ; f_tyin := + [(sarr (xO (xO (xO (xI (xI xH)))))); + (sarr (xO (xO (xO (xI (xI xH))))))] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1322" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1323" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "i.1324" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Z0))), (Pconst (Zpos (xI (xI xH))))) + [MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t.1325" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1322" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1324" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness + (Cassgn + (Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1323" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1324" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t.1325" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))]) ] + ; f_tyout := [(sarr (xO (xO (xO (xI (xI xH))))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1323" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* __bn_cmov *) xO (xI (xO (xI (xO (xO xH))))), + {| f_info := xI (xI (xO (xO (xO (xI xH))))) + ; f_tyin := + [sbool; (sarr (xO (xO (xO (xI (xI xH)))))); + (sarr (xO (xO (xO (xI (xI xH))))))] + ; f_params := + [{| v_var := {| vtype := sbool + ; vname := "cond.1317" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1318" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1319" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "i.1320" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Z0))), (Pconst (Zpos (xI (xI xH))))) + [MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t.1321" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1318" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1320" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t.1321" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pif ((sword U64)) + (Pvar + {| gv := {| v_var := + {| vtype := sbool + ; vname := "cond.1317" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1319" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1320" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t.1321" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness + (Cassgn + (Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1318" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1320" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t.1321" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))]) ] + ; f_tyout := [(sarr (xO (xO (xO (xI (xI xH))))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1318" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* __bn_set0 *) xI (xO (xO (xO (xO (xI xH))))), + {| f_info := xO (xI (xO (xO (xO (xI xH))))) + ; f_tyin := [(sarr (xO (xO (xO (xI (xI xH))))))] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1314" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t.1315" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp1 (Oword_of_int U64) (Pconst (Z0))))); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "i.1316" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Z0))), (Pconst (Zpos (xI (xI xH))))) + [MkI InstrInfo.witness + (Cassgn + (Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1314" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1316" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t.1315" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))]) ] + ; f_tyout := [(sarr (xO (xO (xO (xI (xI xH))))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1314" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* __bn_add1c *) xI (xI (xI (xI (xI (xO xH))))), + {| f_info := xO (xO (xO (xO (xO (xI xH))))) + ; f_tyin := [(sarr (xO (xO (xO (xI (xI xH)))))); (sword U64)] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1310" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U64) + ; vname := "b.1311" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := {| vtype := sbool + ; vname := "cf.1312" |} + ; v_info := dummy_var_info |}; + Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1310" |} + ; v_info := dummy_var_info |} + (Pconst (Z0))] + AT_keep (Oaddcarry (U64)) + [(Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1310" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pconst (Z0))); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "b.1311" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pbool false)]); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "i.1313" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Zpos (xH)))), (Pconst (Zpos (xI (xI xH))))) + [MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := sbool + ; vname := "cf.1312" |} + ; v_info := dummy_var_info |}; + Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1310" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1313" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})] + AT_keep (Oaddcarry (U64)) + [(Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1310" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1313" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})); + (Papp1 (Oword_of_int U64) (Pconst (Z0))); + (Pvar + {| gv := {| v_var := + {| vtype := sbool + ; vname := "cf.1312" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})])]) ] + ; f_tyout := [sbool; (sarr (xO (xO (xO (xI (xI xH))))))] + ; f_res := + [{| v_var := {| vtype := sbool + ; vname := "cf.1312" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1310" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* __bn_addc *) xI (xI (xI (xO (xO xH)))), + {| f_info := xO (xI (xI (xI (xI (xO xH))))) + ; f_tyin := + [(sarr (xO (xO (xO (xI (xI xH)))))); + (sarr (xO (xO (xO (xI (xI xH))))))] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1305" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1306" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t.1308" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1306" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pconst (Z0))))); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := {| vtype := sbool + ; vname := "cf.1307" |} + ; v_info := dummy_var_info |}; + Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1305" |} + ; v_info := dummy_var_info |} + (Pconst (Z0))] + AT_keep (Oaddcarry (U64)) + [(Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1305" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pconst (Z0))); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t.1308" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pbool false)]); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "i.1309" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Zpos (xH)))), (Pconst (Zpos (xI (xI xH))))) + [MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t.1308" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1306" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1309" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := sbool + ; vname := "cf.1307" |} + ; v_info := dummy_var_info |}; + Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1305" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1309" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})] + AT_keep (Oaddcarry (U64)) + [(Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1305" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1309" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t.1308" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := sbool + ; vname := "cf.1307" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})])]) ] + ; f_tyout := [sbool; (sarr (xO (xO (xO (xI (xI xH))))))] + ; f_res := + [{| v_var := {| vtype := sbool + ; vname := "cf.1307" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1305" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* _bn_addc *) xO (xO (xI (xI (xI (xO xH))))), + {| f_info := xI (xO (xI (xI (xI (xO xH))))) + ; f_tyin := + [(sarr (xO (xO (xO (xI (xI xH)))))); + (sarr (xO (xO (xO (xI (xI xH))))))] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1302" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1303" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := {| vtype := sbool + ; vname := "cf.1304" |} + ; v_info := dummy_var_info |}; + Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1302" |} + ; v_info := dummy_var_info |}] + (xI (xI (xI (xO (xO xH))))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1302" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1303" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [sbool; (sarr (xO (xO (xO (xI (xI xH))))))] + ; f_res := + [{| v_var := {| vtype := sbool + ; vname := "cf.1304" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1302" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* __bn_subc *) xO (xO (xI (xO (xO xH)))), + {| f_info := xI (xI (xO (xI (xI (xO xH))))) + ; f_tyin := + [(sarr (xO (xO (xO (xI (xI xH)))))); + (sarr (xO (xO (xO (xI (xI xH))))))] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1297" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1298" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t.1300" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1298" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pconst (Z0))))); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := {| vtype := sbool + ; vname := "cf.1299" |} + ; v_info := dummy_var_info |}; + Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1297" |} + ; v_info := dummy_var_info |} + (Pconst (Z0))] + AT_keep (Osubcarry (U64)) + [(Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1297" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pconst (Z0))); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t.1300" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pbool false)]); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "i.1301" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Zpos (xH)))), (Pconst (Zpos (xI (xI xH))))) + [MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t.1300" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1298" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1301" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := sbool + ; vname := "cf.1299" |} + ; v_info := dummy_var_info |}; + Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1297" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1301" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})] + AT_keep (Osubcarry (U64)) + [(Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1297" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1301" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t.1300" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := sbool + ; vname := "cf.1299" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})])]) ] + ; f_tyout := [sbool; (sarr (xO (xO (xO (xI (xI xH))))))] + ; f_res := + [{| v_var := {| vtype := sbool + ; vname := "cf.1299" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1297" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* _bn_subc *) xI (xO (xO (xI (xI (xO xH))))), + {| f_info := xO (xI (xO (xI (xI (xO xH))))) + ; f_tyin := + [(sarr (xO (xO (xO (xI (xI xH)))))); + (sarr (xO (xO (xO (xI (xI xH))))))] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1294" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1295" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := {| vtype := sbool + ; vname := "cf.1296" |} + ; v_info := dummy_var_info |}; + Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1294" |} + ; v_info := dummy_var_info |}] + (xO (xO (xI (xO (xO xH))))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1294" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1295" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [sbool; (sarr (xO (xO (xO (xI (xI xH))))))] + ; f_res := + [{| v_var := {| vtype := sbool + ; vname := "cf.1296" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1294" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* __addacc3 *) xO (xO (xO (xO (xO (xO xH))))), + {| f_info := xO (xO (xO (xI (xI (xO xH))))) + ; f_tyin := + [(sword U64); (sword U64); (sarr (xO (xO (xO (xI xH))))); sint] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "b1.1289" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U64) + ; vname := "b0.1290" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "a.1291" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := sint + ; vname := "k.1292" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := {| vtype := sbool + ; vname := "cf.1293" |} + ; v_info := dummy_var_info |}; + Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "a.1291" |} + ; v_info := dummy_var_info |} + (Papp2 (Omod Cmp_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1292" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xI xH))))] + AT_keep (Oaddcarry (U64)) + [(Pget AAscale U64 + {| gv := {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "a.1291" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Papp2 (Omod Cmp_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1292" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xI xH))))); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "b0.1290" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pbool false)]); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := {| vtype := sbool + ; vname := "cf.1293" |} + ; v_info := dummy_var_info |}; + Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "a.1291" |} + ; v_info := dummy_var_info |} + (Papp2 (Omod Cmp_int) + (Papp2 (Oadd Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1292" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xH)))) + (Pconst (Zpos (xI xH))))] + AT_keep (Oaddcarry (U64)) + [(Pget AAscale U64 + {| gv := {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "a.1291" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Papp2 (Omod Cmp_int) + (Papp2 (Oadd Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1292" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xH)))) + (Pconst (Zpos (xI xH))))); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "b1.1289" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := sbool + ; vname := "cf.1293" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := {| vtype := sbool + ; vname := "cf.1293" |} + ; v_info := dummy_var_info |}; + Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "a.1291" |} + ; v_info := dummy_var_info |} + (Papp2 (Omod Cmp_int) + (Papp2 (Oadd Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1292" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO xH)))) + (Pconst (Zpos (xI xH))))] + AT_keep (Oaddcarry (U64)) + [(Pget AAscale U64 + {| gv := {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "a.1291" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Papp2 (Omod Cmp_int) + (Papp2 (Oadd Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1292" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO xH)))) + (Pconst (Zpos (xI xH))))); + (Papp1 (Oword_of_int U64) (Pconst (Z0))); + (Pvar + {| gv := {| v_var := + {| vtype := sbool + ; vname := "cf.1293" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sarr (xO (xO (xO (xI xH)))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "a.1291" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* __muln_innerloop *) xI (xO (xO (xO (xO (xO xH))))), + {| f_info := xI (xI (xI (xO (xI (xO xH))))) + ; f_tyin := + [sint; sint; sint; (sarr (xO (xO (xO (xI (xI xH)))))); + (sarr (xO (xO (xO (xI (xI xH)))))); + (sarr (xO (xO (xO (xI xH)))))] + ; f_params := + [{| v_var := {| vtype := sint + ; vname := "k.1279" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := sint + ; vname := "istart.1280" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := sint + ; vname := "iend.1281" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1282" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1283" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1284" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "i.1285" |} + ; v_info := dummy_var_info |}) + ((UpTo, + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "istart.1280" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})), + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "iend.1281" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) + [MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := {| vtype := sint + ; vname := "j.1286" |} + ; v_info := dummy_var_info |}) + AT_inline (sint) + ((Papp2 (Osub Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1279" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1285" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1287" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1282" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1285" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t1.1288" |} + ; v_info := dummy_var_info |}; + Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1287" |} + ; v_info := dummy_var_info |}] + AT_keep (Omulu (U64)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1287" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1283" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "j.1286" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))]); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1284" |} + ; v_info := dummy_var_info |}] + (xO (xO (xO (xO (xO (xO xH)))))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t1.1288" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1287" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1284" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1279" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})])]) ] + ; f_tyout := [(sarr (xO (xO (xO (xI xH)))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1284" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* __bn_muln *) xI (xO (xO (xO (xO xH)))), + {| f_info := xO (xI (xI (xO (xI (xO xH))))) + ; f_tyin := + [(sarr (xO (xO (xO (xI (xI xH)))))); + (sarr (xO (xO (xO (xI (xI xH)))))); + (sarr (xO (xO (xO (xO (xI (xI xH)))))))] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1272" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1273" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "r.1274" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1275" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1272" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pconst (Z0))))); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t1.1276" |} + ; v_info := dummy_var_info |}; + Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1275" |} + ; v_info := dummy_var_info |}] + AT_keep (Omulu (U64)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1275" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1273" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pconst (Z0)))]); + MkI InstrInfo.witness + (Cassgn + (Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "r.1274" |} + ; v_info := dummy_var_info |} + (Pconst (Z0))) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1275" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cassgn + (Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1277" |} + ; v_info := dummy_var_info |} + (Pconst (Zpos (xH)))) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t1.1276" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Copn + [Lnone dummy_var_info sbool; Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; + Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1277" |} + ; v_info := dummy_var_info |} + (Pconst (Zpos (xO xH)))] + AT_keep (Oasm (* set0_64 *) (ExtOp (Oset0 U64))) []); + MkI InstrInfo.witness + (Copn + [Lnone dummy_var_info sbool; Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; + Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1277" |} + ; v_info := dummy_var_info |} + (Pconst (Z0))] + AT_keep (Oasm (* set0_64 *) (ExtOp (Oset0 U64))) []); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "k.1278" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Zpos (xH)))), (Pconst (Zpos (xI (xI xH))))) + [MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1277" |} + ; v_info := dummy_var_info |}] + (xI (xO (xO (xO (xO (xO xH)))))) + [(Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1278" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pconst (Z0)); + (Papp2 (Oadd Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1278" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xH)))); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1272" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1273" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1277" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1275" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1277" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Papp2 (Omod Cmp_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1278" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xI xH))))))); + MkI InstrInfo.witness + (Copn + [Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; + Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1277" |} + ; v_info := dummy_var_info |} + (Papp2 (Omod Cmp_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1278" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xI xH))))] + AT_keep (Oasm (* set0_64 *) (ExtOp (Oset0 U64))) + []); + MkI InstrInfo.witness + (Cassgn + (Laset AAscale U64 + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "r.1274" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1278" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1275" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))]); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "k.1278" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Zpos (xI (xI xH))))), + (Papp2 (Osub Op_int) + (Papp2 (Omul Op_int) (Pconst (Zpos (xO xH))) + (Pconst (Zpos (xI (xI xH))))) + (Pconst (Zpos (xH))))) + [MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1277" |} + ; v_info := dummy_var_info |}] + (xI (xO (xO (xO (xO (xO xH)))))) + [(Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1278" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Papp2 (Oadd Op_int) + (Papp2 (Osub Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1278" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xI (xI xH))))) + (Pconst (Zpos (xH)))); + (Pconst (Zpos (xI (xI xH)))); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1272" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1273" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1277" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1275" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1277" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Papp2 (Omod Cmp_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1278" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xI xH))))))); + MkI InstrInfo.witness + (Copn + [Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; + Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1277" |} + ; v_info := dummy_var_info |} + (Papp2 (Omod Cmp_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1278" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xI xH))))] + AT_keep (Oasm (* set0_64 *) (ExtOp (Oset0 U64))) + []); + MkI InstrInfo.witness + (Cassgn + (Laset AAscale U64 + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "r.1274" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1278" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1275" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))]); + MkI InstrInfo.witness + (Cassgn + (Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "r.1274" |} + ; v_info := dummy_var_info |} + (Papp2 (Osub Op_int) + (Papp2 (Omul Op_int) (Pconst (Zpos (xO xH))) + (Pconst (Zpos (xI (xI xH))))) + (Pconst (Zpos (xH))))) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1277" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Papp2 (Omod Cmp_int) + (Papp2 (Osub Op_int) + (Papp2 (Omul Op_int) (Pconst (Zpos (xO xH))) + (Pconst (Zpos (xI (xI xH))))) + (Pconst (Zpos (xH)))) + (Pconst (Zpos (xI xH))))))) ] + ; f_tyout := [(sarr (xO (xO (xO (xO (xI (xI xH)))))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "r.1274" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* _bn_muln *) xO (xO (xI (xO (xI (xO xH))))), + {| f_info := xI (xO (xI (xO (xI (xO xH))))) + ; f_tyin := + [(sarr (xO (xO (xO (xI (xI xH)))))); + (sarr (xO (xO (xO (xI (xI xH)))))); + (sarr (xO (xO (xO (xO (xI (xI xH)))))))] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1269" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1270" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "r.1271" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "r.1271" |} + ; v_info := dummy_var_info |}] + (xI (xO (xO (xO (xO xH))))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1269" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1270" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "r.1271" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sarr (xO (xO (xO (xO (xI (xI xH)))))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "r.1271" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* __addacc3x2 *) xO (xI (xO (xO (xI (xO xH))))), + {| f_info := xI (xI (xO (xO (xI (xO xH))))) + ; f_tyin := + [(sword U64); (sword U64); (sarr (xO (xO (xO (xI xH))))); sint] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "x.1260" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U64) + ; vname := "y.1261" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "a.1262" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := sint + ; vname := "k.1263" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "b1.1264" |} + ; v_info := dummy_var_info |}; + Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "b0.1265" |} + ; v_info := dummy_var_info |}] + AT_keep (Omulu (U64)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "x.1260" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "y.1261" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t.1266" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "b0.1265" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "b0.1265" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp2 (Olsl (Op_w U64)) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "b0.1265" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Papp1 (Oword_of_int U8) (Pconst (Zpos (xH))))))); + MkI InstrInfo.witness + (Copn + [Lnone dummy_var_info sbool; + Lvar + {| v_var := {| vtype := sbool + ; vname := "cf.1267" |} + ; v_info := dummy_var_info |}; + Lnone dummy_var_info sbool; Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; + Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "b1.1264" |} + ; v_info := dummy_var_info |}] + AT_keep (Oasm (* SHLD_64 *) (BaseOp (None, (SHLD U64)))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "b1.1264" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t.1266" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Papp1 (Oword_of_int U8) (Pconst (Zpos (xH))))]); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "b2.1268" |} + ; v_info := dummy_var_info |}] + AT_keep (Oasm (* MOV_64 *) (BaseOp (None, (MOV U64)))) + [(Papp1 (Oword_of_int U64) (Pconst (Z0)))]); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := {| vtype := sbool + ; vname := "cf.1267" |} + ; v_info := dummy_var_info |}; + Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "b2.1268" |} + ; v_info := dummy_var_info |}] + AT_keep (Oaddcarry (U64)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "b2.1268" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "b2.1268" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := sbool + ; vname := "cf.1267" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := {| vtype := sbool + ; vname := "cf.1267" |} + ; v_info := dummy_var_info |}; + Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "a.1262" |} + ; v_info := dummy_var_info |} + (Papp2 (Omod Cmp_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1263" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xI xH))))] + AT_keep (Oaddcarry (U64)) + [(Pget AAscale U64 + {| gv := {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "a.1262" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Papp2 (Omod Cmp_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1263" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xI xH))))); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "b0.1265" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pbool false)]); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := {| vtype := sbool + ; vname := "cf.1267" |} + ; v_info := dummy_var_info |}; + Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "a.1262" |} + ; v_info := dummy_var_info |} + (Papp2 (Omod Cmp_int) + (Papp2 (Oadd Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1263" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xH)))) + (Pconst (Zpos (xI xH))))] + AT_keep (Oaddcarry (U64)) + [(Pget AAscale U64 + {| gv := {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "a.1262" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Papp2 (Omod Cmp_int) + (Papp2 (Oadd Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1263" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xH)))) + (Pconst (Zpos (xI xH))))); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "b1.1264" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := sbool + ; vname := "cf.1267" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := {| vtype := sbool + ; vname := "cf.1267" |} + ; v_info := dummy_var_info |}; + Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "a.1262" |} + ; v_info := dummy_var_info |} + (Papp2 (Omod Cmp_int) + (Papp2 (Oadd Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1263" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO xH)))) + (Pconst (Zpos (xI xH))))] + AT_keep (Oaddcarry (U64)) + [(Pget AAscale U64 + {| gv := {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "a.1262" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Papp2 (Omod Cmp_int) + (Papp2 (Oadd Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1263" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO xH)))) + (Pconst (Zpos (xI xH))))); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "b2.1268" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := sbool + ; vname := "cf.1267" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sarr (xO (xO (xO (xI xH)))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "a.1262" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* __sqrn_innerloop *) xO (xO (xO (xO (xI (xO xH))))), + {| f_info := xI (xO (xO (xO (xI (xO xH))))) + ; f_tyin := + [sint; sint; sint; (sarr (xO (xO (xO (xI (xI xH)))))); + (sarr (xO (xO (xO (xI xH)))))] + ; f_params := + [{| v_var := {| vtype := sint + ; vname := "k.1251" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := sint + ; vname := "istart.1252" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := sint + ; vname := "iend.1253" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1254" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1255" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "i.1256" |} + ; v_info := dummy_var_info |}) + ((UpTo, + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "istart.1252" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})), + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "iend.1253" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) + [MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := {| vtype := sint + ; vname := "j.1257" |} + ; v_info := dummy_var_info |}) + AT_inline (sint) + ((Papp2 (Osub Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1251" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1256" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "ti.1258" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1254" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1256" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "tj.1259" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1254" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "j.1257" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1255" |} + ; v_info := dummy_var_info |}] + (xO (xI (xO (xO (xI (xO xH)))))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "ti.1258" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "tj.1259" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1255" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1251" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})])]) ] + ; f_tyout := [(sarr (xO (xO (xO (xI xH)))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1255" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* __bn_sqrn *) xO (xI (xI (xI xH))), + {| f_info := xI (xI (xI (xI (xO (xO xH))))) + ; f_tyin := + [(sarr (xO (xO (xO (xI (xI xH)))))); + (sarr (xO (xO (xO (xO (xI (xI xH)))))))] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1245" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "r.1246" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1247" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1245" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pconst (Z0))))); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t1.1248" |} + ; v_info := dummy_var_info |}; + Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1247" |} + ; v_info := dummy_var_info |}] + AT_keep (Omulu (U64)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1247" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1247" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "r.1246" |} + ; v_info := dummy_var_info |} + (Pconst (Z0))) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1247" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cassgn + (Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1249" |} + ; v_info := dummy_var_info |} + (Pconst (Zpos (xH)))) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t1.1248" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Copn + [Lnone dummy_var_info sbool; Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; + Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1249" |} + ; v_info := dummy_var_info |} + (Pconst (Zpos (xO xH)))] + AT_keep (Oasm (* set0_64 *) (ExtOp (Oset0 U64))) []); + MkI InstrInfo.witness + (Copn + [Lnone dummy_var_info sbool; Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; + Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1249" |} + ; v_info := dummy_var_info |} + (Pconst (Z0))] + AT_keep (Oasm (* set0_64 *) (ExtOp (Oset0 U64))) []); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "k.1250" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Zpos (xH)))), (Pconst (Zpos (xI (xI xH))))) + [MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1249" |} + ; v_info := dummy_var_info |}] + (xO (xO (xO (xO (xI (xO xH)))))) + [(Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1250" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pconst (Z0)); + (Papp2 (Odiv Cmp_int) + (Papp2 (Oadd Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1250" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xH)))) + (Pconst (Zpos (xO xH)))); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1245" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1249" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cif + (Papp2 (Oeq Op_int) + (Papp2 (Omod Cmp_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1250" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO xH)))) + (Pconst (Z0))) + [MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1247" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1245" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Papp2 (Odiv Cmp_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1250" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO xH))))))); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t1.1248" |} + ; v_info := dummy_var_info |}; + Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1247" |} + ; v_info := dummy_var_info |}] + AT_keep (Omulu (U64)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1247" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1247" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1249" |} + ; v_info := dummy_var_info |}] + (xO (xO (xO (xO (xO (xO xH)))))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t1.1248" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1247" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1249" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1250" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})])] + []); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1247" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1249" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Papp2 (Omod Cmp_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1250" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xI xH))))))); + MkI InstrInfo.witness + (Copn + [Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; + Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1249" |} + ; v_info := dummy_var_info |} + (Papp2 (Omod Cmp_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1250" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xI xH))))] + AT_keep (Oasm (* set0_64 *) (ExtOp (Oset0 U64))) + []); + MkI InstrInfo.witness + (Cassgn + (Laset AAscale U64 + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "r.1246" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1250" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1247" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))]); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "k.1250" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Zpos (xI (xI xH))))), + (Papp2 (Osub Op_int) + (Papp2 (Omul Op_int) (Pconst (Zpos (xO xH))) + (Pconst (Zpos (xI (xI xH))))) + (Pconst (Zpos (xH))))) + [MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1249" |} + ; v_info := dummy_var_info |}] + (xO (xO (xO (xO (xI (xO xH)))))) + [(Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1250" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Papp2 (Oadd Op_int) + (Papp2 (Osub Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1250" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xI (xI xH))))) + (Pconst (Zpos (xH)))); + (Papp2 (Odiv Cmp_int) + (Papp2 (Oadd Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1250" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xH)))) + (Pconst (Zpos (xO xH)))); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1245" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1249" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cif + (Papp2 (Oeq Op_int) + (Papp2 (Omod Cmp_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1250" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO xH)))) + (Pconst (Z0))) + [MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1247" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1245" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Papp2 (Odiv Cmp_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1250" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO xH))))))); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t1.1248" |} + ; v_info := dummy_var_info |}; + Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1247" |} + ; v_info := dummy_var_info |}] + AT_keep (Omulu (U64)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1247" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1247" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1249" |} + ; v_info := dummy_var_info |}] + (xO (xO (xO (xO (xO (xO xH)))))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t1.1248" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1247" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1249" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1250" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})])] + []); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1247" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1249" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Papp2 (Omod Cmp_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1250" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xI xH))))))); + MkI InstrInfo.witness + (Copn + [Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; + Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1249" |} + ; v_info := dummy_var_info |} + (Papp2 (Omod Cmp_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1250" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xI xH))))] + AT_keep (Oasm (* set0_64 *) (ExtOp (Oset0 U64))) + []); + MkI InstrInfo.witness + (Cassgn + (Laset AAscale U64 + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "r.1246" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1250" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1247" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))]); + MkI InstrInfo.witness + (Cassgn + (Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "r.1246" |} + ; v_info := dummy_var_info |} + (Papp2 (Osub Op_int) + (Papp2 (Omul Op_int) (Pconst (Zpos (xO xH))) + (Pconst (Zpos (xI (xI xH))))) + (Pconst (Zpos (xH))))) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1249" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Papp2 (Omod Cmp_int) + (Papp2 (Osub Op_int) + (Papp2 (Omul Op_int) (Pconst (Zpos (xO xH))) + (Pconst (Zpos (xI (xI xH))))) + (Pconst (Zpos (xH)))) + (Pconst (Zpos (xI xH))))))) ] + ; f_tyout := [(sarr (xO (xO (xO (xO (xI (xI xH)))))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "r.1246" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* _bn_sqrn *) xI (xO (xI (xI (xO (xO xH))))), + {| f_info := xO (xI (xI (xI (xO (xO xH))))) + ; f_tyin := + [(sarr (xO (xO (xO (xI (xI xH)))))); + (sarr (xO (xO (xO (xO (xI (xI xH)))))))] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1243" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "r.1244" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "r.1244" |} + ; v_info := dummy_var_info |}] + (xO (xI (xI (xI xH)))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1243" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "r.1244" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sarr (xO (xO (xO (xO (xI (xI xH)))))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "r.1244" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* __fp_caddP *) xI (xO (xI (xO (xO (xO xH))))), + {| f_info := xO (xO (xI (xI (xO (xO xH))))) + ; f_tyin := [sbool; (sarr (xO (xO (xO (xI (xI xH))))))] + ; f_params := + [{| v_var := {| vtype := sbool + ; vname := "cf.1235" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "x.1236" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "glob_pp.1237" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "glob_p.1070" |} + ; v_info := dummy_var_info |} ; gs := Sglob |}))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_tmp.1238" |} + ; v_info := dummy_var_info |}] + (xI (xI (xO (xI (xO (xO xH)))))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "glob_pp.1237" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1239" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp1 (Oword_of_int U64) (Pconst (Z0))))); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "i.1240" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Z0))), (Pconst (Zpos (xI (xI xH))))) + [MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t.1241" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_tmp.1238" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1240" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t.1241" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pif ((sword U64)) + (Papp1 Onot + (Pvar + {| gv := {| v_var := + {| vtype := sbool + ; vname := "cf.1235" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1239" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t.1241" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness + (Cassgn + (Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_tmp.1238" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1240" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t.1241" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "tmp.1242" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_tmp.1238" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lnone dummy_var_info sbool; + Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "x.1236" |} + ; v_info := dummy_var_info |}] + (xI (xI (xI (xO (xO xH))))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "x.1236" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "tmp.1242" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sarr (xO (xO (xO (xI (xI xH))))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "x.1236" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* __fp_cminusP *) xI (xI (xI (xI (xI xH)))), + {| f_info := xI (xO (xO (xI (xO (xO xH))))) + ; f_tyin := [(sarr (xO (xO (xO (xI (xI xH))))))] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "x.1230" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_tmp.1231" |} + ; v_info := dummy_var_info |}] + (xI (xI (xO (xI (xO (xO xH)))))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "x.1230" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "tmp.1232" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_tmp.1231" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "glob_mpp.1233" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "glob_mp.1069" |} + ; v_info := dummy_var_info |} ; gs := Sglob |}))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := {| vtype := sbool + ; vname := "_cf.1234" |} + ; v_info := dummy_var_info |}; + Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "tmp.1232" |} + ; v_info := dummy_var_info |}] + (xI (xI (xI (xO (xO xH))))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "tmp.1232" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "glob_mpp.1233" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "x.1230" |} + ; v_info := dummy_var_info |}] + (xO (xI (xO (xI (xO (xO xH)))))) + [(Pvar + {| gv := {| v_var := + {| vtype := sbool + ; vname := "_cf.1234" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "x.1230" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "tmp.1232" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sarr (xO (xO (xO (xI (xI xH))))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "x.1230" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* __fp_add *) xI (xI (xI (xO (xO (xO xH))))), + {| f_info := xO (xO (xO (xI (xO (xO xH))))) + ; f_tyin := + [(sarr (xO (xO (xO (xI (xI xH)))))); + (sarr (xO (xO (xO (xI (xI xH))))))] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1228" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1229" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun + [Lnone dummy_var_info sbool; + Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1228" |} + ; v_info := dummy_var_info |}] + (xI (xI (xI (xO (xO xH))))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1228" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1229" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1228" |} + ; v_info := dummy_var_info |}] + (xI (xI (xI (xI (xI xH))))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1228" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sarr (xO (xO (xO (xI (xI xH))))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1228" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* _fp_add *) xO (xI (xO (xI xH))), + {| f_info := xO (xI (xI (xO (xO (xO xH))))) + ; f_tyin := + [(sarr (xO (xO (xO (xI (xI xH)))))); + (sarr (xO (xO (xO (xI (xI xH))))))] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1226" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1227" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1226" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1226" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1226" |} + ; v_info := dummy_var_info |}] + (xI (xI (xI (xO (xO (xO xH)))))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1226" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1227" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sarr (xO (xO (xO (xI (xI xH))))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1226" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* __fp_sub *) xI (xI (xO (xO (xO (xO xH))))), + {| f_info := xO (xO (xI (xO (xO (xO xH))))) + ; f_tyin := + [(sarr (xO (xO (xO (xI (xI xH)))))); + (sarr (xO (xO (xO (xI (xI xH))))))] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1223" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1224" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := {| vtype := sbool + ; vname := "cf.1225" |} + ; v_info := dummy_var_info |}; + Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1223" |} + ; v_info := dummy_var_info |}] + (xO (xO (xI (xO (xO xH))))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1223" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1224" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1223" |} + ; v_info := dummy_var_info |}] + (xI (xO (xI (xO (xO (xO xH)))))) + [(Pvar + {| gv := {| v_var := + {| vtype := sbool + ; vname := "cf.1225" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1223" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sarr (xO (xO (xO (xI (xI xH))))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1223" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* _fp_sub *) xI (xI (xI (xO xH))), + {| f_info := xO (xI (xO (xO (xO (xO xH))))) + ; f_tyin := + [(sarr (xO (xO (xO (xI (xI xH)))))); + (sarr (xO (xO (xO (xI (xI xH))))))] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1221" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1222" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1221" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1221" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1221" |} + ; v_info := dummy_var_info |}] + (xI (xI (xO (xO (xO (xO xH)))))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1221" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1222" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sarr (xO (xO (xO (xI (xI xH))))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1221" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* __fp_rdcn *) xI (xO (xI (xO (xI xH)))), + {| f_info := xO (xI (xI (xI (xI xH)))) + ; f_tyin := + [(sarr (xO (xO (xO (xO (xI (xI xH))))))); + (sarr (xO (xO (xO (xI (xI xH))))))] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "a.1211" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1212" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Copn + [Lnone dummy_var_info sbool; Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; + Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "zero.1213" |} + ; v_info := dummy_var_info |}] + AT_keep (Oasm (* set0_64 *) (ExtOp (Oset0 U64))) []); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "u0r.1214" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "glob_u0.1067" |} + ; v_info := dummy_var_info |} ; gs := Sglob |}))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "p0.1215" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "glob_p.1070" |} + ; v_info := dummy_var_info |} ; gs := Sglob |} + (Pconst (Z0))))); + MkI InstrInfo.witness + (Copn + [Lnone dummy_var_info sbool; Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; + Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1216" |} + ; v_info := dummy_var_info |} + (Pconst (Z0))] + AT_keep (Oasm (* set0_64 *) (ExtOp (Oset0 U64))) []); + MkI InstrInfo.witness + (Copn + [Lnone dummy_var_info sbool; Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; + Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1216" |} + ; v_info := dummy_var_info |} + (Pconst (Zpos (xH)))] + AT_keep (Oasm (* set0_64 *) (ExtOp (Oset0 U64))) []); + MkI InstrInfo.witness + (Copn + [Lnone dummy_var_info sbool; Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; + Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1216" |} + ; v_info := dummy_var_info |} + (Pconst (Zpos (xO xH)))] + AT_keep (Oasm (* set0_64 *) (ExtOp (Oset0 U64))) []); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "k.1218" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Z0))), (Pconst (Zpos (xI (xI xH))))) + [MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "glob_pp.1217" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "glob_p.1070" |} + ; v_info := dummy_var_info |} ; gs := Sglob |}))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1216" |} + ; v_info := dummy_var_info |}] + (xI (xO (xO (xO (xO (xO xH)))))) + [(Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1218" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pconst (Z0)); + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1218" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1212" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "glob_pp.1217" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1216" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1219" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "a.1211" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1218" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1216" |} + ; v_info := dummy_var_info |}] + (xO (xO (xO (xO (xO (xO xH)))))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "zero.1213" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1219" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1216" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1218" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1219" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1216" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Papp2 (Omod Cmp_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1218" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xI xH))))))); + MkI InstrInfo.witness + (Copn + [Lnone dummy_var_info (sword U64); + Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1219" |} + ; v_info := dummy_var_info |}] + AT_keep (Omulu (U64)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1219" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "u0r.1214" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1212" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1218" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1219" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t1.1220" |} + ; v_info := dummy_var_info |}; + Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1219" |} + ; v_info := dummy_var_info |}] + AT_keep (Omulu (U64)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1219" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "p0.1215" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1216" |} + ; v_info := dummy_var_info |}] + (xO (xO (xO (xO (xO (xO xH)))))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t1.1220" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1219" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1216" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1218" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})])]); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "k.1218" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Zpos (xI (xI xH))))), + (Papp2 (Osub Op_int) + (Papp2 (Omul Op_int) (Pconst (Zpos (xO xH))) + (Pconst (Zpos (xI (xI xH))))) + (Pconst (Zpos (xH))))) + [MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "glob_pp.1217" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "glob_p.1070" |} + ; v_info := dummy_var_info |} ; gs := Sglob |}))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1216" |} + ; v_info := dummy_var_info |}] + (xI (xO (xO (xO (xO (xO xH)))))) + [(Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1218" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Papp2 (Oadd Op_int) + (Papp2 (Osub Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1218" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xI (xI xH))))) + (Pconst (Zpos (xH)))); + (Pconst (Zpos (xI (xI xH)))); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1212" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "glob_pp.1217" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1216" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1219" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "a.1211" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1218" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1216" |} + ; v_info := dummy_var_info |}] + (xO (xO (xO (xO (xO (xO xH)))))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "zero.1213" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1219" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1216" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1218" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1219" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1216" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Papp2 (Omod Cmp_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1218" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xI xH))))))); + MkI InstrInfo.witness + (Cassgn + (Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1212" |} + ; v_info := dummy_var_info |} + (Papp2 (Osub Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1218" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xI (xI xH)))))) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t0.1219" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Copn + [Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; + Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1216" |} + ; v_info := dummy_var_info |} + (Papp2 (Omod Cmp_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "k.1218" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xI xH))))] + AT_keep (Oasm (* set0_64 *) (ExtOp (Oset0 U64))) + [])]); + MkI InstrInfo.witness + (Cassgn + (Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1216" |} + ; v_info := dummy_var_info |} + (Papp2 (Omod Cmp_int) + (Papp2 (Osub Op_int) + (Papp2 (Omul Op_int) (Pconst (Zpos (xO xH))) + (Pconst (Zpos (xI (xI xH))))) + (Pconst (Zpos (xH)))) + (Pconst (Zpos (xI xH))))) + AT_none ((sword U64)) + ((Papp2 (Oadd (Op_w U64)) + (Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1216" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Papp2 (Omod Cmp_int) + (Papp2 (Osub Op_int) + (Papp2 (Omul Op_int) (Pconst (Zpos (xO xH))) + (Pconst (Zpos (xI (xI xH))))) + (Pconst (Zpos (xH)))) + (Pconst (Zpos (xI xH))))) + (Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "a.1211" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Papp2 (Osub Op_int) + (Papp2 (Omul Op_int) (Pconst (Zpos (xO xH))) + (Pconst (Zpos (xI (xI xH))))) + (Pconst (Zpos (xH)))))))); + MkI InstrInfo.witness + (Cassgn + (Laset AAscale U64 + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1212" |} + ; v_info := dummy_var_info |} + (Papp2 (Osub Op_int) (Pconst (Zpos (xI (xI xH)))) + (Pconst (Zpos (xH))))) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := (sarr (xO (xO (xO (xI xH))))) + ; vname := "x.1216" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Papp2 (Omod Cmp_int) + (Papp2 (Osub Op_int) + (Papp2 (Omul Op_int) (Pconst (Zpos (xO xH))) + (Pconst (Zpos (xI (xI xH))))) + (Pconst (Zpos (xH)))) + (Pconst (Zpos (xI xH))))))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1212" |} + ; v_info := dummy_var_info |}] + (xI (xI (xI (xI (xI xH))))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1212" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sarr (xO (xO (xO (xI (xI xH))))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1212" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* _fp_mul *) xO (xO (xI (xO xH))), + {| f_info := xI (xO (xI (xI (xI xH)))) + ; f_tyin := + [(sarr (xO (xO (xO (xI (xI xH)))))); + (sarr (xO (xO (xO (xI (xI xH)))))); + (sarr (xO (xO (xO (xI (xI xH))))))] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1206" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1207" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1208" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1208" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1208" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "tmp.1210" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xO (xI (xI xH)))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "_tmp.1209" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "tmp.1210" |} + ; v_info := dummy_var_info |}] + (xI (xO (xO (xO (xO xH))))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1206" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1207" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "tmp.1210" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1208" |} + ; v_info := dummy_var_info |}] + (xI (xO (xI (xO (xI xH))))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "tmp.1210" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1208" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sarr (xO (xO (xO (xI (xI xH))))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1208" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* _fp_mulU *) xI (xI (xO (xO (xI xH)))), + {| f_info := xO (xO (xI (xI (xI xH)))) + ; f_tyin := + [(sarr (xO (xO (xO (xI (xI xH)))))); + (sarr (xO (xO (xO (xI (xI xH))))))] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1202" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1203" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1202" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1202" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "tmp.1205" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xO (xI (xI xH)))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "_tmp.1204" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "tmp.1205" |} + ; v_info := dummy_var_info |}] + (xI (xO (xO (xO (xO xH))))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1202" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1203" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "tmp.1205" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1202" |} + ; v_info := dummy_var_info |}] + (xI (xO (xI (xO (xI xH))))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "tmp.1205" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1202" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sarr (xO (xO (xO (xI (xI xH))))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1202" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* _fp_sqr *) xI (xO (xO (xO xH))), + {| f_info := xI (xI (xO (xI (xI xH)))) + ; f_tyin := + [(sarr (xO (xO (xO (xI (xI xH)))))); + (sarr (xO (xO (xO (xI (xI xH))))))] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1198" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1199" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1199" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1199" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "tmp.1201" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xO (xI (xI xH)))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "_tmp.1200" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "tmp.1201" |} + ; v_info := dummy_var_info |}] + (xO (xI (xI (xI xH)))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1198" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "tmp.1201" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1199" |} + ; v_info := dummy_var_info |}] + (xI (xO (xI (xO (xI xH))))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "tmp.1201" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1199" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sarr (xO (xO (xO (xI (xI xH))))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1199" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* _fp_sqrU *) xO (xO (xO (xI (xI xH)))), + {| f_info := xO (xI (xO (xI (xI xH)))) + ; f_tyin := [(sarr (xO (xO (xO (xI (xI xH))))))] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1195" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1195" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1195" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "tmp.1197" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xO (xI (xI xH)))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "_tmp.1196" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "tmp.1197" |} + ; v_info := dummy_var_info |}] + (xO (xI (xI (xI xH)))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1195" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "tmp.1197" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1195" |} + ; v_info := dummy_var_info |}] + (xI (xO (xI (xO (xI xH))))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "tmp.1197" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1195" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sarr (xO (xO (xO (xI (xI xH))))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1195" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* _fp_exp *) xO (xI (xI xH)), + {| f_info := xI (xI (xI (xO (xI xH)))) + ; f_tyin := + [(sarr (xO (xO (xO (xI (xI xH)))))); + (sarr (xO (xO (xO (xI (xI xH)))))); + (sarr (xO (xO (xO (xI (xI xH))))))] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1181" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_b.1182" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1183" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "x.1185" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_x.1184" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "glob_oneMp.1186" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "glob_oneM.1066" |} + ; v_info := dummy_var_info |} ; gs := Sglob |}))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "x.1185" |} + ; v_info := dummy_var_info |}] + (xI (xO (xO (xI (xI xH))))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1181" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "x.1185" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1183" |} + ; v_info := dummy_var_info |}] + (xI (xO (xO (xI (xI xH))))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "glob_oneMp.1186" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1183" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_x.1184" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "x.1185" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "bb.1187" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_b.1182" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "rr.1188" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1183" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "j.1190" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Z0))), (Pconst (Zpos (xI (xI xH))))) + [MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1189" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "bb.1187" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t.1191" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1189" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "j.1190" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "k.1192" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp1 (Oword_of_int U64) + (Pconst (Zpos (xO (xO (xO (xO (xO (xO xH))))))))))); + MkI InstrInfo.witness + (Cwhile NoAlign [] + ((Papp2 (Oneq (Op_w U64)) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "k.1192" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Papp1 (Oword_of_int U64) (Pconst (Z0))))) + [MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "ss.1193" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "k.1192" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Copn + [Lnone dummy_var_info sbool; + Lvar + {| v_var := + {| vtype := sbool + ; vname := "cf.1194" |} + ; v_info := dummy_var_info |}; + Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; + Lnone dummy_var_info sbool; + Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t.1191" |} + ; v_info := dummy_var_info |}] + AT_keep + (Oasm (* SHR_64 *) (BaseOp (None, (SHR U64)))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t.1191" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Papp1 (Oword_of_int U8) (Pconst (Zpos (xH))))]); + MkI InstrInfo.witness + (Cif + (Pvar + {| gv := {| v_var := + {| vtype := sbool + ; vname := "cf.1194" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + [MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1183" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "rr.1188" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "x.1185" |} + ; v_info := dummy_var_info |}) + AT_none + ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_x.1184" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall DoNotInline + [Lvar + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1183" |} + ; v_info := dummy_var_info |}] + (xI (xI (xO (xO (xI xH))))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1183" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "x.1185" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_x.1184" |} + ; v_info := dummy_var_info |}) + AT_none + ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "x.1185" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "rr.1188" |} + ; v_info := dummy_var_info |}) + AT_none + ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1183" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))] + []); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "x.1185" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_x.1184" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall DoNotInline + [Lvar + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "x.1185" |} + ; v_info := dummy_var_info |}] + (xO (xO (xO (xI (xI xH))))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "x.1185" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_x.1184" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "x.1185" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "k.1192" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "ss.1193" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "k.1192" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp2 (Osub (Op_w U64)) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "k.1192" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Papp1 (Oword_of_int U64) + (Pconst (Zpos (xH)))))))])]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1183" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "rr.1188" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))) ] + ; f_tyout := [(sarr (xO (xO (xO (xI (xI xH))))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1183" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* __fp_inv *) xI (xI (xO xH)), + {| f_info := xO (xI (xI (xO (xI xH)))) + ; f_tyin := + [(sarr (xO (xO (xO (xI (xI xH)))))); + (sarr (xO (xO (xO (xI (xI xH))))))] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1178" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1179" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "glob_pm2p.1180" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "glob_pm2.1068" |} + ; v_info := dummy_var_info |} ; gs := Sglob |}))); + MkI InstrInfo.witness + (Ccall DoNotInline + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1179" |} + ; v_info := dummy_var_info |}] + (xO (xI (xI xH))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1178" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "glob_pm2p.1180" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1179" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sarr (xO (xO (xO (xI (xI xH))))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1179" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* _fp_fromM *) xO (xO xH), + {| f_info := xO (xO (xI (xO (xI xH)))) + ; f_tyin := [(sarr (xO (xO (xO (xI (xI xH))))))] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1173" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1173" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1173" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "i.1174" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Z0))), (Pconst (Zpos (xI (xI xH))))) + [MkI InstrInfo.witness + (Cassgn + (Laset AAscale U64 + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "_tmp.1175" |} + ; v_info := dummy_var_info |} + (Papp2 (Oadd Op_int) (Pconst (Zpos (xI (xI xH)))) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1174" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))) + AT_none ((sword U64)) + ((Papp1 (Oword_of_int U64) (Pconst (Z0)))))]); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "i.1174" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Z0))), (Pconst (Zpos (xI (xI xH))))) + [MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t.1176" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1173" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1174" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness + (Cassgn + (Laset AAscale U64 + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "_tmp.1175" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1174" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t.1176" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "tmp.1177" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xO (xI (xI xH)))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "_tmp.1175" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1173" |} + ; v_info := dummy_var_info |}] + (xI (xO (xI (xO (xI xH))))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "tmp.1177" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1173" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sarr (xO (xO (xO (xI (xI xH))))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1173" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* _fp_toM *) xO (xO (xO xH)), + {| f_info := xO (xI (xO (xO (xI xH)))) + ; f_tyin := [(sarr (xO (xO (xO (xI (xI xH))))))] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1171" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1171" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1171" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "glob_rMp.1172" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "glob_rM.1065" |} + ; v_info := dummy_var_info |} ; gs := Sglob |}))); + MkI InstrInfo.witness + (Ccall DoNotInline + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1171" |} + ; v_info := dummy_var_info |}] + (xI (xI (xO (xO (xI xH))))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1171" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "glob_rMp.1172" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sarr (xO (xO (xO (xI (xI xH))))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1171" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* bn_eq *) xI (xI (xI (xI (xO xH)))), + {| f_info := xO (xO (xO (xO (xI xH)))) + ; f_tyin := [(sword U64); (sword U64)] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "ap.1164" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U64) + ; vname := "bp.1165" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_a.1167" |} + ; v_info := dummy_var_info |}] + (xI (xO xH)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "ap.1164" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1168" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_a.1167" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_b.1169" |} + ; v_info := dummy_var_info |}] + (xI (xO xH)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "bp.1165" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1170" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_b.1169" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "r.1166" |} + ; v_info := dummy_var_info |}] + (xI (xO (xO (xO (xI xH))))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1168" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1170" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sword U64)] + ; f_res := + [{| v_var := {| vtype := (sword U64) + ; vname := "r.1166" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* bn_test0 *) xO (xO (xI (xI (xO xH)))), + {| f_info := xI (xO (xI (xI (xO xH)))) + ; f_tyin := [(sword U64)] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "ap.1160" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_a.1162" |} + ; v_info := dummy_var_info |}] + (xI (xO xH)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "ap.1160" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1163" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_a.1162" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "r.1161" |} + ; v_info := dummy_var_info |}] + (xO (xI (xI (xI (xO xH))))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1163" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "r.1161" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "r.1161" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))) ] + ; f_tyout := [(sword U64)] + ; f_res := + [{| v_var := {| vtype := (sword U64) + ; vname := "r.1161" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* bn_copy *) xO (xI (xO (xI (xO xH)))), + {| f_info := xI (xI (xO (xI (xO xH)))) + ; f_tyin := [(sword U64); (sword U64)] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "rp.1156" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U64) + ; vname := "ap.1157" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "i.1158" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Z0))), (Pconst (Zpos (xI (xI xH))))) + [MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "t.1159" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pload U64 + {| v_var := + {| vtype := (sword U64) + ; vname := "ap.1157" |} + ; v_info := dummy_var_info |} + (Papp1 (Oword_of_int U64) + (Papp2 (Omul Op_int) + (Pconst (Zpos (xO (xO (xO xH))))) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1158" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))))); + MkI InstrInfo.witness + (Cassgn + (Lmem U64 + {| v_var := + {| vtype := (sword U64) + ; vname := "rp.1156" |} + ; v_info := dummy_var_info |} + (Papp1 (Oword_of_int U64) + (Papp2 (Omul Op_int) + (Pconst (Zpos (xO (xO (xO xH))))) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1158" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "t.1159" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))]) ] + ; f_tyout := [] + ; f_res := [] + ; f_extra := tt + ; |} ) + ; ( (* bn_set0 *) xO (xO (xO (xI (xO xH)))), + {| f_info := xI (xO (xO (xI (xO xH)))) + ; f_tyin := [(sword U64)] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "rp.1154" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "i.1155" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Z0))), (Pconst (Zpos (xI (xI xH))))) + [MkI InstrInfo.witness + (Cassgn + (Lmem U64 + {| v_var := + {| vtype := (sword U64) + ; vname := "rp.1154" |} + ; v_info := dummy_var_info |} + (Papp1 (Oword_of_int U64) + (Papp2 (Omul Op_int) + (Pconst (Zpos (xO (xO (xO xH))))) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.1155" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))) + AT_none ((sword U64)) + ((Papp1 (Oword_of_int U64) (Pconst (Z0)))))]) ] + ; f_tyout := [] + ; f_res := [] + ; f_extra := tt + ; |} ) + ; ( (* bn_addn *) xI (xO (xI (xO (xO xH)))), + {| f_info := xO (xI (xI (xO (xO xH)))) + ; f_tyin := [(sword U64); (sword U64); (sword U64)] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "rp.1147" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U64) + ; vname := "ap.1148" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U64) + ; vname := "bp.1149" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_a.1150" |} + ; v_info := dummy_var_info |}] + (xI (xO xH)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "ap.1148" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1151" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_a.1150" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_b.1152" |} + ; v_info := dummy_var_info |}] + (xI (xO xH)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "bp.1149" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1153" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_b.1152" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lnone dummy_var_info sbool; + Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1151" |} + ; v_info := dummy_var_info |}] + (xI (xI (xI (xO (xO xH))))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1151" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1153" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Ccall InlineFun [] (xI xH) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "rp.1147" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1151" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [] + ; f_res := [] + ; f_extra := tt + ; |} ) + ; ( (* bn_subn *) xO (xI (xO (xO (xO xH)))), + {| f_info := xI (xI (xO (xO (xO xH)))) + ; f_tyin := [(sword U64); (sword U64); (sword U64)] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "rp.1140" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U64) + ; vname := "ap.1141" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U64) + ; vname := "bp.1142" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_a.1143" |} + ; v_info := dummy_var_info |}] + (xI (xO xH)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "ap.1141" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1144" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_a.1143" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_b.1145" |} + ; v_info := dummy_var_info |}] + (xI (xO xH)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "bp.1142" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1146" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_b.1145" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lnone dummy_var_info sbool; + Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1144" |} + ; v_info := dummy_var_info |}] + (xO (xO (xI (xO (xO xH))))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1144" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1146" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Ccall InlineFun [] (xI xH) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "rp.1140" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1144" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [] + ; f_res := [] + ; f_extra := tt + ; |} ) + ; ( (* bn_muln *) xI (xI (xI (xI xH))), + {| f_info := xO (xO (xO (xO (xO xH)))) + ; f_tyin := [(sword U64); (sword U64); (sword U64)] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "rp.1131" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U64) + ; vname := "ap.1132" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U64) + ; vname := "bp.1133" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_a.1134" |} + ; v_info := dummy_var_info |}] + (xI (xO xH)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "ap.1132" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1135" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_a.1134" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_b.1136" |} + ; v_info := dummy_var_info |}] + (xI (xO xH)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "bp.1133" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1137" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_b.1136" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "r.1139" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xO (xI (xI xH)))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "_r.1138" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "r.1139" |} + ; v_info := dummy_var_info |}] + (xI (xO (xO (xO (xO xH))))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1135" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1137" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "r.1139" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Ccall InlineFun [] (xI (xO (xI (xI xH)))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "rp.1131" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "r.1139" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [] + ; f_res := [] + ; f_extra := tt + ; |} ) + ; ( (* bn_sqrn *) xI (xI (xO (xI xH))), + {| f_info := xO (xO (xI (xI xH))) + ; f_tyin := [(sword U64); (sword U64)] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "rp.1125" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U64) + ; vname := "ap.1126" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_a.1127" |} + ; v_info := dummy_var_info |}] + (xI (xO xH)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "ap.1126" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1128" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_a.1127" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "r.1130" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xO (xI (xI xH)))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "_r.1129" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "r.1130" |} + ; v_info := dummy_var_info |}] + (xO (xI (xI (xI xH)))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1128" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "r.1130" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Ccall InlineFun [] (xI (xO (xI (xI xH)))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "rp.1125" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI xH))))))) + ; vname := "r.1130" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [] + ; f_res := [] + ; f_extra := tt + ; |} ) + ; ( (* fp_add *) xO (xO (xO (xI xH))), + {| f_info := xI (xO (xO (xI xH))) + ; f_tyin := [(sword U64); (sword U64); (sword U64)] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "rp.1118" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U64) + ; vname := "ap.1119" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U64) + ; vname := "bp.1120" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_a.1121" |} + ; v_info := dummy_var_info |}] + (xI (xO xH)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "ap.1119" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1122" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_a.1121" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_b.1123" |} + ; v_info := dummy_var_info |}] + (xI (xO xH)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "bp.1120" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1124" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_b.1123" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall DoNotInline + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1122" |} + ; v_info := dummy_var_info |}] + (xO (xI (xO (xI xH)))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1122" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1124" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Ccall InlineFun [] (xI xH) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "rp.1118" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1122" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [] + ; f_res := [] + ; f_extra := tt + ; |} ) + ; ( (* fp_sub *) xI (xO (xI (xO xH))), + {| f_info := xO (xI (xI (xO xH))) + ; f_tyin := [(sword U64); (sword U64); (sword U64)] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "rp.1111" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U64) + ; vname := "ap.1112" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U64) + ; vname := "bp.1113" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_a.1114" |} + ; v_info := dummy_var_info |}] + (xI (xO xH)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "ap.1112" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1115" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_a.1114" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_b.1116" |} + ; v_info := dummy_var_info |}] + (xI (xO xH)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "bp.1113" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1117" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_b.1116" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall DoNotInline + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1115" |} + ; v_info := dummy_var_info |}] + (xI (xI (xI (xO xH)))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1115" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1117" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Ccall InlineFun [] (xI xH) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "rp.1111" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1115" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [] + ; f_res := [] + ; f_extra := tt + ; |} ) + ; ( (* fp_mul *) xO (xI (xO (xO xH))), + {| f_info := xI (xI (xO (xO xH))) + ; f_tyin := [(sword U64); (sword U64); (sword U64)] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "rp.1102" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U64) + ; vname := "ap.1103" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U64) + ; vname := "bp.1104" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_a.1105" |} + ; v_info := dummy_var_info |}] + (xI (xO xH)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "ap.1103" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1106" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_a.1105" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_b.1107" |} + ; v_info := dummy_var_info |}] + (xI (xO xH)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "bp.1104" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1108" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_b.1107" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1110" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_r.1109" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall DoNotInline + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1110" |} + ; v_info := dummy_var_info |}] + (xO (xO (xI (xO xH)))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1106" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1108" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1110" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Ccall InlineFun [] (xI xH) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "rp.1102" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1110" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [] + ; f_res := [] + ; f_extra := tt + ; |} ) + ; ( (* fp_sqr *) xI (xI (xI xH)), + {| f_info := xO (xO (xO (xO xH))) + ; f_tyin := [(sword U64); (sword U64)] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "rp.1096" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U64) + ; vname := "ap.1097" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_a.1098" |} + ; v_info := dummy_var_info |}] + (xI (xO xH)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "ap.1097" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1099" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_a.1098" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1101" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_r.1100" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall DoNotInline + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1101" |} + ; v_info := dummy_var_info |}] + (xI (xO (xO (xO xH)))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1099" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1101" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Ccall InlineFun [] (xI xH) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "rp.1096" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1101" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [] + ; f_res := [] + ; f_extra := tt + ; |} ) + ; ( (* fp_expm_noct *) xO (xO (xI xH)), + {| f_info := xI (xO (xI xH)) + ; f_tyin := [(sword U64); (sword U64); (sword U64)] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "rp.1086" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U64) + ; vname := "ap.1087" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U64) + ; vname := "bp.1088" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "_rp.1089" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "rp.1086" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_a.1090" |} + ; v_info := dummy_var_info |}] + (xI (xO xH)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "ap.1087" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1091" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_a.1090" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_b.1092" |} + ; v_info := dummy_var_info |}] + (xI (xO xH)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "bp.1088" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1093" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_b.1092" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1095" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_r.1094" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall DoNotInline + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1095" |} + ; v_info := dummy_var_info |}] + (xO (xI (xI xH))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1091" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "b.1093" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1095" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "rp.1086" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "_rp.1089" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall InlineFun [] (xI xH) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "rp.1086" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1095" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [] + ; f_res := [] + ; f_extra := tt + ; |} ) + ; ( (* fp_inv *) xI (xO (xO xH)), + {| f_info := xO (xI (xO xH)) + ; f_tyin := [(sword U64); (sword U64)] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "rp.1079" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U64) + ; vname := "ap.1080" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "_rp.1081" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "rp.1079" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_a.1082" |} + ; v_info := dummy_var_info |}] + (xI (xO xH)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "ap.1080" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1083" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_a.1082" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1085" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_r.1084" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1085" |} + ; v_info := dummy_var_info |}] + (xI (xI (xO xH))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1083" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1085" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "rp.1079" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "_rp.1081" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall InlineFun [] (xI xH) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "rp.1079" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "r.1085" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [] + ; f_res := [] + ; f_extra := tt + ; |} ) + ; ( (* fp_toM *) xO (xI xH), + {| f_info := xI (xI xH) + ; f_tyin := [(sword U64); (sword U64)] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "rp.1075" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U64) + ; vname := "ap.1076" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_a.1077" |} + ; v_info := dummy_var_info |}] + (xI (xO xH)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "ap.1076" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1078" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_a.1077" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall DoNotInline + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1078" |} + ; v_info := dummy_var_info |}] + (xO (xO (xO xH))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1078" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Ccall InlineFun [] (xI xH) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "rp.1075" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1078" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [] + ; f_res := [] + ; f_extra := tt + ; |} ) + ; ( (* fp_fromM *) xH, + {| f_info := xO xH + ; f_tyin := [(sword U64); (sword U64)] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "rp.1071" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U64) + ; vname := "ap.1072" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_a.1073" |} + ; v_info := dummy_var_info |}] + (xI (xO xH)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "ap.1072" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1074" |} + ; v_info := dummy_var_info |}) + AT_none ((sarr (xO (xO (xO (xI (xI xH))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "_a.1073" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall DoNotInline + [Lvar + {| v_var := + {| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1074" |} + ; v_info := dummy_var_info |}] + (xO (xO xH)) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1074" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Ccall InlineFun [] (xI xH) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "rp.1071" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "a.1074" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [] + ; f_res := [] + ; f_extra := tt + ; |} ) ] ; + p_globs := [({| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "glob_rM.1065" |}, + (@Garr (xO (xO (xO (xI (xI xH))))) (* TODO: pp_gd *) _)) + ; ({| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "glob_oneM.1066" |}, + (@Garr (xO (xO (xO (xI (xI xH))))) (* TODO: pp_gd *) _)) + ; ({| vtype := (sword U64) + ; vname := "glob_u0.1067" |}, + (@Gword U64 (* TODO: pp_gd *) _)) + ; ({| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "glob_pm2.1068" |}, + (@Garr (xO (xO (xO (xI (xI xH))))) (* TODO: pp_gd *) _)) + ; ({| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "glob_mp.1069" |}, + (@Garr (xO (xO (xO (xI (xI xH))))) (* TODO: pp_gd *) _)) + ; ({| vtype := (sarr (xO (xO (xO (xI (xI xH)))))) + ; vname := "glob_p.1070" |}, + (@Garr (xO (xO (xO (xI (xI xH))))) (* TODO: pp_gd *) _))] ; + p_extra := tt |}. + + set rMZ := [48 ; 155 ; 214 ; 220 ; 101 ; 91 ; 229 ; 40 ; 194 ; 152 ; 135 ; 118 ; 103 ; 115 ; 236 ; 172 ; 141 ; 104 ; 17 ; 131 ; 63 ; 151 ; 39 ; 171 ; 11 ; 124 ; 108 ; 141 ; 175 ; 198 ; 92 ; 23 ; 126 ; 52 ; 222 ; 45 ; 191 ; 146 ; 205 ; 171 ; 154 ; 109 ; 104 ; 199 ; 97 ; 106 ; 225 ; 105 ; 42 ; 209 ; 205 ; 155 ; 168 ; 37 ; 0 ; 0]%Z. + set rM := WArray.fill 56 [seq word.mkword U8 i | i <- rMZ]. + destruct rM as [rM|]; [ exact rM | exact (WArray.empty 56) ]. + + set oneMZ := [44 ; 116 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 252 ; 4 ; 244 ; 15 ; 185 ; 212 ; 172 ; 159 ; 85 ; 251 ; 164 ; 1 ; 216 ; 12 ; 65 ; 119 ; 95 ; 84 ; 84 ; 50 ; 233 ; 218 ; 46 ; 189 ; 167 ; 238 ; 236 ; 0 ; 0]%Z. + set oneM := WArray.fill 56 [seq word.mkword U8 i | i <- oneMZ]. + destruct oneM as [oneM|]; [ exact oneM | exact (WArray.empty 56) ]. + + set u0 := (word.mkword U64 1 : u64). + exact u0. + + set pm2Z := [253 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 226 ; 122 ; 118 ; 193 ; 253 ; 163 ; 174 ; 88 ; 49 ; 120 ; 92 ; 198 ; 123 ; 86 ; 32 ; 197 ; 129 ; 214 ; 95 ; 252 ; 108 ; 68 ; 115 ; 23 ; 39 ; 31 ; 52 ; 2 ; 0]%Z. + set pm2 := WArray.fill 56 [seq word.mkword U8 i | i <- pm2Z]. + destruct pm2 as [pm2|]; [ exact pm2 | exact (WArray.empty 56) ]. + + set mpZ := [ (Zpos 1) (* FIXME: 1 *) ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 0 ; 29 ; 133 ; 137 ; 62 ; 2 ; 92 ; 81 ; 167 ; 206 ; 135 ; 163 ; 57 ; 132 ; 169 ; 223 ; 58 ; 126 ; 41 ; 160 ; 3 ; 147 ; 187 ; 140 ; 232 ; 216 ; 224 ; 203 ; 253 ; 255]%Z. + set mp := WArray.fill 56 [seq word.mkword U8 i | i <- mpZ]. + destruct mp as [mp|]; [ exact mp | exact (WArray.empty 56) ]. + + + set pZ := [255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 255 ; 226 ; 122 ; 118 ; 193 ; 253 ; 163 ; 174 ; 88 ; 49 ; 120 ; 92 ; 198 ; 123 ; 86 ; 32 ; 197 ; 129 ; 214 ; 95 ; 252 ; 108 ; 68 ; 115 ; 23 ; 39 ; 31 ; 52 ; 2 ; 0]%Z. + set p := WArray.fill 56 [seq word.mkword U8 i | i <- pZ]. + destruct p as [p|]; [ exact p | exact (WArray.empty 56) ]. +Defined. From cb97425bf09aeca3f0f584164da8a0ac80513645 Mon Sep 17 00:00:00 2001 From: bshvass Date: Tue, 25 Oct 2022 18:13:51 +0200 Subject: [PATCH 281/383] progress --- theories/Jasmin/examples/aes/aes.v | 65 +++++++++++++++++++++++++++--- 1 file changed, 60 insertions(+), 5 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes.v b/theories/Jasmin/examples/aes/aes.v index 15da1992..8be3c9ca 100644 --- a/theories/Jasmin/examples/aes/aes.v +++ b/theories/Jasmin/examples/aes/aes.v @@ -1075,8 +1075,13 @@ From mathcomp.word Require Import word. Infix "^" := wxor. (* copy of the easycrypt functional definition *) +Locate ".-tuple". + +Definition W4u8 : 4.-tuple u8 -> u32 := wcat. +Definition W4u32 : 4.-tuple u32 -> u128 := wcat. + Definition key_expand (wn1 : u128) (rcon : u8) : 'word U128 := - let rcon := wpack U32 4 [toword rcon; 0%Z; 0%Z; 0%Z] in + let rcon := W4u8 (* U32 4 *) [tuple rcon ; 0%R; 0%R; 0%R] (* [toword rcon; 0%Z; 0%Z; 0%Z] *) in let w0 := subword 0 32 wn1 in let w1 := subword 1 32 wn1 in let w2 := subword 2 32 wn1 in @@ -1088,11 +1093,11 @@ Definition key_expand (wn1 : u128) (rcon : u8) : 'word U128 := let w5 := w1 ^ w4 in let w6 := w2 ^ w5 in let w7 := w3 ^ w6 in - wpack U128 4 [toword w4; toword w5; toword w6; toword w7]. + W4u32 [tuple w4; w5; w6; w7]. Ltac neq_loc_auto ::= eapply injective_translate_var3; auto. -Notation "m ⊕ k" := (@word.wxor _ m k) (at level 70). +Notation "m ⊕ k" := (@word.word.wxor _ m k) (at level 20). Lemma lsr_word0 {ws1} a : @lsr ws1 word0 a = word0. Proof. @@ -1120,7 +1125,7 @@ Proof. Qed. (* Lemma wcat_r_zero_extend : *) - (* wcat_r [seq zero_extend a ] *) +(* wcat_r [seq zero_extend a ] *) Lemma wpshufd_1280 : forall a, wpshufd_128 a 0 = a. Proof. @@ -1130,6 +1135,30 @@ Proof. unfold iota, map. rewrite !wpshufd10. Admitted. +(* wpack *) + +(* Lemma wpack_w2t : *) + (* w2t (wpack ws n l) = *) + (* t2w [tuple ] *) +(* tuple *) + +Lemma wcat_eq ws p a t : + (forall (i : 'I_p), subword (i * ws) ws a = tnth t i) -> a = wcat t. +Proof. + intros. + rewrite -[a]wcat_subwordK. + apply f_equal. apply eq_from_tnth. + intros i. + rewrite -H tnth_map tnth_ord_tuple. + reflexivity. +Qed. + +Definition W4u32_eq : forall a t, (forall (i : 'I_4), subword (i * U32) U32 a = tnth t i) -> a = W4u32 t := wcat_eq U32 4. + +Lemma subword_xor {n} i ws (a b : n.-word) : + subword i ws (a ⊕ b) = (subword i ws a) ⊕ (subword i ws b). +Proof. +Admitted. Lemma key_expand_correct rcon rkey temp2 rcon_ : toword rcon_ = rcon -> @@ -1147,7 +1176,6 @@ Proof. rewrite !coerce_to_choice_type_K. unfold eval_jdg. - repeat clear_get. unfold sopn_sem. @@ -1163,4 +1191,31 @@ Proof. eapply u_ret. split. easy. + + + unfold totce. + f_equal. + + apply W4u32_eq. + intros [[ | [ | [ | i]]] j]; simpl. + unfold tnth. + simpl. + rewrite mul0n. + unfold word.wxor. + rewrite !subword_xor. + + simpl. + rewrite tnth_ord_tuple. + destruct i as []. + + simpl. + pose proof (@wcat_subwordK 32 4). + change (32 * 4)%nat with 128%nat in H1. + + rewrite <- H1. + + + wpack + lift2_vec + eapply val_inj. Admitted. From e211c931d7f248e151b78cd1e00d4470d27076a9 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Thu, 27 Oct 2022 11:53:42 +0200 Subject: [PATCH 282/383] some lemmas on words --- theories/Jasmin/examples/aes/aes.v | 162 ++++++++++++++++++++++++++--- 1 file changed, 147 insertions(+), 15 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes.v b/theories/Jasmin/examples/aes/aes.v index 8be3c9ca..8b50652e 100644 --- a/theories/Jasmin/examples/aes/aes.v +++ b/theories/Jasmin/examples/aes/aes.v @@ -1056,6 +1056,8 @@ Definition Jkey_expand rcon rkey temp2 := get_tr (xO (xI (xO (xO xH)))) 1%positi Definition rcon (i : Z) := nth 54%Z [:: 1; 2; 4; 8; 16; 32; 64; 128; 27; 54]%Z ((Z.to_nat i) - 1). +Require Import micromega.Lia. + Lemma rcon_correct : forall (i : Z), (1 <= i < 10)%Z -> ⊢ ⦃ fun _ => True ⦄ Jrcon i ⇓ [('int ; rcon i)] ⦃ fun _ => True ⦄. @@ -1068,7 +1070,7 @@ Proof. | |- _ => eapply r_put_lhs with (pre := fun _ => True); ssprove_contract_put_get_lhs; eapply r_put_lhs; rewrite ?coerce_to_choice_type_K; eapply r_ret; easy | |- _ => simpl; ssprove_contract_put_get_lhs; rewrite !coerce_to_choice_type_K end. - micromega.Lia.lia. + lia. Qed. From mathcomp.word Require Import word. @@ -1160,6 +1162,134 @@ Lemma subword_xor {n} i ws (a b : n.-word) : Proof. Admitted. +Local Open Scope Z_scope. + +Lemma wrepr_lsr (ws : wsize.wsize) a i : + (0 <= a < modulus ws)%Z -> + lsr (wrepr ws a) i = wrepr ws (Z.shiftr a (Z.of_nat i)). +Proof. + intros H. + unfold lsr. + rewrite mkwordK. + unfold wrepr. + apply val_inj. + simpl. + rewrite [a mod _]Z.mod_small. + reflexivity. + assumption. +Qed. + +Lemma modulus_gt0' n : (0 < modulus n)%Z. +Proof. + apply Z.ltb_lt. + apply modulus_gt0. +Qed. + +Lemma wcat_r_bound n (l : seq n.-word) : + (0 <= wcat_r l < modulus (size l * n))%Z. +Proof. + induction l. + - simpl. + split. + + reflexivity. + + apply Z.ltb_lt. + apply modulus_gt0. + - simpl. + (* IHl implies that the wcat shifted is less than the modulus and then the lor is less than that *) + Admitted. + +(* following two lemmas are from fiat crypto, consider importing *) + Lemma mod_pow_same_base_larger a b n m : + 0 <= n < m -> 0 < b -> + (a mod (b^n)) mod (b^m) = a mod b^n. + Proof. + intros. + pose proof Z.mod_pos_bound a (b^n) ltac:(auto with zarith). + assert (b^n <= b^m). + eapply Z.pow_le_mono_r; lia. + apply Z.mod_small. auto with zarith. + Qed. + + Lemma mod_pow_same_base_smaller a b n m : + 0 <= m <= n -> 0 < b -> + (a mod (b^n)) mod (b^m) = a mod b^m. + Proof. + intros. replace n with (m+(n-m)) by lia. + rewrite -> Z.pow_add_r, Z.rem_mul_r by auto with zarith. + rewrite <- Zplus_mod_idemp_r. + rewrite <- Zmult_mod_idemp_l. + rewrite Z.mod_same. + rewrite Z.mul_0_l. + rewrite Z.mod_0_l. + rewrite Z.add_0_r. + rewrite Z.mod_mod. + reflexivity. + all: eapply Z.pow_nonzero; lia. + Qed. + +Lemma nat_of_wsize_m ws : (wsize_size_minus_1 ws).+1 = nat_of_wsize ws. +Proof. destruct ws; reflexivity. Qed. + +Lemma subword_make_vec i (ws1 ws2 : wsize.wsize) l : + (size l * ws1 <= ws2)%nat -> + subword (i * ws1) ws1 (@make_vec ws1 ws2 l) = nth word0 l i. +Proof. + intros H. + simpl. + unfold subword. + simpl. + rewrite urepr_word. + apply val_inj. + rewrite -> nat_of_wsize_m at 2. + simpl. + (* rewrite [wcat_r _ mod _]Z.mod_small. *) + (* unfold subword. *) + (* unfold make_vec. *) + (* rewrite wrepr_lsr. *) + revert i. + induction l; intros i. + - rewrite Z.shiftr_0_l. + rewrite Z.mod_0_l. + rewrite nth_nil. + reflexivity. + pose proof modulus_gt0' ws2. + lia. + - + cbn [wcat_r]. + + (* the inner mod can be removed since we taking mod ws1 at the end anyway, but proving this is a bit tricky. *) + (* we need some commutativity between shiftr and mod a power of 2 *) + + (* replace *) + + (* simpl. *) + (* simpl. *) + (* cbn -[Z.shiftl]. *) + (* rewrite Z.shiftr_lor. *) + (* rewrite Z.shiftr_shiftl_r. *) + + (* unfold modulus. *) + (* rewrite !two_power_nat_equiv. *) + (* rewrite mod_pow_same_base_smaller. *) + (* From mathcomp Require Import zify. *) + (* all: try (zify; nia). *) + + (* destruct i. *) + (* + *) + (* simpl. *) + (* rewrite Z.shiftr_0_r. *) + (* (* this goal is true, but annoying, need lemma about lor and mod a power of 2 *) *) + (* admit. *) + (* + *) + (* replace (Z.of_nat (i.+1 * ws1)%Nrec - Pos.of_succ_nat (wsize_size_minus_1 ws1)) with *) + (* (Z.of_nat (i * ws1)%nat). *) + (* 2: { zify; simpl; nia. } *) + (* cbn -[Z.of_nat muln_rec]. *) + (* (* this goal is true, but annoying, need lemma about lor and mod a power of 2 *) *) + (* admit. *) + (* zify; simpl in *; nia. *) +Admitted. + Lemma key_expand_correct rcon rkey temp2 rcon_ : toword rcon_ = rcon -> ⊢ ⦃ fun _ => True ⦄ @@ -1197,25 +1327,27 @@ Proof. f_equal. apply W4u32_eq. - intros [[ | [ | [ | i]]] j]; simpl. - unfold tnth. - simpl. + intros [[ | [ | [ | i]]] j]; simpl; unfold tnth; simpl. rewrite mul0n. - unfold word.wxor. - rewrite !subword_xor. + unfold word.wxor. rewrite !subword_xor. + - simpl. - rewrite tnth_ord_tuple. - destruct i as []. + + Check lift2_vec. + Check wshufps_128. simpl. - pose proof (@wcat_subwordK 32 4). - change (32 * 4)%nat with 128%nat in H1. + (* rewrite tnth_ord_tuple. *) + (* destruct i as []. *) + + (* simpl. *) + (* pose proof (@wcat_subwordK 32 4). *) + (* change (32 * 4)%nat with 128%nat in H1. *) - rewrite <- H1. + (* rewrite <- H1. *) - wpack - lift2_vec - eapply val_inj. + (* wpack *) + (* lift2_vec *) + (* eapply val_inj. *) Admitted. From ba974f12644f3103d8d4bc820b65656b8894c366 Mon Sep 17 00:00:00 2001 From: bshvass Date: Thu, 27 Oct 2022 16:53:43 +0200 Subject: [PATCH 283/383] word lemmas, reached a point where I need to define AES ops properly --- theories/Jasmin/examples/aes/aes.v | 187 ++++++++++++++++++++++++++--- 1 file changed, 173 insertions(+), 14 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes.v b/theories/Jasmin/examples/aes/aes.v index 8b50652e..997f81f8 100644 --- a/theories/Jasmin/examples/aes/aes.v +++ b/theories/Jasmin/examples/aes/aes.v @@ -1227,9 +1227,54 @@ Proof. all: eapply Z.pow_nonzero; lia. Qed. + Lemma nat_of_wsize_m ws : (wsize_size_minus_1 ws).+1 = nat_of_wsize ws. Proof. destruct ws; reflexivity. Qed. +(* this should be proven, since it does a lot of heavy lifting in the following proofs *) +(* it should also be true, though there may be an off by one error somewhere (see e.g. the minus 1) *) +Lemma subword_make_vec1 {ws1} i ws2 ws3 (l : seq (word.word ws1)) : + (* i + ws2 does 'reach across' a single word in the list *) + ((i + ws2 - 1) / ws1)%nat = (i / ws1)%nat -> + subword i ws2 (make_vec ws3 l) = subword (i mod ws1) ws2 (nth word0 l (i / ws1)%nat). +Proof. + intros. +Admitted. + +Lemma subword_0_128 (l : seq u128) : + subword 0 0 (make_vec U128 l) = subword 0 0 (nth word0 l 0). +Proof. + by rewrite subword_make_vec1. +Qed. + +Lemma subword_0_32_128 (l : seq u128) : + subword 0 U32 (make_vec U128 l) = subword 0 U32 (nth word0 l 0). +Proof. + by rewrite subword_make_vec1. +Qed. + +Lemma subword_1_32_128 (l : seq u128) : + subword 1 U32 (make_vec U128 l) = subword 1 U32 (nth word0 l 0). +Proof. + by rewrite subword_make_vec1. +Qed. + +Lemma subword_2_32_128 (l : seq u128) : + subword 2 U32 (make_vec U128 l) = subword 2 U32 (nth word0 l 0). +Proof. + by rewrite subword_make_vec1. +Qed. + +Lemma subword_3_32_128 (l : seq u128) : + subword 3 U32 (make_vec U128 l) = subword 3 U32 (nth word0 l 0). +Proof. + by rewrite subword_make_vec1. +Qed. + +(* use zify to use lia in a goal with ssr integers/naturals *) +(* install via opam: coq-mathcomp-zify *) +From mathcomp Require Import zify. + Lemma subword_make_vec i (ws1 ws2 : wsize.wsize) l : (size l * ws1 <= ws2)%nat -> subword (i * ws1) ws1 (@make_vec ws1 ws2 l) = nth word0 l i. @@ -1290,6 +1335,110 @@ Proof. (* zify; simpl in *; nia. *) Admitted. + + (* Lemma subword_make_vec_32_128 : *) + (* subword (i * ws1) ws1 (@make_vec ws1 ws2 l) = nth word0 l i *) + +(* +nth_map +forall [T1 : Type] (x1 : T1) [T2 : Type] (x2 : T2) (f : T1 -> T2) [n : nat] [s : seq T1], (n < size s)%N -> nth x2 [seq f i | i <- s] n = f (nth x1 s n) *) + +Lemma subword_u {ws} (w : word.word ws) : subword 0 ws w = w. +Proof. by rewrite subword0 zero_extend_u. Qed. + +Lemma nth_map2 {A B C} (a : A) (b : B) (c : C) la lb f n : + (n < Nat.min (size la) (size lb))%nat -> nth c (map2 f la lb) n = f (nth a la n) (nth b lb n). +Proof. + revert la lb. + induction n; intros. + - destruct la. + + simpl in H; zify; lia. + + destruct lb. + * simpl in H; zify; lia. + * reflexivity. + - destruct la. + + simpl in H; zify; lia. + + destruct lb. + * simpl in H; zify; lia. + * simpl. + eapply IHn. + simpl in H. + zify; lia. +Qed. + +Lemma subword_make_vec_32_0_32_128 (l : seq u32) : subword 0 U32 (make_vec U128 l) = nth word0 l 0. +Proof. + rewrite subword_make_vec1. + rewrite subword_u. + all: auto. +Qed. + +Lemma subword_make_vec_32_1_32_128 (l : seq u32) : subword U32 U32 (make_vec U128 l) = nth word0 l 1. +Proof. + rewrite subword_make_vec1. + rewrite subword_u. + all: auto. +Qed. + +Lemma subword_make_vec_32_2_32_128 (l : seq u32) : subword (2 * U32) U32 (make_vec U128 l) = nth word0 l 2. +Proof. + rewrite subword_make_vec1. + rewrite subword_u. + all: auto. +Qed. + +Lemma subword_make_vec_32_3_32_128 (l : seq u32) : subword (3 * U32) U32 (make_vec U128 l) = nth word0 l 3. +Proof. + rewrite subword_make_vec1. + rewrite subword_u. + all: auto. +Qed. + +(* Lemma subword_wshufps_0_32_128 o s1 s2 : subword 0 U32 (wshufps_128 o s1 s2) = wpshufd1 s1 o 0. *) +(* Proof. *) +(* unfold wshufps_128. *) +(* rewrite subword_make_vec1. *) +(* rewrite subword_u. *) +(* reflexivity. *) +(* reflexivity. *) +(* Qed. *) + +(* Lemma subword_wshufps_128 o s1 s2 : subword 0 U32 (wshufps_128 o s1 s2) = *) +(* wpshufd1 s1 o 0. *) +(* Proof. *) +(* unfold wshufps_128. *) +(* rewrite subword_make_vec1. *) +(* rewrite subword_u. *) +(* reflexivity. *) +(* reflexivity. *) +(* Qed. *) + + +Arguments nat_of_wsize : simpl never. +Arguments wsize_size_minus_1 : simpl never. + +(* Lemma wpshufd1 : *) + +Lemma make_vec_single {ws1} ws2 (a : word.word ws1) : + make_vec ws2 [:: a] = zero_extend ws2 a. +Proof. + unfold make_vec. cbn -[Z.of_nat]. + by rewrite Z.shiftl_0_l Z.lor_0_r. +Qed. + +Lemma wshr_word0 {ws} i : @wshr ws 0 i = word0. +Proof. + unfold wshr. + by rewrite lsr_word0. +Qed. + +Lemma wxor_0_r {n} (a : n.-word) : wxor a word0 = a. +Proof. + unfold wxor. + apply val_inj. simpl. + by rewrite Z.lxor_0_r. +Qed. + Lemma key_expand_correct rcon rkey temp2 rcon_ : toword rcon_ = rcon -> ⊢ ⦃ fun _ => True ⦄ @@ -1328,26 +1477,36 @@ Proof. apply W4u32_eq. intros [[ | [ | [ | i]]] j]; simpl; unfold tnth; simpl. - rewrite mul0n. unfold word.wxor. rewrite !subword_xor. + rewrite mul0n. + unfold lift2_vec. + rewrite !subword_0_32_128. + erewrite !nth_map2. + simpl. + rewrite mul0n. + rewrite !subword_u. + rewrite !subword_make_vec_32_0_32_128. + simpl. + unfold wpack. + simpl. + unfold wpshufd1. + simpl. + rewrite make_vec_single. - Check lift2_vec. - Check wshufps_128. + rewrite zero_extend_u. + rewrite wrepr0. + rewrite !wshr0. + rewrite !subword_make_vec_32_0_32_128. simpl. - (* rewrite tnth_ord_tuple. *) - (* destruct i as []. *) - - (* simpl. *) - (* pose proof (@wcat_subwordK 32 4). *) - (* change (32 * 4)%nat with 128%nat in H1. *) - - (* rewrite <- H1. *) + rewrite wshr_word0. + rewrite subword_word0. + rewrite wxor_0_r. + (* this goal is probably false (e.g. the two sides depends on different variables) + i don't know where this went wrong, but possibly in AESKEYGENASSIST, though it looks like it does not affect the first 32 bits + *) - (* wpack *) - (* lift2_vec *) - (* eapply val_inj. *) Admitted. From 88b1ae15af8832d5d3669949f26d052f6000f625 Mon Sep 17 00:00:00 2001 From: Benjamin Salling Hvass Date: Fri, 28 Oct 2022 10:49:34 +0200 Subject: [PATCH 284/383] updated dependencies --- README.md | 5 +++-- ssprove.opam | 1 + 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index 1499849e..baf8b246 100644 --- a/README.md +++ b/README.md @@ -32,12 +32,13 @@ A documentation is available in [DOC.md]. #### Prerequisites - OCaml `>=4.05.0 & <4.13.0` -- Coq `8.14.0` -- Equations `1.3+8.14` +- Coq `8.15.2 +- Equations `1.3+8.15 - Mathcomp `1.13.0` - Mathcomp analysis `0.3.13` - Coq Extructures `0.3.1` - Coq Deriving `0.1` +- mczify 1.2.0+1.12+8.13 You can get them all from the `opam` package manager for OCaml: ```sh diff --git a/ssprove.opam b/ssprove.opam index 71b11cd6..85a3812b 100644 --- a/ssprove.opam +++ b/ssprove.opam @@ -14,6 +14,7 @@ depends: [ "coq-mathcomp-analysis" {= "0.3.13"} "coq-extructures" {(>= "0.3.1" & < "dev")} "coq-deriving" {(>= "0.1" & < "dev")} + "coq-mathcomp-zify" {>= "1.2"} ] build: [ [make "-j%{jobs}%"] From c6260e8c951af07aecec73b13ddbc759aee13b81 Mon Sep 17 00:00:00 2001 From: bshvass Date: Mon, 31 Oct 2022 17:24:48 +0100 Subject: [PATCH 285/383] progress (one 'subword' case done in 'key_expand' lemma) --- theories/Jasmin/examples/aes/aes.v | 222 +++++++++++++++++++++++------ 1 file changed, 177 insertions(+), 45 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes.v b/theories/Jasmin/examples/aes/aes.v index 997f81f8..eedaa858 100644 --- a/theories/Jasmin/examples/aes/aes.v +++ b/theories/Jasmin/examples/aes/aes.v @@ -1082,15 +1082,16 @@ Locate ".-tuple". Definition W4u8 : 4.-tuple u8 -> u32 := wcat. Definition W4u32 : 4.-tuple u32 -> u128 := wcat. -Definition key_expand (wn1 : u128) (rcon : u8) : 'word U128 := - let rcon := W4u8 (* U32 4 *) [tuple rcon ; 0%R; 0%R; 0%R] (* [toword rcon; 0%Z; 0%Z; 0%Z] *) in - let w0 := subword 0 32 wn1 in - let w1 := subword 1 32 wn1 in - let w2 := subword 2 32 wn1 in - let w3 := subword 3 32 wn1 in +(* Definition subword {s} (n : nat) (l : nat) (x : word s) : word l := subword n l x. *) +Definition key_expand (wn1 : u128) (rcon : u8) : 'word U128 := + let rcon := zero_extend U32 rcon (* W4u8 *) (* U32 4 *) (* [tuple rcon ; 0%R; 0%R; 0%R] *) (* [toword rcon; 0%Z; 0%Z; 0%Z] *) in + let w0 := subword 0 U32 wn1 in + let w1 := subword 1 U32 wn1 in + let w2 := subword 2 U32 wn1 in + let w3 := subword 3 U32 wn1 in let tmp := w3 in - let tmp := (rotr tmp 1) ^ rcon in + let tmp := substitute (wror tmp 1) ^ rcon in let w4 := w0 ^ tmp in let w5 := w1 ^ w4 in let w6 := w2 ^ w5 in @@ -1198,9 +1199,14 @@ Proof. (* IHl implies that the wcat shifted is less than the modulus and then the lor is less than that *) Admitted. + +(* use zify to use lia in a goal with ssr integers/naturals *) +(* install via opam: coq-mathcomp-zify *) +From mathcomp Require Import zify. + (* following two lemmas are from fiat crypto, consider importing *) Lemma mod_pow_same_base_larger a b n m : - 0 <= n < m -> 0 < b -> + 0 <= n <= m -> 0 < b -> (a mod (b^n)) mod (b^m) = a mod b^n. Proof. intros. @@ -1227,6 +1233,25 @@ Proof. all: eapply Z.pow_nonzero; lia. Qed. + Lemma larger_modulus a n m : + (n <= m)%nat -> + (a mod modulus n) mod modulus m = a mod modulus n. + Proof. + intros H. + rewrite !modulusZE. + apply mod_pow_same_base_larger. + zify. simpl. lia. lia. + Qed. + + Lemma smaller_modulus a n m : + (m <= n)%nat -> + (a mod modulus n) mod modulus m = a mod modulus m. + Proof. + intros H. + rewrite !modulusZE. + apply mod_pow_same_base_smaller. + zify. simpl. lia. lia. + Qed. Lemma nat_of_wsize_m ws : (wsize_size_minus_1 ws).+1 = nat_of_wsize ws. Proof. destruct ws; reflexivity. Qed. @@ -1271,10 +1296,6 @@ Proof. by rewrite subword_make_vec1. Qed. -(* use zify to use lia in a goal with ssr integers/naturals *) -(* install via opam: coq-mathcomp-zify *) -From mathcomp Require Import zify. - Lemma subword_make_vec i (ws1 ws2 : wsize.wsize) l : (size l * ws1 <= ws2)%nat -> subword (i * ws1) ws1 (@make_vec ws1 ws2 l) = nth word0 l i. @@ -1439,6 +1460,91 @@ Proof. by rewrite Z.lxor_0_r. Qed. +Lemma wxor_0_l {n} (a : n.-word) : wxor word0 a = a. +Proof. + apply val_inj. + reflexivity. +Qed. + +(* Lemma lsr_add_r {n} (w : n.-word) i j : lsr (lsr w i) j = lsr w (i + j). *) +(* Proof. *) +(* unfold lsr. *) +(* rewrite urepr_word; simpl. *) +(* apply val_inj. *) +(* simpl. *) + +(* from fiat crypto, but proof is more involved *) +Lemma mod_pull_div a b c + : 0 <= c -> (a / b) mod c = a mod (c * b) / b. +Admitted. + +Lemma shiftr_shiftr_mod w ws1 ws2 i j : + (ws2 + j <= ws1)%nat -> + Z.shiftr (Z.shiftr w (Z.of_nat i) mod modulus ws1) (Z.of_nat j) mod modulus ws2 = + Z.shiftr w (Z.of_nat (i + j)) mod modulus ws2. +Proof. + intros H. + rewrite modulusZE. + simpl. + rewrite !modulusZE. + rewrite !Z.shiftr_div_pow2. + rewrite !mod_pull_div. + simpl. + rewrite -!Z.pow_add_r. + rewrite mod_pow_same_base_smaller. + rewrite Z.div_div. + rewrite -Z.pow_add_r. + rewrite Nat2Z.inj_add. + f_equal. f_equal. f_equal. + all: try lia. +Qed. + +Lemma subword_wshr {ws1} i j ws2 (w : ws1.-word) : + (ws2 + i <= ws1)%nat -> + subword i ws2 (lsr w j) = subword (j + i) ws2 w. +Proof. + intros H. + unfold subword; simpl. + apply val_inj; simpl. + rewrite urepr_word. + unfold lsr. + simpl. + rewrite urepr_word. + rewrite !smaller_modulus. + rewrite shiftr_shiftr_mod. + reflexivity. + all: lia. +Qed. + + Lemma wxor_involutive {n} : forall k : word n, k ⊕ k = word0. + Proof. + intros k. + apply/eqP/eq_from_wbit=> i. + rewrite !wxorE addbb. + unfold wbit. + rewrite Z.testbit_0_l. + reflexivity. + Qed. + + (* Lemma wxorC : ∀ m k : word, (m ⊕ k) = (k ⊕ m). *) + (* Proof. *) + (* intros m k. *) + (* apply/eqP/eq_from_wbit=> i. *) + (* by rewrite !wxorE addbC. *) + (* Qed. *) + + Lemma wxorA {n} : forall m k l : word n, ((m ⊕ k) ⊕ l) = (m ⊕ (k ⊕ l)). + Proof. + intros m k l. + apply/eqP/eq_from_wbit=> i. + by rewrite !wxorE addbA. + Qed. + + Lemma wror_substitute {n} (w : word.word n) k : wror (substitute w) k = substitute (wror w k). + Proof. + (* I would like to case on w, but not sure how to do this most efficiently? *) + Admitted. + Lemma key_expand_correct rcon rkey temp2 rcon_ : toword rcon_ = rcon -> ⊢ ⦃ fun _ => True ⦄ @@ -1471,42 +1577,68 @@ Proof. split. easy. - unfold totce. f_equal. - apply W4u32_eq. intros [[ | [ | [ | i]]] j]; simpl; unfold tnth; simpl. - unfold word.wxor. rewrite !subword_xor. - rewrite mul0n. - unfold lift2_vec. - rewrite !subword_0_32_128. - erewrite !nth_map2. - simpl. - rewrite mul0n. - rewrite !subword_u. - - rewrite !subword_make_vec_32_0_32_128. - simpl. - unfold wpack. - simpl. - unfold wpshufd1. - simpl. - - rewrite make_vec_single. - - rewrite zero_extend_u. - - rewrite wrepr0. - rewrite !wshr0. - rewrite !subword_make_vec_32_0_32_128. - simpl. - rewrite wshr_word0. - rewrite subword_word0. - rewrite wxor_0_r. - - (* this goal is probably false (e.g. the two sides depends on different variables) - i don't know where this went wrong, but possibly in AESKEYGENASSIST, though it looks like it does not affect the first 32 bits - *) + - + unfold word.wxor. rewrite !subword_xor. + rewrite mul0n. + unfold lift2_vec. + rewrite !subword_0_32_128. + erewrite !nth_map2. + simpl. + rewrite mul0n. + rewrite !subword_u. + + rewrite !subword_make_vec_32_0_32_128. + simpl. + unfold wpack. + simpl. + unfold wpshufd1. + simpl. + + rewrite make_vec_single. + + rewrite zero_extend_u. + + (* rewrite wrepr0. *) + rewrite !wshr0. + rewrite !subword_make_vec_32_0_32_128. + simpl. + + unfold wAESKEYGENASSIST. + simpl. + + rewrite subword_wshr. + rewrite subword_make_vec_32_3_32_128. + simpl. + + rewrite !wxorA. + f_equal. + + unfold wpshufd1. + simpl. + rewrite wshr0. + rewrite -wxorA. + rewrite wxor_involutive. + + rewrite wxor_0_l. + rewrite wror_substitute. + unfold word.wxor. + f_equal. + f_equal. + simpl. + rewrite -H. + pose proof isword_word (rcon_). + apply val_inj. + simpl. + rewrite Z.mod_small. + reflexivity. + zify. lia. + zify. unfold wsize_size_minus_1. simpl. lia. + simpl. lia. + simpl. lia. + - Admitted. From 3fba84bc293b6e14d84aa564375f6aa13e295ff7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Thu, 3 Nov 2022 16:36:33 +0100 Subject: [PATCH 286/383] Provide semantics for deterministic programs --- theories/Crypt/package/pkg_rhl.v | 103 ++++++++++++++++++++++++++++++- 1 file changed, 102 insertions(+), 1 deletion(-) diff --git a/theories/Crypt/package/pkg_rhl.v b/theories/Crypt/package/pkg_rhl.v index 38dc5949..dfa17c2f 100644 --- a/theories/Crypt/package/pkg_rhl.v +++ b/theories/Crypt/package/pkg_rhl.v @@ -4,7 +4,6 @@ basic crypto-style reasoning notions. *) - From Coq Require Import Utf8. From Relational Require Import OrderEnrichedCategory OrderEnrichedRelativeMonadExamples. @@ -1056,6 +1055,108 @@ Proof. cbn. reflexivity. Qed. +(* Simpler semantics for deterministic programs *) + +Inductive deterministic {A : choiceType} : raw_code A → Type := +| deterministic_ret : + ∀ x, deterministic (ret x) +| deterministic_get : + ∀ ℓ k, (∀ x, deterministic (k x)) → deterministic (getr ℓ k) +| deterministic_put : + ∀ ℓ v k, deterministic k → deterministic (putr ℓ v k). + +Fixpoint det_run {A : choiceType} c [h : @deterministic A c] s : A * heap := + match h with + | deterministic_ret x => (x, s) + | deterministic_get ℓ k hk => det_run (k (get_heap s ℓ)) (h := hk _) s + | deterministic_put ℓ v k hk => det_run k (h := hk) (set_heap s ℓ v) + end. + +Lemma det_run_sem : + ∀ {A : choiceType} (c : raw_code A) (hd : deterministic c) s, + θ_dens (θ0 (repr c) s) = dunit (det_run c (h := hd) s). +Proof. + intros A c hd s. + induction hd as [x | ℓ k hk ihk | ℓ v k hk ihk] in s |- *. + - reflexivity. + - simpl. rewrite <- ihk. reflexivity. + - simpl. rewrite <- ihk. reflexivity. +Qed. + +Definition det_jdg {A B : choiceType} (pre : precond) (post : postcond A B) + (p : raw_code A) (q : raw_code B) hp hq := + ∀ (s₀ s₁ : heap), + pre (s₀, s₁) → + post (det_run p (h := hp) s₀) (det_run q (h := hq) s₁). + +Lemma det_to_sem : + ∀ {A₀ A₁ : ord_choiceType} pre post (c₀ : raw_code A₀) (c₁ : raw_code A₁) + (hd₀ : deterministic c₀) + (hd₁ : deterministic c₁), + det_jdg pre post c₀ c₁ hd₀ hd₁ → + ⊢ ⦃ pre ⦄ c₀ ≈ c₁ ⦃ post ⦄. +Proof. + intros A₀ A₁ pre post c₀ c₁ dc₀ dc₁ h. + eapply from_sem_jdg. intros [s₀ s₁]. hnf. intro P. hnf. + intros [hpre hpost]. simpl. + unfold SDistr_carrier. unfold F_choice_prod_obj. simpl. + + unfold det_jdg in h. specialize (h s₀ s₁ hpre). + set (u := det_run c₀ _) in *. + set (v := det_run c₁ _) in *. + + eexists (dunit (u, v)). + split. + - unfold coupling. split. + + unfold lmg. unfold dfst. + apply distr_ext. intro. + rewrite dlet_unit. simpl. + rewrite - det_run_sem. reflexivity. + + unfold rmg. unfold dsnd. + apply distr_ext. intro. + rewrite dlet_unit. simpl. + rewrite - det_run_sem. reflexivity. + - intros [] [] hh. + eapply hpost. + rewrite dunit1E in hh. + lazymatch type of hh with + | context [ ?x == ?y ] => + destruct (x == y) eqn:e + end. + 2:{ + rewrite e in hh. simpl in hh. + rewrite order.Order.POrderTheory.ltxx in hh. discriminate. + } + move: e => /eqP e. inversion e. + subst. assumption. +Qed. + +Lemma sem_to_dem : + ∀ {A₀ A₁ : ord_choiceType} pre post (c₀ : raw_code A₀) (c₁ : raw_code A₁) + (hd₀ : deterministic c₀) + (hd₁ : deterministic c₁), + ⊢ ⦃ pre ⦄ c₀ ≈ c₁ ⦃ post ⦄ → + det_jdg pre post c₀ c₁ hd₀ hd₁. +Proof. + intros A₀ A₁ pre post c₀ c₁ hd₀ hd₁ h. + intros s₀ s₁ hpre. + eapply to_sem_jdg in h. specialize (h (s₀, s₁)). hnf in h. simpl in h. + specialize (h (λ '(v₀, s₀', (v₁, s₁')), post (v₀, s₀') (v₁, s₁'))). + destruct h as [c [hc h]]. + - split. 1: assumption. + intros [] []. tauto. + - set (u := det_run c₀ _) in *. + set (v := det_run c₁ _) in *. + specialize (h u v). + assert (hc' : coupling c (dunit u) (dunit v)). + { rewrite - !det_run_sem. exact hc. } + destruct u, v. + apply h. + apply coupling_SDistr_unit_F_choice_prod in hc'. subst. + unfold SDistr_unit. rewrite dunit1E. rewrite eq_refl. simpl. + apply ltr0n. +Qed. + (* Rules using commands instead of bind *) Theorem rsame_head_cmd : From 5257fc612b78d92980650545bf02d081ea100f98 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Fri, 4 Nov 2022 09:54:31 +0100 Subject: [PATCH 287/383] Prove r_transL_val --- theories/Crypt/package/pkg_rhl.v | 28 +++++++++++++++++++++++++++- 1 file changed, 27 insertions(+), 1 deletion(-) diff --git a/theories/Crypt/package/pkg_rhl.v b/theories/Crypt/package/pkg_rhl.v index dfa17c2f..93db2a19 100644 --- a/theories/Crypt/package/pkg_rhl.v +++ b/theories/Crypt/package/pkg_rhl.v @@ -1131,7 +1131,7 @@ Proof. subst. assumption. Qed. -Lemma sem_to_dem : +Lemma sem_to_det : ∀ {A₀ A₁ : ord_choiceType} pre post (c₀ : raw_code A₀) (c₁ : raw_code A₁) (hd₀ : deterministic c₀) (hd₁ : deterministic c₁), @@ -1157,6 +1157,32 @@ Proof. apply ltr0n. Qed. +(* Similar to r_transL but relaxed for deterministic programs and for + stateless conditions. +*) +Lemma r_transL_val : + ∀ {A₀ A₁ : ord_choiceType} {P Q} + (c₀ c₀' : raw_code A₀) (c₁ : raw_code A₁), + deterministic c₀' → + deterministic c₀ → + deterministic c₁ → + ⊢ ⦃ λ _, P ⦄ c₀ ≈ c₀' ⦃ λ '(v₀, _) '(v₁, _), v₀ = v₁ ⦄ → + ⊢ ⦃ λ _, P ⦄ c₀ ≈ c₁ ⦃ λ '(v₀, _) '(v₁, _), Q v₀ v₁ ⦄ → + ⊢ ⦃ λ _, P ⦄ c₀' ≈ c₁ ⦃ λ '(v₀, _) '(v₁, _), Q v₀ v₁ ⦄. +Proof. + intros A₀ A₁ P Q c₀ c₀' c₁ hd₀' hd₀ hd₁ he h. + unshelve eapply det_to_sem. 1,2: assumption. + unshelve eapply sem_to_det in he. 1,2: assumption. + unshelve eapply sem_to_det in h. 1,2: assumption. + intros s₀ s₁ hP. + specialize (h s₀ s₁ hP). specialize (he s₀ s₀ hP). + destruct (det_run c₀ _). + destruct (det_run c₀' _). + destruct (det_run c₁ _). + subst. + assumption. +Qed. + (* Rules using commands instead of bind *) Theorem rsame_head_cmd : From 56d4a4814073e088eb692948ca7787e52e0cceea Mon Sep 17 00:00:00 2001 From: bshvass Date: Tue, 8 Nov 2022 09:06:45 +0100 Subject: [PATCH 288/383] aes progress --- theories/Jasmin/examples/aes/aes.v | 64 ++++++++++++++++++++++++++++-- 1 file changed, 61 insertions(+), 3 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes.v b/theories/Jasmin/examples/aes/aes.v index eedaa858..dd832436 100644 --- a/theories/Jasmin/examples/aes/aes.v +++ b/theories/Jasmin/examples/aes/aes.v @@ -1077,8 +1077,6 @@ From mathcomp.word Require Import word. Infix "^" := wxor. (* copy of the easycrypt functional definition *) -Locate ".-tuple". - Definition W4u8 : 4.-tuple u8 -> u32 := wcat. Definition W4u32 : 4.-tuple u32 -> u128 := wcat. @@ -1545,7 +1543,7 @@ Qed. (* I would like to case on w, but not sure how to do this most efficiently? *) Admitted. -Lemma key_expand_correct rcon rkey temp2 rcon_ : +Lemma key_expand1_correct rcon rkey temp2 rcon_ : toword rcon_ = rcon -> ⊢ ⦃ fun _ => True ⦄ l ← (Jkey_expand rcon rkey temp2) ;; @@ -1642,3 +1640,63 @@ Proof. - Admitted. + +Lemma key_expand2_correct rcon rkey temp2 : + subword 0 U32 temp2 = word0 -> + ⊢ ⦃ fun _ => True ⦄ + l ← (Jkey_expand rcon rkey temp2) ;; + ret (subword 0 U32 (coerce_to_choice_type ('word U128) (nth ('word U128 ; word0) l 1%nat).π2)) + ⇓ word0 + ⦃ fun _ => True ⦄. +Proof. + (* unfold Jkey_expand, get_tr, get_translated_fun. *) + + intros H. + simpl_fun. repeat setjvars. + (* rewrite !zero_extend_u. *) + (* rewrite !coerce_to_choice_type_K. *) + + unfold eval_jdg. + repeat clear_get. + + unfold sopn_sem. + unfold tr_app_sopn_tuple. + unfold tr_app_sopn_single. + + simpl. + + rewrite !zero_extend_u. + rewrite !coerce_to_choice_type_K. + + repeat eapply u_put. + eapply u_ret. + + split. easy. + + (* Set Printing All. *) + (* unfold lift2_vec. *) + rewrite subword_0_32_128. + simpl. + rewrite subword_make_vec_32_0_32_128. + simpl. + unfold wpshufd1. + simpl. + rewrite subword_wshr. + simpl. + rewrite addn0. + rewrite subword_u. + rewrite subword_0_32_128. + simpl. + rewrite subword_make_vec_32_0_32_128. + simpl. + rewrite subword_u. + unfold wpshufd1. + simpl. + rewrite subword_wshr. + rewrite add0n. + assumption. + unfold wsize_size_minus_1, nat127. + zify. lia. + unfold wsize_size_minus_1, nat127. + zify. lia. +Qed. From dbce2395aefa799081ae428292f8e1208717f2b9 Mon Sep 17 00:00:00 2001 From: bshvass Date: Tue, 8 Nov 2022 09:06:57 +0100 Subject: [PATCH 289/383] usage of new transitivity lemma to xor example --- theories/Crypt/package/pkg_rhl.v | 6 +- theories/Jasmin/examples/xor/xor.v | 191 ++++++++++++++++++++++------- 2 files changed, 148 insertions(+), 49 deletions(-) diff --git a/theories/Crypt/package/pkg_rhl.v b/theories/Crypt/package/pkg_rhl.v index 93db2a19..381931a8 100644 --- a/theories/Crypt/package/pkg_rhl.v +++ b/theories/Crypt/package/pkg_rhl.v @@ -1166,9 +1166,9 @@ Lemma r_transL_val : deterministic c₀' → deterministic c₀ → deterministic c₁ → - ⊢ ⦃ λ _, P ⦄ c₀ ≈ c₀' ⦃ λ '(v₀, _) '(v₁, _), v₀ = v₁ ⦄ → - ⊢ ⦃ λ _, P ⦄ c₀ ≈ c₁ ⦃ λ '(v₀, _) '(v₁, _), Q v₀ v₁ ⦄ → - ⊢ ⦃ λ _, P ⦄ c₀' ≈ c₁ ⦃ λ '(v₀, _) '(v₁, _), Q v₀ v₁ ⦄. + ⊢ ⦃ λ '(_, _), P ⦄ c₀ ≈ c₀' ⦃ λ '(v₀, _) '(v₁, _), v₀ = v₁ ⦄ → + ⊢ ⦃ λ '(_, _), P ⦄ c₀ ≈ c₁ ⦃ λ '(v₀, _) '(v₁, _), Q v₀ v₁ ⦄ → + ⊢ ⦃ λ '(_, _), P ⦄ c₀' ≈ c₁ ⦃ λ '(v₀, _) '(v₁, _), Q v₀ v₁ ⦄. Proof. intros A₀ A₁ P Q c₀ c₀' c₁ hd₀' hd₀ hd₁ he h. unshelve eapply det_to_sem. 1,2: assumption. diff --git a/theories/Jasmin/examples/xor/xor.v b/theories/Jasmin/examples/xor/xor.v index 528885d3..e0f37c8f 100644 --- a/theories/Jasmin/examples/xor/xor.v +++ b/theories/Jasmin/examples/xor/xor.v @@ -88,6 +88,7 @@ Definition default_prog' := (1%positive, fun s_id : p_id => (ret tt)). Definition default_call := (1%positive, fun (s_id : p_id) (x : [choiceType of seq typed_chElement]) => ret x). Definition get_tr sp n := List.nth_default default_call sp n. Definition tr_xor := Eval simpl in (get_tr tr_P.2 0). +Eval simpl in (tr_P.1). Opaque translate_for. @@ -104,19 +105,27 @@ Proof. (* repeat setoid_rewrite (@zero_extend_u U64). *) (* proof *) + unfold eval_jdg. + repeat clear_get. + + ssprove_swap_lhs 1. + ssprove_swap_lhs 0. ssprove_swap_lhs 1. - ssprove_contract_put_get_lhs. - ssprove_swap_seq_lhs [:: 1 ; 0 ; 2 ; 1]. - ssprove_contract_put_get_lhs. - ssprove_swap_seq_lhs [:: 1 ; 0 ; 2 ; 1]. - ssprove_contract_put_get_lhs. - ssprove_swap_seq_lhs [:: 0 ; 2 ; 1 ]. - ssprove_contract_put_lhs. - ssprove_swap_seq_lhs [:: 2 ; 1 ]. - ssprove_contract_put_get_lhs. + rewrite !zero_extend_u. + + (* ssprove_swap_lhs 1. *) + (* ssprove_contract_put_get_lhs. *) + (* ssprove_swap_seq_lhs [:: 1 ; 0 ; 2 ; 1]. *) + (* ssprove_contract_put_get_lhs. *) + (* ssprove_swap_seq_lhs [:: 1 ; 0 ; 2 ; 1]. *) + (* ssprove_contract_put_get_lhs. *) + (* ssprove_swap_seq_lhs [:: 0 ; 2 ; 1 ]. *) + (* ssprove_contract_put_lhs. *) + (* ssprove_swap_seq_lhs [:: 2 ; 1 ]. *) + (* ssprove_contract_put_get_lhs. *) repeat eapply u_put. eapply u_ret. - rewrite !zero_extend_u. + (* rewrite !zero_extend_u. *) easy. Qed. @@ -126,12 +135,6 @@ Qed. From Relational Require Import OrderEnrichedCategory GenericRulesSimple. -Set Warnings "-notation-overridden,-ambiguous-paths,-notation-incompatible-format". -From mathcomp Require Import all_ssreflect all_algebra reals distr - fingroup.fingroup realsum ssrnat ssreflect ssrfun ssrbool ssrnum eqtype choice - seq. -Set Warnings "notation-overridden,ambiguous-paths,notation-incompatible-format". - From Crypt Require Import Axioms ChoiceAsOrd SubDistr Couplings UniformDistrLemmas FreeProbProg Theta_dens RulesStateProb UniformStateProb pkg_composition pkg_rhl Package Prelude. @@ -171,28 +174,19 @@ Section word_fin. by apply/all_filterP/allP=> i; rewrite in_ziota isSome_insub. Qed. + From mathcomp Require Import zify. + Lemma ltzS x y : (x < Z.succ y) = (x <= y). - Proof. - apply/idP. unfold le, lt=>//=. - destruct (Z.leb _ _) eqn:E. - - apply Z.ltb_lt. lia. - - intros contra. - apply Z.ltb_lt in contra. lia. - Qed. + Proof. zify; lia. Qed. Lemma ltSz x y : (Z.succ x <= y) = (x < y). - apply/idP. unfold le, lt=>//=. - destruct (Z.ltb _ _) eqn:E. - - apply Z.leb_le. - lia. - - intros contra. - apply Z.leb_le in contra. lia. - Qed. + Proof. zify; lia. Qed. + Lemma addzS x y : (x + Z.succ y) = Z.succ (x + y). - Proof. by unfold add => //=; rewrite Z.add_succ_r. Qed. + Proof. zify; lia. Qed. Lemma addSz x y : (Z.succ x + y) = Z.succ (x + y). - Proof. by unfold add => //=; rewrite Z.add_succ_l. Qed. + Proof. zify; lia. Qed. Lemma mem_ziota m k i : (i \in ziota m k) = (m <= i < m + k). Proof. @@ -335,7 +329,7 @@ Section OTP_example. ret (m ⊕ k) }. - Notation N := ((2 ^ n).-1.+1). + Notation N := ((expn 2 n).-1.+1). #[export] Instance : Positive N. Proof. red; by rewrite prednK_modulus expn_gt0. Qed. @@ -442,7 +436,7 @@ Section Jasmin_OTP. Notation word := (word n). Notation " 'word " := (chWord n) : package_scope. Notation " 'word " := (chWord n) (in custom pack_type at level 2) : package_scope. - Notation N := ((2 ^ n).-1.+1). + Notation N := ((expn 2 n).-1.+1). Definition id0 : BinNums.positive := 1. @@ -502,6 +496,7 @@ Section Jasmin_OTP. IND_CPA_jasmin_real_game false ≈₀ IND_CPA_jasmin_real_game true. Proof. eapply eq_rel_perf_ind_ignore with (L := xor_locs); [apply fsubsetUr|]. + Opaque n. simplify_eq_rel m. Transparent n. @@ -510,18 +505,7 @@ Section Jasmin_OTP. intros x. (* note that this simpl chokes if called before ssprove_sync_eq *) - simpl. - ssprove_invariant. - ssprove_swap_seq_rhs [::1%nat]. - ssprove_contract_put_get_rhs. - ssprove_swap_seq_rhs [::0%nat ; 3%nat ; 2%nat ; 1%nat ]. - ssprove_contract_put_get_rhs. - ssprove_swap_seq_rhs [::1%nat ; 0%nat ; 2%nat ; 1%nat ]. - ssprove_contract_put_get_rhs. - ssprove_swap_seq_rhs [::2%nat ; 1%nat ]. - ssprove_contract_put_rhs. - ssprove_swap_seq_rhs [::2%nat ; 1%nat ]. - ssprove_contract_put_get_rhs. + apply rsymmetry; repeat clear_get; apply rsymmetry. rewrite !zero_extend_u. (* why is this not inferred? *) @@ -571,3 +555,118 @@ Section Jasmin_OTP. assumption. Qed. End Jasmin_OTP. + +From Hacspec Require Import Xor_Both. +From Hacspec Require Import Hacspec_Lib_Pre. +(* consider exporting this from Hacspec_Lib_Pre? Needed for int64 : Type coercion *) +From Hacspec Require Import ChoiceEquality. + +Section JasminHacspec. + + Definition state_xor (x y : int64) : raw_code int64 := + xor (x, y). + + Definition pure_xor (x y : int64) : raw_code int64 := + lift_to_code (L:=fset0) (I := [interface]) (is_pure (xor (x, y))). + + Definition state_pure_xor x y := code_eq_proof_statement (xor (x, y)). + Notation jazz_xor w1 w2 := ((snd tr_xor) 1%positive [('word U64; w1); ('word U64; w2)]). + Notation hdtc res := (coerce_to_choice_type ('word U64) (hd ('word U64 ; chCanonical _) res).π2). + + Lemma rxor_pure : forall w1 w2, + ⊢ ⦃ true_precond ⦄ + res ← jazz_xor w1 w2 ;; + ret (hdtc res) + ≈ + pure_xor w1 w2 + ⦃ fun '(a, h₀) '(b, h₁) => (a = b) ⦄. + Proof. + intros w1 w2. + simpl_fun. + + repeat setjvars. + + Ltac neq_loc_auto ::= eapply injective_translate_var3; auto. + + repeat clear_get. + + rewrite !zero_extend_u. + eapply r_put_lhs with (pre := fun _ => Logic.True). + repeat eapply r_put_lhs. + eapply r_ret. + + intros ? ? ?. + rewrite coerce_to_choice_type_K. + reflexivity. + Qed. + + Lemma rxor_state : forall w1 w2, + ⊢ ⦃ true_precond ⦄ + res ← ((snd tr_xor) 1%positive [('word U64; w1); ('word U64; w2)]) ;; + ret (coerce_to_choice_type ('word U64) (hd ('word U64 ; chCanonical _) res).π2) + ≈ + state_xor w1 w2 + ⦃ fun '(a, _) '(b, _) => (a = b) ⦄. + Proof. + intros w1 w2. + unfold state_xor. + + simpl_fun. + repeat setjvars. + repeat clear_get. + + rewrite !zero_extend_u. + rewrite coerce_to_choice_type_K. + eapply r_put_vs_put with (pre := fun _ => Logic.True). + repeat eapply r_put_vs_put. + repeat eapply r_put_rhs. + eapply r_ret. + easy. + Qed. + + Lemma val_sym : + ∀ {A : ord_choiceType} {pre : precond} + {c₀ : raw_code A} {c₁ : raw_code A}, + ⊢ ⦃ true_precond ⦄ + c₀ + ≈ + c₁ + ⦃ fun '(a, _) '(b, _) => a = b ⦄ -> + ⊢ ⦃ fun '(h0, h1) => true_precond (h0, h1) ⦄ + c₁ + ≈ + c₀ + ⦃ fun '(a, _) '(b, _) => a = b ⦄. + Proof. + intros. + eapply rsymmetry. + eapply rpost_weaken_rule. + 1: exact H. + intros [] []; auto. + Qed. + + Lemma rxor_pure_via_state : forall w1 w2, + ⊢ ⦃ true_precond ⦄ + res ← ((snd tr_xor) 1%positive [('word U64; w1); ('word U64; w2)]) ;; + ret (coerce_to_choice_type ('word U64) (hd ('word U64 ; chCanonical _) res).π2) + ≈ + pure_xor w1 w2 + ⦃ fun '(a, _) '(b, _) => (a = b) ⦄. + Proof. + intros w1 w2. + eapply @r_transL_val with (c₀ := state_xor w1 w2) (P := Logic.True). + - repeat constructor. + - repeat constructor. + - repeat constructor. + - eapply rsymmetry. + eapply rpost_weaken_rule. + 1: eapply rxor_state. + intros [] []; auto. + - pose proof state_pure_xor. + eapply rpre_weaken_rule. + 1: eapply rpost_weaken_rule. + 1: eapply state_pure_xor. + 2: auto. + intros [] []. unfold pre_to_post_ret; intuition subst. + Qed. +End JasminHacspec. From ce7395d7f6bd7c302da3e7d5b3bea95c8935e0fb Mon Sep 17 00:00:00 2001 From: bshvass Date: Thu, 24 Nov 2022 12:39:06 +0100 Subject: [PATCH 290/383] more aes --- theories/Jasmin/examples/aes/aes.v | 47 ++++++++++++++++++++++++++++-- 1 file changed, 45 insertions(+), 2 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes.v b/theories/Jasmin/examples/aes/aes.v index dd832436..48b690f3 100644 --- a/theories/Jasmin/examples/aes/aes.v +++ b/theories/Jasmin/examples/aes/aes.v @@ -1053,8 +1053,8 @@ Definition get_tr := get_translated_fun ssprove_jasmin_prog. Definition Jrcon (i : Z) := get_tr (xI (xI (xO (xO xH)))) 1%positive [('int ; i)]. Definition Jkey_combine rkey temp1 temp2 := get_tr (xO (xI (xI (xO xH)))) 1%positive [('word U128 ; rkey) ; ('word U128 ; temp1) ; ('word U128 ; temp2)]. Definition Jkey_expand rcon rkey temp2 := get_tr (xO (xI (xO (xO xH)))) 1%positive [ ('int ; rcon) ; ('word U128 ; rkey) ; ('word U128 ; temp2) ]. - -Definition rcon (i : Z) := nth 54%Z [:: 1; 2; 4; 8; 16; 32; 64; 128; 27; 54]%Z ((Z.to_nat i) - 1). +Definition Jkeys_expand rkey := get_tr (xO (xO (xI xH))) 1%positive [('word U128 ; rkey)]. +Definition rcon (i : Z) : Z := nth 54%Z [:: 1; 2; 4; 8; 16; 32; 64; 128; 27; 54]%Z ((Z.to_nat i) - 1). Require Import micromega.Lia. @@ -1700,3 +1700,46 @@ Proof. unfold wsize_size_minus_1, nat127. zify. lia. Qed. + +From extructures Require Import ord fset fmap. + +Definition getmd {T S} m d i := match @getm T S m i with Some a => a | _ => d end. + +Local Open Scope Z_scope. + +Definition rkeys : Location := ( chMap 'nat ('word U128) ; 0%nat ). + +Definition keyExpansion (key : u128) := + #put rkeys := @emptym nat_ordType u128 ;; + rkeys0 ← get rkeys ;; + #put rkeys := setm rkeys0 0%nat word0 ;; + for_loop (fun i => + rkeys0 ← get rkeys ;; + #put rkeys := setm rkeys0 i (key_expand (zero_extend _ (getmd rkeys0 word0 i - 1)) (wrepr U8 (rcon (Z.of_nat i)))) ;; + ret tt) 10 ;; + ret rkeys. + +Opaque translate_for. +Notation hdtc res := (coerce_to_choice_type ('array) (hd ('word U64 ; chCanonical _) res).π2). +Notation call fn := (translate_call _ fn _). + +Lemma keyExpansionE rkey : + ⊢ ⦃ fun '(_, _) => True ⦄ + res ← Jkeys_expand rkey ;; + ret (hdtc res) + ≈ + keyExpansion rkey + ⦃ fun '(_, _) '(_, _) => True ⦄. +Proof. + unfold Jkeys_expand. + unfold get_tr, get_translated_fun, translate_prog', translate_funs. + Opaque translate_call. + simpl. + + simpl_fun. repeat setjvars. + + repeat clear_get. + unfold keyExpansion. + eapply r_put_vs_put with (pre := fun _ => Logic.True). + eapply r_get_vs_get_remember. + From 4f1141cf752ee0dec7f4b2bb407022a8b69fc281 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Fri, 2 Dec 2022 11:13:54 +0100 Subject: [PATCH 291/383] Add missing backticks --- README.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index baf8b246..741a10ef 100644 --- a/README.md +++ b/README.md @@ -32,8 +32,8 @@ A documentation is available in [DOC.md]. #### Prerequisites - OCaml `>=4.05.0 & <4.13.0` -- Coq `8.15.2 -- Equations `1.3+8.15 +- Coq `8.15.2` +- Equations `1.3+8.15` - Mathcomp `1.13.0` - Mathcomp analysis `0.3.13` - Coq Extructures `0.3.1` From 9dd4a278052fa856b1322c7cb4b8ed9d0cf9f023 Mon Sep 17 00:00:00 2001 From: bshvass Date: Thu, 8 Dec 2022 06:13:54 +0100 Subject: [PATCH 292/383] progress on equivalence between `keyExpansion` and `JKEYS_EXPAND` several changes: - new generic for loop over lists, lemma on connection to translated for loop - computing variables of functions; NB: the way it is currently done is not sufficient, since it does not take into account the Locations used by callees - several lemmas on words and arrays - some tactics for discharging goals about Locations and translated variables --- theories/Jasmin/examples/aes/aes.v | 1498 ++++++++++++++++++++++------ theories/Jasmin/jasmin_utils.v | 2 +- 2 files changed, 1171 insertions(+), 329 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes.v b/theories/Jasmin/examples/aes/aes.v index 48b690f3..1c7f473c 100644 --- a/theories/Jasmin/examples/aes/aes.v +++ b/theories/Jasmin/examples/aes/aes.v @@ -1026,6 +1026,53 @@ Proof. p_extra := tt |}. Defined. +(* use zify to use lia in a goal with ssr integers/naturals *) +(* install via opam: coq-mathcomp-zify *) +From mathcomp Require Import zify. + +From Coq Require Import Utf8. +From extructures Require Import ord fset fmap. + +Require Import micromega.Lia. +From mathcomp.word Require Import word. +From mathcomp.word Require Import ssrZ. +From JasminSSProve Require Import jasmin_utils. +Import ListNotations. +Import JasminNotation JasminCodeNotation. +Import PackageNotation. + +Require Import MSetGenTree. + +Notation RCON := (xI (xI (xO (xO xH)))). +Notation KEY_COMBINE := (xO (xI (xI (xO xH)))). +Notation KEY_EXPAND := (xO (xI (xO (xO xH)))). +Notation KEYS_EXPAND := (xO (xO (xI xH))). + +Infix "^" := wxor. + +Definition get_vars_Sv {eft ept} P fname : Sv.t := +match (assoc (@p_funcs _ _ eft ept P) fname) with + | Some f => vars_c (f_body f) + | None => Sv.empty + end. + +Definition fset_of_Sv (fc_id : p_id) (t : Sv.t) : {fset Location} := + Sv.fold (fun e s => translate_var fc_id e |: s) t fset0. + +Definition get_tr := get_translated_fun ssprove_jasmin_prog. +Definition get_vars {eft ept} P fname fc_id := fset_of_Sv fc_id (@get_vars_Sv eft ept P fname). + +Definition pdisj (P : precond) (L : {fset Location}) := + forall h1 h2 l v, l \in L -> ( (P ((set_heap h1 l v), h2)) <-> P (h1, h2)). + +Ltac tvars H := unfold get_vars, get_vars_Sv, fset_of_Sv, Sv.fold in H; simpl in H. + +Ltac solve_in := + repeat match goal with + | |- is_true (?v \in fset1 ?v :|: _) => apply/fsetU1P; left; auto + | |- is_true (_ \in fsetU _ _) => apply/fsetU1P; right + end. + Fixpoint list_to_chtuple (l : list typed_chElement) : lchtuple [seq t.π1 | t <- l] := match l as l0 return lchtuple [seq t.π1 | t <- l0] @@ -1043,58 +1090,85 @@ Fixpoint list_to_chtuple (l : list typed_chElement) : lchtuple [seq t.π1 | t <- end rec end. -From JasminSSProve Require Import jasmin_utils. +Notation trp := (translate_prog' ssprove_jasmin_prog).1. +Notation trc := (fun fn i => translate_call ssprove_jasmin_prog fn trp i). -Import ListNotations. -Import JasminNotation JasminCodeNotation. -Import PackageNotation. +(* I use trc to be able to reuse statements about the function inside other functions where theyll appear as translate_calls (and not get_translated_funs). + Furthermore, I think this is necessary to assure that all calls gets the complete list of translated functions. + Otherwise result might depend on which buffer of translated functions gets passed to the call. + In this construction we always use all of them, opposed to get_translated_fun which just uses the necessary ones (I believe). + *) -Definition get_tr := get_translated_fun ssprove_jasmin_prog. -Definition Jrcon (i : Z) := get_tr (xI (xI (xO (xO xH)))) 1%positive [('int ; i)]. -Definition Jkey_combine rkey temp1 temp2 := get_tr (xO (xI (xI (xO xH)))) 1%positive [('word U128 ; rkey) ; ('word U128 ; temp1) ; ('word U128 ; temp2)]. -Definition Jkey_expand rcon rkey temp2 := get_tr (xO (xI (xO (xO xH)))) 1%positive [ ('int ; rcon) ; ('word U128 ; rkey) ; ('word U128 ; temp2) ]. -Definition Jkeys_expand rkey := get_tr (xO (xO (xI xH))) 1%positive [('word U128 ; rkey)]. -Definition rcon (i : Z) : Z := nth 54%Z [:: 1; 2; 4; 8; 16; 32; 64; 128; 27; 54]%Z ((Z.to_nat i) - 1). +Notation JRCON i j := (trc RCON i [('int ; j)]). +(* Notation JRCON (j : Z) := (get_tr RCON i [('int ; j)]). *) +Notation JRCON_vars i := (get_vars ssprove_jasmin_prog RCON i). -Require Import micromega.Lia. +Notation JKEY_COMBINE i rkey temp1 temp2 := (trc KEY_COMBINE i [('word U128 ; rkey) ; ('word U128 ; temp1) ; ('word U128 ; temp2)]). +(* Notation JKEY_COMBINE rkey temp1 temp2 := (get_tr KEY_COMBINE i [('word U128 ; rkey) ; ('word U128 ; temp1) ; ('word U128 ; temp2)]). *) +Notation JKEY_COMBINE_vars i := (get_vars ssprove_jasmin_prog KEY_COMBINE i). -Lemma rcon_correct : - forall (i : Z), (1 <= i < 10)%Z -> - ⊢ ⦃ fun _ => True ⦄ Jrcon i ⇓ [('int ; rcon i)] ⦃ fun _ => True ⦄. -Proof. - unfold Jrcon, get_tr, get_translated_fun. - intros i H. - simpl_fun. repeat setjvars. - repeat match goal with - | |- context[(?a =? ?b)%Z] => let E := fresh in destruct (a =? b)%Z eqn:E; [rewrite ?Z.eqb_eq in E; subst|] - | |- _ => eapply r_put_lhs with (pre := fun _ => True); ssprove_contract_put_get_lhs; eapply r_put_lhs; rewrite ?coerce_to_choice_type_K; eapply r_ret; easy - | |- _ => simpl; ssprove_contract_put_get_lhs; rewrite !coerce_to_choice_type_K - end. - lia. -Qed. -From mathcomp.word Require Import word. +Notation JKEY_EXPAND i rcon rkey temp2 := (trc KEY_EXPAND i [ ('int ; rcon) ; ('word U128 ; rkey) ; ('word U128 ; temp2) ]). +(* Notation JKEY_EXPAND rcon rkey temp2 := (get_tr KEY_EXPAND i [ ('int ; rcon) ; ('word U128 ; rkey) ; ('word U128 ; temp2) ]). *) +Notation JKEY_EXPAND_vars i := (get_vars ssprove_jasmin_prog KEY_EXPAND i). -Infix "^" := wxor. +Notation JKEYS_EXPAND i rkey := (trc KEYS_EXPAND i [('word U128 ; rkey)]). +(* Notation JKEYS_EXPAND rkey := (get_tr KEYS_EXPAND i [('word U128 ; rkey)]). *) +Notation JKEYS_EXPAND_vars i := (get_vars ssprove_jasmin_prog KEYS_EXPAND i). -(* copy of the easycrypt functional definition *) -Definition W4u8 : 4.-tuple u8 -> u32 := wcat. -Definition W4u32 : 4.-tuple u32 -> u128 := wcat. - -(* Definition subword {s} (n : nat) (l : nat) (x : word s) : word l := subword n l x. *) +Definition rcon (i : Z) : Z := nth 54%Z [:: 1; 2; 4; 8; 16; 32; 64; 128; 27; 54]%Z ((Z.to_nat i) - 1). Definition key_expand (wn1 : u128) (rcon : u8) : 'word U128 := let rcon := zero_extend U32 rcon (* W4u8 *) (* U32 4 *) (* [tuple rcon ; 0%R; 0%R; 0%R] *) (* [toword rcon; 0%Z; 0%Z; 0%Z] *) in let w0 := subword 0 U32 wn1 in - let w1 := subword 1 U32 wn1 in - let w2 := subword 2 U32 wn1 in - let w3 := subword 3 U32 wn1 in + let w1 := subword (1 * U32) U32 wn1 in + let w2 := subword (2 * U32) U32 wn1 in + let w3 := subword (3 * U32) U32 wn1 in let tmp := w3 in let tmp := substitute (wror tmp 1) ^ rcon in let w4 := w0 ^ tmp in let w5 := w1 ^ w4 in let w6 := w2 ^ w5 in let w7 := w3 ^ w6 in - W4u32 [tuple w4; w5; w6; w7]. + wcat [tuple w4; w5; w6; w7]. + +Lemma rcon_correct id0 pre i : + (pdisj pre (JRCON_vars id0)) -> + (1 <= i < 10)%Z -> + ⊢ ⦃ fun '(s0, s1) => pre (s0, s1) ⦄ JRCON id0 i + ≈ ret ([('int ; rcon i)] : tchlist) + ⦃ fun '(v0, s0) '(v1, s1) => pre (s0, s1) /\ v0 = v1 /\ v1 = ([('int ; rcon i)] : tchlist) ⦄. +Proof. + unfold get_tr, get_translated_fun. + intros Hpdisj H. + simpl_fun. + tvars Hpdisj. + repeat setjvars. + repeat match goal with + | |- context[(?a =? ?b)%Z] => let E := fresh in destruct (a =? b)%Z eqn:E; [rewrite ?Z.eqb_eq in E; subst|] + (* | |- _ => eapply r_put_lhs with (pre := fun _ => True); ssprove_contract_put_get_lhs; eapply r_put_lhs; rewrite ?coerce_to_choice_type_K; eapply r_ret; easy *) + | |- _ => simpl; ssprove_contract_put_get_lhs; rewrite !coerce_to_choice_type_K + end. + simpl. eapply r_put_lhs. ssprove_contract_put_get_lhs; eapply r_put_lhs; rewrite ?coerce_to_choice_type_K. + eapply r_restore_lhs. intros. unfold set_lhs in *. + destruct H0 as [s0 []]. + exists (set_heap s0 c 1%Z). subst. split. apply Hpdisj. + solve_in. + assumption. rewrite set_heap_commut. reflexivity. + apply injective_translate_var3. auto. + eapply r_ret. + intros; split. + destruct H0 as [s0 []]. subst. + apply Hpdisj. + solve_in. + assumption. + split; easy. + (* the remaining cases are similar, but should be automated *) +Admitted. +(* Qed. *) + +(* copy of the easycrypt functional definition *) +Definition W4u8 : 4.-tuple u8 -> u32 := wcat. +Definition W4u32 : 4.-tuple u32 -> u128 := wcat. Ltac neq_loc_auto ::= eapply injective_translate_var3; auto. @@ -1125,23 +1199,15 @@ Proof. apply subword0. Qed. -(* Lemma wcat_r_zero_extend : *) -(* wcat_r [seq zero_extend a ] *) - -Lemma wpshufd_1280 : forall a, wpshufd_128 a 0 = a. -Proof. - intros a. - unfold wpshufd_128. - rewrite wrepr0. - unfold iota, map. - rewrite !wpshufd10. -Admitted. -(* wpack *) - -(* Lemma wpack_w2t : *) - (* w2t (wpack ws n l) = *) - (* t2w [tuple ] *) -(* tuple *) +(* Lemma wpshufd_1280 : forall a, wpshufd_128 a 0 = a. *) +(* Proof. *) +(* intros a. *) +(* unfold wpshufd_128. *) +(* rewrite wrepr0. *) +(* unfold iota, map. *) +(* rewrite !wpshufd10. *) +(* simpl. *) +(* Admitted. *) Lemma wcat_eq ws p a t : (forall (i : 'I_p), subword (i * ws) ws a = tnth t i) -> a = wcat t. @@ -1156,10 +1222,39 @@ Qed. Definition W4u32_eq : forall a t, (forall (i : 'I_4), subword (i * U32) U32 a = tnth t i) -> a = W4u32 t := wcat_eq U32 4. +Lemma wbit_subword {ws1} i ws2 (w : word ws1) j : + (ws2 <= ws1)%nat -> + (j < ws2)%nat -> + wbit (subword i ws2 w) j = wbit w (i + j)%nat. +Proof. + intros. + unfold subword. + simpl. + unfold urepr. + simpl. + unfold wbit. + simpl. + unfold modulus. + rewrite !two_power_nat_equiv. + rewrite Z.mod_pow2_bits_low. + rewrite Z.mod_pow2_bits_low. + rewrite Z.shiftr_spec. + f_equal. lia. lia. lia. lia. +Qed. + Lemma subword_xor {n} i ws (a b : n.-word) : + (* I don't know if the assumption is necessary *) + (ws <= n)%nat -> subword i ws (a ⊕ b) = (subword i ws a) ⊕ (subword i ws b). Proof. -Admitted. + intros H. + apply/eqP/eq_from_wbit. + intros. rewrite !wbit_subword. + rewrite !wxorE. + rewrite !wbit_subword. + reflexivity. + all: auto. +Qed. Local Open Scope Z_scope. @@ -1184,183 +1279,259 @@ Proof. apply modulus_gt0. Qed. -Lemma wcat_r_bound n (l : seq n.-word) : - (0 <= wcat_r l < modulus (size l * n))%Z. +(* Lemma wcat_r_bound n (l : seq n.-word) : *) +(* (0 <= wcat_r l < modulus (size l * n))%Z. *) +(* Proof. *) +(* induction l. *) +(* - simpl. *) +(* split. *) +(* + reflexivity. *) +(* + apply Z.ltb_lt. *) +(* apply modulus_gt0. *) +(* - simpl. *) +(* (* IHl implies that the wcat shifted is less than the modulus and then the lor is less than that *) *) +(* Admitted. *) + +(* following two lemmas are from fiat crypto, consider importing *) +Lemma mod_pow_same_base_larger a b n m : + 0 <= n <= m -> 0 < b -> + (a mod (b^n)) mod (b^m) = a mod b^n. Proof. - induction l. - - simpl. - split. - + reflexivity. - + apply Z.ltb_lt. - apply modulus_gt0. - - simpl. - (* IHl implies that the wcat shifted is less than the modulus and then the lor is less than that *) - Admitted. + intros. + pose proof Z.mod_pos_bound a (b^n) ltac:(auto with zarith). + assert (b^n <= b^m). + eapply Z.pow_le_mono_r; lia. + apply Z.mod_small. auto with zarith. +Qed. +Lemma mod_pow_same_base_smaller a b n m : + 0 <= m <= n -> 0 < b -> + (a mod (b^n)) mod (b^m) = a mod b^m. +Proof. + intros. replace n with (m+(n-m)) by lia. + rewrite -> Z.pow_add_r, Z.rem_mul_r by auto with zarith. + rewrite <- Zplus_mod_idemp_r. + rewrite <- Zmult_mod_idemp_l. + rewrite Z.mod_same. + rewrite Z.mul_0_l. + rewrite Z.mod_0_l. + rewrite Z.add_0_r. + rewrite Z.mod_mod. + reflexivity. + all: eapply Z.pow_nonzero; lia. +Qed. -(* use zify to use lia in a goal with ssr integers/naturals *) -(* install via opam: coq-mathcomp-zify *) -From mathcomp Require Import zify. +Lemma larger_modulus a n m : + (n <= m)%nat -> + (a mod modulus n) mod modulus m = a mod modulus n. +Proof. + intros H. + rewrite !modulusZE. + apply mod_pow_same_base_larger. + zify. simpl. lia. lia. +Qed. -(* following two lemmas are from fiat crypto, consider importing *) - Lemma mod_pow_same_base_larger a b n m : - 0 <= n <= m -> 0 < b -> - (a mod (b^n)) mod (b^m) = a mod b^n. - Proof. - intros. - pose proof Z.mod_pos_bound a (b^n) ltac:(auto with zarith). - assert (b^n <= b^m). - eapply Z.pow_le_mono_r; lia. - apply Z.mod_small. auto with zarith. - Qed. - - Lemma mod_pow_same_base_smaller a b n m : - 0 <= m <= n -> 0 < b -> - (a mod (b^n)) mod (b^m) = a mod b^m. - Proof. - intros. replace n with (m+(n-m)) by lia. - rewrite -> Z.pow_add_r, Z.rem_mul_r by auto with zarith. - rewrite <- Zplus_mod_idemp_r. - rewrite <- Zmult_mod_idemp_l. - rewrite Z.mod_same. - rewrite Z.mul_0_l. - rewrite Z.mod_0_l. - rewrite Z.add_0_r. - rewrite Z.mod_mod. - reflexivity. - all: eapply Z.pow_nonzero; lia. - Qed. - - Lemma larger_modulus a n m : - (n <= m)%nat -> - (a mod modulus n) mod modulus m = a mod modulus n. - Proof. - intros H. - rewrite !modulusZE. - apply mod_pow_same_base_larger. - zify. simpl. lia. lia. - Qed. - - Lemma smaller_modulus a n m : - (m <= n)%nat -> - (a mod modulus n) mod modulus m = a mod modulus m. - Proof. - intros H. - rewrite !modulusZE. - apply mod_pow_same_base_smaller. - zify. simpl. lia. lia. - Qed. +Lemma smaller_modulus a n m : + (m <= n)%nat -> + (a mod modulus n) mod modulus m = a mod modulus m. +Proof. + intros H. + rewrite !modulusZE. + apply mod_pow_same_base_smaller. + zify. simpl. lia. lia. +Qed. Lemma nat_of_wsize_m ws : (wsize_size_minus_1 ws).+1 = nat_of_wsize ws. Proof. destruct ws; reflexivity. Qed. +Lemma modulus_ne0 : forall n, modulus n <> 0. +Proof. + intros n. + pose proof modulus_gt0 n. + zify. lia. +Qed. + +Lemma enum0 : + enum ('I_0) = []. +Proof. + assert (size (enum 'I_0) = 0%nat). + { apply size_enum_ord. } + apply size0nil. assumption. +Qed. + +Lemma nth_aux {T} (a : T) l : + [seq nth a l (val i) | i <- enum 'I_(size l)] = l. +Proof. + replace [seq nth a l (val i) | i <- enum 'I_(size l)] with [seq nth a l i | i <- [seq val i | i <- enum 'I_(size l)]]. + 2: { rewrite -map_comp. reflexivity. } + rewrite val_enum_ord. + rewrite map_nth_iota0. + rewrite take_size. reflexivity. + lia. +Qed. + +Lemma make_vec_wcat {ws1} (l : seq (word.word ws1)) : + wcat_r l = wcat [tuple nth word0 l i | i < size l]. +Proof. + unfold wcat. + simpl. + rewrite nth_aux. + reflexivity. +Qed. +Lemma wbit_wrepr (ws : wsize.wsize) a i : + (i < ws)%nat -> + wbit (urepr (wrepr ws a)) i = wbit a i. +Proof. + intros H. + unfold wbit. + unfold wrepr. + unfold urepr. + simpl. unfold modulus. + rewrite two_power_nat_equiv. + rewrite Z.mod_pow2_bits_low. + reflexivity. + unfold nat_of_wsize in *. lia. +Qed. + +Lemma wbit_make_vec {ws1} (ws2 : wsize.wsize) (l : seq (word.word ws1)) i : + (i < ws2)%nat -> + wbit (urepr (make_vec ws2 l)) i = wbit (nth word0 l (i %/ ws1)) (i %% ws1). +Proof. + intros H. + unfold make_vec. + rewrite make_vec_wcat. + rewrite wbit_wrepr. + rewrite wcat_wbitE. + unfold urepr. + simpl. + repeat f_equal. + apply nth_aux. + assumption. +Qed. + +Lemma divn_aux j i n : + (j < n)%nat -> + (n <= j %% n + i %% n)%nat = false -> + (j + i) %/ n = i %/ n. +Proof. + intros H1 H2. + rewrite divnD. + rewrite H2. + rewrite divn_small. + lia. + assumption. + lia. +Qed. -(* this should be proven, since it does a lot of heavy lifting in the following proofs *) -(* it should also be true, though there may be an off by one error somewhere (see e.g. the minus 1) *) -Lemma subword_make_vec1 {ws1} i ws2 ws3 (l : seq (word.word ws1)) : +Lemma modn_aux j i n : + (j < n)%nat -> + (n <= j %% n + i %% n)%nat = false -> + (j + i) %% n = (j + i %% n)%nat. +Proof. + intros H1 H2. + rewrite modnD. + rewrite H2. + rewrite modn_small. + lia. + assumption. + lia. +Qed. + +Lemma subword_make_vec1 {ws1} i ws2 (ws3 : wsize.wsize) (l : seq (word.word ws1)) : (* i + ws2 does 'reach across' a single word in the list *) - ((i + ws2 - 1) / ws1)%nat = (i / ws1)%nat -> - subword i ws2 (make_vec ws3 l) = subword (i mod ws1) ws2 (nth word0 l (i / ws1)%nat). + (ws2 <= ws1)%nat -> + (i + ws2 <= ws3)%nat -> + (ws1 <= (ws2 - 1) %% ws1 + i %% ws1)%nat = false -> + (* i think this condition is equivalent, but the others fit with other lemmas *) + (* ((i + ws2 - 1) / ws1)%nat = (i / ws1)%nat -> *) + subword i ws2 (make_vec ws3 l) = subword (i %% ws1) ws2 (nth word0 l (i %/ ws1)%nat). Proof. - intros. -Admitted. + intros H1 H2 H3. + rewrite !subwordE. + f_equal. + apply eq_mktuple. + intros j. + destruct j. simpl. + rewrite wbit_make_vec. + f_equal. + f_equal. + f_equal. + apply divn_aux. + simpl. lia. + rewrite modn_small in H3. rewrite modn_small. lia. lia. lia. + apply modn_aux. lia. + rewrite modn_small in H3. rewrite modn_small. lia. lia. lia. + simpl. unfold nat_of_wsize in *. lia. +Qed. + +Lemma make_vec_ws ws (l : seq (word.word ws)) : + make_vec ws l = nth word0 l 0. +Proof. + apply/eqP. + apply/eq_from_wbit. + intros [i]. + rewrite wbit_make_vec. + simpl. + rewrite divn_small. + rewrite modn_small. + reflexivity. + unfold nat_of_wsize. lia. + unfold nat_of_wsize. lia. + unfold nat_of_wsize. simpl. lia. +Qed. Lemma subword_0_128 (l : seq u128) : subword 0 0 (make_vec U128 l) = subword 0 0 (nth word0 l 0). Proof. - by rewrite subword_make_vec1. + by rewrite make_vec_ws. Qed. Lemma subword_0_32_128 (l : seq u128) : subword 0 U32 (make_vec U128 l) = subword 0 U32 (nth word0 l 0). Proof. - by rewrite subword_make_vec1. + by rewrite make_vec_ws. Qed. Lemma subword_1_32_128 (l : seq u128) : subword 1 U32 (make_vec U128 l) = subword 1 U32 (nth word0 l 0). Proof. - by rewrite subword_make_vec1. + by rewrite make_vec_ws. Qed. Lemma subword_2_32_128 (l : seq u128) : subword 2 U32 (make_vec U128 l) = subword 2 U32 (nth word0 l 0). Proof. - by rewrite subword_make_vec1. + by rewrite make_vec_ws. Qed. Lemma subword_3_32_128 (l : seq u128) : subword 3 U32 (make_vec U128 l) = subword 3 U32 (nth word0 l 0). Proof. - by rewrite subword_make_vec1. + by rewrite make_vec_ws. Qed. -Lemma subword_make_vec i (ws1 ws2 : wsize.wsize) l : - (size l * ws1 <= ws2)%nat -> - subword (i * ws1) ws1 (@make_vec ws1 ws2 l) = nth word0 l i. -Proof. - intros H. - simpl. - unfold subword. - simpl. - rewrite urepr_word. - apply val_inj. - rewrite -> nat_of_wsize_m at 2. - simpl. - (* rewrite [wcat_r _ mod _]Z.mod_small. *) - (* unfold subword. *) - (* unfold make_vec. *) - (* rewrite wrepr_lsr. *) - revert i. - induction l; intros i. - - rewrite Z.shiftr_0_l. - rewrite Z.mod_0_l. - rewrite nth_nil. - reflexivity. - pose proof modulus_gt0' ws2. - lia. - - - cbn [wcat_r]. - - (* the inner mod can be removed since we taking mod ws1 at the end anyway, but proving this is a bit tricky. *) - (* we need some commutativity between shiftr and mod a power of 2 *) - - (* replace *) - - (* simpl. *) - (* simpl. *) - (* cbn -[Z.shiftl]. *) - (* rewrite Z.shiftr_lor. *) - (* rewrite Z.shiftr_shiftl_r. *) - - (* unfold modulus. *) - (* rewrite !two_power_nat_equiv. *) - (* rewrite mod_pow_same_base_smaller. *) - (* From mathcomp Require Import zify. *) - (* all: try (zify; nia). *) - - (* destruct i. *) - (* + *) - (* simpl. *) - (* rewrite Z.shiftr_0_r. *) - (* (* this goal is true, but annoying, need lemma about lor and mod a power of 2 *) *) - (* admit. *) - (* + *) - (* replace (Z.of_nat (i.+1 * ws1)%Nrec - Pos.of_succ_nat (wsize_size_minus_1 ws1)) with *) - (* (Z.of_nat (i * ws1)%nat). *) - (* 2: { zify; simpl; nia. } *) - (* cbn -[Z.of_nat muln_rec]. *) - (* (* this goal is true, but annoying, need lemma about lor and mod a power of 2 *) *) - (* admit. *) - (* zify; simpl in *; nia. *) -Admitted. - - (* Lemma subword_make_vec_32_128 : *) - (* subword (i * ws1) ws1 (@make_vec ws1 ws2 l) = nth word0 l i *) - -(* -nth_map -forall [T1 : Type] (x1 : T1) [T2 : Type] (x2 : T2) (f : T1 -> T2) [n : nat] [s : seq T1], (n < size s)%N -> nth x2 [seq f i | i <- s] n = f (nth x1 s n) *) +Lemma subword_make_vec {ws1} i (ws2 : wsize.wsize) (l : seq (word.word ws1)) : + (ws1 <= ws2)%nat -> + ((i + 1) * ws1 < ws2)%nat -> + subword (i * ws1) ws1 (make_vec ws2 l) = nth word0 l i. +Proof. + intros H1 H2. + apply/eqP. + apply /eq_from_wbit. + intros [i0]. simpl. + rewrite wbit_subword. + rewrite wbit_make_vec. + rewrite addnC. + rewrite divn_aux. + rewrite mulnK. + rewrite modn_aux. + rewrite modnMl. + rewrite addn0. + reflexivity. all: try lia. + rewrite modnMl. lia. + rewrite modnMl. lia. + unfold nat_of_ord in *. unfold nat_of_wsize in *. lia. +Qed. Lemma subword_u {ws} (w : word.word ws) : subword 0 ws w = w. Proof. by rewrite subword0 zero_extend_u. Qed. @@ -1432,12 +1603,9 @@ Qed. (* reflexivity. *) (* Qed. *) - Arguments nat_of_wsize : simpl never. Arguments wsize_size_minus_1 : simpl never. -(* Lemma wpshufd1 : *) - Lemma make_vec_single {ws1} ws2 (a : word.word ws1) : make_vec ws2 [:: a] = zero_extend ws2 a. Proof. @@ -1514,100 +1682,81 @@ Proof. all: lia. Qed. - Lemma wxor_involutive {n} : forall k : word n, k ⊕ k = word0. - Proof. - intros k. - apply/eqP/eq_from_wbit=> i. - rewrite !wxorE addbb. - unfold wbit. - rewrite Z.testbit_0_l. - reflexivity. - Qed. - - (* Lemma wxorC : ∀ m k : word, (m ⊕ k) = (k ⊕ m). *) - (* Proof. *) - (* intros m k. *) - (* apply/eqP/eq_from_wbit=> i. *) - (* by rewrite !wxorE addbC. *) - (* Qed. *) - - Lemma wxorA {n} : forall m k l : word n, ((m ⊕ k) ⊕ l) = (m ⊕ (k ⊕ l)). - Proof. - intros m k l. - apply/eqP/eq_from_wbit=> i. - by rewrite !wxorE addbA. - Qed. - - Lemma wror_substitute {n} (w : word.word n) k : wror (substitute w) k = substitute (wror w k). - Proof. - (* I would like to case on w, but not sure how to do this most efficiently? *) - Admitted. - -Lemma key_expand1_correct rcon rkey temp2 rcon_ : - toword rcon_ = rcon -> - ⊢ ⦃ fun _ => True ⦄ - l ← (Jkey_expand rcon rkey temp2) ;; - ret (nth ('word U128 ; word0) l 0%nat) - ⇓ ('word U128 ; (key_expand rkey rcon_)) - ⦃ fun _ => True ⦄. +Lemma wxor_involutive {n} : forall k : word n, k ⊕ k = word0. Proof. - intros H. - unfold Jkey_expand, get_tr, get_translated_fun. - - simpl_fun. repeat setjvars. - rewrite !zero_extend_u. - rewrite !coerce_to_choice_type_K. + intros k. + apply/eqP/eq_from_wbit=> i. + rewrite !wxorE addbb. + unfold wbit. + rewrite Z.testbit_0_l. + reflexivity. +Qed. - unfold eval_jdg. - repeat clear_get. +(* Lemma wxorC : ∀ m k : word, (m ⊕ k) = (k ⊕ m). *) +(* Proof. *) +(* intros m k. *) +(* apply/eqP/eq_from_wbit=> i. *) +(* by rewrite !wxorE addbC. *) +(* Qed. *) - unfold sopn_sem. - unfold tr_app_sopn_tuple. - unfold tr_app_sopn_single. +Lemma wxorA {n} : forall m k l : word n, ((m ⊕ k) ⊕ l) = (m ⊕ (k ⊕ l)). +Proof. + intros m k l. + apply/eqP/eq_from_wbit=> i. + by rewrite !wxorE addbA. +Qed. - simpl. +Lemma wror_substitute {n} (w : word.word n) k : wror (substitute w) k = substitute (wror w k). +Proof. + (* I would like to case on w, but not sure how to do this most efficiently? *) +Admitted. - rewrite !zero_extend_u. - rewrite !coerce_to_choice_type_K. +Notation pr T l n := (coerce_to_choice_type T (nth (T ; chCanonical T) l n).π2). +Lemma wxorC {n} (a b : word n) : wxor a b = wxor b a. +Proof. + apply/eqP/eq_from_wbit=> i. rewrite !wxorE. + rewrite addbC. reflexivity. +Qed. - repeat eapply u_put. - eapply u_ret. +Lemma wreprI ws (a : word.word ws) : wrepr ws (toword a) = a. - split. easy. +Proof. + apply val_inj. simpl. destruct a. rewrite Z.mod_small. reflexivity. + simpl in *. lia. +Qed. - unfold totce. - f_equal. +Lemma key_expand_aux rcon rkey temp2 rcon_ : + toword rcon_ = rcon -> + subword 0 U32 temp2 = word0 -> + ((rkey ⊕ lift2_vec U128 (wshufps_128 (wpack U8 2 [0; 0; 1; 0])) U128 temp2 rkey) + ⊕ lift2_vec U128 (wshufps_128 (wpack U8 2 [0; 3; 0; 2])) U128 (lift2_vec U128 (wshufps_128 (wpack U8 2 [0; 0; 1; 0])) U128 temp2 rkey) + (rkey ⊕ lift2_vec U128 (wshufps_128 (wpack U8 2 [0; 0; 1; 0])) U128 temp2 rkey)) ⊕ wpshufd_128 (wAESKEYGENASSIST rkey (wrepr U8 rcon)) (wunsigned (wpack U8 2 [3; 3; 3; 3])) = + key_expand rkey rcon_. +Proof. + intros. + subst. + unfold key_expand. apply W4u32_eq. - intros [[ | [ | [ | i]]] j]; simpl; unfold tnth; simpl. + intros [[ | [ | [ | [ | i]]]] j]; simpl; unfold tnth; simpl. - - unfold word.wxor. rewrite !subword_xor. + rewrite !subword_xor. rewrite mul0n. unfold lift2_vec. rewrite !subword_0_32_128. - erewrite !nth_map2. simpl. rewrite mul0n. + rewrite !make_vec_ws. rewrite !subword_u. - rewrite !subword_make_vec_32_0_32_128. - simpl. unfold wpack. simpl. unfold wpshufd1. simpl. - - rewrite make_vec_single. - - rewrite zero_extend_u. - - (* rewrite wrepr0. *) rewrite !wshr0. rewrite !subword_make_vec_32_0_32_128. simpl. unfold wAESKEYGENASSIST. - simpl. - rewrite subword_wshr. rewrite subword_make_vec_32_3_32_128. simpl. @@ -1625,36 +1774,136 @@ Proof. rewrite wror_substitute. unfold word.wxor. f_equal. - f_equal. + rewrite wreprI. + reflexivity. + all: auto. + - + simpl. + unfold lift2_vec. + rewrite !make_vec_ws. + rewrite mul1n. + unfold wpack. + simpl. + rewrite mul0n. + rewrite !subword_u. + rewrite !subword_xor. + rewrite !subword_make_vec_32_1_32_128. simpl. - rewrite -H. - pose proof isword_word (rcon_). - apply val_inj. + unfold wpshufd1. + simpl. + rewrite !subword_wshr. + rewrite !addn0. + rewrite !subword_make_vec_32_3_32_128. simpl. - rewrite Z.mod_small. + unfold wpshufd1. + rewrite subword_wshr. + simpl. + rewrite addn0. + rewrite !wxorA. + f_equal. + rewrite H0. + rewrite wxor_0_l. + f_equal. + rewrite wror_substitute. + unfold word.wxor. + f_equal. + rewrite wreprI. reflexivity. - zify. lia. - zify. unfold wsize_size_minus_1. simpl. lia. - simpl. lia. - simpl. lia. + all: try auto. - - Admitted. + simpl. + unfold lift2_vec. + rewrite !make_vec_ws. + rewrite mul1n. + unfold wpack. + simpl. + rewrite mul0n. + rewrite !subword_u. + rewrite !subword_xor. + rewrite !subword_make_vec_32_2_32_128. + simpl. + unfold wpshufd1. + simpl. + rewrite !subword_wshr. + rewrite !addn0. + rewrite !subword_xor. + rewrite !subword_make_vec_32_3_32_128. + simpl. + rewrite !subword_make_vec_32_0_32_128. + unfold wpshufd1. + rewrite subword_wshr. + simpl. + rewrite addn0. + rewrite !wxorA. + f_equal. + rewrite H0. + rewrite wxor_0_l. + f_equal. + f_equal. + rewrite wror_substitute. + unfold word.wxor. + f_equal. + rewrite wreprI. + reflexivity. + all: try auto. + - + simpl. + unfold lift2_vec. + rewrite !make_vec_ws. + rewrite mul1n. + unfold wpack. + simpl. + rewrite mul0n. + rewrite !subword_u. + rewrite !subword_xor. + rewrite !subword_make_vec_32_3_32_128. + simpl. + unfold wpshufd1. + simpl. + rewrite !subword_wshr. + rewrite !addn0. + rewrite !subword_xor. + rewrite !subword_make_vec_32_3_32_128. + simpl. + rewrite !subword_make_vec_32_2_32_128. + unfold wpshufd1. + rewrite subword_wshr. + simpl. + rewrite !wxorA. + f_equal. + rewrite wxorC. + rewrite !wxorA. + f_equal. + rewrite subword_wshr. + rewrite addn0. + f_equal. + rewrite wror_substitute. + rewrite wxorC. + rewrite wxorA. + f_equal. + f_equal. + rewrite wreprI. + reflexivity. + all: auto. + lia. +Qed. -Lemma key_expand2_correct rcon rkey temp2 : +Lemma key_expand1_correct id0 rcon rkey temp2 rcon_ : + toword rcon_ = rcon -> subword 0 U32 temp2 = word0 -> ⊢ ⦃ fun _ => True ⦄ - l ← (Jkey_expand rcon rkey temp2) ;; - ret (subword 0 U32 (coerce_to_choice_type ('word U128) (nth ('word U128 ; word0) l 1%nat).π2)) - ⇓ word0 + l ← (JKEY_EXPAND id0 rcon rkey temp2) ;; + ret (nth ('word U128 ; chCanonical _) l 0%nat) + ⇓ ('word U128 ; (key_expand rkey rcon_)) ⦃ fun _ => True ⦄. Proof. - (* unfold Jkey_expand, get_tr, get_translated_fun. *) + intros H1 H2. + unfold get_tr, get_translated_fun. - intros H. simpl_fun. repeat setjvars. - (* rewrite !zero_extend_u. *) - (* rewrite !coerce_to_choice_type_K. *) + rewrite !zero_extend_u. + rewrite !coerce_to_choice_type_K. unfold eval_jdg. repeat clear_get. @@ -1673,73 +1922,666 @@ Proof. split. easy. - (* Set Printing All. *) - (* unfold lift2_vec. *) - rewrite subword_0_32_128. - simpl. - rewrite subword_make_vec_32_0_32_128. - simpl. - unfold wpshufd1. - simpl. - rewrite subword_wshr. - simpl. + unfold totce. + f_equal. + apply key_expand_aux. + assumption. + assumption. +Qed. + +Lemma key_expand_aux2 rkey temp2 : + subword 0 U32 temp2 = word0 -> + subword 0 U32 + (lift2_vec U128 (wshufps_128 (wpack U8 2 [0; 3; 0; 2])) U128 (lift2_vec U128 (wshufps_128 (wpack U8 2 [0; 0; 1; 0])) U128 temp2 rkey) + (word.wxor rkey (lift2_vec U128 (wshufps_128 (wpack U8 2 [0; 0; 1; 0])) U128 temp2 rkey))) = word0. +Proof. + intros. + rewrite subword_0_32_128. simpl. + rewrite subword_make_vec_32_0_32_128. simpl. + unfold wpshufd1. simpl. + rewrite subword_wshr. simpl. rewrite addn0. rewrite subword_u. - rewrite subword_0_32_128. - simpl. - rewrite subword_make_vec_32_0_32_128. - simpl. + rewrite subword_0_32_128. simpl. + rewrite subword_make_vec_32_0_32_128. simpl. rewrite subword_u. - unfold wpshufd1. - simpl. + unfold wpshufd1. simpl. rewrite subword_wshr. rewrite add0n. assumption. - unfold wsize_size_minus_1, nat127. - zify. lia. - unfold wsize_size_minus_1, nat127. - zify. lia. + auto. auto. Qed. -From extructures Require Import ord fset fmap. +Lemma key_expand2_correct id0 rcon rkey temp2 : + subword 0 U32 temp2 = word0 -> + ⊢ ⦃ fun _ => True ⦄ + l ← (JKEY_EXPAND id0 rcon rkey temp2) ;; + ret (subword 0 U32 (pr ('word U128) l 1%nat)) + ⇓ word0 + ⦃ fun _ => True ⦄. +Proof. + intros H. + simpl_fun. + repeat setjvars. + + unfold eval_jdg. + repeat clear_get. + + unfold sopn_sem. + unfold tr_app_sopn_tuple. + unfold tr_app_sopn_single. + + simpl. + + rewrite !zero_extend_u. + rewrite !coerce_to_choice_type_K. + + repeat eapply u_put. + eapply u_ret. + + split. easy. + apply key_expand_aux2. + assumption. +Qed. + +Lemma key_expandP pre id0 rcon rkey temp2 rcon_ : + (pdisj pre (JKEY_EXPAND_vars id0)) -> + toword rcon_ = rcon -> + subword 0 U32 temp2 = word0 -> + ⊢ ⦃ fun '(s0, s1) => pre (s0, s1) ⦄ + JKEY_EXPAND id0 rcon rkey temp2 + ≈ ret tt + ⦃ fun '(v0, s0) '(v1, s1) => pre (s0, s1) /\ exists o1 o2, v0 = [ ('word U128 ; o1) ; ('word U128 ; o2) ] /\ o1 = key_expand rkey rcon_ /\ subword 0 U32 o2 = word0 ⦄. +Proof. + intros disj Hrcon Htemp2. + tvars disj. + simpl_fun. + repeat setjvars. + repeat clear_get. + + unfold sopn_sem. + unfold tr_app_sopn_tuple. + unfold tr_app_sopn_single. + + simpl. + + rewrite !zero_extend_u. + rewrite !coerce_to_choice_type_K. + + repeat eapply r_put_lhs. + eapply r_ret. + intros s0 s1 Hpre. + repeat match goal with + | [ H : set_lhs _ _ _ _ |- _ ] => let sn := fresh in let Hsn := fresh in destruct H as [sn [Hsn]] + end. + split. + (* Goal: prove pre is preserved by using disj; this should be automated *) + - + subst. + eapply disj; [|eapply disj; [|eapply disj; [|eapply disj; [|eapply disj; [|eapply disj; [|eapply disj]]]]]]. + 1-7: solve_in. + (* TODO: Fix how the variable set is computed: It needs to include the called functions variables as well *) + 1-3: admit. + assumption. + - eexists. + eexists. + split. + 1: reflexivity. + split. + (* this is key_expand_correct1 *) + + apply key_expand_aux. + assumption. + assumption. + + apply key_expand_aux2. + assumption. +Admitted. Definition getmd {T S} m d i := match @getm T S m i with Some a => a | _ => d end. Local Open Scope Z_scope. -Definition rkeys : Location := ( chMap 'nat ('word U128) ; 0%nat ). +Fixpoint for_list (c : Z → raw_code 'unit) (vs : seq Z) : raw_code 'unit := + match vs with + | [::] => ret tt + | v :: vs => c v ;; for_list c vs + end. + +Definition for_loop' (c : Z -> raw_code 'unit) lo hi := for_list c (wrange UpTo lo hi). + +Definition to_arr ws len (a : 'array) := + mkfmapf (fun i => chArray_get ws a i (wsize_size ws)) (ziota 0 len). + +Notation " 'arr ws " := (chMap 'int ('word ws)) (at level 2) : package_scope. -Definition keyExpansion (key : u128) := - #put rkeys := @emptym nat_ordType u128 ;; - rkeys0 ← get rkeys ;; - #put rkeys := setm rkeys0 0%nat word0 ;; - for_loop (fun i => - rkeys0 ← get rkeys ;; - #put rkeys := setm rkeys0 i (key_expand (zero_extend _ (getmd rkeys0 word0 i - 1)) (wrepr U8 (rcon (Z.of_nat i)))) ;; - ret tt) 10 ;; - ret rkeys. +Definition rkeys : Location := ( 'arr U128 ; 0%nat ). + +Definition keyExpansion (key : u128) : raw_code ('arr U128) := + #put rkeys := @emptym Z_ordType u128 ;; + rkeys0 ← get rkeys ;; + #put rkeys := setm rkeys0 0 key ;; + for_loop' (fun i => rkeys0 ← get rkeys ;; #put rkeys := setm rkeys0 i (key_expand (zero_extend _ (getmd rkeys0 word0 (i - 1))) (wrepr U8 (rcon i))) ;; ret tt) 1 11 ;; + rkeys0 ← get rkeys ;; + ret rkeys0. + +Lemma iota_aux {A} k c n (f : nat -> A) g : + (forall a, a \in (iota k n) -> f a = g (a + c)%nat) -> + [seq f i | i <- iota k n] = [seq g i | i <- iota (k + c) n]. +Proof. + revert k c. + induction n. + - reflexivity. + - intros k c ex. + simpl. rewrite -addSn. + rewrite <- IHn. + f_equal. + apply ex. + simpl. + rewrite in_cons. + + apply/orP. left. apply/eqP. reflexivity. + intros a ain. apply ex. + simpl. rewrite in_cons. + apply/orP. right. assumption. +Qed. + +Lemma for_loop'_rule I c₀ c₁ lo hi : + lo <= hi -> + (∀ i, (lo <= i < hi)%Z -> ⊢ ⦃ λ '(s₀, s₁), I i (s₀, s₁) ⦄ c₀ i ≈ c₁ i ⦃ λ '(_, s₀) '(_, s₁), I (Z.succ i) (s₀,s₁) ⦄) → + ⊢ ⦃ λ '(s₀, s₁), I lo (s₀, s₁) ⦄ + for_loop' c₀ lo hi ≈ for_loop' c₁ lo hi + ⦃ λ '(_,s₀) '(_,s₁), I hi (s₀,s₁) ⦄. +Proof. + intros hle h. + remember (Z.to_nat (hi - lo)). + revert hle h Heqn. revert lo hi. + induction n as [| n ih]; intros. + - simpl. + assert (hi = lo). + { zify. lia. } + unfold for_loop'. + simpl. + rewrite -Heqn. + simpl. + subst. + apply r_ret. + easy. + - unfold for_loop'. + simpl. rewrite -Heqn. simpl. rewrite Z.add_0_r. + eapply r_bind. + + eapply h. lia. + + intros a1 a2. + replace [seq lo + Z.of_nat i | i <- iota 1 n] with [seq (Z.succ lo) + Z.of_nat i | i <- iota 0 n]. + replace n with (Z.to_nat (hi - Z.succ lo)). + apply ih. + * lia. + * intros i hi2. apply h. lia. + * lia. + * lia. + * replace (iota 1 n) with (iota (0 + 1) n). apply iota_aux. + intros. lia. + f_equal. +Qed. + +Lemma translate_for_rule I lo hi (v : var_i) m_id s_id (body1 : p_id -> p_id * raw_code 'unit) body2 : + lo <= hi -> + (forall i s_id', (lo <= i < hi) -> + ⊢ ⦃ λ '(s₀, s₁), set_lhs (translate_var m_id v) (truncate_el (vtype v) (i : chInt)) (I i) (s₀, s₁) ⦄ + let (_, body1') := body1 s_id' in + body1' + ≈ body2 i ⦃ λ '(_, s₀) '(_, s₁), I (Z.succ i) (s₀,s₁) ⦄) → + ⊢ ⦃ λ '(s₀,s₁), I lo (s₀, s₁)⦄ + translate_for v (wrange UpTo lo hi) m_id body1 s_id + ≈ for_loop' body2 lo hi + ⦃ λ '(_,s₀) '(_,s₁), I hi (s₀,s₁) ⦄. +Proof. + intros Hle ih. + remember (Z.to_nat (hi - lo)). + revert Heqn Hle ih. revert n lo hi s_id. + induction n as [|n ih2]; intros. + - assert (hi = lo). { zify. lia. }. + subst. + unfold translate_for, for_loop'. simpl. + rewrite -Heqn. + simpl. + apply r_ret. + easy. + - unfold translate_for, for_loop'. + unfold wrange. + rewrite -Heqn. + simpl. + specialize (ih lo s_id) as ih''. + destruct (body1 s_id). + eapply r_put_lhs. + eapply r_bind. + eapply r_transL. + 2: rewrite Z.add_0_r; eapply ih''. + eapply rreflexivity_rule. lia. + intros a0 a1. + replace (iota 1 n) with (iota (0 + 1) n) by f_equal. + rewrite <- iota_aux with (f := fun i => Z.succ lo + Z.of_nat i). + fold translate_for. + replace n with (Z.to_nat (hi - Z.succ lo)) by lia. + specialize (ih2 (Z.succ lo) hi p ltac:(lia) ltac:(lia)). + eapply ih2. + intros i s_id' ile. + specialize (ih i s_id'). + destruct (body1 s_id'). apply ih. lia. + intros a ain. lia. +Qed. Opaque translate_for. Notation hdtc res := (coerce_to_choice_type ('array) (hd ('word U64 ; chCanonical _) res).π2). Notation call fn := (translate_call _ fn _). -Lemma keyExpansionE rkey : - ⊢ ⦃ fun '(_, _) => True ⦄ - res ← Jkeys_expand rkey ;; - ret (hdtc res) +From Relational Require Import OrderEnrichedCategory + OrderEnrichedRelativeMonadExamples. +From Crypt Require Import Prelude Axioms ChoiceAsOrd. + +Theorem rpre_hypothesis_rule' : + ∀ {A₀ A₁ : ord_choiceType} {p₀ : raw_code A₀} {p₁ : raw_code A₁} + (pre : precond) post, + (∀ s₀ s₁, + pre (s₀, s₁) → ⊢ ⦃ λ '(s₀', s₁'), s₀' = s₀ ∧ s₁' = s₁ ⦄ p₀ ≈ p₁ ⦃ post ⦄ + ) → + ⊢ ⦃ pre ⦄ p₀ ≈ p₁ ⦃ post ⦄. +Proof. + intros A₀ A₁ p₀ p₁ pre post h. + eapply rpre_hypothesis_rule. + intros s0 s1 H. eapply rpre_weaken_rule. + eapply h. + eassumption. + easy. +Qed. + +Lemma wsize_size_aux (ws : wsize.wsize) : + (ws %/ U8 + ws %% U8) = wsize_size ws. +Proof. destruct ws; reflexivity. Qed. + +Lemma encode_aux {ws} (w : word.word ws) : + LE.encode w = [seq subword ((Z.to_nat i0) * U8) U8 w | i0 <- ziota 0 (wsize_size ws)]. +Proof. + unfold LE.encode. + unfold split_vec. + unfold ziota. + rewrite -wsize_size_aux. + simpl. + rewrite Z2Nat.inj_add. + rewrite !Nat2Z.id. + rewrite -map_comp. + unfold comp. + apply map_ext. + intros a Ha. + rewrite Nat2Z.id. + reflexivity. + apply Zle_0_nat. + apply Zle_0_nat. +Qed. + +Lemma wsize_size_bits ws: + wsize_size ws < wsize_bits ws. +Proof. + unfold wsize_size, wsize_bits. + destruct ws; simpl; lia. +Qed. + +Lemma chArray_get_set_eq ws a i w : + (* (i * wsize_bits ws < wsize_size ws) -> *) + chArray_get ws (chArray_set a AAscale i w) i (wsize_size ws) = w. +Proof. + unfold chArray_get. + unfold chArray_set. + rewrite <- LE.decodeK. + + f_equal. + rewrite encode_aux. + apply map_ext. + intros j Hj. + unfold chArray_get8. + rewrite chArray_write_get. + assert ((0 <=? i * wsize_size ws + j - i * mk_scale AAscale ws) && (i * wsize_size ws + j - i * mk_scale AAscale ws /InP. rewrite in_ziota=>/andP [] H1 h2. lia. + rewrite H. + unfold LE.wread8. + unfold LE.encode. + unfold split_vec. + unshelve erewrite nth_map. exact 0%nat. + simpl. + rewrite nth_iota. + simpl. + f_equal. + lia. + simpl. move: Hj=>/InP. rewrite in_ziota=>/andP [] H1 h2. + replace (ws %/ U8 + ws %% U8)%nat with (Z.to_nat (wsize_size ws)). lia. + destruct ws; simpl; reflexivity. + rewrite size_iota. + simpl. move: Hj=>/InP. rewrite in_ziota=>/andP [] H1 h2. + replace (ws %/ U8 + ws %% U8)%nat with (Z.to_nat (wsize_size ws)). lia. + destruct ws; simpl; reflexivity. +Qed. + +Lemma chArray_get_set_neq ws a i j (w : 'word ws) : + i <> j -> + chArray_get ws (chArray_set a AAscale i w) j (wsize_size ws) = chArray_get ws a j (wsize_size ws). +Proof. + intros H. + unfold chArray_get. + unfold chArray_set. + f_equal. + apply map_ext. + intros a0 Ha0. + unfold chArray_get8. + rewrite chArray_write_get. + assert ((0 <=? j * wsize_size ws + a0 - i * mk_scale AAscale ws) && (j * wsize_size ws + a0 - i * mk_scale AAscale ws /InP. rewrite in_ziota=>/andP [] H1 h2. + nia. + + rewrite H0. + reflexivity. +Qed. + +Lemma getm_to_arr' ws len a i : + (len <= i) -> + to_arr ws len a i = None. +Proof. + intros. unfold to_arr. + rewrite mkfmapfE. +Admitted. (* figure out a proof that is less stupid than the one for getm_to_arr *) + +Lemma getm_to_arr ws len a i : + (0 <= i < len) -> + to_arr ws len a i = Some (chArray_get ws a i (wsize_size ws)). +Proof. + unfold to_arr. + rewrite mkfmapfE. + intros H. + (* this is a stupid proof and should be true by in_ziota, though for some reason the \in's resolve differently (one uses Z_eqType the other Z_ordType) *) + assert (is_true (@in_mem (Ord.sort Z_ordType) i (@ssrbool.mem (Equality.sort (Ord.eqType Z_ordType)) (seq_predType (Ord.eqType Z_ordType)) (ziota Z0 len)))). + { assert (0 <= len) by lia. move: H. move: (Z.le_refl 0). replace len with (0 + len) at 1 by (now rewrite Z.add_0_l). generalize 0 at 2 3 4 5. + change (∀ z : Z, 0 <= z -> z <= i < z + len → + (is_true (@in_mem (Ord.sort Z_ordType) i (@ssrbool.mem (Equality.sort (Ord.eqType Z_ordType)) (seq_predType (Ord.eqType Z_ordType)) (ziota z len)))) + ) with ((fun len => ((forall z, 0 <= z -> z <= i < z + len -> + (is_true (@in_mem (Ord.sort Z_ordType) i (@ssrbool.mem (Equality.sort (Ord.eqType Z_ordType)) (seq_predType (Ord.eqType Z_ordType)) (ziota z len)))) + ))) len). + apply natlike_ind. + - intros z Hz Hz2. lia. + - intros x Hx Ih z Hz Hz2. rewrite ziotaS_cons. + destruct (Z.eq_dec z i). + + rewrite in_cons. apply/orP. left. apply/eqP. easy. + + rewrite in_cons. apply/orP. right. apply Ih. lia. lia. lia. assumption. } + rewrite H0. + reflexivity. +Qed. + +Lemma to_arr_set_eq ws len a i w : + (0 <= i < len) -> + (to_arr ws len (chArray_set a AAscale i w)) i = Some w. +Proof. + intros H. + rewrite getm_to_arr. + rewrite chArray_get_set_eq. + reflexivity. + assumption. +Qed. + +Lemma to_arr_set_neq' ws len a i j (w : 'word ws) : + (i <> j) -> + (0 <= j < len) -> + (to_arr ws len (chArray_set a AAscale i w)) j = Some (chArray_get ws a j (wsize_size ws)). +Proof. + intros Hneq Hi. + rewrite getm_to_arr. + rewrite chArray_get_set_neq. + reflexivity. + assumption. + assumption. +Qed. + +Lemma to_arr_set_neq ws len a i j (w : 'word ws) : + (i <> j) -> + (0 <= j < len) -> + (to_arr ws len (chArray_set a AAscale i w)) j = (to_arr ws len a) j. +Proof. + intros Hneq Hi. + rewrite !getm_to_arr. + rewrite chArray_get_set_neq. + reflexivity. + assumption. + assumption. + assumption. +Qed. + +Lemma keyExpansionE pre id0 rkey : + (pdisj pre (JKEYS_EXPAND_vars id0)) -> + ⊢ ⦃ fun '(h0, h1) => pre (h0, h1) ⦄ + res ← JKEYS_EXPAND id0 rkey ;; + ret (to_arr U128 11 (hdtc res)) ≈ keyExpansion rkey - ⦃ fun '(_, _) '(_, _) => True ⦄. + ⦃ fun '(v0, h0) '(v1, h1) => pre (h0, h1) /\ v0 = v1 ⦄. Proof. - unfold Jkeys_expand. - unfold get_tr, get_translated_fun, translate_prog', translate_funs. - Opaque translate_call. - simpl. + intros disj. + (* unfold JKEYS_EXPAND. *) + unfold call. (* get_tr, get_translated_fun, translate_prog', translate_funs. *) + Opaque translate_call. + Opaque wrange. + simpl. - simpl_fun. repeat setjvars. + simpl_fun. + repeat setjvars. - repeat clear_get. - unfold keyExpansion. - eapply r_put_vs_put with (pre := fun _ => Logic.True). - eapply r_get_vs_get_remember. + repeat clear_get. + eapply r_put_lhs. + eapply r_get_remember_lhs. + intros v. + eapply r_put_lhs. + eapply r_put_lhs. + unfold keyExpansion. + eapply r_put_rhs. + eapply r_get_remember_rhs. + intros v0. + Opaque for_loop'. + eapply r_put_rhs. + rewrite bind_assoc. + + rewrite bind_assoc. + eapply r_bind. + simpl. + eapply rpre_weaken_rule. + eapply translate_for_rule with (I := fun i => fun '(h0, h1) => pre (h0, h1) /\ (get_heap h0 key = chArray_get U128 (get_heap h0 rkeys) (i - 1) 16) /\ forall j, 0 <= j < i -> (to_arr U128 11 (get_heap h0 rkeys)) j = (get_heap h1 aes.rkeys) j). lia. + intros i s_id ile. + eapply r_get_remember_lhs. + intros x. + + simpl. + rewrite bind_assoc. + eapply r_bind with (m₁ := ret _) (f₁ := fun _ => _). + + epose proof rcon_correct s_id~1 _ x _ _. + eapply H. + intros a0 a1. + simpl. + eapply rpre_hypothesis_rule'. intros s0 s1 [H1 [H2 H3]]. subst. + + destruct H1 as [[s6 []]]. + simpl in *. + subst. + + simpl. repeat clear_get. + eapply r_put_lhs with (pre := λ '(s0',s1'), _ ). + eapply r_get_remember_lhs. intros x0. + eapply r_get_remember_lhs. intros x1. + rewrite bind_assoc. + eapply r_bind with (m₁ := ret _) (f₁ := fun _ => _). + epose proof key_expandP _ (s_id~0~1)%positive (rcon (get_heap (set_heap s6 round i) round)) x0 x1 (wrepr _ (rcon (get_heap (set_heap s6 round i) round))) _ _ _. + rewrite !coerce_to_choice_type_K. + eapply H0. + intros a2 a3. + + eapply rpre_hypothesis_rule'. + intros s2 s3 [H4 [o1 [o2 [H5 [H6 H7]]]]]. + subst. + simpl in *. + + destruct H4 as [[[s7 [[]]]]]. + simpl in *. + subst. + + rewrite !zero_extend_u. + eapply r_put_lhs with (pre := λ '(s0',s1'), _). + eapply r_put_lhs. + + eapply r_get_remember_lhs. intros x2. + eapply r_get_remember_lhs. intros x3. + eapply r_get_remember_lhs. intros x4. + eapply r_put_lhs. + eapply r_get_remember_rhs. intros x5. + eapply r_put_rhs. + eapply r_ret. + intros s4 s5 H8. + + (* all this should be automated *) + destruct H8 as [s7 [[[s8 [[[[[s9 [[s10 [[]]]]]]]]]]]]]. + simpl in *. + subst. + + rewrite get_set_heap_eq. + rewrite get_set_heap_eq. + rewrite get_set_heap_eq. + rewrite get_set_heap_neq. + rewrite get_set_heap_neq. + rewrite get_set_heap_neq. + rewrite get_set_heap_neq. + rewrite get_set_heap_neq. + rewrite get_set_heap_neq. + rewrite get_set_heap_neq. + rewrite get_set_heap_neq. + rewrite get_set_heap_neq. + rewrite get_set_heap_eq. + rewrite get_set_heap_neq. + rewrite get_set_heap_eq. + rewrite get_set_heap_neq. + rewrite get_set_heap_neq. + rewrite get_set_heap_eq. + + rewrite !coerce_to_choice_type_K. + rewrite !zero_extend_u. + split; [|split]. + + (* prove that pre is preserved in the inductive step *) + tvars disj. + apply disj. unfold rkeys. + solve_in. + apply disj. solve_in. + apply disj. solve_in. + apply disj. solve_in. + apply disj. solve_in. + (* what to do with the heap of the rhs? *) admit. + + (* prove the first invariant *) + replace (Z.succ i - 1) with i by lia. + rewrite chArray_get_set_eq. + reflexivity. + (* prove the second invariant *) + intros j Hj. + destruct (Z.eq_dec i j). + + (* i = j *) + subst. + rewrite to_arr_set_eq. + rewrite setmE. rewrite eq_refl. + destruct H as []. destruct H0. rewrite H0. + f_equal. unfold getmd. rewrite -H1. rewrite getm_to_arr. + f_equal. lia. lia. lia. + + (* i <> j *) + rewrite to_arr_set_neq. + rewrite setmE. + assert (@eq bool (@eq_op Z_ordType j i) false). apply/eqP. auto. + rewrite H0. + apply H. lia. assumption. lia. + + (* trivial *) + 1-12: neq_loc_auto. + + (* prove base case *) + intros s0 s1 H. + destruct H as [s2 [[[s3 [[s4 [[s5 [[[s6 []]]]]]]]]]]]. + simpl in *; subst. + + rewrite get_set_heap_eq. + rewrite get_set_heap_neq. + rewrite get_set_heap_eq. + rewrite get_set_heap_neq. + rewrite get_set_heap_neq. + rewrite get_set_heap_eq. + rewrite get_set_heap_neq. + rewrite get_set_heap_eq. + + rewrite !coerce_to_choice_type_K. + rewrite !zero_extend_u. + split; [|split]. + + (* prove that pre is preserved *) admit. + + (* first invariant *) + rewrite chArray_get_set_eq. reflexivity. + + (* second invariant *) + intros j Hj. assert (j = 0) by lia. subst. + rewrite to_arr_set_eq. rewrite setmE. rewrite eq_refl. reflexivity. + lia. + 1-4: neq_loc_auto. + + (* after for loop *) + intros a0 a1. + simpl. + eapply r_get_remember_lhs with (pre := fun '(s0, s1) => _). + intros x. + eapply r_get_remember_rhs. + intros x0. + eapply r_ret. + intros s0 s1 H. + destruct H as [[[]]]. + destruct H0. + simpl in *. subst. + split. assumption. + eapply eq_fmap. + intros j. + + destruct ((0 <=? j) && (j LocationUtility.opsig_in_remove_fset. simpl. auto. + simpl in c. + reflexivity. + KEY_COMBINE. []opr pack_state KEY_COMBINE. + Lemma rxor_state : forall w1 w2, + ⊢ ⦃ true_precond ⦄ + res ← Jkey_combine ;; + ret (coerce_to_choice_type ('word U64) (hd ('word U64 ; chCanonical _) res).π2) + ≈ + state_xor w1 w2 + ⦃ fun '(a, _) '(b, _) => (a = b) ⦄. + Proof. + intros w1 w2. + unfold state_xor. diff --git a/theories/Jasmin/jasmin_utils.v b/theories/Jasmin/jasmin_utils.v index 358c7f98..cab3bff5 100644 --- a/theories/Jasmin/jasmin_utils.v +++ b/theories/Jasmin/jasmin_utils.v @@ -110,7 +110,7 @@ Ltac2 setjvars () := | None => Control.throw (Tactic_failure (Some (fprintf "Not a valid ident: %s (was: %t)" s i))) | Some id => let x := Fresh.fresh (Fresh.Free.of_goal ()) id in - set ($x := $$ $i) + set ($x := $$ $i) in * end end. From 73a957bfe17f89c08c6cc86ffffe23f38fb5396c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Fri, 9 Dec 2022 11:10:38 +0100 Subject: [PATCH 293/383] Update build.yml --- .github/workflows/build.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index d5628002..6cfa2c5c 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -45,6 +45,6 @@ jobs: - name: Build run: | opam repo add coq-released https://coq.inria.fr/opam/released - opam install coq.8.14.0 coq-equations.1.3+8.14 coq-mathcomp-ssreflect.1.13.0 coq-mathcomp-analysis.0.3.13 coq-extructures.0.3.1 coq-deriving.0.1.0 + opam install coq.8.15.2 coq-equations.1.3+8.15 coq-mathcomp-ssreflect.1.13.0 coq-mathcomp-analysis.0.3.13 coq-extructures.0.3.1 coq-deriving.0.1.0 opam exec -- make -j4 From 3b5d8e61d59b5d04b0ffe77bf4d1f2195cc1b0c4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Fri, 9 Dec 2022 16:18:53 +0100 Subject: [PATCH 294/383] Don't really manage to improve AES yet --- theories/Jasmin/examples/aes/aes.v | 162 +++++++++++++++-------------- 1 file changed, 83 insertions(+), 79 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes.v b/theories/Jasmin/examples/aes/aes.v index 1c7f473c..a1b2f471 100644 --- a/theories/Jasmin/examples/aes/aes.v +++ b/theories/Jasmin/examples/aes/aes.v @@ -15,6 +15,9 @@ From Crypt Require Import Prelude Package. Import ListNotations. Local Open Scope string. +Set Bullet Behavior "Strict Subproofs". +(* Set Default Goal Selector "!". *) (* I give up on this for now. *) + Definition ssprove_jasmin_prog : uprog. Proof. refine {| p_funcs := @@ -1148,20 +1151,22 @@ Proof. (* | |- _ => eapply r_put_lhs with (pre := fun _ => True); ssprove_contract_put_get_lhs; eapply r_put_lhs; rewrite ?coerce_to_choice_type_K; eapply r_ret; easy *) | |- _ => simpl; ssprove_contract_put_get_lhs; rewrite !coerce_to_choice_type_K end. - simpl. eapply r_put_lhs. ssprove_contract_put_get_lhs; eapply r_put_lhs; rewrite ?coerce_to_choice_type_K. - eapply r_restore_lhs. intros. unfold set_lhs in *. - destruct H0 as [s0 []]. - exists (set_heap s0 c 1%Z). subst. split. apply Hpdisj. - solve_in. - assumption. rewrite set_heap_commut. reflexivity. - apply injective_translate_var3. auto. - eapply r_ret. - intros; split. - destruct H0 as [s0 []]. subst. - apply Hpdisj. - solve_in. - assumption. - split; easy. + - simpl. eapply r_put_lhs. + ssprove_contract_put_get_lhs; eapply r_put_lhs; rewrite ?coerce_to_choice_type_K. + eapply r_restore_lhs. + + intros. unfold set_lhs in *. + destruct H0 as [s0 []]. + exists (set_heap s0 c 1%Z). subst. split. + * apply Hpdisj. 1: solve_in. + assumption. + * rewrite set_heap_commut. 1: reflexivity. + apply injective_translate_var3. auto. + + eapply r_ret. + intros; split. + * destruct H0 as [s0 []]. subst. + apply Hpdisj. 1: solve_in. + assumption. + * split. all: easy. (* the remaining cases are similar, but should be automated *) Admitted. (* Qed. *) @@ -1237,9 +1242,11 @@ Proof. unfold modulus. rewrite !two_power_nat_equiv. rewrite Z.mod_pow2_bits_low. - rewrite Z.mod_pow2_bits_low. - rewrite Z.shiftr_spec. - f_equal. lia. lia. lia. lia. + { rewrite Z.mod_pow2_bits_low. 2: lia. + rewrite Z.shiftr_spec. 2: lia. + f_equal. lia. + } + lia. Qed. Lemma subword_xor {n} i ws (a b : n.-word) : @@ -1249,11 +1256,10 @@ Lemma subword_xor {n} i ws (a b : n.-word) : Proof. intros H. apply/eqP/eq_from_wbit. - intros. rewrite !wbit_subword. + intros. rewrite !wbit_subword. 2,3: auto. rewrite !wxorE. - rewrite !wbit_subword. + rewrite !wbit_subword. 2-5: auto. reflexivity. - all: auto. Qed. Local Open Scope Z_scope. @@ -1268,9 +1274,8 @@ Proof. unfold wrepr. apply val_inj. simpl. - rewrite [a mod _]Z.mod_small. + rewrite [a mod _]Z.mod_small. 2: assumption. reflexivity. - assumption. Qed. Lemma modulus_gt0' n : (0 < modulus n)%Z. @@ -1300,7 +1305,7 @@ Proof. intros. pose proof Z.mod_pos_bound a (b^n) ltac:(auto with zarith). assert (b^n <= b^m). - eapply Z.pow_le_mono_r; lia. + { eapply Z.pow_le_mono_r; lia. } apply Z.mod_small. auto with zarith. Qed. @@ -1312,13 +1317,12 @@ Proof. rewrite -> Z.pow_add_r, Z.rem_mul_r by auto with zarith. rewrite <- Zplus_mod_idemp_r. rewrite <- Zmult_mod_idemp_l. - rewrite Z.mod_same. + rewrite Z.mod_same. 2: eapply Z.pow_nonzero ; lia. rewrite Z.mul_0_l. - rewrite Z.mod_0_l. + rewrite Z.mod_0_l. 2: eapply Z.pow_nonzero ; lia. rewrite Z.add_0_r. - rewrite Z.mod_mod. + rewrite Z.mod_mod. 2: eapply Z.pow_nonzero ; lia. reflexivity. - all: eapply Z.pow_nonzero; lia. Qed. Lemma larger_modulus a n m : @@ -1327,8 +1331,8 @@ Lemma larger_modulus a n m : Proof. intros H. rewrite !modulusZE. - apply mod_pow_same_base_larger. - zify. simpl. lia. lia. + apply mod_pow_same_base_larger. 2: lia. + zify. simpl. lia. Qed. Lemma smaller_modulus a n m : @@ -1337,8 +1341,8 @@ Lemma smaller_modulus a n m : Proof. intros H. rewrite !modulusZE. - apply mod_pow_same_base_smaller. - zify. simpl. lia. lia. + apply mod_pow_same_base_smaller. 2: lia. + zify. simpl. lia. Qed. Lemma nat_of_wsize_m ws : (wsize_size_minus_1 ws).+1 = nat_of_wsize ws. @@ -1364,9 +1368,8 @@ Proof. replace [seq nth a l (val i) | i <- enum 'I_(size l)] with [seq nth a l i | i <- [seq val i | i <- enum 'I_(size l)]]. 2: { rewrite -map_comp. reflexivity. } rewrite val_enum_ord. - rewrite map_nth_iota0. + rewrite map_nth_iota0. 2: lia. rewrite take_size. reflexivity. - lia. Qed. Lemma make_vec_wcat {ws1} (l : seq (word.word ws1)) : @@ -1388,8 +1391,8 @@ Proof. simpl. unfold modulus. rewrite two_power_nat_equiv. rewrite Z.mod_pow2_bits_low. + 2:{ unfold nat_of_wsize in *. lia. } reflexivity. - unfold nat_of_wsize in *. lia. Qed. Lemma wbit_make_vec {ws1} (ws2 : wsize.wsize) (l : seq (word.word ws1)) i : @@ -1399,13 +1402,12 @@ Proof. intros H. unfold make_vec. rewrite make_vec_wcat. - rewrite wbit_wrepr. + rewrite wbit_wrepr. 2: assumption. rewrite wcat_wbitE. unfold urepr. simpl. repeat f_equal. apply nth_aux. - assumption. Qed. Lemma divn_aux j i n : @@ -1414,12 +1416,9 @@ Lemma divn_aux j i n : (j + i) %/ n = i %/ n. Proof. intros H1 H2. - rewrite divnD. + rewrite divnD. 2: lia. rewrite H2. - rewrite divn_small. - lia. - assumption. - lia. + rewrite divn_small. all: lia. Qed. Lemma modn_aux j i n : @@ -1428,12 +1427,9 @@ Lemma modn_aux j i n : (j + i) %% n = (j + i %% n)%nat. Proof. intros H1 H2. - rewrite modnD. + rewrite modnD. 2: lia. rewrite H2. - rewrite modn_small. - lia. - assumption. - lia. + rewrite modn_small. all: lia. Qed. Lemma subword_make_vec1 {ws1} i ws2 (ws3 : wsize.wsize) (l : seq (word.word ws1)) : @@ -1451,16 +1447,17 @@ Proof. apply eq_mktuple. intros j. destruct j. simpl. - rewrite wbit_make_vec. - f_equal. + rewrite wbit_make_vec. 2: lia. f_equal. - f_equal. - apply divn_aux. - simpl. lia. - rewrite modn_small in H3. rewrite modn_small. lia. lia. lia. - apply modn_aux. lia. - rewrite modn_small in H3. rewrite modn_small. lia. lia. lia. - simpl. unfold nat_of_wsize in *. lia. + - f_equal. f_equal. + apply divn_aux. 1:{ simpl. lia. } + rewrite modn_small in H3. 2: lia. + rewrite modn_small. 2: lia. + lia. + - apply modn_aux. 1: lia. + rewrite modn_small in H3. 2: lia. + rewrite modn_small. 1: lia. + lia. Qed. Lemma make_vec_ws ws (l : seq (word.word ws)) : @@ -1984,14 +1981,27 @@ Proof. assumption. Qed. +Ltac pdisj_apply h := + lazymatch goal with + | |- ?pre (set_heap _ _ _, _) => + eapply h ; [ solve_in | pdisj_apply h ] + | |- _ => try assumption + end. + Lemma key_expandP pre id0 rcon rkey temp2 rcon_ : - (pdisj pre (JKEY_EXPAND_vars id0)) -> - toword rcon_ = rcon -> - subword 0 U32 temp2 = word0 -> - ⊢ ⦃ fun '(s0, s1) => pre (s0, s1) ⦄ + pdisj pre (JKEY_EXPAND_vars id0) → + toword rcon_ = rcon → + subword 0 U32 temp2 = word0 → + ⊢ ⦃ λ '(s0, s1), pre (s0, s1) ⦄ JKEY_EXPAND id0 rcon rkey temp2 ≈ ret tt - ⦃ fun '(v0, s0) '(v1, s1) => pre (s0, s1) /\ exists o1 o2, v0 = [ ('word U128 ; o1) ; ('word U128 ; o2) ] /\ o1 = key_expand rkey rcon_ /\ subword 0 U32 o2 = word0 ⦄. + ⦃ λ '(v0, s0) '(v1, s1), + pre (s0, s1) ∧ + ∃ o1 o2, + v0 = [ ('word U128 ; o1) ; ('word U128 ; o2) ] ∧ + o1 = key_expand rkey rcon_ ∧ + subword 0 U32 o2 = word0 + ⦄. Proof. intros disj Hrcon Htemp2. tvars disj. @@ -2011,29 +2021,23 @@ Proof. repeat eapply r_put_lhs. eapply r_ret. intros s0 s1 Hpre. - repeat match goal with - | [ H : set_lhs _ _ _ _ |- _ ] => let sn := fresh in let Hsn := fresh in destruct H as [sn [Hsn]] - end. + repeat + match goal with + | [ H : set_lhs _ _ _ _ |- _ ] => + let sn := fresh in + let Hsn := fresh in + destruct H as [sn [Hsn]] + end. split. (* Goal: prove pre is preserved by using disj; this should be automated *) - - - subst. - eapply disj; [|eapply disj; [|eapply disj; [|eapply disj; [|eapply disj; [|eapply disj; [|eapply disj]]]]]]. - 1-7: solve_in. + - subst. + pdisj_apply disj. (* TODO: Fix how the variable set is computed: It needs to include the called functions variables as well *) - 1-3: admit. - assumption. - - eexists. - eexists. - split. - 1: reflexivity. - split. + all: admit. + - eexists _, _. intuition eauto. (* this is key_expand_correct1 *) - + apply key_expand_aux. - assumption. - assumption. - + apply key_expand_aux2. - assumption. + + apply key_expand_aux. all: assumption. + + apply key_expand_aux2. assumption. Admitted. Definition getmd {T S} m d i := match @getm T S m i with Some a => a | _ => d end. From fddc183ea6a1411f804160dcd5b07e3e516929f2 Mon Sep 17 00:00:00 2001 From: bshvass Date: Fri, 9 Dec 2022 21:26:34 +0100 Subject: [PATCH 295/383] compute variables manually --- theories/Jasmin/examples/aes/aes.v | 99 ++++++++++++++++++++++++++++-- 1 file changed, 95 insertions(+), 4 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes.v b/theories/Jasmin/examples/aes/aes.v index 1c7f473c..5fad5603 100644 --- a/theories/Jasmin/examples/aes/aes.v +++ b/theories/Jasmin/examples/aes/aes.v @@ -1050,6 +1050,91 @@ Notation KEYS_EXPAND := (xO (xO (xI xH))). Infix "^" := wxor. +Definition get_vars_lval (m_id : p_id) (l : lval) := + match l with + | Lnone _ _ => fset0 + | Lvar x => fset1 (translate_var m_id x) + | Lmem _ x _ => fset1 (translate_var m_id x) + | Laset _ _ x _ => fset1 (translate_var m_id x) + | Lasub _ _ _ x _ => fset1 (translate_var m_id x) + end. +Fixpoint get_vars_lvals (m_id : p_id) (ls : lvals) := + foldr (fun l locs => get_vars_lval m_id l :|: locs) fset0 ls. +Fixpoint get_vars_for (ws : seq Z) (m_id : p_id) (c : p_id -> p_id * {fset Location}) (s_id : p_id) := + match ws with + | [] => fset0 + | w :: ws => + let (s_id1, locs1) := c s_id in + locs1 :|: get_vars_for ws m_id c s_id1 + end. +Definition fvars := seq (funname * (p_id -> {fset Location})). +Definition get_vars_call (f : funname) (fs : fvars) := + match (assoc fs f) with + | Some fv => fv + | None => (fun s_id => fset0) + end. +Fixpoint get_vars_instr_r (ws_def : seq Z) (fs : fvars) (i : instr_r) (m_id : p_id) (s_id : p_id) {struct i} : p_id * {fset Location} +with get_vars_instr (ws_def : seq Z) (fs : fvars) (i : instr) (m_id : p_id) (s_id : p_id) {struct i} : p_id * {fset Location} := + get_vars_instr_r ws_def fs (instr_d i) m_id s_id. +Proof. + pose proof + (get_vars_cmd := + (fix get_vars_cmd (ws_def : seq Z) (fs : fvars) (c : cmd) (m_id : p_id) (s_id : p_id) {struct c} : p_id * {fset Location} := + match c with + | [::] => (s_id, fset0) + | i :: c => + let (s_id1, locs1) := get_vars_instr ws_def fs i m_id s_id in + let (s_id2, locs2) := get_vars_cmd ws_def fs c m_id s_id1 in + (s_id2, locs1 :|: locs2) + end)). + refine + (match i with + | Cassgn l _ s e => (s_id, get_vars_lval m_id l) + | Copn ls _ o es => (s_id, get_vars_lvals m_id ls) + | Cif e c1 c2 => + let (s_id1, locs1) := get_vars_cmd ws_def fs c1 m_id s_id in + let (s_id2, locs2) := get_vars_cmd ws_def fs c2 m_id s_id1 in + (s_id2, locs1 :|: locs2) + | Cfor i r c => + let '(d, lo, hi) := r in + let ws := + match lo, hi with + | Pconst vlo, Pconst vhi => wrange d vlo vhi + | _, _ => ws_def + end in + let (s_id', fresh) := fresh_id s_id in + let cᵗ := get_vars_cmd ws fs c m_id in + (s_id', translate_var m_id i |: get_vars_for ws m_id cᵗ fresh) + | Ccall ii xs f args => + let (s_id', fresh) := fresh_id s_id in + (s_id', get_vars_lvals m_id xs :|: get_vars_call f fs fresh) + | _ => (s_id, fset0) + end). +Defined. + +Fixpoint get_vars_cmd (ws_def : seq Z) (fs : fvars) (c : cmd) (m_id : p_id) (s_id : p_id) {struct c} : p_id * {fset Location} := + match c with + | [::] => (s_id, fset0) + | i :: c => + let (s_id1, locs1) := get_vars_instr ws_def fs i m_id s_id in + let (s_id2, locs2) := get_vars_cmd ws_def fs c m_id s_id1 in + (s_id2, locs1 :|: locs2) + end. + +Fixpoint get_vars_funs (ws_def : seq Z) (fs : seq _ufun_decl) : fvars := + match fs with + | [::] => [::] + | f :: fs' => + let '(fn, f_extra) := f in + let fvs := get_vars_funs ws_def fs' in + let fps := fun s_id => foldr (fun v locs => translate_var s_id (v_var v) |: locs) fset0 (f_params f_extra) in + let fv := fun s_id => (get_vars_cmd ws_def fvs (f_body f_extra) s_id s_id).2 in + (fn, fun s_id => fps s_id :|: fv s_id) :: fvs + end. +Definition get_vars_prog {ept} (ws_def : seq Z) (P : _prog unit ept) := + get_vars_funs ws_def (p_funcs P). +Definition ws_def : seq Z := [::]. + Definition get_vars_Sv {eft ept} P fname : Sv.t := match (assoc (@p_funcs _ _ eft ept P) fname) with | Some f => vars_c (f_body f) @@ -1092,6 +1177,8 @@ Fixpoint list_to_chtuple (l : list typed_chElement) : lchtuple [seq t.π1 | t <- Notation trp := (translate_prog' ssprove_jasmin_prog).1. Notation trc := (fun fn i => translate_call ssprove_jasmin_prog fn trp i). +Notation vp := (get_vars_prog ws_def ssprove_jasmin_prog). +Notation vc := (fun fn i => get_vars_call fn vp i). (* I use trc to be able to reuse statements about the function inside other functions where theyll appear as translate_calls (and not get_translated_funs). Furthermore, I think this is necessary to assure that all calls gets the complete list of translated functions. @@ -1101,19 +1188,23 @@ Notation trc := (fun fn i => translate_call ssprove_jasmin_prog fn trp i). Notation JRCON i j := (trc RCON i [('int ; j)]). (* Notation JRCON (j : Z) := (get_tr RCON i [('int ; j)]). *) -Notation JRCON_vars i := (get_vars ssprove_jasmin_prog RCON i). +Notation JRCON_vars i := (vc RCON i). +(* Notation JRCON_vars i := (get_vars ssprove_jasmin_prog RCON i). *) Notation JKEY_COMBINE i rkey temp1 temp2 := (trc KEY_COMBINE i [('word U128 ; rkey) ; ('word U128 ; temp1) ; ('word U128 ; temp2)]). (* Notation JKEY_COMBINE rkey temp1 temp2 := (get_tr KEY_COMBINE i [('word U128 ; rkey) ; ('word U128 ; temp1) ; ('word U128 ; temp2)]). *) -Notation JKEY_COMBINE_vars i := (get_vars ssprove_jasmin_prog KEY_COMBINE i). +Notation JKEY_COMBINE_vars i := (vc KEY_COMBINE i). +(* Notation JKEY_COMBINE_vars i := (get_vars ssprove_jasmin_prog KEY_COMBINE i). *) Notation JKEY_EXPAND i rcon rkey temp2 := (trc KEY_EXPAND i [ ('int ; rcon) ; ('word U128 ; rkey) ; ('word U128 ; temp2) ]). (* Notation JKEY_EXPAND rcon rkey temp2 := (get_tr KEY_EXPAND i [ ('int ; rcon) ; ('word U128 ; rkey) ; ('word U128 ; temp2) ]). *) -Notation JKEY_EXPAND_vars i := (get_vars ssprove_jasmin_prog KEY_EXPAND i). +Notation JKEY_EXPAND_vars i := (vc KEY_EXPAND i). +(* Notation JKEY_EXPAND_vars i := (get_vars ssprove_jasmin_prog KEY_EXPAND i). *) Notation JKEYS_EXPAND i rkey := (trc KEYS_EXPAND i [('word U128 ; rkey)]). (* Notation JKEYS_EXPAND rkey := (get_tr KEYS_EXPAND i [('word U128 ; rkey)]). *) -Notation JKEYS_EXPAND_vars i := (get_vars ssprove_jasmin_prog KEYS_EXPAND i). +Notation JKEYS_EXPAND_vars i := (vc KEYS_EXPAND i). +(* Notation JKEYS_EXPAND_vars i := (get_vars ssprove_jasmin_prog KEYS_EXPAND i). *) Definition rcon (i : Z) : Z := nth 54%Z [:: 1; 2; 4; 8; 16; 32; 64; 128; 27; 54]%Z ((Z.to_nat i) - 1). From 216bc72f9e8150eb8dbaa8a2fbc43342f40f3dc0 Mon Sep 17 00:00:00 2001 From: bshvass Date: Sat, 10 Dec 2022 00:16:32 +0100 Subject: [PATCH 296/383] much less redundant version, though still very slow Maybe it is using fset's union that is the bottleneck --- theories/Jasmin/examples/aes/aes.v | 100 +++++++++++++++-------------- 1 file changed, 52 insertions(+), 48 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes.v b/theories/Jasmin/examples/aes/aes.v index 5fad5603..32fbc19e 100644 --- a/theories/Jasmin/examples/aes/aes.v +++ b/theories/Jasmin/examples/aes/aes.v @@ -1050,22 +1050,21 @@ Notation KEYS_EXPAND := (xO (xO (xI xH))). Infix "^" := wxor. -Definition get_vars_lval (m_id : p_id) (l : lval) := - match l with - | Lnone _ _ => fset0 - | Lvar x => fset1 (translate_var m_id x) - | Lmem _ x _ => fset1 (translate_var m_id x) - | Laset _ _ x _ => fset1 (translate_var m_id x) - | Lasub _ _ _ x _ => fset1 (translate_var m_id x) +Definition get_vars_Sv {eft ept} P fname : Sv.t := +match (assoc (@p_funcs _ _ eft ept P) fname) with + | Some f => vars_c (f_body f) + | None => Sv.empty end. -Fixpoint get_vars_lvals (m_id : p_id) (ls : lvals) := - foldr (fun l locs => get_vars_lval m_id l :|: locs) fset0 ls. -Fixpoint get_vars_for (ws : seq Z) (m_id : p_id) (c : p_id -> p_id * {fset Location}) (s_id : p_id) := + +Definition fset_of_Sv (fc_id : p_id) (t : Sv.t) : {fset Location} := + Sv.fold (fun e s => translate_var fc_id e |: s) t fset0. + +Fixpoint get_vars_for (ws : seq Z) (m_id : p_id) (c : {fset Location} -> p_id -> p_id * {fset Location}) (acc : {fset Location}) (s_id : p_id) := match ws with - | [] => fset0 + | [] => acc | w :: ws => - let (s_id1, locs1) := c s_id in - locs1 :|: get_vars_for ws m_id c s_id1 + let (s_id1, locs1) := c acc s_id in + get_vars_for ws m_id c locs1 s_id1 end. Definition fvars := seq (funname * (p_id -> {fset Location})). Definition get_vars_call (f : funname) (fs : fvars) := @@ -1073,28 +1072,28 @@ Definition get_vars_call (f : funname) (fs : fvars) := | Some fv => fv | None => (fun s_id => fset0) end. -Fixpoint get_vars_instr_r (ws_def : seq Z) (fs : fvars) (i : instr_r) (m_id : p_id) (s_id : p_id) {struct i} : p_id * {fset Location} -with get_vars_instr (ws_def : seq Z) (fs : fvars) (i : instr) (m_id : p_id) (s_id : p_id) {struct i} : p_id * {fset Location} := - get_vars_instr_r ws_def fs (instr_d i) m_id s_id. +Fixpoint get_vars_instr_r (ws_def : seq Z) (fs : fvars) (i : instr_r) (m_id : p_id) (acc : {fset Location}) (s_id : p_id) {struct i} : p_id * {fset Location} +with get_vars_instr (ws_def : seq Z) (fs : fvars) (i : instr) (m_id : p_id) (acc : {fset Location}) (s_id : p_id) {struct i} : p_id * {fset Location} := + get_vars_instr_r ws_def fs (instr_d i) m_id acc s_id. Proof. pose proof (get_vars_cmd := - (fix get_vars_cmd (ws_def : seq Z) (fs : fvars) (c : cmd) (m_id : p_id) (s_id : p_id) {struct c} : p_id * {fset Location} := + fix get_vars_cmd (ws_def : seq Z) (fs : fvars) (c : cmd) (m_id : p_id) (acc : {fset Location}) (s_id : p_id) {struct c} : p_id * {fset Location} := match c with - | [::] => (s_id, fset0) + | [::] => (s_id, acc) | i :: c => - let (s_id1, locs1) := get_vars_instr ws_def fs i m_id s_id in - let (s_id2, locs2) := get_vars_cmd ws_def fs c m_id s_id1 in - (s_id2, locs1 :|: locs2) - end)). + let (s_id1, acc') := get_vars_instr ws_def fs i m_id acc s_id in + let (s_id2, acc'') := get_vars_cmd ws_def fs c m_id acc' s_id1 in + (s_id2, acc'') + end). refine (match i with - | Cassgn l _ s e => (s_id, get_vars_lval m_id l) - | Copn ls _ o es => (s_id, get_vars_lvals m_id ls) + | Cassgn l _ s e => (s_id, acc) + | Copn ls _ o es => (s_id, acc) | Cif e c1 c2 => - let (s_id1, locs1) := get_vars_cmd ws_def fs c1 m_id s_id in - let (s_id2, locs2) := get_vars_cmd ws_def fs c2 m_id s_id1 in - (s_id2, locs1 :|: locs2) + let (s_id1, locs1) := get_vars_cmd ws_def fs c1 m_id acc s_id in + let (s_id2, locs2) := get_vars_cmd ws_def fs c2 m_id locs1 s_id1 in + (s_id2, locs2) | Cfor i r c => let '(d, lo, hi) := r in let ws := @@ -1104,21 +1103,21 @@ Proof. end in let (s_id', fresh) := fresh_id s_id in let cᵗ := get_vars_cmd ws fs c m_id in - (s_id', translate_var m_id i |: get_vars_for ws m_id cᵗ fresh) + (s_id', get_vars_for ws m_id cᵗ acc fresh) | Ccall ii xs f args => let (s_id', fresh) := fresh_id s_id in - (s_id', get_vars_lvals m_id xs :|: get_vars_call f fs fresh) - | _ => (s_id, fset0) + (s_id', acc :|: get_vars_call f fs fresh) + | _ => (s_id, acc) end). Defined. -Fixpoint get_vars_cmd (ws_def : seq Z) (fs : fvars) (c : cmd) (m_id : p_id) (s_id : p_id) {struct c} : p_id * {fset Location} := +Fixpoint get_vars_cmd (ws_def : seq Z) (fs : fvars) (c : cmd) (m_id : p_id) (acc : {fset Location}) (s_id : p_id) {struct c} : p_id * {fset Location} := match c with - | [::] => (s_id, fset0) + | [::] => (s_id, acc) | i :: c => - let (s_id1, locs1) := get_vars_instr ws_def fs i m_id s_id in - let (s_id2, locs2) := get_vars_cmd ws_def fs c m_id s_id1 in - (s_id2, locs1 :|: locs2) + let (s_id1, acc') := get_vars_instr ws_def fs i m_id acc s_id in + let (s_id2, acc'') := get_vars_cmd ws_def fs c m_id acc' s_id1 in + (s_id2, acc'') end. Fixpoint get_vars_funs (ws_def : seq Z) (fs : seq _ufun_decl) : fvars := @@ -1127,22 +1126,14 @@ Fixpoint get_vars_funs (ws_def : seq Z) (fs : seq _ufun_decl) : fvars := | f :: fs' => let '(fn, f_extra) := f in let fvs := get_vars_funs ws_def fs' in - let fps := fun s_id => foldr (fun v locs => translate_var s_id (v_var v) |: locs) fset0 (f_params f_extra) in - let fv := fun s_id => (get_vars_cmd ws_def fvs (f_body f_extra) s_id s_id).2 in - (fn, fun s_id => fps s_id :|: fv s_id) :: fvs + (* let fps := fun s_id => foldr (fun v locs => translate_var s_id (v_var v) |: locs) fset0 (f_params f_extra) in *) + let fv := fun s_id => (get_vars_cmd ws_def fvs (f_body f_extra) s_id (fset_of_Sv s_id (vars_c (f_body f_extra))) s_id).2 in + (fn, fv) :: fvs end. Definition get_vars_prog {ept} (ws_def : seq Z) (P : _prog unit ept) := get_vars_funs ws_def (p_funcs P). -Definition ws_def : seq Z := [::]. -Definition get_vars_Sv {eft ept} P fname : Sv.t := -match (assoc (@p_funcs _ _ eft ept P) fname) with - | Some f => vars_c (f_body f) - | None => Sv.empty - end. - -Definition fset_of_Sv (fc_id : p_id) (t : Sv.t) : {fset Location} := - Sv.fold (fun e s => translate_var fc_id e |: s) t fset0. +Definition ws_def : seq Z := [::]. Definition get_tr := get_translated_fun ssprove_jasmin_prog. Definition get_vars {eft ept} P fname fc_id := fset_of_Sv fc_id (@get_vars_Sv eft ept P fname). @@ -1190,21 +1181,34 @@ Notation JRCON i j := (trc RCON i [('int ; j)]). (* Notation JRCON (j : Z) := (get_tr RCON i [('int ; j)]). *) Notation JRCON_vars i := (vc RCON i). (* Notation JRCON_vars i := (get_vars ssprove_jasmin_prog RCON i). *) +Goal JRCON_vars 1%positive = fset0. + unfold get_vars_call. simpl. cbn. + Abort. Notation JKEY_COMBINE i rkey temp1 temp2 := (trc KEY_COMBINE i [('word U128 ; rkey) ; ('word U128 ; temp1) ; ('word U128 ; temp2)]). (* Notation JKEY_COMBINE rkey temp1 temp2 := (get_tr KEY_COMBINE i [('word U128 ; rkey) ; ('word U128 ; temp1) ; ('word U128 ; temp2)]). *) Notation JKEY_COMBINE_vars i := (vc KEY_COMBINE i). (* Notation JKEY_COMBINE_vars i := (get_vars ssprove_jasmin_prog KEY_COMBINE i). *) +Goal JKEY_COMBINE_vars 1%positive = fset0. + unfold get_vars_call. simpl. cbn. + Abort. Notation JKEY_EXPAND i rcon rkey temp2 := (trc KEY_EXPAND i [ ('int ; rcon) ; ('word U128 ; rkey) ; ('word U128 ; temp2) ]). (* Notation JKEY_EXPAND rcon rkey temp2 := (get_tr KEY_EXPAND i [ ('int ; rcon) ; ('word U128 ; rkey) ; ('word U128 ; temp2) ]). *) Notation JKEY_EXPAND_vars i := (vc KEY_EXPAND i). -(* Notation JKEY_EXPAND_vars i := (get_vars ssprove_jasmin_prog KEY_EXPAND i). *) +(* Notation JKEY_EXPAND_vars i := (get_vars ssprove_jasmin_prog KEY_EXPAND intro). *) +(* this is slow and I'm not sure why. *) +Goal JKEY_EXPAND_vars 1%positive = fset0. + unfold get_vars_call. simpl. cbn. + Abort. Notation JKEYS_EXPAND i rkey := (trc KEYS_EXPAND i [('word U128 ; rkey)]). (* Notation JKEYS_EXPAND rkey := (get_tr KEYS_EXPAND i [('word U128 ; rkey)]). *) Notation JKEYS_EXPAND_vars i := (vc KEYS_EXPAND i). (* Notation JKEYS_EXPAND_vars i := (get_vars ssprove_jasmin_prog KEYS_EXPAND i). *) +Goal JKEYS_EXPAND_vars 1%positive = fset0. + unfold get_vars_call. simpl. cbn. + Abort. Definition rcon (i : Z) : Z := nth 54%Z [:: 1; 2; 4; 8; 16; 32; 64; 128; 27; 54]%Z ((Z.to_nat i) - 1). From 1a36dae40f5211133e8a4eb3a828b4d485b114fd Mon Sep 17 00:00:00 2001 From: bshvass Date: Sat, 10 Dec 2022 02:19:50 +0100 Subject: [PATCH 297/383] use identifier instead of concrete set of Locations this solution is much more clever and avoids expensive computations --- theories/Jasmin/examples/aes/aes.v | 117 +---------------------------- 1 file changed, 3 insertions(+), 114 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes.v b/theories/Jasmin/examples/aes/aes.v index 32fbc19e..5e053041 100644 --- a/theories/Jasmin/examples/aes/aes.v +++ b/theories/Jasmin/examples/aes/aes.v @@ -1049,99 +1049,12 @@ Notation KEY_EXPAND := (xO (xI (xO (xO xH)))). Notation KEYS_EXPAND := (xO (xO (xI xH))). Infix "^" := wxor. - -Definition get_vars_Sv {eft ept} P fname : Sv.t := -match (assoc (@p_funcs _ _ eft ept P) fname) with - | Some f => vars_c (f_body f) - | None => Sv.empty - end. - -Definition fset_of_Sv (fc_id : p_id) (t : Sv.t) : {fset Location} := - Sv.fold (fun e s => translate_var fc_id e |: s) t fset0. - -Fixpoint get_vars_for (ws : seq Z) (m_id : p_id) (c : {fset Location} -> p_id -> p_id * {fset Location}) (acc : {fset Location}) (s_id : p_id) := - match ws with - | [] => acc - | w :: ws => - let (s_id1, locs1) := c acc s_id in - get_vars_for ws m_id c locs1 s_id1 - end. -Definition fvars := seq (funname * (p_id -> {fset Location})). -Definition get_vars_call (f : funname) (fs : fvars) := - match (assoc fs f) with - | Some fv => fv - | None => (fun s_id => fset0) - end. -Fixpoint get_vars_instr_r (ws_def : seq Z) (fs : fvars) (i : instr_r) (m_id : p_id) (acc : {fset Location}) (s_id : p_id) {struct i} : p_id * {fset Location} -with get_vars_instr (ws_def : seq Z) (fs : fvars) (i : instr) (m_id : p_id) (acc : {fset Location}) (s_id : p_id) {struct i} : p_id * {fset Location} := - get_vars_instr_r ws_def fs (instr_d i) m_id acc s_id. -Proof. - pose proof - (get_vars_cmd := - fix get_vars_cmd (ws_def : seq Z) (fs : fvars) (c : cmd) (m_id : p_id) (acc : {fset Location}) (s_id : p_id) {struct c} : p_id * {fset Location} := - match c with - | [::] => (s_id, acc) - | i :: c => - let (s_id1, acc') := get_vars_instr ws_def fs i m_id acc s_id in - let (s_id2, acc'') := get_vars_cmd ws_def fs c m_id acc' s_id1 in - (s_id2, acc'') - end). - refine - (match i with - | Cassgn l _ s e => (s_id, acc) - | Copn ls _ o es => (s_id, acc) - | Cif e c1 c2 => - let (s_id1, locs1) := get_vars_cmd ws_def fs c1 m_id acc s_id in - let (s_id2, locs2) := get_vars_cmd ws_def fs c2 m_id locs1 s_id1 in - (s_id2, locs2) - | Cfor i r c => - let '(d, lo, hi) := r in - let ws := - match lo, hi with - | Pconst vlo, Pconst vhi => wrange d vlo vhi - | _, _ => ws_def - end in - let (s_id', fresh) := fresh_id s_id in - let cᵗ := get_vars_cmd ws fs c m_id in - (s_id', get_vars_for ws m_id cᵗ acc fresh) - | Ccall ii xs f args => - let (s_id', fresh) := fresh_id s_id in - (s_id', acc :|: get_vars_call f fs fresh) - | _ => (s_id, acc) - end). -Defined. - -Fixpoint get_vars_cmd (ws_def : seq Z) (fs : fvars) (c : cmd) (m_id : p_id) (acc : {fset Location}) (s_id : p_id) {struct c} : p_id * {fset Location} := - match c with - | [::] => (s_id, acc) - | i :: c => - let (s_id1, acc') := get_vars_instr ws_def fs i m_id acc s_id in - let (s_id2, acc'') := get_vars_cmd ws_def fs c m_id acc' s_id1 in - (s_id2, acc'') - end. - -Fixpoint get_vars_funs (ws_def : seq Z) (fs : seq _ufun_decl) : fvars := - match fs with - | [::] => [::] - | f :: fs' => - let '(fn, f_extra) := f in - let fvs := get_vars_funs ws_def fs' in - (* let fps := fun s_id => foldr (fun v locs => translate_var s_id (v_var v) |: locs) fset0 (f_params f_extra) in *) - let fv := fun s_id => (get_vars_cmd ws_def fvs (f_body f_extra) s_id (fset_of_Sv s_id (vars_c (f_body f_extra))) s_id).2 in - (fn, fv) :: fvs - end. -Definition get_vars_prog {ept} (ws_def : seq Z) (P : _prog unit ept) := - get_vars_funs ws_def (p_funcs P). - Definition ws_def : seq Z := [::]. Definition get_tr := get_translated_fun ssprove_jasmin_prog. -Definition get_vars {eft ept} P fname fc_id := fset_of_Sv fc_id (@get_vars_Sv eft ept P fname). - -Definition pdisj (P : precond) (L : {fset Location}) := - forall h1 h2 l v, l \in L -> ( (P ((set_heap h1 l v), h2)) <-> P (h1, h2)). -Ltac tvars H := unfold get_vars, get_vars_Sv, fset_of_Sv, Sv.fold in H; simpl in H. +Definition pdisj (P : precond) (s_id : p_id) := + forall h1 h2 l a v s_id', l = translate_var s_id' v -> (s_id ⪯ s_id') -> (P ((set_heap h1 l a), h2) <-> P (h1, h2)). Ltac solve_in := repeat match goal with @@ -1168,8 +1081,6 @@ Fixpoint list_to_chtuple (l : list typed_chElement) : lchtuple [seq t.π1 | t <- Notation trp := (translate_prog' ssprove_jasmin_prog).1. Notation trc := (fun fn i => translate_call ssprove_jasmin_prog fn trp i). -Notation vp := (get_vars_prog ws_def ssprove_jasmin_prog). -Notation vc := (fun fn i => get_vars_call fn vp i). (* I use trc to be able to reuse statements about the function inside other functions where theyll appear as translate_calls (and not get_translated_funs). Furthermore, I think this is necessary to assure that all calls gets the complete list of translated functions. @@ -1179,36 +1090,15 @@ Notation vc := (fun fn i => get_vars_call fn vp i). Notation JRCON i j := (trc RCON i [('int ; j)]). (* Notation JRCON (j : Z) := (get_tr RCON i [('int ; j)]). *) -Notation JRCON_vars i := (vc RCON i). -(* Notation JRCON_vars i := (get_vars ssprove_jasmin_prog RCON i). *) -Goal JRCON_vars 1%positive = fset0. - unfold get_vars_call. simpl. cbn. - Abort. Notation JKEY_COMBINE i rkey temp1 temp2 := (trc KEY_COMBINE i [('word U128 ; rkey) ; ('word U128 ; temp1) ; ('word U128 ; temp2)]). (* Notation JKEY_COMBINE rkey temp1 temp2 := (get_tr KEY_COMBINE i [('word U128 ; rkey) ; ('word U128 ; temp1) ; ('word U128 ; temp2)]). *) -Notation JKEY_COMBINE_vars i := (vc KEY_COMBINE i). -(* Notation JKEY_COMBINE_vars i := (get_vars ssprove_jasmin_prog KEY_COMBINE i). *) -Goal JKEY_COMBINE_vars 1%positive = fset0. - unfold get_vars_call. simpl. cbn. - Abort. Notation JKEY_EXPAND i rcon rkey temp2 := (trc KEY_EXPAND i [ ('int ; rcon) ; ('word U128 ; rkey) ; ('word U128 ; temp2) ]). (* Notation JKEY_EXPAND rcon rkey temp2 := (get_tr KEY_EXPAND i [ ('int ; rcon) ; ('word U128 ; rkey) ; ('word U128 ; temp2) ]). *) -Notation JKEY_EXPAND_vars i := (vc KEY_EXPAND i). -(* Notation JKEY_EXPAND_vars i := (get_vars ssprove_jasmin_prog KEY_EXPAND intro). *) -(* this is slow and I'm not sure why. *) -Goal JKEY_EXPAND_vars 1%positive = fset0. - unfold get_vars_call. simpl. cbn. - Abort. Notation JKEYS_EXPAND i rkey := (trc KEYS_EXPAND i [('word U128 ; rkey)]). (* Notation JKEYS_EXPAND rkey := (get_tr KEYS_EXPAND i [('word U128 ; rkey)]). *) -Notation JKEYS_EXPAND_vars i := (vc KEYS_EXPAND i). -(* Notation JKEYS_EXPAND_vars i := (get_vars ssprove_jasmin_prog KEYS_EXPAND i). *) -Goal JKEYS_EXPAND_vars 1%positive = fset0. - unfold get_vars_call. simpl. cbn. - Abort. Definition rcon (i : Z) : Z := nth 54%Z [:: 1; 2; 4; 8; 16; 32; 64; 128; 27; 54]%Z ((Z.to_nat i) - 1). @@ -1227,7 +1117,7 @@ Definition key_expand (wn1 : u128) (rcon : u8) : 'word U128 := wcat [tuple w4; w5; w6; w7]. Lemma rcon_correct id0 pre i : - (pdisj pre (JRCON_vars id0)) -> + (pdisj pre id0) -> (1 <= i < 10)%Z -> ⊢ ⦃ fun '(s0, s1) => pre (s0, s1) ⦄ JRCON id0 i ≈ ret ([('int ; rcon i)] : tchlist) @@ -1236,7 +1126,6 @@ Proof. unfold get_tr, get_translated_fun. intros Hpdisj H. simpl_fun. - tvars Hpdisj. repeat setjvars. repeat match goal with | |- context[(?a =? ?b)%Z] => let E := fresh in destruct (a =? b)%Z eqn:E; [rewrite ?Z.eqb_eq in E; subst|] From bf059b2bd45ee66f0ff58f34d39bdfe11f606843 Mon Sep 17 00:00:00 2001 From: bshvass Date: Sat, 10 Dec 2022 02:29:09 +0100 Subject: [PATCH 298/383] finish an SSProve proof as sanity check --- theories/Jasmin/examples/aes/aes.v | 137 +++++++++++++++++++++++++++-- 1 file changed, 132 insertions(+), 5 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes.v b/theories/Jasmin/examples/aes/aes.v index 2031b2a1..9da25d7a 100644 --- a/theories/Jasmin/examples/aes/aes.v +++ b/theories/Jasmin/examples/aes/aes.v @@ -1141,19 +1141,146 @@ Proof. + intros. unfold set_lhs in *. destruct H0 as [s0 []]. exists (set_heap s0 c 1%Z). subst. split. - * apply Hpdisj. 1: solve_in. + * eapply Hpdisj. 1-2: reflexivity. assumption. * rewrite set_heap_commut. 1: reflexivity. apply injective_translate_var3. auto. + eapply r_ret. intros; split. * destruct H0 as [s0 []]. subst. - apply Hpdisj. 1: solve_in. + eapply Hpdisj. 1-2: reflexivity. assumption. * split. all: easy. - (* the remaining cases are similar, but should be automated *) -Admitted. -(* Qed. *) + - simpl. eapply r_put_lhs. + ssprove_contract_put_get_lhs; eapply r_put_lhs; rewrite ?coerce_to_choice_type_K. + eapply r_restore_lhs. + + intros. unfold set_lhs in *. + destruct H1 as [s0 []]. + exists (set_heap s0 c 2%Z). subst. split. + * eapply Hpdisj. 1-2: reflexivity. + assumption. + * rewrite set_heap_commut. 1: reflexivity. + apply injective_translate_var3. auto. + + eapply r_ret. + intros; split. + * destruct H1 as [s0 []]. subst. + eapply Hpdisj. 1-2: reflexivity. + assumption. + * split. all: easy. + - simpl. eapply r_put_lhs. + ssprove_contract_put_get_lhs; eapply r_put_lhs; rewrite ?coerce_to_choice_type_K. + eapply r_restore_lhs. + + intros s0 s1 Hheap. unfold set_lhs in *. + destruct Hheap as [s2 []]. + exists (set_heap s2 c 4%Z). subst. split. + * eapply Hpdisj. 1-2: reflexivity. + assumption. + * rewrite set_heap_commut. 1: reflexivity. + apply injective_translate_var3. auto. + + eapply r_ret. + intros s0 s1 Hheap; split. + * destruct Hheap as [s2 []]. subst. + eapply Hpdisj. 1-2: reflexivity. + assumption. + * split. all: easy. + - simpl. eapply r_put_lhs. + ssprove_contract_put_get_lhs; eapply r_put_lhs; rewrite ?coerce_to_choice_type_K. + eapply r_restore_lhs. + + intros s0 s1 Hheap. unfold set_lhs in *. + destruct Hheap as [s2 []]. + exists (set_heap s2 c 8%Z). subst. split. + * eapply Hpdisj. 1-2: reflexivity. + assumption. + * rewrite set_heap_commut. 1: reflexivity. + apply injective_translate_var3. auto. + + eapply r_ret. + intros s0 s1 Hheap; split. + * destruct Hheap as [s2 []]. subst. + eapply Hpdisj. 1-2: reflexivity. + assumption. + * split. all: easy. + - simpl. eapply r_put_lhs. + ssprove_contract_put_get_lhs; eapply r_put_lhs; rewrite ?coerce_to_choice_type_K. + eapply r_restore_lhs. + + intros s0 s1 Hheap. unfold set_lhs in *. + destruct Hheap as [s2 []]. + exists (set_heap s2 c 16%Z). subst. split. + * eapply Hpdisj. 1-2: reflexivity. + assumption. + * rewrite set_heap_commut. 1: reflexivity. + apply injective_translate_var3. auto. + + eapply r_ret. + intros s0 s1 Hheap; split. + * destruct Hheap as [s2 []]. subst. + eapply Hpdisj. 1-2: reflexivity. + assumption. + * split. all: easy. + - simpl. eapply r_put_lhs. + ssprove_contract_put_get_lhs; eapply r_put_lhs; rewrite ?coerce_to_choice_type_K. + eapply r_restore_lhs. + + intros s0 s1 Hheap. unfold set_lhs in *. + destruct Hheap as [s2 []]. + exists (set_heap s2 c 32%Z). subst. split. + * eapply Hpdisj. 1-2: reflexivity. + assumption. + * rewrite set_heap_commut. 1: reflexivity. + apply injective_translate_var3. auto. + + eapply r_ret. + intros s0 s1 Hheap; split. + * destruct Hheap as [s2 []]. subst. + eapply Hpdisj. 1-2: reflexivity. + assumption. + * split. all: easy. + - simpl. eapply r_put_lhs. + ssprove_contract_put_get_lhs; eapply r_put_lhs; rewrite ?coerce_to_choice_type_K. + eapply r_restore_lhs. + + intros s0 s1 Hheap. unfold set_lhs in *. + destruct Hheap as [s2 []]. + exists (set_heap s2 c 64%Z). subst. split. + * eapply Hpdisj. 1-2: reflexivity. + assumption. + * rewrite set_heap_commut. 1: reflexivity. + apply injective_translate_var3. auto. + + eapply r_ret. + intros s0 s1 Hheap; split. + * destruct Hheap as [s2 []]. subst. + eapply Hpdisj. 1-2: reflexivity. + assumption. + * split. all: easy. + - simpl. eapply r_put_lhs. + ssprove_contract_put_get_lhs; eapply r_put_lhs; rewrite ?coerce_to_choice_type_K. + eapply r_restore_lhs. + + intros s0 s1 Hheap. unfold set_lhs in *. + destruct Hheap as [s2 []]. + exists (set_heap s2 c 128%Z). subst. split. + * eapply Hpdisj. 1-2: reflexivity. + assumption. + * rewrite set_heap_commut. 1: reflexivity. + apply injective_translate_var3. auto. + + eapply r_ret. + intros s0 s1 Hheap; split. + * destruct Hheap as [s2 []]. subst. + eapply Hpdisj. 1-2: reflexivity. + assumption. + * split. all: easy. + - simpl. eapply r_put_lhs. + ssprove_contract_put_get_lhs; eapply r_put_lhs; rewrite ?coerce_to_choice_type_K. + eapply r_restore_lhs. + + intros s0 s1 Hheap. unfold set_lhs in *. + destruct Hheap as [s2 []]. + exists (set_heap s2 c 27%Z). subst. split. + * eapply Hpdisj. 1-2: reflexivity. + assumption. + * rewrite set_heap_commut. 1: reflexivity. + apply injective_translate_var3. auto. + + eapply r_ret. + intros s0 s1 Hheap; split. + * destruct Hheap as [s2 []]. subst. + eapply Hpdisj. 1-2: reflexivity. + assumption. + * split. all: easy. + - lia. +Qed. (* copy of the easycrypt functional definition *) Definition W4u8 : 4.-tuple u8 -> u32 := wcat. From 7d1b31bd45d4dc7fafb4f925cd95697e52b84b0e Mon Sep 17 00:00:00 2001 From: bshvass Date: Sun, 11 Dec 2022 01:02:53 +0100 Subject: [PATCH 299/383] cleaning --- theories/Jasmin/examples/aes/aes.v | 98 +++--------------------------- 1 file changed, 10 insertions(+), 88 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes.v b/theories/Jasmin/examples/aes/aes.v index 9da25d7a..0261c367 100644 --- a/theories/Jasmin/examples/aes/aes.v +++ b/theories/Jasmin/examples/aes/aes.v @@ -1846,8 +1846,7 @@ Proof. unfold key_expand. apply W4u32_eq. intros [[ | [ | [ | [ | i]]]] j]; simpl; unfold tnth; simpl. - - - rewrite !subword_xor. + - rewrite !subword_xor. rewrite mul0n. unfold lift2_vec. rewrite !subword_0_32_128. @@ -1863,15 +1862,12 @@ Proof. rewrite !wshr0. rewrite !subword_make_vec_32_0_32_128. simpl. - unfold wAESKEYGENASSIST. rewrite subword_wshr. rewrite subword_make_vec_32_3_32_128. simpl. - rewrite !wxorA. f_equal. - unfold wpshufd1. simpl. rewrite wshr0. @@ -1885,8 +1881,7 @@ Proof. rewrite wreprI. reflexivity. all: auto. - - - simpl. + - simpl. unfold lift2_vec. rewrite !make_vec_ws. rewrite mul1n. @@ -1918,9 +1913,7 @@ Proof. rewrite wreprI. reflexivity. all: try auto. - - - - simpl. + - simpl. unfold lift2_vec. rewrite !make_vec_ws. rewrite mul1n. @@ -1955,8 +1948,7 @@ Proof. rewrite wreprI. reflexivity. all: try auto. - - - simpl. + - simpl. unfold lift2_vec. rewrite !make_vec_ws. rewrite mul1n. @@ -1994,47 +1986,7 @@ Proof. rewrite wreprI. reflexivity. all: auto. - lia. -Qed. - -Lemma key_expand1_correct id0 rcon rkey temp2 rcon_ : - toword rcon_ = rcon -> - subword 0 U32 temp2 = word0 -> - ⊢ ⦃ fun _ => True ⦄ - l ← (JKEY_EXPAND id0 rcon rkey temp2) ;; - ret (nth ('word U128 ; chCanonical _) l 0%nat) - ⇓ ('word U128 ; (key_expand rkey rcon_)) - ⦃ fun _ => True ⦄. -Proof. - intros H1 H2. - unfold get_tr, get_translated_fun. - - simpl_fun. repeat setjvars. - rewrite !zero_extend_u. - rewrite !coerce_to_choice_type_K. - - unfold eval_jdg. - repeat clear_get. - - unfold sopn_sem. - unfold tr_app_sopn_tuple. - unfold tr_app_sopn_single. - - simpl. - - rewrite !zero_extend_u. - rewrite !coerce_to_choice_type_K. - - repeat eapply u_put. - eapply u_ret. - - split. easy. - - unfold totce. - f_equal. - apply key_expand_aux. - assumption. - assumption. + - lia. Qed. Lemma key_expand_aux2 rkey temp2 : @@ -2060,42 +2012,11 @@ Proof. auto. auto. Qed. -Lemma key_expand2_correct id0 rcon rkey temp2 : - subword 0 U32 temp2 = word0 -> - ⊢ ⦃ fun _ => True ⦄ - l ← (JKEY_EXPAND id0 rcon rkey temp2) ;; - ret (subword 0 U32 (pr ('word U128) l 1%nat)) - ⇓ word0 - ⦃ fun _ => True ⦄. -Proof. - intros H. - simpl_fun. - repeat setjvars. - - unfold eval_jdg. - repeat clear_get. - - unfold sopn_sem. - unfold tr_app_sopn_tuple. - unfold tr_app_sopn_single. - - simpl. - - rewrite !zero_extend_u. - rewrite !coerce_to_choice_type_K. - - repeat eapply u_put. - eapply u_ret. - - split. easy. - apply key_expand_aux2. - assumption. -Qed. Ltac pdisj_apply h := lazymatch goal with | |- ?pre (set_heap _ _ _, _) => - eapply h ; [ solve_in | pdisj_apply h ] + eapply h ; [ reflexivity | auto with preceq | pdisj_apply h ] | |- _ => try assumption end. @@ -2389,7 +2310,6 @@ Proof. assert ((0 <=? j * wsize_size ws + a0 - i * mk_scale AAscale ws) && (j * wsize_size ws + a0 - i * mk_scale AAscale ws /InP. rewrite in_ziota=>/andP [] H1 h2. nia. - rewrite H0. reflexivity. Qed. @@ -2415,14 +2335,16 @@ Proof. change (∀ z : Z, 0 <= z -> z <= i < z + len → (is_true (@in_mem (Ord.sort Z_ordType) i (@ssrbool.mem (Equality.sort (Ord.eqType Z_ordType)) (seq_predType (Ord.eqType Z_ordType)) (ziota z len)))) ) with ((fun len => ((forall z, 0 <= z -> z <= i < z + len -> - (is_true (@in_mem (Ord.sort Z_ordType) i (@ssrbool.mem (Equality.sort (Ord.eqType Z_ordType)) (seq_predType (Ord.eqType Z_ordType)) (ziota z len)))) + (is_true (@in_mem (Ord.sort Z_ordType) i (@ssrbool.mem (Equality.sort (Ord.eqType Z_ordType)) (seq_predType (Ord.eqType Z_ordType)) (ziota z len)))) ))) len). apply natlike_ind. - intros z Hz Hz2. lia. - intros x Hx Ih z Hz Hz2. rewrite ziotaS_cons. destruct (Z.eq_dec z i). + rewrite in_cons. apply/orP. left. apply/eqP. easy. - + rewrite in_cons. apply/orP. right. apply Ih. lia. lia. lia. assumption. } + + rewrite in_cons. apply/orP. right. apply Ih. lia. lia. + + lia. + - assumption. } rewrite H0. reflexivity. Qed. From fa7efcda26d2ac685136cc23889cb8cda21406e1 Mon Sep 17 00:00:00 2001 From: bshvass Date: Sun, 11 Dec 2022 01:03:33 +0100 Subject: [PATCH 300/383] more cleaning --- theories/Jasmin/examples/aes/aes.v | 27 +++++++++++++-------------- 1 file changed, 13 insertions(+), 14 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes.v b/theories/Jasmin/examples/aes/aes.v index 0261c367..76fbcff0 100644 --- a/theories/Jasmin/examples/aes/aes.v +++ b/theories/Jasmin/examples/aes/aes.v @@ -1066,29 +1066,28 @@ Ltac solve_in := end. Fixpoint list_to_chtuple (l : list typed_chElement) : lchtuple [seq t.π1 | t <- l] := - match l as l0 - return lchtuple [seq t.π1 | t <- l0] + match l as l0 return lchtuple [seq t.π1 | t <- l0] with | [] => tt | tc' :: l' => - let rec := @list_to_chtuple l' in - match l' as l'0 - return - lchtuple [seq t.π1 | t <- l'0] -> - lchtuple [seq t.π1 | t <- (tc'::l'0)] - with - | [] => fun _ => tc'.π2 - | tc'' :: l'' => fun rec => (tc'.π2, rec) - end rec + let rec := @list_to_chtuple l' in + match l' as l'0 + return + lchtuple [seq t.π1 | t <- l'0] -> + lchtuple [seq t.π1 | t <- (tc'::l'0)] + with + | [] => fun _ => tc'.π2 + | tc'' :: l'' => fun rec => (tc'.π2, rec) + end rec end. Notation trp := (translate_prog' ssprove_jasmin_prog).1. Notation trc := (fun fn i => translate_call ssprove_jasmin_prog fn trp i). (* I use trc to be able to reuse statements about the function inside other functions where theyll appear as translate_calls (and not get_translated_funs). - Furthermore, I think this is necessary to assure that all calls gets the complete list of translated functions. - Otherwise result might depend on which buffer of translated functions gets passed to the call. - In this construction we always use all of them, opposed to get_translated_fun which just uses the necessary ones (I believe). + Furthermore, I think this is necessary to assure that all calls gets the complete list of translated functions. + Otherwise result might depend on which buffer of translated functions gets passed to the call. + In this construction we always use all of them, opposed to get_translated_fun which just uses the necessary ones (I believe). *) Notation JRCON i j := (trc RCON i [('int ; j)]). From 1793b5b4119bb8db341d202d7861956172ad0418 Mon Sep 17 00:00:00 2001 From: bshvass Date: Sun, 11 Dec 2022 01:05:38 +0100 Subject: [PATCH 301/383] redefine `pdisj` and reprove `rcon` and `key_expand` correctness Now we use the 'stackframes' of the functions to distinguish between which variables are allowed to be used, instead of computing the sets explicityly. This seems cleaner, and avoids the variable computation. Now we have to prove that variables always avoids these stackframes; this can be partially automated. --- theories/Jasmin/examples/aes/aes.v | 71 ++++++++++++++++++------------ 1 file changed, 44 insertions(+), 27 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes.v b/theories/Jasmin/examples/aes/aes.v index 76fbcff0..12e9e97d 100644 --- a/theories/Jasmin/examples/aes/aes.v +++ b/theories/Jasmin/examples/aes/aes.v @@ -1057,7 +1057,7 @@ Definition ws_def : seq Z := [::]. Definition get_tr := get_translated_fun ssprove_jasmin_prog. Definition pdisj (P : precond) (s_id : p_id) := - forall h1 h2 l a v s_id', l = translate_var s_id' v -> (s_id ⪯ s_id') -> (P ((set_heap h1 l a), h2) <-> P (h1, h2)). + forall h1 h2 l a v s_id', l = translate_var s_id' v -> (s_id ⪯ s_id') -> (P (h1, h2) -> P ((set_heap h1 l a), h2)). Ltac solve_in := repeat match goal with @@ -1120,7 +1120,7 @@ Definition key_expand (wn1 : u128) (rcon : u8) : 'word U128 := Lemma rcon_correct id0 pre i : (pdisj pre id0) -> - (1 <= i < 10)%Z -> + (forall s0 s1, pre (s0, s1) -> (1 <= i < 11)%Z) -> ⊢ ⦃ fun '(s0, s1) => pre (s0, s1) ⦄ JRCON id0 i ≈ ret ([('int ; rcon i)] : tchlist) ⦃ fun '(v0, s0) '(v1, s1) => pre (s0, s1) /\ v0 = v1 /\ v1 = ([('int ; rcon i)] : tchlist) ⦄. @@ -1278,7 +1278,24 @@ Proof. eapply Hpdisj. 1-2: reflexivity. assumption. * split. all: easy. - - lia. + - destruct (i =? 10)%Z eqn:E. rewrite Z.eqb_eq in E. subst. + simpl. eapply r_put_lhs. + ssprove_contract_put_get_lhs; eapply r_put_lhs; rewrite ?coerce_to_choice_type_K. + eapply r_restore_lhs. + + intros s0 s1 Hheap. unfold set_lhs in *. + destruct Hheap as [s2 []]. + exists (set_heap s2 c 54%Z). subst. split. + * eapply Hpdisj. 1-2: reflexivity. + assumption. + * rewrite set_heap_commut. 1: reflexivity. + apply injective_translate_var3. auto. + + eapply r_ret. + intros s0 s1 Hheap; split. + * destruct Hheap as [s2 []]. subst. + eapply Hpdisj. 1-2: reflexivity. + assumption. + * split. all: easy. + + eapply rpre_hypothesis_rule. intros. apply H in H9. lia. Qed. (* copy of the easycrypt functional definition *) @@ -2011,6 +2028,13 @@ Proof. auto. auto. Qed. +#[global] Hint Resolve preceq_I preceq_O preceq_refl : preceq. +Ltac solve_preceq := + repeat lazymatch goal with + | |- ?a ⪯ ?a => reflexivity + | |- ?a ⪯ ?b~1 => etransitivity; [|apply preceq_I] + | |- ?a ⪯ ?b~0 => etransitivity; [|apply preceq_O] + end. Ltac pdisj_apply h := lazymatch goal with @@ -2020,56 +2044,49 @@ Ltac pdisj_apply h := end. Lemma key_expandP pre id0 rcon rkey temp2 rcon_ : - pdisj pre (JKEY_EXPAND_vars id0) → + pdisj pre id0 → toword rcon_ = rcon → - subword 0 U32 temp2 = word0 → + (forall s0 s1, pre (s0, s1) -> subword 0 U32 temp2 = word0) → ⊢ ⦃ λ '(s0, s1), pre (s0, s1) ⦄ JKEY_EXPAND id0 rcon rkey temp2 ≈ ret tt - ⦃ λ '(v0, s0) '(v1, s1), - pre (s0, s1) ∧ - ∃ o1 o2, - v0 = [ ('word U128 ; o1) ; ('word U128 ; o2) ] ∧ - o1 = key_expand rkey rcon_ ∧ - subword 0 U32 o2 = word0 - ⦄. + ⦃ λ '(v0, s0) '(v1, s1), + pre (s0, s1) ∧ + ∃ o1 o2, + v0 = [ ('word U128 ; o1) ; ('word U128 ; o2) ] ∧ + o1 = key_expand rkey rcon_ ∧ + subword 0 U32 o2 = word0 + ⦄. Proof. intros disj Hrcon Htemp2. - tvars disj. simpl_fun. repeat setjvars. repeat clear_get. - unfold sopn_sem. unfold tr_app_sopn_tuple. unfold tr_app_sopn_single. simpl. - rewrite !zero_extend_u. rewrite !coerce_to_choice_type_K. repeat eapply r_put_lhs. eapply r_ret. intros s0 s1 Hpre. + repeat match goal with | [ H : set_lhs _ _ _ _ |- _ ] => - let sn := fresh in - let Hsn := fresh in - destruct H as [sn [Hsn]] + let sn := fresh in + let Hsn := fresh in + destruct H as [sn [Hsn]] end. split. - (* Goal: prove pre is preserved by using disj; this should be automated *) - - subst. - pdisj_apply disj. - (* TODO: Fix how the variable set is computed: It needs to include the called functions variables as well *) - all: admit. + - subst. pdisj_apply disj. - eexists _, _. intuition eauto. - (* this is key_expand_correct1 *) - + apply key_expand_aux. all: assumption. - + apply key_expand_aux2. assumption. -Admitted. + + apply key_expand_aux. assumption. eapply Htemp2. eassumption. + + apply key_expand_aux2. eapply Htemp2. eassumption. +Qed. Definition getmd {T S} m d i := match @getm T S m i with Some a => a | _ => d end. From db893954f1c56e6af9297b77d6e81f78aaad8565 Mon Sep 17 00:00:00 2001 From: bshvass Date: Sun, 11 Dec 2022 01:07:57 +0100 Subject: [PATCH 302/383] restate `translate_for_rule` and refactor/automate `keyExpansionE` --- theories/Jasmin/examples/aes/aes.v | 537 +++++++++++++++++------------ 1 file changed, 319 insertions(+), 218 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes.v b/theories/Jasmin/examples/aes/aes.v index 12e9e97d..ed9eed8a 100644 --- a/theories/Jasmin/examples/aes/aes.v +++ b/theories/Jasmin/examples/aes/aes.v @@ -2103,18 +2103,6 @@ Definition for_loop' (c : Z -> raw_code 'unit) lo hi := for_list c (wrange UpTo Definition to_arr ws len (a : 'array) := mkfmapf (fun i => chArray_get ws a i (wsize_size ws)) (ziota 0 len). -Notation " 'arr ws " := (chMap 'int ('word ws)) (at level 2) : package_scope. - -Definition rkeys : Location := ( 'arr U128 ; 0%nat ). - -Definition keyExpansion (key : u128) : raw_code ('arr U128) := - #put rkeys := @emptym Z_ordType u128 ;; - rkeys0 ← get rkeys ;; - #put rkeys := setm rkeys0 0 key ;; - for_loop' (fun i => rkeys0 ← get rkeys ;; #put rkeys := setm rkeys0 i (key_expand (zero_extend _ (getmd rkeys0 word0 (i - 1))) (wrepr U8 (rcon i))) ;; ret tt) 1 11 ;; - rkeys0 ← get rkeys ;; - ret rkeys0. - Lemma iota_aux {A} k c n (f : nat -> A) g : (forall a, a \in (iota k n) -> f a = g (a + c)%nat) -> [seq f i | i <- iota k n] = [seq g i | i <- iota (k + c) n]. @@ -2129,7 +2117,6 @@ Proof. apply ex. simpl. rewrite in_cons. - apply/orP. left. apply/eqP. reflexivity. intros a ain. apply ex. simpl. rewrite in_cons. @@ -2175,18 +2162,20 @@ Proof. Qed. Lemma translate_for_rule I lo hi (v : var_i) m_id s_id (body1 : p_id -> p_id * raw_code 'unit) body2 : + (* it is annoying that this is a proof obligation, since its true for all translated programs, but I don't know how to prove the theorem without it *) + (forall s_id', s_id' ⪯ (body1 s_id').1) -> lo <= hi -> - (forall i s_id', (lo <= i < hi) -> - ⊢ ⦃ λ '(s₀, s₁), set_lhs (translate_var m_id v) (truncate_el (vtype v) (i : chInt)) (I i) (s₀, s₁) ⦄ - let (_, body1') := body1 s_id' in - body1' - ≈ body2 i ⦃ λ '(_, s₀) '(_, s₁), I (Z.succ i) (s₀,s₁) ⦄) → + (forall i s_id', (s_id ⪯ s_id') -> (lo <= i < hi) -> + ⊢ ⦃ λ '(s₀, s₁), set_lhs (translate_var m_id v) (truncate_el (vtype v) (i : chInt)) (I i) (s₀, s₁) ⦄ + let (_, body1') := body1 s_id' in + body1' + ≈ body2 i ⦃ λ '(_, s₀) '(_, s₁), I (Z.succ i) (s₀,s₁) ⦄) → ⊢ ⦃ λ '(s₀,s₁), I lo (s₀, s₁)⦄ translate_for v (wrange UpTo lo hi) m_id body1 s_id ≈ for_loop' body2 lo hi ⦃ λ '(_,s₀) '(_,s₁), I hi (s₀,s₁) ⦄. Proof. - intros Hle ih. + intros Hbody1 Hle ih. remember (Z.to_nat (hi - lo)). revert Heqn Hle ih. revert n lo hi s_id. induction n as [|n ih2]; intros. @@ -2202,23 +2191,24 @@ Proof. rewrite -Heqn. simpl. specialize (ih lo s_id) as ih''. + specialize (Hbody1 s_id). destruct (body1 s_id). eapply r_put_lhs. eapply r_bind. - eapply r_transL. - 2: rewrite Z.add_0_r; eapply ih''. - eapply rreflexivity_rule. lia. - intros a0 a1. - replace (iota 1 n) with (iota (0 + 1) n) by f_equal. - rewrite <- iota_aux with (f := fun i => Z.succ lo + Z.of_nat i). - fold translate_for. - replace n with (Z.to_nat (hi - Z.succ lo)) by lia. - specialize (ih2 (Z.succ lo) hi p ltac:(lia) ltac:(lia)). - eapply ih2. - intros i s_id' ile. - specialize (ih i s_id'). - destruct (body1 s_id'). apply ih. lia. - intros a ain. lia. + + eapply r_transL. + 2: rewrite Z.add_0_r; eapply ih''; [ reflexivity | lia ]. + eapply rreflexivity_rule. + + intros a0 a1. + replace (iota 1 n) with (iota (0 + 1) n) by f_equal. + rewrite <- iota_aux with (f := fun i => Z.succ lo + Z.of_nat i) by lia. + replace n with (Z.to_nat (hi - Z.succ lo)) by lia. + specialize (ih2 (Z.succ lo) hi p ltac:(lia) ltac:(lia)). + eapply ih2. + intros i s_id' Hs_id' ile. + specialize (ih i s_id'). + destruct (body1 s_id'). apply ih. + etransitivity. eassumption. assumption. + lia. Qed. Opaque translate_for. @@ -2245,6 +2235,23 @@ Proof. easy. Qed. +Theorem rpre_weak_hypothesis_rule' : + ∀ {A₀ A₁ : ord_choiceType} {p₀ : raw_code A₀} {p₁ : raw_code A₁} + (pre : precond) post, + (∀ s₀ s₁, + pre (s₀, s₁) → ⊢ ⦃ λ '(s0, s1), pre (s0, s1) ⦄ p₀ ≈ p₁ ⦃ post ⦄ + ) → + ⊢ ⦃ pre ⦄ p₀ ≈ p₁ ⦃ post ⦄. +Proof. + intros A₀ A₁ p₀ p₁ pre post h. + eapply rpre_hypothesis_rule'. + intros. eapply rpre_weaken_rule. + eapply h. eassumption. + intros s0' s1' [H0 H1]. + subst. + assumption. +Qed. + Lemma wsize_size_aux (ws : wsize.wsize) : (ws %/ U8 + ws %% U8) = wsize_size ws. Proof. destruct ws; reflexivity. Qed. @@ -2330,8 +2337,8 @@ Proof. reflexivity. Qed. -Lemma getm_to_arr' ws len a i : - (len <= i) -> +Lemma getm_to_arr_None' ws len a (i: Z) : + ((len <=? i) || (i to_arr ws len a i = None. Proof. intros. unfold to_arr. @@ -2403,8 +2410,103 @@ Proof. assumption. Qed. +(* TODO: move these, note they are the same as fresh1 and fresh2 *) +Lemma prec_O : + forall i, i ≺ i~0. +Proof. + simpl; split. + - apply preceq_O. + - apply nesym. apply xO_neq. +Qed. + +Lemma prec_I : + forall i, i ≺ i~1. +Proof. + simpl; split. + - apply preceq_I. + - apply nesym. apply xI_neq. +Qed. + +Lemma rcon_U8 i : + 0 <= rcon i < wbase U8. +Proof. + unfold rcon, wbase, modulus, two_power_nat; simpl. + destruct (10 + let sn := fresh in + let Hsn := fresh in + destruct H as [sn [Hsn]] + | [ H : set_rhs _ _ _ _ |- _ ] => + let sn := fresh in + let Hsn := fresh in + destruct H as [sn [Hsn]] + | [ H : _ /\ _ |- _ ] => + let H1 := fresh in + let H2 := fresh in + destruct H as [H1 H2] + | [ H : (_ ⋊ _) _ |- _ ] => + let H1 := fresh in + let H2 := fresh in + destruct H as [H1 H2] + | [ H : exists _, _ |- _ ] => + let o := fresh in + destruct H as [o] + end; simpl in *; subst. + +Ltac split_post := + repeat + match goal with + | |- (_ ⋊ _) _ => split + | |- _ /\ _ => split + | |- set_lhs _ _ _ _ => eexists + end. + +Ltac neq_loc_auto := solve [ eapply injective_translate_var2; auto | eapply injective_translate_var3; auto ]. + +(* I don't know what rewrite * means, but this is much faster than regular rewrite, which also sometimes overflows the stack *) +Ltac sheap := + repeat first [ rewrite * get_set_heap_neq; [| neq_loc_auto ] | + rewrite * get_set_heap_eq ]. + +(* This works sometimes, but might be very slow *) +Ltac simpl_heap := + repeat lazymatch goal with + | |- context [ get_heap (set_heap _ ?l _) ?l ] => rewrite -> get_set_heap_eq + | |- context [ get_heap (set_heap (translate_var ?s_id _) (translate_var ?s_id _ ) _ ) _ ] => (rewrite -> get_set_heap_neq by (apply injective_translate_var3; auto)) + | |- context [ get_heap (set_heap _ (translate_var _ _ ) _ ) _ ] => (rewrite -> get_set_heap_neq by (apply injective_translate_var2; assumption)) + end. + +Ltac simpl_heap' := + repeat lazymatch goal with + | |- context [ get_heap (set_heap _ _ _) _ ] => + try rewrite -> get_set_heap_eq; + try (rewrite -> get_set_heap_neq by (apply injective_translate_var3; auto)); + try (rewrite -> get_set_heap_neq by (apply injective_translate_var2; assumption)) + end. + +Notation " 'arr ws " := (chMap 'int ('word ws)) (at level 2) : package_scope. + +Definition rkeys : Location := ( 'arr U128 ; 0%nat ). + +Definition keyExpansion (key : u128) : raw_code ('arr U128) := + #put rkeys := @emptym Z_ordType u128 ;; + rkeys0 ← get rkeys ;; + #put rkeys := setm rkeys0 0 key ;; + for_loop' (fun i => rkeys0 ← get rkeys ;; #put rkeys := setm rkeys0 i (key_expand (zero_extend _ (getmd rkeys0 word0 (i - 1))) (wrepr U8 (rcon i))) ;; ret tt) 1 11 ;; + rkeys0 ← get rkeys ;; + ret rkeys0. + Lemma keyExpansionE pre id0 rkey : - (pdisj pre (JKEYS_EXPAND_vars id0)) -> + (pdisj pre id0) -> ⊢ ⦃ fun '(h0, h1) => pre (h0, h1) ⦄ res ← JKEYS_EXPAND id0 rkey ;; ret (to_arr U128 11 (hdtc res)) @@ -2413,203 +2515,202 @@ Lemma keyExpansionE pre id0 rkey : ⦃ fun '(v0, h0) '(v1, h1) => pre (h0, h1) /\ v0 = v1 ⦄. Proof. intros disj. - (* unfold JKEYS_EXPAND. *) - unfold call. (* get_tr, get_translated_fun, translate_prog', translate_funs. *) + unfold translate_call. + Opaque translate_call. Opaque wrange. - simpl. + Opaque for_loop'. - simpl_fun. + simpl. simpl_fun. repeat setjvars. - repeat clear_get. + ssprove_code_simpl. + ssprove_code_simpl_more. + eapply r_put_lhs. - eapply r_get_remember_lhs. - intros v. + eapply r_get_remember_lhs. intros v. eapply r_put_lhs. eapply r_put_lhs. + unfold keyExpansion. eapply r_put_rhs. - eapply r_get_remember_rhs. - intros v0. - Opaque for_loop'. + eapply r_get_remember_rhs. intros v0. eapply r_put_rhs. - rewrite bind_assoc. - rewrite bind_assoc. eapply r_bind. - simpl. - eapply rpre_weaken_rule. - eapply translate_for_rule with (I := fun i => fun '(h0, h1) => pre (h0, h1) /\ (get_heap h0 key = chArray_get U128 (get_heap h0 rkeys) (i - 1) 16) /\ forall j, 0 <= j < i -> (to_arr U128 11 (get_heap h0 rkeys)) j = (get_heap h1 aes.rkeys) j). lia. - intros i s_id ile. - eapply r_get_remember_lhs. - intros x. - - simpl. - rewrite bind_assoc. - eapply r_bind with (m₁ := ret _) (f₁ := fun _ => _). - - epose proof rcon_correct s_id~1 _ x _ _. - eapply H. - intros a0 a1. - simpl. - eapply rpre_hypothesis_rule'. intros s0 s1 [H1 [H2 H3]]. subst. - - destruct H1 as [[s6 []]]. - simpl in *. - subst. - - simpl. repeat clear_get. - eapply r_put_lhs with (pre := λ '(s0',s1'), _ ). - eapply r_get_remember_lhs. intros x0. - eapply r_get_remember_lhs. intros x1. - rewrite bind_assoc. - eapply r_bind with (m₁ := ret _) (f₁ := fun _ => _). - epose proof key_expandP _ (s_id~0~1)%positive (rcon (get_heap (set_heap s6 round i) round)) x0 x1 (wrepr _ (rcon (get_heap (set_heap s6 round i) round))) _ _ _. - rewrite !coerce_to_choice_type_K. - eapply H0. - intros a2 a3. - - eapply rpre_hypothesis_rule'. - intros s2 s3 [H4 [o1 [o2 [H5 [H6 H7]]]]]. - subst. - simpl in *. - - destruct H4 as [[[s7 [[]]]]]. - simpl in *. - subst. - - rewrite !zero_extend_u. - eapply r_put_lhs with (pre := λ '(s0',s1'), _). - eapply r_put_lhs. - - eapply r_get_remember_lhs. intros x2. - eapply r_get_remember_lhs. intros x3. - eapply r_get_remember_lhs. intros x4. - eapply r_put_lhs. - eapply r_get_remember_rhs. intros x5. - eapply r_put_rhs. - eapply r_ret. - intros s4 s5 H8. - - (* all this should be automated *) - destruct H8 as [s7 [[[s8 [[[[[s9 [[s10 [[]]]]]]]]]]]]]. - simpl in *. - subst. - - rewrite get_set_heap_eq. - rewrite get_set_heap_eq. - rewrite get_set_heap_eq. - rewrite get_set_heap_neq. - rewrite get_set_heap_neq. - rewrite get_set_heap_neq. - rewrite get_set_heap_neq. - rewrite get_set_heap_neq. - rewrite get_set_heap_neq. - rewrite get_set_heap_neq. - rewrite get_set_heap_neq. - rewrite get_set_heap_neq. - rewrite get_set_heap_eq. - rewrite get_set_heap_neq. - rewrite get_set_heap_eq. - rewrite get_set_heap_neq. - rewrite get_set_heap_neq. - rewrite get_set_heap_eq. - - rewrite !coerce_to_choice_type_K. - rewrite !zero_extend_u. - split; [|split]. - - (* prove that pre is preserved in the inductive step *) - tvars disj. - apply disj. unfold rkeys. - solve_in. - apply disj. solve_in. - apply disj. solve_in. - apply disj. solve_in. - apply disj. solve_in. - (* what to do with the heap of the rhs? *) admit. - - (* prove the first invariant *) - replace (Z.succ i - 1) with i by lia. - rewrite chArray_get_set_eq. - reflexivity. - - (* prove the second invariant *) - intros j Hj. - destruct (Z.eq_dec i j). - - (* i = j *) - subst. - rewrite to_arr_set_eq. - rewrite setmE. rewrite eq_refl. - destruct H as []. destruct H0. rewrite H0. - f_equal. unfold getmd. rewrite -H1. rewrite getm_to_arr. - f_equal. lia. lia. lia. - - (* i <> j *) - rewrite to_arr_set_neq. - rewrite setmE. - assert (@eq bool (@eq_op Z_ordType j i) false). apply/eqP. auto. - rewrite H0. - apply H. lia. assumption. lia. - - (* trivial *) - 1-12: neq_loc_auto. - - (* prove base case *) - intros s0 s1 H. - destruct H as [s2 [[[s3 [[s4 [[s5 [[[s6 []]]]]]]]]]]]. - simpl in *; subst. - - rewrite get_set_heap_eq. - rewrite get_set_heap_neq. - rewrite get_set_heap_eq. - rewrite get_set_heap_neq. - rewrite get_set_heap_neq. - rewrite get_set_heap_eq. - rewrite get_set_heap_neq. - rewrite get_set_heap_eq. - - rewrite !coerce_to_choice_type_K. - rewrite !zero_extend_u. - split; [|split]. - - (* prove that pre is preserved *) admit. - - (* first invariant *) - rewrite chArray_get_set_eq. reflexivity. - - (* second invariant *) - intros j Hj. assert (j = 0) by lia. subst. - rewrite to_arr_set_eq. rewrite setmE. rewrite eq_refl. reflexivity. - lia. - 1-4: neq_loc_auto. + - simpl. + eapply rpre_weaken_rule. + + eapply translate_for_rule with + (I := fun i => fun '(h0, h1) => pre (h0, h1) + /\ subword 0 U32 (get_heap h0 temp2) = word0 + /\ (get_heap h0 key = chArray_get U128 (get_heap h0 rkeys) (i - 1) 16) + /\ forall j, 0 <= j < i -> (to_arr U128 11 (get_heap h0 rkeys)) j = (get_heap h1 aes.rkeys) j). + (* the two following bullets are small assumptions of the translate_for rule *) + * intros. simpl. solve_preceq. + * lia. + (* Inductive step of the for loop rule, we have to prove the bodies are equivalent and imply the successor predicate *) + * intros i s_id Hs_id ile. + ssprove_code_simpl. + + (* NB: Do not rewrite here, since it breaks unification when trying to apply other correctness lemmas *) + (* rewrite !coerce_to_choice_type_K. *) + + eapply r_get_remember_lhs. intros. + + (* Now we apply the correctnes of rcon *) + eapply r_bind with (m₁ := ret _) (f₁ := fun _ => _). + ** eapply rcon_correct with (id0 := (s_id~1)%positive) (i:=x). + (* We have to prove the precond is disjoint from the variables of rcon, i.e. any variables stored locally in rcon does not change the precond *) + *** intros s0 s1 l a vr s_id' Hl Hs_id' H. + assert (id0_preceq : id0 ⪯ s_id'). { + etransitivity. eapply preceq_I. etransitivity. eassumption. etransitivity. eapply preceq_I. eassumption. + } + assert (id0_neq : id0 <> s_id'). { + apply prec_neq. eapply prec_preceq_trans. eapply preceq_prec_trans. etransitivity. eapply preceq_I. eassumption. eapply prec_I. assumption. + } + intros. destruct_pre. split_post. + { eapply disj. reflexivity. eassumption. eassumption. } + { sheap. assumption. } + { sheap. assumption. } + { sheap. assumption. } + { rewrite set_heap_commut. reflexivity. + apply injective_translate_var2. assumption. } + { simpl. sheap. reflexivity. } + (* this is an assumption of rcon_correct *) + *** intros; destruct_pre. fold round. sheap. rewrite coerce_to_choice_type_K. lia. + (* we continue after the rcon call *) + ** intros a0 a1. + simpl; ssprove_code_simpl. + (* we need to know the value of a0 here *) + eapply rpre_weak_hypothesis_rule'; intros. + destruct_pre; simpl. + repeat clear_get. + eapply r_put_lhs with (pre := λ '(s0',s1'), _ ). + eapply r_get_remember_lhs. intros x0. + eapply r_get_remember_lhs. intros x1. + sheap. + + eapply r_bind with (m₁ := ret _) (f₁ := fun _ => _). + + (* First we apply correctness of key_expandP *) + *** (* Here the rewrite is necessary. How should correctness be phrased in general such that this is not important? *) + rewrite !coerce_to_choice_type_K. + + eapply key_expandP with (id0 := (s_id~0~1)%positive) (rcon :=(rcon i)) (rkey := x0) (temp2 := x1) (rcon_ := wrepr _ (rcon i)). + (* again, we have to prove that our precond does not depend key_expand locations *) + { intros s0 s1 l a vr s_id' Hl Hs_id' H. + assert (id0_preceq : id0 ⪯ s_id'). { + etransitivity. eapply preceq_I. etransitivity. eassumption. etransitivity. eapply preceq_O. etransitivity. eapply preceq_I. eassumption. + } + assert (id0_neq : id0 <> s_id'). { + apply prec_neq. eapply prec_preceq_trans. eapply preceq_prec_trans. etransitivity. eapply preceq_I. eassumption. eapply prec_O. etransitivity. eapply prec_I. assumption. + } + destruct_pre. sheap. split_post. + { eapply disj. reflexivity. eassumption. eassumption. } + { sheap; assumption. } + { sheap; assumption. } + { sheap; assumption. } + { reflexivity. } + { simpl. sheap. reflexivity. } + { reflexivity. } + { reflexivity. } + { rewrite set_heap_commut; [ | neq_loc_auto ]. + rewrite [set_heap _ _ a](set_heap_commut); [ | neq_loc_auto ]. + reflexivity. } + { simpl. sheap. reflexivity. } + { simpl. sheap. reflexivity. } + } + (* this is an assumption of key_expandP, true by definition of rcon *) + { apply wunsigned_repr_small. apply rcon_U8. } + { intros. destruct_pre. sheap. assumption. } + (* we continue after the call *) + *** intros. + eapply rpre_weak_hypothesis_rule'. + intros; destruct_pre. simpl. + rewrite !zero_extend_u. + + eapply r_put_lhs with (pre := λ '(s0',s1'), _). + eapply r_put_lhs. + eapply r_get_remember_lhs. intros x2. + eapply r_get_remember_lhs. intros x3. + eapply r_get_remember_lhs. intros x4. + eapply r_put_lhs. + eapply r_get_remember_rhs. intros x5. + eapply r_put_rhs. + eapply r_ret. + + sheap. + rewrite !coerce_to_choice_type_K. + rewrite !zero_extend_u. + intros s6 s7 H25. + + destruct_pre. + sheap. + + split_post. + (* here we prove that the invariant is preserved after a single loop, assuming it holds before *) + { pdisj_apply disj. admit. (* rhs *) } + { assumption. } + { replace (Z.succ i - 1) with i by lia. + rewrite chArray_get_set_eq. + reflexivity. } + { intros j Hj. + destruct (Z.eq_dec i j). + + (* i = j *) + subst. + rewrite to_arr_set_eq. + rewrite setmE. rewrite eq_refl. + + f_equal. unfold getmd. rewrite -H42. rewrite getm_to_arr. + f_equal. rewrite !get_set_heap_neq in H32. rewrite -H32. assumption. + neq_loc_auto. neq_loc_auto. lia. lia. lia. + + (* i <> j *) + rewrite to_arr_set_neq. + rewrite setmE. + assert (@eq bool (@eq_op Z_ordType j i) false). apply/eqP. auto. + rewrite H2. + apply H42. lia. assumption. lia. } + (* the next bullet is the proof that the invariant of the for loop is true at the beginning (this goal is generated by pre_weaken rule and translate_for) *) + + intros s0 s1 H. + destruct_pre. + sheap. + + rewrite !coerce_to_choice_type_K. + rewrite !zero_extend_u. + + split_post. + (* prove that pre is preserved *) + * pdisj_apply disj. + (* the rhs *) + admit. + (* first invariant *) + * simpl. unfold tr_app_sopn_tuple. simpl. rewrite subword_word0. reflexivity. + (* second invariant *) + * rewrite chArray_get_set_eq. reflexivity. + (* third invariant *) + * intros j Hj. assert (j = 0) by lia. subst. + rewrite to_arr_set_eq. rewrite setmE. rewrite eq_refl. reflexivity. lia. (* after for loop *) - intros a0 a1. - simpl. - eapply r_get_remember_lhs with (pre := fun '(s0, s1) => _). - intros x. - eapply r_get_remember_rhs. - intros x0. - eapply r_ret. - intros s0 s1 H. - destruct H as [[[]]]. - destruct H0. - simpl in *. subst. - split. assumption. - eapply eq_fmap. - intros j. - - destruct ((0 <=? j) && (j _). intros x. + eapply r_get_remember_rhs. intros x0. + rewrite !coerce_to_choice_type_K. + eapply r_ret. + intros s0 s1 H. + destruct_pre. split_post. + (* prove the final post conditions: pre and that the values of rkeys agree *) + + assumption. + + eapply eq_fmap. intros j. + destruct ((0 <=? j) && (j getm_to_arr_None' by lia. + (* we need to preserve this invariant on the RHS, on add the length to array type *) + admit. Admitted. From Hacspec Require Import Hacspec_Aes_Jazz ChoiceEquality. From c294d17328f0206823d20e5e64af3896d76a8cd2 Mon Sep 17 00:00:00 2001 From: bshvass Date: Mon, 12 Dec 2022 00:13:54 +0100 Subject: [PATCH 303/383] Cleanup and automation, also finish small things in `keyExpansionE` Note I also added preliminaries for defining arrays using maps from fintypes instead of integers. This way we can use that arrays are always undefined outside their length. I'm unsure if this adds too much complexity. It would save us from maintaining invariants which state that arrays are always `None` outside their bounds. --- theories/Jasmin/examples/aes/aes.v | 483 ++++++++++------------------- 1 file changed, 159 insertions(+), 324 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes.v b/theories/Jasmin/examples/aes/aes.v index ed9eed8a..d5e6f757 100644 --- a/theories/Jasmin/examples/aes/aes.v +++ b/theories/Jasmin/examples/aes/aes.v @@ -1056,8 +1056,9 @@ Definition ws_def : seq Z := [::]. Definition get_tr := get_translated_fun ssprove_jasmin_prog. -Definition pdisj (P : precond) (s_id : p_id) := - forall h1 h2 l a v s_id', l = translate_var s_id' v -> (s_id ⪯ s_id') -> (P (h1, h2) -> P ((set_heap h1 l a), h2)). +Definition pdisj (P : precond) (s_id : p_id) (rhs : {fset Location}) := + (forall h1 h2 l a v s_id', l = translate_var s_id' v -> (s_id ⪯ s_id') -> (P (h1, h2) -> P (set_heap h1 l a, h2))) /\ + (forall h1 h2 l a, l \in rhs -> (P (h1, h2) -> P (h1, set_heap h2 l a))). Ltac solve_in := repeat match goal with @@ -1102,6 +1103,78 @@ Notation JKEY_EXPAND i rcon rkey temp2 := (trc KEY_EXPAND i [ ('int ; rcon) ; (' Notation JKEYS_EXPAND i rkey := (trc KEYS_EXPAND i [('word U128 ; rkey)]). (* Notation JKEYS_EXPAND rkey := (get_tr KEYS_EXPAND i [('word U128 ; rkey)]). *) +Ltac destruct_pre := + repeat + match goal with + | [ H : set_lhs _ _ _ _ |- _ ] => + let sn := fresh in + let Hsn := fresh in + destruct H as [sn [Hsn]] + | [ H : set_rhs _ _ _ _ |- _ ] => + let sn := fresh in + let Hsn := fresh in + destruct H as [sn [Hsn]] + | [ H : _ /\ _ |- _ ] => + let H1 := fresh in + let H2 := fresh in + destruct H as [H1 H2] + | [ H : (_ ⋊ _) _ |- _ ] => + let H1 := fresh in + let H2 := fresh in + destruct H as [H1 H2] + | [ H : exists _, _ |- _ ] => + let o := fresh in + destruct H as [o] + end; simpl in *; subst. + +Ltac split_post := + repeat + match goal with + | |- (_ ⋊ _) _ => split + | |- _ /\ _ => split + | |- set_lhs _ _ _ _ => eexists + end. + +(* NB: this redefines neq_loc_auto, which helps some tactics, since checking for inequality by computation is not feasible for translated variables *) +Ltac neq_loc_auto ::= solve [ eapply injective_translate_var3; auto | eapply injective_translate_var2; auto ]. + +(* I don't know what rewrite * means, but this is much faster than regular rewrite, which also sometimes overflows the stack *) +Ltac sheap := + repeat first [ rewrite * get_set_heap_neq; [| neq_loc_auto ] | + rewrite * get_set_heap_eq ]. + +(* This works sometimes, but might be very slow *) +Ltac simpl_heap := + repeat lazymatch goal with + | |- context [ get_heap (set_heap _ ?l _) ?l ] => rewrite -> get_set_heap_eq + | |- context [ get_heap (set_heap (translate_var ?s_id _) (translate_var ?s_id _ ) _ ) _ ] => (rewrite -> get_set_heap_neq by (apply injective_translate_var3; auto)) + | |- context [ get_heap (set_heap _ (translate_var _ _ ) _ ) _ ] => (rewrite -> get_set_heap_neq by (apply injective_translate_var2; assumption)) + end. + +Ltac simpl_heap' := + repeat lazymatch goal with + | |- context [ get_heap (set_heap _ _ _) _ ] => + try rewrite -> get_set_heap_eq; + try (rewrite -> get_set_heap_neq by (apply injective_translate_var3; auto)); + try (rewrite -> get_set_heap_neq by (apply injective_translate_var2; assumption)) + end. + +#[global] Hint Resolve preceq_I preceq_O preceq_refl : preceq. +Ltac solve_preceq := + repeat lazymatch goal with + | |- ?a ⪯ ?a => reflexivity + | |- ?a ⪯ ?b~1 => etransitivity; [|apply preceq_I] + | |- ?a ⪯ ?b~0 => etransitivity; [|apply preceq_O] + end. + +Ltac pdisj_apply h := + lazymatch goal with + | |- ?pre (set_heap _ _ _, set_heap _ _ _) => eapply h; [ solve_in | pdisj_apply h ] + | |- ?pre (set_heap _ _ _, _) => + eapply h ; [ reflexivity | auto with preceq | pdisj_apply h ] + | |- _ => try assumption + end. + Definition rcon (i : Z) : Z := nth 54%Z [:: 1; 2; 4; 8; 16; 32; 64; 128; 27; 54]%Z ((Z.to_nat i) - 1). Definition key_expand (wn1 : u128) (rcon : u8) : 'word U128 := @@ -1119,7 +1192,7 @@ Definition key_expand (wn1 : u128) (rcon : u8) : 'word U128 := wcat [tuple w4; w5; w6; w7]. Lemma rcon_correct id0 pre i : - (pdisj pre id0) -> + (pdisj pre id0 fset0) -> (forall s0 s1, pre (s0, s1) -> (1 <= i < 11)%Z) -> ⊢ ⦃ fun '(s0, s1) => pre (s0, s1) ⦄ JRCON id0 i ≈ ret ([('int ; rcon i)] : tchlist) @@ -1131,178 +1204,18 @@ Proof. repeat setjvars. repeat match goal with | |- context[(?a =? ?b)%Z] => let E := fresh in destruct (a =? b)%Z eqn:E; [rewrite ?Z.eqb_eq in E; subst|] - (* | |- _ => eapply r_put_lhs with (pre := fun _ => True); ssprove_contract_put_get_lhs; eapply r_put_lhs; rewrite ?coerce_to_choice_type_K; eapply r_ret; easy *) | |- _ => simpl; ssprove_contract_put_get_lhs; rewrite !coerce_to_choice_type_K end. - - simpl. eapply r_put_lhs. - ssprove_contract_put_get_lhs; eapply r_put_lhs; rewrite ?coerce_to_choice_type_K. - eapply r_restore_lhs. - + intros. unfold set_lhs in *. - destruct H0 as [s0 []]. - exists (set_heap s0 c 1%Z). subst. split. - * eapply Hpdisj. 1-2: reflexivity. - assumption. - * rewrite set_heap_commut. 1: reflexivity. - apply injective_translate_var3. auto. - + eapply r_ret. - intros; split. - * destruct H0 as [s0 []]. subst. - eapply Hpdisj. 1-2: reflexivity. - assumption. - * split. all: easy. - - simpl. eapply r_put_lhs. - ssprove_contract_put_get_lhs; eapply r_put_lhs; rewrite ?coerce_to_choice_type_K. - eapply r_restore_lhs. - + intros. unfold set_lhs in *. - destruct H1 as [s0 []]. - exists (set_heap s0 c 2%Z). subst. split. - * eapply Hpdisj. 1-2: reflexivity. - assumption. - * rewrite set_heap_commut. 1: reflexivity. - apply injective_translate_var3. auto. - + eapply r_ret. - intros; split. - * destruct H1 as [s0 []]. subst. - eapply Hpdisj. 1-2: reflexivity. - assumption. - * split. all: easy. - - simpl. eapply r_put_lhs. - ssprove_contract_put_get_lhs; eapply r_put_lhs; rewrite ?coerce_to_choice_type_K. - eapply r_restore_lhs. - + intros s0 s1 Hheap. unfold set_lhs in *. - destruct Hheap as [s2 []]. - exists (set_heap s2 c 4%Z). subst. split. - * eapply Hpdisj. 1-2: reflexivity. - assumption. - * rewrite set_heap_commut. 1: reflexivity. - apply injective_translate_var3. auto. - + eapply r_ret. - intros s0 s1 Hheap; split. - * destruct Hheap as [s2 []]. subst. - eapply Hpdisj. 1-2: reflexivity. - assumption. - * split. all: easy. - - simpl. eapply r_put_lhs. - ssprove_contract_put_get_lhs; eapply r_put_lhs; rewrite ?coerce_to_choice_type_K. - eapply r_restore_lhs. - + intros s0 s1 Hheap. unfold set_lhs in *. - destruct Hheap as [s2 []]. - exists (set_heap s2 c 8%Z). subst. split. - * eapply Hpdisj. 1-2: reflexivity. - assumption. - * rewrite set_heap_commut. 1: reflexivity. - apply injective_translate_var3. auto. - + eapply r_ret. - intros s0 s1 Hheap; split. - * destruct Hheap as [s2 []]. subst. - eapply Hpdisj. 1-2: reflexivity. - assumption. - * split. all: easy. - - simpl. eapply r_put_lhs. - ssprove_contract_put_get_lhs; eapply r_put_lhs; rewrite ?coerce_to_choice_type_K. - eapply r_restore_lhs. - + intros s0 s1 Hheap. unfold set_lhs in *. - destruct Hheap as [s2 []]. - exists (set_heap s2 c 16%Z). subst. split. - * eapply Hpdisj. 1-2: reflexivity. - assumption. - * rewrite set_heap_commut. 1: reflexivity. - apply injective_translate_var3. auto. - + eapply r_ret. - intros s0 s1 Hheap; split. - * destruct Hheap as [s2 []]. subst. - eapply Hpdisj. 1-2: reflexivity. - assumption. - * split. all: easy. - - simpl. eapply r_put_lhs. - ssprove_contract_put_get_lhs; eapply r_put_lhs; rewrite ?coerce_to_choice_type_K. - eapply r_restore_lhs. - + intros s0 s1 Hheap. unfold set_lhs in *. - destruct Hheap as [s2 []]. - exists (set_heap s2 c 32%Z). subst. split. - * eapply Hpdisj. 1-2: reflexivity. - assumption. - * rewrite set_heap_commut. 1: reflexivity. - apply injective_translate_var3. auto. - + eapply r_ret. - intros s0 s1 Hheap; split. - * destruct Hheap as [s2 []]. subst. - eapply Hpdisj. 1-2: reflexivity. - assumption. - * split. all: easy. - - simpl. eapply r_put_lhs. - ssprove_contract_put_get_lhs; eapply r_put_lhs; rewrite ?coerce_to_choice_type_K. - eapply r_restore_lhs. - + intros s0 s1 Hheap. unfold set_lhs in *. - destruct Hheap as [s2 []]. - exists (set_heap s2 c 64%Z). subst. split. - * eapply Hpdisj. 1-2: reflexivity. - assumption. - * rewrite set_heap_commut. 1: reflexivity. - apply injective_translate_var3. auto. - + eapply r_ret. - intros s0 s1 Hheap; split. - * destruct Hheap as [s2 []]. subst. - eapply Hpdisj. 1-2: reflexivity. - assumption. - * split. all: easy. - - simpl. eapply r_put_lhs. - ssprove_contract_put_get_lhs; eapply r_put_lhs; rewrite ?coerce_to_choice_type_K. - eapply r_restore_lhs. - + intros s0 s1 Hheap. unfold set_lhs in *. - destruct Hheap as [s2 []]. - exists (set_heap s2 c 128%Z). subst. split. - * eapply Hpdisj. 1-2: reflexivity. - assumption. - * rewrite set_heap_commut. 1: reflexivity. - apply injective_translate_var3. auto. - + eapply r_ret. - intros s0 s1 Hheap; split. - * destruct Hheap as [s2 []]. subst. - eapply Hpdisj. 1-2: reflexivity. - assumption. - * split. all: easy. - - simpl. eapply r_put_lhs. - ssprove_contract_put_get_lhs; eapply r_put_lhs; rewrite ?coerce_to_choice_type_K. - eapply r_restore_lhs. - + intros s0 s1 Hheap. unfold set_lhs in *. - destruct Hheap as [s2 []]. - exists (set_heap s2 c 27%Z). subst. split. - * eapply Hpdisj. 1-2: reflexivity. - assumption. - * rewrite set_heap_commut. 1: reflexivity. - apply injective_translate_var3. auto. - + eapply r_ret. - intros s0 s1 Hheap; split. - * destruct Hheap as [s2 []]. subst. - eapply Hpdisj. 1-2: reflexivity. - assumption. - * split. all: easy. - - destruct (i =? 10)%Z eqn:E. rewrite Z.eqb_eq in E. subst. - simpl. eapply r_put_lhs. - ssprove_contract_put_get_lhs; eapply r_put_lhs; rewrite ?coerce_to_choice_type_K. - eapply r_restore_lhs. - + intros s0 s1 Hheap. unfold set_lhs in *. - destruct Hheap as [s2 []]. - exists (set_heap s2 c 54%Z). subst. split. - * eapply Hpdisj. 1-2: reflexivity. - assumption. - * rewrite set_heap_commut. 1: reflexivity. - apply injective_translate_var3. auto. - + eapply r_ret. - intros s0 s1 Hheap; split. - * destruct Hheap as [s2 []]. subst. - eapply Hpdisj. 1-2: reflexivity. - assumption. - * split. all: easy. - + eapply rpre_hypothesis_rule. intros. apply H in H9. lia. + all: ssprove_code_simpl; rewrite !coerce_to_choice_type_K; eapply r_put_lhs; ssprove_contract_put_get_lhs; eapply r_put_lhs; eapply r_ret. + all: intros; destruct_pre; split_post; [ pdisj_apply Hpdisj | rewrite coerce_to_choice_type_K; auto | easy ]. + destruct (i =? 10)%Z eqn:E. rewrite Z.eqb_eq in E. subst. reflexivity. + apply H in H13. lia. Qed. (* copy of the easycrypt functional definition *) Definition W4u8 : 4.-tuple u8 -> u32 := wcat. Definition W4u32 : 4.-tuple u32 -> u128 := wcat. -Ltac neq_loc_auto ::= eapply injective_translate_var3; auto. Notation "m ⊕ k" := (@word.word.wxor _ m k) (at level 20). @@ -1411,19 +1324,6 @@ Proof. apply modulus_gt0. Qed. -(* Lemma wcat_r_bound n (l : seq n.-word) : *) -(* (0 <= wcat_r l < modulus (size l * n))%Z. *) -(* Proof. *) -(* induction l. *) -(* - simpl. *) -(* split. *) -(* + reflexivity. *) -(* + apply Z.ltb_lt. *) -(* apply modulus_gt0. *) -(* - simpl. *) -(* (* IHl implies that the wcat shifted is less than the modulus and then the lor is less than that *) *) -(* Admitted. *) - (* following two lemmas are from fiat crypto, consider importing *) Lemma mod_pow_same_base_larger a b n m : 0 <= n <= m -> 0 < b -> @@ -1708,25 +1608,6 @@ Proof. all: auto. Qed. -(* Lemma subword_wshufps_0_32_128 o s1 s2 : subword 0 U32 (wshufps_128 o s1 s2) = wpshufd1 s1 o 0. *) -(* Proof. *) -(* unfold wshufps_128. *) -(* rewrite subword_make_vec1. *) -(* rewrite subword_u. *) -(* reflexivity. *) -(* reflexivity. *) -(* Qed. *) - -(* Lemma subword_wshufps_128 o s1 s2 : subword 0 U32 (wshufps_128 o s1 s2) = *) -(* wpshufd1 s1 o 0. *) -(* Proof. *) -(* unfold wshufps_128. *) -(* rewrite subword_make_vec1. *) -(* rewrite subword_u. *) -(* reflexivity. *) -(* reflexivity. *) -(* Qed. *) - Arguments nat_of_wsize : simpl never. Arguments wsize_size_minus_1 : simpl never. @@ -1756,13 +1637,6 @@ Proof. reflexivity. Qed. -(* Lemma lsr_add_r {n} (w : n.-word) i j : lsr (lsr w i) j = lsr w (i + j). *) -(* Proof. *) -(* unfold lsr. *) -(* rewrite urepr_word; simpl. *) -(* apply val_inj. *) -(* simpl. *) - (* from fiat crypto, but proof is more involved *) Lemma mod_pull_div a b c : 0 <= c -> (a / b) mod c = a mod (c * b) / b. @@ -1816,13 +1690,6 @@ Proof. reflexivity. Qed. -(* Lemma wxorC : ∀ m k : word, (m ⊕ k) = (k ⊕ m). *) -(* Proof. *) -(* intros m k. *) -(* apply/eqP/eq_from_wbit=> i. *) -(* by rewrite !wxorE addbC. *) -(* Qed. *) - Lemma wxorA {n} : forall m k l : word n, ((m ⊕ k) ⊕ l) = (m ⊕ (k ⊕ l)). Proof. intros m k l. @@ -1843,7 +1710,6 @@ Proof. Qed. Lemma wreprI ws (a : word.word ws) : wrepr ws (toword a) = a. - Proof. apply val_inj. simpl. destruct a. rewrite Z.mod_small. reflexivity. simpl in *. lia. @@ -1889,7 +1755,6 @@ Proof. rewrite wshr0. rewrite -wxorA. rewrite wxor_involutive. - rewrite wxor_0_l. rewrite wror_substitute. unfold word.wxor. @@ -2028,23 +1893,8 @@ Proof. auto. auto. Qed. -#[global] Hint Resolve preceq_I preceq_O preceq_refl : preceq. -Ltac solve_preceq := - repeat lazymatch goal with - | |- ?a ⪯ ?a => reflexivity - | |- ?a ⪯ ?b~1 => etransitivity; [|apply preceq_I] - | |- ?a ⪯ ?b~0 => etransitivity; [|apply preceq_O] - end. - -Ltac pdisj_apply h := - lazymatch goal with - | |- ?pre (set_heap _ _ _, _) => - eapply h ; [ reflexivity | auto with preceq | pdisj_apply h ] - | |- _ => try assumption - end. - Lemma key_expandP pre id0 rcon rkey temp2 rcon_ : - pdisj pre id0 → + pdisj pre id0 fset0 → toword rcon_ = rcon → (forall s0 s1, pre (s0, s1) -> subword 0 U32 temp2 = word0) → ⊢ ⦃ λ '(s0, s1), pre (s0, s1) ⦄ @@ -2062,10 +1912,7 @@ Proof. simpl_fun. repeat setjvars. repeat clear_get. - unfold sopn_sem. - unfold tr_app_sopn_tuple. - unfold tr_app_sopn_single. - + unfold sopn_sem, tr_app_sopn_tuple, tr_app_sopn_single. simpl. rewrite !zero_extend_u. rewrite !coerce_to_choice_type_K. @@ -2073,18 +1920,10 @@ Proof. repeat eapply r_put_lhs. eapply r_ret. intros s0 s1 Hpre. - - repeat - match goal with - | [ H : set_lhs _ _ _ _ |- _ ] => - let sn := fresh in - let Hsn := fresh in - destruct H as [sn [Hsn]] - end. - split. - - subst. pdisj_apply disj. - - eexists _, _. intuition eauto. - + apply key_expand_aux. assumption. eapply Htemp2. eassumption. + destruct_pre; split_post. + - pdisj_apply disj. + - eexists _, _. intuition auto. + + apply key_expand_aux. reflexivity. eapply Htemp2. eassumption. + apply key_expand_aux2. eapply Htemp2. eassumption. Qed. @@ -2100,6 +1939,9 @@ Fixpoint for_list (c : Z → raw_code 'unit) (vs : seq Z) : raw_code 'unit := Definition for_loop' (c : Z -> raw_code 'unit) lo hi := for_list c (wrange UpTo lo hi). +Definition to_oarr ws len (a : 'array) : (chMap (chFin len) ('word ws)) := + mkfmapf (fun (i : 'I_len) => chArray_get ws a i (wsize_size ws)) (ord_enum len). + Definition to_arr ws len (a : 'array) := mkfmapf (fun i => chArray_get ws a i (wsize_size ws)) (ziota 0 len). @@ -2290,7 +2132,6 @@ Proof. unfold chArray_get. unfold chArray_set. rewrite <- LE.decodeK. - f_equal. rewrite encode_aux. apply map_ext. @@ -2345,6 +2186,15 @@ Proof. rewrite mkfmapfE. Admitted. (* figure out a proof that is less stupid than the one for getm_to_arr *) +Lemma getm_to_oarr ws len a (i : 'I_(pos len)) : + to_oarr ws len a i = Some (chArray_get ws a i (wsize_size ws)). +Proof. + unfold to_oarr. + rewrite mkfmapfE. + rewrite mem_ord_enum. + reflexivity. +Qed. + Lemma getm_to_arr ws len a i : (0 <= i < len) -> to_arr ws len a i = Some (chArray_get ws a i (wsize_size ws)). @@ -2372,6 +2222,15 @@ Proof. reflexivity. Qed. +Lemma to_oarr_set_eq ws len a (i : 'I_(pos len)) w : + (* (0 <= i < len) -> *) + (to_oarr ws len (chArray_set a AAscale i w)) i = Some w. +Proof. + rewrite getm_to_oarr. + rewrite chArray_get_set_eq. + reflexivity. +Qed. + Lemma to_arr_set_eq ws len a i w : (0 <= i < len) -> (to_arr ws len (chArray_set a AAscale i w)) i = Some w. @@ -2388,7 +2247,7 @@ Lemma to_arr_set_neq' ws len a i j (w : 'word ws) : (0 <= j < len) -> (to_arr ws len (chArray_set a AAscale i w)) j = Some (chArray_get ws a j (wsize_size ws)). Proof. - intros Hneq Hi. + intros Hneq H. rewrite getm_to_arr. rewrite chArray_get_set_neq. reflexivity. @@ -2401,7 +2260,7 @@ Lemma to_arr_set_neq ws len a i j (w : 'word ws) : (0 <= j < len) -> (to_arr ws len (chArray_set a AAscale i w)) j = (to_arr ws len a) j. Proof. - intros Hneq Hi. + intros Hneq H. rewrite !getm_to_arr. rewrite chArray_get_set_neq. reflexivity. @@ -2438,67 +2297,24 @@ Proof. simpl. lia. Qed. -Ltac destruct_pre := - repeat - match goal with - | [ H : set_lhs _ _ _ _ |- _ ] => - let sn := fresh in - let Hsn := fresh in - destruct H as [sn [Hsn]] - | [ H : set_rhs _ _ _ _ |- _ ] => - let sn := fresh in - let Hsn := fresh in - destruct H as [sn [Hsn]] - | [ H : _ /\ _ |- _ ] => - let H1 := fresh in - let H2 := fresh in - destruct H as [H1 H2] - | [ H : (_ ⋊ _) _ |- _ ] => - let H1 := fresh in - let H2 := fresh in - destruct H as [H1 H2] - | [ H : exists _, _ |- _ ] => - let o := fresh in - destruct H as [o] - end; simpl in *; subst. - -Ltac split_post := - repeat - match goal with - | |- (_ ⋊ _) _ => split - | |- _ /\ _ => split - | |- set_lhs _ _ _ _ => eexists - end. +(* Notation " 'arr ws len " := (chMap (chFin len) ('word ws)) (at level 2) : package_scope. *) -Ltac neq_loc_auto := solve [ eapply injective_translate_var2; auto | eapply injective_translate_var3; auto ]. - -(* I don't know what rewrite * means, but this is much faster than regular rewrite, which also sometimes overflows the stack *) -Ltac sheap := - repeat first [ rewrite * get_set_heap_neq; [| neq_loc_auto ] | - rewrite * get_set_heap_eq ]. - -(* This works sometimes, but might be very slow *) -Ltac simpl_heap := - repeat lazymatch goal with - | |- context [ get_heap (set_heap _ ?l _) ?l ] => rewrite -> get_set_heap_eq - | |- context [ get_heap (set_heap (translate_var ?s_id _) (translate_var ?s_id _ ) _ ) _ ] => (rewrite -> get_set_heap_neq by (apply injective_translate_var3; auto)) - | |- context [ get_heap (set_heap _ (translate_var _ _ ) _ ) _ ] => (rewrite -> get_set_heap_neq by (apply injective_translate_var2; assumption)) - end. +(* Definition rkeys : Location := ( (chMap (chFin (mkpos 11)) ('word U128)) ; 0%nat ). *) -Ltac simpl_heap' := - repeat lazymatch goal with - | |- context [ get_heap (set_heap _ _ _) _ ] => - try rewrite -> get_set_heap_eq; - try (rewrite -> get_set_heap_neq by (apply injective_translate_var3; auto)); - try (rewrite -> get_set_heap_neq by (apply injective_translate_var2; assumption)) - end. +(* Definition keyExpansion (key : u128) : raw_code (chMap (chFin (mkpos 11)) ('word U128)):= *) +(* #put rkeys := @emptym (chElement_ordType (chFin (mkpos 11))) u128 ;; *) +(* rkeys0 ← get rkeys ;; *) +(* #put rkeys := setm rkeys0 (inord 0) key ;; *) +(* for_loop' (fun i => rkeys0 ← get rkeys ;; #put rkeys := setm rkeys0 (inord (Z.to_nat i)) (key_expand (zero_extend _ (getmd rkeys0 word0 (inord (Z.to_nat i - 1)))) (wrepr U8 (rcon i))) ;; ret tt) 1 11 ;; *) +(* rkeys0 ← get rkeys ;; *) +(* ret rkeys0. *) Notation " 'arr ws " := (chMap 'int ('word ws)) (at level 2) : package_scope. Definition rkeys : Location := ( 'arr U128 ; 0%nat ). Definition keyExpansion (key : u128) : raw_code ('arr U128) := - #put rkeys := @emptym Z_ordType u128 ;; + #put rkeys := @emptym (chElement_ordType 'int) u128 ;; rkeys0 ← get rkeys ;; #put rkeys := setm rkeys0 0 key ;; for_loop' (fun i => rkeys0 ← get rkeys ;; #put rkeys := setm rkeys0 i (key_expand (zero_extend _ (getmd rkeys0 word0 (i - 1))) (wrepr U8 (rcon i))) ;; ret tt) 1 11 ;; @@ -2506,16 +2322,16 @@ Definition keyExpansion (key : u128) : raw_code ('arr U128) := ret rkeys0. Lemma keyExpansionE pre id0 rkey : - (pdisj pre id0) -> + (pdisj pre id0 [fset rkeys]) -> ⊢ ⦃ fun '(h0, h1) => pre (h0, h1) ⦄ - res ← JKEYS_EXPAND id0 rkey ;; - ret (to_arr U128 11 (hdtc res)) + JKEYS_EXPAND id0 rkey ≈ keyExpansion rkey - ⦃ fun '(v0, h0) '(v1, h1) => pre (h0, h1) /\ v0 = v1 ⦄. + ⦃ fun '(v0, h0) '(v1, h1) => pre (h0, h1) /\ (to_arr U128 (mkpos 11) (hdtc v0)) = v1 ⦄. Proof. intros disj. unfold translate_call. + unfold translate_call_body. Opaque translate_call. Opaque wrange. @@ -2544,7 +2360,9 @@ Proof. (I := fun i => fun '(h0, h1) => pre (h0, h1) /\ subword 0 U32 (get_heap h0 temp2) = word0 /\ (get_heap h0 key = chArray_get U128 (get_heap h0 rkeys) (i - 1) 16) - /\ forall j, 0 <= j < i -> (to_arr U128 11 (get_heap h0 rkeys)) j = (get_heap h1 aes.rkeys) j). + /\ (forall j, (0 <= j < i) -> (to_arr U128 (mkpos 11) (get_heap h0 rkeys)) j = (get_heap h1 aes.rkeys) j) + /\ (forall j, (j < 0) \/ (11 <= j) -> get_heap h1 aes.rkeys j = None)). + (* the two following bullets are small assumptions of the translate_for rule *) * intros. simpl. solve_preceq. * lia. @@ -2561,7 +2379,10 @@ Proof. eapply r_bind with (m₁ := ret _) (f₁ := fun _ => _). ** eapply rcon_correct with (id0 := (s_id~1)%positive) (i:=x). (* We have to prove the precond is disjoint from the variables of rcon, i.e. any variables stored locally in rcon does not change the precond *) - *** intros s0 s1 l a vr s_id' Hl Hs_id' H. + *** split. + (* rcon_correct does not use any variables on the rhs *) + 2: { easy. } + intros s0 s1 l a vr s_id' Hl Hs_id' H. assert (id0_preceq : id0 ⪯ s_id'). { etransitivity. eapply preceq_I. etransitivity. eassumption. etransitivity. eapply preceq_I. eassumption. } @@ -2573,6 +2394,7 @@ Proof. { sheap. assumption. } { sheap. assumption. } { sheap. assumption. } + { assumption. } { rewrite set_heap_commut. reflexivity. apply injective_translate_var2. assumption. } { simpl. sheap. reflexivity. } @@ -2595,10 +2417,12 @@ Proof. (* First we apply correctness of key_expandP *) *** (* Here the rewrite is necessary. How should correctness be phrased in general such that this is not important? *) rewrite !coerce_to_choice_type_K. - eapply key_expandP with (id0 := (s_id~0~1)%positive) (rcon :=(rcon i)) (rkey := x0) (temp2 := x1) (rcon_ := wrepr _ (rcon i)). (* again, we have to prove that our precond does not depend key_expand locations *) - { intros s0 s1 l a vr s_id' Hl Hs_id' H. + { split. + (* key_expandP also does not use variables on the rhs *) + 2: { easy. } + intros s0 s1 l a vr s_id' Hl Hs_id' H. assert (id0_preceq : id0 ⪯ s_id'). { etransitivity. eapply preceq_I. etransitivity. eassumption. etransitivity. eapply preceq_O. etransitivity. eapply preceq_I. eassumption. } @@ -2610,6 +2434,7 @@ Proof. { sheap; assumption. } { sheap; assumption. } { sheap; assumption. } + { assumption. } { reflexivity. } { simpl. sheap. reflexivity. } { reflexivity. } @@ -2649,7 +2474,7 @@ Proof. split_post. (* here we prove that the invariant is preserved after a single loop, assuming it holds before *) - { pdisj_apply disj. admit. (* rhs *) } + { pdisj_apply disj. } { assumption. } { replace (Z.succ i - 1) with i by lia. rewrite chArray_get_set_eq. @@ -2658,12 +2483,14 @@ Proof. destruct (Z.eq_dec i j). (* i = j *) - subst. + subst. simpl. + pose proof to_arr_set_eq. + simpl. rewrite to_arr_set_eq. rewrite setmE. rewrite eq_refl. - f_equal. unfold getmd. rewrite -H42. rewrite getm_to_arr. - f_equal. rewrite !get_set_heap_neq in H32. rewrite -H32. assumption. + f_equal. unfold getmd. rewrite -H43. rewrite getm_to_arr. + f_equal. rewrite !get_set_heap_neq in H34. rewrite -H34. assumption. neq_loc_auto. neq_loc_auto. lia. lia. lia. (* i <> j *) @@ -2671,7 +2498,15 @@ Proof. rewrite setmE. assert (@eq bool (@eq_op Z_ordType j i) false). apply/eqP. auto. rewrite H2. - apply H42. lia. assumption. lia. } + apply H43. lia. assumption. lia. } + { intros j Hj. + + rewrite setmE. + (* why do I have to set printing off to realize this? Shouldn't j == i always mean the same on the same type? *) + assert (@eq_op (Ord.eqType Z_ordType) j i = false). apply/eqP. lia. + rewrite H2. + apply H45. + assumption. } (* the next bullet is the proof that the invariant of the for loop is true at the beginning (this goal is generated by pre_weaken rule and translate_for) *) + intros s0 s1 H. destruct_pre. @@ -2683,8 +2518,6 @@ Proof. split_post. (* prove that pre is preserved *) * pdisj_apply disj. - (* the rhs *) - admit. (* first invariant *) * simpl. unfold tr_app_sopn_tuple. simpl. rewrite subword_word0. reflexivity. (* second invariant *) @@ -2692,13 +2525,15 @@ Proof. (* third invariant *) * intros j Hj. assert (j = 0) by lia. subst. rewrite to_arr_set_eq. rewrite setmE. rewrite eq_refl. reflexivity. lia. - + * intros. rewrite setmE. + (* Set Printing All. *) + replace (_ == _) with false. + apply emptymE. symmetry. apply/eqP. lia. (* after for loop *) - intros a0 a1. simpl. eapply r_get_remember_lhs with (pre := fun '(s0, s1) => _). intros x. eapply r_get_remember_rhs. intros x0. - rewrite !coerce_to_choice_type_K. eapply r_ret. intros s0 s1 H. destruct_pre. split_post. @@ -2707,11 +2542,11 @@ Proof. + eapply eq_fmap. intros j. destruct ((0 <=? j) && (j getm_to_arr_None' by lia. - (* we need to preserve this invariant on the RHS, on add the length to array type *) - admit. -Admitted. + rewrite H6. reflexivity. + lia. +Qed. From Hacspec Require Import Hacspec_Aes_Jazz ChoiceEquality. From 7ac003d765b856409ff7e94e86ecfa0a305c4cad Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9o=20Winterhalter?= Date: Mon, 12 Dec 2022 11:50:33 +0100 Subject: [PATCH 304/383] Remove spurious dot --- theories/Jasmin/examples/aes/aes.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/theories/Jasmin/examples/aes/aes.v b/theories/Jasmin/examples/aes/aes.v index d5e6f757..178b33c5 100644 --- a/theories/Jasmin/examples/aes/aes.v +++ b/theories/Jasmin/examples/aes/aes.v @@ -2021,7 +2021,7 @@ Proof. remember (Z.to_nat (hi - lo)). revert Heqn Hle ih. revert n lo hi s_id. induction n as [|n ih2]; intros. - - assert (hi = lo). { zify. lia. }. + - assert (hi = lo). { zify. lia. } subst. unfold translate_for, for_loop'. simpl. rewrite -Heqn. From 302983bd119c2b3910dd1a6f1d22d8b585dded59 Mon Sep 17 00:00:00 2001 From: bshvass Date: Tue, 13 Dec 2022 09:19:50 +0100 Subject: [PATCH 305/383] more aes, transitivity lemma for unary statements, unary loop rule also change rcon to use words instead of Z --- theories/Jasmin/examples/aes/aes.v | 278 +++++++++++++++++++++++++---- 1 file changed, 247 insertions(+), 31 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes.v b/theories/Jasmin/examples/aes/aes.v index d5e6f757..6d12baeb 100644 --- a/theories/Jasmin/examples/aes/aes.v +++ b/theories/Jasmin/examples/aes/aes.v @@ -1175,7 +1175,10 @@ Ltac pdisj_apply h := | |- _ => try assumption end. -Definition rcon (i : Z) : Z := nth 54%Z [:: 1; 2; 4; 8; 16; 32; 64; 128; 27; 54]%Z ((Z.to_nat i) - 1). +Definition rcon (i : Z) : u8 := nth (wrepr U8 54%Z) [:: (wrepr U8 1%Z); (wrepr U8 2%Z); (wrepr U8 4%Z); (wrepr U8 8%Z); (wrepr U8 16%Z); (wrepr U8 32%Z); (wrepr U8 64%Z); (wrepr U8 128%Z); (wrepr U8 27%Z); (wrepr U8 54%Z)]%Z ((Z.to_nat i) - 1). + +Notation hdtc res := (coerce_to_choice_type ('array) (hd ('word U64 ; chCanonical _) res).π2). +Notation call fn := (translate_call _ fn _). Definition key_expand (wn1 : u128) (rcon : u8) : 'word U128 := let rcon := zero_extend U32 rcon (* W4u8 *) (* U32 4 *) (* [tuple rcon ; 0%R; 0%R; 0%R] *) (* [toword rcon; 0%Z; 0%Z; 0%Z] *) in @@ -1195,8 +1198,8 @@ Lemma rcon_correct id0 pre i : (pdisj pre id0 fset0) -> (forall s0 s1, pre (s0, s1) -> (1 <= i < 11)%Z) -> ⊢ ⦃ fun '(s0, s1) => pre (s0, s1) ⦄ JRCON id0 i - ≈ ret ([('int ; rcon i)] : tchlist) - ⦃ fun '(v0, s0) '(v1, s1) => pre (s0, s1) /\ v0 = v1 /\ v1 = ([('int ; rcon i)] : tchlist) ⦄. + ≈ ret tt + ⦃ fun '(v0, s0) '(v1, s1) => pre (s0, s1) /\ exists o, v0 = ([('int ; o)] : tchlist) /\ o = wunsigned (rcon i) ⦄. Proof. unfold get_tr, get_translated_fun. intros Hpdisj H. @@ -1207,7 +1210,7 @@ Proof. | |- _ => simpl; ssprove_contract_put_get_lhs; rewrite !coerce_to_choice_type_K end. all: ssprove_code_simpl; rewrite !coerce_to_choice_type_K; eapply r_put_lhs; ssprove_contract_put_get_lhs; eapply r_put_lhs; eapply r_ret. - all: intros; destruct_pre; split_post; [ pdisj_apply Hpdisj | rewrite coerce_to_choice_type_K; auto | easy ]. + all: intros; destruct_pre; split_post; [ pdisj_apply Hpdisj | rewrite coerce_to_choice_type_K; eexists; split; eauto ]. destruct (i =? 10)%Z eqn:E. rewrite Z.eqb_eq in E. subst. reflexivity. apply H in H13. lia. Qed. @@ -1965,6 +1968,67 @@ Proof. apply/orP. right. assumption. Qed. +Lemma u_for_loop'_rule I c lo hi : + lo <= hi -> + (∀ i, (lo <= i < hi)%Z -> + ⊢ ⦃ λ '(s₀, _), I i s₀ ⦄ + c i ≈ ret tt + ⦃ λ '(_, s₀) '(_, _), I (Z.succ i) s₀ ⦄) → + ⊢ ⦃ λ '(s₀, _), I lo s₀ ⦄ + for_loop' c lo hi ≈ ret tt + ⦃ λ '(_,s₀) '(_,_), I hi s₀ ⦄. +Proof. + intros hle h. + remember (Z.to_nat (hi - lo)). + revert hle h Heqn. revert lo hi. + induction n as [| n ih]; intros. + - simpl. + assert (hi = lo). + { zify. lia. } + unfold for_loop'. + simpl. + rewrite -Heqn. + simpl. + subst. + apply r_ret. + easy. + - unfold for_loop'. + simpl. rewrite -Heqn. simpl. rewrite Z.add_0_r. + eapply r_bind with (m₁ := ret tt) (f₁ := fun _ => _). + + eapply h. lia. + + intros a1 a2. + destruct a1, a2. + replace [seq lo + Z.of_nat i | i <- iota 1 n] with [seq (Z.succ lo) + Z.of_nat i | i <- iota 0 n]. + replace n with (Z.to_nat (hi - Z.succ lo)). + eapply ih. + * lia. + * intros i hi2. apply h. lia. + * lia. + * lia. + * replace (iota 1 n) with (iota (0 + 1) n). apply iota_aux. + intros. lia. + f_equal. +Qed. + +Lemma u_for_loop'_rule' (I : Z -> heap -> Prop) c lo hi (pre : precond) : + lo <= hi -> + (forall h1 h2, pre (h1, h2) -> I lo h1) -> + (∀ i, (lo <= i < hi)%Z -> + ⊢ ⦃ λ '(s₀, _), I i s₀ ⦄ + c i ≈ ret tt + ⦃ λ '(_, s₀) '(_, _), I (Z.succ i) s₀ ⦄) → + ⊢ ⦃ pre ⦄ + for_loop' c lo hi ≈ ret tt + ⦃ λ '(_,s₀) '(_,_), I hi s₀ ⦄. +Proof. + intros. + eapply rpre_weaken_rule. + eapply u_for_loop'_rule. + assumption. + assumption. + apply H0. +Qed. + Lemma for_loop'_rule I c₀ c₁ lo hi : lo <= hi -> (∀ i, (lo <= i < hi)%Z -> ⊢ ⦃ λ '(s₀, s₁), I i (s₀, s₁) ⦄ c₀ i ≈ c₁ i ⦃ λ '(_, s₀) '(_, s₁), I (Z.succ i) (s₀,s₁) ⦄) → @@ -2021,7 +2085,7 @@ Proof. remember (Z.to_nat (hi - lo)). revert Heqn Hle ih. revert n lo hi s_id. induction n as [|n ih2]; intros. - - assert (hi = lo). { zify. lia. }. + - assert (hi = lo). { zify. lia. } subst. unfold translate_for, for_loop'. simpl. rewrite -Heqn. @@ -2054,8 +2118,6 @@ Proof. Qed. Opaque translate_for. -Notation hdtc res := (coerce_to_choice_type ('array) (hd ('word U64 ; chCanonical _) res).π2). -Notation call fn := (translate_call _ fn _). From Relational Require Import OrderEnrichedCategory OrderEnrichedRelativeMonadExamples. @@ -2286,17 +2348,6 @@ Proof. - apply nesym. apply xI_neq. Qed. -Lemma rcon_U8 i : - 0 <= rcon i < wbase U8. -Proof. - unfold rcon, wbase, modulus, two_power_nat; simpl. - destruct (10 rkeys0 ← get rkeys ;; #put rkeys := setm rkeys0 i (key_expand (zero_extend _ (getmd rkeys0 word0 (i - 1))) (wrepr U8 (rcon i))) ;; ret tt) 1 11 ;; + for_loop' (fun i => rkeys0 ← get rkeys ;; #put rkeys := setm rkeys0 i (key_expand (zero_extend _ (getmd rkeys0 word0 (i - 1))) (rcon i)) ;; ret tt) 1 11 ;; rkeys0 ← get rkeys ;; ret rkeys0. +Definition key_i (k : u128) i := + iteri i (fun i ki => key_expand ki (rcon (i + 1))) k. + +From extructures Require Import ord. + +Lemma aes_keyExpansion_h k : + ⊢ ⦃ fun '(h0, h1) => True ⦄ + keyExpansion k + ≈ + ret tt + ⦃ fun '(v0, h0) '(_, _) => forall i, 0 <= i < 11 -> (getmd v0 word0 i) = key_i k (Z.to_nat i) ⦄. +Proof. + unfold keyExpansion. + eapply r_put_lhs with (pre := fun _ => _). + eapply r_get_remember_lhs. intros x. + eapply r_put_lhs. + eapply r_bind with (m₁ := ret _). + eapply u_for_loop'_rule' with + (I:= fun i => fun h => forall j, 0 <= j < i -> getmd (get_heap h rkeys) word0 j = key_i k (Z.to_nat j)). +lia. + - intros i ile Hpre. + destruct_pre. + intros j Hj. + rewrite !get_set_heap_eq. + unfold getmd. + rewrite setmE. + assert (@eq_op (Ord.eqType Z_ordType) j Z0) by (apply/eqP; lia). + rewrite H. + move: H=>/eqP ->. + simpl. + reflexivity. + - intros i ile. + ssprove_code_simpl. + eapply r_get_remember_lhs with (pre := fun '(_, _) => _). intros x0. + eapply r_put_lhs. + eapply r_ret. + intros s0 s1 Hpre. + destruct_pre. + intros j Hj. + rewrite get_set_heap_eq. + rewrite -> H4 by lia. + unfold getmd in *. + rewrite setmE. + destruct (Z.eq_dec j i). + + subst. + rewrite eq_refl. + rewrite zero_extend_u. + replace (Z.to_nat i) with (Z.to_nat (i - 1)).+1 by lia. + unfold key_i at 2. + rewrite iteriS. + f_equal. f_equal. simpl. lia. + + assert (@eq_op (Ord.eqType Z_ordType) j i = false). + apply/eqP. assumption. + rewrite H0. + rewrite H4. + reflexivity. + lia. + - intros s0 s1. + eapply r_get_remember_lhs with (pre := fun '(_, _) => _). intros x0. + eapply r_ret. + intros s2 s3 Hpre i Hi. + destruct_pre. + apply H1. lia. +Qed. +(* hoare aes_keyExpansion_h k : *) +(* Aes.keyExpansion : key = k *) +(* ==> *) +(* forall i, 0 <= i < 11 => res.[i] = key_i k i. *) +(* proof. *) +(* proc. *) +(* while (1 <= round <= 11 /\ forall i, 0 <= i < round => rkeys.[i] = key_i k i). *) +(* + by auto => />; smt (key_iE iteriS get_setE). *) +(* by auto => />; smt(key_iE iteri0 get_setE). *) +(* qed. *) + +Lemma u_trans_det : + ∀ {A₀ A₁ : ord_choiceType} + (P P0 P1 : precond) + (Q : A₀ -> A₁ -> Prop) (Q0 : A₀ -> Prop) (Q1 : A₁ -> Prop) + (c₀ : raw_code A₀) (c₁ : raw_code A₁), + (forall h0 h1, P (h0, h1) -> P0 (h0, h1)) -> + (forall h0 h1, P1 (h1, h0) -> P (h0, h1)) -> + (forall v0 v1, Q v0 v1 -> Q0 v0 -> Q1 v1) -> + deterministic c₀ → + deterministic c₁ → + ⊢ ⦃ λ '(h₀, h₁), P (h₀, h₁) ⦄ c₀ ≈ c₁ ⦃ λ '(v₀, _) '(v₁, _), Q v₀ v₁ ⦄ → + ⊢ ⦃ λ '(h₀, h₁), P0 (h₀, h₁) ⦄ c₀ ≈ ret tt ⦃ λ '(v₀, _) '(_ , _), Q0 v₀ ⦄ -> + ⊢ ⦃ λ '(h₀, h₁), P1 (h₀, h₁) ⦄ c₁ ≈ ret tt ⦃ λ '(v₀, _) '(_ , _), Q1 v₀ ⦄. +Proof. + intros A₀ A₁ P P0 P1 Q Q0 Q1 c0 c1 HP0 HP1 HQ Hd0 Hd1 Hc Hc0. + unshelve eapply det_to_sem. assumption. constructor. + unshelve eapply sem_to_det in Hc. 1,2: assumption. + unshelve eapply sem_to_det in Hc0. assumption. constructor. + intros s₀ s₁ hP1. eapply HP1 in hP1 as HP. eapply HP0 in HP as hP0. + specialize (Hc s₁ s₀ HP). specialize (Hc0 s₁ s₀ hP0). + destruct (det_run c0 _). + destruct (det_run c1 _). + simpl in *. + eapply HQ. eassumption. eassumption. +Qed. + +Lemma u_trans_det' : + ∀ {A₀ A₁ : ord_choiceType} + (P P0 P1 : precond) + (Q : A₁ -> A₀ -> Prop) (Q0 : A₀ -> Prop) (Q1 : A₁ -> Prop) + (c₀ : raw_code A₀) (c₁ : raw_code A₁), + (forall h0 h1, P (h1, h0) -> P0 (h0, h1)) -> + (forall h0 h1, P1 (h1, h0) -> P (h1, h0)) -> + (forall v1 v0, Q v1 v0 -> Q0 v0 -> Q1 v1) -> + deterministic c₀ → + deterministic c₁ → + ⊢ ⦃ λ '(h₀, h₁), P (h₀, h₁) ⦄ c₁ ≈ c₀ ⦃ λ '(v₀, _) '(v₁, _), Q v₀ v₁ ⦄ → + ⊢ ⦃ λ '(h₀, h₁), P0 (h₀, h₁) ⦄ c₀ ≈ ret tt ⦃ λ '(v₀, _) '(_ , _), Q0 v₀ ⦄ -> + ⊢ ⦃ λ '(h₀, h₁), P1 (h₀, h₁) ⦄ c₁ ≈ ret tt ⦃ λ '(v₀, _) '(_ , _), Q1 v₀ ⦄. +Proof. + intros A₀ A₁ P P0 P1 Q Q0 Q1 c0 c1 HP0 HP1 HQ Hd0 Hd1 Hc Hc0. + unshelve eapply det_to_sem. assumption. constructor. + unshelve eapply sem_to_det in Hc. 1,2: assumption. + unshelve eapply sem_to_det in Hc0. assumption. constructor. + intros s₀ s₁ hP1. eapply HP1 in hP1 as HP. eapply HP0 in HP as hP0. + specialize (Hc s₀ s₁ HP). specialize (Hc0 s₁ s₀ hP0). + destruct (det_run c0 _). + destruct (det_run c1 _). + simpl in *. + eapply HQ. eassumption. eassumption. +Qed. + Lemma keyExpansionE pre id0 rkey : (pdisj pre id0 [fset rkeys]) -> ⊢ ⦃ fun '(h0, h1) => pre (h0, h1) ⦄ @@ -2417,12 +2595,12 @@ Proof. (* First we apply correctness of key_expandP *) *** (* Here the rewrite is necessary. How should correctness be phrased in general such that this is not important? *) rewrite !coerce_to_choice_type_K. - eapply key_expandP with (id0 := (s_id~0~1)%positive) (rcon :=(rcon i)) (rkey := x0) (temp2 := x1) (rcon_ := wrepr _ (rcon i)). + eapply key_expandP with (id0 := (s_id~0~1)%positive) (rcon := (wunsigned (rcon i))) (rkey := x0) (temp2 := x1) (rcon_ := rcon i). (* again, we have to prove that our precond does not depend key_expand locations *) { split. (* key_expandP also does not use variables on the rhs *) 2: { easy. } - intros s0 s1 l a vr s_id' Hl Hs_id' H. + intros s0 s1 l a vr s_id' Hl Hs_id' H1. assert (id0_preceq : id0 ⪯ s_id'). { etransitivity. eapply preceq_I. etransitivity. eassumption. etransitivity. eapply preceq_O. etransitivity. eapply preceq_I. eassumption. } @@ -2437,8 +2615,7 @@ Proof. { assumption. } { reflexivity. } { simpl. sheap. reflexivity. } - { reflexivity. } - { reflexivity. } + { eexists. eauto. } { rewrite set_heap_commut; [ | neq_loc_auto ]. rewrite [set_heap _ _ a](set_heap_commut); [ | neq_loc_auto ]. reflexivity. } @@ -2446,7 +2623,7 @@ Proof. { simpl. sheap. reflexivity. } } (* this is an assumption of key_expandP, true by definition of rcon *) - { apply wunsigned_repr_small. apply rcon_U8. } + { reflexivity. } { intros. destruct_pre. sheap. assumption. } (* we continue after the call *) *** intros. @@ -2467,7 +2644,7 @@ Proof. sheap. rewrite !coerce_to_choice_type_K. rewrite !zero_extend_u. - intros s6 s7 H25. + intros s6 s7 H24. destruct_pre. sheap. @@ -2489,23 +2666,23 @@ Proof. rewrite to_arr_set_eq. rewrite setmE. rewrite eq_refl. - f_equal. unfold getmd. rewrite -H43. rewrite getm_to_arr. - f_equal. rewrite !get_set_heap_neq in H34. rewrite -H34. assumption. + f_equal. unfold getmd. rewrite -H41. rewrite getm_to_arr. + f_equal. rewrite !get_set_heap_neq in H33. rewrite -H33. assumption. neq_loc_auto. neq_loc_auto. lia. lia. lia. (* i <> j *) rewrite to_arr_set_neq. rewrite setmE. assert (@eq bool (@eq_op Z_ordType j i) false). apply/eqP. auto. - rewrite H2. - apply H43. lia. assumption. lia. } + rewrite H3. + apply H41. lia. assumption. lia. } { intros j Hj. rewrite setmE. (* why do I have to set printing off to realize this? Shouldn't j == i always mean the same on the same type? *) assert (@eq_op (Ord.eqType Z_ordType) j i = false). apply/eqP. lia. - rewrite H2. - apply H45. + rewrite H3. + apply H43. assumption. } (* the next bullet is the proof that the invariant of the for loop is true at the beginning (this goal is generated by pre_weaken rule and translate_for) *) + intros s0 s1 H. @@ -2548,6 +2725,45 @@ Proof. lia. Qed. +(* without the pre in the post, try to remove this and generalize lemmas instead *) +Lemma keyExpansionE' pre id0 rkey : + (pdisj pre id0 [fset rkeys]) -> + ⊢ ⦃ fun '(h0, h1) => pre (h0, h1) ⦄ + JKEYS_EXPAND id0 rkey + ≈ + keyExpansion rkey + ⦃ fun '(v0, _) '(v1, _) => (to_arr U128 (mkpos 11) (hdtc v0)) = v1 ⦄. +Proof. + intros. + eapply rpost_weaken_rule. + eapply keyExpansionE. + assumption. + intros. + destruct a₀, a₁. + easy. +Qed. + +(* maybe extend this to also preserve a precond, to do this prove a similar `u_trans_det` *) +Lemma keys_expand_jazz_correct pre id0 rkey : + (pdisj pre id0 [fset rkeys]) -> + ⊢ ⦃ fun '(h0, h1) => pre (h0, h1) ⦄ + JKEYS_EXPAND id0 rkey + ≈ + ret tt + ⦃ fun '(v0, _) '(_, _) => forall i, 0 <= i < 11 -> getmd (to_arr U128 (mkpos 11) (hdtc v0)) word0 i = key_i rkey (Z.to_nat i) ⦄. +Proof. + intros h. + eapply u_trans_det' with (P0 := fun '(_, _) => True) (P1 := fun '(_, _) => _). + 7: { eapply aes_keyExpansion_h. } + 6: { eapply keyExpansionE'. eassumption. } + - easy. + - easy. + - intros. simpl in *. rewrite H. apply H0. assumption. + - unfold keyExpansion. + repeat constructor. + - admit. (* TODO: figure out how to do this *) +Admitted. + From Hacspec Require Import Hacspec_Aes_Jazz ChoiceEquality. Section Hacspec. From 11b365512306207b56a8184b43a134b9f0f34967 Mon Sep 17 00:00:00 2001 From: bshvass Date: Tue, 13 Dec 2022 14:37:03 +0100 Subject: [PATCH 306/383] implement several specs, prove `aes_rounds_h` --- theories/Jasmin/examples/aes/aes.v | 83 ++++++++++++++++++++++++++++-- 1 file changed, 80 insertions(+), 3 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes.v b/theories/Jasmin/examples/aes/aes.v index 6d12baeb..bd7dc5a1 100644 --- a/theories/Jasmin/examples/aes/aes.v +++ b/theories/Jasmin/examples/aes/aes.v @@ -1050,6 +1050,7 @@ Notation RCON := (xI (xI (xO (xO xH)))). Notation KEY_COMBINE := (xO (xI (xI (xO xH)))). Notation KEY_EXPAND := (xO (xI (xO (xO xH)))). Notation KEYS_EXPAND := (xO (xO (xI xH))). +Notation ADDROUNDKEY := (xO (xI (xI xH))). Infix "^" := wxor. Definition ws_def : seq Z := [::]. @@ -1103,6 +1104,8 @@ Notation JKEY_EXPAND i rcon rkey temp2 := (trc KEY_EXPAND i [ ('int ; rcon) ; (' Notation JKEYS_EXPAND i rkey := (trc KEYS_EXPAND i [('word U128 ; rkey)]). (* Notation JKEYS_EXPAND rkey := (get_tr KEYS_EXPAND i [('word U128 ; rkey)]). *) +Notation JADDROUNDKEY state rk := (trc KEYS_EXPAND i [('word U128 ; state) ; ('word U128 ; rk)]). + Ltac destruct_pre := repeat match goal with @@ -1187,7 +1190,7 @@ Definition key_expand (wn1 : u128) (rcon : u8) : 'word U128 := let w2 := subword (2 * U32) U32 wn1 in let w3 := subword (3 * U32) U32 wn1 in let tmp := w3 in - let tmp := substitute (wror tmp 1) ^ rcon in + let tmp := SubWord (wror tmp 1) ^ rcon in let w4 := w0 ^ tmp in let w5 := w1 ^ w4 in let w6 := w2 ^ w5 in @@ -1700,7 +1703,7 @@ Proof. by rewrite !wxorE addbA. Qed. -Lemma wror_substitute {n} (w : word.word n) k : wror (substitute w) k = substitute (wror w k). +Lemma wror_substitute w k : wror (SubWord w) k = SubWord (wror w k). Proof. (* I would like to case on w, but not sure how to do this most efficiently? *) Admitted. @@ -2368,7 +2371,10 @@ Definition keyExpansion (key : u128) : raw_code ('arr U128) := #put rkeys := @emptym (chElement_ordType 'int) u128 ;; rkeys0 ← get rkeys ;; #put rkeys := setm rkeys0 0 key ;; - for_loop' (fun i => rkeys0 ← get rkeys ;; #put rkeys := setm rkeys0 i (key_expand (zero_extend _ (getmd rkeys0 word0 (i - 1))) (rcon i)) ;; ret tt) 1 11 ;; + for_loop' (fun i => + rkeys0 ← get rkeys ;; + #put rkeys := setm rkeys0 i (key_expand (zero_extend _ (getmd rkeys0 word0 (i - 1))) (rcon i)) ;; + ret tt) 1 11 ;; rkeys0 ← get rkeys ;; ret rkeys0. @@ -2764,6 +2770,77 @@ Proof. - admit. (* TODO: figure out how to do this *) Admitted. +Definition aes (key msg : u128) := + let state := wxor msg (key_i key 0) in + let state := iteri 9 (fun i state => AESENC_ state (key_i key (i + 1))) state in + AESENCLAST_ state (key_i key 10). + +Definition invaes (key cipher : u128) := + let state := wxor cipher (key_i key 10) in + let state := iteri 9 (fun i state => AESDEC_ state (key_i key (10 -(i + 1)))) state in + wAESDECLAST state (key_i key 0). + +(* Definition rkeys : Location := () *) +(* Definition (rkeys : chMap 'int ('word U128)) (msg : 'word U128) := *) +Definition state : Location := ( 'word U128 ; 0%nat). + +Definition aes_rounds (rkeys : 'arr U128) (msg : 'word U128) := + #put state := wxor msg (getmd rkeys word0 0) ;; + for_loop' (fun i => + state0 ← get state ;; + #put state := AESENC_ state0 (getmd rkeys word0 i) ;; + ret tt + ) 1 10 ;; + state0 ← get state ;; + #put state := AESENCLAST_ state0 (getmd rkeys word0 10) ;; + state0 ← get state ;; + ret state0. + +Lemma aes_rounds_h rkeys k m : + (forall i, 0 <= i < 11 -> getmd rkeys word0 i = key_i k (Z.to_nat i)) -> + ⊢ ⦃ fun '(_, _) => True ⦄ + aes_rounds rkeys m + ≈ + ret tt + ⦃ fun '(v0, _) '(_, _) => v0 = aes k m ⦄. +Proof. + unfold aes_rounds. + intros H. + eapply r_put_lhs with (pre := fun _ => _). + eapply r_bind with (m₁ := ret _). + set (st0 := m ⊕ (key_i k 0%nat)). + eapply u_for_loop'_rule' with + (I := fun i => fun h => get_heap h state = iteri (Z.to_nat i - 1) (fun i state => AESENC_ state (key_i k (i + 1))) st0). + - lia. + - intros. + simpl. + destruct_pre. sheap. rewrite H. reflexivity. lia. + - intros i Hi. + eapply r_get_remember_lhs with (pre := fun '(_, _) => _). intros x. + eapply r_put_lhs. eapply r_ret. + intros s0 s1 pre. + destruct_pre; sheap. + replace (Z.to_nat (Z.succ i) - 1)%nat with ((Z.to_nat i - 1).+1) by lia. + rewrite iteriS. + rewrite H5. + rewrite H. repeat f_equal. lia. lia. + - intros a0 a1. + eapply r_get_remember_lhs with (pre := fun '(_, _) => _). intros x. + eapply r_put_lhs. + eapply r_get_remember_lhs. intros x0. + eapply r_ret. + intros s0 s1 pre. + Opaque getmd. + destruct pre as [[s2 [[H4 H3] H2]] H1]. + simpl in H3, H1. subst. + sheap. + unfold aes. + rewrite H4. + rewrite H. + replace ((Z.to_nat 10) - 1)%nat with 9%nat by reflexivity. + reflexivity. lia. +Qed. + From Hacspec Require Import Hacspec_Aes_Jazz ChoiceEquality. Section Hacspec. From bd6b5089336909b8e83560cceeb8be72dd24c4f6 Mon Sep 17 00:00:00 2001 From: bshvass Date: Tue, 13 Dec 2022 14:45:22 +0100 Subject: [PATCH 307/383] separate file for the aes prog --- theories/Jasmin/examples/aes/aes_jazz.v | 1074 +++++++++++++++++++++++ 1 file changed, 1074 insertions(+) create mode 100644 theories/Jasmin/examples/aes/aes_jazz.v diff --git a/theories/Jasmin/examples/aes/aes_jazz.v b/theories/Jasmin/examples/aes/aes_jazz.v new file mode 100644 index 00000000..50b8906e --- /dev/null +++ b/theories/Jasmin/examples/aes/aes_jazz.v @@ -0,0 +1,1074 @@ +Set Warnings "-notation-overridden,-ambiguous-paths". +From mathcomp Require Import all_ssreflect all_algebra reals distr realsum + fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool + ssrnum eqtype choice seq. +Set Warnings "notation-overridden,ambiguous-paths". + +Require Import List. +Set Warnings "-notation-overridden". +From Jasmin Require Import expr. +Set Warnings "notation-overridden". +From Jasmin Require Import x86_instr_decl x86_extra. +From JasminSSProve Require Import jasmin_translate. +From Crypt Require Import Prelude Package. + +Import ListNotations. +Local Open Scope string. + +Set Bullet Behavior "Strict Subproofs". +(* Set Default Goal Selector "!". *) (* I give up on this for now. *) + +Definition ssprove_jasmin_prog : uprog. +Proof. + refine {| p_funcs := + rev [ ( (* RCON *) xI (xI (xO (xO xH))), + {| f_info := xO (xO (xO (xI xH))) + ; f_tyin := [sint] + ; f_params := + [{| v_var := {| vtype := sint + ; vname := "i.322" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := {| vtype := sint + ; vname := "c.323" |} + ; v_info := dummy_var_info |}) + AT_inline (sint) + ((Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.322" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xH)))) + (Pconst (Zpos (xH))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.322" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO xH)))) + (Pconst (Zpos (xO xH))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.322" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xI xH)))) + (Pconst (Zpos (xO (xO xH)))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.322" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO (xO xH))))) + (Pconst (Zpos (xO (xO (xO xH))))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.322" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xI (xO xH))))) + (Pconst (Zpos (xO (xO (xO (xO xH)))))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.322" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO (xI xH))))) + (Pconst (Zpos (xO (xO (xO (xO (xO xH))))))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := + "i.322" |} + ; v_info := + dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xI (xI xH))))) + (Pconst + (Zpos (xO (xO (xO (xO (xO (xO xH)))))))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := + "i.322" |} + ; v_info := + dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO (xO (xO xH)))))) + (Pconst + (Zpos (xO (xO (xO (xO (xO (xO (xO xH))))))))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := + sint + ; vname := + "i.322" |} + ; v_info := + dummy_var_info |} ; gs := Slocal |}) + (Pconst + (Zpos (xI (xO (xO xH)))))) + (Pconst + (Zpos (xI (xI (xO (xI xH)))))) + (Pconst + (Zpos (xO (xI (xI (xO (xI xH)))))))))))))))))) ] + ; f_tyout := [sint] + ; f_res := + [{| v_var := {| vtype := sint + ; vname := "c.323" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* key_combine *) xO (xI (xI (xO xH))), + {| f_info := xI (xI (xI (xO xH))) + ; f_tyin := [(sword U128); (sword U128); (sword U128)] + ; f_params := + [{| v_var := {| vtype := (sword U128) + ; vname := "rkey.319" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "temp1.320" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "temp2.321" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "temp1.320" |} + ; v_info := dummy_var_info |}] + AT_keep + (Oasm (* VPSHUFD_128 *) (BaseOp (None, (VPSHUFD U128)))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp1.320" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (PappN (Opack U8 PE2) + [(Pconst (Zpos (xI xH))); (Pconst (Zpos (xI xH))); + (Pconst (Zpos (xI xH))); (Pconst (Zpos (xI xH)))])]); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.321" |} + ; v_info := dummy_var_info |}] + AT_keep + (Oasm (* VSHUFPS_128 *) (BaseOp (None, (VSHUFPS U128)))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.321" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.319" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (PappN (Opack U8 PE2) + [(Pconst (Z0)); (Pconst (Zpos (xH))); (Pconst (Z0)); + (Pconst (Z0))])]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.319" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U128)) + ((Papp2 (Olxor U128) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.319" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.321" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.321" |} + ; v_info := dummy_var_info |}] + AT_keep + (Oasm (* VSHUFPS_128 *) (BaseOp (None, (VSHUFPS U128)))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.321" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.319" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (PappN (Opack U8 PE2) + [(Pconst (Zpos (xO xH))); (Pconst (Z0)); + (Pconst (Zpos (xI xH))); (Pconst (Z0))])]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.319" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U128)) + ((Papp2 (Olxor U128) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.319" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.321" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.319" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U128)) + ((Papp2 (Olxor U128) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.319" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp1.320" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))) ] + ; f_tyout := [(sword U128); (sword U128)] + ; f_res := + [{| v_var := {| vtype := (sword U128) + ; vname := "rkey.319" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "temp2.321" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* key_expand *) xO (xI (xO (xO xH))), + {| f_info := xI (xO (xI (xO xH))) + ; f_tyin := [sint; (sword U128); (sword U128)] + ; f_params := + [{| v_var := {| vtype := sint + ; vname := "rcon.315" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "rkey.316" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "temp2.317" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "temp1.318" |} + ; v_info := dummy_var_info |}] + AT_keep + (Oasm (* VAESKEYGENASSIST *) + (BaseOp (None, VAESKEYGENASSIST))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.316" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Papp1 (Oword_of_int U8) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "rcon.315" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))]); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.316" |} + ; v_info := dummy_var_info |}; + Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.317" |} + ; v_info := dummy_var_info |}] + (xO (xI (xI (xO xH)))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.316" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp1.318" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.317" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sword U128); (sword U128)] + ; f_res := + [{| v_var := {| vtype := (sword U128) + ; vname := "rkey.316" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "temp2.317" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* keys_expand *) xO (xO (xI xH)), + {| f_info := xO (xO (xI (xO xH))) + ; f_tyin := [(sword U128)] + ; f_params := + [{| v_var := {| vtype := (sword U128) + ; vname := "key.310" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Laset AAscale U128 + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.311" |} + ; v_info := dummy_var_info |} + (Pconst (Z0))) + AT_none ((sword U128)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.310" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.312" |} + ; v_info := dummy_var_info |}] + AT_keep (Oasm (* set0_128 *) (ExtOp (Oset0 U128))) []); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "round.313" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Zpos (xH)))), + (Pconst (Zpos (xI (xI (xO xH)))))) + [MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := sint + ; vname := "rcon.314" |} + ; v_info := dummy_var_info |}] + (xI (xI (xO (xO xH)))) + [(Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "round.313" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "key.310" |} + ; v_info := dummy_var_info |}; + Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.312" |} + ; v_info := dummy_var_info |}] + (xO (xI (xO (xO xH)))) + [(Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "rcon.314" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.310" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.312" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Laset AAscale U128 + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.311" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "round.313" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) + AT_none ((sword U128)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.310" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))]) ] + ; f_tyout := [(sarr (xO (xO (xO (xO (xI (xI (xO xH))))))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.311" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* keys_expand_inv *) xI (xO (xO xH)), + {| f_info := xI (xO (xO (xO xH))) + ; f_tyin := [(sword U128)] + ; f_params := + [{| v_var := {| vtype := (sword U128) + ; vname := "key.305" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Laset AAscale U128 + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.306" |} + ; v_info := dummy_var_info |} + (Pconst (Z0))) + AT_none ((sword U128)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.305" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.307" |} + ; v_info := dummy_var_info |}] + AT_keep (Oasm (* set0_128 *) (ExtOp (Oset0 U128))) []); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "round.308" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Zpos (xH)))), + (Pconst (Zpos (xI (xI (xO xH)))))) + [MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := sint + ; vname := "rcon.309" |} + ; v_info := dummy_var_info |}] + (xI (xI (xO (xO xH)))) + [(Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "round.308" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "key.305" |} + ; v_info := dummy_var_info |}; + Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.307" |} + ; v_info := dummy_var_info |}] + (xO (xI (xO (xO xH)))) + [(Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "rcon.309" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.305" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.307" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cif + (Papp2 (Oneq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "round.308" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO (xI (xO xH)))))) + [MkI InstrInfo.witness + (Copn + [Laset AAscale U128 + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.306" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "round.308" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})] + AT_keep + (Oasm (* AESIMC *) (BaseOp (None, AESIMC))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.305" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})])] + [MkI InstrInfo.witness + (Cassgn + (Laset AAscale U128 + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.306" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "round.308" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) + AT_none ((sword U128)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.305" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))])]) ] + ; f_tyout := [(sarr (xO (xO (xO (xO (xI (xI (xO xH))))))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.306" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* aes_rounds *) xI (xI (xO xH)), + {| f_info := xO (xO (xO (xO xH))) + ; f_tyin := + [(sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))); (sword U128)] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.301" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "in.302" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "state.303" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U128)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "in.302" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "state.303" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U128)) + ((Papp2 (Olxor U128) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "state.303" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pget AAscale U128 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.301" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pconst (Z0)))))); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "round.304" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Zpos (xH)))), + (Pconst (Zpos (xO (xI (xO xH)))))) + [MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "state.303" |} + ; v_info := dummy_var_info |}] + AT_keep (Oasm (* AESENC *) (BaseOp (None, AESENC))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "state.303" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pget AAscale U128 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.301" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "round.304" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))])]); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "state.303" |} + ; v_info := dummy_var_info |}] + AT_keep (Oasm (* AESENCLAST *) (BaseOp (None, AESENCLAST))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "state.303" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pget AAscale U128 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.301" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pconst (Zpos (xO (xI (xO xH))))))]) ] + ; f_tyout := [(sword U128)] + ; f_res := + [{| v_var := {| vtype := (sword U128) + ; vname := "state.303" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* AddRoundKey *) xO (xI (xI xH)), + {| f_info := xI (xI (xI xH)) + ; f_tyin := [(sword U128); (sword U128)] + ; f_params := + [{| v_var := {| vtype := (sword U128) + ; vname := "state.299" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "rk.300" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "state.299" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U128)) + ((Papp2 (Olxor U128) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "state.299" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "rk.300" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))) ] + ; f_tyout := [(sword U128)] + ; f_res := + [{| v_var := {| vtype := (sword U128) + ; vname := "state.299" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* invaes_rounds *) xO (xO (xO xH)), + {| f_info := xI (xO (xI xH)) + ; f_tyin := + [(sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))); (sword U128)] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.294" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "in.295" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "state.296" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U128)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "in.295" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "rk.297" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U128)) + ((Pget AAscale U128 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.294" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pconst (Zpos (xO (xI (xO xH)))))))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "state.296" |} + ; v_info := dummy_var_info |}] + (xO (xI (xI xH))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "state.296" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "rk.297" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "round.298" |} + ; v_info := dummy_var_info |}) + ((DownTo, (Pconst (Z0))), (Pconst (Zpos (xI (xO (xO xH)))))) + [MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "state.296" |} + ; v_info := dummy_var_info |}] + AT_keep (Oasm (* AESDEC *) (BaseOp (None, AESDEC))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "state.296" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pget AAscale U128 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.294" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "round.298" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))])]); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "state.296" |} + ; v_info := dummy_var_info |}] + AT_keep (Oasm (* AESDECLAST *) (BaseOp (None, AESDECLAST))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "state.296" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pget AAscale U128 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.294" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pconst (Z0)))]) ] + ; f_tyout := [(sword U128)] + ; f_res := + [{| v_var := {| vtype := (sword U128) + ; vname := "state.296" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* aes *) xO (xI xH), + {| f_info := xO (xI (xO xH)) + ; f_tyin := [(sword U128); (sword U128)] + ; f_params := + [{| v_var := {| vtype := (sword U128) + ; vname := "key.290" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "in.291" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.293" |} + ; v_info := dummy_var_info |}] + (xO (xO (xI xH))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.290" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "out.292" |} + ; v_info := dummy_var_info |}] + (xI (xI (xO xH))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.293" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "in.291" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sword U128)] + ; f_res := + [{| v_var := {| vtype := (sword U128) + ; vname := "out.292" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* invaes *) xI xH, + {| f_info := xI (xI xH) + ; f_tyin := [(sword U128); (sword U128)] + ; f_params := + [{| v_var := {| vtype := (sword U128) + ; vname := "key.286" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "in.287" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.289" |} + ; v_info := dummy_var_info |}] + (xI (xO (xO xH))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.286" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "out.288" |} + ; v_info := dummy_var_info |}] + (xO (xO (xO xH))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.289" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "in.287" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sword U128)] + ; f_res := + [{| v_var := {| vtype := (sword U128) + ; vname := "out.288" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* aes_jazz *) xO (xO xH), + {| f_info := xI (xO xH) + ; f_tyin := [(sword U128); (sword U128)] + ; f_params := + [{| v_var := {| vtype := (sword U128) + ; vname := "key.283" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "in.284" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "out.285" |} + ; v_info := dummy_var_info |}] + (xO (xI xH)) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.283" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "in.284" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sword U128)] + ; f_res := + [{| v_var := {| vtype := (sword U128) + ; vname := "out.285" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* invaes_jazz *) xH, + {| f_info := xO xH + ; f_tyin := [(sword U128); (sword U128)] + ; f_params := + [{| v_var := {| vtype := (sword U128) + ; vname := "key.280" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "in.281" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "out.282" |} + ; v_info := dummy_var_info |}] + (xI xH) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.280" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "in.281" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sword U128)] + ; f_res := + [{| v_var := {| vtype := (sword U128) + ; vname := "out.282" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) ] ; + p_globs := [] ; + p_extra := tt |}. +Defined. + +(* use zify to use lia in a goal with ssr integers/naturals *) +(* install via opam: coq-mathcomp-zify *) +From mathcomp Require Import zify. + +From Coq Require Import Utf8. +From extructures Require Import ord fset fmap. + +Require Import micromega.Lia. +From mathcomp.word Require Import word. +From mathcomp.word Require Import ssrZ. +From JasminSSProve Require Import jasmin_utils. +Import ListNotations. +Import JasminNotation JasminCodeNotation. +Import PackageNotation. + +Notation RCON := (xI (xI (xO (xO xH)))). +Notation KEY_COMBINE := (xO (xI (xI (xO xH)))). +Notation KEY_EXPAND := (xO (xI (xO (xO xH)))). +Notation KEYS_EXPAND := (xO (xO (xI xH))). +Notation ADDROUNDKEY := (xO (xI (xI xH))). + +Notation trp := (translate_prog' ssprove_jasmin_prog).1. +Notation trc := (fun fn i => translate_call ssprove_jasmin_prog fn trp i). + +(* I use trc to be able to reuse statements about the function inside other functions where theyll appear as translate_calls (and not get_translated_funs). + Furthermore, I think this is necessary to assure that all calls gets the complete list of translated functions. + Otherwise result might depend on which buffer of translated functions gets passed to the call. + In this construction we always use all of them, opposed to get_translated_fun which just uses the necessary ones (I believe). + *) + +Notation JRCON i j := (trc RCON i [('int ; j)]). +(* Notation JRCON (j : Z) := (get_tr RCON i [('int ; j)]). *) + +Notation JKEY_COMBINE i rkey temp1 temp2 := (trc KEY_COMBINE i [('word U128 ; rkey) ; ('word U128 ; temp1) ; ('word U128 ; temp2)]). +(* Notation JKEY_COMBINE rkey temp1 temp2 := (get_tr KEY_COMBINE i [('word U128 ; rkey) ; ('word U128 ; temp1) ; ('word U128 ; temp2)]). *) + +Notation JKEY_EXPAND i rcon rkey temp2 := (trc KEY_EXPAND i [ ('int ; rcon) ; ('word U128 ; rkey) ; ('word U128 ; temp2) ]). +(* Notation JKEY_EXPAND rcon rkey temp2 := (get_tr KEY_EXPAND i [ ('int ; rcon) ; ('word U128 ; rkey) ; ('word U128 ; temp2) ]). *) + +Notation JKEYS_EXPAND i rkey := (trc KEYS_EXPAND i [('word U128 ; rkey)]). +(* Notation JKEYS_EXPAND rkey := (get_tr KEYS_EXPAND i [('word U128 ; rkey)]). *) + +Notation JADDROUNDKEY state rk := (trc KEYS_EXPAND i [('word U128 ; state) ; ('word U128 ; rk)]). From 5779f4bac45a997d65c76bfaad268a2e0257d187 Mon Sep 17 00:00:00 2001 From: bshvass Date: Tue, 13 Dec 2022 14:46:20 +0100 Subject: [PATCH 308/383] update _CoqProject --- _CoqProject | 1 + 1 file changed, 1 insertion(+) diff --git a/_CoqProject b/_CoqProject index b8505148..f2e14383 100644 --- a/_CoqProject +++ b/_CoqProject @@ -83,6 +83,7 @@ theories/Jasmin/jasmin_utils.v theories/Jasmin/examples/add1.v theories/Jasmin/examples/aes.v +theories/Jasmin/examples/aes/aes_jazz.v theories/Jasmin/examples/bigadd.v theories/Jasmin/examples/ex.v theories/Jasmin/examples/int_add.v From 41c0035e17a416c04c22f496b73a8053628a06b2 Mon Sep 17 00:00:00 2001 From: bshvass Date: Tue, 13 Dec 2022 15:59:25 +0100 Subject: [PATCH 309/383] added aes_hac and restructured aes/ a bit --- theories/Jasmin/examples/aes/aes.v | 1079 +---------------------- theories/Jasmin/examples/aes/aes_hac.v | 67 ++ theories/Jasmin/examples/aes/aes_jazz.v | 11 - 3 files changed, 69 insertions(+), 1088 deletions(-) create mode 100644 theories/Jasmin/examples/aes/aes_hac.v diff --git a/theories/Jasmin/examples/aes/aes.v b/theories/Jasmin/examples/aes/aes.v index bd7dc5a1..d699c0c5 100644 --- a/theories/Jasmin/examples/aes/aes.v +++ b/theories/Jasmin/examples/aes/aes.v @@ -18,1040 +18,15 @@ Local Open Scope string. Set Bullet Behavior "Strict Subproofs". (* Set Default Goal Selector "!". *) (* I give up on this for now. *) -Definition ssprove_jasmin_prog : uprog. -Proof. - refine {| p_funcs := - rev [ ( (* RCON *) xI (xI (xO (xO xH))), - {| f_info := xO (xO (xO (xI xH))) - ; f_tyin := [sint] - ; f_params := - [{| v_var := {| vtype := sint - ; vname := "i.322" |} - ; v_info := dummy_var_info |}] - ; f_body := - [ MkI InstrInfo.witness - (Cassgn - (Lvar - {| v_var := {| vtype := sint - ; vname := "c.323" |} - ; v_info := dummy_var_info |}) - AT_inline (sint) - ((Pif (sint) - (Papp2 (Oeq Op_int) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "i.322" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pconst (Zpos (xH)))) - (Pconst (Zpos (xH))) - (Pif (sint) - (Papp2 (Oeq Op_int) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "i.322" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pconst (Zpos (xO xH)))) - (Pconst (Zpos (xO xH))) - (Pif (sint) - (Papp2 (Oeq Op_int) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "i.322" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pconst (Zpos (xI xH)))) - (Pconst (Zpos (xO (xO xH)))) - (Pif (sint) - (Papp2 (Oeq Op_int) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "i.322" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pconst (Zpos (xO (xO xH))))) - (Pconst (Zpos (xO (xO (xO xH))))) - (Pif (sint) - (Papp2 (Oeq Op_int) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "i.322" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pconst (Zpos (xI (xO xH))))) - (Pconst (Zpos (xO (xO (xO (xO xH)))))) - (Pif (sint) - (Papp2 (Oeq Op_int) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "i.322" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pconst (Zpos (xO (xI xH))))) - (Pconst (Zpos (xO (xO (xO (xO (xO xH))))))) - (Pif (sint) - (Papp2 (Oeq Op_int) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := - "i.322" |} - ; v_info := - dummy_var_info |} ; gs := Slocal |}) - (Pconst (Zpos (xI (xI xH))))) - (Pconst - (Zpos (xO (xO (xO (xO (xO (xO xH)))))))) - (Pif (sint) - (Papp2 (Oeq Op_int) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := - "i.322" |} - ; v_info := - dummy_var_info |} ; gs := Slocal |}) - (Pconst (Zpos (xO (xO (xO xH)))))) - (Pconst - (Zpos (xO (xO (xO (xO (xO (xO (xO xH))))))))) - (Pif (sint) - (Papp2 (Oeq Op_int) - (Pvar - {| gv := {| v_var := - {| vtype := - sint - ; vname := - "i.322" |} - ; v_info := - dummy_var_info |} ; gs := Slocal |}) - (Pconst - (Zpos (xI (xO (xO xH)))))) - (Pconst - (Zpos (xI (xI (xO (xI xH)))))) - (Pconst - (Zpos (xO (xI (xI (xO (xI xH)))))))))))))))))) ] - ; f_tyout := [sint] - ; f_res := - [{| v_var := {| vtype := sint - ; vname := "c.323" |} - ; v_info := dummy_var_info |}] - ; f_extra := tt - ; |} ) - ; ( (* key_combine *) xO (xI (xI (xO xH))), - {| f_info := xI (xI (xI (xO xH))) - ; f_tyin := [(sword U128); (sword U128); (sword U128)] - ; f_params := - [{| v_var := {| vtype := (sword U128) - ; vname := "rkey.319" |} - ; v_info := dummy_var_info |}; - {| v_var := {| vtype := (sword U128) - ; vname := "temp1.320" |} - ; v_info := dummy_var_info |}; - {| v_var := {| vtype := (sword U128) - ; vname := "temp2.321" |} - ; v_info := dummy_var_info |}] - ; f_body := - [ MkI InstrInfo.witness - (Copn - [Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "temp1.320" |} - ; v_info := dummy_var_info |}] - AT_keep - (Oasm (* VPSHUFD_128 *) (BaseOp (None, (VPSHUFD U128)))) - [(Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "temp1.320" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (PappN (Opack U8 PE2) - [(Pconst (Zpos (xI xH))); (Pconst (Zpos (xI xH))); - (Pconst (Zpos (xI xH))); (Pconst (Zpos (xI xH)))])]); - MkI InstrInfo.witness - (Copn - [Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "temp2.321" |} - ; v_info := dummy_var_info |}] - AT_keep - (Oasm (* VSHUFPS_128 *) (BaseOp (None, (VSHUFPS U128)))) - [(Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "temp2.321" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "rkey.319" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (PappN (Opack U8 PE2) - [(Pconst (Z0)); (Pconst (Zpos (xH))); (Pconst (Z0)); - (Pconst (Z0))])]); - MkI InstrInfo.witness - (Cassgn - (Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "rkey.319" |} - ; v_info := dummy_var_info |}) - AT_none ((sword U128)) - ((Papp2 (Olxor U128) - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "rkey.319" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "temp2.321" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})))); - MkI InstrInfo.witness - (Copn - [Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "temp2.321" |} - ; v_info := dummy_var_info |}] - AT_keep - (Oasm (* VSHUFPS_128 *) (BaseOp (None, (VSHUFPS U128)))) - [(Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "temp2.321" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "rkey.319" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (PappN (Opack U8 PE2) - [(Pconst (Zpos (xO xH))); (Pconst (Z0)); - (Pconst (Zpos (xI xH))); (Pconst (Z0))])]); - MkI InstrInfo.witness - (Cassgn - (Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "rkey.319" |} - ; v_info := dummy_var_info |}) - AT_none ((sword U128)) - ((Papp2 (Olxor U128) - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "rkey.319" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "temp2.321" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})))); - MkI InstrInfo.witness - (Cassgn - (Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "rkey.319" |} - ; v_info := dummy_var_info |}) - AT_none ((sword U128)) - ((Papp2 (Olxor U128) - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "rkey.319" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "temp1.320" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})))) ] - ; f_tyout := [(sword U128); (sword U128)] - ; f_res := - [{| v_var := {| vtype := (sword U128) - ; vname := "rkey.319" |} - ; v_info := dummy_var_info |}; - {| v_var := {| vtype := (sword U128) - ; vname := "temp2.321" |} - ; v_info := dummy_var_info |}] - ; f_extra := tt - ; |} ) - ; ( (* key_expand *) xO (xI (xO (xO xH))), - {| f_info := xI (xO (xI (xO xH))) - ; f_tyin := [sint; (sword U128); (sword U128)] - ; f_params := - [{| v_var := {| vtype := sint - ; vname := "rcon.315" |} - ; v_info := dummy_var_info |}; - {| v_var := {| vtype := (sword U128) - ; vname := "rkey.316" |} - ; v_info := dummy_var_info |}; - {| v_var := {| vtype := (sword U128) - ; vname := "temp2.317" |} - ; v_info := dummy_var_info |}] - ; f_body := - [ MkI InstrInfo.witness - (Copn - [Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "temp1.318" |} - ; v_info := dummy_var_info |}] - AT_keep - (Oasm (* VAESKEYGENASSIST *) - (BaseOp (None, VAESKEYGENASSIST))) - [(Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "rkey.316" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Papp1 (Oword_of_int U8) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "rcon.315" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}))]); - MkI InstrInfo.witness - (Ccall InlineFun - [Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "rkey.316" |} - ; v_info := dummy_var_info |}; - Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "temp2.317" |} - ; v_info := dummy_var_info |}] - (xO (xI (xI (xO xH)))) - [(Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "rkey.316" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "temp1.318" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "temp2.317" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] - ; f_tyout := [(sword U128); (sword U128)] - ; f_res := - [{| v_var := {| vtype := (sword U128) - ; vname := "rkey.316" |} - ; v_info := dummy_var_info |}; - {| v_var := {| vtype := (sword U128) - ; vname := "temp2.317" |} - ; v_info := dummy_var_info |}] - ; f_extra := tt - ; |} ) - ; ( (* keys_expand *) xO (xO (xI xH)), - {| f_info := xO (xO (xI (xO xH))) - ; f_tyin := [(sword U128)] - ; f_params := - [{| v_var := {| vtype := (sword U128) - ; vname := "key.310" |} - ; v_info := dummy_var_info |}] - ; f_body := - [ MkI InstrInfo.witness - (Cassgn - (Laset AAscale U128 - {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.311" |} - ; v_info := dummy_var_info |} - (Pconst (Z0))) - AT_none ((sword U128)) - ((Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "key.310" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}))); - MkI InstrInfo.witness - (Copn - [Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "temp2.312" |} - ; v_info := dummy_var_info |}] - AT_keep (Oasm (* set0_128 *) (ExtOp (Oset0 U128))) []); - MkI InstrInfo.witness - (Cfor - ({| v_var := {| vtype := sint - ; vname := "round.313" |} - ; v_info := dummy_var_info |}) - ((UpTo, (Pconst (Zpos (xH)))), - (Pconst (Zpos (xI (xI (xO xH)))))) - [MkI InstrInfo.witness - (Ccall InlineFun - [Lvar - {| v_var := - {| vtype := sint - ; vname := "rcon.314" |} - ; v_info := dummy_var_info |}] - (xI (xI (xO (xO xH)))) - [(Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "round.313" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})]); - MkI InstrInfo.witness - (Ccall InlineFun - [Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "key.310" |} - ; v_info := dummy_var_info |}; - Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "temp2.312" |} - ; v_info := dummy_var_info |}] - (xO (xI (xO (xO xH)))) - [(Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "rcon.314" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "key.310" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "temp2.312" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})]); - MkI InstrInfo.witness - (Cassgn - (Laset AAscale U128 - {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.311" |} - ; v_info := dummy_var_info |} - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "round.313" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})) - AT_none ((sword U128)) - ((Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "key.310" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})))]) ] - ; f_tyout := [(sarr (xO (xO (xO (xO (xI (xI (xO xH))))))))] - ; f_res := - [{| v_var := - {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.311" |} - ; v_info := dummy_var_info |}] - ; f_extra := tt - ; |} ) - ; ( (* keys_expand_inv *) xI (xO (xO xH)), - {| f_info := xI (xO (xO (xO xH))) - ; f_tyin := [(sword U128)] - ; f_params := - [{| v_var := {| vtype := (sword U128) - ; vname := "key.305" |} - ; v_info := dummy_var_info |}] - ; f_body := - [ MkI InstrInfo.witness - (Cassgn - (Laset AAscale U128 - {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.306" |} - ; v_info := dummy_var_info |} - (Pconst (Z0))) - AT_none ((sword U128)) - ((Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "key.305" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}))); - MkI InstrInfo.witness - (Copn - [Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "temp2.307" |} - ; v_info := dummy_var_info |}] - AT_keep (Oasm (* set0_128 *) (ExtOp (Oset0 U128))) []); - MkI InstrInfo.witness - (Cfor - ({| v_var := {| vtype := sint - ; vname := "round.308" |} - ; v_info := dummy_var_info |}) - ((UpTo, (Pconst (Zpos (xH)))), - (Pconst (Zpos (xI (xI (xO xH)))))) - [MkI InstrInfo.witness - (Ccall InlineFun - [Lvar - {| v_var := - {| vtype := sint - ; vname := "rcon.309" |} - ; v_info := dummy_var_info |}] - (xI (xI (xO (xO xH)))) - [(Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "round.308" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})]); - MkI InstrInfo.witness - (Ccall InlineFun - [Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "key.305" |} - ; v_info := dummy_var_info |}; - Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "temp2.307" |} - ; v_info := dummy_var_info |}] - (xO (xI (xO (xO xH)))) - [(Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "rcon.309" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "key.305" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "temp2.307" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})]); - MkI InstrInfo.witness - (Cif - (Papp2 (Oneq Op_int) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "round.308" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pconst (Zpos (xO (xI (xO xH)))))) - [MkI InstrInfo.witness - (Copn - [Laset AAscale U128 - {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.306" |} - ; v_info := dummy_var_info |} - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "round.308" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})] - AT_keep - (Oasm (* AESIMC *) (BaseOp (None, AESIMC))) - [(Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "key.305" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})])] - [MkI InstrInfo.witness - (Cassgn - (Laset AAscale U128 - {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.306" |} - ; v_info := dummy_var_info |} - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "round.308" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})) - AT_none ((sword U128)) - ((Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "key.305" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})))])]) ] - ; f_tyout := [(sarr (xO (xO (xO (xO (xI (xI (xO xH))))))))] - ; f_res := - [{| v_var := - {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.306" |} - ; v_info := dummy_var_info |}] - ; f_extra := tt - ; |} ) - ; ( (* aes_rounds *) xI (xI (xO xH)), - {| f_info := xO (xO (xO (xO xH))) - ; f_tyin := - [(sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))); (sword U128)] - ; f_params := - [{| v_var := - {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.301" |} - ; v_info := dummy_var_info |}; - {| v_var := {| vtype := (sword U128) - ; vname := "in.302" |} - ; v_info := dummy_var_info |}] - ; f_body := - [ MkI InstrInfo.witness - (Cassgn - (Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "state.303" |} - ; v_info := dummy_var_info |}) - AT_none ((sword U128)) - ((Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "in.302" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}))); - MkI InstrInfo.witness - (Cassgn - (Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "state.303" |} - ; v_info := dummy_var_info |}) - AT_none ((sword U128)) - ((Papp2 (Olxor U128) - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "state.303" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pget AAscale U128 - {| gv := {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.301" |} - ; v_info := dummy_var_info |} ; gs := Slocal |} - (Pconst (Z0)))))); - MkI InstrInfo.witness - (Cfor - ({| v_var := {| vtype := sint - ; vname := "round.304" |} - ; v_info := dummy_var_info |}) - ((UpTo, (Pconst (Zpos (xH)))), - (Pconst (Zpos (xO (xI (xO xH)))))) - [MkI InstrInfo.witness - (Copn - [Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "state.303" |} - ; v_info := dummy_var_info |}] - AT_keep (Oasm (* AESENC *) (BaseOp (None, AESENC))) - [(Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "state.303" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Pget AAscale U128 - {| gv := {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.301" |} - ; v_info := dummy_var_info |} ; gs := Slocal |} - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "round.304" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}))])]); - MkI InstrInfo.witness - (Copn - [Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "state.303" |} - ; v_info := dummy_var_info |}] - AT_keep (Oasm (* AESENCLAST *) (BaseOp (None, AESENCLAST))) - [(Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "state.303" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Pget AAscale U128 - {| gv := {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.301" |} - ; v_info := dummy_var_info |} ; gs := Slocal |} - (Pconst (Zpos (xO (xI (xO xH))))))]) ] - ; f_tyout := [(sword U128)] - ; f_res := - [{| v_var := {| vtype := (sword U128) - ; vname := "state.303" |} - ; v_info := dummy_var_info |}] - ; f_extra := tt - ; |} ) - ; ( (* AddRoundKey *) xO (xI (xI xH)), - {| f_info := xI (xI (xI xH)) - ; f_tyin := [(sword U128); (sword U128)] - ; f_params := - [{| v_var := {| vtype := (sword U128) - ; vname := "state.299" |} - ; v_info := dummy_var_info |}; - {| v_var := {| vtype := (sword U128) - ; vname := "rk.300" |} - ; v_info := dummy_var_info |}] - ; f_body := - [ MkI InstrInfo.witness - (Cassgn - (Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "state.299" |} - ; v_info := dummy_var_info |}) - AT_none ((sword U128)) - ((Papp2 (Olxor U128) - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "state.299" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "rk.300" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})))) ] - ; f_tyout := [(sword U128)] - ; f_res := - [{| v_var := {| vtype := (sword U128) - ; vname := "state.299" |} - ; v_info := dummy_var_info |}] - ; f_extra := tt - ; |} ) - ; ( (* invaes_rounds *) xO (xO (xO xH)), - {| f_info := xI (xO (xI xH)) - ; f_tyin := - [(sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))); (sword U128)] - ; f_params := - [{| v_var := - {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.294" |} - ; v_info := dummy_var_info |}; - {| v_var := {| vtype := (sword U128) - ; vname := "in.295" |} - ; v_info := dummy_var_info |}] - ; f_body := - [ MkI InstrInfo.witness - (Cassgn - (Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "state.296" |} - ; v_info := dummy_var_info |}) - AT_none ((sword U128)) - ((Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "in.295" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}))); - MkI InstrInfo.witness - (Cassgn - (Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "rk.297" |} - ; v_info := dummy_var_info |}) - AT_none ((sword U128)) - ((Pget AAscale U128 - {| gv := {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.294" |} - ; v_info := dummy_var_info |} ; gs := Slocal |} - (Pconst (Zpos (xO (xI (xO xH)))))))); - MkI InstrInfo.witness - (Ccall InlineFun - [Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "state.296" |} - ; v_info := dummy_var_info |}] - (xO (xI (xI xH))) - [(Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "state.296" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "rk.297" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})]); - MkI InstrInfo.witness - (Cfor - ({| v_var := {| vtype := sint - ; vname := "round.298" |} - ; v_info := dummy_var_info |}) - ((DownTo, (Pconst (Z0))), (Pconst (Zpos (xI (xO (xO xH)))))) - [MkI InstrInfo.witness - (Copn - [Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "state.296" |} - ; v_info := dummy_var_info |}] - AT_keep (Oasm (* AESDEC *) (BaseOp (None, AESDEC))) - [(Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "state.296" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Pget AAscale U128 - {| gv := {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.294" |} - ; v_info := dummy_var_info |} ; gs := Slocal |} - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "round.298" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}))])]); - MkI InstrInfo.witness - (Copn - [Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "state.296" |} - ; v_info := dummy_var_info |}] - AT_keep (Oasm (* AESDECLAST *) (BaseOp (None, AESDECLAST))) - [(Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "state.296" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Pget AAscale U128 - {| gv := {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.294" |} - ; v_info := dummy_var_info |} ; gs := Slocal |} - (Pconst (Z0)))]) ] - ; f_tyout := [(sword U128)] - ; f_res := - [{| v_var := {| vtype := (sword U128) - ; vname := "state.296" |} - ; v_info := dummy_var_info |}] - ; f_extra := tt - ; |} ) - ; ( (* aes *) xO (xI xH), - {| f_info := xO (xI (xO xH)) - ; f_tyin := [(sword U128); (sword U128)] - ; f_params := - [{| v_var := {| vtype := (sword U128) - ; vname := "key.290" |} - ; v_info := dummy_var_info |}; - {| v_var := {| vtype := (sword U128) - ; vname := "in.291" |} - ; v_info := dummy_var_info |}] - ; f_body := - [ MkI InstrInfo.witness - (Ccall InlineFun - [Lvar - {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.293" |} - ; v_info := dummy_var_info |}] - (xO (xO (xI xH))) - [(Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "key.290" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})]); - MkI InstrInfo.witness - (Ccall InlineFun - [Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "out.292" |} - ; v_info := dummy_var_info |}] - (xI (xI (xO xH))) - [(Pvar - {| gv := {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.293" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "in.291" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] - ; f_tyout := [(sword U128)] - ; f_res := - [{| v_var := {| vtype := (sword U128) - ; vname := "out.292" |} - ; v_info := dummy_var_info |}] - ; f_extra := tt - ; |} ) - ; ( (* invaes *) xI xH, - {| f_info := xI (xI xH) - ; f_tyin := [(sword U128); (sword U128)] - ; f_params := - [{| v_var := {| vtype := (sword U128) - ; vname := "key.286" |} - ; v_info := dummy_var_info |}; - {| v_var := {| vtype := (sword U128) - ; vname := "in.287" |} - ; v_info := dummy_var_info |}] - ; f_body := - [ MkI InstrInfo.witness - (Ccall InlineFun - [Lvar - {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.289" |} - ; v_info := dummy_var_info |}] - (xI (xO (xO xH))) - [(Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "key.286" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})]); - MkI InstrInfo.witness - (Ccall InlineFun - [Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "out.288" |} - ; v_info := dummy_var_info |}] - (xO (xO (xO xH))) - [(Pvar - {| gv := {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.289" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "in.287" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] - ; f_tyout := [(sword U128)] - ; f_res := - [{| v_var := {| vtype := (sword U128) - ; vname := "out.288" |} - ; v_info := dummy_var_info |}] - ; f_extra := tt - ; |} ) - ; ( (* aes_jazz *) xO (xO xH), - {| f_info := xI (xO xH) - ; f_tyin := [(sword U128); (sword U128)] - ; f_params := - [{| v_var := {| vtype := (sword U128) - ; vname := "key.283" |} - ; v_info := dummy_var_info |}; - {| v_var := {| vtype := (sword U128) - ; vname := "in.284" |} - ; v_info := dummy_var_info |}] - ; f_body := - [ MkI InstrInfo.witness - (Ccall InlineFun - [Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "out.285" |} - ; v_info := dummy_var_info |}] - (xO (xI xH)) - [(Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "key.283" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "in.284" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] - ; f_tyout := [(sword U128)] - ; f_res := - [{| v_var := {| vtype := (sword U128) - ; vname := "out.285" |} - ; v_info := dummy_var_info |}] - ; f_extra := tt - ; |} ) - ; ( (* invaes_jazz *) xH, - {| f_info := xO xH - ; f_tyin := [(sword U128); (sword U128)] - ; f_params := - [{| v_var := {| vtype := (sword U128) - ; vname := "key.280" |} - ; v_info := dummy_var_info |}; - {| v_var := {| vtype := (sword U128) - ; vname := "in.281" |} - ; v_info := dummy_var_info |}] - ; f_body := - [ MkI InstrInfo.witness - (Ccall InlineFun - [Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "out.282" |} - ; v_info := dummy_var_info |}] - (xI xH) - [(Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "key.280" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "in.281" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] - ; f_tyout := [(sword U128)] - ; f_res := - [{| v_var := {| vtype := (sword U128) - ; vname := "out.282" |} - ; v_info := dummy_var_info |}] - ; f_extra := tt - ; |} ) ] ; - p_globs := [] ; - p_extra := tt |}. -Defined. - -(* use zify to use lia in a goal with ssr integers/naturals *) -(* install via opam: coq-mathcomp-zify *) -From mathcomp Require Import zify. - From Coq Require Import Utf8. From extructures Require Import ord fset fmap. Require Import micromega.Lia. -From mathcomp.word Require Import word. -From mathcomp.word Require Import ssrZ. -From JasminSSProve Require Import jasmin_utils. -Import ListNotations. +From mathcomp.word Require Import word ssrZ. +From JasminSSProve Require Import aes_jazz jasmin_utils. Import JasminNotation JasminCodeNotation. Import PackageNotation. -Require Import MSetGenTree. - -Notation RCON := (xI (xI (xO (xO xH)))). -Notation KEY_COMBINE := (xO (xI (xI (xO xH)))). -Notation KEY_EXPAND := (xO (xI (xO (xO xH)))). -Notation KEYS_EXPAND := (xO (xO (xI xH))). -Notation ADDROUNDKEY := (xO (xI (xI xH))). - Infix "^" := wxor. Definition ws_def : seq Z := [::]. @@ -1083,29 +58,6 @@ Fixpoint list_to_chtuple (l : list typed_chElement) : lchtuple [seq t.π1 | t <- end rec end. -Notation trp := (translate_prog' ssprove_jasmin_prog).1. -Notation trc := (fun fn i => translate_call ssprove_jasmin_prog fn trp i). - -(* I use trc to be able to reuse statements about the function inside other functions where theyll appear as translate_calls (and not get_translated_funs). - Furthermore, I think this is necessary to assure that all calls gets the complete list of translated functions. - Otherwise result might depend on which buffer of translated functions gets passed to the call. - In this construction we always use all of them, opposed to get_translated_fun which just uses the necessary ones (I believe). - *) - -Notation JRCON i j := (trc RCON i [('int ; j)]). -(* Notation JRCON (j : Z) := (get_tr RCON i [('int ; j)]). *) - -Notation JKEY_COMBINE i rkey temp1 temp2 := (trc KEY_COMBINE i [('word U128 ; rkey) ; ('word U128 ; temp1) ; ('word U128 ; temp2)]). -(* Notation JKEY_COMBINE rkey temp1 temp2 := (get_tr KEY_COMBINE i [('word U128 ; rkey) ; ('word U128 ; temp1) ; ('word U128 ; temp2)]). *) - -Notation JKEY_EXPAND i rcon rkey temp2 := (trc KEY_EXPAND i [ ('int ; rcon) ; ('word U128 ; rkey) ; ('word U128 ; temp2) ]). -(* Notation JKEY_EXPAND rcon rkey temp2 := (get_tr KEY_EXPAND i [ ('int ; rcon) ; ('word U128 ; rkey) ; ('word U128 ; temp2) ]). *) - -Notation JKEYS_EXPAND i rkey := (trc KEYS_EXPAND i [('word U128 ; rkey)]). -(* Notation JKEYS_EXPAND rkey := (get_tr KEYS_EXPAND i [('word U128 ; rkey)]). *) - -Notation JADDROUNDKEY state rk := (trc KEYS_EXPAND i [('word U128 ; state) ; ('word U128 ; rk)]). - Ltac destruct_pre := repeat match goal with @@ -2840,30 +1792,3 @@ Proof. replace ((Z.to_nat 10) - 1)%nat with 9%nat by reflexivity. reflexivity. lia. Qed. - -From Hacspec Require Import Hacspec_Aes_Jazz ChoiceEquality. - -Section Hacspec. - Check key_combine. - (* Check pack_eq_proof_statement _ _ _. *) - Goal forall (key temp1 temp2 : u128), True. - intros t1 t2 t3. destruct key_combine. - (* pose (get_op_default pack_state). *) - pose (get_op_default pack_state (KEY_COMBINE, - (Hacspec_Lib_Pre.int128 '× Hacspec_Lib_Pre.int128 '× Hacspec_Lib_Pre.int128, - Hacspec_Lib_Pre.int128 '× Hacspec_Lib_Pre.int128)) (t1, t2, t3)). - Check opr. - simpl. unfold IfToCEIf. simpl. apply/InP. apply -> LocationUtility.opsig_in_remove_fset. simpl. auto. - simpl in c. - reflexivity. - KEY_COMBINE. []opr pack_state KEY_COMBINE. - Lemma rxor_state : forall w1 w2, - ⊢ ⦃ true_precond ⦄ - res ← Jkey_combine ;; - ret (coerce_to_choice_type ('word U64) (hd ('word U64 ; chCanonical _) res).π2) - ≈ - state_xor w1 w2 - ⦃ fun '(a, _) '(b, _) => (a = b) ⦄. - Proof. - intros w1 w2. - unfold state_xor. diff --git a/theories/Jasmin/examples/aes/aes_hac.v b/theories/Jasmin/examples/aes/aes_hac.v new file mode 100644 index 00000000..8e7e5d27 --- /dev/null +++ b/theories/Jasmin/examples/aes/aes_hac.v @@ -0,0 +1,67 @@ +Set Warnings "-notation-overridden,-ambiguous-paths". +From mathcomp Require Import all_ssreflect all_algebra reals distr realsum + fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool + ssrnum eqtype choice seq. +Set Warnings "notation-overridden,ambiguous-paths". + +Require Import List. +Set Warnings "-notation-overridden". +From Jasmin Require Import expr. +Set Warnings "notation-overridden". +From Jasmin Require Import x86_instr_decl x86_extra. +From JasminSSProve Require Import jasmin_translate. +From Crypt Require Import Prelude Package. + +Import ListNotations. +Local Open Scope string. + +Set Bullet Behavior "Strict Subproofs". +(* Set Default Goal Selector "!". *) (* I give up on this for now. *) + +From Coq Require Import Utf8. +From extructures Require Import ord fset fmap. +Require Import micromega.Lia. +From mathcomp.word Require Import word ssrZ. +From JasminSSProve Require Import aes_jazz jasmin_utils. +Import JasminNotation JasminCodeNotation. +Import PackageNotation. + +From Hacspec Require Import Hacspec_Aes_Jazz ChoiceEquality. + +Notation call fn := (translate_call _ fn _). + +Section Hacspec. + + Lemma foo id0 rcon rkey temp2 : + ⊢ ⦃ fun '(_, _) => True ⦄ + JKEY_COMBINE id0 rcon rkey temp2 + ≈ + is_state (key_combine rcon rkey temp2) + ⦃ fun '(v0, _) '(v1, _) => + exists o1 o2, v0 = [('word U128 ; o1) ; ('word U128 ; o2)] + /\ (o1, o2) = v1 ⦄. + Proof. + unfold translate_call, translate_call_body. + Opaque translate_call. + + simpl. + unfold sopn_sem, tr_app_sopn_tuple, tr_app_sopn_single. + simpl. + + Admitted. + + + Lemma bar id0 rcon rkey temp2 : + ⊢ ⦃ fun '(_, _) => True ⦄ + JKEY_EXPAND id0 rcon rkey temp2 + ≈ + key_expand (wrepr U8 rcon) rkey temp2 + ⦃ fun '(v0, _) '(v1, _) => + exists o1 o2, v0 = [('word U128 ; o1) ; ('word U128 ; o2)] + /\ (o1, o2) = v1 ⦄. + Proof. + Transparent translate_call. + unfold translate_call, translate_call_body. + Opaque translate_call. + simpl. +Admitted. diff --git a/theories/Jasmin/examples/aes/aes_jazz.v b/theories/Jasmin/examples/aes/aes_jazz.v index 50b8906e..1c121016 100644 --- a/theories/Jasmin/examples/aes/aes_jazz.v +++ b/theories/Jasmin/examples/aes/aes_jazz.v @@ -1029,18 +1029,7 @@ Proof. p_extra := tt |}. Defined. -(* use zify to use lia in a goal with ssr integers/naturals *) -(* install via opam: coq-mathcomp-zify *) -From mathcomp Require Import zify. - -From Coq Require Import Utf8. -From extructures Require Import ord fset fmap. - -Require Import micromega.Lia. -From mathcomp.word Require Import word. -From mathcomp.word Require Import ssrZ. From JasminSSProve Require Import jasmin_utils. -Import ListNotations. Import JasminNotation JasminCodeNotation. Import PackageNotation. From e1dd8ac57be70ace28ca9032f0f6a0c4781bf16e Mon Sep 17 00:00:00 2001 From: bshvass Date: Tue, 13 Dec 2022 16:01:53 +0100 Subject: [PATCH 310/383] clean --- theories/Jasmin/examples/aes/aes_hac.v | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes_hac.v b/theories/Jasmin/examples/aes/aes_hac.v index 8e7e5d27..e5b16f29 100644 --- a/theories/Jasmin/examples/aes/aes_hac.v +++ b/theories/Jasmin/examples/aes/aes_hac.v @@ -37,17 +37,17 @@ Section Hacspec. JKEY_COMBINE id0 rcon rkey temp2 ≈ is_state (key_combine rcon rkey temp2) - ⦃ fun '(v0, _) '(v1, _) => - exists o1 o2, v0 = [('word U128 ; o1) ; ('word U128 ; o2)] + ⦃ fun '(v0, _) '(v1, _) => + exists o1 o2, v0 = [('word U128 ; o1) ; ('word U128 ; o2)] /\ (o1, o2) = v1 ⦄. Proof. unfold translate_call, translate_call_body. Opaque translate_call. - + simpl. unfold sopn_sem, tr_app_sopn_tuple, tr_app_sopn_single. simpl. - + Admitted. @@ -56,12 +56,12 @@ Section Hacspec. JKEY_EXPAND id0 rcon rkey temp2 ≈ key_expand (wrepr U8 rcon) rkey temp2 - ⦃ fun '(v0, _) '(v1, _) => - exists o1 o2, v0 = [('word U128 ; o1) ; ('word U128 ; o2)] + ⦃ fun '(v0, _) '(v1, _) => + exists o1 o2, v0 = [('word U128 ; o1) ; ('word U128 ; o2)] /\ (o1, o2) = v1 ⦄. Proof. Transparent translate_call. unfold translate_call, translate_call_body. Opaque translate_call. simpl. -Admitted. +Admitted. From f34ea2a079ebcae1c2503c5657af4e91d4a2617b Mon Sep 17 00:00:00 2001 From: bshvass Date: Tue, 13 Dec 2022 18:34:27 +0100 Subject: [PATCH 311/383] import zify --- theories/Jasmin/examples/aes/aes.v | 2 ++ 1 file changed, 2 insertions(+) diff --git a/theories/Jasmin/examples/aes/aes.v b/theories/Jasmin/examples/aes/aes.v index d699c0c5..c8e9400a 100644 --- a/theories/Jasmin/examples/aes/aes.v +++ b/theories/Jasmin/examples/aes/aes.v @@ -27,6 +27,8 @@ From JasminSSProve Require Import aes_jazz jasmin_utils. Import JasminNotation JasminCodeNotation. Import PackageNotation. +From mathcomp Require Import zify. + Infix "^" := wxor. Definition ws_def : seq Z := [::]. From 8af2a92e1b5ec474e3b249156e2ebfb4296f5586 Mon Sep 17 00:00:00 2001 From: bshvass Date: Tue, 13 Dec 2022 18:34:43 +0100 Subject: [PATCH 312/383] add notation for remaining aes functions --- theories/Jasmin/examples/aes/aes_jazz.v | 31 ++++++++++++++++++------- 1 file changed, 23 insertions(+), 8 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes_jazz.v b/theories/Jasmin/examples/aes/aes_jazz.v index 1c121016..1033c86b 100644 --- a/theories/Jasmin/examples/aes/aes_jazz.v +++ b/theories/Jasmin/examples/aes/aes_jazz.v @@ -1034,11 +1034,23 @@ Import JasminNotation JasminCodeNotation. Import PackageNotation. Notation RCON := (xI (xI (xO (xO xH)))). + Notation KEY_COMBINE := (xO (xI (xI (xO xH)))). Notation KEY_EXPAND := (xO (xI (xO (xO xH)))). +Notation KEY_EXPAND_INV := (xI (xO (xO xH))). Notation KEYS_EXPAND := (xO (xO (xI xH))). + Notation ADDROUNDKEY := (xO (xI (xI xH))). +Notation AES_ROUNDS := (xI (xI (xO xH))). +Notation INVAES_ROUNDS := (xO (xO (xO xH))). + +Notation AES := (xO (xI xH)). +Notation INVAES := (xI xH). + +Notation AES_JAZZ := (xO (xO xH)). +Notation INVAES_JAZZ := (xH). + Notation trp := (translate_prog' ssprove_jasmin_prog).1. Notation trc := (fun fn i => translate_call ssprove_jasmin_prog fn trp i). @@ -1047,17 +1059,20 @@ Notation trc := (fun fn i => translate_call ssprove_jasmin_prog fn trp i). Otherwise result might depend on which buffer of translated functions gets passed to the call. In this construction we always use all of them, opposed to get_translated_fun which just uses the necessary ones (I believe). *) - Notation JRCON i j := (trc RCON i [('int ; j)]). -(* Notation JRCON (j : Z) := (get_tr RCON i [('int ; j)]). *) Notation JKEY_COMBINE i rkey temp1 temp2 := (trc KEY_COMBINE i [('word U128 ; rkey) ; ('word U128 ; temp1) ; ('word U128 ; temp2)]). -(* Notation JKEY_COMBINE rkey temp1 temp2 := (get_tr KEY_COMBINE i [('word U128 ; rkey) ; ('word U128 ; temp1) ; ('word U128 ; temp2)]). *) - Notation JKEY_EXPAND i rcon rkey temp2 := (trc KEY_EXPAND i [ ('int ; rcon) ; ('word U128 ; rkey) ; ('word U128 ; temp2) ]). -(* Notation JKEY_EXPAND rcon rkey temp2 := (get_tr KEY_EXPAND i [ ('int ; rcon) ; ('word U128 ; rkey) ; ('word U128 ; temp2) ]). *) - +Notation JKEY_EXPAND_INV i key := (trc KEY_EXPAND_INV i [('word U128 ; key)]). Notation JKEYS_EXPAND i rkey := (trc KEYS_EXPAND i [('word U128 ; rkey)]). -(* Notation JKEYS_EXPAND rkey := (get_tr KEYS_EXPAND i [('word U128 ; rkey)]). *) -Notation JADDROUNDKEY state rk := (trc KEYS_EXPAND i [('word U128 ; state) ; ('word U128 ; rk)]). +Notation JADDROUNDKEY i state rk := (trc KEYS_EXPAND i [('word U128 ; state) ; ('word U128 ; rk)]). + +Notation JAES_ROUNDS i rkeys m := (trc AES_ROUNDS i [('array U128 ; rkeys) ; ('word U128 ; m)]). +Notation JINVAES_ROUNDS i rkeys m := (trc INVAES_ROUNDS i [('array U128 ; rkeys) ; ('word U128 ; m)]). + +Notation JAES i key m := (trc AES i [('word U128 ; key) ; ('word U128 ; m)]). +Notation JINVAES i key m := (trc INVAES i [('word U128 ; key) ; ('word U128 ; m)]). + +Notation JAES_JAZZ i key m := (trc AES i [('word U128 ; key) ; ('word U128 ; m)]). +Notation JINVAES_JAZZ i key m := (trc AES i [('word U128 ; key) ; ('word U128 ; m)]). From cb6eb95956974ecb6186b2ab20aa97d1fa09c7b6 Mon Sep 17 00:00:00 2001 From: bshvass Date: Tue, 13 Dec 2022 18:44:29 +0100 Subject: [PATCH 313/383] minor fix --- theories/Jasmin/examples/aes/aes_jazz.v | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes_jazz.v b/theories/Jasmin/examples/aes/aes_jazz.v index 1033c86b..b986217d 100644 --- a/theories/Jasmin/examples/aes/aes_jazz.v +++ b/theories/Jasmin/examples/aes/aes_jazz.v @@ -1068,8 +1068,8 @@ Notation JKEYS_EXPAND i rkey := (trc KEYS_EXPAND i [('word U128 ; rkey)]). Notation JADDROUNDKEY i state rk := (trc KEYS_EXPAND i [('word U128 ; state) ; ('word U128 ; rk)]). -Notation JAES_ROUNDS i rkeys m := (trc AES_ROUNDS i [('array U128 ; rkeys) ; ('word U128 ; m)]). -Notation JINVAES_ROUNDS i rkeys m := (trc INVAES_ROUNDS i [('array U128 ; rkeys) ; ('word U128 ; m)]). +Notation JAES_ROUNDS i rkeys m := (trc AES_ROUNDS i [('array ; rkeys) ; ('word U128 ; m)]). +Notation JINVAES_ROUNDS i rkeys m := (trc INVAES_ROUNDS i [('array ; rkeys) ; ('word U128 ; m)]). Notation JAES i key m := (trc AES i [('word U128 ; key) ; ('word U128 ; m)]). Notation JINVAES i key m := (trc INVAES i [('word U128 ; key) ; ('word U128 ; m)]). From 065478124b18bec78dad6aa3248fb984aee12261 Mon Sep 17 00:00:00 2001 From: bshvass Date: Wed, 14 Dec 2022 02:40:54 +0100 Subject: [PATCH 314/383] clean and minor fix --- theories/Jasmin/examples/aes/aes.v | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes.v b/theories/Jasmin/examples/aes/aes.v index c8e9400a..50868676 100644 --- a/theories/Jasmin/examples/aes/aes.v +++ b/theories/Jasmin/examples/aes/aes.v @@ -134,8 +134,8 @@ Ltac pdisj_apply h := Definition rcon (i : Z) : u8 := nth (wrepr U8 54%Z) [:: (wrepr U8 1%Z); (wrepr U8 2%Z); (wrepr U8 4%Z); (wrepr U8 8%Z); (wrepr U8 16%Z); (wrepr U8 32%Z); (wrepr U8 64%Z); (wrepr U8 128%Z); (wrepr U8 27%Z); (wrepr U8 54%Z)]%Z ((Z.to_nat i) - 1). -Notation hdtc res := (coerce_to_choice_type ('array) (hd ('word U64 ; chCanonical _) res).π2). Notation call fn := (translate_call _ fn _). +Notation hdtcA res := (coerce_to_choice_type ('array) (hd ('word U64 ; chCanonical _) res).π2). Definition key_expand (wn1 : u128) (rcon : u8) : 'word U128 := let rcon := zero_extend U32 rcon (* W4u8 *) (* U32 4 *) (* [tuple rcon ; 0%R; 0%R; 0%R] *) (* [toword rcon; 0%Z; 0%Z; 0%Z] *) in @@ -158,7 +158,6 @@ Lemma rcon_correct id0 pre i : ≈ ret tt ⦃ fun '(v0, s0) '(v1, s1) => pre (s0, s1) /\ exists o, v0 = ([('int ; o)] : tchlist) /\ o = wunsigned (rcon i) ⦄. Proof. - unfold get_tr, get_translated_fun. intros Hpdisj H. simpl_fun. repeat setjvars. @@ -496,7 +495,7 @@ Qed. Lemma subword_make_vec {ws1} i (ws2 : wsize.wsize) (l : seq (word.word ws1)) : (ws1 <= ws2)%nat -> - ((i + 1) * ws1 < ws2)%nat -> + ((i + 1) * ws1 <= ws2)%nat -> subword (i * ws1) ws1 (make_vec ws2 l) = nth word0 l i. Proof. intros H1 H2. @@ -1459,13 +1458,13 @@ Proof. eapply HQ. eassumption. eassumption. Qed. -Lemma keyExpansionE pre id0 rkey : +Lemma keyExpansion_E pre id0 rkey : (pdisj pre id0 [fset rkeys]) -> ⊢ ⦃ fun '(h0, h1) => pre (h0, h1) ⦄ JKEYS_EXPAND id0 rkey ≈ keyExpansion rkey - ⦃ fun '(v0, h0) '(v1, h1) => pre (h0, h1) /\ (to_arr U128 (mkpos 11) (hdtc v0)) = v1 ⦄. + ⦃ fun '(v0, h0) '(v1, h1) => pre (h0, h1) /\ (to_arr U128 (mkpos 11) (hdtcA v0)) = v1 ⦄. Proof. intros disj. unfold translate_call. @@ -1686,17 +1685,17 @@ Proof. Qed. (* without the pre in the post, try to remove this and generalize lemmas instead *) -Lemma keyExpansionE' pre id0 rkey : +Lemma keyExpansion_E' pre id0 rkey : (pdisj pre id0 [fset rkeys]) -> ⊢ ⦃ fun '(h0, h1) => pre (h0, h1) ⦄ JKEYS_EXPAND id0 rkey ≈ keyExpansion rkey - ⦃ fun '(v0, _) '(v1, _) => (to_arr U128 (mkpos 11) (hdtc v0)) = v1 ⦄. + ⦃ fun '(v0, _) '(v1, _) => (to_arr U128 (mkpos 11) (hdtcA v0)) = v1 ⦄. Proof. intros. eapply rpost_weaken_rule. - eapply keyExpansionE. + eapply keyExpansion_E. assumption. intros. destruct a₀, a₁. @@ -1710,12 +1709,12 @@ Lemma keys_expand_jazz_correct pre id0 rkey : JKEYS_EXPAND id0 rkey ≈ ret tt - ⦃ fun '(v0, _) '(_, _) => forall i, 0 <= i < 11 -> getmd (to_arr U128 (mkpos 11) (hdtc v0)) word0 i = key_i rkey (Z.to_nat i) ⦄. + ⦃ fun '(v0, _) '(_, _) => forall i, 0 <= i < 11 -> getmd (to_arr U128 (mkpos 11) (hdtcA v0)) word0 i = key_i rkey (Z.to_nat i) ⦄. Proof. intros h. eapply u_trans_det' with (P0 := fun '(_, _) => True) (P1 := fun '(_, _) => _). 7: { eapply aes_keyExpansion_h. } - 6: { eapply keyExpansionE'. eassumption. } + 6: { eapply keyExpansion_E'. eassumption. } - easy. - easy. - intros. simpl in *. rewrite H. apply H0. assumption. From 6d38cec329eeb71f1ab773553de5528186aee43c Mon Sep 17 00:00:00 2001 From: bshvass Date: Wed, 14 Dec 2022 02:43:47 +0100 Subject: [PATCH 315/383] several word lemmas and more AES --- theories/Jasmin/examples/aes/aes.v | 362 +++++++++++++++++++++++++++-- 1 file changed, 343 insertions(+), 19 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes.v b/theories/Jasmin/examples/aes/aes.v index 50868676..0fbe07a8 100644 --- a/theories/Jasmin/examples/aes/aes.v +++ b/theories/Jasmin/examples/aes/aes.v @@ -656,6 +656,127 @@ Proof. by rewrite !wxorE addbA. Qed. +Lemma nth_split_vec {ws1} ws2 n (d : word.word ws2) (w : word.word ws1) : + (n < ws1 %/ ws2 + ws1 %% ws2)%nat -> + nth d (split_vec ws2 w) n = subword (n * ws2) ws2 w. +Proof. + intros H. + unfold split_vec. + erewrite nth_map. + f_equal. + rewrite nth_iota. + lia. + assumption. + rewrite size_iota. + assumption. + Unshelve. exact 0%nat. +Qed. + +Lemma subword_U8_SubWord n w : + (0 <= n < 4)%nat -> + subword (n * U8) U8 (SubWord w) = Sbox (subword (n * U8) U8 w). +Proof. + intros. + unfold SubWord. + rewrite subword_make_vec. + erewrite nth_map. + f_equal. + apply nth_split_vec. + cbn. simpl. lia. + simpl. lia. cbn. simpl. lia. + unfold nat_of_wsize, wsize_size_minus_1. zify. simpl. nia. + Unshelve. exact word0. +Qed. + +Lemma split_vec_make_vec {ws1} (ws2 : wsize.wsize) (l : seq (word.word ws1)) : + (ws2 %% ws1 = 0)%nat -> + (size l = ws2 %/ ws1)%nat -> + split_vec ws1 (make_vec ws2 l) = l. +Proof. + destruct l. + - simpl. + intros . + unfold make_vec. + simpl. + unfold split_vec. + rewrite -H0 H. + simpl. + reflexivity. + - intros Hmod Hsize. + simpl. + unfold split_vec. + rewrite <- take_size. + erewrite <- map_nth_iota0. + rewrite Hsize. rewrite Hmod. + rewrite addn0. + apply map_ext. + intros. + apply subword_make_vec. + simpl in Hsize. zify. nia. + move: H => /InP. rewrite mem_iota. + intros H. zify. nia. + easy. +Qed. + +Lemma SubWord_make_vec l : + (size l = 4)%nat -> + SubWord (make_vec U32 l) = make_vec U32 [seq Sbox i | i <- l]. +Proof. + intros. + unfold SubWord. + rewrite split_vec_make_vec. + easy. + unfold nat_of_wsize, wsize_size_minus_1. + easy. + unfold nat_of_wsize, wsize_size_minus_1. + easy. +Qed. + +Lemma ShiftRows_SubBytes s : ShiftRows (SubBytes s) = SubBytes (ShiftRows s). +Proof. + unfold ShiftRows, SubBytes. simpl. + f_equal. f_equal. + rewrite !subword_make_vec_32_0_32_128. simpl. + rewrite !subword_make_vec_32_1_32_128. simpl. + rewrite !subword_make_vec_32_2_32_128. simpl. + rewrite !subword_make_vec_32_3_32_128. simpl. + rewrite -> !subword_U8_SubWord by lia. + rewrite -> !SubWord_make_vec by reflexivity. + simpl. reflexivity. + f_equal. + rewrite !subword_make_vec_32_0_32_128. simpl. + rewrite !subword_make_vec_32_1_32_128. simpl. + rewrite !subword_make_vec_32_2_32_128. simpl. + (* rewrite !subword_make_vec_32_3_32_128. simpl. *) + rewrite -> !subword_U8_SubWord by lia. + rewrite -> !SubWord_make_vec by reflexivity. + simpl. reflexivity. + f_equal. + rewrite !subword_make_vec_32_0_32_128. simpl. + rewrite !subword_make_vec_32_1_32_128. simpl. + rewrite !subword_make_vec_32_2_32_128. simpl. + rewrite !subword_make_vec_32_3_32_128. simpl. + rewrite -> !subword_U8_SubWord by lia. + rewrite -> !SubWord_make_vec by reflexivity. + simpl. reflexivity. + f_equal. + rewrite !subword_make_vec_32_0_32_128. simpl. + rewrite !subword_make_vec_32_1_32_128. simpl. + rewrite !subword_make_vec_32_2_32_128. simpl. + rewrite !subword_make_vec_32_3_32_128. simpl. + rewrite -> !subword_U8_SubWord by lia. + rewrite -> !SubWord_make_vec by reflexivity. + simpl. reflexivity. +Qed. + +Lemma wAESENC_wAESENC_ s k : wAESENC s k = wAESENC_ s k. +Proof. + unfold wAESENC, wAESENC_. + f_equal. f_equal. + rewrite ShiftRows_SubBytes. + reflexivity. +Qed. + Lemma wror_substitute w k : wror (SubWord w) k = SubWord (wror w k). Proof. (* I would like to case on w, but not sure how to do this most efficiently? *) @@ -1073,6 +1194,27 @@ Proof. lia. Qed. +Lemma translate_for_rule_weaken (pre : precond) (I : Z -> heap * heap -> Prop) lo hi (v : var_i) m_id s_id (body1 : p_id -> p_id * raw_code 'unit) body2 : + (forall h0 h1, pre (h0, h1) -> I lo (h0, h1)) -> + (* it is annoying that this is a proof obligation, since its true for all translated programs, but I don't know how to prove the theorem without it *) + (forall s_id', s_id' ⪯ (body1 s_id').1) -> + lo <= hi -> + (forall i s_id', (s_id ⪯ s_id') -> (lo <= i < hi) -> + ⊢ ⦃ λ '(s₀, s₁), set_lhs (translate_var m_id v) (truncate_el (vtype v) (i : chInt)) (I i) (s₀, s₁) ⦄ + let (_, body1') := body1 s_id' in + body1' + ≈ body2 i ⦃ λ '(_, s₀) '(_, s₁), I (Z.succ i) (s₀,s₁) ⦄) → + ⊢ ⦃ pre ⦄ + translate_for v (wrange UpTo lo hi) m_id body1 s_id + ≈ for_loop' body2 lo hi + ⦃ λ '(_,s₀) '(_,s₁), I hi (s₀,s₁) ⦄. +Proof. + intros. + eapply rpre_weaken_rule. + eapply translate_for_rule. + all: easy. +Qed. + Opaque translate_for. From Relational Require Import OrderEnrichedCategory @@ -1725,71 +1867,253 @@ Admitted. Definition aes (key msg : u128) := let state := wxor msg (key_i key 0) in - let state := iteri 9 (fun i state => AESENC_ state (key_i key (i + 1))) state in - AESENCLAST_ state (key_i key 10). + let state := iteri 9 (fun i state => wAESENC_ state (key_i key (i + 1))) state in + wAESENCLAST_ state (key_i key 10). Definition invaes (key cipher : u128) := let state := wxor cipher (key_i key 10) in - let state := iteri 9 (fun i state => AESDEC_ state (key_i key (10 -(i + 1)))) state in + let state := iteri 9 (fun i state => wAESDEC_ state (key_i key (10 -(i + 1)))) state in wAESDECLAST state (key_i key 0). (* Definition rkeys : Location := () *) (* Definition (rkeys : chMap 'int ('word U128)) (msg : 'word U128) := *) Definition state : Location := ( 'word U128 ; 0%nat). -Definition aes_rounds (rkeys : 'arr U128) (msg : 'word U128) := +Definition aes_rounds (rkeys : 'arr U128) (msg : 'word U128) : raw_code u128 := #put state := wxor msg (getmd rkeys word0 0) ;; for_loop' (fun i => state0 ← get state ;; - #put state := AESENC_ state0 (getmd rkeys word0 i) ;; + #put state := wAESENC_ state0 (getmd rkeys word0 i) ;; ret tt ) 1 10 ;; state0 ← get state ;; - #put state := AESENCLAST_ state0 (getmd rkeys word0 10) ;; + #put state := wAESENCLAST_ state0 (getmd rkeys word0 10) ;; state0 ← get state ;; ret state0. Lemma aes_rounds_h rkeys k m : - (forall i, 0 <= i < 11 -> getmd rkeys word0 i = key_i k (Z.to_nat i)) -> - ⊢ ⦃ fun '(_, _) => True ⦄ + ⊢ ⦃ fun '(_, _) => (forall i, 0 <= i < 11 -> getmd rkeys word0 i = key_i k (Z.to_nat i)) ⦄ aes_rounds rkeys m ≈ ret tt ⦃ fun '(v0, _) '(_, _) => v0 = aes k m ⦄. Proof. unfold aes_rounds. - intros H. eapply r_put_lhs with (pre := fun _ => _). eapply r_bind with (m₁ := ret _). set (st0 := m ⊕ (key_i k 0%nat)). eapply u_for_loop'_rule' with - (I := fun i => fun h => get_heap h state = iteri (Z.to_nat i - 1) (fun i state => AESENC_ state (key_i k (i + 1))) st0). + (I := fun i => fun h => get_heap h state = iteri (Z.to_nat i - 1) (fun i state => wAESENC_ state (key_i k (i + 1))) st0 + /\ (forall i, 0 <= i < 11 -> getmd rkeys word0 i = key_i k (Z.to_nat i))). - lia. - intros. simpl. - destruct_pre. sheap. rewrite H. reflexivity. lia. + destruct_pre. sheap. split_post. + + rewrite H1. reflexivity. lia. + + assumption. - intros i Hi. eapply r_get_remember_lhs with (pre := fun '(_, _) => _). intros x. eapply r_put_lhs. eapply r_ret. intros s0 s1 pre. - destruct_pre; sheap. - replace (Z.to_nat (Z.succ i) - 1)%nat with ((Z.to_nat i - 1).+1) by lia. - rewrite iteriS. - rewrite H5. - rewrite H. repeat f_equal. lia. lia. + destruct_pre; sheap; split_post. + + replace (Z.to_nat (Z.succ i) - 1)%nat with ((Z.to_nat i - 1).+1) by lia. + rewrite iteriS. + rewrite H0. + rewrite H6. repeat f_equal. lia. lia. + + assumption. - intros a0 a1. eapply r_get_remember_lhs with (pre := fun '(_, _) => _). intros x. eapply r_put_lhs. eapply r_get_remember_lhs. intros x0. eapply r_ret. intros s0 s1 pre. - Opaque getmd. - destruct pre as [[s2 [[H4 H3] H2]] H1]. + destruct pre as [[s2 [[[H5 H4] H3] H2]] H1]. simpl in H3, H1. subst. sheap. unfold aes. rewrite H4. - rewrite H. + rewrite H5. replace ((Z.to_nat 10) - 1)%nat with 9%nat by reflexivity. reflexivity. lia. Qed. + +Notation hdtc128 res := (coerce_to_choice_type ('word U128) (hd ('word U128 ; chCanonical _) res).π2). + +Lemma getmd_to_arr a ws len x i : + (0 <= i < len) -> + getmd (to_arr ws len a) x i = chArray_get ws a i (wsize_size ws). +Proof. + intros. + unfold getmd. + rewrite getm_to_arr. + reflexivity. + assumption. +Qed. + +(* NOTE: This is only so simple because InvMixColumns is not properly implemented *) +Lemma AESDEC_AESDEC_ s k : wAESDEC s (InvMixColumns k) = wAESDEC_ s k. +Proof. + unfold wAESDEC, wAESDEC_. + unfold InvMixColumns. + reflexivity. +Qed. + +Lemma wAESENCLAST_wAESENCLAST_ s k : wAESENCLAST s k = wAESENCLAST_ s k. +Proof. + unfold wAESENCLAST, wAESENCLAST_. + rewrite ShiftRows_SubBytes. + reflexivity. +Qed. + +Lemma aes_rounds_E pre id0 rkeys msg : + (pdisj pre id0 [fset state]) -> + ⊢ ⦃ fun '(h0, h1) => pre (h0, h1) ⦄ + JAES_ROUNDS id0 rkeys msg + ≈ + aes_rounds (to_arr U128 (mkpos 11) rkeys) msg + ⦃ fun '(v0, h0) '(v1, h1) => pre (h0, h1) /\ hdtc128 v0 = v1 ⦄. +Proof. + + intros disj. + Transparent translate_call. + unfold translate_call. + unfold translate_call_body. + + Opaque translate_call. + Opaque wrange. + Opaque for_loop'. + + simpl. simpl_fun. + repeat setjvars. + ssprove_code_simpl. + ssprove_code_simpl_more. + unfold aes_rounds. + + repeat clear_get. + do 4 eapply r_put_lhs. + eapply r_put_rhs. + + eapply r_bind. + - eapply translate_for_rule_weaken with + (I := fun i => fun '(h0, h1) => pre (h0, h1) + /\ get_heap h0 state = get_heap h1 aes.state + /\ get_heap h0 rkeys0 = rkeys). + + intros; destruct_pre. + rewrite !zero_extend_u. + rewrite !coerce_to_choice_type_K. + sheap. + split_post. + * pdisj_apply disj. + * rewrite getmd_to_arr. reflexivity. lia. + * reflexivity. + + intros. simpl. auto with preceq. + + lia. + + intros. + repeat (eapply r_get_remember_lhs; intros). + eapply r_put_lhs. + eapply r_get_remember_rhs; intros. + eapply r_put_rhs. + eapply r_ret. + intros s0 s1 Hpre; destruct_pre. + unfold tr_app_sopn_tuple. + simpl. + rewrite !zero_extend_u. + rewrite !coerce_to_choice_type_K. + sheap. + split_post. + * pdisj_apply disj. + * rewrite -> H12. + rewrite wAESENC_wAESENC_. + rewrite getmd_to_arr. + reflexivity. lia. + * reflexivity. + - intros a0 a. + eapply r_get_remember_lhs with (pre := fun '(_, _) => _). intros x. + eapply r_get_remember_lhs. intros x0. + eapply r_put_lhs. + eapply r_get_remember_lhs. intros x1. + + eapply r_get_remember_rhs. intros x2. + eapply r_put_rhs. + eapply r_get_remember_rhs. intros x3. + eapply r_ret. + + intros s0 s1 Hpre; destruct_pre. + rewrite !coerce_to_choice_type_K. + rewrite !zero_extend_u. + sheap. + split_post. + + pdisj_apply disj. + + unfold tr_app_sopn_tuple. + simpl. + rewrite !zero_extend_u. + rewrite -> H6. + rewrite getmd_to_arr. + rewrite wAESENCLAST_wAESENCLAST_. + reflexivity. + lia. +Qed. + +Definition Caes (key msg : u128) := + rkeys ← keyExpansion key ;; + cipher ← aes_rounds rkeys msg ;; + ret cipher. + +Lemma aes_h k m : + (* (forall i, (0 <= i < 11)%nat -> rkeys i = Some (key_i k i)) -> *) + ⊢ ⦃ fun '(_, _) => True ⦄ + Caes k m + ≈ + ret tt + ⦃ fun '(v0, _) '(_, _) => v0 = aes k m ⦄. +Proof. + unfold Caes. + eapply r_bind with (m₁ := ret _). + - eapply aes_keyExpansion_h. + - intros a0 []. + eapply r_bind with (m₁ := ret _). + eapply aes_rounds_h. + intros a1 []. + eapply r_ret. + intros. + assumption. +Qed. + +Lemma aes_E pre id0 k m : + (pdisj pre id0 fset0) -> + ⊢ ⦃ fun '(h0, h1) => pre (h0, h1) ⦄ + JAES id0 k m + ≈ + Caes k m + ⦃ fun '(v0, h0) '(v1, h1) => pre (h0, h1) /\ hdtc128 v0 = v1 ⦄. +Proof. + intros disj. + Transparent translate_call. + unfold translate_call. + unfold translate_call_body. + + Opaque translate_call. + Opaque wrange. + Opaque for_loop'. + + simpl. + (* a bit too slow *) + (* simpl_fun. *) + (* repeat setjvars. *) + + (* eapply r_put_lhs. *) + (* eapply r_put_lhs. *) + (* eapply r_get_remember_lhs. intros. *) + (* (* eapply r_bind. *) *) + (* rewrite !bind_assoc. *) + + (* ssprove_code_simpl. *) + (* ssprove_code_simpl_more. *) + (* unfold aes_rounds. *) + + (* repeat clear_get. *) + (* do 4 eapply r_put_lhs. *) + (* eapply r_put_rhs. *) + + (* eapply r_bind. *) + From 0245e7a3cda53502078fea7ea445ab58ce7bb46a Mon Sep 17 00:00:00 2001 From: bshvass Date: Wed, 14 Dec 2022 11:07:45 +0100 Subject: [PATCH 316/383] static translation for better control over reductions in proofs --- theories/Jasmin/examples/aes/aes_jazz.v | 46 ++++++++++++++++--------- theories/Jasmin/jasmin_translate.v | 15 ++++++++ 2 files changed, 44 insertions(+), 17 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes_jazz.v b/theories/Jasmin/examples/aes/aes_jazz.v index b986217d..714072c0 100644 --- a/theories/Jasmin/examples/aes/aes_jazz.v +++ b/theories/Jasmin/examples/aes/aes_jazz.v @@ -1054,25 +1054,37 @@ Notation INVAES_JAZZ := (xH). Notation trp := (translate_prog' ssprove_jasmin_prog).1. Notation trc := (fun fn i => translate_call ssprove_jasmin_prog fn trp i). -(* I use trc to be able to reuse statements about the function inside other functions where theyll appear as translate_calls (and not get_translated_funs). - Furthermore, I think this is necessary to assure that all calls gets the complete list of translated functions. - Otherwise result might depend on which buffer of translated functions gets passed to the call. - In this construction we always use all of them, opposed to get_translated_fun which just uses the necessary ones (I believe). - *) -Notation JRCON i j := (trc RCON i [('int ; j)]). +Notation funlist := [seq f.1 | f <- p_funcs ssprove_jasmin_prog]. -Notation JKEY_COMBINE i rkey temp1 temp2 := (trc KEY_COMBINE i [('word U128 ; rkey) ; ('word U128 ; temp1) ; ('word U128 ; temp2)]). -Notation JKEY_EXPAND i rcon rkey temp2 := (trc KEY_EXPAND i [ ('int ; rcon) ; ('word U128 ; rkey) ; ('word U128 ; temp2) ]). -Notation JKEY_EXPAND_INV i key := (trc KEY_EXPAND_INV i [('word U128 ; key)]). -Notation JKEYS_EXPAND i rkey := (trc KEYS_EXPAND i [('word U128 ; rkey)]). +Definition static_fun fn := (fn, match assoc trp fn with Some c => c | None => fun _ => ret tt end). -Notation JADDROUNDKEY i state rk := (trc KEYS_EXPAND i [('word U128 ; state) ; ('word U128 ; rk)]). +Definition static_funs := [seq static_fun f | f <- funlist]. -Notation JAES_ROUNDS i rkeys m := (trc AES_ROUNDS i [('array ; rkeys) ; ('word U128 ; m)]). -Notation JINVAES_ROUNDS i rkeys m := (trc INVAES_ROUNDS i [('array ; rkeys) ; ('word U128 ; m)]). +Definition strp := (translate_prog_static ssprove_jasmin_prog static_funs). +Opaque strp. -Notation JAES i key m := (trc AES i [('word U128 ; key) ; ('word U128 ; m)]). -Notation JINVAES i key m := (trc INVAES i [('word U128 ; key) ; ('word U128 ; m)]). +Definition get_translated_static_fun P fn st_func := + match assoc (translate_prog_static P st_func).2 fn with + | Some f => f + | None => fun _ _ => ret [::] + end. -Notation JAES_JAZZ i key m := (trc AES i [('word U128 ; key) ; ('word U128 ; m)]). -Notation JINVAES_JAZZ i key m := (trc AES i [('word U128 ; key) ; ('word U128 ; m)]). +Definition call fn i := (get_translated_static_fun ssprove_jasmin_prog fn static_funs i). + +Notation JRCON i j := (call RCON i [('int ; j)]). + +Notation JKEY_COMBINE i rkey temp1 temp2 := (call KEY_COMBINE i [('word U128 ; rkey) ; ('word U128 ; temp1) ; ('word U128 ; temp2)]). +Notation JKEY_EXPAND i rcon rkey temp2 := (call KEY_EXPAND i [ ('int ; rcon) ; ('word U128 ; rkey) ; ('word U128 ; temp2) ]). +Notation JKEY_EXPAND_INV i key := (call KEY_EXPAND_INV i [('word U128 ; key)]). +Notation JKEYS_EXPAND i rkey := (call KEYS_EXPAND i [('word U128 ; rkey)]). + +Notation JADDROUNDKEY i state rk := (call KEYS_EXPAND i [('word U128 ; state) ; ('word U128 ; rk)]). + +Notation JAES_ROUNDS i rkeys m := (call AES_ROUNDS i [('array ; rkeys) ; ('word U128 ; m)]). +Notation JINVAES_ROUNDS i rkeys m := (call INVAES_ROUNDS i [('array ; rkeys) ; ('word U128 ; m)]). + +Notation JAES i key m := (call AES i [('word U128 ; key) ; ('word U128 ; m)]). +Notation JINVAES i key m := (call INVAES i [('word U128 ; key) ; ('word U128 ; m)]). + +Notation JAES_JAZZ i key m := (call AES i [('word U128 ; key) ; ('word U128 ; m)]). +Notation JINVAES_JAZZ i key m := (call AES i [('word U128 ; key) ; ('word U128 ; m)]). diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index d818848e..50f93bbb 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -4374,6 +4374,21 @@ Definition translate_funs (P : uprog) : seq _ufun_decl → fdefs * ssprove_prog Definition translate_prog' P := translate_funs P (p_funcs P). +Fixpoint translate_funs_static (P : uprog) (fs : seq _ufun_decl) (st_funcs : fdefs) : fdefs * ssprove_prog := + match fs with + | [::] => ([::], [::]) + | f :: fs' => + let '(tr_fs', tr_p') := translate_funs_static P fs' st_funcs in + let '(fn, f_extra) := f in + let tr_body := fun sid => (translate_cmd P st_funcs (f_body f_extra) sid sid).2 in + let tr_fs := (fn, tr_body) :: tr_fs' in + let tr_p := (fn, translate_call_body P fn tr_body) :: tr_p' in + (tr_fs, tr_p) + end. + +Definition translate_prog_static P st_funcs := + translate_funs_static P (p_funcs P) st_funcs. + Lemma tr_prog_inv {P fn f} : get_fundef (p_funcs P) fn = Some f → ∑ fs' l, From 75abb7731ef1a373127e7b27eb43b319b7049f04 Mon Sep 17 00:00:00 2001 From: bshvass Date: Wed, 14 Dec 2022 11:23:35 +0100 Subject: [PATCH 317/383] match proofs to new translation --- theories/Jasmin/examples/aes/aes.v | 55 +++++++++++++++--------------- 1 file changed, 28 insertions(+), 27 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes.v b/theories/Jasmin/examples/aes/aes.v index 0fbe07a8..8dae3e92 100644 --- a/theories/Jasmin/examples/aes/aes.v +++ b/theories/Jasmin/examples/aes/aes.v @@ -134,7 +134,6 @@ Ltac pdisj_apply h := Definition rcon (i : Z) : u8 := nth (wrepr U8 54%Z) [:: (wrepr U8 1%Z); (wrepr U8 2%Z); (wrepr U8 4%Z); (wrepr U8 8%Z); (wrepr U8 16%Z); (wrepr U8 32%Z); (wrepr U8 64%Z); (wrepr U8 128%Z); (wrepr U8 27%Z); (wrepr U8 54%Z)]%Z ((Z.to_nat i) - 1). -Notation call fn := (translate_call _ fn _). Notation hdtcA res := (coerce_to_choice_type ('array) (hd ('word U64 ; chCanonical _) res).π2). Definition key_expand (wn1 : u128) (rcon : u8) : 'word U128 := @@ -158,6 +157,9 @@ Lemma rcon_correct id0 pre i : ≈ ret tt ⦃ fun '(v0, s0) '(v1, s1) => pre (s0, s1) /\ exists o, v0 = ([('int ; o)] : tchlist) /\ o = wunsigned (rcon i) ⦄. Proof. + unfold JRCON. + unfold get_translated_static_fun. + simpl. intros Hpdisj H. simpl_fun. repeat setjvars. @@ -175,7 +177,6 @@ Qed. Definition W4u8 : 4.-tuple u8 -> u32 := wcat. Definition W4u32 : 4.-tuple u32 -> u128 := wcat. - Notation "m ⊕ k" := (@word.word.wxor _ m k) (at level 20). Lemma lsr_word0 {ws1} a : @lsr ws1 word0 a = word0. @@ -988,6 +989,8 @@ Lemma key_expandP pre id0 rcon rkey temp2 rcon_ : subword 0 U32 o2 = word0 ⦄. Proof. + unfold JKEY_EXPAND. + unfold get_translated_static_fun. intros disj Hrcon Htemp2. simpl_fun. repeat setjvars. @@ -1609,9 +1612,12 @@ Lemma keyExpansion_E pre id0 rkey : ⦃ fun '(v0, h0) '(v1, h1) => pre (h0, h1) /\ (to_arr U128 (mkpos 11) (hdtcA v0)) = v1 ⦄. Proof. intros disj. - unfold translate_call. - unfold translate_call_body. + unfold JKEYS_EXPAND. + unfold get_translated_static_fun. + unfold translate_prog_static. + unfold translate_funs_static. + unfold translate_call_body. Opaque translate_call. Opaque wrange. Opaque for_loop'. @@ -1649,9 +1655,6 @@ Proof. * intros i s_id Hs_id ile. ssprove_code_simpl. - (* NB: Do not rewrite here, since it breaks unification when trying to apply other correctness lemmas *) - (* rewrite !coerce_to_choice_type_K. *) - eapply r_get_remember_lhs. intros. (* Now we apply the correctnes of rcon *) @@ -1685,10 +1688,11 @@ Proof. (* we need to know the value of a0 here *) eapply rpre_weak_hypothesis_rule'; intros. destruct_pre; simpl. + fold rcon. repeat clear_get. eapply r_put_lhs with (pre := λ '(s0',s1'), _ ). - eapply r_get_remember_lhs. intros x0. eapply r_get_remember_lhs. intros x1. + eapply r_get_remember_lhs. intros x2. sheap. eapply r_bind with (m₁ := ret _) (f₁ := fun _ => _). @@ -1696,7 +1700,7 @@ Proof. (* First we apply correctness of key_expandP *) *** (* Here the rewrite is necessary. How should correctness be phrased in general such that this is not important? *) rewrite !coerce_to_choice_type_K. - eapply key_expandP with (id0 := (s_id~0~1)%positive) (rcon := (wunsigned (rcon i))) (rkey := x0) (temp2 := x1) (rcon_ := rcon i). + eapply key_expandP with (id0 := (s_id~0~1)%positive) (rcon := (wunsigned (aes.rcon i))) (rkey := x1) (temp2 := x2) (rcon_ := aes.rcon i). (* again, we have to prove that our precond does not depend key_expand locations *) { split. (* key_expandP also does not use variables on the rhs *) @@ -1973,11 +1977,12 @@ Lemma aes_rounds_E pre id0 rkeys msg : aes_rounds (to_arr U128 (mkpos 11) rkeys) msg ⦃ fun '(v0, h0) '(v1, h1) => pre (h0, h1) /\ hdtc128 v0 = v1 ⦄. Proof. - - intros disj. - Transparent translate_call. - unfold translate_call. + unfold JAES_ROUNDS. + unfold get_translated_static_fun. + unfold translate_prog_static. + unfold translate_funs_static. unfold translate_call_body. + intros disj. Opaque translate_call. Opaque wrange. @@ -2087,23 +2092,19 @@ Lemma aes_E pre id0 k m : Caes k m ⦃ fun '(v0, h0) '(v1, h1) => pre (h0, h1) /\ hdtc128 v0 = v1 ⦄. Proof. - intros disj. - Transparent translate_call. - unfold translate_call. + unfold JAES. + unfold get_translated_static_fun. + unfold translate_prog_static. + unfold translate_funs_static. unfold translate_call_body. + intros disj. - Opaque translate_call. - Opaque wrange. - Opaque for_loop'. - - simpl. - (* a bit too slow *) - (* simpl_fun. *) - (* repeat setjvars. *) + simpl. simpl_fun. + repeat setjvars. - (* eapply r_put_lhs. *) - (* eapply r_put_lhs. *) - (* eapply r_get_remember_lhs. intros. *) + eapply r_put_lhs. + eapply r_put_lhs. + eapply r_get_remember_lhs. intros. (* (* eapply r_bind. *) *) (* rewrite !bind_assoc. *) From 1c0c1bbe99e9078b09debae9e69a87fc6b4915d9 Mon Sep 17 00:00:00 2001 From: bshvass Date: Wed, 14 Dec 2022 14:50:50 +0100 Subject: [PATCH 318/383] prove JAES is equivalent to imperative spec of AES --- theories/Jasmin/examples/aes/aes.v | 126 ++++++++++++++++++++++------- 1 file changed, 99 insertions(+), 27 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes.v b/theories/Jasmin/examples/aes/aes.v index 8dae3e92..20405933 100644 --- a/theories/Jasmin/examples/aes/aes.v +++ b/theories/Jasmin/examples/aes/aes.v @@ -8,7 +8,7 @@ Require Import List. Set Warnings "-notation-overridden". From Jasmin Require Import expr. Set Warnings "notation-overridden". -From Jasmin Require Import x86_instr_decl x86_extra. +From Jasmin Require Import x86_instr_decl x86_extra waes. From JasminSSProve Require Import jasmin_translate. From Crypt Require Import Prelude Package. @@ -29,9 +29,6 @@ Import PackageNotation. From mathcomp Require Import zify. -Infix "^" := wxor. -Definition ws_def : seq Z := [::]. - Definition get_tr := get_translated_fun ssprove_jasmin_prog. Definition pdisj (P : precond) (s_id : p_id) (rhs : {fset Location}) := @@ -136,6 +133,8 @@ Definition rcon (i : Z) : u8 := nth (wrepr U8 54%Z) [:: (wrepr U8 1%Z); (wrepr U Notation hdtcA res := (coerce_to_choice_type ('array) (hd ('word U64 ; chCanonical _) res).π2). +Notation "m ⊕ k" := (@word.word.wxor _ m k) (at level 20). + Definition key_expand (wn1 : u128) (rcon : u8) : 'word U128 := let rcon := zero_extend U32 rcon (* W4u8 *) (* U32 4 *) (* [tuple rcon ; 0%R; 0%R; 0%R] *) (* [toword rcon; 0%Z; 0%Z; 0%Z] *) in let w0 := subword 0 U32 wn1 in @@ -143,11 +142,11 @@ Definition key_expand (wn1 : u128) (rcon : u8) : 'word U128 := let w2 := subword (2 * U32) U32 wn1 in let w3 := subword (3 * U32) U32 wn1 in let tmp := w3 in - let tmp := SubWord (wror tmp 1) ^ rcon in - let w4 := w0 ^ tmp in - let w5 := w1 ^ w4 in - let w6 := w2 ^ w5 in - let w7 := w3 ^ w6 in + let tmp := SubWord (wror tmp 1) ⊕ rcon in + let w4 := w0 ⊕ tmp in + let w5 := w1 ⊕ w4 in + let w6 := w2 ⊕ w5 in + let w7 := w3 ⊕ w6 in wcat [tuple w4; w5; w6; w7]. Lemma rcon_correct id0 pre i : @@ -177,8 +176,6 @@ Qed. Definition W4u8 : 4.-tuple u8 -> u32 := wcat. Definition W4u32 : 4.-tuple u32 -> u128 := wcat. -Notation "m ⊕ k" := (@word.word.wxor _ m k) (at level 20). - Lemma lsr_word0 {ws1} a : @lsr ws1 word0 a = word0. Proof. unfold lsr. @@ -1609,7 +1606,7 @@ Lemma keyExpansion_E pre id0 rkey : JKEYS_EXPAND id0 rkey ≈ keyExpansion rkey - ⦃ fun '(v0, h0) '(v1, h1) => pre (h0, h1) /\ (to_arr U128 (mkpos 11) (hdtcA v0)) = v1 ⦄. + ⦃ fun '(v0, h0) '(v1, h1) => pre (h0, h1) /\ exists o, v0 = [( 'array ; o)] /\ to_arr U128 (mkpos 11) o = v1 ⦄. Proof. intros disj. @@ -1821,7 +1818,9 @@ Proof. destruct_pre. split_post. (* prove the final post conditions: pre and that the values of rkeys agree *) + assumption. - + eapply eq_fmap. intros j. + + eexists. split. 1: reflexivity. + eapply eq_fmap. intros j. + simpl. destruct ((0 <=? j) && (j pre (h0, h1) /\ hdtc128 v0 = v1 ⦄. + ⦃ fun '(v0, h0) '(v1, h1) => pre (h0, h1) /\ exists o, v0 = [ ('word U128 ; o) ] /\ o = v1 ⦄. Proof. unfold JAES_ROUNDS. unfold get_translated_static_fun. @@ -2055,6 +2054,10 @@ Proof. rewrite -> H6. rewrite getmd_to_arr. rewrite wAESENCLAST_wAESENCLAST_. + eexists. split. + 1: reflexivity. + simpl. + rewrite zero_extend_u. reflexivity. lia. Qed. @@ -2085,7 +2088,7 @@ Proof. Qed. Lemma aes_E pre id0 k m : - (pdisj pre id0 fset0) -> + (pdisj pre id0 [fset rkeys ; state]) -> ⊢ ⦃ fun '(h0, h1) => pre (h0, h1) ⦄ JAES id0 k m ≈ @@ -2101,20 +2104,89 @@ Proof. simpl. simpl_fun. repeat setjvars. + ssprove_code_simpl. + repeat clear_get. + unfold Caes. eapply r_put_lhs. eapply r_put_lhs. - eapply r_get_remember_lhs. intros. - (* (* eapply r_bind. *) *) - (* rewrite !bind_assoc. *) - - (* ssprove_code_simpl. *) - (* ssprove_code_simpl_more. *) - (* unfold aes_rounds. *) - - (* repeat clear_get. *) - (* do 4 eapply r_put_lhs. *) - (* eapply r_put_rhs. *) + eapply r_bind. + - rewrite !zero_extend_u. + eapply keyExpansion_E. + split. + + intros s0 s1 l a vr s_id' Hl Hs_id' H. + assert (id0_preceq : id0 ⪯ s_id'). { + etransitivity. eapply preceq_I. eassumption. + } + assert (id0_neq : id0 <> s_id'). { + apply prec_neq. eapply prec_preceq_trans. eapply prec_I. eassumption. + } + destruct_pre. split_post. + * eapply disj. reflexivity. eassumption. eassumption. + * reflexivity. + * rewrite set_heap_commut. rewrite [set_heap (set_heap H2 _ _) _ _]set_heap_commut. reflexivity. + neq_loc_auto. neq_loc_auto. + + intros; destruct_pre; split_post. + * eapply disj. + ** move: H. rewrite in_fset in_cons=>/orP [];[|easy] => /eqP ->. solve_in. + ** eassumption. + * reflexivity. + * reflexivity. + - intros. + eapply rpre_weak_hypothesis_rule'. + Opaque aes_rounds. + intros; destruct_pre. + simpl. + rewrite !coerce_to_choice_type_K. + fold rkeys. clear_get. - (* eapply r_bind. *) + eapply r_put_lhs with (pre := fun _ => _). + eapply r_get_remember_lhs. intros. + (* this is a very brute force way of remembering the walu of 'in', should be done differently *) + eapply rpre_weak_hypothesis_rule'. + intros; destruct_pre. sheap. + eapply r_bind. + + eapply aes_rounds_E. + split. + * intros s0 s1 l a vr s_id' Hl Hs_id' H. + assert (id0_preceq : id0 ⪯ s_id'). { + etransitivity. eapply preceq_O. etransitivity. eapply preceq_I. eassumption. + } + assert (id0_neq : id0 <> s_id'). { + apply prec_neq. eapply prec_preceq_trans. etransitivity. eapply prec_O. eapply prec_I. eassumption. + } + destruct_pre. sheap. split_post. + ** eapply disj. reflexivity. eassumption. eassumption. + ** reflexivity. + ** reflexivity. + ** eexists. eauto. + ** rewrite set_heap_commut. + rewrite [set_heap (set_heap _ _ _) _ a]set_heap_commut. + rewrite [set_heap (set_heap _ _ _) _ a]set_heap_commut. + reflexivity. + all: neq_loc_auto. + ** simpl. sheap. reflexivity. + * intros; destruct_pre; split_post. + ** eapply disj. + *** move: H. rewrite in_fset in_cons=>/orP []. move=> /eqP ->. solve_in. + simpl. clear -l. easy. + *** eassumption. + ** reflexivity. + ** reflexivity. + ** eexists. eauto. + ** reflexivity. + ** simpl. sheap. reflexivity. + + intros. + eapply rpre_weak_hypothesis_rule'. + intros; destruct_pre. + simpl. fold out. clear_get. + eapply r_put_lhs with (pre := fun _ => _). + eapply r_ret. + intros. + destruct_pre; sheap; split_post. + * pdisj_apply disj. + * rewrite !coerce_to_choice_type_K. + rewrite !zero_extend_u. + reflexivity. +Qed. From d193457282decd4412a46bb5e5018b3eebb2e715 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Wed, 14 Dec 2022 15:20:17 +0100 Subject: [PATCH 319/383] First part of showing AES done --- theories/Jasmin/examples/aes/aes_hac.v | 143 ++++++++++++++++++++++--- 1 file changed, 130 insertions(+), 13 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes_hac.v b/theories/Jasmin/examples/aes/aes_hac.v index 8e7e5d27..e9225e9b 100644 --- a/theories/Jasmin/examples/aes/aes_hac.v +++ b/theories/Jasmin/examples/aes/aes_hac.v @@ -26,30 +26,147 @@ From JasminSSProve Require Import aes_jazz jasmin_utils. Import JasminNotation JasminCodeNotation. Import PackageNotation. -From Hacspec Require Import Hacspec_Aes_Jazz ChoiceEquality. +From Hacspec Require Import Hacspec_Aes_Jazz ChoiceEquality Hacspec_Lib. +Open Scope hacspec_scope. Notation call fn := (translate_call _ fn _). Section Hacspec. - Lemma foo id0 rcon rkey temp2 : - ⊢ ⦃ fun '(_, _) => True ⦄ - JKEY_COMBINE id0 rcon rkey temp2 - ≈ - is_state (key_combine rcon rkey temp2) - ⦃ fun '(v0, _) '(v1, _) => - exists o1 o2, v0 = [('word U128 ; o1) ; ('word U128 ; o2)] - /\ (o1, o2) = v1 ⦄. + (* NB: this redefines neq_loc_auto, which helps some tactics, since checking for inequality by computation is not feasible for translated variables *) + Ltac neq_loc_auto ::= solve [ eapply injective_translate_var3; auto | eapply injective_translate_var2; auto ]. + + Ltac destruct_pre := + repeat + match goal with + | [ H : set_lhs _ _ _ _ |- _ ] => + let sn := fresh in + let Hsn := fresh in + destruct H as [sn [Hsn]] + | [ H : set_rhs _ _ _ _ |- _ ] => + let sn := fresh in + let Hsn := fresh in + destruct H as [sn [Hsn]] + | [ H : _ /\ _ |- _ ] => + let H1 := fresh in + let H2 := fresh in + destruct H as [H1 H2] + | [ H : (_ ⋊ _) _ |- _ ] => + let H1 := fresh in + let H2 := fresh in + destruct H as [H1 H2] + | [ H : exists _, _ |- _ ] => + let o := fresh in + destruct H as [o] + end; simpl in *; subst. + + Lemma det_jkey id0 rcon rkey temp2 : deterministic (JKEY_COMBINE id0 rcon rkey temp2). Proof. unfold translate_call, translate_call_body. Opaque translate_call. - - simpl. - unfold sopn_sem, tr_app_sopn_tuple, tr_app_sopn_single. simpl. + + repeat (apply deterministic_put || (apply deterministic_get ; intros) || apply deterministic_ret). + Transparent translate_call. + Defined. + + Lemma det_key_combine rcon rkey temp2 : deterministic (is_state (key_combine rcon rkey temp2)). + Proof. + repeat (apply deterministic_put || (apply deterministic_get ; intros) || apply deterministic_ret). + Defined. + + Lemma unfold_det_run : forall {A : choiceType} c [h : @deterministic A c] s, @det_run A c h s = match h with + | deterministic_ret x => (x, s) + | deterministic_get ℓ k hk => det_run (k (get_heap s ℓ)) (h := hk _) s + | deterministic_put ℓ v k hk => det_run k (h := hk) (set_heap s ℓ v) + end. + Proof. destruct h ; reflexivity. Qed. + + Ltac bind_jazz_hac := match goal with + | [ |- context [ ⊢ ⦃ ?P ⦄ putr ?l ?jazz ?f ≈ _ ⦃ ?Q ⦄ ] ] => + apply (@r_bind _ _ _ _ (ret jazz) _ (fun x => putr l x f) _ _ (pre_to_post P) _) ; [ | intros ; unfold pre_to_post ] + end. + + Ltac remove_get_in_lhs := + eapply better_r_get_remind_lhs ; + unfold Remembers_lhs , rem_lhs ; + [ intros ? ? k ; + destruct_pre ; + repeat (rewrite get_set_heap_neq ; [ | apply injective_translate_var3 ; reflexivity ]) ; + rewrite get_set_heap_eq ; + reflexivity | ]. + + Lemma foo id0 rcon rkey temp2 : + ⊢ ⦃ fun '(_, _) => True ⦄ + JKEY_COMBINE id0 rcon rkey temp2 + ≈ + is_state (key_combine rcon rkey temp2) + ⦃ fun '(v0, _) '(v1, _) => + exists o1 o2, v0 = [('word U128 ; o1) ; ('word U128 ; o2)] + /\ (o1, o2) = v1 ⦄. + Proof. + set (JKEY_COMBINE _ _ _ _). + unfold translate_call, translate_call_body in r |- *. + Opaque translate_call. + (* unfold ssprove_jasmin_prog in r. *) + simpl in r. + + subst r. + rewrite !zero_extend_u. + unfold key_combine. + + apply better_r_put_lhs. + apply better_r_put_lhs. + apply better_r_put_lhs. - Admitted. + remove_get_in_lhs. + bind_jazz_hac. + admit. + + apply better_r_put_lhs. + remove_get_in_lhs. + remove_get_in_lhs. + bind_jazz_hac. + admit. + + apply better_r_put_lhs. + remove_get_in_lhs. + remove_get_in_lhs. + bind_jazz_hac. + admit. + + apply better_r_put_lhs. + remove_get_in_lhs. + remove_get_in_lhs. + bind_jazz_hac. + admit. + apply better_r_put_lhs. + remove_get_in_lhs. + remove_get_in_lhs. + bind_jazz_hac. + admit. + + apply better_r_put_lhs. + remove_get_in_lhs. + remove_get_in_lhs. + bind_jazz_hac. + admit. + + apply better_r_put_lhs. + remove_get_in_lhs. + remove_get_in_lhs. + apply r_ret. + + intros. + destruct_pre. + eexists. + eexists. + split ; [ reflexivity | ]. + cbn. + rewrite !zero_extend_u. + reflexivity. + Admitted. Lemma bar id0 rcon rkey temp2 : ⊢ ⦃ fun '(_, _) => True ⦄ From ed5e6fbb4aaf25e5e424e847dc8a3f67df6d11fb Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Wed, 14 Dec 2022 17:08:22 +0100 Subject: [PATCH 320/383] WIP aes_hac --- theories/Jasmin/examples/aes/aes_hac.v | 202 ++++++++++++++++++++----- 1 file changed, 168 insertions(+), 34 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes_hac.v b/theories/Jasmin/examples/aes/aes_hac.v index e9225e9b..d4e841e0 100644 --- a/theories/Jasmin/examples/aes/aes_hac.v +++ b/theories/Jasmin/examples/aes/aes_hac.v @@ -84,7 +84,7 @@ Section Hacspec. Ltac bind_jazz_hac := match goal with | [ |- context [ ⊢ ⦃ ?P ⦄ putr ?l ?jazz ?f ≈ _ ⦃ ?Q ⦄ ] ] => - apply (@r_bind _ _ _ _ (ret jazz) _ (fun x => putr l x f) _ _ (pre_to_post P) _) ; [ | intros ; unfold pre_to_post ] + apply (@r_bind _ _ _ _ (ret jazz) _ (fun x => putr l x f) _ _ Q _) ; [ | intros ; unfold pre_to_post ] end. Ltac remove_get_in_lhs := @@ -96,13 +96,15 @@ Section Hacspec. rewrite get_set_heap_eq ; reflexivity | ]. - Lemma foo id0 rcon rkey temp2 : + Notation JVSHUFPS i rkey temp1 temp2 := (trc VSHUFPS i [('word U128 ; rkey) ; ('word U128 ; temp1) ; ('word U128 ; temp2)]). + + Lemma key_combined_eq id0 rcon rkey temp2 : ⊢ ⦃ fun '(_, _) => True ⦄ JKEY_COMBINE id0 rcon rkey temp2 ≈ is_state (key_combine rcon rkey temp2) - ⦃ fun '(v0, _) '(v1, _) => - exists o1 o2, v0 = [('word U128 ; o1) ; ('word U128 ; o2)] + ⦃ fun '(v0, _) '(v1, _) => + exists o1 o2, v0 = [('word U128 ; o1) ; ('word U128 ; o2)] /\ (o1, o2) = v1 ⦄. Proof. set (JKEY_COMBINE _ _ _ _). @@ -118,40 +120,170 @@ Section Hacspec. apply better_r_put_lhs. apply better_r_put_lhs. apply better_r_put_lhs. - - remove_get_in_lhs. - bind_jazz_hac. - admit. - apply better_r_put_lhs. remove_get_in_lhs. - remove_get_in_lhs. - bind_jazz_hac. - admit. + match goal with + | [ |- context [ ⊢ ⦃ ?P ⦄ putr ?l ?jazz ?f ≈ _ ⦃ ?Q ⦄ ] ] => + eapply (@r_bind _ _ _ _ (ret jazz) _ (fun x => putr l x f) _ _ (pre_to_post true_precond) _) ; [ | intros ; unfold pre_to_post ] + end. - apply better_r_put_lhs. - remove_get_in_lhs. - remove_get_in_lhs. - bind_jazz_hac. - admit. + { + apply forget_precond. + rewrite !zero_extend_u. - apply better_r_put_lhs. - remove_get_in_lhs. - remove_get_in_lhs. - bind_jazz_hac. - admit. + unfold tr_app_sopn_tuple. + unfold sopn_sem. + unfold sopn.get_instr_desc. + unfold asm_opI. + unfold asm_op_instr. + unfold semi, arch_extra.get_instr_desc. + unfold instr_desc, _asm_op_decl, instr_desc_op, _asm, x86_extra. + unfold x86_sem.x86. + unfold x86_op_decl. + unfold x86_instr_desc. + unfold id_semi. + unfold Ox86_VPSHUFD_instr. + unfold ".1". + unfold x86_VPSHUFD. + unfold wpshufd. - apply better_r_put_lhs. - remove_get_in_lhs. - remove_get_in_lhs. - bind_jazz_hac. - admit. + set (totce _) at 2. + cbn in t. + unfold totce in t. - apply better_r_put_lhs. - remove_get_in_lhs. - remove_get_in_lhs. + set (chCanonical _). + cbn in s. + subst s. + + set (tr_app_sopn _ _ _ _). + cbn in y. + subst y. + hnf. + + unfold totce. + subst t. + unfold ".π2". + + unfold wpshufd_128. + unfold iota. + unfold map. + set (wpshufd1 _ _ _). + set (wpshufd1 _ _ _). + set (wpshufd1 _ _ _). + set (wpshufd1 _ _ _). + unfold vpshufd. + set (fun _ : T Hacspec_Lib_Pre.int128 => _). + set (_ shift_right _). + + apply (@r_bind _ _ _ _ (ret w) b (fun w => ret (wrepr U128 (wcat_r [w; w0; w1; w2]))) y true_precond (fun _ _ => True)). + - apply r_ret ; reflexivity. + - intros. + subst y. hnf. clear b. + set (fun _ : T Hacspec_Lib_Pre.int128 => _). + set (_ shift_right _). + apply (@r_bind _ _ _ _ (ret w0) b (fun _ => ret (wrepr U128 (wcat_r [_; _; _; _]))) y (fun '(_, _) => True) (fun _ _ => True)). + + apply r_ret ; reflexivity. + + intros. + subst y. hnf. clear b. + + set (fun _ : T Hacspec_Lib_Pre.int128 => _). + set (_ shift_right _). + apply (@r_bind _ _ _ _ (ret w1) b (fun _ => ret (wrepr U128 (wcat_r [_; _; _; _]))) y (fun '(_, _) => True) (fun _ _ => True)). + * apply r_ret ; reflexivity. + * intros. + subst y. hnf. clear b. + + + set (fun _ : T Hacspec_Lib_Pre.int128 => _). + set (_ shift_right _). + apply (@r_bind _ _ _ _ (ret w2) b (fun _ => ret (wrepr U128 (wcat_r [_; _; _; _]))) y (fun '(_, _) => True) (fun _ _ => True)). + -- apply r_ret ; reflexivity. + -- intros. + subst y. hnf. clear b. + unfold wcat_r. + + Set Printing Coercions. + + unfold lift_to_both0, lift_to_both. + unfold is_pure. + unfold "_ .| _". + unfold Hacspec_Lib_Pre.int_or. + unfold word.wor. + unfold lift_to_both. + unfold lift_scope. + unfold is_state. + unfold lift_to_code. + unfold lift_code_scope. + unfold prog. + + apply r_ret. + intros. + + unfold T_ct, eq_rect_r, Logic.eq_sym, Hacspec_Lib_Pre.int, ChoiceEq, Hacspec_Lib_Pre.int_obligation_1, ct, eq_rect. + + unfold pre_to_post. + split ; [ | reflexivity ]. + + rewrite Z.lor_comm. + rewrite (Z.lor_comm (urepr a₀0)). + rewrite (Z.lor_comm (urepr a₀1)). + rewrite (Z.lor_comm (urepr a₀2)). + + unfold wor at 1. + + + + simpl. + + replace (int_to_Z (Posz 32)) with (Hacspec_Lib_Pre.usize 32). + + unfold "_ shift_left _". + unfold Hacspec_Lib_Pre.shift_left_. + unfold wshl. + unfold lsl. + + + unfold lift_scope, lift_to_both0, lift_to_both, is_pure, is_state. + + apply (@r_bind _ _ _ _ (ret w2) b (fun _ => ret (wrepr U128 (wcat_r [_; _; _; _]))) y (fun '(_, _) => True) (fun _ _ => True)). + + } + + set (U8 %/ 2). + assert (n = 4). admit. + replace n with 4%nat in *. + unfold curry. + + Set Printing Coercions. + unfold nat_of_wsize. + unfold wsize_size_minus_1. + unfold nat7. + unfold "%/". + unfold edivn. + cbn. + + unfold embed_tuple. + + unfold encode_tuple. + unfold lchtuple. + unfold tr_app_sopn. + unfold embed_tuple. + cbn. + + rewrite !zero_extend_u. + apply r_ret. + intros. + + + unfold tr_app_sopn. + + bind_jazz_hac. - admit. + Set Printing Implicit. + Set Printing Coercions. + shelve. + + do 5 (apply better_r_put_lhs ; do 2 remove_get_in_lhs ; bind_jazz_hac ; [shelve | ]). apply better_r_put_lhs. remove_get_in_lhs. @@ -166,6 +298,8 @@ Section Hacspec. cbn. rewrite !zero_extend_u. reflexivity. + + Admitted. Lemma bar id0 rcon rkey temp2 : @@ -173,12 +307,12 @@ Section Hacspec. JKEY_EXPAND id0 rcon rkey temp2 ≈ key_expand (wrepr U8 rcon) rkey temp2 - ⦃ fun '(v0, _) '(v1, _) => - exists o1 o2, v0 = [('word U128 ; o1) ; ('word U128 ; o2)] + ⦃ fun '(v0, _) '(v1, _) => + exists o1 o2, v0 = [('word U128 ; o1) ; ('word U128 ; o2)] /\ (o1, o2) = v1 ⦄. Proof. Transparent translate_call. unfold translate_call, translate_call_body. Opaque translate_call. simpl. -Admitted. +Admitted. From 012de4b494290d14c2ed31cfc114740d344f2ab9 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Fri, 16 Dec 2022 11:02:33 +0100 Subject: [PATCH 321/383] Aes subproof done --- theories/Jasmin/examples/aes/aes_hac.v | 416 +++++++++++++++---------- 1 file changed, 246 insertions(+), 170 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes_hac.v b/theories/Jasmin/examples/aes/aes_hac.v index 6a008f9f..1d0eba1c 100644 --- a/theories/Jasmin/examples/aes/aes_hac.v +++ b/theories/Jasmin/examples/aes/aes_hac.v @@ -33,7 +33,6 @@ Notation call fn := (translate_call _ fn _). Section Hacspec. -<<<<<<< HEAD (* NB: this redefines neq_loc_auto, which helps some tactics, since checking for inequality by computation is not feasible for translated variables *) Ltac neq_loc_auto ::= solve [ eapply injective_translate_var3; auto | eapply injective_translate_var2; auto ]. @@ -83,10 +82,16 @@ Section Hacspec. end. Proof. destruct h ; reflexivity. Qed. - Ltac bind_jazz_hac := match goal with - | [ |- context [ ⊢ ⦃ ?P ⦄ putr ?l ?jazz ?f ≈ _ ⦃ ?Q ⦄ ] ] => - apply (@r_bind _ _ _ _ (ret jazz) _ (fun x => putr l x f) _ _ Q _) ; [ | intros ; unfold pre_to_post ] - end. + Ltac bind_jazz_hac := + match goal with + | [ |- context [ ⊢ ⦃ ?P ⦄ putr ?l ?jazz ?f ≈ _ ⦃ ?Q ⦄ ] ] => + eapply (@r_bind _ _ _ _ (ret jazz) _ (fun x => putr l x f) _ _ (fun '(v0, h0) '(v1, h1) => v0 = v1 /\ P (h0, h1)) _) ; [ | intros ; unfold pre_to_post ] + end. + + (* match goal with *) + (* | [ |- context [ ⊢ ⦃ ?P ⦄ putr ?l ?jazz ?f ≈ _ ⦃ ?Q ⦄ ] ] => *) + (* apply (@r_bind _ _ _ _ (ret jazz) _ (fun x => putr l x f) _ _ Q _) ; [ | intros ; unfold pre_to_post ] *) + (* end. *) Ltac remove_get_in_lhs := eapply better_r_get_remind_lhs ; @@ -98,7 +103,63 @@ Section Hacspec. reflexivity | ]. Notation JVSHUFPS i rkey temp1 temp2 := (trc VSHUFPS i [('word U128 ; rkey) ; ('word U128 ; temp1) ; ('word U128 ; temp2)]). - + + Lemma wpshupfd_eq : + forall (rkey : 'word U128) (i : nat), + i < 4 -> + wpshufd1 rkey (wrepr U8 255) i = + is_pure (vpshufd1 rkey (Hacspec_Lib_Pre.repr 255) (Hacspec_Lib_Pre.repr i)). + Proof. + Opaque Z.mul. + clear. + intros. + unfold vpshufd1. + unfold wpshufd1. + simpl. + apply word_ext. + f_equal. + simpl. + rewrite Zmod_mod. + unfold Hacspec_Lib_Pre.shift_right_, wshr, lsr, Hacspec_Lib_Pre.unsigned, wunsigned ; rewrite mkwordK. + f_equal. + f_equal. + f_equal. + f_equal. + unfold Hacspec_Lib_Pre.repr. + unfold wrepr. + unfold toword at 1, mkword at 2. + unfold Hacspec_Lib_Pre.from_uint_size, Hacspec_Lib_Pre.Z_uint_sizeable, Hacspec_Lib_Pre.unsigned, wunsigned. + unfold Hacspec_Lib_Pre.int_mul, mul_word. + rewrite !mkwordK. + rewrite (Zmod_small _ (modulus nat127.+1)) ; [ | destruct i as [ | [ | [ | [] ]]] ; easy ]. + rewrite (Zmod_small _ (modulus (wsize_size_minus_1 U32).+1)) ; [ | destruct i as [ | [ | [ | [] ]]] ; easy ]. + f_equal. + rewrite (Zmod_small _ (modulus U32)) ; [ | destruct i as [ | [ | [ | [] ]]] ; easy ]. + f_equal. + unfold wunsigned. + unfold Hacspec_Lib_Pre.usize_shift_right. + unfold wshr. + unfold urepr, val, word_subType. + Set Printing Coercions. + unfold toword, mkword. + unfold lsr. + unfold mkword. + simpl. + Compute modulus nat7.+1. + rewrite (Zmod_small) ; [ | destruct i as [ | [ | [ | [] ]]] ; easy ]. + rewrite (Zmod_small _ (modulus nat31.+1)) ; [ | destruct i as [ | [ | [ | [] ]]] ; easy ]. + f_equal. + f_equal. + Opaque Nat.mul. + cbn. + replace (2 mod (modulus (nat_of_wsize U32)))%Z with 2%Z by reflexivity. + cbn. + rewrite (Zmod_small) ; [ | destruct i as [ | [ | [ | [] ]]] ; easy ]. + rewrite (Zmod_small) ; [ | destruct i as [ | [ | [ | [] ]]] ; easy ]. + rewrite (Zmod_small) ; [ | destruct i as [ | [ | [ | [] ]]] ; easy ]. + lia. + Qed. + Lemma key_combined_eq id0 rcon rkey temp2 : ⊢ ⦃ fun '(_, _) => True ⦄ JKEY_COMBINE id0 rcon rkey temp2 @@ -123,173 +184,190 @@ Section Hacspec. apply better_r_put_lhs. remove_get_in_lhs. - match goal with - | [ |- context [ ⊢ ⦃ ?P ⦄ putr ?l ?jazz ?f ≈ _ ⦃ ?Q ⦄ ] ] => - eapply (@r_bind _ _ _ _ (ret jazz) _ (fun x => putr l x f) _ _ (pre_to_post true_precond) _) ; [ | intros ; unfold pre_to_post ] - end. + bind_jazz_hac. + (* match goal with *) + (* | [ |- context [ ⊢ ⦃ ?P ⦄ putr ?l ?jazz ?f ≈ _ ⦃ ?Q ⦄ ] ] => *) + (* eapply (@r_bind _ _ _ _ (ret jazz) _ (fun x => putr l x f) _ _ (fun '(v0, h0) '(v1, h1) => v0 = v1 /\ P (h0, h1)) _) ; [ | intros ; unfold pre_to_post ] *) + (* end. *) { - apply forget_precond. - rewrite !zero_extend_u. - - unfold tr_app_sopn_tuple. - unfold sopn_sem. - unfold sopn.get_instr_desc. - unfold asm_opI. - unfold asm_op_instr. - unfold semi, arch_extra.get_instr_desc. - unfold instr_desc, _asm_op_decl, instr_desc_op, _asm, x86_extra. - unfold x86_sem.x86. - unfold x86_op_decl. - unfold x86_instr_desc. - unfold id_semi. - unfold Ox86_VPSHUFD_instr. - unfold ".1". - unfold x86_VPSHUFD. - unfold wpshufd. - - set (totce _) at 2. - cbn in t. - unfold totce in t. - - set (chCanonical _). - cbn in s. - subst s. - - set (tr_app_sopn _ _ _ _). - cbn in y. - subst y. - hnf. - - unfold totce. - subst t. - unfold ".π2". - - unfold wpshufd_128. - unfold iota. - unfold map. - set (wpshufd1 _ _ _). - set (wpshufd1 _ _ _). - set (wpshufd1 _ _ _). - set (wpshufd1 _ _ _). - unfold vpshufd. - set (fun _ : T Hacspec_Lib_Pre.int128 => _). - set (_ shift_right _). - - apply (@r_bind _ _ _ _ (ret w) b (fun w => ret (wrepr U128 (wcat_r [w; w0; w1; w2]))) y true_precond (fun _ _ => True)). - - apply r_ret ; reflexivity. - - intros. - subst y. hnf. clear b. - set (fun _ : T Hacspec_Lib_Pre.int128 => _). - set (_ shift_right _). - apply (@r_bind _ _ _ _ (ret w0) b (fun _ => ret (wrepr U128 (wcat_r [_; _; _; _]))) y (fun '(_, _) => True) (fun _ _ => True)). - + apply r_ret ; reflexivity. - + intros. - subst y. hnf. clear b. - - set (fun _ : T Hacspec_Lib_Pre.int128 => _). - set (_ shift_right _). - apply (@r_bind _ _ _ _ (ret w1) b (fun _ => ret (wrepr U128 (wcat_r [_; _; _; _]))) y (fun '(_, _) => True) (fun _ _ => True)). - * apply r_ret ; reflexivity. - * intros. - subst y. hnf. clear b. - - - set (fun _ : T Hacspec_Lib_Pre.int128 => _). - set (_ shift_right _). - apply (@r_bind _ _ _ _ (ret w2) b (fun _ => ret (wrepr U128 (wcat_r [_; _; _; _]))) y (fun '(_, _) => True) (fun _ _ => True)). - -- apply r_ret ; reflexivity. - -- intros. - subst y. hnf. clear b. - unfold wcat_r. - - Set Printing Coercions. - - unfold lift_to_both0, lift_to_both. - unfold is_pure. - unfold "_ .| _". - unfold Hacspec_Lib_Pre.int_or. - unfold word.wor. - unfold lift_to_both. - unfold lift_scope. - unfold is_state. - unfold lift_to_code. - unfold lift_code_scope. - unfold prog. - - apply r_ret. - intros. - - unfold T_ct, eq_rect_r, Logic.eq_sym, Hacspec_Lib_Pre.int, ChoiceEq, Hacspec_Lib_Pre.int_obligation_1, ct, eq_rect. - - unfold pre_to_post. - split ; [ | reflexivity ]. - - rewrite Z.lor_comm. - rewrite (Z.lor_comm (urepr a₀0)). - rewrite (Z.lor_comm (urepr a₀1)). - rewrite (Z.lor_comm (urepr a₀2)). - - unfold wor at 1. - - - - simpl. - - replace (int_to_Z (Posz 32)) with (Hacspec_Lib_Pre.usize 32). - - unfold "_ shift_left _". - unfold Hacspec_Lib_Pre.shift_left_. - unfold wshl. - unfold lsl. - - - unfold lift_scope, lift_to_both0, lift_to_both, is_pure, is_state. - - apply (@r_bind _ _ _ _ (ret w2) b (fun _ => ret (wrepr U128 (wcat_r [_; _; _; _]))) y (fun '(_, _) => True) (fun _ _ => True)). + (* apply forget_precond. *) + rewrite !zero_extend_u. + + unfold tr_app_sopn_tuple. + unfold sopn_sem. + unfold sopn.get_instr_desc. + unfold asm_opI. + unfold asm_op_instr. + unfold semi, arch_extra.get_instr_desc. + unfold instr_desc, _asm_op_decl, instr_desc_op, _asm, x86_extra. + unfold x86_sem.x86. + unfold x86_op_decl. + unfold x86_instr_desc. + unfold id_semi. + unfold Ox86_VPSHUFD_instr. + unfold ".1". + unfold x86_VPSHUFD. + unfold wpshufd. + + set (totce _) at 2. + cbn in t. + unfold totce in t. + + set (chCanonical _). + cbn in s. + subst s. + + set (tr_app_sopn _ _ _ _). + cbn in y. + subst y. + hnf. + + unfold totce. + subst t. + unfold ".π2". + + unfold wpshufd_128. + unfold iota. + unfold map. + (* set (wpshufd1 _ _ _). *) + (* set (wpshufd1 _ _ _). *) + (* set (wpshufd1 _ _ _). *) + unfold vpshufd. + + do 4 (set (w := wpshufd1 _ _ _) ; + set (y := fun _ : Hacspec_Lib_Pre.int32 => _) ; + set (b := vpshufd1 _ _ _); + let k := fresh in + match goal with + | [ |- context [ ⊢ ⦃ ?P ⦄ _ ≈ _ ⦃ _ ⦄ ] ] => set (k := P) + end ; + apply (@r_bind _ _ _ _ (ret w) (prog (is_state b)) (fun w => ret (wrepr U128 (wcat_r [_ ; _ ; _ ; _]))) y _ (fun '(v0, h0) '(v1, h1) => v0 = v1 /\ k (h0, h1))) ; [ apply r_ret ; intros ; subst w ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K ;cbn ; rewrite! zero_extend_u ; now rewrite wpshupfd_eq | intros ; subst w y b ; hnf ]). + + apply r_ret. + intros. + destruct H3 as [? [? [? [? []]]]]. + subst. + subst H. + clear -H7. + split ; [ | eexists ; apply H7 ]. + + apply word_ext. + unfold wcat_r. + + unfold ".|". + unfold "_ shift_left _". + unfold Hacspec_Lib_Pre.shift_left_. + unfold Hacspec_Lib_Pre.int_or. + unfold Hacspec_Lib_Pre.repr. + unfold Hacspec_Lib_Pre.from_uint_size. + unfold Hacspec_Lib_Pre.usize. + unfold Hacspec_Lib_Pre.Z_uint_sizeable. + unfold Hacspec_Lib_Pre.unsigned. + unfold lift_to_both0 , lift_to_both, is_pure. + unfold word.wor, wor. + unfold wshl, lsl. + unfold wrepr, wunsigned, urepr, val, word_subType, mkword, toword. + unfold wrepr. + unfold mkword. + unfold toword. + unfold Hacspec_Lib_Pre.unsigned. + rewrite !Zmod_small. + rewrite <- Z.lor_assoc. + rewrite <- Z.lor_assoc. + f_equal. + symmetry. + rewrite <- Z.lor_comm. + rewrite <- Z.lor_assoc. + rewrite <- Z.lor_comm. + rewrite <- Z.lor_assoc. + rewrite <- Z.lor_comm. + rewrite <- Z.lor_assoc. + rewrite Z.shiftl_lor. + rewrite Z.shiftl_lor. + rewrite Z.shiftl_lor. + rewrite Z.shiftl_lor. + rewrite Z.shiftl_lor. + rewrite Z.shiftl_lor. + f_equal. + f_equal. + rewrite Z.lor_0_r. + reflexivity. + + all: try easy. + + destruct a₁2. + split. lia. + apply (ssrbool.elimT (iswordZP _ _)) in i. + destruct i. + eapply Z.lt_trans ; [ apply H0 | easy ]. + + cbn. + destruct a₁2. + split. apply Z.shiftl_nonneg. lia. + apply (ssrbool.elimT (iswordZP _ _)) in i. + destruct i. + admit. + + cbn. + destruct a₁2. + split. lia. + apply (ssrbool.elimT (iswordZP _ _)) in i. + destruct i. + eapply Z.lt_trans ; [ apply H0 | easy ]. + + + cbn. + destruct a₁1. + split. lia. + apply (ssrbool.elimT (iswordZP _ _)) in i. + destruct i. + eapply Z.lt_trans ; [ apply H0 | easy ]. + + cbn. + destruct a₁1. + admit. + + cbn. + destruct a₁1. + split. lia. + apply (ssrbool.elimT (iswordZP _ _)) in i. + destruct i. + eapply Z.lt_trans ; [ apply H0 | easy ]. + + cbn. + destruct a₁0. + split. lia. + apply (ssrbool.elimT (iswordZP _ _)) in i. + destruct i. + eapply Z.lt_trans ; [ apply H0 | easy ]. + + cbn. + destruct a₁0. + admit. + + cbn. + destruct a₁0. + split. lia. + apply (ssrbool.elimT (iswordZP _ _)) in i. + destruct i. + eapply Z.lt_trans ; [ apply H0 | easy ]. + + cbn. + destruct a₁. + split. lia. + apply (ssrbool.elimT (iswordZP _ _)) in i. + destruct i. + eapply Z.lt_trans ; [ apply H0 | easy ]. + + cbn. + destruct a₁. + admit. } - - set (U8 %/ 2). - assert (n = 4). admit. - replace n with 4%nat in *. - unfold curry. - - Set Printing Coercions. - unfold nat_of_wsize. - unfold wsize_size_minus_1. - unfold nat7. - unfold "%/". - unfold edivn. - cbn. - - unfold embed_tuple. - - unfold encode_tuple. - unfold lchtuple. - unfold tr_app_sopn. - unfold embed_tuple. - cbn. - - rewrite !zero_extend_u. - apply r_ret. - intros. - - - unfold tr_app_sopn. - - - bind_jazz_hac. - Set Printing Implicit. - Set Printing Coercions. - shelve. do 5 (apply better_r_put_lhs ; do 2 remove_get_in_lhs ; bind_jazz_hac ; [shelve | ]). - - apply better_r_put_lhs. - remove_get_in_lhs. - remove_get_in_lhs. - apply r_ret. + apply better_r_put_lhs ; do 2 remove_get_in_lhs ; apply r_ret. intros. destruct_pre. @@ -299,9 +377,8 @@ Section Hacspec. cbn. rewrite !zero_extend_u. reflexivity. + Admitted. - -======= Lemma foo id0 rcon rkey temp2 : ⊢ ⦃ fun '(_, _) => True ⦄ JKEY_COMBINE id0 rcon rkey temp2 @@ -318,7 +395,6 @@ Section Hacspec. unfold sopn_sem, tr_app_sopn_tuple, tr_app_sopn_single. simpl. ->>>>>>> 1c0c1bbe99e9078b09debae9e69a87fc6b4915d9 Admitted. Lemma bar id0 rcon rkey temp2 : From bf2c68588c39fedb8c232510a68b00f2e954fbda Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Fri, 16 Dec 2022 14:32:47 +0100 Subject: [PATCH 322/383] Progress --- theories/Jasmin/examples/aes/aes_hac.v | 84 +++++++++++++++++++++++--- 1 file changed, 76 insertions(+), 8 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes_hac.v b/theories/Jasmin/examples/aes/aes_hac.v index 1d0eba1c..514bff7d 100644 --- a/theories/Jasmin/examples/aes/aes_hac.v +++ b/theories/Jasmin/examples/aes/aes_hac.v @@ -308,8 +308,10 @@ Section Hacspec. split. apply Z.shiftl_nonneg. lia. apply (ssrbool.elimT (iswordZP _ _)) in i. destruct i. - admit. - + rewrite Z.shiftl_mul_pow2 ; [ | easy]. + rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 96)) toword) in H0 ; [ | easy]. + apply H0. + cbn. destruct a₁2. split. lia. @@ -327,8 +329,13 @@ Section Hacspec. cbn. destruct a₁1. - admit. - + split. apply Z.shiftl_nonneg. lia. + apply (ssrbool.elimT (iswordZP _ _)) in i. + destruct i. + rewrite Z.shiftl_mul_pow2 ; [ | easy]. + rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 64)) toword) in H0 ; [ | easy]. + eapply Z.lt_trans ; [ apply H0 | easy ]. + cbn. destruct a₁1. split. lia. @@ -345,7 +352,12 @@ Section Hacspec. cbn. destruct a₁0. - admit. + split. apply Z.shiftl_nonneg. lia. + apply (ssrbool.elimT (iswordZP _ _)) in i. + destruct i. + rewrite Z.shiftl_mul_pow2 ; [ | easy]. + rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 32)) toword) in H0 ; [ | easy]. + eapply Z.lt_trans ; [ apply H0 | easy ]. cbn. destruct a₁0. @@ -361,9 +373,65 @@ Section Hacspec. destruct i. eapply Z.lt_trans ; [ apply H0 | easy ]. - cbn. - destruct a₁. - admit. + destruct a₁, a₁0, a₁1, a₁2. + rewrite !Z.shiftl_lor. + rewrite !Z.shiftl_mul_pow2 ; try easy. + rewrite !Z.mul_0_l. + rewrite Z.lor_0_r. + replace (int_to_Z (Posz 32)) with 32%Z by reflexivity. + + apply (ssrbool.elimT (iswordZP _ _)) in i, i0, i1, i2. + split. + { + apply Z.lor_nonneg. split. easy. + apply Z.lor_nonneg. split. apply Z.mul_nonneg_nonneg ; easy. + apply Z.lor_nonneg. split. repeat apply Z.mul_nonneg_nonneg ; easy. + repeat apply Z.mul_nonneg_nonneg ; easy. + } + { + rewrite <- !Z.mul_assoc. + rewrite <- !Z.pow_add_r ; try easy. + simpl. + + assert (forall (x y : Z) (k : nat), (0 <= x < 2 ^ k)%Z -> (0 <= y < 2 ^ k)%Z -> (0 <= Z.lor x y < 2 ^ k)%Z). + { + clear. + intros. + + split. + apply Z.lor_nonneg ; easy. + destruct x as [ | x | x ]. + - apply H0. + - destruct y as [ | y | y ]. + + apply H. + + simpl in *. + admit. + + easy. + - easy. + } + + apply (H toword _ nat127.+1). split ; [ easy | ]. + eapply Z.lt_trans ; [apply i | easy]. + + apply (H (toword0 * _)%Z _ nat127.+1). split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. + eapply Z.lt_le_trans. + rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 32)) toword0) in i0 ; [ | easy]. + apply i0. + easy. + + apply (H (toword1 * _)%Z _ nat127.+1). split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. + + eapply Z.lt_le_trans. + rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 64)) toword1) in i1 ; [ | easy]. + apply i1. + easy. + + split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. + eapply Z.lt_le_trans. + rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 96)) toword2) in i2 ; [ | easy]. + apply i2. + easy. + } } do 5 (apply better_r_put_lhs ; do 2 remove_get_in_lhs ; bind_jazz_hac ; [shelve | ]). From 134ad92cf41152245adbb48fa7debef99e259908 Mon Sep 17 00:00:00 2001 From: bshvass Date: Mon, 19 Dec 2022 06:15:50 +0100 Subject: [PATCH 323/383] update to the newest version of jasmin also regenerated examples with additional printing --- README.md | 4 +- theories/Jasmin/examples/add1.v | 16 +- theories/Jasmin/examples/aes.v | 1357 ++++++++++--------- theories/Jasmin/examples/aes/aes.v | 4 +- theories/Jasmin/examples/aes/aes_jazz.v | 1420 ++++++++++---------- theories/Jasmin/examples/bigadd.v | 60 +- theories/Jasmin/examples/ex.v | 26 +- theories/Jasmin/examples/int_add.v | 99 +- theories/Jasmin/examples/int_incr.v | 79 +- theories/Jasmin/examples/int_reg.v | 12 +- theories/Jasmin/examples/int_shift.v | 75 +- theories/Jasmin/examples/liveness_bork.v | 16 +- theories/Jasmin/examples/matrix_product.v | 834 ++++++------ theories/Jasmin/examples/retz.v | 8 +- theories/Jasmin/examples/test_for.v | 14 +- theories/Jasmin/examples/test_inline_var.v | 153 +-- theories/Jasmin/examples/test_shift.v | 10 +- theories/Jasmin/examples/three_functions.v | 80 +- theories/Jasmin/examples/two_functions.v | 63 +- theories/Jasmin/examples/u64_incr.v | 53 +- theories/Jasmin/examples/xor.v | 20 +- theories/Jasmin/examples/xor/xor.v | 358 +++-- theories/Jasmin/jasmin_translate.v | 38 +- 23 files changed, 2461 insertions(+), 2338 deletions(-) diff --git a/README.md b/README.md index 741a10ef..19177b2c 100644 --- a/README.md +++ b/README.md @@ -57,7 +57,9 @@ In order to build the `jasmin` branch, a recent version of `https://github.com/j cd jasmin opam install . ``` -The last version of Jasmin that is known to work is `ca721130dd`, but we try to track `main`. +The last version of Jasmin that is known to work is `52624d84`, but we try to track `main`. +For all proofs to work and a pretty printer for Coq AST's, the version available at `https://github.com/bshvass/jasmin` is currently necessary. +The pretty printer is available via the `-coq` compiler flag. To install a local copy of Jasmin, one may use ```sh diff --git a/theories/Jasmin/examples/add1.v b/theories/Jasmin/examples/add1.v index cde41e09..997f0be2 100644 --- a/theories/Jasmin/examples/add1.v +++ b/theories/Jasmin/examples/add1.v @@ -22,46 +22,48 @@ Definition ssprove_jasmin_prog : uprog. Proof. refine {| p_funcs := [ ( (* add1 *) xH, - {| f_info := xO xH + {| f_info := FunInfo.witness ; f_tyin := [(sword U64)] ; f_params := [{| v_var := {| vtype := (sword U64) - ; vname := "arg.141" |} + ; vname := "arg.139" |} ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness (Cassgn (Lvar {| v_var := {| vtype := (sword U64) - ; vname := "z.142" |} + ; vname := "z.140" |} ; v_info := dummy_var_info |}) AT_none ((sword U64)) ((Pvar {| gv := {| v_var := {| vtype := (sword U64) - ; vname := "arg.141" |} + ; vname := "arg.139" |} ; v_info := dummy_var_info |} ; gs := Slocal |}))); MkI InstrInfo.witness (Cassgn (Lvar {| v_var := {| vtype := (sword U64) - ; vname := "z.142" |} + ; vname := "z.140" |} ; v_info := dummy_var_info |}) AT_none ((sword U64)) ((Papp2 (Oadd (Op_w U64)) (Pvar {| gv := {| v_var := {| vtype := (sword U64) - ; vname := "z.142" |} + ; vname := "z.140" |} ; v_info := dummy_var_info |} ; gs := Slocal |}) (Papp1 (Oword_of_int U64) (Pconst (Zpos (xH))))))) ] ; f_tyout := [(sword U64)] ; f_res := [{| v_var := {| vtype := (sword U64) - ; vname := "z.142" |} + ; vname := "z.140" |} ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) ] ; p_globs := [] ; p_extra := tt |}. + Defined. +Notation ADD1 := ( xH ). \ No newline at end of file diff --git a/theories/Jasmin/examples/aes.v b/theories/Jasmin/examples/aes.v index 45e72461..5af98609 100644 --- a/theories/Jasmin/examples/aes.v +++ b/theories/Jasmin/examples/aes.v @@ -21,589 +21,191 @@ Local Open Scope string. Definition ssprove_jasmin_prog : uprog. Proof. refine {| p_funcs := - [ ( (* RCON *) xI (xI (xO (xO xH))), - {| f_info := xO (xO (xO (xI xH))) - ; f_tyin := [sint] - ; f_params := - [{| v_var := {| vtype := sint - ; vname := "i.322" |} - ; v_info := dummy_var_info |}] - ; f_body := - [ MkI InstrInfo.witness - (Cassgn - (Lvar - {| v_var := {| vtype := sint - ; vname := "c.323" |} - ; v_info := dummy_var_info |}) - AT_inline (sint) - ((Pif (sint) - (Papp2 (Oeq Op_int) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "i.322" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pconst (Zpos (xH)))) - (Pconst (Zpos (xH))) - (Pif (sint) - (Papp2 (Oeq Op_int) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "i.322" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pconst (Zpos (xO xH)))) - (Pconst (Zpos (xO xH))) - (Pif (sint) - (Papp2 (Oeq Op_int) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "i.322" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pconst (Zpos (xI xH)))) - (Pconst (Zpos (xO (xO xH)))) - (Pif (sint) - (Papp2 (Oeq Op_int) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "i.322" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pconst (Zpos (xO (xO xH))))) - (Pconst (Zpos (xO (xO (xO xH))))) - (Pif (sint) - (Papp2 (Oeq Op_int) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "i.322" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pconst (Zpos (xI (xO xH))))) - (Pconst (Zpos (xO (xO (xO (xO xH)))))) - (Pif (sint) - (Papp2 (Oeq Op_int) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "i.322" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pconst (Zpos (xO (xI xH))))) - (Pconst (Zpos (xO (xO (xO (xO (xO xH))))))) - (Pif (sint) - (Papp2 (Oeq Op_int) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := - "i.322" |} - ; v_info := - dummy_var_info |} ; gs := Slocal |}) - (Pconst (Zpos (xI (xI xH))))) - (Pconst - (Zpos (xO (xO (xO (xO (xO (xO xH)))))))) - (Pif (sint) - (Papp2 (Oeq Op_int) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := - "i.322" |} - ; v_info := - dummy_var_info |} ; gs := Slocal |}) - (Pconst (Zpos (xO (xO (xO xH)))))) - (Pconst - (Zpos (xO (xO (xO (xO (xO (xO (xO xH))))))))) - (Pif (sint) - (Papp2 (Oeq Op_int) - (Pvar - {| gv := {| v_var := - {| vtype := - sint - ; vname := - "i.322" |} - ; v_info := - dummy_var_info |} ; gs := Slocal |}) - (Pconst - (Zpos (xI (xO (xO xH)))))) - (Pconst - (Zpos (xI (xI (xO (xI xH)))))) - (Pconst - (Zpos (xO (xI (xI (xO (xI xH)))))))))))))))))) ] - ; f_tyout := [sint] - ; f_res := - [{| v_var := {| vtype := sint - ; vname := "c.323" |} - ; v_info := dummy_var_info |}] - ; f_extra := tt - ; |} ) - ; ( (* key_combine *) xO (xI (xI (xO xH))), - {| f_info := xI (xI (xI (xO xH))) - ; f_tyin := [(sword U128); (sword U128); (sword U128)] + [ ( (* invaes_jazz *) xH, + {| f_info := FunInfo.witness + ; f_tyin := [(sword U128); (sword U128)] ; f_params := [{| v_var := {| vtype := (sword U128) - ; vname := "rkey.319" |} + ; vname := "key.278" |} ; v_info := dummy_var_info |}; {| v_var := {| vtype := (sword U128) - ; vname := "temp1.320" |} - ; v_info := dummy_var_info |}; - {| v_var := {| vtype := (sword U128) - ; vname := "temp2.321" |} + ; vname := "in.279" |} ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness - (Copn - [Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "temp1.320" |} - ; v_info := dummy_var_info |}] - AT_keep - (Oasm (* VPSHUFD_128 *) (BaseOp (None, (VPSHUFD U128)))) - [(Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "temp1.320" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (PappN (Opack U8 PE2) - [(Pconst (Zpos (xI xH))); (Pconst (Zpos (xI xH))); - (Pconst (Zpos (xI xH))); (Pconst (Zpos (xI xH)))])]); - MkI InstrInfo.witness - (Copn - [Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "temp2.321" |} - ; v_info := dummy_var_info |}] - AT_keep - (Oasm (* VSHUFPS_128 *) (BaseOp (None, (VSHUFPS U128)))) - [(Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "temp2.321" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "rkey.319" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (PappN (Opack U8 PE2) - [(Pconst (Z0)); (Pconst (Zpos (xH))); (Pconst (Z0)); - (Pconst (Z0))])]); - MkI InstrInfo.witness - (Cassgn - (Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "rkey.319" |} - ; v_info := dummy_var_info |}) - AT_none ((sword U128)) - ((Papp2 (Olxor U128) - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "rkey.319" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "temp2.321" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})))); - MkI InstrInfo.witness - (Copn + (Ccall InlineFun [Lvar {| v_var := {| vtype := (sword U128) - ; vname := "temp2.321" |} + ; vname := "out.280" |} ; v_info := dummy_var_info |}] - AT_keep - (Oasm (* VSHUFPS_128 *) (BaseOp (None, (VSHUFPS U128)))) + (xO xH) [(Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "temp2.321" |} + ; vname := "key.278" |} ; v_info := dummy_var_info |} ; gs := Slocal |}); (Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "rkey.319" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (PappN (Opack U8 PE2) - [(Pconst (Zpos (xO xH))); (Pconst (Z0)); - (Pconst (Zpos (xI xH))); (Pconst (Z0))])]); - MkI InstrInfo.witness - (Cassgn - (Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "rkey.319" |} - ; v_info := dummy_var_info |}) - AT_none ((sword U128)) - ((Papp2 (Olxor U128) - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "rkey.319" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "temp2.321" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})))); - MkI InstrInfo.witness - (Cassgn - (Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "rkey.319" |} - ; v_info := dummy_var_info |}) - AT_none ((sword U128)) - ((Papp2 (Olxor U128) - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "rkey.319" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "temp1.320" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})))) ] - ; f_tyout := [(sword U128); (sword U128)] + ; vname := "in.279" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sword U128)] ; f_res := [{| v_var := {| vtype := (sword U128) - ; vname := "rkey.319" |} - ; v_info := dummy_var_info |}; - {| v_var := {| vtype := (sword U128) - ; vname := "temp2.321" |} - ; v_info := dummy_var_info |}] + ; vname := "out.280" |} + ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) - ; ( (* key_expand *) xO (xI (xO (xO xH))), - {| f_info := xI (xO (xI (xO xH))) - ; f_tyin := [sint; (sword U128); (sword U128)] + ; ( (* aes_jazz *) xI xH, + {| f_info := FunInfo.witness + ; f_tyin := [(sword U128); (sword U128)] ; f_params := - [{| v_var := {| vtype := sint - ; vname := "rcon.315" |} + [{| v_var := {| vtype := (sword U128) + ; vname := "key.281" |} ; v_info := dummy_var_info |}; {| v_var := {| vtype := (sword U128) - ; vname := "rkey.316" |} - ; v_info := dummy_var_info |}; - {| v_var := {| vtype := (sword U128) - ; vname := "temp2.317" |} + ; vname := "in.282" |} ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness - (Copn - [Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "temp1.318" |} - ; v_info := dummy_var_info |}] - AT_keep - (Oasm (* VAESKEYGENASSIST *) - (BaseOp (None, VAESKEYGENASSIST))) - [(Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "rkey.316" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Papp1 (Oword_of_int U8) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "rcon.315" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}))]); - MkI InstrInfo.witness (Ccall InlineFun [Lvar {| v_var := {| vtype := (sword U128) - ; vname := "rkey.316" |} - ; v_info := dummy_var_info |}; - Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "temp2.317" |} - ; v_info := dummy_var_info |}] - (xO (xI (xI (xO xH)))) + ; vname := "out.283" |} + ; v_info := dummy_var_info |}] + (xO (xO xH)) [(Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "rkey.316" |} + ; vname := "key.281" |} ; v_info := dummy_var_info |} ; gs := Slocal |}); (Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "temp1.318" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "temp2.317" |} + ; vname := "in.282" |} ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] - ; f_tyout := [(sword U128); (sword U128)] + ; f_tyout := [(sword U128)] ; f_res := [{| v_var := {| vtype := (sword U128) - ; vname := "rkey.316" |} - ; v_info := dummy_var_info |}; - {| v_var := {| vtype := (sword U128) - ; vname := "temp2.317" |} - ; v_info := dummy_var_info |}] + ; vname := "out.283" |} + ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) - ; ( (* keys_expand *) xO (xO (xI xH)), - {| f_info := xO (xO (xI (xO xH))) - ; f_tyin := [(sword U128)] + ; ( (* invaes *) xO xH, + {| f_info := FunInfo.witness + ; f_tyin := [(sword U128); (sword U128)] ; f_params := [{| v_var := {| vtype := (sword U128) - ; vname := "key.310" |} - ; v_info := dummy_var_info |}] + ; vname := "key.284" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "in.285" |} + ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness - (Cassgn - (Laset AAscale U128 + (Ccall InlineFun + [Lvar {| v_var := {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.311" |} - ; v_info := dummy_var_info |} - (Pconst (Z0))) - AT_none ((sword U128)) - ((Pvar + ; vname := "rkeys.287" |} + ; v_info := dummy_var_info |}] + (xO (xI xH)) + [(Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "key.310" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}))); + ; vname := "key.284" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); MkI InstrInfo.witness - (Copn + (Ccall InlineFun [Lvar {| v_var := {| vtype := (sword U128) - ; vname := "temp2.312" |} + ; vname := "out.286" |} ; v_info := dummy_var_info |}] - AT_keep (Oasm (* set0_128 *) (ExtOp (Oset0 U128))) []); - MkI InstrInfo.witness - (Cfor - ({| v_var := {| vtype := sint - ; vname := "round.313" |} - ; v_info := dummy_var_info |}) - ((UpTo, (Pconst (Zpos (xH)))), - (Pconst (Zpos (xI (xI (xO xH)))))) - [MkI InstrInfo.witness - (Ccall InlineFun - [Lvar - {| v_var := - {| vtype := sint - ; vname := "rcon.314" |} - ; v_info := dummy_var_info |}] - (xI (xI (xO (xO xH)))) - [(Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "round.313" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})]); - MkI InstrInfo.witness - (Ccall InlineFun - [Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "key.310" |} - ; v_info := dummy_var_info |}; - Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "temp2.312" |} - ; v_info := dummy_var_info |}] - (xO (xI (xO (xO xH)))) - [(Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "rcon.314" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "key.310" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "temp2.312" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})]); - MkI InstrInfo.witness - (Cassgn - (Laset AAscale U128 - {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.311" |} - ; v_info := dummy_var_info |} - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "round.313" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})) - AT_none ((sword U128)) - ((Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "key.310" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})))]) ] - ; f_tyout := [(sarr (xO (xO (xO (xO (xI (xI (xO xH))))))))] + (xI (xO xH)) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.287" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "in.285" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sword U128)] ; f_res := - [{| v_var := - {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.311" |} + [{| v_var := {| vtype := (sword U128) + ; vname := "out.286" |} ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) - ; ( (* keys_expand_inv *) xI (xO (xO xH)), - {| f_info := xI (xO (xO (xO xH))) - ; f_tyin := [(sword U128)] + ; ( (* aes *) xO (xO xH), + {| f_info := FunInfo.witness + ; f_tyin := [(sword U128); (sword U128)] ; f_params := [{| v_var := {| vtype := (sword U128) - ; vname := "key.305" |} - ; v_info := dummy_var_info |}] + ; vname := "key.288" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "in.289" |} + ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness - (Cassgn - (Laset AAscale U128 + (Ccall InlineFun + [Lvar {| v_var := {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.306" |} - ; v_info := dummy_var_info |} - (Pconst (Z0))) - AT_none ((sword U128)) - ((Pvar + ; vname := "rkeys.291" |} + ; v_info := dummy_var_info |}] + (xO (xO (xO xH))) + [(Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "key.305" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}))); + ; vname := "key.288" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); MkI InstrInfo.witness - (Copn + (Ccall InlineFun [Lvar {| v_var := {| vtype := (sword U128) - ; vname := "temp2.307" |} + ; vname := "out.290" |} ; v_info := dummy_var_info |}] - AT_keep (Oasm (* set0_128 *) (ExtOp (Oset0 U128))) []); - MkI InstrInfo.witness - (Cfor - ({| v_var := {| vtype := sint - ; vname := "round.308" |} - ; v_info := dummy_var_info |}) - ((UpTo, (Pconst (Zpos (xH)))), - (Pconst (Zpos (xI (xI (xO xH)))))) - [MkI InstrInfo.witness - (Ccall InlineFun - [Lvar - {| v_var := - {| vtype := sint - ; vname := "rcon.309" |} - ; v_info := dummy_var_info |}] - (xI (xI (xO (xO xH)))) - [(Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "round.308" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})]); - MkI InstrInfo.witness - (Ccall InlineFun - [Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "key.305" |} - ; v_info := dummy_var_info |}; - Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "temp2.307" |} - ; v_info := dummy_var_info |}] - (xO (xI (xO (xO xH)))) - [(Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "rcon.309" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "key.305" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "temp2.307" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})]); - MkI InstrInfo.witness - (Cif - (Papp2 (Oneq Op_int) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "round.308" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pconst (Zpos (xO (xI (xO xH)))))) - [MkI InstrInfo.witness - (Copn - [Laset AAscale U128 - {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.306" |} - ; v_info := dummy_var_info |} - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "round.308" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})] - AT_keep - (Oasm (* AESIMC *) (BaseOp (None, AESIMC))) - [(Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "key.305" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})])] - [MkI InstrInfo.witness - (Cassgn - (Laset AAscale U128 - {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.306" |} - ; v_info := dummy_var_info |} - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "round.308" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})) - AT_none ((sword U128)) - ((Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "key.305" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})))])]) ] - ; f_tyout := [(sarr (xO (xO (xO (xO (xI (xI (xO xH))))))))] + (xI (xI xH)) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.291" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "in.289" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sword U128)] ; f_res := - [{| v_var := - {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.306" |} + [{| v_var := {| vtype := (sword U128) + ; vname := "out.290" |} ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) - ; ( (* aes_rounds *) xI (xI (xO xH)), - {| f_info := xO (xO (xO (xO xH))) + ; ( (* invaes_rounds *) xI (xO xH), + {| f_info := FunInfo.witness ; f_tyin := [(sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))); (sword U128)] ; f_params := [{| v_var := {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.301" |} + ; vname := "rkeys.292" |} ; v_info := dummy_var_info |}; {| v_var := {| vtype := (sword U128) - ; vname := "in.302" |} + ; vname := "in.293" |} ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness @@ -611,102 +213,113 @@ Proof. (Lvar {| v_var := {| vtype := (sword U128) - ; vname := "state.303" |} + ; vname := "state.294" |} ; v_info := dummy_var_info |}) AT_none ((sword U128)) ((Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "in.302" |} + ; vname := "in.293" |} ; v_info := dummy_var_info |} ; gs := Slocal |}))); MkI InstrInfo.witness (Cassgn (Lvar {| v_var := {| vtype := (sword U128) - ; vname := "state.303" |} + ; vname := "rk.295" |} ; v_info := dummy_var_info |}) AT_none ((sword U128)) - ((Papp2 (Olxor U128) - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "state.303" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pget AAscale U128 - {| gv := {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.301" |} - ; v_info := dummy_var_info |} ; gs := Slocal |} - (Pconst (Z0)))))); + ((Pget AAscale U128 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.292" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pconst (Zpos (xO (xI (xO xH)))))))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "state.294" |} + ; v_info := dummy_var_info |}] + (xI (xO (xO xH))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "state.294" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "rk.295" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); MkI InstrInfo.witness (Cfor ({| v_var := {| vtype := sint - ; vname := "round.304" |} + ; vname := "round.296" |} ; v_info := dummy_var_info |}) - ((UpTo, (Pconst (Zpos (xH)))), - (Pconst (Zpos (xO (xI (xO xH)))))) + ((DownTo, (Pconst (Z0))), (Pconst (Zpos (xI (xO (xO xH)))))) [MkI InstrInfo.witness (Copn [Lvar {| v_var := {| vtype := (sword U128) - ; vname := "state.303" |} + ; vname := "state.294" |} ; v_info := dummy_var_info |}] - AT_keep (Oasm (* AESENC *) (BaseOp (None, AESENC))) + AT_keep (Oasm (* AESDEC *) (BaseOp (None, AESDEC))) [(Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "state.303" |} + ; vname := "state.294" |} ; v_info := dummy_var_info |} ; gs := Slocal |}); (Pget AAscale U128 {| gv := {| v_var := {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.301" |} + ; vname := "rkeys.292" |} ; v_info := dummy_var_info |} ; gs := Slocal |} (Pvar {| gv := {| v_var := {| vtype := sint - ; vname := "round.304" |} + ; vname := "round.296" |} ; v_info := dummy_var_info |} ; gs := Slocal |}))])]); MkI InstrInfo.witness (Copn [Lvar {| v_var := {| vtype := (sword U128) - ; vname := "state.303" |} + ; vname := "state.294" |} ; v_info := dummy_var_info |}] - AT_keep (Oasm (* AESENCLAST *) (BaseOp (None, AESENCLAST))) + AT_keep (Oasm (* AESDECLAST *) (BaseOp (None, AESDECLAST))) [(Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "state.303" |} + ; vname := "state.294" |} ; v_info := dummy_var_info |} ; gs := Slocal |}); (Pget AAscale U128 {| gv := {| v_var := {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.301" |} + ; vname := "rkeys.292" |} ; v_info := dummy_var_info |} ; gs := Slocal |} - (Pconst (Zpos (xO (xI (xO xH))))))]) ] + (Pconst (Z0)))]) ] ; f_tyout := [(sword U128)] ; f_res := [{| v_var := {| vtype := (sword U128) - ; vname := "state.303" |} + ; vname := "state.294" |} ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) - ; ( (* AddRoundKey *) xO (xI (xI xH)), - {| f_info := xI (xI (xI xH)) + ; ( (* AddRoundKey *) xI (xO (xO xH)), + {| f_info := FunInfo.witness ; f_tyin := [(sword U128); (sword U128)] ; f_params := [{| v_var := {| vtype := (sword U128) - ; vname := "state.299" |} + ; vname := "state.297" |} ; v_info := dummy_var_info |}; {| v_var := {| vtype := (sword U128) - ; vname := "rk.300" |} + ; vname := "rk.298" |} ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness @@ -714,38 +327,38 @@ Proof. (Lvar {| v_var := {| vtype := (sword U128) - ; vname := "state.299" |} + ; vname := "state.297" |} ; v_info := dummy_var_info |}) AT_none ((sword U128)) ((Papp2 (Olxor U128) (Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "state.299" |} + ; vname := "state.297" |} ; v_info := dummy_var_info |} ; gs := Slocal |}) (Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "rk.300" |} + ; vname := "rk.298" |} ; v_info := dummy_var_info |} ; gs := Slocal |})))) ] ; f_tyout := [(sword U128)] ; f_res := [{| v_var := {| vtype := (sword U128) - ; vname := "state.299" |} + ; vname := "state.297" |} ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) - ; ( (* invaes_rounds *) xO (xO (xO xH)), - {| f_info := xI (xO (xI xH)) + ; ( (* aes_rounds *) xI (xI xH), + {| f_info := FunInfo.witness ; f_tyin := [(sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))); (sword U128)] ; f_params := [{| v_var := {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.294" |} + ; vname := "rkeys.299" |} ; v_info := dummy_var_info |}; {| v_var := {| vtype := (sword U128) - ; vname := "in.295" |} + ; vname := "in.300" |} ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness @@ -753,278 +366,678 @@ Proof. (Lvar {| v_var := {| vtype := (sword U128) - ; vname := "state.296" |} + ; vname := "state.301" |} ; v_info := dummy_var_info |}) AT_none ((sword U128)) ((Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "in.295" |} + ; vname := "in.300" |} ; v_info := dummy_var_info |} ; gs := Slocal |}))); MkI InstrInfo.witness (Cassgn (Lvar {| v_var := {| vtype := (sword U128) - ; vname := "rk.297" |} + ; vname := "state.301" |} ; v_info := dummy_var_info |}) AT_none ((sword U128)) - ((Pget AAscale U128 - {| gv := {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.294" |} - ; v_info := dummy_var_info |} ; gs := Slocal |} - (Pconst (Zpos (xO (xI (xO xH)))))))); - MkI InstrInfo.witness - (Ccall InlineFun - [Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "state.296" |} - ; v_info := dummy_var_info |}] - (xO (xI (xI xH))) - [(Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "state.296" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "rk.297" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})]); + ((Papp2 (Olxor U128) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "state.301" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pget AAscale U128 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.299" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pconst (Z0)))))); MkI InstrInfo.witness (Cfor ({| v_var := {| vtype := sint - ; vname := "round.298" |} + ; vname := "round.302" |} ; v_info := dummy_var_info |}) - ((DownTo, (Pconst (Z0))), (Pconst (Zpos (xI (xO (xO xH)))))) + ((UpTo, (Pconst (Zpos (xH)))), + (Pconst (Zpos (xO (xI (xO xH)))))) [MkI InstrInfo.witness (Copn [Lvar {| v_var := {| vtype := (sword U128) - ; vname := "state.296" |} + ; vname := "state.301" |} ; v_info := dummy_var_info |}] - AT_keep (Oasm (* AESDEC *) (BaseOp (None, AESDEC))) + AT_keep (Oasm (* AESENC *) (BaseOp (None, AESENC))) [(Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "state.296" |} + ; vname := "state.301" |} ; v_info := dummy_var_info |} ; gs := Slocal |}); (Pget AAscale U128 {| gv := {| v_var := {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.294" |} + ; vname := "rkeys.299" |} ; v_info := dummy_var_info |} ; gs := Slocal |} (Pvar {| gv := {| v_var := {| vtype := sint - ; vname := "round.298" |} + ; vname := "round.302" |} ; v_info := dummy_var_info |} ; gs := Slocal |}))])]); MkI InstrInfo.witness (Copn [Lvar {| v_var := {| vtype := (sword U128) - ; vname := "state.296" |} + ; vname := "state.301" |} ; v_info := dummy_var_info |}] - AT_keep (Oasm (* AESDECLAST *) (BaseOp (None, AESDECLAST))) + AT_keep (Oasm (* AESENCLAST *) (BaseOp (None, AESENCLAST))) [(Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "state.296" |} + ; vname := "state.301" |} ; v_info := dummy_var_info |} ; gs := Slocal |}); (Pget AAscale U128 {| gv := {| v_var := {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.294" |} + ; vname := "rkeys.299" |} ; v_info := dummy_var_info |} ; gs := Slocal |} - (Pconst (Z0)))]) ] + (Pconst (Zpos (xO (xI (xO xH))))))]) ] ; f_tyout := [(sword U128)] ; f_res := [{| v_var := {| vtype := (sword U128) - ; vname := "state.296" |} + ; vname := "state.301" |} ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) - ; ( (* aes *) xO (xI xH), - {| f_info := xO (xI (xO xH)) - ; f_tyin := [(sword U128); (sword U128)] + ; ( (* keys_expand_inv *) xO (xI xH), + {| f_info := FunInfo.witness + ; f_tyin := [(sword U128)] ; f_params := [{| v_var := {| vtype := (sword U128) - ; vname := "key.290" |} - ; v_info := dummy_var_info |}; - {| v_var := {| vtype := (sword U128) - ; vname := "in.291" |} - ; v_info := dummy_var_info |}] + ; vname := "key.303" |} + ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness - (Ccall InlineFun - [Lvar + (Cassgn + (Laset AAscale U128 {| v_var := {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.293" |} - ; v_info := dummy_var_info |}] - (xO (xO (xI xH))) - [(Pvar + ; vname := "rkeys.304" |} + ; v_info := dummy_var_info |} + (Pconst (Z0))) + AT_none ((sword U128)) + ((Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "key.290" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})]); + ; vname := "key.303" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); MkI InstrInfo.witness - (Ccall InlineFun + (Copn [Lvar {| v_var := {| vtype := (sword U128) - ; vname := "out.292" |} + ; vname := "temp2.305" |} ; v_info := dummy_var_info |}] - (xI (xI (xO xH))) - [(Pvar + AT_keep (Oasm (* set0_128 *) (ExtOp (Oset0 U128))) []); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "round.306" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Zpos (xH)))), + (Pconst (Zpos (xI (xI (xO xH)))))) + [MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := sint + ; vname := "rcon.307" |} + ; v_info := dummy_var_info |}] + (xI (xI (xO xH))) + [(Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "round.306" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "key.303" |} + ; v_info := dummy_var_info |}; + Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.305" |} + ; v_info := dummy_var_info |}] + (xO (xI (xO xH))) + [(Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "rcon.307" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.303" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.305" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cif + (Papp2 (Oneq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "round.306" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO (xI (xO xH)))))) + [MkI InstrInfo.witness + (Copn + [Laset AAscale U128 + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.304" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "round.306" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})] + AT_keep + (Oasm (* AESIMC *) (BaseOp (None, AESIMC))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.303" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})])] + [MkI InstrInfo.witness + (Cassgn + (Laset AAscale U128 + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.304" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "round.306" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) + AT_none ((sword U128)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.303" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))])]) ] + ; f_tyout := [(sarr (xO (xO (xO (xO (xI (xI (xO xH))))))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.304" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* keys_expand *) xO (xO (xO xH)), + {| f_info := FunInfo.witness + ; f_tyin := [(sword U128)] + ; f_params := + [{| v_var := {| vtype := (sword U128) + ; vname := "key.308" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Laset AAscale U128 + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.309" |} + ; v_info := dummy_var_info |} + (Pconst (Z0))) + AT_none ((sword U128)) + ((Pvar {| gv := {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.293" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "in.291" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] - ; f_tyout := [(sword U128)] + {| vtype := (sword U128) + ; vname := "key.308" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.310" |} + ; v_info := dummy_var_info |}] + AT_keep (Oasm (* set0_128 *) (ExtOp (Oset0 U128))) []); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "round.311" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Zpos (xH)))), + (Pconst (Zpos (xI (xI (xO xH)))))) + [MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := sint + ; vname := "rcon.312" |} + ; v_info := dummy_var_info |}] + (xI (xI (xO xH))) + [(Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "round.311" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "key.308" |} + ; v_info := dummy_var_info |}; + Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.310" |} + ; v_info := dummy_var_info |}] + (xO (xI (xO xH))) + [(Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "rcon.312" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.308" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.310" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Laset AAscale U128 + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.309" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "round.311" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) + AT_none ((sword U128)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.308" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))]) ] + ; f_tyout := [(sarr (xO (xO (xO (xO (xI (xI (xO xH))))))))] ; f_res := - [{| v_var := {| vtype := (sword U128) - ; vname := "out.292" |} + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.309" |} ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) - ; ( (* invaes *) xI xH, - {| f_info := xI (xI xH) - ; f_tyin := [(sword U128); (sword U128)] + ; ( (* key_expand *) xO (xI (xO xH)), + {| f_info := FunInfo.witness + ; f_tyin := [sint; (sword U128); (sword U128)] ; f_params := - [{| v_var := {| vtype := (sword U128) - ; vname := "key.286" |} + [{| v_var := {| vtype := sint + ; vname := "rcon.313" |} ; v_info := dummy_var_info |}; {| v_var := {| vtype := (sword U128) - ; vname := "in.287" |} + ; vname := "rkey.314" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "temp2.315" |} ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness - (Ccall InlineFun + (Copn [Lvar {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.289" |} + {| vtype := (sword U128) + ; vname := "temp1.316" |} ; v_info := dummy_var_info |}] - (xI (xO (xO xH))) + AT_keep + (Oasm (* VAESKEYGENASSIST *) + (BaseOp (None, VAESKEYGENASSIST))) [(Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "key.286" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})]); + ; vname := "rkey.314" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Papp1 (Oword_of_int U8) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "rcon.313" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))]); MkI InstrInfo.witness (Ccall InlineFun [Lvar {| v_var := {| vtype := (sword U128) - ; vname := "out.288" |} - ; v_info := dummy_var_info |}] - (xO (xO (xO xH))) + ; vname := "rkey.314" |} + ; v_info := dummy_var_info |}; + Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.315" |} + ; v_info := dummy_var_info |}] + (xO (xO (xI xH))) [(Pvar {| gv := {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.289" |} + {| vtype := (sword U128) + ; vname := "rkey.314" |} ; v_info := dummy_var_info |} ; gs := Slocal |}); (Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "in.287" |} + ; vname := "temp1.316" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.315" |} ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] - ; f_tyout := [(sword U128)] + ; f_tyout := [(sword U128); (sword U128)] ; f_res := [{| v_var := {| vtype := (sword U128) - ; vname := "out.288" |} - ; v_info := dummy_var_info |}] + ; vname := "rkey.314" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "temp2.315" |} + ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) - ; ( (* aes_jazz *) xO (xO xH), - {| f_info := xI (xO xH) - ; f_tyin := [(sword U128); (sword U128)] + ; ( (* key_combine *) xO (xO (xI xH)), + {| f_info := FunInfo.witness + ; f_tyin := [(sword U128); (sword U128); (sword U128)] ; f_params := [{| v_var := {| vtype := (sword U128) - ; vname := "key.283" |} + ; vname := "rkey.317" |} ; v_info := dummy_var_info |}; {| v_var := {| vtype := (sword U128) - ; vname := "in.284" |} + ; vname := "temp1.318" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "temp2.319" |} ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness - (Ccall InlineFun + (Copn [Lvar {| v_var := {| vtype := (sword U128) - ; vname := "out.285" |} + ; vname := "temp1.318" |} ; v_info := dummy_var_info |}] - (xO (xI xH)) + AT_keep + (Oasm (* VPSHUFD_128 *) (BaseOp (None, (VPSHUFD U128)))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp1.318" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (PappN (Opack U8 PE2) + [(Pconst (Zpos (xI xH))); (Pconst (Zpos (xI xH))); + (Pconst (Zpos (xI xH))); (Pconst (Zpos (xI xH)))])]); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.319" |} + ; v_info := dummy_var_info |}] + AT_keep + (Oasm (* VSHUFPS_128 *) (BaseOp (None, (VSHUFPS U128)))) [(Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "key.283" |} + ; vname := "temp2.319" |} ; v_info := dummy_var_info |} ; gs := Slocal |}); (Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "in.284" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] - ; f_tyout := [(sword U128)] - ; f_res := - [{| v_var := {| vtype := (sword U128) - ; vname := "out.285" |} - ; v_info := dummy_var_info |}] - ; f_extra := tt - ; |} ) - ; ( (* invaes_jazz *) xH, - {| f_info := xO xH - ; f_tyin := [(sword U128); (sword U128)] - ; f_params := - [{| v_var := {| vtype := (sword U128) - ; vname := "key.280" |} - ; v_info := dummy_var_info |}; - {| v_var := {| vtype := (sword U128) - ; vname := "in.281" |} - ; v_info := dummy_var_info |}] - ; f_body := - [ MkI InstrInfo.witness - (Ccall InlineFun + ; vname := "rkey.317" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (PappN (Opack U8 PE2) + [(Pconst (Z0)); (Pconst (Zpos (xH))); (Pconst (Z0)); + (Pconst (Z0))])]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.317" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U128)) + ((Papp2 (Olxor U128) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.317" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.319" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness + (Copn [Lvar {| v_var := {| vtype := (sword U128) - ; vname := "out.282" |} + ; vname := "temp2.319" |} ; v_info := dummy_var_info |}] - (xI xH) + AT_keep + (Oasm (* VSHUFPS_128 *) (BaseOp (None, (VSHUFPS U128)))) [(Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "key.280" |} + ; vname := "temp2.319" |} ; v_info := dummy_var_info |} ; gs := Slocal |}); (Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "in.281" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] - ; f_tyout := [(sword U128)] + ; vname := "rkey.317" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (PappN (Opack U8 PE2) + [(Pconst (Zpos (xO xH))); (Pconst (Z0)); + (Pconst (Zpos (xI xH))); (Pconst (Z0))])]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.317" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U128)) + ((Papp2 (Olxor U128) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.317" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.319" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.317" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U128)) + ((Papp2 (Olxor U128) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.317" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp1.318" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))) ] + ; f_tyout := [(sword U128); (sword U128)] ; f_res := [{| v_var := {| vtype := (sword U128) - ; vname := "out.282" |} + ; vname := "rkey.317" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "temp2.319" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* RCON *) xI (xI (xO xH)), + {| f_info := FunInfo.witness + ; f_tyin := [sint] + ; f_params := + [{| v_var := {| vtype := sint + ; vname := "i.320" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := {| vtype := sint + ; vname := "c.321" |} + ; v_info := dummy_var_info |}) + AT_inline (sint) + ((Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.320" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xH)))) + (Pconst (Zpos (xH))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.320" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO xH)))) + (Pconst (Zpos (xO xH))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.320" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xI xH)))) + (Pconst (Zpos (xO (xO xH)))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.320" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO (xO xH))))) + (Pconst (Zpos (xO (xO (xO xH))))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.320" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xI (xO xH))))) + (Pconst (Zpos (xO (xO (xO (xO xH)))))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.320" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO (xI xH))))) + (Pconst (Zpos (xO (xO (xO (xO (xO xH))))))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := + "i.320" |} + ; v_info := + dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xI (xI xH))))) + (Pconst + (Zpos (xO (xO (xO (xO (xO (xO xH)))))))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := + "i.320" |} + ; v_info := + dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO (xO (xO xH)))))) + (Pconst + (Zpos (xO (xO (xO (xO (xO (xO (xO xH))))))))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := + sint + ; vname := + "i.320" |} + ; v_info := + dummy_var_info |} ; gs := Slocal |}) + (Pconst + (Zpos (xI (xO (xO xH)))))) + (Pconst + (Zpos (xI (xI (xO (xI xH)))))) + (Pconst + (Zpos (xO (xI (xI (xO (xI xH)))))))))))))))))) ] + ; f_tyout := [sint] + ; f_res := + [{| v_var := {| vtype := sint + ; vname := "c.321" |} ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) ] ; p_globs := [] ; p_extra := tt |}. + Defined. +Notation INVAES_JAZZ := ( xH ). +Notation AES_JAZZ := ( xI xH ). +Notation INVAES := ( xO xH ). +Notation AES := ( xO (xO xH) ). +Notation INVAES_ROUNDS := ( xI (xO xH) ). +Notation ADDROUNDKEY := ( xI (xO (xO xH)) ). +Notation AES_ROUNDS := ( xI (xI xH) ). +Notation KEYS_EXPAND_INV := ( xO (xI xH) ). +Notation KEYS_EXPAND := ( xO (xO (xO xH)) ). +Notation KEY_EXPAND := ( xO (xI (xO xH)) ). +Notation KEY_COMBINE := ( xO (xO (xI xH)) ). +Notation RCON := ( xI (xI (xO xH)) ). \ No newline at end of file diff --git a/theories/Jasmin/examples/aes/aes.v b/theories/Jasmin/examples/aes/aes.v index 20405933..911c0015 100644 --- a/theories/Jasmin/examples/aes/aes.v +++ b/theories/Jasmin/examples/aes/aes.v @@ -158,7 +158,6 @@ Lemma rcon_correct id0 pre i : Proof. unfold JRCON. unfold get_translated_static_fun. - simpl. intros Hpdisj H. simpl_fun. repeat setjvars. @@ -1844,6 +1843,9 @@ Proof. assumption. intros. destruct a₀, a₁. + destruct_pre. + rewrite coerce_to_choice_type_K. + simpl. easy. Qed. diff --git a/theories/Jasmin/examples/aes/aes_jazz.v b/theories/Jasmin/examples/aes/aes_jazz.v index 714072c0..324be0ad 100644 --- a/theories/Jasmin/examples/aes/aes_jazz.v +++ b/theories/Jasmin/examples/aes/aes_jazz.v @@ -6,604 +6,288 @@ Set Warnings "notation-overridden,ambiguous-paths". Require Import List. Set Warnings "-notation-overridden". -From Jasmin Require Import expr. +From Jasmin Require Import expr sem. Set Warnings "notation-overridden". From Jasmin Require Import x86_instr_decl x86_extra. -From JasminSSProve Require Import jasmin_translate. +From JasminSSProve Require Import jasmin_translate jasmin_utils. From Crypt Require Import Prelude Package. Import ListNotations. +Import JasminNotation JasminCodeNotation. +Import PackageNotation. Local Open Scope string. Set Bullet Behavior "Strict Subproofs". (* Set Default Goal Selector "!". *) (* I give up on this for now. *) + Definition ssprove_jasmin_prog : uprog. Proof. refine {| p_funcs := - rev [ ( (* RCON *) xI (xI (xO (xO xH))), - {| f_info := xO (xO (xO (xI xH))) - ; f_tyin := [sint] - ; f_params := - [{| v_var := {| vtype := sint - ; vname := "i.322" |} - ; v_info := dummy_var_info |}] - ; f_body := - [ MkI InstrInfo.witness - (Cassgn - (Lvar - {| v_var := {| vtype := sint - ; vname := "c.323" |} - ; v_info := dummy_var_info |}) - AT_inline (sint) - ((Pif (sint) - (Papp2 (Oeq Op_int) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "i.322" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pconst (Zpos (xH)))) - (Pconst (Zpos (xH))) - (Pif (sint) - (Papp2 (Oeq Op_int) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "i.322" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pconst (Zpos (xO xH)))) - (Pconst (Zpos (xO xH))) - (Pif (sint) - (Papp2 (Oeq Op_int) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "i.322" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pconst (Zpos (xI xH)))) - (Pconst (Zpos (xO (xO xH)))) - (Pif (sint) - (Papp2 (Oeq Op_int) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "i.322" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pconst (Zpos (xO (xO xH))))) - (Pconst (Zpos (xO (xO (xO xH))))) - (Pif (sint) - (Papp2 (Oeq Op_int) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "i.322" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pconst (Zpos (xI (xO xH))))) - (Pconst (Zpos (xO (xO (xO (xO xH)))))) - (Pif (sint) - (Papp2 (Oeq Op_int) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "i.322" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pconst (Zpos (xO (xI xH))))) - (Pconst (Zpos (xO (xO (xO (xO (xO xH))))))) - (Pif (sint) - (Papp2 (Oeq Op_int) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := - "i.322" |} - ; v_info := - dummy_var_info |} ; gs := Slocal |}) - (Pconst (Zpos (xI (xI xH))))) - (Pconst - (Zpos (xO (xO (xO (xO (xO (xO xH)))))))) - (Pif (sint) - (Papp2 (Oeq Op_int) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := - "i.322" |} - ; v_info := - dummy_var_info |} ; gs := Slocal |}) - (Pconst (Zpos (xO (xO (xO xH)))))) - (Pconst - (Zpos (xO (xO (xO (xO (xO (xO (xO xH))))))))) - (Pif (sint) - (Papp2 (Oeq Op_int) - (Pvar - {| gv := {| v_var := - {| vtype := - sint - ; vname := - "i.322" |} - ; v_info := - dummy_var_info |} ; gs := Slocal |}) - (Pconst - (Zpos (xI (xO (xO xH)))))) - (Pconst - (Zpos (xI (xI (xO (xI xH)))))) - (Pconst - (Zpos (xO (xI (xI (xO (xI xH)))))))))))))))))) ] - ; f_tyout := [sint] - ; f_res := - [{| v_var := {| vtype := sint - ; vname := "c.323" |} - ; v_info := dummy_var_info |}] - ; f_extra := tt - ; |} ) - ; ( (* key_combine *) xO (xI (xI (xO xH))), - {| f_info := xI (xI (xI (xO xH))) + [ ( (* dec *) xH, + {| f_info := FunInfo.witness ; f_tyin := [(sword U128); (sword U128); (sword U128)] ; f_params := [{| v_var := {| vtype := (sword U128) - ; vname := "rkey.319" |} + ; vname := "k.297" |} ; v_info := dummy_var_info |}; {| v_var := {| vtype := (sword U128) - ; vname := "temp1.320" |} + ; vname := "n.298" |} ; v_info := dummy_var_info |}; {| v_var := {| vtype := (sword U128) - ; vname := "temp2.321" |} + ; vname := "c.299" |} ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness - (Copn + (Ccall InlineFun [Lvar {| v_var := {| vtype := (sword U128) - ; vname := "temp1.320" |} + ; vname := "mask.301" |} ; v_info := dummy_var_info |}] - AT_keep - (Oasm (* VPSHUFD_128 *) (BaseOp (None, (VPSHUFD U128)))) + (xI xH) [(Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "temp1.320" |} + ; vname := "k.297" |} ; v_info := dummy_var_info |} ; gs := Slocal |}); - (PappN (Opack U8 PE2) - [(Pconst (Zpos (xI xH))); (Pconst (Zpos (xI xH))); - (Pconst (Zpos (xI xH))); (Pconst (Zpos (xI xH)))])]); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "n.298" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); MkI InstrInfo.witness - (Copn + (Ccall InlineFun [Lvar {| v_var := {| vtype := (sword U128) - ; vname := "temp2.321" |} + ; vname := "p.300" |} ; v_info := dummy_var_info |}] - AT_keep - (Oasm (* VSHUFPS_128 *) (BaseOp (None, (VSHUFPS U128)))) + (xO xH) [(Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "temp2.321" |} + ; vname := "mask.301" |} ; v_info := dummy_var_info |} ; gs := Slocal |}); (Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "rkey.319" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (PappN (Opack U8 PE2) - [(Pconst (Z0)); (Pconst (Zpos (xH))); (Pconst (Z0)); - (Pconst (Z0))])]); - MkI InstrInfo.witness - (Cassgn - (Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "rkey.319" |} - ; v_info := dummy_var_info |}) - AT_none ((sword U128)) - ((Papp2 (Olxor U128) - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "rkey.319" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "temp2.321" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})))); - MkI InstrInfo.witness - (Copn + ; vname := "c.299" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sword U128)] + ; f_res := + [{| v_var := {| vtype := (sword U128) + ; vname := "p.300" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* enc *) xO (xO xH), + {| f_info := FunInfo.witness + ; f_tyin := [(sword U128); (sword U128); (sword U128)] + ; f_params := + [{| v_var := {| vtype := (sword U128) + ; vname := "k.302" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "n.303" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "p.304" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun [Lvar {| v_var := {| vtype := (sword U128) - ; vname := "temp2.321" |} + ; vname := "mask.306" |} ; v_info := dummy_var_info |}] - AT_keep - (Oasm (* VSHUFPS_128 *) (BaseOp (None, (VSHUFPS U128)))) + (xI xH) [(Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "temp2.321" |} + ; vname := "k.302" |} ; v_info := dummy_var_info |} ; gs := Slocal |}); (Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "rkey.319" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (PappN (Opack U8 PE2) - [(Pconst (Zpos (xO xH))); (Pconst (Z0)); - (Pconst (Zpos (xI xH))); (Pconst (Z0))])]); + ; vname := "n.303" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); MkI InstrInfo.witness - (Cassgn - (Lvar + (Ccall InlineFun + [Lvar {| v_var := {| vtype := (sword U128) - ; vname := "rkey.319" |} - ; v_info := dummy_var_info |}) - AT_none ((sword U128)) - ((Papp2 (Olxor U128) - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "rkey.319" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "temp2.321" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})))); - MkI InstrInfo.witness + ; vname := "c.305" |} + ; v_info := dummy_var_info |}] + (xO xH) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "mask.306" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "p.304" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sword U128)] + ; f_res := + [{| v_var := {| vtype := (sword U128) + ; vname := "c.305" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* xor *) xO xH, + {| f_info := FunInfo.witness + ; f_tyin := [(sword U128); (sword U128)] + ; f_params := + [{| v_var := {| vtype := (sword U128) + ; vname := "a.307" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "b.308" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness (Cassgn (Lvar {| v_var := {| vtype := (sword U128) - ; vname := "rkey.319" |} + ; vname := "r.309" |} ; v_info := dummy_var_info |}) AT_none ((sword U128)) ((Papp2 (Olxor U128) (Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "rkey.319" |} + ; vname := "a.307" |} ; v_info := dummy_var_info |} ; gs := Slocal |}) (Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "temp1.320" |} + ; vname := "b.308" |} ; v_info := dummy_var_info |} ; gs := Slocal |})))) ] - ; f_tyout := [(sword U128); (sword U128)] + ; f_tyout := [(sword U128)] ; f_res := [{| v_var := {| vtype := (sword U128) - ; vname := "rkey.319" |} - ; v_info := dummy_var_info |}; - {| v_var := {| vtype := (sword U128) - ; vname := "temp2.321" |} - ; v_info := dummy_var_info |}] + ; vname := "r.309" |} + ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) - ; ( (* key_expand *) xO (xI (xO (xO xH))), - {| f_info := xI (xO (xI (xO xH))) - ; f_tyin := [sint; (sword U128); (sword U128)] + ; ( (* invaes *) xI (xO xH), + {| f_info := FunInfo.witness + ; f_tyin := [(sword U128); (sword U128)] ; f_params := - [{| v_var := {| vtype := sint - ; vname := "rcon.315" |} + [{| v_var := {| vtype := (sword U128) + ; vname := "key.310" |} ; v_info := dummy_var_info |}; {| v_var := {| vtype := (sword U128) - ; vname := "rkey.316" |} - ; v_info := dummy_var_info |}; - {| v_var := {| vtype := (sword U128) - ; vname := "temp2.317" |} + ; vname := "in.311" |} ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness - (Copn + (Ccall InlineFun [Lvar {| v_var := - {| vtype := (sword U128) - ; vname := "temp1.318" |} + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.313" |} ; v_info := dummy_var_info |}] - AT_keep - (Oasm (* VAESKEYGENASSIST *) - (BaseOp (None, VAESKEYGENASSIST))) + (xI (xI xH)) [(Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "rkey.316" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Papp1 (Oword_of_int U8) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "rcon.315" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}))]); + ; vname := "key.310" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); MkI InstrInfo.witness (Ccall InlineFun [Lvar {| v_var := {| vtype := (sword U128) - ; vname := "rkey.316" |} - ; v_info := dummy_var_info |}; - Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "temp2.317" |} - ; v_info := dummy_var_info |}] - (xO (xI (xI (xO xH)))) + ; vname := "out.312" |} + ; v_info := dummy_var_info |}] + (xO (xI xH)) [(Pvar {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "rkey.316" |} + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.313" |} ; v_info := dummy_var_info |} ; gs := Slocal |}); (Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "temp1.318" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "temp2.317" |} + ; vname := "in.311" |} ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] - ; f_tyout := [(sword U128); (sword U128)] + ; f_tyout := [(sword U128)] ; f_res := [{| v_var := {| vtype := (sword U128) - ; vname := "rkey.316" |} - ; v_info := dummy_var_info |}; - {| v_var := {| vtype := (sword U128) - ; vname := "temp2.317" |} - ; v_info := dummy_var_info |}] - ; f_extra := tt - ; |} ) - ; ( (* keys_expand *) xO (xO (xI xH)), - {| f_info := xO (xO (xI (xO xH))) - ; f_tyin := [(sword U128)] - ; f_params := - [{| v_var := {| vtype := (sword U128) - ; vname := "key.310" |} - ; v_info := dummy_var_info |}] - ; f_body := - [ MkI InstrInfo.witness - (Cassgn - (Laset AAscale U128 - {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.311" |} - ; v_info := dummy_var_info |} - (Pconst (Z0))) - AT_none ((sword U128)) - ((Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "key.310" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}))); - MkI InstrInfo.witness - (Copn - [Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "temp2.312" |} - ; v_info := dummy_var_info |}] - AT_keep (Oasm (* set0_128 *) (ExtOp (Oset0 U128))) []); - MkI InstrInfo.witness - (Cfor - ({| v_var := {| vtype := sint - ; vname := "round.313" |} - ; v_info := dummy_var_info |}) - ((UpTo, (Pconst (Zpos (xH)))), - (Pconst (Zpos (xI (xI (xO xH)))))) - [MkI InstrInfo.witness - (Ccall InlineFun - [Lvar - {| v_var := - {| vtype := sint - ; vname := "rcon.314" |} - ; v_info := dummy_var_info |}] - (xI (xI (xO (xO xH)))) - [(Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "round.313" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})]); - MkI InstrInfo.witness - (Ccall InlineFun - [Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "key.310" |} - ; v_info := dummy_var_info |}; - Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "temp2.312" |} - ; v_info := dummy_var_info |}] - (xO (xI (xO (xO xH)))) - [(Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "rcon.314" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "key.310" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "temp2.312" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})]); - MkI InstrInfo.witness - (Cassgn - (Laset AAscale U128 - {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.311" |} - ; v_info := dummy_var_info |} - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "round.313" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})) - AT_none ((sword U128)) - ((Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "key.310" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})))]) ] - ; f_tyout := [(sarr (xO (xO (xO (xO (xI (xI (xO xH))))))))] - ; f_res := - [{| v_var := - {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.311" |} + ; vname := "out.312" |} ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) - ; ( (* keys_expand_inv *) xI (xO (xO xH)), - {| f_info := xI (xO (xO (xO xH))) - ; f_tyin := [(sword U128)] + ; ( (* aes *) xI xH, + {| f_info := FunInfo.witness + ; f_tyin := [(sword U128); (sword U128)] ; f_params := [{| v_var := {| vtype := (sword U128) - ; vname := "key.305" |} - ; v_info := dummy_var_info |}] + ; vname := "key.314" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "in.315" |} + ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness - (Cassgn - (Laset AAscale U128 + (Ccall InlineFun + [Lvar {| v_var := {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.306" |} - ; v_info := dummy_var_info |} - (Pconst (Z0))) - AT_none ((sword U128)) - ((Pvar + ; vname := "rkeys.317" |} + ; v_info := dummy_var_info |}] + (xI (xO (xO xH))) + [(Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "key.305" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}))); + ; vname := "key.314" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); MkI InstrInfo.witness - (Copn + (Ccall InlineFun [Lvar {| v_var := {| vtype := (sword U128) - ; vname := "temp2.307" |} + ; vname := "out.316" |} ; v_info := dummy_var_info |}] - AT_keep (Oasm (* set0_128 *) (ExtOp (Oset0 U128))) []); - MkI InstrInfo.witness - (Cfor - ({| v_var := {| vtype := sint - ; vname := "round.308" |} - ; v_info := dummy_var_info |}) - ((UpTo, (Pconst (Zpos (xH)))), - (Pconst (Zpos (xI (xI (xO xH)))))) - [MkI InstrInfo.witness - (Ccall InlineFun - [Lvar - {| v_var := - {| vtype := sint - ; vname := "rcon.309" |} - ; v_info := dummy_var_info |}] - (xI (xI (xO (xO xH)))) - [(Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "round.308" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})]); - MkI InstrInfo.witness - (Ccall InlineFun - [Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "key.305" |} - ; v_info := dummy_var_info |}; - Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "temp2.307" |} - ; v_info := dummy_var_info |}] - (xO (xI (xO (xO xH)))) - [(Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "rcon.309" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "key.305" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "temp2.307" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})]); - MkI InstrInfo.witness - (Cif - (Papp2 (Oneq Op_int) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "round.308" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pconst (Zpos (xO (xI (xO xH)))))) - [MkI InstrInfo.witness - (Copn - [Laset AAscale U128 - {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.306" |} - ; v_info := dummy_var_info |} - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "round.308" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})] - AT_keep - (Oasm (* AESIMC *) (BaseOp (None, AESIMC))) - [(Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "key.305" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})])] - [MkI InstrInfo.witness - (Cassgn - (Laset AAscale U128 - {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.306" |} - ; v_info := dummy_var_info |} - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "round.308" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})) - AT_none ((sword U128)) - ((Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "key.305" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})))])]) ] - ; f_tyout := [(sarr (xO (xO (xO (xO (xI (xI (xO xH))))))))] + (xO (xO (xO xH))) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.317" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "in.315" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; f_tyout := [(sword U128)] ; f_res := - [{| v_var := - {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.306" |} + [{| v_var := {| vtype := (sword U128) + ; vname := "out.316" |} ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) - ; ( (* aes_rounds *) xI (xI (xO xH)), - {| f_info := xO (xO (xO (xO xH))) + ; ( (* invaes_rounds *) xO (xI xH), + {| f_info := FunInfo.witness ; f_tyin := [(sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))); (sword U128)] ; f_params := [{| v_var := {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.301" |} + ; vname := "rkeys.318" |} ; v_info := dummy_var_info |}; {| v_var := {| vtype := (sword U128) - ; vname := "in.302" |} + ; vname := "in.319" |} ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness @@ -611,102 +295,113 @@ Proof. (Lvar {| v_var := {| vtype := (sword U128) - ; vname := "state.303" |} + ; vname := "state.320" |} ; v_info := dummy_var_info |}) AT_none ((sword U128)) ((Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "in.302" |} + ; vname := "in.319" |} ; v_info := dummy_var_info |} ; gs := Slocal |}))); MkI InstrInfo.witness (Cassgn (Lvar {| v_var := {| vtype := (sword U128) - ; vname := "state.303" |} + ; vname := "rk.321" |} ; v_info := dummy_var_info |}) AT_none ((sword U128)) - ((Papp2 (Olxor U128) - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "state.303" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pget AAscale U128 - {| gv := {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.301" |} - ; v_info := dummy_var_info |} ; gs := Slocal |} - (Pconst (Z0)))))); + ((Pget AAscale U128 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.318" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pconst (Zpos (xO (xI (xO xH)))))))); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "state.320" |} + ; v_info := dummy_var_info |}] + (xO (xI (xO xH))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "state.320" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "rk.321" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); MkI InstrInfo.witness (Cfor ({| v_var := {| vtype := sint - ; vname := "round.304" |} + ; vname := "round.322" |} ; v_info := dummy_var_info |}) - ((UpTo, (Pconst (Zpos (xH)))), - (Pconst (Zpos (xO (xI (xO xH)))))) + ((DownTo, (Pconst (Z0))), (Pconst (Zpos (xI (xO (xO xH)))))) [MkI InstrInfo.witness (Copn [Lvar {| v_var := {| vtype := (sword U128) - ; vname := "state.303" |} + ; vname := "state.320" |} ; v_info := dummy_var_info |}] - AT_keep (Oasm (* AESENC *) (BaseOp (None, AESENC))) + AT_keep (Oasm (* AESDEC *) (BaseOp (None, AESDEC))) [(Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "state.303" |} + ; vname := "state.320" |} ; v_info := dummy_var_info |} ; gs := Slocal |}); (Pget AAscale U128 {| gv := {| v_var := {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.301" |} + ; vname := "rkeys.318" |} ; v_info := dummy_var_info |} ; gs := Slocal |} (Pvar {| gv := {| v_var := {| vtype := sint - ; vname := "round.304" |} + ; vname := "round.322" |} ; v_info := dummy_var_info |} ; gs := Slocal |}))])]); MkI InstrInfo.witness (Copn [Lvar {| v_var := {| vtype := (sword U128) - ; vname := "state.303" |} + ; vname := "state.320" |} ; v_info := dummy_var_info |}] - AT_keep (Oasm (* AESENCLAST *) (BaseOp (None, AESENCLAST))) + AT_keep (Oasm (* AESDECLAST *) (BaseOp (None, AESDECLAST))) [(Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "state.303" |} + ; vname := "state.320" |} ; v_info := dummy_var_info |} ; gs := Slocal |}); (Pget AAscale U128 {| gv := {| v_var := {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.301" |} + ; vname := "rkeys.318" |} ; v_info := dummy_var_info |} ; gs := Slocal |} - (Pconst (Zpos (xO (xI (xO xH))))))]) ] + (Pconst (Z0)))]) ] ; f_tyout := [(sword U128)] ; f_res := [{| v_var := {| vtype := (sword U128) - ; vname := "state.303" |} + ; vname := "state.320" |} ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) - ; ( (* AddRoundKey *) xO (xI (xI xH)), - {| f_info := xI (xI (xI xH)) + ; ( (* AddRoundKey *) xO (xI (xO xH)), + {| f_info := FunInfo.witness ; f_tyin := [(sword U128); (sword U128)] ; f_params := [{| v_var := {| vtype := (sword U128) - ; vname := "state.299" |} + ; vname := "state.323" |} ; v_info := dummy_var_info |}; {| v_var := {| vtype := (sword U128) - ; vname := "rk.300" |} + ; vname := "rk.324" |} ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness @@ -714,38 +409,38 @@ Proof. (Lvar {| v_var := {| vtype := (sword U128) - ; vname := "state.299" |} + ; vname := "state.323" |} ; v_info := dummy_var_info |}) AT_none ((sword U128)) ((Papp2 (Olxor U128) (Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "state.299" |} + ; vname := "state.323" |} ; v_info := dummy_var_info |} ; gs := Slocal |}) (Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "rk.300" |} + ; vname := "rk.324" |} ; v_info := dummy_var_info |} ; gs := Slocal |})))) ] ; f_tyout := [(sword U128)] ; f_res := [{| v_var := {| vtype := (sword U128) - ; vname := "state.299" |} + ; vname := "state.323" |} ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) - ; ( (* invaes_rounds *) xO (xO (xO xH)), - {| f_info := xI (xO (xI xH)) + ; ( (* aes_rounds *) xO (xO (xO xH)), + {| f_info := FunInfo.witness ; f_tyin := [(sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))); (sword U128)] ; f_params := [{| v_var := {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.294" |} + ; vname := "rkeys.325" |} ; v_info := dummy_var_info |}; {| v_var := {| vtype := (sword U128) - ; vname := "in.295" |} + ; vname := "in.326" |} ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness @@ -753,307 +448,685 @@ Proof. (Lvar {| v_var := {| vtype := (sword U128) - ; vname := "state.296" |} + ; vname := "state.327" |} ; v_info := dummy_var_info |}) AT_none ((sword U128)) ((Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "in.295" |} + ; vname := "in.326" |} ; v_info := dummy_var_info |} ; gs := Slocal |}))); MkI InstrInfo.witness (Cassgn (Lvar {| v_var := {| vtype := (sword U128) - ; vname := "rk.297" |} + ; vname := "state.327" |} ; v_info := dummy_var_info |}) AT_none ((sword U128)) - ((Pget AAscale U128 - {| gv := {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.294" |} - ; v_info := dummy_var_info |} ; gs := Slocal |} - (Pconst (Zpos (xO (xI (xO xH)))))))); - MkI InstrInfo.witness - (Ccall InlineFun - [Lvar - {| v_var := - {| vtype := (sword U128) - ; vname := "state.296" |} - ; v_info := dummy_var_info |}] - (xO (xI (xI xH))) - [(Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "state.296" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "rk.297" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})]); + ((Papp2 (Olxor U128) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "state.327" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pget AAscale U128 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.325" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pconst (Z0)))))); MkI InstrInfo.witness (Cfor ({| v_var := {| vtype := sint - ; vname := "round.298" |} + ; vname := "round.328" |} ; v_info := dummy_var_info |}) - ((DownTo, (Pconst (Z0))), (Pconst (Zpos (xI (xO (xO xH)))))) + ((UpTo, (Pconst (Zpos (xH)))), + (Pconst (Zpos (xO (xI (xO xH)))))) [MkI InstrInfo.witness (Copn [Lvar {| v_var := {| vtype := (sword U128) - ; vname := "state.296" |} + ; vname := "state.327" |} ; v_info := dummy_var_info |}] - AT_keep (Oasm (* AESDEC *) (BaseOp (None, AESDEC))) + AT_keep (Oasm (* AESENC *) (BaseOp (None, AESENC))) [(Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "state.296" |} + ; vname := "state.327" |} ; v_info := dummy_var_info |} ; gs := Slocal |}); (Pget AAscale U128 {| gv := {| v_var := {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.294" |} + ; vname := "rkeys.325" |} ; v_info := dummy_var_info |} ; gs := Slocal |} (Pvar {| gv := {| v_var := {| vtype := sint - ; vname := "round.298" |} + ; vname := "round.328" |} ; v_info := dummy_var_info |} ; gs := Slocal |}))])]); MkI InstrInfo.witness (Copn [Lvar {| v_var := {| vtype := (sword U128) - ; vname := "state.296" |} + ; vname := "state.327" |} ; v_info := dummy_var_info |}] - AT_keep (Oasm (* AESDECLAST *) (BaseOp (None, AESDECLAST))) + AT_keep (Oasm (* AESENCLAST *) (BaseOp (None, AESENCLAST))) [(Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "state.296" |} + ; vname := "state.327" |} ; v_info := dummy_var_info |} ; gs := Slocal |}); (Pget AAscale U128 {| gv := {| v_var := {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.294" |} + ; vname := "rkeys.325" |} ; v_info := dummy_var_info |} ; gs := Slocal |} - (Pconst (Z0)))]) ] + (Pconst (Zpos (xO (xI (xO xH))))))]) ] ; f_tyout := [(sword U128)] ; f_res := [{| v_var := {| vtype := (sword U128) - ; vname := "state.296" |} + ; vname := "state.327" |} ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) - ; ( (* aes *) xO (xI xH), - {| f_info := xO (xI (xO xH)) - ; f_tyin := [(sword U128); (sword U128)] + ; ( (* keys_expand_inv *) xI (xI xH), + {| f_info := FunInfo.witness + ; f_tyin := [(sword U128)] ; f_params := [{| v_var := {| vtype := (sword U128) - ; vname := "key.290" |} - ; v_info := dummy_var_info |}; - {| v_var := {| vtype := (sword U128) - ; vname := "in.291" |} - ; v_info := dummy_var_info |}] + ; vname := "key.329" |} + ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness - (Ccall InlineFun - [Lvar + (Cassgn + (Laset AAscale U128 {| v_var := {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.293" |} - ; v_info := dummy_var_info |}] - (xO (xO (xI xH))) - [(Pvar + ; vname := "rkeys.330" |} + ; v_info := dummy_var_info |} + (Pconst (Z0))) + AT_none ((sword U128)) + ((Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "key.290" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})]); + ; vname := "key.329" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); MkI InstrInfo.witness - (Ccall InlineFun + (Copn [Lvar {| v_var := {| vtype := (sword U128) - ; vname := "out.292" |} + ; vname := "temp2.331" |} ; v_info := dummy_var_info |}] - (xI (xI (xO xH))) - [(Pvar - {| gv := {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.293" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "in.291" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] - ; f_tyout := [(sword U128)] + AT_keep (Oasm (* set0_128 *) (ExtOp (Oset0 U128))) []); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "round.332" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Zpos (xH)))), + (Pconst (Zpos (xI (xI (xO xH)))))) + [MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := sint + ; vname := "rcon.333" |} + ; v_info := dummy_var_info |}] + (xO (xO (xI xH))) + [(Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "round.332" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "key.329" |} + ; v_info := dummy_var_info |}; + Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.331" |} + ; v_info := dummy_var_info |}] + (xI (xI (xO xH))) + [(Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "rcon.333" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.329" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.331" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cif + (Papp2 (Oneq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "round.332" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO (xI (xO xH)))))) + [MkI InstrInfo.witness + (Copn + [Laset AAscale U128 + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.330" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "round.332" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})] + AT_keep + (Oasm (* AESIMC *) (BaseOp (None, AESIMC))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.329" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})])] + [MkI InstrInfo.witness + (Cassgn + (Laset AAscale U128 + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.330" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "round.332" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) + AT_none ((sword U128)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.329" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))])]) ] + ; f_tyout := [(sarr (xO (xO (xO (xO (xI (xI (xO xH))))))))] ; f_res := - [{| v_var := {| vtype := (sword U128) - ; vname := "out.292" |} + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.330" |} ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) - ; ( (* invaes *) xI xH, - {| f_info := xI (xI xH) - ; f_tyin := [(sword U128); (sword U128)] + ; ( (* keys_expand *) xI (xO (xO xH)), + {| f_info := FunInfo.witness + ; f_tyin := [(sword U128)] ; f_params := [{| v_var := {| vtype := (sword U128) - ; vname := "key.286" |} - ; v_info := dummy_var_info |}; - {| v_var := {| vtype := (sword U128) - ; vname := "in.287" |} - ; v_info := dummy_var_info |}] + ; vname := "key.334" |} + ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness - (Ccall InlineFun - [Lvar + (Cassgn + (Laset AAscale U128 {| v_var := {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.289" |} - ; v_info := dummy_var_info |}] - (xI (xO (xO xH))) - [(Pvar + ; vname := "rkeys.335" |} + ; v_info := dummy_var_info |} + (Pconst (Z0))) + AT_none ((sword U128)) + ((Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "key.286" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})]); + ; vname := "key.334" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); MkI InstrInfo.witness - (Ccall InlineFun + (Copn [Lvar {| v_var := {| vtype := (sword U128) - ; vname := "out.288" |} + ; vname := "temp2.336" |} ; v_info := dummy_var_info |}] - (xO (xO (xO xH))) - [(Pvar - {| gv := {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) - ; vname := "rkeys.289" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Pvar - {| gv := {| v_var := - {| vtype := (sword U128) - ; vname := "in.287" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] - ; f_tyout := [(sword U128)] + AT_keep (Oasm (* set0_128 *) (ExtOp (Oset0 U128))) []); + MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "round.337" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Zpos (xH)))), + (Pconst (Zpos (xI (xI (xO xH)))))) + [MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := sint + ; vname := "rcon.338" |} + ; v_info := dummy_var_info |}] + (xO (xO (xI xH))) + [(Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "round.337" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "key.334" |} + ; v_info := dummy_var_info |}; + Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.336" |} + ; v_info := dummy_var_info |}] + (xI (xI (xO xH))) + [(Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "rcon.338" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.334" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.336" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness + (Cassgn + (Laset AAscale U128 + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.335" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "round.337" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) + AT_none ((sword U128)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "key.334" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))]) ] + ; f_tyout := [(sarr (xO (xO (xO (xO (xI (xI (xO xH))))))))] ; f_res := - [{| v_var := {| vtype := (sword U128) - ; vname := "out.288" |} + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xI (xO xH)))))))) + ; vname := "rkeys.335" |} ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) - ; ( (* aes_jazz *) xO (xO xH), - {| f_info := xI (xO xH) - ; f_tyin := [(sword U128); (sword U128)] + ; ( (* key_expand *) xI (xI (xO xH)), + {| f_info := FunInfo.witness + ; f_tyin := [sint; (sword U128); (sword U128)] ; f_params := - [{| v_var := {| vtype := (sword U128) - ; vname := "key.283" |} + [{| v_var := {| vtype := sint + ; vname := "rcon.339" |} ; v_info := dummy_var_info |}; {| v_var := {| vtype := (sword U128) - ; vname := "in.284" |} + ; vname := "rkey.340" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "temp2.341" |} ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness - (Ccall InlineFun + (Copn [Lvar {| v_var := {| vtype := (sword U128) - ; vname := "out.285" |} + ; vname := "temp1.342" |} ; v_info := dummy_var_info |}] - (xO (xI xH)) + AT_keep + (Oasm (* VAESKEYGENASSIST *) + (BaseOp (None, VAESKEYGENASSIST))) [(Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "key.283" |} + ; vname := "rkey.340" |} ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Papp1 (Oword_of_int U8) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "rcon.339" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))]); + MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.340" |} + ; v_info := dummy_var_info |}; + Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.341" |} + ; v_info := dummy_var_info |}] + (xI (xO (xI xH))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.340" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp1.342" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); (Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "in.284" |} + ; vname := "temp2.341" |} ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] - ; f_tyout := [(sword U128)] + ; f_tyout := [(sword U128); (sword U128)] ; f_res := [{| v_var := {| vtype := (sword U128) - ; vname := "out.285" |} - ; v_info := dummy_var_info |}] + ; vname := "rkey.340" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "temp2.341" |} + ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) - ; ( (* invaes_jazz *) xH, - {| f_info := xO xH - ; f_tyin := [(sword U128); (sword U128)] + ; ( (* key_combine *) xI (xO (xI xH)), + {| f_info := FunInfo.witness + ; f_tyin := [(sword U128); (sword U128); (sword U128)] ; f_params := [{| v_var := {| vtype := (sword U128) - ; vname := "key.280" |} + ; vname := "rkey.343" |} ; v_info := dummy_var_info |}; {| v_var := {| vtype := (sword U128) - ; vname := "in.281" |} + ; vname := "temp1.344" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "temp2.345" |} ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness - (Ccall InlineFun + (Copn [Lvar {| v_var := {| vtype := (sword U128) - ; vname := "out.282" |} + ; vname := "temp1.344" |} ; v_info := dummy_var_info |}] - (xI xH) + AT_keep + (Oasm (* VPSHUFD_128 *) (BaseOp (None, (VPSHUFD U128)))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp1.344" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (PappN (Opack U8 PE2) + [(Pconst (Zpos (xI xH))); (Pconst (Zpos (xI xH))); + (Pconst (Zpos (xI xH))); (Pconst (Zpos (xI xH)))])]); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.345" |} + ; v_info := dummy_var_info |}] + AT_keep + (Oasm (* VSHUFPS_128 *) (BaseOp (None, (VSHUFPS U128)))) [(Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "key.280" |} + ; vname := "temp2.345" |} ; v_info := dummy_var_info |} ; gs := Slocal |}); (Pvar {| gv := {| v_var := {| vtype := (sword U128) - ; vname := "in.281" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] - ; f_tyout := [(sword U128)] + ; vname := "rkey.343" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (PappN (Opack U8 PE2) + [(Pconst (Z0)); (Pconst (Zpos (xH))); (Pconst (Z0)); + (Pconst (Z0))])]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.343" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U128)) + ((Papp2 (Olxor U128) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.343" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.345" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness + (Copn + [Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.345" |} + ; v_info := dummy_var_info |}] + AT_keep + (Oasm (* VSHUFPS_128 *) (BaseOp (None, (VSHUFPS U128)))) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.345" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.343" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (PappN (Opack U8 PE2) + [(Pconst (Zpos (xO xH))); (Pconst (Z0)); + (Pconst (Zpos (xI xH))); (Pconst (Z0))])]); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.343" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U128)) + ((Papp2 (Olxor U128) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.343" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp2.345" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.343" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U128)) + ((Papp2 (Olxor U128) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "rkey.343" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U128) + ; vname := "temp1.344" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))) ] + ; f_tyout := [(sword U128); (sword U128)] ; f_res := [{| v_var := {| vtype := (sword U128) - ; vname := "out.282" |} + ; vname := "rkey.343" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U128) + ; vname := "temp2.345" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* RCON *) xO (xO (xI xH)), + {| f_info := FunInfo.witness + ; f_tyin := [sint] + ; f_params := + [{| v_var := {| vtype := sint + ; vname := "i.346" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := {| vtype := sint + ; vname := "c.347" |} + ; v_info := dummy_var_info |}) + AT_inline (sint) + ((Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.346" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xH)))) + (Pconst (Zpos (xH))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.346" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO xH)))) + (Pconst (Zpos (xO xH))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.346" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xI xH)))) + (Pconst (Zpos (xO (xO xH)))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.346" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO (xO xH))))) + (Pconst (Zpos (xO (xO (xO xH))))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.346" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xI (xO xH))))) + (Pconst (Zpos (xO (xO (xO (xO xH)))))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.346" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO (xI xH))))) + (Pconst (Zpos (xO (xO (xO (xO (xO xH))))))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := + "i.346" |} + ; v_info := + dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xI (xI xH))))) + (Pconst + (Zpos (xO (xO (xO (xO (xO (xO xH)))))))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := + "i.346" |} + ; v_info := + dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO (xO (xO xH)))))) + (Pconst + (Zpos (xO (xO (xO (xO (xO (xO (xO xH))))))))) + (Pif (sint) + (Papp2 (Oeq Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := + sint + ; vname := + "i.346" |} + ; v_info := + dummy_var_info |} ; gs := Slocal |}) + (Pconst + (Zpos (xI (xO (xO xH)))))) + (Pconst + (Zpos (xI (xI (xO (xI xH)))))) + (Pconst + (Zpos (xO (xI (xI (xO (xI xH)))))))))))))))))) ] + ; f_tyout := [sint] + ; f_res := + [{| v_var := {| vtype := sint + ; vname := "c.347" |} ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) ] ; p_globs := [] ; p_extra := tt |}. -Defined. - -From JasminSSProve Require Import jasmin_utils. -Import JasminNotation JasminCodeNotation. -Import PackageNotation. - -Notation RCON := (xI (xI (xO (xO xH)))). -Notation KEY_COMBINE := (xO (xI (xI (xO xH)))). -Notation KEY_EXPAND := (xO (xI (xO (xO xH)))). -Notation KEY_EXPAND_INV := (xI (xO (xO xH))). -Notation KEYS_EXPAND := (xO (xO (xI xH))). - -Notation ADDROUNDKEY := (xO (xI (xI xH))). - -Notation AES_ROUNDS := (xI (xI (xO xH))). -Notation INVAES_ROUNDS := (xO (xO (xO xH))). - -Notation AES := (xO (xI xH)). -Notation INVAES := (xI xH). - -Notation AES_JAZZ := (xO (xO xH)). -Notation INVAES_JAZZ := (xH). +Defined. +Notation DEC := ( xH ). +Notation ENC := ( xO (xO xH) ). +Notation XOR := ( xO xH ). +Notation INVAES := ( xI (xO xH) ). +Notation AES := ( xI xH ). +Notation INVAES_ROUNDS := ( xO (xI xH) ). +Notation ADDROUNDKEY := ( xO (xI (xO xH)) ). +Notation AES_ROUNDS := ( xO (xO (xO xH)) ). +Notation KEYS_EXPAND_INV := ( xI (xI xH) ). +Notation KEYS_EXPAND := ( xI (xO (xO xH)) ). +Notation KEY_EXPAND := ( xI (xI (xO xH)) ). +Notation KEY_COMBINE := ( xI (xO (xI xH)) ). +Notation RCON := ( xO (xO (xI xH)) ). Notation trp := (translate_prog' ssprove_jasmin_prog).1. Notation trc := (fun fn i => translate_call ssprove_jasmin_prog fn trp i). - Notation funlist := [seq f.1 | f <- p_funcs ssprove_jasmin_prog]. Definition static_fun fn := (fn, match assoc trp fn with Some c => c | None => fun _ => ret tt end). @@ -1063,20 +1136,14 @@ Definition static_funs := [seq static_fun f | f <- funlist]. Definition strp := (translate_prog_static ssprove_jasmin_prog static_funs). Opaque strp. -Definition get_translated_static_fun P fn st_func := - match assoc (translate_prog_static P st_func).2 fn with - | Some f => f - | None => fun _ _ => ret [::] - end. - Definition call fn i := (get_translated_static_fun ssprove_jasmin_prog fn static_funs i). Notation JRCON i j := (call RCON i [('int ; j)]). Notation JKEY_COMBINE i rkey temp1 temp2 := (call KEY_COMBINE i [('word U128 ; rkey) ; ('word U128 ; temp1) ; ('word U128 ; temp2)]). Notation JKEY_EXPAND i rcon rkey temp2 := (call KEY_EXPAND i [ ('int ; rcon) ; ('word U128 ; rkey) ; ('word U128 ; temp2) ]). -Notation JKEY_EXPAND_INV i key := (call KEY_EXPAND_INV i [('word U128 ; key)]). Notation JKEYS_EXPAND i rkey := (call KEYS_EXPAND i [('word U128 ; rkey)]). +Notation JKEYS_EXPAND_INV i key := (call KEYS_EXPAND_INV i [('word U128 ; key)]). Notation JADDROUNDKEY i state rk := (call KEYS_EXPAND i [('word U128 ; state) ; ('word U128 ; rk)]). @@ -1086,5 +1153,6 @@ Notation JINVAES_ROUNDS i rkeys m := (call INVAES_ROUNDS i [('array ; rkeys) ; ( Notation JAES i key m := (call AES i [('word U128 ; key) ; ('word U128 ; m)]). Notation JINVAES i key m := (call INVAES i [('word U128 ; key) ; ('word U128 ; m)]). -Notation JAES_JAZZ i key m := (call AES i [('word U128 ; key) ; ('word U128 ; m)]). -Notation JINVAES_JAZZ i key m := (call AES i [('word U128 ; key) ; ('word U128 ; m)]). +Notation JXOR i a1 a2 := (call XOR i [('word U128 ; a1) ; ('word U128 ; a2)]). +Notation JENC i n k m := (call ENC i [('word U128 ; n) ; ('word U128 ; k) ; ('word U128 ; m)]). +Notation JDEC i n k m := (call DEC i [('word U128 ; n) ; ('word U128 ; k) ; ('word U128 ; m)]). diff --git a/theories/Jasmin/examples/bigadd.v b/theories/Jasmin/examples/bigadd.v index 7e3a009b..10877094 100644 --- a/theories/Jasmin/examples/bigadd.v +++ b/theories/Jasmin/examples/bigadd.v @@ -22,18 +22,18 @@ Definition ssprove_jasmin_prog : uprog. Proof. refine {| p_funcs := [ ( (* add_inline *) xH, - {| f_info := xO xH + {| f_info := FunInfo.witness ; f_tyin := [(sarr (xO (xO (xO (xO (xO xH)))))); (sarr (xO (xO (xO (xO (xO xH))))))] ; f_params := [{| v_var := {| vtype := (sarr (xO (xO (xO (xO (xO xH)))))) - ; vname := "x.151" |} + ; vname := "x.149" |} ; v_info := dummy_var_info |}; {| v_var := {| vtype := (sarr (xO (xO (xO (xO (xO xH)))))) - ; vname := "y.152" |} + ; vname := "y.150" |} ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness @@ -41,14 +41,14 @@ Proof. (Lvar {| v_var := {| vtype := (sword U64) - ; vname := "xr.154" |} + ; vname := "xr.152" |} ; v_info := dummy_var_info |}) AT_none ((sword U64)) ((Pget AAscale U64 {| gv := {| v_var := {| vtype := (sarr (xO (xO (xO (xO (xO xH)))))) - ; vname := "x.151" |} + ; vname := "x.149" |} ; v_info := dummy_var_info |} ; gs := Slocal |} (Pconst (Z0))))); MkI InstrInfo.witness @@ -56,37 +56,37 @@ Proof. (Lvar {| v_var := {| vtype := (sword U64) - ; vname := "yr.155" |} + ; vname := "yr.153" |} ; v_info := dummy_var_info |}) AT_none ((sword U64)) ((Pget AAscale U64 {| gv := {| v_var := {| vtype := (sarr (xO (xO (xO (xO (xO xH)))))) - ; vname := "y.152" |} + ; vname := "y.150" |} ; v_info := dummy_var_info |} ; gs := Slocal |} (Pconst (Z0))))); MkI InstrInfo.witness (Copn [Lvar {| v_var := {| vtype := sbool - ; vname := "cf.156" |} + ; vname := "cf.154" |} ; v_info := dummy_var_info |}; Lvar {| v_var := {| vtype := (sword U64) - ; vname := "xr.154" |} + ; vname := "xr.152" |} ; v_info := dummy_var_info |}] AT_keep (Oaddcarry (U64)) [(Pvar {| gv := {| v_var := {| vtype := (sword U64) - ; vname := "xr.154" |} + ; vname := "xr.152" |} ; v_info := dummy_var_info |} ; gs := Slocal |}); (Pvar {| gv := {| v_var := {| vtype := (sword U64) - ; vname := "yr.155" |} + ; vname := "yr.153" |} ; v_info := dummy_var_info |} ; gs := Slocal |}); (Pbool false)]); MkI InstrInfo.witness @@ -94,19 +94,19 @@ Proof. (Laset AAscale U64 {| v_var := {| vtype := (sarr (xO (xO (xO (xO (xO xH)))))) - ; vname := "res.153" |} + ; vname := "res.151" |} ; v_info := dummy_var_info |} (Pconst (Z0))) AT_none ((sword U64)) ((Pvar {| gv := {| v_var := {| vtype := (sword U64) - ; vname := "xr.154" |} + ; vname := "xr.152" |} ; v_info := dummy_var_info |} ; gs := Slocal |}))); MkI InstrInfo.witness (Cfor ({| v_var := {| vtype := sint - ; vname := "i.157" |} + ; vname := "i.155" |} ; v_info := dummy_var_info |}) ((UpTo, (Pconst (Zpos (xH)))), (Pconst (Zpos (xO (xO xH))))) [MkI InstrInfo.witness @@ -114,93 +114,95 @@ Proof. (Lvar {| v_var := {| vtype := (sword U64) - ; vname := "xr.154" |} + ; vname := "xr.152" |} ; v_info := dummy_var_info |}) AT_none ((sword U64)) ((Pget AAscale U64 {| gv := {| v_var := {| vtype := (sarr (xO (xO (xO (xO (xO xH)))))) - ; vname := "x.151" |} + ; vname := "x.149" |} ; v_info := dummy_var_info |} ; gs := Slocal |} (Pvar {| gv := {| v_var := {| vtype := sint - ; vname := "i.157" |} + ; vname := "i.155" |} ; v_info := dummy_var_info |} ; gs := Slocal |})))); MkI InstrInfo.witness (Cassgn (Lvar {| v_var := {| vtype := (sword U64) - ; vname := "yr.155" |} + ; vname := "yr.153" |} ; v_info := dummy_var_info |}) AT_none ((sword U64)) ((Pget AAscale U64 {| gv := {| v_var := {| vtype := (sarr (xO (xO (xO (xO (xO xH)))))) - ; vname := "y.152" |} + ; vname := "y.150" |} ; v_info := dummy_var_info |} ; gs := Slocal |} (Pvar {| gv := {| v_var := {| vtype := sint - ; vname := "i.157" |} + ; vname := "i.155" |} ; v_info := dummy_var_info |} ; gs := Slocal |})))); MkI InstrInfo.witness (Copn [Lvar {| v_var := {| vtype := sbool - ; vname := "cf.156" |} + ; vname := "cf.154" |} ; v_info := dummy_var_info |}; Lvar {| v_var := {| vtype := (sword U64) - ; vname := "xr.154" |} + ; vname := "xr.152" |} ; v_info := dummy_var_info |}] AT_keep (Oaddcarry (U64)) [(Pvar {| gv := {| v_var := {| vtype := (sword U64) - ; vname := "xr.154" |} + ; vname := "xr.152" |} ; v_info := dummy_var_info |} ; gs := Slocal |}); (Pvar {| gv := {| v_var := {| vtype := (sword U64) - ; vname := "yr.155" |} + ; vname := "yr.153" |} ; v_info := dummy_var_info |} ; gs := Slocal |}); (Pvar {| gv := {| v_var := {| vtype := sbool - ; vname := "cf.156" |} + ; vname := "cf.154" |} ; v_info := dummy_var_info |} ; gs := Slocal |})]); MkI InstrInfo.witness (Cassgn (Laset AAscale U64 {| v_var := {| vtype := (sarr (xO (xO (xO (xO (xO xH)))))) - ; vname := "res.153" |} + ; vname := "res.151" |} ; v_info := dummy_var_info |} (Pvar {| gv := {| v_var := {| vtype := sint - ; vname := "i.157" |} + ; vname := "i.155" |} ; v_info := dummy_var_info |} ; gs := Slocal |})) AT_none ((sword U64)) ((Pvar {| gv := {| v_var := {| vtype := (sword U64) - ; vname := "xr.154" |} + ; vname := "xr.152" |} ; v_info := dummy_var_info |} ; gs := Slocal |})))]) ] ; f_tyout := [(sarr (xO (xO (xO (xO (xO xH))))))] ; f_res := [{| v_var := {| vtype := (sarr (xO (xO (xO (xO (xO xH)))))) - ; vname := "res.153" |} + ; vname := "res.151" |} ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) ] ; p_globs := [] ; p_extra := tt |}. + Defined. +Notation ADD_INLINE := ( xH ). \ No newline at end of file diff --git a/theories/Jasmin/examples/ex.v b/theories/Jasmin/examples/ex.v index cf52163d..6178c211 100644 --- a/theories/Jasmin/examples/ex.v +++ b/theories/Jasmin/examples/ex.v @@ -22,69 +22,71 @@ Definition ssprove_jasmin_prog : uprog. Proof. refine {| p_funcs := [ ( (* add *) xH, - {| f_info := xO xH + {| f_info := FunInfo.witness ; f_tyin := [(sword U64); (sword U64)] ; f_params := [{| v_var := {| vtype := (sword U64) - ; vname := "x.144" |} + ; vname := "x.142" |} ; v_info := dummy_var_info |}; {| v_var := {| vtype := (sword U64) - ; vname := "y.145" |} + ; vname := "y.143" |} ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness (Copn [Lvar {| v_var := {| vtype := sbool - ; vname := "cf.146" |} + ; vname := "cf.144" |} ; v_info := dummy_var_info |}; Lvar {| v_var := {| vtype := (sword U64) - ; vname := "x.144" |} + ; vname := "x.142" |} ; v_info := dummy_var_info |}] AT_keep (Oaddcarry (U64)) [(Pvar {| gv := {| v_var := {| vtype := (sword U64) - ; vname := "x.144" |} + ; vname := "x.142" |} ; v_info := dummy_var_info |} ; gs := Slocal |}); (Pvar {| gv := {| v_var := {| vtype := (sword U64) - ; vname := "y.145" |} + ; vname := "y.143" |} ; v_info := dummy_var_info |} ; gs := Slocal |}); (Pbool false)]); MkI InstrInfo.witness (Copn [Lvar {| v_var := {| vtype := sbool - ; vname := "cf.146" |} + ; vname := "cf.144" |} ; v_info := dummy_var_info |}; Lvar {| v_var := {| vtype := (sword U64) - ; vname := "y.145" |} + ; vname := "y.143" |} ; v_info := dummy_var_info |}] AT_keep (Oaddcarry (U64)) [(Pvar {| gv := {| v_var := {| vtype := (sword U64) - ; vname := "y.145" |} + ; vname := "y.143" |} ; v_info := dummy_var_info |} ; gs := Slocal |}); (Pvar {| gv := {| v_var := {| vtype := (sword U64) - ; vname := "x.144" |} + ; vname := "x.142" |} ; v_info := dummy_var_info |} ; gs := Slocal |}); (Pbool false)]) ] ; f_tyout := [(sword U64)] ; f_res := [{| v_var := {| vtype := (sword U64) - ; vname := "y.145" |} + ; vname := "y.143" |} ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) ] ; p_globs := [] ; p_extra := tt |}. + Defined. +Notation ADD := ( xH ). \ No newline at end of file diff --git a/theories/Jasmin/examples/int_add.v b/theories/Jasmin/examples/int_add.v index 5588f333..9826dfbb 100644 --- a/theories/Jasmin/examples/int_add.v +++ b/theories/Jasmin/examples/int_add.v @@ -21,94 +21,97 @@ Local Open Scope string. Definition ssprove_jasmin_prog : uprog. Proof. refine {| p_funcs := - [ ( (* odd *) xI xH, - {| f_info := xO (xO xH) - ; f_tyin := [(sword U64); (sword U64)] + [ ( (* add *) xH, + {| f_info := FunInfo.witness + ; f_tyin := [sint; sint] ; f_params := - [{| v_var := {| vtype := (sword U64) - ; vname := "n.157" |} + [{| v_var := {| vtype := sint + ; vname := "n.152" |} ; v_info := dummy_var_info |}; - {| v_var := {| vtype := (sword U64) - ; vname := "m.158" |} + {| v_var := {| vtype := sint + ; vname := "m.153" |} ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness (Cfor ({| v_var := {| vtype := sint - ; vname := "i.159" |} + ; vname := "i.154" |} ; v_info := dummy_var_info |}) ((UpTo, (Pconst (Z0))), - (Papp1 (Oint_of_word U64) - (Pvar - {| gv := {| v_var := - {| vtype := (sword U64) - ; vname := "n.157" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}))) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "n.152" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) [MkI InstrInfo.witness (Cassgn (Lvar - {| v_var := - {| vtype := (sword U64) - ; vname := "m.158" |} + {| v_var := {| vtype := sint + ; vname := "m.153" |} ; v_info := dummy_var_info |}) - AT_none ((sword U64)) - ((Papp2 (Oadd (Op_w U64)) + AT_inline (sint) + ((Papp2 (Oadd Op_int) (Pvar {| gv := {| v_var := - {| vtype := (sword U64) - ; vname := "m.158" |} + {| vtype := sint + ; vname := "m.153" |} ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Papp1 (Oword_of_int U64) (Pconst (Zpos (xH)))))))]) ] - ; f_tyout := [(sword U64)] + (Pconst (Zpos (xH))))))]) ] + ; f_tyout := [sint] ; f_res := - [{| v_var := {| vtype := (sword U64) - ; vname := "m.158" |} + [{| v_var := {| vtype := sint + ; vname := "m.153" |} ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) - ; ( (* add *) xH, - {| f_info := xO xH - ; f_tyin := [sint; sint] + ; ( (* odd *) xO xH, + {| f_info := FunInfo.witness + ; f_tyin := [(sword U64); (sword U64)] ; f_params := - [{| v_var := {| vtype := sint - ; vname := "n.154" |} + [{| v_var := {| vtype := (sword U64) + ; vname := "n.155" |} ; v_info := dummy_var_info |}; - {| v_var := {| vtype := sint - ; vname := "m.155" |} + {| v_var := {| vtype := (sword U64) + ; vname := "m.156" |} ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness (Cfor ({| v_var := {| vtype := sint - ; vname := "i.156" |} + ; vname := "i.157" |} ; v_info := dummy_var_info |}) ((UpTo, (Pconst (Z0))), - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "n.154" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})) + (Papp1 (Oint_of_word U64) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "n.155" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))) [MkI InstrInfo.witness (Cassgn (Lvar - {| v_var := {| vtype := sint - ; vname := "m.155" |} + {| v_var := + {| vtype := (sword U64) + ; vname := "m.156" |} ; v_info := dummy_var_info |}) - AT_inline (sint) - ((Papp2 (Oadd Op_int) + AT_none ((sword U64)) + ((Papp2 (Oadd (Op_w U64)) (Pvar {| gv := {| v_var := - {| vtype := sint - ; vname := "m.155" |} + {| vtype := (sword U64) + ; vname := "m.156" |} ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pconst (Zpos (xH))))))]) ] - ; f_tyout := [sint] + (Papp1 (Oword_of_int U64) (Pconst (Zpos (xH)))))))]) ] + ; f_tyout := [(sword U64)] ; f_res := - [{| v_var := {| vtype := sint - ; vname := "m.155" |} + [{| v_var := {| vtype := (sword U64) + ; vname := "m.156" |} ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) ] ; p_globs := [] ; p_extra := tt |}. + Defined. +Notation ADD := ( xH ). +Notation ODD := ( xO xH ). \ No newline at end of file diff --git a/theories/Jasmin/examples/int_incr.v b/theories/Jasmin/examples/int_incr.v index ea01b2a8..9e37d1c8 100644 --- a/theories/Jasmin/examples/int_incr.v +++ b/theories/Jasmin/examples/int_incr.v @@ -21,37 +21,8 @@ Local Open Scope string. Definition ssprove_jasmin_prog : uprog. Proof. refine {| p_funcs := - [ ( (* incr *) xI xH, - {| f_info := xO (xO xH) - ; f_tyin := [sint] - ; f_params := - [{| v_var := {| vtype := sint - ; vname := "n.155" |} - ; v_info := dummy_var_info |}] - ; f_body := - [ MkI InstrInfo.witness - (Cassgn - (Lvar - {| v_var := {| vtype := sint - ; vname := "m.156" |} - ; v_info := dummy_var_info |}) - AT_inline (sint) - ((Papp2 (Oadd Op_int) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "n.155" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pconst (Zpos (xH)))))) ] - ; f_tyout := [sint] - ; f_res := - [{| v_var := {| vtype := sint - ; vname := "m.156" |} - ; v_info := dummy_var_info |}] - ; f_extra := tt - ; |} ) - ; ( (* f *) xH, - {| f_info := xO xH + [ ( (* f *) xH, + {| f_info := FunInfo.witness ; f_tyin := [] ; f_params := [] ; f_body := @@ -59,42 +30,74 @@ Proof. (Ccall InlineFun [Lvar {| v_var := {| vtype := sint - ; vname := "x.153" |} + ; vname := "x.151" |} ; v_info := dummy_var_info |}] - (xI xH) [(Pconst (Z0))]); + (xO xH) [(Pconst (Z0))]); MkI InstrInfo.witness (Cassgn (Lvar {| v_var := {| vtype := (sword U64) - ; vname := "xx.154" |} + ; vname := "xx.152" |} ; v_info := dummy_var_info |}) AT_none ((sword U64)) ((Pvar {| gv := {| v_var := {| vtype := (sword U64) - ; vname := "y.152" |} + ; vname := "y.150" |} ; v_info := dummy_var_info |} ; gs := Slocal |}))); MkI InstrInfo.witness (Cassgn (Lvar {| v_var := {| vtype := (sword U64) - ; vname := "y.152" |} + ; vname := "y.150" |} ; v_info := dummy_var_info |}) AT_none ((sword U64)) ((Papp1 (Oword_of_int U64) (Pvar {| gv := {| v_var := {| vtype := sint - ; vname := "x.153" |} + ; vname := "x.151" |} ; v_info := dummy_var_info |} ; gs := Slocal |})))) ] ; f_tyout := [(sword U64)] ; f_res := [{| v_var := {| vtype := (sword U64) - ; vname := "y.152" |} + ; vname := "y.150" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* incr *) xO xH, + {| f_info := FunInfo.witness + ; f_tyin := [sint] + ; f_params := + [{| v_var := {| vtype := sint + ; vname := "n.153" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := {| vtype := sint + ; vname := "m.154" |} + ; v_info := dummy_var_info |}) + AT_inline (sint) + ((Papp2 (Oadd Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "n.153" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xH)))))) ] + ; f_tyout := [sint] + ; f_res := + [{| v_var := {| vtype := sint + ; vname := "m.154" |} ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) ] ; p_globs := [] ; p_extra := tt |}. + Defined. +Notation F := ( xH ). +Notation INCR := ( xO xH ). \ No newline at end of file diff --git a/theories/Jasmin/examples/int_reg.v b/theories/Jasmin/examples/int_reg.v index 97698bf1..39e43755 100644 --- a/theories/Jasmin/examples/int_reg.v +++ b/theories/Jasmin/examples/int_reg.v @@ -22,32 +22,34 @@ Definition ssprove_jasmin_prog : uprog. Proof. refine {| p_funcs := [ ( (* foo *) xH, - {| f_info := xO xH + {| f_info := FunInfo.witness ; f_tyin := [sint] ; f_params := [{| v_var := {| vtype := sint - ; vname := "k.141" |} + ; vname := "k.139" |} ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness (Cassgn (Lvar {| v_var := {| vtype := sint - ; vname := "x.142" |} + ; vname := "x.140" |} ; v_info := dummy_var_info |}) AT_none (sint) ((Pvar {| gv := {| v_var := {| vtype := sint - ; vname := "k.141" |} + ; vname := "k.139" |} ; v_info := dummy_var_info |} ; gs := Slocal |}))) ] ; f_tyout := [sint] ; f_res := [{| v_var := {| vtype := sint - ; vname := "x.142" |} + ; vname := "x.140" |} ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) ] ; p_globs := [] ; p_extra := tt |}. + Defined. +Notation FOO := ( xH ). \ No newline at end of file diff --git a/theories/Jasmin/examples/int_shift.v b/theories/Jasmin/examples/int_shift.v index d1090bbe..9da2625d 100644 --- a/theories/Jasmin/examples/int_shift.v +++ b/theories/Jasmin/examples/int_shift.v @@ -21,37 +21,8 @@ Local Open Scope string. Definition ssprove_jasmin_prog : uprog. Proof. refine {| p_funcs := - [ ( (* incr *) xI xH, - {| f_info := xO (xO xH) - ; f_tyin := [sint] - ; f_params := - [{| v_var := {| vtype := sint - ; vname := "n.152" |} - ; v_info := dummy_var_info |}] - ; f_body := - [ MkI InstrInfo.witness - (Cassgn - (Lvar - {| v_var := {| vtype := sint - ; vname := "m.153" |} - ; v_info := dummy_var_info |}) - AT_inline (sint) - ((Papp2 (Olsl Op_int) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "n.152" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pconst (Zpos (xI (xO (xO (xO (xO (xO xH))))))))))) ] - ; f_tyout := [sint] - ; f_res := - [{| v_var := {| vtype := sint - ; vname := "m.153" |} - ; v_info := dummy_var_info |}] - ; f_extra := tt - ; |} ) - ; ( (* f *) xH, - {| f_info := xO xH + [ ( (* f *) xH, + {| f_info := FunInfo.witness ; f_tyin := [] ; f_params := [] ; f_body := @@ -59,29 +30,61 @@ Proof. (Ccall InlineFun [Lvar {| v_var := {| vtype := sint - ; vname := "x.151" |} + ; vname := "x.149" |} ; v_info := dummy_var_info |}] - (xI xH) [(Pconst (Z0))]); + (xO xH) [(Pconst (Z0))]); MkI InstrInfo.witness (Cassgn (Lvar {| v_var := {| vtype := (sword U64) - ; vname := "y.150" |} + ; vname := "y.148" |} ; v_info := dummy_var_info |}) AT_none ((sword U64)) ((Papp1 (Oword_of_int U64) (Pvar {| gv := {| v_var := {| vtype := sint - ; vname := "x.151" |} + ; vname := "x.149" |} ; v_info := dummy_var_info |} ; gs := Slocal |})))) ] ; f_tyout := [(sword U64)] ; f_res := [{| v_var := {| vtype := (sword U64) - ; vname := "y.150" |} + ; vname := "y.148" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* incr *) xO xH, + {| f_info := FunInfo.witness + ; f_tyin := [sint] + ; f_params := + [{| v_var := {| vtype := sint + ; vname := "n.150" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := {| vtype := sint + ; vname := "m.151" |} + ; v_info := dummy_var_info |}) + AT_inline (sint) + ((Papp2 (Olsl Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "n.150" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xI (xO (xO (xO (xO (xO xH))))))))))) ] + ; f_tyout := [sint] + ; f_res := + [{| v_var := {| vtype := sint + ; vname := "m.151" |} ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) ] ; p_globs := [] ; p_extra := tt |}. + Defined. +Notation F := ( xH ). +Notation INCR := ( xO xH ). \ No newline at end of file diff --git a/theories/Jasmin/examples/liveness_bork.v b/theories/Jasmin/examples/liveness_bork.v index 554bab55..6be4f6f2 100644 --- a/theories/Jasmin/examples/liveness_bork.v +++ b/theories/Jasmin/examples/liveness_bork.v @@ -22,47 +22,49 @@ Definition ssprove_jasmin_prog : uprog. Proof. refine {| p_funcs := [ ( (* double *) xH, - {| f_info := xO xH + {| f_info := FunInfo.witness ; f_tyin := [(sword U64)] ; f_params := [{| v_var := {| vtype := (sword U64) - ; vname := "n.141" |} + ; vname := "n.139" |} ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness (Cfor ({| v_var := {| vtype := sint - ; vname := "i.142" |} + ; vname := "i.140" |} ; v_info := dummy_var_info |}) ((UpTo, (Pconst (Z0))), (Papp1 (Oint_of_word U64) (Pvar {| gv := {| v_var := {| vtype := (sword U64) - ; vname := "n.141" |} + ; vname := "n.139" |} ; v_info := dummy_var_info |} ; gs := Slocal |}))) [MkI InstrInfo.witness (Cassgn (Lvar {| v_var := {| vtype := (sword U64) - ; vname := "n.141" |} + ; vname := "n.139" |} ; v_info := dummy_var_info |}) AT_none ((sword U64)) ((Papp2 (Oadd (Op_w U64)) (Pvar {| gv := {| v_var := {| vtype := (sword U64) - ; vname := "n.141" |} + ; vname := "n.139" |} ; v_info := dummy_var_info |} ; gs := Slocal |}) (Papp1 (Oword_of_int U64) (Pconst (Zpos (xH)))))))]) ] ; f_tyout := [(sword U64)] ; f_res := [{| v_var := {| vtype := (sword U64) - ; vname := "n.141" |} + ; vname := "n.139" |} ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) ] ; p_globs := [] ; p_extra := tt |}. + Defined. +Notation DOUBLE := ( xH ). \ No newline at end of file diff --git a/theories/Jasmin/examples/matrix_product.v b/theories/Jasmin/examples/matrix_product.v index a3bd6f8c..e8fab0bc 100644 --- a/theories/Jasmin/examples/matrix_product.v +++ b/theories/Jasmin/examples/matrix_product.v @@ -21,344 +21,251 @@ Local Open Scope string. Definition ssprove_jasmin_prog : uprog. Proof. refine {| p_funcs := - [ ( (* dot_product *) xI (xO (xO xH)), - {| f_info := xO (xI (xO xH)) - ; f_tyin := - [(sarr (xO (xO (xO (xO (xI (xO xH))))))); - (sarr (xO (xO (xO (xO (xI (xO xH)))))))] + [ ( (* productMM *) xH, + {| f_info := FunInfo.witness + ; f_tyin := [(sword U64); (sword U64); (sword U64)] ; f_params := - [{| v_var := - {| vtype := (sarr (xO (xO (xO (xO (xI (xO xH))))))) - ; vname := "v1.243" |} + [{| v_var := {| vtype := (sword U64) + ; vname := "x.216" |} ; v_info := dummy_var_info |}; - {| v_var := - {| vtype := (sarr (xO (xO (xO (xO (xI (xO xH))))))) - ; vname := "v2.244" |} + {| v_var := {| vtype := (sword U64) + ; vname := "y.217" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U64) + ; vname := "z.218" |} ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness - (Cassgn - (Lvar - {| v_var := - {| vtype := (sword U64) - ; vname := "res.245" |} - ; v_info := dummy_var_info |}) - AT_none ((sword U64)) - ((Papp1 (Oword_of_int U64) (Pconst (Z0))))); - MkI InstrInfo.witness (Cfor ({| v_var := {| vtype := sint - ; vname := "i.246" |} + ; vname := "i.219" |} ; v_info := dummy_var_info |}) - ((UpTo, (Pconst (Z0))), (Pconst (Zpos (xO (xI (xO xH)))))) + ((UpTo, (Pconst (Z0))), + (Papp2 (Omul Op_int) (Pconst (Zpos (xO (xI (xO xH))))) + (Pconst (Zpos (xO (xI (xO xH))))))) [MkI InstrInfo.witness (Cassgn (Lvar {| v_var := {| vtype := (sword U64) - ; vname := "tmp.247" |} + ; vname := "tmp.220" |} ; v_info := dummy_var_info |}) AT_none ((sword U64)) - ((Pget AAscale U64 - {| gv := {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xI (xO xH))))))) - ; vname := "v1.243" |} - ; v_info := dummy_var_info |} ; gs := Slocal |} + ((Pload U64 + {| v_var := + {| vtype := (sword U64) + ; vname := "x.216" |} + ; v_info := dummy_var_info |} + (Papp1 (Oword_of_int U64) + (Papp2 (Omul Op_int) + (Pconst (Zpos (xO (xO (xO xH))))) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.219" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))))); + MkI InstrInfo.witness + (Cassgn + (Laset AAscale U64 + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "mx.221" |} + ; v_info := dummy_var_info |} (Pvar {| gv := {| v_var := {| vtype := sint - ; vname := "i.246" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})))); + ; vname := "i.219" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "tmp.220" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); MkI InstrInfo.witness (Cassgn (Lvar {| v_var := {| vtype := (sword U64) - ; vname := "tmp.247" |} + ; vname := "tmp.220" |} ; v_info := dummy_var_info |}) AT_none ((sword U64)) - ((Papp2 (Omul (Op_w U64)) - (Pvar - {| gv := {| v_var := - {| vtype := (sword U64) - ; vname := "tmp.247" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pget AAscale U64 - {| gv := {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xI (xO xH))))))) - ; vname := "v2.244" |} - ; v_info := dummy_var_info |} ; gs := Slocal |} - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "i.246" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}))))); + ((Pload U64 + {| v_var := + {| vtype := (sword U64) + ; vname := "y.217" |} + ; v_info := dummy_var_info |} + (Papp1 (Oword_of_int U64) + (Papp2 (Omul Op_int) + (Pconst (Zpos (xO (xO (xO xH))))) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.219" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))))); MkI InstrInfo.witness (Cassgn - (Lvar + (Laset AAscale U64 {| v_var := - {| vtype := (sword U64) - ; vname := "res.245" |} - ; v_info := dummy_var_info |}) + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "my.222" |} + ; v_info := dummy_var_info |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.219" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})) AT_none ((sword U64)) - ((Papp2 (Oadd (Op_w U64)) - (Pvar - {| gv := {| v_var := - {| vtype := (sword U64) - ; vname := "res.245" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pvar - {| gv := {| v_var := - {| vtype := (sword U64) - ; vname := "tmp.247" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}))))]) ] - ; f_tyout := [(sword U64)] - ; f_res := - [{| v_var := {| vtype := (sword U64) - ; vname := "res.245" |} - ; v_info := dummy_var_info |}] - ; f_extra := tt - ; |} ) - ; ( (* product_matrix_vector *) xO (xI xH), - {| f_info := xO (xO (xO xH)) - ; f_tyin := - [(sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))); - (sarr (xO (xO (xO (xO (xI (xO xH))))))); - (sarr (xO (xO (xO (xO (xI (xO xH)))))))] - ; f_params := - [{| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) - ; vname := "m.238" |} - ; v_info := dummy_var_info |}; - {| v_var := - {| vtype := (sarr (xO (xO (xO (xO (xI (xO xH))))))) - ; vname := "v.239" |} - ; v_info := dummy_var_info |}; - {| v_var := - {| vtype := (sarr (xO (xO (xO (xO (xI (xO xH))))))) - ; vname := "res.240" |} - ; v_info := dummy_var_info |}] - ; f_body := - [ MkI InstrInfo.witness + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "tmp.220" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))]); + MkI InstrInfo.witness + (Ccall DoNotInline + [Lvar + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "mz.223" |} + ; v_info := dummy_var_info |}] + (xO xH) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "mx.221" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "my.222" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "mz.223" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness (Cfor ({| v_var := {| vtype := sint - ; vname := "i.241" |} + ; vname := "i.219" |} ; v_info := dummy_var_info |}) - ((UpTo, (Pconst (Z0))), (Pconst (Zpos (xO (xI (xO xH)))))) + ((UpTo, (Pconst (Z0))), + (Papp2 (Omul Op_int) (Pconst (Zpos (xO (xI (xO xH))))) + (Pconst (Zpos (xO (xI (xO xH))))))) [MkI InstrInfo.witness - (Ccall DoNotInline - [Lvar + (Cassgn + (Lvar {| v_var := {| vtype := (sword U64) - ; vname := "tmp.242" |} - ; v_info := dummy_var_info |}] - (xI (xO (xO xH))) - [(Psub AAscale U64 (xO (xI (xO xH))) + ; vname := "tmp.220" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 {| gv := {| v_var := {| vtype := (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) - ; vname := "m.238" |} + ; vname := "mz.223" |} ; v_info := dummy_var_info |} ; gs := Slocal |} - (Papp2 (Omul Op_int) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "i.241" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pconst (Zpos (xO (xI (xO xH))))))); - (Pvar - {| gv := {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xI (xO xH))))))) - ; vname := "v.239" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})]); + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.219" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); MkI InstrInfo.witness (Cassgn - (Laset AAscale U64 + (Lmem U64 {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xI (xO xH))))))) - ; vname := "res.240" |} + {| vtype := (sword U64) + ; vname := "z.218" |} ; v_info := dummy_var_info |} - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "i.241" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})) + (Papp1 (Oword_of_int U64) + (Papp2 (Omul Op_int) + (Pconst (Zpos (xO (xO (xO xH))))) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.219" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))) AT_none ((sword U64)) ((Pvar {| gv := {| v_var := {| vtype := (sword U64) - ; vname := "tmp.242" |} + ; vname := "tmp.220" |} ; v_info := dummy_var_info |} ; gs := Slocal |})))]) ] - ; f_tyout := [(sarr (xO (xO (xO (xO (xI (xO xH)))))))] - ; f_res := - [{| v_var := - {| vtype := (sarr (xO (xO (xO (xO (xI (xO xH))))))) - ; vname := "res.240" |} - ; v_info := dummy_var_info |}] + ; f_tyout := [] + ; f_res := [] ; f_extra := tt ; |} ) - ; ( (* transpose *) xI (xO xH), - {| f_info := xI (xI xH) + ; ( (* product_matrix_matrix *) xO xH, + {| f_info := FunInfo.witness ; f_tyin := [(sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))); + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))); (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH))))))))))] ; f_params := [{| v_var := {| vtype := (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) - ; vname := "m.233" |} + ; vname := "m1.224" |} ; v_info := dummy_var_info |}; {| v_var := {| vtype := (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) - ; vname := "res.234" |} + ; vname := "m2.225" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "res.226" |} ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "pres.227" |} + ; v_info := dummy_var_info |}) + AT_none + ((sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH))))))))))) + ((Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "res.226" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))); + MkI InstrInfo.witness + (Ccall DoNotInline + [Lvar + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "m2t.228" |} + ; v_info := dummy_var_info |}] + (xI xH) + [(Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "m2.225" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}); + (Pvar + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "m2t.228" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); + MkI InstrInfo.witness (Cfor ({| v_var := {| vtype := sint - ; vname := "i.235" |} - ; v_info := dummy_var_info |}) - ((UpTo, (Pconst (Z0))), (Pconst (Zpos (xO (xI (xO xH)))))) - [MkI InstrInfo.witness - (Cfor - ({| v_var := {| vtype := sint - ; vname := "j.236" |} - ; v_info := dummy_var_info |}) - ((UpTo, (Pconst (Z0))), - (Pconst (Zpos (xO (xI (xO xH)))))) - [MkI InstrInfo.witness - (Cassgn - (Lvar - {| v_var := - {| vtype := (sword U64) - ; vname := "tmp.237" |} - ; v_info := dummy_var_info |}) - AT_none ((sword U64)) - ((Pget AAscale U64 - {| gv := {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) - ; vname := "m.233" |} - ; v_info := dummy_var_info |} ; gs := Slocal |} - (Papp2 (Oadd Op_int) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "j.236" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Papp2 (Omul Op_int) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "i.235" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pconst (Zpos (xO (xI (xO xH)))))))))); - MkI InstrInfo.witness - (Cassgn - (Laset AAscale U64 - {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) - ; vname := "res.234" |} - ; v_info := dummy_var_info |} - (Papp2 (Oadd Op_int) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "i.235" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Papp2 (Omul Op_int) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "j.236" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pconst (Zpos (xO (xI (xO xH)))))))) - AT_none ((sword U64)) - ((Pvar - {| gv := {| v_var := - {| vtype := (sword U64) - ; vname := "tmp.237" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})))])]) ] - ; f_tyout := [(sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH))))))))))] - ; f_res := - [{| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) - ; vname := "res.234" |} - ; v_info := dummy_var_info |}] - ; f_extra := tt - ; |} ) - ; ( (* product_matrix_matrix *) xI xH, - {| f_info := xO (xO xH) - ; f_tyin := - [(sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))); - (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))); - (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH))))))))))] - ; f_params := - [{| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) - ; vname := "m1.226" |} - ; v_info := dummy_var_info |}; - {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) - ; vname := "m2.227" |} - ; v_info := dummy_var_info |}; - {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) - ; vname := "res.228" |} - ; v_info := dummy_var_info |}] - ; f_body := - [ MkI InstrInfo.witness - (Cassgn - (Lvar - {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) - ; vname := "pres.229" |} - ; v_info := dummy_var_info |}) - AT_none - ((sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH))))))))))) - ((Pvar - {| gv := {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) - ; vname := "res.228" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}))); - MkI InstrInfo.witness - (Ccall DoNotInline - [Lvar - {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) - ; vname := "m2t.230" |} - ; v_info := dummy_var_info |}] - (xI (xO xH)) - [(Pvar - {| gv := {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) - ; vname := "m2.227" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Pvar - {| gv := {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) - ; vname := "m2t.230" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})]); - MkI InstrInfo.witness - (Cfor - ({| v_var := {| vtype := sint - ; vname := "i.231" |} + ; vname := "i.229" |} ; v_info := dummy_var_info |}) ((UpTo, (Pconst (Z0))), (Pconst (Zpos (xO (xI (xO xH)))))) [MkI InstrInfo.witness @@ -367,46 +274,46 @@ Proof. {| v_var := {| vtype := (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) - ; vname := "rest.232" |} + ; vname := "rest.230" |} ; v_info := dummy_var_info |} (Papp2 (Omul Op_int) (Pvar {| gv := {| v_var := {| vtype := sint - ; vname := "i.231" |} + ; vname := "i.229" |} ; v_info := dummy_var_info |} ; gs := Slocal |}) (Pconst (Zpos (xO (xI (xO xH))))))] - (xO (xI xH)) + (xO (xO xH)) [(Pvar {| gv := {| v_var := {| vtype := (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) - ; vname := "m1.226" |} + ; vname := "m1.224" |} ; v_info := dummy_var_info |} ; gs := Slocal |}); (Psub AAscale U64 (xO (xI (xO xH))) {| gv := {| v_var := {| vtype := (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) - ; vname := "m2t.230" |} + ; vname := "m2t.228" |} ; v_info := dummy_var_info |} ; gs := Slocal |} (Papp2 (Omul Op_int) (Pvar {| gv := {| v_var := {| vtype := sint - ; vname := "i.231" |} + ; vname := "i.229" |} ; v_info := dummy_var_info |} ; gs := Slocal |}) (Pconst (Zpos (xO (xI (xO xH))))))); (Psub AAscale U64 (xO (xI (xO xH))) {| gv := {| v_var := {| vtype := (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) - ; vname := "rest.232" |} + ; vname := "rest.230" |} ; v_info := dummy_var_info |} ; gs := Slocal |} (Papp2 (Omul Op_int) (Pvar {| gv := {| v_var := {| vtype := sint - ; vname := "i.231" |} + ; vname := "i.229" |} ; v_info := dummy_var_info |} ; gs := Slocal |}) (Pconst (Zpos (xO (xI (xO xH)))))))])]); MkI InstrInfo.witness @@ -415,7 +322,7 @@ Proof. {| v_var := {| vtype := (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) - ; vname := "res.228" |} + ; vname := "res.226" |} ; v_info := dummy_var_info |}) AT_none ((sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH))))))))))) @@ -423,7 +330,7 @@ Proof. {| gv := {| v_var := {| vtype := (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) - ; vname := "pres.229" |} + ; vname := "pres.227" |} ; v_info := dummy_var_info |} ; gs := Slocal |}))); MkI InstrInfo.witness (Ccall DoNotInline @@ -431,211 +338,310 @@ Proof. {| v_var := {| vtype := (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) - ; vname := "res.228" |} + ; vname := "res.226" |} ; v_info := dummy_var_info |}] - (xI (xO xH)) + (xI xH) [(Pvar {| gv := {| v_var := {| vtype := (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) - ; vname := "rest.232" |} + ; vname := "rest.230" |} ; v_info := dummy_var_info |} ; gs := Slocal |}); (Pvar {| gv := {| v_var := {| vtype := (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) - ; vname := "res.228" |} + ; vname := "res.226" |} ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] ; f_tyout := [(sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH))))))))))] ; f_res := [{| v_var := {| vtype := (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) - ; vname := "res.228" |} + ; vname := "res.226" |} ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) - ; ( (* productMM *) xH, - {| f_info := xO xH - ; f_tyin := [(sword U64); (sword U64); (sword U64)] + ; ( (* transpose *) xI xH, + {| f_info := FunInfo.witness + ; f_tyin := + [(sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))); + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH))))))))))] ; f_params := - [{| v_var := {| vtype := (sword U64) - ; vname := "x.218" |} + [{| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "m.231" |} ; v_info := dummy_var_info |}; - {| v_var := {| vtype := (sword U64) - ; vname := "y.219" |} + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "res.232" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "i.233" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Z0))), (Pconst (Zpos (xO (xI (xO xH)))))) + [MkI InstrInfo.witness + (Cfor + ({| v_var := {| vtype := sint + ; vname := "j.234" |} + ; v_info := dummy_var_info |}) + ((UpTo, (Pconst (Z0))), + (Pconst (Zpos (xO (xI (xO xH)))))) + [MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "tmp.235" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "m.231" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Papp2 (Oadd Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "j.234" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Papp2 (Omul Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.233" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO (xI (xO xH)))))))))); + MkI InstrInfo.witness + (Cassgn + (Laset AAscale U64 + {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "res.232" |} + ; v_info := dummy_var_info |} + (Papp2 (Oadd Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.233" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Papp2 (Omul Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "j.234" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO (xI (xO xH)))))))) + AT_none ((sword U64)) + ((Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "tmp.235" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))])]) ] + ; f_tyout := [(sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH))))))))))] + ; f_res := + [{| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "res.232" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* product_matrix_vector *) xO (xO xH), + {| f_info := FunInfo.witness + ; f_tyin := + [(sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))); + (sarr (xO (xO (xO (xO (xI (xO xH))))))); + (sarr (xO (xO (xO (xO (xI (xO xH)))))))] + ; f_params := + [{| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "m.236" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xO xH))))))) + ; vname := "v.237" |} ; v_info := dummy_var_info |}; - {| v_var := {| vtype := (sword U64) - ; vname := "z.220" |} + {| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xO xH))))))) + ; vname := "res.238" |} ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness (Cfor ({| v_var := {| vtype := sint - ; vname := "i.221" |} + ; vname := "i.239" |} ; v_info := dummy_var_info |}) - ((UpTo, (Pconst (Z0))), - (Papp2 (Omul Op_int) (Pconst (Zpos (xO (xI (xO xH))))) - (Pconst (Zpos (xO (xI (xO xH))))))) + ((UpTo, (Pconst (Z0))), (Pconst (Zpos (xO (xI (xO xH)))))) [MkI InstrInfo.witness - (Cassgn - (Lvar + (Ccall DoNotInline + [Lvar {| v_var := {| vtype := (sword U64) - ; vname := "tmp.222" |} - ; v_info := dummy_var_info |}) - AT_none ((sword U64)) - ((Pload U64 - {| v_var := - {| vtype := (sword U64) - ; vname := "x.218" |} - ; v_info := dummy_var_info |} - (Papp1 (Oword_of_int U64) - (Papp2 (Omul Op_int) - (Pconst (Zpos (xO (xO (xO xH))))) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "i.221" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})))))); - MkI InstrInfo.witness - (Cassgn - (Laset AAscale U64 - {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) - ; vname := "mx.223" |} - ; v_info := dummy_var_info |} - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "i.221" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})) - AT_none ((sword U64)) - ((Pvar + ; vname := "tmp.240" |} + ; v_info := dummy_var_info |}] + (xI (xO xH)) + [(Psub AAscale U64 (xO (xI (xO xH))) + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) + ; vname := "m.236" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Papp2 (Omul Op_int) + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.239" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pconst (Zpos (xO (xI (xO xH))))))); + (Pvar {| gv := {| v_var := - {| vtype := (sword U64) - ; vname := "tmp.222" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}))); - MkI InstrInfo.witness - (Cassgn - (Lvar - {| v_var := - {| vtype := (sword U64) - ; vname := "tmp.222" |} - ; v_info := dummy_var_info |}) - AT_none ((sword U64)) - ((Pload U64 - {| v_var := - {| vtype := (sword U64) - ; vname := "y.219" |} - ; v_info := dummy_var_info |} - (Papp1 (Oword_of_int U64) - (Papp2 (Omul Op_int) - (Pconst (Zpos (xO (xO (xO xH))))) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "i.221" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})))))); + {| vtype := + (sarr (xO (xO (xO (xO (xI (xO xH))))))) + ; vname := "v.237" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]); MkI InstrInfo.witness (Cassgn (Laset AAscale U64 {| v_var := {| vtype := - (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) - ; vname := "my.224" |} + (sarr (xO (xO (xO (xO (xI (xO xH))))))) + ; vname := "res.238" |} ; v_info := dummy_var_info |} (Pvar {| gv := {| v_var := {| vtype := sint - ; vname := "i.221" |} + ; vname := "i.239" |} ; v_info := dummy_var_info |} ; gs := Slocal |})) AT_none ((sword U64)) ((Pvar {| gv := {| v_var := {| vtype := (sword U64) - ; vname := "tmp.222" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})))]); - MkI InstrInfo.witness - (Ccall DoNotInline - [Lvar + ; vname := "tmp.240" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))]) ] + ; f_tyout := [(sarr (xO (xO (xO (xO (xI (xO xH)))))))] + ; f_res := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xO xH))))))) + ; vname := "res.238" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* dot_product *) xI (xO xH), + {| f_info := FunInfo.witness + ; f_tyin := + [(sarr (xO (xO (xO (xO (xI (xO xH))))))); + (sarr (xO (xO (xO (xO (xI (xO xH)))))))] + ; f_params := + [{| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xO xH))))))) + ; vname := "v1.241" |} + ; v_info := dummy_var_info |}; + {| v_var := + {| vtype := (sarr (xO (xO (xO (xO (xI (xO xH))))))) + ; vname := "v2.242" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) - ; vname := "mz.225" |} - ; v_info := dummy_var_info |}] - (xI xH) - [(Pvar - {| gv := {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) - ; vname := "mx.223" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Pvar - {| gv := {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) - ; vname := "my.224" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}); - (Pvar - {| gv := {| v_var := - {| vtype := - (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) - ; vname := "mz.225" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})]); + {| vtype := (sword U64) + ; vname := "res.243" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp1 (Oword_of_int U64) (Pconst (Z0))))); MkI InstrInfo.witness (Cfor ({| v_var := {| vtype := sint - ; vname := "i.221" |} + ; vname := "i.244" |} ; v_info := dummy_var_info |}) - ((UpTo, (Pconst (Z0))), - (Papp2 (Omul Op_int) (Pconst (Zpos (xO (xI (xO xH))))) - (Pconst (Zpos (xO (xI (xO xH))))))) + ((UpTo, (Pconst (Z0))), (Pconst (Zpos (xO (xI (xO xH)))))) [MkI InstrInfo.witness (Cassgn (Lvar {| v_var := {| vtype := (sword U64) - ; vname := "tmp.222" |} + ; vname := "tmp.245" |} ; v_info := dummy_var_info |}) AT_none ((sword U64)) ((Pget AAscale U64 {| gv := {| v_var := {| vtype := - (sarr (xO (xO (xO (xO (xO (xI (xO (xO (xI xH)))))))))) - ; vname := "mz.225" |} + (sarr (xO (xO (xO (xO (xI (xO xH))))))) + ; vname := "v1.241" |} ; v_info := dummy_var_info |} ; gs := Slocal |} (Pvar {| gv := {| v_var := {| vtype := sint - ; vname := "i.221" |} + ; vname := "i.244" |} ; v_info := dummy_var_info |} ; gs := Slocal |})))); MkI InstrInfo.witness (Cassgn - (Lmem U64 + (Lvar {| v_var := {| vtype := (sword U64) - ; vname := "z.220" |} - ; v_info := dummy_var_info |} - (Papp1 (Oword_of_int U64) - (Papp2 (Omul Op_int) - (Pconst (Zpos (xO (xO (xO xH))))) - (Pvar - {| gv := {| v_var := - {| vtype := sint - ; vname := "i.221" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})))) + ; vname := "tmp.245" |} + ; v_info := dummy_var_info |}) AT_none ((sword U64)) - ((Pvar - {| gv := {| v_var := - {| vtype := (sword U64) - ; vname := "tmp.222" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})))]) ] - ; f_tyout := [] - ; f_res := [] + ((Papp2 (Omul (Op_w U64)) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "tmp.245" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pget AAscale U64 + {| gv := {| v_var := + {| vtype := + (sarr (xO (xO (xO (xO (xI (xO xH))))))) + ; vname := "v2.242" |} + ; v_info := dummy_var_info |} ; gs := Slocal |} + (Pvar + {| gv := {| v_var := + {| vtype := sint + ; vname := "i.244" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "res.243" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp2 (Oadd (Op_w U64)) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "res.243" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "tmp.245" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))))]) ] + ; f_tyout := [(sword U64)] + ; f_res := + [{| v_var := {| vtype := (sword U64) + ; vname := "res.243" |} + ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) ] ; p_globs := [] ; p_extra := tt |}. + Defined. +Notation PRODUCTMM := ( xH ). +Notation PRODUCT_MATRIX_MATRIX := ( xO xH ). +Notation TRANSPOSE := ( xI xH ). +Notation PRODUCT_MATRIX_VECTOR := ( xO (xO xH) ). +Notation DOT_PRODUCT := ( xI (xO xH) ). \ No newline at end of file diff --git a/theories/Jasmin/examples/retz.v b/theories/Jasmin/examples/retz.v index d03ffe97..e422bef2 100644 --- a/theories/Jasmin/examples/retz.v +++ b/theories/Jasmin/examples/retz.v @@ -22,7 +22,7 @@ Definition ssprove_jasmin_prog : uprog. Proof. refine {| p_funcs := [ ( (* zero *) xH, - {| f_info := xO xH + {| f_info := FunInfo.witness ; f_tyin := [] ; f_params := [] ; f_body := @@ -30,17 +30,19 @@ Proof. (Cassgn (Lvar {| v_var := {| vtype := (sword U64) - ; vname := "z.139" |} + ; vname := "z.137" |} ; v_info := dummy_var_info |}) AT_none ((sword U64)) ((Papp1 (Oword_of_int U64) (Pconst (Z0))))) ] ; f_tyout := [(sword U64)] ; f_res := [{| v_var := {| vtype := (sword U64) - ; vname := "z.139" |} + ; vname := "z.137" |} ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) ] ; p_globs := [] ; p_extra := tt |}. + Defined. +Notation ZERO := ( xH ). \ No newline at end of file diff --git a/theories/Jasmin/examples/test_for.v b/theories/Jasmin/examples/test_for.v index 336e7761..aac4b5ae 100644 --- a/theories/Jasmin/examples/test_for.v +++ b/theories/Jasmin/examples/test_for.v @@ -22,7 +22,7 @@ Definition ssprove_jasmin_prog : uprog. Proof. refine {| p_funcs := [ ( (* f *) xH, - {| f_info := xO xH + {| f_info := FunInfo.witness ; f_tyin := [] ; f_params := [] ; f_body := @@ -30,14 +30,14 @@ Proof. (Cassgn (Lvar {| v_var := {| vtype := (sword U64) - ; vname := "r.141" |} + ; vname := "r.139" |} ; v_info := dummy_var_info |}) AT_none ((sword U64)) ((Papp1 (Oword_of_int U64) (Pconst (Z0))))); MkI InstrInfo.witness (Cfor ({| v_var := {| vtype := sint - ; vname := "i.142" |} + ; vname := "i.140" |} ; v_info := dummy_var_info |}) ((DownTo, (Pconst (Z0))), (Pconst (Zpos (xI xH)))) [MkI InstrInfo.witness @@ -45,23 +45,25 @@ Proof. (Lvar {| v_var := {| vtype := (sword U64) - ; vname := "r.141" |} + ; vname := "r.139" |} ; v_info := dummy_var_info |}) AT_none ((sword U64)) ((Papp2 (Oadd (Op_w U64)) (Pvar {| gv := {| v_var := {| vtype := (sword U64) - ; vname := "r.141" |} + ; vname := "r.139" |} ; v_info := dummy_var_info |} ; gs := Slocal |}) (Papp1 (Oword_of_int U64) (Pconst (Zpos (xH)))))))]) ] ; f_tyout := [(sword U64)] ; f_res := [{| v_var := {| vtype := (sword U64) - ; vname := "r.141" |} + ; vname := "r.139" |} ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) ] ; p_globs := [] ; p_extra := tt |}. + Defined. +Notation F := ( xH ). \ No newline at end of file diff --git a/theories/Jasmin/examples/test_inline_var.v b/theories/Jasmin/examples/test_inline_var.v index dc8adc47..aae81844 100644 --- a/theories/Jasmin/examples/test_inline_var.v +++ b/theories/Jasmin/examples/test_inline_var.v @@ -21,132 +21,135 @@ Local Open Scope string. Definition ssprove_jasmin_prog : uprog. Proof. refine {| p_funcs := - [ ( (* addn *) xI xH, - {| f_info := xO (xO xH) - ; f_tyin := [(sword U64); (sword U64)] - ; f_params := - [{| v_var := {| vtype := (sword U64) - ; vname := "r.152" |} - ; v_info := dummy_var_info |}; - {| v_var := {| vtype := (sword U64) - ; vname := "n.153" |} - ; v_info := dummy_var_info |}] - ; f_body := - [ MkI InstrInfo.witness - (Cassgn - (Lvar - {| v_var := {| vtype := (sword U64) - ; vname := "r.152" |} - ; v_info := dummy_var_info |}) - AT_none ((sword U64)) - ((Papp2 (Oadd (Op_w U64)) - (Pvar - {| gv := {| v_var := - {| vtype := (sword U64) - ; vname := "r.152" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pvar - {| gv := {| v_var := - {| vtype := (sword U64) - ; vname := "n.153" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})))); - MkI InstrInfo.witness - (Cassgn - (Lvar - {| v_var := {| vtype := (sword U64) - ; vname := "r.152" |} - ; v_info := dummy_var_info |}) - AT_none ((sword U64)) - ((Papp2 (Oadd (Op_w U64)) - (Pvar - {| gv := {| v_var := - {| vtype := (sword U64) - ; vname := "r.152" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Papp2 (Oadd (Op_w U64)) - (Pvar - {| gv := {| v_var := - {| vtype := (sword U64) - ; vname := "n.153" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pvar - {| gv := {| v_var := - {| vtype := (sword U64) - ; vname := "n.153" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}))))) ] - ; f_tyout := [(sword U64)] - ; f_res := - [{| v_var := {| vtype := (sword U64) - ; vname := "r.152" |} - ; v_info := dummy_var_info |}] - ; f_extra := tt - ; |} ) - ; ( (* f *) xH, - {| f_info := xO xH + [ ( (* f *) xH, + {| f_info := FunInfo.witness ; f_tyin := [(sword U64)] ; f_params := [{| v_var := {| vtype := (sword U64) - ; vname := "r1.150" |} + ; vname := "r1.148" |} ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness (Cassgn (Lvar {| v_var := {| vtype := (sword U64) - ; vname := "r.151" |} + ; vname := "r.149" |} ; v_info := dummy_var_info |}) AT_none ((sword U64)) ((Pvar {| gv := {| v_var := {| vtype := (sword U64) - ; vname := "r1.150" |} + ; vname := "r1.148" |} ; v_info := dummy_var_info |} ; gs := Slocal |}))); MkI InstrInfo.witness (Ccall InlineFun [Lvar {| v_var := {| vtype := (sword U64) - ; vname := "r.151" |} + ; vname := "r.149" |} ; v_info := dummy_var_info |}] - (xI xH) + (xO xH) [(Pvar {| gv := {| v_var := {| vtype := (sword U64) - ; vname := "r.151" |} + ; vname := "r.149" |} ; v_info := dummy_var_info |} ; gs := Slocal |}); (Papp1 (Oword_of_int U64) (Pconst (Zpos (xO (xI xH)))))]); MkI InstrInfo.witness (Ccall InlineFun [Lvar {| v_var := {| vtype := (sword U64) - ; vname := "r.151" |} + ; vname := "r.149" |} ; v_info := dummy_var_info |}] - (xI xH) + (xO xH) [(Pvar {| gv := {| v_var := {| vtype := (sword U64) - ; vname := "r.151" |} + ; vname := "r.149" |} ; v_info := dummy_var_info |} ; gs := Slocal |}); (Papp1 (Oword_of_int U64) (Pconst (Zpos (xI xH))))]); MkI InstrInfo.witness (Ccall InlineFun [Lvar {| v_var := {| vtype := (sword U64) - ; vname := "r.151" |} + ; vname := "r.149" |} ; v_info := dummy_var_info |}] - (xI xH) + (xO xH) [(Pvar {| gv := {| v_var := {| vtype := (sword U64) - ; vname := "r.151" |} + ; vname := "r.149" |} ; v_info := dummy_var_info |} ; gs := Slocal |}); (Papp1 (Oword_of_int U64) (Pconst (Zpos (xI (xO xH)))))]) ] ; f_tyout := [(sword U64)] ; f_res := [{| v_var := {| vtype := (sword U64) - ; vname := "r.151" |} + ; vname := "r.149" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* addn *) xO xH, + {| f_info := FunInfo.witness + ; f_tyin := [(sword U64); (sword U64)] + ; f_params := + [{| v_var := {| vtype := (sword U64) + ; vname := "r.150" |} + ; v_info := dummy_var_info |}; + {| v_var := {| vtype := (sword U64) + ; vname := "n.151" |} + ; v_info := dummy_var_info |}] + ; f_body := + [ MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := {| vtype := (sword U64) + ; vname := "r.150" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp2 (Oadd (Op_w U64)) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "r.150" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "n.151" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})))); + MkI InstrInfo.witness + (Cassgn + (Lvar + {| v_var := {| vtype := (sword U64) + ; vname := "r.150" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp2 (Oadd (Op_w U64)) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "r.150" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Papp2 (Oadd (Op_w U64)) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "n.151" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "n.151" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}))))) ] + ; f_tyout := [(sword U64)] + ; f_res := + [{| v_var := {| vtype := (sword U64) + ; vname := "r.150" |} ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) ] ; p_globs := [] ; p_extra := tt |}. + Defined. +Notation F := ( xH ). +Notation ADDN := ( xO xH ). \ No newline at end of file diff --git a/theories/Jasmin/examples/test_shift.v b/theories/Jasmin/examples/test_shift.v index 6fe6f119..37274da0 100644 --- a/theories/Jasmin/examples/test_shift.v +++ b/theories/Jasmin/examples/test_shift.v @@ -22,18 +22,18 @@ Definition ssprove_jasmin_prog : uprog. Proof. refine {| p_funcs := [ ( (* reduce *) xH, - {| f_info := xO xH + {| f_info := FunInfo.witness ; f_tyin := [(sword U64)] ; f_params := [{| v_var := {| vtype := (sword U64) - ; vname := "a.142" |} + ; vname := "a.140" |} ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness (Cassgn (Lvar {| v_var := {| vtype := (sword U64) - ; vname := "u.143" |} + ; vname := "u.141" |} ; v_info := dummy_var_info |}) AT_none ((sword U64)) ((Papp1 (Oword_of_int U64) @@ -44,10 +44,12 @@ Proof. ; f_tyout := [(sword U64)] ; f_res := [{| v_var := {| vtype := (sword U64) - ; vname := "u.143" |} + ; vname := "u.141" |} ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) ] ; p_globs := [] ; p_extra := tt |}. + Defined. +Notation REDUCE := ( xH ). \ No newline at end of file diff --git a/theories/Jasmin/examples/three_functions.v b/theories/Jasmin/examples/three_functions.v index 904b4a3e..9f665d5f 100644 --- a/theories/Jasmin/examples/three_functions.v +++ b/theories/Jasmin/examples/three_functions.v @@ -21,42 +21,55 @@ Local Open Scope string. Definition ssprove_jasmin_prog : uprog. Proof. refine {| p_funcs := - [ ( (* f *) xI (xO xH), - {| f_info := xO (xI xH) + [ ( (* h *) xH, + {| f_info := FunInfo.witness ; f_tyin := [(sword U64)] ; f_params := [{| v_var := {| vtype := (sword U64) - ; vname := "x.163" |} + ; vname := "z.157" |} ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness (Cassgn (Lvar - {| v_var := - {| vtype := (sword U64) - ; vname := "res_x.164" |} + {| v_var := {| vtype := (sword U64) + ; vname := "z.157" |} ; v_info := dummy_var_info |}) AT_none ((sword U64)) ((Papp2 (Oadd (Op_w U64)) (Pvar {| gv := {| v_var := {| vtype := (sword U64) - ; vname := "x.163" |} + ; vname := "z.157" |} ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Papp1 (Oword_of_int U64) (Pconst (Zpos (xH))))))) ] + (Papp1 (Oword_of_int U64) + (Pconst (Zpos (xO (xI (xO (xI (xO xH))))))))))); + MkI InstrInfo.witness + (Ccall DoNotInline + [Lvar + {| v_var := + {| vtype := (sword U64) + ; vname := "res_z.158" |} + ; v_info := dummy_var_info |}] + (xO xH) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "z.157" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] ; f_tyout := [(sword U64)] ; f_res := [{| v_var := {| vtype := (sword U64) - ; vname := "res_x.164" |} + ; vname := "res_z.158" |} ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) - ; ( (* g *) xI xH, - {| f_info := xO (xO xH) + ; ( (* g *) xO xH, + {| f_info := FunInfo.witness ; f_tyin := [(sword U64)] ; f_params := [{| v_var := {| vtype := (sword U64) - ; vname := "y.161" |} + ; vname := "y.159" |} ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness @@ -64,64 +77,55 @@ Proof. [Lvar {| v_var := {| vtype := (sword U64) - ; vname := "res_y.162" |} + ; vname := "res_y.160" |} ; v_info := dummy_var_info |}] - (xI (xO xH)) + (xI xH) [(Pvar {| gv := {| v_var := {| vtype := (sword U64) - ; vname := "y.161" |} + ; vname := "y.159" |} ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] ; f_tyout := [(sword U64)] ; f_res := [{| v_var := {| vtype := (sword U64) - ; vname := "res_y.162" |} + ; vname := "res_y.160" |} ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) - ; ( (* h *) xH, - {| f_info := xO xH + ; ( (* f *) xI xH, + {| f_info := FunInfo.witness ; f_tyin := [(sword U64)] ; f_params := [{| v_var := {| vtype := (sword U64) - ; vname := "z.159" |} + ; vname := "x.161" |} ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness (Cassgn (Lvar - {| v_var := {| vtype := (sword U64) - ; vname := "z.159" |} + {| v_var := + {| vtype := (sword U64) + ; vname := "res_x.162" |} ; v_info := dummy_var_info |}) AT_none ((sword U64)) ((Papp2 (Oadd (Op_w U64)) (Pvar {| gv := {| v_var := {| vtype := (sword U64) - ; vname := "z.159" |} + ; vname := "x.161" |} ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Papp1 (Oword_of_int U64) - (Pconst (Zpos (xO (xI (xO (xI (xO xH))))))))))); - MkI InstrInfo.witness - (Ccall DoNotInline - [Lvar - {| v_var := - {| vtype := (sword U64) - ; vname := "res_z.160" |} - ; v_info := dummy_var_info |}] - (xI xH) - [(Pvar - {| gv := {| v_var := - {| vtype := (sword U64) - ; vname := "z.159" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + (Papp1 (Oword_of_int U64) (Pconst (Zpos (xH))))))) ] ; f_tyout := [(sword U64)] ; f_res := [{| v_var := {| vtype := (sword U64) - ; vname := "res_z.160" |} + ; vname := "res_x.162" |} ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) ] ; p_globs := [] ; p_extra := tt |}. + Defined. +Notation H := ( xH ). +Notation G := ( xO xH ). +Notation F := ( xI xH ). \ No newline at end of file diff --git a/theories/Jasmin/examples/two_functions.v b/theories/Jasmin/examples/two_functions.v index 2dde9bf3..b5fe8c30 100644 --- a/theories/Jasmin/examples/two_functions.v +++ b/theories/Jasmin/examples/two_functions.v @@ -21,64 +21,67 @@ Local Open Scope string. Definition ssprove_jasmin_prog : uprog. Proof. refine {| p_funcs := - [ ( (* f *) xI xH, - {| f_info := xO (xO xH) + [ ( (* g *) xH, + {| f_info := FunInfo.witness ; f_tyin := [(sword U64)] ; f_params := [{| v_var := {| vtype := (sword U64) - ; vname := "x.152" |} + ; vname := "y.148" |} ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness - (Cassgn - (Lvar + (Ccall DoNotInline + [Lvar {| v_var := {| vtype := (sword U64) - ; vname := "res_x.153" |} - ; v_info := dummy_var_info |}) - AT_none ((sword U64)) - ((Papp2 (Oadd (Op_w U64)) - (Pvar - {| gv := {| v_var := - {| vtype := (sword U64) - ; vname := "x.152" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Papp1 (Oword_of_int U64) (Pconst (Zpos (xH))))))) ] + ; vname := "res_y.149" |} + ; v_info := dummy_var_info |}] + (xO xH) + [(Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "y.148" |} + ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] ; f_tyout := [(sword U64)] ; f_res := [{| v_var := {| vtype := (sword U64) - ; vname := "res_x.153" |} + ; vname := "res_y.149" |} ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) - ; ( (* g *) xH, - {| f_info := xO xH + ; ( (* f *) xO xH, + {| f_info := FunInfo.witness ; f_tyin := [(sword U64)] ; f_params := [{| v_var := {| vtype := (sword U64) - ; vname := "y.150" |} + ; vname := "x.150" |} ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness - (Ccall DoNotInline - [Lvar + (Cassgn + (Lvar {| v_var := {| vtype := (sword U64) - ; vname := "res_y.151" |} - ; v_info := dummy_var_info |}] - (xI xH) - [(Pvar - {| gv := {| v_var := - {| vtype := (sword U64) - ; vname := "y.150" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})]) ] + ; vname := "res_x.151" |} + ; v_info := dummy_var_info |}) + AT_none ((sword U64)) + ((Papp2 (Oadd (Op_w U64)) + (Pvar + {| gv := {| v_var := + {| vtype := (sword U64) + ; vname := "x.150" |} + ; v_info := dummy_var_info |} ; gs := Slocal |}) + (Papp1 (Oword_of_int U64) (Pconst (Zpos (xH))))))) ] ; f_tyout := [(sword U64)] ; f_res := [{| v_var := {| vtype := (sword U64) - ; vname := "res_y.151" |} + ; vname := "res_x.151" |} ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) ] ; p_globs := [] ; p_extra := tt |}. + Defined. +Notation G := ( xH ). +Notation F := ( xO xH ). \ No newline at end of file diff --git a/theories/Jasmin/examples/u64_incr.v b/theories/Jasmin/examples/u64_incr.v index aca48a31..d0770d4a 100644 --- a/theories/Jasmin/examples/u64_incr.v +++ b/theories/Jasmin/examples/u64_incr.v @@ -21,54 +21,57 @@ Local Open Scope string. Definition ssprove_jasmin_prog : uprog. Proof. refine {| p_funcs := - [ ( (* incr *) xI xH, - {| f_info := xO (xO xH) + [ ( (* f *) xH, + {| f_info := FunInfo.witness + ; f_tyin := [] + ; f_params := [] + ; f_body := + [ MkI InstrInfo.witness + (Ccall InlineFun + [Lvar + {| v_var := {| vtype := (sword U64) + ; vname := "x.146" |} + ; v_info := dummy_var_info |}] + (xO xH) [(Papp1 (Oword_of_int U64) (Pconst (Z0)))]) ] + ; f_tyout := [(sword U64)] + ; f_res := + [{| v_var := {| vtype := (sword U64) + ; vname := "x.146" |} + ; v_info := dummy_var_info |}] + ; f_extra := tt + ; |} ) + ; ( (* incr *) xO xH, + {| f_info := FunInfo.witness ; f_tyin := [(sword U64)] ; f_params := [{| v_var := {| vtype := (sword U64) - ; vname := "n.149" |} + ; vname := "n.147" |} ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness (Cassgn (Lvar {| v_var := {| vtype := (sword U64) - ; vname := "m.150" |} + ; vname := "m.148" |} ; v_info := dummy_var_info |}) AT_none ((sword U64)) ((Papp2 (Oadd (Op_w U64)) (Pvar {| gv := {| v_var := {| vtype := (sword U64) - ; vname := "n.149" |} + ; vname := "n.147" |} ; v_info := dummy_var_info |} ; gs := Slocal |}) (Papp1 (Oword_of_int U64) (Pconst (Zpos (xO xH))))))) ] ; f_tyout := [(sword U64)] ; f_res := [{| v_var := {| vtype := (sword U64) - ; vname := "m.150" |} - ; v_info := dummy_var_info |}] - ; f_extra := tt - ; |} ) - ; ( (* f *) xH, - {| f_info := xO xH - ; f_tyin := [] - ; f_params := [] - ; f_body := - [ MkI InstrInfo.witness - (Ccall InlineFun - [Lvar - {| v_var := {| vtype := (sword U64) - ; vname := "x.148" |} - ; v_info := dummy_var_info |}] - (xI xH) [(Papp1 (Oword_of_int U64) (Pconst (Z0)))]) ] - ; f_tyout := [(sword U64)] - ; f_res := - [{| v_var := {| vtype := (sword U64) - ; vname := "x.148" |} + ; vname := "m.148" |} ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) ] ; p_globs := [] ; p_extra := tt |}. + Defined. +Notation F := ( xH ). +Notation INCR := ( xO xH ). \ No newline at end of file diff --git a/theories/Jasmin/examples/xor.v b/theories/Jasmin/examples/xor.v index ab18f341..1397e78b 100644 --- a/theories/Jasmin/examples/xor.v +++ b/theories/Jasmin/examples/xor.v @@ -22,53 +22,55 @@ Definition ssprove_jasmin_prog : uprog. Proof. refine {| p_funcs := [ ( (* xor *) xH, - {| f_info := xO xH + {| f_info := FunInfo.witness ; f_tyin := [(sword U64); (sword U64)] ; f_params := [{| v_var := {| vtype := (sword U64) - ; vname := "x.143" |} + ; vname := "x.141" |} ; v_info := dummy_var_info |}; {| v_var := {| vtype := (sword U64) - ; vname := "y.144" |} + ; vname := "y.142" |} ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness (Cassgn (Lvar {| v_var := {| vtype := (sword U64) - ; vname := "r.145" |} + ; vname := "r.143" |} ; v_info := dummy_var_info |}) AT_none ((sword U64)) ((Pvar {| gv := {| v_var := {| vtype := (sword U64) - ; vname := "x.143" |} + ; vname := "x.141" |} ; v_info := dummy_var_info |} ; gs := Slocal |}))); MkI InstrInfo.witness (Cassgn (Lvar {| v_var := {| vtype := (sword U64) - ; vname := "r.145" |} + ; vname := "r.143" |} ; v_info := dummy_var_info |}) AT_none ((sword U64)) ((Papp2 (Olxor U64) (Pvar {| gv := {| v_var := {| vtype := (sword U64) - ; vname := "r.145" |} + ; vname := "r.143" |} ; v_info := dummy_var_info |} ; gs := Slocal |}) (Pvar {| gv := {| v_var := {| vtype := (sword U64) - ; vname := "y.144" |} + ; vname := "y.142" |} ; v_info := dummy_var_info |} ; gs := Slocal |})))) ] ; f_tyout := [(sword U64)] ; f_res := [{| v_var := {| vtype := (sword U64) - ; vname := "r.145" |} + ; vname := "r.143" |} ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) ] ; p_globs := [] ; p_extra := tt |}. + Defined. +Notation XOR := ( xH ). \ No newline at end of file diff --git a/theories/Jasmin/examples/xor/xor.v b/theories/Jasmin/examples/xor/xor.v index e0f37c8f..e8b186d0 100644 --- a/theories/Jasmin/examples/xor/xor.v +++ b/theories/Jasmin/examples/xor/xor.v @@ -18,114 +18,98 @@ Import PackageNotation. Local Open Scope string. -Context `{asmop : asmOp}. - -Context {T} {pT : progT T}. - -Context {pd : PointerData}. - -Context (P : uprog). - -Context (f : funname). - -Definition xor : uprog. +Definition ssprove_jasmin_prog : uprog. Proof. refine {| p_funcs := [ ( (* xor *) xH, - {| f_info := xO xH + {| f_info := FunInfo.witness ; f_tyin := [(sword U64); (sword U64)] ; f_params := [{| v_var := {| vtype := (sword U64) - ; vname := "x.143" |} + ; vname := "x.141" |} ; v_info := dummy_var_info |}; {| v_var := {| vtype := (sword U64) - ; vname := "y.144" |} + ; vname := "y.142" |} ; v_info := dummy_var_info |}] ; f_body := [ MkI InstrInfo.witness (Cassgn (Lvar {| v_var := {| vtype := (sword U64) - ; vname := "r.145" |} + ; vname := "r.143" |} ; v_info := dummy_var_info |}) AT_none ((sword U64)) ((Pvar {| gv := {| v_var := {| vtype := (sword U64) - ; vname := "x.143" |} + ; vname := "x.141" |} ; v_info := dummy_var_info |} ; gs := Slocal |}))); MkI InstrInfo.witness (Cassgn (Lvar {| v_var := {| vtype := (sword U64) - ; vname := "r.145" |} + ; vname := "r.143" |} ; v_info := dummy_var_info |}) AT_none ((sword U64)) ((Papp2 (Olxor U64) (Pvar {| gv := {| v_var := {| vtype := (sword U64) - ; vname := "r.145" |} + ; vname := "r.143" |} ; v_info := dummy_var_info |} ; gs := Slocal |}) (Pvar {| gv := {| v_var := {| vtype := (sword U64) - ; vname := "y.144" |} + ; vname := "y.142" |} ; v_info := dummy_var_info |} ; gs := Slocal |})))) ] ; f_tyout := [(sword U64)] ; f_res := [{| v_var := {| vtype := (sword U64) - ; vname := "r.145" |} + ; vname := "r.143" |} ; v_info := dummy_var_info |}] ; f_extra := tt ; |} ) ] ; p_globs := [] ; p_extra := tt |}. + Defined. +Notation XOR := ( xH ). + +Notation trp := (translate_prog' ssprove_jasmin_prog).1. +Notation trc := (fun fn i => translate_call ssprove_jasmin_prog fn trp i). +(* Notation funlist := [seq f.1 | f <- p_funcs ssprove_jasmin_prog]. *) + +(* Definition static_fun fn := (fn, match assoc trp fn with Some c => c | None => fun _ => ret tt end). *) + +(* Definition static_funs := [seq static_fun f | f <- funlist]. *) + +(* Definition strp := (translate_prog_static ssprove_jasmin_prog static_funs). *) +(* Opaque strp. *) + +Definition call fn i := trc fn i. -Definition tr_P := Eval simpl in translate_prog' xor. -Definition default_prog' := (1%positive, fun s_id : p_id => (ret tt)). -Definition default_call := (1%positive, fun (s_id : p_id) (x : [choiceType of seq typed_chElement]) => ret x). -Definition get_tr sp n := List.nth_default default_call sp n. -Definition tr_xor := Eval simpl in (get_tr tr_P.2 0). -Eval simpl in (tr_P.1). +Notation JXOR i a b := (call XOR i [('word U64 ; a) ; ('word U64 ; b)]). Opaque translate_for. Ltac neq_loc_auto ::= eapply injective_translate_var3; auto. -Lemma f_xor_correct : forall w1 w2, ⊢ ⦃ fun _ => True ⦄ tr_xor.2 1%positive [('word U64; w1); ('word U64; w2)] ⇓ [('word U64; wxor w1 w2)] ⦃ fun _ => True ⦄. +Lemma f_xor_correct : forall id0 w1 w2, ⊢ ⦃ fun _ => True ⦄ JXOR id0 w1 w2 ⇓ [('word U64; wxor w1 w2)] ⦃ fun _ => True ⦄. Proof. (* preprocessing *) - intros w1 w2. + intros id0 w1 w2. + unfold JXOR. simpl_fun. repeat setjvars. - (* this makes Qed hang *) - (* repeat setoid_rewrite (@zero_extend_u U64). *) - (* proof *) unfold eval_jdg. repeat clear_get. - ssprove_swap_lhs 1. - ssprove_swap_lhs 0. - ssprove_swap_lhs 1. rewrite !zero_extend_u. - (* ssprove_swap_lhs 1. *) - (* ssprove_contract_put_get_lhs. *) - (* ssprove_swap_seq_lhs [:: 1 ; 0 ; 2 ; 1]. *) - (* ssprove_contract_put_get_lhs. *) - (* ssprove_swap_seq_lhs [:: 1 ; 0 ; 2 ; 1]. *) - (* ssprove_contract_put_get_lhs. *) - (* ssprove_swap_seq_lhs [:: 0 ; 2 ; 1 ]. *) - (* ssprove_contract_put_lhs. *) - (* ssprove_swap_seq_lhs [:: 2 ; 1 ]. *) - (* ssprove_contract_put_get_lhs. *) repeat eapply u_put. eapply u_ret. - (* rewrite !zero_extend_u. *) easy. Qed. @@ -438,23 +422,23 @@ Section Jasmin_OTP. Notation " 'word " := (chWord n) (in custom pack_type at level 2) : package_scope. Notation N := ((expn 2 n).-1.+1). - Definition id0 : BinNums.positive := 1. + (* Definition id0 : BinNums.positive := 1. *) - Definition xor_locs := + Definition xor_locs id0 := [fset - (translate_var id0 {| vtype := sword n ; vname := "x.143" |}) ; - (translate_var id0 {| vtype := sword n ; vname := "y.144" |}) ; - (translate_var id0 {| vtype := sword n ; vname := "r.145" |}) + (translate_var id0 {| vtype := sword n ; vname := "x.141" |}) ; + (translate_var id0 {| vtype := sword n ; vname := "y.142" |}) ; + (translate_var id0 {| vtype := sword n ; vname := "r.143" |}) ]. Ltac neq_loc_auto ::= eapply injective_translate_var3; auto. #[local] Open Scope package_scope. - Program Definition JasminEnc (m : 'word n) (k : 'word n) : (* why can't I just use 'word here? *) - code xor_locs [interface] ('word n) := + Program Definition JasminEnc id0 (m : 'word n) (k : 'word n) : (* why can't I just use 'word here? *) + code (xor_locs id0) [interface] ('word n) := {code - e ← tr_xor.2 id0 [:: totce m; totce k] ;; + e ← JXOR id0 m k ;; ret (coerce_to_choice_type _ (hd (totce (chCanonical ('word n))) e).π2) }. Next Obligation. @@ -462,40 +446,40 @@ Section Jasmin_OTP. repeat constructor; repeat rewrite in_fset in_cons; repeat match goal with | [ |- is_true (orb (translate_var ?i1 ?v1 == translate_var ?i1 ?v1) _) ] => - apply/orP; left; by rewrite translate_var_eq + apply/orP; left; by rewrite translate_var_eq eq_refl | |- is_true (orb _ _) => apply/orP; right end. Defined. - Program Definition JasminDec {L : {fset Location }}(c : 'word n) (k : 'word n) : - code xor_locs [interface] 'word n := JasminEnc k c. + Program Definition JasminDec id0 {L : {fset Location }}(c : 'word n) (k : 'word n) : + code (xor_locs id0) [interface] 'word n := JasminEnc id0 k c. - Program Definition IND_CPA_jasmin : - package xor_locs + Program Definition IND_CPA_jasmin id0 : + package (xor_locs id0) [interface] [interface #val #[i1] : 'word → 'word ] := [package #def #[i1] (m : 'word) : 'word { k_val ← sample uniform N ;; - r ← JasminEnc m (word_of_ord k_val) ;; + r ← JasminEnc id0 m (word_of_ord k_val) ;; ret r } ]. - Definition IND_CPA_jasmin_real_game : loc_GamePair [interface #val #[i1] : 'word → 'word ] := - λ b, if b then {locpackage IND_CPA_jasmin } else {locpackage (IND_CPA_real n) }. - Definition IND_CPA_jasmin_ideal_game : loc_GamePair [interface #val #[i1] : 'word → 'word ] := - λ b, if b then {locpackage IND_CPA_jasmin } else {locpackage (IND_CPA_ideal n) }. + Definition IND_CPA_jasmin_real_game id0 : loc_GamePair [interface #val #[i1] : 'word → 'word ] := + λ b, if b then {locpackage IND_CPA_jasmin id0 } else {locpackage (IND_CPA_real n) }. + Definition IND_CPA_jasmin_ideal_game id0 : loc_GamePair [interface #val #[i1] : 'word → 'word ] := + λ b, if b then {locpackage IND_CPA_jasmin id0 } else {locpackage (IND_CPA_ideal n) }. #[local] Open Scope ring_scope. From Crypt Require Import pkg_distr. - Lemma IND_CPA_jasmin_real : - IND_CPA_jasmin_real_game false ≈₀ IND_CPA_jasmin_real_game true. + Lemma IND_CPA_jasmin_real id0 : + IND_CPA_jasmin_real_game id0 false ≈₀ IND_CPA_jasmin_real_game id0 true. Proof. - eapply eq_rel_perf_ind_ignore with (L := xor_locs); [apply fsubsetUr|]. + eapply eq_rel_perf_ind_ignore with (L := xor_locs id0); [apply fsubsetUr|]. Opaque n. simplify_eq_rel m. @@ -521,12 +505,12 @@ Section Jasmin_OTP. 1: eapply H; assumption. Admitted. - Theorem advantage_jas_real : + Theorem advantage_jas_real id0 : ∀ LA A, - fdisjoint LA xor_locs -> + fdisjoint LA (xor_locs id0) -> ValidPackage LA [interface #val #[i1] : 'word → 'word ] A_export A → - Advantage IND_CPA_jasmin_real_game A = 0. + Advantage (IND_CPA_jasmin_real_game id0) A = 0. Proof. intros LA A vA HA. rewrite Advantage_E. @@ -535,17 +519,17 @@ Section Jasmin_OTP. 1: assumption. Qed. - Theorem unconditional_secrecy_jas : + Theorem unconditional_secrecy_jas id0 : ∀ LA A, - fdisjoint LA xor_locs -> + fdisjoint LA (xor_locs id0) -> ValidPackage LA [interface #val #[i1] : 'word → 'word ] A_export A → - Advantage IND_CPA_jasmin_ideal_game A = 0. + Advantage (IND_CPA_jasmin_ideal_game id0) A = 0. Proof. intros LA A vA HA. rewrite Advantage_E. - assert (AdvantageE (IND_CPA_jasmin_ideal_game false) (IND_CPA_jasmin_ideal_game true) A <= 0 + 0). - - rewrite -{2}advantage_jas_real; [|assumption]. + assert (AdvantageE (IND_CPA_jasmin_ideal_game id0 false) (IND_CPA_jasmin_ideal_game id0 true) A <= 0 + 0). + - rewrite -{2}(advantage_jas_real id0); [|assumption]. rewrite -unconditional_secrecy. rewrite !Advantage_E. (* cbn [IND_CPA_jasmin_real_game IND_CPA IND_CPA_jasmin_ideal_game]. *) @@ -556,117 +540,117 @@ Section Jasmin_OTP. Qed. End Jasmin_OTP. -From Hacspec Require Import Xor_Both. -From Hacspec Require Import Hacspec_Lib_Pre. +(* From Hacspec Require Import Xor_Both. *) +(* From Hacspec Require Import Hacspec_Lib_Pre. *) (* consider exporting this from Hacspec_Lib_Pre? Needed for int64 : Type coercion *) -From Hacspec Require Import ChoiceEquality. - -Section JasminHacspec. - - Definition state_xor (x y : int64) : raw_code int64 := - xor (x, y). - - Definition pure_xor (x y : int64) : raw_code int64 := - lift_to_code (L:=fset0) (I := [interface]) (is_pure (xor (x, y))). - - Definition state_pure_xor x y := code_eq_proof_statement (xor (x, y)). - Notation jazz_xor w1 w2 := ((snd tr_xor) 1%positive [('word U64; w1); ('word U64; w2)]). - Notation hdtc res := (coerce_to_choice_type ('word U64) (hd ('word U64 ; chCanonical _) res).π2). - - Lemma rxor_pure : forall w1 w2, - ⊢ ⦃ true_precond ⦄ - res ← jazz_xor w1 w2 ;; - ret (hdtc res) - ≈ - pure_xor w1 w2 - ⦃ fun '(a, h₀) '(b, h₁) => (a = b) ⦄. - Proof. - intros w1 w2. - simpl_fun. - - repeat setjvars. - - Ltac neq_loc_auto ::= eapply injective_translate_var3; auto. - - repeat clear_get. - - rewrite !zero_extend_u. - eapply r_put_lhs with (pre := fun _ => Logic.True). - repeat eapply r_put_lhs. - eapply r_ret. - - intros ? ? ?. - rewrite coerce_to_choice_type_K. - reflexivity. - Qed. - - Lemma rxor_state : forall w1 w2, - ⊢ ⦃ true_precond ⦄ - res ← ((snd tr_xor) 1%positive [('word U64; w1); ('word U64; w2)]) ;; - ret (coerce_to_choice_type ('word U64) (hd ('word U64 ; chCanonical _) res).π2) - ≈ - state_xor w1 w2 - ⦃ fun '(a, _) '(b, _) => (a = b) ⦄. - Proof. - intros w1 w2. - unfold state_xor. - - simpl_fun. - repeat setjvars. - repeat clear_get. - - rewrite !zero_extend_u. - rewrite coerce_to_choice_type_K. - eapply r_put_vs_put with (pre := fun _ => Logic.True). - repeat eapply r_put_vs_put. - repeat eapply r_put_rhs. - eapply r_ret. - easy. - Qed. - - Lemma val_sym : - ∀ {A : ord_choiceType} {pre : precond} - {c₀ : raw_code A} {c₁ : raw_code A}, - ⊢ ⦃ true_precond ⦄ - c₀ - ≈ - c₁ - ⦃ fun '(a, _) '(b, _) => a = b ⦄ -> - ⊢ ⦃ fun '(h0, h1) => true_precond (h0, h1) ⦄ - c₁ - ≈ - c₀ - ⦃ fun '(a, _) '(b, _) => a = b ⦄. - Proof. - intros. - eapply rsymmetry. - eapply rpost_weaken_rule. - 1: exact H. - intros [] []; auto. - Qed. - - Lemma rxor_pure_via_state : forall w1 w2, - ⊢ ⦃ true_precond ⦄ - res ← ((snd tr_xor) 1%positive [('word U64; w1); ('word U64; w2)]) ;; - ret (coerce_to_choice_type ('word U64) (hd ('word U64 ; chCanonical _) res).π2) - ≈ - pure_xor w1 w2 - ⦃ fun '(a, _) '(b, _) => (a = b) ⦄. - Proof. - intros w1 w2. - eapply @r_transL_val with (c₀ := state_xor w1 w2) (P := Logic.True). - - repeat constructor. - - repeat constructor. - - repeat constructor. - - eapply rsymmetry. - eapply rpost_weaken_rule. - 1: eapply rxor_state. - intros [] []; auto. - - pose proof state_pure_xor. - eapply rpre_weaken_rule. - 1: eapply rpost_weaken_rule. - 1: eapply state_pure_xor. - 2: auto. - intros [] []. unfold pre_to_post_ret; intuition subst. - Qed. -End JasminHacspec. +(* From Hacspec Require Import ChoiceEquality. *) + +(* Section JasminHacspec. *) + +(* Definition state_xor (x y : int64) : raw_code int64 := *) +(* xor (x, y). *) + +(* Definition pure_xor (x y : int64) : raw_code int64 := *) +(* lift_to_code (L:=fset0) (I := [interface]) (is_pure (xor (x, y))). *) + +(* Definition state_pure_xor x y := code_eq_proof_statement (xor (x, y)). *) +(* Notation jazz_xor w1 w2 := ((snd tr_xor) 1%positive [('word U64; w1); ('word U64; w2)]). *) +(* Notation hdtc res := (coerce_to_choice_type ('word U64) (hd ('word U64 ; chCanonical _) res).π2). *) + +(* Lemma rxor_pure : forall w1 w2, *) +(* ⊢ ⦃ true_precond ⦄ *) +(* res ← jazz_xor w1 w2 ;; *) +(* ret (hdtc res) *) +(* ≈ *) +(* pure_xor w1 w2 *) +(* ⦃ fun '(a, h₀) '(b, h₁) => (a = b) ⦄. *) +(* Proof. *) +(* intros w1 w2. *) +(* simpl_fun. *) + +(* repeat setjvars. *) + +(* Ltac neq_loc_auto ::= eapply injective_translate_var3; auto. *) + +(* repeat clear_get. *) + +(* rewrite !zero_extend_u. *) +(* eapply r_put_lhs with (pre := fun _ => Logic.True). *) +(* repeat eapply r_put_lhs. *) +(* eapply r_ret. *) + +(* intros ? ? ?. *) +(* rewrite coerce_to_choice_type_K. *) +(* reflexivity. *) +(* Qed. *) + +(* Lemma rxor_state : forall w1 w2, *) +(* ⊢ ⦃ true_precond ⦄ *) +(* res ← ((snd tr_xor) 1%positive [('word U64; w1); ('word U64; w2)]) ;; *) +(* ret (coerce_to_choice_type ('word U64) (hd ('word U64 ; chCanonical _) res).π2) *) +(* ≈ *) +(* state_xor w1 w2 *) +(* ⦃ fun '(a, _) '(b, _) => (a = b) ⦄. *) +(* Proof. *) +(* intros w1 w2. *) +(* unfold state_xor. *) + +(* simpl_fun. *) +(* repeat setjvars. *) +(* repeat clear_get. *) + +(* rewrite !zero_extend_u. *) +(* rewrite coerce_to_choice_type_K. *) +(* eapply r_put_vs_put with (pre := fun _ => Logic.True). *) +(* repeat eapply r_put_vs_put. *) +(* repeat eapply r_put_rhs. *) +(* eapply r_ret. *) +(* easy. *) +(* Qed. *) + +(* Lemma val_sym : *) +(* ∀ {A : ord_choiceType} {pre : precond} *) +(* {c₀ : raw_code A} {c₁ : raw_code A}, *) +(* ⊢ ⦃ true_precond ⦄ *) +(* c₀ *) +(* ≈ *) +(* c₁ *) +(* ⦃ fun '(a, _) '(b, _) => a = b ⦄ -> *) +(* ⊢ ⦃ fun '(h0, h1) => true_precond (h0, h1) ⦄ *) +(* c₁ *) +(* ≈ *) +(* c₀ *) +(* ⦃ fun '(a, _) '(b, _) => a = b ⦄. *) +(* Proof. *) +(* intros. *) +(* eapply rsymmetry. *) +(* eapply rpost_weaken_rule. *) +(* 1: exact H. *) +(* intros [] []; auto. *) +(* Qed. *) + +(* Lemma rxor_pure_via_state : forall w1 w2, *) +(* ⊢ ⦃ true_precond ⦄ *) +(* res ← ((snd tr_xor) 1%positive [('word U64; w1); ('word U64; w2)]) ;; *) +(* ret (coerce_to_choice_type ('word U64) (hd ('word U64 ; chCanonical _) res).π2) *) +(* ≈ *) +(* pure_xor w1 w2 *) +(* ⦃ fun '(a, _) '(b, _) => (a = b) ⦄. *) +(* Proof. *) +(* intros w1 w2. *) +(* eapply @r_transL_val with (c₀ := state_xor w1 w2) (P := Logic.True). *) +(* - repeat constructor. *) +(* - repeat constructor. *) +(* - repeat constructor. *) +(* - eapply rsymmetry. *) +(* eapply rpost_weaken_rule. *) +(* 1: eapply rxor_state. *) +(* intros [] []; auto. *) +(* - pose proof state_pure_xor. *) +(* eapply rpre_weaken_rule. *) +(* 1: eapply rpost_weaken_rule. *) +(* 1: eapply state_pure_xor. *) +(* 2: auto. *) +(* intros [] []. unfold pre_to_post_ret; intuition subst. *) +(* Qed. *) +(* End JasminHacspec. *) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 50f93bbb..0aa78a0a 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1676,7 +1676,7 @@ Section bind_list_alt. Defined. End bind_list_alt. - +Context {fcp : FlagCombinationParams}. Definition embed_ot {t} : sem_ot t → encode t := match t with (* BSH: I'm not sure this will be correct? In jasmin this is an Option bool, perhaps because you don't have to specify all output flags *) @@ -3142,9 +3142,9 @@ Ltac jbind_fresh h := clear h ; intros x hx h ; cbn beta in h. -Lemma app_sopn_nil_ok_size : - ∀ T ts (f : sem_prod ts (exec T)) vs v, - app_sopn ts f vs = ok v → +Lemma app_sopn_nil_ok_size {T} {of_T : forall t, T -> exec (sem_t t)} : + ∀ A ts (f : sem_prod ts (exec A)) vs v, + app_sopn of_T f vs = ok v → size ts = size vs. Proof. intros A ts f vs v h. @@ -3348,8 +3348,8 @@ Lemma list_lchtuple_cons_cons {t1 t2 : stype} {ts : seq stype} (p1 : encode t1) Proof. reflexivity. Qed. Lemma app_sopn_cons {rT} t ts v vs sem : - @app_sopn rT (t :: ts) sem (v :: vs) = - Let v' := of_val t v in @app_sopn rT ts (sem v') vs. + @app_sopn _ of_val rT (t :: ts) sem (v :: vs) = + Let v' := of_val t v in @app_sopn _ of_val rT ts (sem v') vs. Proof. reflexivity. Qed. Lemma sem_prod_cons t ts S : @@ -3362,7 +3362,7 @@ Inductive sem_correct {R} : ∀ (ts : seq stype), (sem_prod ts (exec R)) → Pro Lemma tr_app_sopn_correct {R S} (can : S) emb ts vs vs' (s : sem_prod ts (exec R)) : sem_correct ts s → - app_sopn ts s vs = ok vs' → + app_sopn of_val s vs = ok vs' → tr_app_sopn can emb ts s [seq to_typed_chElement (translate_value v) | v <- vs] = emb vs'. Proof. @@ -3385,7 +3385,7 @@ Qed. Context `{asm_correct : ∀ o, sem_correct (tin (get_instr_desc (Oasm o))) (sopn_sem (Oasm o))}. Lemma app_sopn_list_tuple_correct o vs vs' : - app_sopn _ (sopn_sem o) vs = ok vs' → + app_sopn of_val (sopn_sem o) vs = ok vs' → tr_app_sopn_tuple _ (sopn_sem o) [seq to_typed_chElement (translate_value v) | v <- vs] = embed_tuple vs'. @@ -3434,7 +3434,7 @@ Proof using asm_correct. Qed. Lemma tr_app_sopn_single_correct (op : opN) (v : sem_t (type_of_opN op).2) (vs : values) : - app_sopn (type_of_opN op).1 (sem_opN_typed op) vs = ok v → + app_sopn of_val (sem_opN_typed op) vs = ok v → tr_app_sopn_single (type_of_opN op).1 (sem_opN_typed op) @@ -4066,6 +4066,7 @@ Section Translation. Context `{asmop : asmOp}. Context {pd : PointerData}. +Context {fcp : FlagCombinationParams}. Context (P : uprog). @@ -4126,7 +4127,7 @@ Fixpoint translate_instr_r with translate_instr (tr_f_body : fdefs) (i : instr) (m_id : p_id) (s_id : p_id) {struct i} : p_id * raw_code 'unit := translate_instr_r tr_f_body (instr_d i) m_id s_id. -Proof using P asm_op asmop pd. +Proof using P asm_op asmop pd fcp. pose proof (translate_cmd := (fix translate_cmd (tr_f_body : fdefs) (c : cmd) (m_id : p_id) (s_id : p_id) : p_id * raw_code 'unit := match c with @@ -4266,7 +4267,7 @@ Definition translate_fundef (tr_f_body : fdefs) (p : p_id) (fd : _ufun_decl (* extra_fun_t *)) : funname * fdef. -Proof using P asm_op asmop pd. +Proof using P asm_op asmop pd fcp. destruct fd. destruct _f. split. 1: exact f. constructor. @@ -4327,11 +4328,12 @@ Section Translation. Context `{asmop : asmOp}. Context {pd : PointerData}. +Context {fcp : FlagCombinationParams}. Definition ssprove_prog := seq (funname * trfun). Definition translate_prog (prog : uprog) : fdefs. -Proof using asm_op asmop pd. +Proof using asm_op asmop pd fcp. destruct prog. induction p_funcs. - exact [::]. @@ -4345,7 +4347,7 @@ Proof using asm_op asmop pd. Defined. Definition tr_p (prog : uprog) : ssprove_prog. -Proof using asm_op asmop pd. +Proof using asm_op asmop pd fcp. pose (fs := translate_prog prog). induction fs as [|f fs ?]. - constructor 1. @@ -4389,6 +4391,12 @@ Fixpoint translate_funs_static (P : uprog) (fs : seq _ufun_decl) (st_funcs : fde Definition translate_prog_static P st_funcs := translate_funs_static P (p_funcs P) st_funcs. +Definition get_translated_static_fun P fn st_func := + match assoc (translate_prog_static P st_func).2 fn with + | Some f => f + | None => fun _ _ => ret [::] + end. + Lemma tr_prog_inv {P fn f} : get_fundef (p_funcs P) fn = Some f → ∑ fs' l, @@ -5057,7 +5065,7 @@ Qed. Theorem translate_prog_correct P scs m vargs scs' m' vres : ∀ fn, - sem.sem_call P scs m fn vargs scs' m' vres → + sem.sem_call (P : @uprog asm_op asmop) scs m fn vargs scs' m' vres → handled_program P -> ∀ vm m_id s_id s_st st, Pfun P fn scs m vargs scs' m' vres vm m_id s_id s_st st. @@ -5094,7 +5102,7 @@ Proof using gd asm_correct. translate_for v ws m_id (translate_cmd P SP c m_id) s_id' ⇓ tt ⦃ rel_estate s2 m_id s_id'' (s_id~0 :: s_st) st ⦄ ). - unshelve eapply (@sem_call_Ind _ _ _ _ _ _ Pc Pi_r Pi Pfor Pfun _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H). + unshelve eapply (@sem_call_Ind asm_op syscall_state mk_spp _ Pc Pi_r Pi Pfor Pfun _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H). - (* nil *) intros s m_id s_id s_st st _. simpl. eapply u_ret_eq. From 9700593d50eef8537cb002c3d66ebcd0f58f478d Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Mon, 19 Dec 2022 14:31:41 +0100 Subject: [PATCH 324/383] One subgoal closer, aes_hac --- theories/Jasmin/examples/aes/aes_hac.v | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes_hac.v b/theories/Jasmin/examples/aes/aes_hac.v index 514bff7d..34ce051c 100644 --- a/theories/Jasmin/examples/aes/aes_hac.v +++ b/theories/Jasmin/examples/aes/aes_hac.v @@ -404,8 +404,13 @@ Section Hacspec. - apply H0. - destruct y as [ | y | y ]. + apply H. - + simpl in *. - admit. + + destruct H as [_ ?]. + destruct H0 as [_ ?]. + apply Z.log2_lt_pow2 in H ; [ | easy ]. + apply Z.log2_lt_pow2 in H0 ; [ | easy ]. + apply Z.log2_lt_pow2 ; [ easy | ]. + rewrite (Z.log2_lor) ; [ | easy | easy ]. + apply Z.max_lub_lt ; easy. + easy. - easy. } @@ -445,7 +450,7 @@ Section Hacspec. cbn. rewrite !zero_extend_u. reflexivity. - Admitted. + Qed. Lemma foo id0 rcon rkey temp2 : ⊢ ⦃ fun '(_, _) => True ⦄ From 69ef8d2a3c02ac0d090149db3bbd8ed73d08ae9e Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Mon, 19 Dec 2022 20:56:23 +0100 Subject: [PATCH 325/383] another sub protocol for key_combined --- theories/Jasmin/examples/aes/aes_hac.v | 746 ++++++++++++++++++++----- 1 file changed, 604 insertions(+), 142 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes_hac.v b/theories/Jasmin/examples/aes/aes_hac.v index 34ce051c..8fc27e64 100644 --- a/theories/Jasmin/examples/aes/aes_hac.v +++ b/theories/Jasmin/examples/aes/aes_hac.v @@ -85,7 +85,7 @@ Section Hacspec. Ltac bind_jazz_hac := match goal with | [ |- context [ ⊢ ⦃ ?P ⦄ putr ?l ?jazz ?f ≈ _ ⦃ ?Q ⦄ ] ] => - eapply (@r_bind _ _ _ _ (ret jazz) _ (fun x => putr l x f) _ _ (fun '(v0, h0) '(v1, h1) => v0 = v1 /\ P (h0, h1)) _) ; [ | intros ; unfold pre_to_post ] + eapply (@r_bind _ _ _ _ (ret jazz) _ (fun x => putr l x f) _ _ (fun '(v0, h0) '(v1, h1) => v0 = v1 /\ P (h0, h1)) _) ; [ rewrite !zero_extend_u | intros ; unfold pre_to_post ] end. (* match goal with *) @@ -103,8 +103,8 @@ Section Hacspec. reflexivity | ]. Notation JVSHUFPS i rkey temp1 temp2 := (trc VSHUFPS i [('word U128 ; rkey) ; ('word U128 ; temp1) ; ('word U128 ; temp2)]). - - Lemma wpshupfd_eq : + + Lemma wpshufd_eq : forall (rkey : 'word U128) (i : nat), i < 4 -> wpshufd1 rkey (wrepr U8 255) i = @@ -158,8 +158,94 @@ Section Hacspec. rewrite (Zmod_small) ; [ | destruct i as [ | [ | [ | [] ]]] ; easy ]. rewrite (Zmod_small) ; [ | destruct i as [ | [ | [ | [] ]]] ; easy ]. lia. + Transparent Z.mul. + Transparent Nat.mul. + Qed. + + Lemma wpshufd_eq_state : + forall {H} (rkey : 'word U128) (i : nat), + i < 4 -> +⊢ ⦃ H ⦄ + ret (wpshufd1 rkey (wrepr U8 255) i) ≈ + is_state (vpshufd1 rkey (Hacspec_Lib_Pre.repr 255) (Hacspec_Lib_Pre.repr i)) + ⦃ λ '(v0, h0) '(v1, h1), v0 = v1 ∧ H (h0, h1) ⦄. + Proof. + intros. + rewrite wpshufd_eq ; [ | apply H0 ]. + now apply r_ret. + Qed. + + + Ltac match_wpshufd1_vpshufd1 := + (let w := fresh in + let y := fresh in + let b := fresh in + set (w := wpshufd1 _ _ _) ; + set (y := fun _ : Hacspec_Lib_Pre.int32 => _) ; + set (b := vpshufd1 _ _ _); + let k := fresh in + let l := fresh in + match goal with + | [ |- context [ ⊢ ⦃ ?P ⦄ ?lhs ≈ _ ⦃ _ ⦄ ] ] => set (k := P) ; set (l := lhs) + end ; + pattern (w) in l ; + subst l ; + apply (@r_bind _ _ _ _ (ret w) (prog (is_state b)) _ y _ (fun '(v0, h0) '(v1, h1) => v0 = v1 /\ k (h0, h1))) ; subst w y b ; hnf). + + Lemma Z_lor_pow2 : (forall (x y : Z) (k : nat), (0 <= x < 2 ^ k)%Z -> (0 <= y < 2 ^ k)%Z -> (0 <= Z.lor x y < 2 ^ k)%Z). + Proof. + clear. + intros. + + split. + apply Z.lor_nonneg ; easy. + destruct x as [ | x | x ]. + - apply H0. + - destruct y as [ | y | y ]. + + apply H. + + destruct H as [_ ?]. + destruct H0 as [_ ?]. + apply Z.log2_lt_pow2 in H ; [ | easy ]. + apply Z.log2_lt_pow2 in H0 ; [ | easy ]. + apply Z.log2_lt_pow2 ; [ easy | ]. + rewrite (Z.log2_lor) ; [ | easy | easy ]. + apply Z.max_lub_lt ; easy. + + easy. + - easy. Qed. + Lemma num_smaller_if_modulus_smaller : (forall {WS} (x : 'word WS) z, (modulus WS < z)%Z -> (0 <= x < z)%Z). + Proof. + clear. + cbn. + intros. + destruct x. + pose (ssrbool.elimT (iswordZP _ _) i). + split. easy. + unfold word.toword. + destruct a. + eapply Z.lt_trans ; [ apply H1 | apply H]. + Qed. + + Lemma shift_left_4_byte_ok : + (forall i (a : 'word U32), + i < 4 -> + (0 <= Z.shiftl (wunsigned a) (Z.of_nat (i * 32)) < + modulus (wsize_size_minus_1 U128).+1)%Z). + Proof. + clear. + destruct a. + unfold wunsigned, urepr, val, word_subType, word.toword. + split. apply Z.shiftl_nonneg. lia. + apply (ssrbool.elimT (iswordZP _ _)) in i0. + destruct i0. + rewrite Z.shiftl_mul_pow2 ; [ | lia]. + eapply Z.lt_le_trans. + rewrite <- (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat _) toword) ; [ | lia ]. + apply H1. + destruct i as [ | [ | [ | [ | []] ]] ] ; easy. + Qed. + Lemma key_combined_eq id0 rcon rkey temp2 : ⊢ ⦃ fun '(_, _) => True ⦄ JKEY_COMBINE id0 rcon rkey temp2 @@ -184,17 +270,24 @@ Section Hacspec. apply better_r_put_lhs. remove_get_in_lhs. - bind_jazz_hac. - (* match goal with *) - (* | [ |- context [ ⊢ ⦃ ?P ⦄ putr ?l ?jazz ?f ≈ _ ⦃ ?Q ⦄ ] ] => *) - (* eapply (@r_bind _ _ _ _ (ret jazz) _ (fun x => putr l x f) _ _ (fun '(v0, h0) '(v1, h1) => v0 = v1 /\ P (h0, h1)) _) ; [ | intros ; unfold pre_to_post ] *) - (* end. *) + bind_jazz_hac ; [ shelve | ]. - { + do 5 (apply better_r_put_lhs ; do 2 remove_get_in_lhs ; bind_jazz_hac ; [shelve | ]). + apply better_r_put_lhs ; do 2 remove_get_in_lhs ; apply r_ret. - (* apply forget_precond. *) - rewrite !zero_extend_u. + intros. + destruct_pre. + eexists. + eexists. + split ; [ reflexivity | ]. + cbn. + rewrite !zero_extend_u. + reflexivity. + Unshelve. + { + (* rewrite !zero_extend_u. *) + unfold tr_app_sopn_tuple. unfold sopn_sem. unfold sopn.get_instr_desc. @@ -210,7 +303,7 @@ Section Hacspec. unfold ".1". unfold x86_VPSHUFD. unfold wpshufd. - + set (totce _) at 2. cbn in t. unfold totce in t. @@ -236,24 +329,44 @@ Section Hacspec. (* set (wpshufd1 _ _ _). *) unfold vpshufd. - do 4 (set (w := wpshufd1 _ _ _) ; - set (y := fun _ : Hacspec_Lib_Pre.int32 => _) ; - set (b := vpshufd1 _ _ _); - let k := fresh in - match goal with - | [ |- context [ ⊢ ⦃ ?P ⦄ _ ≈ _ ⦃ _ ⦄ ] ] => set (k := P) - end ; - apply (@r_bind _ _ _ _ (ret w) (prog (is_state b)) (fun w => ret (wrepr U128 (wcat_r [_ ; _ ; _ ; _]))) y _ (fun '(v0, h0) '(v1, h1) => v0 = v1 /\ k (h0, h1))) ; [ apply r_ret ; intros ; subst w ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K ;cbn ; rewrite! zero_extend_u ; now rewrite wpshupfd_eq | intros ; subst w y b ; hnf ]). + match_wpshufd1_vpshufd1. + + replace (truncate_chWord U128 _) with rkey by (simpl ; now rewrite zero_extend_u). + replace (wrepr _ _) with (wrepr U8 255) by (rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; now rewrite coerce_to_choice_type_K). + apply (@wpshufd_eq_state _ rkey 0 ltac:(easy)). + intros. + + match_wpshufd1_vpshufd1. + + replace (truncate_chWord U128 _) with rkey by (simpl ; now rewrite zero_extend_u). + replace (wrepr _ _) with (wrepr U8 255) by (rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; now rewrite coerce_to_choice_type_K). + eapply (@wpshufd_eq_state _ rkey 1 ltac:(easy)). + intros. + + match_wpshufd1_vpshufd1. + + replace (truncate_chWord U128 _) with rkey by (simpl ; now rewrite zero_extend_u). + replace (wrepr _ _) with (wrepr U8 255) by (rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; now rewrite coerce_to_choice_type_K). + eapply (@wpshufd_eq_state _ rkey 2 ltac:(easy)). + intros. + + match_wpshufd1_vpshufd1. + + replace (truncate_chWord U128 _) with rkey by (simpl ; now rewrite zero_extend_u). + replace (wrepr _ _) with (wrepr U8 255) by (rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; now rewrite coerce_to_choice_type_K). + eapply (@wpshufd_eq_state _ rkey 3 ltac:(easy)). + intros. apply r_ret. intros. - destruct H3 as [? [? [? [? []]]]]. + destruct H as [? [? [? [? []]]]]. subst. - subst H. + subst H2. clear -H7. split ; [ | eexists ; apply H7 ]. apply word_ext. + unfold wcat_r. unfold ".|". @@ -265,18 +378,32 @@ Section Hacspec. unfold Hacspec_Lib_Pre.usize. unfold Hacspec_Lib_Pre.Z_uint_sizeable. unfold Hacspec_Lib_Pre.unsigned. + unfold cast_int. unfold lift_to_both0 , lift_to_both, is_pure. unfold word.wor, wor. unfold wshl, lsl. unfold wrepr, wunsigned, urepr, val, word_subType, mkword, toword. + unfold Hacspec_Lib_Pre.repr. + unfold Hacspec_Lib_Pre.nat_uint_sizeable. + unfold Hacspec_Lib_Pre.repr. unfold wrepr. unfold mkword. unfold toword. unfold Hacspec_Lib_Pre.unsigned. + rewrite !Zmod_small. - rewrite <- Z.lor_assoc. - rewrite <- Z.lor_assoc. + + all: try easy. + all: try (apply num_smaller_if_modulus_smaller ; easy). + + 2: apply (shift_left_4_byte_ok 3) ; easy. + 2: apply (shift_left_4_byte_ok 2) ; easy. + 2: apply (shift_left_4_byte_ok 1) ; easy. + + setoid_rewrite <- Z.lor_assoc. + setoid_rewrite <- Z.lor_assoc. f_equal. + symmetry. rewrite <- Z.lor_comm. rewrite <- Z.lor_assoc. @@ -284,103 +411,352 @@ Section Hacspec. rewrite <- Z.lor_assoc. rewrite <- Z.lor_comm. rewrite <- Z.lor_assoc. - rewrite Z.shiftl_lor. - rewrite Z.shiftl_lor. - rewrite Z.shiftl_lor. - rewrite Z.shiftl_lor. - rewrite Z.shiftl_lor. - rewrite Z.shiftl_lor. + rewrite !Z.shiftl_lor. f_equal. f_equal. rewrite Z.lor_0_r. reflexivity. - all: try easy. + destruct a₁, a₁0, a₁1, a₁2. + rewrite !Z.shiftl_lor. + rewrite !Z.shiftl_mul_pow2 ; try easy. + rewrite !Z.mul_0_l. + rewrite Z.lor_0_r. + replace (int_to_Z (Posz 32)) with 32%Z by reflexivity. + + apply (ssrbool.elimT (iswordZP _ _)) in i, i0, i1, i2. + split. + { + apply Z.lor_nonneg. split. easy. + apply Z.lor_nonneg. split. apply Z.mul_nonneg_nonneg ; easy. + apply Z.lor_nonneg. split. repeat apply Z.mul_nonneg_nonneg ; easy. + repeat apply Z.mul_nonneg_nonneg ; easy. + } + { + rewrite <- !Z.mul_assoc. + rewrite <- !Z.pow_add_r ; try easy. + simpl. - destruct a₁2. - split. lia. - apply (ssrbool.elimT (iswordZP _ _)) in i. - destruct i. - eapply Z.lt_trans ; [ apply H0 | easy ]. + apply (Z_lor_pow2 toword _ nat127.+1). split ; [ easy | ]. + eapply Z.lt_trans ; [apply i | easy]. - cbn. - destruct a₁2. - split. apply Z.shiftl_nonneg. lia. - apply (ssrbool.elimT (iswordZP _ _)) in i. - destruct i. - rewrite Z.shiftl_mul_pow2 ; [ | easy]. - rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 96)) toword) in H0 ; [ | easy]. - apply H0. + apply (Z_lor_pow2 (toword0 * _)%Z _ nat127.+1). split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. + eapply Z.lt_le_trans. + rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 32)) toword0) in i0 ; [ | easy]. + apply i0. + easy. + + apply (Z_lor_pow2 (toword1 * _)%Z _ nat127.+1). split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. + + eapply Z.lt_le_trans. + rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 64)) toword1) in i1 ; [ | easy]. + apply i1. + easy. + + split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. + eapply Z.lt_le_trans. + rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 96)) toword2) in i2 ; [ | easy]. + apply i2. + easy. + } + } + { + + unfold tr_app_sopn_tuple. + unfold sopn_sem. + unfold sopn.get_instr_desc. + unfold asm_opI. + unfold asm_op_instr. + unfold semi, arch_extra.get_instr_desc. + unfold instr_desc, _asm_op_decl, instr_desc_op, _asm, x86_extra. + unfold x86_sem.x86. + unfold x86_op_decl. + unfold x86_instr_desc. + unfold id_semi. + unfold Ox86_VPSHUFD_instr. + unfold ".1". + unfold x86_VPSHUFD. + unfold wpshufd. + + set (totce _) at 2. + cbn in t. + unfold totce in t. + + set (chCanonical _). + cbn in s. + subst s. + + set (tr_app_sopn _ _ _ _). + cbn in y. + subst y. + hnf. + + unfold totce. + subst t. + unfold ".π2". + + unfold wshufps_128. + unfold lift2_vec. + unfold make_vec. + rewrite map2E. + unfold zip. + unfold split_vec. + unfold map. + unfold iota. + + set (nat_of_wsize U128 %/ nat_of_wsize U128 + + nat_of_wsize U128 %% nat_of_wsize U128). + cbn in n. + subst n. + hnf. + unfold sopn_sem, tr_app_sopn_tuple, tr_app_sopn_single. - cbn. - destruct a₁2. - split. lia. - apply (ssrbool.elimT (iswordZP _ _)) in i. - destruct i. - eapply Z.lt_trans ; [ apply H0 | easy ]. + unfold vshufps. + + match_wpshufd1_vpshufd1. + set (ret _). + simpl in r. + subst r. + rewrite !zero_extend_u. + replace (word.subword _ _ temp2) with temp2. + 2:{ + destruct temp2. + cbn. + apply word_ext. + cbn. + rewrite Zmod_mod. + rewrite Zmod_small. + reflexivity. + apply (ssrbool.elimT (iswordZP _ _)). + apply i. + } + + replace (wpack U8 2 _) with (wrepr U8 16) by now do 2 (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). + replace (Hacspec_Lib_Pre.pub_u8 + (is_pure + (lift_to_both0 + (is_pure (lift_to_both0 (Hacspec_Lib_Pre.usize 16)))))) with (Hacspec_Lib_Pre.repr (WS := U8) 16) by reflexivity. - cbn. - destruct a₁1. - split. lia. - apply (ssrbool.elimT (iswordZP _ _)) in i. - destruct i. - eapply Z.lt_trans ; [ apply H0 | easy ]. + apply r_ret. + intros. + split ; [ | assumption ]. + remove_T_ct. + Opaque Z.mul. + clear. + intros. + unfold vpshufd1. + unfold wpshufd1. + simpl. + apply word_ext. + f_equal. + simpl. + rewrite Zmod_mod. + unfold Hacspec_Lib_Pre.shift_right_, wshr, lsr, Hacspec_Lib_Pre.unsigned, wunsigned ; rewrite mkwordK. + f_equal. - cbn. - destruct a₁1. - split. apply Z.shiftl_nonneg. lia. - apply (ssrbool.elimT (iswordZP _ _)) in i. - destruct i. - rewrite Z.shiftl_mul_pow2 ; [ | easy]. - rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 64)) toword) in H0 ; [ | easy]. - eapply Z.lt_trans ; [ apply H0 | easy ]. + intros. + + match_wpshufd1_vpshufd1. + + set (ret _). + simpl in r. + subst r. + rewrite !zero_extend_u. + replace (word.subword _ _ temp2) with temp2. + 2:{ + destruct temp2. + cbn. + apply word_ext. + cbn. + rewrite Zmod_mod. + rewrite Zmod_small. + reflexivity. + apply (ssrbool.elimT (iswordZP _ _)). + apply i. + } - cbn. - destruct a₁1. - split. lia. - apply (ssrbool.elimT (iswordZP _ _)) in i. - destruct i. - eapply Z.lt_trans ; [ apply H0 | easy ]. + replace (wpack U8 2 _) with (wrepr U8 16) by now do 2 (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). + replace (Hacspec_Lib_Pre.pub_u8 + (is_pure + (lift_to_both0 + (is_pure (lift_to_both0 (Hacspec_Lib_Pre.usize 16)))))) with (Hacspec_Lib_Pre.repr (WS := U8) 16) by reflexivity. - cbn. - destruct a₁0. - split. lia. - apply (ssrbool.elimT (iswordZP _ _)) in i. - destruct i. - eapply Z.lt_trans ; [ apply H0 | easy ]. + apply r_ret. + intros. + split ; [ | assumption ]. + remove_T_ct. + Opaque Z.mul. + clear. + intros. + unfold vpshufd1. + unfold wpshufd1. + simpl. + apply word_ext. + f_equal. + simpl. + rewrite Zmod_mod. + unfold Hacspec_Lib_Pre.shift_right_, wshr, lsr, Hacspec_Lib_Pre.unsigned, wunsigned ; rewrite mkwordK. + f_equal. - cbn. - destruct a₁0. - split. apply Z.shiftl_nonneg. lia. - apply (ssrbool.elimT (iswordZP _ _)) in i. - destruct i. - rewrite Z.shiftl_mul_pow2 ; [ | easy]. - rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 32)) toword) in H0 ; [ | easy]. - eapply Z.lt_trans ; [ apply H0 | easy ]. + intros. + + match_wpshufd1_vpshufd1. - cbn. - destruct a₁0. - split. lia. - apply (ssrbool.elimT (iswordZP _ _)) in i. - destruct i. - eapply Z.lt_trans ; [ apply H0 | easy ]. + set (ret _). + simpl in r. + subst r. + rewrite !zero_extend_u. + replace (word.subword _ _ rcon) with rcon. + 2:{ + destruct rcon. + cbn. + apply word_ext. + cbn. + rewrite Zmod_mod. + rewrite Zmod_small. + reflexivity. + apply (ssrbool.elimT (iswordZP _ _)). + apply i. + } + + replace (wpack U8 2 _) with (wrepr U8 16) by now do 2 (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). + replace (Hacspec_Lib_Pre.pub_u8 + (is_pure + (lift_to_both0 + (is_pure (lift_to_both0 (Hacspec_Lib_Pre.usize 16)))))) with (Hacspec_Lib_Pre.repr (WS := U8) 16) by reflexivity. - cbn. - destruct a₁. - split. lia. - apply (ssrbool.elimT (iswordZP _ _)) in i. - destruct i. - eapply Z.lt_trans ; [ apply H0 | easy ]. + apply r_ret. + intros. + split ; [ | assumption ]. + remove_T_ct. + Opaque Z.mul. + clear. + intros. + unfold vpshufd1. + unfold wpshufd1. + simpl. + apply word_ext. + f_equal. + simpl. + rewrite Zmod_mod. + unfold Hacspec_Lib_Pre.shift_right_, wshr, lsr, Hacspec_Lib_Pre.unsigned, wunsigned ; rewrite mkwordK. + f_equal. - destruct a₁, a₁0, a₁1, a₁2. + intros. + match_wpshufd1_vpshufd1. + + set (ret _). + simpl in r. + subst r. + rewrite !zero_extend_u. + replace (word.subword _ _ rcon) with rcon. + 2:{ + destruct rcon. + cbn. + apply word_ext. + cbn. + rewrite Zmod_mod. + rewrite Zmod_small. + reflexivity. + apply (ssrbool.elimT (iswordZP _ _)). + apply i. + } + + replace (wpack U8 2 _) with (wrepr U8 16) by now do 2 (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). + replace (Hacspec_Lib_Pre.pub_u8 + (is_pure + (lift_to_both0 + (is_pure (lift_to_both0 (Hacspec_Lib_Pre.usize 16)))))) with (Hacspec_Lib_Pre.repr (WS := U8) 16) by reflexivity. + + apply r_ret. + intros. + split ; [ | assumption ]. + remove_T_ct. + Opaque Z.mul. + clear. + intros. + unfold vpshufd1. + unfold wpshufd1. + simpl. + apply word_ext. + f_equal. + simpl. + rewrite Zmod_mod. + unfold Hacspec_Lib_Pre.shift_right_, wshr, lsr, Hacspec_Lib_Pre.unsigned, wunsigned ; rewrite mkwordK. + f_equal. + + intros. + + apply r_ret. + + intros. + destruct H as [? [? [? [? [? [[]]]]]]]. + subst. + split. + 2:{ + unfold H2. + exists x. easy. + } + + apply word_ext. + unfold wcat_r. + + unfold ".|". + unfold "_ shift_left _". + unfold Hacspec_Lib_Pre.shift_left_. + unfold Hacspec_Lib_Pre.int_or. + unfold Hacspec_Lib_Pre.repr. + unfold Hacspec_Lib_Pre.from_uint_size. + unfold Hacspec_Lib_Pre.usize. + unfold Hacspec_Lib_Pre.Z_uint_sizeable. + unfold Hacspec_Lib_Pre.unsigned. + unfold cast_int. + unfold lift_to_both0 , lift_to_both, is_pure. + unfold word.wor, wor. + unfold wshl, lsl. + unfold wrepr, wunsigned, urepr, val, word_subType, mkword, toword. + unfold Hacspec_Lib_Pre.repr. + unfold Hacspec_Lib_Pre.nat_uint_sizeable. + unfold Hacspec_Lib_Pre.repr. + unfold wrepr. + unfold mkword. + unfold toword. + unfold Hacspec_Lib_Pre.unsigned. + + rewrite !Zmod_small. + + all: try easy. + all: try (apply (num_smaller_if_modulus_smaller) ; easy). + + setoid_rewrite <- Z.lor_assoc. + setoid_rewrite <- Z.lor_assoc. + f_equal. + + rewrite Z.shiftl_0_l. + rewrite Z.lor_0_r. + rewrite Z.shiftl_0_l. + rewrite Z.lor_0_r. + + rewrite !Z.shiftl_lor. + f_equal. + + apply (shift_left_4_byte_ok 3) ; easy. + apply (shift_left_4_byte_ok 2) ; easy. + apply (shift_left_4_byte_ok 1) ; easy. + + + destruct a₁0, a₁1, a₁2, a₁3. rewrite !Z.shiftl_lor. rewrite !Z.shiftl_mul_pow2 ; try easy. rewrite !Z.mul_0_l. rewrite Z.lor_0_r. replace (int_to_Z (Posz 32)) with 32%Z by reflexivity. - apply (ssrbool.elimT (iswordZP _ _)) in i, i0, i1, i2. + destruct (ssrbool.elimT (iswordZP _ _) i). + destruct (ssrbool.elimT (iswordZP _ _) i0). + destruct (ssrbool.elimT (iswordZP _ _) i1). + destruct (ssrbool.elimT (iswordZP _ _) i2). split. { apply Z.lor_nonneg. split. easy. @@ -393,64 +769,150 @@ Section Hacspec. rewrite <- !Z.pow_add_r ; try easy. simpl. - assert (forall (x y : Z) (k : nat), (0 <= x < 2 ^ k)%Z -> (0 <= y < 2 ^ k)%Z -> (0 <= Z.lor x y < 2 ^ k)%Z). - { - clear. - intros. - - split. - apply Z.lor_nonneg ; easy. - destruct x as [ | x | x ]. - - apply H0. - - destruct y as [ | y | y ]. - + apply H. - + destruct H as [_ ?]. - destruct H0 as [_ ?]. - apply Z.log2_lt_pow2 in H ; [ | easy ]. - apply Z.log2_lt_pow2 in H0 ; [ | easy ]. - apply Z.log2_lt_pow2 ; [ easy | ]. - rewrite (Z.log2_lor) ; [ | easy | easy ]. - apply Z.max_lub_lt ; easy. - + easy. - - easy. - } - - apply (H toword _ nat127.+1). split ; [ easy | ]. - eapply Z.lt_trans ; [apply i | easy]. + apply (Z_lor_pow2 toword _ nat127.+1). split ; [ easy | ]. + eapply Z.lt_trans ; [apply H0 | easy]. - apply (H (toword0 * _)%Z _ nat127.+1). split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. + apply (Z_lor_pow2 (toword0 * _)%Z _ nat127.+1). split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. eapply Z.lt_le_trans. - rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 32)) toword0) in i0 ; [ | easy]. - apply i0. + apply (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 32)) toword0) in H6 ; [ | easy]. + apply H6. easy. - apply (H (toword1 * _)%Z _ nat127.+1). split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. + apply (Z_lor_pow2 (toword1 * _)%Z _ nat127.+1). split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. eapply Z.lt_le_trans. - rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 64)) toword1) in i1 ; [ | easy]. - apply i1. + rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 64)) toword1) in H9 ; [ | easy]. + apply H9. easy. split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. eapply Z.lt_le_trans. - rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 96)) toword2) in i2 ; [ | easy]. - apply i2. + rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 96)) toword2) in H11 ; [ | easy]. + apply H11. easy. } - } + { + destruct a₁0, a₁1, a₁2, a₁3. +rewrite !Z.shiftl_lor. + rewrite !Z.shiftl_mul_pow2 ; try easy. + rewrite !Z.mul_0_l. + rewrite Z.lor_0_r. + replace (int_to_Z (Posz 32)) with 32%Z by reflexivity. - do 5 (apply better_r_put_lhs ; do 2 remove_get_in_lhs ; bind_jazz_hac ; [shelve | ]). - apply better_r_put_lhs ; do 2 remove_get_in_lhs ; apply r_ret. + destruct (ssrbool.elimT (iswordZP _ _) i). + destruct (ssrbool.elimT (iswordZP _ _) i0). + destruct (ssrbool.elimT (iswordZP _ _) i1). + destruct (ssrbool.elimT (iswordZP _ _) i2). + split. + { + apply Z.lor_nonneg. split. easy. + apply Z.lor_nonneg. split. apply Z.mul_nonneg_nonneg ; easy. + apply Z.lor_nonneg. split. repeat apply Z.mul_nonneg_nonneg ; easy. + apply Z.lor_nonneg. split. repeat apply Z.mul_nonneg_nonneg ; easy. + easy. + } + { + rewrite <- !Z.mul_assoc. + rewrite <- !Z.pow_add_r ; try easy. + simpl. - intros. - destruct_pre. - eexists. - eexists. - split ; [ reflexivity | ]. - cbn. - rewrite !zero_extend_u. - reflexivity. - Qed. + apply (Z_lor_pow2 toword _ nat127.+1). split ; [ easy | ]. + eapply Z.lt_trans ; [apply H0 | easy]. + + apply (Z_lor_pow2 (toword0 * _)%Z _ nat127.+1). split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. + eapply Z.lt_le_trans. + apply (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 32)) toword0) in H6 ; [ | easy]. + apply H6. + easy. + + apply (Z_lor_pow2 (toword1 * _)%Z _ nat127.+1). split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. + + eapply Z.lt_le_trans. + rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 64)) toword1) in H9 ; [ | easy]. + apply H9. + easy. + + split. + apply Z.lor_nonneg. split. repeat apply Z.mul_nonneg_nonneg ; easy. + easy. + + apply (Z_lor_pow2 (toword2 * _)%Z _ nat127.+1). + + split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. + eapply Z.lt_le_trans. + rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 96)) toword2) in H11 ; [ | easy]. + apply H11. + easy. + easy. + } + } + { + destruct a₁0, a₁1, a₁2, a₁3. +rewrite !Z.shiftl_lor. + rewrite !Z.shiftl_mul_pow2 ; try easy. + rewrite !Z.mul_0_l. + rewrite Z.lor_0_r. + replace (int_to_Z (Posz 32)) with 32%Z by reflexivity. + + destruct (ssrbool.elimT (iswordZP _ _) i). + destruct (ssrbool.elimT (iswordZP _ _) i0). + destruct (ssrbool.elimT (iswordZP _ _) i1). + destruct (ssrbool.elimT (iswordZP _ _) i2). + split. + { + apply Z.lor_nonneg. split. easy. + apply Z.lor_nonneg. split. apply Z.mul_nonneg_nonneg ; easy. + apply Z.lor_nonneg. split. repeat apply Z.mul_nonneg_nonneg ; easy. + repeat apply Z.mul_nonneg_nonneg ; easy. + } + { + rewrite <- !Z.mul_assoc. + rewrite <- !Z.pow_add_r ; try easy. + simpl. + + apply (Z_lor_pow2 toword _ nat127.+1). split ; [ easy | ]. + eapply Z.lt_trans ; [apply H0 | easy]. + + apply (Z_lor_pow2 (toword0 * _)%Z _ nat127.+1). split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. + eapply Z.lt_le_trans. + apply (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 32)) toword0) in H6 ; [ | easy]. + apply H6. + easy. + + apply (Z_lor_pow2 (toword1 * _)%Z _ nat127.+1). split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. + + eapply Z.lt_le_trans. + rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 64)) toword1) in H9 ; [ | easy]. + apply H9. + easy. + + split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. + eapply Z.lt_le_trans. + rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 96)) toword2) in H11 ; [ | easy]. + apply H11. + easy. + } + } + } + { + cbn. + apply r_ret. + intros. + split. + reflexivity. + apply H. + } + { + (* TODO: Next vshufs *) + admit. + } + { + admit. + } + { + admit. + } + Admitted. Lemma foo id0 rcon rkey temp2 : ⊢ ⦃ fun '(_, _) => True ⦄ From b3de40314da5f8c44b9139c197c89074ef55378e Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Tue, 20 Dec 2022 13:31:10 +0100 Subject: [PATCH 326/383] Done showing key_combined (needs cleanup) --- theories/Jasmin/examples/aes/aes_hac.v | 490 +++++++++++++++++++++++-- 1 file changed, 465 insertions(+), 25 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes_hac.v b/theories/Jasmin/examples/aes/aes_hac.v index 8fc27e64..87b23115 100644 --- a/theories/Jasmin/examples/aes/aes_hac.v +++ b/theories/Jasmin/examples/aes/aes_hac.v @@ -103,7 +103,7 @@ Section Hacspec. reflexivity | ]. Notation JVSHUFPS i rkey temp1 temp2 := (trc VSHUFPS i [('word U128 ; rkey) ; ('word U128 ; temp1) ; ('word U128 ; temp2)]). - + Lemma wpshufd_eq : forall (rkey : 'word U128) (i : nat), i < 4 -> @@ -174,7 +174,7 @@ Section Hacspec. rewrite wpshufd_eq ; [ | apply H0 ]. now apply r_ret. Qed. - + Ltac match_wpshufd1_vpshufd1 := (let w := fresh in @@ -226,7 +226,7 @@ Section Hacspec. destruct a. eapply Z.lt_trans ; [ apply H1 | apply H]. Qed. - + Lemma shift_left_4_byte_ok : (forall i (a : 'word U32), i < 4 -> @@ -245,7 +245,7 @@ Section Hacspec. apply H1. destruct i as [ | [ | [ | [ | []] ]] ] ; easy. Qed. - + Lemma key_combined_eq id0 rcon rkey temp2 : ⊢ ⦃ fun '(_, _) => True ⦄ JKEY_COMBINE id0 rcon rkey temp2 @@ -287,7 +287,7 @@ Section Hacspec. Unshelve. { (* rewrite !zero_extend_u. *) - + unfold tr_app_sopn_tuple. unfold sopn_sem. unfold sopn.get_instr_desc. @@ -303,7 +303,7 @@ Section Hacspec. unfold ".1". unfold x86_VPSHUFD. unfold wpshufd. - + set (totce _) at 2. cbn in t. unfold totce in t. @@ -366,7 +366,7 @@ Section Hacspec. split ; [ | eexists ; apply H7 ]. apply word_ext. - + unfold wcat_r. unfold ".|". @@ -390,7 +390,7 @@ Section Hacspec. unfold mkword. unfold toword. unfold Hacspec_Lib_Pre.unsigned. - + rewrite !Zmod_small. all: try easy. @@ -403,7 +403,7 @@ Section Hacspec. setoid_rewrite <- Z.lor_assoc. setoid_rewrite <- Z.lor_assoc. f_equal. - + symmetry. rewrite <- Z.lor_comm. rewrite <- Z.lor_assoc. @@ -510,9 +510,9 @@ Section Hacspec. subst n. hnf. unfold sopn_sem, tr_app_sopn_tuple, tr_app_sopn_single. - + unfold vshufps. - + match_wpshufd1_vpshufd1. set (ret _). @@ -531,7 +531,7 @@ Section Hacspec. apply (ssrbool.elimT (iswordZP _ _)). apply i. } - + replace (wpack U8 2 _) with (wrepr U8 16) by now do 2 (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). replace (Hacspec_Lib_Pre.pub_u8 (is_pure @@ -575,7 +575,7 @@ Section Hacspec. apply (ssrbool.elimT (iswordZP _ _)). apply i. } - + replace (wpack U8 2 _) with (wrepr U8 16) by now do 2 (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). replace (Hacspec_Lib_Pre.pub_u8 (is_pure @@ -600,7 +600,7 @@ Section Hacspec. f_equal. intros. - + match_wpshufd1_vpshufd1. set (ret _). @@ -619,7 +619,7 @@ Section Hacspec. apply (ssrbool.elimT (iswordZP _ _)). apply i. } - + replace (wpack U8 2 _) with (wrepr U8 16) by now do 2 (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). replace (Hacspec_Lib_Pre.pub_u8 (is_pure @@ -662,7 +662,7 @@ Section Hacspec. apply (ssrbool.elimT (iswordZP _ _)). apply i. } - + replace (wpack U8 2 _) with (wrepr U8 16) by now do 2 (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). replace (Hacspec_Lib_Pre.pub_u8 (is_pure @@ -687,7 +687,7 @@ Section Hacspec. f_equal. intros. - + apply r_ret. intros. @@ -723,7 +723,7 @@ Section Hacspec. unfold mkword. unfold toword. unfold Hacspec_Lib_Pre.unsigned. - + rewrite !Zmod_small. all: try easy. @@ -740,12 +740,12 @@ Section Hacspec. rewrite !Z.shiftl_lor. f_equal. - + apply (shift_left_4_byte_ok 3) ; easy. apply (shift_left_4_byte_ok 2) ; easy. apply (shift_left_4_byte_ok 1) ; easy. - - + + destruct a₁0, a₁1, a₁2, a₁3. rewrite !Z.shiftl_lor. rewrite !Z.shiftl_mul_pow2 ; try easy. @@ -904,15 +904,455 @@ rewrite !Z.shiftl_lor. } { (* TODO: Next vshufs *) - admit. + { + + unfold tr_app_sopn_tuple. + unfold sopn_sem. + unfold sopn.get_instr_desc. + unfold asm_opI. + unfold asm_op_instr. + unfold semi, arch_extra.get_instr_desc. + unfold instr_desc, _asm_op_decl, instr_desc_op, _asm, x86_extra. + unfold x86_sem.x86. + unfold x86_op_decl. + unfold x86_instr_desc. + unfold id_semi. + unfold Ox86_VPSHUFD_instr. + unfold ".1". + unfold x86_VPSHUFD. + unfold wpshufd. + + set (totce _) at 2. + cbn in t. + unfold totce in t. + + set (chCanonical _). + cbn in s. + subst s. + + set (tr_app_sopn _ _ _ _). + cbn in y. + subst y. + hnf. + + unfold totce. + subst t. + unfold ".π2". + + unfold wshufps_128. + unfold lift2_vec. + unfold make_vec. + rewrite map2E. + unfold zip. + unfold split_vec. + unfold map. + unfold iota. + + set (nat_of_wsize U128 %/ nat_of_wsize U128 + + nat_of_wsize U128 %% nat_of_wsize U128). + cbn in n. + subst n. + hnf. + unfold sopn_sem, tr_app_sopn_tuple, tr_app_sopn_single. + + unfold vshufps. + + match_wpshufd1_vpshufd1. + + set (ret _). + simpl in r. + subst r. + rewrite !zero_extend_u. + replace (word.subword _ _ a₁0) with a₁0. + 2:{ + destruct a₁0. + cbn. + apply word_ext. + cbn. + rewrite Zmod_mod. + rewrite Zmod_small. + reflexivity. + apply (ssrbool.elimT (iswordZP _ _)). + apply i. + } + + replace (wpack U8 2 _) with (wrepr U8 140) by now do 3 (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). + + replace (Hacspec_Lib_Pre.pub_u8 + (is_pure + (lift_to_both0 + (is_pure (lift_to_both0 (Hacspec_Lib_Pre.usize 140)))))) with (Hacspec_Lib_Pre.repr (WS := U8) 140) by reflexivity. + + apply r_ret. + intros. + split ; [ | assumption ]. + remove_T_ct. + Opaque Z.mul. + clear. + intros. + unfold vpshufd1. + unfold wpshufd1. + simpl. + apply word_ext. + f_equal. + simpl. + rewrite Zmod_mod. + unfold Hacspec_Lib_Pre.shift_right_, wshr, lsr, Hacspec_Lib_Pre.unsigned, wunsigned ; rewrite mkwordK. + f_equal. + + intros. + + match_wpshufd1_vpshufd1. + + set (ret _). + simpl in r. + subst r. + rewrite !zero_extend_u. + replace (word.subword _ _ a₁0) with a₁0. + 2:{ + destruct a₁0. + cbn. + apply word_ext. + cbn. + rewrite Zmod_mod. + rewrite Zmod_small. + reflexivity. + apply (ssrbool.elimT (iswordZP _ _)). + apply i. + } + + replace (wpack U8 2 _) with (wrepr U8 140) by now do 3 (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). + replace (Hacspec_Lib_Pre.pub_u8 + (is_pure + (lift_to_both0 + (is_pure (lift_to_both0 (Hacspec_Lib_Pre.usize 140)))))) with (Hacspec_Lib_Pre.repr (WS := U8) 140) by reflexivity. + + apply r_ret. + intros. + split ; [ | assumption ]. + remove_T_ct. + Opaque Z.mul. + clear. + intros. + unfold vpshufd1. + unfold wpshufd1. + simpl. + apply word_ext. + f_equal. + simpl. + rewrite Zmod_mod. + unfold Hacspec_Lib_Pre.shift_right_, wshr, lsr, Hacspec_Lib_Pre.unsigned, wunsigned ; rewrite mkwordK. + f_equal. + + intros. + + match_wpshufd1_vpshufd1. + + set (ret _). + simpl in r. + subst r. + rewrite !zero_extend_u. + replace (word.subword _ _ a₁1) with a₁1. + 2:{ + destruct a₁1. + cbn. + apply word_ext. + cbn. + rewrite Zmod_mod. + rewrite Zmod_small. + reflexivity. + apply (ssrbool.elimT (iswordZP _ _)). + apply i. + } + + replace (wpack U8 2 _) with (wrepr U8 140) by now do 3 (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). + replace (Hacspec_Lib_Pre.pub_u8 + (is_pure + (lift_to_both0 + (is_pure (lift_to_both0 (Hacspec_Lib_Pre.usize 140)))))) with (Hacspec_Lib_Pre.repr (WS := U8) 140) by reflexivity. + + apply r_ret. + intros. + split ; [ | assumption ]. + remove_T_ct. + Opaque Z.mul. + clear. + intros. + unfold vpshufd1. + unfold wpshufd1. + simpl. + apply word_ext. + f_equal. + simpl. + rewrite Zmod_mod. + unfold Hacspec_Lib_Pre.shift_right_, wshr, lsr, Hacspec_Lib_Pre.unsigned, wunsigned ; rewrite mkwordK. + f_equal. + + intros. + match_wpshufd1_vpshufd1. + + set (ret _). + simpl in r. + subst r. + rewrite !zero_extend_u. + replace (word.subword _ _ a₁1) with a₁1. + 2:{ + destruct a₁1. + cbn. + apply word_ext. + cbn. + rewrite Zmod_mod. + rewrite Zmod_small. + reflexivity. + apply (ssrbool.elimT (iswordZP _ _)). + apply i. + } + + replace (wpack U8 2 _) with (wrepr U8 140) by now do 3 (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). + replace (Hacspec_Lib_Pre.pub_u8 + (is_pure + (lift_to_both0 + (is_pure (lift_to_both0 (Hacspec_Lib_Pre.usize 140)))))) with (Hacspec_Lib_Pre.repr (WS := U8) 140) by reflexivity. + + apply r_ret. + intros. + split ; [ | assumption ]. + remove_T_ct. + Opaque Z.mul. + clear. + intros. + unfold vpshufd1. + unfold wpshufd1. + simpl. + apply word_ext. + f_equal. + simpl. + rewrite Zmod_mod. + unfold Hacspec_Lib_Pre.shift_right_, wshr, lsr, Hacspec_Lib_Pre.unsigned, wunsigned ; rewrite mkwordK. + f_equal. + + intros. + + apply r_ret. + + intros. + destruct H as [? [? [? [? [? [[]]]]]]]. + subst. + split. + 2:{ + unfold H2. + exists x. easy. + } + + apply word_ext. + unfold wcat_r. + + unfold ".|". + unfold "_ shift_left _". + unfold Hacspec_Lib_Pre.shift_left_. + unfold Hacspec_Lib_Pre.int_or. + unfold Hacspec_Lib_Pre.repr. + unfold Hacspec_Lib_Pre.from_uint_size. + unfold Hacspec_Lib_Pre.usize. + unfold Hacspec_Lib_Pre.Z_uint_sizeable. + unfold Hacspec_Lib_Pre.unsigned. + unfold cast_int. + unfold lift_to_both0 , lift_to_both, is_pure. + unfold word.wor, wor. + unfold wshl, lsl. + unfold wrepr, wunsigned, urepr, val, word_subType, mkword, toword. + unfold Hacspec_Lib_Pre.repr. + unfold Hacspec_Lib_Pre.nat_uint_sizeable. + unfold Hacspec_Lib_Pre.repr. + unfold wrepr. + unfold mkword. + unfold toword. + unfold Hacspec_Lib_Pre.unsigned. + + rewrite !Zmod_small. + + all: try easy. + all: try (apply (num_smaller_if_modulus_smaller) ; easy). + + setoid_rewrite <- Z.lor_assoc. + setoid_rewrite <- Z.lor_assoc. + f_equal. + + rewrite Z.shiftl_0_l. + rewrite Z.lor_0_r. + rewrite Z.shiftl_0_l. + rewrite Z.lor_0_r. + + rewrite !Z.shiftl_lor. + f_equal. + + apply (shift_left_4_byte_ok 3) ; easy. + apply (shift_left_4_byte_ok 2) ; easy. + apply (shift_left_4_byte_ok 1) ; easy. + + + destruct a₁2, a₁3, a₁4, a₁5. + rewrite !Z.shiftl_lor. + rewrite !Z.shiftl_mul_pow2 ; try easy. + rewrite !Z.mul_0_l. + rewrite Z.lor_0_r. + replace (int_to_Z (Posz 32)) with 32%Z by reflexivity. + + destruct (ssrbool.elimT (iswordZP _ _) i). + destruct (ssrbool.elimT (iswordZP _ _) i0). + destruct (ssrbool.elimT (iswordZP _ _) i1). + destruct (ssrbool.elimT (iswordZP _ _) i2). + split. + { + apply Z.lor_nonneg. split. easy. + apply Z.lor_nonneg. split. apply Z.mul_nonneg_nonneg ; easy. + apply Z.lor_nonneg. split. repeat apply Z.mul_nonneg_nonneg ; easy. + repeat apply Z.mul_nonneg_nonneg ; easy. + } + { + rewrite <- !Z.mul_assoc. + rewrite <- !Z.pow_add_r ; try easy. + simpl. + + apply (Z_lor_pow2 toword _ nat127.+1). split ; [ easy | ]. + eapply Z.lt_trans ; [apply H0 | easy]. + + apply (Z_lor_pow2 (toword0 * _)%Z _ nat127.+1). split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. + eapply Z.lt_le_trans. + apply (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 32)) toword0) in H6 ; [ | easy]. + apply H6. + easy. + + apply (Z_lor_pow2 (toword1 * _)%Z _ nat127.+1). split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. + + eapply Z.lt_le_trans. + rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 64)) toword1) in H9 ; [ | easy]. + apply H9. + easy. + + split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. + eapply Z.lt_le_trans. + rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 96)) toword2) in H11 ; [ | easy]. + apply H11. + easy. + } + { + destruct a₁2, a₁3, a₁4, a₁5. +rewrite !Z.shiftl_lor. + rewrite !Z.shiftl_mul_pow2 ; try easy. + rewrite !Z.mul_0_l. + rewrite Z.lor_0_r. + replace (int_to_Z (Posz 32)) with 32%Z by reflexivity. + + destruct (ssrbool.elimT (iswordZP _ _) i). + destruct (ssrbool.elimT (iswordZP _ _) i0). + destruct (ssrbool.elimT (iswordZP _ _) i1). + destruct (ssrbool.elimT (iswordZP _ _) i2). + split. + { + apply Z.lor_nonneg. split. easy. + apply Z.lor_nonneg. split. apply Z.mul_nonneg_nonneg ; easy. + apply Z.lor_nonneg. split. repeat apply Z.mul_nonneg_nonneg ; easy. + apply Z.lor_nonneg. split. repeat apply Z.mul_nonneg_nonneg ; easy. + easy. + } + { + rewrite <- !Z.mul_assoc. + rewrite <- !Z.pow_add_r ; try easy. + simpl. + + apply (Z_lor_pow2 toword _ nat127.+1). split ; [ easy | ]. + eapply Z.lt_trans ; [apply H0 | easy]. + + apply (Z_lor_pow2 (toword0 * _)%Z _ nat127.+1). split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. + eapply Z.lt_le_trans. + apply (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 32)) toword0) in H6 ; [ | easy]. + apply H6. + easy. + + apply (Z_lor_pow2 (toword1 * _)%Z _ nat127.+1). split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. + + eapply Z.lt_le_trans. + rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 64)) toword1) in H9 ; [ | easy]. + apply H9. + easy. + + split. + apply Z.lor_nonneg. split. repeat apply Z.mul_nonneg_nonneg ; easy. + easy. + + apply (Z_lor_pow2 (toword2 * _)%Z _ nat127.+1). + + split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. + eapply Z.lt_le_trans. + rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 96)) toword2) in H11 ; [ | easy]. + apply H11. + easy. + easy. + } + } + { + destruct a₁2, a₁3, a₁4, a₁5. + rewrite !Z.shiftl_lor. + rewrite !Z.shiftl_mul_pow2 ; try easy. + rewrite !Z.mul_0_l. + rewrite Z.lor_0_r. + replace (int_to_Z (Posz 32)) with 32%Z by reflexivity. + + destruct (ssrbool.elimT (iswordZP _ _) i). + destruct (ssrbool.elimT (iswordZP _ _) i0). + destruct (ssrbool.elimT (iswordZP _ _) i1). + destruct (ssrbool.elimT (iswordZP _ _) i2). + split. + { + apply Z.lor_nonneg. split. easy. + apply Z.lor_nonneg. split. apply Z.mul_nonneg_nonneg ; easy. + apply Z.lor_nonneg. split. repeat apply Z.mul_nonneg_nonneg ; easy. + repeat apply Z.mul_nonneg_nonneg ; easy. + } + { + rewrite <- !Z.mul_assoc. + rewrite <- !Z.pow_add_r ; try easy. + simpl. + + apply (Z_lor_pow2 toword _ nat127.+1). split ; [ easy | ]. + eapply Z.lt_trans ; [apply H0 | easy]. + + apply (Z_lor_pow2 (toword0 * _)%Z _ nat127.+1). split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. + eapply Z.lt_le_trans. + apply (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 32)) toword0) in H6 ; [ | easy]. + apply H6. + easy. + + apply (Z_lor_pow2 (toword1 * _)%Z _ nat127.+1). split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. + + eapply Z.lt_le_trans. + rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 64)) toword1) in H9 ; [ | easy]. + apply H9. + easy. + + split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. + eapply Z.lt_le_trans. + rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 96)) toword2) in H11 ; [ | easy]. + apply H11. + easy. + } + } + } } { - admit. + apply r_ret. + intros. + split ; [ now destruct_pre | apply H ]. } { - admit. + apply r_ret. + intros. + split ; [ now destruct_pre | apply H ]. } - Admitted. + (* Cleanup *) + Transparent translate_call. + Qed. Lemma foo id0 rcon rkey temp2 : ⊢ ⦃ fun '(_, _) => True ⦄ From 3bc642daa6baf58fb7dcc5264b814e2eb2b42850 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Tue, 20 Dec 2022 15:06:09 +0100 Subject: [PATCH 327/383] Structure of key_expand_eq done (aes_hac) --- theories/Jasmin/examples/aes/aes_hac.v | 149 ++++++++++++++++++++----- 1 file changed, 123 insertions(+), 26 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes_hac.v b/theories/Jasmin/examples/aes/aes_hac.v index 87b23115..109695b0 100644 --- a/theories/Jasmin/examples/aes/aes_hac.v +++ b/theories/Jasmin/examples/aes/aes_hac.v @@ -85,9 +85,9 @@ Section Hacspec. Ltac bind_jazz_hac := match goal with | [ |- context [ ⊢ ⦃ ?P ⦄ putr ?l ?jazz ?f ≈ _ ⦃ ?Q ⦄ ] ] => - eapply (@r_bind _ _ _ _ (ret jazz) _ (fun x => putr l x f) _ _ (fun '(v0, h0) '(v1, h1) => v0 = v1 /\ P (h0, h1)) _) ; [ rewrite !zero_extend_u | intros ; unfold pre_to_post ] + eapply (@r_bind _ _ _ _ (ret jazz) _ (fun x => putr l x f) _ _ (fun '(v0, h0) '(v1, h1) => v0 = v1 /\ P (h0, h1)) _) ; [ rewrite !zero_extend_u | intros ] end. - + (* match goal with *) (* | [ |- context [ ⊢ ⦃ ?P ⦄ putr ?l ?jazz ?f ≈ _ ⦃ ?Q ⦄ ] ] => *) (* apply (@r_bind _ _ _ _ (ret jazz) _ (fun x => putr l x f) _ _ Q _) ; [ | intros ; unfold pre_to_post ] *) @@ -975,7 +975,7 @@ rewrite !Z.shiftl_lor. apply (ssrbool.elimT (iswordZP _ _)). apply i. } - + replace (wpack U8 2 _) with (wrepr U8 140) by now do 3 (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). replace (Hacspec_Lib_Pre.pub_u8 @@ -1064,7 +1064,7 @@ rewrite !Z.shiftl_lor. apply (ssrbool.elimT (iswordZP _ _)). apply i. } - + replace (wpack U8 2 _) with (wrepr U8 140) by now do 3 (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). replace (Hacspec_Lib_Pre.pub_u8 (is_pure @@ -1342,47 +1342,144 @@ rewrite !Z.shiftl_lor. } { apply r_ret. - intros. - split ; [ now destruct_pre | apply H ]. + solve_post_from_pre. } { apply r_ret. - intros. - split ; [ now destruct_pre | apply H ]. + solve_post_from_pre. } (* Cleanup *) Transparent translate_call. Qed. - Lemma foo id0 rcon rkey temp2 : + Ltac bind_jazz_bind := + match goal with + | [ |- context [ ⊢ ⦃ ?P ⦄ putr ?l ?y ?g ≈ bind ?a ?f ⦃ ?Q ⦄ ] ] => + let yv := fresh in + let gv := fresh in + let av := fresh in + let fv := fresh in + set l + ; set (yv := y) + ; set (gv := g) + ; set (av := a) + ; set (fv := f) + ; apply (r_bind (ret yv) (av) (fun x => putr l x gv) fv P (fun '(v0, h0) '(v1, h1) => v0 = v1 /\ P (h0, h1)) Q) ; [ | intros ] + ; subst yv gv av fv ; hnf + end. + + Lemma key_expand_eq id0 rcon rkey temp2 : ⊢ ⦃ fun '(_, _) => True ⦄ - JKEY_COMBINE id0 rcon rkey temp2 + JKEY_EXPAND id0 rcon rkey temp2 ≈ - is_state (key_combine rcon rkey temp2) + key_expand (wrepr U8 rcon) rkey temp2 ⦃ fun '(v0, _) '(v1, _) => exists o1 o2, v0 = [('word U128 ; o1) ; ('word U128 ; o2)] /\ (o1, o2) = v1 ⦄. Proof. - unfold translate_call, translate_call_body. + set (JKEY_EXPAND _ _ _ _). + unfold translate_call, translate_call_body in r |- *. Opaque translate_call. + simpl in r. + subst r. + rewrite !zero_extend_u. - simpl. - unfold sopn_sem, tr_app_sopn_tuple, tr_app_sopn_single. - simpl. + apply better_r_put_lhs. + apply better_r_put_lhs. + apply better_r_put_lhs. - Admitted. + do 2 remove_get_in_lhs. + bind_jazz_hac ; [shelve | ]. - Lemma bar id0 rcon rkey temp2 : - ⊢ ⦃ fun '(_, _) => True ⦄ - JKEY_EXPAND id0 rcon rkey temp2 - ≈ - key_expand (wrepr U8 rcon) rkey temp2 - ⦃ fun '(v0, _) '(v1, _) => - exists o1 o2, v0 = [('word U128 ; o1) ; ('word U128 ; o2)] - /\ (o1, o2) = v1 ⦄. - Proof. + apply better_r_put_lhs. + do 3 remove_get_in_lhs. + + (* Unfold next call *) Transparent translate_call. - unfold translate_call, translate_call_body. + match goal with + | [ |- context [ ⊢ ⦃ ?P ⦄ ?s ≈ _ ⦃ ?Q ⦄ ] ] => + let H := fresh in + set (H := s) + ; unfold translate_call, translate_call_body in H + ; simpl in H + ; unfold tr_app_sopn, sopn_sem, tr_app_sopn_tuple, tr_app_sopn_single in H + ; simpl in H + ; subst H + ; rewrite !zero_extend_u + end. Opaque translate_call. + + apply better_r_put_lhs. + apply better_r_put_lhs. + apply better_r_put_lhs. + + remove_get_in_lhs. + unfold key_combine. + + rewrite !zero_extend_u. + + setoid_rewrite bind_assoc ; bind_jazz_bind ; [shelve | ]. + apply better_r_put_lhs. + do 2 remove_get_in_lhs. + rewrite !zero_extend_u. + + setoid_rewrite bind_assoc ; bind_jazz_bind ; [shelve | ]. + apply better_r_put_lhs. + do 2 remove_get_in_lhs. + rewrite !zero_extend_u. + + setoid_rewrite bind_assoc ; bind_jazz_bind ; [shelve | ]. + apply better_r_put_lhs. + do 2 remove_get_in_lhs. + rewrite !zero_extend_u. + + setoid_rewrite bind_assoc ; bind_jazz_bind ; [shelve | ]. + apply better_r_put_lhs. + do 2 remove_get_in_lhs. + rewrite !zero_extend_u. + + setoid_rewrite bind_assoc ; bind_jazz_bind ; [shelve | ]. + apply better_r_put_lhs. + do 2 remove_get_in_lhs. + rewrite !zero_extend_u. + + setoid_rewrite bind_assoc ; bind_jazz_bind ; [shelve | ]. + apply better_r_put_lhs. + do 2 remove_get_in_lhs. + rewrite !zero_extend_u. + apply better_r_put_lhs. + apply better_r_put_lhs. + do 2 remove_get_in_lhs. + + apply r_ret. + intros. + eexists. + eexists. + split. + reflexivity. simpl. + rewrite !T_ct_id. + rewrite !zero_extend_u. + reflexivity. + + Unshelve. + { + (* Keygen assist *) + admit. + } + { + (* wpshufd_128 _ 255 *) + admit. + } + { + (* wshufps_128 _ 16 *) + admit. + } + { + (* xor *) + apply r_ret. + solve_post_from_pre. + } + + Transparent translate_call. Admitted. From 3ca70993a95cfbdc981adbb735ead11b3f1785f7 Mon Sep 17 00:00:00 2001 From: bshvass Date: Tue, 20 Dec 2022 15:57:17 +0100 Subject: [PATCH 328/383] first attempt at computing locations; note VERY slow --- _CoqProject | 2 + theories/Jasmin/examples/aes/aes_valid.v | 399 +++++++++++++++++++++++ 2 files changed, 401 insertions(+) create mode 100644 theories/Jasmin/examples/aes/aes_valid.v diff --git a/_CoqProject b/_CoqProject index f2e14383..c343a7aa 100644 --- a/_CoqProject +++ b/_CoqProject @@ -101,6 +101,8 @@ theories/Jasmin/examples/two_functions.v theories/Jasmin/examples/u64_incr.v theories/Jasmin/examples/xor.v +theories/Jasmin/examples/aes/aes_valid.v + theories/Jasmin/examples/xor/xor.v # Examples diff --git a/theories/Jasmin/examples/aes/aes_valid.v b/theories/Jasmin/examples/aes/aes_valid.v new file mode 100644 index 00000000..a41d87ee --- /dev/null +++ b/theories/Jasmin/examples/aes/aes_valid.v @@ -0,0 +1,399 @@ +From JasminSSProve Require Import jasmin_translate. + +From Relational Require Import OrderEnrichedCategory GenericRulesSimple. + +Set Warnings "-notation-overridden,-ambiguous-paths". +From mathcomp Require Import all_ssreflect all_algebra reals distr realsum + ssrnat ssreflect ssrfun ssrbool ssrnum eqtype choice seq word word.ssrZ. +Set Warnings "notation-overridden,ambiguous-paths". + +From Mon Require Import SPropBase. +From Crypt Require Import Axioms ChoiceAsOrd SubDistr Couplings + UniformDistrLemmas FreeProbProg Theta_dens RulesStateProb + pkg_core_definition choice_type pkg_composition pkg_rhl Package Prelude. + +From Coq Require Import Utf8. +From extructures Require Import ord fset fmap. + +Import SPropNotations. + +Import PackageNotation. + +From Equations Require Import Equations. +Require Equations.Prop.DepElim. + +Set Equations With UIP. + +Set Bullet Behavior "Strict Subproofs". +Set Default Goal Selector "!". +Set Primitive Projections. + +Import Num.Def. +Import Num.Theory. +Import Order.POrderTheory. + +From JasminSSProve Require Import aes_jazz jasmin_utils. +From Jasmin Require Import expr sem. + +Import JasminNotation JasminCodeNotation. + +Require Import String. +Local Open Scope string. + +Local Open Scope positive_scope. + +Ltac esolve_in := + rewrite in_fset; apply/xseq.InP; + repeat lazymatch goal with + | |- List.In _ (_ :: _) => eapply List.in_cons + | |- _ => eapply List.in_eq + end. + +Ltac tr_inseq_try := + apply/orP ; first [ left ; rewrite translate_var_eq eq_refl ; reflexivity + | right ; tr_inseq_try ]. + +Ltac tr_inset_try := + rewrite in_fset ; tr_inseq_try. + +Ltac tr_auto_in_fset := + eauto ; + try tr_inset_try. + +Ltac until_call := + simpl; repeat match goal with + | |- ValidCode _ _ _ => red + | |- valid_code _ _ (_ ← translate_call _ _ _ _ _ ;; _) => eapply valid_bind + | |- valid_code _ _ (_ ← (x ← _ ;; _) ;; _) => rewrite bind_assoc + | |- _ => constructor; [solve [ tr_auto_in_fset | esolve_in ]| ]; intros + | |- _ -> _ => intros + end. + +Lemma valid_code_cons {A} a l I (c : raw_code A) : + valid_code (fset l) I c -> valid_code (fset (a :: l)) I c. +Proof. + intros. + induction c; econstructor. + - apply inversion_valid_opr in H as []. easy. + - intros. apply H0. apply inversion_valid_opr in H as []. easy. + - apply inversion_valid_getr in H as []. rewrite in_fset in_cons. apply/orP; right. rewrite -in_fset. easy. + - intros. apply H0. apply inversion_valid_getr in H as []. easy. + - apply inversion_valid_putr in H as []. rewrite in_fset in_cons. apply/orP; right. rewrite -in_fset. easy. + - apply inversion_valid_putr in H as []. apply IHc. easy. + - intros. apply H0. eapply inversion_valid_sampler. easy. +Qed. + +Lemma valid_code_catC {A} l1 l2 I (c : raw_code A) : + valid_code (fset (l1 ++ l2)) I c -> valid_code (fset (l2 ++ l1)) I c. +Proof. by rewrite !fset_cat fsetUC. Qed. + +Lemma valid_code_cat_r {A} l1 l2 I (c : raw_code A) : + valid_code (fset l1) I c -> valid_code (fset (l1 ++ l2)) I c. +Proof. + intros. + induction l2. + - rewrite cats0. easy. + - apply valid_code_catC. simpl. apply valid_code_cons. apply valid_code_catC. easy. +Qed. + +Lemma valid_code_cat_l {A} l1 l2 I (c : raw_code A) : + valid_code (fset l2) I c -> valid_code (fset (l1 ++ l2)) I c. +Proof. intros; apply valid_code_catC. apply valid_code_cat_r. easy. Qed. + +Lemma valid_translate_write_lvals1 I id0 (v : var_i) vs : + valid_code (fset [:: translate_var id0 v]) I (translate_write_lvals [::] id0 [:: (Lvar v)] vs) . +Proof. + destruct vs. + - constructor. + - constructor. + 1: auto_in_fset. + constructor. +Qed. + +Lemma valid_translate_write_lvals2 I id0 (v1 v2 : var_i) vs : + valid_code (fset [:: translate_var id0 v1 ; translate_var id0 v2]) I (translate_write_lvals [::] id0 [:: (Lvar v1) ; (Lvar v2)] vs) . +Proof. + destruct vs. + - constructor. + - constructor. + 1: auto_in_fset. + destruct vs. + + constructor. + + constructor. + 1: auto_in_fset. + constructor. +Qed. + +Ltac clear_fset := + repeat match goal with + | |- ValidCode _ _ _ => red + | |- valid_code (fset (_ :: _)) _ _ => eapply valid_code_cons + | |- valid_code (fset (_ ++ _)) _ _ => eapply valid_code_cat_l + end; eapply valid_code_cat_r. + +Ltac fix_lvals1 := clear_fset; eapply valid_translate_write_lvals1. +Ltac fix_lvals2 := clear_fset; eapply valid_translate_write_lvals2. + +(* Definition Jvars {A} : raw_code -> {fset Location}. *) + +Lemma JRCON_valid id0 : + ∑ L, forall I j, ValidCode (fset L) I (JRCON id0 j). +Proof. + eexists. + intros I j. + unfold JRCON. + unfold get_translated_static_fun, translate_prog_static, translate_funs_static, translate_call_body. + simpl. unfold ValidCode. + repeat match goal with + | |- context[BinInt.Z.eqb _ _] => rewrite ?coerce_to_choice_type_K; destruct (BinInt.Z.eqb _ _) + | |- valid_code _ _ _ => constructor + | |- is_true (_ \in _) => solve [ tr_auto_in_fset | esolve_in ] + | _ => intros + end. + Unshelve. exact [::]. +Defined. + +Definition JRCON_locs id0 : {fset Location} := fset (JRCON_valid id0).π1. + +Lemma JKEY_EXPAND_valid id0 : + ∑ L, forall I rcon rkey temp2, ValidCode (fset L) I (JKEY_EXPAND id0 rcon rkey temp2). +Proof. + eexists. + intros rcon rkey temp2. + unfold JRCON. + unfold get_translated_static_fun, translate_prog_static, translate_funs_static, translate_call_body. + simpl. unfold ValidCode. + repeat match goal with + | |- valid_code _ _ _ => constructor + | |- is_true (_ \in _) => solve [ tr_auto_in_fset | esolve_in ] + | _ => intros + end. + Unshelve. exact [::]. +Defined. + +Definition JKEY_EXPAND_locs id0 : {fset Location} := fset (JKEY_EXPAND_valid id0).π1. + +Lemma JKEYS_EXPAND_valid id0 : + ∑ L, forall I rkey, ValidCode (fset L) I (JKEYS_EXPAND id0 rkey). +Proof. + eexists. + intros. + unfold JAES. + unfold get_translated_static_fun, translate_prog_static, translate_funs_static, translate_call_body. + (* Opaque translate_for. *) + Opaque translate_call. + simpl. + unfold translate_for. + rewrite !coerce_typed_code_K. + + Ltac fix_rcon := clear_fset; eapply (JRCON_valid _).π2. + Ltac fix_key_expand := clear_fset; eapply (JKEY_EXPAND_valid _).π2. + + until_call. + 1: fix_rcon. + eapply valid_bind. + 1: fix_lvals1. + + until_call. + 1: fix_key_expand. + eapply valid_bind. + 1: fix_lvals2. + + until_call. + 1: fix_rcon. + eapply valid_bind. + 1: fix_lvals1. + + until_call. + 1: fix_key_expand. + eapply valid_bind. + 1: fix_lvals2. + + until_call. + 1: fix_rcon. + eapply valid_bind. + 1: fix_lvals1. + + until_call. + 1: fix_key_expand. + eapply valid_bind. + 1: fix_lvals2. + + until_call. + 1: fix_rcon. + eapply valid_bind. + 1: fix_lvals1. + + until_call. + 1: fix_key_expand. + eapply valid_bind. + 1: fix_lvals2. + + until_call. + 1: fix_rcon. + eapply valid_bind. + 1: fix_lvals1. + + until_call. + 1: fix_key_expand. + eapply valid_bind. + 1: fix_lvals2. + + until_call. + 1: fix_rcon. + eapply valid_bind. + 1: fix_lvals1. + + until_call. + 1: fix_key_expand. + eapply valid_bind. + 1: fix_lvals2. + + until_call. + 1: fix_rcon. + eapply valid_bind. + 1: fix_lvals1. + + until_call. + 1: fix_key_expand. + eapply valid_bind. + 1: fix_lvals2. + + until_call. + 1: fix_rcon. + eapply valid_bind. + 1: fix_lvals1. + + until_call. + 1: fix_key_expand. + eapply valid_bind. + 1: fix_lvals2. + + until_call. + 1: fix_rcon. + eapply valid_bind. + 1: fix_lvals1. + + until_call. + 1: fix_key_expand. + eapply valid_bind. + 1: fix_lvals2. + + until_call. + 1: fix_rcon. + eapply valid_bind. + 1: fix_lvals1. + + until_call. + 1: fix_key_expand. + eapply valid_bind. + 1: fix_lvals2. + + constructor; [solve [ tr_auto_in_fset | esolve_in ]| ]. + constructor; [solve [ tr_auto_in_fset | esolve_in ]| ]. + constructor; [solve [ tr_auto_in_fset | esolve_in ]| ]. + constructor; [solve [ tr_auto_in_fset | esolve_in ]| ]. + constructor; [solve [ tr_auto_in_fset | esolve_in ]| ]. + constructor. + Unshelve. exact [::]. +Defined. + +Definition JKEYS_EXPAND_locs id0 : {fset Location} := fset (JKEYS_EXPAND_valid id0).π1. + +Lemma JAES_ROUNDS_valid id0 : + ∑ L, forall I rkeys m, ValidCode (fset L) I (JAES_ROUNDS id0 rkeys m). +Proof. + eexists. + intros. + unfold JAES. + unfold get_translated_static_fun. + unfold translate_prog_static. + unfold translate_funs_static. + unfold translate_call_body. + Opaque translate_for. + Opaque translate_call. + simpl. + + rewrite !coerce_typed_code_K. + until_call. + constructor. + Unshelve. exact [::]. +Defined. + +Definition JAES_ROUNDS_locs id0 : {fset Location} := fset (JAES_ROUNDS_valid id0).π1. + +Lemma JAES_valid id0 : + ∑ L, forall I key m, ValidCode (fset L) I (JAES id0 key m). +Proof. + eexists. + unfold JAES. + unfold get_translated_static_fun, translate_prog_static, translate_funs_static, translate_call_body. + Opaque translate_for. + Opaque translate_call. + simpl. + + until_call. + 1: clear_fset. + 1: eapply (JKEYS_EXPAND_valid _).π2. + eapply valid_bind. + 1: clear_fset. + 1: eapply valid_translate_write_lvals1. + until_call. + + 1: clear_fset. + 1: eapply (JAES_ROUNDS_valid _).π2. + eapply valid_bind. + 1: clear_fset. + 1: eapply valid_translate_write_lvals1. + constructor; [solve [ tr_auto_in_fset | esolve_in ]| ]. + constructor. + Unshelve. exact [::]. +Defined. + +Definition JAES_locs id0 : {fset Location} := fset (JAES_valid id0).π1. + +Lemma JXOR_valid id0 : + ∑ L, forall I a1 a2, ValidCode (fset L) I (JXOR id0 a1 a2). +Proof. + eexists. + unfold JXOR. + unfold get_translated_static_fun, translate_prog_static, translate_funs_static, translate_call_body. + Opaque translate_for. + Opaque translate_call. + simpl. + + until_call. + constructor. + Unshelve. exact [::]. +Defined. + +Definition JXOR_locs id0 : {fset Location} := fset (JXOR_valid id0).π1. + +Lemma JENC_valid id0 : + ∑ L, forall I n k m, ValidCode (fset L) I (JENC id0 n k m). +Proof. + + unfold JENC. + unfold get_translated_static_fun, translate_prog_static, translate_funs_static, translate_call_body. + Opaque translate_for. + Opaque translate_call. + simpl. + + eexists. + intros. + until_call. + + 1: clear_fset. + 1: eapply (JAES_valid _).π2. + eapply valid_bind. + 1: clear_fset; eapply valid_translate_write_lvals1. + until_call. + 1: clear_fset; eapply (JXOR_valid _).π2. + eapply valid_bind. + 1: clear_fset; eapply valid_translate_write_lvals1. + constructor; [solve [ tr_auto_in_fset | esolve_in ]| ]. + constructor. + Unshelve. exact [::]. +Defined. + +Definition JENC_locs id0 : {fset Location} := fset (JENC_valid id0).π1. From 2715826ccd2f760e9a84f1343ab10fb469f5c3a8 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Tue, 20 Dec 2022 22:23:02 +0100 Subject: [PATCH 329/383] More progress --- theories/Jasmin/examples/aes/aes_hac.v | 1427 ++++++++---------------- 1 file changed, 451 insertions(+), 976 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes_hac.v b/theories/Jasmin/examples/aes/aes_hac.v index 109695b0..bf89bd83 100644 --- a/theories/Jasmin/examples/aes/aes_hac.v +++ b/theories/Jasmin/examples/aes/aes_hac.v @@ -60,6 +60,7 @@ Section Hacspec. destruct H as [o] end; simpl in *; subst. + Lemma det_jkey id0 rcon rkey temp2 : deterministic (JKEY_COMBINE id0 rcon rkey temp2). Proof. unfold translate_call, translate_call_body. @@ -70,6 +71,7 @@ Section Hacspec. Transparent translate_call. Defined. + Lemma det_key_combine rcon rkey temp2 : deterministic (is_state (key_combine rcon rkey temp2)). Proof. repeat (apply deterministic_put || (apply deterministic_get ; intros) || apply deterministic_ret). @@ -102,13 +104,88 @@ Section Hacspec. rewrite get_set_heap_eq ; reflexivity | ]. + Theorem shiftr_bounds : forall x y z, + (0 <= y)%Z -> + (0 <= x < modulus (z+Z.to_nat y))%Z -> + (0 <= Z.shiftr x y < modulus z)%Z. + Proof. + intros. + rewrite Z.shiftr_div_pow2. + 2:{ cbn. lia. } + assert (modulus (z + Z.to_nat y) / 2 ^ y = modulus z)%Z. + { + unfold modulus. + rewrite two_power_nat_correct. + rewrite two_power_nat_correct. + rewrite Zpower_nat_Z. + rewrite Zpower_nat_Z. + rewrite Nat2Z.inj_add. + rewrite Z2Nat.id ; [ | assumption]. + + rewrite <- Z.pow_sub_r ; [ now rewrite Z.add_simpl_r | lia | ]. + split. assumption. + lia. + } + split. + - apply Z_div_nonneg_nonneg ; lia. + - apply (Z.div_lt_upper_bound). + lia. + eapply Z.lt_le_trans. + apply H0. + rewrite Z.mul_comm. + unfold modulus. + rewrite two_power_nat_correct. + rewrite two_power_nat_correct. + rewrite Zpower_nat_Z. + rewrite Zpower_nat_Z. + rewrite <- Z.pow_add_r. + cbn. + rewrite Nat2Z.inj_add. + rewrite Z2Nat.id. + lia. + cbn. lia. + cbn. lia. + cbn. lia. + Qed. + Theorem shiftl_bounds : forall x y z, + (le y z) -> + (0 <= x < modulus (z - y))%Z -> + (0 <= Z.shiftl x y < modulus z)%Z. + Proof. + intros. + rewrite Z.shiftl_mul_pow2. + 2:{ cbn. lia. } + assert (modulus (z - y) * 2 ^ y = modulus z)%Z. + { + unfold modulus. + rewrite two_power_nat_correct. + rewrite two_power_nat_correct. + rewrite Zpower_nat_Z. + rewrite Zpower_nat_Z. + rewrite <- Z.pow_add_r ; [ | lia | cbn ; lia ]. + f_equal. + rewrite Nat2Z.inj_sub. + rewrite Z.sub_simpl_r. + reflexivity. + apply H. + } + split. + - apply Z.mul_nonneg_nonneg ; lia. + - rewrite <- H1. + rewrite <- (Z.mul_lt_mono_pos_r). + lia. + cbn. + lia. + Qed. + Notation JVSHUFPS i rkey temp1 temp2 := (trc VSHUFPS i [('word U128 ; rkey) ; ('word U128 ; temp1) ; ('word U128 ; temp2)]). - Lemma wpshufd_eq : - forall (rkey : 'word U128) (i : nat), + Lemma wpshufd1_eq : + forall (rkey : 'word U128) (i : nat) (n : nat), i < 4 -> - wpshufd1 rkey (wrepr U8 255) i = - is_pure (vpshufd1 rkey (Hacspec_Lib_Pre.repr 255) (Hacspec_Lib_Pre.repr i)). + (* (Z.of_nat n mod modulus nat7.+1 < modulus (2 + 2 * i))%Z -> *) + wpshufd1 rkey (wrepr U8 n) i = + is_pure (vpshufd1 rkey (Hacspec_Lib_Pre.repr n) (Hacspec_Lib_Pre.repr i)). Proof. Opaque Z.mul. clear. @@ -130,57 +207,138 @@ Section Hacspec. unfold toword at 1, mkword at 2. unfold Hacspec_Lib_Pre.from_uint_size, Hacspec_Lib_Pre.Z_uint_sizeable, Hacspec_Lib_Pre.unsigned, wunsigned. unfold Hacspec_Lib_Pre.int_mul, mul_word. - rewrite !mkwordK. - rewrite (Zmod_small _ (modulus nat127.+1)) ; [ | destruct i as [ | [ | [ | [] ]]] ; easy ]. - rewrite (Zmod_small _ (modulus (wsize_size_minus_1 U32).+1)) ; [ | destruct i as [ | [ | [ | [] ]]] ; easy ]. - f_equal. - rewrite (Zmod_small _ (modulus U32)) ; [ | destruct i as [ | [ | [ | [] ]]] ; easy ]. - f_equal. - unfold wunsigned. unfold Hacspec_Lib_Pre.usize_shift_right. unfold wshr. - unfold urepr, val, word_subType. - Set Printing Coercions. - unfold toword, mkword. unfold lsr. - unfold mkword. - simpl. - Compute modulus nat7.+1. - rewrite (Zmod_small) ; [ | destruct i as [ | [ | [ | [] ]]] ; easy ]. - rewrite (Zmod_small _ (modulus nat31.+1)) ; [ | destruct i as [ | [ | [ | [] ]]] ; easy ]. + rewrite !mkwordK. + rewrite <- Zmult_mod. + setoid_rewrite Zmod_mod. + rewrite <- Zmult_mod. + rewrite Z2Nat.id ; [ | destruct i as [ | [ | [ | [] ]]] ; try easy ]. + rewrite (Zmod_small _ (modulus nat127.+1)). + 2:{ + cbn. + rewrite Zmod_small. + 2:{ + replace (4 mod modulus nat31.+1)%Z with (modulus 2) by reflexivity. + split. + - apply Z.mul_nonneg_nonneg ; [ easy | ]. + apply (ssrbool.elimT (iswordZP _ _) (mkword_proof _ _)). + - replace (modulus nat31.+1) with (32 * modulus (32 - 5))%Z by reflexivity. + rewrite <- (Z.mul_lt_mono_pos_l) ; [ | easy]. + eapply Z.lt_trans ; [ apply (ssrbool.elimT (iswordZP _ _) (mkword_proof _ _)) ; easy | easy ]. + } + { + replace (4 mod modulus nat31.+1)%Z with (modulus 2) by reflexivity. + split. + - apply Z.mul_nonneg_nonneg ; [ easy | ]. + apply (ssrbool.elimT (iswordZP _ _) (mkword_proof _ _)). + - replace (modulus nat127.+1) with (32 * modulus (128 - 5))%Z by reflexivity. + rewrite <- (Z.mul_lt_mono_pos_l) ; [ | easy]. + eapply Z.lt_trans ; [ apply (ssrbool.elimT (iswordZP _ _) (mkword_proof _ _)) ; easy | easy ]. + } + } + + symmetry. + replace ((2 * Z.of_nat i) mod modulus U32)%Z with (2 * Z.of_nat i)%Z by by (destruct i as [ | [ | [ | [] ]]] ; easy). + rewrite Zmod_small. + 2:{ + cbn. + replace (4 mod modulus nat31.+1)%Z with (modulus 2) by reflexivity. + split. + - apply Z.mul_nonneg_nonneg ; [ easy | ]. + apply Z_mod_nonneg_nonneg ; [ | easy ]. + apply Z_mod_nonneg_nonneg ; [ | easy ]. + apply Z.shiftr_nonneg. + apply Z_mod_nonneg_nonneg ; [ | easy ]. + apply Z_mod_nonneg_nonneg ; [ | easy ]. + lia. + - replace (modulus nat31.+1)%Z with (32 * modulus (32 - 5))%Z at 3 by reflexivity. + apply Z.mul_lt_mono_pos_l ; [ easy | ]. + eapply Z.lt_trans. + apply Z.mod_pos_bound. + easy. + easy. + } + + cbn. f_equal. f_equal. - Opaque Nat.mul. - cbn. - replace (2 mod (modulus (nat_of_wsize U32)))%Z with 2%Z by reflexivity. - cbn. - rewrite (Zmod_small) ; [ | destruct i as [ | [ | [ | [] ]]] ; easy ]. - rewrite (Zmod_small) ; [ | destruct i as [ | [ | [ | [] ]]] ; easy ]. - rewrite (Zmod_small) ; [ | destruct i as [ | [ | [ | [] ]]] ; easy ]. - lia. + rewrite Zmod_small. + { + symmetry. + rewrite Zmod_small. + { + symmetry. + f_equal. + { + rewrite Zmod_small ; [ reflexivity | ]. + split ; [ apply Z_mod_nonneg_nonneg ; [ lia | easy ] | ]. + eapply Z.lt_trans. + apply Z.mod_pos_bound. + destruct i as [ | [ | [ | [] ]]] ; easy. + easy. + } + destruct i as [ | [ | [ | [] ]]] ; easy. + } + apply shiftr_bounds. lia. + split. + apply Z_mod_nonneg_nonneg. + lia. + easy. + + eapply Z.lt_le_trans. + apply Z.mod_pos_bound. + destruct i as [ | [ | [ | [] ]]] ; easy. + rewrite modulusD. + destruct i as [ | [ | [ | [] ]]] ; easy. + } + apply shiftr_bounds. lia. + rewrite Zmod_small. + { + split. + apply Z_mod_nonneg_nonneg. + lia. + easy. + + eapply Z.lt_le_trans. + apply Z.mod_pos_bound. + destruct i as [ | [ | [ | [] ]]] ; easy. + destruct i as [ | [ | [ | [] ]]] ; easy. + } + { + split. + apply Z_mod_nonneg_nonneg. + lia. + easy. + + eapply Z.lt_le_trans. + apply Z.mod_pos_bound. + destruct i as [ | [ | [ | [] ]]] ; easy. + destruct i as [ | [ | [ | [] ]]] ; easy. + } Transparent Z.mul. Transparent Nat.mul. Qed. - Lemma wpshufd_eq_state : - forall {H} (rkey : 'word U128) (i : nat), + Lemma wpshufd1_eq_state : + forall {H} (rkey : 'word U128) (i n : nat), i < 4 -> ⊢ ⦃ H ⦄ - ret (wpshufd1 rkey (wrepr U8 255) i) ≈ - is_state (vpshufd1 rkey (Hacspec_Lib_Pre.repr 255) (Hacspec_Lib_Pre.repr i)) + ret (wpshufd1 rkey (wrepr U8 n) i) ≈ + is_state (vpshufd1 rkey (Hacspec_Lib_Pre.repr n) (Hacspec_Lib_Pre.repr i)) ⦃ λ '(v0, h0) '(v1, h1), v0 = v1 ∧ H (h0, h1) ⦄. Proof. intros. - rewrite wpshufd_eq ; [ | apply H0 ]. + rewrite (wpshufd1_eq _ i n) ; [ | apply H0 ]. now apply r_ret. Qed. - - Ltac match_wpshufd1_vpshufd1 := + Ltac match_wpshufd1_vpshufd1 i := (let w := fresh in let y := fresh in let b := fresh in - set (w := wpshufd1 _ _ _) ; + set (w := wpshufd1 _ _ i) ; set (y := fun _ : Hacspec_Lib_Pre.int32 => _) ; set (b := vpshufd1 _ _ _); let k := fresh in @@ -192,6 +350,41 @@ Section Hacspec. subst l ; apply (@r_bind _ _ _ _ (ret w) (prog (is_state b)) _ y _ (fun '(v0, h0) '(v1, h1) => v0 = v1 /\ k (h0, h1))) ; subst w y b ; hnf). + Ltac solve_wpshufd1_vpshufd1 i n := + match_wpshufd1_vpshufd1 i ; [now apply (wpshufd1_eq_state _ i n) | intros ]. + + Lemma shift_left_4_byte_ok : + (forall i (a : 'word U32), + i < 4 -> + (0 <= Z.shiftl (wunsigned a) (Z.of_nat (i * 32)) < + modulus (wsize_size_minus_1 U128).+1)%Z). + Proof. + clear. + destruct a. + unfold wunsigned, urepr, val, word_subType, word.toword. + split. apply Z.shiftl_nonneg. lia. + apply (ssrbool.elimT (iswordZP _ _)) in i0. + destruct i0. + rewrite Z.shiftl_mul_pow2 ; [ | lia]. + eapply Z.lt_le_trans. + rewrite <- (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat _) toword) ; [ | lia ]. + apply H1. + destruct i as [ | [ | [ | [ | []] ]] ] ; easy. + Qed. + + Lemma num_smaller_if_modulus_lte : (forall {WS} (x : 'word WS) z, (modulus WS <= z)%Z -> (0 <= x < z)%Z). + Proof. + clear. + cbn. + intros. + destruct x. + pose (ssrbool.elimT (iswordZP _ _) i). + split. easy. + unfold word.toword. + destruct a. + eapply Z.lt_le_trans ; [ apply H1 | apply H]. + Qed. + Lemma Z_lor_pow2 : (forall (x y : Z) (k : nat), (0 <= x < 2 ^ k)%Z -> (0 <= y < 2 ^ k)%Z -> (0 <= Z.lor x y < 2 ^ k)%Z). Proof. clear. @@ -214,38 +407,150 @@ Section Hacspec. - easy. Qed. - Lemma num_smaller_if_modulus_smaller : (forall {WS} (x : 'word WS) z, (modulus WS < z)%Z -> (0 <= x < z)%Z). + Lemma wpshufd_128_eq_state : + forall {H} (rkey : 'word U128) (n : nat), + ⊢ ⦃ H ⦄ + ret (wpshufd_128 rkey n) ≈ + is_state (vpshufd rkey (Hacspec_Lib_Pre.repr n)) + ⦃ λ '(v0, h0) '(v1, h1), v0 = v1 ∧ H (h0, h1) ⦄. Proof. - clear. - cbn. - intros. - destruct x. - pose (ssrbool.elimT (iswordZP _ _) i). - split. easy. - unfold word.toword. - destruct a. - eapply Z.lt_trans ; [ apply H1 | apply H]. + intros. + unfold wpshufd_128. + unfold vpshufd. + unfold wpshufd_128. + unfold iota. + unfold map. + (* set (wpshufd1 _ _ _). *) + (* set (wpshufd1 _ _ _). *) + (* set (wpshufd1 _ _ _). *) + unfold vpshufd. + + solve_wpshufd1_vpshufd1 0 n. + solve_wpshufd1_vpshufd1 1 n. + solve_wpshufd1_vpshufd1 2 n. + solve_wpshufd1_vpshufd1 3 n. + + apply r_ret. + intros ? ? [? [? [? []]]]. + subst. + subst H4. + split ; [ clear | assumption ]. + + apply word_ext. + + unfold wcat_r. + + Opaque Z.shiftl. + simpl. + Transparent Z.shiftl. + + rewrite Zmod_small. + 2: { + rewrite !Z.shiftl_lor. + rewrite !Z.shiftl_mul_pow2 ; try easy. + rewrite !Z.mul_0_l. + rewrite Z.lor_0_r. + replace (int_to_Z (Posz 32)) with 32%Z by reflexivity. + + repeat apply (Z_lor_pow2 _ _ (32 + 32 + 32 + 32)) ; replace (2 ^ (int_to_Z (Posz(32 + 32 + 32 + 32))))%Z with (2 ^ 32 * 2 ^ 32 * 2 ^ 32 * 2 ^ 32)%Z by reflexivity. + all: split ; [ destruct a₁, a₁0, a₁1, a₁2 ; unfold urepr ; simpl ; apply (ssrbool.elimT (iswordZP _ _)) in i, i0, i1, i2 ; repeat (apply Z.lor_nonneg ; split ; [ repeat apply Z.mul_nonneg_nonneg ; easy | ]) ; repeat apply Z.mul_nonneg_nonneg ; easy | ]. + all: repeat (apply -> (@Z.mul_lt_mono_pos_r (2 ^ 32)) ; [ | easy ]) ; apply (@num_smaller_if_modulus_lte U32) ; easy. + } + + rewrite Zmod_small ; [ | apply num_smaller_if_modulus_lte ; easy]. + rewrite Zmod_small. + 2:{ + setoid_rewrite Zmod_small ; [ | apply num_smaller_if_modulus_lte ; easy | apply num_smaller_if_modulus_lte ; easy ]. + apply (shift_left_4_byte_ok 1) ; easy. + } + rewrite Zmod_small. + 2:{ + setoid_rewrite Zmod_small ; try (apply num_smaller_if_modulus_lte ; easy). + apply (shift_left_4_byte_ok 2) ; easy. + } + rewrite Zmod_small. + 2:{ + setoid_rewrite Zmod_small ; try (apply num_smaller_if_modulus_lte ; easy). + apply (shift_left_4_byte_ok 3) ; easy. + } + setoid_rewrite Zmod_small ; try (apply num_smaller_if_modulus_lte ; easy). + + rewrite !Z.shiftl_lor. + rewrite !Z.shiftl_mul_pow2 ; try easy. + rewrite !Z.mul_0_l. + rewrite Z.lor_0_r. + rewrite <- !Z.mul_assoc. + rewrite <- !Z.pow_add_r ; try easy. + now rewrite <- !Z.lor_assoc. Qed. - Lemma shift_left_4_byte_ok : - (forall i (a : 'word U32), - i < 4 -> - (0 <= Z.shiftl (wunsigned a) (Z.of_nat (i * 32)) < - modulus (wsize_size_minus_1 U128).+1)%Z). + Lemma wshufps_128_eq_state : + forall {H} (a b : 'word U128) (n : nat), + ⊢ ⦃ H ⦄ + ret (wshufps_128 (wrepr U8 n) a b) ≈ + is_state (vshufps a b (Hacspec_Lib_Pre.repr n)) + ⦃ λ '(v0, h0) '(v1, h1), v0 = v1 ∧ H (h0, h1) ⦄. Proof. - clear. - destruct a. - unfold wunsigned, urepr, val, word_subType, word.toword. - split. apply Z.shiftl_nonneg. lia. - apply (ssrbool.elimT (iswordZP _ _)) in i0. - destruct i0. - rewrite Z.shiftl_mul_pow2 ; [ | lia]. - eapply Z.lt_le_trans. - rewrite <- (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat _) toword) ; [ | lia ]. - apply H1. - destruct i as [ | [ | [ | [ | []] ]] ] ; easy. - Qed. + intros. + unfold wshufps_128. + unfold vshufps. + unfold iota. + unfold map. + (* set (wpshufd1 _ _ _). *) + (* set (wpshufd1 _ _ _). *) + (* set (wpshufd1 _ _ _). *) + unfold vpshufd. + + solve_wpshufd1_vpshufd1 0 n. + solve_wpshufd1_vpshufd1 1 n. + solve_wpshufd1_vpshufd1 2 n. + solve_wpshufd1_vpshufd1 3 n. + intros. + apply r_ret. + intros ? ? [? [? [? []]]]. + subst. + subst H4. + split ; [ clear | assumption ]. + + apply word_ext. + + unfold wcat_r. + + Opaque Z.shiftl. + simpl. + Transparent Z.shiftl. + + rewrite !mkwordK. + + rewrite Zmod_small. + 2: { + rewrite !Z.shiftl_lor. + rewrite !Z.shiftl_mul_pow2 ; try easy. + rewrite !Z.mul_0_l. + rewrite Z.lor_0_r. + repeat apply (Z_lor_pow2 _ _ (32 + 32 + 32 + 32)) ; replace (2 ^ (int_to_Z (Posz(32 + 32 + 32 + 32))))%Z with (2 ^ 32 * 2 ^ 32 * 2 ^ 32 * 2 ^ 32)%Z by reflexivity. + all: split ; [ destruct a₁, a₁0, a₁1, a₁2 ; unfold urepr ; simpl ; apply (ssrbool.elimT (iswordZP _ _)) in i, i0, i1, i2 ; repeat (apply Z.lor_nonneg ; split ; [ repeat apply Z.mul_nonneg_nonneg ; easy | ]) ; repeat apply Z.mul_nonneg_nonneg ; easy | ]. + all: repeat (apply -> (@Z.mul_lt_mono_pos_r (2 ^ 32)) ; [ | easy ]) ; apply (@num_smaller_if_modulus_lte U32) ; easy. + } + rewrite !Zmod_small. + all: try apply (@num_smaller_if_modulus_lte U32). + all: try easy. + 2: apply (shiftl_bounds _ 96 128) ; [ lia | cbn ; apply (@num_smaller_if_modulus_lte U32) ; easy ]. + 2: apply (shiftl_bounds _ 64 128) ; [ lia | cbn ; apply (@num_smaller_if_modulus_lte U32) ; easy ]. + 2: apply (shiftl_bounds _ 32 128) ; [ lia | cbn ; apply (@num_smaller_if_modulus_lte U32) ; easy ]. + + rewrite !Z.shiftl_lor. + rewrite !Z.shiftl_mul_pow2 ; try easy. + rewrite !Z.mul_0_l. + rewrite Z.lor_0_r. + rewrite <- !Z.mul_assoc. + rewrite <- !Z.pow_add_r ; try easy. + rewrite <- !Z.lor_assoc. + simpl. + reflexivity. + Qed. + Lemma key_combined_eq id0 rcon rkey temp2 : ⊢ ⦃ fun '(_, _) => True ⦄ JKEY_COMBINE id0 rcon rkey temp2 @@ -286,27 +591,9 @@ Section Hacspec. Unshelve. { - (* rewrite !zero_extend_u. *) - unfold tr_app_sopn_tuple. unfold sopn_sem. unfold sopn.get_instr_desc. - unfold asm_opI. - unfold asm_op_instr. - unfold semi, arch_extra.get_instr_desc. - unfold instr_desc, _asm_op_decl, instr_desc_op, _asm, x86_extra. - unfold x86_sem.x86. - unfold x86_op_decl. - unfold x86_instr_desc. - unfold id_semi. - unfold Ox86_VPSHUFD_instr. - unfold ".1". - unfold x86_VPSHUFD. - unfold wpshufd. - - set (totce _) at 2. - cbn in t. - unfold totce in t. set (chCanonical _). cbn in s. @@ -317,166 +604,17 @@ Section Hacspec. subst y. hnf. - unfold totce. - subst t. - unfold ".π2". - - unfold wpshufd_128. - unfold iota. - unfold map. - (* set (wpshufd1 _ _ _). *) - (* set (wpshufd1 _ _ _). *) - (* set (wpshufd1 _ _ _). *) - unfold vpshufd. - - match_wpshufd1_vpshufd1. - - replace (truncate_chWord U128 _) with rkey by (simpl ; now rewrite zero_extend_u). - replace (wrepr _ _) with (wrepr U8 255) by (rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; now rewrite coerce_to_choice_type_K). - apply (@wpshufd_eq_state _ rkey 0 ltac:(easy)). - intros. - - match_wpshufd1_vpshufd1. - - replace (truncate_chWord U128 _) with rkey by (simpl ; now rewrite zero_extend_u). - replace (wrepr _ _) with (wrepr U8 255) by (rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; now rewrite coerce_to_choice_type_K). - eapply (@wpshufd_eq_state _ rkey 1 ltac:(easy)). - intros. - - match_wpshufd1_vpshufd1. - - replace (truncate_chWord U128 _) with rkey by (simpl ; now rewrite zero_extend_u). - replace (wrepr _ _) with (wrepr U8 255) by (rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; now rewrite coerce_to_choice_type_K). - eapply (@wpshufd_eq_state _ rkey 2 ltac:(easy)). - intros. - - match_wpshufd1_vpshufd1. + replace (toword _) with (255)%Z by (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; now rewrite coerce_to_choice_type_K). replace (truncate_chWord U128 _) with rkey by (simpl ; now rewrite zero_extend_u). - replace (wrepr _ _) with (wrepr U8 255) by (rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; now rewrite coerce_to_choice_type_K). - eapply (@wpshufd_eq_state _ rkey 3 ltac:(easy)). - intros. - - apply r_ret. - intros. - destruct H as [? [? [? [? []]]]]. - subst. - subst H2. - clear -H7. - split ; [ | eexists ; apply H7 ]. - - apply word_ext. - - unfold wcat_r. - - unfold ".|". - unfold "_ shift_left _". - unfold Hacspec_Lib_Pre.shift_left_. - unfold Hacspec_Lib_Pre.int_or. - unfold Hacspec_Lib_Pre.repr. - unfold Hacspec_Lib_Pre.from_uint_size. - unfold Hacspec_Lib_Pre.usize. - unfold Hacspec_Lib_Pre.Z_uint_sizeable. - unfold Hacspec_Lib_Pre.unsigned. - unfold cast_int. - unfold lift_to_both0 , lift_to_both, is_pure. - unfold word.wor, wor. - unfold wshl, lsl. - unfold wrepr, wunsigned, urepr, val, word_subType, mkword, toword. - unfold Hacspec_Lib_Pre.repr. - unfold Hacspec_Lib_Pre.nat_uint_sizeable. - unfold Hacspec_Lib_Pre.repr. - unfold wrepr. - unfold mkword. - unfold toword. - unfold Hacspec_Lib_Pre.unsigned. - - rewrite !Zmod_small. - - all: try easy. - all: try (apply num_smaller_if_modulus_smaller ; easy). - - 2: apply (shift_left_4_byte_ok 3) ; easy. - 2: apply (shift_left_4_byte_ok 2) ; easy. - 2: apply (shift_left_4_byte_ok 1) ; easy. - - setoid_rewrite <- Z.lor_assoc. - setoid_rewrite <- Z.lor_assoc. - f_equal. - - symmetry. - rewrite <- Z.lor_comm. - rewrite <- Z.lor_assoc. - rewrite <- Z.lor_comm. - rewrite <- Z.lor_assoc. - rewrite <- Z.lor_comm. - rewrite <- Z.lor_assoc. - rewrite !Z.shiftl_lor. - f_equal. - f_equal. - rewrite Z.lor_0_r. - reflexivity. - - destruct a₁, a₁0, a₁1, a₁2. - rewrite !Z.shiftl_lor. - rewrite !Z.shiftl_mul_pow2 ; try easy. - rewrite !Z.mul_0_l. - rewrite Z.lor_0_r. - replace (int_to_Z (Posz 32)) with 32%Z by reflexivity. - - apply (ssrbool.elimT (iswordZP _ _)) in i, i0, i1, i2. - split. - { - apply Z.lor_nonneg. split. easy. - apply Z.lor_nonneg. split. apply Z.mul_nonneg_nonneg ; easy. - apply Z.lor_nonneg. split. repeat apply Z.mul_nonneg_nonneg ; easy. - repeat apply Z.mul_nonneg_nonneg ; easy. - } - { - rewrite <- !Z.mul_assoc. - rewrite <- !Z.pow_add_r ; try easy. - simpl. - - apply (Z_lor_pow2 toword _ nat127.+1). split ; [ easy | ]. - eapply Z.lt_trans ; [apply i | easy]. - - apply (Z_lor_pow2 (toword0 * _)%Z _ nat127.+1). split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. - eapply Z.lt_le_trans. - rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 32)) toword0) in i0 ; [ | easy]. - apply i0. - easy. - - apply (Z_lor_pow2 (toword1 * _)%Z _ nat127.+1). split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. - - eapply Z.lt_le_trans. - rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 64)) toword1) in i1 ; [ | easy]. - apply i1. - easy. - split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. - eapply Z.lt_le_trans. - rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 96)) toword2) in i2 ; [ | easy]. - apply i2. - easy. - } + apply (wpshufd_128_eq_state rkey 255). } { unfold tr_app_sopn_tuple. unfold sopn_sem. unfold sopn.get_instr_desc. - unfold asm_opI. - unfold asm_op_instr. - unfold semi, arch_extra.get_instr_desc. - unfold instr_desc, _asm_op_decl, instr_desc_op, _asm, x86_extra. - unfold x86_sem.x86. - unfold x86_op_decl. - unfold x86_instr_desc. - unfold id_semi. - unfold Ox86_VPSHUFD_instr. - unfold ".1". - unfold x86_VPSHUFD. - unfold wpshufd. set (totce _) at 2. cbn in t. @@ -495,11 +633,9 @@ Section Hacspec. subst t. unfold ".π2". - unfold wshufps_128. unfold lift2_vec. - unfold make_vec. - rewrite map2E. - unfold zip. + + unfold map2. unfold split_vec. unfold map. unfold iota. @@ -509,390 +645,65 @@ Section Hacspec. cbn in n. subst n. hnf. - unfold sopn_sem, tr_app_sopn_tuple, tr_app_sopn_single. - - unfold vshufps. - - match_wpshufd1_vpshufd1. - set (ret _). - simpl in r. - subst r. - rewrite !zero_extend_u. - replace (word.subword _ _ temp2) with temp2. + replace (word.subword _ _ _) with temp2. 2:{ destruct temp2. cbn. apply word_ext. cbn. - rewrite Zmod_mod. + rewrite !Zmod_mod. + rewrite Zmod_small. + reflexivity. + apply (ssrbool.elimT (iswordZP _ _)). + apply i. + } + replace (word.subword _ _ _) with rcon. + 2:{ + destruct rcon. + cbn. + apply word_ext. + cbn. + rewrite !Zmod_mod. rewrite Zmod_small. reflexivity. apply (ssrbool.elimT (iswordZP _ _)). apply i. } + + replace (truncate_chWord _ _) with (wrepr U8 16) by now do 2 (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). - replace (wpack U8 2 _) with (wrepr U8 16) by now do 2 (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). - replace (Hacspec_Lib_Pre.pub_u8 - (is_pure - (lift_to_both0 - (is_pure (lift_to_both0 (Hacspec_Lib_Pre.usize 16)))))) with (Hacspec_Lib_Pre.repr (WS := U8) 16) by reflexivity. + unfold make_vec. + unfold wcat_r. + rewrite Z.shiftl_0_l. + rewrite Z.lor_0_r. - apply r_ret. - intros. - split ; [ | assumption ]. - remove_T_ct. - Opaque Z.mul. - clear. - intros. - unfold vpshufd1. - unfold wpshufd1. - simpl. - apply word_ext. - f_equal. - simpl. - rewrite Zmod_mod. - unfold Hacspec_Lib_Pre.shift_right_, wshr, lsr, Hacspec_Lib_Pre.unsigned, wunsigned ; rewrite mkwordK. - f_equal. - - intros. - - match_wpshufd1_vpshufd1. + unfold mkword. + + epose (wshufps_128_eq_state temp2 rcon 16). + unfold lift_scope. + unfold is_state at 1. + unfold lift_code_scope. + unfold prog. + rewrite <- bind_ret. set (ret _). - simpl in r. - subst r. - rewrite !zero_extend_u. - replace (word.subword _ _ temp2) with temp2. - 2:{ - destruct temp2. - cbn. - apply word_ext. - cbn. - rewrite Zmod_mod. - rewrite Zmod_small. - reflexivity. - apply (ssrbool.elimT (iswordZP _ _)). - apply i. - } - - replace (wpack U8 2 _) with (wrepr U8 16) by now do 2 (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). - replace (Hacspec_Lib_Pre.pub_u8 - (is_pure - (lift_to_both0 - (is_pure (lift_to_both0 (Hacspec_Lib_Pre.usize 16)))))) with (Hacspec_Lib_Pre.repr (WS := U8) 16) by reflexivity. - - apply r_ret. - intros. - split ; [ | assumption ]. - remove_T_ct. - Opaque Z.mul. - clear. - intros. - unfold vpshufd1. - unfold wpshufd1. - simpl. - apply word_ext. - f_equal. - simpl. - rewrite Zmod_mod. - unfold Hacspec_Lib_Pre.shift_right_, wshr, lsr, Hacspec_Lib_Pre.unsigned, wunsigned ; rewrite mkwordK. - f_equal. + pattern (wshufps_128 (wrepr U8 16) temp2 rcon) in r0. + subst r0. + eapply (@r_bind _ _ _ _ (ret (wshufps_128 (wrepr U8 16) temp2 rcon))). + apply r. intros. - - match_wpshufd1_vpshufd1. - - set (ret _). - simpl in r. - subst r. - rewrite !zero_extend_u. - replace (word.subword _ _ rcon) with rcon. - 2:{ - destruct rcon. - cbn. - apply word_ext. - cbn. - rewrite Zmod_mod. - rewrite Zmod_small. - reflexivity. - apply (ssrbool.elimT (iswordZP _ _)). - apply i. - } - - replace (wpack U8 2 _) with (wrepr U8 16) by now do 2 (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). - replace (Hacspec_Lib_Pre.pub_u8 - (is_pure - (lift_to_both0 - (is_pure (lift_to_both0 (Hacspec_Lib_Pre.usize 16)))))) with (Hacspec_Lib_Pre.repr (WS := U8) 16) by reflexivity. - apply r_ret. - intros. - split ; [ | assumption ]. - remove_T_ct. - Opaque Z.mul. - clear. - intros. - unfold vpshufd1. - unfold wpshufd1. - simpl. - apply word_ext. - f_equal. - simpl. - rewrite Zmod_mod. - unfold Hacspec_Lib_Pre.shift_right_, wshr, lsr, Hacspec_Lib_Pre.unsigned, wunsigned ; rewrite mkwordK. - f_equal. - - intros. - match_wpshufd1_vpshufd1. - - set (ret _). - simpl in r. - subst r. - rewrite !zero_extend_u. - replace (word.subword _ _ rcon) with rcon. - 2:{ - destruct rcon. - cbn. - apply word_ext. - cbn. - rewrite Zmod_mod. - rewrite Zmod_small. - reflexivity. - apply (ssrbool.elimT (iswordZP _ _)). - apply i. - } - - replace (wpack U8 2 _) with (wrepr U8 16) by now do 2 (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). - replace (Hacspec_Lib_Pre.pub_u8 - (is_pure - (lift_to_both0 - (is_pure (lift_to_both0 (Hacspec_Lib_Pre.usize 16)))))) with (Hacspec_Lib_Pre.repr (WS := U8) 16) by reflexivity. - - apply r_ret. - intros. - split ; [ | assumption ]. - remove_T_ct. - Opaque Z.mul. - clear. - intros. - unfold vpshufd1. - unfold wpshufd1. - simpl. - apply word_ext. - f_equal. - simpl. - rewrite Zmod_mod. - unfold Hacspec_Lib_Pre.shift_right_, wshr, lsr, Hacspec_Lib_Pre.unsigned, wunsigned ; rewrite mkwordK. - f_equal. - - intros. - - apply r_ret. - - intros. - destruct H as [? [? [? [? [? [[]]]]]]]. + intros ? ? []. subst. split. - 2:{ - unfold H2. - exists x. easy. - } - - apply word_ext. - unfold wcat_r. - - unfold ".|". - unfold "_ shift_left _". - unfold Hacspec_Lib_Pre.shift_left_. - unfold Hacspec_Lib_Pre.int_or. - unfold Hacspec_Lib_Pre.repr. - unfold Hacspec_Lib_Pre.from_uint_size. - unfold Hacspec_Lib_Pre.usize. - unfold Hacspec_Lib_Pre.Z_uint_sizeable. - unfold Hacspec_Lib_Pre.unsigned. - unfold cast_int. - unfold lift_to_both0 , lift_to_both, is_pure. - unfold word.wor, wor. - unfold wshl, lsl. - unfold wrepr, wunsigned, urepr, val, word_subType, mkword, toword. - unfold Hacspec_Lib_Pre.repr. - unfold Hacspec_Lib_Pre.nat_uint_sizeable. - unfold Hacspec_Lib_Pre.repr. - unfold wrepr. - unfold mkword. - unfold toword. - unfold Hacspec_Lib_Pre.unsigned. - - rewrite !Zmod_small. - - all: try easy. - all: try (apply (num_smaller_if_modulus_smaller) ; easy). - - setoid_rewrite <- Z.lor_assoc. - setoid_rewrite <- Z.lor_assoc. - f_equal. - - rewrite Z.shiftl_0_l. - rewrite Z.lor_0_r. - rewrite Z.shiftl_0_l. - rewrite Z.lor_0_r. - - rewrite !Z.shiftl_lor. - f_equal. - - apply (shift_left_4_byte_ok 3) ; easy. - apply (shift_left_4_byte_ok 2) ; easy. - apply (shift_left_4_byte_ok 1) ; easy. - - - destruct a₁0, a₁1, a₁2, a₁3. - rewrite !Z.shiftl_lor. - rewrite !Z.shiftl_mul_pow2 ; try easy. - rewrite !Z.mul_0_l. - rewrite Z.lor_0_r. - replace (int_to_Z (Posz 32)) with 32%Z by reflexivity. - - destruct (ssrbool.elimT (iswordZP _ _) i). - destruct (ssrbool.elimT (iswordZP _ _) i0). - destruct (ssrbool.elimT (iswordZP _ _) i1). - destruct (ssrbool.elimT (iswordZP _ _) i2). - split. - { - apply Z.lor_nonneg. split. easy. - apply Z.lor_nonneg. split. apply Z.mul_nonneg_nonneg ; easy. - apply Z.lor_nonneg. split. repeat apply Z.mul_nonneg_nonneg ; easy. - repeat apply Z.mul_nonneg_nonneg ; easy. - } - { - rewrite <- !Z.mul_assoc. - rewrite <- !Z.pow_add_r ; try easy. - simpl. - - apply (Z_lor_pow2 toword _ nat127.+1). split ; [ easy | ]. - eapply Z.lt_trans ; [apply H0 | easy]. - - apply (Z_lor_pow2 (toword0 * _)%Z _ nat127.+1). split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. - eapply Z.lt_le_trans. - apply (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 32)) toword0) in H6 ; [ | easy]. - apply H6. - easy. - - apply (Z_lor_pow2 (toword1 * _)%Z _ nat127.+1). split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. - - eapply Z.lt_le_trans. - rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 64)) toword1) in H9 ; [ | easy]. - apply H9. - easy. - - split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. - eapply Z.lt_le_trans. - rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 96)) toword2) in H11 ; [ | easy]. - apply H11. - easy. - } - { - destruct a₁0, a₁1, a₁2, a₁3. -rewrite !Z.shiftl_lor. - rewrite !Z.shiftl_mul_pow2 ; try easy. - rewrite !Z.mul_0_l. - rewrite Z.lor_0_r. - replace (int_to_Z (Posz 32)) with 32%Z by reflexivity. - - destruct (ssrbool.elimT (iswordZP _ _) i). - destruct (ssrbool.elimT (iswordZP _ _) i0). - destruct (ssrbool.elimT (iswordZP _ _) i1). - destruct (ssrbool.elimT (iswordZP _ _) i2). - split. - { - apply Z.lor_nonneg. split. easy. - apply Z.lor_nonneg. split. apply Z.mul_nonneg_nonneg ; easy. - apply Z.lor_nonneg. split. repeat apply Z.mul_nonneg_nonneg ; easy. - apply Z.lor_nonneg. split. repeat apply Z.mul_nonneg_nonneg ; easy. - easy. - } - { - rewrite <- !Z.mul_assoc. - rewrite <- !Z.pow_add_r ; try easy. - simpl. - - apply (Z_lor_pow2 toword _ nat127.+1). split ; [ easy | ]. - eapply Z.lt_trans ; [apply H0 | easy]. - - apply (Z_lor_pow2 (toword0 * _)%Z _ nat127.+1). split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. - eapply Z.lt_le_trans. - apply (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 32)) toword0) in H6 ; [ | easy]. - apply H6. - easy. - - apply (Z_lor_pow2 (toword1 * _)%Z _ nat127.+1). split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. - - eapply Z.lt_le_trans. - rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 64)) toword1) in H9 ; [ | easy]. - apply H9. - easy. - - split. - apply Z.lor_nonneg. split. repeat apply Z.mul_nonneg_nonneg ; easy. - easy. - - apply (Z_lor_pow2 (toword2 * _)%Z _ nat127.+1). - - split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. - eapply Z.lt_le_trans. - rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 96)) toword2) in H11 ; [ | easy]. - apply H11. - easy. - easy. - } - } - { - destruct a₁0, a₁1, a₁2, a₁3. -rewrite !Z.shiftl_lor. - rewrite !Z.shiftl_mul_pow2 ; try easy. - rewrite !Z.mul_0_l. - rewrite Z.lor_0_r. - replace (int_to_Z (Posz 32)) with 32%Z by reflexivity. - - destruct (ssrbool.elimT (iswordZP _ _) i). - destruct (ssrbool.elimT (iswordZP _ _) i0). - destruct (ssrbool.elimT (iswordZP _ _) i1). - destruct (ssrbool.elimT (iswordZP _ _) i2). - split. - { - apply Z.lor_nonneg. split. easy. - apply Z.lor_nonneg. split. apply Z.mul_nonneg_nonneg ; easy. - apply Z.lor_nonneg. split. repeat apply Z.mul_nonneg_nonneg ; easy. - repeat apply Z.mul_nonneg_nonneg ; easy. - } - { - rewrite <- !Z.mul_assoc. - rewrite <- !Z.pow_add_r ; try easy. - simpl. - - apply (Z_lor_pow2 toword _ nat127.+1). split ; [ easy | ]. - eapply Z.lt_trans ; [apply H0 | easy]. - - apply (Z_lor_pow2 (toword0 * _)%Z _ nat127.+1). split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. - eapply Z.lt_le_trans. - apply (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 32)) toword0) in H6 ; [ | easy]. - apply H6. - easy. - - apply (Z_lor_pow2 (toword1 * _)%Z _ nat127.+1). split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. - - eapply Z.lt_le_trans. - rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 64)) toword1) in H9 ; [ | easy]. - apply H9. - easy. - - split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. - eapply Z.lt_le_trans. - rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 96)) toword2) in H11 ; [ | easy]. - apply H11. - easy. - } - } + destruct a₁0. cbn. unfold wrepr. cbn. apply word_ext. + rewrite Zmod_small. + reflexivity. + apply (ssrbool.elimT (iswordZP _ _)). + apply i. + apply H0. } { cbn. @@ -903,24 +714,10 @@ rewrite !Z.shiftl_lor. apply H. } { - (* TODO: Next vshufs *) - { unfold tr_app_sopn_tuple. unfold sopn_sem. unfold sopn.get_instr_desc. - unfold asm_opI. - unfold asm_op_instr. - unfold semi, arch_extra.get_instr_desc. - unfold instr_desc, _asm_op_decl, instr_desc_op, _asm, x86_extra. - unfold x86_sem.x86. - unfold x86_op_decl. - unfold x86_instr_desc. - unfold id_semi. - unfold Ox86_VPSHUFD_instr. - unfold ".1". - unfold x86_VPSHUFD. - unfold wpshufd. set (totce _) at 2. cbn in t. @@ -939,11 +736,9 @@ rewrite !Z.shiftl_lor. subst t. unfold ".π2". - unfold wshufps_128. unfold lift2_vec. - unfold make_vec. - rewrite map2E. - unfold zip. + + unfold map2. unfold split_vec. unfold map. unfold iota. @@ -953,392 +748,56 @@ rewrite !Z.shiftl_lor. cbn in n. subst n. hnf. - unfold sopn_sem, tr_app_sopn_tuple, tr_app_sopn_single. - - unfold vshufps. - - match_wpshufd1_vpshufd1. - - set (ret _). - simpl in r. - subst r. - rewrite !zero_extend_u. - replace (word.subword _ _ a₁0) with a₁0. - 2:{ - destruct a₁0. - cbn. - apply word_ext. - cbn. - rewrite Zmod_mod. - rewrite Zmod_small. - reflexivity. - apply (ssrbool.elimT (iswordZP _ _)). - apply i. - } - - replace (wpack U8 2 _) with (wrepr U8 140) by now do 3 (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). - - replace (Hacspec_Lib_Pre.pub_u8 - (is_pure - (lift_to_both0 - (is_pure (lift_to_both0 (Hacspec_Lib_Pre.usize 140)))))) with (Hacspec_Lib_Pre.repr (WS := U8) 140) by reflexivity. - - apply r_ret. - intros. - split ; [ | assumption ]. - remove_T_ct. - Opaque Z.mul. - clear. - intros. - unfold vpshufd1. - unfold wpshufd1. - simpl. - apply word_ext. - f_equal. - simpl. - rewrite Zmod_mod. - unfold Hacspec_Lib_Pre.shift_right_, wshr, lsr, Hacspec_Lib_Pre.unsigned, wunsigned ; rewrite mkwordK. - f_equal. - - intros. - - match_wpshufd1_vpshufd1. - set (ret _). - simpl in r. - subst r. - rewrite !zero_extend_u. - replace (word.subword _ _ a₁0) with a₁0. + replace (word.subword _ _ _) with a₁0. 2:{ destruct a₁0. cbn. apply word_ext. cbn. - rewrite Zmod_mod. + rewrite !Zmod_mod. rewrite Zmod_small. reflexivity. apply (ssrbool.elimT (iswordZP _ _)). apply i. } - - replace (wpack U8 2 _) with (wrepr U8 140) by now do 3 (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). - replace (Hacspec_Lib_Pre.pub_u8 - (is_pure - (lift_to_both0 - (is_pure (lift_to_both0 (Hacspec_Lib_Pre.usize 140)))))) with (Hacspec_Lib_Pre.repr (WS := U8) 140) by reflexivity. - - apply r_ret. - intros. - split ; [ | assumption ]. - remove_T_ct. - Opaque Z.mul. - clear. - intros. - unfold vpshufd1. - unfold wpshufd1. - simpl. - apply word_ext. - f_equal. - simpl. - rewrite Zmod_mod. - unfold Hacspec_Lib_Pre.shift_right_, wshr, lsr, Hacspec_Lib_Pre.unsigned, wunsigned ; rewrite mkwordK. - f_equal. - - intros. - - match_wpshufd1_vpshufd1. - - set (ret _). - simpl in r. - subst r. - rewrite !zero_extend_u. - replace (word.subword _ _ a₁1) with a₁1. + replace (word.subword _ _ _) with a₁1. 2:{ destruct a₁1. cbn. apply word_ext. cbn. - rewrite Zmod_mod. + rewrite !Zmod_mod. rewrite Zmod_small. reflexivity. apply (ssrbool.elimT (iswordZP _ _)). apply i. } + + replace (truncate_chWord _ _) with (wrepr U8 140) by now repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). - replace (wpack U8 2 _) with (wrepr U8 140) by now do 3 (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). - replace (Hacspec_Lib_Pre.pub_u8 - (is_pure - (lift_to_both0 - (is_pure (lift_to_both0 (Hacspec_Lib_Pre.usize 140)))))) with (Hacspec_Lib_Pre.repr (WS := U8) 140) by reflexivity. - - apply r_ret. - intros. - split ; [ | assumption ]. - remove_T_ct. - Opaque Z.mul. - clear. - intros. - unfold vpshufd1. - unfold wpshufd1. - simpl. - apply word_ext. - f_equal. - simpl. - rewrite Zmod_mod. - unfold Hacspec_Lib_Pre.shift_right_, wshr, lsr, Hacspec_Lib_Pre.unsigned, wunsigned ; rewrite mkwordK. - f_equal. - - intros. - match_wpshufd1_vpshufd1. - + rewrite <- bind_ret. set (ret _). - simpl in r. + pattern (wshufps_128 (wrepr U8 140) a₁0 a₁1) in r. subst r. - rewrite !zero_extend_u. - replace (word.subword _ _ a₁1) with a₁1. - 2:{ - destruct a₁1. - cbn. - apply word_ext. - cbn. - rewrite Zmod_mod. - rewrite Zmod_small. - reflexivity. - apply (ssrbool.elimT (iswordZP _ _)). - apply i. - } + eapply (@r_bind _ _ _ _ (ret (wshufps_128 (wrepr U8 140) a₁0 a₁1))). + apply (wshufps_128_eq_state a₁0 a₁1 140). - replace (wpack U8 2 _) with (wrepr U8 140) by now do 3 (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). - replace (Hacspec_Lib_Pre.pub_u8 - (is_pure - (lift_to_both0 - (is_pure (lift_to_both0 (Hacspec_Lib_Pre.usize 140)))))) with (Hacspec_Lib_Pre.repr (WS := U8) 140) by reflexivity. - - apply r_ret. intros. - split ; [ | assumption ]. - remove_T_ct. - Opaque Z.mul. - clear. - intros. - unfold vpshufd1. - unfold wpshufd1. - simpl. - apply word_ext. - f_equal. - simpl. - rewrite Zmod_mod. - unfold Hacspec_Lib_Pre.shift_right_, wshr, lsr, Hacspec_Lib_Pre.unsigned, wunsigned ; rewrite mkwordK. - f_equal. - - intros. - apply r_ret. - - intros. - destruct H as [? [? [? [? [? [[]]]]]]]. + intros ? ? []. subst. split. - 2:{ - unfold H2. - exists x. easy. - } - - apply word_ext. - unfold wcat_r. - - unfold ".|". - unfold "_ shift_left _". - unfold Hacspec_Lib_Pre.shift_left_. - unfold Hacspec_Lib_Pre.int_or. - unfold Hacspec_Lib_Pre.repr. - unfold Hacspec_Lib_Pre.from_uint_size. - unfold Hacspec_Lib_Pre.usize. - unfold Hacspec_Lib_Pre.Z_uint_sizeable. - unfold Hacspec_Lib_Pre.unsigned. - unfold cast_int. - unfold lift_to_both0 , lift_to_both, is_pure. - unfold word.wor, wor. - unfold wshl, lsl. - unfold wrepr, wunsigned, urepr, val, word_subType, mkword, toword. - unfold Hacspec_Lib_Pre.repr. - unfold Hacspec_Lib_Pre.nat_uint_sizeable. - unfold Hacspec_Lib_Pre.repr. - unfold wrepr. - unfold mkword. - unfold toword. - unfold Hacspec_Lib_Pre.unsigned. - - rewrite !Zmod_small. - - all: try easy. - all: try (apply (num_smaller_if_modulus_smaller) ; easy). - - setoid_rewrite <- Z.lor_assoc. - setoid_rewrite <- Z.lor_assoc. - f_equal. - - rewrite Z.shiftl_0_l. - rewrite Z.lor_0_r. - rewrite Z.shiftl_0_l. - rewrite Z.lor_0_r. - - rewrite !Z.shiftl_lor. - f_equal. - - apply (shift_left_4_byte_ok 3) ; easy. - apply (shift_left_4_byte_ok 2) ; easy. - apply (shift_left_4_byte_ok 1) ; easy. - - - destruct a₁2, a₁3, a₁4, a₁5. - rewrite !Z.shiftl_lor. - rewrite !Z.shiftl_mul_pow2 ; try easy. - rewrite !Z.mul_0_l. - rewrite Z.lor_0_r. - replace (int_to_Z (Posz 32)) with 32%Z by reflexivity. - - destruct (ssrbool.elimT (iswordZP _ _) i). - destruct (ssrbool.elimT (iswordZP _ _) i0). - destruct (ssrbool.elimT (iswordZP _ _) i1). - destruct (ssrbool.elimT (iswordZP _ _) i2). - split. - { - apply Z.lor_nonneg. split. easy. - apply Z.lor_nonneg. split. apply Z.mul_nonneg_nonneg ; easy. - apply Z.lor_nonneg. split. repeat apply Z.mul_nonneg_nonneg ; easy. - repeat apply Z.mul_nonneg_nonneg ; easy. - } - { - rewrite <- !Z.mul_assoc. - rewrite <- !Z.pow_add_r ; try easy. - simpl. - - apply (Z_lor_pow2 toword _ nat127.+1). split ; [ easy | ]. - eapply Z.lt_trans ; [apply H0 | easy]. - - apply (Z_lor_pow2 (toword0 * _)%Z _ nat127.+1). split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. - eapply Z.lt_le_trans. - apply (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 32)) toword0) in H6 ; [ | easy]. - apply H6. - easy. - - apply (Z_lor_pow2 (toword1 * _)%Z _ nat127.+1). split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. - - eapply Z.lt_le_trans. - rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 64)) toword1) in H9 ; [ | easy]. - apply H9. - easy. - - split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. - eapply Z.lt_le_trans. - rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 96)) toword2) in H11 ; [ | easy]. - apply H11. - easy. - } - { - destruct a₁2, a₁3, a₁4, a₁5. -rewrite !Z.shiftl_lor. - rewrite !Z.shiftl_mul_pow2 ; try easy. - rewrite !Z.mul_0_l. - rewrite Z.lor_0_r. - replace (int_to_Z (Posz 32)) with 32%Z by reflexivity. - - destruct (ssrbool.elimT (iswordZP _ _) i). - destruct (ssrbool.elimT (iswordZP _ _) i0). - destruct (ssrbool.elimT (iswordZP _ _) i1). - destruct (ssrbool.elimT (iswordZP _ _) i2). - split. - { - apply Z.lor_nonneg. split. easy. - apply Z.lor_nonneg. split. apply Z.mul_nonneg_nonneg ; easy. - apply Z.lor_nonneg. split. repeat apply Z.mul_nonneg_nonneg ; easy. - apply Z.lor_nonneg. split. repeat apply Z.mul_nonneg_nonneg ; easy. - easy. - } - { - rewrite <- !Z.mul_assoc. - rewrite <- !Z.pow_add_r ; try easy. - simpl. - - apply (Z_lor_pow2 toword _ nat127.+1). split ; [ easy | ]. - eapply Z.lt_trans ; [apply H0 | easy]. - - apply (Z_lor_pow2 (toword0 * _)%Z _ nat127.+1). split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. - eapply Z.lt_le_trans. - apply (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 32)) toword0) in H6 ; [ | easy]. - apply H6. - easy. - - apply (Z_lor_pow2 (toword1 * _)%Z _ nat127.+1). split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. - - eapply Z.lt_le_trans. - rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 64)) toword1) in H9 ; [ | easy]. - apply H9. - easy. - - split. - apply Z.lor_nonneg. split. repeat apply Z.mul_nonneg_nonneg ; easy. - easy. - - apply (Z_lor_pow2 (toword2 * _)%Z _ nat127.+1). - - split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. - eapply Z.lt_le_trans. - rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 96)) toword2) in H11 ; [ | easy]. - apply H11. - easy. - easy. - } - } - { - destruct a₁2, a₁3, a₁4, a₁5. - rewrite !Z.shiftl_lor. - rewrite !Z.shiftl_mul_pow2 ; try easy. - rewrite !Z.mul_0_l. - rewrite Z.lor_0_r. - replace (int_to_Z (Posz 32)) with 32%Z by reflexivity. - - destruct (ssrbool.elimT (iswordZP _ _) i). - destruct (ssrbool.elimT (iswordZP _ _) i0). - destruct (ssrbool.elimT (iswordZP _ _) i1). - destruct (ssrbool.elimT (iswordZP _ _) i2). - split. - { - apply Z.lor_nonneg. split. easy. - apply Z.lor_nonneg. split. apply Z.mul_nonneg_nonneg ; easy. - apply Z.lor_nonneg. split. repeat apply Z.mul_nonneg_nonneg ; easy. - repeat apply Z.mul_nonneg_nonneg ; easy. - } - { - rewrite <- !Z.mul_assoc. - rewrite <- !Z.pow_add_r ; try easy. - simpl. - - apply (Z_lor_pow2 toword _ nat127.+1). split ; [ easy | ]. - eapply Z.lt_trans ; [apply H0 | easy]. - - apply (Z_lor_pow2 (toword0 * _)%Z _ nat127.+1). split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. - eapply Z.lt_le_trans. - apply (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 32)) toword0) in H6 ; [ | easy]. - apply H6. - easy. - - apply (Z_lor_pow2 (toword1 * _)%Z _ nat127.+1). split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. - - eapply Z.lt_le_trans. - rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 64)) toword1) in H9 ; [ | easy]. - apply H9. - easy. - - split ; [ apply Z.mul_nonneg_nonneg ; easy | ]. - eapply Z.lt_le_trans. - rewrite (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat (Pos.to_nat 96)) toword2) in H11 ; [ | easy]. - apply H11. - easy. - } - } - } + unfold make_vec. + cbn. + rewrite Z.lor_0_r. + destruct a₁2. cbn. unfold wrepr. cbn. apply word_ext. + rewrite Zmod_small. + cbn. + reflexivity. + apply (ssrbool.elimT (iswordZP _ _)). + apply i. + apply H0. } { apply r_ret. @@ -1352,7 +811,7 @@ rewrite !Z.shiftl_lor. Transparent translate_call. Qed. - Ltac bind_jazz_bind := + Ltac bind_jazz_bind := match goal with | [ |- context [ ⊢ ⦃ ?P ⦄ putr ?l ?y ?g ≈ bind ?a ?f ⦃ ?Q ⦄ ] ] => let yv := fresh in @@ -1469,10 +928,26 @@ rewrite !Z.shiftl_lor. } { (* wpshufd_128 _ 255 *) - admit. + + replace (wpack U8 2 _) with (wrepr U8 255%Z) by now repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). + apply (@wpshufd_128_eq_state _ a₁ 255). } { (* wshufps_128 _ 16 *) + replace (wpack U8 2 _) with (wrepr U8 16%Z) by now repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). + + rewrite <- bind_ret. + set (ret _). + pattern (wshufps_128 (wrepr U8 16) temp2 rkey) in r. + subst r. + eapply (@r_bind _ _ _ _ (ret (wshufps_128 (wrepr U8 16) temp2 rkey))). + apply (@wshufps_128_eq_state _ temp2 rkey 16). + + intros. + apply r_ret. + intros ? ? []. + subst. + (* This seems wrong? *) admit. } { From 06a27fcf50df39e3977731e423fd7e0cbd1a1132 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Tue, 20 Dec 2022 22:24:32 +0100 Subject: [PATCH 330/383] Clear whitespace --- theories/Jasmin/examples/aes/aes_hac.v | 34 +++++++++++++------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes_hac.v b/theories/Jasmin/examples/aes/aes_hac.v index bf89bd83..b4a55f14 100644 --- a/theories/Jasmin/examples/aes/aes_hac.v +++ b/theories/Jasmin/examples/aes/aes_hac.v @@ -71,7 +71,7 @@ Section Hacspec. Transparent translate_call. Defined. - + Lemma det_key_combine rcon rkey temp2 : deterministic (is_state (key_combine rcon rkey temp2)). Proof. repeat (apply deterministic_put || (apply deterministic_get ; intros) || apply deterministic_ret). @@ -89,7 +89,7 @@ Section Hacspec. | [ |- context [ ⊢ ⦃ ?P ⦄ putr ?l ?jazz ?f ≈ _ ⦃ ?Q ⦄ ] ] => eapply (@r_bind _ _ _ _ (ret jazz) _ (fun x => putr l x f) _ _ (fun '(v0, h0) '(v1, h1) => v0 = v1 /\ P (h0, h1)) _) ; [ rewrite !zero_extend_u | intros ] end. - + (* match goal with *) (* | [ |- context [ ⊢ ⦃ ?P ⦄ putr ?l ?jazz ?f ≈ _ ⦃ ?Q ⦄ ] ] => *) (* apply (@r_bind _ _ _ _ (ret jazz) _ (fun x => putr l x f) _ _ Q _) ; [ | intros ; unfold pre_to_post ] *) @@ -121,7 +121,7 @@ Section Hacspec. rewrite Zpower_nat_Z. rewrite Nat2Z.inj_add. rewrite Z2Nat.id ; [ | assumption]. - + rewrite <- Z.pow_sub_r ; [ now rewrite Z.add_simpl_r | lia | ]. split. assumption. lia. @@ -177,7 +177,7 @@ Section Hacspec. cbn. lia. Qed. - + Notation JVSHUFPS i rkey temp1 temp2 := (trc VSHUFPS i [('word U128 ; rkey) ; ('word U128 ; temp1) ; ('word U128 ; temp2)]). Lemma wpshufd1_eq : @@ -300,7 +300,7 @@ Section Hacspec. apply Z_mod_nonneg_nonneg. lia. easy. - + eapply Z.lt_le_trans. apply Z.mod_pos_bound. destruct i as [ | [ | [ | [] ]]] ; easy. @@ -311,7 +311,7 @@ Section Hacspec. apply Z_mod_nonneg_nonneg. lia. easy. - + eapply Z.lt_le_trans. apply Z.mod_pos_bound. destruct i as [ | [ | [ | [] ]]] ; easy. @@ -424,7 +424,7 @@ Section Hacspec. (* set (wpshufd1 _ _ _). *) (* set (wpshufd1 _ _ _). *) unfold vpshufd. - + solve_wpshufd1_vpshufd1 0 n. solve_wpshufd1_vpshufd1 1 n. solve_wpshufd1_vpshufd1 2 n. @@ -500,7 +500,7 @@ Section Hacspec. (* set (wpshufd1 _ _ _). *) (* set (wpshufd1 _ _ _). *) unfold vpshufd. - + solve_wpshufd1_vpshufd1 0 n. solve_wpshufd1_vpshufd1 1 n. solve_wpshufd1_vpshufd1 2 n. @@ -550,7 +550,7 @@ Section Hacspec. simpl. reflexivity. Qed. - + Lemma key_combined_eq id0 rcon rkey temp2 : ⊢ ⦃ fun '(_, _) => True ⦄ JKEY_COMBINE id0 rcon rkey temp2 @@ -670,7 +670,7 @@ Section Hacspec. apply (ssrbool.elimT (iswordZP _ _)). apply i. } - + replace (truncate_chWord _ _) with (wrepr U8 16) by now do 2 (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). unfold make_vec. @@ -678,8 +678,8 @@ Section Hacspec. rewrite Z.shiftl_0_l. rewrite Z.lor_0_r. - unfold mkword. - + unfold mkword. + epose (wshufps_128_eq_state temp2 rcon 16). unfold lift_scope. unfold is_state at 1. @@ -773,7 +773,7 @@ Section Hacspec. apply (ssrbool.elimT (iswordZP _ _)). apply i. } - + replace (truncate_chWord _ _) with (wrepr U8 140) by now repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). rewrite <- bind_ret. @@ -790,7 +790,7 @@ Section Hacspec. split. unfold make_vec. cbn. - rewrite Z.lor_0_r. + rewrite Z.lor_0_r. destruct a₁2. cbn. unfold wrepr. cbn. apply word_ext. rewrite Zmod_small. cbn. @@ -811,7 +811,7 @@ Section Hacspec. Transparent translate_call. Qed. - Ltac bind_jazz_bind := + Ltac bind_jazz_bind := match goal with | [ |- context [ ⊢ ⦃ ?P ⦄ putr ?l ?y ?g ≈ bind ?a ?f ⦃ ?Q ⦄ ] ] => let yv := fresh in @@ -881,7 +881,7 @@ Section Hacspec. apply better_r_put_lhs. do 2 remove_get_in_lhs. rewrite !zero_extend_u. - + setoid_rewrite bind_assoc ; bind_jazz_bind ; [shelve | ]. apply better_r_put_lhs. do 2 remove_get_in_lhs. @@ -928,7 +928,7 @@ Section Hacspec. } { (* wpshufd_128 _ 255 *) - + replace (wpack U8 2 _) with (wrepr U8 255%Z) by now repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). apply (@wpshufd_128_eq_state _ a₁ 255). } From c865aa1656cf603dfe4de022cba46cefe24057fc Mon Sep 17 00:00:00 2001 From: bshvass Date: Wed, 21 Dec 2022 04:38:23 +0100 Subject: [PATCH 331/383] new invariants based on predicates and corresponding advantage rules --- theories/Crypt/package/pkg_invariants.v | 128 +++++++++++++++++++++++- theories/Crypt/package/pkg_rhl.v | 122 ++++++++++++++++++++++ 2 files changed, 249 insertions(+), 1 deletion(-) diff --git a/theories/Crypt/package/pkg_invariants.v b/theories/Crypt/package/pkg_invariants.v index aba4a0ff..552ac788 100644 --- a/theories/Crypt/package/pkg_invariants.v +++ b/theories/Crypt/package/pkg_invariants.v @@ -62,6 +62,43 @@ Definition INV' (L1 L2 : {fset Location}) (I (s1, s2) → ∀ l v, l \notin L1 → l \notin L2 → I (set_heap s1 l v, set_heap s2 l v)). +Definition pINV' (P1 P2 : Location -> Prop) + (I : heap_choiceType * heap_choiceType → Prop) + := + ∀ s1 s2, + (I (s1, s2) → ∀ l, ~ P1 l → ~ P2 l → + get_heap s1 l = get_heap s2 l) ∧ + (I (s1, s2) → ∀ l v, ~ P1 l -> ~ P2 l → + I (set_heap s1 l v, set_heap s2 l v)). + +(* TODO: move? *) +Definition pdisjoint (L : {fset Location}) (P : Location -> Prop) := forall l, ~ (l \in L /\ P l). + +Lemma pINV'_to_INV (L : {fset Location}) P1 P2 + (I : heap_choiceType * heap_choiceType → Prop) + (HpINV' : pINV' P1 P2 I) + (Hdisjoint1 : pdisjoint L P1) + (Hdisjoint2 : pdisjoint L P2) : + INV L I. +Proof. + unfold INV. + intros s1 s2. split. + - intros hi l hin. + apply HpINV'. + + assumption. + + intros contra. + eapply Hdisjoint1. eauto. + + intros contra. + eapply Hdisjoint2. eauto. + - intros hi l v hin. + apply HpINV'. + + assumption. + + intros contra. + eapply Hdisjoint1. eauto. + + intros contra. + eapply Hdisjoint2. eauto. +Qed. + Lemma INV'_to_INV (L L1 L2 : {fset Location}) (I : heap_choiceType * heap_choiceType → Prop) (HINV' : INV' L1 L2 I) @@ -86,6 +123,12 @@ Proof. apply Hdisjoint2. assumption. Qed. +(* TODO: add automation? *) +Class pInvariant P₀ P₁ pinv := { + pinv_pINV' : pINV' P₀ P₁ pinv ; + pinv_empty : pinv (empty_heap, empty_heap) +}. + Class Invariant L₀ L₁ inv := { inv_INV' : INV' L₀ L₁ inv ; inv_empty : inv (empty_heap, empty_heap) @@ -119,7 +162,12 @@ Definition heap_ignore (L : {fset Location}) : precond := λ '(h₀, h₁), ∀ (ℓ : Location), ℓ \notin L → get_heap h₀ ℓ = get_heap h₁ ℓ. +Definition heap_ignore_pred (P : Location -> Prop) : precond := + λ '(h₀, h₁), + forall (ℓ : Location), ~ P ℓ -> get_heap h₀ ℓ = get_heap h₁ ℓ. + Arguments heap_ignore : simpl never. +Arguments heap_ignore_pred : simpl never. Lemma heap_ignore_empty : ∀ L, @@ -128,6 +176,35 @@ Proof. intros L ℓ hℓ. reflexivity. Qed. +Lemma heap_ignore_pred_empty : + ∀ P, + heap_ignore_pred P (empty_heap, empty_heap). +Proof. + intros P ℓ hℓ. reflexivity. +Qed. + +Lemma INV'_heap_ignore_pred (P : Location -> Prop) : + ∀ L0 L1 : {fset Location}, + (forall ℓ : Location, P ℓ -> ℓ \in L0 :|: L1) -> + INV' L0 L1 (heap_ignore_pred P). +Proof. + intros L0 L1 hP h0 h1. split. + - intros hh l nin0 nin1. + eapply hh. + intros contra. + apply hP in contra as h. + rewrite in_fsetU in h. move: h => /orP [h | h]. + + rewrite h in nin0. discriminate. + + rewrite h in nin1. discriminate. + - intros h ℓ v n₀ n₁ ℓ' n. + destruct (ℓ' != ℓ) eqn:e. + + rewrite get_set_heap_neq. 2: auto. + rewrite get_set_heap_neq. 2: auto. + apply h. auto. + + move: e => /eqP e. subst. + rewrite !get_set_heap_eq. reflexivity. +Qed. + Lemma INV'_heap_ignore : ∀ L L₀ L₁, fsubset L (L₀ :|: L₁) → @@ -150,6 +227,16 @@ Proof. rewrite !get_set_heap_eq. reflexivity. Qed. +Lemma Invariant_heap_ignore_pred : + ∀ L0 L1 (P : Location -> Prop), + (forall ℓ : Location, P ℓ -> ℓ \in L0 :|: L1) -> + Invariant L0 L1 (heap_ignore_pred P). +Proof. + intros L P h. split. + - apply INV'_heap_ignore_pred. auto. + - apply heap_ignore_pred_empty. +Qed. + Lemma Invariant_heap_ignore : ∀ L L₀ L₁, fsubset L (L₀ :|: L₁) → @@ -164,6 +251,45 @@ Qed. eapply Invariant_heap_ignore : (* typeclass_instances *) ssprove_invariant. +(* TODO: naming? This doesn't seem to correspond to heap_ignore, due to the missing negation, but I use it that way *) +Definition pheap_ignore (P : Location -> Prop) : precond := + λ '(h₀, h₁), + forall (ℓ : Location), P ℓ -> get_heap h₀ ℓ = get_heap h₁ ℓ. + +Lemma pheap_ignore_empty : + ∀ P, + pheap_ignore P (empty_heap, empty_heap). +Proof. intros P ℓ hℓ. reflexivity. Qed. + +Lemma pINV'_pheap_ignore (P : Location -> Prop) : + ∀ P0 P1 : Location -> Prop, + (forall ℓ : Location, ~ P0 ℓ /\ ~ P1 ℓ -> P ℓ) -> + pINV' P0 P1 (pheap_ignore P). +Proof. + intros P0 P1 hP h0 h1. split. + - intros hh l nin1 nin2. + eapply hh. + apply hP. + eauto. + - intros h ℓ v nin0 nin1 ℓ' n. + destruct (ℓ' != ℓ) eqn:e. + + rewrite get_set_heap_neq. 2: auto. + rewrite get_set_heap_neq. 2: auto. + apply h. auto. + + move: e => /eqP e. subst. + rewrite !get_set_heap_eq. reflexivity. +Qed. + +Lemma pInvariant_pheap_ignore : + ∀ P0 P1 (P : Location -> Prop), + (forall ℓ : Location, ~ P0 ℓ /\ ~ P1 ℓ -> P ℓ) -> + pInvariant P0 P1 (pheap_ignore P). +Proof. + intros L P h. split. + - apply pINV'_pheap_ignore. auto. + - apply pheap_ignore_empty. +Qed. + (* Not-really-symmetric (in use) conjunction of invariants *) Definition inv_conj (inv inv' : precond) := λ s, inv s ∧ inv' s. @@ -1598,4 +1724,4 @@ Proof. specialize ih with (1 := h). specialize ih with (1 := hh). rewrite e in ih. apply ih. -Qed. \ No newline at end of file +Qed. diff --git a/theories/Crypt/package/pkg_rhl.v b/theories/Crypt/package/pkg_rhl.v index 381931a8..6d35c83e 100644 --- a/theories/Crypt/package/pkg_rhl.v +++ b/theories/Crypt/package/pkg_rhl.v @@ -412,6 +412,105 @@ Proof. * cbn. intros s₀' s₁' [? ?]. subst. auto. Qed. +(* TODO: generalize, this proof is the same as for eq_upto_inv_perf_ind*) +Lemma eq_upto_pinv_perf_ind : + ∀ {P0 P1 L₀ L₁ LA E} (p₀ p₁ : raw_package) (I : precond) (A : raw_package) + `{ValidPackage L₀ Game_import E p₀} + `{ValidPackage L₁ Game_import E p₁} + `{ValidPackage LA E A_export A}, + pINV' P0 P1 I → + I (empty_heap, empty_heap) → + pdisjoint LA P0 → + pdisjoint LA P1 → + eq_up_to_inv E I p₀ p₁ → + AdvantageE p₀ p₁ A = 0. +Proof. + intros P0 P1 L₀ L₁ LA E p₀ p₁ I A vp₀ vp₁ vA hI' hIe hd₀ hd₁ hp. + unfold AdvantageE, Pr. + pose r := get_op_default A RUN tt. + assert (hI : INV LA I). 1: eapply pINV'_to_INV; eauto. + unshelve epose proof (eq_up_to_inv_adversary_link p₀ p₁ I r hI hp) as h. + 1:{ + eapply valid_get_op_default. + - eauto. + - auto_in_fset. + } + assert ( + ∀ x y : tgt RUN * heap_choiceType, + (let '(b₀, s₀) := x in λ '(b₁, s₁), b₀ = b₁ ∧ I (s₀, s₁)) y → + (fst x == true) ↔ (fst y == true) + ) as Ha. + { intros [b₀ s₀] [b₁ s₁]. simpl. + intros [e ?]. rewrite e. intuition auto. + } + unfold Pr_op. + unshelve epose (rhs := thetaFstd _ (repr (code_link r p₀)) empty_heap). + simpl in rhs. + epose (lhs := Pr_op (A ∘ p₀) RUN tt empty_heap). + assert (lhs = rhs) as he. + { subst lhs rhs. + unfold Pr_op. unfold Pr_code. + unfold thetaFstd. simpl. apply f_equal2. 2: reflexivity. + apply f_equal. apply f_equal. + rewrite get_op_default_link. reflexivity. + } + unfold lhs in he. unfold Pr_op in he. + rewrite he. + unshelve epose (rhs' := thetaFstd _ (repr (code_link r p₁)) empty_heap). + simpl in rhs'. + epose (lhs' := Pr_op (A ∘ p₁) RUN tt empty_heap). + assert (lhs' = rhs') as e'. + { subst lhs' rhs'. + unfold Pr_op. unfold Pr_code. + unfold thetaFstd. simpl. apply f_equal2. 2: reflexivity. + apply f_equal. apply f_equal. + rewrite get_op_default_link. reflexivity. + } + unfold lhs' in e'. unfold Pr_op in e'. + rewrite e'. + unfold rhs', rhs. + unfold SDistr_bind. unfold SDistr_unit. + rewrite !dletE. + assert ( + ∀ x : bool_choiceType * heap_choiceType, + ((let '(b, _) := x in dunit (R:=R) (T:=bool_choiceType) b) true) == + (x.1 == true)%:R + ) as h1. + { intros [b s]. + simpl. rewrite dunit1E. apply/eqP. reflexivity. + } + assert ( + ∀ y, + (λ x : prod_choiceType (tgt RUN) heap_choiceType, (y x) * (let '(b, _) := x in dunit (R:=R) (T:=tgt RUN) b) true) = + (λ x : prod_choiceType (tgt RUN) heap_choiceType, (x.1 == true)%:R * (y x)) + ) as Hrew. + + { intros y. extensionality x. + destruct x as [x1 x2]. + rewrite dunit1E. + simpl. rewrite GRing.mulrC. reflexivity. + } + rewrite !Hrew. + unfold TransformingLaxMorph.rlmm_from_lmla_obligation_1. simpl. + unfold SubDistr.SDistr_obligation_2. simpl. + unfold OrderEnrichedRelativeAdjunctionsExamples.ToTheS_obligation_1. + rewrite !SDistr_rightneutral. simpl. + pose proof (Pr_eq_empty _ _ _ _ h hIe Ha) as Heq. + simpl in Heq. + unfold θ_dens in Heq. + simpl in Heq. unfold pr in Heq. + simpl in Heq. + rewrite Heq. + rewrite /StateTransfThetaDens.unaryStateBeta'_obligation_1. + assert (∀ (x : R), `|x - x| = 0) as Hzero. + { intros x. + assert (x - x = 0) as H3. + { apply /eqP. rewrite GRing.subr_eq0. intuition. } + rewrite H3. apply normr0. + } + apply Hzero. +Qed. + Lemma eq_upto_inv_perf_ind : ∀ {L₀ L₁ LA E} (p₀ p₁ : raw_package) (I : precond) (A : raw_package) `{ValidPackage L₀ Game_import E p₀} @@ -519,6 +618,29 @@ Proof. apply Hzero. Qed. +(* TODO: move? to pkg_advantage *) +Definition padv_equiv P₀ P₁ {L₀ L₁ E} (G₀ G₁ : raw_package) + `{ValidPackage L₀ Game_import E G₀} `{ValidPackage L₁ Game_import E G₁} ε := + ∀ LA A, + ValidPackage LA E A_export A → + pdisjoint LA P₀ → + pdisjoint LA P₁ → + AdvantageE G₀ G₁ A = ε A. + +Lemma eq_rel_perf_ind' : + ∀ {P0 P1 L₀ L₁ E} (p₀ p₁ : raw_package) (inv : precond) + `{ValidPackage L₀ Game_import E p₀} + `{ValidPackage L₁ Game_import E p₁}, + pInvariant P0 P1 inv → + eq_up_to_inv E inv p₀ p₁ → + padv_equiv P0 P1 p₀ p₁ (λ _ : raw_package, 0%R). + (* p₀ ≈₀ p₁. *) +Proof. + intros P0 P1 L₀ L₁ E p₀ p₁ inv v₀ v₁ [? ?] he. + intros LA A vA hd₀ hd₁. + eapply eq_upto_pinv_perf_ind. all: eauto. +Qed. + Lemma eq_rel_perf_ind : ∀ {L₀ L₁ E} (p₀ p₁ : raw_package) (inv : precond) `{ValidPackage L₀ Game_import E p₀} From 06494116af01409ca93aeda90c76094066f92306 Mon Sep 17 00:00:00 2001 From: bshvass Date: Wed, 21 Dec 2022 04:43:36 +0100 Subject: [PATCH 332/383] generalized specs of intermidiate imperative aes (Caes, Cenc, etc.) also added some experimental equivalences for translated code using raw sets of locations instead of predicates, note that these are very slow and should probably be commented out --- theories/Jasmin/examples/aes/aes.v | 323 ++++++++++++++++++++++------- 1 file changed, 246 insertions(+), 77 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes.v b/theories/Jasmin/examples/aes/aes.v index 911c0015..ec1766b8 100644 --- a/theories/Jasmin/examples/aes/aes.v +++ b/theories/Jasmin/examples/aes/aes.v @@ -23,7 +23,7 @@ From extructures Require Import ord fset fmap. Require Import micromega.Lia. From mathcomp.word Require Import word ssrZ. -From JasminSSProve Require Import aes_jazz jasmin_utils. +From JasminSSProve Require Import aes_jazz jasmin_utils aes_valid. Import JasminNotation JasminCodeNotation. Import PackageNotation. @@ -35,6 +35,9 @@ Definition pdisj (P : precond) (s_id : p_id) (rhs : {fset Location}) := (forall h1 h2 l a v s_id', l = translate_var s_id' v -> (s_id ⪯ s_id') -> (P (h1, h2) -> P (set_heap h1 l a, h2))) /\ (forall h1 h2 l a, l \in rhs -> (P (h1, h2) -> P (h1, set_heap h2 l a))). +Definition u_pdisj (P : precond) (lhs : {fset Location}) := + (forall h1 h2 l a, l \in lhs -> (P (h1, h2) -> P (set_heap h1 l a, h2))). + Ltac solve_in := repeat match goal with | |- is_true (?v \in fset1 ?v :|: _) => apply/fsetU1P; left; auto @@ -129,6 +132,19 @@ Ltac pdisj_apply h := | |- _ => try assumption end. +Ltac pdisj'_apply h := + lazymatch goal with + | |- ?pre (set_heap _ _ _, _) => eapply h; [ tr_auto_in_fset | pdisj'_apply h ] + | |- ?pre (_, set_heap _ _ _) => eapply h; [ auto_in_fset | pdisj'_apply h ] + | |- _ => try assumption + end. + +Ltac u_pdisj_apply h := + lazymatch goal with + | |- ?pre (set_heap _ _ _, _) => eapply h; [ solve_in | u_pdisj_apply h ] + | |- _ => try assumption + end. + Definition rcon (i : Z) : u8 := nth (wrepr U8 54%Z) [:: (wrepr U8 1%Z); (wrepr U8 2%Z); (wrepr U8 4%Z); (wrepr U8 8%Z); (wrepr U8 16%Z); (wrepr U8 32%Z); (wrepr U8 64%Z); (wrepr U8 128%Z); (wrepr U8 27%Z); (wrepr U8 54%Z)]%Z ((Z.to_nat i) - 1). Notation hdtcA res := (coerce_to_choice_type ('array) (hd ('word U64 ; chCanonical _) res).π2). @@ -171,6 +187,33 @@ Proof. apply H in H13. lia. Qed. +Definition pdisj' (P : precond) (s_id : p_id) (lhs : {fset Location}) (rhs : {fset Location}) := + (forall h1 h2 l a, l \in lhs -> (P (h1, h2) -> P (set_heap h1 l a, h2))) /\ + (forall h1 h2 l a, l \in rhs -> (P (h1, h2) -> P (h1, set_heap h2 l a))). + +Lemma rcon_correct' id0 pre i : + (pdisj' pre id0 (JRCON_locs id0) fset0) -> + (forall s0 s1, pre (s0, s1) -> (1 <= i < 11)%Z) -> + ⊢ ⦃ fun '(s0, s1) => pre (s0, s1) ⦄ JRCON id0 i + ≈ ret tt + ⦃ fun '(v0, s0) '(v1, s1) => pre (s0, s1) /\ exists o, v0 = ([('int ; o)] : tchlist) /\ o = wunsigned (rcon i) ⦄. +Proof. + unfold JRCON. + unfold JRCON_locs. + unfold get_translated_static_fun. + simpl. + intros Hpdisj H. + simpl_fun. + (* repeat setjvars. *) + repeat match goal with + | |- context[(?a =? ?b)%Z] => let E := fresh in destruct (a =? b)%Z eqn:E; [rewrite ?Z.eqb_eq in E; subst|] + | |- _ => simpl; ssprove_contract_put_get_lhs; rewrite !coerce_to_choice_type_K + end. + all: ssprove_code_simpl; rewrite !coerce_to_choice_type_K; eapply r_put_lhs; ssprove_contract_put_get_lhs; eapply r_put_lhs; eapply r_ret. + all: intros; destruct_pre; split_post; [ pdisj'_apply Hpdisj | rewrite coerce_to_choice_type_K; eexists; split; eauto ]. + destruct (i =? 10)%Z eqn:E. rewrite Z.eqb_eq in E. subst. reflexivity. + apply H in H13. lia. +Qed. (* copy of the easycrypt functional definition *) Definition W4u8 : 4.-tuple u8 -> u32 := wcat. Definition W4u32 : 4.-tuple u32 -> u128 := wcat. @@ -970,6 +1013,42 @@ Proof. auto. auto. Qed. +Lemma key_expandP' pre id0 rcon rkey temp2 rcon_ : + pdisj' pre id0 (JKEY_EXPAND_locs id0) fset0 → + toword rcon_ = rcon → + (forall s0 s1, pre (s0, s1) -> subword 0 U32 temp2 = word0) → + ⊢ ⦃ λ '(s0, s1), pre (s0, s1) ⦄ + JKEY_EXPAND id0 rcon rkey temp2 + ≈ ret tt + ⦃ λ '(v0, s0) '(v1, s1), + pre (s0, s1) ∧ + ∃ o1 o2, + v0 = [ ('word U128 ; o1) ; ('word U128 ; o2) ] ∧ + o1 = key_expand rkey rcon_ ∧ + subword 0 U32 o2 = word0 + ⦄. +Proof. + unfold JKEY_EXPAND, JKEY_EXPAND_locs. + unfold get_translated_static_fun. + simpl. + intros disj Hrcon Htemp2. + simpl_fun. + (* repeat setjvars. *) + time repeat clear_get. + unfold sopn_sem, tr_app_sopn_tuple, tr_app_sopn_single. + simpl. + rewrite !zero_extend_u. + rewrite !coerce_to_choice_type_K. + + repeat eapply r_put_lhs. + eapply r_ret. + intros s0 s1 Hpre. + destruct_pre; split_post. + - pdisj'_apply disj. + - eexists _, _. intuition auto. + + apply key_expand_aux. reflexivity. eapply Htemp2. eassumption. + + apply key_expand_aux2. eapply Htemp2. eassumption. +Qed. Lemma key_expandP pre id0 rcon rkey temp2 rcon_ : pdisj pre id0 fset0 → toword rcon_ = rcon → @@ -1047,12 +1126,12 @@ Qed. Lemma u_for_loop'_rule I c lo hi : lo <= hi -> (∀ i, (lo <= i < hi)%Z -> - ⊢ ⦃ λ '(s₀, _), I i s₀ ⦄ + ⊢ ⦃ λ '(s₀, s₁), I i s₀ s₁ ⦄ c i ≈ ret tt - ⦃ λ '(_, s₀) '(_, _), I (Z.succ i) s₀ ⦄) → - ⊢ ⦃ λ '(s₀, _), I lo s₀ ⦄ + ⦃ λ '(_, s₀) '(_, s₁), I (Z.succ i) s₀ s₁ ⦄) → + ⊢ ⦃ λ '(s₀, s₁), I lo s₀ s₁ ⦄ for_loop' c lo hi ≈ ret tt - ⦃ λ '(_,s₀) '(_,_), I hi s₀ ⦄. + ⦃ λ '(_,s₀) '(_,s₁), I hi s₀ s₁ ⦄. Proof. intros hle h. remember (Z.to_nat (hi - lo)). @@ -1086,16 +1165,77 @@ Proof. f_equal. Qed. -Lemma u_for_loop'_rule' (I : Z -> heap -> Prop) c lo hi (pre : precond) : +Lemma for_loop'_ret I c lo hi : lo <= hi -> - (forall h1 h2, pre (h1, h2) -> I lo h1) -> (∀ i, (lo <= i < hi)%Z -> - ⊢ ⦃ λ '(s₀, _), I i s₀ ⦄ + ⊢ ⦃ λ '(h0, h1), I i h0 h1 ⦄ c i ≈ ret tt - ⦃ λ '(_, s₀) '(_, _), I (Z.succ i) s₀ ⦄) → + ⦃ λ '(_, h0) '(_, h1), I (Z.succ i) h0 h1 ⦄) → + ⊢ ⦃ λ '(h0, h1), I lo h0 h1 ⦄ + for_loop' c lo hi ≈ ret tt + ⦃ λ '(_,h0) '(_,h1), I hi h0 h1 ⦄. +Proof. + intros hle h. + remember (Z.to_nat (hi - lo)). + revert hle h Heqn. revert lo hi. + induction n as [| n ih]; intros. + - simpl. + assert (hi = lo). + { zify. lia. } + unfold for_loop'. + simpl. + rewrite -Heqn. + simpl. + subst. + apply r_ret. + easy. + - unfold for_loop'. + simpl. rewrite -Heqn. simpl. rewrite Z.add_0_r. + eapply r_bind with (m₁ := ret tt) (f₁ := fun _ => _). + + eapply h. lia. + + intros a1 a2. + destruct a1, a2. + replace [seq lo + Z.of_nat i | i <- iota 1 n] with [seq (Z.succ lo) + Z.of_nat i | i <- iota 0 n]. + replace n with (Z.to_nat (hi - Z.succ lo)). + eapply ih. + * lia. + * intros i hi2. apply h. lia. + * lia. + * lia. + * replace (iota 1 n) with (iota (0 + 1) n). apply iota_aux. + intros. lia. + f_equal. +Qed. + +Lemma for_loop'_ret' (I : Z -> heap -> heap -> Prop) c lo hi (pre : precond): + lo <= hi -> + (forall h1 h2, pre (h1, h2) -> I lo h1 h2) -> + (∀ i, (lo <= i < hi)%Z -> + ⊢ ⦃ λ '(h0, h1), I i h0 h1 ⦄ + c i ≈ ret tt + ⦃ λ '(_, h0) '(_, h1), I (Z.succ i) h0 h1 ⦄) → ⊢ ⦃ pre ⦄ for_loop' c lo hi ≈ ret tt - ⦃ λ '(_,s₀) '(_,_), I hi s₀ ⦄. + ⦃ λ '(_,h0) '(_,h1), I hi h0 h1 ⦄. +Proof. + intros. + eapply rpre_weaken_rule. + eapply for_loop'_ret. + assumption. + assumption. + apply H0. +Qed. + +Lemma u_for_loop'_rule' (I : Z -> heap -> heap -> Prop) c lo hi (pre : precond) : + lo <= hi -> + (forall h1 h2, pre (h1, h2) -> I lo h1 h2) -> + (∀ i, (lo <= i < hi)%Z -> + ⊢ ⦃ λ '(s₀, s₁), I i s₀ s₁ ⦄ + c i ≈ ret tt + ⦃ λ '(_, s₀) '(_, s₁), I (Z.succ i) s₀ s₁ ⦄) → + ⊢ ⦃ pre ⦄ + for_loop' c lo hi ≈ ret tt + ⦃ λ '(_,s₀) '(_,s₁), I hi s₀ s₁ ⦄. Proof. intros. eapply rpre_weaken_rule. @@ -1477,64 +1617,71 @@ Definition key_i (k : u128) i := From extructures Require Import ord. -Lemma aes_keyExpansion_h k : - ⊢ ⦃ fun '(h0, h1) => True ⦄ +Lemma aes_keyExpansion_h (pre : precond) k : + u_pdisj pre [fset rkeys] -> + ⊢ ⦃ fun '(h0, h1) => pre (h0, h1) ⦄ keyExpansion k ≈ ret tt - ⦃ fun '(v0, h0) '(_, _) => forall i, 0 <= i < 11 -> (getmd v0 word0 i) = key_i k (Z.to_nat i) ⦄. + ⦃ fun '(v0, h0) '(_, h1) => pre (h0, h1) /\ forall i, 0 <= i < 11 -> (getmd v0 word0 i) = key_i k (Z.to_nat i) ⦄. Proof. + intros Hdisj. unfold keyExpansion. - eapply r_put_lhs with (pre := fun _ => _). + eapply r_put_lhs with (pre := fun '(_, _) => _). eapply r_get_remember_lhs. intros x. eapply r_put_lhs. eapply r_bind with (m₁ := ret _). - eapply u_for_loop'_rule' with - (I:= fun i => fun h => forall j, 0 <= j < i -> getmd (get_heap h rkeys) word0 j = key_i k (Z.to_nat j)). -lia. - - intros i ile Hpre. + eapply for_loop'_ret' with + (I:= fun i => fun h0 h1 => pre (h0, h1) /\ forall j, 0 <= j < i -> getmd (get_heap h0 rkeys) word0 j = key_i k (Z.to_nat j)). + lia. + - intros h1 h2 Hset. destruct_pre. - intros j Hj. - rewrite !get_set_heap_eq. - unfold getmd. - rewrite setmE. - assert (@eq_op (Ord.eqType Z_ordType) j Z0) by (apply/eqP; lia). - rewrite H. - move: H=>/eqP ->. - simpl. - reflexivity. + split_post. + + u_pdisj_apply Hdisj. + + intros j Hj. + unfold getmd. + sheap. + rewrite setmE. + assert (@eq_op (Ord.eqType Z_ordType) j Z0) by (apply/eqP; lia). + rewrite H. + move: H=>/eqP ->. + simpl. + reflexivity. - intros i ile. ssprove_code_simpl. eapply r_get_remember_lhs with (pre := fun '(_, _) => _). intros x0. eapply r_put_lhs. eapply r_ret. intros s0 s1 Hpre. - destruct_pre. - intros j Hj. - rewrite get_set_heap_eq. - rewrite -> H4 by lia. - unfold getmd in *. - rewrite setmE. - destruct (Z.eq_dec j i). - + subst. - rewrite eq_refl. - rewrite zero_extend_u. - replace (Z.to_nat i) with (Z.to_nat (i - 1)).+1 by lia. - unfold key_i at 2. - rewrite iteriS. - f_equal. f_equal. simpl. lia. - + assert (@eq_op (Ord.eqType Z_ordType) j i = false). - apply/eqP. assumption. - rewrite H0. - rewrite H4. - reflexivity. - lia. + destruct_pre. split_post. + + u_pdisj_apply Hdisj. + + intros j Hj. + rewrite get_set_heap_eq. + rewrite -> H6 by lia. + unfold getmd in *. + rewrite setmE. + destruct (Z.eq_dec j i). + * subst. + rewrite eq_refl. + rewrite zero_extend_u. + replace (Z.to_nat i) with (Z.to_nat (i - 1)).+1 by lia. + unfold key_i at 2. + rewrite iteriS. + f_equal. f_equal. simpl. lia. + * assert (@eq_op (Ord.eqType Z_ordType) j i = false). + apply/eqP. assumption. + rewrite H1. + rewrite H6. + reflexivity. + lia. - intros s0 s1. eapply r_get_remember_lhs with (pre := fun '(_, _) => _). intros x0. eapply r_ret. - intros s2 s3 Hpre i Hi. + intros s2 s3 Hpre. destruct_pre. - apply H1. lia. + split. + + easy. + + apply H2. Qed. (* hoare aes_keyExpansion_h k : *) (* Aes.keyExpansion : key = k *) @@ -1858,16 +2005,16 @@ Lemma keys_expand_jazz_correct pre id0 rkey : ret tt ⦃ fun '(v0, _) '(_, _) => forall i, 0 <= i < 11 -> getmd (to_arr U128 (mkpos 11) (hdtcA v0)) word0 i = key_i rkey (Z.to_nat i) ⦄. Proof. - intros h. - eapply u_trans_det' with (P0 := fun '(_, _) => True) (P1 := fun '(_, _) => _). - 7: { eapply aes_keyExpansion_h. } - 6: { eapply keyExpansion_E'. eassumption. } - - easy. - - easy. - - intros. simpl in *. rewrite H. apply H0. assumption. - - unfold keyExpansion. - repeat constructor. - - admit. (* TODO: figure out how to do this *) +(* intros h. *) +(* eapply u_trans_det' with (P0 := fun '(_, _) => _) (P1 := fun '(_, _) => _). *) +(* 7: { eapply aes_keyExpansion_h. } *) +(* 6: { eapply keyExpansion_E'. eassumption. } *) +(* - easy. *) +(* - easy. *) +(* - intros. simpl in *. rewrite H. apply H0. assumption. *) +(* - unfold keyExpansion. *) +(* repeat constructor. *) +(* - admit. (* TODO: figure out how to do this *) *) Admitted. Definition aes (key msg : u128) := @@ -1896,48 +2043,53 @@ Definition aes_rounds (rkeys : 'arr U128) (msg : 'word U128) : raw_code u128 := state0 ← get state ;; ret state0. -Lemma aes_rounds_h rkeys k m : - ⊢ ⦃ fun '(_, _) => (forall i, 0 <= i < 11 -> getmd rkeys word0 i = key_i k (Z.to_nat i)) ⦄ +Lemma aes_rounds_h rkeys k m pre : + u_pdisj pre [fset state] -> + ⊢ ⦃ fun '(h0, h1) => pre (h0, h1) /\ (forall i, 0 <= i < 11 -> getmd rkeys word0 i = key_i k (Z.to_nat i)) ⦄ aes_rounds rkeys m ≈ ret tt - ⦃ fun '(v0, _) '(_, _) => v0 = aes k m ⦄. + ⦃ fun '(v0, h0) '(_, h1) => pre (h0, h1) /\ v0 = aes k m ⦄. Proof. unfold aes_rounds. - eapply r_put_lhs with (pre := fun _ => _). + intros Hdisj. + eapply r_put_lhs with (pre := fun '(_, _) => _). eapply r_bind with (m₁ := ret _). set (st0 := m ⊕ (key_i k 0%nat)). eapply u_for_loop'_rule' with - (I := fun i => fun h => get_heap h state = iteri (Z.to_nat i - 1) (fun i state => wAESENC_ state (key_i k (i + 1))) st0 + (I := fun i => fun h0 h1 => pre (h0, h1) /\ get_heap h0 state = iteri (Z.to_nat i - 1) (fun i state => wAESENC_ state (key_i k (i + 1))) st0 /\ (forall i, 0 <= i < 11 -> getmd rkeys word0 i = key_i k (Z.to_nat i))). - lia. - intros. simpl. destruct_pre. sheap. split_post. - + rewrite H1. reflexivity. lia. + + u_pdisj_apply Hdisj. + + rewrite H3. reflexivity. lia. + assumption. - intros i Hi. eapply r_get_remember_lhs with (pre := fun '(_, _) => _). intros x. eapply r_put_lhs. eapply r_ret. - intros s0 s1 pre. + intros s0 s1 Hpre. destruct_pre; sheap; split_post. + + u_pdisj_apply Hdisj. + replace (Z.to_nat (Z.succ i) - 1)%nat with ((Z.to_nat i - 1).+1) by lia. rewrite iteriS. - rewrite H0. - rewrite H6. repeat f_equal. lia. lia. + rewrite H4. + rewrite H7. repeat f_equal. lia. lia. + assumption. - intros a0 a1. eapply r_get_remember_lhs with (pre := fun '(_, _) => _). intros x. eapply r_put_lhs. eapply r_get_remember_lhs. intros x0. eapply r_ret. - intros s0 s1 pre. - destruct pre as [[s2 [[[H5 H4] H3] H2]] H1]. + intros s0 s1 Hpre. + destruct Hpre as [[s2 [[[H5 [H4 H6]] H3] H2]] H1]. simpl in H3, H1. subst. sheap. + split; [u_pdisj_apply Hdisj|]. unfold aes. rewrite H4. - rewrite H5. + rewrite H6. replace ((Z.to_nat 10) - 1)%nat with 9%nat by reflexivity. reflexivity. lia. Qed. @@ -2069,25 +2221,40 @@ Definition Caes (key msg : u128) := cipher ← aes_rounds rkeys msg ;; ret cipher. -Lemma aes_h k m : +Definition Cenc_locs := [:: state ; rkeys]. + +Lemma aes_h k m pre : (* (forall i, (0 <= i < 11)%nat -> rkeys i = Some (key_i k i)) -> *) - ⊢ ⦃ fun '(_, _) => True ⦄ + (u_pdisj pre [fset state ; rkeys]) -> + ⊢ ⦃ fun '(h0, h1) => pre (h0, h1) ⦄ Caes k m ≈ ret tt - ⦃ fun '(v0, _) '(_, _) => v0 = aes k m ⦄. + ⦃ fun '(v0, h0) '(_, h1) => pre (h0, h1) /\ v0 = aes k m ⦄. Proof. unfold Caes. + intros Hdisj. eapply r_bind with (m₁ := ret _). - eapply aes_keyExpansion_h. + u_pdisj_apply Hdisj. + intros h1 h2 l a lin Hpre. + eapply Hdisj. + admit. + assumption. - intros a0 []. eapply r_bind with (m₁ := ret _). eapply aes_rounds_h. + + intros h1 h2 l a lin Hpre. + eapply Hdisj. + admit. + assumption. + intros a1 []. eapply r_ret. intros. assumption. -Qed. +Admitted. Lemma aes_E pre id0 k m : (pdisj pre id0 [fset rkeys ; state]) -> @@ -2095,7 +2262,7 @@ Lemma aes_E pre id0 k m : JAES id0 k m ≈ Caes k m - ⦃ fun '(v0, h0) '(v1, h1) => pre (h0, h1) /\ hdtc128 v0 = v1 ⦄. + ⦃ fun '(v0, h0) '(v1, h1) => pre (h0, h1) /\ exists o, v0 = [ ('word U128 ; o )] /\ v1 = o ⦄. Proof. unfold JAES. unfold get_translated_static_fun. @@ -2188,7 +2355,9 @@ Proof. intros. destruct_pre; sheap; split_post. * pdisj_apply disj. - * rewrite !coerce_to_choice_type_K. + * eexists. + split; [reflexivity|]. + simpl. rewrite !zero_extend_u. reflexivity. Qed. From 331b5bca5b6caaa464ebd753501f451d3f52da2c Mon Sep 17 00:00:00 2001 From: bshvass Date: Wed, 21 Dec 2022 06:12:22 +0100 Subject: [PATCH 333/383] security proof init --- _CoqProject | 1 + theories/Crypt/examples/PRF.v | 2 + theories/Jasmin/examples/aes/prf.v | 1100 ++++++++++++++++++++++++++++ 3 files changed, 1103 insertions(+) create mode 100644 theories/Jasmin/examples/aes/prf.v diff --git a/_CoqProject b/_CoqProject index c343a7aa..baab728a 100644 --- a/_CoqProject +++ b/_CoqProject @@ -101,6 +101,7 @@ theories/Jasmin/examples/two_functions.v theories/Jasmin/examples/u64_incr.v theories/Jasmin/examples/xor.v +theories/Jasmin/examples/aes/aes.v theories/Jasmin/examples/aes/aes_valid.v theories/Jasmin/examples/xor/xor.v diff --git a/theories/Crypt/examples/PRF.v b/theories/Crypt/examples/PRF.v index 1487be96..5ecc3a7e 100644 --- a/theories/Crypt/examples/PRF.v +++ b/theories/Crypt/examples/PRF.v @@ -184,6 +184,7 @@ Section PRF_example. Definition i_key : nat := 2^n. Definition i_words : nat := 2^n. + (* why does this allow an arbitrary set of Locations? Why not fset0? *) Definition enc {L : { fset Location }} (m : Words) (k : Key) : code L [interface] ('fin (2^n) × 'fin (2^n)) := {code @@ -199,6 +200,7 @@ Section PRF_example. ret k }. + (* why does this not use fset0 for its Locations? *) Definition dec (c : Words) (k : Key) : code (fset [:: key_location; table_location]) diff --git a/theories/Jasmin/examples/aes/prf.v b/theories/Jasmin/examples/aes/prf.v new file mode 100644 index 00000000..6b719063 --- /dev/null +++ b/theories/Jasmin/examples/aes/prf.v @@ -0,0 +1,1100 @@ +(** PRF Example + + Inspired by "State Separation for Code-Based Game-Playing Proofs" + by Brzuska et al. + + Appendix A. + + "Given a pseudorandom function (PRF) we construct a symmetric encryption + scheme that is indistinguishable under chosen plaintext attacks (IND-CPA)." + +*) +From JasminSSProve Require Import jasmin_translate. + +From Relational Require Import OrderEnrichedCategory GenericRulesSimple. + +Set Warnings "-notation-overridden,-ambiguous-paths". +From mathcomp Require Import all_ssreflect all_algebra reals distr realsum + ssrnat ssreflect ssrfun ssrbool ssrnum eqtype choice seq word word.ssrZ. +Set Warnings "notation-overridden,ambiguous-paths". + +From Mon Require Import SPropBase. +From Crypt Require Import Axioms ChoiceAsOrd SubDistr Couplings + UniformDistrLemmas FreeProbProg Theta_dens RulesStateProb + pkg_core_definition choice_type pkg_composition pkg_rhl Package Prelude. + +From Coq Require Import Utf8. +From extructures Require Import ord fset fmap. + +Import SPropNotations. + +Import PackageNotation. + +From Equations Require Import Equations. +Require Equations.Prop.DepElim. + +Set Equations With UIP. + +Set Bullet Behavior "Strict Subproofs". +Set Default Goal Selector "!". +Set Primitive Projections. + +Import Num.Def. +Import Num.Theory. +Import Order.POrderTheory. + + +From Jasmin Require Import word. + +Section PRF_example. + + Context (n : wsize). + + Notation key := 'word n. + Notation pt := 'word n. + Notation ct := 'word n. + + Notation " 'word " := ('word n) (in custom pack_type at level 2). + Notation " 'key " := ('word n) (in custom pack_type at level 2). + + Context (f : key -> pt -> ct). + + Notation N := ((expn 2 n).-1.+1). + + #[export] Instance : Positive N. + Proof. red; by rewrite prednK_modulus expn_gt0. Qed. + + #[export] Instance word_pos (i : wsize.wsize) : Positive i. + Proof. by case i. Qed. + + Notation "m ⊕ k" := (wxor m k) (at level 70). + + #[local] Open Scope package_scope. + + Definition key_location : Location := ('option key ; 0). + Definition plain_location : Location := ( pt ; 1). + Definition cipher_location : Location := ( ct ; 2). + Definition i0 : nat := 3. + Definition i1 : nat := 4. + Definition i2 : nat := 5. + Definition salt_location : Location := ('nat ; 6). + Definition table_location : Location := + (chMap 'nat ('word n) ; 7). + + Definition rel_loc : {fset Location} := + fset [:: key_location ; table_location ]. + + Definition enc (m : pt) (k : key) : + code fset0 [interface] ('word n) := + {code + r ← sample uniform N ;; + let pad := f (word_of_ord r) k in + let c := m ⊕ pad in + ret c + }. + + Definition kgen : code (fset [:: key_location]) [interface] 'word n := + {code + k ← get key_location ;; + match k with + | None => + k_val ← sample uniform N ;; + #put key_location := Some (word_of_ord k_val) ;; + ret (word_of_ord k_val) + | Some k_val => + ret k_val + end + }. + + Definition dec (c : 'word n) (k : 'word n) : + code fset0 [interface] ('word n) := + enc k c. + + Definition EVAL_location_tt := (fset [:: key_location]). + Definition EVAL_location_ff := (fset [:: table_location]). + + Definition EVAL_pkg_tt : + package EVAL_location_tt [interface] + [interface #val #[i0] : 'word → 'key ] := + [package + #def #[i0] (r : 'word) : 'key + { + k_val ← kgen ;; + ret (f r k_val) + } + ]. + + Definition EVAL_pkg_ff : + package EVAL_location_ff [interface] + [interface #val #[i0] : 'word → 'key ] := + [package + #def #[i0] (r : 'word) : 'key + { + T ← get table_location ;; + match getm T (ord_of_word r) with + | None => + T_key ← sample uniform N ;; + #put table_location := (setm T (ord_of_word r) (word_of_ord T_key)) ;; + ret (word_of_ord T_key) + | Some T_key => ret T_key + end + } + ]. + + Definition EVAL : loc_GamePair [interface #val #[i0] : 'word → 'key ] := + λ b, if b then {locpackage EVAL_pkg_tt } else {locpackage EVAL_pkg_ff }. + + Definition MOD_CPA_location : {fset Location} := fset0. + + Definition MOD_CPA_tt_pkg : + package MOD_CPA_location + [interface #val #[i0] : 'word → 'key ] + [interface #val #[i1] : 'word → 'word ] := + [package + #def #[i1] (m : 'word) : 'word + { + #import {sig #[i0] : 'word → 'key } as eval ;; + r ← sample uniform N ;; + pad ← eval (word_of_ord r) ;; + let c := m ⊕ pad in + ret c + } + ]. + + Definition MOD_CPA_ff_pkg : + package MOD_CPA_location + [interface #val #[i0] : 'word → 'key] + [interface #val #[i1] : 'word → 'word]:= + [package + #def #[i1] (m : 'word) : 'word + { + #import {sig #[i0] : 'word → 'key } as eval ;; + r ← sample uniform N ;; + m' ← sample uniform N ;; + pad ← eval (word_of_ord r) ;; + let c := (word_of_ord m' ⊕ pad) in + ret c + } + ]. + + Definition IND_CPA_location : {fset Location} := fset [:: key_location]. + + Program Definition IND_CPA_pkg_tt : + package IND_CPA_location + [interface] + [interface #val #[i1] : 'word → 'word ] := + [package + #def #[i1] (m : 'word) : 'word + { + k_val ← kgen ;; + enc m k_val + } + ]. + (* why is this not inferred? *) + Next Obligation. + repeat constructor. red. + intros []. + rewrite in_fset in_cons. move=>/orP []. 2: easy. move=>/eqP H. noconf H. simpl. + eexists. + split. + 1: reflexivity. + intros. repeat constructor. + 1: auto_in_fset. destruct v. + 1: intros; repeat constructor. + 1: intros; repeat constructor. + auto_in_fset. + Defined. + + Program Definition IND_CPA_pkg_ff : + package IND_CPA_location + [interface] + [interface #val #[i1] : 'word → 'word ] := + [package + #def #[i1] (m : 'word) : 'word + { + k_val ← kgen ;; + m' ← sample uniform N ;; + enc (word_of_ord m') k_val + } + ]. + (* TODO: infer this *) + Next Obligation. + repeat constructor. red. + intros []. + rewrite in_fset in_cons. move=>/orP []. 2: easy. move=>/eqP H. noconf H. simpl. + eexists. + split. + 1: reflexivity. + intros. repeat constructor. + 1: auto_in_fset. destruct v. + 1: intros; repeat constructor. + 1: intros; repeat constructor. + auto_in_fset. + Defined. + + Program Definition IND_CPA : + loc_GamePair [interface #val #[i1] : 'word → 'word ] := + λ b, + if b then {locpackage IND_CPA_pkg_tt } else {locpackage IND_CPA_pkg_ff }. + + Local Open Scope ring_scope. + + Definition prf_epsilon A := Advantage EVAL A. + + Definition statistical_gap := + AdvantageE (MOD_CPA_ff_pkg ∘ EVAL false) (MOD_CPA_tt_pkg ∘ EVAL false). + + Lemma IND_CPA_equiv_false : + IND_CPA false ≈₀ MOD_CPA_ff_pkg ∘ (EVAL true). + Proof. + (* We go to the relation logic using equality as invariant. *) + eapply eq_rel_perf_ind_eq. + simplify_eq_rel m. + simplify_linking. + (* We now conduct the proof in relational logic. *) + ssprove_swap_rhs 1%N. + ssprove_swap_rhs 0%N. + ssprove_sync_eq. cbn -[expn]. intros [k|]. + - cbn -[expn]. ssprove_swap_rhs 0%N. + eapply rpost_weaken_rule. + 1: eapply rreflexivity_rule. + cbn. intros [? ?] [? ?] e. inversion e. intuition auto. + - cbn -[expn]. + ssprove_swap_rhs 0%N. + ssprove_swap_rhs 1%N. + ssprove_swap_rhs 0%N. + ssprove_swap_rhs 2%N. + ssprove_swap_rhs 1%N. + eapply rpost_weaken_rule. 1: eapply rreflexivity_rule. + cbn. intros [? ?] [? ?] e. inversion e. intuition auto. + Qed. + + Lemma IND_CPA_equiv_true : + MOD_CPA_tt_pkg ∘ (EVAL true) ≈₀ IND_CPA true. + Proof. + (* We go to the relation logic using equality as invariant. *) + eapply eq_rel_perf_ind_eq. + simplify_eq_rel m. + simplify_linking. + (* We now conduct the proof in relational logic. *) + ssprove_swap_lhs 0%N. + ssprove_sync_eq. cbn -[expn]. intros [k|]. + - cbn -[expn]. eapply rpost_weaken_rule. 1: eapply rreflexivity_rule. + cbn. intros [? ?] [? ?] e. inversion e. intuition auto. + - cbn -[expn]. + ssprove_swap_rhs 1%N. + ssprove_swap_rhs 0%N. + eapply rpost_weaken_rule. 1: eapply rreflexivity_rule. + cbn. intros [? ?] [? ?] e. inversion e. intuition auto. + Qed. + + (** Security of PRF + + The bound is given by using the triangle inequality several times, + using the following chain: + IND_CPA false ≈ MOD_CPA_ff_pkg ∘ EVAL true + ≈ MOD_CPA_ff_pkg ∘ EVAL false + ≈ MOD_CPA_tt_pkg ∘ EVAL false + ≈ MOD_CPA_tt_pkg ∘ EVAL true + ≈ IND_CPA true + + *) + Theorem security_based_on_prf : + ∀ LA A, + ValidPackage LA + [interface #val #[i1] : 'word → 'word ] A_export A → + fdisjoint LA (IND_CPA false).(locs) → + fdisjoint LA (IND_CPA true).(locs) → + Advantage IND_CPA A <= + prf_epsilon (A ∘ MOD_CPA_ff_pkg) + + statistical_gap A + + prf_epsilon (A ∘ MOD_CPA_tt_pkg). + Proof. + intros LA A vA hd₀ hd₁. unfold prf_epsilon, statistical_gap. + rewrite !Advantage_E. + ssprove triangle (IND_CPA false) [:: + MOD_CPA_ff_pkg ∘ EVAL true ; + MOD_CPA_ff_pkg ∘ EVAL false ; + MOD_CPA_tt_pkg ∘ EVAL false ; + MOD_CPA_tt_pkg ∘ EVAL true + ] (IND_CPA true) A + as ineq. + eapply le_trans. 1: exact ineq. + clear ineq. + erewrite IND_CPA_equiv_false. all: eauto. + 2:{ simpl. unfold MOD_CPA_location. rewrite fset0U. auto. } + erewrite IND_CPA_equiv_true. all: eauto. + 2:{ simpl. unfold MOD_CPA_location. rewrite fset0U. auto. } + rewrite GRing.add0r GRing.addr0. + rewrite !Advantage_link. rewrite Advantage_sym. auto. + Qed. + +End PRF_example. + +From JasminSSProve Require Import aes.aes aes_jazz jasmin_utils aes_valid. +From Jasmin Require Import expr sem. + +Import JasminNotation JasminCodeNotation. + +(* From Jasmin Require Import expr. *) +Require Import String. +Local Open Scope string. + +Section JasminPRF. + + Ltac neq_loc_auto ::= solve [ eapply injective_translate_var3; auto | eapply injective_translate_var2; auto ]. + + Notation n := U128. + + Definition key := 'word n. + Definition pt := 'word n. + Definition ct := 'word n. + + Notation " 'word " := ('word n) (in custom pack_type at level 2). + Notation " 'key " := ('word n) (in custom pack_type at level 2). + Notation N := ((expn 2 n).-1.+1). + + (* #[export] Instance : Positive N. *) + (* Proof. generalize 128; intros; red; by rewrite prednK_modulus expn_gt0. Qed. *) + (* (* #[export] Instance : Positive ((2 ^ n).-1.+1). *) *) + (* Proof. exact _. Qed. *) + + (* #[export] Instance word_pos (i : wsize.wsize) : Positive i. *) + (* Proof. by case i. Qed. *) + (* Notation N := *) + Notation enc := (enc U128 aes). + Notation kgen := (kgen U128). + Notation key_location := (key_location U128). + + Definition ltup2 (l : tchlist) := + match l with + | [::] => (word0, word0) + | a1 :: l1 => + match l with + | [::] => (word0, word0) + | a2 :: l2 => (coerce_to_choice_type ('word n) a1.π2, coerce_to_choice_type ('word n) a2.π2) + end + end. + + (* Program Definition IND_CPA_pkg_Caes : *) + (* package (fset [:: rkeys; state]) *) + (* [interface #val #[i2] : 'unit → 'word] *) + (* [interface #val #[i1] : 'word → 'word] := *) + (* [package *) + (* #def #[i1] (m : 'word) : 'word *) + (* { *) + (* k ← get key_location ;; *) + (* k_val ← match k with *) + (* | None => *) + (* k_val ← sample uniform N ;; *) + (* #put key_location := Some (word_of_ord k_val) ;; *) + (* ret (word_of_ord k_val) *) + (* | Some k_val => *) + (* ret k_val *) + (* end ;; *) + (* #import {sig #[i2] : 'unit → 'key } as kg ;; *) + (* k_val ← kg (chCanonical 'unit) ;; *) + (* Caes m k_val *) + (* } *) + (* ]. *) + (* Next Obligation. *) + (* (* infer this *) *) + (* repeat constructor. red. *) + (* intros []. *) + (* rewrite in_fset in_cons. move=>/orP []. 2: easy. move=>/eqP H. noconf H. simpl. *) + (* eexists. *) + (* split. *) + (* 1: reflexivity. *) + (* intros. repeat constructor. *) + (* all: auto_in_fset. *) + (* Defined. *) + (* Opaque Caes. *) + + Definition Cenc (m : pt) (k : key) : + code (fset [:: state ; rkeys]) [interface] ('word n). + Proof. + refine + {code + r ← sample uniform N ;; + pad ← Caes (word_of_ord r) k ;; + ret (m ⊕ pad) + }. + repeat constructor. + all: auto_in_fset. + Unshelve. exact _. + Defined. + + Definition Cenc_locs := [:: state ; rkeys]. + Opaque wrange. + Opaque expn. + + Definition IND_CPA_pkg_Cenc : + package (fset (key_location :: Cenc_locs)) + [interface] + [interface #val #[i1] : 'word → 'word]. + Proof. + refine + [package + #def #[i1] (m : 'word) : 'word + { + k_val ← kgen ;; + Cenc m k_val + } + ]. + (* infer this *) + repeat constructor. red. + intros []. + rewrite in_fset in_cons. move=>/orP []. 2: easy. move=>/eqP H. noconf H. simpl. + eexists. + split. + 1: reflexivity. + intros. repeat constructor. + all: auto_in_fset. + intros. destruct v. + 1: repeat constructor; auto_in_fset. + 1: repeat constructor; auto_in_fset. + Defined. + + Definition IND_CPA_pkg_JENC (id0 : p_id) : + package (fset (key_location :: (JENC_valid id0).π1)) + [interface] + [interface #val #[i1] : 'word → 'word ]. + Proof. + refine + [package + #def #[i1] (m : 'word) : 'word + { + k_val ← kgen ;; + r ← sample uniform N ;; + res ← JENC id0 (word_of_ord r) k_val m ;; + ret (hdtc128 res) + } + ]. + repeat constructor. + intros []. + rewrite in_fset in_cons => /orP []; [|easy]; move=> /eqP H; noconf H. + cbv zeta match. + eexists. + split. + 1: reflexivity. + intros x. + constructor. + 1: auto_in_fset. + intros. destruct v. + - constructor. intros. + eapply valid_bind. + + red. eapply valid_code_cons. + 1: eapply (JENC_valid id0).π2. + + constructor. + - constructor. + intros. + constructor. + 1: auto_in_fset. + constructor. intros. + eapply valid_bind. + + red. eapply valid_code_cons. + 1: eapply (JENC_valid id0).π2. + + constructor. + Unshelve. all: exact _. + Defined. + + (* Notation KG_pkg := (KG_pkg U128). *) + Notation IND_CPA_pkg_ff := (IND_CPA_pkg_ff U128 aes). + Notation MOD_CPA_ff_pkg := (MOD_CPA_ff_pkg U128). + Notation IND_CPA := (IND_CPA U128 aes). + Notation EVAL := (EVAL U128 aes). + + (* Lemma fsubsetUl' : forall [T : ordType] (s1 s2 s3 : {fset T}), fsubset s1 s2 -> fsubset s1 (s2 :|: s3). *) + (* Proof. *) + + (* intros. *) + (* eapply fsubsetU. *) + (* rewrite -[s1]fsetUid. *) + (* eapply fsetSU. *) + Lemma fsubset_ext2 : ∀ [T : ordType] (s1 s2 : {fset T}), fsubset s1 s2 -> (forall x, x \in s1 -> x \in s2). + Proof. + intros. + rewrite -fsub1set. + eapply fsubset_trans. 2: eassumption. + rewrite fsub1set. assumption. + Qed. + + Lemma fsubset_cons : ∀ [T : ordType] a (s1 s2 : {fset T}), fsubset s1 s2 -> fsubset s1 (a |: s2). + Proof. + intros. + apply fsubset_ext. + intros. rewrite in_fset in_cons. + apply/orP. right. + eapply fsubset_ext2. + 1: eassumption. + assumption. + Qed. + +(* fsubsetUl: ∀ [T : ordType] (s1 s2 : {fset T}), fsubset s1 (s1 :|: s2) *) + Definition IND_CPA_Cenc : + loc_GamePair [interface #val #[i1] : 'word → 'word ] := + λ b, + if b then {locpackage IND_CPA_pkg_Cenc } else (IND_CPA true). + + Definition IND_CPA_JENC id0 : + loc_GamePair [interface #val #[i1] : 'word → 'word ] := + λ b, + if b then {locpackage IND_CPA_pkg_JENC id0} else {locpackage IND_CPA_pkg_Cenc}. +(* Lemma aes_h k m : *) +(* (* (forall i, (0 <= i < 11)%nat -> rkeys i = Some (key_i k i)) -> *) *) +(* ⊢ ⦃ fun '(h0, h1) => heap_ignore (fset Cenc_locs) (h0, h1) ⦄ *) +(* Caes k m *) +(* ≈ *) +(* ret (chCanonical chUnit) *) +(* ⦃ fun '(v0, h0) '(_, h1) => heap_ignore (fset Cenc_locs) (h0, h1) /\ v0 = aes k m ⦄. *) +(* Proof. *) +(* unfold Caes. *) +(* eapply r_bind with (m₁ := ret _). *) +(* - eapply aes_keyExpansion_h. *) +(* - intros a0 []. *) +(* eapply r_bind with (m₁ := ret _). *) +(* eapply aes_rounds_h. *) +(* intros a1 []. *) +(* eapply r_ret. *) +(* intros. *) +(* assumption. *) +(* Qed. *) +(* Print Instances Invariant. *) + (* Lemma heap_ignore_set_l h1 h2 l v L : l \notin L -> heap_ignore L ((set_heap h1 l v), h2). *) + (* Proof. *) + (* intros H a anin. *) + (* unfold heap_igno *) + (* eexists. *) + (* o *) + + + (* Lemma heap_ignore_fset0 h1 h2 : heap_ignore fset0 (h1, h2). *) + (* Proof. *) + (* intros l lnin. *) +(* pdisj *) + (* Definition heap_ignore_later (id : p_id) (L : {fset Location}) : precond := *) + (* λ '(h₀, h₁), *) + (* ∀ (ℓ : Location) (s_id : p_id) (v : var), ℓ \notin L \/ (id ≺ s_id /\ ℓ = translate_var s_id v) → get_heap h₀ ℓ = get_heap h₁ ℓ. *) + (* (* Instance : forall L1 L2, Invariant L1 L2 pdisj. := pdisj. *) *) + +(* Lemma INV'_heap_ignore_later id : *) +(* ∀ L L₀ L₁, *) +(* fsubset L (L₀ :|: L₁) → *) +(* INV' L₀ L₁ (heap_ignore_later id L). *) +(* Proof. *) +(* intros L L₀ L₁ hs h₀ h₁. split. *) +(* - intros hh ℓ n₀ n₁. *) +(* eapply hh. *) +(* left. *) +(* apply /negP. intro h. *) +(* eapply injectSubset in h. 2: eauto. *) +(* rewrite in_fsetU in h. move: h => /orP [h | h]. *) +(* + rewrite h in n₀. discriminate. *) +(* + rewrite h in n₁. discriminate. *) +(* - intros h ℓ v n₀ n₁ ℓ' n. *) +(* destruct (ℓ' != ℓ) eqn:e. *) +(* + rewrite get_set_heap_neq. 2: auto. *) +(* rewrite get_set_heap_neq. 2: auto. *) +(* apply h. *) +(* + move: e => /eqP e. subst. *) +(* rewrite !get_set_heap_eq. reflexivity. *) +(* Unshelve. 1: exact xH. exact (Var sbool ""). *) +(* Qed. *) + +(* Lemma Invariant_heap_ignore_later id : *) +(* ∀ L L₀ L₁, *) +(* fsubset L (L₀ :|: L₁) → *) +(* Invariant L₀ L₁ (heap_ignore_later id L). *) +(* Proof. *) +(* intros L L₀ L₁ h. split. *) +(* - apply INV'_heap_ignore_later. auto. *) +(* - intros L' id' v H. apply get_empty_heap. *) +(* Qed. *) + +(* Hint Extern 10 (Invariant _ _ (heap_ignore_later _ _)) => *) + (* eapply Invariant_heap_ignore_later *) + (* : (* typeclass_instances *) ssprove_invariant. *) + +(* Definition heap_ignore_pred' (P : Location -> Prop) : precond := *) + (* λ '(h₀, h₁), *) + (* forall (ℓ : Location), ~ P ℓ -> get_heap h₀ ℓ = get_heap h₁ ℓ. *) + +(* Arguments heap_ignore_pred' : simpl never. *) + +(* Lemma heap_ignore_pred'_empty : *) +(* ∀ P, *) +(* heap_ignore_pred' P (empty_heap, empty_heap). *) +(* Proof. *) +(* intros P ℓ hℓ. reflexivity. *) +(* Qed. *) + +Definition heap_ignore_pred' (P : Location -> Prop) : precond := + λ '(h₀, h₁), + forall (ℓ : Location), P ℓ -> get_heap h₀ ℓ = get_heap h₁ ℓ. + +Lemma heap_ignore_pred'_empty : + ∀ P, + heap_ignore_pred' P (empty_heap, empty_heap). +Proof. + intros P ℓ hℓ. reflexivity. +Qed. + +Lemma INV''_heap_ignore_pred' (P : Location -> Prop) : + ∀ P0 P1 : Location -> Prop, + (forall ℓ : Location, ~ P0 ℓ /\ ~ P1 ℓ -> P ℓ) -> + INV'' P0 P1 (heap_ignore_pred' P). +Proof. + intros P0 P1 hP h0 h1. split. + - intros hh l nin1 nin2. + eapply hh. + apply hP. + eauto. + - intros h ℓ v nin0 nin1 ℓ' n. + destruct (ℓ' != ℓ) eqn:e. + + rewrite get_set_heap_neq. 2: auto. + rewrite get_set_heap_neq. 2: auto. + apply h. auto. + + move: e => /eqP e. subst. + rewrite !get_set_heap_eq. reflexivity. +Qed. + +Lemma Invariant'_heap_ignore_pred' : + ∀ P0 P1 (P : Location -> Prop), + (forall ℓ : Location, ~ P0 ℓ /\ ~ P1 ℓ -> P ℓ) -> + Invariant' P0 P1 (heap_ignore_pred' P). +Proof. + intros L P h. split. + - apply INV''_heap_ignore_pred'. auto. + - apply heap_ignore_pred'_empty. +Qed. + +Definition adv_equiv' P0 P1 {L₀ L₁ E} (G₀ G₁ : raw_package) + `{ValidPackage L₀ Game_import E G₀} `{ValidPackage L₁ Game_import E G₁} ε := + ∀ LA A, + ValidPackage LA E A_export A → + pdisjoint LA P0 → + pdisjoint LA P1 → + AdvantageE G₀ G₁ A = ε A. + +Lemma eq_rel_perf_ind'' : + ∀ P0 P1 {L₀ L₁ E} (p₀ p₁ : raw_package) (inv : precond) + `{ValidPackage L₀ Game_import E p₀} + `{ValidPackage L₁ Game_import E p₁}, + Invariant' P0 P1 inv → + eq_up_to_inv E inv p₀ p₁ → + adv_equiv' P0 P1 p₀ p₁ (λ _ : raw_package, 0%R). +Proof. + intros P0 P1 L₀ L₁ E p₀ p₁ inv v₀ v₁ [? ?] he. + (* adv_equiv. *) + (* Locate "≈₀". *) + intros LA A vA hd₀ hd₁. + eapply eq_upto_inv_perf_ind'. all: eauto. +Qed. + +(* TODO: move *) +Lemma JXOR_E pre id0 x y : + (pdisj pre id0 fset0) -> + ⊢ ⦃ fun '(h0, h1) => pre (h0, h1) ⦄ + JXOR id0 x y + ≈ + ret (chCanonical chUnit) + ⦃ fun '(v0, h0) '(v1, h1) => pre (h0, h1) /\ (exists o, (v0 = cons ('word U128 ; o ) nil ) /\ (o = x ⊕ y)) ⦄. +Proof. + unfold JXOR. + unfold get_translated_static_fun. + unfold translate_prog_static. + unfold translate_funs_static. + unfold translate_call_body. + intros disj. + + simpl. simpl_fun. + repeat setjvars. + ssprove_code_simpl. + repeat clear_get. + repeat eapply r_put_lhs. + eapply r_ret. + rewrite !zero_extend_u. + (* rewrite coerce_to_choice_type_K. *) + intros. destruct_pre; split_post. + 1: pdisj_apply disj. + eexists; split; [reflexivity|]. reflexivity. +Qed. + +Lemma IND_CPA_JENC_equiv_false id0 : + adv_equiv' (fun l => exists s_id v, id0 ⪯ s_id /\ l = translate_var s_id v) (fun l => l = state \/ l = rkeys) (IND_CPA_JENC id0 true) (IND_CPA_JENC id0 false) (λ _ : raw_package, 0%R). + Proof. + eapply eq_rel_perf_ind''. + 1: eapply Invariant'_heap_ignore_pred' with + (* with (L := JENC_locs id0). *) + (P := fun l => forall s_id v, id0 ⪯ s_id -> l != translate_var s_id v). + + (* (id:=id0) *) (* (L:=fset0) *) (* (L:=(fset (JENC_valid id0 (fset [::])).π1)). *) +(* _ignore with (L := fset Cenc_locs). *) + - intros. apply/eqP. intros contra. + destruct H. + apply H. + exists s_id, v. split; auto. + + + (* admit. *) + (* eapply fsubsetU. apply/orP; left. simpl. *) + (* rewrite [fset (key_location :: _)]fset_cons. *) + (* eapply fsubset_cons. *) + (* eapply fsubsetxx. *) + - + + unfold eq_up_to_inv. + unfold get_op_default. + unfold lookup_op. + unfold IND_CPA_JENC. + unfold IND_CPA_pkg_JENC. + + (* unfold JENC. *) + (* unfold get_translated_static_fun. *) + (* unfold translate_prog_static. *) + (* unfold translate_funs_static. *) + (* unfold translate_call_body. *) + Opaque Caes. + Opaque translate_call. + (* Opaque wrange. *) + Opaque wrange. + Opaque expn. + Arguments heap_ignore_pred' : simpl never. + simpl. + (* simplify_linking. *) + simplify_eq_rel m. + simplify_linking. + rewrite !cast_fun_K. + ssprove_sync. + { intros h0 h1 hpre. apply hpre. admit. } + (* Transparent heap_ignore_later. *) + (* { unfold get_pre_cond. intros. eapply H. left. admit. } intros. *) + (* ssprove_sync. *) + destruct a. + + ssprove_code_simpl. + simpl. + ssprove_sync. intros. + rewrite !zero_extend_u. + repeat clear_get. + do 3 eapply r_put_lhs. + eapply r_bind. + * +(* eapply rpre_weak_hypothesis_rule'. *) + (* intros. *) + (* destruct_pre. *) + + eapply aes_E; split. + ** intros. + destruct_pre. + eexists. + eexists. + *** eexists. + eexists. + **** eexists. + split. + ***** instantiate (1 := set_heap H6 (translate_var s_id' v) a0). + intros l lnin. + rewrite get_set_heap_neq. + 1: eapply H7. 1: assumption. + eapply lnin. + admit. + ***** reflexivity. + **** reflexivity. + *** rewrite set_heap_commut. + 1: rewrite [set_heap _ _ a0]set_heap_commut. + 1: rewrite [set_heap _ _ a0]set_heap_commut. + 1: reflexivity. + (* 1: unfold heap_ignore_pred' in H7. *) + (* Unset Printing Notations. *) + 1-3: admit. + ** intros. + destruct_pre. + + eexists. + eexists. + *** eexists. + eexists. + **** eexists. + split. + ***** instantiate (1 := H5). + intros l2 lnin. + rewrite get_set_heap_neq. + 1: eapply H6. 1: assumption. + admit. + ***** reflexivity. + **** reflexivity. + *** reflexivity. + * + simpl. + intros. + + eapply rpre_weak_hypothesis_rule'; intros. + destruct_pre. + simpl. + clear_get. + eapply r_put_lhs with (pre := fun _ => _). + eapply r_get_remember_lhs. intros. + eapply r_bind with (m₁ := ret (chCanonical chUnit)) (f₁ := fun _ => _). + 1: eapply JXOR_E; split. + + ** intros. + unfold set_lhs. + simpl. + destruct_pre. + simpl. + eexists. + 1: do 2 eexists. + 1: do 7 eexists. + 1: instantiate (1:= (set_heap H13 (translate_var s_id' v) a0)). + 1: { intros l hl. rewrite get_set_heap_neq. 1: eapply H14. 1: assumption. apply hl. admit. } + 1: reflexivity. + 1: rewrite [set_heap _ _ a0]set_heap_commut. + 1: rewrite [set_heap _ _ a0]set_heap_commut. + 1: rewrite [set_heap _ _ a0]set_heap_commut. + 1: rewrite [set_heap _ _ a0]set_heap_commut. + 1: reflexivity. + 1-4: admit. + sheap. simpl. rewrite get_set_heap_neq. 1: sheap. 1: reflexivity. + admit. + ** + intros. + easy. + ** + + intros. + eapply rpre_weak_hypothesis_rule'; intros. + destruct_pre; simpl. + clear_get. + eapply r_put_lhs with (pre := fun _ => _). + (* eapply rpost_weaken_rule. *) + eapply r_ret. + rewrite !coerce_to_choice_type_K. + rewrite !zero_extend_u. + intros. + destruct_pre; simpl; split_post. + 1: sheap. + 1: by rewrite wxorC. + intros l s_id. + rewrite !get_set_heap_neq. + (* Unset Printing Notations. *) + 1: eapply H18. + 1: eassumption. + 1-5: apply s_id; reflexivity. + + admit. + Admitted. + + Lemma IND_CPA_jazz_equiv_false : + (IND_CPA_Cenc) true ≈₀ (IND_CPA_Cenc) false. + Proof. + eapply eq_rel_perf_ind_ignore with (L := fset Cenc_locs). + - eapply fsubsetU. apply/orP; left. simpl. + rewrite [fset (key_location :: _)]fset_cons. + eapply fsubset_cons. + eapply fsubsetxx. + - + (* We go to the relation logic using equality as invariant. *) + (* eapply eq_rel_perf_ind_eq. *) + unfold eq_up_to_inv. + Opaque Caes. + (* Opaque wrange. *) + Opaque wrange. + Opaque expn. + simplify_eq_rel m. + ssprove_sync. intros. + destruct a. + + simpl. + ssprove_sync. intros x. + eapply r_bind with (m₁ := ret (chCanonical chUnit)) (f₁ := fun _ => _). + * 1: eapply aes_h. + intros h1 h2 l a lin h. + intros l2 lnin. + unfold Cenc_locs in *. + admit. + * intros. eapply r_ret. + intros. destruct_pre; split_post; auto. + + simpl. + ssprove_sync. intros x. + ssprove_sync. + ssprove_sync. intros. + eapply r_bind with (m₁ := ret (chCanonical chUnit)) (f₁ := fun _ => _). + * 1: eapply aes_h. + intros h1 h2 l a2 lin h. + intros l2 lnin. + unfold Cenc_locs in *. + rewrite get_set_heap_neq. + 1: eapply h. 1: assumption. + admit. + * intros. eapply r_ret. + intros. destruct_pre; split_post; auto. + Admitted. + + Definition JIND_CPA id0 : + loc_GamePair [interface #val #[i1] : 'word → 'word ] := + λ b, + if b then {locpackage IND_CPA_pkg_JENC id0 } else (IND_CPA true). + + Theorem jasmin_security_based_on_prf id0 : + ∀ LA A, + ValidPackage LA + [interface #val #[i1] : 'word → 'word ] A_export A → + pdisjoint LA (λ l : Location, ∃ (s_id : p_id) (v : var), id0 ⪯ s_id ∧ l = translate_var s_id v) -> + pdisjoint LA (λ l : Location, l = state ∨ l = rkeys) -> + (* fdisjoint LA (JIND_CPA id0 false).(locs) → *) + (* fdisjoint LA (JIND_CPA id0 true).(locs) → *) + Advantage (JIND_CPA id0) A = 0%R. + Proof. + intros LA A vA hd₀ hd₁. unfold prf_epsilon, statistical_gap. + rewrite !Advantage_E. + eapply AdvantageE_le_0. + ssprove triangle (JIND_CPA id0 false) [:: + IND_CPA_pkg_Cenc : raw_package + ] (JIND_CPA id0 true) A + as ineq. + eapply Order.POrderTheory.le_trans. + 1: exact ineq. + clear ineq. + rewrite Advantage_sym. + erewrite IND_CPA_jazz_equiv_false. all: eauto. + 2-3: admit. + rewrite Advantage_sym. + pose proof IND_CPA_JENC_equiv_false id0. + unfold adv_equiv' in H. + specialize (H LA A vA hd₀ hd₁). + rewrite H. + rewrite GRing.addr0. + apply Order.POrderTheory.le_refl. + Admitted. + (* reflexivity. *) + (* auto. *) + + (* erewrite IND_CPA_equiv_true. all: eauto. *) + (* 2:{ simpl. unfold MOD_CPA_location. rewrite fset0U. auto. } *) + (* rewrite GRing.add0r GRing.addr0. *) + (* rewrite !Advantage_link. rewrite Advantage_sym. auto. *) + (* Qed. *) + (* + eapply rpre_weaken_rule. 1: eapply r_ret. eapply rreflexivity_rule. *) + (* - intros. *) + (* (* cbv zeta match. *) *) + (* (* eapply cmd_sample_preserve_pre. *) *) + (* (* eapply rsame_head. *) *) + (* ssprove_code_simpl. *) + (* eapply rpre_weaken_rule. *) + (* 1: ssprove_sync_eq. *) + (* 2: { intros. noconf H. easy. } *) + (* intros. *) + (* eapply r_bind with (m₁ := ret (chCanonical chUnit)) (f₁ := fun _ => _). *) + (* + eapply rpre_weaken_rule. 1: eapply aes_h. *) + (* easy. *) + (* + intros. *) + (* eapply r_ret. *) + (* intros. subst. split. *) + (* auto. *) + (* rreflexivity_rule. *) + + (* eapply r_bind. *) + (* rewrite !zero_extend_u. *) + (* eapply r_put_lhs with (pre := fun '(_, _) => _). *) + (* eapply r_put_lhs. *) + (* eapply r_put_lhs. *) + (* eapply r_bind with (m₁ := ret (chCanonical chUnit)) (f₁ := fun _ => _). *) + (* + *) + + (* eapply r_bind with (pre := fun _ => _). *) + + (* (* eapply sampler_case. *) *) + (* 2: easy. *) + (* eapply cmd_sample_preserve_pre. *) + (* eapply r_bind. *) + (* ssprove_code_simpl. *) + (* eapply r_uniform_bij. *) + (* eapply r_sample. *) + (* ssprove_sync. *) + (* ssprove_sync_eq. intros. *) + (* eapply rsame_head. *) + (* eapply r_bind. *) + (* ssprove_sync. intros. *) + + (* 1: ssprove_sync_eq. *) + (* ssprove_code_simpl. *) + (* simplify_linking. *) + (* simpl. *) + (* simplify_linking. *) + (* unfold get_op_default. *) + (* unfold lookup_op. *) + (* cbv match zeta. *) + (* unfold IND_CPA_jazz. *) + (* (* cbn. *) *) + (* (* cbn. *) *) + (* (* unfold IND_CPA_pkg_ff. *) *) + (* (* move: H; rewrite in_fset in_cons=>/orP []. 2: easy. *) *) + (* (* move=> /eqP H. noconf H. *) *) + + + (* unfold JKEYS_EXPAND. *) + (* unfold get_translated_static_fun. *) + (* unfold translate_prog_static. *) + (* unfold translate_funs_static. *) + (* unfold translate_call_body. *) + + (* simplify_eq_rel m. *) + (* simplify_linking. *) + (* (* We now conduct the proof in relational logic. *) *) + (* ssprove_swap_rhs 1%N. *) + (* ssprove_swap_rhs 0%N. *) + (* ssprove_sync_eq. cbn -[expn]. intros [k|]. *) + (* - cbn -[expn]. ssprove_swap_rhs 0%N. *) + (* eapply rpost_weaken_rule. *) + (* 1: eapply rreflexivity_rule. *) + (* cbn. intros [? ?] [? ?] e. inversion e. intuition auto. *) + (* - cbn -[expn]. *) + (* ssprove_swap_rhs 0%N. *) + (* ssprove_swap_rhs 1%N. *) + (* ssprove_swap_rhs 0%N. *) + (* ssprove_swap_rhs 2%N. *) + (* ssprove_swap_rhs 1%N. *) + (* eapply rpost_weaken_rule. 1: eapply rreflexivity_rule. *) + (* cbn. intros [? ?] [? ?] e. inversion e. intuition auto. *) + (* Qed. *) + + (* Opaque translate_for. *) + (* Opaque translate_call. *) + (* simpl. *) + (* (* Opaque wrange. *) *) + (* (* Opaque for_loop'. *) *) + (* constructor. *) + (* 1: rewrite in_fset; apply/xseq.InP; apply List.in_eq. *) + (* constructor. *) + (* 1: rewrite in_fset. 1: apply/xseq.InP; apply List.in_cons; eapply List.in_eq. *) + (* constructor. *) + (* 1: rewrite in_fset; apply/xseq.InP; repeat lazymatch goal with | |- List.In _ (_ :: _) => eapply List.in_cons | |- _ => eapply List.in_eq end. *) + (* constructor. *) + (* 1: rewrite in_fset; apply/xseq.InP; repeat lazymatch goal with | |- List.In _ (_ :: _) => eapply List.in_cons | |- _ => eapply List.in_eq end. *) + (* constructor. *) + (* 1: rewrite in_fset; apply/xseq.InP; repeat lazymatch goal with | |- List.In _ (_ :: _) => eapply List.in_cons | |- _ => eapply List.in_eq end. *) + (* intros. rewrite 3!bind_assoc. *) + (* eapply valid_bind. *) + (* { Transparent translate_call. unfold translate_call. Opaque translate_call. simpl. constructor. *) + (* Set Printing All. *) + (* valid_code *) + + (* simpl. *) + (* constructor. *) + (* 1: rewrite in_fset; apply/xseq.InP; repeat lazymatch goal with | |- List.In _ (_ :: _) => eapply List.in_cons | |- _ => eapply List.in_eq end. *) + (* constructor. *) + (* 1: rewrite in_fset; apply/xseq.InP; repeat lazymatch goal with | |- List.In _ (_ :: _) => eapply List.in_cons | |- _ => eapply List.in_eq end. *) + (* constructor. *) + (* 1: rewrite in_fset; apply/xseq.InP; repeat lazymatch goal with | |- List.In _ (_ :: _) => eapply List.in_cons | |- _ => eapply List.in_eq end. *) + (* 1: erewrite -> in_cons. *) + + (* cbn. simpl. *) + (* 2: easy. *) + (* simpl. *) + + (* Program Definition jazz_enc id0 {L : { fset Location }} (m : pt U128) (k : key U128) : *) + (* code L [interface] ('word U128 × 'word U128) := *) + (* {code *) + (* r ← sample uniform N ;; *) + (* pad ← JAES id0 (word_of_ord r) k ;; *) + (* let c := m ⊕ (hdtc128 pad) in *) + (* ret (word_of_ord r, c) *) + (* }. *) From 7bb83fdf828d7aa642533f1fa2254c5e92dad0f1 Mon Sep 17 00:00:00 2001 From: bshvass Date: Wed, 21 Dec 2022 06:12:47 +0100 Subject: [PATCH 334/383] security proof cleaning --- theories/Jasmin/examples/aes/prf.v | 541 +++++++++-------------------- 1 file changed, 169 insertions(+), 372 deletions(-) diff --git a/theories/Jasmin/examples/aes/prf.v b/theories/Jasmin/examples/aes/prf.v index 6b719063..bcd91dc2 100644 --- a/theories/Jasmin/examples/aes/prf.v +++ b/theories/Jasmin/examples/aes/prf.v @@ -328,7 +328,6 @@ Section PRF_example. rewrite GRing.add0r GRing.addr0. rewrite !Advantage_link. rewrite Advantage_sym. auto. Qed. - End PRF_example. From JasminSSProve Require Import aes.aes aes_jazz jasmin_utils aes_valid. @@ -639,57 +638,57 @@ Proof. intros P ℓ hℓ. reflexivity. Qed. -Lemma INV''_heap_ignore_pred' (P : Location -> Prop) : - ∀ P0 P1 : Location -> Prop, - (forall ℓ : Location, ~ P0 ℓ /\ ~ P1 ℓ -> P ℓ) -> - INV'' P0 P1 (heap_ignore_pred' P). -Proof. - intros P0 P1 hP h0 h1. split. - - intros hh l nin1 nin2. - eapply hh. - apply hP. - eauto. - - intros h ℓ v nin0 nin1 ℓ' n. - destruct (ℓ' != ℓ) eqn:e. - + rewrite get_set_heap_neq. 2: auto. - rewrite get_set_heap_neq. 2: auto. - apply h. auto. - + move: e => /eqP e. subst. - rewrite !get_set_heap_eq. reflexivity. -Qed. +(* Lemma pINV'_heap_ignore_pred' (P : Location -> Prop) : *) +(* ∀ P0 P1 : Location -> Prop, *) +(* (forall ℓ : Location, ~ P0 ℓ /\ ~ P1 ℓ -> P ℓ) -> *) +(* pINV' P0 P1 (heap_ignore_pred' P). *) +(* Proof. *) +(* intros P0 P1 hP h0 h1. split. *) +(* - intros hh l nin1 nin2. *) +(* eapply hh. *) +(* apply hP. *) +(* eauto. *) +(* - intros h ℓ v nin0 nin1 ℓ' n. *) +(* destruct (ℓ' != ℓ) eqn:e. *) +(* + rewrite get_set_heap_neq. 2: auto. *) +(* rewrite get_set_heap_neq. 2: auto. *) +(* apply h. auto. *) +(* + move: e => /eqP e. subst. *) +(* rewrite !get_set_heap_eq. reflexivity. *) +(* Qed. *) -Lemma Invariant'_heap_ignore_pred' : - ∀ P0 P1 (P : Location -> Prop), - (forall ℓ : Location, ~ P0 ℓ /\ ~ P1 ℓ -> P ℓ) -> - Invariant' P0 P1 (heap_ignore_pred' P). -Proof. - intros L P h. split. - - apply INV''_heap_ignore_pred'. auto. - - apply heap_ignore_pred'_empty. -Qed. +(* Lemma Invariant'_heap_ignore_pred' : *) +(* ∀ P0 P1 (P : Location -> Prop), *) +(* (forall ℓ : Location, ~ P0 ℓ /\ ~ P1 ℓ -> P ℓ) -> *) +(* Invariant' P0 P1 (heap_ignore_pred' P). *) +(* Proof. *) +(* intros L P h. split. *) +(* - apply INV''_heap_ignore_pred'. auto. *) +(* - apply heap_ignore_pred'_empty. *) +(* Qed. *) -Definition adv_equiv' P0 P1 {L₀ L₁ E} (G₀ G₁ : raw_package) - `{ValidPackage L₀ Game_import E G₀} `{ValidPackage L₁ Game_import E G₁} ε := - ∀ LA A, - ValidPackage LA E A_export A → - pdisjoint LA P0 → - pdisjoint LA P1 → - AdvantageE G₀ G₁ A = ε A. - -Lemma eq_rel_perf_ind'' : - ∀ P0 P1 {L₀ L₁ E} (p₀ p₁ : raw_package) (inv : precond) - `{ValidPackage L₀ Game_import E p₀} - `{ValidPackage L₁ Game_import E p₁}, - Invariant' P0 P1 inv → - eq_up_to_inv E inv p₀ p₁ → - adv_equiv' P0 P1 p₀ p₁ (λ _ : raw_package, 0%R). -Proof. - intros P0 P1 L₀ L₁ E p₀ p₁ inv v₀ v₁ [? ?] he. - (* adv_equiv. *) - (* Locate "≈₀". *) - intros LA A vA hd₀ hd₁. - eapply eq_upto_inv_perf_ind'. all: eauto. -Qed. +(* Definition adv_equiv' P0 P1 {L₀ L₁ E} (G₀ G₁ : raw_package) *) +(* `{ValidPackage L₀ Game_import E G₀} `{ValidPackage L₁ Game_import E G₁} ε := *) +(* ∀ LA A, *) +(* ValidPackage LA E A_export A → *) +(* pdisjoint LA P0 → *) +(* pdisjoint LA P1 → *) +(* AdvantageE G₀ G₁ A = ε A. *) + +(* Lemma eq_rel_perf_ind'' : *) +(* ∀ P0 P1 {L₀ L₁ E} (p₀ p₁ : raw_package) (inv : precond) *) +(* `{ValidPackage L₀ Game_import E p₀} *) +(* `{ValidPackage L₁ Game_import E p₁}, *) +(* Invariant' P0 P1 inv → *) +(* eq_up_to_inv E inv p₀ p₁ → *) +(* adv_equiv' P0 P1 p₀ p₁ (λ _ : raw_package, 0%R). *) +(* Proof. *) +(* intros P0 P1 L₀ L₁ E p₀ p₁ inv v₀ v₁ [? ?] he. *) +(* (* adv_equiv. *) *) +(* (* Locate "≈₀". *) *) +(* intros LA A vA hd₀ hd₁. *) +(* eapply eq_upto_inv_perf_ind'. all: eauto. *) +(* Qed. *) (* TODO: move *) Lemma JXOR_E pre id0 x y : @@ -714,218 +713,150 @@ Proof. repeat eapply r_put_lhs. eapply r_ret. rewrite !zero_extend_u. - (* rewrite coerce_to_choice_type_K. *) intros. destruct_pre; split_post. 1: pdisj_apply disj. eexists; split; [reflexivity|]. reflexivity. Qed. +(* TODO: move *) +Arguments pheap_ignore : simpl never. + Lemma IND_CPA_JENC_equiv_false id0 : - adv_equiv' (fun l => exists s_id v, id0 ⪯ s_id /\ l = translate_var s_id v) (fun l => l = state \/ l = rkeys) (IND_CPA_JENC id0 true) (IND_CPA_JENC id0 false) (λ _ : raw_package, 0%R). - Proof. - eapply eq_rel_perf_ind''. - 1: eapply Invariant'_heap_ignore_pred' with - (* with (L := JENC_locs id0). *) + padv_equiv (fun l => exists s_id v, id0 ⪯ s_id /\ l = translate_var s_id v) (fun l => l = state \/ l = rkeys) (IND_CPA_JENC id0 true) (IND_CPA_JENC id0 false) (λ _ : raw_package, 0%R). +Proof. + eapply eq_rel_perf_ind'. + (* invariant *) + { eapply pInvariant_pheap_ignore with (P := fun l => forall s_id v, id0 ⪯ s_id -> l != translate_var s_id v). - - (* (id:=id0) *) (* (L:=fset0) *) (* (L:=(fset (JENC_valid id0 (fset [::])).π1)). *) -(* _ignore with (L := fset Cenc_locs). *) - - intros. apply/eqP. intros contra. - destruct H. - apply H. - exists s_id, v. split; auto. - - - (* admit. *) - (* eapply fsubsetU. apply/orP; left. simpl. *) - (* rewrite [fset (key_location :: _)]fset_cons. *) - (* eapply fsubset_cons. *) - (* eapply fsubsetxx. *) - - - - unfold eq_up_to_inv. - unfold get_op_default. - unfold lookup_op. - unfold IND_CPA_JENC. - unfold IND_CPA_pkg_JENC. - - (* unfold JENC. *) - (* unfold get_translated_static_fun. *) - (* unfold translate_prog_static. *) - (* unfold translate_funs_static. *) - (* unfold translate_call_body. *) + { intros. apply/eqP. intros contra. + destruct H. apply H. + exists s_id, v. split; auto. } } + unfold eq_up_to_inv, get_op_default, lookup_op, IND_CPA_JENC, IND_CPA_pkg_JENC. Opaque Caes. Opaque translate_call. - (* Opaque wrange. *) Opaque wrange. Opaque expn. - Arguments heap_ignore_pred' : simpl never. simpl. - (* simplify_linking. *) - simplify_eq_rel m. - simplify_linking. - rewrite !cast_fun_K. - ssprove_sync. - { intros h0 h1 hpre. apply hpre. admit. } - (* Transparent heap_ignore_later. *) - (* { unfold get_pre_cond. intros. eapply H. left. admit. } intros. *) - (* ssprove_sync. *) - destruct a. - + ssprove_code_simpl. - simpl. - ssprove_sync. intros. - rewrite !zero_extend_u. - repeat clear_get. - do 3 eapply r_put_lhs. - eapply r_bind. - * -(* eapply rpre_weak_hypothesis_rule'. *) - (* intros. *) - (* destruct_pre. *) - - eapply aes_E; split. - ** intros. - destruct_pre. - eexists. - eexists. - *** eexists. - eexists. - **** eexists. - split. - ***** instantiate (1 := set_heap H6 (translate_var s_id' v) a0). - intros l lnin. - rewrite get_set_heap_neq. - 1: eapply H7. 1: assumption. - eapply lnin. - admit. - ***** reflexivity. - **** reflexivity. - *** rewrite set_heap_commut. - 1: rewrite [set_heap _ _ a0]set_heap_commut. - 1: rewrite [set_heap _ _ a0]set_heap_commut. - 1: reflexivity. - (* 1: unfold heap_ignore_pred' in H7. *) - (* Unset Printing Notations. *) - 1-3: admit. - ** intros. - destruct_pre. - - eexists. - eexists. - *** eexists. - eexists. - **** eexists. - split. - ***** instantiate (1 := H5). - intros l2 lnin. - rewrite get_set_heap_neq. - 1: eapply H6. 1: assumption. - admit. - ***** reflexivity. - **** reflexivity. - *** reflexivity. - * - simpl. - intros. - - eapply rpre_weak_hypothesis_rule'; intros. - destruct_pre. - simpl. - clear_get. - eapply r_put_lhs with (pre := fun _ => _). - eapply r_get_remember_lhs. intros. + simplify_eq_rel m. + simplify_linking. + rewrite !cast_fun_K. + ssprove_sync. + { intros h0 h1 hpre. apply hpre. admit. } + intros. + eapply r_bind with (mid := fun '(a₀, s₀) '(a₁, s₁) => pheap_ignore (λ l : ∑ _ : choice_type, nat, ∀ (s_id : p_id) (v : var), id0 ⪯ s_id → l != translate_var s_id v) (s₀, s₁) /\ a₀ = a₁). + { destruct a. + - eapply r_ret. easy. + - ssprove_sync. intros. + ssprove_sync. + { intros h0 h1 H1 H2 H. rewrite !get_set_heap_neq. 1: eapply H1; eauto. 1-2: admit. } + eapply r_ret. easy. } + intros. + (* TODO: find easier way to do next three lines *) + eapply rpre_weak_hypothesis_rule'. + intros; destruct_pre. + eapply rpre_weaken_rule with (pre:= fun '(s₀, s₁) => pheap_ignore (λ l : ∑ _ : choice_type, nat, ∀ (s_id : p_id) (v : var), id0 ⪯ s_id → l != translate_var s_id v) (s₀, s₁)); try easy. + ssprove_code_simpl. + simpl. + ssprove_sync. intros. + rewrite !zero_extend_u. + repeat clear_get. + do 3 eapply r_put_lhs. + eapply r_bind. + - eapply aes_E; split. + + intros. + destruct_pre. + do 2 eexists. + 1: do 2 eexists. + 1: do 2 eexists. + 1: instantiate (1 := set_heap H7 (translate_var s_id' v) a1). + all: try reflexivity. + { intros l lnin. rewrite get_set_heap_neq. 1: eapply H8; auto. admit. } + { repeat rewrite [set_heap _ _ a1]set_heap_commut; auto. 1-3: admit. } + + intros. + destruct_pre. + do 2 eexists. + 1: do 2 eexists. + 1: do 2 eexists. + 1: instantiate (1 := H6). + all: try reflexivity. + intros l2 lnin. + rewrite get_set_heap_neq. + 1: eapply H7. 1: assumption. + admit. + - simpl. intros. + eapply rpre_weak_hypothesis_rule'; intros. + destruct_pre. + simpl. + clear_get. + eapply r_put_lhs with (pre := fun _ => _). + eapply r_get_remember_lhs. intros. eapply r_bind with (m₁ := ret (chCanonical chUnit)) (f₁ := fun _ => _). 1: eapply JXOR_E; split. - - ** intros. - unfold set_lhs. - simpl. - destruct_pre. - simpl. - eexists. - 1: do 2 eexists. - 1: do 7 eexists. - 1: instantiate (1:= (set_heap H13 (translate_var s_id' v) a0)). - 1: { intros l hl. rewrite get_set_heap_neq. 1: eapply H14. 1: assumption. apply hl. admit. } - 1: reflexivity. - 1: rewrite [set_heap _ _ a0]set_heap_commut. - 1: rewrite [set_heap _ _ a0]set_heap_commut. - 1: rewrite [set_heap _ _ a0]set_heap_commut. - 1: rewrite [set_heap _ _ a0]set_heap_commut. - 1: reflexivity. - 1-4: admit. - sheap. simpl. rewrite get_set_heap_neq. 1: sheap. 1: reflexivity. - admit. - ** - intros. - easy. - ** - - intros. - eapply rpre_weak_hypothesis_rule'; intros. - destruct_pre; simpl. - clear_get. - eapply r_put_lhs with (pre := fun _ => _). - (* eapply rpost_weaken_rule. *) - eapply r_ret. - rewrite !coerce_to_choice_type_K. - rewrite !zero_extend_u. - intros. - destruct_pre; simpl; split_post. - 1: sheap. - 1: by rewrite wxorC. - intros l s_id. - rewrite !get_set_heap_neq. - (* Unset Printing Notations. *) - 1: eapply H18. - 1: eassumption. - 1-5: apply s_id; reflexivity. - + admit. + + intros. + destruct_pre. + 1: do 1 eexists. + 1: do 2 eexists. + 1: do 7 eexists. + 1: instantiate (1:= (set_heap H14 (translate_var s_id' v) a1)). + all: try reflexivity. + { intros l hl. rewrite get_set_heap_neq. 1: eapply H15. 1: assumption. apply hl. admit. } + { repeat rewrite [set_heap _ _ a1]set_heap_commut; auto. 1-4: admit. } + { sheap. simpl. rewrite get_set_heap_neq. 1: sheap. 1: reflexivity. admit. } + + intros. easy. + + intros. + eapply rpre_weak_hypothesis_rule'; intros. + destruct_pre; simpl. + clear_get. + eapply r_put_lhs with (pre := fun _ => _). + eapply r_ret. + rewrite !coerce_to_choice_type_K. + rewrite !zero_extend_u. + intros. + destruct_pre; simpl; split_post. + { sheap. by rewrite wxorC. } + { intros l s_id. + rewrite !get_set_heap_neq. + 1: eapply H19; auto. + 1-5: apply s_id; reflexivity. Admitted. Lemma IND_CPA_jazz_equiv_false : (IND_CPA_Cenc) true ≈₀ (IND_CPA_Cenc) false. Proof. eapply eq_rel_perf_ind_ignore with (L := fset Cenc_locs). - - eapply fsubsetU. apply/orP; left. simpl. + { eapply fsubsetU. apply/orP; left. simpl. rewrite [fset (key_location :: _)]fset_cons. eapply fsubset_cons. - eapply fsubsetxx. - - - (* We go to the relation logic using equality as invariant. *) - (* eapply eq_rel_perf_ind_eq. *) + eapply fsubsetxx. } unfold eq_up_to_inv. - Opaque Caes. - (* Opaque wrange. *) - Opaque wrange. - Opaque expn. + Opaque Caes. + Opaque wrange. + Opaque expn. simplify_eq_rel m. ssprove_sync. intros. - destruct a. - + simpl. - ssprove_sync. intros x. - eapply r_bind with (m₁ := ret (chCanonical chUnit)) (f₁ := fun _ => _). - * 1: eapply aes_h. - intros h1 h2 l a lin h. - intros l2 lnin. - unfold Cenc_locs in *. - admit. - * intros. eapply r_ret. - intros. destruct_pre; split_post; auto. - + simpl. - ssprove_sync. intros x. - ssprove_sync. - ssprove_sync. intros. - eapply r_bind with (m₁ := ret (chCanonical chUnit)) (f₁ := fun _ => _). - * 1: eapply aes_h. - intros h1 h2 l a2 lin h. - intros l2 lnin. - unfold Cenc_locs in *. - rewrite get_set_heap_neq. - 1: eapply h. 1: assumption. - admit. - * intros. eapply r_ret. - intros. destruct_pre; split_post; auto. + eapply r_bind with (mid := fun '(a0, s0) '(a1, s1) => a0 = a1 /\ heap_ignore (fset Cenc_locs) (s0, s1)). + { destruct a. + - eapply r_ret. easy. + - ssprove_sync. intros. + ssprove_sync. + (* { intros h0 h1 H1 H2 H. rewrite !get_set_heap_neq. 1: eapply H1; eauto. 1-2: admit. } *) + eapply r_ret. easy. } + intros. simpl. + (* TODO: find easier way to do next three lines *) + eapply rpre_weak_hypothesis_rule'. + intros; destruct_pre. + eapply rpre_weaken_rule with (pre:= fun '(s₀, s₁) => heap_ignore (fset Cenc_locs) (s₀, s₁)); try easy. + ssprove_sync. intros. + eapply r_bind with (m₁ := ret (chCanonical chUnit)) (f₁ := fun _ => _). + - 1: eapply aes_h. + intros h1 h2 l a2 lin h. + intros l2 lnin. + unfold Cenc_locs in *. + rewrite get_set_heap_neq. + 1: apply h; auto. + admit. + - intros. eapply r_ret. + intros. destruct_pre; split_post; auto. Admitted. Definition JIND_CPA id0 : @@ -958,143 +889,9 @@ Lemma IND_CPA_JENC_equiv_false id0 : 2-3: admit. rewrite Advantage_sym. pose proof IND_CPA_JENC_equiv_false id0. - unfold adv_equiv' in H. + unfold padv_equiv in H. specialize (H LA A vA hd₀ hd₁). rewrite H. rewrite GRing.addr0. apply Order.POrderTheory.le_refl. Admitted. - (* reflexivity. *) - (* auto. *) - - (* erewrite IND_CPA_equiv_true. all: eauto. *) - (* 2:{ simpl. unfold MOD_CPA_location. rewrite fset0U. auto. } *) - (* rewrite GRing.add0r GRing.addr0. *) - (* rewrite !Advantage_link. rewrite Advantage_sym. auto. *) - (* Qed. *) - (* + eapply rpre_weaken_rule. 1: eapply r_ret. eapply rreflexivity_rule. *) - (* - intros. *) - (* (* cbv zeta match. *) *) - (* (* eapply cmd_sample_preserve_pre. *) *) - (* (* eapply rsame_head. *) *) - (* ssprove_code_simpl. *) - (* eapply rpre_weaken_rule. *) - (* 1: ssprove_sync_eq. *) - (* 2: { intros. noconf H. easy. } *) - (* intros. *) - (* eapply r_bind with (m₁ := ret (chCanonical chUnit)) (f₁ := fun _ => _). *) - (* + eapply rpre_weaken_rule. 1: eapply aes_h. *) - (* easy. *) - (* + intros. *) - (* eapply r_ret. *) - (* intros. subst. split. *) - (* auto. *) - (* rreflexivity_rule. *) - - (* eapply r_bind. *) - (* rewrite !zero_extend_u. *) - (* eapply r_put_lhs with (pre := fun '(_, _) => _). *) - (* eapply r_put_lhs. *) - (* eapply r_put_lhs. *) - (* eapply r_bind with (m₁ := ret (chCanonical chUnit)) (f₁ := fun _ => _). *) - (* + *) - - (* eapply r_bind with (pre := fun _ => _). *) - - (* (* eapply sampler_case. *) *) - (* 2: easy. *) - (* eapply cmd_sample_preserve_pre. *) - (* eapply r_bind. *) - (* ssprove_code_simpl. *) - (* eapply r_uniform_bij. *) - (* eapply r_sample. *) - (* ssprove_sync. *) - (* ssprove_sync_eq. intros. *) - (* eapply rsame_head. *) - (* eapply r_bind. *) - (* ssprove_sync. intros. *) - - (* 1: ssprove_sync_eq. *) - (* ssprove_code_simpl. *) - (* simplify_linking. *) - (* simpl. *) - (* simplify_linking. *) - (* unfold get_op_default. *) - (* unfold lookup_op. *) - (* cbv match zeta. *) - (* unfold IND_CPA_jazz. *) - (* (* cbn. *) *) - (* (* cbn. *) *) - (* (* unfold IND_CPA_pkg_ff. *) *) - (* (* move: H; rewrite in_fset in_cons=>/orP []. 2: easy. *) *) - (* (* move=> /eqP H. noconf H. *) *) - - - (* unfold JKEYS_EXPAND. *) - (* unfold get_translated_static_fun. *) - (* unfold translate_prog_static. *) - (* unfold translate_funs_static. *) - (* unfold translate_call_body. *) - - (* simplify_eq_rel m. *) - (* simplify_linking. *) - (* (* We now conduct the proof in relational logic. *) *) - (* ssprove_swap_rhs 1%N. *) - (* ssprove_swap_rhs 0%N. *) - (* ssprove_sync_eq. cbn -[expn]. intros [k|]. *) - (* - cbn -[expn]. ssprove_swap_rhs 0%N. *) - (* eapply rpost_weaken_rule. *) - (* 1: eapply rreflexivity_rule. *) - (* cbn. intros [? ?] [? ?] e. inversion e. intuition auto. *) - (* - cbn -[expn]. *) - (* ssprove_swap_rhs 0%N. *) - (* ssprove_swap_rhs 1%N. *) - (* ssprove_swap_rhs 0%N. *) - (* ssprove_swap_rhs 2%N. *) - (* ssprove_swap_rhs 1%N. *) - (* eapply rpost_weaken_rule. 1: eapply rreflexivity_rule. *) - (* cbn. intros [? ?] [? ?] e. inversion e. intuition auto. *) - (* Qed. *) - - (* Opaque translate_for. *) - (* Opaque translate_call. *) - (* simpl. *) - (* (* Opaque wrange. *) *) - (* (* Opaque for_loop'. *) *) - (* constructor. *) - (* 1: rewrite in_fset; apply/xseq.InP; apply List.in_eq. *) - (* constructor. *) - (* 1: rewrite in_fset. 1: apply/xseq.InP; apply List.in_cons; eapply List.in_eq. *) - (* constructor. *) - (* 1: rewrite in_fset; apply/xseq.InP; repeat lazymatch goal with | |- List.In _ (_ :: _) => eapply List.in_cons | |- _ => eapply List.in_eq end. *) - (* constructor. *) - (* 1: rewrite in_fset; apply/xseq.InP; repeat lazymatch goal with | |- List.In _ (_ :: _) => eapply List.in_cons | |- _ => eapply List.in_eq end. *) - (* constructor. *) - (* 1: rewrite in_fset; apply/xseq.InP; repeat lazymatch goal with | |- List.In _ (_ :: _) => eapply List.in_cons | |- _ => eapply List.in_eq end. *) - (* intros. rewrite 3!bind_assoc. *) - (* eapply valid_bind. *) - (* { Transparent translate_call. unfold translate_call. Opaque translate_call. simpl. constructor. *) - (* Set Printing All. *) - (* valid_code *) - - (* simpl. *) - (* constructor. *) - (* 1: rewrite in_fset; apply/xseq.InP; repeat lazymatch goal with | |- List.In _ (_ :: _) => eapply List.in_cons | |- _ => eapply List.in_eq end. *) - (* constructor. *) - (* 1: rewrite in_fset; apply/xseq.InP; repeat lazymatch goal with | |- List.In _ (_ :: _) => eapply List.in_cons | |- _ => eapply List.in_eq end. *) - (* constructor. *) - (* 1: rewrite in_fset; apply/xseq.InP; repeat lazymatch goal with | |- List.In _ (_ :: _) => eapply List.in_cons | |- _ => eapply List.in_eq end. *) - (* 1: erewrite -> in_cons. *) - - (* cbn. simpl. *) - (* 2: easy. *) - (* simpl. *) - - (* Program Definition jazz_enc id0 {L : { fset Location }} (m : pt U128) (k : key U128) : *) - (* code L [interface] ('word U128 × 'word U128) := *) - (* {code *) - (* r ← sample uniform N ;; *) - (* pad ← JAES id0 (word_of_ord r) k ;; *) - (* let c := m ⊕ (hdtc128 pad) in *) - (* ret (word_of_ord r, c) *) - (* }. *) From b7f7371538a238503eab82d7193b4379d1c3220a Mon Sep 17 00:00:00 2001 From: bshvass Date: Wed, 21 Dec 2022 06:17:03 +0100 Subject: [PATCH 335/383] more cleaning --- theories/Jasmin/examples/aes/aes_valid.v | 2 - theories/Jasmin/examples/aes/prf.v | 456 +++++++---------------- 2 files changed, 129 insertions(+), 329 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes_valid.v b/theories/Jasmin/examples/aes/aes_valid.v index a41d87ee..0aa4ae72 100644 --- a/theories/Jasmin/examples/aes/aes_valid.v +++ b/theories/Jasmin/examples/aes/aes_valid.v @@ -134,8 +134,6 @@ Ltac clear_fset := Ltac fix_lvals1 := clear_fset; eapply valid_translate_write_lvals1. Ltac fix_lvals2 := clear_fset; eapply valid_translate_write_lvals2. -(* Definition Jvars {A} : raw_code -> {fset Location}. *) - Lemma JRCON_valid id0 : ∑ L, forall I j, ValidCode (fset L) I (JRCON id0 j). Proof. diff --git a/theories/Jasmin/examples/aes/prf.v b/theories/Jasmin/examples/aes/prf.v index bcd91dc2..5c2bdf84 100644 --- a/theories/Jasmin/examples/aes/prf.v +++ b/theories/Jasmin/examples/aes/prf.v @@ -353,14 +353,6 @@ Section JasminPRF. Notation " 'key " := ('word n) (in custom pack_type at level 2). Notation N := ((expn 2 n).-1.+1). - (* #[export] Instance : Positive N. *) - (* Proof. generalize 128; intros; red; by rewrite prednK_modulus expn_gt0. Qed. *) - (* (* #[export] Instance : Positive ((2 ^ n).-1.+1). *) *) - (* Proof. exact _. Qed. *) - - (* #[export] Instance word_pos (i : wsize.wsize) : Positive i. *) - (* Proof. by case i. Qed. *) - (* Notation N := *) Notation enc := (enc U128 aes). Notation kgen := (kgen U128). Notation key_location := (key_location U128). @@ -375,40 +367,6 @@ Section JasminPRF. end end. - (* Program Definition IND_CPA_pkg_Caes : *) - (* package (fset [:: rkeys; state]) *) - (* [interface #val #[i2] : 'unit → 'word] *) - (* [interface #val #[i1] : 'word → 'word] := *) - (* [package *) - (* #def #[i1] (m : 'word) : 'word *) - (* { *) - (* k ← get key_location ;; *) - (* k_val ← match k with *) - (* | None => *) - (* k_val ← sample uniform N ;; *) - (* #put key_location := Some (word_of_ord k_val) ;; *) - (* ret (word_of_ord k_val) *) - (* | Some k_val => *) - (* ret k_val *) - (* end ;; *) - (* #import {sig #[i2] : 'unit → 'key } as kg ;; *) - (* k_val ← kg (chCanonical 'unit) ;; *) - (* Caes m k_val *) - (* } *) - (* ]. *) - (* Next Obligation. *) - (* (* infer this *) *) - (* repeat constructor. red. *) - (* intros []. *) - (* rewrite in_fset in_cons. move=>/orP []. 2: easy. move=>/eqP H. noconf H. simpl. *) - (* eexists. *) - (* split. *) - (* 1: reflexivity. *) - (* intros. repeat constructor. *) - (* all: auto_in_fset. *) - (* Defined. *) - (* Opaque Caes. *) - Definition Cenc (m : pt) (k : key) : code (fset [:: state ; rkeys]) [interface] ('word n). Proof. @@ -503,13 +461,6 @@ Section JasminPRF. Notation IND_CPA := (IND_CPA U128 aes). Notation EVAL := (EVAL U128 aes). - (* Lemma fsubsetUl' : forall [T : ordType] (s1 s2 s3 : {fset T}), fsubset s1 s2 -> fsubset s1 (s2 :|: s3). *) - (* Proof. *) - - (* intros. *) - (* eapply fsubsetU. *) - (* rewrite -[s1]fsetUid. *) - (* eapply fsetSU. *) Lemma fsubset_ext2 : ∀ [T : ordType] (s1 s2 : {fset T}), fsubset s1 s2 -> (forall x, x \in s1 -> x \in s2). Proof. intros. @@ -529,7 +480,6 @@ Section JasminPRF. assumption. Qed. -(* fsubsetUl: ∀ [T : ordType] (s1 s2 : {fset T}), fsubset s1 (s1 :|: s2) *) Definition IND_CPA_Cenc : loc_GamePair [interface #val #[i1] : 'word → 'word ] := λ b, @@ -539,285 +489,135 @@ Section JasminPRF. loc_GamePair [interface #val #[i1] : 'word → 'word ] := λ b, if b then {locpackage IND_CPA_pkg_JENC id0} else {locpackage IND_CPA_pkg_Cenc}. -(* Lemma aes_h k m : *) -(* (* (forall i, (0 <= i < 11)%nat -> rkeys i = Some (key_i k i)) -> *) *) -(* ⊢ ⦃ fun '(h0, h1) => heap_ignore (fset Cenc_locs) (h0, h1) ⦄ *) -(* Caes k m *) -(* ≈ *) -(* ret (chCanonical chUnit) *) -(* ⦃ fun '(v0, h0) '(_, h1) => heap_ignore (fset Cenc_locs) (h0, h1) /\ v0 = aes k m ⦄. *) -(* Proof. *) -(* unfold Caes. *) -(* eapply r_bind with (m₁ := ret _). *) -(* - eapply aes_keyExpansion_h. *) -(* - intros a0 []. *) -(* eapply r_bind with (m₁ := ret _). *) -(* eapply aes_rounds_h. *) -(* intros a1 []. *) -(* eapply r_ret. *) -(* intros. *) -(* assumption. *) -(* Qed. *) -(* Print Instances Invariant. *) - (* Lemma heap_ignore_set_l h1 h2 l v L : l \notin L -> heap_ignore L ((set_heap h1 l v), h2). *) - (* Proof. *) - (* intros H a anin. *) - (* unfold heap_igno *) - (* eexists. *) - (* o *) - - - (* Lemma heap_ignore_fset0 h1 h2 : heap_ignore fset0 (h1, h2). *) - (* Proof. *) - (* intros l lnin. *) -(* pdisj *) - (* Definition heap_ignore_later (id : p_id) (L : {fset Location}) : precond := *) - (* λ '(h₀, h₁), *) - (* ∀ (ℓ : Location) (s_id : p_id) (v : var), ℓ \notin L \/ (id ≺ s_id /\ ℓ = translate_var s_id v) → get_heap h₀ ℓ = get_heap h₁ ℓ. *) - (* (* Instance : forall L1 L2, Invariant L1 L2 pdisj. := pdisj. *) *) - -(* Lemma INV'_heap_ignore_later id : *) -(* ∀ L L₀ L₁, *) -(* fsubset L (L₀ :|: L₁) → *) -(* INV' L₀ L₁ (heap_ignore_later id L). *) -(* Proof. *) -(* intros L L₀ L₁ hs h₀ h₁. split. *) -(* - intros hh ℓ n₀ n₁. *) -(* eapply hh. *) -(* left. *) -(* apply /negP. intro h. *) -(* eapply injectSubset in h. 2: eauto. *) -(* rewrite in_fsetU in h. move: h => /orP [h | h]. *) -(* + rewrite h in n₀. discriminate. *) -(* + rewrite h in n₁. discriminate. *) -(* - intros h ℓ v n₀ n₁ ℓ' n. *) -(* destruct (ℓ' != ℓ) eqn:e. *) -(* + rewrite get_set_heap_neq. 2: auto. *) -(* rewrite get_set_heap_neq. 2: auto. *) -(* apply h. *) -(* + move: e => /eqP e. subst. *) -(* rewrite !get_set_heap_eq. reflexivity. *) -(* Unshelve. 1: exact xH. exact (Var sbool ""). *) -(* Qed. *) - -(* Lemma Invariant_heap_ignore_later id : *) -(* ∀ L L₀ L₁, *) -(* fsubset L (L₀ :|: L₁) → *) -(* Invariant L₀ L₁ (heap_ignore_later id L). *) -(* Proof. *) -(* intros L L₀ L₁ h. split. *) -(* - apply INV'_heap_ignore_later. auto. *) -(* - intros L' id' v H. apply get_empty_heap. *) -(* Qed. *) - -(* Hint Extern 10 (Invariant _ _ (heap_ignore_later _ _)) => *) - (* eapply Invariant_heap_ignore_later *) - (* : (* typeclass_instances *) ssprove_invariant. *) - -(* Definition heap_ignore_pred' (P : Location -> Prop) : precond := *) - (* λ '(h₀, h₁), *) - (* forall (ℓ : Location), ~ P ℓ -> get_heap h₀ ℓ = get_heap h₁ ℓ. *) - -(* Arguments heap_ignore_pred' : simpl never. *) - -(* Lemma heap_ignore_pred'_empty : *) -(* ∀ P, *) -(* heap_ignore_pred' P (empty_heap, empty_heap). *) -(* Proof. *) -(* intros P ℓ hℓ. reflexivity. *) -(* Qed. *) - -Definition heap_ignore_pred' (P : Location -> Prop) : precond := - λ '(h₀, h₁), - forall (ℓ : Location), P ℓ -> get_heap h₀ ℓ = get_heap h₁ ℓ. - -Lemma heap_ignore_pred'_empty : - ∀ P, - heap_ignore_pred' P (empty_heap, empty_heap). -Proof. - intros P ℓ hℓ. reflexivity. -Qed. - -(* Lemma pINV'_heap_ignore_pred' (P : Location -> Prop) : *) -(* ∀ P0 P1 : Location -> Prop, *) -(* (forall ℓ : Location, ~ P0 ℓ /\ ~ P1 ℓ -> P ℓ) -> *) -(* pINV' P0 P1 (heap_ignore_pred' P). *) -(* Proof. *) -(* intros P0 P1 hP h0 h1. split. *) -(* - intros hh l nin1 nin2. *) -(* eapply hh. *) -(* apply hP. *) -(* eauto. *) -(* - intros h ℓ v nin0 nin1 ℓ' n. *) -(* destruct (ℓ' != ℓ) eqn:e. *) -(* + rewrite get_set_heap_neq. 2: auto. *) -(* rewrite get_set_heap_neq. 2: auto. *) -(* apply h. auto. *) -(* + move: e => /eqP e. subst. *) -(* rewrite !get_set_heap_eq. reflexivity. *) -(* Qed. *) - -(* Lemma Invariant'_heap_ignore_pred' : *) -(* ∀ P0 P1 (P : Location -> Prop), *) -(* (forall ℓ : Location, ~ P0 ℓ /\ ~ P1 ℓ -> P ℓ) -> *) -(* Invariant' P0 P1 (heap_ignore_pred' P). *) -(* Proof. *) -(* intros L P h. split. *) -(* - apply INV''_heap_ignore_pred'. auto. *) -(* - apply heap_ignore_pred'_empty. *) -(* Qed. *) - -(* Definition adv_equiv' P0 P1 {L₀ L₁ E} (G₀ G₁ : raw_package) *) -(* `{ValidPackage L₀ Game_import E G₀} `{ValidPackage L₁ Game_import E G₁} ε := *) -(* ∀ LA A, *) -(* ValidPackage LA E A_export A → *) -(* pdisjoint LA P0 → *) -(* pdisjoint LA P1 → *) -(* AdvantageE G₀ G₁ A = ε A. *) - -(* Lemma eq_rel_perf_ind'' : *) -(* ∀ P0 P1 {L₀ L₁ E} (p₀ p₁ : raw_package) (inv : precond) *) -(* `{ValidPackage L₀ Game_import E p₀} *) -(* `{ValidPackage L₁ Game_import E p₁}, *) -(* Invariant' P0 P1 inv → *) -(* eq_up_to_inv E inv p₀ p₁ → *) -(* adv_equiv' P0 P1 p₀ p₁ (λ _ : raw_package, 0%R). *) -(* Proof. *) -(* intros P0 P1 L₀ L₁ E p₀ p₁ inv v₀ v₁ [? ?] he. *) -(* (* adv_equiv. *) *) -(* (* Locate "≈₀". *) *) -(* intros LA A vA hd₀ hd₁. *) -(* eapply eq_upto_inv_perf_ind'. all: eauto. *) -(* Qed. *) - -(* TODO: move *) -Lemma JXOR_E pre id0 x y : - (pdisj pre id0 fset0) -> - ⊢ ⦃ fun '(h0, h1) => pre (h0, h1) ⦄ - JXOR id0 x y - ≈ - ret (chCanonical chUnit) - ⦃ fun '(v0, h0) '(v1, h1) => pre (h0, h1) /\ (exists o, (v0 = cons ('word U128 ; o ) nil ) /\ (o = x ⊕ y)) ⦄. -Proof. - unfold JXOR. - unfold get_translated_static_fun. - unfold translate_prog_static. - unfold translate_funs_static. - unfold translate_call_body. - intros disj. - - simpl. simpl_fun. - repeat setjvars. - ssprove_code_simpl. - repeat clear_get. - repeat eapply r_put_lhs. - eapply r_ret. - rewrite !zero_extend_u. - intros. destruct_pre; split_post. - 1: pdisj_apply disj. - eexists; split; [reflexivity|]. reflexivity. -Qed. - -(* TODO: move *) -Arguments pheap_ignore : simpl never. - -Lemma IND_CPA_JENC_equiv_false id0 : - padv_equiv (fun l => exists s_id v, id0 ⪯ s_id /\ l = translate_var s_id v) (fun l => l = state \/ l = rkeys) (IND_CPA_JENC id0 true) (IND_CPA_JENC id0 false) (λ _ : raw_package, 0%R). -Proof. - eapply eq_rel_perf_ind'. - (* invariant *) - { eapply pInvariant_pheap_ignore with - (P := fun l => forall s_id v, id0 ⪯ s_id -> l != translate_var s_id v). - { intros. apply/eqP. intros contra. - destruct H. apply H. - exists s_id, v. split; auto. } } - unfold eq_up_to_inv, get_op_default, lookup_op, IND_CPA_JENC, IND_CPA_pkg_JENC. - Opaque Caes. - Opaque translate_call. - Opaque wrange. - Opaque expn. - simpl. - simplify_eq_rel m. - simplify_linking. - rewrite !cast_fun_K. - ssprove_sync. - { intros h0 h1 hpre. apply hpre. admit. } - intros. - eapply r_bind with (mid := fun '(a₀, s₀) '(a₁, s₁) => pheap_ignore (λ l : ∑ _ : choice_type, nat, ∀ (s_id : p_id) (v : var), id0 ⪯ s_id → l != translate_var s_id v) (s₀, s₁) /\ a₀ = a₁). - { destruct a. - - eapply r_ret. easy. - - ssprove_sync. intros. - ssprove_sync. - { intros h0 h1 H1 H2 H. rewrite !get_set_heap_neq. 1: eapply H1; eauto. 1-2: admit. } - eapply r_ret. easy. } - intros. - (* TODO: find easier way to do next three lines *) - eapply rpre_weak_hypothesis_rule'. - intros; destruct_pre. - eapply rpre_weaken_rule with (pre:= fun '(s₀, s₁) => pheap_ignore (λ l : ∑ _ : choice_type, nat, ∀ (s_id : p_id) (v : var), id0 ⪯ s_id → l != translate_var s_id v) (s₀, s₁)); try easy. - ssprove_code_simpl. - simpl. - ssprove_sync. intros. - rewrite !zero_extend_u. - repeat clear_get. - do 3 eapply r_put_lhs. - eapply r_bind. - - eapply aes_E; split. - + intros. - destruct_pre. - do 2 eexists. - 1: do 2 eexists. - 1: do 2 eexists. - 1: instantiate (1 := set_heap H7 (translate_var s_id' v) a1). - all: try reflexivity. - { intros l lnin. rewrite get_set_heap_neq. 1: eapply H8; auto. admit. } - { repeat rewrite [set_heap _ _ a1]set_heap_commut; auto. 1-3: admit. } - + intros. - destruct_pre. - do 2 eexists. - 1: do 2 eexists. - 1: do 2 eexists. - 1: instantiate (1 := H6). - all: try reflexivity. - intros l2 lnin. - rewrite get_set_heap_neq. - 1: eapply H7. 1: assumption. - admit. - - simpl. intros. - eapply rpre_weak_hypothesis_rule'; intros. - destruct_pre. + + (* TODO: move *) + Lemma JXOR_E pre id0 x y : + (pdisj pre id0 fset0) -> + ⊢ ⦃ fun '(h0, h1) => pre (h0, h1) ⦄ + JXOR id0 x y + ≈ + ret (chCanonical chUnit) + ⦃ fun '(v0, h0) '(v1, h1) => pre (h0, h1) /\ (exists o, (v0 = cons ('word U128 ; o ) nil ) /\ (o = x ⊕ y)) ⦄. + Proof. + unfold JXOR. + unfold get_translated_static_fun. + unfold translate_prog_static. + unfold translate_funs_static. + unfold translate_call_body. + intros disj. + + simpl. simpl_fun. + repeat setjvars. + ssprove_code_simpl. + repeat clear_get. + repeat eapply r_put_lhs. + eapply r_ret. + rewrite !zero_extend_u. + intros. destruct_pre; split_post. + 1: pdisj_apply disj. + eexists; split; [reflexivity|]. reflexivity. + Qed. + + (* TODO: move *) + Arguments pheap_ignore : simpl never. + + Lemma IND_CPA_JENC_equiv_false id0 : + padv_equiv (fun l => exists s_id v, id0 ⪯ s_id /\ l = translate_var s_id v) (fun l => l = state \/ l = rkeys) (IND_CPA_JENC id0 true) (IND_CPA_JENC id0 false) (λ _ : raw_package, 0%R). + Proof. + eapply eq_rel_perf_ind'. + (* invariant *) + { eapply pInvariant_pheap_ignore with + (P := fun l => forall s_id v, id0 ⪯ s_id -> l != translate_var s_id v). + { intros. apply/eqP. intros contra. + destruct H. apply H. + exists s_id, v. split; auto. } } + unfold eq_up_to_inv, get_op_default, lookup_op, IND_CPA_JENC, IND_CPA_pkg_JENC. + Opaque Caes. + Opaque translate_call. + Opaque wrange. + Opaque expn. simpl. - clear_get. - eapply r_put_lhs with (pre := fun _ => _). - eapply r_get_remember_lhs. intros. - eapply r_bind with (m₁ := ret (chCanonical chUnit)) (f₁ := fun _ => _). - 1: eapply JXOR_E; split. - + intros. - destruct_pre. - 1: do 1 eexists. - 1: do 2 eexists. - 1: do 7 eexists. - 1: instantiate (1:= (set_heap H14 (translate_var s_id' v) a1)). - all: try reflexivity. - { intros l hl. rewrite get_set_heap_neq. 1: eapply H15. 1: assumption. apply hl. admit. } - { repeat rewrite [set_heap _ _ a1]set_heap_commut; auto. 1-4: admit. } - { sheap. simpl. rewrite get_set_heap_neq. 1: sheap. 1: reflexivity. admit. } - + intros. easy. - + intros. + simplify_eq_rel m. + simplify_linking. + rewrite !cast_fun_K. + ssprove_sync. + { intros h0 h1 hpre. apply hpre. admit. } + intros. + eapply r_bind with (mid := fun '(a₀, s₀) '(a₁, s₁) => pheap_ignore (λ l : ∑ _ : choice_type, nat, ∀ (s_id : p_id) (v : var), id0 ⪯ s_id → l != translate_var s_id v) (s₀, s₁) /\ a₀ = a₁). + { destruct a. + - eapply r_ret. easy. + - ssprove_sync. intros. + ssprove_sync. + { intros h0 h1 H1 H2 H. rewrite !get_set_heap_neq. 1: eapply H1; eauto. 1-2: admit. } + eapply r_ret. easy. } + intros. + (* TODO: find easier way to do next three lines *) + eapply rpre_weak_hypothesis_rule'. + intros; destruct_pre. + eapply rpre_weaken_rule with (pre:= fun '(s₀, s₁) => pheap_ignore (λ l : ∑ _ : choice_type, nat, ∀ (s_id : p_id) (v : var), id0 ⪯ s_id → l != translate_var s_id v) (s₀, s₁)); try easy. + ssprove_code_simpl. + simpl. + ssprove_sync. intros. + rewrite !zero_extend_u. + repeat clear_get. + do 3 eapply r_put_lhs. + eapply r_bind. + - eapply aes_E; split. + + intros. + destruct_pre. + do 2 eexists. + 1: do 2 eexists. + 1: do 2 eexists. + 1: instantiate (1 := set_heap H7 (translate_var s_id' v) a1). + all: try reflexivity. + { intros l lnin. rewrite get_set_heap_neq. 1: eapply H8; auto. admit. } + { repeat rewrite [set_heap _ _ a1]set_heap_commut; auto. 1-3: admit. } + + intros. + destruct_pre. + do 2 eexists. + 1: do 2 eexists. + 1: do 2 eexists. + 1: instantiate (1 := H6). + all: try reflexivity. + intros l2 lnin. + rewrite get_set_heap_neq. + 1: eapply H7. 1: assumption. + admit. + - simpl. intros. eapply rpre_weak_hypothesis_rule'; intros. - destruct_pre; simpl. + destruct_pre. + simpl. clear_get. eapply r_put_lhs with (pre := fun _ => _). - eapply r_ret. - rewrite !coerce_to_choice_type_K. - rewrite !zero_extend_u. - intros. - destruct_pre; simpl; split_post. - { sheap. by rewrite wxorC. } - { intros l s_id. - rewrite !get_set_heap_neq. - 1: eapply H19; auto. - 1-5: apply s_id; reflexivity. + eapply r_get_remember_lhs. intros. + eapply r_bind with (m₁ := ret (chCanonical chUnit)) (f₁ := fun _ => _). + 1: eapply JXOR_E; split. + + intros. + destruct_pre. + 1: do 1 eexists. + 1: do 2 eexists. + 1: do 7 eexists. + 1: instantiate (1:= (set_heap H14 (translate_var s_id' v) a1)). + all: try reflexivity. + { intros l hl. rewrite get_set_heap_neq. 1: eapply H15. 1: assumption. apply hl. admit. } + { repeat rewrite [set_heap _ _ a1]set_heap_commut; auto. 1-4: admit. } + { sheap. simpl. rewrite get_set_heap_neq. 1: sheap. 1: reflexivity. admit. } + + intros. easy. + + intros. + eapply rpre_weak_hypothesis_rule'; intros. + destruct_pre; simpl. + clear_get. + eapply r_put_lhs with (pre := fun _ => _). + eapply r_ret. + rewrite !coerce_to_choice_type_K. + rewrite !zero_extend_u. + intros. + destruct_pre; simpl; split_post. + { sheap. by rewrite wxorC. } + { intros l s_id. + rewrite !get_set_heap_neq. + 1: eapply H19; auto. + 1-5: apply s_id; reflexivity. Admitted. Lemma IND_CPA_jazz_equiv_false : @@ -878,8 +678,8 @@ Proof. rewrite !Advantage_E. eapply AdvantageE_le_0. ssprove triangle (JIND_CPA id0 false) [:: - IND_CPA_pkg_Cenc : raw_package - ] (JIND_CPA id0 true) A + IND_CPA_pkg_Cenc : raw_package + ] (JIND_CPA id0 true) A as ineq. eapply Order.POrderTheory.le_trans. 1: exact ineq. @@ -895,3 +695,5 @@ Proof. rewrite GRing.addr0. apply Order.POrderTheory.le_refl. Admitted. + +End JasminPRF. From 10b52d9ba179e3aa04f1256c453117081dde8e05 Mon Sep 17 00:00:00 2001 From: bshvass Date: Wed, 21 Dec 2022 12:25:12 +0100 Subject: [PATCH 336/383] cleared dubious admit in `prf.v` --- theories/Jasmin/examples/aes/prf.v | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/theories/Jasmin/examples/aes/prf.v b/theories/Jasmin/examples/aes/prf.v index 5c2bdf84..002531d8 100644 --- a/theories/Jasmin/examples/aes/prf.v +++ b/theories/Jasmin/examples/aes/prf.v @@ -499,13 +499,8 @@ Section JasminPRF. ret (chCanonical chUnit) ⦃ fun '(v0, h0) '(v1, h1) => pre (h0, h1) /\ (exists o, (v0 = cons ('word U128 ; o ) nil ) /\ (o = x ⊕ y)) ⦄. Proof. - unfold JXOR. - unfold get_translated_static_fun. - unfold translate_prog_static. - unfold translate_funs_static. - unfold translate_call_body. + unfold JXOR, get_translated_static_fun, translate_prog_static, translate_funs_static, translate_call_body. intros disj. - simpl. simpl_fun. repeat setjvars. ssprove_code_simpl. @@ -548,7 +543,10 @@ Section JasminPRF. - eapply r_ret. easy. - ssprove_sync. intros. ssprove_sync. - { intros h0 h1 H1 H2 H. rewrite !get_set_heap_neq. 1: eapply H1; eauto. 1-2: admit. } + { intros h0 h1 Hh l H. + destruct (l == key_location) eqn:E. + - move: E => /eqP heq. subst. rewrite !get_set_heap_eq. reflexivity. + - move: E => /negP Hneq. rewrite !get_set_heap_neq; auto. 1-2: apply /negP; auto. } eapply r_ret. easy. } intros. (* TODO: find easier way to do next three lines *) @@ -570,7 +568,7 @@ Section JasminPRF. 1: do 2 eexists. 1: instantiate (1 := set_heap H7 (translate_var s_id' v) a1). all: try reflexivity. - { intros l lnin. rewrite get_set_heap_neq. 1: eapply H8; auto. admit. } + { intros l lnin. rewrite get_set_heap_neq. 1: eapply H8; auto. eapply lnin. admit. } { repeat rewrite [set_heap _ _ a1]set_heap_commut; auto. 1-3: admit. } + intros. destruct_pre. From 30edbfff7b3d5494b92bf222bfc6a97251f950a7 Mon Sep 17 00:00:00 2001 From: bshvass Date: Thu, 22 Dec 2022 09:39:35 +0100 Subject: [PATCH 337/383] cleanup and restructuring --- _CoqProject | 4 + theories/Jasmin/examples/aes/aes.v | 1916 ++-------------------- theories/Jasmin/examples/aes/aes_prf.v | 696 ++++++++ theories/Jasmin/examples/aes/aes_spec.v | 236 +++ theories/Jasmin/examples/aes/aes_utils.v | 608 +++++++ theories/Jasmin/examples/aes/aes_valid.v | 128 +- theories/Jasmin/examples/aes/utils.v | 408 +++++ theories/Jasmin/word.v | 483 ++++++ 8 files changed, 2552 insertions(+), 1927 deletions(-) create mode 100644 theories/Jasmin/examples/aes/aes_prf.v create mode 100644 theories/Jasmin/examples/aes/aes_spec.v create mode 100644 theories/Jasmin/examples/aes/aes_utils.v create mode 100644 theories/Jasmin/examples/aes/utils.v create mode 100644 theories/Jasmin/word.v diff --git a/_CoqProject b/_CoqProject index baab728a..3f503ab0 100644 --- a/_CoqProject +++ b/_CoqProject @@ -80,6 +80,7 @@ theories/Crypt/rules/UniformStateProb.v # Jasmin theories/Jasmin/jasmin_translate.v theories/Jasmin/jasmin_utils.v +theories/Jasmin/word.v theories/Jasmin/examples/add1.v theories/Jasmin/examples/aes.v @@ -102,7 +103,10 @@ theories/Jasmin/examples/u64_incr.v theories/Jasmin/examples/xor.v theories/Jasmin/examples/aes/aes.v +theories/Jasmin/examples/aes/aes_prf.v +theories/Jasmin/examples/aes/aes_utils.v theories/Jasmin/examples/aes/aes_valid.v +theories/Jasmin/examples/aes/aes_spec.v theories/Jasmin/examples/xor/xor.v diff --git a/theories/Jasmin/examples/aes/aes.v b/theories/Jasmin/examples/aes/aes.v index ec1766b8..f1dc87ee 100644 --- a/theories/Jasmin/examples/aes/aes.v +++ b/theories/Jasmin/examples/aes/aes.v @@ -1,176 +1,36 @@ Set Warnings "-notation-overridden,-ambiguous-paths". -From mathcomp Require Import all_ssreflect all_algebra reals distr realsum - fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool - ssrnum eqtype choice seq. +From mathcomp Require Import all_ssreflect all_algebra zify. +From mathcomp.word Require Import word ssrZ. Set Warnings "notation-overridden,ambiguous-paths". -Require Import List. -Set Warnings "-notation-overridden". -From Jasmin Require Import expr. -Set Warnings "notation-overridden". -From Jasmin Require Import x86_instr_decl x86_extra waes. -From JasminSSProve Require Import jasmin_translate. -From Crypt Require Import Prelude Package. +From Coq Require Import Utf8 ZArith micromega.Lia List. -Import ListNotations. -Local Open Scope string. +From Jasmin Require Import expr xseq waes word x86_instr_decl x86_extra. +From JasminSSProve Require Import jasmin_utils jasmin_translate word aes_jazz aes_utils aes_spec. -Set Bullet Behavior "Strict Subproofs". -(* Set Default Goal Selector "!". *) (* I give up on this for now. *) +From Relational Require Import OrderEnrichedCategory. +From Crypt Require Import Prelude Package ChoiceAsOrd choice_type. -From Coq Require Import Utf8. From extructures Require Import ord fset fmap. -Require Import micromega.Lia. -From mathcomp.word Require Import word ssrZ. -From JasminSSProve Require Import aes_jazz jasmin_utils aes_valid. +Import ListNotations. Import JasminNotation JasminCodeNotation. Import PackageNotation. +Import AesNotation. -From mathcomp Require Import zify. - -Definition get_tr := get_translated_fun ssprove_jasmin_prog. - -Definition pdisj (P : precond) (s_id : p_id) (rhs : {fset Location}) := - (forall h1 h2 l a v s_id', l = translate_var s_id' v -> (s_id ⪯ s_id') -> (P (h1, h2) -> P (set_heap h1 l a, h2))) /\ - (forall h1 h2 l a, l \in rhs -> (P (h1, h2) -> P (h1, set_heap h2 l a))). - -Definition u_pdisj (P : precond) (lhs : {fset Location}) := - (forall h1 h2 l a, l \in lhs -> (P (h1, h2) -> P (set_heap h1 l a, h2))). - -Ltac solve_in := - repeat match goal with - | |- is_true (?v \in fset1 ?v :|: _) => apply/fsetU1P; left; auto - | |- is_true (_ \in fsetU _ _) => apply/fsetU1P; right - end. - -Fixpoint list_to_chtuple (l : list typed_chElement) : lchtuple [seq t.π1 | t <- l] := - match l as l0 return lchtuple [seq t.π1 | t <- l0] - with - | [] => tt - | tc' :: l' => - let rec := @list_to_chtuple l' in - match l' as l'0 - return - lchtuple [seq t.π1 | t <- l'0] -> - lchtuple [seq t.π1 | t <- (tc'::l'0)] - with - | [] => fun _ => tc'.π2 - | tc'' :: l'' => fun rec => (tc'.π2, rec) - end rec - end. - -Ltac destruct_pre := - repeat - match goal with - | [ H : set_lhs _ _ _ _ |- _ ] => - let sn := fresh in - let Hsn := fresh in - destruct H as [sn [Hsn]] - | [ H : set_rhs _ _ _ _ |- _ ] => - let sn := fresh in - let Hsn := fresh in - destruct H as [sn [Hsn]] - | [ H : _ /\ _ |- _ ] => - let H1 := fresh in - let H2 := fresh in - destruct H as [H1 H2] - | [ H : (_ ⋊ _) _ |- _ ] => - let H1 := fresh in - let H2 := fresh in - destruct H as [H1 H2] - | [ H : exists _, _ |- _ ] => - let o := fresh in - destruct H as [o] - end; simpl in *; subst. +Set Bullet Behavior "Strict Subproofs". +Set Default Goal Selector "!". -Ltac split_post := - repeat - match goal with - | |- (_ ⋊ _) _ => split - | |- _ /\ _ => split - | |- set_lhs _ _ _ _ => eexists - end. +Local Open Scope Z. -(* NB: this redefines neq_loc_auto, which helps some tactics, since checking for inequality by computation is not feasible for translated variables *) Ltac neq_loc_auto ::= solve [ eapply injective_translate_var3; auto | eapply injective_translate_var2; auto ]. -(* I don't know what rewrite * means, but this is much faster than regular rewrite, which also sometimes overflows the stack *) -Ltac sheap := - repeat first [ rewrite * get_set_heap_neq; [| neq_loc_auto ] | - rewrite * get_set_heap_eq ]. - -(* This works sometimes, but might be very slow *) -Ltac simpl_heap := - repeat lazymatch goal with - | |- context [ get_heap (set_heap _ ?l _) ?l ] => rewrite -> get_set_heap_eq - | |- context [ get_heap (set_heap (translate_var ?s_id _) (translate_var ?s_id _ ) _ ) _ ] => (rewrite -> get_set_heap_neq by (apply injective_translate_var3; auto)) - | |- context [ get_heap (set_heap _ (translate_var _ _ ) _ ) _ ] => (rewrite -> get_set_heap_neq by (apply injective_translate_var2; assumption)) - end. - -Ltac simpl_heap' := - repeat lazymatch goal with - | |- context [ get_heap (set_heap _ _ _) _ ] => - try rewrite -> get_set_heap_eq; - try (rewrite -> get_set_heap_neq by (apply injective_translate_var3; auto)); - try (rewrite -> get_set_heap_neq by (apply injective_translate_var2; assumption)) - end. - -#[global] Hint Resolve preceq_I preceq_O preceq_refl : preceq. -Ltac solve_preceq := - repeat lazymatch goal with - | |- ?a ⪯ ?a => reflexivity - | |- ?a ⪯ ?b~1 => etransitivity; [|apply preceq_I] - | |- ?a ⪯ ?b~0 => etransitivity; [|apply preceq_O] - end. - -Ltac pdisj_apply h := - lazymatch goal with - | |- ?pre (set_heap _ _ _, set_heap _ _ _) => eapply h; [ solve_in | pdisj_apply h ] - | |- ?pre (set_heap _ _ _, _) => - eapply h ; [ reflexivity | auto with preceq | pdisj_apply h ] - | |- _ => try assumption - end. - -Ltac pdisj'_apply h := - lazymatch goal with - | |- ?pre (set_heap _ _ _, _) => eapply h; [ tr_auto_in_fset | pdisj'_apply h ] - | |- ?pre (_, set_heap _ _ _) => eapply h; [ auto_in_fset | pdisj'_apply h ] - | |- _ => try assumption - end. - -Ltac u_pdisj_apply h := - lazymatch goal with - | |- ?pre (set_heap _ _ _, _) => eapply h; [ solve_in | u_pdisj_apply h ] - | |- _ => try assumption - end. - -Definition rcon (i : Z) : u8 := nth (wrepr U8 54%Z) [:: (wrepr U8 1%Z); (wrepr U8 2%Z); (wrepr U8 4%Z); (wrepr U8 8%Z); (wrepr U8 16%Z); (wrepr U8 32%Z); (wrepr U8 64%Z); (wrepr U8 128%Z); (wrepr U8 27%Z); (wrepr U8 54%Z)]%Z ((Z.to_nat i) - 1). - -Notation hdtcA res := (coerce_to_choice_type ('array) (hd ('word U64 ; chCanonical _) res).π2). - -Notation "m ⊕ k" := (@word.word.wxor _ m k) (at level 20). - -Definition key_expand (wn1 : u128) (rcon : u8) : 'word U128 := - let rcon := zero_extend U32 rcon (* W4u8 *) (* U32 4 *) (* [tuple rcon ; 0%R; 0%R; 0%R] *) (* [toword rcon; 0%Z; 0%Z; 0%Z] *) in - let w0 := subword 0 U32 wn1 in - let w1 := subword (1 * U32) U32 wn1 in - let w2 := subword (2 * U32) U32 wn1 in - let w3 := subword (3 * U32) U32 wn1 in - let tmp := w3 in - let tmp := SubWord (wror tmp 1) ⊕ rcon in - let w4 := w0 ⊕ tmp in - let w5 := w1 ⊕ w4 in - let w6 := w2 ⊕ w5 in - let w7 := w3 ⊕ w6 in - wcat [tuple w4; w5; w6; w7]. - -Lemma rcon_correct id0 pre i : +Lemma rcon_E id0 pre i : (pdisj pre id0 fset0) -> (forall s0 s1, pre (s0, s1) -> (1 <= i < 11)%Z) -> ⊢ ⦃ fun '(s0, s1) => pre (s0, s1) ⦄ JRCON id0 i ≈ ret tt - ⦃ fun '(v0, s0) '(v1, s1) => pre (s0, s1) /\ exists o, v0 = ([('int ; o)] : tchlist) /\ o = wunsigned (rcon i) ⦄. + ⦃ fun '(v0, s0) '(v1, s1) => pre (s0, s1) /\ exists o, v0 = [('int ; o)] /\ o = wunsigned (rcon i) ⦄. Proof. unfold JRCON. unfold get_translated_static_fun. @@ -183,679 +43,35 @@ Proof. end. all: ssprove_code_simpl; rewrite !coerce_to_choice_type_K; eapply r_put_lhs; ssprove_contract_put_get_lhs; eapply r_put_lhs; eapply r_ret. all: intros; destruct_pre; split_post; [ pdisj_apply Hpdisj | rewrite coerce_to_choice_type_K; eexists; split; eauto ]. - destruct (i =? 10)%Z eqn:E. rewrite Z.eqb_eq in E. subst. reflexivity. - apply H in H13. lia. -Qed. - -Definition pdisj' (P : precond) (s_id : p_id) (lhs : {fset Location}) (rhs : {fset Location}) := - (forall h1 h2 l a, l \in lhs -> (P (h1, h2) -> P (set_heap h1 l a, h2))) /\ - (forall h1 h2 l a, l \in rhs -> (P (h1, h2) -> P (h1, set_heap h2 l a))). - -Lemma rcon_correct' id0 pre i : - (pdisj' pre id0 (JRCON_locs id0) fset0) -> - (forall s0 s1, pre (s0, s1) -> (1 <= i < 11)%Z) -> - ⊢ ⦃ fun '(s0, s1) => pre (s0, s1) ⦄ JRCON id0 i - ≈ ret tt - ⦃ fun '(v0, s0) '(v1, s1) => pre (s0, s1) /\ exists o, v0 = ([('int ; o)] : tchlist) /\ o = wunsigned (rcon i) ⦄. -Proof. - unfold JRCON. - unfold JRCON_locs. - unfold get_translated_static_fun. - simpl. - intros Hpdisj H. - simpl_fun. - (* repeat setjvars. *) - repeat match goal with - | |- context[(?a =? ?b)%Z] => let E := fresh in destruct (a =? b)%Z eqn:E; [rewrite ?Z.eqb_eq in E; subst|] - | |- _ => simpl; ssprove_contract_put_get_lhs; rewrite !coerce_to_choice_type_K - end. - all: ssprove_code_simpl; rewrite !coerce_to_choice_type_K; eapply r_put_lhs; ssprove_contract_put_get_lhs; eapply r_put_lhs; eapply r_ret. - all: intros; destruct_pre; split_post; [ pdisj'_apply Hpdisj | rewrite coerce_to_choice_type_K; eexists; split; eauto ]. - destruct (i =? 10)%Z eqn:E. rewrite Z.eqb_eq in E. subst. reflexivity. - apply H in H13. lia. -Qed. -(* copy of the easycrypt functional definition *) -Definition W4u8 : 4.-tuple u8 -> u32 := wcat. -Definition W4u32 : 4.-tuple u32 -> u128 := wcat. - -Lemma lsr_word0 {ws1} a : @lsr ws1 word0 a = word0. -Proof. - unfold lsr. - rewrite Z.shiftr_0_l. - apply val_inj. - reflexivity. -Qed. - -Lemma subword_word0 {ws1} a ws2 : @subword ws1 a ws2 word0 = word0. -Proof. - unfold subword. - rewrite lsr_word0. - apply val_inj. - reflexivity. -Qed. - -Lemma wpshufd10 : forall w n, wpshufd1 w 0 n = zero_extend U32 w. -Proof. - unfold wpshufd1. - intros a n. - rewrite subword_word0 Z.mul_0_r wshr0. - change 32%nat with (nat_of_wsize U32). - apply subword0. -Qed. - -(* Lemma wpshufd_1280 : forall a, wpshufd_128 a 0 = a. *) -(* Proof. *) -(* intros a. *) -(* unfold wpshufd_128. *) -(* rewrite wrepr0. *) -(* unfold iota, map. *) -(* rewrite !wpshufd10. *) -(* simpl. *) -(* Admitted. *) - -Lemma wcat_eq ws p a t : - (forall (i : 'I_p), subword (i * ws) ws a = tnth t i) -> a = wcat t. -Proof. - intros. - rewrite -[a]wcat_subwordK. - apply f_equal. apply eq_from_tnth. - intros i. - rewrite -H tnth_map tnth_ord_tuple. - reflexivity. -Qed. - -Definition W4u32_eq : forall a t, (forall (i : 'I_4), subword (i * U32) U32 a = tnth t i) -> a = W4u32 t := wcat_eq U32 4. - -Lemma wbit_subword {ws1} i ws2 (w : word ws1) j : - (ws2 <= ws1)%nat -> - (j < ws2)%nat -> - wbit (subword i ws2 w) j = wbit w (i + j)%nat. -Proof. - intros. - unfold subword. - simpl. - unfold urepr. - simpl. - unfold wbit. - simpl. - unfold modulus. - rewrite !two_power_nat_equiv. - rewrite Z.mod_pow2_bits_low. - { rewrite Z.mod_pow2_bits_low. 2: lia. - rewrite Z.shiftr_spec. 2: lia. - f_equal. lia. - } - lia. -Qed. - -Lemma subword_xor {n} i ws (a b : n.-word) : - (* I don't know if the assumption is necessary *) - (ws <= n)%nat -> - subword i ws (a ⊕ b) = (subword i ws a) ⊕ (subword i ws b). -Proof. - intros H. - apply/eqP/eq_from_wbit. - intros. rewrite !wbit_subword. 2,3: auto. - rewrite !wxorE. - rewrite !wbit_subword. 2-5: auto. - reflexivity. -Qed. - -Local Open Scope Z_scope. - -Lemma wrepr_lsr (ws : wsize.wsize) a i : - (0 <= a < modulus ws)%Z -> - lsr (wrepr ws a) i = wrepr ws (Z.shiftr a (Z.of_nat i)). -Proof. - intros H. - unfold lsr. - rewrite mkwordK. - unfold wrepr. - apply val_inj. - simpl. - rewrite [a mod _]Z.mod_small. 2: assumption. - reflexivity. -Qed. - -Lemma modulus_gt0' n : (0 < modulus n)%Z. -Proof. - apply Z.ltb_lt. - apply modulus_gt0. -Qed. - -(* following two lemmas are from fiat crypto, consider importing *) -Lemma mod_pow_same_base_larger a b n m : - 0 <= n <= m -> 0 < b -> - (a mod (b^n)) mod (b^m) = a mod b^n. -Proof. - intros. - pose proof Z.mod_pos_bound a (b^n) ltac:(auto with zarith). - assert (b^n <= b^m). - { eapply Z.pow_le_mono_r; lia. } - apply Z.mod_small. auto with zarith. -Qed. - -Lemma mod_pow_same_base_smaller a b n m : - 0 <= m <= n -> 0 < b -> - (a mod (b^n)) mod (b^m) = a mod b^m. -Proof. - intros. replace n with (m+(n-m)) by lia. - rewrite -> Z.pow_add_r, Z.rem_mul_r by auto with zarith. - rewrite <- Zplus_mod_idemp_r. - rewrite <- Zmult_mod_idemp_l. - rewrite Z.mod_same. 2: eapply Z.pow_nonzero ; lia. - rewrite Z.mul_0_l. - rewrite Z.mod_0_l. 2: eapply Z.pow_nonzero ; lia. - rewrite Z.add_0_r. - rewrite Z.mod_mod. 2: eapply Z.pow_nonzero ; lia. - reflexivity. -Qed. - -Lemma larger_modulus a n m : - (n <= m)%nat -> - (a mod modulus n) mod modulus m = a mod modulus n. -Proof. - intros H. - rewrite !modulusZE. - apply mod_pow_same_base_larger. 2: lia. - zify. simpl. lia. -Qed. - -Lemma smaller_modulus a n m : - (m <= n)%nat -> - (a mod modulus n) mod modulus m = a mod modulus m. -Proof. - intros H. - rewrite !modulusZE. - apply mod_pow_same_base_smaller. 2: lia. - zify. simpl. lia. -Qed. - -Lemma nat_of_wsize_m ws : (wsize_size_minus_1 ws).+1 = nat_of_wsize ws. -Proof. destruct ws; reflexivity. Qed. -Lemma modulus_ne0 : forall n, modulus n <> 0. -Proof. - intros n. - pose proof modulus_gt0 n. - zify. lia. -Qed. - -Lemma enum0 : - enum ('I_0) = []. -Proof. - assert (size (enum 'I_0) = 0%nat). - { apply size_enum_ord. } - apply size0nil. assumption. -Qed. - -Lemma nth_aux {T} (a : T) l : - [seq nth a l (val i) | i <- enum 'I_(size l)] = l. -Proof. - replace [seq nth a l (val i) | i <- enum 'I_(size l)] with [seq nth a l i | i <- [seq val i | i <- enum 'I_(size l)]]. - 2: { rewrite -map_comp. reflexivity. } - rewrite val_enum_ord. - rewrite map_nth_iota0. 2: lia. - rewrite take_size. reflexivity. -Qed. - -Lemma make_vec_wcat {ws1} (l : seq (word.word ws1)) : - wcat_r l = wcat [tuple nth word0 l i | i < size l]. -Proof. - unfold wcat. - simpl. - rewrite nth_aux. - reflexivity. -Qed. -Lemma wbit_wrepr (ws : wsize.wsize) a i : - (i < ws)%nat -> - wbit (urepr (wrepr ws a)) i = wbit a i. -Proof. - intros H. - unfold wbit. - unfold wrepr. - unfold urepr. - simpl. unfold modulus. - rewrite two_power_nat_equiv. - rewrite Z.mod_pow2_bits_low. - 2:{ unfold nat_of_wsize in *. lia. } - reflexivity. -Qed. - -Lemma wbit_make_vec {ws1} (ws2 : wsize.wsize) (l : seq (word.word ws1)) i : - (i < ws2)%nat -> - wbit (urepr (make_vec ws2 l)) i = wbit (nth word0 l (i %/ ws1)) (i %% ws1). -Proof. - intros H. - unfold make_vec. - rewrite make_vec_wcat. - rewrite wbit_wrepr. 2: assumption. - rewrite wcat_wbitE. - unfold urepr. - simpl. - repeat f_equal. - apply nth_aux. -Qed. - -Lemma divn_aux j i n : - (j < n)%nat -> - (n <= j %% n + i %% n)%nat = false -> - (j + i) %/ n = i %/ n. -Proof. - intros H1 H2. - rewrite divnD. 2: lia. - rewrite H2. - rewrite divn_small. all: lia. -Qed. - -Lemma modn_aux j i n : - (j < n)%nat -> - (n <= j %% n + i %% n)%nat = false -> - (j + i) %% n = (j + i %% n)%nat. -Proof. - intros H1 H2. - rewrite modnD. 2: lia. - rewrite H2. - rewrite modn_small. all: lia. -Qed. - -Lemma subword_make_vec1 {ws1} i ws2 (ws3 : wsize.wsize) (l : seq (word.word ws1)) : - (* i + ws2 does 'reach across' a single word in the list *) - (ws2 <= ws1)%nat -> - (i + ws2 <= ws3)%nat -> - (ws1 <= (ws2 - 1) %% ws1 + i %% ws1)%nat = false -> - (* i think this condition is equivalent, but the others fit with other lemmas *) - (* ((i + ws2 - 1) / ws1)%nat = (i / ws1)%nat -> *) - subword i ws2 (make_vec ws3 l) = subword (i %% ws1) ws2 (nth word0 l (i %/ ws1)%nat). -Proof. - intros H1 H2 H3. - rewrite !subwordE. - f_equal. - apply eq_mktuple. - intros j. - destruct j. simpl. - rewrite wbit_make_vec. 2: lia. - f_equal. - - f_equal. f_equal. - apply divn_aux. 1:{ simpl. lia. } - rewrite modn_small in H3. 2: lia. - rewrite modn_small. 2: lia. - lia. - - apply modn_aux. 1: lia. - rewrite modn_small in H3. 2: lia. - rewrite modn_small. 1: lia. - lia. -Qed. - -Lemma make_vec_ws ws (l : seq (word.word ws)) : - make_vec ws l = nth word0 l 0. -Proof. - apply/eqP. - apply/eq_from_wbit. - intros [i]. - rewrite wbit_make_vec. - simpl. - rewrite divn_small. - rewrite modn_small. - reflexivity. - unfold nat_of_wsize. lia. - unfold nat_of_wsize. lia. - unfold nat_of_wsize. simpl. lia. -Qed. - -Lemma subword_0_128 (l : seq u128) : - subword 0 0 (make_vec U128 l) = subword 0 0 (nth word0 l 0). -Proof. - by rewrite make_vec_ws. -Qed. - -Lemma subword_0_32_128 (l : seq u128) : - subword 0 U32 (make_vec U128 l) = subword 0 U32 (nth word0 l 0). -Proof. - by rewrite make_vec_ws. -Qed. - -Lemma subword_1_32_128 (l : seq u128) : - subword 1 U32 (make_vec U128 l) = subword 1 U32 (nth word0 l 0). -Proof. - by rewrite make_vec_ws. -Qed. - -Lemma subword_2_32_128 (l : seq u128) : - subword 2 U32 (make_vec U128 l) = subword 2 U32 (nth word0 l 0). -Proof. - by rewrite make_vec_ws. -Qed. - -Lemma subword_3_32_128 (l : seq u128) : - subword 3 U32 (make_vec U128 l) = subword 3 U32 (nth word0 l 0). -Proof. - by rewrite make_vec_ws. -Qed. - - -Lemma subword_make_vec {ws1} i (ws2 : wsize.wsize) (l : seq (word.word ws1)) : - (ws1 <= ws2)%nat -> - ((i + 1) * ws1 <= ws2)%nat -> - subword (i * ws1) ws1 (make_vec ws2 l) = nth word0 l i. -Proof. - intros H1 H2. - apply/eqP. - apply /eq_from_wbit. - intros [i0]. simpl. - rewrite wbit_subword. - rewrite wbit_make_vec. - rewrite addnC. - rewrite divn_aux. - rewrite mulnK. - rewrite modn_aux. - rewrite modnMl. - rewrite addn0. - reflexivity. all: try lia. - rewrite modnMl. lia. - rewrite modnMl. lia. - unfold nat_of_ord in *. unfold nat_of_wsize in *. lia. -Qed. - -Lemma subword_u {ws} (w : word.word ws) : subword 0 ws w = w. -Proof. by rewrite subword0 zero_extend_u. Qed. - -Lemma nth_map2 {A B C} (a : A) (b : B) (c : C) la lb f n : - (n < Nat.min (size la) (size lb))%nat -> nth c (map2 f la lb) n = f (nth a la n) (nth b lb n). -Proof. - revert la lb. - induction n; intros. - - destruct la. - + simpl in H; zify; lia. - + destruct lb. - * simpl in H; zify; lia. - * reflexivity. - - destruct la. - + simpl in H; zify; lia. - + destruct lb. - * simpl in H; zify; lia. - * simpl. - eapply IHn. - simpl in H. - zify; lia. -Qed. - -Lemma subword_make_vec_32_0_32_128 (l : seq u32) : subword 0 U32 (make_vec U128 l) = nth word0 l 0. -Proof. - rewrite subword_make_vec1. - rewrite subword_u. - all: auto. -Qed. - -Lemma subword_make_vec_32_1_32_128 (l : seq u32) : subword U32 U32 (make_vec U128 l) = nth word0 l 1. -Proof. - rewrite subword_make_vec1. - rewrite subword_u. - all: auto. -Qed. - -Lemma subword_make_vec_32_2_32_128 (l : seq u32) : subword (2 * U32) U32 (make_vec U128 l) = nth word0 l 2. -Proof. - rewrite subword_make_vec1. - rewrite subword_u. - all: auto. -Qed. - -Lemma subword_make_vec_32_3_32_128 (l : seq u32) : subword (3 * U32) U32 (make_vec U128 l) = nth word0 l 3. -Proof. - rewrite subword_make_vec1. - rewrite subword_u. - all: auto. + destruct (i =? 10)%Z eqn:E. + - rewrite Z.eqb_eq in E. subst. reflexivity. + - apply H in H13. lia. Qed. Arguments nat_of_wsize : simpl never. Arguments wsize_size_minus_1 : simpl never. -Lemma make_vec_single {ws1} ws2 (a : word.word ws1) : - make_vec ws2 [:: a] = zero_extend ws2 a. -Proof. - unfold make_vec. cbn -[Z.of_nat]. - by rewrite Z.shiftl_0_l Z.lor_0_r. -Qed. - -Lemma wshr_word0 {ws} i : @wshr ws 0 i = word0. -Proof. - unfold wshr. - by rewrite lsr_word0. -Qed. - -Lemma wxor_0_r {n} (a : n.-word) : wxor a word0 = a. -Proof. - unfold wxor. - apply val_inj. simpl. - by rewrite Z.lxor_0_r. -Qed. - -Lemma wxor_0_l {n} (a : n.-word) : wxor word0 a = a. -Proof. - apply val_inj. - reflexivity. -Qed. - -(* from fiat crypto, but proof is more involved *) -Lemma mod_pull_div a b c - : 0 <= c -> (a / b) mod c = a mod (c * b) / b. -Admitted. - -Lemma shiftr_shiftr_mod w ws1 ws2 i j : - (ws2 + j <= ws1)%nat -> - Z.shiftr (Z.shiftr w (Z.of_nat i) mod modulus ws1) (Z.of_nat j) mod modulus ws2 = - Z.shiftr w (Z.of_nat (i + j)) mod modulus ws2. -Proof. - intros H. - rewrite modulusZE. - simpl. - rewrite !modulusZE. - rewrite !Z.shiftr_div_pow2. - rewrite !mod_pull_div. - simpl. - rewrite -!Z.pow_add_r. - rewrite mod_pow_same_base_smaller. - rewrite Z.div_div. - rewrite -Z.pow_add_r. - rewrite Nat2Z.inj_add. - f_equal. f_equal. f_equal. - all: try lia. -Qed. - -Lemma subword_wshr {ws1} i j ws2 (w : ws1.-word) : - (ws2 + i <= ws1)%nat -> - subword i ws2 (lsr w j) = subword (j + i) ws2 w. -Proof. - intros H. - unfold subword; simpl. - apply val_inj; simpl. - rewrite urepr_word. - unfold lsr. - simpl. - rewrite urepr_word. - rewrite !smaller_modulus. - rewrite shiftr_shiftr_mod. - reflexivity. - all: lia. -Qed. - -Lemma wxor_involutive {n} : forall k : word n, k ⊕ k = word0. -Proof. - intros k. - apply/eqP/eq_from_wbit=> i. - rewrite !wxorE addbb. - unfold wbit. - rewrite Z.testbit_0_l. - reflexivity. -Qed. - -Lemma wxorA {n} : forall m k l : word n, ((m ⊕ k) ⊕ l) = (m ⊕ (k ⊕ l)). -Proof. - intros m k l. - apply/eqP/eq_from_wbit=> i. - by rewrite !wxorE addbA. -Qed. - -Lemma nth_split_vec {ws1} ws2 n (d : word.word ws2) (w : word.word ws1) : - (n < ws1 %/ ws2 + ws1 %% ws2)%nat -> - nth d (split_vec ws2 w) n = subword (n * ws2) ws2 w. -Proof. - intros H. - unfold split_vec. - erewrite nth_map. - f_equal. - rewrite nth_iota. - lia. - assumption. - rewrite size_iota. - assumption. - Unshelve. exact 0%nat. -Qed. - -Lemma subword_U8_SubWord n w : - (0 <= n < 4)%nat -> - subword (n * U8) U8 (SubWord w) = Sbox (subword (n * U8) U8 w). -Proof. - intros. - unfold SubWord. - rewrite subword_make_vec. - erewrite nth_map. - f_equal. - apply nth_split_vec. - cbn. simpl. lia. - simpl. lia. cbn. simpl. lia. - unfold nat_of_wsize, wsize_size_minus_1. zify. simpl. nia. - Unshelve. exact word0. -Qed. - -Lemma split_vec_make_vec {ws1} (ws2 : wsize.wsize) (l : seq (word.word ws1)) : - (ws2 %% ws1 = 0)%nat -> - (size l = ws2 %/ ws1)%nat -> - split_vec ws1 (make_vec ws2 l) = l. -Proof. - destruct l. - - simpl. - intros . - unfold make_vec. - simpl. - unfold split_vec. - rewrite -H0 H. - simpl. - reflexivity. - - intros Hmod Hsize. - simpl. - unfold split_vec. - rewrite <- take_size. - erewrite <- map_nth_iota0. - rewrite Hsize. rewrite Hmod. - rewrite addn0. - apply map_ext. - intros. - apply subword_make_vec. - simpl in Hsize. zify. nia. - move: H => /InP. rewrite mem_iota. - intros H. zify. nia. - easy. -Qed. - -Lemma SubWord_make_vec l : - (size l = 4)%nat -> - SubWord (make_vec U32 l) = make_vec U32 [seq Sbox i | i <- l]. -Proof. - intros. - unfold SubWord. - rewrite split_vec_make_vec. - easy. - unfold nat_of_wsize, wsize_size_minus_1. - easy. - unfold nat_of_wsize, wsize_size_minus_1. - easy. -Qed. - -Lemma ShiftRows_SubBytes s : ShiftRows (SubBytes s) = SubBytes (ShiftRows s). -Proof. - unfold ShiftRows, SubBytes. simpl. - f_equal. f_equal. - rewrite !subword_make_vec_32_0_32_128. simpl. - rewrite !subword_make_vec_32_1_32_128. simpl. - rewrite !subword_make_vec_32_2_32_128. simpl. - rewrite !subword_make_vec_32_3_32_128. simpl. - rewrite -> !subword_U8_SubWord by lia. - rewrite -> !SubWord_make_vec by reflexivity. - simpl. reflexivity. - f_equal. - rewrite !subword_make_vec_32_0_32_128. simpl. - rewrite !subword_make_vec_32_1_32_128. simpl. - rewrite !subword_make_vec_32_2_32_128. simpl. - (* rewrite !subword_make_vec_32_3_32_128. simpl. *) - rewrite -> !subword_U8_SubWord by lia. - rewrite -> !SubWord_make_vec by reflexivity. - simpl. reflexivity. - f_equal. - rewrite !subword_make_vec_32_0_32_128. simpl. - rewrite !subword_make_vec_32_1_32_128. simpl. - rewrite !subword_make_vec_32_2_32_128. simpl. - rewrite !subword_make_vec_32_3_32_128. simpl. - rewrite -> !subword_U8_SubWord by lia. - rewrite -> !SubWord_make_vec by reflexivity. - simpl. reflexivity. - f_equal. - rewrite !subword_make_vec_32_0_32_128. simpl. - rewrite !subword_make_vec_32_1_32_128. simpl. - rewrite !subword_make_vec_32_2_32_128. simpl. - rewrite !subword_make_vec_32_3_32_128. simpl. - rewrite -> !subword_U8_SubWord by lia. - rewrite -> !SubWord_make_vec by reflexivity. - simpl. reflexivity. -Qed. - -Lemma wAESENC_wAESENC_ s k : wAESENC s k = wAESENC_ s k. -Proof. - unfold wAESENC, wAESENC_. - f_equal. f_equal. - rewrite ShiftRows_SubBytes. - reflexivity. -Qed. - -Lemma wror_substitute w k : wror (SubWord w) k = SubWord (wror w k). -Proof. - (* I would like to case on w, but not sure how to do this most efficiently? *) -Admitted. - -Notation pr T l n := (coerce_to_choice_type T (nth (T ; chCanonical T) l n).π2). -Lemma wxorC {n} (a b : word n) : wxor a b = wxor b a. -Proof. - apply/eqP/eq_from_wbit=> i. rewrite !wxorE. - rewrite addbC. reflexivity. -Qed. - -Lemma wreprI ws (a : word.word ws) : wrepr ws (toword a) = a. -Proof. - apply val_inj. simpl. destruct a. rewrite Z.mod_small. reflexivity. - simpl in *. lia. -Qed. - Lemma key_expand_aux rcon rkey temp2 rcon_ : - toword rcon_ = rcon -> - subword 0 U32 temp2 = word0 -> + word.toword rcon_ = rcon -> + word.subword 0 U32 temp2 = word.word0 -> ((rkey ⊕ lift2_vec U128 (wshufps_128 (wpack U8 2 [0; 0; 1; 0])) U128 temp2 rkey) ⊕ lift2_vec U128 (wshufps_128 (wpack U8 2 [0; 3; 0; 2])) U128 (lift2_vec U128 (wshufps_128 (wpack U8 2 [0; 0; 1; 0])) U128 temp2 rkey) (rkey ⊕ lift2_vec U128 (wshufps_128 (wpack U8 2 [0; 0; 1; 0])) U128 temp2 rkey)) ⊕ wpshufd_128 (wAESKEYGENASSIST rkey (wrepr U8 rcon)) (wunsigned (wpack U8 2 [3; 3; 3; 3])) = key_expand rkey rcon_. Proof. + Set Printing Implicit. intros. subst. unfold key_expand. - apply W4u32_eq. + apply (wcat_eq U32 4). intros [[ | [ | [ | [ | i]]]] j]; simpl; unfold tnth; simpl. - - rewrite !subword_xor. + - rewrite !subword_xor; auto. rewrite mul0n. unfold lift2_vec. - rewrite !subword_0_32_128. - simpl. - rewrite mul0n. rewrite !make_vec_ws. + simpl. rewrite !subword_u. + simpl. rewrite !subword_make_vec_32_0_32_128. unfold wpack. simpl. @@ -865,7 +81,7 @@ Proof. rewrite !subword_make_vec_32_0_32_128. simpl. unfold wAESKEYGENASSIST. - rewrite subword_wshr. + rewrite subword_wshr; auto. rewrite subword_make_vec_32_3_32_128. simpl. rewrite !wxorA. @@ -881,7 +97,6 @@ Proof. f_equal. rewrite wreprI. reflexivity. - all: auto. - simpl. unfold lift2_vec. rewrite !make_vec_ws. @@ -890,17 +105,17 @@ Proof. simpl. rewrite mul0n. rewrite !subword_u. - rewrite !subword_xor. + rewrite !subword_xor; auto. rewrite !subword_make_vec_32_1_32_128. simpl. unfold wpshufd1. simpl. - rewrite !subword_wshr. + rewrite !subword_wshr; auto. rewrite !addn0. rewrite !subword_make_vec_32_3_32_128. simpl. unfold wpshufd1. - rewrite subword_wshr. + rewrite subword_wshr; auto. simpl. rewrite addn0. rewrite !wxorA. @@ -913,7 +128,6 @@ Proof. f_equal. rewrite wreprI. reflexivity. - all: try auto. - simpl. unfold lift2_vec. rewrite !make_vec_ws. @@ -922,19 +136,19 @@ Proof. simpl. rewrite mul0n. rewrite !subword_u. - rewrite !subword_xor. + rewrite !subword_xor; auto. rewrite !subword_make_vec_32_2_32_128. simpl. unfold wpshufd1. simpl. - rewrite !subword_wshr. + rewrite !subword_wshr; auto. rewrite !addn0. - rewrite !subword_xor. + rewrite !subword_xor; auto. rewrite !subword_make_vec_32_3_32_128. simpl. rewrite !subword_make_vec_32_0_32_128. unfold wpshufd1. - rewrite subword_wshr. + rewrite subword_wshr; auto. simpl. rewrite addn0. rewrite !wxorA. @@ -948,7 +162,6 @@ Proof. f_equal. rewrite wreprI. reflexivity. - all: try auto. - simpl. unfold lift2_vec. rewrite !make_vec_ws. @@ -957,26 +170,26 @@ Proof. simpl. rewrite mul0n. rewrite !subword_u. - rewrite !subword_xor. + rewrite !subword_xor; auto. rewrite !subword_make_vec_32_3_32_128. simpl. unfold wpshufd1. simpl. - rewrite !subword_wshr. + rewrite !subword_wshr; auto. rewrite !addn0. - rewrite !subword_xor. + rewrite !subword_xor; auto. rewrite !subword_make_vec_32_3_32_128. simpl. rewrite !subword_make_vec_32_2_32_128. unfold wpshufd1. - rewrite subword_wshr. + rewrite subword_wshr; auto. simpl. rewrite !wxorA. f_equal. rewrite wxorC. rewrite !wxorA. f_equal. - rewrite subword_wshr. + rewrite subword_wshr; auto. rewrite addn0. f_equal. rewrite wror_substitute. @@ -991,68 +204,29 @@ Proof. Qed. Lemma key_expand_aux2 rkey temp2 : - subword 0 U32 temp2 = word0 -> - subword 0 U32 + word.subword 0 U32 temp2 = word.word0 -> + word.subword 0 U32 (lift2_vec U128 (wshufps_128 (wpack U8 2 [0; 3; 0; 2])) U128 (lift2_vec U128 (wshufps_128 (wpack U8 2 [0; 0; 1; 0])) U128 temp2 rkey) - (word.wxor rkey (lift2_vec U128 (wshufps_128 (wpack U8 2 [0; 0; 1; 0])) U128 temp2 rkey))) = word0. + (word.wxor rkey (lift2_vec U128 (wshufps_128 (wpack U8 2 [0; 0; 1; 0])) U128 temp2 rkey))) = word.word0. Proof. intros. - rewrite subword_0_32_128. simpl. + unfold lift2_vec. + rewrite !make_vec_ws. rewrite subword_make_vec_32_0_32_128. simpl. unfold wpshufd1. simpl. - rewrite subword_wshr. simpl. + rewrite subword_wshr; auto. simpl. rewrite addn0. rewrite subword_u. - rewrite subword_0_32_128. simpl. rewrite subword_make_vec_32_0_32_128. simpl. rewrite subword_u. unfold wpshufd1. simpl. - rewrite subword_wshr. - rewrite add0n. - assumption. - auto. auto. + rewrite subword_wshr; auto. Qed. -Lemma key_expandP' pre id0 rcon rkey temp2 rcon_ : - pdisj' pre id0 (JKEY_EXPAND_locs id0) fset0 → - toword rcon_ = rcon → - (forall s0 s1, pre (s0, s1) -> subword 0 U32 temp2 = word0) → - ⊢ ⦃ λ '(s0, s1), pre (s0, s1) ⦄ - JKEY_EXPAND id0 rcon rkey temp2 - ≈ ret tt - ⦃ λ '(v0, s0) '(v1, s1), - pre (s0, s1) ∧ - ∃ o1 o2, - v0 = [ ('word U128 ; o1) ; ('word U128 ; o2) ] ∧ - o1 = key_expand rkey rcon_ ∧ - subword 0 U32 o2 = word0 - ⦄. -Proof. - unfold JKEY_EXPAND, JKEY_EXPAND_locs. - unfold get_translated_static_fun. - simpl. - intros disj Hrcon Htemp2. - simpl_fun. - (* repeat setjvars. *) - time repeat clear_get. - unfold sopn_sem, tr_app_sopn_tuple, tr_app_sopn_single. - simpl. - rewrite !zero_extend_u. - rewrite !coerce_to_choice_type_K. - - repeat eapply r_put_lhs. - eapply r_ret. - intros s0 s1 Hpre. - destruct_pre; split_post. - - pdisj'_apply disj. - - eexists _, _. intuition auto. - + apply key_expand_aux. reflexivity. eapply Htemp2. eassumption. - + apply key_expand_aux2. eapply Htemp2. eassumption. -Qed. -Lemma key_expandP pre id0 rcon rkey temp2 rcon_ : +Lemma key_expand_E pre id0 rcon rkey temp2 rcon_ : pdisj pre id0 fset0 → - toword rcon_ = rcon → - (forall s0 s1, pre (s0, s1) -> subword 0 U32 temp2 = word0) → + word.toword rcon_ = rcon → + (forall s0 s1, pre (s0, s1) -> word.subword 0 U32 temp2 = word.word0) → ⊢ ⦃ λ '(s0, s1), pre (s0, s1) ⦄ JKEY_EXPAND id0 rcon rkey temp2 ≈ ret tt @@ -1061,689 +235,26 @@ Lemma key_expandP pre id0 rcon rkey temp2 rcon_ : ∃ o1 o2, v0 = [ ('word U128 ; o1) ; ('word U128 ; o2) ] ∧ o1 = key_expand rkey rcon_ ∧ - subword 0 U32 o2 = word0 + word.subword 0 U32 o2 = word.word0 ⦄. Proof. - unfold JKEY_EXPAND. - unfold get_translated_static_fun. + unfold JKEY_EXPAND, get_translated_static_fun. intros disj Hrcon Htemp2. - simpl_fun. + simpl_fun. simpl. repeat setjvars. repeat clear_get. unfold sopn_sem, tr_app_sopn_tuple, tr_app_sopn_single. simpl. rewrite !zero_extend_u. rewrite !coerce_to_choice_type_K. - repeat eapply r_put_lhs. eapply r_ret. intros s0 s1 Hpre. destruct_pre; split_post. - pdisj_apply disj. - eexists _, _. intuition auto. - + apply key_expand_aux. reflexivity. eapply Htemp2. eassumption. - + apply key_expand_aux2. eapply Htemp2. eassumption. -Qed. - -Definition getmd {T S} m d i := match @getm T S m i with Some a => a | _ => d end. - -Local Open Scope Z_scope. - -Fixpoint for_list (c : Z → raw_code 'unit) (vs : seq Z) : raw_code 'unit := - match vs with - | [::] => ret tt - | v :: vs => c v ;; for_list c vs - end. - -Definition for_loop' (c : Z -> raw_code 'unit) lo hi := for_list c (wrange UpTo lo hi). - -Definition to_oarr ws len (a : 'array) : (chMap (chFin len) ('word ws)) := - mkfmapf (fun (i : 'I_len) => chArray_get ws a i (wsize_size ws)) (ord_enum len). - -Definition to_arr ws len (a : 'array) := - mkfmapf (fun i => chArray_get ws a i (wsize_size ws)) (ziota 0 len). - -Lemma iota_aux {A} k c n (f : nat -> A) g : - (forall a, a \in (iota k n) -> f a = g (a + c)%nat) -> - [seq f i | i <- iota k n] = [seq g i | i <- iota (k + c) n]. -Proof. - revert k c. - induction n. - - reflexivity. - - intros k c ex. - simpl. rewrite -addSn. - rewrite <- IHn. - f_equal. - apply ex. - simpl. - rewrite in_cons. - apply/orP. left. apply/eqP. reflexivity. - intros a ain. apply ex. - simpl. rewrite in_cons. - apply/orP. right. assumption. -Qed. - -Lemma u_for_loop'_rule I c lo hi : - lo <= hi -> - (∀ i, (lo <= i < hi)%Z -> - ⊢ ⦃ λ '(s₀, s₁), I i s₀ s₁ ⦄ - c i ≈ ret tt - ⦃ λ '(_, s₀) '(_, s₁), I (Z.succ i) s₀ s₁ ⦄) → - ⊢ ⦃ λ '(s₀, s₁), I lo s₀ s₁ ⦄ - for_loop' c lo hi ≈ ret tt - ⦃ λ '(_,s₀) '(_,s₁), I hi s₀ s₁ ⦄. -Proof. - intros hle h. - remember (Z.to_nat (hi - lo)). - revert hle h Heqn. revert lo hi. - induction n as [| n ih]; intros. - - simpl. - assert (hi = lo). - { zify. lia. } - unfold for_loop'. - simpl. - rewrite -Heqn. - simpl. - subst. - apply r_ret. - easy. - - unfold for_loop'. - simpl. rewrite -Heqn. simpl. rewrite Z.add_0_r. - eapply r_bind with (m₁ := ret tt) (f₁ := fun _ => _). - + eapply h. lia. - + intros a1 a2. - destruct a1, a2. - replace [seq lo + Z.of_nat i | i <- iota 1 n] with [seq (Z.succ lo) + Z.of_nat i | i <- iota 0 n]. - replace n with (Z.to_nat (hi - Z.succ lo)). - eapply ih. - * lia. - * intros i hi2. apply h. lia. - * lia. - * lia. - * replace (iota 1 n) with (iota (0 + 1) n). apply iota_aux. - intros. lia. - f_equal. -Qed. - -Lemma for_loop'_ret I c lo hi : - lo <= hi -> - (∀ i, (lo <= i < hi)%Z -> - ⊢ ⦃ λ '(h0, h1), I i h0 h1 ⦄ - c i ≈ ret tt - ⦃ λ '(_, h0) '(_, h1), I (Z.succ i) h0 h1 ⦄) → - ⊢ ⦃ λ '(h0, h1), I lo h0 h1 ⦄ - for_loop' c lo hi ≈ ret tt - ⦃ λ '(_,h0) '(_,h1), I hi h0 h1 ⦄. -Proof. - intros hle h. - remember (Z.to_nat (hi - lo)). - revert hle h Heqn. revert lo hi. - induction n as [| n ih]; intros. - - simpl. - assert (hi = lo). - { zify. lia. } - unfold for_loop'. - simpl. - rewrite -Heqn. - simpl. - subst. - apply r_ret. - easy. - - unfold for_loop'. - simpl. rewrite -Heqn. simpl. rewrite Z.add_0_r. - eapply r_bind with (m₁ := ret tt) (f₁ := fun _ => _). - + eapply h. lia. - + intros a1 a2. - destruct a1, a2. - replace [seq lo + Z.of_nat i | i <- iota 1 n] with [seq (Z.succ lo) + Z.of_nat i | i <- iota 0 n]. - replace n with (Z.to_nat (hi - Z.succ lo)). - eapply ih. - * lia. - * intros i hi2. apply h. lia. - * lia. - * lia. - * replace (iota 1 n) with (iota (0 + 1) n). apply iota_aux. - intros. lia. - f_equal. -Qed. - -Lemma for_loop'_ret' (I : Z -> heap -> heap -> Prop) c lo hi (pre : precond): - lo <= hi -> - (forall h1 h2, pre (h1, h2) -> I lo h1 h2) -> - (∀ i, (lo <= i < hi)%Z -> - ⊢ ⦃ λ '(h0, h1), I i h0 h1 ⦄ - c i ≈ ret tt - ⦃ λ '(_, h0) '(_, h1), I (Z.succ i) h0 h1 ⦄) → - ⊢ ⦃ pre ⦄ - for_loop' c lo hi ≈ ret tt - ⦃ λ '(_,h0) '(_,h1), I hi h0 h1 ⦄. -Proof. - intros. - eapply rpre_weaken_rule. - eapply for_loop'_ret. - assumption. - assumption. - apply H0. -Qed. - -Lemma u_for_loop'_rule' (I : Z -> heap -> heap -> Prop) c lo hi (pre : precond) : - lo <= hi -> - (forall h1 h2, pre (h1, h2) -> I lo h1 h2) -> - (∀ i, (lo <= i < hi)%Z -> - ⊢ ⦃ λ '(s₀, s₁), I i s₀ s₁ ⦄ - c i ≈ ret tt - ⦃ λ '(_, s₀) '(_, s₁), I (Z.succ i) s₀ s₁ ⦄) → - ⊢ ⦃ pre ⦄ - for_loop' c lo hi ≈ ret tt - ⦃ λ '(_,s₀) '(_,s₁), I hi s₀ s₁ ⦄. -Proof. - intros. - eapply rpre_weaken_rule. - eapply u_for_loop'_rule. - assumption. - assumption. - apply H0. -Qed. - -Lemma for_loop'_rule I c₀ c₁ lo hi : - lo <= hi -> - (∀ i, (lo <= i < hi)%Z -> ⊢ ⦃ λ '(s₀, s₁), I i (s₀, s₁) ⦄ c₀ i ≈ c₁ i ⦃ λ '(_, s₀) '(_, s₁), I (Z.succ i) (s₀,s₁) ⦄) → - ⊢ ⦃ λ '(s₀, s₁), I lo (s₀, s₁) ⦄ - for_loop' c₀ lo hi ≈ for_loop' c₁ lo hi - ⦃ λ '(_,s₀) '(_,s₁), I hi (s₀,s₁) ⦄. -Proof. - intros hle h. - remember (Z.to_nat (hi - lo)). - revert hle h Heqn. revert lo hi. - induction n as [| n ih]; intros. - - simpl. - assert (hi = lo). - { zify. lia. } - unfold for_loop'. - simpl. - rewrite -Heqn. - simpl. - subst. - apply r_ret. - easy. - - unfold for_loop'. - simpl. rewrite -Heqn. simpl. rewrite Z.add_0_r. - eapply r_bind. - + eapply h. lia. - + intros a1 a2. - replace [seq lo + Z.of_nat i | i <- iota 1 n] with [seq (Z.succ lo) + Z.of_nat i | i <- iota 0 n]. - replace n with (Z.to_nat (hi - Z.succ lo)). - apply ih. - * lia. - * intros i hi2. apply h. lia. - * lia. - * lia. - * replace (iota 1 n) with (iota (0 + 1) n). apply iota_aux. - intros. lia. - f_equal. -Qed. - -Lemma translate_for_rule I lo hi (v : var_i) m_id s_id (body1 : p_id -> p_id * raw_code 'unit) body2 : - (* it is annoying that this is a proof obligation, since its true for all translated programs, but I don't know how to prove the theorem without it *) - (forall s_id', s_id' ⪯ (body1 s_id').1) -> - lo <= hi -> - (forall i s_id', (s_id ⪯ s_id') -> (lo <= i < hi) -> - ⊢ ⦃ λ '(s₀, s₁), set_lhs (translate_var m_id v) (truncate_el (vtype v) (i : chInt)) (I i) (s₀, s₁) ⦄ - let (_, body1') := body1 s_id' in - body1' - ≈ body2 i ⦃ λ '(_, s₀) '(_, s₁), I (Z.succ i) (s₀,s₁) ⦄) → - ⊢ ⦃ λ '(s₀,s₁), I lo (s₀, s₁)⦄ - translate_for v (wrange UpTo lo hi) m_id body1 s_id - ≈ for_loop' body2 lo hi - ⦃ λ '(_,s₀) '(_,s₁), I hi (s₀,s₁) ⦄. -Proof. - intros Hbody1 Hle ih. - remember (Z.to_nat (hi - lo)). - revert Heqn Hle ih. revert n lo hi s_id. - induction n as [|n ih2]; intros. - - assert (hi = lo). { zify. lia. } - subst. - unfold translate_for, for_loop'. simpl. - rewrite -Heqn. - simpl. - apply r_ret. - easy. - - unfold translate_for, for_loop'. - unfold wrange. - rewrite -Heqn. - simpl. - specialize (ih lo s_id) as ih''. - specialize (Hbody1 s_id). - destruct (body1 s_id). - eapply r_put_lhs. - eapply r_bind. - + eapply r_transL. - 2: rewrite Z.add_0_r; eapply ih''; [ reflexivity | lia ]. - eapply rreflexivity_rule. - + intros a0 a1. - replace (iota 1 n) with (iota (0 + 1) n) by f_equal. - rewrite <- iota_aux with (f := fun i => Z.succ lo + Z.of_nat i) by lia. - replace n with (Z.to_nat (hi - Z.succ lo)) by lia. - specialize (ih2 (Z.succ lo) hi p ltac:(lia) ltac:(lia)). - eapply ih2. - intros i s_id' Hs_id' ile. - specialize (ih i s_id'). - destruct (body1 s_id'). apply ih. - etransitivity. eassumption. assumption. - lia. -Qed. - -Lemma translate_for_rule_weaken (pre : precond) (I : Z -> heap * heap -> Prop) lo hi (v : var_i) m_id s_id (body1 : p_id -> p_id * raw_code 'unit) body2 : - (forall h0 h1, pre (h0, h1) -> I lo (h0, h1)) -> - (* it is annoying that this is a proof obligation, since its true for all translated programs, but I don't know how to prove the theorem without it *) - (forall s_id', s_id' ⪯ (body1 s_id').1) -> - lo <= hi -> - (forall i s_id', (s_id ⪯ s_id') -> (lo <= i < hi) -> - ⊢ ⦃ λ '(s₀, s₁), set_lhs (translate_var m_id v) (truncate_el (vtype v) (i : chInt)) (I i) (s₀, s₁) ⦄ - let (_, body1') := body1 s_id' in - body1' - ≈ body2 i ⦃ λ '(_, s₀) '(_, s₁), I (Z.succ i) (s₀,s₁) ⦄) → - ⊢ ⦃ pre ⦄ - translate_for v (wrange UpTo lo hi) m_id body1 s_id - ≈ for_loop' body2 lo hi - ⦃ λ '(_,s₀) '(_,s₁), I hi (s₀,s₁) ⦄. -Proof. - intros. - eapply rpre_weaken_rule. - eapply translate_for_rule. - all: easy. -Qed. - -Opaque translate_for. - -From Relational Require Import OrderEnrichedCategory - OrderEnrichedRelativeMonadExamples. -From Crypt Require Import Prelude Axioms ChoiceAsOrd. - -Theorem rpre_hypothesis_rule' : - ∀ {A₀ A₁ : ord_choiceType} {p₀ : raw_code A₀} {p₁ : raw_code A₁} - (pre : precond) post, - (∀ s₀ s₁, - pre (s₀, s₁) → ⊢ ⦃ λ '(s₀', s₁'), s₀' = s₀ ∧ s₁' = s₁ ⦄ p₀ ≈ p₁ ⦃ post ⦄ - ) → - ⊢ ⦃ pre ⦄ p₀ ≈ p₁ ⦃ post ⦄. -Proof. - intros A₀ A₁ p₀ p₁ pre post h. - eapply rpre_hypothesis_rule. - intros s0 s1 H. eapply rpre_weaken_rule. - eapply h. - eassumption. - easy. -Qed. - -Theorem rpre_weak_hypothesis_rule' : - ∀ {A₀ A₁ : ord_choiceType} {p₀ : raw_code A₀} {p₁ : raw_code A₁} - (pre : precond) post, - (∀ s₀ s₁, - pre (s₀, s₁) → ⊢ ⦃ λ '(s0, s1), pre (s0, s1) ⦄ p₀ ≈ p₁ ⦃ post ⦄ - ) → - ⊢ ⦃ pre ⦄ p₀ ≈ p₁ ⦃ post ⦄. -Proof. - intros A₀ A₁ p₀ p₁ pre post h. - eapply rpre_hypothesis_rule'. - intros. eapply rpre_weaken_rule. - eapply h. eassumption. - intros s0' s1' [H0 H1]. - subst. - assumption. -Qed. - -Lemma wsize_size_aux (ws : wsize.wsize) : - (ws %/ U8 + ws %% U8) = wsize_size ws. -Proof. destruct ws; reflexivity. Qed. - -Lemma encode_aux {ws} (w : word.word ws) : - LE.encode w = [seq subword ((Z.to_nat i0) * U8) U8 w | i0 <- ziota 0 (wsize_size ws)]. -Proof. - unfold LE.encode. - unfold split_vec. - unfold ziota. - rewrite -wsize_size_aux. - simpl. - rewrite Z2Nat.inj_add. - rewrite !Nat2Z.id. - rewrite -map_comp. - unfold comp. - apply map_ext. - intros a Ha. - rewrite Nat2Z.id. - reflexivity. - apply Zle_0_nat. - apply Zle_0_nat. -Qed. - -Lemma wsize_size_bits ws: - wsize_size ws < wsize_bits ws. -Proof. - unfold wsize_size, wsize_bits. - destruct ws; simpl; lia. -Qed. - -Lemma chArray_get_set_eq ws a i w : - (* (i * wsize_bits ws < wsize_size ws) -> *) - chArray_get ws (chArray_set a AAscale i w) i (wsize_size ws) = w. -Proof. - unfold chArray_get. - unfold chArray_set. - rewrite <- LE.decodeK. - f_equal. - rewrite encode_aux. - apply map_ext. - intros j Hj. - unfold chArray_get8. - rewrite chArray_write_get. - assert ((0 <=? i * wsize_size ws + j - i * mk_scale AAscale ws) && (i * wsize_size ws + j - i * mk_scale AAscale ws /InP. rewrite in_ziota=>/andP [] H1 h2. lia. - rewrite H. - unfold LE.wread8. - unfold LE.encode. - unfold split_vec. - unshelve erewrite nth_map. exact 0%nat. - simpl. - rewrite nth_iota. - simpl. - f_equal. - lia. - simpl. move: Hj=>/InP. rewrite in_ziota=>/andP [] H1 h2. - replace (ws %/ U8 + ws %% U8)%nat with (Z.to_nat (wsize_size ws)). lia. - destruct ws; simpl; reflexivity. - rewrite size_iota. - simpl. move: Hj=>/InP. rewrite in_ziota=>/andP [] H1 h2. - replace (ws %/ U8 + ws %% U8)%nat with (Z.to_nat (wsize_size ws)). lia. - destruct ws; simpl; reflexivity. -Qed. - -Lemma chArray_get_set_neq ws a i j (w : 'word ws) : - i <> j -> - chArray_get ws (chArray_set a AAscale i w) j (wsize_size ws) = chArray_get ws a j (wsize_size ws). -Proof. - intros H. - unfold chArray_get. - unfold chArray_set. - f_equal. - apply map_ext. - intros a0 Ha0. - unfold chArray_get8. - rewrite chArray_write_get. - assert ((0 <=? j * wsize_size ws + a0 - i * mk_scale AAscale ws) && (j * wsize_size ws + a0 - i * mk_scale AAscale ws /InP. rewrite in_ziota=>/andP [] H1 h2. - nia. - rewrite H0. - reflexivity. -Qed. - -Lemma getm_to_arr_None' ws len a (i: Z) : - ((len <=? i) || (i - to_arr ws len a i = None. -Proof. - intros. unfold to_arr. - rewrite mkfmapfE. -Admitted. (* figure out a proof that is less stupid than the one for getm_to_arr *) - -Lemma getm_to_oarr ws len a (i : 'I_(pos len)) : - to_oarr ws len a i = Some (chArray_get ws a i (wsize_size ws)). -Proof. - unfold to_oarr. - rewrite mkfmapfE. - rewrite mem_ord_enum. - reflexivity. -Qed. - -Lemma getm_to_arr ws len a i : - (0 <= i < len) -> - to_arr ws len a i = Some (chArray_get ws a i (wsize_size ws)). -Proof. - unfold to_arr. - rewrite mkfmapfE. - intros H. - (* this is a stupid proof and should be true by in_ziota, though for some reason the \in's resolve differently (one uses Z_eqType the other Z_ordType) *) - assert (is_true (@in_mem (Ord.sort Z_ordType) i (@ssrbool.mem (Equality.sort (Ord.eqType Z_ordType)) (seq_predType (Ord.eqType Z_ordType)) (ziota Z0 len)))). - { assert (0 <= len) by lia. move: H. move: (Z.le_refl 0). replace len with (0 + len) at 1 by (now rewrite Z.add_0_l). generalize 0 at 2 3 4 5. - change (∀ z : Z, 0 <= z -> z <= i < z + len → - (is_true (@in_mem (Ord.sort Z_ordType) i (@ssrbool.mem (Equality.sort (Ord.eqType Z_ordType)) (seq_predType (Ord.eqType Z_ordType)) (ziota z len)))) - ) with ((fun len => ((forall z, 0 <= z -> z <= i < z + len -> - (is_true (@in_mem (Ord.sort Z_ordType) i (@ssrbool.mem (Equality.sort (Ord.eqType Z_ordType)) (seq_predType (Ord.eqType Z_ordType)) (ziota z len)))) - ))) len). - apply natlike_ind. - - intros z Hz Hz2. lia. - - intros x Hx Ih z Hz Hz2. rewrite ziotaS_cons. - destruct (Z.eq_dec z i). - + rewrite in_cons. apply/orP. left. apply/eqP. easy. - + rewrite in_cons. apply/orP. right. apply Ih. lia. lia. - + lia. - - assumption. } - rewrite H0. - reflexivity. -Qed. - -Lemma to_oarr_set_eq ws len a (i : 'I_(pos len)) w : - (* (0 <= i < len) -> *) - (to_oarr ws len (chArray_set a AAscale i w)) i = Some w. -Proof. - rewrite getm_to_oarr. - rewrite chArray_get_set_eq. - reflexivity. -Qed. - -Lemma to_arr_set_eq ws len a i w : - (0 <= i < len) -> - (to_arr ws len (chArray_set a AAscale i w)) i = Some w. -Proof. - intros H. - rewrite getm_to_arr. - rewrite chArray_get_set_eq. - reflexivity. - assumption. -Qed. - -Lemma to_arr_set_neq' ws len a i j (w : 'word ws) : - (i <> j) -> - (0 <= j < len) -> - (to_arr ws len (chArray_set a AAscale i w)) j = Some (chArray_get ws a j (wsize_size ws)). -Proof. - intros Hneq H. - rewrite getm_to_arr. - rewrite chArray_get_set_neq. - reflexivity. - assumption. - assumption. -Qed. - -Lemma to_arr_set_neq ws len a i j (w : 'word ws) : - (i <> j) -> - (0 <= j < len) -> - (to_arr ws len (chArray_set a AAscale i w)) j = (to_arr ws len a) j. -Proof. - intros Hneq H. - rewrite !getm_to_arr. - rewrite chArray_get_set_neq. - reflexivity. - assumption. - assumption. - assumption. -Qed. - -(* TODO: move these, note they are the same as fresh1 and fresh2 *) -Lemma prec_O : - forall i, i ≺ i~0. -Proof. - simpl; split. - - apply preceq_O. - - apply nesym. apply xO_neq. -Qed. - -Lemma prec_I : - forall i, i ≺ i~1. -Proof. - simpl; split. - - apply preceq_I. - - apply nesym. apply xI_neq. -Qed. - -(* Notation " 'arr ws len " := (chMap (chFin len) ('word ws)) (at level 2) : package_scope. *) - -(* Definition rkeys : Location := ( (chMap (chFin (mkpos 11)) ('word U128)) ; 0%nat ). *) - -(* Definition keyExpansion (key : u128) : raw_code (chMap (chFin (mkpos 11)) ('word U128)):= *) -(* #put rkeys := @emptym (chElement_ordType (chFin (mkpos 11))) u128 ;; *) -(* rkeys0 ← get rkeys ;; *) -(* #put rkeys := setm rkeys0 (inord 0) key ;; *) -(* for_loop' (fun i => rkeys0 ← get rkeys ;; #put rkeys := setm rkeys0 (inord (Z.to_nat i)) (key_expand (zero_extend _ (getmd rkeys0 word0 (inord (Z.to_nat i - 1)))) (wrepr U8 (rcon i))) ;; ret tt) 1 11 ;; *) -(* rkeys0 ← get rkeys ;; *) -(* ret rkeys0. *) - -Notation " 'arr ws " := (chMap 'int ('word ws)) (at level 2) : package_scope. - -Definition rkeys : Location := ( 'arr U128 ; 0%nat ). - -Definition keyExpansion (key : u128) : raw_code ('arr U128) := - #put rkeys := @emptym (chElement_ordType 'int) u128 ;; - rkeys0 ← get rkeys ;; - #put rkeys := setm rkeys0 0 key ;; - for_loop' (fun i => - rkeys0 ← get rkeys ;; - #put rkeys := setm rkeys0 i (key_expand (zero_extend _ (getmd rkeys0 word0 (i - 1))) (rcon i)) ;; - ret tt) 1 11 ;; - rkeys0 ← get rkeys ;; - ret rkeys0. - -Definition key_i (k : u128) i := - iteri i (fun i ki => key_expand ki (rcon (i + 1))) k. - -From extructures Require Import ord. - -Lemma aes_keyExpansion_h (pre : precond) k : - u_pdisj pre [fset rkeys] -> - ⊢ ⦃ fun '(h0, h1) => pre (h0, h1) ⦄ - keyExpansion k - ≈ - ret tt - ⦃ fun '(v0, h0) '(_, h1) => pre (h0, h1) /\ forall i, 0 <= i < 11 -> (getmd v0 word0 i) = key_i k (Z.to_nat i) ⦄. -Proof. - intros Hdisj. - unfold keyExpansion. - eapply r_put_lhs with (pre := fun '(_, _) => _). - eapply r_get_remember_lhs. intros x. - eapply r_put_lhs. - eapply r_bind with (m₁ := ret _). - eapply for_loop'_ret' with - (I:= fun i => fun h0 h1 => pre (h0, h1) /\ forall j, 0 <= j < i -> getmd (get_heap h0 rkeys) word0 j = key_i k (Z.to_nat j)). - lia. - - intros h1 h2 Hset. - destruct_pre. - split_post. - + u_pdisj_apply Hdisj. - + intros j Hj. - unfold getmd. - sheap. - rewrite setmE. - assert (@eq_op (Ord.eqType Z_ordType) j Z0) by (apply/eqP; lia). - rewrite H. - move: H=>/eqP ->. - simpl. - reflexivity. - - intros i ile. - ssprove_code_simpl. - eapply r_get_remember_lhs with (pre := fun '(_, _) => _). intros x0. - eapply r_put_lhs. - eapply r_ret. - intros s0 s1 Hpre. - destruct_pre. split_post. - + u_pdisj_apply Hdisj. - + intros j Hj. - rewrite get_set_heap_eq. - rewrite -> H6 by lia. - unfold getmd in *. - rewrite setmE. - destruct (Z.eq_dec j i). - * subst. - rewrite eq_refl. - rewrite zero_extend_u. - replace (Z.to_nat i) with (Z.to_nat (i - 1)).+1 by lia. - unfold key_i at 2. - rewrite iteriS. - f_equal. f_equal. simpl. lia. - * assert (@eq_op (Ord.eqType Z_ordType) j i = false). - apply/eqP. assumption. - rewrite H1. - rewrite H6. - reflexivity. - lia. - - intros s0 s1. - eapply r_get_remember_lhs with (pre := fun '(_, _) => _). intros x0. - eapply r_ret. - intros s2 s3 Hpre. - destruct_pre. - split. - + easy. - + apply H2. -Qed. -(* hoare aes_keyExpansion_h k : *) -(* Aes.keyExpansion : key = k *) -(* ==> *) -(* forall i, 0 <= i < 11 => res.[i] = key_i k i. *) -(* proof. *) -(* proc. *) -(* while (1 <= round <= 11 /\ forall i, 0 <= i < round => rkeys.[i] = key_i k i). *) -(* + by auto => />; smt (key_iE iteriS get_setE). *) -(* by auto => />; smt(key_iE iteri0 get_setE). *) -(* qed. *) - -Lemma u_trans_det : - ∀ {A₀ A₁ : ord_choiceType} - (P P0 P1 : precond) - (Q : A₀ -> A₁ -> Prop) (Q0 : A₀ -> Prop) (Q1 : A₁ -> Prop) - (c₀ : raw_code A₀) (c₁ : raw_code A₁), - (forall h0 h1, P (h0, h1) -> P0 (h0, h1)) -> - (forall h0 h1, P1 (h1, h0) -> P (h0, h1)) -> - (forall v0 v1, Q v0 v1 -> Q0 v0 -> Q1 v1) -> - deterministic c₀ → - deterministic c₁ → - ⊢ ⦃ λ '(h₀, h₁), P (h₀, h₁) ⦄ c₀ ≈ c₁ ⦃ λ '(v₀, _) '(v₁, _), Q v₀ v₁ ⦄ → - ⊢ ⦃ λ '(h₀, h₁), P0 (h₀, h₁) ⦄ c₀ ≈ ret tt ⦃ λ '(v₀, _) '(_ , _), Q0 v₀ ⦄ -> - ⊢ ⦃ λ '(h₀, h₁), P1 (h₀, h₁) ⦄ c₁ ≈ ret tt ⦃ λ '(v₀, _) '(_ , _), Q1 v₀ ⦄. -Proof. - intros A₀ A₁ P P0 P1 Q Q0 Q1 c0 c1 HP0 HP1 HQ Hd0 Hd1 Hc Hc0. - unshelve eapply det_to_sem. assumption. constructor. - unshelve eapply sem_to_det in Hc. 1,2: assumption. - unshelve eapply sem_to_det in Hc0. assumption. constructor. - intros s₀ s₁ hP1. eapply HP1 in hP1 as HP. eapply HP0 in HP as hP0. - specialize (Hc s₁ s₀ HP). specialize (Hc0 s₁ s₀ hP0). - destruct (det_run c0 _). - destruct (det_run c1 _). - simpl in *. - eapply HQ. eassumption. eassumption. -Qed. - -Lemma u_trans_det' : - ∀ {A₀ A₁ : ord_choiceType} - (P P0 P1 : precond) - (Q : A₁ -> A₀ -> Prop) (Q0 : A₀ -> Prop) (Q1 : A₁ -> Prop) - (c₀ : raw_code A₀) (c₁ : raw_code A₁), - (forall h0 h1, P (h1, h0) -> P0 (h0, h1)) -> - (forall h0 h1, P1 (h1, h0) -> P (h1, h0)) -> - (forall v1 v0, Q v1 v0 -> Q0 v0 -> Q1 v1) -> - deterministic c₀ → - deterministic c₁ → - ⊢ ⦃ λ '(h₀, h₁), P (h₀, h₁) ⦄ c₁ ≈ c₀ ⦃ λ '(v₀, _) '(v₁, _), Q v₀ v₁ ⦄ → - ⊢ ⦃ λ '(h₀, h₁), P0 (h₀, h₁) ⦄ c₀ ≈ ret tt ⦃ λ '(v₀, _) '(_ , _), Q0 v₀ ⦄ -> - ⊢ ⦃ λ '(h₀, h₁), P1 (h₀, h₁) ⦄ c₁ ≈ ret tt ⦃ λ '(v₀, _) '(_ , _), Q1 v₀ ⦄. -Proof. - intros A₀ A₁ P P0 P1 Q Q0 Q1 c0 c1 HP0 HP1 HQ Hd0 Hd1 Hc Hc0. - unshelve eapply det_to_sem. assumption. constructor. - unshelve eapply sem_to_det in Hc. 1,2: assumption. - unshelve eapply sem_to_det in Hc0. assumption. constructor. - intros s₀ s₁ hP1. eapply HP1 in hP1 as HP. eapply HP0 in HP as hP0. - specialize (Hc s₀ s₁ HP). specialize (Hc0 s₁ s₀ hP0). - destruct (det_run c0 _). - destruct (det_run c1 _). - simpl in *. - eapply HQ. eassumption. eassumption. + + apply key_expand_aux; eauto. + + apply key_expand_aux2; eauto. Qed. Lemma keyExpansion_E pre id0 rkey : @@ -1755,15 +266,10 @@ Lemma keyExpansion_E pre id0 rkey : ⦃ fun '(v0, h0) '(v1, h1) => pre (h0, h1) /\ exists o, v0 = [( 'array ; o)] /\ to_arr U128 (mkpos 11) o = v1 ⦄. Proof. intros disj. - - unfold JKEYS_EXPAND. - unfold get_translated_static_fun. - unfold translate_prog_static. - unfold translate_funs_static. - unfold translate_call_body. + unfold JKEYS_EXPAND, get_translated_static_fun, translate_prog_static, translate_funs_static, translate_call_body. Opaque translate_call. Opaque wrange. - Opaque for_loop'. + Opaque for_loop. simpl. simpl_fun. repeat setjvars. @@ -1786,10 +292,10 @@ Proof. eapply rpre_weaken_rule. + eapply translate_for_rule with (I := fun i => fun '(h0, h1) => pre (h0, h1) - /\ subword 0 U32 (get_heap h0 temp2) = word0 + /\ word.subword 0 U32 (get_heap h0 temp2) = word.word0 /\ (get_heap h0 key = chArray_get U128 (get_heap h0 rkeys) (i - 1) 16) - /\ (forall j, (0 <= j < i) -> (to_arr U128 (mkpos 11) (get_heap h0 rkeys)) j = (get_heap h1 aes.rkeys) j) - /\ (forall j, (j < 0) \/ (11 <= j) -> get_heap h1 aes.rkeys j = None)). + /\ (forall j, (0 <= j < i) -> (to_arr U128 (mkpos 11) (get_heap h0 rkeys)) j = (get_heap h1 aes_spec.rkeys) j) + /\ (forall j, (j < 0) \/ (11 <= j) -> get_heap h1 aes_spec.rkeys j = None)). (* the two following bullets are small assumptions of the translate_for rule *) * intros. simpl. solve_preceq. @@ -1802,25 +308,25 @@ Proof. (* Now we apply the correctnes of rcon *) eapply r_bind with (m₁ := ret _) (f₁ := fun _ => _). - ** eapply rcon_correct with (id0 := (s_id~1)%positive) (i:=x). + ** eapply rcon_E with (id0 := (s_id~1)%positive) (i:=x). (* We have to prove the precond is disjoint from the variables of rcon, i.e. any variables stored locally in rcon does not change the precond *) *** split. (* rcon_correct does not use any variables on the rhs *) 2: { easy. } intros s0 s1 l a vr s_id' Hl Hs_id' H. assert (id0_preceq : id0 ⪯ s_id'). { - etransitivity. eapply preceq_I. etransitivity. eassumption. etransitivity. eapply preceq_I. eassumption. + etransitivity. 1: eapply preceq_I. etransitivity. 1: eassumption. etransitivity. 1: eapply preceq_I. eassumption. } assert (id0_neq : id0 <> s_id'). { - apply prec_neq. eapply prec_preceq_trans. eapply preceq_prec_trans. etransitivity. eapply preceq_I. eassumption. eapply prec_I. assumption. + apply prec_neq. eapply prec_preceq_trans. 1: eapply preceq_prec_trans. 1: etransitivity. 1: eapply preceq_I. 1: eassumption. 1: eapply prec_I. assumption. } intros. destruct_pre. split_post. - { eapply disj. reflexivity. eassumption. eassumption. } + { eapply disj; eauto. } { sheap. assumption. } { sheap. assumption. } { sheap. assumption. } { assumption. } - { rewrite set_heap_commut. reflexivity. + { rewrite set_heap_commut; auto. apply injective_translate_var2. assumption. } { simpl. sheap. reflexivity. } (* this is an assumption of rcon_correct *) @@ -1829,7 +335,7 @@ Proof. ** intros a0 a1. simpl; ssprove_code_simpl. (* we need to know the value of a0 here *) - eapply rpre_weak_hypothesis_rule'; intros. + eapply rpre_weak_hypothesis_rule; intros. destruct_pre; simpl. fold rcon. repeat clear_get. @@ -1843,20 +349,20 @@ Proof. (* First we apply correctness of key_expandP *) *** (* Here the rewrite is necessary. How should correctness be phrased in general such that this is not important? *) rewrite !coerce_to_choice_type_K. - eapply key_expandP with (id0 := (s_id~0~1)%positive) (rcon := (wunsigned (aes.rcon i))) (rkey := x1) (temp2 := x2) (rcon_ := aes.rcon i). + eapply key_expand_E with (id0 := (s_id~0~1)%positive) (rcon := (wunsigned (aes_spec.rcon i))) (rkey := x1) (temp2 := x2) (rcon_ := aes_spec.rcon i). (* again, we have to prove that our precond does not depend key_expand locations *) { split. (* key_expandP also does not use variables on the rhs *) 2: { easy. } intros s0 s1 l a vr s_id' Hl Hs_id' H1. assert (id0_preceq : id0 ⪯ s_id'). { - etransitivity. eapply preceq_I. etransitivity. eassumption. etransitivity. eapply preceq_O. etransitivity. eapply preceq_I. eassumption. + etransitivity. 1: eapply preceq_I. etransitivity. 1: eassumption. etransitivity. 1: eapply preceq_O. etransitivity. 1: eapply preceq_I. eassumption. } assert (id0_neq : id0 <> s_id'). { - apply prec_neq. eapply prec_preceq_trans. eapply preceq_prec_trans. etransitivity. eapply preceq_I. eassumption. eapply prec_O. etransitivity. eapply prec_I. assumption. + apply prec_neq. eapply prec_preceq_trans. 1: eapply preceq_prec_trans. 1: etransitivity. 1: eapply preceq_I. 1: eassumption. 1: eapply prec_O. etransitivity. 1: eapply prec_I. assumption. } destruct_pre. sheap. split_post. - { eapply disj. reflexivity. eassumption. eassumption. } + { eapply disj; eauto. } { sheap; assumption. } { sheap; assumption. } { sheap; assumption. } @@ -1875,7 +381,7 @@ Proof. { intros. destruct_pre. sheap. assumption. } (* we continue after the call *) *** intros. - eapply rpre_weak_hypothesis_rule'. + eapply rpre_weak_hypothesis_rule. intros; destruct_pre. simpl. rewrite !zero_extend_u. @@ -1908,27 +414,26 @@ Proof. destruct (Z.eq_dec i j). (* i = j *) - subst. simpl. - pose proof to_arr_set_eq. - simpl. - rewrite to_arr_set_eq. - rewrite setmE. rewrite eq_refl. + - subst. simpl. + pose proof to_arr_set_eq. + simpl. + rewrite to_arr_set_eq. 2: lia. + rewrite setmE. rewrite eq_refl. - f_equal. unfold getmd. rewrite -H41. rewrite getm_to_arr. - f_equal. rewrite !get_set_heap_neq in H33. rewrite -H33. assumption. - neq_loc_auto. neq_loc_auto. lia. lia. lia. + f_equal. unfold getmd. rewrite -H41. 2: lia. rewrite getm_to_arr. 2: lia. + f_equal. rewrite !get_set_heap_neq in H33. 2-3: neq_loc_auto. rewrite -H33. assumption. (* i <> j *) - rewrite to_arr_set_neq. - rewrite setmE. - assert (@eq bool (@eq_op Z_ordType j i) false). apply/eqP. auto. - rewrite H3. - apply H41. lia. assumption. lia. } + - rewrite to_arr_set_neq. 2-3: lia. + rewrite setmE. + assert (@eq bool (@eq_op Z_ordType j i) false). 1: apply/eqP; auto. + rewrite H3. + apply H41. lia. } { intros j Hj. rewrite setmE. (* why do I have to set printing off to realize this? Shouldn't j == i always mean the same on the same type? *) - assert (@eq_op (Ord.eqType Z_ordType) j i = false). apply/eqP. lia. + assert (@eq_op (Ord.eqType Z_ordType) j i = false). 1: apply/eqP; lia. rewrite H3. apply H43. assumption. } @@ -1949,11 +454,11 @@ Proof. * rewrite chArray_get_set_eq. reflexivity. (* third invariant *) * intros j Hj. assert (j = 0) by lia. subst. - rewrite to_arr_set_eq. rewrite setmE. rewrite eq_refl. reflexivity. lia. + rewrite to_arr_set_eq. 1: rewrite setmE; rewrite eq_refl; reflexivity. lia. * intros. rewrite setmE. (* Set Printing All. *) replace (_ == _) with false. - apply emptymE. symmetry. apply/eqP. lia. + 1: apply emptymE. symmetry. apply/eqP. lia. (* after for loop *) - intros a0 a1. simpl. @@ -1971,157 +476,10 @@ Proof. (* within bounds, this follows from the precondition *) * rewrite !coerce_to_choice_type_K. apply H4. lia. * rewrite -> getm_to_arr_None' by lia. - rewrite H6. reflexivity. + rewrite H6; auto. lia. Qed. -(* without the pre in the post, try to remove this and generalize lemmas instead *) -Lemma keyExpansion_E' pre id0 rkey : - (pdisj pre id0 [fset rkeys]) -> - ⊢ ⦃ fun '(h0, h1) => pre (h0, h1) ⦄ - JKEYS_EXPAND id0 rkey - ≈ - keyExpansion rkey - ⦃ fun '(v0, _) '(v1, _) => (to_arr U128 (mkpos 11) (hdtcA v0)) = v1 ⦄. -Proof. - intros. - eapply rpost_weaken_rule. - eapply keyExpansion_E. - assumption. - intros. - destruct a₀, a₁. - destruct_pre. - rewrite coerce_to_choice_type_K. - simpl. - easy. -Qed. - -(* maybe extend this to also preserve a precond, to do this prove a similar `u_trans_det` *) -Lemma keys_expand_jazz_correct pre id0 rkey : - (pdisj pre id0 [fset rkeys]) -> - ⊢ ⦃ fun '(h0, h1) => pre (h0, h1) ⦄ - JKEYS_EXPAND id0 rkey - ≈ - ret tt - ⦃ fun '(v0, _) '(_, _) => forall i, 0 <= i < 11 -> getmd (to_arr U128 (mkpos 11) (hdtcA v0)) word0 i = key_i rkey (Z.to_nat i) ⦄. -Proof. -(* intros h. *) -(* eapply u_trans_det' with (P0 := fun '(_, _) => _) (P1 := fun '(_, _) => _). *) -(* 7: { eapply aes_keyExpansion_h. } *) -(* 6: { eapply keyExpansion_E'. eassumption. } *) -(* - easy. *) -(* - easy. *) -(* - intros. simpl in *. rewrite H. apply H0. assumption. *) -(* - unfold keyExpansion. *) -(* repeat constructor. *) -(* - admit. (* TODO: figure out how to do this *) *) -Admitted. - -Definition aes (key msg : u128) := - let state := wxor msg (key_i key 0) in - let state := iteri 9 (fun i state => wAESENC_ state (key_i key (i + 1))) state in - wAESENCLAST_ state (key_i key 10). - -Definition invaes (key cipher : u128) := - let state := wxor cipher (key_i key 10) in - let state := iteri 9 (fun i state => wAESDEC_ state (key_i key (10 -(i + 1)))) state in - wAESDECLAST state (key_i key 0). - -(* Definition rkeys : Location := () *) -(* Definition (rkeys : chMap 'int ('word U128)) (msg : 'word U128) := *) -Definition state : Location := ( 'word U128 ; 0%nat). - -Definition aes_rounds (rkeys : 'arr U128) (msg : 'word U128) : raw_code u128 := - #put state := wxor msg (getmd rkeys word0 0) ;; - for_loop' (fun i => - state0 ← get state ;; - #put state := wAESENC_ state0 (getmd rkeys word0 i) ;; - ret tt - ) 1 10 ;; - state0 ← get state ;; - #put state := wAESENCLAST_ state0 (getmd rkeys word0 10) ;; - state0 ← get state ;; - ret state0. - -Lemma aes_rounds_h rkeys k m pre : - u_pdisj pre [fset state] -> - ⊢ ⦃ fun '(h0, h1) => pre (h0, h1) /\ (forall i, 0 <= i < 11 -> getmd rkeys word0 i = key_i k (Z.to_nat i)) ⦄ - aes_rounds rkeys m - ≈ - ret tt - ⦃ fun '(v0, h0) '(_, h1) => pre (h0, h1) /\ v0 = aes k m ⦄. -Proof. - unfold aes_rounds. - intros Hdisj. - eapply r_put_lhs with (pre := fun '(_, _) => _). - eapply r_bind with (m₁ := ret _). - set (st0 := m ⊕ (key_i k 0%nat)). - eapply u_for_loop'_rule' with - (I := fun i => fun h0 h1 => pre (h0, h1) /\ get_heap h0 state = iteri (Z.to_nat i - 1) (fun i state => wAESENC_ state (key_i k (i + 1))) st0 - /\ (forall i, 0 <= i < 11 -> getmd rkeys word0 i = key_i k (Z.to_nat i))). - - lia. - - intros. - simpl. - destruct_pre. sheap. split_post. - + u_pdisj_apply Hdisj. - + rewrite H3. reflexivity. lia. - + assumption. - - intros i Hi. - eapply r_get_remember_lhs with (pre := fun '(_, _) => _). intros x. - eapply r_put_lhs. eapply r_ret. - intros s0 s1 Hpre. - destruct_pre; sheap; split_post. - + u_pdisj_apply Hdisj. - + replace (Z.to_nat (Z.succ i) - 1)%nat with ((Z.to_nat i - 1).+1) by lia. - rewrite iteriS. - rewrite H4. - rewrite H7. repeat f_equal. lia. lia. - + assumption. - - intros a0 a1. - eapply r_get_remember_lhs with (pre := fun '(_, _) => _). intros x. - eapply r_put_lhs. - eapply r_get_remember_lhs. intros x0. - eapply r_ret. - intros s0 s1 Hpre. - destruct Hpre as [[s2 [[[H5 [H4 H6]] H3] H2]] H1]. - simpl in H3, H1. subst. - sheap. - split; [u_pdisj_apply Hdisj|]. - unfold aes. - rewrite H4. - rewrite H6. - replace ((Z.to_nat 10) - 1)%nat with 9%nat by reflexivity. - reflexivity. lia. -Qed. - -Notation hdtc128 res := (coerce_to_choice_type ('word U128) (hd ('word U128 ; chCanonical _) res).π2). - -Lemma getmd_to_arr a ws len x i : - (0 <= i < len) -> - getmd (to_arr ws len a) x i = chArray_get ws a i (wsize_size ws). -Proof. - intros. - unfold getmd. - rewrite getm_to_arr. - reflexivity. - assumption. -Qed. - -(* NOTE: This is only so simple because InvMixColumns is not properly implemented *) -Lemma AESDEC_AESDEC_ s k : wAESDEC s (InvMixColumns k) = wAESDEC_ s k. -Proof. - unfold wAESDEC, wAESDEC_. - unfold InvMixColumns. - reflexivity. -Qed. - -Lemma wAESENCLAST_wAESENCLAST_ s k : wAESENCLAST s k = wAESENCLAST_ s k. -Proof. - unfold wAESENCLAST, wAESENCLAST_. - rewrite ShiftRows_SubBytes. - reflexivity. -Qed. - Lemma aes_rounds_E pre id0 rkeys msg : (pdisj pre id0 [fset state]) -> ⊢ ⦃ fun '(h0, h1) => pre (h0, h1) ⦄ @@ -2130,16 +488,12 @@ Lemma aes_rounds_E pre id0 rkeys msg : aes_rounds (to_arr U128 (mkpos 11) rkeys) msg ⦃ fun '(v0, h0) '(v1, h1) => pre (h0, h1) /\ exists o, v0 = [ ('word U128 ; o) ] /\ o = v1 ⦄. Proof. - unfold JAES_ROUNDS. - unfold get_translated_static_fun. - unfold translate_prog_static. - unfold translate_funs_static. - unfold translate_call_body. + unfold JAES_ROUNDS, get_translated_static_fun, translate_prog_static, translate_funs_static, translate_call_body. intros disj. Opaque translate_call. Opaque wrange. - Opaque for_loop'. + Opaque for_loop. simpl. simpl_fun. repeat setjvars. @@ -2154,7 +508,7 @@ Proof. eapply r_bind. - eapply translate_for_rule_weaken with (I := fun i => fun '(h0, h1) => pre (h0, h1) - /\ get_heap h0 state = get_heap h1 aes.state + /\ get_heap h0 state = get_heap h1 aes_spec.state /\ get_heap h0 rkeys0 = rkeys). + intros; destruct_pre. rewrite !zero_extend_u. @@ -2162,7 +516,7 @@ Proof. sheap. split_post. * pdisj_apply disj. - * rewrite getmd_to_arr. reflexivity. lia. + * rewrite getmd_to_arr; auto. lia. * reflexivity. + intros. simpl. auto with preceq. + lia. @@ -2182,8 +536,8 @@ Proof. * pdisj_apply disj. * rewrite -> H12. rewrite wAESENC_wAESENC_. - rewrite getmd_to_arr. - reflexivity. lia. + rewrite getmd_to_arr; auto. + lia. * reflexivity. - intros a0 a. eapply r_get_remember_lhs with (pre := fun '(_, _) => _). intros x. @@ -2206,56 +560,15 @@ Proof. simpl. rewrite !zero_extend_u. rewrite -> H6. - rewrite getmd_to_arr. + rewrite getmd_to_arr; try lia. rewrite wAESENCLAST_wAESENCLAST_. eexists. split. - 1: reflexivity. - simpl. - rewrite zero_extend_u. - reflexivity. - lia. + * reflexivity. + * simpl. + rewrite zero_extend_u. + reflexivity. Qed. -Definition Caes (key msg : u128) := - rkeys ← keyExpansion key ;; - cipher ← aes_rounds rkeys msg ;; - ret cipher. - -Definition Cenc_locs := [:: state ; rkeys]. - -Lemma aes_h k m pre : - (* (forall i, (0 <= i < 11)%nat -> rkeys i = Some (key_i k i)) -> *) - (u_pdisj pre [fset state ; rkeys]) -> - ⊢ ⦃ fun '(h0, h1) => pre (h0, h1) ⦄ - Caes k m - ≈ - ret tt - ⦃ fun '(v0, h0) '(_, h1) => pre (h0, h1) /\ v0 = aes k m ⦄. -Proof. - unfold Caes. - intros Hdisj. - eapply r_bind with (m₁ := ret _). - - eapply aes_keyExpansion_h. - u_pdisj_apply Hdisj. - intros h1 h2 l a lin Hpre. - eapply Hdisj. - admit. - assumption. - - intros a0 []. - eapply r_bind with (m₁ := ret _). - eapply aes_rounds_h. - - intros h1 h2 l a lin Hpre. - eapply Hdisj. - admit. - assumption. - - intros a1 []. - eapply r_ret. - intros. - assumption. -Admitted. - Lemma aes_E pre id0 k m : (pdisj pre id0 [fset rkeys ; state]) -> ⊢ ⦃ fun '(h0, h1) => pre (h0, h1) ⦄ @@ -2264,11 +577,7 @@ Lemma aes_E pre id0 k m : Caes k m ⦃ fun '(v0, h0) '(v1, h1) => pre (h0, h1) /\ exists o, v0 = [ ('word U128 ; o )] /\ v1 = o ⦄. Proof. - unfold JAES. - unfold get_translated_static_fun. - unfold translate_prog_static. - unfold translate_funs_static. - unfold translate_call_body. + unfold JAES, get_translated_static_fun, translate_prog_static, translate_funs_static, translate_call_body. intros disj. simpl. simpl_fun. @@ -2285,16 +594,16 @@ Proof. split. + intros s0 s1 l a vr s_id' Hl Hs_id' H. assert (id0_preceq : id0 ⪯ s_id'). { - etransitivity. eapply preceq_I. eassumption. + etransitivity. 1: eapply preceq_I. eassumption. } assert (id0_neq : id0 <> s_id'). { - apply prec_neq. eapply prec_preceq_trans. eapply prec_I. eassumption. + apply prec_neq. eapply prec_preceq_trans. 1: eapply prec_I. eassumption. } destruct_pre. split_post. - * eapply disj. reflexivity. eassumption. eassumption. + * eapply disj; eauto. * reflexivity. - * rewrite set_heap_commut. rewrite [set_heap (set_heap H2 _ _) _ _]set_heap_commut. reflexivity. - neq_loc_auto. neq_loc_auto. + * rewrite set_heap_commut. 2: neq_loc_auto. rewrite [set_heap (set_heap H2 _ _) _ _]set_heap_commut. 1: reflexivity. + neq_loc_auto. + intros; destruct_pre; split_post. * eapply disj. ** move: H. rewrite in_fset in_cons=>/orP [];[|easy] => /eqP ->. solve_in. @@ -2302,7 +611,7 @@ Proof. * reflexivity. * reflexivity. - intros. - eapply rpre_weak_hypothesis_rule'. + eapply rpre_weak_hypothesis_rule. Opaque aes_rounds. intros; destruct_pre. simpl. @@ -2311,33 +620,33 @@ Proof. eapply r_put_lhs with (pre := fun _ => _). eapply r_get_remember_lhs. intros. - (* this is a very brute force way of remembering the walu of 'in', should be done differently *) - eapply rpre_weak_hypothesis_rule'. + (* this is a very brute force way of remembering the value of 'in', should be done differently *) + eapply rpre_weak_hypothesis_rule. intros; destruct_pre. sheap. eapply r_bind. + eapply aes_rounds_E. split. * intros s0 s1 l a vr s_id' Hl Hs_id' H. assert (id0_preceq : id0 ⪯ s_id'). { - etransitivity. eapply preceq_O. etransitivity. eapply preceq_I. eassumption. + etransitivity. 1: eapply preceq_O. etransitivity. 1: eapply preceq_I. eassumption. } assert (id0_neq : id0 <> s_id'). { - apply prec_neq. eapply prec_preceq_trans. etransitivity. eapply prec_O. eapply prec_I. eassumption. + apply prec_neq. eapply prec_preceq_trans. 1: etransitivity. 1: eapply prec_O. 1: eapply prec_I. eassumption. } destruct_pre. sheap. split_post. - ** eapply disj. reflexivity. eassumption. eassumption. + ** eapply disj; eauto. ** reflexivity. ** reflexivity. ** eexists. eauto. ** rewrite set_heap_commut. - rewrite [set_heap (set_heap _ _ _) _ a]set_heap_commut. - rewrite [set_heap (set_heap _ _ _) _ a]set_heap_commut. - reflexivity. + 1: rewrite [set_heap (set_heap _ _ _) _ a]set_heap_commut. + 1: rewrite [set_heap (set_heap _ _ _) _ a]set_heap_commut. + 1: reflexivity. all: neq_loc_auto. ** simpl. sheap. reflexivity. * intros; destruct_pre; split_post. ** eapply disj. - *** move: H. rewrite in_fset in_cons=>/orP []. move=> /eqP ->. solve_in. + *** move: H. rewrite in_fset in_cons=>/orP []. 1: move=> /eqP ->; solve_in. simpl. clear -l. easy. *** eassumption. ** reflexivity. @@ -2346,8 +655,7 @@ Proof. ** reflexivity. ** simpl. sheap. reflexivity. + intros. - - eapply rpre_weak_hypothesis_rule'. + eapply rpre_weak_hypothesis_rule. intros; destruct_pre. simpl. fold out. clear_get. eapply r_put_lhs with (pre := fun _ => _). diff --git a/theories/Jasmin/examples/aes/aes_prf.v b/theories/Jasmin/examples/aes/aes_prf.v new file mode 100644 index 00000000..22f4aef7 --- /dev/null +++ b/theories/Jasmin/examples/aes/aes_prf.v @@ -0,0 +1,696 @@ +(** PRF Example + + Inspired by "State Separation for Code-Based Game-Playing Proofs" + by Brzuska et al. + + Appendix A. + + "Given a pseudorandom function (PRF) we construct a symmetric encryption + scheme that is indistinguishable under chosen plaintext attacks (IND-CPA)." + +*) +From JasminSSProve Require Import jasmin_translate aes_valid aes_spec aes.aes word aes_utils. + +From Relational Require Import OrderEnrichedCategory GenericRulesSimple. + +Set Warnings "-notation-overridden,-ambiguous-paths". +From mathcomp Require Import all_ssreflect all_algebra reals distr realsum + ssrnat ssreflect ssrfun ssrbool ssrnum eqtype choice seq word word.ssrZ. +Set Warnings "notation-overridden,ambiguous-paths". + +From Mon Require Import SPropBase. +From Crypt Require Import Axioms ChoiceAsOrd SubDistr Couplings + UniformDistrLemmas FreeProbProg Theta_dens RulesStateProb + pkg_core_definition choice_type pkg_composition pkg_rhl Package Prelude. + +From Coq Require Import Utf8. +From extructures Require Import ord fset fmap. + +Import SPropNotations. + +Import PackageNotation. + +From Equations Require Import Equations. +Require Equations.Prop.DepElim. + +Set Equations With UIP. + +Set Bullet Behavior "Strict Subproofs". +Set Default Goal Selector "!". +Set Primitive Projections. + +Import Num.Def. +Import Num.Theory. +Import Order.POrderTheory. + +From Jasmin Require Import word. + +Section PRF_example. + + Context (n : wsize). + + Notation key := 'word n. + Notation pt := 'word n. + Notation ct := 'word n. + + Notation " 'word " := ('word n) (in custom pack_type at level 2). + Notation " 'key " := ('word n) (in custom pack_type at level 2). + + Context (f : key -> pt -> ct). + + Notation N := ((expn 2 n).-1.+1). + + #[export] Instance : Positive N. + Proof. red; by rewrite prednK_modulus expn_gt0. Qed. + + #[export] Instance word_pos (i : wsize.wsize) : Positive i. + Proof. by case i. Qed. + + #[local] Open Scope package_scope. + + Definition key_location : Location := ('option key ; 0). + Definition plain_location : Location := ( pt ; 1). + Definition cipher_location : Location := ( ct ; 2). + Definition i0 : nat := 3. + Definition i1 : nat := 4. + Definition i2 : nat := 5. + Definition salt_location : Location := ('nat ; 6). + Definition table_location : Location := + (chMap 'nat ('word n) ; 7). + + Definition rel_loc : {fset Location} := + fset [:: key_location ; table_location ]. + + Definition enc (m : pt) (k : key) : + code fset0 [interface] ('word n) := + {code + r ← sample uniform N ;; + let pad := f (word_of_ord r) k in + let c := m ⊕ pad in + ret c + }. + + Definition kgen : code (fset [:: key_location]) [interface] 'word n := + {code + k ← get key_location ;; + match k with + | None => + k_val ← sample uniform N ;; + #put key_location := Some (word_of_ord k_val) ;; + ret (word_of_ord k_val) + | Some k_val => + ret k_val + end + }. + + Definition dec (c : 'word n) (k : 'word n) : + code fset0 [interface] ('word n) := + enc k c. + + Definition EVAL_location_tt := (fset [:: key_location]). + Definition EVAL_location_ff := (fset [:: table_location]). + + Definition EVAL_pkg_tt : + package EVAL_location_tt [interface] + [interface #val #[i0] : 'word → 'key ] := + [package + #def #[i0] (r : 'word) : 'key + { + k_val ← kgen ;; + ret (f r k_val) + } + ]. + + Definition EVAL_pkg_ff : + package EVAL_location_ff [interface] + [interface #val #[i0] : 'word → 'key ] := + [package + #def #[i0] (r : 'word) : 'key + { + T ← get table_location ;; + match getm T (ord_of_word r) with + | None => + T_key ← sample uniform N ;; + #put table_location := (setm T (ord_of_word r) (word_of_ord T_key)) ;; + ret (word_of_ord T_key) + | Some T_key => ret T_key + end + } + ]. + + Definition EVAL : loc_GamePair [interface #val #[i0] : 'word → 'key ] := + λ b, if b then {locpackage EVAL_pkg_tt } else {locpackage EVAL_pkg_ff }. + + Definition MOD_CPA_location : {fset Location} := fset0. + + Definition MOD_CPA_tt_pkg : + package MOD_CPA_location + [interface #val #[i0] : 'word → 'key ] + [interface #val #[i1] : 'word → 'word ] := + [package + #def #[i1] (m : 'word) : 'word + { + #import {sig #[i0] : 'word → 'key } as eval ;; + r ← sample uniform N ;; + pad ← eval (word_of_ord r) ;; + let c := m ⊕ pad in + ret c + } + ]. + + Definition MOD_CPA_ff_pkg : + package MOD_CPA_location + [interface #val #[i0] : 'word → 'key] + [interface #val #[i1] : 'word → 'word]:= + [package + #def #[i1] (m : 'word) : 'word + { + #import {sig #[i0] : 'word → 'key } as eval ;; + r ← sample uniform N ;; + m' ← sample uniform N ;; + pad ← eval (word_of_ord r) ;; + let c := (word_of_ord m' ⊕ pad) in + ret c + } + ]. + + Definition IND_CPA_location : {fset Location} := fset [:: key_location]. + + Program Definition IND_CPA_pkg_tt : + package IND_CPA_location + [interface] + [interface #val #[i1] : 'word → 'word ] := + [package + #def #[i1] (m : 'word) : 'word + { + k_val ← kgen ;; + enc m k_val + } + ]. + (* why is this not inferred? *) + Next Obligation. + repeat constructor. red. + intros []. + rewrite in_fset in_cons. move=>/orP []. 2: easy. move=>/eqP H. noconf H. simpl. + eexists. + split. + 1: reflexivity. + intros. repeat constructor. + 1: auto_in_fset. destruct v. + 1: intros; repeat constructor. + 1: intros; repeat constructor. + auto_in_fset. + Defined. + + Program Definition IND_CPA_pkg_ff : + package IND_CPA_location + [interface] + [interface #val #[i1] : 'word → 'word ] := + [package + #def #[i1] (m : 'word) : 'word + { + k_val ← kgen ;; + m' ← sample uniform N ;; + enc (word_of_ord m') k_val + } + ]. + (* TODO: infer this *) + Next Obligation. + repeat constructor. red. + intros []. + rewrite in_fset in_cons. move=>/orP []. 2: easy. move=>/eqP H. noconf H. simpl. + eexists. + split. + 1: reflexivity. + intros. repeat constructor. + 1: auto_in_fset. destruct v. + 1: intros; repeat constructor. + 1: intros; repeat constructor. + auto_in_fset. + Defined. + + Program Definition IND_CPA : + loc_GamePair [interface #val #[i1] : 'word → 'word ] := + λ b, + if b then {locpackage IND_CPA_pkg_tt } else {locpackage IND_CPA_pkg_ff }. + + Local Open Scope ring_scope. + + Definition prf_epsilon A := Advantage EVAL A. + + Definition statistical_gap := + AdvantageE (MOD_CPA_ff_pkg ∘ EVAL false) (MOD_CPA_tt_pkg ∘ EVAL false). + + Lemma IND_CPA_equiv_false : + IND_CPA false ≈₀ MOD_CPA_ff_pkg ∘ (EVAL true). + Proof. + (* We go to the relation logic using equality as invariant. *) + eapply eq_rel_perf_ind_eq. + simplify_eq_rel m. + simplify_linking. + (* We now conduct the proof in relational logic. *) + ssprove_swap_rhs 1%N. + ssprove_swap_rhs 0%N. + ssprove_sync_eq. cbn -[expn]. intros [k|]. + - cbn -[expn]. ssprove_swap_rhs 0%N. + eapply rpost_weaken_rule. + 1: eapply rreflexivity_rule. + cbn. intros [? ?] [? ?] e. inversion e. intuition auto. + - cbn -[expn]. + ssprove_swap_rhs 0%N. + ssprove_swap_rhs 1%N. + ssprove_swap_rhs 0%N. + ssprove_swap_rhs 2%N. + ssprove_swap_rhs 1%N. + eapply rpost_weaken_rule. 1: eapply rreflexivity_rule. + cbn. intros [? ?] [? ?] e. inversion e. intuition auto. + Qed. + + Lemma IND_CPA_equiv_true : + MOD_CPA_tt_pkg ∘ (EVAL true) ≈₀ IND_CPA true. + Proof. + (* We go to the relation logic using equality as invariant. *) + eapply eq_rel_perf_ind_eq. + simplify_eq_rel m. + simplify_linking. + (* We now conduct the proof in relational logic. *) + ssprove_swap_lhs 0%N. + ssprove_sync_eq. cbn -[expn]. intros [k|]. + - cbn -[expn]. eapply rpost_weaken_rule. 1: eapply rreflexivity_rule. + cbn. intros [? ?] [? ?] e. inversion e. intuition auto. + - cbn -[expn]. + ssprove_swap_rhs 1%N. + ssprove_swap_rhs 0%N. + eapply rpost_weaken_rule. 1: eapply rreflexivity_rule. + cbn. intros [? ?] [? ?] e. inversion e. intuition auto. + Qed. + + (** Security of PRF + + The bound is given by using the triangle inequality several times, + using the following chain: + IND_CPA false ≈ MOD_CPA_ff_pkg ∘ EVAL true + ≈ MOD_CPA_ff_pkg ∘ EVAL false + ≈ MOD_CPA_tt_pkg ∘ EVAL false + ≈ MOD_CPA_tt_pkg ∘ EVAL true + ≈ IND_CPA true + + *) + Theorem security_based_on_prf : + ∀ LA A, + ValidPackage LA + [interface #val #[i1] : 'word → 'word ] A_export A → + fdisjoint LA (IND_CPA false).(locs) → + fdisjoint LA (IND_CPA true).(locs) → + Advantage IND_CPA A <= + prf_epsilon (A ∘ MOD_CPA_ff_pkg) + + statistical_gap A + + prf_epsilon (A ∘ MOD_CPA_tt_pkg). + Proof. + intros LA A vA hd₀ hd₁. unfold prf_epsilon, statistical_gap. + rewrite !Advantage_E. + ssprove triangle (IND_CPA false) [:: + MOD_CPA_ff_pkg ∘ EVAL true ; + MOD_CPA_ff_pkg ∘ EVAL false ; + MOD_CPA_tt_pkg ∘ EVAL false ; + MOD_CPA_tt_pkg ∘ EVAL true + ] (IND_CPA true) A + as ineq. + eapply le_trans. 1: exact ineq. + clear ineq. + erewrite IND_CPA_equiv_false. all: eauto. + 2:{ simpl. unfold MOD_CPA_location. rewrite fset0U. auto. } + erewrite IND_CPA_equiv_true. all: eauto. + 2:{ simpl. unfold MOD_CPA_location. rewrite fset0U. auto. } + rewrite GRing.add0r GRing.addr0. + rewrite !Advantage_link. rewrite Advantage_sym. auto. + Qed. +End PRF_example. + +From JasminSSProve Require Import aes.aes aes_jazz jasmin_utils aes_valid. +From Jasmin Require Import expr sem. + +Import JasminNotation JasminCodeNotation. + +(* From Jasmin Require Import expr. *) +Require Import String. +Local Open Scope string. + +Section JasminPRF. + + Ltac neq_loc_auto ::= solve [ eapply injective_translate_var3; auto | eapply injective_translate_var2; auto ]. + + Notation n := U128. + + Definition key := 'word n. + Definition pt := 'word n. + Definition ct := 'word n. + + Notation " 'word " := ('word n) (in custom pack_type at level 2). + Notation " 'key " := ('word n) (in custom pack_type at level 2). + Notation N := ((expn 2 n).-1.+1). + + Notation enc := (enc U128 aes). + Notation kgen := (kgen U128). + Notation key_location := (key_location U128). + + Definition ltup2 (l : tchlist) := + match l with + | [::] => (word0, word0) + | a1 :: l1 => + match l with + | [::] => (word0, word0) + | a2 :: l2 => (coerce_to_choice_type ('word n) a1.π2, coerce_to_choice_type ('word n) a2.π2) + end + end. + + Definition Cenc (m : pt) (k : key) : + code (fset [:: state ; rkeys]) [interface] ('word n). + Proof. + refine + {code + r ← sample uniform N ;; + pad ← Caes (word_of_ord r) k ;; + ret (m ⊕ pad) + }. + repeat constructor. + all: auto_in_fset. + Unshelve. exact _. + Defined. + + Definition Cenc_locs := [:: state ; rkeys]. + Opaque wrange. + Opaque expn. + + Definition IND_CPA_pkg_Cenc : + package (fset (key_location :: Cenc_locs)) + [interface] + [interface #val #[i1] : 'word → 'word]. + Proof. + refine + [package + #def #[i1] (m : 'word) : 'word + { + k_val ← kgen ;; + Cenc m k_val + } + ]. + (* infer this *) + repeat constructor. red. + intros []. + rewrite in_fset in_cons. move=>/orP []. 2: easy. move=>/eqP H. noconf H. simpl. + eexists. + split. + 1: reflexivity. + intros. repeat constructor. + all: auto_in_fset. + intros. destruct v. + 1: repeat constructor; auto_in_fset. + 1: repeat constructor; auto_in_fset. + Defined. + + Notation hdtc128 l := (coerce_to_choice_type ('word U128) (head ( 'word U128 ; word0 ) l).π2). + + Definition IND_CPA_pkg_JENC (id0 : p_id) : + package (fset (key_location :: (JENC_valid id0).π1)) + [interface] + [interface #val #[i1] : 'word → 'word ]. + Proof. + refine + [package + #def #[i1] (m : 'word) : 'word + { + k_val ← kgen ;; + r ← sample uniform N ;; + res ← JENC id0 (word_of_ord r) k_val m ;; + ret (hdtc128 res) + } + ]. + repeat constructor. + intros []. + rewrite in_fset in_cons => /orP []; [|easy]; move=> /eqP H; noconf H. + cbv zeta match. + eexists. + split. + 1: reflexivity. + intros x. + constructor. + 1: auto_in_fset. + intros. destruct v. + - constructor. intros. + eapply valid_bind. + + red. eapply valid_code_cons. + 1: eapply (JENC_valid id0).π2. + + constructor. + - constructor. + intros. + constructor. + 1: auto_in_fset. + constructor. intros. + eapply valid_bind. + + red. eapply valid_code_cons. + 1: eapply (JENC_valid id0).π2. + + constructor. + Unshelve. all: exact _. + Defined. + + (* Notation KG_pkg := (KG_pkg U128). *) + Notation IND_CPA_pkg_ff := (IND_CPA_pkg_ff U128 aes). + Notation MOD_CPA_ff_pkg := (MOD_CPA_ff_pkg U128). + Notation IND_CPA := (IND_CPA U128 aes). + Notation EVAL := (EVAL U128 aes). + + Lemma fsubset_ext2 : ∀ [T : ordType] (s1 s2 : {fset T}), fsubset s1 s2 -> (forall x, x \in s1 -> x \in s2). + Proof. + intros. + rewrite -fsub1set. + eapply fsubset_trans. 2: eassumption. + rewrite fsub1set. assumption. + Qed. + + Lemma fsubset_cons : ∀ [T : ordType] a (s1 s2 : {fset T}), fsubset s1 s2 -> fsubset s1 (a |: s2). + Proof. + intros. + apply fsubset_ext. + intros. rewrite in_fset in_cons. + apply/orP. right. + eapply fsubset_ext2. + 1: eassumption. + assumption. + Qed. + + Definition IND_CPA_Cenc : + loc_GamePair [interface #val #[i1] : 'word → 'word ] := + λ b, + if b then {locpackage IND_CPA_pkg_Cenc } else (IND_CPA true). + + Definition IND_CPA_JENC id0 : + loc_GamePair [interface #val #[i1] : 'word → 'word ] := + λ b, + if b then {locpackage IND_CPA_pkg_JENC id0} else {locpackage IND_CPA_pkg_Cenc}. + + (* TODO: move *) + Lemma JXOR_E pre id0 x y : + (pdisj pre id0 fset0) -> + ⊢ ⦃ fun '(h0, h1) => pre (h0, h1) ⦄ + JXOR id0 x y + ≈ + ret (chCanonical chUnit) + ⦃ fun '(v0, h0) '(v1, h1) => pre (h0, h1) /\ (exists o, (v0 = cons ('word U128 ; o ) nil ) /\ (o = x ⊕ y)) ⦄. + Proof. + unfold JXOR, get_translated_static_fun, translate_prog_static, translate_funs_static, translate_call_body. + intros disj. + simpl. simpl_fun. + repeat setjvars. + ssprove_code_simpl. + repeat clear_get. + repeat eapply r_put_lhs. + eapply r_ret. + rewrite !zero_extend_u. + intros. destruct_pre; split_post. + 1: pdisj_apply disj. + eexists; split; [reflexivity|]. reflexivity. + Qed. + + (* TODO: move *) + Arguments pheap_ignore : simpl never. + + Lemma IND_CPA_JENC_equiv_false id0 : + padv_equiv (fun l => exists s_id v, id0 ⪯ s_id /\ l = translate_var s_id v) (fun l => l = state \/ l = rkeys) (IND_CPA_JENC id0 true) (IND_CPA_JENC id0 false) (λ _ : raw_package, 0%R). + Proof. + eapply eq_rel_perf_ind'. + (* invariant *) + { eapply pInvariant_pheap_ignore with + (P := fun l => forall s_id v, id0 ⪯ s_id -> l != translate_var s_id v). + { intros. apply/eqP. intros contra. + destruct H. apply H. + exists s_id, v. split; auto. } } + unfold eq_up_to_inv, get_op_default, lookup_op, IND_CPA_JENC, IND_CPA_pkg_JENC. + Opaque Caes. + Opaque translate_call. + Opaque wrange. + Opaque expn. + simpl. + simplify_eq_rel m. + simplify_linking. + rewrite !cast_fun_K. + ssprove_sync. + { intros h0 h1 hpre. apply hpre. admit. } + intros. + eapply r_bind with (mid := fun '(a₀, s₀) '(a₁, s₁) => pheap_ignore (λ l : ∑ _ : choice_type, nat, ∀ (s_id : p_id) (v : var), id0 ⪯ s_id → l != translate_var s_id v) (s₀, s₁) /\ a₀ = a₁). + { destruct a. + - eapply r_ret. easy. + - ssprove_sync. intros. + ssprove_sync. + { intros h0 h1 Hh l H. + destruct (l == key_location) eqn:E. + - move: E => /eqP heq. subst. rewrite !get_set_heap_eq. reflexivity. + - move: E => /negP Hneq. rewrite !get_set_heap_neq; auto. 1-2: apply /negP; auto. } + eapply r_ret. easy. } + intros. + (* TODO: find easier way to do next three lines *) + eapply rpre_weak_hypothesis_rule. + intros; destruct_pre. + eapply rpre_weaken_rule with (pre:= fun '(s₀, s₁) => pheap_ignore (λ l : ∑ _ : choice_type, nat, ∀ (s_id : p_id) (v : var), id0 ⪯ s_id → l != translate_var s_id v) (s₀, s₁)); try easy. + ssprove_code_simpl. + simpl. + ssprove_sync. intros. + rewrite !zero_extend_u. + repeat clear_get. + do 3 eapply r_put_lhs. + eapply r_bind. + - eapply aes_E; split. + + intros. + destruct_pre. + do 2 eexists. + 1: do 2 eexists. + 1: do 2 eexists. + 1: instantiate (1 := set_heap H7 (translate_var s_id' v) a1). + all: try reflexivity. + { intros l lnin. rewrite get_set_heap_neq. 1: eapply H8; auto. eapply lnin. admit. } + { repeat rewrite [set_heap _ _ a1]set_heap_commut; auto. 1-3: admit. } + + intros. + destruct_pre. + do 2 eexists. + 1: do 2 eexists. + 1: do 2 eexists. + 1: instantiate (1 := H6). + all: try reflexivity. + intros l2 lnin. + rewrite get_set_heap_neq. + 1: eapply H7. 1: assumption. + admit. + - simpl. intros. + eapply rpre_weak_hypothesis_rule; intros. + destruct_pre. + simpl. + clear_get. + eapply r_put_lhs with (pre := fun _ => _). + eapply r_get_remember_lhs. intros. + eapply r_bind with (m₁ := ret (chCanonical chUnit)) (f₁ := fun _ => _). + 1: eapply JXOR_E; split. + + intros. + destruct_pre. + 1: do 1 eexists. + 1: do 2 eexists. + 1: do 7 eexists. + 1: instantiate (1:= (set_heap H14 (translate_var s_id' v) a1)). + all: try reflexivity. + { intros l hl. rewrite get_set_heap_neq. 1: eapply H15. 1: assumption. apply hl. admit. } + { repeat rewrite [set_heap _ _ a1]set_heap_commut; auto. 1-4: admit. } + { sheap. simpl. rewrite get_set_heap_neq. 1: sheap. 1: reflexivity. admit. } + + intros. easy. + + intros. + eapply rpre_weak_hypothesis_rule; intros. + destruct_pre; simpl. + clear_get. + eapply r_put_lhs with (pre := fun _ => _). + eapply r_ret. + rewrite !coerce_to_choice_type_K. + rewrite !zero_extend_u. + intros. + destruct_pre; simpl; split_post. + { sheap. by rewrite wxorC. } + { intros l s_id. + rewrite !get_set_heap_neq. + 1: eapply H19; auto. + 1-5: apply s_id; reflexivity. + Admitted. + + Lemma IND_CPA_jazz_equiv_false : + (IND_CPA_Cenc) true ≈₀ (IND_CPA_Cenc) false. + Proof. + eapply eq_rel_perf_ind_ignore with (L := fset Cenc_locs). + { eapply fsubsetU. apply/orP; left. simpl. + rewrite [fset (key_location :: _)]fset_cons. + eapply fsubset_cons. + eapply fsubsetxx. } + unfold eq_up_to_inv. + Opaque Caes. + Opaque wrange. + Opaque expn. + simplify_eq_rel m. + ssprove_sync. intros. + eapply r_bind with (mid := fun '(a0, s0) '(a1, s1) => a0 = a1 /\ heap_ignore (fset Cenc_locs) (s0, s1)). + { destruct a. + - eapply r_ret. easy. + - ssprove_sync. intros. + ssprove_sync. + (* { intros h0 h1 H1 H2 H. rewrite !get_set_heap_neq. 1: eapply H1; eauto. 1-2: admit. } *) + eapply r_ret. easy. } + intros. simpl. + (* TODO: find easier way to do next three lines *) + eapply rpre_weak_hypothesis_rule. + intros; destruct_pre. + eapply rpre_weaken_rule with (pre:= fun '(s₀, s₁) => heap_ignore (fset Cenc_locs) (s₀, s₁)); try easy. + ssprove_sync. intros. + eapply r_bind with (m₁ := ret (chCanonical chUnit)) (f₁ := fun _ => _). + - 1: eapply aes_h. + intros h1 h2 l a2 lin h. + intros l2 lnin. + unfold Cenc_locs in *. + rewrite get_set_heap_neq. + 1: apply h; auto. + admit. + - intros. eapply r_ret. + intros. destruct_pre; split_post; auto. + Admitted. + + Definition JIND_CPA id0 : + loc_GamePair [interface #val #[i1] : 'word → 'word ] := + λ b, + if b then {locpackage IND_CPA_pkg_JENC id0 } else (IND_CPA true). + + Theorem jasmin_security_based_on_prf id0 : + ∀ LA A, + ValidPackage LA + [interface #val #[i1] : 'word → 'word ] A_export A → + pdisjoint LA (λ l : Location, ∃ (s_id : p_id) (v : var), id0 ⪯ s_id ∧ l = translate_var s_id v) -> + pdisjoint LA (λ l : Location, l = state ∨ l = rkeys) -> + (* fdisjoint LA (JIND_CPA id0 false).(locs) → *) + (* fdisjoint LA (JIND_CPA id0 true).(locs) → *) + Advantage (JIND_CPA id0) A = 0%R. + Proof. + intros LA A vA hd₀ hd₁. unfold prf_epsilon, statistical_gap. + rewrite !Advantage_E. + eapply AdvantageE_le_0. + ssprove triangle (JIND_CPA id0 false) [:: + IND_CPA_pkg_Cenc : raw_package + ] (JIND_CPA id0 true) A + as ineq. + eapply Order.POrderTheory.le_trans. + 1: exact ineq. + clear ineq. + rewrite Advantage_sym. + erewrite IND_CPA_jazz_equiv_false. all: eauto. + 2-3: admit. + rewrite Advantage_sym. + pose proof IND_CPA_JENC_equiv_false id0. + unfold padv_equiv in H. + specialize (H LA A vA hd₀ hd₁). + rewrite H. + rewrite GRing.addr0. + apply Order.POrderTheory.le_refl. + Admitted. + +End JasminPRF. diff --git a/theories/Jasmin/examples/aes/aes_spec.v b/theories/Jasmin/examples/aes/aes_spec.v new file mode 100644 index 00000000..11cb5a6e --- /dev/null +++ b/theories/Jasmin/examples/aes/aes_spec.v @@ -0,0 +1,236 @@ +Set Warnings "-notation-overridden,-ambiguous-paths". +From mathcomp Require Import all_ssreflect all_algebra zify. +From mathcomp.word Require Import word ssrZ. +Set Warnings "notation-overridden,ambiguous-paths". + +From Coq Require Import Utf8 ZArith micromega.Lia List. + +From Jasmin Require Import expr xseq waes word. +From JasminSSProve Require Import jasmin_translate word aes_utils. + +From Relational Require Import OrderEnrichedCategory. +From Crypt Require Import Prelude Package ChoiceAsOrd choice_type. + +From extructures Require Import ord fset fmap. + +Import ListNotations. +Import JasminNotation. +Import PackageNotation. +Import AesNotation. + +Set Bullet Behavior "Strict Subproofs". +Set Default Goal Selector "!". + +Local Open Scope Z. + +(** Specs *) + +Definition rcon (i : Z) : u8 := nth (wrepr U8 54%Z) [:: (wrepr U8 1%Z); (wrepr U8 2%Z); (wrepr U8 4%Z); (wrepr U8 8%Z); (wrepr U8 16%Z); (wrepr U8 32%Z); (wrepr U8 64%Z); (wrepr U8 128%Z); (wrepr U8 27%Z); (wrepr U8 54%Z)]%Z ((Z.to_nat i) - 1). + +Ltac neq_loc_auto ::= solve [ eapply injective_translate_var3; auto | eapply injective_translate_var2; auto ]. + +Definition key_expand (wn1 : u128) (rcon : u8) : 'word U128 := + let rcon := zero_extend U32 rcon in + let w0 := subword 0 U32 wn1 in + let w1 := subword (1 * U32) U32 wn1 in + let w2 := subword (2 * U32) U32 wn1 in + let w3 := subword (3 * U32) U32 wn1 in + let tmp := w3 in + let tmp := SubWord (wror tmp 1) ⊕ rcon in + let w4 := w0 ⊕ tmp in + let w5 := w1 ⊕ w4 in + let w6 := w2 ⊕ w5 in + let w7 := w3 ⊕ w6 in + wcat [tuple w4; w5; w6; w7]. + +Definition key_i (k : u128) i := + iteri i (fun i ki => key_expand ki (rcon (i + 1))) k. + +Definition aes (key msg : u128) := + let state := wxor msg (key_i key 0) in + let state := iteri 9 (fun i state => wAESENC_ state (key_i key (i + 1))) state in + wAESENCLAST_ state (key_i key 10). + +Definition invaes (key cipher : u128) := + let state := wxor cipher (key_i key 10) in + let state := iteri 9 (fun i state => wAESDEC_ state (key_i key (10 -(i + 1)))) state in + wAESDECLAST state (key_i key 0). + +Definition rkeys : Location := ( 'arr U128 ; 0%nat ). +Definition state : Location := ( 'word U128 ; 0%nat). +Definition Cenc_locs := [:: state ; rkeys]. + +Definition keyExpansion (key : u128) : raw_code ('arr U128) := + #put rkeys := @emptym (chElement_ordType 'int) u128 ;; + rkeys0 ← get rkeys ;; + #put rkeys := setm rkeys0 0 key ;; + lfor_loop (fun i => + rkeys0 ← get rkeys ;; + #put rkeys := setm rkeys0 i (key_expand (zero_extend _ (getmd rkeys0 word0 (i - 1))) (rcon i)) ;; + ret tt) 1 11 ;; + rkeys0 ← get rkeys ;; + ret rkeys0. + +Definition aes_rounds (rkeys : 'arr U128) (msg : 'word U128) : raw_code u128 := + #put state := wxor msg (getmd rkeys word0 0) ;; + lfor_loop (fun i => + state0 ← get state ;; + #put state := wAESENC_ state0 (getmd rkeys word0 i) ;; + ret tt + ) 1 10 ;; + state0 ← get state ;; + #put state := wAESENCLAST_ state0 (getmd rkeys word0 10) ;; + state0 ← get state ;; + ret state0. + +Definition Caes (key msg : u128) := + rkeys ← keyExpansion key ;; + cipher ← aes_rounds rkeys msg ;; + ret cipher. + +(** Correctness proofs *) + +Lemma keyExpansion_h (pre : precond) k : + u_pdisj pre [fset rkeys] -> + ⊢ ⦃ fun '(h0, h1) => pre (h0, h1) ⦄ + keyExpansion k + ≈ + ret tt + ⦃ fun '(v0, h0) '(_, h1) => pre (h0, h1) /\ forall i, 0 <= i < 11 -> (getmd v0 word0 i) = key_i k (Z.to_nat i) ⦄. +Proof. + intros Hdisj. + unfold keyExpansion. + eapply r_put_lhs with (pre := fun '(_, _) => _). + eapply r_get_remember_lhs. intros x. + eapply r_put_lhs. + eapply r_bind with (m₁ := ret _). + { eapply u_lfor_loop_rule_weaken with + (I:= fun i => fun h0 h1 => pre (h0, h1) /\ forall j, 0 <= j < i -> getmd (get_heap h0 rkeys) word0 j = key_i k (Z.to_nat j)). + { lia. } + - intros h1 h2 Hset. + destruct_pre. + split_post. + + u_pdisj_apply Hdisj. + + intros j Hj. + sheap. + unfold getmd. + rewrite setmE. + assert (@eq_op (Ord.eqType Z_ordType) j Z0) by (apply/eqP; lia). + rewrite H. + move: H=>/eqP ->. + simpl. + reflexivity. + - intros i ile. + ssprove_code_simpl. + eapply r_get_remember_lhs with (pre := fun '(_, _) => _). intros x0. + eapply r_put_lhs. + eapply r_ret. + intros s0 s1 Hpre. + destruct_pre. split_post. + + u_pdisj_apply Hdisj. + + intros j Hj. + rewrite get_set_heap_eq. + rewrite -> H6 by lia. + unfold getmd in *. + rewrite setmE. + destruct (Z.eq_dec j i). + * subst. + rewrite eq_refl. + rewrite zero_extend_u. + replace (Z.to_nat i) with (Z.to_nat (i - 1)).+1 by lia. + unfold key_i at 2. + rewrite iteriS. + f_equal. f_equal. simpl. lia. + * assert (@eq_op (Ord.eqType Z_ordType) j i = false). + { apply/eqP. assumption. } + rewrite H1; auto. + rewrite H6; auto. + lia. } + intros s0 s1. + eapply r_get_remember_lhs with (pre := fun '(_, _) => _). intros x0. + eapply r_ret. + intros s2 s3 Hpre. + destruct_pre. + split. + - easy. + - apply H2. +Qed. + +Lemma aes_rounds_h rkeys k m pre : + u_pdisj pre [fset state] -> + ⊢ ⦃ fun '(h0, h1) => pre (h0, h1) /\ (forall i, 0 <= i < 11 -> getmd rkeys word0 i = key_i k (Z.to_nat i)) ⦄ + aes_rounds rkeys m + ≈ + ret tt + ⦃ fun '(v0, h0) '(_, h1) => pre (h0, h1) /\ v0 = aes k m ⦄. +Proof. + unfold aes_rounds. + intros Hdisj. + set (st0 := m ⊕ (key_i k 0%nat)). + eapply r_put_lhs with (pre := fun '(_, _) => _). + eapply r_bind with (m₁ := ret _). + { eapply u_lfor_loop_rule_weaken with + (I := fun i => fun h0 h1 => pre (h0, h1) /\ get_heap h0 state = iteri (Z.to_nat i - 1) (fun i state => wAESENC_ state (key_i k (i + 1))) st0 + /\ (forall i, 0 <= i < 11 -> getmd rkeys word0 i = key_i k (Z.to_nat i))). + - lia. + - intros. + simpl. + destruct_pre. sheap. split_post. + + u_pdisj_apply Hdisj. + + rewrite H3; auto. lia. + + assumption. + - intros i Hi. + eapply r_get_remember_lhs with (pre := fun '(_, _) => _). intros x. + eapply r_put_lhs. eapply r_ret. + intros s0 s1 Hpre. + destruct_pre; sheap; split_post. + + u_pdisj_apply Hdisj. + + replace (Z.to_nat (Z.succ i) - 1)%nat with ((Z.to_nat i - 1).+1) by lia. + rewrite iteriS. + rewrite H4. + rewrite H7. 2: lia. repeat f_equal. lia. + + assumption. } + intros a0 a1. + eapply r_get_remember_lhs with (pre := fun '(_, _) => _). intros x. + eapply r_put_lhs. + eapply r_get_remember_lhs. intros x0. + eapply r_ret. + intros s0 s1 Hpre. + destruct Hpre as [[s2 [[[H5 [H4 H6]] H3] H2]] H1]. + simpl in H3, H1. subst. + sheap. + split; [u_pdisj_apply Hdisj|]. + unfold aes. + rewrite H4. + rewrite H6. 2: lia. + replace ((Z.to_nat 10) - 1)%nat with 9%nat by reflexivity. + reflexivity. +Qed. + +Lemma aes_h k m pre : + (u_pdisj pre [fset state ; rkeys]) -> + ⊢ ⦃ fun '(h0, h1) => pre (h0, h1) ⦄ + Caes k m + ≈ + ret tt + ⦃ fun '(v0, h0) '(_, h1) => pre (h0, h1) /\ v0 = aes k m ⦄. +Proof. + unfold Caes. + intros Hdisj. + eapply r_bind with (m₁ := ret _). + { eapply keyExpansion_h. + u_pdisj_apply Hdisj. + intros h1 h2 l a lin Hpre. + eapply Hdisj; auto. + admit. } + intros a0 []. + eapply r_bind with (m₁ := ret _). + { eapply aes_rounds_h. + intros h1 h2 l a lin Hpre. + eapply Hdisj; auto. + admit. } + intros a1 []. + eapply r_ret. + intros. + assumption. +Admitted. diff --git a/theories/Jasmin/examples/aes/aes_utils.v b/theories/Jasmin/examples/aes/aes_utils.v new file mode 100644 index 00000000..e4ef17fa --- /dev/null +++ b/theories/Jasmin/examples/aes/aes_utils.v @@ -0,0 +1,608 @@ +Set Warnings "-notation-overridden,-ambiguous-paths". +From mathcomp Require Import all_ssreflect all_algebra zify. +From mathcomp.word Require Import word ssrZ. +Set Warnings "notation-overridden,ambiguous-paths". + +From Coq Require Import Utf8 ZArith micromega.Lia List. + +From Jasmin Require Import expr xseq. +From JasminSSProve Require Import jasmin_translate. + +From Relational Require Import OrderEnrichedCategory. +From Crypt Require Import Prelude Package ChoiceAsOrd. + +From extructures Require Import ord fset fmap. + +Import ListNotations. +Import JasminNotation. +Import PackageNotation. + +Set Bullet Behavior "Strict Subproofs". +Set Default Goal Selector "!". + +(** Notations *) + +Module AesNotation. + Notation " 'arr ws " := (chMap 'int ('word ws)) (at level 2) : package_scope. +End AesNotation. + +(** For loops *) + +Local Open Scope Z. + +Fixpoint for_list (c : Z → raw_code 'unit) (vs : seq Z) : raw_code 'unit := + match vs with + | [::] => ret tt + | v :: vs => c v ;; for_list c vs + end. + +Definition lfor_loop (c : Z -> raw_code 'unit) lo hi := for_list c (wrange UpTo lo hi). + +Lemma iota_aux {A} k c n (f : nat -> A) g : + (forall a, a \in (iota k n) -> f a = g (a + c)%nat) -> + [seq f i | i <- iota k n] = [seq g i | i <- iota (k + c) n]. +Proof. + revert k c. + induction n. + - reflexivity. + - intros k c ex. + simpl. rewrite -addSn -IHn. + + f_equal. + apply ex. + rewrite in_cons eq_refl => //=. + + intros a ain. apply ex. + simpl. rewrite in_cons. + apply/orP. right. assumption. +Qed. + +Lemma u_lfor_loop_rule I c lo hi : + lo <= hi -> + (∀ i, (lo <= i < hi)%Z -> + ⊢ ⦃ λ '(s₀, s₁), I i s₀ s₁ ⦄ + c i ≈ ret tt + ⦃ λ '(_, s₀) '(_, s₁), I (Z.succ i) s₀ s₁ ⦄) → + ⊢ ⦃ λ '(s₀, s₁), I lo s₀ s₁ ⦄ + lfor_loop c lo hi ≈ ret tt + ⦃ λ '(_,s₀) '(_,s₁), I hi s₀ s₁ ⦄. +Proof. + intros hle h. + remember (Z.to_nat (hi - lo)). + revert hle h Heqn. revert lo hi. + induction n as [| n ih]; intros. + - assert (hi = lo) by lia. + unfold lfor_loop=>/=. + rewrite -Heqn. + subst. + apply r_ret. easy. + - unfold lfor_loop=>/=. + rewrite -Heqn. simpl. rewrite Z.add_0_r. + eapply r_bind with (m₁ := ret tt) (f₁ := fun _ => _). + + eapply h. lia. + + intros a1 a2. + destruct a1, a2. + replace [seq lo + Z.of_nat i | i <- iota 1 n] with [seq (Z.succ lo) + Z.of_nat i | i <- iota 0 n]. + 2: { replace (iota 1 n) with (iota (0 + 1) n) by f_equal. apply iota_aux. intros. lia. } + replace n with (Z.to_nat (hi - Z.succ lo)) by lia. + eapply ih. + all: try lia. + intros i hi2. apply h. lia. +Qed. + +Lemma u_lfor_loop_rule_weaken (I : Z -> heap -> heap -> Prop) c lo hi (pre : precond) : + lo <= hi -> + (forall h1 h2, pre (h1, h2) -> I lo h1 h2) -> + (∀ i, (lo <= i < hi)%Z -> + ⊢ ⦃ λ '(s₀, s₁), I i s₀ s₁ ⦄ + c i ≈ ret tt + ⦃ λ '(_, s₀) '(_, s₁), I (Z.succ i) s₀ s₁ ⦄) → + ⊢ ⦃ pre ⦄ + lfor_loop c lo hi ≈ ret tt + ⦃ λ '(_,s₀) '(_,s₁), I hi s₀ s₁ ⦄. +Proof. + intros. + eapply rpre_weaken_rule. + 1: eapply u_lfor_loop_rule; eauto. + assumption. +Qed. + +Lemma lfor_loop_rule I c₀ c₁ lo hi : + lo <= hi -> + (∀ i, (lo <= i < hi)%Z -> ⊢ ⦃ λ '(s₀, s₁), I i (s₀, s₁) ⦄ c₀ i ≈ c₁ i ⦃ λ '(_, s₀) '(_, s₁), I (Z.succ i) (s₀,s₁) ⦄) → + ⊢ ⦃ λ '(s₀, s₁), I lo (s₀, s₁) ⦄ + lfor_loop c₀ lo hi ≈ lfor_loop c₁ lo hi + ⦃ λ '(_,s₀) '(_,s₁), I hi (s₀,s₁) ⦄. +Proof. + intros hle h. + remember (Z.to_nat (hi - lo)). + revert hle h Heqn. revert lo hi. + induction n as [| n ih]; intros. + - assert (hi = lo) by lia. + unfold lfor_loop=>/=. + rewrite -Heqn. + subst. + apply r_ret. easy. + - unfold lfor_loop=>/=. + rewrite -Heqn. simpl. rewrite Z.add_0_r. + eapply r_bind. + + eapply h. lia. + + intros a1 a2. + destruct a1, a2. + replace [seq lo + Z.of_nat i | i <- iota 1 n] with [seq (Z.succ lo) + Z.of_nat i | i <- iota 0 n]. + 2: { replace (iota 1 n) with (iota (0 + 1) n) by f_equal. apply iota_aux. intros. lia. } + replace n with (Z.to_nat (hi - Z.succ lo)) by lia. + eapply ih. + all: try lia. + intros i hi2. apply h. lia. +Qed. + +Lemma translate_for_rule I lo hi (v : var_i) m_id s_id (body1 : p_id -> p_id * raw_code 'unit) body2 : + (* it is annoying that this is a proof obligation, since its true for all translated programs, but I don't know how to prove the theorem without it *) + (forall s_id', s_id' ⪯ (body1 s_id').1) -> + lo <= hi -> + (forall i s_id', (s_id ⪯ s_id') -> (lo <= i < hi) -> + ⊢ ⦃ λ '(s₀, s₁), set_lhs (translate_var m_id v) (truncate_el (vtype v) (i : chInt)) (I i) (s₀, s₁) ⦄ + let (_, body1') := body1 s_id' in + body1' ≈ body2 i + ⦃ λ '(_, s₀) '(_, s₁), I (Z.succ i) (s₀,s₁) ⦄) → + ⊢ ⦃ λ '(s₀,s₁), I lo (s₀, s₁)⦄ + translate_for v (wrange UpTo lo hi) m_id body1 s_id + ≈ lfor_loop body2 lo hi + ⦃ λ '(_,s₀) '(_,s₁), I hi (s₀,s₁) ⦄. +Proof. + intros Hbody1 Hle ih. + remember (Z.to_nat (hi - lo)). + revert Heqn Hle ih. revert n lo hi s_id. + induction n as [|n ih2]; intros. + - assert (hi = lo). { zify. lia. } + subst. + unfold translate_for, lfor_loop. simpl. + rewrite -Heqn. + simpl. + apply r_ret. + easy. + - unfold translate_for, lfor_loop. + unfold wrange. + rewrite -Heqn. + simpl. + specialize (ih lo s_id) as ih''. + specialize (Hbody1 s_id). + destruct (body1 s_id). + eapply r_put_lhs. + eapply r_bind. + + eapply r_transL. + 2: rewrite Z.add_0_r; eapply ih''; [ reflexivity | lia ]. + eapply rreflexivity_rule. + + intros a0 a1. + replace (iota 1 n) with (iota (0 + 1) n) by f_equal. + rewrite <- iota_aux with (f := fun i => Z.succ lo + Z.of_nat i) by lia. + replace n with (Z.to_nat (hi - Z.succ lo)) by lia. + specialize (ih2 (Z.succ lo) hi p ltac:(lia) ltac:(lia)). + eapply ih2. + intros i s_id' Hs_id' ile. + specialize (ih i s_id'). + destruct (body1 s_id'). apply ih. + 1: etransitivity; eauto. + lia. +Qed. + +Lemma translate_for_rule_weaken (pre : precond) (I : Z -> heap * heap -> Prop) lo hi (v : var_i) m_id s_id (body1 : p_id -> p_id * raw_code 'unit) body2 : + (forall h0 h1, pre (h0, h1) -> I lo (h0, h1)) -> + (* it is annoying that this is a proof obligation, since its true for all translated programs, but I don't know how to prove the theorem without it *) + (forall s_id', s_id' ⪯ (body1 s_id').1) -> + lo <= hi -> + (forall i s_id', (s_id ⪯ s_id') -> (lo <= i < hi) -> + ⊢ ⦃ λ '(s₀, s₁), set_lhs (translate_var m_id v) (truncate_el (vtype v) (i : chInt)) (I i) (s₀, s₁) ⦄ + let (_, body1') := body1 s_id' in + body1' + ≈ body2 i ⦃ λ '(_, s₀) '(_, s₁), I (Z.succ i) (s₀,s₁) ⦄) → + ⊢ ⦃ pre ⦄ + translate_for v (wrange UpTo lo hi) m_id body1 s_id + ≈ lfor_loop body2 lo hi + ⦃ λ '(_,s₀) '(_,s₁), I hi (s₀,s₁) ⦄. +Proof. + intros. + eapply rpre_weaken_rule. + 1: eapply translate_for_rule. + all: easy. +Qed. + +(** Arrays *) + +Definition getmd {T S} m d i := match @getm T S m i with Some a => a | _ => d end. + +Definition to_oarr ws len (a : 'array) : (chMap (chFin len) ('word ws)) := + mkfmapf (fun (i : 'I_len) => chArray_get ws a (Z.of_nat i) (wsize_size ws)) (ord_enum len). +Definition to_arr ws len (a : 'array) := + mkfmapf (fun i => chArray_get ws a i (wsize_size ws)) (ziota 0 len). + +Lemma wsize_size_aux (ws : wsize.wsize) : + (ws %/ U8 + ws %% U8)%nat = Z.to_nat (wsize_size ws). +Proof. destruct ws; reflexivity. Qed. + +Lemma encode_aux {ws} (w : word.word ws) : + LE.encode w = [seq word.subword ((Z.to_nat i0) * U8) U8 w | i0 <- ziota 0 (wsize_size ws)]. +Proof. + unfold LE.encode. + unfold split_vec. + unfold ziota. + rewrite -wsize_size_aux. + simpl. + rewrite -map_comp. + unfold comp. + apply map_ext. + intros a Ha. + rewrite Nat2Z.id. + reflexivity. +Qed. + +Lemma wsize_size_bits ws: + wsize_size ws < wsize_bits ws. +Proof. + unfold wsize_size, wsize_bits. + destruct ws; simpl; lia. +Qed. + +Lemma chArray_get_set_eq ws a i w : + chArray_get ws (chArray_set a AAscale i w) i (wsize_size ws) = w. +Proof. + unfold chArray_get. + unfold chArray_set. + rewrite <- LE.decodeK. + f_equal. + rewrite encode_aux. + apply map_ext. + intros j Hj. + unfold chArray_get8. + rewrite chArray_write_get. + assert ((0 <=? i * wsize_size ws + j - i * mk_scale AAscale ws) && (i * wsize_size ws + j - i * mk_scale AAscale ws /InP. rewrite in_ziota=>/andP [] H1 h2. lia. } + rewrite H. + unfold LE.wread8. + unfold LE.encode. + unfold split_vec. + unshelve erewrite nth_map. 1: exact 0%nat. + { simpl. + rewrite nth_iota. + 1: f_equal; lia. + simpl. move: Hj=>/InP. rewrite in_ziota=>/andP [] H1 h2. + replace (ws %/ U8 + ws %% U8)%nat with (Z.to_nat (wsize_size ws)); [lia|]. + destruct ws; simpl; reflexivity. } + rewrite size_iota. + simpl. move: Hj=>/InP. rewrite in_ziota=>/andP [] H1 h2. + replace (ws %/ U8 + ws %% U8)%nat with (Z.to_nat (wsize_size ws)); [lia|]. + destruct ws; simpl; reflexivity. +Qed. + +Lemma chArray_get_set_neq ws a i j (w : 'word ws) : + i <> j -> + chArray_get ws (chArray_set a AAscale i w) j (wsize_size ws) = chArray_get ws a j (wsize_size ws). +Proof. + intros H. + unfold chArray_get. + unfold chArray_set. + f_equal. + apply map_ext. + intros a0 Ha0. + unfold chArray_get8. + rewrite chArray_write_get. + assert ((0 <=? j * wsize_size ws + a0 - i * mk_scale AAscale ws) && (j * wsize_size ws + a0 - i * mk_scale AAscale ws /InP. rewrite in_ziota=>/andP [] H1 h2. nia. } + rewrite H0. + reflexivity. +Qed. + +Lemma getm_to_arr_None' ws len a (i: Z) : + ((len <=? i) || (i + to_arr ws len a i = None. +Proof. + intros. unfold to_arr. + rewrite mkfmapfE. +Admitted. (* figure out a proof that is less stupid than the one for getm_to_arr *) + +Lemma getm_to_oarr ws len a (i : 'I_(pos len)) : + to_oarr ws len a i = Some (chArray_get ws a i (wsize_size ws)). +Proof. + unfold to_oarr. + rewrite mkfmapfE. + rewrite mem_ord_enum. + reflexivity. +Qed. + +Lemma getm_to_arr ws len a i : + (0 <= i < len) -> + to_arr ws len a i = Some (chArray_get ws a i (wsize_size ws)). +Proof. + unfold to_arr. + rewrite mkfmapfE. + intros H. + (* this is a stupid proof and should be true by in_ziota, though for some reason the \in's resolve differently (one uses Z_eqType the other Z_ordType) *) + assert (is_true (@in_mem (Ord.sort Z_ordType) i (@ssrbool.mem (Equality.sort (Ord.eqType Z_ordType)) (seq_predType (Ord.eqType Z_ordType)) (ziota Z0 len)))). + { assert (0 <= len) by lia. move: H. move: (Z.le_refl 0). replace len with (0 + len) at 1 by (now rewrite Z.add_0_l). generalize 0 at 2 3 4 5. + change (∀ z : Z, 0 <= z -> z <= i < z + len → + (is_true (@in_mem (Ord.sort Z_ordType) i (@ssrbool.mem (Equality.sort (Ord.eqType Z_ordType)) (seq_predType (Ord.eqType Z_ordType)) (ziota z len)))) + ) with ((fun len => ((forall z, 0 <= z -> z <= i < z + len -> + (is_true (@in_mem (Ord.sort Z_ordType) i (@ssrbool.mem (Equality.sort (Ord.eqType Z_ordType)) (seq_predType (Ord.eqType Z_ordType)) (ziota z len)))) + ))) len). + apply natlike_ind. + - intros z Hz Hz2. lia. + - intros x Hx Ih z Hz Hz2. rewrite ziotaS_cons. 2: lia. + destruct (Z.eq_dec z i). + + rewrite in_cons. apply/orP. left. apply/eqP. easy. + + rewrite in_cons. apply/orP. right. apply Ih. all: lia. + - assumption. } + rewrite H0. + reflexivity. +Qed. + +Lemma getmd_to_arr a ws len x i : + (0 <= i < len) -> + getmd (to_arr ws len a) x i = chArray_get ws a i (wsize_size ws). +Proof. + intros. + unfold getmd. + rewrite getm_to_arr; auto. +Qed. + +Lemma to_oarr_set_eq ws len a (i : 'I_(pos len)) w : + (to_oarr ws len (chArray_set a AAscale i w)) i = Some w. +Proof. + rewrite getm_to_oarr. + rewrite chArray_get_set_eq. + reflexivity. +Qed. + +Lemma to_arr_set_eq ws len a i w : + (0 <= i < len) -> + (to_arr ws len (chArray_set a AAscale i w)) i = Some w. +Proof. + intros H. + rewrite getm_to_arr; auto. + rewrite chArray_get_set_eq; auto. +Qed. + +Lemma to_arr_set_neq' ws len a i j (w : 'word ws) : + (i <> j) -> + (0 <= j < len) -> + (to_arr ws len (chArray_set a AAscale i w)) j = Some (chArray_get ws a j (wsize_size ws)). +Proof. + intros Hneq H. + rewrite getm_to_arr; auto. + rewrite chArray_get_set_neq; auto. +Qed. + +Lemma to_arr_set_neq ws len a i j (w : 'word ws) : + (i <> j) -> + (0 <= j < len) -> + (to_arr ws len (chArray_set a AAscale i w)) j = (to_arr ws len a) j. +Proof. + intros Hneq H. + rewrite !getm_to_arr; auto. + rewrite chArray_get_set_neq; auto. +Qed. + +(** Additional rules *) + +Theorem rpre_weak_hypothesis_rule : + ∀ {A₀ A₁ : ord_choiceType} {p₀ : raw_code A₀} {p₁ : raw_code A₁} + (pre : precond) post, + (∀ s₀ s₁, + pre (s₀, s₁) → ⊢ ⦃ λ '(s0, s1), pre (s0, s1) ⦄ p₀ ≈ p₁ ⦃ post ⦄ + ) → + ⊢ ⦃ pre ⦄ p₀ ≈ p₁ ⦃ post ⦄. +Proof. + intros A₀ A₁ p₀ p₁ pre post h. + eapply rpre_hypothesis_rule. + intros. eapply rpre_weaken_rule. + 1: eapply h; eauto. + intros s0' s1' [H0 H1]. + subst. + assumption. +Qed. + +(** Valid code *) + +Lemma valid_code_cons {A} a l I (c : raw_code A) : + valid_code (fset l) I c -> valid_code (fset (a :: l)) I c. +Proof. + intros. + induction c; econstructor. + - apply inversion_valid_opr in H as []. easy. + - intros. apply H0. apply inversion_valid_opr in H as []. easy. + - apply inversion_valid_getr in H as []. rewrite in_fset in_cons. apply/orP; right. rewrite -in_fset. easy. + - intros. apply H0. apply inversion_valid_getr in H as []. easy. + - apply inversion_valid_putr in H as []. rewrite in_fset in_cons. apply/orP; right. rewrite -in_fset. easy. + - apply inversion_valid_putr in H as []. apply IHc. easy. + - intros. apply H0. eapply inversion_valid_sampler. easy. +Qed. + +Lemma valid_code_catC {A} l1 l2 I (c : raw_code A) : + valid_code (fset (l1 ++ l2)) I c -> valid_code (fset (l2 ++ l1)) I c. +Proof. by rewrite !fset_cat fsetUC. Qed. + +Lemma valid_code_cat_r {A} l1 l2 I (c : raw_code A) : + valid_code (fset l1) I c -> valid_code (fset (l1 ++ l2)) I c. +Proof. + intros. + induction l2. + - rewrite cats0. easy. + - apply valid_code_catC. simpl. apply valid_code_cons. apply valid_code_catC. easy. +Qed. + +Lemma valid_code_cat_l {A} l1 l2 I (c : raw_code A) : + valid_code (fset l2) I c -> valid_code (fset (l1 ++ l2)) I c. +Proof. intros; apply valid_code_catC. apply valid_code_cat_r. easy. Qed. + +Lemma valid_translate_write_lvals1 I id0 (v : var_i) vs : + valid_code (fset [:: translate_var id0 v]) I (translate_write_lvals [::] id0 [:: (Lvar v)] vs) . +Proof. + destruct vs. + - constructor. + - constructor. + 1: auto_in_fset. + constructor. +Qed. + +Lemma valid_translate_write_lvals2 I id0 (v1 v2 : var_i) vs : + valid_code (fset [:: translate_var id0 v1 ; translate_var id0 v2]) I (translate_write_lvals [::] id0 [:: (Lvar v1) ; (Lvar v2)] vs) . +Proof. + destruct vs. + - constructor. + - constructor. + 1: auto_in_fset. + destruct vs. + + constructor. + + constructor. + 1: auto_in_fset. + constructor. +Qed. + +(** Invariants and tactics *) + +Definition pdisj (P : precond) (s_id : p_id) (rhs : {fset Location}) := + (forall h1 h2 l a v s_id', l = translate_var s_id' v -> (s_id ⪯ s_id') -> (P (h1, h2) -> P (set_heap h1 l a, h2))) /\ + (forall h1 h2 l a, l \in rhs -> (P (h1, h2) -> P (h1, set_heap h2 l a))). + +Definition u_pdisj (P : precond) (lhs : {fset Location}) := + (forall h1 h2 l a, l \in lhs -> (P (h1, h2) -> P (set_heap h1 l a, h2))). + +Definition pdisj' (P : precond) (s_id : p_id) (lhs : {fset Location}) (rhs : {fset Location}) := + (forall h1 h2 l a, l \in lhs -> (P (h1, h2) -> P (set_heap h1 l a, h2))) /\ + (forall h1 h2 l a, l \in rhs -> (P (h1, h2) -> P (h1, set_heap h2 l a))). + +Ltac solve_in := + repeat match goal with + | |- is_true (?v \in fset1 ?v :|: _) => apply/fsetU1P; left; auto + | |- is_true (_ \in fsetU _ _) => apply/fsetU1P; right + end. + +Ltac destruct_pre := + repeat + match goal with + | [ H : set_lhs _ _ _ _ |- _ ] => + let sn := fresh in + let Hsn := fresh in + destruct H as [sn [Hsn]] + | [ H : set_rhs _ _ _ _ |- _ ] => + let sn := fresh in + let Hsn := fresh in + destruct H as [sn [Hsn]] + | [ H : _ /\ _ |- _ ] => + let H1 := fresh in + let H2 := fresh in + destruct H as [H1 H2] + | [ H : (_ ⋊ _) _ |- _ ] => + let H1 := fresh in + let H2 := fresh in + destruct H as [H1 H2] + | [ H : exists _, _ |- _ ] => + let o := fresh in + destruct H as [o] + end; simpl in *; subst. + +(* I don't know what rewrite * means, but this is much faster than regular rewrite, which also sometimes overflows the stack *) +Ltac sheap := + repeat first [ rewrite * get_set_heap_neq; [| neq_loc_auto ] | + rewrite * get_set_heap_eq ]. + +(* This works sometimes, but might be very slow *) +Ltac simpl_heap := + repeat lazymatch goal with + | |- context [ get_heap (set_heap _ ?l _) ?l ] => rewrite -> get_set_heap_eq + | |- context [ get_heap (set_heap (translate_var ?s_id _) (translate_var ?s_id _ ) _ ) _ ] => (rewrite -> get_set_heap_neq by (apply injective_translate_var3; auto)) + | |- context [ get_heap (set_heap _ (translate_var _ _ ) _ ) _ ] => (rewrite -> get_set_heap_neq by (apply injective_translate_var2; assumption)) + end. + +Ltac split_post := + repeat + match goal with + | |- (_ ⋊ _) _ => split + | |- _ /\ _ => split + | |- set_lhs _ _ _ _ => eexists + end. + +(* NB: this redefines neq_loc_auto, which helps some tactics, since checking for inequality by computation is not feasible for translated variables *) +(* Ltac neq_loc_auto ::= solve [ eapply injective_translate_var3; auto | eapply injective_translate_var2; auto ]. *) + +#[global] Hint Resolve preceq_I preceq_O preceq_refl : preceq. +Ltac solve_preceq := + repeat lazymatch goal with + | |- ?a ⪯ ?a => reflexivity + | |- ?a ⪯ ?b~1 => etransitivity; [|apply preceq_I] + | |- ?a ⪯ ?b~0 => etransitivity; [|apply preceq_O] + end. + +Ltac esolve_in := + rewrite in_fset; apply/xseq.InP; + repeat lazymatch goal with + | |- List.In _ (_ :: _) => eapply List.in_cons + | |- _ => eapply List.in_eq + end. + +Ltac tr_inseq_try := + apply/orP ; first [ left ; rewrite translate_var_eq eq_refl ; reflexivity + | right ; tr_inseq_try ]. + +Ltac tr_inset_try := + rewrite in_fset ; tr_inseq_try. + +Ltac tr_auto_in_fset := + eauto ; + try tr_inset_try. + +Ltac until_call := + simpl; repeat match goal with + | |- ValidCode _ _ _ => red + | |- valid_code _ _ (_ ← translate_call _ _ _ _ _ ;; _) => eapply valid_bind + | |- valid_code _ _ (_ ← (x ← _ ;; _) ;; _) => rewrite bind_assoc + | |- _ => constructor; [solve [ tr_auto_in_fset | esolve_in ]| ]; intros + | |- _ -> _ => intros + end. + +Ltac pdisj_apply h := + lazymatch goal with + | |- ?pre (set_heap _ _ _, set_heap _ _ _) => eapply h; [ solve_in | pdisj_apply h ] + | |- ?pre (set_heap _ _ _, _) => + eapply h ; [ reflexivity | auto with preceq | pdisj_apply h ] + | |- _ => try assumption + end. + +Ltac pdisj'_apply h := + lazymatch goal with + | |- ?pre (set_heap _ _ _, _) => eapply h; [ tr_auto_in_fset | pdisj'_apply h ] + | |- ?pre (_, set_heap _ _ _) => eapply h; [ auto_in_fset | pdisj'_apply h ] + | |- _ => try assumption + end. + +Ltac u_pdisj_apply h := + lazymatch goal with + | |- ?pre (set_heap _ _ _, _) => eapply h; [ solve_in | u_pdisj_apply h ] + | |- _ => try assumption + end. + +Ltac clear_fset := + repeat match goal with + | |- ValidCode _ _ _ => red + | |- valid_code (fset (_ :: _)) _ _ => eapply valid_code_cons + | |- valid_code (fset (_ ++ _)) _ _ => eapply valid_code_cat_l + end; eapply valid_code_cat_r. + +(** Misc (TODO: move these) *) + +(* TODO: move these, note they are the same as fresh1 and fresh2 *) +Lemma prec_O : + forall i, i ≺ i~0. +Proof. + simpl; split. + - apply preceq_O. + - apply nesym. apply xO_neq. +Qed. + +Lemma prec_I : + forall i, i ≺ i~1. +Proof. + simpl; split. + - apply preceq_I. + - apply nesym. apply xI_neq. +Qed. + +(** *) diff --git a/theories/Jasmin/examples/aes/aes_valid.v b/theories/Jasmin/examples/aes/aes_valid.v index 0aa4ae72..aa11ae61 100644 --- a/theories/Jasmin/examples/aes/aes_valid.v +++ b/theories/Jasmin/examples/aes/aes_valid.v @@ -1,136 +1,18 @@ -From JasminSSProve Require Import jasmin_translate. - -From Relational Require Import OrderEnrichedCategory GenericRulesSimple. - Set Warnings "-notation-overridden,-ambiguous-paths". -From mathcomp Require Import all_ssreflect all_algebra reals distr realsum - ssrnat ssreflect ssrfun ssrbool ssrnum eqtype choice seq word word.ssrZ. +From mathcomp Require Import all_ssreflect seq. Set Warnings "notation-overridden,ambiguous-paths". -From Mon Require Import SPropBase. -From Crypt Require Import Axioms ChoiceAsOrd SubDistr Couplings - UniformDistrLemmas FreeProbProg Theta_dens RulesStateProb - pkg_core_definition choice_type pkg_composition pkg_rhl Package Prelude. - -From Coq Require Import Utf8. -From extructures Require Import ord fset fmap. - -Import SPropNotations. - -Import PackageNotation. - -From Equations Require Import Equations. -Require Equations.Prop.DepElim. +From JasminSSProve Require Import jasmin_translate aes_utils aes_jazz. +From Relational Require Import OrderEnrichedCategory GenericRulesSimple. +From Crypt Require Import Axioms ChoiceAsOrd pkg_core_definition choice_type Prelude. -Set Equations With UIP. +From extructures Require Import fset ord. Set Bullet Behavior "Strict Subproofs". Set Default Goal Selector "!". -Set Primitive Projections. - -Import Num.Def. -Import Num.Theory. -Import Order.POrderTheory. - -From JasminSSProve Require Import aes_jazz jasmin_utils. -From Jasmin Require Import expr sem. - -Import JasminNotation JasminCodeNotation. - -Require Import String. -Local Open Scope string. Local Open Scope positive_scope. -Ltac esolve_in := - rewrite in_fset; apply/xseq.InP; - repeat lazymatch goal with - | |- List.In _ (_ :: _) => eapply List.in_cons - | |- _ => eapply List.in_eq - end. - -Ltac tr_inseq_try := - apply/orP ; first [ left ; rewrite translate_var_eq eq_refl ; reflexivity - | right ; tr_inseq_try ]. - -Ltac tr_inset_try := - rewrite in_fset ; tr_inseq_try. - -Ltac tr_auto_in_fset := - eauto ; - try tr_inset_try. - -Ltac until_call := - simpl; repeat match goal with - | |- ValidCode _ _ _ => red - | |- valid_code _ _ (_ ← translate_call _ _ _ _ _ ;; _) => eapply valid_bind - | |- valid_code _ _ (_ ← (x ← _ ;; _) ;; _) => rewrite bind_assoc - | |- _ => constructor; [solve [ tr_auto_in_fset | esolve_in ]| ]; intros - | |- _ -> _ => intros - end. - -Lemma valid_code_cons {A} a l I (c : raw_code A) : - valid_code (fset l) I c -> valid_code (fset (a :: l)) I c. -Proof. - intros. - induction c; econstructor. - - apply inversion_valid_opr in H as []. easy. - - intros. apply H0. apply inversion_valid_opr in H as []. easy. - - apply inversion_valid_getr in H as []. rewrite in_fset in_cons. apply/orP; right. rewrite -in_fset. easy. - - intros. apply H0. apply inversion_valid_getr in H as []. easy. - - apply inversion_valid_putr in H as []. rewrite in_fset in_cons. apply/orP; right. rewrite -in_fset. easy. - - apply inversion_valid_putr in H as []. apply IHc. easy. - - intros. apply H0. eapply inversion_valid_sampler. easy. -Qed. - -Lemma valid_code_catC {A} l1 l2 I (c : raw_code A) : - valid_code (fset (l1 ++ l2)) I c -> valid_code (fset (l2 ++ l1)) I c. -Proof. by rewrite !fset_cat fsetUC. Qed. - -Lemma valid_code_cat_r {A} l1 l2 I (c : raw_code A) : - valid_code (fset l1) I c -> valid_code (fset (l1 ++ l2)) I c. -Proof. - intros. - induction l2. - - rewrite cats0. easy. - - apply valid_code_catC. simpl. apply valid_code_cons. apply valid_code_catC. easy. -Qed. - -Lemma valid_code_cat_l {A} l1 l2 I (c : raw_code A) : - valid_code (fset l2) I c -> valid_code (fset (l1 ++ l2)) I c. -Proof. intros; apply valid_code_catC. apply valid_code_cat_r. easy. Qed. - -Lemma valid_translate_write_lvals1 I id0 (v : var_i) vs : - valid_code (fset [:: translate_var id0 v]) I (translate_write_lvals [::] id0 [:: (Lvar v)] vs) . -Proof. - destruct vs. - - constructor. - - constructor. - 1: auto_in_fset. - constructor. -Qed. - -Lemma valid_translate_write_lvals2 I id0 (v1 v2 : var_i) vs : - valid_code (fset [:: translate_var id0 v1 ; translate_var id0 v2]) I (translate_write_lvals [::] id0 [:: (Lvar v1) ; (Lvar v2)] vs) . -Proof. - destruct vs. - - constructor. - - constructor. - 1: auto_in_fset. - destruct vs. - + constructor. - + constructor. - 1: auto_in_fset. - constructor. -Qed. - -Ltac clear_fset := - repeat match goal with - | |- ValidCode _ _ _ => red - | |- valid_code (fset (_ :: _)) _ _ => eapply valid_code_cons - | |- valid_code (fset (_ ++ _)) _ _ => eapply valid_code_cat_l - end; eapply valid_code_cat_r. - Ltac fix_lvals1 := clear_fset; eapply valid_translate_write_lvals1. Ltac fix_lvals2 := clear_fset; eapply valid_translate_write_lvals2. diff --git a/theories/Jasmin/examples/aes/utils.v b/theories/Jasmin/examples/aes/utils.v new file mode 100644 index 00000000..e49ee6a9 --- /dev/null +++ b/theories/Jasmin/examples/aes/utils.v @@ -0,0 +1,408 @@ +Set Warnings "-notation-overridden,-ambiguous-paths". +From mathcomp Require Import all_ssreflect all_algebra zify. +From mathcomp.word Require Import word ssrZ. +Set Warnings "notation-overridden,ambiguous-paths". + +From Coq Require Import Utf8 ZArith micromega.Lia List. + +From Jasmin Require Import expr xseq. +From JasminSSProve Require Import jasmin_translate. + +From Relational Require Import OrderEnrichedCategory. +From Crypt Require Import Prelude Package ChoiceAsOrd. + +From extructures Require Import ord fset fmap. + +Import ListNotations. +Import JasminNotation. +Import PackageNotation. + +Set Bullet Behavior "Strict Subproofs". +Set Default Goal Selector "!". + +(** For loops *) + +Local Open Scope Z. + +Fixpoint for_list (c : Z → raw_code 'unit) (vs : seq Z) : raw_code 'unit := + match vs with + | [::] => ret tt + | v :: vs => c v ;; for_list c vs + end. + +Definition for_loop (c : Z -> raw_code 'unit) lo hi := for_list c (wrange UpTo lo hi). + +Lemma iota_aux {A} k c n (f : nat -> A) g : + (forall a, a \in (iota k n) -> f a = g (a + c)%nat) -> + [seq f i | i <- iota k n] = [seq g i | i <- iota (k + c) n]. +Proof. + revert k c. + induction n. + - reflexivity. + - intros k c ex. + simpl. rewrite -addSn -IHn. + + f_equal. + apply ex. + rewrite in_cons eq_refl => //=. + + intros a ain. apply ex. + simpl. rewrite in_cons. + apply/orP. right. assumption. +Qed. + +Lemma u_for_loop_rule I c lo hi : + lo <= hi -> + (∀ i, (lo <= i < hi)%Z -> + ⊢ ⦃ λ '(s₀, s₁), I i s₀ s₁ ⦄ + c i ≈ ret tt + ⦃ λ '(_, s₀) '(_, s₁), I (Z.succ i) s₀ s₁ ⦄) → + ⊢ ⦃ λ '(s₀, s₁), I lo s₀ s₁ ⦄ + for_loop c lo hi ≈ ret tt + ⦃ λ '(_,s₀) '(_,s₁), I hi s₀ s₁ ⦄. +Proof. + intros hle h. + remember (Z.to_nat (hi - lo)). + revert hle h Heqn. revert lo hi. + induction n as [| n ih]; intros. + - assert (hi = lo) by lia. + unfold for_loop=>/=. + rewrite -Heqn. + subst. + apply r_ret. easy. + - unfold for_loop=>/=. + rewrite -Heqn. simpl. rewrite Z.add_0_r. + eapply r_bind with (m₁ := ret tt) (f₁ := fun _ => _). + + eapply h. lia. + + intros a1 a2. + destruct a1, a2. + replace [seq lo + Z.of_nat i | i <- iota 1 n] with [seq (Z.succ lo) + Z.of_nat i | i <- iota 0 n]. + 2: { replace (iota 1 n) with (iota (0 + 1) n) by f_equal. apply iota_aux. intros. lia. } + replace n with (Z.to_nat (hi - Z.succ lo)) by lia. + eapply ih. + all: try lia. + intros i hi2. apply h. lia. +Qed. + +Lemma u_for_loop_rule_weaken (I : Z -> heap -> heap -> Prop) c lo hi (pre : precond) : + lo <= hi -> + (forall h1 h2, pre (h1, h2) -> I lo h1 h2) -> + (∀ i, (lo <= i < hi)%Z -> + ⊢ ⦃ λ '(s₀, s₁), I i s₀ s₁ ⦄ + c i ≈ ret tt + ⦃ λ '(_, s₀) '(_, s₁), I (Z.succ i) s₀ s₁ ⦄) → + ⊢ ⦃ pre ⦄ + for_loop c lo hi ≈ ret tt + ⦃ λ '(_,s₀) '(_,s₁), I hi s₀ s₁ ⦄. +Proof. + intros. + eapply rpre_weaken_rule. + 1: eapply u_for_loop_rule; eauto. + assumption. +Qed. + +Lemma for_loop_rule I c₀ c₁ lo hi : + lo <= hi -> + (∀ i, (lo <= i < hi)%Z -> ⊢ ⦃ λ '(s₀, s₁), I i (s₀, s₁) ⦄ c₀ i ≈ c₁ i ⦃ λ '(_, s₀) '(_, s₁), I (Z.succ i) (s₀,s₁) ⦄) → + ⊢ ⦃ λ '(s₀, s₁), I lo (s₀, s₁) ⦄ + for_loop c₀ lo hi ≈ for_loop c₁ lo hi + ⦃ λ '(_,s₀) '(_,s₁), I hi (s₀,s₁) ⦄. +Proof. + intros hle h. + remember (Z.to_nat (hi - lo)). + revert hle h Heqn. revert lo hi. + induction n as [| n ih]; intros. + - assert (hi = lo) by lia. + unfold for_loop=>/=. + rewrite -Heqn. + subst. + apply r_ret. easy. + - unfold for_loop=>/=. + rewrite -Heqn. simpl. rewrite Z.add_0_r. + eapply r_bind. + + eapply h. lia. + + intros a1 a2. + destruct a1, a2. + replace [seq lo + Z.of_nat i | i <- iota 1 n] with [seq (Z.succ lo) + Z.of_nat i | i <- iota 0 n]. + 2: { replace (iota 1 n) with (iota (0 + 1) n) by f_equal. apply iota_aux. intros. lia. } + replace n with (Z.to_nat (hi - Z.succ lo)) by lia. + eapply ih. + all: try lia. + intros i hi2. apply h. lia. +Qed. + +Lemma translate_for_rule I lo hi (v : var_i) m_id s_id (body1 : p_id -> p_id * raw_code 'unit) body2 : + (* it is annoying that this is a proof obligation, since its true for all translated programs, but I don't know how to prove the theorem without it *) + (forall s_id', s_id' ⪯ (body1 s_id').1) -> + lo <= hi -> + (forall i s_id', (s_id ⪯ s_id') -> (lo <= i < hi) -> + ⊢ ⦃ λ '(s₀, s₁), set_lhs (translate_var m_id v) (truncate_el (vtype v) (i : chInt)) (I i) (s₀, s₁) ⦄ + let (_, body1') := body1 s_id' in + body1' ≈ body2 i + ⦃ λ '(_, s₀) '(_, s₁), I (Z.succ i) (s₀,s₁) ⦄) → + ⊢ ⦃ λ '(s₀,s₁), I lo (s₀, s₁)⦄ + translate_for v (wrange UpTo lo hi) m_id body1 s_id + ≈ for_loop body2 lo hi + ⦃ λ '(_,s₀) '(_,s₁), I hi (s₀,s₁) ⦄. +Proof. + intros Hbody1 Hle ih. + remember (Z.to_nat (hi - lo)). + revert Heqn Hle ih. revert n lo hi s_id. + induction n as [|n ih2]; intros. + - assert (hi = lo). { zify. lia. } + subst. + unfold translate_for, for_loop. simpl. + rewrite -Heqn. + simpl. + apply r_ret. + easy. + - unfold translate_for, for_loop. + unfold wrange. + rewrite -Heqn. + simpl. + specialize (ih lo s_id) as ih''. + specialize (Hbody1 s_id). + destruct (body1 s_id). + eapply r_put_lhs. + eapply r_bind. + + eapply r_transL. + 2: rewrite Z.add_0_r; eapply ih''; [ reflexivity | lia ]. + eapply rreflexivity_rule. + + intros a0 a1. + replace (iota 1 n) with (iota (0 + 1) n) by f_equal. + rewrite <- iota_aux with (f := fun i => Z.succ lo + Z.of_nat i) by lia. + replace n with (Z.to_nat (hi - Z.succ lo)) by lia. + specialize (ih2 (Z.succ lo) hi p ltac:(lia) ltac:(lia)). + eapply ih2. + intros i s_id' Hs_id' ile. + specialize (ih i s_id'). + destruct (body1 s_id'). apply ih. + 1: etransitivity; eauto. + lia. +Qed. + +Lemma translate_for_rule_weaken (pre : precond) (I : Z -> heap * heap -> Prop) lo hi (v : var_i) m_id s_id (body1 : p_id -> p_id * raw_code 'unit) body2 : + (forall h0 h1, pre (h0, h1) -> I lo (h0, h1)) -> + (* it is annoying that this is a proof obligation, since its true for all translated programs, but I don't know how to prove the theorem without it *) + (forall s_id', s_id' ⪯ (body1 s_id').1) -> + lo <= hi -> + (forall i s_id', (s_id ⪯ s_id') -> (lo <= i < hi) -> + ⊢ ⦃ λ '(s₀, s₁), set_lhs (translate_var m_id v) (truncate_el (vtype v) (i : chInt)) (I i) (s₀, s₁) ⦄ + let (_, body1') := body1 s_id' in + body1' + ≈ body2 i ⦃ λ '(_, s₀) '(_, s₁), I (Z.succ i) (s₀,s₁) ⦄) → + ⊢ ⦃ pre ⦄ + translate_for v (wrange UpTo lo hi) m_id body1 s_id + ≈ for_loop body2 lo hi + ⦃ λ '(_,s₀) '(_,s₁), I hi (s₀,s₁) ⦄. +Proof. + intros. + eapply rpre_weaken_rule. + 1: eapply translate_for_rule. + all: easy. +Qed. + +(** Arrays *) + +Definition getmd {T S} m d i := match @getm T S m i with Some a => a | _ => d end. + +Definition to_oarr ws len (a : 'array) : (chMap (chFin len) ('word ws)) := + mkfmapf (fun (i : 'I_len) => chArray_get ws a (Z.of_nat i) (wsize_size ws)) (ord_enum len). +Definition to_arr ws len (a : 'array) := + mkfmapf (fun i => chArray_get ws a i (wsize_size ws)) (ziota 0 len). + +Lemma wsize_size_aux (ws : wsize.wsize) : + (ws %/ U8 + ws %% U8)%nat = Z.to_nat (wsize_size ws). +Proof. destruct ws; reflexivity. Qed. + +Lemma encode_aux {ws} (w : word.word ws) : + LE.encode w = [seq word.subword ((Z.to_nat i0) * U8) U8 w | i0 <- ziota 0 (wsize_size ws)]. +Proof. + unfold LE.encode. + unfold split_vec. + unfold ziota. + rewrite -wsize_size_aux. + simpl. + (* rewrite Z2Nat.inj_add. *) + (* rewrite !Nat2Z.id. *) + rewrite -map_comp. + unfold comp. + apply map_ext. + intros a Ha. + rewrite Nat2Z.id. + reflexivity. + (* apply Zle_0_nat. *) + (* apply Zle_0_nat. *) +Qed. + +Lemma wsize_size_bits ws: + wsize_size ws < wsize_bits ws. +Proof. + unfold wsize_size, wsize_bits. + destruct ws; simpl; lia. +Qed. + +Lemma chArray_get_set_eq ws a i w : + chArray_get ws (chArray_set a AAscale i w) i (wsize_size ws) = w. +Proof. + unfold chArray_get. + unfold chArray_set. + rewrite <- LE.decodeK. + f_equal. + rewrite encode_aux. + apply map_ext. + intros j Hj. + unfold chArray_get8. + rewrite chArray_write_get. + assert ((0 <=? i * wsize_size ws + j - i * mk_scale AAscale ws) && (i * wsize_size ws + j - i * mk_scale AAscale ws /InP. rewrite in_ziota=>/andP [] H1 h2. lia. } + rewrite H. + unfold LE.wread8. + unfold LE.encode. + unfold split_vec. + unshelve erewrite nth_map. 1: exact 0%nat. + { simpl. + rewrite nth_iota. + 1: f_equal; lia. + simpl. move: Hj=>/InP. rewrite in_ziota=>/andP [] H1 h2. + replace (ws %/ U8 + ws %% U8)%nat with (Z.to_nat (wsize_size ws)); [lia|]. + destruct ws; simpl; reflexivity. } + rewrite size_iota. + simpl. move: Hj=>/InP. rewrite in_ziota=>/andP [] H1 h2. + replace (ws %/ U8 + ws %% U8)%nat with (Z.to_nat (wsize_size ws)); [lia|]. + destruct ws; simpl; reflexivity. +Qed. + +Lemma chArray_get_set_neq ws a i j (w : 'word ws) : + i <> j -> + chArray_get ws (chArray_set a AAscale i w) j (wsize_size ws) = chArray_get ws a j (wsize_size ws). +Proof. + intros H. + unfold chArray_get. + unfold chArray_set. + f_equal. + apply map_ext. + intros a0 Ha0. + unfold chArray_get8. + rewrite chArray_write_get. + assert ((0 <=? j * wsize_size ws + a0 - i * mk_scale AAscale ws) && (j * wsize_size ws + a0 - i * mk_scale AAscale ws /InP. rewrite in_ziota=>/andP [] H1 h2. nia. } + rewrite H0. + reflexivity. +Qed. + +Lemma getm_to_arr_None' ws len a (i: Z) : + ((len <=? i) || (i + to_arr ws len a i = None. +Proof. + intros. unfold to_arr. + rewrite mkfmapfE. +Admitted. (* figure out a proof that is less stupid than the one for getm_to_arr *) + +Lemma getm_to_oarr ws len a (i : 'I_(pos len)) : + to_oarr ws len a i = Some (chArray_get ws a i (wsize_size ws)). +Proof. + unfold to_oarr. + rewrite mkfmapfE. + rewrite mem_ord_enum. + reflexivity. +Qed. + +Lemma getm_to_arr ws len a i : + (0 <= i < len) -> + to_arr ws len a i = Some (chArray_get ws a i (wsize_size ws)). +Proof. + unfold to_arr. + rewrite mkfmapfE. + intros H. + (* this is a stupid proof and should be true by in_ziota, though for some reason the \in's resolve differently (one uses Z_eqType the other Z_ordType) *) + assert (is_true (@in_mem (Ord.sort Z_ordType) i (@ssrbool.mem (Equality.sort (Ord.eqType Z_ordType)) (seq_predType (Ord.eqType Z_ordType)) (ziota Z0 len)))). + { assert (0 <= len) by lia. move: H. move: (Z.le_refl 0). replace len with (0 + len) at 1 by (now rewrite Z.add_0_l). generalize 0 at 2 3 4 5. + change (∀ z : Z, 0 <= z -> z <= i < z + len → + (is_true (@in_mem (Ord.sort Z_ordType) i (@ssrbool.mem (Equality.sort (Ord.eqType Z_ordType)) (seq_predType (Ord.eqType Z_ordType)) (ziota z len)))) + ) with ((fun len => ((forall z, 0 <= z -> z <= i < z + len -> + (is_true (@in_mem (Ord.sort Z_ordType) i (@ssrbool.mem (Equality.sort (Ord.eqType Z_ordType)) (seq_predType (Ord.eqType Z_ordType)) (ziota z len)))) + ))) len). + apply natlike_ind. + - intros z Hz Hz2. lia. + - intros x Hx Ih z Hz Hz2. rewrite ziotaS_cons. 2: lia. + destruct (Z.eq_dec z i). + + rewrite in_cons. apply/orP. left. apply/eqP. easy. + + rewrite in_cons. apply/orP. right. apply Ih. all: lia. + - assumption. } + rewrite H0. + reflexivity. +Qed. + +Lemma to_oarr_set_eq ws len a (i : 'I_(pos len)) w : + (to_oarr ws len (chArray_set a AAscale i w)) i = Some w. +Proof. + rewrite getm_to_oarr. + rewrite chArray_get_set_eq. + reflexivity. +Qed. + +Lemma to_arr_set_eq ws len a i w : + (0 <= i < len) -> + (to_arr ws len (chArray_set a AAscale i w)) i = Some w. +Proof. + intros H. + rewrite getm_to_arr; auto. + rewrite chArray_get_set_eq; auto. +Qed. + +Lemma to_arr_set_neq' ws len a i j (w : 'word ws) : + (i <> j) -> + (0 <= j < len) -> + (to_arr ws len (chArray_set a AAscale i w)) j = Some (chArray_get ws a j (wsize_size ws)). +Proof. + intros Hneq H. + rewrite getm_to_arr; auto. + rewrite chArray_get_set_neq; auto. +Qed. + +Lemma to_arr_set_neq ws len a i j (w : 'word ws) : + (i <> j) -> + (0 <= j < len) -> + (to_arr ws len (chArray_set a AAscale i w)) j = (to_arr ws len a) j. +Proof. + intros Hneq H. + rewrite !getm_to_arr; auto. + rewrite chArray_get_set_neq; auto. +Qed. + +(** Additional rules *) + +Theorem rpre_weak_hypothesis_rule : + ∀ {A₀ A₁ : ord_choiceType} {p₀ : raw_code A₀} {p₁ : raw_code A₁} + (pre : precond) post, + (∀ s₀ s₁, + pre (s₀, s₁) → ⊢ ⦃ λ '(s0, s1), pre (s0, s1) ⦄ p₀ ≈ p₁ ⦃ post ⦄ + ) → + ⊢ ⦃ pre ⦄ p₀ ≈ p₁ ⦃ post ⦄. +Proof. + intros A₀ A₁ p₀ p₁ pre post h. + eapply rpre_hypothesis_rule. + intros. eapply rpre_weaken_rule. + 1: eapply h; eauto. + intros s0' s1' [H0 H1]. + subst. + assumption. +Qed. + +(** Misc (TODO: move these) *) + +(* TODO: move these, note they are the same as fresh1 and fresh2 *) +Lemma prec_O : + forall i, i ≺ i~0. +Proof. + simpl; split. + - apply preceq_O. + - apply nesym. apply xO_neq. +Qed. + +Lemma prec_I : + forall i, i ≺ i~1. +Proof. + simpl; split. + - apply preceq_I. + - apply nesym. apply xI_neq. +Qed. diff --git a/theories/Jasmin/word.v b/theories/Jasmin/word.v new file mode 100644 index 00000000..1f2158e5 --- /dev/null +++ b/theories/Jasmin/word.v @@ -0,0 +1,483 @@ +From Coq Require Import Utf8 ZArith micromega.Lia. + +From mathcomp Require Import all_ssreflect all_algebra. +From mathcomp.word Require Import word ssrZ. + +(* NB: This changes the behaviour of lia, making it work on goals with ssr types *) +From mathcomp Require Import zify. + +Set Bullet Behavior "Strict Subproofs". +Set Default Goal Selector "!". + +Notation "m ⊕ k" := (wxor m k) (at level 20). +Notation "m ⟫ k" := (lsr m k) (at level 20). + +Lemma lsr_word0 {n} a : word0 ⟫ a = @word0 n. +Proof. + unfold lsr. + rewrite Z.shiftr_0_l. + apply val_inj. + reflexivity. +Qed. + +Lemma wxor_0_r {n} (a : word n) : a ⊕ word0 = a. +Proof. + unfold wxor. + apply val_inj. simpl. + by rewrite Z.lxor_0_r. +Qed. + +Lemma wxor_0_l {n} (a : word n) : wxor word0 a = a. +Proof. + apply val_inj. + reflexivity. +Qed. + +Lemma wxor_involutive {n} : forall k : word n, k ⊕ k = word0. +Proof. + intros k. + apply/eqP/eq_from_wbit=> i. + rewrite !wxorE addbb. + unfold wbit. + rewrite Z.testbit_0_l. + reflexivity. +Qed. + +Lemma wxorA {n} : forall m k l : word n, ((m ⊕ k) ⊕ l) = (m ⊕ (k ⊕ l)). +Proof. + intros m k l. + apply/eqP/eq_from_wbit=> i. + by rewrite !wxorE addbA. +Qed. + +Lemma wxorC {n} (a b : word n) : a ⊕ b = b ⊕ a. +Proof. + apply/eqP/eq_from_wbit=> i. rewrite !wxorE. + rewrite addbC. reflexivity. +Qed. + +Lemma subword_word0 {n} a m : @subword n a m word0 = word0. +Proof. + unfold subword. + rewrite lsr_word0. + apply val_inj. + reflexivity. +Qed. + +Lemma wcat_eq ws p a t : + (forall (i : 'I_p), subword (i * ws) ws a = tnth t i) -> a = wcat t. +Proof. + intros. + rewrite -[a]wcat_subwordK. + apply f_equal. apply eq_from_tnth. + intros i. + rewrite -H tnth_map tnth_ord_tuple. + reflexivity. +Qed. + +Lemma wbit_subword {ws1} i ws2 (w : word ws1) j : + (ws2 <= ws1)%nat -> + (j < ws2)%nat -> + wbit (subword i ws2 w) j = wbit w (i + j)%nat. +Proof. + intros. + unfold subword. + simpl. + unfold urepr. + simpl. + unfold wbit. + simpl. + unfold modulus. + rewrite !two_power_nat_equiv. + rewrite Z.mod_pow2_bits_low. + { rewrite Z.mod_pow2_bits_low. 2: lia. + rewrite Z.shiftr_spec. 2: lia. + f_equal. lia. + } + lia. +Qed. + +Lemma subword_xor {n} i ws (a b : n.-word) : + (* I don't know if the assumption is necessary *) + (ws <= n)%nat -> + subword i ws (a ⊕ b) = (subword i ws a) ⊕ (subword i ws b). +Proof. + intros H. + apply/eqP/eq_from_wbit. + intros. rewrite !wbit_subword. 2,3: auto. + rewrite !wxorE. + rewrite !wbit_subword. 2-5: auto. + reflexivity. +Qed. + +Lemma nth_aux {T} (a : T) l : + [seq nth a l (val i) | i <- enum 'I_(size l)] = l. +Proof. + replace [seq nth a l (val i) | i <- enum 'I_(size l)] with [seq nth a l i | i <- [seq val i | i <- enum 'I_(size l)]]. + 2: { rewrite -map_comp. reflexivity. } + rewrite val_enum_ord. + rewrite map_nth_iota0. 2: lia. + rewrite take_size. reflexivity. +Qed. + +Lemma wcat_r_wcat {n} (l : seq (word n)) : + wcat_r l = wcat [tuple nth word0 l i | i < size l]. +Proof. + rewrite/wcat=>/=. + rewrite nth_aux. + reflexivity. +Qed. + +From Coq Require Import ZArith. + +(* following three lemmas are from fiat crypto, consider importing *) +Local Open Scope Z. +Lemma mod_pow_same_base_larger a b n m : + 0 <= n <= m -> 0 < b -> + (a mod (b^n)) mod (b^m) = a mod b^n. +Proof. + intros. + pose proof Z.mod_pos_bound a (b^n) ltac:(auto with zarith). + assert (b^n <= b^m). + { eapply Z.pow_le_mono_r; lia. } + apply Z.mod_small. auto with zarith. +Qed. + +Lemma mod_pow_same_base_smaller a b n m : + 0 <= m <= n -> 0 < b -> + (a mod (b^n)) mod (b^m) = a mod b^m. +Proof. + intros. replace n with (m+(n-m)) by lia. + rewrite -> Z.pow_add_r, Z.rem_mul_r by auto with zarith. + rewrite <- Zplus_mod_idemp_r. + rewrite <- Zmult_mod_idemp_l. + rewrite Z.mod_same. 2: eapply Z.pow_nonzero ; lia. + rewrite Z.mul_0_l. + rewrite Z.mod_0_l. 2: eapply Z.pow_nonzero ; lia. + rewrite Z.add_0_r. + rewrite Z.mod_mod. 2: eapply Z.pow_nonzero ; lia. + reflexivity. +Qed. + +Lemma mod_pull_div a b c : 0 <= c -> (a / b) mod c = a mod (c * b) / b. +Admitted. +(* end of fiat crypto lemmas *) + +Lemma shiftr_shiftr_mod w ws1 ws2 i j : + (ws2 + j <= ws1)%nat -> + Z.shiftr (Z.shiftr w (Z.of_nat i) mod modulus ws1) (Z.of_nat j) mod modulus ws2 = + Z.shiftr w (Z.of_nat (i + j)) mod modulus ws2. +Proof. + intros H. + rewrite !modulusZE. + rewrite !Z.shiftr_div_pow2; try lia. + rewrite !mod_pull_div; try lia. + simpl. + rewrite -!Z.pow_add_r; try lia. + rewrite mod_pow_same_base_smaller; try lia. + rewrite Z.div_div; try lia. + rewrite -Z.pow_add_r; try lia. + rewrite Nat2Z.inj_add. + f_equal. f_equal. f_equal. lia. +Qed. + +Lemma larger_modulus a n m : + (n <= m)%nat -> + (a mod modulus n) mod modulus m = a mod modulus n. +Proof. + intros H. + rewrite !modulusZE. + apply mod_pow_same_base_larger. 2: lia. + zify. simpl. lia. +Qed. + +Lemma smaller_modulus a n m : + (m <= n)%nat -> + (a mod modulus n) mod modulus m = a mod modulus m. +Proof. + intros H. + rewrite !modulusZE. + apply mod_pow_same_base_smaller. 2: lia. + zify. simpl. lia. +Qed. + +Lemma subword_wshr {n} i j m (w : word n) : + (m + i <= n)%nat -> + subword i m (lsr w j) = subword (j + i) m w. +Proof. + intros H. + unfold subword; simpl. + apply val_inj; simpl. + rewrite urepr_word. + unfold lsr. + simpl. + rewrite urepr_word. + rewrite !smaller_modulus; try lia. + rewrite shiftr_shiftr_mod; try lia. +Qed. + +From Jasmin Require Import word. + +Lemma subword_u {ws : wsize} (w : word ws) : subword 0 ws w = w. +Proof. by rewrite subword0 zero_extend_u. Qed. + +Lemma wbit_wrepr (ws : wsize.wsize) a i : + (i < ws)%nat -> + word.word.wbit (urepr (wrepr ws a)) i = word.word.wbit a i. +Proof. + move=>H/=. + rewrite/word.word.wbit/wrepr/urepr=>/=. + rewrite/modulus two_power_nat_equiv Z.mod_pow2_bits_low=>//. + unfold nat_of_wsize in *. lia. +Qed. + +Lemma wbit_make_vec {ws1} (ws2 : wsize) (l : seq (word.word ws1)) i : + (i < ws2)%nat -> + word.word.wbit (urepr (make_vec ws2 l)) i = word.word.wbit (nth word0 l (i %/ ws1)) (i %% ws1). +Proof. + move=> H. + rewrite /make_vec wcat_r_wcat wbit_wrepr=>//. + rewrite wcat_wbitE=>/=. + repeat f_equal. + apply nth_aux. +Qed. + +Lemma divn_aux j i n : + (j < n)%nat -> + (n <= j %% n + i %% n)%nat = false -> + (j + i) %/ n = i %/ n. +Proof. + intros H1 H2. + rewrite divnD. 2: lia. + rewrite H2. + rewrite divn_small. all: lia. +Qed. + +Lemma modn_aux j i n : + (j < n)%nat -> + (n <= j %% n + i %% n)%nat = false -> + (j + i) %% n = (j + i %% n)%nat. +Proof. + intros H1 H2. + rewrite modnD. 2: lia. + rewrite H2. + rewrite modn_small. all: lia. +Qed. + +Lemma subword_make_vec_full {ws1} i (ws2 ws3 : wsize.wsize) (l : seq (word.word ws1)) : + (* i + ws2 does 'reach across' a single word in the list *) + (ws2 <= ws1)%nat -> + (i + ws2 <= ws3)%nat -> + (ws1 <= (ws2 - 1) %% ws1 + i %% ws1)%nat = false -> + (* i think this condition is equivalent, but the others fit with other lemmas *) + (* ((i + ws2 - 1) / ws1)%nat = (i / ws1)%nat -> *) + subword i ws2 (make_vec ws3 l) = subword (i %% ws1) ws2 (nth word0 l (i %/ ws1)%nat). +Proof. + intros H1 H2 H3. + rewrite !subwordE. + f_equal. + apply eq_mktuple. + intros j. + destruct j. simpl. + rewrite wbit_make_vec. 2: lia. + f_equal. + - f_equal. f_equal. + apply divn_aux. 1:{ simpl. lia. } + rewrite modn_small in H3. 2: lia. + rewrite modn_small. 2: lia. + lia. + - apply modn_aux. 1: lia. + rewrite modn_small in H3. 2: lia. + rewrite modn_small. 1: lia. + lia. +Qed. + +Lemma subword_make_vec {ws1} i (ws2 : wsize.wsize) (l : seq (word.word ws1)) : + (ws1 <= ws2)%nat -> + ((i + 1) * ws1 <= ws2)%nat -> + subword (i * ws1) ws1 (make_vec ws2 l) = nth word0 l i. +Proof. + intros H1 H2. + rewrite subword_make_vec_full. + all: try lia. + { rewrite modnMl mulnK. + 2: { unfold nat_of_wsize; lia. } + apply subword_u. } + rewrite modnMl. unfold nat_of_wsize. lia. +Qed. + +Lemma make_vec_ws ws (l : seq (word ws)) : + make_vec ws l = nth word0 l 0. +Proof. + apply/eqP. apply/eq_from_wbit. + intros [i]. + rewrite wbit_make_vec=>/=. + 2: unfold nat_of_wsize in *; lia. + rewrite divn_small. + 2: unfold nat_of_wsize in *; lia. + rewrite modn_small. + 2: unfold nat_of_wsize in *; lia. + reflexivity. +Qed. + +Lemma make_vec_single {ws1} ws2 (a : word ws1) : + make_vec ws2 [:: a] = zero_extend ws2 a. +Proof. + unfold make_vec. cbn -[Z.of_nat]. + by rewrite Z.shiftl_0_l Z.lor_0_r. +Qed. + +Lemma wshr_word0 {ws} i : @wshr ws 0 i = word0. +Proof. + unfold wshr. by rewrite lsr_word0. +Qed. + +Lemma nth_split_vec {ws1} ws2 n (d : word ws2) (w : word ws1) : + (n < ws1 %/ ws2 + ws1 %% ws2)%nat -> + nth d (split_vec ws2 w) n = subword (n * ws2) ws2 w. +Proof. + intros H. + unfold split_vec. + erewrite nth_map. + 1: f_equal; rewrite nth_iota; try lia. + rewrite size_iota. + assumption. + Unshelve. exact 0%nat. +Qed. + +From Jasmin Require Import waes utils xseq. + +Lemma subword_U8_SubWord n w : + (0 <= n < 4)%nat -> + subword (n * U8) U8 (SubWord w) = Sbox (subword (n * U8) U8 w). +Proof. + intros. + unfold SubWord. + rewrite subword_make_vec. + 1: erewrite nth_map; f_equal. + all: try (unfold nat_of_wsize, wsize_size_minus_1; zify; simpl; lia). + apply nth_split_vec. + cbn. lia. + Unshelve. exact word0. +Qed. + +Lemma split_vec_make_vec {ws1} (ws2 : wsize.wsize) (l : seq (word.word ws1)) : + (ws2 %% ws1 = 0)%nat -> + (size l = ws2 %/ ws1)%nat -> + split_vec ws1 (make_vec ws2 l) = l. +Proof. + destruct l. + - intros . + unfold make_vec, split_vec. + rewrite -H0 H. + reflexivity. + - intros Hmod Hsize. + unfold split_vec. + rewrite <- take_size. + erewrite <- map_nth_iota0. + 2: easy. + rewrite Hsize Hmod addn0. + apply map_ext. + intros. + apply subword_make_vec. + 1: simpl in Hsize; nia. + move: H => /InP. rewrite mem_iota. + nia. +Qed. + +Lemma SubWord_make_vec l : + (size l = 4)%nat -> + SubWord (make_vec U32 l) = make_vec U32 [seq Sbox i | i <- l]. +Proof. + intros. + unfold SubWord. + rewrite split_vec_make_vec. + all: unfold nat_of_wsize, wsize_size_minus_1; easy. +Qed. + +Lemma subword_make_vec_32_0_32_128 (l : seq u32) : subword 0 U32 (make_vec U128 l) = nth word0 l 0. +Proof. + rewrite subword_make_vec_full; rewrite ?subword_u. + all: auto. +Qed. + +Lemma subword_make_vec_32_1_32_128 (l : seq u32) : subword U32 U32 (make_vec U128 l) = nth word0 l 1. +Proof. + rewrite subword_make_vec_full; rewrite ?subword_u. + all: auto. +Qed. + +Lemma subword_make_vec_32_2_32_128 (l : seq u32) : subword (2 * U32) U32 (make_vec U128 l) = nth word0 l 2. +Proof. + rewrite subword_make_vec_full; rewrite ?subword_u. + all: auto. +Qed. + +Lemma subword_make_vec_32_3_32_128 (l : seq u32) : subword (3 * U32) U32 (make_vec U128 l) = nth word0 l 3. +Proof. + rewrite subword_make_vec_full; rewrite ?subword_u. + all: auto. +Qed. + +Lemma wbit_wror {ws} (a : word ws) n m : wbit_n (wror a n) m = wbit_n a (Z.to_nat (((Z.of_nat m) - n) mod (wsize_bits ws)))%Z. +Proof. + unfold wror. + (* rewrite urepr_word. *) + (* wbit_n *) + rewrite worE. + rewrite wshrE. + rewrite wshlE. + destruct ((Z.to_nat (wsize_bits ws - n mod wsize_bits ws) <= m <= wsize_size_minus_1 ws))%nat eqn:E. + { cbn -[Z.sub]. + rewrite Nat2Z.inj_add. + (* rewrite Z2Nat.inj_add. *) + rewrite Z2Nat.id. + 2: admit. admit. } +Admitted. + +Lemma wror_substitute w k : wror (SubWord w) k = SubWord (wror w k). +Proof. + unfold SubWord. + unfold wror. + (* I would like to case on w, but not sure how to do this most efficiently? *) +Admitted. + +Lemma wreprI ws (a : word.word ws) : wrepr ws (toword a) = a. +Proof. + apply val_inj. simpl. destruct a. rewrite Z.mod_small. 1: reflexivity. + simpl in *. lia. +Qed. + +(** AES *) + +Lemma ShiftRows_SubBytes s : ShiftRows (SubBytes s) = SubBytes (ShiftRows s). +Proof. + unfold ShiftRows, SubBytes. simpl. + f_equal. f_equal. + all: rewrite !subword_make_vec_32_0_32_128 !subword_make_vec_32_1_32_128 !subword_make_vec_32_2_32_128 !subword_make_vec_32_3_32_128; simpl; + rewrite -> !subword_U8_SubWord by lia; + rewrite -> !SubWord_make_vec by reflexivity; reflexivity. +Qed. + +Lemma wAESENC_wAESENC_ s k : wAESENC s k = wAESENC_ s k. +Proof. + unfold wAESENC, wAESENC_. + f_equal. f_equal. + rewrite ShiftRows_SubBytes. + reflexivity. +Qed. + +(* NOTE: This is only so simple because InvMixColumns is not properly implemented *) +Lemma AESDEC_AESDEC_ s k : wAESDEC s (InvMixColumns k) = wAESDEC_ s k. +Proof. + unfold wAESDEC, wAESDEC_. + unfold InvMixColumns. + reflexivity. +Qed. + +Lemma wAESENCLAST_wAESENCLAST_ s k : wAESENCLAST s k = wAESENCLAST_ s k. +Proof. + unfold wAESENCLAST, wAESENCLAST_. + rewrite ShiftRows_SubBytes. + reflexivity. +Qed. From e455fa69c6d7c096fab458fe442c55f4de690d20 Mon Sep 17 00:00:00 2001 From: bshvass Date: Fri, 23 Dec 2022 08:55:27 +0100 Subject: [PATCH 338/383] remove unused definitions --- theories/Jasmin/examples/aes/aes_prf.v | 23 ++--------------------- 1 file changed, 2 insertions(+), 21 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes_prf.v b/theories/Jasmin/examples/aes/aes_prf.v index 22f4aef7..7dab9be9 100644 --- a/theories/Jasmin/examples/aes/aes_prf.v +++ b/theories/Jasmin/examples/aes/aes_prf.v @@ -69,18 +69,13 @@ Section PRF_example. #[local] Open Scope package_scope. Definition key_location : Location := ('option key ; 0). - Definition plain_location : Location := ( pt ; 1). - Definition cipher_location : Location := ( ct ; 2). + Definition i0 : nat := 3. Definition i1 : nat := 4. - Definition i2 : nat := 5. - Definition salt_location : Location := ('nat ; 6). + Definition table_location : Location := (chMap 'nat ('word n) ; 7). - Definition rel_loc : {fset Location} := - fset [:: key_location ; table_location ]. - Definition enc (m : pt) (k : key) : code fset0 [interface] ('word n) := {code @@ -103,10 +98,6 @@ Section PRF_example. end }. - Definition dec (c : 'word n) (k : 'word n) : - code fset0 [interface] ('word n) := - enc k c. - Definition EVAL_location_tt := (fset [:: key_location]). Definition EVAL_location_ff := (fset [:: table_location]). @@ -354,16 +345,6 @@ Section JasminPRF. Notation kgen := (kgen U128). Notation key_location := (key_location U128). - Definition ltup2 (l : tchlist) := - match l with - | [::] => (word0, word0) - | a1 :: l1 => - match l with - | [::] => (word0, word0) - | a2 :: l2 => (coerce_to_choice_type ('word n) a1.π2, coerce_to_choice_type ('word n) a2.π2) - end - end. - Definition Cenc (m : pt) (k : key) : code (fset [:: state ; rkeys]) [interface] ('word n). Proof. From 16f71545c8be42ac8fca0e21bb283f15dadcbbd2 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Mon, 2 Jan 2023 13:51:01 +0100 Subject: [PATCH 339/383] Apply subproof, instead of repeating it --- theories/Jasmin/examples/aes/aes_hac.v | 296 ++++++++++++++++--------- 1 file changed, 194 insertions(+), 102 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes_hac.v b/theories/Jasmin/examples/aes/aes_hac.v index b4a55f14..2a2eea50 100644 --- a/theories/Jasmin/examples/aes/aes_hac.v +++ b/theories/Jasmin/examples/aes/aes_hac.v @@ -31,6 +31,8 @@ Open Scope hacspec_scope. Notation call fn := (translate_call _ fn _). +#[global] Hint Resolve preceq_I preceq_O preceq_refl : preceq. + Section Hacspec. (* NB: this redefines neq_loc_auto, which helps some tactics, since checking for inequality by computation is not feasible for translated variables *) @@ -551,15 +553,21 @@ Section Hacspec. reflexivity. Qed. - Lemma key_combined_eq id0 rcon rkey temp2 : - ⊢ ⦃ fun '(_, _) => True ⦄ + Definition pdisj (P : precond) (s_id : p_id) (rhs : {fset Location}) := + (forall h1 h2 l a v s_id', l = translate_var s_id' v -> (s_id ⪯ s_id') -> (P (h1, h2) -> P (set_heap h1 l a, h2))) /\ + (forall h1 h2 l a, l \in rhs -> (P (h1, h2) -> P (h1, set_heap h2 l a))). + + Lemma key_combined_eq id0 rcon rkey temp2 (pre : precond) : + (pdisj pre id0 fset0) -> + ⊢ ⦃ pre ⦄ JKEY_COMBINE id0 rcon rkey temp2 ≈ is_state (key_combine rcon rkey temp2) - ⦃ fun '(v0, _) '(v1, _) => - exists o1 o2, v0 = [('word U128 ; o1) ; ('word U128 ; o2)] - /\ (o1, o2) = v1 ⦄. + ⦃ fun '(v0, h0) '(v1, h1) => + (exists o1 o2, v0 = [('word U128 ; o1) ; ('word U128 ; o2)] + /\ (o1, o2) = v1) /\ pre (h0, h1) ⦄. Proof. + intros H_pdisj. set (JKEY_COMBINE _ _ _ _). unfold translate_call, translate_call_body in r |- *. Opaque translate_call. @@ -581,13 +589,21 @@ Section Hacspec. apply better_r_put_lhs ; do 2 remove_get_in_lhs ; apply r_ret. intros. - destruct_pre. - eexists. - eexists. - split ; [ reflexivity | ]. - cbn. - rewrite !zero_extend_u. - reflexivity. + split. + { + destruct_pre. + eexists. + eexists. + split ; [ reflexivity | ]. + cbn. + rewrite !zero_extend_u. + reflexivity. + } + { + destruct_pre. + destruct H_pdisj. + repeat eapply H ; try easy. + } Unshelve. { @@ -811,6 +827,7 @@ Section Hacspec. Transparent translate_call. Qed. + Ltac bind_jazz_bind := match goal with | [ |- context [ ⊢ ⦃ ?P ⦄ putr ?l ?y ?g ≈ bind ?a ?f ⦃ ?Q ⦄ ] ] => @@ -827,15 +844,64 @@ Section Hacspec. ; subst yv gv av fv ; hnf end. - Lemma key_expand_eq id0 rcon rkey temp2 : - ⊢ ⦃ fun '(_, _) => True ⦄ + Ltac solve_in := + repeat match goal with + | |- is_true (?v \in fset1 ?v :|: _) => apply/fsetU1P; left; auto + | |- is_true (_ \in fsetU _ _) => apply/fsetU1P; right + end. + + Ltac pdisj_apply h := + lazymatch goal with + | |- ?pre (set_heap _ _ _, set_heap _ _ _) => eapply h; [ solve_in | pdisj_apply h ] + | |- ?pre (set_heap _ _ _, _) => + eapply h ; [ reflexivity | auto with preceq | pdisj_apply h ] + | |- _ => try assumption + end. + + Theorem rpre_hypothesis_rule' : + ∀ {A₀ A₁ : _} {p₀ : raw_code A₀} {p₁ : raw_code A₁} + (pre : precond) post, + (∀ s₀ s₁, + pre (s₀, s₁) → ⊢ ⦃ λ '(s₀', s₁'), s₀' = s₀ ∧ s₁' = s₁ ⦄ p₀ ≈ p₁ ⦃ post ⦄ + ) → + ⊢ ⦃ pre ⦄ p₀ ≈ p₁ ⦃ post ⦄. + Proof. + intros A₀ A₁ p₀ p₁ pre post h. + eapply rpre_hypothesis_rule. + intros s0 s1 H. eapply rpre_weaken_rule. + eapply h. + eassumption. + easy. + Qed. + + Theorem rpre_weak_hypothesis_rule' : + ∀ {A₀ A₁ : _} {p₀ : raw_code A₀} {p₁ : raw_code A₁} + (pre : precond) post, + (∀ s₀ s₁, + pre (s₀, s₁) → ⊢ ⦃ λ '(s0, s1), pre (s0, s1) ⦄ p₀ ≈ p₁ ⦃ post ⦄ + ) → + ⊢ ⦃ pre ⦄ p₀ ≈ p₁ ⦃ post ⦄. + Proof. + intros A₀ A₁ p₀ p₁ pre post h. + eapply rpre_hypothesis_rule'. + intros. eapply rpre_weaken_rule. + eapply h. eassumption. + intros s0' s1' [H0 H1]. + subst. + assumption. + Qed. + + Lemma key_expand_eq id0 rcon rkey temp2 (pre : precond) : + (pdisj pre id0 fset0) -> + ⊢ ⦃ pre ⦄ JKEY_EXPAND id0 rcon rkey temp2 ≈ key_expand (wrepr U8 rcon) rkey temp2 - ⦃ fun '(v0, _) '(v1, _) => - exists o1 o2, v0 = [('word U128 ; o1) ; ('word U128 ; o2)] - /\ (o1, o2) = v1 ⦄. + ⦃ fun '(v0, h0) '(v1, h1) => + (exists o1 o2, v0 = [('word U128 ; o1) ; ('word U128 ; o2)] + /\ (o1, o2) = v1) /\ pre (h0, h1) ⦄. Proof. + intros H_pdisj. set (JKEY_EXPAND _ _ _ _). unfold translate_call, translate_call_body in r |- *. Opaque translate_call. @@ -846,115 +912,141 @@ Section Hacspec. apply better_r_put_lhs. apply better_r_put_lhs. apply better_r_put_lhs. - + do 2 remove_get_in_lhs. bind_jazz_hac ; [shelve | ]. + + eapply rpre_weak_hypothesis_rule'. + intros ? ? [? H]. + (* set (set_lhs _ _ _) in H. *) + (* apply rpre_weaken_rule with (pre := λ s : heap * heap, s.1 = s₀ ∧ s.2 = s₁ /\ p s). *) + (* } *) + + + (* apply H. *) + (* s.1 = s₀ ∧ s.2 = s₁ /\ set_lhs ($$"temp2.317") temp2 *) + (* (set_lhs ($$"rkey.316") rkey *) + (* (set_lhs ($$"rcon.315") (coe_cht 'int (coe_cht 'int rcon)) pre)) *) + (* (s₀, s₁)). *) + apply better_r_put_lhs. do 3 remove_get_in_lhs. - (* Unfold next call *) - Transparent translate_call. + rewrite bind_assoc. + rewrite bind_assoc. match goal with - | [ |- context [ ⊢ ⦃ ?P ⦄ ?s ≈ _ ⦃ ?Q ⦄ ] ] => - let H := fresh in - set (H := s) - ; unfold translate_call, translate_call_body in H - ; simpl in H - ; unfold tr_app_sopn, sopn_sem, tr_app_sopn_tuple, tr_app_sopn_single in H - ; simpl in H - ; subst H - ; rewrite !zero_extend_u + | [ |- context [ ⊢ ⦃ ?pre ⦄ _ ≈ _ ⦃ _ ⦄ ] ] => set (P := pre) end. - Opaque translate_call. + apply r_bind with (mid := λ '(v0, h0) '(v1, h1), + (∃ o1 o2 : 'word U128, + v0 = [('word U128; o1); ('word U128; o2)] ∧ (o1, o2) = v1) /\ P (h0, h1)). + 2:{ + intros. + subst P. + destruct a₁0. + destruct a₀0 as [ | ? [] ] ; simpl ; repeat apply better_r_put_lhs ; repeat remove_get_in_lhs ; apply r_ret ; intros ; destruct_pre ; try easy. + split. + eexists. + eexists. + split. + reflexivity. + (* reflexivity. *) + inversion H25. + subst. + inversion H24. + subst. + cbn. + now rewrite !zero_extend_u. - apply better_r_put_lhs. - apply better_r_put_lhs. - apply better_r_put_lhs. + (* do 2 (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). *) - remove_get_in_lhs. - unfold key_combine. + (* CAN BE DONE WITH: pdisj_apply H_pdisj. *) + destruct H_pdisj. + repeat eapply H ; easy. + } - rewrite !zero_extend_u. + subst. + subst P. - setoid_rewrite bind_assoc ; bind_jazz_bind ; [shelve | ]. - apply better_r_put_lhs. - do 2 remove_get_in_lhs. - rewrite !zero_extend_u. + (* eapply rpre_hypothesis_rule. *) + (* intros ? ? [? [[]]]. *) + (* subst. *) + (* (* apply rpre_weaken_rule with (pre := pre). *) *) - setoid_rewrite bind_assoc ; bind_jazz_bind ; [shelve | ]. - apply better_r_put_lhs. - do 2 remove_get_in_lhs. - rewrite !zero_extend_u. + (* 2:{ *) + (* intros ? ? []. *) + (* destruct_pre. *) + (* destruct H_pdisj. *) + (* eapply H; try easy. *) + (* eapply H; try easy. *) + (* eapply H; try easy. *) + (* eapply H; try easy. *) + (* } *) - setoid_rewrite bind_assoc ; bind_jazz_bind ; [shelve | ]. - apply better_r_put_lhs. - do 2 remove_get_in_lhs. - rewrite !zero_extend_u. + (* (* eapply rpost_weaken_rule. *) *) - setoid_rewrite bind_assoc ; bind_jazz_bind ; [shelve | ]. - apply better_r_put_lhs. - do 2 remove_get_in_lhs. - rewrite !zero_extend_u. + intros. + apply (key_combined_eq (id0~1)%positive rkey a₁ temp2). - setoid_rewrite bind_assoc ; bind_jazz_bind ; [shelve | ]. - apply better_r_put_lhs. - do 2 remove_get_in_lhs. - rewrite !zero_extend_u. + (* Unset Printing Notations. *) - setoid_rewrite bind_assoc ; bind_jazz_bind ; [shelve | ]. - apply better_r_put_lhs. - do 2 remove_get_in_lhs. - rewrite !zero_extend_u. - apply better_r_put_lhs. - apply better_r_put_lhs. - do 2 remove_get_in_lhs. + (* eapply H_pdisj. *) - apply r_ret. - intros. - eexists. - eexists. + (* destruct H_pdisj. *) split. - reflexivity. - simpl. - rewrite !T_ct_id. - rewrite !zero_extend_u. - reflexivity. + - intros. + subst. + repeat destruct H. + subst. + cbn in H2. + subst. + unfold set_lhs. - Unshelve. - { - (* Keygen assist *) + (* exists (set_heap x0 (translate_var id0~1 v) a). *) + subst. + (* inversion H3. *) + (* subst. *) + (* exists (set_heap x0 (translate_var id0~1 v) a). *) + (* rewrite set_heap_contract. *) + destruct_pre. + repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). + eexists. + split. + split. + reflexivity. + eexists. + split. + eexists. + split. + exists (set_heap H9 (translate_var s_id' v) a). + (* eexists. *) + split. + (* apply H10. *) + eapply H_pdisj. + reflexivity. + etransitivity. + apply fresh2_weak. + assumption. + assumption. + reflexivity. + reflexivity. + reflexivity. + + rewrite ![set_heap _ (translate_var s_id' v) a]set_heap_commut. + reflexivity. admit. - } - { - (* wpshufd_128 _ 255 *) + admit. + admit. + admit. + - intros. + subst. + discriminate. - replace (wpack U8 2 _) with (wrepr U8 255%Z) by now repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). - apply (@wpshufd_128_eq_state _ a₁ 255). - } + Unshelve. { - (* wshufps_128 _ 16 *) - replace (wpack U8 2 _) with (wrepr U8 16%Z) by now repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). - - rewrite <- bind_ret. - set (ret _). - pattern (wshufps_128 (wrepr U8 16) temp2 rkey) in r. - subst r. - eapply (@r_bind _ _ _ _ (ret (wshufps_128 (wrepr U8 16) temp2 rkey))). - apply (@wshufps_128_eq_state _ temp2 rkey 16). - - intros. - apply r_ret. - intros ? ? []. - subst. - (* This seems wrong? *) + (* Keygen assist *) admit. } - { - (* xor *) - apply r_ret. - solve_post_from_pre. - } - Transparent translate_call. Admitted. From db77f8f2e00e1d07401661023c5664d32657b1a6 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Wed, 4 Jan 2023 15:33:21 +0100 Subject: [PATCH 340/383] Subword and sbox proven --- theories/Jasmin/examples/aes/aes_hac.v | 996 +++++++++++++++++++------ 1 file changed, 751 insertions(+), 245 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes_hac.v b/theories/Jasmin/examples/aes/aes_hac.v index 2a2eea50..9daf6ecc 100644 --- a/theories/Jasmin/examples/aes/aes_hac.v +++ b/theories/Jasmin/examples/aes/aes_hac.v @@ -1,7 +1,7 @@ Set Warnings "-notation-overridden,-ambiguous-paths". From mathcomp Require Import all_ssreflect all_algebra reals distr realsum - fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool - ssrnum eqtype choice seq. + fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool + ssrnum eqtype choice seq. Set Warnings "notation-overridden,ambiguous-paths". Require Import List. @@ -26,13 +26,16 @@ From JasminSSProve Require Import aes_jazz jasmin_utils. Import JasminNotation JasminCodeNotation. Import PackageNotation. -From Hacspec Require Import Hacspec_Aes_Jazz ChoiceEquality Hacspec_Lib. +From Hacspec Require Import Hacspec_Aes_Jazz ChoiceEquality Hacspec_Lib Hacspec_Lib_Pre. Open Scope hacspec_scope. Notation call fn := (translate_call _ fn _). #[global] Hint Resolve preceq_I preceq_O preceq_refl : preceq. +From Hacspec Require Import Hacspec_Lib. + + Section Hacspec. (* NB: this redefines neq_loc_auto, which helps some tactics, since checking for inequality by computation is not feasible for translated variables *) @@ -149,6 +152,7 @@ Section Hacspec. cbn. lia. cbn. lia. Qed. + Theorem shiftl_bounds : forall x y z, (le y z) -> (0 <= x < modulus (z - y))%Z -> @@ -180,6 +184,21 @@ Section Hacspec. lia. Qed. + Theorem shiftr_smaller : forall x y n, + (0 <= y)%Z -> + (0 <= x < modulus (n + Z.to_nat y))%Z -> + Z.shiftr x y = (Z.shiftr x y mod modulus n)%Z. + Proof. + intros. + rewrite Zmod_small. + 2:{ + apply shiftr_bounds. + - apply H. + - apply H0. + } + reflexivity. + Qed. + Notation JVSHUFPS i rkey temp1 temp2 := (trc VSHUFPS i [('word U128 ; rkey) ; ('word U128 ; temp1) ; ('word U128 ; temp2)]). Lemma wpshufd1_eq : @@ -189,147 +208,147 @@ Section Hacspec. wpshufd1 rkey (wrepr U8 n) i = is_pure (vpshufd1 rkey (Hacspec_Lib_Pre.repr n) (Hacspec_Lib_Pre.repr i)). Proof. - Opaque Z.mul. - clear. - intros. - unfold vpshufd1. - unfold wpshufd1. - simpl. - apply word_ext. - f_equal. - simpl. - rewrite Zmod_mod. - unfold Hacspec_Lib_Pre.shift_right_, wshr, lsr, Hacspec_Lib_Pre.unsigned, wunsigned ; rewrite mkwordK. - f_equal. - f_equal. - f_equal. - f_equal. - unfold Hacspec_Lib_Pre.repr. - unfold wrepr. - unfold toword at 1, mkword at 2. - unfold Hacspec_Lib_Pre.from_uint_size, Hacspec_Lib_Pre.Z_uint_sizeable, Hacspec_Lib_Pre.unsigned, wunsigned. - unfold Hacspec_Lib_Pre.int_mul, mul_word. - unfold Hacspec_Lib_Pre.usize_shift_right. - unfold wshr. - unfold lsr. - rewrite !mkwordK. - rewrite <- Zmult_mod. - setoid_rewrite Zmod_mod. - rewrite <- Zmult_mod. - rewrite Z2Nat.id ; [ | destruct i as [ | [ | [ | [] ]]] ; try easy ]. - rewrite (Zmod_small _ (modulus nat127.+1)). - 2:{ - cbn. - rewrite Zmod_small. - 2:{ - replace (4 mod modulus nat31.+1)%Z with (modulus 2) by reflexivity. - split. - - apply Z.mul_nonneg_nonneg ; [ easy | ]. - apply (ssrbool.elimT (iswordZP _ _) (mkword_proof _ _)). - - replace (modulus nat31.+1) with (32 * modulus (32 - 5))%Z by reflexivity. - rewrite <- (Z.mul_lt_mono_pos_l) ; [ | easy]. - eapply Z.lt_trans ; [ apply (ssrbool.elimT (iswordZP _ _) (mkword_proof _ _)) ; easy | easy ]. - } - { - replace (4 mod modulus nat31.+1)%Z with (modulus 2) by reflexivity. - split. - - apply Z.mul_nonneg_nonneg ; [ easy | ]. - apply (ssrbool.elimT (iswordZP _ _) (mkword_proof _ _)). - - replace (modulus nat127.+1) with (32 * modulus (128 - 5))%Z by reflexivity. - rewrite <- (Z.mul_lt_mono_pos_l) ; [ | easy]. - eapply Z.lt_trans ; [ apply (ssrbool.elimT (iswordZP _ _) (mkword_proof _ _)) ; easy | easy ]. - } - } - - symmetry. - replace ((2 * Z.of_nat i) mod modulus U32)%Z with (2 * Z.of_nat i)%Z by by (destruct i as [ | [ | [ | [] ]]] ; easy). + Opaque Z.mul. + clear. + intros. + unfold vpshufd1. + unfold wpshufd1. + simpl. + apply word_ext. + f_equal. + simpl. + rewrite Zmod_mod. + unfold Hacspec_Lib_Pre.shift_right_, wshr, lsr, Hacspec_Lib_Pre.unsigned, wunsigned ; rewrite mkwordK. + f_equal. + f_equal. + f_equal. + f_equal. + unfold Hacspec_Lib_Pre.repr. + unfold wrepr. + unfold toword at 1, mkword at 2. + unfold Hacspec_Lib_Pre.from_uint_size, Hacspec_Lib_Pre.Z_uint_sizeable, Hacspec_Lib_Pre.unsigned, wunsigned. + unfold Hacspec_Lib_Pre.int_mul, mul_word. + unfold Hacspec_Lib_Pre.usize_shift_right. + unfold wshr. + unfold lsr. + rewrite !mkwordK. + rewrite <- Zmult_mod. + setoid_rewrite Zmod_mod. + rewrite <- Zmult_mod. + rewrite Z2Nat.id ; [ | destruct i as [ | [ | [ | [] ]]] ; try easy ]. + rewrite (Zmod_small _ (modulus nat127.+1)). + 2:{ + cbn. rewrite Zmod_small. 2:{ - cbn. replace (4 mod modulus nat31.+1)%Z with (modulus 2) by reflexivity. split. - - apply Z.mul_nonneg_nonneg ; [ easy | ]. - apply Z_mod_nonneg_nonneg ; [ | easy ]. - apply Z_mod_nonneg_nonneg ; [ | easy ]. - apply Z.shiftr_nonneg. - apply Z_mod_nonneg_nonneg ; [ | easy ]. - apply Z_mod_nonneg_nonneg ; [ | easy ]. - lia. - - replace (modulus nat31.+1)%Z with (32 * modulus (32 - 5))%Z at 3 by reflexivity. - apply Z.mul_lt_mono_pos_l ; [ easy | ]. - eapply Z.lt_trans. - apply Z.mod_pos_bound. - easy. - easy. + - apply Z.mul_nonneg_nonneg ; [ easy | ]. + apply (ssrbool.elimT (iswordZP _ _) (mkword_proof _ _)). + - replace (modulus nat31.+1) with (32 * modulus (32 - 5))%Z by reflexivity. + rewrite <- (Z.mul_lt_mono_pos_l) ; [ | easy]. + eapply Z.lt_trans ; [ apply (ssrbool.elimT (iswordZP _ _) (mkword_proof _ _)) ; easy | easy ]. + } + { + replace (4 mod modulus nat31.+1)%Z with (modulus 2) by reflexivity. + split. + - apply Z.mul_nonneg_nonneg ; [ easy | ]. + apply (ssrbool.elimT (iswordZP _ _) (mkword_proof _ _)). + - replace (modulus nat127.+1) with (32 * modulus (128 - 5))%Z by reflexivity. + rewrite <- (Z.mul_lt_mono_pos_l) ; [ | easy]. + eapply Z.lt_trans ; [ apply (ssrbool.elimT (iswordZP _ _) (mkword_proof _ _)) ; easy | easy ]. } + } + symmetry. + replace ((2 * Z.of_nat i) mod modulus U32)%Z with (2 * Z.of_nat i)%Z by by (destruct i as [ | [ | [ | [] ]]] ; easy). + rewrite Zmod_small. + 2:{ cbn. - f_equal. - f_equal. + replace (4 mod modulus nat31.+1)%Z with (modulus 2) by reflexivity. + split. + - apply Z.mul_nonneg_nonneg ; [ easy | ]. + apply Z_mod_nonneg_nonneg ; [ | easy ]. + apply Z_mod_nonneg_nonneg ; [ | easy ]. + apply Z.shiftr_nonneg. + apply Z_mod_nonneg_nonneg ; [ | easy ]. + apply Z_mod_nonneg_nonneg ; [ | easy ]. + lia. + - replace (modulus nat31.+1)%Z with (32 * modulus (32 - 5))%Z at 3 by reflexivity. + apply Z.mul_lt_mono_pos_l ; [ easy | ]. + eapply Z.lt_trans. + apply Z.mod_pos_bound. + easy. + easy. + } + + cbn. + f_equal. + f_equal. + rewrite Zmod_small. + { + symmetry. rewrite Zmod_small. { symmetry. - rewrite Zmod_small. + f_equal. { - symmetry. - f_equal. - { - rewrite Zmod_small ; [ reflexivity | ]. - split ; [ apply Z_mod_nonneg_nonneg ; [ lia | easy ] | ]. - eapply Z.lt_trans. - apply Z.mod_pos_bound. - destruct i as [ | [ | [ | [] ]]] ; easy. - easy. - } + rewrite Zmod_small ; [ reflexivity | ]. + split ; [ apply Z_mod_nonneg_nonneg ; [ lia | easy ] | ]. + eapply Z.lt_trans. + apply Z.mod_pos_bound. destruct i as [ | [ | [ | [] ]]] ; easy. + easy. } - apply shiftr_bounds. lia. - split. - apply Z_mod_nonneg_nonneg. - lia. - easy. - - eapply Z.lt_le_trans. - apply Z.mod_pos_bound. - destruct i as [ | [ | [ | [] ]]] ; easy. - rewrite modulusD. destruct i as [ | [ | [ | [] ]]] ; easy. } apply shiftr_bounds. lia. - rewrite Zmod_small. - { - split. - apply Z_mod_nonneg_nonneg. - lia. - easy. + split. + apply Z_mod_nonneg_nonneg. + lia. + easy. - eapply Z.lt_le_trans. - apply Z.mod_pos_bound. - destruct i as [ | [ | [ | [] ]]] ; easy. - destruct i as [ | [ | [ | [] ]]] ; easy. - } - { - split. - apply Z_mod_nonneg_nonneg. - lia. - easy. + eapply Z.lt_le_trans. + apply Z.mod_pos_bound. + destruct i as [ | [ | [ | [] ]]] ; easy. + rewrite modulusD. + destruct i as [ | [ | [ | [] ]]] ; easy. + } + apply shiftr_bounds. lia. + rewrite Zmod_small. + { + split. + apply Z_mod_nonneg_nonneg. + lia. + easy. - eapply Z.lt_le_trans. - apply Z.mod_pos_bound. - destruct i as [ | [ | [ | [] ]]] ; easy. - destruct i as [ | [ | [ | [] ]]] ; easy. - } - Transparent Z.mul. - Transparent Nat.mul. + eapply Z.lt_le_trans. + apply Z.mod_pos_bound. + destruct i as [ | [ | [ | [] ]]] ; easy. + destruct i as [ | [ | [ | [] ]]] ; easy. + } + { + split. + apply Z_mod_nonneg_nonneg. + lia. + easy. + + eapply Z.lt_le_trans. + apply Z.mod_pos_bound. + destruct i as [ | [ | [ | [] ]]] ; easy. + destruct i as [ | [ | [ | [] ]]] ; easy. + } + Transparent Z.mul. + Transparent Nat.mul. Qed. Lemma wpshufd1_eq_state : forall {H} (rkey : 'word U128) (i n : nat), i < 4 -> -⊢ ⦃ H ⦄ - ret (wpshufd1 rkey (wrepr U8 n) i) ≈ - is_state (vpshufd1 rkey (Hacspec_Lib_Pre.repr n) (Hacspec_Lib_Pre.repr i)) - ⦃ λ '(v0, h0) '(v1, h1), v0 = v1 ∧ H (h0, h1) ⦄. + ⊢ ⦃ H ⦄ + ret (wpshufd1 rkey (wrepr U8 n) i) ≈ + is_state (vpshufd1 rkey (Hacspec_Lib_Pre.repr n) (Hacspec_Lib_Pre.repr i)) + ⦃ λ '(v0, h0) '(v1, h1), v0 = v1 ∧ H (h0, h1) ⦄. Proof. intros. rewrite (wpshufd1_eq _ i n) ; [ | apply H0 ]. @@ -364,8 +383,8 @@ Section Hacspec. clear. destruct a. unfold wunsigned, urepr, val, word_subType, word.toword. - split. apply Z.shiftl_nonneg. lia. apply (ssrbool.elimT (iswordZP _ _)) in i0. + split. apply Z.shiftl_nonneg. lia. destruct i0. rewrite Z.shiftl_mul_pow2 ; [ | lia]. eapply Z.lt_le_trans. @@ -376,15 +395,15 @@ Section Hacspec. Lemma num_smaller_if_modulus_lte : (forall {WS} (x : 'word WS) z, (modulus WS <= z)%Z -> (0 <= x < z)%Z). Proof. - clear. - cbn. - intros. - destruct x. - pose (ssrbool.elimT (iswordZP _ _) i). - split. easy. - unfold word.toword. - destruct a. - eapply Z.lt_le_trans ; [ apply H1 | apply H]. + clear. + cbn. + intros. + destruct x. + pose (ssrbool.elimT (iswordZP _ _) i). + split. easy. + unfold word.toword. + destruct a. + eapply Z.lt_le_trans ; [ apply H1 | apply H]. Qed. Lemma Z_lor_pow2 : (forall (x y : Z) (k : nat), (0 <= x < 2 ^ k)%Z -> (0 <= y < 2 ^ k)%Z -> (0 <= Z.lor x y < 2 ^ k)%Z). @@ -412,9 +431,9 @@ Section Hacspec. Lemma wpshufd_128_eq_state : forall {H} (rkey : 'word U128) (n : nat), ⊢ ⦃ H ⦄ - ret (wpshufd_128 rkey n) ≈ - is_state (vpshufd rkey (Hacspec_Lib_Pre.repr n)) - ⦃ λ '(v0, h0) '(v1, h1), v0 = v1 ∧ H (h0, h1) ⦄. + ret (wpshufd_128 rkey n) ≈ + is_state (vpshufd rkey (Hacspec_Lib_Pre.repr n)) + ⦃ λ '(v0, h0) '(v1, h1), v0 = v1 ∧ H (h0, h1) ⦄. Proof. intros. unfold wpshufd_128. @@ -489,9 +508,9 @@ Section Hacspec. Lemma wshufps_128_eq_state : forall {H} (a b : 'word U128) (n : nat), ⊢ ⦃ H ⦄ - ret (wshufps_128 (wrepr U8 n) a b) ≈ - is_state (vshufps a b (Hacspec_Lib_Pre.repr n)) - ⦃ λ '(v0, h0) '(v1, h1), v0 = v1 ∧ H (h0, h1) ⦄. + ret (wshufps_128 (wrepr U8 n) a b) ≈ + is_state (vshufps a b (Hacspec_Lib_Pre.repr n)) + ⦃ λ '(v0, h0) '(v1, h1), v0 = v1 ∧ H (h0, h1) ⦄. Proof. intros. unfold wshufps_128. @@ -507,40 +526,40 @@ Section Hacspec. solve_wpshufd1_vpshufd1 1 n. solve_wpshufd1_vpshufd1 2 n. solve_wpshufd1_vpshufd1 3 n. - intros. - apply r_ret. - intros ? ? [? [? [? []]]]. - subst. - subst H4. - split ; [ clear | assumption ]. + intros. + apply r_ret. + intros ? ? [? [? [? []]]]. + subst. + subst H4. + split ; [ clear | assumption ]. - apply word_ext. + apply word_ext. - unfold wcat_r. + unfold wcat_r. - Opaque Z.shiftl. - simpl. - Transparent Z.shiftl. + Opaque Z.shiftl. + simpl. + Transparent Z.shiftl. - rewrite !mkwordK. + rewrite !mkwordK. - rewrite Zmod_small. - 2: { - rewrite !Z.shiftl_lor. - rewrite !Z.shiftl_mul_pow2 ; try easy. - rewrite !Z.mul_0_l. - rewrite Z.lor_0_r. - repeat apply (Z_lor_pow2 _ _ (32 + 32 + 32 + 32)) ; replace (2 ^ (int_to_Z (Posz(32 + 32 + 32 + 32))))%Z with (2 ^ 32 * 2 ^ 32 * 2 ^ 32 * 2 ^ 32)%Z by reflexivity. + rewrite Zmod_small. + 2: { + rewrite !Z.shiftl_lor. + rewrite !Z.shiftl_mul_pow2 ; try easy. + rewrite !Z.mul_0_l. + rewrite Z.lor_0_r. + repeat apply (Z_lor_pow2 _ _ (32 + 32 + 32 + 32)) ; replace (2 ^ (int_to_Z (Posz(32 + 32 + 32 + 32))))%Z with (2 ^ 32 * 2 ^ 32 * 2 ^ 32 * 2 ^ 32)%Z by reflexivity. all: split ; [ destruct a₁, a₁0, a₁1, a₁2 ; unfold urepr ; simpl ; apply (ssrbool.elimT (iswordZP _ _)) in i, i0, i1, i2 ; repeat (apply Z.lor_nonneg ; split ; [ repeat apply Z.mul_nonneg_nonneg ; easy | ]) ; repeat apply Z.mul_nonneg_nonneg ; easy | ]. all: repeat (apply -> (@Z.mul_lt_mono_pos_r (2 ^ 32)) ; [ | easy ]) ; apply (@num_smaller_if_modulus_lte U32) ; easy. - } + } - rewrite !Zmod_small. - all: try apply (@num_smaller_if_modulus_lte U32). - all: try easy. - 2: apply (shiftl_bounds _ 96 128) ; [ lia | cbn ; apply (@num_smaller_if_modulus_lte U32) ; easy ]. - 2: apply (shiftl_bounds _ 64 128) ; [ lia | cbn ; apply (@num_smaller_if_modulus_lte U32) ; easy ]. - 2: apply (shiftl_bounds _ 32 128) ; [ lia | cbn ; apply (@num_smaller_if_modulus_lte U32) ; easy ]. + rewrite !Zmod_small. + all: try apply (@num_smaller_if_modulus_lte U32). + all: try easy. + 2: apply (shiftl_bounds _ 96 128) ; [ lia | cbn ; apply (@num_smaller_if_modulus_lte U32) ; easy ]. + 2: apply (shiftl_bounds _ 64 128) ; [ lia | cbn ; apply (@num_smaller_if_modulus_lte U32) ; easy ]. + 2: apply (shiftl_bounds _ 32 128) ; [ lia | cbn ; apply (@num_smaller_if_modulus_lte U32) ; easy ]. rewrite !Z.shiftl_lor. rewrite !Z.shiftl_mul_pow2 ; try easy. @@ -555,7 +574,7 @@ Section Hacspec. Definition pdisj (P : precond) (s_id : p_id) (rhs : {fset Location}) := (forall h1 h2 l a v s_id', l = translate_var s_id' v -> (s_id ⪯ s_id') -> (P (h1, h2) -> P (set_heap h1 l a, h2))) /\ - (forall h1 h2 l a, l \in rhs -> (P (h1, h2) -> P (h1, set_heap h2 l a))). + (forall h1 h2 l a, l \in rhs -> (P (h1, h2) -> P (h1, set_heap h2 l a))). Lemma key_combined_eq id0 rcon rkey temp2 (pre : precond) : (pdisj pre id0 fset0) -> @@ -565,10 +584,13 @@ Section Hacspec. is_state (key_combine rcon rkey temp2) ⦃ fun '(v0, h0) '(v1, h1) => (exists o1 o2, v0 = [('word U128 ; o1) ; ('word U128 ; o2)] - /\ (o1, o2) = v1) /\ pre (h0, h1) ⦄. + /\ (o1, o2) = v1) /\ pre (h0, h1) ⦄. Proof. intros H_pdisj. set (JKEY_COMBINE _ _ _ _). + unfold JKEY_COMBINE in r. + unfold get_translated_static_fun in r. + simpl in r. unfold translate_call, translate_call_body in r |- *. Opaque translate_call. (* unfold ssprove_jasmin_prog in r. *) @@ -581,10 +603,8 @@ Section Hacspec. apply better_r_put_lhs. apply better_r_put_lhs. apply better_r_put_lhs. - remove_get_in_lhs. bind_jazz_hac ; [ shelve | ]. - do 5 (apply better_r_put_lhs ; do 2 remove_get_in_lhs ; bind_jazz_hac ; [shelve | ]). apply better_r_put_lhs ; do 2 remove_get_in_lhs ; apply r_ret. @@ -627,7 +647,6 @@ Section Hacspec. apply (wpshufd_128_eq_state rkey 255). } { - unfold tr_app_sopn_tuple. unfold sopn_sem. unfold sopn.get_instr_desc. @@ -827,7 +846,7 @@ Section Hacspec. Transparent translate_call. Qed. - + Ltac bind_jazz_bind := match goal with | [ |- context [ ⊢ ⦃ ?P ⦄ putr ?l ?y ?g ≈ bind ?a ?f ⦃ ?Q ⦄ ] ] => @@ -844,62 +863,525 @@ Section Hacspec. ; subst yv gv av fv ; hnf end. - Ltac solve_in := - repeat match goal with - | |- is_true (?v \in fset1 ?v :|: _) => apply/fsetU1P; left; auto - | |- is_true (_ \in fsetU _ _) => apply/fsetU1P; right - end. - - Ltac pdisj_apply h := - lazymatch goal with - | |- ?pre (set_heap _ _ _, set_heap _ _ _) => eapply h; [ solve_in | pdisj_apply h ] - | |- ?pre (set_heap _ _ _, _) => - eapply h ; [ reflexivity | auto with preceq | pdisj_apply h ] - | |- _ => try assumption - end. - - Theorem rpre_hypothesis_rule' : - ∀ {A₀ A₁ : _} {p₀ : raw_code A₀} {p₁ : raw_code A₁} - (pre : precond) post, - (∀ s₀ s₁, - pre (s₀, s₁) → ⊢ ⦃ λ '(s₀', s₁'), s₀' = s₀ ∧ s₁' = s₁ ⦄ p₀ ≈ p₁ ⦃ post ⦄ - ) → - ⊢ ⦃ pre ⦄ p₀ ≈ p₁ ⦃ post ⦄. - Proof. - intros A₀ A₁ p₀ p₁ pre post h. - eapply rpre_hypothesis_rule. - intros s0 s1 H. eapply rpre_weaken_rule. - eapply h. - eassumption. - easy. - Qed. + Ltac solve_in := + repeat match goal with + | |- is_true (?v \in fset1 ?v :|: _) => apply/fsetU1P; left; auto + | |- is_true (_ \in fsetU _ _) => apply/fsetU1P; right + end. + + Ltac pdisj_apply h := + lazymatch goal with + | |- ?pre (set_heap _ _ _, set_heap _ _ _) => eapply h; [ solve_in | pdisj_apply h ] + | |- ?pre (set_heap _ _ _, _) => + eapply h ; [ reflexivity | auto with preceq | pdisj_apply h ] + | |- _ => try assumption + end. + + Theorem rpre_hypothesis_rule' : + ∀ {A₀ A₁ : _} {p₀ : raw_code A₀} {p₁ : raw_code A₁} + (pre : precond) post, + (∀ s₀ s₁, + pre (s₀, s₁) → ⊢ ⦃ λ '(s₀', s₁'), s₀' = s₀ ∧ s₁' = s₁ ⦄ p₀ ≈ p₁ ⦃ post ⦄ + ) → + ⊢ ⦃ pre ⦄ p₀ ≈ p₁ ⦃ post ⦄. + Proof. + intros A₀ A₁ p₀ p₁ pre post h. + eapply rpre_hypothesis_rule. + intros s0 s1 H. eapply rpre_weaken_rule. + eapply h. + eassumption. + easy. + Qed. + + Theorem rpre_weak_hypothesis_rule' : + ∀ {A₀ A₁ : _} {p₀ : raw_code A₀} {p₁ : raw_code A₁} + (pre : precond) post, + (∀ s₀ s₁, + pre (s₀, s₁) → ⊢ ⦃ λ '(s0, s1), pre (s0, s1) ⦄ p₀ ≈ p₁ ⦃ post ⦄ + ) → + ⊢ ⦃ pre ⦄ p₀ ≈ p₁ ⦃ post ⦄. + Proof. + intros A₀ A₁ p₀ p₁ pre post h. + eapply rpre_hypothesis_rule'. + intros. eapply rpre_weaken_rule. + eapply h. eassumption. + intros s0' s1' [H0 H1]. + subst. + assumption. + Qed. + + Ltac match_pattern_and_bind p := + unfold let_both at 1, is_state at 1, prog ; + match goal with + | [ |- context [ ⊢ ⦃ ?P ⦄ ?x ≈ _ ⦃ ?Q ⦄ ] ] => + let Hx := fresh in + set (Hx := x) ; + pattern p in Hx ; + subst Hx ; + + (* Match bind and apply *) + match goal with + | [ |- context [ ⊢ ⦃ ?P ⦄ _ ≈ bind ?a ?f ⦃ ?Q ⦄ ] ] => + let av := fresh in + let fv := fresh in + set (av := a) + ; set (fv := f) + ; eapply (r_bind (ret p) av _ fv P (fun '(v0, h0) '(v1, h1) => v0 = _ v1 /\ P (h0, h1)) Q) (* (v0 = v1) *) + ; subst av fv ; hnf ; [ | intros ; apply rpre_hypothesis_rule' ; intros ? ? [] ; apply rpre_weaken_rule with (pre := fun '(s₀, s₁) => P (s₀, s₁)) + ] + end + end. + + Corollary better_r_put_rhs : forall {A B : choice.Choice.type} (ℓ : Location) + (v : choice.Choice.sort (Value (projT1 ℓ))) (r₀ : raw_code A) + (r₁ : raw_code B) (pre : precond) + (post : postcond (choice.Choice.sort A) (choice.Choice.sort B)), + ⊢ ⦃ set_rhs ℓ v pre ⦄ r₀ ≈ r₁ ⦃ post ⦄ -> + ⊢ ⦃ pre ⦄ r₀ ≈ #put ℓ := v ;; r₁ ⦃ post ⦄. + Proof. + intros. + eapply rpre_hypothesis_rule. + intros. + eapply rpre_weaken_rule. + apply r_put_rhs. + apply H. + intuition. + Unshelve. + subst. + intuition. + Qed. + + Check word.subword (1 * U32)%nat U32. + (* let x1 := subword (1 * U32) U32 v1 in *) + (* let x1 = (v1 >> 32) % (1_u128 << 32); *) + Lemma subword_eq (n : int128) (i : nat): + (i < 4) -> + word.subword (i * U32)%nat U32 n = + @repr U32 (unsigned (((lift_to_both0 n) shift_right (lift_to_both0 (usize (i * 32)))) .% (( + lift_to_both0 (@repr U128 1)) shift_left (lift_to_both0 (usize 32))))). + Proof. + intros. + apply word_ext. + simpl. + unfold Hacspec_Lib_Pre.int_mod. + replace (Hacspec_Lib_Pre.shift_left_ (repr 1) (repr 32)) with (@repr U128 (modulus 32)) by reflexivity. + setoid_rewrite wunsigned_repr. + replace (wunsigned (repr (modulus 32))) with (modulus 32) by reflexivity. + replace (modulus (wsize_size_minus_1 U128).+1) with (modulus 96 * modulus 32)%Z by reflexivity. + rewrite mod_pq_mod_q. + rewrite Zmod_mod. + f_equal. + do 4 (destruct i ; [easy | ]) ; easy. + easy. + easy. + Qed. + + Lemma nat_to_be_range_is_subword : forall {WS : wsize.wsize} {WS_inp : wsize.wsize} (n : @int WS_inp) i `{H_WS : WS <= WS_inp} , (@repr WS (nat_be_range WS (toword n) i) = word.subword (i * WS) WS n). + Proof. + intros. + apply word_ext. + cbn. + unfold nat_be_range. + replace (_ ^ WS)%Z with (modulus WS)%Z by (destruct WS ; reflexivity). + replace (modulus WS_inp) with (modulus (WS_inp - WS) * modulus WS)%Z by (destruct WS , WS_inp ; easy). + rewrite mod_pq_mod_q ; [ | easy | easy ]. + rewrite !Zmod_mod. + f_equal. + rewrite <- Z.shiftr_div_pow2 ; [ | lia ]. + rewrite Nat2Z.inj_mul. + f_equal. now zify. + Qed. + + (* Compute (U32 %/ U8 + U32 %% U8)%nat. *) + (* (* [seq subword (i * U8)%nat U8 n | i <- [0;1;2;3]] *) *) + + (* Compute @to_be_bytes'' U32 327. *) + + (* Compute (fun (k : Z) => *) + (* (map *) + (* (fun i : nat => nat_be_range' 8 k i) *) + (* (seq.iota 1 (nat_of_wsize U32 / 8)))) 65536. *) + + (* Goal forall i, (urepr (word.subword (i * U8)%nat (U8 / 2) (@repr U32 327))) = 255. *) + (* destruct i ; [ | destruct i ; [ | destruct i ; [ | destruct i ; [ | admit] ] ] ] ; cbn. *) + (* Admitted. *) + + (* intros. *) + (* unfold word.subword. *) + (* unfold urepr, val, word_subType, toword, mkword, lsr, mkword. *) + (* unfold repr, wrepr, mkword, urepr, val, word_subType, toword. *) + (* rewrite (Zmod_small 4294967295). *) + + (* Compute (Z.shiftr 4294967295 (1 * U8)%nat) mod modulus U8. *) + (* Check word.subword. *) + + Lemma sbox_eq : + (forall n i, (i < 4)%nat -> + @Hacspec_Lib_Pre.array_index int8 (@int_default U8) + (uint_size_to_nat + (Z_to_uint_size + (Z.modulo (Zpos (xO (xO (xO (xO (xO (xO (xO (xO xH))))))))) + (modulus (S nat31))))) sbox_v U8 + (@Hacspec_Lib_Pre.array_index int8 (@int_default U8) + (S (S (S (S O)))) + (Hacspec_Lib_Pre.u32_to_be_bytes n) U32 + (@repr U32 i)) = waes.Sbox (word.subword (i * U8) U8 n)). + Proof. + intros. + + simpl. + unfold Hacspec_Lib_Pre.u32_to_be_bytes. + unfold to_be_bytes. + rewrite !eq_rect_K. + unfold Hacspec_Lib_Pre.array_index at 2. + assert (H0 : forall (n : int32) i, i < 4 -> Hacspec_Lib_Pre.array_index (WS := U8) sbox_v (repr (nat_be_range 8 n i)) = waes.Sbox (word.subword (i * U8) U8 n)). + 2: do 4 (destruct i ; [ simpl ; apply H0 ; apply H | ]) ; discriminate. + clear ; intros. + rewrite (nat_to_be_range_is_subword (WS := U8) n i (H_WS := ltac:(easy))). + + destruct (word.subword (i * U8) U8 n). + destruct toword. + - reflexivity. + - do 8 (destruct p ; [ | | shelve ]). + all: destruct p ; easy. + Unshelve. + all: reflexivity. + - easy. + Qed. + + Lemma SubWord_eq id0 (n : int32) pre : + (pdisj pre id0 fset0) -> + ⊢ ⦃ pre ⦄ + ret (waes.SubWord n) ≈ + subword (lift_to_both0 (repr (unsigned (lift_to_both0 n)))) + ⦃ fun '(v0, h0) '(v1, h1) => (v0 = v1) /\ pre (h0, h1) ⦄. + Proof. + intros. + unfold waes.SubWord. + unfold split_vec. + replace (U32 %/ U8 + U32 %% U8) with 4 by reflexivity. + + unfold subword. + setoid_rewrite bind_rewrite. + apply better_r_put_rhs. + + (* Unroll for loop *) + unfold let_both at 1, is_state at 1, prog. + setoid_rewrite <- foldi__move_S. + replace (prog (lift_to_both0 (usize _) .+ one)) with (ret (usize 1)) by reflexivity. + unfold bind at 3. + + setoid_rewrite <- foldi__move_S. + replace (prog (is_state (usize 1 .+ one))) with (ret (usize 2)) by reflexivity. + unfold bind at 3. + + setoid_rewrite <- foldi__move_S. + replace (prog (is_state (usize 2 .+ one))) with (ret (usize 3)) by reflexivity. + unfold bind at 3. + + setoid_rewrite <- foldi__move_S. + replace (prog (is_state (usize 3 .+ one))) with (ret (usize 4)) by reflexivity. + unfold bind at 3. + unfold foldi_. + + rewrite bind_ret. + setoid_rewrite bind_ret. + rewrite bind_rewrite. + + rewrite !ct_T_id. + rewrite !T_ct_id. + + apply r_ret. + intros. + destruct_pre. + split. + unfold repr, unsigned. + rewrite !wrepr_unsigned. + rewrite <- !sbox_eq ; try easy. + + unfold Hacspec_Lib_Pre.u32_from_be_bytes, from_be_bytes. + unfold from_be_bytes_fold_fun. + + + Check set_nth. + assert (forall A WS n (a : nseq A n) (i : @int WS) x, + array_to_list (Hacspec_Lib_Pre.array_upd a i x) = + set_nth x (array_to_list a) (Z.to_nat (unsigned i)) x). + admit. + (* set (array_to_list _). *) + set (Hacspec_Lib_Pre.array_upd _ _ _) at 2. + + set ([ _ ; _ ; _ ; _ ]). + replace (make_vec U32 l) with (4, make_vec U32 l).2 by reflexivity. + Set Printing Coercions. + unfold T_ct. + unfold Datatypes.id. + unfold eq_rect_r. + unfold eq_rect. + unfold Logic.eq_sym. + unfold ChoiceEq. + unfold int32, int. unfold Hacspec_Lib_Pre.int_obligation_1. + apply f_equal. + + rewrite H0. + rewrite H0. + rewrite H0. + rewrite H0. + + replace (Z.to_nat (unsigned (wrepr U32 0))) with 0 by reflexivity. + replace (Z.to_nat (unsigned (wrepr U32 1))) with 1 by reflexivity. + replace (Z.to_nat (unsigned (wrepr U32 2))) with 2 by reflexivity. + replace (Z.to_nat (unsigned (wrepr U32 3))) with 3 by reflexivity. + + unfold set_nth. + unfold Hacspec_Lib_Pre.array_new_. + rewrite eq_rect_K. + + (* assert (forall A x, array_to_list (Hacspec_Lib_Pre.array_from_list A x) = x). *) + (* admit. *) + + unfold repeat. + unfold Hacspec_Lib_Pre.array_from_list. + unfold Datatypes.length, list_iter, zip, foldr. + unfold array_to_list. + simpl. + f_equal. + + unfold int8_to_nat, uint_size_to_nat, from_uint_size, nat_uint_sizeable, Z_to_uint_size. + unfold unsigned, repr. + unfold Hacspec_Lib_Pre.int_add, add_word. + unfold wunsigned, wrepr, mkword, urepr, val, word_subType, toword. + apply word_ext. + + unfold make_vec. + unfold wcat_r. + subst l. + hnf. + + rewrite !nat_N_Z. + rewrite !Z2Nat.id. + + set (Hacspec_Lib_Pre.array_index _ _). + set (Hacspec_Lib_Pre.array_index _ _). + set (Hacspec_Lib_Pre.array_index _ _). + set (Hacspec_Lib_Pre.array_index _ _). + + rewrite !Zmod_small. + + rewrite !Z.shiftl_mul_pow2. + simpl. + rewrite Z.lor_0_r. + + destruct t0. + destruct t1. + destruct t2. + destruct t3. + + unfold urepr, val, word_subType, word.toword. + + cbn. + + destruct toword, toword0, toword1, toword2. + all: try discriminate. + reflexivity. + + + + + + destruct toword ; [ | | easy ]. + 2:{ + destruct toword0 ; [ | | easy ]. + 2:{ + destruct toword1 ; [ | | easy ]. + 2:{ + destruct toword2 ; [ | | easy ]. + 2:{ + simpl. + unfold Pos.lor. + + unfold Z.lor at 1. + + Z.shiftl_lor. + + set (array_to_list _). + rewrite H3 in l0. + + unfold array_to_list. + simpl (U32 / 8). + hnf. + + simpl. - Theorem rpre_weak_hypothesis_rule' : - ∀ {A₀ A₁ : _} {p₀ : raw_code A₀} {p₁ : raw_code A₁} - (pre : precond) post, - (∀ s₀ s₁, - pre (s₀, s₁) → ⊢ ⦃ λ '(s0, s1), pre (s0, s1) ⦄ p₀ ≈ p₁ ⦃ post ⦄ - ) → - ⊢ ⦃ pre ⦄ p₀ ≈ p₁ ⦃ post ⦄. - Proof. - intros A₀ A₁ p₀ p₁ pre post h. - eapply rpre_hypothesis_rule'. - intros. eapply rpre_weaken_rule. - eapply h. eassumption. - intros s0' s1' [H0 H1]. + + simpl. + + unfold make_vec, wcat_r. + unfold Hacspec_Lib_Pre.array_upd. + unfold eq_rect_r. + simpl. + unfold Hacspec_Lib_Pre.u32_from_be_bytes, from_be_bytes. + unfold array_to_list. + simpl. + unfold Hacspec_Lib_Pre.array_new_. + unfold Hacspec_Lib_Pre.array_from_list. + unfold repeat. + unfold Datatypes.length. + unfold list_iter, zip, foldr. + simpl. + unfold Hacspec_Lib_Pre.array_index. + simpl. + match_pattern_and_bind (waes.Sbox (word.subword (0 * U8) U8 n)). + + + unfold Hacspec_Lib_Pre.u32_from_le_bytes. + unfold array_to_list. + Set Printing Coercions. + set (iters := nat_of_wsize _ / _) ; cbn in iters ; subst iters ; hnf. + unfold array_to_list_helper. + simpl. + + assert (waes.Sbox (word.subword (0 * U8) U8 n) = (Hacspec_Lib_Pre.array_index sbox_v + (Hacspec_Lib_Pre.array_index (WS := U8) + (Hacspec_Lib_Pre.u32_to_le_bytes (repr (unsigned n))) + (repr 0)))). + 2:{ + Set Printing Coercions. + rewrite <- H0. + + match_pattern_and_bind (make_vec U32 + [seq waes.Sbox i | i <- [seq word.subword (i * U8) U8 n | i <- iota 0 4]]). + + unfold make_vec. + unfold iota. + unfold map. + unfold wcat_r. + + replace (lift_to_both0 (usize 0) .+ one) with (lift_to_both0 (usize 1)) by reflexivity. + 2:{ + setoid_rewrite <- foldi__move_S. + setoid_rewrite <- foldi__move_S. + setoid_rewrite <- foldi__move_S. + + match_pattern_and_bind (urepr (waes.Sbox (word.subword (0 * U8) U8 n))). + apply r_ret. + intros. + simpl. + split. + + + 2:{ + apply r_ret. + intros. + rewrite H0. + destruct_pre. + split. + reflexivity. + pdisj_apply. + destruct H2. + destruct H2. subst. - assumption. - Qed. + destruct H. + apply H0. + + + Qed. + + + Lemma keygen_assist_eq id0 (v1 : 'word U128) (v2 : 'word U8) (pre : precond) : + (pdisj pre id0 fset0) -> + ⊢ ⦃ pre ⦄ + ret (waes.wAESKEYGENASSIST v1 v2) + (* (tr_app_sopn_tuple (w2_ty U128 U8) *) + (* (sopn_sem (Oasm (BaseOp (None, VAESKEYGENASSIST)))) *) + (* [totce v1; totce v2]) *) + ≈ + prog (is_state (aeskeygenassist v1 v2)) + ⦃ fun '(v0, h0) '(v1, h1) => (v0 = v1) /\ pre (h0, h1) ⦄. + Proof. + intros. + + (* let rcon := zero_extend U32 v2 in *) + (* let x1 := subword (1 * U32) U32 v1 in *) + (* let x3 := subword (3 * U32) U32 v1 in *) + (* let y0 := SubWord x1 in *) + (* let y1 := wxor (wror (SubWord x1) 1) rcon in *) + (* let y2 := SubWord x3 in *) + (* let y3 := wxor (wror (SubWord x3) 1) rcon in *) + (* make_vec U128 [:: y0; y1; y2; y3]. *) + + + (* let x1 = (v1 >> 32) % (1_u128 << 32); *) + (* let x3 = (v1 >> 96) % (1_u128 << 32); *) + (* let y0 = subword(x1 as u32); *) + (* let y1 = ror(subword(x1 as u32), 1) ^ (v2 as u32); *) + (* let y2 = subword(x3 as u32); *) + (* let y3 = ror(subword(x3 as u32), 1) ^ (v2 as u32); *) + (* (y0 as u128) | ((y1 as u128) << 32) | ((y2 as u128) << 64) | (((y3) as u128) << 96) *) + + + unfold waes.wAESKEYGENASSIST. + + unfold make_vec. + unfold wcat_r. + rewrite Z.shiftl_0_l. + rewrite Z.lor_0_r. + + unfold aeskeygenassist. + + (* Unfold let both and match *) + unfold let_both at 1, is_state at 1, prog. + match_pattern_and_bind (@word.subword (wsize_size_minus_1 U128).+1 (1 * U32) U32 v1). + { + apply r_ret. + intros. + rewrite (subword_eq v1) ; [ | easy ]. + split ; easy. + } + + unfold let_both at 1, is_state at 1, prog. + match_pattern_and_bind (@word.subword (wsize_size_minus_1 U128).+1 (3 * U32) U32 v1). + { + apply r_ret. + intros. + rewrite (subword_eq v1) ; [ | easy ]. + split ; easy. + } + + unfold let_both at 1, is_state at 1, prog. + match_pattern_and_bind (waes.SubWord a₀). + { + apply r_ret. + intros. + split. + - reflexivity. + - apply H0. + } + + + + unfold let_both at 1, is_state at 1, prog. + match_pattern_and_bind (word.subword (3 * U32) U32 v1). + { + apply r_ret. + intros. + split. + - reflexivity. + - apply H0. + } + + (* Returns 0, which is incorrect!? *) + Admitted. Lemma key_expand_eq id0 rcon rkey temp2 (pre : precond) : (pdisj pre id0 fset0) -> ⊢ ⦃ pre ⦄ - JKEY_EXPAND id0 rcon rkey temp2 - ≈ - key_expand (wrepr U8 rcon) rkey temp2 - ⦃ fun '(v0, h0) '(v1, h1) => - (exists o1 o2, v0 = [('word U128 ; o1) ; ('word U128 ; o2)] - /\ (o1, o2) = v1) /\ pre (h0, h1) ⦄. + JKEY_EXPAND id0 rcon rkey temp2 + ≈ + key_expand (wrepr U8 rcon) rkey temp2 + ⦃ fun '(v0, h0) '(v1, h1) => + (exists o1 o2, v0 = [('word U128 ; o1) ; ('word U128 ; o2)] + /\ (o1, o2) = v1) /\ pre (h0, h1) ⦄. Proof. intros H_pdisj. set (JKEY_EXPAND _ _ _ _). @@ -912,35 +1394,35 @@ Section Hacspec. apply better_r_put_lhs. apply better_r_put_lhs. apply better_r_put_lhs. - + do 2 remove_get_in_lhs. bind_jazz_hac ; [shelve | ]. - + eapply rpre_weak_hypothesis_rule'. intros ? ? [? H]. (* set (set_lhs _ _ _) in H. *) (* apply rpre_weaken_rule with (pre := λ s : heap * heap, s.1 = s₀ ∧ s.2 = s₁ /\ p s). *) (* } *) - - - (* apply H. *) - (* s.1 = s₀ ∧ s.2 = s₁ /\ set_lhs ($$"temp2.317") temp2 *) - (* (set_lhs ($$"rkey.316") rkey *) - (* (set_lhs ($$"rcon.315") (coe_cht 'int (coe_cht 'int rcon)) pre)) *) - (* (s₀, s₁)). *) - + + + (* apply H. *) + (* s.1 = s₀ ∧ s.2 = s₁ /\ set_lhs ($$"temp2.317") temp2 *) + (* (set_lhs ($$"rkey.316") rkey *) + (* (set_lhs ($$"rcon.315") (coe_cht 'int (coe_cht 'int rcon)) pre)) *) + (* (s₀, s₁)). *) + apply better_r_put_lhs. do 3 remove_get_in_lhs. rewrite bind_assoc. rewrite bind_assoc. match goal with - | [ |- context [ ⊢ ⦃ ?pre ⦄ _ ≈ _ ⦃ _ ⦄ ] ] => set (P := pre) + | [ |- context [ ⊢ ⦃ ?pre ⦄ _ ≈ _ ⦃ _ ⦄ ] ] => set (P := pre) end. apply r_bind with (mid := λ '(v0, h0) '(v1, h1), - (∃ o1 o2 : 'word U128, - v0 = [('word U128; o1); ('word U128; o2)] ∧ (o1, o2) = v1) /\ P (h0, h1)). + (∃ o1 o2 : 'word U128, + v0 = [('word U128; o1); ('word U128; o2)] ∧ (o1, o2) = v1) /\ P (h0, h1)). 2:{ intros. subst P. @@ -1032,21 +1514,45 @@ Section Hacspec. reflexivity. reflexivity. reflexivity. - + rewrite ![set_heap _ (translate_var s_id' v) a]set_heap_commut. - reflexivity. - admit. - admit. - admit. - admit. + + reflexivity. + + admit. + + admit. + + admit. + + admit. - intros. subst. discriminate. - Unshelve. - { - (* Keygen assist *) - admit. - } - Transparent translate_call. -Admitted. + Unshelve. + { + + (* Keygen assist *) + + unfold tr_app_sopn_tuple. + unfold sopn_sem. + unfold sopn.get_instr_desc. + + set (totce _) at 2. + cbn in t. + unfold totce in t. + + set (chCanonical _). + cbn in s. + subst s. + + set (tr_app_sopn _ _ _ _). + cbn in y. + subst y. + hnf. + + subst t. + + admit. + } + Transparent translate_call. + Admitted. + + +(* End Hacspec. *) From c1616e2ebfe5a5aba16656c1194bbdc039df7512 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Wed, 4 Jan 2023 21:15:51 +0100 Subject: [PATCH 341/383] Filled into larger proof --- theories/Jasmin/examples/aes/aes_hac.v | 641 ++++++++++++++++--------- 1 file changed, 412 insertions(+), 229 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes_hac.v b/theories/Jasmin/examples/aes/aes_hac.v index 9daf6ecc..dff22837 100644 --- a/theories/Jasmin/examples/aes/aes_hac.v +++ b/theories/Jasmin/examples/aes/aes_hac.v @@ -910,28 +910,6 @@ Section Hacspec. assumption. Qed. - Ltac match_pattern_and_bind p := - unfold let_both at 1, is_state at 1, prog ; - match goal with - | [ |- context [ ⊢ ⦃ ?P ⦄ ?x ≈ _ ⦃ ?Q ⦄ ] ] => - let Hx := fresh in - set (Hx := x) ; - pattern p in Hx ; - subst Hx ; - - (* Match bind and apply *) - match goal with - | [ |- context [ ⊢ ⦃ ?P ⦄ _ ≈ bind ?a ?f ⦃ ?Q ⦄ ] ] => - let av := fresh in - let fv := fresh in - set (av := a) - ; set (fv := f) - ; eapply (r_bind (ret p) av _ fv P (fun '(v0, h0) '(v1, h1) => v0 = _ v1 /\ P (h0, h1)) Q) (* (v0 = v1) *) - ; subst av fv ; hnf ; [ | intros ; apply rpre_hypothesis_rule' ; intros ? ? [] ; apply rpre_weaken_rule with (pre := fun '(s₀, s₁) => P (s₀, s₁)) - ] - end - end. - Corollary better_r_put_rhs : forall {A B : choice.Choice.type} (ℓ : Location) (v : choice.Choice.sort (Value (projT1 ℓ))) (r₀ : raw_code A) (r₁ : raw_code B) (pre : precond) @@ -991,29 +969,6 @@ Section Hacspec. rewrite Nat2Z.inj_mul. f_equal. now zify. Qed. - - (* Compute (U32 %/ U8 + U32 %% U8)%nat. *) - (* (* [seq subword (i * U8)%nat U8 n | i <- [0;1;2;3]] *) *) - - (* Compute @to_be_bytes'' U32 327. *) - - (* Compute (fun (k : Z) => *) - (* (map *) - (* (fun i : nat => nat_be_range' 8 k i) *) - (* (seq.iota 1 (nat_of_wsize U32 / 8)))) 65536. *) - - (* Goal forall i, (urepr (word.subword (i * U8)%nat (U8 / 2) (@repr U32 327))) = 255. *) - (* destruct i ; [ | destruct i ; [ | destruct i ; [ | destruct i ; [ | admit] ] ] ] ; cbn. *) - (* Admitted. *) - - (* intros. *) - (* unfold word.subword. *) - (* unfold urepr, val, word_subType, toword, mkword, lsr, mkword. *) - (* unfold repr, wrepr, mkword, urepr, val, word_subType, toword. *) - (* rewrite (Zmod_small 4294967295). *) - - (* Compute (Z.shiftr 4294967295 (1 * U8)%nat) mod modulus U8. *) - (* Check word.subword. *) Lemma sbox_eq : (forall n i, (i < 4)%nat -> @@ -1027,33 +982,41 @@ Section Hacspec. (Hacspec_Lib_Pre.u32_to_be_bytes n) U32 (@repr U32 i)) = waes.Sbox (word.subword (i * U8) U8 n)). Proof. - intros. - - simpl. - unfold Hacspec_Lib_Pre.u32_to_be_bytes. - unfold to_be_bytes. - rewrite !eq_rect_K. - unfold Hacspec_Lib_Pre.array_index at 2. - assert (H0 : forall (n : int32) i, i < 4 -> Hacspec_Lib_Pre.array_index (WS := U8) sbox_v (repr (nat_be_range 8 n i)) = waes.Sbox (word.subword (i * U8) U8 n)). - 2: do 4 (destruct i ; [ simpl ; apply H0 ; apply H | ]) ; discriminate. - clear ; intros. - rewrite (nat_to_be_range_is_subword (WS := U8) n i (H_WS := ltac:(easy))). - - destruct (word.subword (i * U8) U8 n). - destruct toword. - - reflexivity. - - do 8 (destruct p ; [ | | shelve ]). - all: destruct p ; easy. - Unshelve. - all: reflexivity. - - easy. - Qed. - + Admitted. + (* intros. *) + + (* simpl. *) + (* unfold Hacspec_Lib_Pre.u32_to_be_bytes. *) + (* unfold to_be_bytes. *) + (* rewrite !eq_rect_K. *) + (* unfold Hacspec_Lib_Pre.array_index at 2. *) + (* assert (H0 : forall (n : int32) i, i < 4 -> Hacspec_Lib_Pre.array_index (WS := U8) sbox_v (repr (nat_be_range 8 n i)) = waes.Sbox (word.subword (i * U8) U8 n)). *) + (* 2: do 4 (destruct i ; [ simpl ; apply H0 ; apply H | ]) ; discriminate. *) + (* clear ; intros. *) + (* rewrite (nat_to_be_range_is_subword (WS := U8) n i (H_WS := ltac:(easy))). *) + + (* destruct (word.subword (i * U8) U8 n). *) + (* destruct toword. *) + (* - reflexivity. *) + (* - do 8 (destruct p ; [ | | shelve ]). *) + (* all: destruct p ; easy. *) + (* Unshelve. *) + (* all: reflexivity. *) + (* - easy. *) + (* Qed. *) + + Lemma array_to_list_upd_spec : (forall A WS n (a : nseq A n) (i : @int WS) x, + array_to_list (Hacspec_Lib_Pre.array_upd a i x) = + set_nth x (array_to_list a) (Z.to_nat (unsigned i)) x). + Proof. + Admitted. + + Lemma SubWord_eq id0 (n : int32) pre : - (pdisj pre id0 fset0) -> + (pdisj pre id0 (CEfset ([res_238_loc]))) -> ⊢ ⦃ pre ⦄ ret (waes.SubWord n) ≈ - subword (lift_to_both0 (repr (unsigned (lift_to_both0 n)))) + subword n ⦃ fun '(v0, h0) '(v1, h1) => (v0 = v1) /\ pre (h0, h1) ⦄. Proof. intros. @@ -1095,20 +1058,22 @@ Section Hacspec. intros. destruct_pre. split. + 2:{ + cbn. + + apply H. + setoid_rewrite <- fset1E. + apply (ssrbool.introT (fset1P _ _)). + reflexivity. + apply H2. + } + unfold repr, unsigned. - rewrite !wrepr_unsigned. rewrite <- !sbox_eq ; try easy. unfold Hacspec_Lib_Pre.u32_from_be_bytes, from_be_bytes. unfold from_be_bytes_fold_fun. - - Check set_nth. - assert (forall A WS n (a : nseq A n) (i : @int WS) x, - array_to_list (Hacspec_Lib_Pre.array_upd a i x) = - set_nth x (array_to_list a) (Z.to_nat (unsigned i)) x). - admit. - (* set (array_to_list _). *) set (Hacspec_Lib_Pre.array_upd _ _ _) at 2. set ([ _ ; _ ; _ ; _ ]). @@ -1123,173 +1088,322 @@ Section Hacspec. unfold int32, int. unfold Hacspec_Lib_Pre.int_obligation_1. apply f_equal. - rewrite H0. - rewrite H0. - rewrite H0. - rewrite H0. + do 4 rewrite array_to_list_upd_spec. replace (Z.to_nat (unsigned (wrepr U32 0))) with 0 by reflexivity. replace (Z.to_nat (unsigned (wrepr U32 1))) with 1 by reflexivity. replace (Z.to_nat (unsigned (wrepr U32 2))) with 2 by reflexivity. replace (Z.to_nat (unsigned (wrepr U32 3))) with 3 by reflexivity. - - unfold set_nth. - unfold Hacspec_Lib_Pre.array_new_. - rewrite eq_rect_K. - (* assert (forall A x, array_to_list (Hacspec_Lib_Pre.array_from_list A x) = x). *) - (* admit. *) + subst l. - unfold repeat. - unfold Hacspec_Lib_Pre.array_from_list. - unfold Datatypes.length, list_iter, zip, foldr. - unfold array_to_list. + unfold Hacspec_Lib_Pre.array_new_. simpl. - f_equal. + rewrite eq_rect_K. + set (getm _ _). + cbn in o. + subst o. + hnf. + set (_ ++ _). + cbn in l. + subst l. + hnf. + unfold fold_right. + unfold set_nth. + rewrite !nat_N_Z. unfold int8_to_nat, uint_size_to_nat, from_uint_size, nat_uint_sizeable, Z_to_uint_size. unfold unsigned, repr. unfold Hacspec_Lib_Pre.int_add, add_word. - unfold wunsigned, wrepr, mkword, urepr, val, word_subType, toword. - apply word_ext. - unfold make_vec. unfold wcat_r. - subst l. - hnf. - - rewrite !nat_N_Z. - rewrite !Z2Nat.id. + unfold wunsigned, wrepr, mkword, urepr, val, word_subType. + + set (Hacspec_Lib_Pre.array_index _ _). set (Hacspec_Lib_Pre.array_index _ _). set (Hacspec_Lib_Pre.array_index _ _). set (Hacspec_Lib_Pre.array_index _ _). - rewrite !Zmod_small. + unfold toword in |- *. - rewrite !Z.shiftl_mul_pow2. - simpl. - rewrite Z.lor_0_r. + rewrite !Z2Nat.id. + + 2: { + destruct t3. + apply (ssrbool.elimT (iswordZP _ _)) in i. + rewrite Zmod_small ; [ lia | ]. + destruct i. + split ; [ assumption | eapply Z.lt_trans ; [ apply H3 | easy ] ]. + } + 2: { + destruct t2. + apply (ssrbool.elimT (iswordZP _ _)) in i. + rewrite Zmod_small ; [ lia | ]. + destruct i. + split ; [ assumption | eapply Z.lt_trans ; [ apply H3 | easy ] ]. + } + 2: { + destruct t1. + apply (ssrbool.elimT (iswordZP _ _)) in i. + rewrite Zmod_small ; [ lia | ]. + destruct i. + split ; [ assumption | eapply Z.lt_trans ; [ apply H3 | easy ] ]. + } + 2: { + destruct t0. + apply (ssrbool.elimT (iswordZP _ _)) in i. + rewrite Zmod_small ; [ lia | ]. + destruct i. + split ; [ assumption | eapply Z.lt_trans ; [ apply H3 | easy ] ]. + } - destruct t0. - destruct t1. - destruct t2. - destruct t3. + unfold Z.of_nat. - unfold urepr, val, word_subType, word.toword. + f_equal. + apply word_ext. - cbn. + Unset Printing Coercions. - destruct toword, toword0, toword1, toword2. - all: try discriminate. - reflexivity. - - - - - - destruct toword ; [ | | easy ]. - 2:{ - destruct toword0 ; [ | | easy ]. - 2:{ - destruct toword1 ; [ | | easy ]. - 2:{ - destruct toword2 ; [ | | easy ]. - 2:{ - simpl. - unfold Pos.lor. - - unfold Z.lor at 1. - - Z.shiftl_lor. - - set (array_to_list _). - rewrite H3 in l0. - - unfold array_to_list. - simpl (U32 / 8). - hnf. - - simpl. - + (* rewrite !Zmod_small. *) + rewrite !Z.shiftl_mul_pow2 ; try easy. simpl. + cbn. - unfold make_vec, wcat_r. - unfold Hacspec_Lib_Pre.array_upd. - unfold eq_rect_r. - simpl. - unfold Hacspec_Lib_Pre.u32_from_be_bytes, from_be_bytes. - unfold array_to_list. - simpl. - unfold Hacspec_Lib_Pre.array_new_. - unfold Hacspec_Lib_Pre.array_from_list. - unfold repeat. - unfold Datatypes.length. - unfold list_iter, zip, foldr. - simpl. - unfold Hacspec_Lib_Pre.array_index. - simpl. - match_pattern_and_bind (waes.Sbox (word.subword (0 * U8) U8 n)). + replace 1%Z with (1 mod modulus nat31.+1)%Z by reflexivity. + replace 256%Z with (256 mod modulus nat31.+1)%Z by reflexivity. + replace 65536%Z with (65536 mod modulus nat31.+1)%Z by reflexivity. + replace 16777216%Z with (16777216 mod modulus nat31.+1)%Z by reflexivity. + rewrite <- !Zmult_mod. + rewrite !Zmod_mod. + rewrite <- !Z.add_mod. + + rewrite <- Z.add_assoc. + rewrite (Z.add_mod ((_ * 1 + _ * 256) mod _)). + rewrite !Zmod_mod. + rewrite <- Z.add_mod. + + rewrite Z.add_comm. + rewrite <- Z.add_assoc. + rewrite (Z.add_mod ((_ * 65536) mod _)). + rewrite !Zmod_mod. + rewrite <- Z.add_mod. + rewrite Z.add_comm. + rewrite <- Z.add_assoc. + rewrite Z.add_comm. + rewrite <- Z.add_assoc. + rewrite <- Z.add_assoc. - unfold Hacspec_Lib_Pre.u32_from_le_bytes. - unfold array_to_list. - Set Printing Coercions. - set (iters := nat_of_wsize _ / _) ; cbn in iters ; subst iters ; hnf. - unfold array_to_list_helper. simpl. + cbn. - assert (waes.Sbox (word.subword (0 * U8) U8 n) = (Hacspec_Lib_Pre.array_index sbox_v - (Hacspec_Lib_Pre.array_index (WS := U8) - (Hacspec_Lib_Pre.u32_to_le_bytes (repr (unsigned n))) - (repr 0)))). - 2:{ - Set Printing Coercions. - rewrite <- H0. + f_equal. - match_pattern_and_bind (make_vec U32 - [seq waes.Sbox i | i <- [seq word.subword (i * U8) U8 n | i <- iota 0 4]]). + all: try easy. - unfold make_vec. - unfold iota. - unfold map. - unfold wcat_r. + (* apply Z.bits_inj. *) + (* intros i. *) - replace (lift_to_both0 (usize 0) .+ one) with (lift_to_both0 (usize 1)) by reflexivity. - 2:{ - setoid_rewrite <- foldi__move_S. - setoid_rewrite <- foldi__move_S. - setoid_rewrite <- foldi__move_S. + assert (H_lor_add : forall (a b : Z) (k : nat), (0 <= a < modulus k)%Z -> (a + Z.shiftl b k)%Z = Z.lor a (Z.shiftl b k)). + { + clear ; intros. - match_pattern_and_bind (urepr (waes.Sbox (word.subword (0 * U8) U8 n))). - apply r_ret. - intros. - simpl. - split. + assert (Z.land a (Z.shiftl b k) = 0). + { + apply Z.bits_inj_iff. + intros i. + rewrite Z.land_spec. + rewrite Z.bits_0. + destruct (0 <=? i)%Z eqn:i0. + { + destruct (i + let Hx := fresh in + set (Hx := x) ; + pattern p in Hx ; + subst Hx ; + + (* Match bind and apply *) + match goal with + | [ |- context [ ⊢ ⦃ ?P ⦄ _ ≈ bind ?a ?f ⦃ ?Q ⦄ ] ] => + let av := fresh in + let fv := fresh in + set (av := a) + ; set (fv := f) + ; eapply (r_bind (ret p) av _ fv P (fun '(v0, h0) '(v1, h1) => v0 = repr v1 /\ P (h0, h1)) Q) (* (v0 = v1) *) + ; subst av fv ; hnf ; [ | intros ; apply rpre_hypothesis_rule' ; intros ? ? [] ; apply rpre_weaken_rule with (pre := fun '(s₀, s₁) => P (s₀, s₁)) + ] + end + end. + + Ltac match_pattern_and_bind p := + unfold let_both at 1, is_state at 1, prog ; + match goal with + | [ |- context [ ⊢ ⦃ ?P ⦄ ?x ≈ _ ⦃ ?Q ⦄ ] ] => + let Hx := fresh in + set (Hx := x) ; + pattern p in Hx ; + subst Hx ; + + (* Match bind and apply *) + match goal with + | [ |- context [ ⊢ ⦃ ?P ⦄ _ ≈ bind ?a ?f ⦃ ?Q ⦄ ] ] => + let av := fresh in + let fv := fresh in + set (av := a) + ; set (fv := f) + ; eapply (r_bind (ret p) av _ fv P (fun '(v0, h0) '(v1, h1) => v0 = v1 /\ P (h0, h1)) Q) (* (v0 = v1) *) + ; subst av fv ; hnf ; [ | intros ; apply rpre_hypothesis_rule' ; intros ? ? [] ; apply rpre_weaken_rule with (pre := fun '(s₀, s₁) => P (s₀, s₁)) + ] + end + end. Lemma keygen_assist_eq id0 (v1 : 'word U128) (v2 : 'word U8) (pre : precond) : - (pdisj pre id0 fset0) -> + (pdisj pre id0 (CEfset [res_238_loc])) -> ⊢ ⦃ pre ⦄ ret (waes.wAESKEYGENASSIST v1 v2) (* (tr_app_sopn_tuple (w2_ty U128 U8) *) @@ -1330,51 +1444,87 @@ Section Hacspec. unfold aeskeygenassist. (* Unfold let both and match *) - unfold let_both at 1, is_state at 1, prog. - match_pattern_and_bind (@word.subword (wsize_size_minus_1 U128).+1 (1 * U32) U32 v1). + (* unfold let_both at 1, is_state at 1, prog. *) + match_pattern_and_bind_repr (@word.subword (wsize_size_minus_1 U128).+1 (1 * U32) U32 v1). { apply r_ret. intros. rewrite (subword_eq v1) ; [ | easy ]. - split ; easy. + split. reflexivity. assumption. } + - unfold let_both at 1, is_state at 1, prog. - match_pattern_and_bind (@word.subword (wsize_size_minus_1 U128).+1 (3 * U32) U32 v1). + (* unfold let_both at 1, is_state at 1, prog. *) + match_pattern_and_bind_repr (@word.subword (wsize_size_minus_1 U128).+1 (3 * U32) U32 v1). { apply r_ret. intros. rewrite (subword_eq v1) ; [ | easy ]. split ; easy. } - + unfold let_both at 1, is_state at 1, prog. match_pattern_and_bind (waes.SubWord a₀). { + subst. + apply (SubWord_eq id0 (repr a₁) (λ '(s₀1, s₁1), pre (s₀1, s₁1))). + destruct_pre. + hnf. + eapply H. + } + + match_pattern_and_bind (word.wxor (wror (sz:=U32) a₀1 1) (zero_extend U32 (sz':=U8) v2)). + { + subst. apply r_ret. intros. split. - - reflexivity. + - (* TODO *) admit. - apply H0. } - - - unfold let_both at 1, is_state at 1, prog. - match_pattern_and_bind (word.subword (3 * U32) U32 v1). + match_pattern_and_bind (waes.SubWord a₀0). + { + subst. + apply (SubWord_eq id0 (repr a₁0) (λ '(s₀1, s₁1), pre (s₀1, s₁1))). + destruct_pre. + hnf. + eapply H. + } + + match_pattern_and_bind (word.wxor (wror (sz:=U32) a₀3 1) + (zero_extend U32 (sz':=U8) v2)). { + subst. apply r_ret. intros. split. - - reflexivity. + - (* TODO *) admit. - apply H0. - } + } + + apply r_ret. + intros. + subst. + all: try (intros ? ? [] ; subst ; assumption). + split. + - set (Hacspec_Lib_Pre.int_or _ _). + cbn in t. + subst t. - (* Returns 0, which is incorrect!? *) + apply word_ext. + rewrite <- !Z.lor_assoc. + rewrite !Z.shiftl_lor. + rewrite !Z.shiftl_shiftl. + rewrite !Zmod_small. + f_equal. + + all: admit. + - apply H12. Admitted. Lemma key_expand_eq id0 rcon rkey temp2 (pre : precond) : - (pdisj pre id0 fset0) -> + (pdisj pre id0 (CEfset [res_238_loc])) -> ⊢ ⦃ pre ⦄ JKEY_EXPAND id0 rcon rkey temp2 ≈ @@ -1387,7 +1537,8 @@ Section Hacspec. set (JKEY_EXPAND _ _ _ _). unfold translate_call, translate_call_body in r |- *. Opaque translate_call. - simpl in r. + unfold JKEY_EXPAND in r. + cbn in r. subst r. rewrite !zero_extend_u. @@ -1534,22 +1685,54 @@ Section Hacspec. unfold sopn_sem. unfold sopn.get_instr_desc. - set (totce _) at 2. - cbn in t. - unfold totce in t. - - set (chCanonical _). - cbn in s. - subst s. - set (tr_app_sopn _ _ _ _). - cbn in y. - subst y. - hnf. + Opaque aeskeygenassist. + repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). + Transparent aeskeygenassist. + apply (keygen_assist_eq (id0~1)%positive ). - subst t. - - admit. + split. + - intros. + subst. + destruct_pre. + unfold set_lhs. + eexists. + eexists. + eexists. + split. + exists (set_heap H5 (translate_var s_id' v) a). + split. + eapply H_pdisj. + reflexivity. + + etransitivity. + apply fresh2_weak. + apply H0. + apply H6. + reflexivity. + reflexivity. + + rewrite ![set_heap _ (translate_var s_id' v) a]set_heap_commut. + reflexivity. + admit. + admit. + admit. + - intros. + subst. + destruct_pre. + unfold set_lhs. + eexists. + eexists. + eexists. + split. + eexists. + split. + eapply H_pdisj. + apply H. + apply H6. + reflexivity. + reflexivity. + reflexivity. } Transparent translate_call. Admitted. From aee4d21950388e4c417f97b541f4b2d455138b78 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Thu, 5 Jan 2023 14:09:17 +0100 Subject: [PATCH 342/383] Finished more subproofs --- theories/Jasmin/examples/aes/aes_hac.v | 193 +++++++++++++++++-------- 1 file changed, 130 insertions(+), 63 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes_hac.v b/theories/Jasmin/examples/aes/aes_hac.v index dff22837..0f2aad18 100644 --- a/theories/Jasmin/examples/aes/aes_hac.v +++ b/theories/Jasmin/examples/aes/aes_hac.v @@ -153,8 +153,8 @@ Section Hacspec. cbn. lia. Qed. - Theorem shiftl_bounds : forall x y z, - (le y z) -> + Theorem shiftl_bounds : forall x (y z : nat), + (y <= z)%Z -> (0 <= x < modulus (z - y))%Z -> (0 <= Z.shiftl x y < modulus z)%Z. Proof. @@ -173,6 +173,7 @@ Section Hacspec. rewrite Nat2Z.inj_sub. rewrite Z.sub_simpl_r. reflexivity. + apply Nat2Z.inj_le. apply H. } split. @@ -557,9 +558,9 @@ Section Hacspec. rewrite !Zmod_small. all: try apply (@num_smaller_if_modulus_lte U32). all: try easy. - 2: apply (shiftl_bounds _ 96 128) ; [ lia | cbn ; apply (@num_smaller_if_modulus_lte U32) ; easy ]. - 2: apply (shiftl_bounds _ 64 128) ; [ lia | cbn ; apply (@num_smaller_if_modulus_lte U32) ; easy ]. - 2: apply (shiftl_bounds _ 32 128) ; [ lia | cbn ; apply (@num_smaller_if_modulus_lte U32) ; easy ]. + 2: apply (shiftl_bounds _ 96 128) ; [ easy | cbn ; apply (@num_smaller_if_modulus_lte U32) ; easy ]. + 2: apply (shiftl_bounds _ 64 128) ; [ easy | cbn ; apply (@num_smaller_if_modulus_lte U32) ; easy ]. + 2: apply (shiftl_bounds _ 32 128) ; [ easy | cbn ; apply (@num_smaller_if_modulus_lte U32) ; easy ]. rewrite !Z.shiftl_lor. rewrite !Z.shiftl_mul_pow2 ; try easy. @@ -969,7 +970,34 @@ Section Hacspec. rewrite Nat2Z.inj_mul. f_equal. now zify. Qed. - + + Theorem modulus_exact : forall {WS : wsize.wsize} (x : 'word WS), (0 <= x < modulus WS)%Z. + Proof. + intros. + destruct x. + cbn. + apply (ssrbool.elimT (iswordZP _ _)) in i. + apply i. + Qed. + + Theorem modulus_smaller : forall (WS : wsize.wsize) (m : nat) {x : 'word WS}, (WS <= m)%Z -> (0 <= x < modulus m)%Z. + Proof. + intros. + destruct x. + cbn. + apply (ssrbool.elimT (iswordZP _ _)) in i. + split. + - easy. + - eapply Z.lt_le_trans. + apply i. + rewrite modulusZE. + rewrite modulusZE. + apply (Z.pow_le_mono_r 2). + reflexivity. + (* apply Nat2Z.inj_le. *) + apply H. + Qed. + Lemma sbox_eq : (forall n i, (i < 4)%nat -> @Hacspec_Lib_Pre.array_index int8 (@int_default U8) @@ -982,36 +1010,35 @@ Section Hacspec. (Hacspec_Lib_Pre.u32_to_be_bytes n) U32 (@repr U32 i)) = waes.Sbox (word.subword (i * U8) U8 n)). Proof. - Admitted. - (* intros. *) - - (* simpl. *) - (* unfold Hacspec_Lib_Pre.u32_to_be_bytes. *) - (* unfold to_be_bytes. *) - (* rewrite !eq_rect_K. *) - (* unfold Hacspec_Lib_Pre.array_index at 2. *) - (* assert (H0 : forall (n : int32) i, i < 4 -> Hacspec_Lib_Pre.array_index (WS := U8) sbox_v (repr (nat_be_range 8 n i)) = waes.Sbox (word.subword (i * U8) U8 n)). *) - (* 2: do 4 (destruct i ; [ simpl ; apply H0 ; apply H | ]) ; discriminate. *) - (* clear ; intros. *) - (* rewrite (nat_to_be_range_is_subword (WS := U8) n i (H_WS := ltac:(easy))). *) - - (* destruct (word.subword (i * U8) U8 n). *) - (* destruct toword. *) - (* - reflexivity. *) - (* - do 8 (destruct p ; [ | | shelve ]). *) - (* all: destruct p ; easy. *) - (* Unshelve. *) - (* all: reflexivity. *) - (* - easy. *) - (* Qed. *) + intros. + + simpl. + unfold Hacspec_Lib_Pre.u32_to_be_bytes. + unfold to_be_bytes. + rewrite !eq_rect_K. + unfold Hacspec_Lib_Pre.array_index at 2. + assert (H0 : forall (n : int32) i, i < 4 -> Hacspec_Lib_Pre.array_index (WS := U8) sbox_v (repr (nat_be_range 8 n i)) = waes.Sbox (word.subword (i * U8) U8 n)). + 2: do 4 (destruct i ; [ simpl ; apply H0 ; apply H | ]) ; discriminate. + clear ; intros. + rewrite (nat_to_be_range_is_subword (WS := U8) n i (H_WS := ltac:(easy))). + + destruct (word.subword (i * U8) U8 n). + destruct toword. + - reflexivity. + - do 8 (destruct p ; [ | | shelve ]). + all: destruct p ; easy. + Unshelve. + all: reflexivity. + - easy. + Qed. Lemma array_to_list_upd_spec : (forall A WS n (a : nseq A n) (i : @int WS) x, array_to_list (Hacspec_Lib_Pre.array_upd a i x) = set_nth x (array_to_list a) (Z.to_nat (unsigned i)) x). Proof. Admitted. - - + + Lemma SubWord_eq id0 (n : int32) pre : (pdisj pre id0 (CEfset ([res_238_loc]))) -> ⊢ ⦃ pre ⦄ @@ -1067,7 +1094,7 @@ Section Hacspec. reflexivity. apply H2. } - + unfold repr, unsigned. rewrite <- !sbox_eq ; try easy. @@ -1119,17 +1146,17 @@ Section Hacspec. unfold wcat_r. unfold wunsigned, wrepr, mkword, urepr, val, word_subType. - - + + set (Hacspec_Lib_Pre.array_index _ _). set (Hacspec_Lib_Pre.array_index _ _). set (Hacspec_Lib_Pre.array_index _ _). set (Hacspec_Lib_Pre.array_index _ _). - + unfold toword in |- *. rewrite !Z2Nat.id. - + 2: { destruct t3. apply (ssrbool.elimT (iswordZP _ _)) in i. @@ -1164,7 +1191,7 @@ Section Hacspec. f_equal. apply word_ext. - Unset Printing Coercions. + Unset Printing Coercions. (* rewrite !Zmod_small. *) rewrite !Z.shiftl_mul_pow2 ; try easy. @@ -1247,12 +1274,12 @@ Section Hacspec. destruct i ; easy. } } - + rewrite <- Z.lxor_lor ; [ | apply H0 ]. rewrite <- Z.add_nocarry_lxor ; [ | apply H0 ]. reflexivity. } - + replace 1%Z with (modulus 0)%Z by reflexivity. replace 256%Z with (modulus 8)%Z by reflexivity. replace 65536%Z with (modulus 16)%Z by reflexivity. @@ -1282,10 +1309,9 @@ Section Hacspec. eapply Z.lt_trans. apply i. easy. - + rewrite <- modulusZE. - apply shiftl_bounds. - lia. + apply shiftl_bounds. easy. apply i0. } 2: { @@ -1308,18 +1334,16 @@ Section Hacspec. eapply Z.lt_trans. apply i. easy. - + rewrite <- modulusZE. - apply shiftl_bounds. - lia. + apply shiftl_bounds. easy. split. lia. eapply Z.lt_trans. apply i0. easy. rewrite <- modulusZE. - apply shiftl_bounds. - lia. + apply shiftl_bounds. easy. split. lia. eapply Z.lt_le_trans. apply i1. @@ -1339,21 +1363,20 @@ Section Hacspec. eapply Z.lt_trans. apply i. easy. - + rewrite <- modulusZE. - apply shiftl_bounds. - lia. + apply shiftl_bounds. easy. split. lia. eapply Z.lt_le_trans. apply i0. easy. } - + rewrite !Z.shiftl_lor. rewrite <- !Z.lor_assoc. rewrite !Z.shiftl_shiftl. - + reflexivity. all: try easy. Qed. @@ -1401,7 +1424,7 @@ Section Hacspec. ] end end. - + Lemma keygen_assist_eq id0 (v1 : 'word U128) (v2 : 'word U8) (pre : precond) : (pdisj pre id0 (CEfset [res_238_loc])) -> ⊢ ⦃ pre ⦄ @@ -1450,9 +1473,9 @@ Section Hacspec. apply r_ret. intros. rewrite (subword_eq v1) ; [ | easy ]. - split. reflexivity. assumption. + split. reflexivity. assumption. } - + (* unfold let_both at 1, is_state at 1, prog. *) match_pattern_and_bind_repr (@word.subword (wsize_size_minus_1 U128).+1 (3 * U32) U32 v1). @@ -1462,8 +1485,7 @@ Section Hacspec. rewrite (subword_eq v1) ; [ | easy ]. split ; easy. } - - unfold let_both at 1, is_state at 1, prog. + match_pattern_and_bind (waes.SubWord a₀). { subst. @@ -1479,7 +1501,7 @@ Section Hacspec. apply r_ret. intros. split. - - (* TODO *) admit. + - reflexivity. - apply H0. } @@ -1491,7 +1513,7 @@ Section Hacspec. hnf. eapply H. } - + match_pattern_and_bind (word.wxor (wror (sz:=U32) a₀3 1) (zero_extend U32 (sz':=U8) v2)). { @@ -1499,9 +1521,9 @@ Section Hacspec. apply r_ret. intros. split. - - (* TODO *) admit. + - reflexivity. - apply H0. - } + } apply r_ret. intros. @@ -1519,9 +1541,54 @@ Section Hacspec. rewrite !Zmod_small. f_equal. - all: admit. + + apply (modulus_smaller U32 U128). easy. + + apply (shiftl_bounds _ 96 128). easy. + apply (modulus_exact a₁4). + + apply (modulus_smaller U32 U128). easy. + + apply (modulus_smaller U32 U128). easy. + + apply (shiftl_bounds _ 64 128). easy. + apply (modulus_smaller U32 U64). easy. + + apply (modulus_smaller U32 U128). easy. + + apply (modulus_smaller U32 U128). easy. + + apply (shiftl_bounds _ 32 128). easy. + apply (modulus_smaller U32 96). easy. + + apply (modulus_smaller U32 U128). easy. + + apply (modulus_smaller U32 U128). easy. + + (* destruct a₁1 , a₁2 , a₁3 , a₁4. *) + (* unfold urepr, val, word_subType, word.toword. *) + (* apply (ssrbool.elimT (iswordZP _ _)) in i, i0, i1, i2. *) + split. + * apply Z.lor_nonneg. split. apply word_geZ0. + apply Z.lor_nonneg. split. apply Z.shiftl_nonneg. apply word_geZ0. + apply Z.lor_nonneg. split. apply Z.shiftl_nonneg. apply word_geZ0. + apply Z.shiftl_nonneg. apply word_geZ0. + * rewrite modulusZE. + apply Z_lor_pow2. + split. apply word_geZ0. + eapply Z.lt_trans. + apply (modulus_exact a₁1). + easy. + + apply Z_lor_pow2. + split. apply Z.shiftl_nonneg. apply word_geZ0. + rewrite <- modulusZE. + apply (shiftl_bounds _ U32 U128). easy. + apply num_smaller_if_modulus_lte. easy. + + apply Z_lor_pow2. + split. apply Z.shiftl_nonneg. apply word_geZ0. + rewrite <- modulusZE. + apply (shiftl_bounds _ U64 U128). easy. + apply num_smaller_if_modulus_lte. easy. + + rewrite <- modulusZE. + apply (shiftl_bounds _ 96 U128). easy. + apply num_smaller_if_modulus_lte. easy. + + easy. + + easy. + + easy. - apply H12. - Admitted. + Qed. Lemma key_expand_eq id0 rcon rkey temp2 (pre : precond) : (pdisj pre id0 (CEfset [res_238_loc])) -> @@ -1704,7 +1771,7 @@ Section Hacspec. split. eapply H_pdisj. reflexivity. - + etransitivity. apply fresh2_weak. apply H0. From 40f7bdcc9bb1ef9b0c51751186a96a249b3905f4 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Wed, 11 Jan 2023 20:51:02 +0100 Subject: [PATCH 343/383] Done with key_expand --- theories/Jasmin/examples/aes/aes_hac.v | 228 +++++++++---------------- 1 file changed, 81 insertions(+), 147 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes_hac.v b/theories/Jasmin/examples/aes/aes_hac.v index 0f2aad18..2e357d43 100644 --- a/theories/Jasmin/examples/aes/aes_hac.v +++ b/theories/Jasmin/examples/aes/aes_hac.v @@ -1025,20 +1025,11 @@ Section Hacspec. destruct (word.subword (i * U8) U8 n). destruct toword. - reflexivity. - - do 8 (destruct p ; [ | | shelve ]). + - do 8 (destruct p ; [ | | reflexivity ]). all: destruct p ; easy. - Unshelve. - all: reflexivity. - easy. Qed. - Lemma array_to_list_upd_spec : (forall A WS n (a : nseq A n) (i : @int WS) x, - array_to_list (Hacspec_Lib_Pre.array_upd a i x) = - set_nth x (array_to_list a) (Z.to_nat (unsigned i)) x). - Proof. - Admitted. - - Lemma SubWord_eq id0 (n : int32) pre : (pdisj pre id0 (CEfset ([res_238_loc]))) -> ⊢ ⦃ pre ⦄ @@ -1083,6 +1074,12 @@ Section Hacspec. apply r_ret. intros. + + unfold Hacspec_Lib_Pre.u32_from_be_bytes, from_be_bytes. + unfold from_be_bytes_fold_fun. + + rewrite !array_to_list_upd_spec. + destruct_pre. split. 2:{ @@ -1098,10 +1095,27 @@ Section Hacspec. unfold repr, unsigned. rewrite <- !sbox_eq ; try easy. - unfold Hacspec_Lib_Pre.u32_from_be_bytes, from_be_bytes. - unfold from_be_bytes_fold_fun. + rewrite Hacspec_Lib_Pre.array_to_list_equation_1. + unfold Hacspec_Lib_Pre.array_to_list_clause_1. + unfold Hacspec_Lib_Pre.array_to_list_obligations_obligation_1. + + rewrite Hacspec_Lib_Pre.array_to_list_helper_equation_2. + unfold Hacspec_Lib_Pre.array_to_list_helper_clause_2. + unfold Hacspec_Lib_Pre.array_to_list_helper_clause_2_clause_1. - set (Hacspec_Lib_Pre.array_upd _ _ _) at 2. + rewrite Hacspec_Lib_Pre.array_to_list_helper_equation_2. + unfold Hacspec_Lib_Pre.array_to_list_helper_clause_2. + unfold Hacspec_Lib_Pre.array_to_list_helper_clause_2_clause_1. + + rewrite Hacspec_Lib_Pre.array_to_list_helper_equation_2. + unfold Hacspec_Lib_Pre.array_to_list_helper_clause_2. + unfold Hacspec_Lib_Pre.array_to_list_helper_clause_2_clause_1. + + rewrite Hacspec_Lib_Pre.array_to_list_helper_equation_2. + unfold Hacspec_Lib_Pre.array_to_list_helper_clause_2. + unfold Hacspec_Lib_Pre.array_to_list_helper_clause_2_clause_1. + + rewrite Hacspec_Lib_Pre.array_to_list_helper_equation_1. set ([ _ ; _ ; _ ; _ ]). replace (make_vec U32 l) with (4, make_vec U32 l).2 by reflexivity. @@ -1115,13 +1129,15 @@ Section Hacspec. unfold int32, int. unfold Hacspec_Lib_Pre.int_obligation_1. apply f_equal. - do 4 rewrite array_to_list_upd_spec. - replace (Z.to_nat (unsigned (wrepr U32 0))) with 0 by reflexivity. replace (Z.to_nat (unsigned (wrepr U32 1))) with 1 by reflexivity. replace (Z.to_nat (unsigned (wrepr U32 2))) with 2 by reflexivity. replace (Z.to_nat (unsigned (wrepr U32 3))) with 3 by reflexivity. + replace (Pos.to_nat 1) with 1 by reflexivity. + replace (Pos.to_nat 2) with 2 by reflexivity. + replace (Pos.to_nat 3) with 3 by reflexivity. + subst l. unfold Hacspec_Lib_Pre.array_new_. @@ -1157,35 +1173,6 @@ Section Hacspec. rewrite !Z2Nat.id. - 2: { - destruct t3. - apply (ssrbool.elimT (iswordZP _ _)) in i. - rewrite Zmod_small ; [ lia | ]. - destruct i. - split ; [ assumption | eapply Z.lt_trans ; [ apply H3 | easy ] ]. - } - 2: { - destruct t2. - apply (ssrbool.elimT (iswordZP _ _)) in i. - rewrite Zmod_small ; [ lia | ]. - destruct i. - split ; [ assumption | eapply Z.lt_trans ; [ apply H3 | easy ] ]. - } - 2: { - destruct t1. - apply (ssrbool.elimT (iswordZP _ _)) in i. - rewrite Zmod_small ; [ lia | ]. - destruct i. - split ; [ assumption | eapply Z.lt_trans ; [ apply H3 | easy ] ]. - } - 2: { - destruct t0. - apply (ssrbool.elimT (iswordZP _ _)) in i. - rewrite Zmod_small ; [ lia | ]. - destruct i. - split ; [ assumption | eapply Z.lt_trans ; [ apply H3 | easy ] ]. - } - unfold Z.of_nat. f_equal. @@ -1294,84 +1281,6 @@ Section Hacspec. rewrite !H_lor_add. - 2, 4, 6, 8: apply (ssrbool.elimT (iswordZP _ _)) ; now destruct t0. - 2: { - destruct t0. - apply (ssrbool.elimT (iswordZP _ _)) in i. - destruct t1. - apply (ssrbool.elimT (iswordZP _ _)) in i0. - split. - - apply Z.lor_nonneg. split. lia. - apply Z.shiftl_nonneg. lia. - - rewrite modulusZE. - apply Z_lor_pow2. - split. lia. - eapply Z.lt_trans. - apply i. - easy. - - rewrite <- modulusZE. - apply shiftl_bounds. easy. - apply i0. - } - 2: { - destruct t0. - apply (ssrbool.elimT (iswordZP _ _)) in i. - destruct t1. - apply (ssrbool.elimT (iswordZP _ _)) in i0. - destruct t2. - apply (ssrbool.elimT (iswordZP _ _)) in i1. - split. - - apply Z.lor_nonneg. split. - apply Z.lor_nonneg. split. lia. - apply Z.shiftl_nonneg. lia. - apply Z.shiftl_nonneg. lia. - - rewrite modulusZE. - apply Z_lor_pow2. - split. apply Z.lor_nonneg. split. lia. apply Z.shiftl_nonneg. lia. - apply Z_lor_pow2. - split. lia. - eapply Z.lt_trans. - apply i. - easy. - - rewrite <- modulusZE. - apply shiftl_bounds. easy. - split. lia. - eapply Z.lt_trans. - apply i0. - easy. - - rewrite <- modulusZE. - apply shiftl_bounds. easy. - split. lia. - eapply Z.lt_le_trans. - apply i1. - easy. - } - 2:{ - destruct t0. - apply (ssrbool.elimT (iswordZP _ _)) in i. - destruct t1. - apply (ssrbool.elimT (iswordZP _ _)) in i0. - split. - - apply Z.lor_nonneg. split. lia. - apply Z.shiftl_nonneg. lia. - - rewrite modulusZE. - apply Z_lor_pow2. - split. lia. - eapply Z.lt_trans. - apply i. - easy. - - rewrite <- modulusZE. - apply shiftl_bounds. easy. - split. lia. - eapply Z.lt_le_trans. - apply i0. - easy. - } - rewrite !Z.shiftl_lor. rewrite <- !Z.lor_assoc. @@ -1379,6 +1288,37 @@ Section Hacspec. reflexivity. all: try easy. + all: try rewrite Zmod_small. + + all: try (apply (ssrbool.elimT (iswordZP _ _)) ; now destruct t0). + all: try split. + + all: try (rewrite modulusZE ; apply Z_lor_pow2 ; rewrite <- modulusZE). + all: try apply shiftl_bounds. + all: try (rewrite modulusZE ; apply Z_lor_pow2 ; rewrite <- modulusZE). + all: try apply shiftl_bounds. + all: try easy. + + all: try apply Z.lor_nonneg. + all: try split. + all: try apply Z.shiftl_nonneg. + all: try apply Z.lor_nonneg. + all: try split. + all: try apply Z.shiftl_nonneg. + all: try apply Z.lor_nonneg. + all: try split. + all: try apply Z.shiftl_nonneg. + all: try easy. + + all: try apply (modulus_exact t). + all: try apply (modulus_exact t0). + all: try apply (modulus_exact t1). + all: try apply (modulus_exact t2). + + all: try (apply (modulus_smaller U8 16) ; easy). + all: try (apply (modulus_smaller U8 24) ; easy). + all: try (apply (modulus_smaller U8 32) ; easy). + all: cbn ; lia. Qed. Ltac match_pattern_and_bind_repr p := @@ -1424,7 +1364,7 @@ Section Hacspec. ] end end. - + Lemma keygen_assist_eq id0 (v1 : 'word U128) (v2 : 'word U8) (pre : precond) : (pdisj pre id0 (CEfset [res_238_loc])) -> ⊢ ⦃ pre ⦄ @@ -1521,7 +1461,7 @@ Section Hacspec. apply r_ret. intros. split. - - reflexivity. + - reflexivity. - apply H0. } @@ -1541,19 +1481,13 @@ Section Hacspec. rewrite !Zmod_small. f_equal. - + apply (modulus_smaller U32 U128). easy. + all: try (apply (modulus_smaller U32 U128) ; easy). + apply (shiftl_bounds _ 96 128). easy. apply (modulus_exact a₁4). - + apply (modulus_smaller U32 U128). easy. - + apply (modulus_smaller U32 U128). easy. + apply (shiftl_bounds _ 64 128). easy. apply (modulus_smaller U32 U64). easy. - + apply (modulus_smaller U32 U128). easy. - + apply (modulus_smaller U32 U128). easy. + apply (shiftl_bounds _ 32 128). easy. apply (modulus_smaller U32 96). easy. - + apply (modulus_smaller U32 U128). easy. - + apply (modulus_smaller U32 U128). easy. + (* destruct a₁1 , a₁2 , a₁3 , a₁4. *) (* unfold urepr, val, word_subType, word.toword. *) (* apply (ssrbool.elimT (iswordZP _ _)) in i, i0, i1, i2. *) @@ -1733,15 +1667,13 @@ Section Hacspec. reflexivity. reflexivity. - rewrite ![set_heap _ (translate_var s_id' v) a]set_heap_commut. - + reflexivity. - + admit. - + admit. - + admit. - + admit. - - intros. - subst. - discriminate. + rewrite ![set_heap _ (translate_var s_id' v) a]set_heap_commut + ; (reflexivity || + (apply injective_translate_var2 ; + red ; + intros ; + subst ; + now apply (precneq_I s_id'))). Unshelve. { @@ -1779,11 +1711,13 @@ Section Hacspec. reflexivity. reflexivity. - rewrite ![set_heap _ (translate_var s_id' v) a]set_heap_commut. - reflexivity. - admit. - admit. - admit. + rewrite ![set_heap _ (translate_var s_id' v) a]set_heap_commut ; + (reflexivity || + (apply injective_translate_var2 ; + red ; + intros ; + subst ; + now apply (precneq_I s_id'))). - intros. subst. destruct_pre. @@ -1801,8 +1735,8 @@ Section Hacspec. reflexivity. reflexivity. } - Transparent translate_call. - Admitted. + - easy. +Qed. (* End Hacspec. *) From cb9bbafc1ef11c958eae78fb9c779c26794a8d65 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Wed, 11 Jan 2023 20:54:31 +0100 Subject: [PATCH 344/383] Done with key_expand (cleanup) --- theories/Jasmin/examples/aes/aes_hac.v | 122 +++---------------------- 1 file changed, 14 insertions(+), 108 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes_hac.v b/theories/Jasmin/examples/aes/aes_hac.v index 2e357d43..bda40979 100644 --- a/theories/Jasmin/examples/aes/aes_hac.v +++ b/theories/Jasmin/examples/aes/aes_hac.v @@ -95,11 +95,6 @@ Section Hacspec. eapply (@r_bind _ _ _ _ (ret jazz) _ (fun x => putr l x f) _ _ (fun '(v0, h0) '(v1, h1) => v0 = v1 /\ P (h0, h1)) _) ; [ rewrite !zero_extend_u | intros ] end. - (* match goal with *) - (* | [ |- context [ ⊢ ⦃ ?P ⦄ putr ?l ?jazz ?f ≈ _ ⦃ ?Q ⦄ ] ] => *) - (* apply (@r_bind _ _ _ _ (ret jazz) _ (fun x => putr l x f) _ _ Q _) ; [ | intros ; unfold pre_to_post ] *) - (* end. *) - Ltac remove_get_in_lhs := eapply better_r_get_remind_lhs ; unfold Remembers_lhs , rem_lhs ; @@ -205,7 +200,6 @@ Section Hacspec. Lemma wpshufd1_eq : forall (rkey : 'word U128) (i : nat) (n : nat), i < 4 -> - (* (Z.of_nat n mod modulus nat7.+1 < modulus (2 + 2 * i))%Z -> *) wpshufd1 rkey (wrepr U8 n) i = is_pure (vpshufd1 rkey (Hacspec_Lib_Pre.repr n) (Hacspec_Lib_Pre.repr i)). Proof. @@ -442,9 +436,6 @@ Section Hacspec. unfold wpshufd_128. unfold iota. unfold map. - (* set (wpshufd1 _ _ _). *) - (* set (wpshufd1 _ _ _). *) - (* set (wpshufd1 _ _ _). *) unfold vpshufd. solve_wpshufd1_vpshufd1 0 n. @@ -518,9 +509,6 @@ Section Hacspec. unfold vshufps. unfold iota. unfold map. - (* set (wpshufd1 _ _ _). *) - (* set (wpshufd1 _ _ _). *) - (* set (wpshufd1 _ _ _). *) unfold vpshufd. solve_wpshufd1_vpshufd1 0 n. @@ -594,7 +582,6 @@ Section Hacspec. simpl in r. unfold translate_call, translate_call_body in r |- *. Opaque translate_call. - (* unfold ssprove_jasmin_prog in r. *) simpl in r. subst r. @@ -930,9 +917,6 @@ Section Hacspec. intuition. Qed. - Check word.subword (1 * U32)%nat U32. - (* let x1 := subword (1 * U32) U32 v1 in *) - (* let x1 = (v1 >> 32) % (1_u128 << 32); *) Lemma subword_eq (n : int128) (i : nat): (i < 4) -> word.subword (i * U32)%nat U32 n = @@ -994,7 +978,6 @@ Section Hacspec. rewrite modulusZE. apply (Z.pow_le_mono_r 2). reflexivity. - (* apply Nat2Z.inj_le. *) apply H. Qed. @@ -1180,7 +1163,6 @@ Section Hacspec. Unset Printing Coercions. - (* rewrite !Zmod_small. *) rewrite !Z.shiftl_mul_pow2 ; try easy. simpl. @@ -1218,9 +1200,6 @@ Section Hacspec. all: try easy. - (* apply Z.bits_inj. *) - (* intros i. *) - assert (H_lor_add : forall (a b : Z) (k : nat), (0 <= a < modulus k)%Z -> (a + Z.shiftl b k)%Z = Z.lor a (Z.shiftl b k)). { clear ; intros. @@ -1309,7 +1288,7 @@ Section Hacspec. all: try split. all: try apply Z.shiftl_nonneg. all: try easy. - + all: try apply (modulus_exact t). all: try apply (modulus_exact t0). all: try apply (modulus_exact t1). @@ -1337,7 +1316,7 @@ Section Hacspec. let fv := fresh in set (av := a) ; set (fv := f) - ; eapply (r_bind (ret p) av _ fv P (fun '(v0, h0) '(v1, h1) => v0 = repr v1 /\ P (h0, h1)) Q) (* (v0 = v1) *) + ; eapply (r_bind (ret p) av _ fv P (fun '(v0, h0) '(v1, h1) => v0 = repr v1 /\ P (h0, h1)) Q) ; subst av fv ; hnf ; [ | intros ; apply rpre_hypothesis_rule' ; intros ? ? [] ; apply rpre_weaken_rule with (pre := fun '(s₀, s₁) => P (s₀, s₁)) ] end @@ -1359,7 +1338,7 @@ Section Hacspec. let fv := fresh in set (av := a) ; set (fv := f) - ; eapply (r_bind (ret p) av _ fv P (fun '(v0, h0) '(v1, h1) => v0 = v1 /\ P (h0, h1)) Q) (* (v0 = v1) *) + ; eapply (r_bind (ret p) av _ fv P (fun '(v0, h0) '(v1, h1) => v0 = v1 /\ P (h0, h1)) Q) ; subst av fv ; hnf ; [ | intros ; apply rpre_hypothesis_rule' ; intros ? ? [] ; apply rpre_weaken_rule with (pre := fun '(s₀, s₁) => P (s₀, s₁)) ] end @@ -1369,34 +1348,12 @@ Section Hacspec. (pdisj pre id0 (CEfset [res_238_loc])) -> ⊢ ⦃ pre ⦄ ret (waes.wAESKEYGENASSIST v1 v2) - (* (tr_app_sopn_tuple (w2_ty U128 U8) *) - (* (sopn_sem (Oasm (BaseOp (None, VAESKEYGENASSIST)))) *) - (* [totce v1; totce v2]) *) ≈ prog (is_state (aeskeygenassist v1 v2)) ⦃ fun '(v0, h0) '(v1, h1) => (v0 = v1) /\ pre (h0, h1) ⦄. Proof. intros. - (* let rcon := zero_extend U32 v2 in *) - (* let x1 := subword (1 * U32) U32 v1 in *) - (* let x3 := subword (3 * U32) U32 v1 in *) - (* let y0 := SubWord x1 in *) - (* let y1 := wxor (wror (SubWord x1) 1) rcon in *) - (* let y2 := SubWord x3 in *) - (* let y3 := wxor (wror (SubWord x3) 1) rcon in *) - (* make_vec U128 [:: y0; y1; y2; y3]. *) - - - (* let x1 = (v1 >> 32) % (1_u128 << 32); *) - (* let x3 = (v1 >> 96) % (1_u128 << 32); *) - (* let y0 = subword(x1 as u32); *) - (* let y1 = ror(subword(x1 as u32), 1) ^ (v2 as u32); *) - (* let y2 = subword(x3 as u32); *) - (* let y3 = ror(subword(x3 as u32), 1) ^ (v2 as u32); *) - (* (y0 as u128) | ((y1 as u128) << 32) | ((y2 as u128) << 64) | (((y3) as u128) << 96) *) - - unfold waes.wAESKEYGENASSIST. unfold make_vec. @@ -1406,8 +1363,6 @@ Section Hacspec. unfold aeskeygenassist. - (* Unfold let both and match *) - (* unfold let_both at 1, is_state at 1, prog. *) match_pattern_and_bind_repr (@word.subword (wsize_size_minus_1 U128).+1 (1 * U32) U32 v1). { apply r_ret. @@ -1416,8 +1371,6 @@ Section Hacspec. split. reflexivity. assumption. } - - (* unfold let_both at 1, is_state at 1, prog. *) match_pattern_and_bind_repr (@word.subword (wsize_size_minus_1 U128).+1 (3 * U32) U32 v1). { apply r_ret. @@ -1455,7 +1408,7 @@ Section Hacspec. } match_pattern_and_bind (word.wxor (wror (sz:=U32) a₀3 1) - (zero_extend U32 (sz':=U8) v2)). + (zero_extend U32 (sz':=U8) v2)). { subst. apply r_ret. @@ -1488,10 +1441,7 @@ Section Hacspec. apply (modulus_smaller U32 U64). easy. + apply (shiftl_bounds _ 32 128). easy. apply (modulus_smaller U32 96). easy. - + (* destruct a₁1 , a₁2 , a₁3 , a₁4. *) - (* unfold urepr, val, word_subType, word.toword. *) - (* apply (ssrbool.elimT (iswordZP _ _)) in i, i0, i1, i2. *) - split. + + split. * apply Z.lor_nonneg. split. apply word_geZ0. apply Z.lor_nonneg. split. apply Z.shiftl_nonneg. apply word_geZ0. apply Z.lor_nonneg. split. apply Z.shiftl_nonneg. apply word_geZ0. @@ -1553,16 +1503,6 @@ Section Hacspec. eapply rpre_weak_hypothesis_rule'. intros ? ? [? H]. - (* set (set_lhs _ _ _) in H. *) - (* apply rpre_weaken_rule with (pre := λ s : heap * heap, s.1 = s₀ ∧ s.2 = s₁ /\ p s). *) - (* } *) - - - (* apply H. *) - (* s.1 = s₀ ∧ s.2 = s₁ /\ set_lhs ($$"temp2.317") temp2 *) - (* (set_lhs ($$"rkey.316") rkey *) - (* (set_lhs ($$"rcon.315") (coe_cht 'int (coe_cht 'int rcon)) pre)) *) - (* (s₀, s₁)). *) apply better_r_put_lhs. do 3 remove_get_in_lhs. @@ -1585,7 +1525,6 @@ Section Hacspec. eexists. split. reflexivity. - (* reflexivity. *) inversion H25. subst. inversion H24. @@ -1593,41 +1532,15 @@ Section Hacspec. cbn. now rewrite !zero_extend_u. - (* do 2 (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). *) - - (* CAN BE DONE WITH: pdisj_apply H_pdisj. *) - destruct H_pdisj. - repeat eapply H ; easy. + pdisj_apply H_pdisj. } subst. subst P. - (* eapply rpre_hypothesis_rule. *) - (* intros ? ? [? [[]]]. *) - (* subst. *) - (* (* apply rpre_weaken_rule with (pre := pre). *) *) - - (* 2:{ *) - (* intros ? ? []. *) - (* destruct_pre. *) - (* destruct H_pdisj. *) - (* eapply H; try easy. *) - (* eapply H; try easy. *) - (* eapply H; try easy. *) - (* eapply H; try easy. *) - (* } *) - - (* (* eapply rpost_weaken_rule. *) *) - intros. apply (key_combined_eq (id0~1)%positive rkey a₁ temp2). - (* Unset Printing Notations. *) - - (* eapply H_pdisj. *) - - (* destruct H_pdisj. *) split. - intros. subst. @@ -1637,12 +1550,7 @@ Section Hacspec. subst. unfold set_lhs. - (* exists (set_heap x0 (translate_var id0~1 v) a). *) subst. - (* inversion H3. *) - (* subst. *) - (* exists (set_heap x0 (translate_var id0~1 v) a). *) - (* rewrite set_heap_contract. *) destruct_pre. repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). eexists. @@ -1654,9 +1562,7 @@ Section Hacspec. eexists. split. exists (set_heap H9 (translate_var s_id' v) a). - (* eexists. *) split. - (* apply H10. *) eapply H_pdisj. reflexivity. etransitivity. @@ -1668,7 +1574,7 @@ Section Hacspec. reflexivity. rewrite ![set_heap _ (translate_var s_id' v) a]set_heap_commut - ; (reflexivity || + ; (reflexivity || (apply injective_translate_var2 ; red ; intros ; @@ -1712,12 +1618,12 @@ Section Hacspec. reflexivity. rewrite ![set_heap _ (translate_var s_id' v) a]set_heap_commut ; - (reflexivity || - (apply injective_translate_var2 ; - red ; - intros ; - subst ; - now apply (precneq_I s_id'))). + (reflexivity || + (apply injective_translate_var2 ; + red ; + intros ; + subst ; + now apply (precneq_I s_id'))). - intros. subst. destruct_pre. @@ -1737,6 +1643,6 @@ Section Hacspec. } - easy. -Qed. + Qed. (* End Hacspec. *) From 99350cfb111de1c267ba8e5aab31bdad284afb69 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Thu, 12 Jan 2023 18:23:31 +0100 Subject: [PATCH 345/383] Updated to changes in hacspec --- theories/Jasmin/examples/aes/aes_hac.v | 50 ++++++++++---------------- 1 file changed, 19 insertions(+), 31 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes_hac.v b/theories/Jasmin/examples/aes/aes_hac.v index bda40979..08854c6a 100644 --- a/theories/Jasmin/examples/aes/aes_hac.v +++ b/theories/Jasmin/examples/aes/aes_hac.v @@ -26,7 +26,7 @@ From JasminSSProve Require Import aes_jazz jasmin_utils. Import JasminNotation JasminCodeNotation. Import PackageNotation. -From Hacspec Require Import Hacspec_Aes_Jazz ChoiceEquality Hacspec_Lib Hacspec_Lib_Pre. +From Hacspec Require Import Hacspec_Aes_Jazz ChoiceEquality Hacspec_Lib Hacspec_Lib_Pre Hacspec_Lib_Comparable. Open Scope hacspec_scope. Notation call fn := (translate_call _ fn _). @@ -1008,10 +1008,11 @@ Section Hacspec. destruct (word.subword (i * U8) U8 n). destruct toword. - reflexivity. - - do 8 (destruct p ; [ | | reflexivity ]). + - (* SLOW! *) (* admit. *) + do 8 (destruct p ; [ | | reflexivity ]). all: destruct p ; easy. - easy. - Qed. + (* Admitted. *) Qed. Lemma SubWord_eq id0 (n : int32) pre : (pdisj pre id0 (CEfset ([res_238_loc]))) -> @@ -1078,27 +1079,14 @@ Section Hacspec. unfold repr, unsigned. rewrite <- !sbox_eq ; try easy. + rewrite Hacspec_Lib_Pre.array_to_list_equation_2. + rewrite Hacspec_Lib_Pre.array_to_list_equation_2. + rewrite Hacspec_Lib_Pre.array_to_list_equation_2. + rewrite Hacspec_Lib_Pre.array_to_list_equation_2. rewrite Hacspec_Lib_Pre.array_to_list_equation_1. - unfold Hacspec_Lib_Pre.array_to_list_clause_1. - unfold Hacspec_Lib_Pre.array_to_list_obligations_obligation_1. - - rewrite Hacspec_Lib_Pre.array_to_list_helper_equation_2. - unfold Hacspec_Lib_Pre.array_to_list_helper_clause_2. - unfold Hacspec_Lib_Pre.array_to_list_helper_clause_2_clause_1. - - rewrite Hacspec_Lib_Pre.array_to_list_helper_equation_2. - unfold Hacspec_Lib_Pre.array_to_list_helper_clause_2. - unfold Hacspec_Lib_Pre.array_to_list_helper_clause_2_clause_1. - rewrite Hacspec_Lib_Pre.array_to_list_helper_equation_2. - unfold Hacspec_Lib_Pre.array_to_list_helper_clause_2. - unfold Hacspec_Lib_Pre.array_to_list_helper_clause_2_clause_1. + unfold nseq_hd. - rewrite Hacspec_Lib_Pre.array_to_list_helper_equation_2. - unfold Hacspec_Lib_Pre.array_to_list_helper_clause_2. - unfold Hacspec_Lib_Pre.array_to_list_helper_clause_2_clause_1. - - rewrite Hacspec_Lib_Pre.array_to_list_helper_equation_1. set ([ _ ; _ ; _ ; _ ]). replace (make_vec U32 l) with (4, make_vec U32 l).2 by reflexivity. @@ -1125,15 +1113,15 @@ Section Hacspec. unfold Hacspec_Lib_Pre.array_new_. simpl. - rewrite eq_rect_K. - set (getm _ _). - cbn in o. - subst o. - hnf. - set (_ ++ _). - cbn in l. - subst l. - hnf. + (* rewrite eq_rect_K. *) + (* set (getm _ _). *) + (* cbn in o. *) + (* subst o. *) + (* hnf. *) + (* set (_ ++ _). *) + (* cbn in l. *) + (* subst l. *) + (* hnf. *) unfold fold_right. unfold set_nth. @@ -1645,4 +1633,4 @@ Section Hacspec. - easy. Qed. -(* End Hacspec. *) +End Hacspec. From 62d67dafeb41dd09c84b10dee8dcd439448c8feb Mon Sep 17 00:00:00 2001 From: "Benjamin S. Hvass" Date: Mon, 16 Jan 2023 17:12:11 +0100 Subject: [PATCH 346/383] remove word admits --- theories/Jasmin/examples/aes/aes.v | 8 +- theories/Jasmin/examples/aes/aes_spec.v | 2 +- theories/Jasmin/word.v | 294 +++++++++++++++++------- 3 files changed, 212 insertions(+), 92 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes.v b/theories/Jasmin/examples/aes/aes.v index f1dc87ee..0ad57bf3 100644 --- a/theories/Jasmin/examples/aes/aes.v +++ b/theories/Jasmin/examples/aes/aes.v @@ -92,7 +92,7 @@ Proof. rewrite -wxorA. rewrite wxor_involutive. rewrite wxor_0_l. - rewrite wror_substitute. + rewrite RotWord_SubWord. unfold word.wxor. f_equal. rewrite wreprI. @@ -123,7 +123,7 @@ Proof. rewrite H0. rewrite wxor_0_l. f_equal. - rewrite wror_substitute. + rewrite RotWord_SubWord. unfold word.wxor. f_equal. rewrite wreprI. @@ -157,7 +157,7 @@ Proof. rewrite wxor_0_l. f_equal. f_equal. - rewrite wror_substitute. + rewrite RotWord_SubWord. unfold word.wxor. f_equal. rewrite wreprI. @@ -192,7 +192,7 @@ Proof. rewrite subword_wshr; auto. rewrite addn0. f_equal. - rewrite wror_substitute. + rewrite RotWord_SubWord. rewrite wxorC. rewrite wxorA. f_equal. diff --git a/theories/Jasmin/examples/aes/aes_spec.v b/theories/Jasmin/examples/aes/aes_spec.v index 11cb5a6e..019c6880 100644 --- a/theories/Jasmin/examples/aes/aes_spec.v +++ b/theories/Jasmin/examples/aes/aes_spec.v @@ -36,7 +36,7 @@ Definition key_expand (wn1 : u128) (rcon : u8) : 'word U128 := let w2 := subword (2 * U32) U32 wn1 in let w3 := subword (3 * U32) U32 wn1 in let tmp := w3 in - let tmp := SubWord (wror tmp 1) ⊕ rcon in + let tmp := SubWord (RotWord tmp) ⊕ rcon in let w4 := w0 ⊕ tmp in let w5 := w1 ⊕ w4 in let w6 := w2 ⊕ w5 in diff --git a/theories/Jasmin/word.v b/theories/Jasmin/word.v index 1f2158e5..19e363bc 100644 --- a/theories/Jasmin/word.v +++ b/theories/Jasmin/word.v @@ -75,41 +75,6 @@ Proof. reflexivity. Qed. -Lemma wbit_subword {ws1} i ws2 (w : word ws1) j : - (ws2 <= ws1)%nat -> - (j < ws2)%nat -> - wbit (subword i ws2 w) j = wbit w (i + j)%nat. -Proof. - intros. - unfold subword. - simpl. - unfold urepr. - simpl. - unfold wbit. - simpl. - unfold modulus. - rewrite !two_power_nat_equiv. - rewrite Z.mod_pow2_bits_low. - { rewrite Z.mod_pow2_bits_low. 2: lia. - rewrite Z.shiftr_spec. 2: lia. - f_equal. lia. - } - lia. -Qed. - -Lemma subword_xor {n} i ws (a b : n.-word) : - (* I don't know if the assumption is necessary *) - (ws <= n)%nat -> - subword i ws (a ⊕ b) = (subword i ws a) ⊕ (subword i ws b). -Proof. - intros H. - apply/eqP/eq_from_wbit. - intros. rewrite !wbit_subword. 2,3: auto. - rewrite !wxorE. - rewrite !wbit_subword. 2-5: auto. - reflexivity. -Qed. - Lemma nth_aux {T} (a : T) l : [seq nth a l (val i) | i <- enum 'I_(size l)] = l. Proof. @@ -216,32 +181,47 @@ Proof. rewrite shiftr_shiftr_mod; try lia. Qed. -From Jasmin Require Import word. -Lemma subword_u {ws : wsize} (w : word ws) : subword 0 ws w = w. -Proof. by rewrite subword0 zero_extend_u. Qed. +Lemma wbit_subword {ws1} i ws2 (w : word ws1) (j : 'I_ws2) : + (* (ws2 <= ws1)%nat -> *) + (* (j < ws2)%nat -> *) + wbit (subword i ws2 w) j = wbit w (i + j)%nat. +Proof. + intros. + unfold subword. + rewrite wbit_mkword. + apply wbit_lsr. +Qed. -Lemma wbit_wrepr (ws : wsize.wsize) a i : - (i < ws)%nat -> - word.word.wbit (urepr (wrepr ws a)) i = word.word.wbit a i. +Lemma subword_xor {n} i ws (a b : n.-word) : + (* I don't know if the assumption is necessary *) + (* (ws <= n)%nat -> *) + subword i ws (a ⊕ b) = (subword i ws a) ⊕ (subword i ws b). Proof. - move=>H/=. - rewrite/word.word.wbit/wrepr/urepr=>/=. - rewrite/modulus two_power_nat_equiv Z.mod_pow2_bits_low=>//. - unfold nat_of_wsize in *. lia. + (* intros H. *) + apply/eqP/eq_from_wbit. + intros. rewrite !wbit_subword. + rewrite !wxorE. + rewrite !wbit_subword. + reflexivity. Qed. -Lemma wbit_make_vec {ws1} (ws2 : wsize) (l : seq (word.word ws1)) i : - (i < ws2)%nat -> - word.word.wbit (urepr (make_vec ws2 l)) i = word.word.wbit (nth word0 l (i %/ ws1)) (i %% ws1). +(** AES *) + +Lemma subword_subword {k} i j n m (w : k.-word) : (i + n <= m)%nat -> subword i n (subword j m w) = subword (i + j) n w. Proof. - move=> H. - rewrite /make_vec wcat_r_wcat wbit_wrepr=>//. - rewrite wcat_wbitE=>/=. - repeat f_equal. - apply nth_aux. + intros. + apply/eqP/eq_from_wbit => l. + rewrite !wbit_subword. + assert (i + l < m)%nat. 1: destruct l; simpl; lia. + change (i + l)%nat with (@Ordinal m (i + l) H0 : nat). + rewrite wbit_subword. + f_equal. + simpl. lia. Qed. +Locate "`_". + Lemma divn_aux j i n : (j < n)%nat -> (n <= j %% n + i %% n)%nat = false -> @@ -264,6 +244,122 @@ Proof. rewrite modn_small. all: lia. Qed. +(* Local Open Scope ring_scope. *) +Lemma subword_wcat {n p} i l (s : p.-tuple n.-word) : + (* i + l does 'reach across' a single word in the tuple *) + (l <= n)%nat -> + ((l - 1) %% n + i %% n < n)%nat -> + subword i l (wcat s) = subword (i %% n) l (s`_(i %/ n))%R. +Proof. + intros H1 (* H2 *) H3. + rewrite !subwordE. + f_equal. + apply eq_mktuple => j. + rewrite wcat_wbitE. + destruct j. simpl. + f_equal. + - f_equal. f_equal. + apply divn_aux. 1:{ simpl. lia. } + rewrite modn_small in H3. 2: lia. + rewrite modn_small. 2: lia. + lia. + - apply modn_aux. 1: lia. + rewrite modn_small in H3. 2: lia. + rewrite modn_small. 1: lia. + lia. +Qed. + +(* Lemma nth_wsplitnec {n p} (i : 'I_p) (w : (n * p).-word) : *) +(* (* (n < n %/ l + n %% l)%nat -> *) *) +(* ((wsplitn w)`_i)%R = subword (i * n) n w. *) +(* Proof. *) +(* (* intros H. *) *) +(* (* unfold split_vec. *) *) +(* unfold wsplitn. *) +(* (* Unset Printing Notations. *) *) +(* (* pose proof nth_mktuple . *) *) +(* rewrite *) +(* rewrite (nth_map 0). *) +(* erewrite nth_map. *) +(* 1: f_equal; rewrite nth_iota; try lia. *) +(* rewrite size_iota. *) +(* assumption. *) +(* Unshelve. exact 0%nat. *) +(* Qed. *) + +Lemma mkword_word {n} (w : n.-word) : + mkword n w = w. +Proof. + apply val_inj; simpl. + rewrite Z.mod_small. + 1: reflexivity. + destruct w. simpl. lia. +Qed. + +Lemma subword_u {n} (w : n.-word) : subword 0 n w = w. +Proof. + unfold subword. unfold lsr. rewrite Z.shiftr_0_r. rewrite ureprK. + apply mkword_word. +Qed. + +From Jasmin Require Import word. + +(* Lemma make_vec_eq {ws1 ws2 : wsize} {p : nat} a t : *) +(* (p * ws1 = ws2) -> *) +(* (forall (i : 'I_p), subword (i * ws1) ws1 a = nth word0 t i) -> a = make_vec ws2 t. *) +(* Proof. *) +(* intros. *) +(* unfold make_vec. *) +(* unfold wrepr. *) +(* apply val_inj. *) +(* simpl. *) +(* rewrite wcat *) + +(* Lemma wcat_eq ws p a t : *) +(* (forall (i : 'I_p), subword (i * ws) ws a = tnth t i) -> a = wcat t. *) +(* Proof. *) +(* intros. *) +(* rewrite -[a]wcat_subwordK. *) +(* apply f_equal. apply eq_from_tnth. *) +(* intros i. *) +(* rewrite -H tnth_map tnth_ord_tuple. *) +(* reflexivity. *) +(* Qed. *) + +Lemma wbit_wrepr (ws : wsize.wsize) a i : + (i < ws)%nat -> + word.word.wbit (urepr (wrepr ws a)) i = word.word.wbit a i. +Proof. + move=>H/=. + rewrite/word.word.wbit/wrepr/urepr=>/=. + rewrite/modulus two_power_nat_equiv Z.mod_pow2_bits_low=>//. + unfold nat_of_wsize in *. lia. +Qed. + +Lemma wbit_make_vec {ws1} (ws2 : wsize) (l : seq (word.word ws1)) i : + (i < ws2)%nat -> + word.word.wbit (urepr (make_vec ws2 l)) i = word.word.wbit (nth word0 l (i %/ ws1)) (i %% ws1). +Proof. + move=> H. + rewrite /make_vec wcat_r_wcat wbit_wrepr=>//. + rewrite wcat_wbitE=>/=. + repeat f_equal. + apply nth_aux. +Qed. + +Lemma wbit_n_make_vec {ws1} (ws2 : wsize) (l : seq (word ws1)) i : + (i < ws2)%nat -> + wbit_n (make_vec ws2 l) i = wbit_n (nth word0 l (i %/ ws1)) (i %% ws1). +Proof. + move=> H. + unfold wbit_n. + rewrite /make_vec wcat_r_wcat wbit_wrepr=>//. + rewrite wcat_wbitE=>/=. + repeat f_equal. + rewrite nth_aux. + reflexivity. +Qed. + Lemma subword_make_vec_full {ws1} i (ws2 ws3 : wsize.wsize) (l : seq (word.word ws1)) : (* i + ws2 does 'reach across' a single word in the list *) (ws2 <= ws1)%nat -> @@ -292,6 +388,8 @@ Proof. lia. Qed. +(* Lemma subw *) + Lemma subword_make_vec {ws1} i (ws2 : wsize.wsize) (l : seq (word.word ws1)) : (ws1 <= ws2)%nat -> ((i + 1) * ws1 <= ws2)%nat -> @@ -395,6 +493,16 @@ Proof. all: unfold nat_of_wsize, wsize_size_minus_1; easy. Qed. +Lemma SubBytes_make_vec l : + (size l = 4)%nat -> + SubBytes (make_vec U128 l) = make_vec U128 [seq SubWord i | i <- l]. +Proof. + intros. + unfold SubBytes. + rewrite split_vec_make_vec. + all: unfold nat_of_wsize, wsize_size_minus_1; easy. +Qed. + Lemma subword_make_vec_32_0_32_128 (l : seq u32) : subword 0 U32 (make_vec U128 l) = nth word0 l 0. Proof. rewrite subword_make_vec_full; rewrite ?subword_u. @@ -419,28 +527,6 @@ Proof. all: auto. Qed. -Lemma wbit_wror {ws} (a : word ws) n m : wbit_n (wror a n) m = wbit_n a (Z.to_nat (((Z.of_nat m) - n) mod (wsize_bits ws)))%Z. -Proof. - unfold wror. - (* rewrite urepr_word. *) - (* wbit_n *) - rewrite worE. - rewrite wshrE. - rewrite wshlE. - destruct ((Z.to_nat (wsize_bits ws - n mod wsize_bits ws) <= m <= wsize_size_minus_1 ws))%nat eqn:E. - { cbn -[Z.sub]. - rewrite Nat2Z.inj_add. - (* rewrite Z2Nat.inj_add. *) - rewrite Z2Nat.id. - 2: admit. admit. } -Admitted. - -Lemma wror_substitute w k : wror (SubWord w) k = SubWord (wror w k). -Proof. - unfold SubWord. - unfold wror. - (* I would like to case on w, but not sure how to do this most efficiently? *) -Admitted. Lemma wreprI ws (a : word.word ws) : wrepr ws (toword a) = a. Proof. @@ -450,13 +536,47 @@ Qed. (** AES *) +Lemma subword_SubWord n w : + (0 <= n < 4)%nat -> subword (n * U8) U8 (SubWord w) = Sbox (subword (n * U8) U8 w). +Proof. + intros. + unfold SubWord. + rewrite subword_make_vec. + 1: erewrite nth_map; f_equal. + all: try (unfold nat_of_wsize, wsize_size_minus_1; zify; simpl; lia). + apply nth_split_vec. + cbn. lia. + Unshelve. exact word0. +Qed. + +Lemma subword_SubBytes n w : (0 <= n < 4)%nat -> subword (n * U32) U32 (SubBytes w) = SubWord (subword (n * U32) U32 w). +Proof. + intros. + unfold SubBytes. + rewrite subword_make_vec. + 1: erewrite nth_map; f_equal. + all: try (unfold nat_of_wsize, wsize_size_minus_1; zify; simpl; lia). + apply nth_split_vec. + cbn. lia. + Unshelve. exact word0. +Qed. + +(* Check SubBytes. *) + Lemma ShiftRows_SubBytes s : ShiftRows (SubBytes s) = SubBytes (ShiftRows s). Proof. - unfold ShiftRows, SubBytes. simpl. - f_equal. f_equal. - all: rewrite !subword_make_vec_32_0_32_128 !subword_make_vec_32_1_32_128 !subword_make_vec_32_2_32_128 !subword_make_vec_32_3_32_128; simpl; - rewrite -> !subword_U8_SubWord by lia; - rewrite -> !SubWord_make_vec by reflexivity; reflexivity. + unfold ShiftRows. simpl. + rewrite !subword_SubBytes; try reflexivity. + rewrite !subword_SubWord; try reflexivity. + rewrite SubBytes_make_vec; auto. simpl. + rewrite !SubWord_make_vec; auto. +Qed. + +Lemma RotWord_SubWord w : RotWord (SubWord w) = SubWord (RotWord w). +Proof. + unfold RotWord. + rewrite SubWord_make_vec; auto. + rewrite !subword_SubWord; auto. Qed. Lemma wAESENC_wAESENC_ s k : wAESENC s k = wAESENC_ s k. @@ -467,13 +587,13 @@ Proof. reflexivity. Qed. -(* NOTE: This is only so simple because InvMixColumns is not properly implemented *) -Lemma AESDEC_AESDEC_ s k : wAESDEC s (InvMixColumns k) = wAESDEC_ s k. -Proof. - unfold wAESDEC, wAESDEC_. - unfold InvMixColumns. - reflexivity. -Qed. +(* (* NOTE: This is only so simple because InvMixColumns is not properly implemented *) *) +(* Lemma AESDEC_AESDEC_ s k : wAESDEC s (InvMixColumns k) = wAESDEC_ s k. *) +(* Proof. *) +(* unfold wAESDEC, wAESDEC_. *) +(* unfold InvMixColumns. *) +(* reflexivity. *) +(* Qed. *) Lemma wAESENCLAST_wAESENCLAST_ s k : wAESENCLAST s k = wAESENCLAST_ s k. Proof. From cf4384a0af522b19fc013f6085a689f260bda6d2 Mon Sep 17 00:00:00 2001 From: "Benjamin S. Hvass" Date: Wed, 18 Jan 2023 14:26:54 +0100 Subject: [PATCH 347/383] remove remaining admits --- theories/Jasmin/examples/aes/aes.v | 21 +++-- theories/Jasmin/examples/aes/aes_prf.v | 114 +++++++++++++++++------ theories/Jasmin/examples/aes/aes_spec.v | 16 +++- theories/Jasmin/examples/aes/aes_utils.v | 70 ++++++++++---- 4 files changed, 165 insertions(+), 56 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes.v b/theories/Jasmin/examples/aes/aes.v index 0ad57bf3..f34c373b 100644 --- a/theories/Jasmin/examples/aes/aes.v +++ b/theories/Jasmin/examples/aes/aes.v @@ -258,7 +258,7 @@ Proof. Qed. Lemma keyExpansion_E pre id0 rkey : - (pdisj pre id0 [fset rkeys]) -> + (pdisj pre id0 (fset [rkeys])) -> ⊢ ⦃ fun '(h0, h1) => pre (h0, h1) ⦄ JKEYS_EXPAND id0 rkey ≈ @@ -405,7 +405,7 @@ Proof. split_post. (* here we prove that the invariant is preserved after a single loop, assuming it holds before *) - { pdisj_apply disj. } + { pdisj_apply disj. auto_in_fset. } { assumption. } { replace (Z.succ i - 1) with i by lia. rewrite chArray_get_set_eq. @@ -447,7 +447,7 @@ Proof. split_post. (* prove that pre is preserved *) - * pdisj_apply disj. + * pdisj_apply disj. all: auto_in_fset. (* first invariant *) * simpl. unfold tr_app_sopn_tuple. simpl. rewrite subword_word0. reflexivity. (* second invariant *) @@ -481,7 +481,7 @@ Proof. Qed. Lemma aes_rounds_E pre id0 rkeys msg : - (pdisj pre id0 [fset state]) -> + (pdisj pre id0 (fset [state])) -> ⊢ ⦃ fun '(h0, h1) => pre (h0, h1) ⦄ JAES_ROUNDS id0 rkeys msg ≈ @@ -515,7 +515,7 @@ Proof. rewrite !coerce_to_choice_type_K. sheap. split_post. - * pdisj_apply disj. + * pdisj_apply disj. auto_in_fset. * rewrite getmd_to_arr; auto. lia. * reflexivity. + intros. simpl. auto with preceq. @@ -533,7 +533,7 @@ Proof. rewrite !coerce_to_choice_type_K. sheap. split_post. - * pdisj_apply disj. + * pdisj_apply disj. auto_in_fset. * rewrite -> H12. rewrite wAESENC_wAESENC_. rewrite getmd_to_arr; auto. @@ -555,7 +555,7 @@ Proof. rewrite !zero_extend_u. sheap. split_post. - + pdisj_apply disj. + + pdisj_apply disj. auto_in_fset. + unfold tr_app_sopn_tuple. simpl. rewrite !zero_extend_u. @@ -570,7 +570,7 @@ Proof. Qed. Lemma aes_E pre id0 k m : - (pdisj pre id0 [fset rkeys ; state]) -> + (pdisj pre id0 (fset Cenc_locs)) -> ⊢ ⦃ fun '(h0, h1) => pre (h0, h1) ⦄ JAES id0 k m ≈ @@ -606,7 +606,7 @@ Proof. neq_loc_auto. + intros; destruct_pre; split_post. * eapply disj. - ** move: H. rewrite in_fset in_cons=>/orP [];[|easy] => /eqP ->. solve_in. + ** move: H. rewrite !in_fset !in_cons=>/orP [] ;[|easy] => /eqP ->. simpl. apply/orP; auto. ** eassumption. * reflexivity. * reflexivity. @@ -646,7 +646,8 @@ Proof. ** simpl. sheap. reflexivity. * intros; destruct_pre; split_post. ** eapply disj. - *** move: H. rewrite in_fset in_cons=>/orP []. 1: move=> /eqP ->; solve_in. + *** move: H. rewrite [l \in @fset _ [state]]in_fset in_cons =>/orP []. 1: move=> /eqP ->; solve_in. + 1: unfold Cenc_locs; auto_in_fset. simpl. clear -l. easy. *** eassumption. ** reflexivity. diff --git a/theories/Jasmin/examples/aes/aes_prf.v b/theories/Jasmin/examples/aes/aes_prf.v index 7dab9be9..07cc00b8 100644 --- a/theories/Jasmin/examples/aes/aes_prf.v +++ b/theories/Jasmin/examples/aes/aes_prf.v @@ -359,7 +359,6 @@ Section JasminPRF. Unshelve. exact _. Defined. - Definition Cenc_locs := [:: state ; rkeys]. Opaque wrange. Opaque expn. @@ -496,16 +495,66 @@ Section JasminPRF. (* TODO: move *) Arguments pheap_ignore : simpl never. + Lemma translate_var_option {A} s_id v i : ( 'option A ; i ) != translate_var s_id v. + Proof. + unfold translate_var. + apply/eqP => contra. + apply EqdepFacts.eq_sigT_fst in contra. + destruct v. + destruct vtype0; simpl in contra; noconf contra. + Qed. + + (* NOTE: the next 5 lemmas are not used, but might useful. Move *) + Lemma nat_of_stype_bound s : 5 <= nat_of_stype s. + Proof. + destruct s. 1-2: simpl; try micromega.Lia.lia. + - simpl. pose proof Pos2Nat.is_succ p as []. rewrite H. + pose proof Nat.pow_le_mono_r 11 1 (x.+1) ltac:(micromega.Lia.lia) ltac:(micromega.Lia.lia). simpl in *. micromega.Lia.lia. + - cbn [nat_of_stype]. + assert (0 < nat_of_wsize w). 1: destruct w; unfold nat_of_wsize; simpl; try micromega.Lia.lia. + pose proof Nat.pow_le_mono_r 13 1 w ltac:(micromega.Lia.lia) ltac:(micromega.Lia.lia). simpl in *. micromega.Lia.lia. + Qed. + + Lemma nat_of_p_id_ident_bound s_id v : 2 <= nat_of_p_id_ident s_id v. + Proof. + unfold nat_of_p_id_ident. + pose proof nat_of_p_id_pos s_id. + pose proof nat_of_ident_pos v. + pose proof Nat.pow_le_mono_r 3 1 (nat_of_p_id s_id) ltac:(micromega.Lia.lia) ltac:(micromega.Lia.lia). + pose proof Nat.pow_le_mono_r 2 1 (nat_of_ident v) ltac:(micromega.Lia.lia) ltac:(micromega.Lia.lia). + simpl in *; micromega.Lia.lia. + Qed. + + Lemma nat_of_p_id_var_bound s_id v : 10 <= nat_of_p_id_var s_id v. + Proof. + unfold nat_of_p_id_var. + pose proof nat_of_stype_bound (vtype v). + pose proof nat_of_p_id_ident_bound s_id (vname v). + micromega.Lia.nia. + Qed. + + Lemma translate_var_bound {A} s_id v i : i < 10 -> ( A ; i ) != translate_var s_id v. + Proof. + intros. + apply/eqP => contra. + inversion contra. + pose proof nat_of_p_id_var_bound s_id v. + micromega.Lia.lia. + Qed. + Lemma IND_CPA_JENC_equiv_false id0 : - padv_equiv (fun l => exists s_id v, id0 ⪯ s_id /\ l = translate_var s_id v) (fun l => l = state \/ l = rkeys) (IND_CPA_JENC id0 true) (IND_CPA_JENC id0 false) (λ _ : raw_package, 0%R). + padv_equiv (fun l => exists s_id v, id0 ⪯ s_id /\ l = translate_var s_id v) (fun l => l \in fset Cenc_locs) (IND_CPA_JENC id0 true) (IND_CPA_JENC id0 false) (λ _ : raw_package, 0%R). Proof. eapply eq_rel_perf_ind'. (* invariant *) { eapply pInvariant_pheap_ignore with - (P := fun l => forall s_id v, id0 ⪯ s_id -> l != translate_var s_id v). - { intros. apply/eqP. intros contra. - destruct H. apply H. - exists s_id, v. split; auto. } } + (P := fun l => (forall s_id v, id0 ⪯ s_id -> l != translate_var s_id v) /\ l \notin fset Cenc_locs). + { intros. + split. + - intros. apply/eqP. intros contra. + destruct H. apply H. + exists s_id, v. split; auto. + - apply/negP; easy. } } unfold eq_up_to_inv, get_op_default, lookup_op, IND_CPA_JENC, IND_CPA_pkg_JENC. Opaque Caes. Opaque translate_call. @@ -516,9 +565,11 @@ Section JasminPRF. simplify_linking. rewrite !cast_fun_K. ssprove_sync. - { intros h0 h1 hpre. apply hpre. admit. } + { intros h0 h1 hpre. apply hpre. split. + - intros. apply translate_var_option. + - unfold Cenc_locs. rewrite in_fset in_cons; auto. } intros. - eapply r_bind with (mid := fun '(a₀, s₀) '(a₁, s₁) => pheap_ignore (λ l : ∑ _ : choice_type, nat, ∀ (s_id : p_id) (v : var), id0 ⪯ s_id → l != translate_var s_id v) (s₀, s₁) /\ a₀ = a₁). + eapply r_bind with (mid := fun '(a₀, s₀) '(a₁, s₁) => pheap_ignore (λ l : ∑ _ : choice_type, nat, (∀ (s_id : p_id) (v : var), id0 ⪯ s_id → l != translate_var s_id v) /\ l \notin fset Cenc_locs) (s₀, s₁) /\ a₀ = a₁). { destruct a. - eapply r_ret. easy. - ssprove_sync. intros. @@ -532,7 +583,7 @@ Section JasminPRF. (* TODO: find easier way to do next three lines *) eapply rpre_weak_hypothesis_rule. intros; destruct_pre. - eapply rpre_weaken_rule with (pre:= fun '(s₀, s₁) => pheap_ignore (λ l : ∑ _ : choice_type, nat, ∀ (s_id : p_id) (v : var), id0 ⪯ s_id → l != translate_var s_id v) (s₀, s₁)); try easy. + eapply rpre_weaken_rule with (pre:= fun '(s₀, s₁) => pheap_ignore (λ l : ∑ _ : choice_type, nat, (∀ (s_id : p_id) (v : var), id0 ⪯ s_id → l != translate_var s_id v) /\ l \notin fset Cenc_locs) (s₀, s₁)); try easy. ssprove_code_simpl. simpl. ssprove_sync. intros. @@ -548,8 +599,13 @@ Section JasminPRF. 1: do 2 eexists. 1: instantiate (1 := set_heap H7 (translate_var s_id' v) a1). all: try reflexivity. - { intros l lnin. rewrite get_set_heap_neq. 1: eapply H8; auto. eapply lnin. admit. } - { repeat rewrite [set_heap _ _ a1]set_heap_commut; auto. 1-3: admit. } + { intros l lnin. rewrite get_set_heap_neq. 1: eapply H8; auto. + apply lnin. + etransitivity. + 2: eassumption. + solve_preceq. } + { repeat rewrite [set_heap _ _ a1]set_heap_commut; auto. + 1-3: apply injective_translate_var2; apply prec_neq; eapply prec_preceq_trans; try eassumption; apply prec_I. } + intros. destruct_pre. do 2 eexists. @@ -560,7 +616,9 @@ Section JasminPRF. intros l2 lnin. rewrite get_set_heap_neq. 1: eapply H7. 1: assumption. - admit. + unfold Cenc_locs in lnin. + destruct lnin. apply /eqP => contra; subst. + rewrite H in H2. easy. - simpl. intros. eapply rpre_weak_hypothesis_rule; intros. destruct_pre. @@ -577,9 +635,13 @@ Section JasminPRF. 1: do 7 eexists. 1: instantiate (1:= (set_heap H14 (translate_var s_id' v) a1)). all: try reflexivity. - { intros l hl. rewrite get_set_heap_neq. 1: eapply H15. 1: assumption. apply hl. admit. } - { repeat rewrite [set_heap _ _ a1]set_heap_commut; auto. 1-4: admit. } - { sheap. simpl. rewrite get_set_heap_neq. 1: sheap. 1: reflexivity. admit. } + { intros l hl. rewrite get_set_heap_neq. 1: eapply H15. 1: assumption. apply hl. + etransitivity. 2: eauto. + solve_preceq. } + { repeat rewrite [set_heap _ _ a1]set_heap_commut; auto. + 1-4: apply injective_translate_var2; apply prec_neq; eapply prec_preceq_trans; try eassumption; solve_prec. } + { sheap. simpl. rewrite get_set_heap_neq. 1: sheap. 1: reflexivity. + apply injective_translate_var2; apply prec_neq; eapply prec_preceq_trans; try eassumption; solve_prec. } + intros. easy. + intros. eapply rpre_weak_hypothesis_rule; intros. @@ -595,9 +657,9 @@ Section JasminPRF. { intros l s_id. rewrite !get_set_heap_neq. 1: eapply H19; auto. - 1-5: apply s_id; reflexivity. - Admitted. - + 1-5: apply s_id; reflexivity. } + Qed. + Lemma IND_CPA_jazz_equiv_false : (IND_CPA_Cenc) true ≈₀ (IND_CPA_Cenc) false. Proof. @@ -632,10 +694,11 @@ Section JasminPRF. unfold Cenc_locs in *. rewrite get_set_heap_neq. 1: apply h; auto. - admit. + apply/eqP=>contra; subst. + move: lnin => /negP. easy. - intros. eapply r_ret. intros. destruct_pre; split_post; auto. - Admitted. + Qed. Definition JIND_CPA id0 : loc_GamePair [interface #val #[i1] : 'word → 'word ] := @@ -647,12 +710,12 @@ Section JasminPRF. ValidPackage LA [interface #val #[i1] : 'word → 'word ] A_export A → pdisjoint LA (λ l : Location, ∃ (s_id : p_id) (v : var), id0 ⪯ s_id ∧ l = translate_var s_id v) -> - pdisjoint LA (λ l : Location, l = state ∨ l = rkeys) -> - (* fdisjoint LA (JIND_CPA id0 false).(locs) → *) - (* fdisjoint LA (JIND_CPA id0 true).(locs) → *) + pdisjoint LA (λ l : Location, l \in fset Cenc_locs) -> + fdisjoint LA (IND_CPA_Cenc false).(locs) → + fdisjoint LA (IND_CPA_Cenc true).(locs) → Advantage (JIND_CPA id0) A = 0%R. Proof. - intros LA A vA hd₀ hd₁. unfold prf_epsilon, statistical_gap. + intros LA A vA hd₀ hd₁ hd2 hd3. unfold prf_epsilon, statistical_gap. rewrite !Advantage_E. eapply AdvantageE_le_0. ssprove triangle (JIND_CPA id0 false) [:: @@ -664,7 +727,6 @@ Section JasminPRF. clear ineq. rewrite Advantage_sym. erewrite IND_CPA_jazz_equiv_false. all: eauto. - 2-3: admit. rewrite Advantage_sym. pose proof IND_CPA_JENC_equiv_false id0. unfold padv_equiv in H. @@ -672,6 +734,6 @@ Section JasminPRF. rewrite H. rewrite GRing.addr0. apply Order.POrderTheory.le_refl. - Admitted. + Qed. End JasminPRF. diff --git a/theories/Jasmin/examples/aes/aes_spec.v b/theories/Jasmin/examples/aes/aes_spec.v index 019c6880..693428c0 100644 --- a/theories/Jasmin/examples/aes/aes_spec.v +++ b/theories/Jasmin/examples/aes/aes_spec.v @@ -208,7 +208,7 @@ Proof. Qed. Lemma aes_h k m pre : - (u_pdisj pre [fset state ; rkeys]) -> + (u_pdisj pre (fset Cenc_locs)) -> ⊢ ⦃ fun '(h0, h1) => pre (h0, h1) ⦄ Caes k m ≈ @@ -222,15 +222,23 @@ Proof. u_pdisj_apply Hdisj. intros h1 h2 l a lin Hpre. eapply Hdisj; auto. - admit. } + rewrite in_fset in lin. + simpl in lin. + unfold Cenc_locs. + move: lin => /InP []; [move=> ->|by []]. + auto_in_fset. } intros a0 []. eapply r_bind with (m₁ := ret _). { eapply aes_rounds_h. intros h1 h2 l a lin Hpre. eapply Hdisj; auto. - admit. } + rewrite in_fset in lin. + simpl in lin. + unfold Cenc_locs. + move: lin => /InP []; [move=> ->|by []]. + auto_in_fset. } intros a1 []. eapply r_ret. intros. assumption. -Admitted. +Qed. diff --git a/theories/Jasmin/examples/aes/aes_utils.v b/theories/Jasmin/examples/aes/aes_utils.v index e4ef17fa..a128300c 100644 --- a/theories/Jasmin/examples/aes/aes_utils.v +++ b/theories/Jasmin/examples/aes/aes_utils.v @@ -291,13 +291,56 @@ Proof. reflexivity. Qed. +Lemma in_ziota' i p z : + @in_mem (Ord.sort Z_ordType) i (@mem (Equality.sort (Ord.eqType Z_ordType)) (seq_predType (Ord.eqType Z_ordType)) (ziota p z)) = (p <=? i) && (i ∀ p : Z, @in_mem (Ord.sort Z_ordType) i (@mem (Equality.sort (Ord.eqType Z_ordType)) (seq_predType (Ord.eqType Z_ordType)) (ziota p z)) = (p <=? i) && (i P z). + 1: { apply natlike_ind. + - unfold P. intros. rewrite in_nil. lia. + - unfold P. intros. + rewrite ziotaS_cons. 2: auto. + destruct (Z.eq_dec x i). + + subst. + simpl. + unfold in_mem. + simpl. + unfold in_mem in H0. + simpl in H0. + rewrite H0. + destruct (Z.eq_dec i p). + * subst. rewrite eq_refl. lia. + * assert ((@eq_op (Ord.eqType Z_ordType) i p) = false). + 1: { apply/eqP. intros contra. subst. easy. } + rewrite H1. lia. + + simpl. + unfold in_mem. + simpl. + unfold in_mem in H0. + simpl in H0. + rewrite H0. + destruct (Z.eq_dec i p). + * subst. rewrite eq_refl. lia. + * assert ((@eq_op (Ord.eqType Z_ordType) i p) = false). + 1: { apply/eqP. intros contra. subst. easy. } + rewrite H1. lia. } + assumption. +Qed. + Lemma getm_to_arr_None' ws len a (i: Z) : ((len <=? i) || (i to_arr ws len a i = None. Proof. intros. unfold to_arr. rewrite mkfmapfE. -Admitted. (* figure out a proof that is less stupid than the one for getm_to_arr *) + rewrite in_ziota'. + assert ((0 <=? i) && (i z <= i < z + len → - (is_true (@in_mem (Ord.sort Z_ordType) i (@ssrbool.mem (Equality.sort (Ord.eqType Z_ordType)) (seq_predType (Ord.eqType Z_ordType)) (ziota z len)))) - ) with ((fun len => ((forall z, 0 <= z -> z <= i < z + len -> - (is_true (@in_mem (Ord.sort Z_ordType) i (@ssrbool.mem (Equality.sort (Ord.eqType Z_ordType)) (seq_predType (Ord.eqType Z_ordType)) (ziota z len)))) - ))) len). - apply natlike_ind. - - intros z Hz Hz2. lia. - - intros x Hx Ih z Hz Hz2. rewrite ziotaS_cons. 2: lia. - destruct (Z.eq_dec z i). - + rewrite in_cons. apply/orP. left. apply/eqP. easy. - + rewrite in_cons. apply/orP. right. apply Ih. all: lia. - - assumption. } + rewrite in_ziota'. + assert ((0 <=? i) && (i apply prec_I + | |- ?a ≺ ?a~0 => apply prec_O + | |- ?a ≺ ?b~1 => etransitivity; [|apply prec_I] + | |- ?a ≺ ?b~0 => etransitivity; [|apply prec_O] + end. + (** *) From 4bfa19525c2155d34114facf233bbe34d2a9004c Mon Sep 17 00:00:00 2001 From: "Benjamin S. Hvass" Date: Wed, 18 Jan 2023 15:31:22 +0100 Subject: [PATCH 348/383] minor fix, print assumptions and end of `aes_prf` --- theories/Jasmin/examples/aes/aes_prf.v | 2 ++ theories/Jasmin/word.v | 42 +++++--------------------- 2 files changed, 10 insertions(+), 34 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes_prf.v b/theories/Jasmin/examples/aes/aes_prf.v index 07cc00b8..61b1585c 100644 --- a/theories/Jasmin/examples/aes/aes_prf.v +++ b/theories/Jasmin/examples/aes/aes_prf.v @@ -736,4 +736,6 @@ Section JasminPRF. apply Order.POrderTheory.le_refl. Qed. + Print Assumptions jasmin_security_based_on_prf. + End JasminPRF. diff --git a/theories/Jasmin/word.v b/theories/Jasmin/word.v index 19e363bc..dd443e0a 100644 --- a/theories/Jasmin/word.v +++ b/theories/Jasmin/word.v @@ -123,29 +123,8 @@ Proof. rewrite Z.mod_mod. 2: eapply Z.pow_nonzero ; lia. reflexivity. Qed. - -Lemma mod_pull_div a b c : 0 <= c -> (a / b) mod c = a mod (c * b) / b. -Admitted. (* end of fiat crypto lemmas *) -Lemma shiftr_shiftr_mod w ws1 ws2 i j : - (ws2 + j <= ws1)%nat -> - Z.shiftr (Z.shiftr w (Z.of_nat i) mod modulus ws1) (Z.of_nat j) mod modulus ws2 = - Z.shiftr w (Z.of_nat (i + j)) mod modulus ws2. -Proof. - intros H. - rewrite !modulusZE. - rewrite !Z.shiftr_div_pow2; try lia. - rewrite !mod_pull_div; try lia. - simpl. - rewrite -!Z.pow_add_r; try lia. - rewrite mod_pow_same_base_smaller; try lia. - rewrite Z.div_div; try lia. - rewrite -Z.pow_add_r; try lia. - rewrite Nat2Z.inj_add. - f_equal. f_equal. f_equal. lia. -Qed. - Lemma larger_modulus a n m : (n <= m)%nat -> (a mod modulus n) mod modulus m = a mod modulus n. @@ -167,24 +146,19 @@ Proof. Qed. Lemma subword_wshr {n} i j m (w : word n) : - (m + i <= n)%nat -> subword i m (lsr w j) = subword (j + i) m w. Proof. - intros H. - unfold subword; simpl. - apply val_inj; simpl. - rewrite urepr_word. - unfold lsr. - simpl. - rewrite urepr_word. - rewrite !smaller_modulus; try lia. - rewrite shiftr_shiftr_mod; try lia. + intros. + apply/eqP/eq_from_wbit. + intros. + rewrite !wbit_subword. + rewrite wbit_lsr. + f_equal. + f_equal. + lia. Qed. - Lemma wbit_subword {ws1} i ws2 (w : word ws1) (j : 'I_ws2) : - (* (ws2 <= ws1)%nat -> *) - (* (j < ws2)%nat -> *) wbit (subword i ws2 w) j = wbit w (i + j)%nat. Proof. intros. From f8a6261f9957de7717bd6f490b49c271eff699da Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Tue, 24 Jan 2023 00:00:55 +0100 Subject: [PATCH 349/383] Closer to unrolling loop --- theories/Jasmin/examples/aes/aes_hac.v | 1538 +++++++++++++----------- 1 file changed, 849 insertions(+), 689 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes_hac.v b/theories/Jasmin/examples/aes/aes_hac.v index 08854c6a..e0dc8d60 100644 --- a/theories/Jasmin/examples/aes/aes_hac.v +++ b/theories/Jasmin/examples/aes/aes_hac.v @@ -35,6 +35,8 @@ Notation call fn := (translate_call _ fn _). From Hacspec Require Import Hacspec_Lib. +From mathcomp Require Import zify_ssreflect zify_algebra zify. +Ltac Zify.zify_post_hook ::= Z.div_mod_to_equations. Section Hacspec. @@ -92,7 +94,7 @@ Section Hacspec. Ltac bind_jazz_hac := match goal with | [ |- context [ ⊢ ⦃ ?P ⦄ putr ?l ?jazz ?f ≈ _ ⦃ ?Q ⦄ ] ] => - eapply (@r_bind _ _ _ _ (ret jazz) _ (fun x => putr l x f) _ _ (fun '(v0, h0) '(v1, h1) => v0 = v1 /\ P (h0, h1)) _) ; [ rewrite !zero_extend_u | intros ] + eapply (@r_bind _ _ _ _ (ret jazz) _ (fun x => putr l x f) _ _ (fun '(v0, h0) '(v1, h1) => v0 = v1 /\ P (h0, h1)) _) ; [ try rewrite !zero_extend_u | intros ] end. Ltac remove_get_in_lhs := @@ -197,177 +199,162 @@ Section Hacspec. Notation JVSHUFPS i rkey temp1 temp2 := (trc VSHUFPS i [('word U128 ; rkey) ; ('word U128 ; temp1) ; ('word U128 ; temp2)]). - Lemma wpshufd1_eq : - forall (rkey : 'word U128) (i : nat) (n : nat), - i < 4 -> - wpshufd1 rkey (wrepr U8 n) i = - is_pure (vpshufd1 rkey (Hacspec_Lib_Pre.repr n) (Hacspec_Lib_Pre.repr i)). + Lemma modulus_gt0_Z : + forall n, (0 < modulus n)%Z. + Proof. easy. Qed. + + Lemma modulus_ge0_Z : + forall n, (0 <= modulus n)%Z. + Proof. easy. Qed. + + Lemma isword_Z : forall n k, (0 <= @toword n k < modulus n)%Z. + Proof. + apply (fun n k => ssrbool.elimT (iswordZP n (toword k)) (@isword_word n k)). + Qed. + + Lemma lt_add_right : forall n m p, (0 < p)%Z -> (n < m)%Z -> (n < m + p)%Z. Proof. - Opaque Z.mul. - clear. intros. - unfold vpshufd1. - unfold wpshufd1. - simpl. - apply word_ext. - f_equal. - simpl. - rewrite Zmod_mod. - unfold Hacspec_Lib_Pre.shift_right_, wshr, lsr, Hacspec_Lib_Pre.unsigned, wunsigned ; rewrite mkwordK. - f_equal. - f_equal. - f_equal. - f_equal. - unfold Hacspec_Lib_Pre.repr. - unfold wrepr. - unfold toword at 1, mkword at 2. - unfold Hacspec_Lib_Pre.from_uint_size, Hacspec_Lib_Pre.Z_uint_sizeable, Hacspec_Lib_Pre.unsigned, wunsigned. - unfold Hacspec_Lib_Pre.int_mul, mul_word. - unfold Hacspec_Lib_Pre.usize_shift_right. - unfold wshr. - unfold lsr. - rewrite !mkwordK. - rewrite <- Zmult_mod. - setoid_rewrite Zmod_mod. - rewrite <- Zmult_mod. - rewrite Z2Nat.id ; [ | destruct i as [ | [ | [ | [] ]]] ; try easy ]. - rewrite (Zmod_small _ (modulus nat127.+1)). - 2:{ - cbn. - rewrite Zmod_small. - 2:{ - replace (4 mod modulus nat31.+1)%Z with (modulus 2) by reflexivity. - split. - - apply Z.mul_nonneg_nonneg ; [ easy | ]. - apply (ssrbool.elimT (iswordZP _ _) (mkword_proof _ _)). - - replace (modulus nat31.+1) with (32 * modulus (32 - 5))%Z by reflexivity. - rewrite <- (Z.mul_lt_mono_pos_l) ; [ | easy]. - eapply Z.lt_trans ; [ apply (ssrbool.elimT (iswordZP _ _) (mkword_proof _ _)) ; easy | easy ]. - } - { - replace (4 mod modulus nat31.+1)%Z with (modulus 2) by reflexivity. - split. - - apply Z.mul_nonneg_nonneg ; [ easy | ]. - apply (ssrbool.elimT (iswordZP _ _) (mkword_proof _ _)). - - replace (modulus nat127.+1) with (32 * modulus (128 - 5))%Z by reflexivity. - rewrite <- (Z.mul_lt_mono_pos_l) ; [ | easy]. - eapply Z.lt_trans ; [ apply (ssrbool.elimT (iswordZP _ _) (mkword_proof _ _)) ; easy | easy ]. - } - } + eapply Z.lt_trans. + apply H0. + lia. + Qed. - symmetry. - replace ((2 * Z.of_nat i) mod modulus U32)%Z with (2 * Z.of_nat i)%Z by by (destruct i as [ | [ | [ | [] ]]] ; easy). - rewrite Zmod_small. - 2:{ - cbn. - replace (4 mod modulus nat31.+1)%Z with (modulus 2) by reflexivity. - split. - - apply Z.mul_nonneg_nonneg ; [ easy | ]. - apply Z_mod_nonneg_nonneg ; [ | easy ]. - apply Z_mod_nonneg_nonneg ; [ | easy ]. - apply Z.shiftr_nonneg. - apply Z_mod_nonneg_nonneg ; [ | easy ]. - apply Z_mod_nonneg_nonneg ; [ | easy ]. - lia. - - replace (modulus nat31.+1)%Z with (32 * modulus (32 - 5))%Z at 3 by reflexivity. - apply Z.mul_lt_mono_pos_l ; [ easy | ]. - eapply Z.lt_trans. - apply Z.mod_pos_bound. - easy. - easy. - } + Lemma le_add_right : forall n m p, (0 <= p)%Z -> (n <= m)%Z -> (n <= m + p)%Z. + Proof. + intros. + eapply Z.le_trans. + apply H0. + lia. + Qed. - cbn. - f_equal. - f_equal. - rewrite Zmod_small. - { - symmetry. - rewrite Zmod_small. - { - symmetry. - f_equal. - { - rewrite Zmod_small ; [ reflexivity | ]. - split ; [ apply Z_mod_nonneg_nonneg ; [ lia | easy ] | ]. - eapply Z.lt_trans. - apply Z.mod_pos_bound. - destruct i as [ | [ | [ | [] ]]] ; easy. - easy. - } - destruct i as [ | [ | [ | [] ]]] ; easy. - } - apply shiftr_bounds. lia. - split. - apply Z_mod_nonneg_nonneg. - lia. + Lemma modulusDZ : forall n m p, (n <= modulus (m + p)%nat)%Z = (n <= modulus m * modulus p)%Z . + Proof. + intros. + rewrite modulusD. + rewrite mulZE. + reflexivity. + Qed. + + Lemma modulus_add_r : forall n m p, (0 <= n < modulus m)%Z -> (0 <= n < modulus (m + p)%nat)%Z. + Proof. + intros. + destruct n as [ | n | ] ; [ easy | | easy ]. + rewrite modulusD. + rewrite <- mulZE. + split. easy. + induction p. + - rewrite Z.mul_1_r. + apply H. + - rewrite modulusS. + rewrite GRing.Theory.mulr2n. + rewrite <- addZE. + eapply Z.lt_trans. + apply IHp. + apply Zmult_lt_compat_l. + easy. + apply Z.lt_add_pos_r. easy. + Qed. - eapply Z.lt_le_trans. - apply Z.mod_pos_bound. - destruct i as [ | [ | [ | [] ]]] ; easy. - rewrite modulusD. - destruct i as [ | [ | [ | [] ]]] ; easy. - } - apply shiftr_bounds. lia. + Lemma small_modulus_smaller : forall n m p, (0 <= n)%Z -> (0 < m <= p)%Z -> (0 <= n mod m < p)%Z. + Proof. + intros. + split. apply Z_mod_nonneg_nonneg. apply H. apply Z.lt_le_incl. apply H0. + eapply Z.lt_le_trans. + apply Z.mod_pos_bound. + lia. + apply H0. + Qed. + + Lemma mod_mod_larger : forall n m p, (0 <= n)%Z -> (0 < m <= p)%Z -> (n mod m mod p = n mod m)%Z. + Proof. + intros. rewrite Zmod_small. - { - split. - apply Z_mod_nonneg_nonneg. - lia. - easy. + reflexivity. + apply small_modulus_smaller. + apply H. + apply H0. + Qed. - eapply Z.lt_le_trans. - apply Z.mod_pos_bound. - destruct i as [ | [ | [ | [] ]]] ; easy. - destruct i as [ | [ | [ | [] ]]] ; easy. - } + Lemma mod_mod_divisable : forall n m p, (0 < p)%Z -> (exists k, m = k * p /\ 0 < k)%Z -> (n mod m mod p = n mod p)%Z. + Proof. + intros. + destruct H0 as [ ? [] ]. + subst. + now apply mod_pq_mod_q. + Qed. + + + Lemma Z_shiftl_mod_modulus_S : forall n (m p : nat), + (Z.shiftl n (Z.of_nat m.+1) mod modulus (p.+1) = 2 * (Z.shiftl n (Z.of_nat m) mod modulus p))%Z. + Proof. + intros. + rewrite <- Zmult_mod_distr_l. + + f_equal. { - split. - apply Z_mod_nonneg_nonneg. - lia. - easy. + rewrite Z.shiftl_mul_pow2. + rewrite Nat2Z.inj_succ. + rewrite Z.pow_succ_r. + rewrite Z.mul_comm. + rewrite <- Z.mul_assoc. + rewrite <- (Z.mul_comm n). + rewrite <- Z.shiftl_mul_pow2. + reflexivity. - eapply Z.lt_le_trans. - apply Z.mod_pos_bound. - destruct i as [ | [ | [ | [] ]]] ; easy. - destruct i as [ | [ | [ | [] ]]] ; easy. + lia. + lia. + lia. } - Transparent Z.mul. - Transparent Nat.mul. Qed. - Lemma wpshufd1_eq_state : - forall {H} (rkey : 'word U128) (i n : nat), - i < 4 -> - ⊢ ⦃ H ⦄ - ret (wpshufd1 rkey (wrepr U8 n) i) ≈ - is_state (vpshufd1 rkey (Hacspec_Lib_Pre.repr n) (Hacspec_Lib_Pre.repr i)) - ⦃ λ '(v0, h0) '(v1, h1), v0 = v1 ∧ H (h0, h1) ⦄. + Lemma Z_shiftl_mod_modulus_add : forall n (m p k : nat), + (Z.shiftl n (Z.of_nat (m + k)) mod modulus (p + k) = modulus k * (Z.shiftl n (Z.of_nat m) mod modulus p))%Z. Proof. intros. - rewrite (wpshufd1_eq _ i n) ; [ | apply H0 ]. - now apply r_ret. + induction k. + - rewrite !addn0. + rewrite Z.mul_1_l. + reflexivity. + - rewrite !addnS. + rewrite Z_shiftl_mod_modulus_S. + rewrite IHk. + rewrite Z.mul_assoc. + reflexivity. Qed. - Ltac match_wpshufd1_vpshufd1 i := - (let w := fresh in - let y := fresh in - let b := fresh in - set (w := wpshufd1 _ _ i) ; - set (y := fun _ : Hacspec_Lib_Pre.int32 => _) ; - set (b := vpshufd1 _ _ _); - let k := fresh in - let l := fresh in - match goal with - | [ |- context [ ⊢ ⦃ ?P ⦄ ?lhs ≈ _ ⦃ _ ⦄ ] ] => set (k := P) ; set (l := lhs) - end ; - pattern (w) in l ; - subst l ; - apply (@r_bind _ _ _ _ (ret w) (prog (is_state b)) _ y _ (fun '(v0, h0) '(v1, h1) => v0 = v1 /\ k (h0, h1))) ; subst w y b ; hnf). + Lemma subn_diag : forall p m, m <= p -> p = p - m + m. + Proof. + intros. + pose subn_eq0. + pose (@subnA p m m (leqnn m) H). + epose (addKn m 0). + setoid_rewrite addn0 in e1. + setoid_rewrite e1 in e0. + now rewrite (subn0 p) in e0. + Qed. - Ltac solve_wpshufd1_vpshufd1 i n := - match_wpshufd1_vpshufd1 i ; [now apply (wpshufd1_eq_state _ i n) | intros ]. + Lemma Z_shiftl_mod_modulus : forall n (m p k : nat), (m <= p) -> (Z.shiftl n (Z.of_nat m) mod modulus p = modulus m * (n mod modulus (p - m)))%Z. + Proof. + intros. + replace p with (p - m + m) at 1 by now rewrite <- (subn_diag p m H). + replace (m) with (0 + m) at 1 by reflexivity. + apply Z_shiftl_mod_modulus_add. + Qed. + + (* Lemma Z_shiftr_mod_modulus : forall n m p, (m <= p) -> (Z.shiftr n (Z.of_nat m) mod modulus p = (n mod modulus (p - m)) / modulus m)%Z. *) + (* Proof. *) + (* intros. *) + (* replace p with (p - m + m) at 1 by now rewrite <- (subn_diag p m H). *) + (* replace (m) with (0 + m) at 1 by reflexivity. *) + (* Admitted. *) + + Ltac solve_lower_bounds := + (simple apply Z.mul_nonneg_nonneg || simple apply Zle_0_pos || simple apply Z_mod_nonneg_nonneg || simple apply Nat2Z.is_nonneg || simple apply modulus_ge0_Z || simple apply (fun x y => proj2 (Z.shiftr_nonneg x y)) || simple apply (fun x y => proj2 (Z.shiftl_nonneg x y)) || simple apply word_geZ0 || (apply Z.lor_nonneg ; solve_upper_bound)) + with + solve_upper_bound := + ((split ; [ repeat solve_lower_bounds | ]) || (apply small_modulus_smaller ; now repeat solve_lower_bounds) || (rewrite <- (Z.mul_lt_mono_pos_l) ; [ | easy]) || apply isword_Z || (apply shiftr_bounds ; repeat solve_lower_bounds) || apply modulus_add_r || rewrite Z.shiftr_0_r || lia). Lemma shift_left_4_byte_ok : (forall i (a : 'word U32), @@ -388,17 +375,13 @@ Section Hacspec. destruct i as [ | [ | [ | [ | []] ]] ] ; easy. Qed. - Lemma num_smaller_if_modulus_lte : (forall {WS} (x : 'word WS) z, (modulus WS <= z)%Z -> (0 <= x < z)%Z). + Lemma num_smaller_if_modulus_le : (forall {WS} (x : 'word WS) z, (modulus WS <= z)%Z -> (0 <= x < z)%Z). Proof. - clear. cbn. intros. - destruct x. - pose (ssrbool.elimT (iswordZP _ _) i). - split. easy. - unfold word.toword. - destruct a. - eapply Z.lt_le_trans ; [ apply H1 | apply H]. + split. + - apply isword_Z. + - eapply Z.lt_le_trans ; [ apply isword_Z | apply H ]. Qed. Lemma Z_lor_pow2 : (forall (x y : Z) (k : nat), (0 <= x < 2 ^ k)%Z -> (0 <= y < 2 ^ k)%Z -> (0 <= Z.lor x y < 2 ^ k)%Z). @@ -423,78 +406,312 @@ Section Hacspec. - easy. Qed. + Lemma rebuild_128_eq : + forall (v0 v1 v2 v3 : 'word U32) , + make_vec _ [v0 ; v1 ; v2 ; v3] = is_pure (rebuild_u128 v0 v1 v2 v3). + Proof. + intros. + simpl. + unfold "shift_left". + unfold Hacspec_Lib_Pre.shift_left_. + unfold is_pure. + unfold ".|". + unfold Hacspec_Lib_Pre.int_or. + rewrite !lift3_both_equation_1 ; simpl. + + unfold make_vec. + unfold wcat_r. + + apply word_ext. + + rewrite Z.shiftl_0_l. + rewrite Z.lor_0_r. + rewrite !Z.shiftl_lor. + simpl int_to_Z. + rewrite !Z.shiftl_shiftl ; try easy. + simpl (_ + _)%Z. + + unfold wshl, lsl. + setoid_rewrite wunsigned_repr. + rewrite Zmod_small. + rewrite Zmod_small. + rewrite mod_mod_larger. + rewrite Zmod_small. + rewrite Zmod_small. + rewrite mod_mod_larger. + rewrite Zmod_small. + rewrite Zmod_small. + rewrite mod_mod_larger. + rewrite Zmod_small. + rewrite Zmod_small. + unfold word.wor, wor, toword, mkword. + rewrite Zmod_small. + rewrite Zmod_small. + rewrite Zmod_small. + reflexivity. + + all: try apply shiftl_bounds. + all: try now apply (@num_smaller_if_modulus_le U32). + all: try easy. + repeat (rewrite modulusZE ; apply Z_lor_pow2 ; rewrite <- modulusZE). + all: try now apply (@num_smaller_if_modulus_le U32). + 1: replace 32%Z with (int_to_Z 32) by reflexivity. + 2: replace 64%Z with (int_to_Z 64) by reflexivity. + 3: replace 96%Z with (int_to_Z 96) by reflexivity. + all: apply shiftl_bounds ; [ easy | ]. + all: try now apply (@num_smaller_if_modulus_le U32). + Qed. + + Lemma rebuild_32_eq : + forall (v0 v1 v2 v3 : 'word U8) , + make_vec _ [v0 ; v1 ; v2 ; v3] = is_pure (rebuild_u32 v0 v1 v2 v3). + Proof. + intros. + simpl. + unfold "shift_left". + unfold Hacspec_Lib_Pre.shift_left_. + unfold is_pure. + unfold ".|". + unfold Hacspec_Lib_Pre.int_or. + rewrite !lift3_both_equation_1 ; simpl. + + unfold make_vec. + unfold wcat_r. + + apply word_ext. + + rewrite Z.shiftl_0_l. + rewrite Z.lor_0_r. + rewrite !Z.shiftl_lor. + simpl int_to_Z. + rewrite !Z.shiftl_shiftl ; try easy. + simpl (_ + _)%Z. + + unfold wshl, lsl. + setoid_rewrite wunsigned_repr. + rewrite Zmod_small. + rewrite Zmod_small. + rewrite mod_mod_larger. + rewrite Zmod_small. + rewrite Zmod_small. + rewrite mod_mod_larger. + rewrite Zmod_small. + rewrite Zmod_small. + rewrite mod_mod_larger. + rewrite Zmod_small. + rewrite Zmod_small. + unfold word.wor, wor, toword, mkword. + rewrite Zmod_small. + rewrite Zmod_small. + rewrite Zmod_small. + reflexivity. + + all: try apply shiftl_bounds. + all: try now apply (@num_smaller_if_modulus_le U8). + all: try easy. + repeat (rewrite modulusZE ; apply Z_lor_pow2 ; rewrite <- modulusZE). + all: try now apply (@num_smaller_if_modulus_le U8). + 1: replace 8%Z with (int_to_Z 8) by reflexivity. + 2: replace 16%Z with (int_to_Z 16) by reflexivity. + 3: replace 24%Z with (int_to_Z 24) by reflexivity. + all: apply shiftl_bounds ; [ easy | ]. + all: try now apply (@num_smaller_if_modulus_le U8). + Qed. + + Lemma index_32_eq : + forall (v : 'word U128) (i : nat), + i < 4 -> + word.subword (i * U32) U32 v = is_pure (index_u32 v (repr (Z.of_nat i))). + Proof. + intros. + unfold word.subword. + unfold index_u32. + simpl. + unfold "shift_left", Hacspec_Lib_Pre.shift_left_. + unfold "shift_right", Hacspec_Lib_Pre.shift_right_. + unfold ".%", Hacspec_Lib_Pre.int_mod. + unfold ".*", Hacspec_Lib_Pre.int_mul. + unfold is_pure. + rewrite !lift3_both_equation_1 ; simpl. + unfold wshl, lsl. + unfold wshr, lsr. + unfold wmod, mul_word. + apply word_ext. + simpl. + cbn. + + rewrite Z2Nat.id. + rewrite (Zmod_small (Z.of_nat i)). + rewrite (Zmod_small ( (Z.of_nat i) * _)). + rewrite (Zmod_small ( (Z.of_nat i) * _)). + rewrite (mod_mod_larger _ 4294967296). + rewrite (Zmod_mod _ (modulus U32)). + f_equal. + f_equal. + all: try now do 4 (destruct i as [ | i ] ; [ easy | ]). + repeat solve_lower_bounds. + Qed. + + + Lemma index_8_eq : + forall (v : 'word U32) (i : nat), + i < 4 -> + word.subword (i * U8) U8 v = is_pure (index_u8 v (repr (Z.of_nat i))). + Proof. + intros. + unfold word.subword. + unfold index_u32. + simpl. + unfold "shift_left", Hacspec_Lib_Pre.shift_left_. + unfold "shift_right", Hacspec_Lib_Pre.shift_right_. + unfold ".%", Hacspec_Lib_Pre.int_mod. + unfold ".*", Hacspec_Lib_Pre.int_mul. + unfold is_pure. + rewrite !lift3_both_equation_1 ; simpl. + unfold wshl, lsl. + unfold wshr, lsr. + unfold wmod, mul_word. + apply word_ext. + simpl. + cbn. + + rewrite Z2Nat.id. + rewrite (Zmod_small (Z.of_nat i)). + rewrite (Zmod_small ( (Z.of_nat i) * _)). + rewrite (Zmod_small ( (Z.of_nat i) * _)). + rewrite (mod_mod_larger _ 256). + rewrite (Zmod_mod _ (modulus U8)). + f_equal. + f_equal. + all: try now do 4 (destruct i as [ | i ] ; [ easy | ]). + repeat solve_lower_bounds. + Qed. + + Lemma wpshufd1_eq : + forall (rkey : 'word U128) (i : nat) (n : 'word U8), + i < 4 -> + wpshufd1 rkey n i = + is_pure (vpshufd1 rkey n (Hacspec_Lib_Pre.repr i)). + Proof. + Opaque Z.mul. + clear. + intros. + unfold vpshufd1. + unfold wpshufd1. + + Opaque index_u32. + unfold is_pure at 1, lift_scope ; simpl. + rewrite (index_32_eq _ 0). + f_equal. + f_equal. + unfold is_pure at 1, ".%" ; rewrite !lift3_both_equation_1 ; simpl. + simpl. + setoid_rewrite lift3_both_equation_1 ; simpl. + setoid_rewrite lift3_both_equation_1 ; simpl. + setoid_rewrite lift3_both_equation_1 ; simpl. + apply word_ext. + simpl. + f_equal. + f_equal. + f_equal. + f_equal. + rewrite Zmod_small. + unfold Hacspec_Lib_Pre.int_mul. + unfold mul_word. + unfold unsigned, wunsigned. + rewrite !mkwordK. + rewrite (Zmod_small _ (modulus U32)). + rewrite (Zmod_small _ (modulus U32)). + rewrite (Zmod_small _ (modulus U32)). + f_equal. + cbn. + replace (4 mod _)%Z with (modulus 2)%Z by reflexivity. + rewrite Z2Nat.id. + symmetry. + rewrite (Zmod_small _ (modulus nat7.+1)). + symmetry. + f_equal. + f_equal. + f_equal. + all: try now do 4 (destruct i as [ | i ] ; [ easy | ]). + apply small_modulus_smaller. + now repeat solve_lower_bounds. + easy. + + split ; [ cbn ; now repeat solve_lower_bounds | ]. + replace (modulus U32)%Z with (32 * modulus (U32 - 5))%Z by reflexivity. + apply Zmult_lt_compat_l. easy. + apply small_modulus_smaller. + cbn ; now repeat solve_lower_bounds. + easy. + + apply small_modulus_smaller. + cbn ; now repeat solve_lower_bounds. + easy. + + apply (@num_smaller_if_modulus_le U32). + easy. + Qed. + + Lemma wpshufd1_eq_state : + forall {H} (rkey : 'word U128) (n : 'word U8) (i : nat), + i < 4 -> + ⊢ ⦃ H ⦄ + ret (wpshufd1 rkey n i) ≈ + is_state (vpshufd1 rkey n (Hacspec_Lib_Pre.repr i)) + ⦃ λ '(v0, h0) '(v1, h1), v0 = v1 ∧ H (h0, h1) ⦄. + Proof. + intros. + rewrite (wpshufd1_eq _ i n) ; [ | apply H0 ]. + now apply r_ret. + Qed. + + Ltac match_wpshufd1_vpshufd1 i := + (let w := fresh in + let y := fresh in + let b := fresh in + set (w := wpshufd1 _ _ i) ; + set (y := fun _ : Hacspec_Lib_Pre.int32 => _) ; + set (b := vpshufd1 _ _ _); + let k := fresh in + let l := fresh in + match goal with + | [ |- context [ ⊢ ⦃ ?P ⦄ ?lhs ≈ _ ⦃ _ ⦄ ] ] => set (k := P) ; set (l := lhs) + end ; + pattern (w) in l ; + subst l ; + apply (@r_bind _ _ _ _ (ret w) (prog (is_state b)) _ y _ (fun '(v0, h0) '(v1, h1) => v0 = v1 /\ k (h0, h1))) ; subst w y b ; hnf). + + Ltac solve_wpshufd1_vpshufd1 i := + match_wpshufd1_vpshufd1 i ; [now apply wpshufd1_eq_state | intros ]. + Lemma wpshufd_128_eq_state : forall {H} (rkey : 'word U128) (n : nat), ⊢ ⦃ H ⦄ ret (wpshufd_128 rkey n) ≈ - is_state (vpshufd rkey (Hacspec_Lib_Pre.repr n)) + is_state (vpshufd rkey (repr n)) ⦃ λ '(v0, h0) '(v1, h1), v0 = v1 ∧ H (h0, h1) ⦄. Proof. intros. unfold wpshufd_128. - unfold vpshufd. unfold wpshufd_128. unfold iota. unfold map. + + setoid_rewrite rebuild_128_eq. unfold vpshufd. - solve_wpshufd1_vpshufd1 0 n. - solve_wpshufd1_vpshufd1 1 n. - solve_wpshufd1_vpshufd1 2 n. - solve_wpshufd1_vpshufd1 3 n. + solve_wpshufd1_vpshufd1 0. + solve_wpshufd1_vpshufd1 1. + solve_wpshufd1_vpshufd1 2. + solve_wpshufd1_vpshufd1 3. apply r_ret. intros ? ? [? [? [? []]]]. subst. subst H4. split ; [ clear | assumption ]. - - apply word_ext. - - unfold wcat_r. - - Opaque Z.shiftl. - simpl. - Transparent Z.shiftl. - - rewrite Zmod_small. - 2: { - rewrite !Z.shiftl_lor. - rewrite !Z.shiftl_mul_pow2 ; try easy. - rewrite !Z.mul_0_l. - rewrite Z.lor_0_r. - replace (int_to_Z (Posz 32)) with 32%Z by reflexivity. - - repeat apply (Z_lor_pow2 _ _ (32 + 32 + 32 + 32)) ; replace (2 ^ (int_to_Z (Posz(32 + 32 + 32 + 32))))%Z with (2 ^ 32 * 2 ^ 32 * 2 ^ 32 * 2 ^ 32)%Z by reflexivity. - all: split ; [ destruct a₁, a₁0, a₁1, a₁2 ; unfold urepr ; simpl ; apply (ssrbool.elimT (iswordZP _ _)) in i, i0, i1, i2 ; repeat (apply Z.lor_nonneg ; split ; [ repeat apply Z.mul_nonneg_nonneg ; easy | ]) ; repeat apply Z.mul_nonneg_nonneg ; easy | ]. - all: repeat (apply -> (@Z.mul_lt_mono_pos_r (2 ^ 32)) ; [ | easy ]) ; apply (@num_smaller_if_modulus_lte U32) ; easy. - } - - rewrite Zmod_small ; [ | apply num_smaller_if_modulus_lte ; easy]. - rewrite Zmod_small. - 2:{ - setoid_rewrite Zmod_small ; [ | apply num_smaller_if_modulus_lte ; easy | apply num_smaller_if_modulus_lte ; easy ]. - apply (shift_left_4_byte_ok 1) ; easy. - } - rewrite Zmod_small. - 2:{ - setoid_rewrite Zmod_small ; try (apply num_smaller_if_modulus_lte ; easy). - apply (shift_left_4_byte_ok 2) ; easy. - } - rewrite Zmod_small. - 2:{ - setoid_rewrite Zmod_small ; try (apply num_smaller_if_modulus_lte ; easy). - apply (shift_left_4_byte_ok 3) ; easy. - } - setoid_rewrite Zmod_small ; try (apply num_smaller_if_modulus_lte ; easy). - - rewrite !Z.shiftl_lor. - rewrite !Z.shiftl_mul_pow2 ; try easy. - rewrite !Z.mul_0_l. - rewrite Z.lor_0_r. - rewrite <- !Z.mul_assoc. - rewrite <- !Z.pow_add_r ; try easy. - now rewrite <- !Z.lor_assoc. + reflexivity. Qed. Lemma wshufps_128_eq_state : @@ -511,53 +728,19 @@ Section Hacspec. unfold map. unfold vpshufd. - solve_wpshufd1_vpshufd1 0 n. - solve_wpshufd1_vpshufd1 1 n. - solve_wpshufd1_vpshufd1 2 n. - solve_wpshufd1_vpshufd1 3 n. + solve_wpshufd1_vpshufd1 0. + solve_wpshufd1_vpshufd1 1. + solve_wpshufd1_vpshufd1 2. + solve_wpshufd1_vpshufd1 3. + + rewrite rebuild_128_eq. + intros. apply r_ret. intros ? ? [? [? [? []]]]. subst. subst H4. split ; [ clear | assumption ]. - - apply word_ext. - - unfold wcat_r. - - Opaque Z.shiftl. - simpl. - Transparent Z.shiftl. - - rewrite !mkwordK. - - rewrite Zmod_small. - 2: { - rewrite !Z.shiftl_lor. - rewrite !Z.shiftl_mul_pow2 ; try easy. - rewrite !Z.mul_0_l. - rewrite Z.lor_0_r. - repeat apply (Z_lor_pow2 _ _ (32 + 32 + 32 + 32)) ; replace (2 ^ (int_to_Z (Posz(32 + 32 + 32 + 32))))%Z with (2 ^ 32 * 2 ^ 32 * 2 ^ 32 * 2 ^ 32)%Z by reflexivity. - all: split ; [ destruct a₁, a₁0, a₁1, a₁2 ; unfold urepr ; simpl ; apply (ssrbool.elimT (iswordZP _ _)) in i, i0, i1, i2 ; repeat (apply Z.lor_nonneg ; split ; [ repeat apply Z.mul_nonneg_nonneg ; easy | ]) ; repeat apply Z.mul_nonneg_nonneg ; easy | ]. - all: repeat (apply -> (@Z.mul_lt_mono_pos_r (2 ^ 32)) ; [ | easy ]) ; apply (@num_smaller_if_modulus_lte U32) ; easy. - } - - rewrite !Zmod_small. - all: try apply (@num_smaller_if_modulus_lte U32). - all: try easy. - 2: apply (shiftl_bounds _ 96 128) ; [ easy | cbn ; apply (@num_smaller_if_modulus_lte U32) ; easy ]. - 2: apply (shiftl_bounds _ 64 128) ; [ easy | cbn ; apply (@num_smaller_if_modulus_lte U32) ; easy ]. - 2: apply (shiftl_bounds _ 32 128) ; [ easy | cbn ; apply (@num_smaller_if_modulus_lte U32) ; easy ]. - - rewrite !Z.shiftl_lor. - rewrite !Z.shiftl_mul_pow2 ; try easy. - rewrite !Z.mul_0_l. - rewrite Z.lor_0_r. - rewrite <- !Z.mul_assoc. - rewrite <- !Z.pow_add_r ; try easy. - rewrite <- !Z.lor_assoc. - simpl. reflexivity. Qed. @@ -912,380 +1095,90 @@ Section Hacspec. apply r_put_rhs. apply H. intuition. - Unshelve. - subst. - intuition. - Qed. - - Lemma subword_eq (n : int128) (i : nat): - (i < 4) -> - word.subword (i * U32)%nat U32 n = - @repr U32 (unsigned (((lift_to_both0 n) shift_right (lift_to_both0 (usize (i * 32)))) .% (( - lift_to_both0 (@repr U128 1)) shift_left (lift_to_both0 (usize 32))))). - Proof. - intros. - apply word_ext. - simpl. - unfold Hacspec_Lib_Pre.int_mod. - replace (Hacspec_Lib_Pre.shift_left_ (repr 1) (repr 32)) with (@repr U128 (modulus 32)) by reflexivity. - setoid_rewrite wunsigned_repr. - replace (wunsigned (repr (modulus 32))) with (modulus 32) by reflexivity. - replace (modulus (wsize_size_minus_1 U128).+1) with (modulus 96 * modulus 32)%Z by reflexivity. - rewrite mod_pq_mod_q. - rewrite Zmod_mod. - f_equal. - do 4 (destruct i ; [easy | ]) ; easy. - easy. - easy. - Qed. - - Lemma nat_to_be_range_is_subword : forall {WS : wsize.wsize} {WS_inp : wsize.wsize} (n : @int WS_inp) i `{H_WS : WS <= WS_inp} , (@repr WS (nat_be_range WS (toword n) i) = word.subword (i * WS) WS n). - Proof. - intros. - apply word_ext. - cbn. - unfold nat_be_range. - replace (_ ^ WS)%Z with (modulus WS)%Z by (destruct WS ; reflexivity). - replace (modulus WS_inp) with (modulus (WS_inp - WS) * modulus WS)%Z by (destruct WS , WS_inp ; easy). - rewrite mod_pq_mod_q ; [ | easy | easy ]. - rewrite !Zmod_mod. - f_equal. - rewrite <- Z.shiftr_div_pow2 ; [ | lia ]. - rewrite Nat2Z.inj_mul. - f_equal. now zify. - Qed. - - Theorem modulus_exact : forall {WS : wsize.wsize} (x : 'word WS), (0 <= x < modulus WS)%Z. - Proof. - intros. - destruct x. - cbn. - apply (ssrbool.elimT (iswordZP _ _)) in i. - apply i. - Qed. - - Theorem modulus_smaller : forall (WS : wsize.wsize) (m : nat) {x : 'word WS}, (WS <= m)%Z -> (0 <= x < modulus m)%Z. - Proof. - intros. - destruct x. - cbn. - apply (ssrbool.elimT (iswordZP _ _)) in i. - split. - - easy. - - eapply Z.lt_le_trans. - apply i. - rewrite modulusZE. - rewrite modulusZE. - apply (Z.pow_le_mono_r 2). - reflexivity. - apply H. - Qed. - - Lemma sbox_eq : - (forall n i, (i < 4)%nat -> - @Hacspec_Lib_Pre.array_index int8 (@int_default U8) - (uint_size_to_nat - (Z_to_uint_size - (Z.modulo (Zpos (xO (xO (xO (xO (xO (xO (xO (xO xH))))))))) - (modulus (S nat31))))) sbox_v U8 - (@Hacspec_Lib_Pre.array_index int8 (@int_default U8) - (S (S (S (S O)))) - (Hacspec_Lib_Pre.u32_to_be_bytes n) U32 - (@repr U32 i)) = waes.Sbox (word.subword (i * U8) U8 n)). - Proof. - intros. - - simpl. - unfold Hacspec_Lib_Pre.u32_to_be_bytes. - unfold to_be_bytes. - rewrite !eq_rect_K. - unfold Hacspec_Lib_Pre.array_index at 2. - assert (H0 : forall (n : int32) i, i < 4 -> Hacspec_Lib_Pre.array_index (WS := U8) sbox_v (repr (nat_be_range 8 n i)) = waes.Sbox (word.subword (i * U8) U8 n)). - 2: do 4 (destruct i ; [ simpl ; apply H0 ; apply H | ]) ; discriminate. - clear ; intros. - rewrite (nat_to_be_range_is_subword (WS := U8) n i (H_WS := ltac:(easy))). - - destruct (word.subword (i * U8) U8 n). - destruct toword. - - reflexivity. - - (* SLOW! *) (* admit. *) - do 8 (destruct p ; [ | | reflexivity ]). - all: destruct p ; easy. - - easy. - (* Admitted. *) Qed. - - Lemma SubWord_eq id0 (n : int32) pre : - (pdisj pre id0 (CEfset ([res_238_loc]))) -> - ⊢ ⦃ pre ⦄ - ret (waes.SubWord n) ≈ - subword n - ⦃ fun '(v0, h0) '(v1, h1) => (v0 = v1) /\ pre (h0, h1) ⦄. - Proof. - intros. - unfold waes.SubWord. - unfold split_vec. - replace (U32 %/ U8 + U32 %% U8) with 4 by reflexivity. - - unfold subword. - setoid_rewrite bind_rewrite. - apply better_r_put_rhs. - - (* Unroll for loop *) - unfold let_both at 1, is_state at 1, prog. - setoid_rewrite <- foldi__move_S. - replace (prog (lift_to_both0 (usize _) .+ one)) with (ret (usize 1)) by reflexivity. - unfold bind at 3. - - setoid_rewrite <- foldi__move_S. - replace (prog (is_state (usize 1 .+ one))) with (ret (usize 2)) by reflexivity. - unfold bind at 3. - - setoid_rewrite <- foldi__move_S. - replace (prog (is_state (usize 2 .+ one))) with (ret (usize 3)) by reflexivity. - unfold bind at 3. - - setoid_rewrite <- foldi__move_S. - replace (prog (is_state (usize 3 .+ one))) with (ret (usize 4)) by reflexivity. - unfold bind at 3. - unfold foldi_. - - rewrite bind_ret. - setoid_rewrite bind_ret. - rewrite bind_rewrite. - - rewrite !ct_T_id. - rewrite !T_ct_id. - - apply r_ret. - intros. - - unfold Hacspec_Lib_Pre.u32_from_be_bytes, from_be_bytes. - unfold from_be_bytes_fold_fun. - - rewrite !array_to_list_upd_spec. - - destruct_pre. - split. - 2:{ - cbn. - - apply H. - setoid_rewrite <- fset1E. - apply (ssrbool.introT (fset1P _ _)). - reflexivity. - apply H2. - } - - unfold repr, unsigned. - rewrite <- !sbox_eq ; try easy. - - rewrite Hacspec_Lib_Pre.array_to_list_equation_2. - rewrite Hacspec_Lib_Pre.array_to_list_equation_2. - rewrite Hacspec_Lib_Pre.array_to_list_equation_2. - rewrite Hacspec_Lib_Pre.array_to_list_equation_2. - rewrite Hacspec_Lib_Pre.array_to_list_equation_1. - - unfold nseq_hd. - - - set ([ _ ; _ ; _ ; _ ]). - replace (make_vec U32 l) with (4, make_vec U32 l).2 by reflexivity. - Set Printing Coercions. - unfold T_ct. - unfold Datatypes.id. - unfold eq_rect_r. - unfold eq_rect. - unfold Logic.eq_sym. - unfold ChoiceEq. - unfold int32, int. unfold Hacspec_Lib_Pre.int_obligation_1. - apply f_equal. - - replace (Z.to_nat (unsigned (wrepr U32 0))) with 0 by reflexivity. - replace (Z.to_nat (unsigned (wrepr U32 1))) with 1 by reflexivity. - replace (Z.to_nat (unsigned (wrepr U32 2))) with 2 by reflexivity. - replace (Z.to_nat (unsigned (wrepr U32 3))) with 3 by reflexivity. - - replace (Pos.to_nat 1) with 1 by reflexivity. - replace (Pos.to_nat 2) with 2 by reflexivity. - replace (Pos.to_nat 3) with 3 by reflexivity. - - subst l. - - unfold Hacspec_Lib_Pre.array_new_. - simpl. - (* rewrite eq_rect_K. *) - (* set (getm _ _). *) - (* cbn in o. *) - (* subst o. *) - (* hnf. *) - (* set (_ ++ _). *) - (* cbn in l. *) - (* subst l. *) - (* hnf. *) - - unfold fold_right. - unfold set_nth. - rewrite !nat_N_Z. - unfold int8_to_nat, uint_size_to_nat, from_uint_size, nat_uint_sizeable, Z_to_uint_size. - unfold unsigned, repr. - unfold Hacspec_Lib_Pre.int_add, add_word. - unfold make_vec. - unfold wcat_r. - unfold wunsigned, wrepr, mkword, urepr, val, word_subType. - - - - set (Hacspec_Lib_Pre.array_index _ _). - set (Hacspec_Lib_Pre.array_index _ _). - set (Hacspec_Lib_Pre.array_index _ _). - set (Hacspec_Lib_Pre.array_index _ _). - - unfold toword in |- *. - - rewrite !Z2Nat.id. - - unfold Z.of_nat. - - f_equal. - apply word_ext. - - Unset Printing Coercions. - - rewrite !Z.shiftl_mul_pow2 ; try easy. - - simpl. - cbn. - - replace 1%Z with (1 mod modulus nat31.+1)%Z by reflexivity. - replace 256%Z with (256 mod modulus nat31.+1)%Z by reflexivity. - replace 65536%Z with (65536 mod modulus nat31.+1)%Z by reflexivity. - replace 16777216%Z with (16777216 mod modulus nat31.+1)%Z by reflexivity. - rewrite <- !Zmult_mod. - rewrite !Zmod_mod. - rewrite <- !Z.add_mod. - - rewrite <- Z.add_assoc. - rewrite (Z.add_mod ((_ * 1 + _ * 256) mod _)). - rewrite !Zmod_mod. - rewrite <- Z.add_mod. - - rewrite Z.add_comm. - rewrite <- Z.add_assoc. - rewrite (Z.add_mod ((_ * 65536) mod _)). - rewrite !Zmod_mod. - rewrite <- Z.add_mod. - - rewrite Z.add_comm. - rewrite <- Z.add_assoc. - rewrite Z.add_comm. - rewrite <- Z.add_assoc. - rewrite <- Z.add_assoc. + Unshelve. + subst. + intuition. + Qed. - simpl. + Lemma nat_to_be_range_is_subword : forall {WS : wsize.wsize} {WS_inp : wsize.wsize} (n : @int WS_inp) i `{H_WS : WS <= WS_inp} , (@repr WS (nat_be_range WS (toword n) i) = word.subword (i * WS) WS n). + Proof. + intros. + apply word_ext. cbn. - + unfold nat_be_range. + replace (_ ^ WS)%Z with (modulus WS)%Z by (destruct WS ; reflexivity). + replace (modulus WS_inp) with (modulus (WS_inp - WS) * modulus WS)%Z by (destruct WS , WS_inp ; easy). + rewrite mod_pq_mod_q ; [ | easy | easy ]. + rewrite !Zmod_mod. f_equal. + rewrite <- Z.shiftr_div_pow2 ; [ | lia ]. + rewrite Nat2Z.inj_mul. + f_equal. now zify. + Qed. - all: try easy. - - assert (H_lor_add : forall (a b : Z) (k : nat), (0 <= a < modulus k)%Z -> (a + Z.shiftl b k)%Z = Z.lor a (Z.shiftl b k)). - { - clear ; intros. - - assert (Z.land a (Z.shiftl b k) = 0). - { - apply Z.bits_inj_iff. - intros i. - rewrite Z.land_spec. - rewrite Z.bits_0. - - destruct (0 <=? i)%Z eqn:i0. - { - destruct (i (0 <= x < modulus m)%Z. + Proof. + intros. + destruct x. + cbn. + apply (ssrbool.elimT (iswordZP _ _)) in i. + split. + - easy. + - eapply Z.lt_le_trans. + apply i. + rewrite modulusZE. + rewrite modulusZE. + apply (Z.pow_le_mono_r 2). reflexivity. - } - - replace 1%Z with (modulus 0)%Z by reflexivity. - replace 256%Z with (modulus 8)%Z by reflexivity. - replace 65536%Z with (modulus 16)%Z by reflexivity. - replace 16777216%Z with (modulus 24)%Z by reflexivity. - - rewrite !modulusZE. - rewrite <- !Z.shiftl_mul_pow2 ; try easy. - - rewrite !Z.add_assoc. - rewrite !Z.shiftl_0_r. - rewrite Z.lor_0_r. - - rewrite !H_lor_add. - - - rewrite !Z.shiftl_lor. - rewrite <- !Z.lor_assoc. - rewrite !Z.shiftl_shiftl. + apply H. + Qed. - reflexivity. - all: try easy. - all: try rewrite Zmod_small. + Lemma sbox_eq : + (forall n i, (i < 4)%nat -> + is_pure (array_index sbox_v + (index_u8 (lift_to_both0 n) (lift_to_both0 (usize i)))) = waes.Sbox (word.subword (i * U8) U8 n)). + Proof. + intros. + rewrite index_8_eq ; [ | apply H ]. - all: try (apply (ssrbool.elimT (iswordZP _ _)) ; now destruct t0). - all: try split. + destruct (is_pure (index_u8 _ _)). + destruct toword. + - reflexivity. + - (* SLOW! *) admit. + (* repeat (destruct p ; [ | | reflexivity ]) ; exfalso ; destruct p ; discriminate i0. *) + - easy. + Admitted. (* Qed. *) - all: try (rewrite modulusZE ; apply Z_lor_pow2 ; rewrite <- modulusZE). - all: try apply shiftl_bounds. - all: try (rewrite modulusZE ; apply Z_lor_pow2 ; rewrite <- modulusZE). - all: try apply shiftl_bounds. - all: try easy. + Lemma SubWord_eq id0 (n : int32) pre : + (pdisj pre id0 fset0) -> + ⊢ ⦃ pre ⦄ + ret (waes.SubWord n) ≈ + is_state (subword n) + ⦃ fun '(v0, h0) '(v1, h1) => (v0 = v1) /\ pre (h0, h1) ⦄. + Proof. + intros. + unfold waes.SubWord. + unfold split_vec. + replace (U32 %/ U8 + U32 %% U8) with 4 by reflexivity. - all: try apply Z.lor_nonneg. - all: try split. - all: try apply Z.shiftl_nonneg. - all: try apply Z.lor_nonneg. - all: try split. - all: try apply Z.shiftl_nonneg. - all: try apply Z.lor_nonneg. - all: try split. - all: try apply Z.shiftl_nonneg. - all: try easy. + unfold map. + unfold iota. + rewrite rebuild_32_eq. - all: try apply (modulus_exact t). - all: try apply (modulus_exact t0). - all: try apply (modulus_exact t1). - all: try apply (modulus_exact t2). + unfold subword. + do 4 (rewrite <- sbox_eq ; [ | easy ]). - all: try (apply (modulus_smaller U8 16) ; easy). - all: try (apply (modulus_smaller U8 24) ; easy). - all: try (apply (modulus_smaller U8 32) ; easy). - all: cbn ; lia. + apply r_ret. + split ; easy. Qed. Ltac match_pattern_and_bind_repr p := @@ -1333,7 +1226,7 @@ Section Hacspec. end. Lemma keygen_assist_eq id0 (v1 : 'word U128) (v2 : 'word U8) (pre : precond) : - (pdisj pre id0 (CEfset [res_238_loc])) -> + (pdisj pre id0 fset0) -> ⊢ ⦃ pre ⦄ ret (waes.wAESKEYGENASSIST v1 v2) ≈ @@ -1344,10 +1237,7 @@ Section Hacspec. unfold waes.wAESKEYGENASSIST. - unfold make_vec. - unfold wcat_r. - rewrite Z.shiftl_0_l. - rewrite Z.lor_0_r. + rewrite rebuild_128_eq. unfold aeskeygenassist. @@ -1355,28 +1245,33 @@ Section Hacspec. { apply r_ret. intros. - rewrite (subword_eq v1) ; [ | easy ]. - split. reflexivity. assumption. + rewrite index_32_eq ; [ | easy ]. + split. setoid_rewrite wrepr_unsigned. reflexivity. assumption. } match_pattern_and_bind_repr (@word.subword (wsize_size_minus_1 U128).+1 (3 * U32) U32 v1). { apply r_ret. intros. - rewrite (subword_eq v1) ; [ | easy ]. - split ; easy. + rewrite index_32_eq ; [ | easy ]. + split ; [ setoid_rewrite wrepr_unsigned | ] ; easy. } match_pattern_and_bind (waes.SubWord a₀). { subst. - apply (SubWord_eq id0 (repr a₁) (λ '(s₀1, s₁1), pre (s₀1, s₁1))). - destruct_pre. - hnf. - eapply H. + replace (is_pure (lift_to_both0 _)) with (@repr U32 a₁). + 2:{ + pose (isword_Z _ a₁). + destruct a₁. + apply word_ext. + now rewrite Zmod_small. + } + eapply (SubWord_eq id0 (repr a₁) (λ '(s₀1, s₁1), pre (s₀1, s₁1))). + apply H. } - match_pattern_and_bind (word.wxor (wror (sz:=U32) a₀1 1) (zero_extend U32 (sz':=U8) v2)). + match_pattern_and_bind (word.wxor (wror (sz:=U32) a₀1 8) (zero_extend U32 (sz':=U8) v2)). { subst. apply r_ret. @@ -1389,13 +1284,18 @@ Section Hacspec. match_pattern_and_bind (waes.SubWord a₀0). { subst. + replace (is_pure (lift_to_both0 _)) with (@repr U32 a₁0). + 2:{ + pose (isword_Z _ a₁0). + destruct a₁0. + apply word_ext. + now rewrite Zmod_small. + } apply (SubWord_eq id0 (repr a₁0) (λ '(s₀1, s₁1), pre (s₀1, s₁1))). - destruct_pre. - hnf. - eapply H. + apply H. } - match_pattern_and_bind (word.wxor (wror (sz:=U32) a₀3 1) + match_pattern_and_bind (word.wxor (wror (sz:=U32) a₀3 8) (zero_extend U32 (sz':=U8) v2)). { subst. @@ -1406,64 +1306,16 @@ Section Hacspec. - apply H0. } + subst. apply r_ret. intros. subst. all: try (intros ? ? [] ; subst ; assumption). - split. - - set (Hacspec_Lib_Pre.int_or _ _). - cbn in t. - subst t. - - apply word_ext. - rewrite <- !Z.lor_assoc. - rewrite !Z.shiftl_lor. - rewrite !Z.shiftl_shiftl. - rewrite !Zmod_small. - f_equal. - - all: try (apply (modulus_smaller U32 U128) ; easy). - + apply (shiftl_bounds _ 96 128). easy. - apply (modulus_exact a₁4). - + apply (shiftl_bounds _ 64 128). easy. - apply (modulus_smaller U32 U64). easy. - + apply (shiftl_bounds _ 32 128). easy. - apply (modulus_smaller U32 96). easy. - + split. - * apply Z.lor_nonneg. split. apply word_geZ0. - apply Z.lor_nonneg. split. apply Z.shiftl_nonneg. apply word_geZ0. - apply Z.lor_nonneg. split. apply Z.shiftl_nonneg. apply word_geZ0. - apply Z.shiftl_nonneg. apply word_geZ0. - * rewrite modulusZE. - apply Z_lor_pow2. - split. apply word_geZ0. - eapply Z.lt_trans. - apply (modulus_exact a₁1). - easy. - - apply Z_lor_pow2. - split. apply Z.shiftl_nonneg. apply word_geZ0. - rewrite <- modulusZE. - apply (shiftl_bounds _ U32 U128). easy. - apply num_smaller_if_modulus_lte. easy. - - apply Z_lor_pow2. - split. apply Z.shiftl_nonneg. apply word_geZ0. - rewrite <- modulusZE. - apply (shiftl_bounds _ U64 U128). easy. - apply num_smaller_if_modulus_lte. easy. - - rewrite <- modulusZE. - apply (shiftl_bounds _ 96 U128). easy. - apply num_smaller_if_modulus_lte. easy. - + easy. - + easy. - + easy. - - apply H12. + easy. Qed. Lemma key_expand_eq id0 rcon rkey temp2 (pre : precond) : - (pdisj pre id0 (CEfset [res_238_loc])) -> + (pdisj pre id0 fset0) -> ⊢ ⦃ pre ⦄ JKEY_EXPAND id0 rcon rkey temp2 ≈ @@ -1488,7 +1340,6 @@ Section Hacspec. do 2 remove_get_in_lhs. bind_jazz_hac ; [shelve | ]. - eapply rpre_weak_hypothesis_rule'. intros ? ? [? H]. @@ -1497,12 +1348,13 @@ Section Hacspec. rewrite bind_assoc. rewrite bind_assoc. + rewrite <- bind_ret. match goal with | [ |- context [ ⊢ ⦃ ?pre ⦄ _ ≈ _ ⦃ _ ⦄ ] ] => set (P := pre) end. apply r_bind with (mid := λ '(v0, h0) '(v1, h1), (∃ o1 o2 : 'word U128, - v0 = [('word U128; o1); ('word U128; o2)] ∧ (o1, o2) = v1) /\ P (h0, h1)). + v0 = [('word U128; o1) ; ('word U128; o2)] ∧ (o1, o2) = v1) /\ P (h0, h1)). 2:{ intros. subst P. @@ -1513,6 +1365,7 @@ Section Hacspec. eexists. split. reflexivity. + rewrite !zero_extend_u. inversion H25. subst. inversion H24. @@ -1631,6 +1484,313 @@ Section Hacspec. } - easy. + Transparent translate_call. + Qed. + + (* Lemma foldr_foldi : forall A (default : T A) L I (f : Z -> _ -> raw_code A) x g y pre, *) + (* forall (n : nat), *) + (* (f 1%Z (f 0%Z x)) = (y ← f 0%Z x ;; f 1%Z (ret y)) -> *) + (* (forall n x y, *) + (* ⊢ ⦃ pre ⦄ *) + (* f n x ≈ is_state (g (usize n) y) *) + (* ⦃ fun '(v0, h0) '(v1, h1) => *) + (* True /\ pre (h0, h1) ⦄) -> *) + (* ⊢ ⦃ pre ⦄ *) + (* (foldr f x (rev [seq Z.of_nat i | i <- iota 0 (S n)])) ≈ *) + (* (foldi_both' (acc := seq A) (L := L) (I := I) (lift_to_both0 (repr 0)) (lift_to_both0 (repr (Z.of_nat (S n)))) *) + (* y g) *) + (* ⦃ fun '(v0, h0) '(v1, h1) => *) + (* True /\ pre (h0, h1) ⦄. *) + (* Proof. *) + (* intros. *) + (* induction n. *) + (* - cbn. *) + (* simpl. *) + (* rewrite <- (bind_ret _ (f _ _)). *) + (* eapply r_bind. *) + (* apply H0. *) + (* intros. *) + (* apply r_ret. *) + (* easy. *) + (* - rewrite <- foldl_rev. *) + (* rewrite revK. *) + (* cbn. *) + (* rewrite <- revK. *) + (* rewrite foldl_rev. *) + (* admit. *) + (* Admitted. *) + + Lemma rcon_eq id0 (j : nat) (pre : precond) : + (pdisj pre id0 fset0) -> + (0 < j < 11)%Z -> + ⊢ ⦃ pre ⦄ + JRCON id0 (Z.of_nat j) + ≈ + is_state (array_index (rcon_v) (@repr U8 j)) + ⦃ fun '(v0, h0) '(v1, h1) => + (exists o1, v0 = [('int; o1)] /\ repr o1 = v1) /\ pre (h0, h1) ⦄. + Proof. + intros. + unfold JRCON. + unfold get_translated_static_fun. + simpl. + apply better_r_put_lhs. + remove_get_in_lhs. + fold @bind. + rewrite !coerce_to_choice_type_K. + repeat setoid_rewrite coerce_to_choice_type_K. + cbn. + rewrite !array_from_list_helper_equation_2. + simpl. + rewrite Hacspec_Lib_Pre.array_index_equation_2. + simpl. + cbn. + unfold array_index_clause_2. + unfold array_index_clause_2_clause_1. + simpl. + destruct j as [ | j ]. + { + easy. + } + + do 10 (destruct j as [ | j ] ; [ simpl ; repeat (remove_get_in_lhs ; simpl) ; apply better_r_put_lhs ; remove_get_in_lhs ; apply r_ret ; intros ; destruct_pre ; split ; [ eexists ; split ; [ | reflexivity] ; f_equal ; unfold totce ; repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K) ; reflexivity | eapply H ; [ reflexivity | reflexivity | ] ; eapply H ; [ reflexivity | reflexivity | ] ; apply H5 ] | ]). + exfalso. + destruct H0. + simpl in H1. + rewrite !Pos2Z.inj_succ in H1. + eapply Z.lt_asymm. + apply H1. + lia. Qed. + Lemma keys_expand_eq id0 rkey (pre : precond) : + (pdisj pre id0 (fset ((seq_choice uint8; 278) :: seq.map CE_loc_to_loc ( + [])))) -> + ⊢ ⦃ pre ⦄ + JKEYS_EXPAND id0 rkey + ≈ + is_state (keys_expand rkey) + ⦃ fun '(v0, h0) '(v1, h1) => + (exists o1, v0 = [('array; o1)] /\ True) /\ pre (h0, h1) ⦄. + Proof. + intros H_pdisj. + set (JKEYS_EXPAND _ _). + unfold translate_call, translate_call_body in r |- *. + Opaque translate_call. + unfold JKEY_EXPAND in r. + unfold get_translated_static_fun, JAES_ROUNDS, get_translated_static_fun, translate_prog_static, translate_funs_static, translate_call_body in r. + simpl in r. + subst r. + rewrite !zero_extend_u. + + + apply better_r, r_put_lhs, better_r. + remove_get_in_lhs. + apply better_r, r_get_remember_lhs ; intros ; apply better_r. + + unfold keys_expand. + + unfold let_mut_both at 1, is_state at 1, is_state at 1, is_state at 1. + Opaque is_state. Opaque is_pure. + match goal with + | [ |- context [ ⊢ ⦃ ?P ⦄ ?lhs ≈ ?rhs ⦃ ?Q ⦄ ] ] => + simpl rhs + end. + Transparent is_state. Transparent is_pure. + + rewrite bind_rewrite. + setoid_rewrite bind_rewrite. + apply better_r_put_rhs. + + unfold let_mut_both at 1, is_state at 1, is_state at 1, is_state at 1. + Opaque is_state. Opaque is_pure. + match goal with + | [ |- context [ ⊢ ⦃ ?P ⦄ ?lhs ≈ ?rhs ⦃ ?Q ⦄ ] ] => + simpl rhs + end. + Transparent is_state. Transparent is_pure. + + rewrite bind_rewrite. + apply better_r_put_rhs. + rewrite bind_rewrite. + apply better_r_put_rhs. + apply better_r_put_rhs. + apply better_r_put_lhs. + + apply better_r_put_lhs. + + + unfold let_mut_both at 1, is_state at 1, is_state at 1, is_state at 1. + Opaque is_state. Opaque is_pure. + match goal with + | [ |- context [ ⊢ ⦃ ?P ⦄ ?lhs ≈ ?rhs ⦃ ?Q ⦄ ] ] => + simpl rhs + end. + Transparent is_state. Transparent is_pure. + + set (set_lhs _ _ _). + rewrite bind_assoc. + eapply (@r_bind _ _ _ _ _ _ _ _ _ (λ '(v0, h0) '(v1, h1), p (h0, h1))) ; [ shelve | ]. + subst p. + intros. + (* rewrite bind_rewrite. *) + eapply better_r_get_remind_lhs. shelve. + destruct a₁. + simpl. + destruct s. + simpl. + + apply r_ret. + intros. + destruct_pre. + split. + eexists. + split. + reflexivity. + reflexivity. + + apply H_pdisj. + admit. + apply H_pdisj. + admit. + eapply H_pdisj. + admit. + admit. + + Unshelve. + 2: apply x. + + simpl. + + intros. + + set (fun (_ : p_id) => _). + set (fun (_ : int_type) (_ : _ * _ * _) => _). + + rewrite !coerce_typed_code_K. + rewrite bind_rewrite. + rewrite bind_rewrite. + + unfold foldi_pre ; replace (unsigned (repr 12) - unsigned (repr 1))%Z with 11%Z by reflexivity. + replace (Z.to_nat (11 - 1)) with 10 by reflexivity. + replace (Pos.to_nat 11) with 11 by reflexivity. + + assert (forall j n, [seq (1 + Z.of_nat i)%Z | i <- iota j (S n)] = + ((1 + Z.of_nat j)%Z :: [seq (1 + Z.of_nat i)%Z | i <- iota (S j) n])) by reflexivity. + + rewrite H. + unfold translate_for ; fold translate_for. + rewrite <- foldi__move_S. + unfold y at 1. + unfold y0 at 1. + rewrite <- bind_assoc. + eapply r_bind. + + apply better_r_put_lhs. + remove_get_in_lhs. + + rewrite bind_assoc. + + eapply r_bind with (mid := λ '(v0, h0) '(v1, h1), + (∃ o1 : (λ i : choice_type_choiceType, i) 'int, + v0 = [('int; o1)] ∧ repr o1 = v1) ∧ + _ (h0, h1)). + { + set (set_lhs _ _ _). + epose (rcon_eq (id0~1~1)%positive 1 p0). + unfold JRCON in r. + replace (call 12%positive (id0~1~1)%positive [totce (coe_cht 'int _)]) + with + (get_translated_static_fun ssprove_jasmin_prog 12%positive + static_funs (id0~1~1)%positive [('int; Z.of_nat 1)]). + apply r. + admit. + easy. + Transparent translate_call. + unfold translate_call, translate_call_body in r. + simpl. + cbn. + repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). + reflexivity. + } + Admitted. + + Lemma addroundkey_eq id0 (rkeys : 'array) (rkeys' : seq uint8) m (pre : precond) : + (pdisj pre id0 (fset [CE_loc_to_loc res_238_loc ; (CE_loc_to_loc ( nseq int8 1 ; 0%nat ) : Location) ])) -> + seq.unzip2 (FMap.fmval rkeys) = seq.unzip2 (FMap.fmval rkeys') -> + ⊢ ⦃ pre ⦄ + JAES_ROUNDS id0 rkeys m + ≈ + is_state (aes_rounds rkeys' m) + ⦃ fun '(v0, h0) '(v1, h1) => (exists o1, v0 = [('word U128; o1)] /\ o1 = v1) /\ pre (h0, h1) ⦄. + Proof. + intros H_pdisj rkeys_ext. + set (JAES_ROUNDS _ _ _). + unfold JAES_ROUNDS in r. + unfold get_translated_static_fun, JAES_ROUNDS, get_translated_static_fun, translate_prog_static, translate_funs_static, translate_call_body in r. + Opaque translate_call. + simpl in r. + subst r. + rewrite !zero_extend_u. + + apply better_r, r_put_lhs, better_r. + apply better_r, r_put_lhs, better_r. + remove_get_in_lhs. + apply better_r, r_put_lhs, better_r. + remove_get_in_lhs. + remove_get_in_lhs. + rewrite !zero_extend_u. + + unfold aes_rounds. + + rewrite !coerce_to_choice_type_K. + Set Printing Coercions. + unfold lift_to_both0 at 1. + + unfold let_mut_both at 1, is_state at 1, is_state at 1, is_state at 1. + Opaque is_state. Opaque is_pure. + simpl. Transparent is_state. Transparent is_pure. + + bind_jazz_bind. + { admit. (* xor *) } + + apply better_r_put_lhs. + apply better_r_put_rhs. + + rewrite bind_assoc. + rewrite bind_assoc. + rewrite <- bind_assoc. + + eapply r_bind. + { admit. (* AES Enc loop *) } + + intros. + + { admit. (* AES Enc last *) } + Admitted. + + Lemma aes_eq id0 key m (pre : precond) : + (pdisj pre id0 (fset [CE_loc_to_loc res_238_loc ; (CE_loc_to_loc ( nseq int8 1 ; 0%nat ) : Location) ])) -> + ⊢ ⦃ pre ⦄ + JAES id0 key m + ≈ + is_state (aes key m) + ⦃ fun '(v0, h0) '(v1, h1) => (exists o1, v0 = [('word U128; o1)] /\ o1 = v1) /\ pre (h0, h1) ⦄. + Proof. + intros H_pdisj. + set (JAES _ _ _). + unfold JAES_ROUNDS in r. + unfold get_translated_static_fun, JAES_ROUNDS, get_translated_static_fun, translate_prog_static, translate_funs_static, translate_call_body in r. + Opaque translate_call. + simpl in r. + subst r. + rewrite !zero_extend_u. + + apply better_r_put_lhs. + apply better_r_put_lhs. + remove_get_in_lhs. + Admitted. + + + End Hacspec. From eee22e259620343f067d75b0b1b6850a9084d267 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Tue, 24 Jan 2023 16:50:56 +0100 Subject: [PATCH 350/383] WIP aes_hac --- theories/Jasmin/examples/aes/aes_hac.v | 353 +++++++++++++++++++++---- 1 file changed, 296 insertions(+), 57 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes_hac.v b/theories/Jasmin/examples/aes/aes_hac.v index e0dc8d60..4a36b908 100644 --- a/theories/Jasmin/examples/aes/aes_hac.v +++ b/theories/Jasmin/examples/aes/aes_hac.v @@ -29,7 +29,7 @@ Import PackageNotation. From Hacspec Require Import Hacspec_Aes_Jazz ChoiceEquality Hacspec_Lib Hacspec_Lib_Pre Hacspec_Lib_Comparable. Open Scope hacspec_scope. -Notation call fn := (translate_call _ fn _). +(* Notation call fn := (translate_call _ fn _). *) #[global] Hint Resolve preceq_I preceq_O preceq_refl : preceq. @@ -1563,15 +1563,74 @@ Section Hacspec. lia. Qed. + Theorem loop_eq : + forall (acc : ChoiceEquality) id0 pre d i c id v I L y + (y0 : int -> acc -> code L I acc) id', + (i < d) -> + (i + d < modulus U32) -> + ⊢ ⦃ pre ⦄ + translate_write_var id0 v + (totce (translate_value (values.Vint (1 + Z.of_nat i)))) ;; + y id ≈ y0 (repr i.+1) c ⦃ λ '(_, h0) '(_, h1), pre (h0, h1) ⦄ -> + ⊢ ⦃ pre ⦄ + (translate_for v + [seq (1 + Z.of_nat i)%Z | i <- iota i d] id0 (fun id => (id' id, y id)) id) ≈ + (foldi_ (I := I) (L := L) (S d) (repr (S i)) y0 c ) + ⦃ fun '(v0, h0) '(v1, h1) => True /\ pre (h0, h1) ⦄ . + Proof. + clear ; intros. + generalize dependent i. + generalize dependent c. + generalize dependent id. + induction d ; intros. + - discriminate. + - assert (forall j n, [seq (1 + Z.of_nat i)%Z | i <- iota j (S n)] = + ((1 + Z.of_nat j)%Z :: [seq (1 + Z.of_nat i)%Z | i <- iota (S j) n])) by reflexivity. + replace (d.+1 - i) with (d - i).+1. + rewrite H2. + unfold translate_for ; fold translate_for. + rewrite <- foldi__move_S. + rewrite <- bind_assoc. + apply r_bind with (mid := fun '(v0, h0) '(v1, h1) => pre (h0, h1)). + 2:{ + intros. + rewrite bind_rewrite. + epose (IHd (id' id) (ct_T a₁) (S i) _ _ _). + replace (Hacspec_Lib_Pre.int_add (repr _) _) with (@repr U32 (S (S i))). + apply better_r. + apply r. + simpl. + cbn. + unfold Hacspec_Lib_Pre.int_add, add_word. + rewrite mkwordK. + rewrite Zmod_small. + easy. + easy. + } + apply H1. + lia. + + Unshelve. + easy. + easy. + easy. + Qed. + + Locate key_list_t. + Print getm. Lemma keys_expand_eq id0 rkey (pre : precond) : - (pdisj pre id0 (fset ((seq_choice uint8; 278) :: seq.map CE_loc_to_loc ( - [])))) -> + (pdisj pre id0 (fset ([(seq_choice int128; 277) ; (@int_choice U128; 278) ; (@int_choice U128; 279) ; ('array ; 1)]))) -> ⊢ ⦃ pre ⦄ JKEYS_EXPAND id0 rkey ≈ is_state (keys_expand rkey) ⦃ fun '(v0, h0) '(v1, h1) => - (exists o1, v0 = [('array; o1)] /\ True) /\ pre (h0, h1) ⦄. + (exists o1, v0 = [('array; o1)] + /\ (forall (j : nat), + forall (a : 'word U8) (b : 'word U128), + (getm o1 (Z.of_nat j) = Some a) -> + (getm v1 (j / 16) = Some b) -> + a = index_u8 (index_u32 b (repr ((j mod 16) / 4))) (repr (j mod 4)))) /\ pre (h0, h1) ⦄. Proof. intros H_pdisj. set (JKEYS_EXPAND _ _). @@ -1586,8 +1645,9 @@ Section Hacspec. apply better_r, r_put_lhs, better_r. remove_get_in_lhs. - apply better_r, r_get_remember_lhs ; intros ; apply better_r. + apply better_r. eapply r_get_remember_lhs. intros. + unfold keys_expand. unfold let_mut_both at 1, is_state at 1, is_state at 1, is_state at 1. @@ -1630,36 +1690,65 @@ Section Hacspec. set (set_lhs _ _ _). rewrite bind_assoc. - eapply (@r_bind _ _ _ _ _ _ _ _ _ (λ '(v0, h0) '(v1, h1), p (h0, h1))) ; [ shelve | ]. - subst p. - intros. - (* rewrite bind_rewrite. *) - eapply better_r_get_remind_lhs. shelve. - destruct a₁. - simpl. - destruct s. - simpl. - - apply r_ret. - intros. - destruct_pre. - split. - eexists. - split. - reflexivity. - reflexivity. - apply H_pdisj. - admit. - apply H_pdisj. - admit. - eapply H_pdisj. - admit. - admit. - - Unshelve. - 2: apply x. + eapply (@r_bind _ _ _ _ _ _ _ _ _ (λ '(v0, h0) '(v1, h1), p (h0, h1))). + 2:{ + subst p. + intros. + (* rewrite bind_rewrite. *) + eapply r_get_remember_lhs. intros v. + destruct a₁. + simpl. + destruct s. + simpl. + apply r_ret. + intros. + destruct_pre. + split. + { + eexists. + split. + - reflexivity. + - intros. + simpl in H. + rewrite !coerce_to_choice_type_K in H. + rewrite !zero_extend_u in H. + cbn. + admit. + } + { + apply H_pdisj. + rewrite in_fset. + now rewrite mem_head. + apply H_pdisj. + rewrite in_fset. + rewrite in_cons ; simpl. + now rewrite mem_head. + eapply H_pdisj. + rewrite in_fset. + rewrite in_cons ; simpl. + rewrite in_cons ; simpl. + rewrite mem_head. + now rewrite Bool.orb_true_r. + + apply H_pdisj. + rewrite in_fset. + now rewrite mem_head. + + eapply H_pdisj. + reflexivity. + reflexivity. + eapply H_pdisj. + reflexivity. + reflexivity. + eapply H_pdisj. + reflexivity. + reflexivity. + apply H15. + } + } + simpl. intros. @@ -1675,48 +1764,198 @@ Section Hacspec. replace (Z.to_nat (11 - 1)) with 10 by reflexivity. replace (Pos.to_nat 11) with 11 by reflexivity. + epose (@loop_eq (( (seq int128) '× (@int U128) '× (@int U128))) _ p 10 0 _ _ _ _ _ (fun x => snd (y x)) y0 (fun x => fst (y x)) ). + + eapply rpost_weaken_rule. + + hnf in r. + apply r. + easy. + setoid_rewrite Nat.add_0_l. + + assert (forall j n, [seq (1 + Z.of_nat i)%Z | i <- iota j (S n)] = ((1 + Z.of_nat j)%Z :: [seq (1 + Z.of_nat i)%Z | i <- iota (S j) n])) by reflexivity. + + rewrite H. + unfold translate_for ; fold translate_for. + rewrite <- foldi__move_S. + + + + rewrite H. unfold translate_for ; fold translate_for. rewrite <- foldi__move_S. + + } + + assert (forall i, + ⊢ ⦃ p ⦄ + let (s_id', c') := y (id0~1)%positive in + translate_write_var id0 ($$$"round.337") + (totce (translate_value (values.Vint i))) ;; + c' = + cur' ← y0 (repr i) + (Hacspec_Lib_Pre.seq_push + (Hacspec_Lib_Pre.seq_new_ (repr 0) (unsigned (repr 0))) + rkey, rkey, repr 0) ;; + Si ← (repr i) + ⦃ λ '(_, h0) '(_, h1), ⦄ + ). + unfold y at 1. unfold y0 at 1. - rewrite <- bind_assoc. - eapply r_bind. - apply better_r_put_lhs. - remove_get_in_lhs. + assert (forall A B (x : raw_code A) (y : raw_code B) l, (x ;; y) = ((x ;; v ← get l ;; ret v) ;; y)). + admit. + + rewrite <- bind_assoc. + erewrite (H0 _ _ _ _ ($$"rkeys.335")). + clear H0. - rewrite bind_assoc. - eapply r_bind with (mid := λ '(v0, h0) '(v1, h1), - (∃ o1 : (λ i : choice_type_choiceType, i) 'int, - v0 = [('int; o1)] ∧ repr o1 = v1) ∧ - _ (h0, h1)). + + eapply r_bind with (mid := λ '(v0, h0) '(v1, h1), p (h0, h1)). { + rewrite bind_assoc. + apply better_r_put_lhs. + remove_get_in_lhs. fold @bind. + + rewrite bind_assoc. + rewrite bind_assoc. set (set_lhs _ _ _). - epose (rcon_eq (id0~1~1)%positive 1 p0). - unfold JRCON in r. - replace (call 12%positive (id0~1~1)%positive [totce (coe_cht 'int _)]) - with - (get_translated_static_fun ssprove_jasmin_prog 12%positive - static_funs (id0~1~1)%positive [('int; Z.of_nat 1)]). - apply r. - admit. - easy. - Transparent translate_call. - unfold translate_call, translate_call_body in r. + eapply r_bind with (mid := λ '(v0, h0) '(v1, h1), + (∃ o1 : (λ i : choice_type_choiceType, i) 'int, + v0 = [('int; o1)] ∧ repr o1 = v1) ∧ + p0 (h0, h1)) ; subst p0. + { + replace (translate_call ssprove_jasmin_prog 12%positive static_funs (id0~1~1)%positive [totce (coe_cht 'int _)]) + with + (get_translated_static_fun ssprove_jasmin_prog 12%positive + static_funs (id0~1~1)%positive [('int; Z.of_nat 1)]). + 2:{ + Transparent translate_call. + simpl. + cbn. + repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). + reflexivity. + Opaque translate_call. + } + simpl. + apply (rcon_eq (id0~1~1)%positive 1). + admit. + easy. + } + + intros. + apply rpre_hypothesis_rule. + intros. + destruct H0. + destruct H0. + destruct H0. + eapply rpre_weaken_rule. + 2:{ + intros ? ? []. subst. + apply H1. + } + clear H1. + rewrite H0. + rewrite <- H2. + clear H0 H2. + apply better_r_put_lhs. + remove_get_in_lhs. + subst p. + remove_get_in_lhs. + remove_get_in_lhs. fold @bind. + + rewrite bind_assoc. + rewrite bind_assoc. + set (set_lhs _ _ _). + set (set_lhs _ _ _). + eapply r_bind with (mid := λ '(v0, h0) '(v1, h1), + (∃ o1 o2 : 'word U128, + v0 = [('word U128; o1); ('word U128; o2)] ∧ (o1, o2) = v1) + ∧ p0 (h0, h1)). + { + + pose key_expand_eq. + replace (translate_call _ _ _ _ _) + with + (get_translated_static_fun ssprove_jasmin_prog 11%positive + static_funs (id0~1~0~1)%positive [('int; x0); ('word U128; rkey); ('word U128; repr 0)]). + 2:{ + Transparent translate_call. + simpl. + cbn. + repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). + reflexivity. + Opaque translate_call. + } + unfold JKEY_EXPAND in r. + specialize (r (id0~1~0~1)%positive x0 rkey (repr 0) p0). + unfold repr at 1. + apply r. + + admit. + } + + + intros. + apply rpre_hypothesis_rule. + intros. + destruct H0. + destruct H0. + destruct H0. + eapply rpre_weaken_rule. + 2:{ + intros ? ? []. subst. + apply H1. + } + clear H1. + destruct H0. + destruct a₁0. + rewrite ct_T_prod_propegate. simpl. - cbn. - repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). - reflexivity. + inversion H1. + subst. + clear H1. + apply better_r_put_lhs ; fold @bind. + apply better_r_put_lhs ; fold @bind. + simpl in p. + subst p0. + subst p. + rewrite !coerce_to_choice_type_K. + rewrite !zero_extend_u. + remove_get_in_lhs. + apply better_r. eapply r_get_remember_lhs. intros. + remove_get_in_lhs. + + rewrite !coerce_to_choice_type_K. + rewrite !zero_extend_u. + apply better_r_put_lhs. + + + apply better_r_put_rhs. + apply better_r_put_rhs. + apply better_r_put_rhs. + + apply better_r. eapply r_get_remember_lhs. intros. + + apply r_ret. + intros. + admit. } + + intros. + + + (* TODO Reamining rounds *) Admitted. Lemma addroundkey_eq id0 (rkeys : 'array) (rkeys' : seq uint8) m (pre : precond) : - (pdisj pre id0 (fset [CE_loc_to_loc res_238_loc ; (CE_loc_to_loc ( nseq int8 1 ; 0%nat ) : Location) ])) -> + (pdisj pre id0 (fset [ (CE_loc_to_loc ( nseq int8 1 ; 0%nat ) : Location) ])) -> seq.unzip2 (FMap.fmval rkeys) = seq.unzip2 (FMap.fmval rkeys') -> ⊢ ⦃ pre ⦄ JAES_ROUNDS id0 rkeys m From cd6bda2760581a06e4dede74a84ca00bd6a73c83 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Wed, 25 Jan 2023 02:58:39 +0100 Subject: [PATCH 351/383] WIP for_loop --- theories/Jasmin/examples/aes/aes_hac.v | 513 ++++++++++++++----------- 1 file changed, 297 insertions(+), 216 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes_hac.v b/theories/Jasmin/examples/aes/aes_hac.v index 4a36b908..f06f56f3 100644 --- a/theories/Jasmin/examples/aes/aes_hac.v +++ b/theories/Jasmin/examples/aes/aes_hac.v @@ -100,7 +100,7 @@ Section Hacspec. Ltac remove_get_in_lhs := eapply better_r_get_remind_lhs ; unfold Remembers_lhs , rem_lhs ; - [ intros ? ? k ; + [ intros ? ? ? ; destruct_pre ; repeat (rewrite get_set_heap_neq ; [ | apply injective_translate_var3 ; reflexivity ]) ; rewrite get_set_heap_eq ; @@ -552,7 +552,7 @@ Section Hacspec. repeat solve_lower_bounds. Qed. - + Lemma index_8_eq : forall (v : 'word U32) (i : nat), i < 4 -> @@ -598,7 +598,7 @@ Section Hacspec. intros. unfold vpshufd1. unfold wpshufd1. - + Opaque index_u32. unfold is_pure at 1, lift_scope ; simpl. rewrite (index_32_eq _ 0). @@ -648,7 +648,7 @@ Section Hacspec. apply small_modulus_smaller. cbn ; now repeat solve_lower_bounds. easy. - + apply (@num_smaller_if_modulus_le U32). easy. Qed. @@ -734,7 +734,7 @@ Section Hacspec. solve_wpshufd1_vpshufd1 3. rewrite rebuild_128_eq. - + intros. apply r_ret. intros ? ? [? [? [? []]]]. @@ -1487,46 +1487,13 @@ Section Hacspec. Transparent translate_call. Qed. - (* Lemma foldr_foldi : forall A (default : T A) L I (f : Z -> _ -> raw_code A) x g y pre, *) - (* forall (n : nat), *) - (* (f 1%Z (f 0%Z x)) = (y ← f 0%Z x ;; f 1%Z (ret y)) -> *) - (* (forall n x y, *) - (* ⊢ ⦃ pre ⦄ *) - (* f n x ≈ is_state (g (usize n) y) *) - (* ⦃ fun '(v0, h0) '(v1, h1) => *) - (* True /\ pre (h0, h1) ⦄) -> *) - (* ⊢ ⦃ pre ⦄ *) - (* (foldr f x (rev [seq Z.of_nat i | i <- iota 0 (S n)])) ≈ *) - (* (foldi_both' (acc := seq A) (L := L) (I := I) (lift_to_both0 (repr 0)) (lift_to_both0 (repr (Z.of_nat (S n)))) *) - (* y g) *) - (* ⦃ fun '(v0, h0) '(v1, h1) => *) - (* True /\ pre (h0, h1) ⦄. *) - (* Proof. *) - (* intros. *) - (* induction n. *) - (* - cbn. *) - (* simpl. *) - (* rewrite <- (bind_ret _ (f _ _)). *) - (* eapply r_bind. *) - (* apply H0. *) - (* intros. *) - (* apply r_ret. *) - (* easy. *) - (* - rewrite <- foldl_rev. *) - (* rewrite revK. *) - (* cbn. *) - (* rewrite <- revK. *) - (* rewrite foldl_rev. *) - (* admit. *) - (* Admitted. *) - Lemma rcon_eq id0 (j : nat) (pre : precond) : (pdisj pre id0 fset0) -> - (0 < j < 11)%Z -> + (0 <= j < 10)%nat -> ⊢ ⦃ pre ⦄ - JRCON id0 (Z.of_nat j) + JRCON id0 (Z.pos (Pos.of_succ_nat j)) ≈ - is_state (array_index (rcon_v) (@repr U8 j)) + is_state (array_index (rcon_v) (@repr U32 (S j))) ⦃ fun '(v0, h0) '(v1, h1) => (exists o1, v0 = [('int; o1)] /\ repr o1 = v1) /\ pre (h0, h1) ⦄. Proof. @@ -1548,78 +1515,212 @@ Section Hacspec. unfold array_index_clause_2. unfold array_index_clause_2_clause_1. simpl. - destruct j as [ | j ]. - { - easy. - } + (* SLOW! *) (* admit. *) do 10 (destruct j as [ | j ] ; [ simpl ; repeat (remove_get_in_lhs ; simpl) ; apply better_r_put_lhs ; remove_get_in_lhs ; apply r_ret ; intros ; destruct_pre ; split ; [ eexists ; split ; [ | reflexivity] ; f_equal ; unfold totce ; repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K) ; reflexivity | eapply H ; [ reflexivity | reflexivity | ] ; eapply H ; [ reflexivity | reflexivity | ] ; apply H5 ] | ]). + exfalso. - destruct H0. - simpl in H1. - rewrite !Pos2Z.inj_succ in H1. - eapply Z.lt_asymm. - apply H1. lia. Qed. + (* Admitted. *) + + + (* Theorem loop_eq : *) + (* forall (acc : ChoiceEquality) id0 pre d i c v I L y *) + (* (y0 : int -> acc -> code L I acc) id' (inv : postcond _ _), *) + (* (i < d)%nat -> *) + (* (i + d < modulus U32)%Z -> *) + (* (forall c j, (i <= j < d)%nat -> ⊢ ⦃ pre ⦄ *) + (* translate_write_var id0 v *) + (* (@existT choice_type (fun t : choice_type => Choice.sort (chElement t)) chInt (Z.of_nat (j.+1))) ;; *) + (* y id0 ≈ y0 (repr j.+1) c ⦃ λ '(s0, h0) '(s1, h1), (inv (s0, h0) (s1, h1)) /\ pre (h0, h1) ⦄) -> *) + (* inv (emptym, empty_heap) (_, empty_heap) -> *) + (* ⊢ ⦃ pre ⦄ *) + (* (translate_for v *) + (* [seq (1 + Z.of_nat i)%Z | i <- iota i d] id0 (fun id => (id' id, y id)) id0~1) ≈ *) + (* (foldi_ (I := I) (L := L) (S d) (repr (S i)) y0 c ) *) + (* ⦃ fun '(v0, h0) '(v1, h1) => pre (h0, h1) ⦄ . *) + (* Proof. *) + (* clear ; intros. *) + (* generalize dependent i. *) + (* generalize dependent c. *) + (* generalize dependent id0. *) + (* induction d ; intros. *) + (* - discriminate. *) + (* - assert (forall j n, [seq (1 + Z.of_nat i)%Z | i <- iota j (S n)] = *) + (* ((1 + Z.of_nat j)%Z :: [seq (1 + Z.of_nat i)%Z | i <- iota (S j) n])) by reflexivity. *) + (* replace (d.+1 - i) with (d - i).+1 by lia. *) + (* rewrite H3. *) + (* unfold translate_for ; fold translate_for. *) + (* rewrite <- foldi__move_S. *) + (* rewrite <- bind_assoc. *) + (* apply r_bind with (mid := fun '(v0, h0) '(v1, h1) => inv (v0, h0) (v1, h1) /\ pre (h0, h1)). *) + (* 2:{ *) + (* intros. *) + (* rewrite bind_rewrite. *) + (* replace (Hacspec_Lib_Pre.int_add (repr _) _) with (@repr U32 (S (S i))). *) + (* 2:{ *) + (* simpl. *) + (* cbn. *) + (* unfold Hacspec_Lib_Pre.int_add, add_word. *) + (* rewrite mkwordK. *) + (* rewrite Zmod_small. *) + (* cbn. *) + (* apply word_ext. *) + (* f_equal. *) + (* rewrite Pos.add_1_r. *) + (* reflexivity. *) + (* split. solve_lower_bounds. *) + (* eapply Z.le_lt_trans. *) + (* 2: apply H1. *) + (* zify. *) + (* rewrite <- addn1. *) + (* setoid_rewrite Nat2Z.inj_add. *) + (* rewrite Z.add_assoc. *) + (* apply Zplus_le_compat_r. *) + (* apply le_add_right. *) + (* easy. *) + (* easy. *) + (* } *) + (* apply better_r. *) + (* eapply rpre_hypothesis_rule. *) + (* intros ? ? []. *) + (* eapply rpre_weaken_rule ; [ | ]. *) + (* - specialize (IHd id0). *) + (* specialize (IHd (ct_T a₁)). *) + (* admit. *) + (* (* apply IHd. *) + (* + apply H4. *) + (* + admit. *) + (* + setoid_rewrite <- Nat2Z.inj_add. *) + (* setoid_rewrite addSnnS. *) + (* rewrite Nat2Z.inj_add. *) + (* apply H1. *) + (* + intros. eapply H2. *) + (* apply H6. *) + (* lia. *) + (* - now (intros ? ? [] ; subst). *) + (* } *) + (* replace (totce (translate_value (values.Vint (1 + Z.of_nat i)))) *) + (* with (@existT choice_type (fun t : choice_type => Choice.sort (chElement t)) chInt (Z.of_nat (i.+1))). *) + (* 2:{ *) + (* cbn. *) + (* repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). *) + (* rewrite Zpos_P_of_succ_nat. *) + (* unfold Z.succ. *) + (* rewrite Z.add_comm. *) + (* reflexivity. *) + (* } *) + (* specialize (H2 c (i)). *) *) + (* (* apply H2. *) + (* apply H. *) + (* lia. *) + (* *) Admitted. *) + + Definition unfold_translate_for : forall v j d id0 id' y, + (translate_for v [seq (1 + Z.of_nat i)%Z | i <- iota j (S d)] id0 y id') = + (translate_write_var id0 v (@existT choice_type (fun t : choice_type => Choice.sort (chElement t)) chInt (Z.of_nat (j.+1))) ;; + (snd (y id')) ;; + translate_for v [seq (1 + Z.of_nat i)%Z | i <- iota (S j) d] id0 y (fst (y id'))). + Proof. + intros. + assert (forall j n, [seq (1 + Z.of_nat i)%Z | i <- iota j (S n)] = + ((1 + Z.of_nat j)%Z :: [seq (1 + Z.of_nat i)%Z | i <- iota (S j) n])) by reflexivity. + rewrite H. + unfold translate_for ; fold translate_for. + destruct (y id'). + replace (totce (translate_value (values.Vint (1 + Z.of_nat j)))) + with (@existT choice_type (fun t : choice_type => Choice.sort (chElement t)) chInt (Z.of_nat (j.+1))). + 2:{ + cbn. + repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). + rewrite Zpos_P_of_succ_nat. + unfold Z.succ. + rewrite Z.add_comm. + reflexivity. + } + reflexivity. + Qed. Theorem loop_eq : - forall (acc : ChoiceEquality) id0 pre d i c id v I L y - (y0 : int -> acc -> code L I acc) id', - (i < d) -> - (i + d < modulus U32) -> - ⊢ ⦃ pre ⦄ - translate_write_var id0 v - (totce (translate_value (values.Vint (1 + Z.of_nat i)))) ;; - y id ≈ y0 (repr i.+1) c ⦃ λ '(_, h0) '(_, h1), pre (h0, h1) ⦄ -> + forall {acc : ChoiceEquality} v d (j : nat) id0 s_id id' y I L (y0 : @int U32 -> acc -> code L I acc) pre c, + (0 < d) -> + (forall k c s_id, + j <= k < j + d -> + ⊢ ⦃ set_lhs + (translate_var id0 (v_var v)) + (@truncate_el chInt (vtype (v_var v)) (S k)) + pre ⦄ + y s_id + ≈ y0 (repr (Pos.of_succ_nat k)) c + ⦃ λ '(_, h0) '(_, h1), pre (h0, h1) ⦄) -> ⊢ ⦃ pre ⦄ (translate_for v - [seq (1 + Z.of_nat i)%Z | i <- iota i d] id0 (fun id => (id' id, y id)) id) ≈ - (foldi_ (I := I) (L := L) (S d) (repr (S i)) y0 c ) - ⦃ fun '(v0, h0) '(v1, h1) => True /\ pre (h0, h1) ⦄ . + [seq (1 + Z.of_nat i)%Z | i <- iota j d] id0 (fun id => (id' id, y id)) s_id) ≈ + (foldi_ (I := I) (L := L) (d) (repr (S j)) y0 c ) + ⦃ fun '(v0, h0) '(v1, h1) => pre (h0, h1) ⦄ . Proof. - clear ; intros. - generalize dependent i. + intros. + generalize dependent j. generalize dependent c. - generalize dependent id. + generalize dependent s_id. induction d ; intros. - - discriminate. - - assert (forall j n, [seq (1 + Z.of_nat i)%Z | i <- iota j (S n)] = - ((1 + Z.of_nat j)%Z :: [seq (1 + Z.of_nat i)%Z | i <- iota (S j) n])) by reflexivity. - replace (d.+1 - i) with (d - i).+1. - rewrite H2. - unfold translate_for ; fold translate_for. - rewrite <- foldi__move_S. - rewrite <- bind_assoc. - apply r_bind with (mid := fun '(v0, h0) '(v1, h1) => pre (h0, h1)). + discriminate. + + destruct d. + - rewrite unfold_translate_for. + simpl. + apply better_r_put_lhs. + setoid_rewrite T_ct_id. + eapply r_bind. + apply H0. + lia. + + intros. + apply r_ret. + intros. apply H1. + - rewrite <- foldi__move_S. + rewrite unfold_translate_for. + + apply better_r_put_lhs. + setoid_rewrite bind_rewrite. + apply r_bind with (mid := λ '(_, h0) '(_, h1), pre (h0, h1)). + 2:{ intros. - rewrite bind_rewrite. - epose (IHd (id' id) (ct_T a₁) (S i) _ _ _). - replace (Hacspec_Lib_Pre.int_add (repr _) _) with (@repr U32 (S (S i))). + replace (Hacspec_Lib_Pre.int_add (repr j.+1) one) + with + (@repr U32 j.+2). + 2:{ + simpl. + cbn. + unfold Hacspec_Lib_Pre.int_add, add_word. + rewrite mkwordK. + cbn. + apply word_ext. + rewrite Zplus_mod. + rewrite Zmod_mod. + rewrite <- Zplus_mod. + f_equal. + now zify. + } + apply better_r. + unfold ".1". + pose (IHd ltac:(easy) (id' s_id) (ct_T a₁) j.+1). apply r. - simpl. - cbn. - unfold Hacspec_Lib_Pre.int_add, add_word. - rewrite mkwordK. - rewrite Zmod_small. - easy. - easy. - } - apply H1. - lia. - Unshelve. - easy. - easy. - easy. + intros. + apply H0. + lia. + } + unfold ".2". + apply H0. + lia. Qed. - - Locate key_list_t. - Print getm. + Lemma keys_expand_eq id0 rkey (pre : precond) : - (pdisj pre id0 (fset ([(seq_choice int128; 277) ; (@int_choice U128; 278) ; (@int_choice U128; 279) ; ('array ; 1)]))) -> + (pdisj pre id0 (fset ([(seq_choice int128; 279) ; (@int_choice U128; 278) ; (@int_choice U128; 277)]))) -> ⊢ ⦃ pre ⦄ JKEYS_EXPAND id0 rkey ≈ @@ -1647,7 +1748,7 @@ Section Hacspec. remove_get_in_lhs. apply better_r. eapply r_get_remember_lhs. intros. - + unfold keys_expand. unfold let_mut_both at 1, is_state at 1, is_state at 1, is_state at 1. @@ -1677,6 +1778,15 @@ Section Hacspec. apply better_r_put_rhs. apply better_r_put_lhs. + set (tr_app_sopn_tuple _ _ _). + cbn in s. + set (repr 0) at 8. + assert (s = t) by now apply word_ext. + generalize dependent s. + generalize dependent t. + intros. + subst. + apply better_r_put_lhs. @@ -1748,8 +1858,8 @@ Section Hacspec. apply H15. } } - - simpl. + + (* simpl. *) intros. @@ -1760,144 +1870,119 @@ Section Hacspec. rewrite bind_rewrite. rewrite bind_rewrite. - unfold foldi_pre ; replace (unsigned (repr 12) - unsigned (repr 1))%Z with 11%Z by reflexivity. + unfold foldi_both', foldi_both, lift_scope, is_state at 1, lift_code_scope, prog, is_state at 1, foldi. + unfold foldi_pre ; replace (unsigned _ - unsigned _)%Z with 10%Z by reflexivity. replace (Z.to_nat (11 - 1)) with 10 by reflexivity. - replace (Pos.to_nat 11) with 11 by reflexivity. + replace (Pos.to_nat 10) with 10 by reflexivity. - epose (@loop_eq (( (seq int128) '× (@int U128) '× (@int U128))) _ p 10 0 _ _ _ _ _ (fun x => snd (y x)) y0 (fun x => fst (y x)) ). - - eapply rpost_weaken_rule. - - hnf in r. - apply r. - easy. - setoid_rewrite Nat.add_0_l. - - assert (forall j n, [seq (1 + Z.of_nat i)%Z | i <- iota j (S n)] = - ((1 + Z.of_nat j)%Z :: [seq (1 + Z.of_nat i)%Z | i <- iota (S j) n])) by reflexivity. - - rewrite H. - unfold translate_for ; fold translate_for. - rewrite <- foldi__move_S. - - - - - - rewrite H. - unfold translate_for ; fold translate_for. - rewrite <- foldi__move_S. - - } - - assert (forall i, - ⊢ ⦃ p ⦄ - let (s_id', c') := y (id0~1)%positive in - translate_write_var id0 ($$$"round.337") - (totce (translate_value (values.Vint i))) ;; - c' = - cur' ← y0 (repr i) - (Hacspec_Lib_Pre.seq_push - (Hacspec_Lib_Pre.seq_new_ (repr 0) (unsigned (repr 0))) - rkey, rkey, repr 0) ;; - Si ← (repr i) - ⦃ λ '(_, h0) '(_, h1), ⦄ - ). - - unfold y at 1. - unfold y0 at 1. + apply (@loop_eq (seq int128 '× int '× int) _ 10 0). + { easy. } + { + intros. - assert (forall A B (x : raw_code A) (y : raw_code B) l, (x ;; y) = ((x ;; v ← get l ;; ret v) ;; y)). - admit. + subst y. + subst y0. + subst p. - rewrite <- bind_assoc. - erewrite (H0 _ _ _ _ ($$"rkeys.335")). - clear H0. + remove_get_in_lhs. + rewrite bind_assoc. + destruct c as [? []]. + destruct t0 as []. + assert (t = t1). admit. subst. + assert (rkey = (mkWord (nbits:=U128) (toword:=toword) i)). admit. subst. - - eapply r_bind with (mid := λ '(v0, h0) '(v1, h1), p (h0, h1)). + set (set_lhs _ _ _). + eapply r_bind with (mid := λ '(v0, h0) '(v1, h1), + (∃ o1 : (λ i : choice_type_choiceType, i) 'int, + v0 = [('int; o1)] ∧ repr o1 = v1) ∧ + p (h0, h1)) ; subst p. { - rewrite bind_assoc. - apply better_r_put_lhs. - remove_get_in_lhs. fold @bind. - - rewrite bind_assoc. - rewrite bind_assoc. - set (set_lhs _ _ _). - eapply r_bind with (mid := λ '(v0, h0) '(v1, h1), - (∃ o1 : (λ i : choice_type_choiceType, i) 'int, - v0 = [('int; o1)] ∧ repr o1 = v1) ∧ - p0 (h0, h1)) ; subst p0. - { - replace (translate_call ssprove_jasmin_prog 12%positive static_funs (id0~1~1)%positive [totce (coe_cht 'int _)]) - with - (get_translated_static_fun ssprove_jasmin_prog 12%positive - static_funs (id0~1~1)%positive [('int; Z.of_nat 1)]). - 2:{ - Transparent translate_call. - simpl. - cbn. - repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). - reflexivity. - Opaque translate_call. - } + (* replace (totce _) *) + (* with (@existT choice_type (fun t : choice_type => Choice.sort (chElement t)) chInt (Z.of_nat (Pos.of_succ_nat j))). *) + set [ _ ]. + + replace (translate_call ssprove_jasmin_prog 12%positive + static_funs (s_id~1)%positive l) + with + (get_translated_static_fun ssprove_jasmin_prog 12%positive + static_funs (s_id~1)%positive l). + 2:{ + Transparent translate_call. simpl. - apply (rcon_eq (id0~1~1)%positive 1). - admit. - easy. + cbn. + repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). + reflexivity. + Opaque translate_call. } - - intros. - apply rpre_hypothesis_rule. - intros. - destruct H0. - destruct H0. - destruct H0. - eapply rpre_weaken_rule. + subst l. + replace (totce _) + with (@existT choice_type (fun t : choice_type => Choice.sort (chElement t)) chInt (Pos.of_succ_nat k)). 2:{ - intros ? ? []. subst. - apply H1. + cbn. + repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). + unfold totce. + rewrite Zpos_P_of_succ_nat. + reflexivity. } - clear H1. - rewrite H0. - rewrite <- H2. - clear H0 H2. - apply better_r_put_lhs. - remove_get_in_lhs. - subst p. - remove_get_in_lhs. - remove_get_in_lhs. fold @bind. + apply (rcon_eq (s_id~1)%positive k). + admit. + setoid_rewrite Nat.add_0_l in H. + apply H. + } + + intros. + apply rpre_hypothesis_rule. + intros. + destruct H0. + destruct H0. + destruct H0. + eapply rpre_weaken_rule. + 2:{ + intros ? ? []. subst. + apply H1. + } + clear H1. + rewrite H0. + rewrite <- H2. + clear H0 H2. + apply better_r_put_lhs. + remove_get_in_lhs. + remove_get_in_lhs. + remove_get_in_lhs. fold @bind. rewrite bind_assoc. - rewrite bind_assoc. - set (set_lhs _ _ _). set (set_lhs _ _ _). eapply r_bind with (mid := λ '(v0, h0) '(v1, h1), (∃ o1 o2 : 'word U128, v0 = [('word U128; o1); ('word U128; o2)] ∧ (o1, o2) = v1) - ∧ p0 (h0, h1)). + ∧ p (h0, h1)). { - + pose key_expand_eq. + unfold JKEY_EXPAND in r. + specialize (r (s_id~0~1)%positive x0 t1 (mkWord (nbits:=U128) (toword:=toword) i) p). + replace (translate_call _ _ _ _ _) with (get_translated_static_fun ssprove_jasmin_prog 11%positive - static_funs (id0~1~0~1)%positive [('int; x0); ('word U128; rkey); ('word U128; repr 0)]). + static_funs (s_id~0~1)%positive [('int; x0); ('word U128; (mkWord (nbits:=U128) (toword:=toword) i)); ('word U128; t1) ]). 2:{ Transparent translate_call. simpl. cbn. repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). + rewrite !zero_extend_u. reflexivity. Opaque translate_call. } - unfold JKEY_EXPAND in r. - specialize (r (id0~1~0~1)%positive x0 rkey (repr 0) p0). - unfold repr at 1. - apply r. - + unfold lift_to_both0. + Set Printing Coercions. + unfold is_pure. + unfold lift_to_both. + unfold repr. + (* apply r. *) (* TODO?? *) admit. } @@ -1924,7 +2009,6 @@ Section Hacspec. apply better_r_put_lhs ; fold @bind. apply better_r_put_lhs ; fold @bind. simpl in p. - subst p0. subst p. rewrite !coerce_to_choice_type_K. rewrite !zero_extend_u. @@ -1936,27 +2020,24 @@ Section Hacspec. rewrite !zero_extend_u. apply better_r_put_lhs. - + apply better_r_put_rhs. apply better_r_put_rhs. apply better_r_put_rhs. - apply better_r. eapply r_get_remember_lhs. intros. - apply r_ret. intros. admit. } - - intros. - - - (* TODO Reamining rounds *) Admitted. - Lemma addroundkey_eq id0 (rkeys : 'array) (rkeys' : seq uint8) m (pre : precond) : + Lemma addroundkey_eq id0 (rkeys : 'array) (rkeys' : seq int128) m (pre : precond) : (pdisj pre id0 (fset [ (CE_loc_to_loc ( nseq int8 1 ; 0%nat ) : Location) ])) -> - seq.unzip2 (FMap.fmval rkeys) = seq.unzip2 (FMap.fmval rkeys') -> + ((forall (j : nat), + forall (a : 'word U8) (b : 'word U128), + (getm rkeys (Z.of_nat j) = Some a) -> + (getm rkeys' (j / 16) = Some b) -> + a = index_u8 (index_u32 b (repr ((j mod 16) / 4))) (repr (j mod 4)))) -> ⊢ ⦃ pre ⦄ JAES_ROUNDS id0 rkeys m ≈ @@ -2009,7 +2090,7 @@ Section Hacspec. Admitted. Lemma aes_eq id0 key m (pre : precond) : - (pdisj pre id0 (fset [CE_loc_to_loc res_238_loc ; (CE_loc_to_loc ( nseq int8 1 ; 0%nat ) : Location) ])) -> + (pdisj pre id0 (fset [(CE_loc_to_loc ( nseq int8 1 ; 0%nat ) : Location) ])) -> ⊢ ⦃ pre ⦄ JAES id0 key m ≈ From 75202a5b0112b0ea5c681bfc9483b17efcbbcb92 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Wed, 25 Jan 2023 14:18:47 +0100 Subject: [PATCH 352/383] A bit of cleanup --- theories/Jasmin/examples/aes/aes_hac.v | 933 ++++++++++++------------- 1 file changed, 455 insertions(+), 478 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes_hac.v b/theories/Jasmin/examples/aes/aes_hac.v index f06f56f3..3189c9c7 100644 --- a/theories/Jasmin/examples/aes/aes_hac.v +++ b/theories/Jasmin/examples/aes/aes_hac.v @@ -40,6 +40,8 @@ Ltac Zify.zify_post_hook ::= Z.div_mod_to_equations. Section Hacspec. +(*** Helper definitions *) + (* NB: this redefines neq_loc_auto, which helps some tactics, since checking for inequality by computation is not feasible for translated variables *) Ltac neq_loc_auto ::= solve [ eapply injective_translate_var3; auto | eapply injective_translate_var2; auto ]. @@ -343,13 +345,6 @@ Section Hacspec. apply Z_shiftl_mod_modulus_add. Qed. - (* Lemma Z_shiftr_mod_modulus : forall n m p, (m <= p) -> (Z.shiftr n (Z.of_nat m) mod modulus p = (n mod modulus (p - m)) / modulus m)%Z. *) - (* Proof. *) - (* intros. *) - (* replace p with (p - m + m) at 1 by now rewrite <- (subn_diag p m H). *) - (* replace (m) with (0 + m) at 1 by reflexivity. *) - (* Admitted. *) - Ltac solve_lower_bounds := (simple apply Z.mul_nonneg_nonneg || simple apply Zle_0_pos || simple apply Z_mod_nonneg_nonneg || simple apply Nat2Z.is_nonneg || simple apply modulus_ge0_Z || simple apply (fun x y => proj2 (Z.shiftr_nonneg x y)) || simple apply (fun x y => proj2 (Z.shiftl_nonneg x y)) || simple apply word_geZ0 || (apply Z.lor_nonneg ; solve_upper_bound)) with @@ -406,6 +401,283 @@ Section Hacspec. - easy. Qed. + Definition pdisj (P : precond) (s_id : p_id) (rhs : {fset Location}) := + (forall h1 h2 l a v s_id', l = translate_var s_id' v -> (s_id ⪯ s_id') -> (P (h1, h2) -> P (set_heap h1 l a, h2))) /\ + (forall h1 h2 l a, l \in rhs -> (P (h1, h2) -> P (h1, set_heap h2 l a))). + + Ltac solve_in := + repeat match goal with + | |- is_true (?v \in fset1 ?v :|: _) => apply/fsetU1P; left; auto + | |- is_true (_ \in fsetU _ _) => apply/fsetU1P; right + end. + + Ltac pdisj_apply h := + lazymatch goal with + | |- ?pre (set_heap _ _ _, set_heap _ _ _) => eapply h; [ solve_in | pdisj_apply h ] + | |- ?pre (set_heap _ _ _, _) => + eapply h ; [ reflexivity | auto with preceq | pdisj_apply h ] + | |- _ => try assumption + end. + + + Ltac bind_jazz_bind := + match goal with + | [ |- context [ ⊢ ⦃ ?P ⦄ putr ?l ?y ?g ≈ bind ?a ?f ⦃ ?Q ⦄ ] ] => + let yv := fresh in + let gv := fresh in + let av := fresh in + let fv := fresh in + set l + ; set (yv := y) + ; set (gv := g) + ; set (av := a) + ; set (fv := f) + ; apply (r_bind (ret yv) (av) (fun x => putr l x gv) fv P (fun '(v0, h0) '(v1, h1) => v0 = v1 /\ P (h0, h1)) Q) ; [ | intros ] + ; subst yv gv av fv ; hnf + end. + + Theorem rpre_hypothesis_rule' : + ∀ {A₀ A₁ : _} {p₀ : raw_code A₀} {p₁ : raw_code A₁} + (pre : precond) post, + (∀ s₀ s₁, + pre (s₀, s₁) → ⊢ ⦃ λ '(s₀', s₁'), s₀' = s₀ ∧ s₁' = s₁ ⦄ p₀ ≈ p₁ ⦃ post ⦄ + ) → + ⊢ ⦃ pre ⦄ p₀ ≈ p₁ ⦃ post ⦄. + Proof. + intros A₀ A₁ p₀ p₁ pre post h. + eapply rpre_hypothesis_rule. + intros s0 s1 H. eapply rpre_weaken_rule. + eapply h. + eassumption. + easy. + Qed. + + Theorem rpre_weak_hypothesis_rule' : + ∀ {A₀ A₁ : _} {p₀ : raw_code A₀} {p₁ : raw_code A₁} + (pre : precond) post, + (∀ s₀ s₁, + pre (s₀, s₁) → ⊢ ⦃ λ '(s0, s1), pre (s0, s1) ⦄ p₀ ≈ p₁ ⦃ post ⦄ + ) → + ⊢ ⦃ pre ⦄ p₀ ≈ p₁ ⦃ post ⦄. + Proof. + intros A₀ A₁ p₀ p₁ pre post h. + eapply rpre_hypothesis_rule'. + intros. eapply rpre_weaken_rule. + eapply h. eassumption. + intros s0' s1' [H0 H1]. + subst. + assumption. + Qed. + + Corollary better_r_put_rhs : forall {A B : choice.Choice.type} (ℓ : Location) + (v : choice.Choice.sort (Value (projT1 ℓ))) (r₀ : raw_code A) + (r₁ : raw_code B) (pre : precond) + (post : postcond (choice.Choice.sort A) (choice.Choice.sort B)), + ⊢ ⦃ set_rhs ℓ v pre ⦄ r₀ ≈ r₁ ⦃ post ⦄ -> + ⊢ ⦃ pre ⦄ r₀ ≈ #put ℓ := v ;; r₁ ⦃ post ⦄. + Proof. + intros. + eapply rpre_hypothesis_rule. + intros. + eapply rpre_weaken_rule. + apply r_put_rhs. + apply H. + intuition. + Unshelve. + subst. + intuition. + Qed. + + Theorem modulus_exact : forall {WS : wsize.wsize} (x : 'word WS), (0 <= x < modulus WS)%Z. + Proof. + intros. + destruct x. + cbn. + apply (ssrbool.elimT (iswordZP _ _)) in i. + apply i. + Qed. + + Theorem modulus_smaller : forall (WS : wsize.wsize) (m : nat) {x : 'word WS}, (WS <= m)%Z -> (0 <= x < modulus m)%Z. + Proof. + intros. + destruct x. + cbn. + apply (ssrbool.elimT (iswordZP _ _)) in i. + split. + - easy. + - eapply Z.lt_le_trans. + apply i. + rewrite modulusZE. + rewrite modulusZE. + apply (Z.pow_le_mono_r 2). + reflexivity. + apply H. + Qed. + + Ltac match_pattern_and_bind_repr p := + unfold let_both at 1, is_state at 1, prog ; + match goal with + | [ |- context [ ⊢ ⦃ ?P ⦄ ?x ≈ _ ⦃ ?Q ⦄ ] ] => + let Hx := fresh in + set (Hx := x) ; + pattern p in Hx ; + subst Hx ; + + (* Match bind and apply *) + match goal with + | [ |- context [ ⊢ ⦃ ?P ⦄ _ ≈ bind ?a ?f ⦃ ?Q ⦄ ] ] => + let av := fresh in + let fv := fresh in + set (av := a) + ; set (fv := f) + ; eapply (r_bind (ret p) av _ fv P (fun '(v0, h0) '(v1, h1) => v0 = repr v1 /\ P (h0, h1)) Q) + ; subst av fv ; hnf ; [ | intros ; apply rpre_hypothesis_rule' ; intros ? ? [] ; apply rpre_weaken_rule with (pre := fun '(s₀, s₁) => P (s₀, s₁)) + ] + end + end. + + Ltac match_pattern_and_bind p := + unfold let_both at 1, is_state at 1, prog ; + match goal with + | [ |- context [ ⊢ ⦃ ?P ⦄ ?x ≈ _ ⦃ ?Q ⦄ ] ] => + let Hx := fresh in + set (Hx := x) ; + pattern p in Hx ; + subst Hx ; + + (* Match bind and apply *) + match goal with + | [ |- context [ ⊢ ⦃ ?P ⦄ _ ≈ bind ?a ?f ⦃ ?Q ⦄ ] ] => + let av := fresh in + let fv := fresh in + set (av := a) + ; set (fv := f) + ; eapply (r_bind (ret p) av _ fv P (fun '(v0, h0) '(v1, h1) => v0 = v1 /\ P (h0, h1)) Q) + ; subst av fv ; hnf ; [ | intros ; apply rpre_hypothesis_rule' ; intros ? ? [] ; apply rpre_weaken_rule with (pre := fun '(s₀, s₁) => P (s₀, s₁)) + ] + end + end. + + Definition unfold_translate_for : forall v j d id0 id' y, + (translate_for v [seq (1 + Z.of_nat i)%Z | i <- iota j (S d)] id0 y id') = + (translate_write_var id0 v (@existT choice_type (fun t : choice_type => Choice.sort (chElement t)) chInt (Z.of_nat (j.+1))) ;; + (snd (y id')) ;; + translate_for v [seq (1 + Z.of_nat i)%Z | i <- iota (S j) d] id0 y (fst (y id'))). + Proof. + intros. + assert (forall j n, [seq (1 + Z.of_nat i)%Z | i <- iota j (S n)] = + ((1 + Z.of_nat j)%Z :: [seq (1 + Z.of_nat i)%Z | i <- iota (S j) n])) by reflexivity. + rewrite H. + unfold translate_for ; fold translate_for. + destruct (y id'). + replace (totce (translate_value (values.Vint (1 + Z.of_nat j)))) + with (@existT choice_type (fun t : choice_type => Choice.sort (chElement t)) chInt (Z.of_nat (j.+1))). + 2:{ + cbn. + repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). + rewrite Zpos_P_of_succ_nat. + unfold Z.succ. + rewrite Z.add_comm. + reflexivity. + } + reflexivity. + Qed. + + Theorem loop_eq : + forall {acc : ChoiceEquality} v d (j : nat) id0 s_id id' y I L (y0 : @int U32 -> acc -> code L I acc) (pre : _ -> precond) c, + (0 < d) -> + (forall k c s_id, + j <= k < j + d -> + ⊢ ⦃ set_lhs + (translate_var id0 (v_var v)) + (@truncate_el chInt (vtype (v_var v)) (S k)) + (pre c) ⦄ + y s_id + ≈ y0 (repr (Pos.of_succ_nat k)) c + ⦃ λ '(_, h0) '(v1, h1), (pre (ct_T v1)) (h0, h1) ⦄) -> + ⊢ ⦃ (pre c) ⦄ + (translate_for v + [seq (1 + Z.of_nat i)%Z | i <- iota j d] id0 (fun id => (id' id, y id)) s_id) ≈ + (foldi_ (I := I) (L := L) (d) (repr (S j)) y0 c ) + ⦃ fun '(v0, h0) '(v1, h1) => (pre (ct_T v1)) (h0, h1) ⦄ . + Proof. + intros. + generalize dependent j. + generalize dependent c. + generalize dependent s_id. + induction d ; intros. + discriminate. + + destruct d. + - rewrite unfold_translate_for. + simpl. + apply better_r_put_lhs. + setoid_rewrite T_ct_id. + eapply r_bind. + apply H0. + lia. + + intros. + apply r_ret. + intros. apply H1. + - rewrite <- foldi__move_S. + rewrite unfold_translate_for. + + apply better_r_put_lhs. + setoid_rewrite bind_rewrite. + apply r_bind with (mid := λ '(_, h0) '(v1, h1), (pre (ct_T v1)) (h0, h1)). + + 2:{ + intros. + replace (Hacspec_Lib_Pre.int_add (repr j.+1) one) + with + (@repr U32 j.+2). + 2:{ + simpl. + cbn. + unfold Hacspec_Lib_Pre.int_add, add_word. + rewrite mkwordK. + cbn. + apply word_ext. + rewrite Zplus_mod. + rewrite Zmod_mod. + rewrite <- Zplus_mod. + f_equal. + now zify. + } + + apply better_r. + unfold ".1". + pose (IHd ltac:(easy) (id' s_id) (ct_T a₁) j.+1). + apply r. + + intros. + apply H0. + lia. + } + unfold ".2". + apply H0. + lia. + Qed. + + Lemma nat_to_be_range_is_subword : forall {WS : wsize.wsize} {WS_inp : wsize.wsize} (n : @int WS_inp) i `{H_WS : WS <= WS_inp} , (@repr WS (nat_be_range WS (toword n) i) = word.subword (i * WS) WS n). + Proof. + intros. + apply word_ext. + cbn. + unfold nat_be_range. + replace (_ ^ WS)%Z with (modulus WS)%Z by (destruct WS ; reflexivity). + replace (modulus WS_inp) with (modulus (WS_inp - WS) * modulus WS)%Z by (destruct WS , WS_inp ; easy). + rewrite mod_pq_mod_q ; [ | easy | easy ]. + rewrite !Zmod_mod. + f_equal. + rewrite <- Z.shiftr_div_pow2 ; [ | lia ]. + rewrite Nat2Z.inj_mul. + f_equal. now zify. + Qed. + + (*** Equality proofs *) + Lemma rebuild_128_eq : forall (v0 v1 v2 v3 : 'word U32) , make_vec _ [v0 ; v1 ; v2 ; v3] = is_pure (rebuild_u128 v0 v1 v2 v3). @@ -744,10 +1016,6 @@ Section Hacspec. reflexivity. Qed. - Definition pdisj (P : precond) (s_id : p_id) (rhs : {fset Location}) := - (forall h1 h2 l a v s_id', l = translate_var s_id' v -> (s_id ⪯ s_id') -> (P (h1, h2) -> P (set_heap h1 l a, h2))) /\ - (forall h1 h2 l a, l \in rhs -> (P (h1, h2) -> P (h1, set_heap h2 l a))). - Lemma key_combined_eq id0 rcon rkey temp2 (pre : precond) : (pdisj pre id0 fset0) -> ⊢ ⦃ pre ⦄ @@ -792,8 +1060,7 @@ Section Hacspec. } { destruct_pre. - destruct H_pdisj. - repeat eapply H ; try easy. + pdisj_apply H_pdisj. } Unshelve. @@ -987,159 +1254,34 @@ Section Hacspec. pattern (wshufps_128 (wrepr U8 140) a₁0 a₁1) in r. subst r. eapply (@r_bind _ _ _ _ (ret (wshufps_128 (wrepr U8 140) a₁0 a₁1))). - apply (wshufps_128_eq_state a₁0 a₁1 140). - - intros. - apply r_ret. - intros ? ? []. - subst. - split. - unfold make_vec. - cbn. - rewrite Z.lor_0_r. - destruct a₁2. cbn. unfold wrepr. cbn. apply word_ext. - rewrite Zmod_small. - cbn. - reflexivity. - apply (ssrbool.elimT (iswordZP _ _)). - apply i. - apply H0. - } - { - apply r_ret. - solve_post_from_pre. - } - { - apply r_ret. - solve_post_from_pre. - } - (* Cleanup *) - Transparent translate_call. - Qed. - - - Ltac bind_jazz_bind := - match goal with - | [ |- context [ ⊢ ⦃ ?P ⦄ putr ?l ?y ?g ≈ bind ?a ?f ⦃ ?Q ⦄ ] ] => - let yv := fresh in - let gv := fresh in - let av := fresh in - let fv := fresh in - set l - ; set (yv := y) - ; set (gv := g) - ; set (av := a) - ; set (fv := f) - ; apply (r_bind (ret yv) (av) (fun x => putr l x gv) fv P (fun '(v0, h0) '(v1, h1) => v0 = v1 /\ P (h0, h1)) Q) ; [ | intros ] - ; subst yv gv av fv ; hnf - end. - - Ltac solve_in := - repeat match goal with - | |- is_true (?v \in fset1 ?v :|: _) => apply/fsetU1P; left; auto - | |- is_true (_ \in fsetU _ _) => apply/fsetU1P; right - end. - - Ltac pdisj_apply h := - lazymatch goal with - | |- ?pre (set_heap _ _ _, set_heap _ _ _) => eapply h; [ solve_in | pdisj_apply h ] - | |- ?pre (set_heap _ _ _, _) => - eapply h ; [ reflexivity | auto with preceq | pdisj_apply h ] - | |- _ => try assumption - end. - - Theorem rpre_hypothesis_rule' : - ∀ {A₀ A₁ : _} {p₀ : raw_code A₀} {p₁ : raw_code A₁} - (pre : precond) post, - (∀ s₀ s₁, - pre (s₀, s₁) → ⊢ ⦃ λ '(s₀', s₁'), s₀' = s₀ ∧ s₁' = s₁ ⦄ p₀ ≈ p₁ ⦃ post ⦄ - ) → - ⊢ ⦃ pre ⦄ p₀ ≈ p₁ ⦃ post ⦄. - Proof. - intros A₀ A₁ p₀ p₁ pre post h. - eapply rpre_hypothesis_rule. - intros s0 s1 H. eapply rpre_weaken_rule. - eapply h. - eassumption. - easy. - Qed. - - Theorem rpre_weak_hypothesis_rule' : - ∀ {A₀ A₁ : _} {p₀ : raw_code A₀} {p₁ : raw_code A₁} - (pre : precond) post, - (∀ s₀ s₁, - pre (s₀, s₁) → ⊢ ⦃ λ '(s0, s1), pre (s0, s1) ⦄ p₀ ≈ p₁ ⦃ post ⦄ - ) → - ⊢ ⦃ pre ⦄ p₀ ≈ p₁ ⦃ post ⦄. - Proof. - intros A₀ A₁ p₀ p₁ pre post h. - eapply rpre_hypothesis_rule'. - intros. eapply rpre_weaken_rule. - eapply h. eassumption. - intros s0' s1' [H0 H1]. - subst. - assumption. - Qed. - - Corollary better_r_put_rhs : forall {A B : choice.Choice.type} (ℓ : Location) - (v : choice.Choice.sort (Value (projT1 ℓ))) (r₀ : raw_code A) - (r₁ : raw_code B) (pre : precond) - (post : postcond (choice.Choice.sort A) (choice.Choice.sort B)), - ⊢ ⦃ set_rhs ℓ v pre ⦄ r₀ ≈ r₁ ⦃ post ⦄ -> - ⊢ ⦃ pre ⦄ r₀ ≈ #put ℓ := v ;; r₁ ⦃ post ⦄. - Proof. - intros. - eapply rpre_hypothesis_rule. - intros. - eapply rpre_weaken_rule. - apply r_put_rhs. - apply H. - intuition. - Unshelve. - subst. - intuition. - Qed. - - Lemma nat_to_be_range_is_subword : forall {WS : wsize.wsize} {WS_inp : wsize.wsize} (n : @int WS_inp) i `{H_WS : WS <= WS_inp} , (@repr WS (nat_be_range WS (toword n) i) = word.subword (i * WS) WS n). - Proof. - intros. - apply word_ext. - cbn. - unfold nat_be_range. - replace (_ ^ WS)%Z with (modulus WS)%Z by (destruct WS ; reflexivity). - replace (modulus WS_inp) with (modulus (WS_inp - WS) * modulus WS)%Z by (destruct WS , WS_inp ; easy). - rewrite mod_pq_mod_q ; [ | easy | easy ]. - rewrite !Zmod_mod. - f_equal. - rewrite <- Z.shiftr_div_pow2 ; [ | lia ]. - rewrite Nat2Z.inj_mul. - f_equal. now zify. - Qed. - - Theorem modulus_exact : forall {WS : wsize.wsize} (x : 'word WS), (0 <= x < modulus WS)%Z. - Proof. - intros. - destruct x. - cbn. - apply (ssrbool.elimT (iswordZP _ _)) in i. - apply i. - Qed. - - Theorem modulus_smaller : forall (WS : wsize.wsize) (m : nat) {x : 'word WS}, (WS <= m)%Z -> (0 <= x < modulus m)%Z. - Proof. - intros. - destruct x. - cbn. - apply (ssrbool.elimT (iswordZP _ _)) in i. - split. - - easy. - - eapply Z.lt_le_trans. - apply i. - rewrite modulusZE. - rewrite modulusZE. - apply (Z.pow_le_mono_r 2). + apply (wshufps_128_eq_state a₁0 a₁1 140). + + intros. + apply r_ret. + intros ? ? []. + subst. + split. + unfold make_vec. + cbn. + rewrite Z.lor_0_r. + destruct a₁2. cbn. unfold wrepr. cbn. apply word_ext. + rewrite Zmod_small. + cbn. reflexivity. - apply H. + apply (ssrbool.elimT (iswordZP _ _)). + apply i. + apply H0. + } + { + apply r_ret. + solve_post_from_pre. + } + { + apply r_ret. + solve_post_from_pre. + } + (* Cleanup *) + Transparent translate_call. Qed. Lemma sbox_eq : @@ -1153,10 +1295,10 @@ Section Hacspec. destruct (is_pure (index_u8 _ _)). destruct toword. - reflexivity. - - (* SLOW! *) admit. - (* repeat (destruct p ; [ | | reflexivity ]) ; exfalso ; destruct p ; discriminate i0. *) + - (* SLOW! *) (* admit. *) + repeat (destruct p ; [ | | reflexivity ]) ; exfalso ; destruct p ; discriminate i0. - easy. - Admitted. (* Qed. *) + (* Admitted. *) Qed. Lemma SubWord_eq id0 (n : int32) pre : (pdisj pre id0 fset0) -> @@ -1181,50 +1323,6 @@ Section Hacspec. split ; easy. Qed. - Ltac match_pattern_and_bind_repr p := - unfold let_both at 1, is_state at 1, prog ; - match goal with - | [ |- context [ ⊢ ⦃ ?P ⦄ ?x ≈ _ ⦃ ?Q ⦄ ] ] => - let Hx := fresh in - set (Hx := x) ; - pattern p in Hx ; - subst Hx ; - - (* Match bind and apply *) - match goal with - | [ |- context [ ⊢ ⦃ ?P ⦄ _ ≈ bind ?a ?f ⦃ ?Q ⦄ ] ] => - let av := fresh in - let fv := fresh in - set (av := a) - ; set (fv := f) - ; eapply (r_bind (ret p) av _ fv P (fun '(v0, h0) '(v1, h1) => v0 = repr v1 /\ P (h0, h1)) Q) - ; subst av fv ; hnf ; [ | intros ; apply rpre_hypothesis_rule' ; intros ? ? [] ; apply rpre_weaken_rule with (pre := fun '(s₀, s₁) => P (s₀, s₁)) - ] - end - end. - - Ltac match_pattern_and_bind p := - unfold let_both at 1, is_state at 1, prog ; - match goal with - | [ |- context [ ⊢ ⦃ ?P ⦄ ?x ≈ _ ⦃ ?Q ⦄ ] ] => - let Hx := fresh in - set (Hx := x) ; - pattern p in Hx ; - subst Hx ; - - (* Match bind and apply *) - match goal with - | [ |- context [ ⊢ ⦃ ?P ⦄ _ ≈ bind ?a ?f ⦃ ?Q ⦄ ] ] => - let av := fresh in - let fv := fresh in - set (av := a) - ; set (fv := f) - ; eapply (r_bind (ret p) av _ fv P (fun '(v0, h0) '(v1, h1) => v0 = v1 /\ P (h0, h1)) Q) - ; subst av fv ; hnf ; [ | intros ; apply rpre_hypothesis_rule' ; intros ? ? [] ; apply rpre_weaken_rule with (pre := fun '(s₀, s₁) => P (s₀, s₁)) - ] - end - end. - Lemma keygen_assist_eq id0 (v1 : 'word U128) (v2 : 'word U8) (pre : precond) : (pdisj pre id0 fset0) -> ⊢ ⦃ pre ⦄ @@ -1396,23 +1494,17 @@ Section Hacspec. repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). eexists. split. - split. - reflexivity. + split ; [ reflexivity | ]. eexists. - split. + split ; [ | reflexivity ]. eexists. - split. + split ; [ | reflexivity ]. exists (set_heap H9 (translate_var s_id' v) a). - split. - eapply H_pdisj. - reflexivity. + split ; [ | reflexivity ]. + pdisj_apply H_pdisj. etransitivity. apply fresh2_weak. assumption. - assumption. - reflexivity. - reflexivity. - reflexivity. rewrite ![set_heap _ (translate_var s_id' v) a]set_heap_commut ; (reflexivity || @@ -1448,13 +1540,11 @@ Section Hacspec. split. exists (set_heap H5 (translate_var s_id' v) a). split. - eapply H_pdisj. - reflexivity. + pdisj_apply H_pdisj. etransitivity. apply fresh2_weak. apply H0. - apply H6. reflexivity. reflexivity. @@ -1470,17 +1560,14 @@ Section Hacspec. destruct_pre. unfold set_lhs. eexists. + split ; [ | reflexivity ]. eexists. + split ; [ | reflexivity ]. eexists. - split. - eexists. - split. + split ; [ | reflexivity ]. eapply H_pdisj. apply H. apply H6. - reflexivity. - reflexivity. - reflexivity. } - easy. @@ -1521,204 +1608,8 @@ Section Hacspec. exfalso. lia. - Qed. - (* Admitted. *) - - - (* Theorem loop_eq : *) - (* forall (acc : ChoiceEquality) id0 pre d i c v I L y *) - (* (y0 : int -> acc -> code L I acc) id' (inv : postcond _ _), *) - (* (i < d)%nat -> *) - (* (i + d < modulus U32)%Z -> *) - (* (forall c j, (i <= j < d)%nat -> ⊢ ⦃ pre ⦄ *) - (* translate_write_var id0 v *) - (* (@existT choice_type (fun t : choice_type => Choice.sort (chElement t)) chInt (Z.of_nat (j.+1))) ;; *) - (* y id0 ≈ y0 (repr j.+1) c ⦃ λ '(s0, h0) '(s1, h1), (inv (s0, h0) (s1, h1)) /\ pre (h0, h1) ⦄) -> *) - (* inv (emptym, empty_heap) (_, empty_heap) -> *) - (* ⊢ ⦃ pre ⦄ *) - (* (translate_for v *) - (* [seq (1 + Z.of_nat i)%Z | i <- iota i d] id0 (fun id => (id' id, y id)) id0~1) ≈ *) - (* (foldi_ (I := I) (L := L) (S d) (repr (S i)) y0 c ) *) - (* ⦃ fun '(v0, h0) '(v1, h1) => pre (h0, h1) ⦄ . *) - (* Proof. *) - (* clear ; intros. *) - (* generalize dependent i. *) - (* generalize dependent c. *) - (* generalize dependent id0. *) - (* induction d ; intros. *) - (* - discriminate. *) - (* - assert (forall j n, [seq (1 + Z.of_nat i)%Z | i <- iota j (S n)] = *) - (* ((1 + Z.of_nat j)%Z :: [seq (1 + Z.of_nat i)%Z | i <- iota (S j) n])) by reflexivity. *) - (* replace (d.+1 - i) with (d - i).+1 by lia. *) - (* rewrite H3. *) - (* unfold translate_for ; fold translate_for. *) - (* rewrite <- foldi__move_S. *) - (* rewrite <- bind_assoc. *) - (* apply r_bind with (mid := fun '(v0, h0) '(v1, h1) => inv (v0, h0) (v1, h1) /\ pre (h0, h1)). *) - (* 2:{ *) - (* intros. *) - (* rewrite bind_rewrite. *) - (* replace (Hacspec_Lib_Pre.int_add (repr _) _) with (@repr U32 (S (S i))). *) - (* 2:{ *) - (* simpl. *) - (* cbn. *) - (* unfold Hacspec_Lib_Pre.int_add, add_word. *) - (* rewrite mkwordK. *) - (* rewrite Zmod_small. *) - (* cbn. *) - (* apply word_ext. *) - (* f_equal. *) - (* rewrite Pos.add_1_r. *) - (* reflexivity. *) - (* split. solve_lower_bounds. *) - (* eapply Z.le_lt_trans. *) - (* 2: apply H1. *) - (* zify. *) - (* rewrite <- addn1. *) - (* setoid_rewrite Nat2Z.inj_add. *) - (* rewrite Z.add_assoc. *) - (* apply Zplus_le_compat_r. *) - (* apply le_add_right. *) - (* easy. *) - (* easy. *) - (* } *) - (* apply better_r. *) - (* eapply rpre_hypothesis_rule. *) - (* intros ? ? []. *) - (* eapply rpre_weaken_rule ; [ | ]. *) - (* - specialize (IHd id0). *) - (* specialize (IHd (ct_T a₁)). *) - (* admit. *) - (* (* apply IHd. *) - (* + apply H4. *) - (* + admit. *) - (* + setoid_rewrite <- Nat2Z.inj_add. *) - (* setoid_rewrite addSnnS. *) - (* rewrite Nat2Z.inj_add. *) - (* apply H1. *) - (* + intros. eapply H2. *) - (* apply H6. *) - (* lia. *) - (* - now (intros ? ? [] ; subst). *) - (* } *) - (* replace (totce (translate_value (values.Vint (1 + Z.of_nat i)))) *) - (* with (@existT choice_type (fun t : choice_type => Choice.sort (chElement t)) chInt (Z.of_nat (i.+1))). *) - (* 2:{ *) - (* cbn. *) - (* repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). *) - (* rewrite Zpos_P_of_succ_nat. *) - (* unfold Z.succ. *) - (* rewrite Z.add_comm. *) - (* reflexivity. *) - (* } *) - (* specialize (H2 c (i)). *) *) - (* (* apply H2. *) - (* apply H. *) - (* lia. *) - (* *) Admitted. *) - - Definition unfold_translate_for : forall v j d id0 id' y, - (translate_for v [seq (1 + Z.of_nat i)%Z | i <- iota j (S d)] id0 y id') = - (translate_write_var id0 v (@existT choice_type (fun t : choice_type => Choice.sort (chElement t)) chInt (Z.of_nat (j.+1))) ;; - (snd (y id')) ;; - translate_for v [seq (1 + Z.of_nat i)%Z | i <- iota (S j) d] id0 y (fst (y id'))). - Proof. - intros. - assert (forall j n, [seq (1 + Z.of_nat i)%Z | i <- iota j (S n)] = - ((1 + Z.of_nat j)%Z :: [seq (1 + Z.of_nat i)%Z | i <- iota (S j) n])) by reflexivity. - rewrite H. - unfold translate_for ; fold translate_for. - destruct (y id'). - replace (totce (translate_value (values.Vint (1 + Z.of_nat j)))) - with (@existT choice_type (fun t : choice_type => Choice.sort (chElement t)) chInt (Z.of_nat (j.+1))). - 2:{ - cbn. - repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). - rewrite Zpos_P_of_succ_nat. - unfold Z.succ. - rewrite Z.add_comm. - reflexivity. - } - reflexivity. - Qed. - - Theorem loop_eq : - forall {acc : ChoiceEquality} v d (j : nat) id0 s_id id' y I L (y0 : @int U32 -> acc -> code L I acc) pre c, - (0 < d) -> - (forall k c s_id, - j <= k < j + d -> - ⊢ ⦃ set_lhs - (translate_var id0 (v_var v)) - (@truncate_el chInt (vtype (v_var v)) (S k)) - pre ⦄ - y s_id - ≈ y0 (repr (Pos.of_succ_nat k)) c - ⦃ λ '(_, h0) '(_, h1), pre (h0, h1) ⦄) -> - ⊢ ⦃ pre ⦄ - (translate_for v - [seq (1 + Z.of_nat i)%Z | i <- iota j d] id0 (fun id => (id' id, y id)) s_id) ≈ - (foldi_ (I := I) (L := L) (d) (repr (S j)) y0 c ) - ⦃ fun '(v0, h0) '(v1, h1) => pre (h0, h1) ⦄ . - Proof. - intros. - generalize dependent j. - generalize dependent c. - generalize dependent s_id. - induction d ; intros. - discriminate. - - destruct d. - - rewrite unfold_translate_for. - simpl. - apply better_r_put_lhs. - setoid_rewrite T_ct_id. - eapply r_bind. - apply H0. - lia. - - intros. - apply r_ret. - intros. apply H1. - - rewrite <- foldi__move_S. - rewrite unfold_translate_for. - - apply better_r_put_lhs. - setoid_rewrite bind_rewrite. - apply r_bind with (mid := λ '(_, h0) '(_, h1), pre (h0, h1)). - - 2:{ - intros. - replace (Hacspec_Lib_Pre.int_add (repr j.+1) one) - with - (@repr U32 j.+2). - 2:{ - simpl. - cbn. - unfold Hacspec_Lib_Pre.int_add, add_word. - rewrite mkwordK. - cbn. - apply word_ext. - rewrite Zplus_mod. - rewrite Zmod_mod. - rewrite <- Zplus_mod. - f_equal. - now zify. - } - - apply better_r. - unfold ".1". - pose (IHd ltac:(easy) (id' s_id) (ct_T a₁) j.+1). - apply r. + (* Admitted. *) Qed. - intros. - apply H0. - lia. - } - unfold ".2". - apply H0. - lia. - Qed. - Lemma keys_expand_eq id0 rkey (pre : precond) : (pdisj pre id0 (fset ([(seq_choice int128; 279) ; (@int_choice U128; 278) ; (@int_choice U128; 277)]))) -> ⊢ ⦃ pre ⦄ @@ -1781,7 +1672,7 @@ Section Hacspec. set (tr_app_sopn_tuple _ _ _). cbn in s. set (repr 0) at 8. - assert (s = t) by now apply word_ext. + assert (s = t) by now apply word_ext. generalize dependent s. generalize dependent t. intros. @@ -1798,10 +1689,23 @@ Section Hacspec. end. Transparent is_state. Transparent is_pure. - set (set_lhs _ _ _). rewrite bind_assoc. - eapply (@r_bind _ _ _ _ _ _ _ _ _ (λ '(v0, h0) '(v1, h1), p (h0, h1))). + set (set_lhs _ _ _). + set (Hacspec_Lib_Pre.seq_push _ _) in *. + pattern (t0) in p. + set (fun _ => _) in p. + pattern (rkey) in y. + set (fun _ => _) in y. + subst y. + pattern (t) in y0. + set (fun _ => _) in y0. + subst y0. + pose (fun '(t0, rkey, t) => y t rkey t0). + replace p with (p0 (t0, rkey, t)) by reflexivity. + + + eapply (@r_bind _ _ _ _ _ _ _ _ _ (λ '(v0, h0) '(v1, h1), (p0 v1) (h0, h1))). 2:{ subst p. intros. @@ -1823,39 +1727,23 @@ Section Hacspec. - intros. simpl in H. rewrite !coerce_to_choice_type_K in H. - rewrite !zero_extend_u in H. - cbn. admit. } { - apply H_pdisj. - rewrite in_fset. - now rewrite mem_head. - apply H_pdisj. - rewrite in_fset. - rewrite in_cons ; simpl. - now rewrite mem_head. - eapply H_pdisj. - rewrite in_fset. - rewrite in_cons ; simpl. - rewrite in_cons ; simpl. - rewrite mem_head. - now rewrite Bool.orb_true_r. - - apply H_pdisj. - rewrite in_fset. - now rewrite mem_head. - - eapply H_pdisj. - reflexivity. - reflexivity. - eapply H_pdisj. - reflexivity. - reflexivity. - eapply H_pdisj. - reflexivity. - reflexivity. - apply H15. + destruct_pre. + pdisj_apply H_pdisj. + - rewrite in_fset. + now rewrite mem_head. + - rewrite in_fset. + rewrite in_cons ; simpl. + now rewrite mem_head. + - rewrite in_fset. + rewrite in_cons ; simpl. + rewrite in_cons ; simpl. + rewrite mem_head. + now rewrite Bool.orb_true_r. + - rewrite in_fset. + now rewrite mem_head. } } @@ -1875,24 +1763,29 @@ Section Hacspec. replace (Z.to_nat (11 - 1)) with 10 by reflexivity. replace (Pos.to_nat 10) with 10 by reflexivity. - - apply (@loop_eq (seq int128 '× int '× int) _ 10 0). + subst y1. + subst p. + subst t0. + + apply (@loop_eq (seq int128 '× int '× int) _ 10 0 _ _ _ _ _ _ _ p0). { easy. } { intros. subst y. subst y0. - subst p. - + subst p0. + hnf. + remove_get_in_lhs. rewrite bind_assoc. destruct c as [? []]. destruct t0 as []. - assert (t = t1). admit. subst. - assert (rkey = (mkWord (nbits:=U128) (toword:=toword) i)). admit. subst. - + (* assert (t = t1). admit. subst. *) + (* assert (rkey = (mkWord (nbits:=U128) (toword:=toword) i)). admit. subst. *) + + set (set_lhs _ _ _). eapply r_bind with (mid := λ '(v0, h0) '(v1, h1), (∃ o1 : (λ i : choice_type_choiceType, i) 'int, @@ -1931,7 +1824,7 @@ Section Hacspec. setoid_rewrite Nat.add_0_l in H. apply H. } - + intros. apply rpre_hypothesis_rule. intros. @@ -1967,7 +1860,7 @@ Section Hacspec. replace (translate_call _ _ _ _ _) with (get_translated_static_fun ssprove_jasmin_prog 11%positive - static_funs (s_id~0~1)%positive [('int; x0); ('word U128; (mkWord (nbits:=U128) (toword:=toword) i)); ('word U128; t1) ]). + static_funs (s_id~0~1)%positive [('int; x0); ('word U128; t1); ('word U128; (mkWord (nbits:=U128) (toword:=toword) i))]). 2:{ Transparent translate_call. simpl. @@ -1978,11 +1871,11 @@ Section Hacspec. Opaque translate_call. } unfold lift_to_both0. - Set Printing Coercions. + unfold is_pure. unfold lift_to_both. unfold repr. - (* apply r. *) (* TODO?? *) + apply r. admit. } @@ -2027,10 +1920,38 @@ Section Hacspec. apply r_ret. intros. + + rewrite !ct_T_id. + repeat remove_T_ct. + rewrite !zero_extend_u. + admit. } Admitted. + Lemma aes_enc_eq id0 state key (pre : precond) : + (pdisj pre id0 (fset [ (CE_loc_to_loc ( nseq int8 1 ; 0%nat ) : Location) ])) -> + ⊢ ⦃ pre ⦄ + ret (waes.wAESENC state key) + ≈ + prog (is_state (aesenc state key)) + ⦃ fun '(v0, h0) '(v1, h1) => (v0 = v1) /\ pre (h0, h1) ⦄. + Proof. + + Admitted. + + Lemma aes_enc_last_eq id0 state key (pre : precond) : + (pdisj pre id0 (fset [ (CE_loc_to_loc ( nseq int8 1 ; 0%nat ) : Location) ])) -> + ⊢ ⦃ pre ⦄ + ret (waes.wAESENCLAST state key) + ≈ + prog (is_state (aesenclast state key)) + ⦃ fun '(v0, h0) '(v1, h1) => (v0 = v1) /\ pre (h0, h1) ⦄. + Proof. + + Admitted. + + Lemma addroundkey_eq id0 (rkeys : 'array) (rkeys' : seq int128) m (pre : precond) : (pdisj pre id0 (fset [ (CE_loc_to_loc ( nseq int8 1 ; 0%nat ) : Location) ])) -> ((forall (j : nat), @@ -2047,7 +1968,10 @@ Section Hacspec. intros H_pdisj rkeys_ext. set (JAES_ROUNDS _ _ _). unfold JAES_ROUNDS in r. - unfold get_translated_static_fun, JAES_ROUNDS, get_translated_static_fun, translate_prog_static, translate_funs_static, translate_call_body in r. + Transparent translate_call. + unfold get_translated_static_fun in r. + simpl in r. + unfold translate_call_body in r. Opaque translate_call. simpl in r. subst r. @@ -2064,7 +1988,7 @@ Section Hacspec. unfold aes_rounds. rewrite !coerce_to_choice_type_K. - Set Printing Coercions. + unfold lift_to_both0 at 1. unfold let_mut_both at 1, is_state at 1, is_state at 1, is_state at 1. @@ -2082,11 +2006,66 @@ Section Hacspec. rewrite <- bind_assoc. eapply r_bind. - { admit. (* AES Enc loop *) } + { + set (fun (_ : p_id) => _). + set (fun (_ : int_type) (_ : _) => _). + + rewrite !coerce_typed_code_K. + rewrite bind_rewrite. + rewrite bind_rewrite. + + unfold foldi_both', foldi_both, lift_scope, is_state at 1, lift_code_scope, prog, is_state at 1, foldi. + unfold foldi_pre ; replace (unsigned _ - unsigned _)%Z with 9%Z by reflexivity. + replace (Z.to_nat (10 - 1)) with 9 by reflexivity. + replace (Pos.to_nat 9) with 9 by reflexivity. + + set (set_rhs _ _ _). + pattern (a₁) in p. + set (fun _ => _) in p. + subst y0. + subst p. + + apply (@loop_eq int _ 9 0 _ _ _ _ _ _ _ y1) ; subst y1 ; hnf. + { easy. } + { + intros. + remove_get_in_lhs. + remove_get_in_lhs. + remove_get_in_lhs. + + bind_jazz_hac. + - pose aes_enc_eq. + admit. (* AES Enc loop *) + - apply better_r_put_rhs. + apply better_r_put_lhs. + apply r_ret. + intros. + destruct_pre. + admit. + } + } intros. + remove_get_in_lhs. + remove_get_in_lhs. + bind_jazz_hac. { admit. (* AES Enc last *) } + + apply better_r_put_lhs. + remove_get_in_lhs. + + apply r_ret. + + intros. + + destruct_pre. + split. + - eexists. + split. + + reflexivity. + + admit. + - pdisj_apply H_pdisj. Admitted. Lemma aes_eq id0 key m (pre : precond) : @@ -2111,6 +2090,4 @@ Section Hacspec. remove_get_in_lhs. Admitted. - - End Hacspec. From d28f55a4ad69a61050acefcba81cae2b25c14371 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Wed, 25 Jan 2023 15:59:51 +0100 Subject: [PATCH 353/383] aes done, only subprofs left --- theories/Jasmin/examples/aes/aes_hac.v | 295 +++++++++++++++++++++++-- 1 file changed, 276 insertions(+), 19 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes_hac.v b/theories/Jasmin/examples/aes/aes_hac.v index 3189c9c7..608731ba 100644 --- a/theories/Jasmin/examples/aes/aes_hac.v +++ b/theories/Jasmin/examples/aes/aes_hac.v @@ -1618,11 +1618,8 @@ Section Hacspec. is_state (keys_expand rkey) ⦃ fun '(v0, h0) '(v1, h1) => (exists o1, v0 = [('array; o1)] - /\ (forall (j : nat), - forall (a : 'word U8) (b : 'word U128), - (getm o1 (Z.of_nat j) = Some a) -> - (getm v1 (j / 16) = Some b) -> - a = index_u8 (index_u32 b (repr ((j mod 16) / 4))) (repr (j mod 4)))) /\ pre (h0, h1) ⦄. + /\ (forall k, ((chArray_get U128 o1 k (wsize_size U128)) + = is_pure (seq_index (A := @int U128) v1 (lift_to_both0 (repr k)))))) /\ pre (h0, h1) ⦄. Proof. intros H_pdisj. set (JKEYS_EXPAND _ _). @@ -1725,8 +1722,7 @@ Section Hacspec. split. - reflexivity. - intros. - simpl in H. - rewrite !coerce_to_choice_type_K in H. + destruct_pre. admit. } { @@ -1953,12 +1949,14 @@ Section Hacspec. Lemma addroundkey_eq id0 (rkeys : 'array) (rkeys' : seq int128) m (pre : precond) : - (pdisj pre id0 (fset [ (CE_loc_to_loc ( nseq int8 1 ; 0%nat ) : Location) ])) -> - ((forall (j : nat), - forall (a : 'word U8) (b : 'word U128), - (getm rkeys (Z.of_nat j) = Some a) -> - (getm rkeys' (j / 16) = Some b) -> - a = index_u8 (index_u32 b (repr ((j mod 16) / 4))) (repr (j mod 4)))) -> + (pdisj pre id0 (fset [ (@int_choice U128; 334) ])) -> + (forall k, ((chArray_get U128 rkeys k (wsize_size U128)) + = is_pure (seq_index rkeys' (lift_to_both0 (repr k))))) -> + (* ((forall (j : nat), *) + (* forall (a : 'word U8) (b : 'word U128), *) + (* (getm rkeys (Z.of_nat j) = Some a) -> *) + (* (getm rkeys' (j / 16) = Some b) -> *) + (* a = index_u8 (index_u32 b (repr ((j mod 16) / 4))) (repr (j mod 4)))) -> *) ⊢ ⦃ pre ⦄ JAES_ROUNDS id0 rkeys m ≈ @@ -2034,8 +2032,56 @@ Section Hacspec. remove_get_in_lhs. bind_jazz_hac. - - pose aes_enc_eq. - admit. (* AES Enc loop *) + - unfold sopn_sem. + unfold sopn.get_instr_desc. + unfold asm_op_instr. + unfold asm_opI. + unfold arch_extra.get_instr_desc. + unfold semi. + unfold instr_desc. + unfold instr_desc_op. + unfold _asm_op_decl. + unfold _asm. + unfold x86_extra. + unfold x86.x86. + unfold x86_op_decl. + unfold x86_instr_desc. + unfold id_semi. + unfold Ox86_AESENC_instr. + unfold mk_instr_aes2. + unfold ".1". + unfold x86_AESENC. + unfold tr_app_sopn_tuple. + unfold encode_tuple. + unfold jasmin_translate.encode. + unfold w_ty. + unfold map. + unfold lchtuple. + unfold chCanonical. + unfold w2_ty. + unfold tr_app_sopn. + unfold embed_tuple. + unfold embed_ot. + unfold unembed. + unfold truncate_el. + unfold totce. + unfold ".π2". + + rewrite !coerce_to_choice_type_K. + set (truncate_chWord _ _). + set (truncate_chWord _ _). + cbn in s0. + cbn in s. + subst s0. + subst s. + rewrite !zero_extend_u. + + (* AES Enc loop *) + + rewrite <- rkeys_ext. + apply (aes_enc_eq id0 c (chArray_get U128 rkeys (Pos.of_succ_nat k) (wsize_size U128))). + admit. + - apply better_r_put_rhs. apply better_r_put_lhs. apply r_ret. @@ -2048,9 +2094,59 @@ Section Hacspec. intros. remove_get_in_lhs. remove_get_in_lhs. + rewrite <- bind_ret. bind_jazz_hac. - { admit. (* AES Enc last *) } + { + unfold sopn_sem. + unfold sopn.get_instr_desc. + unfold asm_op_instr. + unfold asm_opI. + unfold arch_extra.get_instr_desc. + unfold semi. + unfold instr_desc. + unfold instr_desc_op. + unfold _asm_op_decl. + unfold _asm. + unfold x86_extra. + unfold x86.x86. + unfold x86_op_decl. + unfold x86_instr_desc. + unfold id_semi. + unfold Ox86_AESENCLAST_instr. + unfold mk_instr_aes2. + unfold ".1". + unfold x86_AESENCLAST. + unfold tr_app_sopn_tuple. + unfold encode_tuple. + unfold jasmin_translate.encode. + unfold w_ty. + unfold map. + unfold lchtuple. + unfold chCanonical. + unfold w2_ty. + unfold tr_app_sopn. + unfold embed_tuple. + unfold embed_ot. + unfold unembed. + unfold truncate_el. + unfold totce. + unfold ".π2". + + rewrite !coerce_to_choice_type_K. + set (truncate_chWord _ _). + set (truncate_chWord _ _). + cbn in s0. + cbn in s. + subst s0. + subst s. + rewrite !zero_extend_u. + + rewrite <- rkeys_ext. + + apply (aes_enc_last_eq id0 a₁0 (chArray_get U128 rkeys 10 (wsize_size U128))). + pdisj_apply H_pdisj. + admit. (* AES Enc last *) } apply better_r_put_lhs. remove_get_in_lhs. @@ -2064,12 +2160,17 @@ Section Hacspec. - eexists. split. + reflexivity. - + admit. + + setoid_rewrite zero_extend_u. + reflexivity. - pdisj_apply H_pdisj. + rewrite in_fset. + now rewrite mem_head. + (* Qed. *) Admitted. Lemma aes_eq id0 key m (pre : precond) : - (pdisj pre id0 (fset [(CE_loc_to_loc ( nseq int8 1 ; 0%nat ) : Location) ])) -> + (pdisj pre id0 (fset [(@int_choice U128; 334) ; (@seq_choice int128; 279); (@int_choice U128; 278); + (@int_choice U128; 277)])) -> ⊢ ⦃ pre ⦄ JAES id0 key m ≈ @@ -2085,9 +2186,165 @@ Section Hacspec. subst r. rewrite !zero_extend_u. + unfold aes. + apply better_r_put_lhs. apply better_r_put_lhs. remove_get_in_lhs. - Admitted. + + rewrite bind_assoc. + rewrite bind_assoc. + + eapply r_bind. + apply keys_expand_eq. + + split. + { + intros. + destruct_pre. + unfold set_lhs. + eexists (set_heap (set_heap H4 ($$"key.314") _) (translate_var s_id' v) a). + split. + 2:{ + rewrite set_heap_commut. + f_equal. + f_equal. + apply f_equal. + reflexivity. + apply injective_translate_var2. + red ; intros. + subst. + now apply (precneq_I s_id'). + } + exists (set_heap H4 (translate_var s_id' v) a). + split. + 2:{ + rewrite set_heap_commut. + reflexivity. + apply injective_translate_var2. + red ; intros. + subst. + now apply (precneq_I s_id'). + } + pdisj_apply H_pdisj. + etransitivity. + apply preceq_I. + apply H0. + } + { + intros. + destruct_pre. + eexists. + split ; [ | reflexivity ]. + eexists. + split ; [ | reflexivity ]. + apply H_pdisj. + + rewrite in_fset. + rewrite in_fset in H. + rewrite in_cons ; simpl. + rewrite H. + now rewrite Bool.orb_true_r. + apply H4. + } + + intros. + apply rpre_hypothesis_rule. + intros ? ? []. + eapply rpre_weaken_rule. + 2:{ + intros ? ? []. subst. + apply H0. + } + clear H0. + destruct H. + destruct H. + subst. + apply better_r_put_lhs. + remove_get_in_lhs. fold @bind. + remove_get_in_lhs. + + rewrite bind_assoc. + rewrite bind_assoc. + + rewrite <- bind_ret. + eapply r_bind. + + apply addroundkey_eq. + { + split. + - intros. + destruct_pre. + eexists. + split. + 2:{ + rewrite ![set_heap _ (translate_var s_id' v) a]set_heap_commut + ; (reflexivity || + (apply injective_translate_var2 ; + red ; intros ; subst ; + apply (precneq_O s_id') ; + etransitivity ; [apply preceq_I | apply H1])). + } + eexists. + split ; [ | reflexivity ]. + eexists. + split ; [ | reflexivity ]. + pdisj_apply H_pdisj. + etransitivity. + apply preceq_O. + etransitivity. + apply preceq_I. + apply H1. + - intros. + destruct_pre. + eexists. + split ; [| reflexivity ]. + eexists. + split ; [ | reflexivity ]. + eexists. + split ; [ | reflexivity ]. + eapply H_pdisj. + + rewrite in_fset. + rewrite in_cons ; simpl. + rewrite in_fset in H. + rewrite mem_seq1 in H. + rewrite H. + now rewrite Bool.orb_true_l. + apply H7. + } + { + intros. + rewrite !coerce_to_choice_type_K. + apply H0. + } + + intros. + apply rpre_hypothesis_rule. + intros ? ? []. + eapply rpre_weaken_rule. + 2:{ + intros ? ? []. subst. + apply H1. + } + clear H1. + destruct H. + destruct H. + subst. + apply better_r_put_lhs. + rewrite bind_rewrite. + remove_get_in_lhs. + apply r_ret. + + intros. + destruct_pre. + split. + eexists. + split ; [reflexivity | ]. + rewrite !zero_extend_u. + setoid_rewrite zero_extend_u. + reflexivity. + pdisj_apply H_pdisj. + Qed. End Hacspec. From 81b377eb4ee5401bf92ab89e55ce5a790c918e92 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Wed, 25 Jan 2023 20:15:49 +0100 Subject: [PATCH 354/383] WIP --- theories/Jasmin/examples/aes/aes_hac.v | 401 +++++++++++++++++++++---- 1 file changed, 342 insertions(+), 59 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes_hac.v b/theories/Jasmin/examples/aes/aes_hac.v index 608731ba..a0226b0a 100644 --- a/theories/Jasmin/examples/aes/aes_hac.v +++ b/theories/Jasmin/examples/aes/aes_hac.v @@ -23,6 +23,7 @@ From extructures Require Import ord fset fmap. Require Import micromega.Lia. From mathcomp.word Require Import word ssrZ. From JasminSSProve Require Import aes_jazz jasmin_utils. +From JasminSSProve Require Import aes_utils. Import JasminNotation JasminCodeNotation. Import PackageNotation. @@ -584,22 +585,25 @@ Section Hacspec. Qed. Theorem loop_eq : - forall {acc : ChoiceEquality} v d (j : nat) id0 s_id id' y I L (y0 : @int U32 -> acc -> code L I acc) (pre : _ -> precond) c, + forall {acc : ChoiceEquality} v d (j : nat) id0 s_id id' y I L (y0 : @int U32 -> acc -> code L I acc) (pre : _ -> _ -> precond) c, (0 < d) -> + (id0 ⪯ s_id) -> + (forall id, id ⪯ id' id) -> (forall k c s_id, + (id0 ⪯ s_id) -> j <= k < j + d -> ⊢ ⦃ set_lhs (translate_var id0 (v_var v)) (@truncate_el chInt (vtype (v_var v)) (S k)) - (pre c) ⦄ + (pre k c) ⦄ y s_id ≈ y0 (repr (Pos.of_succ_nat k)) c - ⦃ λ '(_, h0) '(v1, h1), (pre (ct_T v1)) (h0, h1) ⦄) -> - ⊢ ⦃ (pre c) ⦄ + ⦃ λ '(_, h0) '(v1, h1), (pre (S k) (ct_T v1)) (h0, h1) ⦄) -> + ⊢ ⦃ (pre j c) ⦄ (translate_for v [seq (1 + Z.of_nat i)%Z | i <- iota j d] id0 (fun id => (id' id, y id)) s_id) ≈ (foldi_ (I := I) (L := L) (d) (repr (S j)) y0 c ) - ⦃ fun '(v0, h0) '(v1, h1) => (pre (ct_T v1)) (h0, h1) ⦄ . + ⦃ fun '(v0, h0) '(v1, h1) => (pre (j + d) (ct_T v1)) (h0, h1) ⦄ . Proof. intros. generalize dependent j. @@ -614,18 +618,19 @@ Section Hacspec. apply better_r_put_lhs. setoid_rewrite T_ct_id. eapply r_bind. + apply H2. apply H0. lia. intros. apply r_ret. - intros. apply H1. + intros. rewrite addn1. apply H3. - rewrite <- foldi__move_S. rewrite unfold_translate_for. apply better_r_put_lhs. setoid_rewrite bind_rewrite. - apply r_bind with (mid := λ '(_, h0) '(v1, h1), (pre (ct_T v1)) (h0, h1)). + apply r_bind with (mid := λ '(_, h0) '(v1, h1), (pre (j.+1) (ct_T v1)) (h0, h1)). 2:{ intros. @@ -646,16 +651,26 @@ Section Hacspec. now zify. } + assert (id0 ⪯ id' s_id). + { + etransitivity. + apply H0. + apply H1. + } + apply better_r. unfold ".1". - pose (IHd ltac:(easy) (id' s_id) (ct_T a₁) j.+1). + pose (IHd ltac:(easy) (id' s_id) H3 (ct_T a₁) j.+1). + rewrite <- addSnnS. apply r. intros. - apply H0. + apply H2. + apply H4. lia. } unfold ".2". + apply H2. apply H0. lia. Qed. @@ -1295,10 +1310,10 @@ Section Hacspec. destruct (is_pure (index_u8 _ _)). destruct toword. - reflexivity. - - (* SLOW! *) (* admit. *) - repeat (destruct p ; [ | | reflexivity ]) ; exfalso ; destruct p ; discriminate i0. - - easy. - (* Admitted. *) Qed. + - (* SLOW! *)admit. + (* repeat (destruct p ; [ | | reflexivity ]) ; exfalso ; destruct p ; discriminate i0. *) + - (* easy. *) + Admitted. (* Qed. *) Lemma SubWord_eq id0 (n : int32) pre : (pdisj pre id0 fset0) -> @@ -1603,12 +1618,20 @@ Section Hacspec. unfold array_index_clause_2_clause_1. simpl. - (* SLOW! *) (* admit. *) - do 10 (destruct j as [ | j ] ; [ simpl ; repeat (remove_get_in_lhs ; simpl) ; apply better_r_put_lhs ; remove_get_in_lhs ; apply r_ret ; intros ; destruct_pre ; split ; [ eexists ; split ; [ | reflexivity] ; f_equal ; unfold totce ; repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K) ; reflexivity | eapply H ; [ reflexivity | reflexivity | ] ; eapply H ; [ reflexivity | reflexivity | ] ; apply H5 ] | ]). + (* SLOW! *) admit. + (* do 10 (destruct j as [ | j ] ; [ simpl ; repeat (remove_get_in_lhs ; simpl) ; apply better_r_put_lhs ; remove_get_in_lhs ; apply r_ret ; intros ; destruct_pre ; split ; [ eexists ; split ; [ | reflexivity] ; f_equal ; unfold totce ; repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K) ; reflexivity | eapply H ; [ reflexivity | reflexivity | ] ; eapply H ; [ reflexivity | reflexivity | ] ; apply H5 ] | ]). *) + (* exfalso. *) + (* lia. *) + Admitted. (* Qed. *) - exfalso. - lia. - (* Admitted. *) Qed. + Ltac split_post := + repeat + match goal with + | |- (_ ⋊ _) _ => split + | |- _ /\ _ => split + | |- set_lhs _ _ _ _ => eexists + | |- set_rhs _ _ _ _ => eexists + end. Lemma keys_expand_eq id0 rkey (pre : precond) : (pdisj pre id0 (fset ([(seq_choice int128; 279) ; (@int_choice U128; 278) ; (@int_choice U128; 277)]))) -> @@ -1618,8 +1641,8 @@ Section Hacspec. is_state (keys_expand rkey) ⦃ fun '(v0, h0) '(v1, h1) => (exists o1, v0 = [('array; o1)] - /\ (forall k, ((chArray_get U128 o1 k (wsize_size U128)) - = is_pure (seq_index (A := @int U128) v1 (lift_to_both0 (repr k)))))) /\ pre (h0, h1) ⦄. + /\ (((chArray_get U128 o1 10 (wsize_size U128)) + = is_pure (seq_index (A := @int U128) v1 (lift_to_both0 (repr 10)))))) /\ pre (h0, h1) ⦄. Proof. intros H_pdisj. set (JKEYS_EXPAND _ _). @@ -1662,6 +1685,8 @@ Section Hacspec. rewrite bind_rewrite. apply better_r_put_rhs. rewrite bind_rewrite. + + apply better_r_put_rhs. apply better_r_put_rhs. apply better_r_put_lhs. @@ -1688,8 +1713,15 @@ Section Hacspec. rewrite bind_assoc. + rewrite !coerce_to_choice_type_K. + rewrite !zero_extend_u. + set (set_lhs _ _ _). set (Hacspec_Lib_Pre.seq_push _ _) in *. + set (set_lhs ($$"rkeys.335") _) in p. + pattern 0%Z in p0. + set 0%Z in p0. + subst p0. pattern (t0) in p. set (fun _ => _) in p. pattern (rkey) in y. @@ -1698,31 +1730,57 @@ Section Hacspec. pattern (t) in y0. set (fun _ => _) in y0. subst y0. - pose (fun '(t0, rkey, t) => y t rkey t0). - replace p with (p0 (t0, rkey, t)) by reflexivity. - + pattern (z) in y. + set (fun _ => _) in y. + subst y. + pose (fun n '(t0, rkey, t) => y0 n t rkey t0). + replace p with (p0 0 (t0, rkey, t)) by reflexivity. - eapply (@r_bind _ _ _ _ _ _ _ _ _ (λ '(v0, h0) '(v1, h1), (p0 v1) (h0, h1))). + eapply (@r_bind _ _ _ _ _ _ _ _ _ (λ '(v0, h0) '(v1, h1), (p0 10 v1) (h0, h1))). 2:{ - subst p. intros. - (* rewrite bind_rewrite. *) - eapply r_get_remember_lhs. intros v. + subst p. + subst p0. + set 10. + subst y0. + hnf. destruct a₁. - simpl. destruct s. - simpl. + rewrite bind_rewrite. + + apply better_r_get_remind_lhs with (v := chArray_set x AAscale n s1). + unfold Remembers_lhs , rem_lhs. + intros ? ? ?. + destruct_pre. + repeat (rewrite get_set_heap_neq ; [ | apply injective_translate_var3 ; reflexivity ]). + rewrite get_set_heap_eq. + reflexivity. + rewrite ct_T_prod_propegate. + rewrite ct_T_prod_propegate. + + unfold trunc_list. + unfold map. + unfold zip. + unfold totce. + unfold jasmin_translate.encode. + unfold truncate_el. + rewrite !coerce_to_choice_type_K. + unfold ".π2". apply r_ret. intros. - destruct_pre. split. { + destruct_pre. eexists. split. - - reflexivity. + - repeat (rewrite get_set_heap_neq ; [ | apply injective_translate_var3 ; reflexivity ]). + reflexivity. - intros. - destruct_pre. + set (get_heap H11 ($$"rkeys.335")). + simpl in s2. + pose (chArray_get_set_eq U128 s2 10 s1). + rewrite e. admit. } { @@ -1765,6 +1823,8 @@ Section Hacspec. apply (@loop_eq (seq int128 '× int '× int) _ 10 0 _ _ _ _ _ _ _ p0). { easy. } + { apply preceq_I. } + { intros. etransitivity. apply preceq_O. apply preceq_O. } { intros. @@ -1778,18 +1838,12 @@ Section Hacspec. destruct c as [? []]. destruct t0 as []. - (* assert (t = t1). admit. subst. *) - (* assert (rkey = (mkWord (nbits:=U128) (toword:=toword) i)). admit. subst. *) - - set (set_lhs _ _ _). eapply r_bind with (mid := λ '(v0, h0) '(v1, h1), (∃ o1 : (λ i : choice_type_choiceType, i) 'int, v0 = [('int; o1)] ∧ repr o1 = v1) ∧ p (h0, h1)) ; subst p. { - (* replace (totce _) *) - (* with (@existT choice_type (fun t : choice_type => Choice.sort (chElement t)) chInt (Z.of_nat (Pos.of_succ_nat j))). *) set [ _ ]. replace (translate_call ssprove_jasmin_prog 12%positive @@ -1816,26 +1870,131 @@ Section Hacspec. reflexivity. } apply (rcon_eq (s_id~1)%positive k). - admit. - setoid_rewrite Nat.add_0_l in H. - apply H. + { + split ; [ | discriminate ]. + intros. + + destruct_pre. + eexists. + split. + 2:{ + rewrite [set_heap _ (translate_var s_id' v) a]set_heap_commut. + reflexivity. + (apply injective_translate_var2 ; + red ; + intros ; + subst ; + apply (precneq_I s_id)). + etransitivity. + apply H2. + apply H. + + } + eexists. + split. + 2:{ + rewrite [set_heap _ (translate_var s_id' v) a]set_heap_commut. + reflexivity. + (apply injective_translate_var2 ; + red ; + intros ; + subst ; + apply (precneq_I s_id)). + etransitivity. + apply H2. + apply H. + + } + eexists. + split. + 2:{ + rewrite [set_heap _ (translate_var s_id' v) a]set_heap_commut. + reflexivity. + (apply injective_translate_var2 ; + red ; + intros ; + subst ; + apply (precneq_I s_id)). + etransitivity. + apply H2. + apply H. + } + eexists. + split. + 2:{ + reflexivity. + } + eexists. + split. + 2:{ + reflexivity. + } + + split_post. + all: try reflexivity. + 2:{ + rewrite ![set_heap _ (translate_var s_id' v) a]set_heap_commut. + reflexivity. + (apply injective_translate_var2 ; + red ; + intros ; + subst ; + apply (precneq_I s_id)). + etransitivity. + apply H2. + apply H. + } + 2:{ + rewrite ![set_heap _ (translate_var s_id' v) a]set_heap_commut. + repeat (rewrite get_set_heap_neq ; [ | apply injective_translate_var3 ; reflexivity ]). + symmetry. + repeat (rewrite get_set_heap_neq ; [ | apply injective_translate_var3 ; reflexivity ]). + symmetry. + rewrite get_set_heap_neq. + reflexivity. + (apply injective_translate_var2 ; + red ; + intros ; + subst ; + apply (precneq_I s_id)). + etransitivity. + apply H2. + apply H. + (apply injective_translate_var2 ; + red ; + intros ; + subst ; + apply (precneq_I s_id)). + etransitivity. + apply H2. + apply H. + } + + pdisj_apply H_pdisj. + etransitivity. + apply H. + etransitivity. + apply preceq_I. + apply H2. + } + easy. } intros. apply rpre_hypothesis_rule. intros. - destruct H0. - destruct H0. - destruct H0. + destruct H1. + destruct H1. + destruct H1. eapply rpre_weaken_rule. 2:{ intros ? ? []. subst. - apply H1. + apply H2. } - clear H1. - rewrite H0. - rewrite <- H2. - clear H0 H2. + clear H2. + rewrite H1. + rewrite <- H3. + clear H1 H3. apply better_r_put_lhs. remove_get_in_lhs. remove_get_in_lhs. @@ -1872,6 +2031,130 @@ Section Hacspec. unfold lift_to_both. unfold repr. apply r. + + split ; [ | discriminate]. + intros. + subst p. + destruct_pre. + eexists. + split. + 2:{ + rewrite [set_heap _ (translate_var s_id' v) a]set_heap_commut. + reflexivity. + (apply injective_translate_var2 ; + red ; + intros ; + subst ; + apply (precneq_O s_id)). + etransitivity. + apply preceq_I. + etransitivity. + apply H2. + apply H. + } + eexists. + split. + 2:{ + rewrite [set_heap _ (translate_var s_id' v) a]set_heap_commut. + reflexivity. + (apply injective_translate_var2 ; + red ; + intros ; + subst ; + apply (precneq_O s_id)). + etransitivity. + apply preceq_I. + etransitivity. + apply H2. + apply H. + } + eexists. + split. + 2:{ + rewrite [set_heap _ (translate_var s_id' v) a]set_heap_commut. + reflexivity. + (apply injective_translate_var2 ; + red ; + intros ; + subst ; + apply (precneq_O s_id)). + etransitivity. + apply preceq_I. + etransitivity. + apply H2. + apply H. + } + eexists. + split. + 2:{ + rewrite [set_heap _ (translate_var s_id' v) a]set_heap_commut. + reflexivity. + (apply injective_translate_var2 ; + red ; + intros ; + subst ; + apply (precneq_O s_id)). + etransitivity. + apply preceq_I. + etransitivity. + apply H2. + apply H. + } + + eexists. + split. + 2:{ + reflexivity. + }. + + eexists. + split. + 2:{ + reflexivity. + }. + + eexists. + split. + 2:{ + reflexivity. + }. + + eexists. + split. + 2:{ + reflexivity. + } + + split. + eexists. + split. + 2:{ + rewrite [set_heap _ (translate_var s_id' v) a]set_heap_commut. + reflexivity. + (apply injective_translate_var2 ; + red ; + intros ; + subst ; + apply (precneq_O s_id)). + etransitivity. + apply preceq_I. + etransitivity. + apply H2. + apply H. + } + eapply H_pdisj. + reflexivity. + etransitivity. + apply H. + etransitivity. + apply preceq_O. + etransitivity. + apply preceq_I. + apply H2. + apply H22. + + all: try reflexivity. + apply H22. admit. } @@ -1879,28 +2162,28 @@ Section Hacspec. intros. apply rpre_hypothesis_rule. intros. - destruct H0. - destruct H0. - destruct H0. + destruct H1. + destruct H1. + destruct H1. eapply rpre_weaken_rule. 2:{ intros ? ? []. subst. - apply H1. + apply H2. } - clear H1. - destruct H0. + clear H2. + destruct H1. destruct a₁0. rewrite ct_T_prod_propegate. simpl. - inversion H1. + inversion H2. subst. - clear H1. + clear H2. apply better_r_put_lhs ; fold @bind. apply better_r_put_lhs ; fold @bind. simpl in p. subst p. rewrite !coerce_to_choice_type_K. - rewrite !zero_extend_u. + (* rewrite !zero_extend_u. *) remove_get_in_lhs. apply better_r. eapply r_get_remember_lhs. intros. remove_get_in_lhs. @@ -1916,7 +2199,7 @@ Section Hacspec. apply r_ret. intros. - + destruct_pre. rewrite !ct_T_id. repeat remove_T_ct. rewrite !zero_extend_u. From e8a173b7e04ddd29758f14528760e29c2fc76707 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Thu, 26 Jan 2023 17:43:23 +0100 Subject: [PATCH 355/383] Correct Invariant? --- theories/Jasmin/examples/aes/aes_hac.v | 1159 ++++++++++++++++-------- 1 file changed, 762 insertions(+), 397 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes_hac.v b/theories/Jasmin/examples/aes/aes_hac.v index a0226b0a..f8bd7d79 100644 --- a/theories/Jasmin/examples/aes/aes_hac.v +++ b/theories/Jasmin/examples/aes/aes_hac.v @@ -585,7 +585,7 @@ Section Hacspec. Qed. Theorem loop_eq : - forall {acc : ChoiceEquality} v d (j : nat) id0 s_id id' y I L (y0 : @int U32 -> acc -> code L I acc) (pre : _ -> _ -> precond) c, + forall {acc : ChoiceEquality} v d (j : nat) id0 s_id id' y I L (y0 : @int U32 -> acc -> code L I acc) (pre : _ -> _ -> precond) (inv : _ -> _ -> precond) c, (0 < d) -> (id0 ⪯ s_id) -> (forall id, id ⪯ id' id) -> @@ -595,15 +595,16 @@ Section Hacspec. ⊢ ⦃ set_lhs (translate_var id0 (v_var v)) (@truncate_el chInt (vtype (v_var v)) (S k)) - (pre k c) ⦄ + (fun '(h0, h1) => (inv k c) (h0, h1) /\ (pre k c) (h0, h1)) ⦄ y s_id ≈ y0 (repr (Pos.of_succ_nat k)) c - ⦃ λ '(_, h0) '(v1, h1), (pre (S k) (ct_T v1)) (h0, h1) ⦄) -> - ⊢ ⦃ (pre j c) ⦄ + ⦃ λ '(_, h0) '(v1, h1), (inv (S k) (ct_T v1) (h0, h1)) /\ (pre (S k) (ct_T v1)) (h0, h1) ⦄) -> + (forall j c, pdisj (pre j c) id0 fset0) -> + ⊢ ⦃ fun '(h0, h1) => inv j c (h0, h1) /\ (pre j c) (h0, h1) ⦄ (translate_for v [seq (1 + Z.of_nat i)%Z | i <- iota j d] id0 (fun id => (id' id, y id)) s_id) ≈ (foldi_ (I := I) (L := L) (d) (repr (S j)) y0 c ) - ⦃ fun '(v0, h0) '(v1, h1) => (pre (j + d) (ct_T v1)) (h0, h1) ⦄ . + ⦃ fun '(v0, h0) '(v1, h1) => (inv (j + d) (ct_T v1) (h0, h1)) /\ (pre (j + d) (ct_T v1)) (h0, h1) ⦄ . Proof. intros. generalize dependent j. @@ -617,20 +618,29 @@ Section Hacspec. simpl. apply better_r_put_lhs. setoid_rewrite T_ct_id. + (* apply rpre_hypothesis_rule'. *) + (* intros. *) + (* destruct_pre. *) + (* clear H7. *) + (* eapply rpre_weaken_rule. *) + (* 2:{ intros ? ? []. subst. eapply H3. reflexivity. easy. apply H8. } *) eapply r_bind. - apply H2. - apply H0. - lia. - - intros. - apply r_ret. - intros. rewrite addn1. apply H3. + { + apply H2. + apply H0. + lia. + } + { + intros. + apply r_ret. + intros. rewrite addn1. apply H4. + } - rewrite <- foldi__move_S. rewrite unfold_translate_for. apply better_r_put_lhs. setoid_rewrite bind_rewrite. - apply r_bind with (mid := λ '(_, h0) '(v1, h1), (pre (j.+1) (ct_T v1)) (h0, h1)). + apply r_bind with (mid := λ '(_, h0) '(v1, h1), (inv (j.+1) (ct_T v1) ((h0, h1)) /\ (pre (j.+1) (ct_T v1) (h0, h1)))). 2:{ intros. @@ -660,14 +670,22 @@ Section Hacspec. apply better_r. unfold ".1". - pose (IHd ltac:(easy) (id' s_id) H3 (ct_T a₁) j.+1). + pose (IHd ltac:(easy) (id' s_id) H4 (ct_T a₁) j.+1 ). rewrite <- addSnnS. - apply r. - intros. - apply H2. - apply H4. - lia. + (* eapply rpre_weak_hypothesis_rule'. *) + (* intros ? ? []. *) + (* eapply rpre_weaken_rule. *) + (* 2:{ intros ? ? []. apply H8. }. *) + (* clear H6. *) + + apply r ; clear r. + { + intros. + apply H2. + apply H5. + lia. + } } unfold ".2". apply H2. @@ -1641,8 +1659,8 @@ Section Hacspec. is_state (keys_expand rkey) ⦃ fun '(v0, h0) '(v1, h1) => (exists o1, v0 = [('array; o1)] - /\ (((chArray_get U128 o1 10 (wsize_size U128)) - = is_pure (seq_index (A := @int U128) v1 (lift_to_both0 (repr 10)))))) /\ pre (h0, h1) ⦄. + /\ (forall k, k <= 10 -> ((chArray_get U128 o1 k (wsize_size U128)) + = is_pure (seq_index (A := @int U128) v1 (lift_to_both0 (repr k)))))) /\ pre (h0, h1) ⦄. Proof. intros H_pdisj. set (JKEYS_EXPAND _ _). @@ -1654,7 +1672,6 @@ Section Hacspec. subst r. rewrite !zero_extend_u. - apply better_r, r_put_lhs, better_r. remove_get_in_lhs. apply better_r. eapply r_get_remember_lhs. intros. @@ -1682,21 +1699,25 @@ Section Hacspec. end. Transparent is_state. Transparent is_pure. + set (Hacspec_Lib_Pre.seq_new_ _ _). + + rewrite !zero_extend_u. + rewrite !coerce_to_choice_type_K. + rewrite bind_rewrite. apply better_r_put_rhs. rewrite bind_rewrite. apply better_r_put_rhs. + set (temp2 := repr 0) at 1 2. apply better_r_put_rhs. apply better_r_put_lhs. set (tr_app_sopn_tuple _ _ _). cbn in s. - set (repr 0) at 8. - assert (s = t) by now apply word_ext. + assert (s = temp2) by now apply word_ext. generalize dependent s. - generalize dependent t. intros. subst. @@ -1713,238 +1734,660 @@ Section Hacspec. rewrite bind_assoc. - rewrite !coerce_to_choice_type_K. - rewrite !zero_extend_u. + (* rewrite !coerce_to_choice_type_K. *) + (* rewrite !zero_extend_u. *) set (set_lhs _ _ _). - set (Hacspec_Lib_Pre.seq_push _ _) in *. - set (set_lhs ($$"rkeys.335") _) in p. - pattern 0%Z in p0. - set 0%Z in p0. - subst p0. - pattern (t0) in p. + + set (gl := _). + + subst t. + (* set (set_lhs ($$"rkeys.335") _) in p. *) + (* pattern 0%Z in p0. *) + (* set 0%Z in p0. *) + (* subst p0. *) + pattern (rkey) in p. set (fun _ => _) in p. - pattern (rkey) in y. + set (rkeys := Hacspec_Lib_Pre.seq_push _ _) in *. + pattern (rkeys) in y. set (fun _ => _) in y. subst y. - pattern (t) in y0. + pattern (temp2) in y0. set (fun _ => _) in y0. subst y0. - pattern (z) in y. - set (fun _ => _) in y. + (* pattern (z) in y. *) + (* set (fun _ => _) in y. *) + (* subst y. *) + (* rename y into y0. *) + pose (p0 := fun (n : nat) '(rkeys, rkey, temp2) => y temp2 rkeys rkey). + (* subst y0. *) subst y. - pose (fun n '(t0, rkey, t) => y0 n t rkey t0). - replace p with (p0 0 (t0, rkey, t)) by reflexivity. + subst gl. + replace p with (p0 0 (rkeys, rkey, temp2)) by reflexivity. + subst p. - eapply (@r_bind _ _ _ _ _ _ _ _ _ (λ '(v0, h0) '(v1, h1), (p0 10 v1) (h0, h1))). + pose (fun n v1 '(s₀, s₁) => + ⊢ ⦃ fun '(h0 , h1) => (p0 n v1) (s₀ , s₁) -> (p0 n v1) (h0 , h1) ⦄ + v ← get (translate_var id0 + {| vtype := sarr 176; vname := "rkeys.335" |}) ;; + ret (trunc_list [sarr 176] [totce v]) ≈ + ret ((fst (fst v1))) + ⦃ λ '(v0, h0) '(v1, h1), + (exists o1, v0 = [('array; o1)] + /\ (forall k, k <= n -> + ((chArray_get U128 o1 k (wsize_size U128)) + = is_pure (seq_index (A := @int U128) v1 (lift_to_both0 (repr k)))))) /\ pre (h0, h1) ⦄). + + apply rpre_weaken_rule with (pre := (λ '(h0, h1), (P 0 (rkeys, rkey, temp2) (h0, h1)) /\ (p0 0 (rkeys, rkey, temp2)) (h0, h1))). 2:{ - intros. - subst p. - subst p0. - set 10. - subst y0. + subst P. hnf. - destruct a₁. - destruct s. - rewrite bind_rewrite. - - apply better_r_get_remind_lhs with (v := chArray_set x AAscale n s1). - unfold Remembers_lhs , rem_lhs. intros ? ? ?. + split ; [ | apply H ]. + apply rpre_hypothesis_rule'. + intros ? ? ?. + eapply rpre_weaken_rule. + 2:{ intros ? ? []. subst. apply H0. apply H. } clear H. + subst p0 ; hnf. + + apply better_r. + apply r_get_remind_lhs with (v := chArray_set x AAscale 0 rkey). + unfold Remembers_lhs. + intros. + destruct_pre. + repeat (rewrite get_set_heap_neq ; [ | apply injective_translate_var3 ; reflexivity ]). destruct_pre. repeat (rewrite get_set_heap_neq ; [ | apply injective_translate_var3 ; reflexivity ]). rewrite get_set_heap_eq. reflexivity. - rewrite ct_T_prod_propegate. - rewrite ct_T_prod_propegate. - - unfold trunc_list. - unfold map. - unfold zip. - unfold totce. - unfold jasmin_translate.encode. - unfold truncate_el. - rewrite !coerce_to_choice_type_K. - unfold ".π2". - apply r_ret. intros. + destruct_pre. + destruct_pre. split. - { - destruct_pre. - eexists. + - eexists. split. - - repeat (rewrite get_set_heap_neq ; [ | apply injective_translate_var3 ; reflexivity ]). - reflexivity. - - intros. - set (get_heap H11 ($$"rkeys.335")). - simpl in s2. - pose (chArray_get_set_eq U128 s2 10 s1). - rewrite e. - admit. - } - { - destruct_pre. - pdisj_apply H_pdisj. - - rewrite in_fset. + reflexivity. + intros [] ; [ | discriminate ]. intros _. + simpl. + repeat (rewrite get_set_heap_neq ; [ | apply injective_translate_var3 ; reflexivity ]). + rewrite !coerce_to_choice_type_K. + pose chArray_get_set_eq. + rewrite e. + subst rkeys. + reflexivity. + - pdisj_apply H_pdisj. + + rewrite in_fset. now rewrite mem_head. - - rewrite in_fset. + + rewrite in_fset. rewrite in_cons ; simpl. now rewrite mem_head. - - rewrite in_fset. + + rewrite in_fset. rewrite in_cons ; simpl. rewrite in_cons ; simpl. rewrite mem_head. now rewrite Bool.orb_true_r. - - rewrite in_fset. + + rewrite in_fset. now rewrite mem_head. - } } - (* simpl. *) - - intros. + eapply (r_bind) with (mid := (λ '(v0, h0) '(v1, h1), P 10 v1 (h0, h1) /\ (p0 10 v1) (h0, h1))). + 2:{ + intros. + subst P. + destruct a₁. + destruct s. + rewrite ct_T_prod_propegate. + rewrite ct_T_prod_propegate. + subst p0. + hnf. - set (fun (_ : p_id) => _). - set (fun (_ : int_type) (_ : _ * _ * _) => _). + rewrite bind_rewrite. - rewrite !coerce_typed_code_K. - rewrite bind_rewrite. - rewrite bind_rewrite. + eapply rpre_weak_hypothesis_rule'. + intros ? ? []. + eapply rpre_weaken_rule. + 2:{ intros ? ? []. apply H2. }. + clear H0. + unfold ".1" in H. + set (set_lhs _ _ _) in *. + eapply rpre_hypothesis_rule'. + intros. + eapply rpre_weaken_rule. + apply H. + intros ? ? []. + subst. + intros. + apply H0. + } - unfold foldi_both', foldi_both, lift_scope, is_state at 1, lift_code_scope, prog, is_state at 1, foldi. - unfold foldi_pre ; replace (unsigned _ - unsigned _)%Z with 10%Z by reflexivity. - replace (Z.to_nat (11 - 1)) with 10 by reflexivity. - replace (Pos.to_nat 10) with 10 by reflexivity. + { + (* simpl. *) - subst y1. - subst p. - subst t0. + intros. - apply (@loop_eq (seq int128 '× int '× int) _ 10 0 _ _ _ _ _ _ _ p0). - { easy. } - { apply preceq_I. } - { intros. etransitivity. apply preceq_O. apply preceq_O. } - { - intros. + set (fun (_ : p_id) => _). + set (fun (_ : int_type) (_ : _ * _ * _) => _). - subst y. - subst y0. - subst p0. - hnf. + rewrite !coerce_typed_code_K. + rewrite bind_rewrite. + rewrite bind_rewrite. - remove_get_in_lhs. - rewrite bind_assoc. - destruct c as [? []]. - destruct t0 as []. + unfold foldi_both', foldi_both, lift_scope, is_state at 1, lift_code_scope, prog, is_state at 1, foldi. + unfold foldi_pre ; replace (unsigned _ - unsigned _)%Z with 10%Z by reflexivity. + replace (Z.to_nat (11 - 1)) with 10 by reflexivity. + replace (Pos.to_nat 10) with 10 by reflexivity. - set (set_lhs _ _ _). - eapply r_bind with (mid := λ '(v0, h0) '(v1, h1), - (∃ o1 : (λ i : choice_type_choiceType, i) 'int, - v0 = [('int; o1)] ∧ repr o1 = v1) ∧ - p (h0, h1)) ; subst p. - { - set [ _ ]. + (* subst rkeys. *) - replace (translate_call ssprove_jasmin_prog 12%positive - static_funs (s_id~1)%positive l) - with - (get_translated_static_fun ssprove_jasmin_prog 12%positive - static_funs (s_id~1)%positive l). - 2:{ - Transparent translate_call. - simpl. - cbn. - repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). - reflexivity. - Opaque translate_call. - } - subst l. - replace (totce _) - with (@existT choice_type (fun t : choice_type => Choice.sort (chElement t)) chInt (Pos.of_succ_nat k)). - 2:{ - cbn. - repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). - unfold totce. - rewrite Zpos_P_of_succ_nat. - reflexivity. - } - apply (rcon_eq (s_id~1)%positive k). + apply (@loop_eq (seq int128 '× int '× int) _ 10 0 _ _ _ _ _ _ _ p0 P). + { easy. } + { apply preceq_I. } + { intros. etransitivity. apply preceq_O. apply preceq_O. } { - split ; [ | discriminate ]. intros. - - destruct_pre. - eexists. - split. - 2:{ - rewrite [set_heap _ (translate_var s_id' v) a]set_heap_commut. - reflexivity. - (apply injective_translate_var2 ; - red ; - intros ; - subst ; - apply (precneq_I s_id)). - etransitivity. - apply H2. - apply H. + subst y. + subst y0. + hnf. + + (* assert (pdisj (p0 k.+1 v1) id0 *) + (* (fset *) + (* [(seq_choice int128; 279); (@int_choice U128; 278); *) + (* (@int_choice U128; 277)])). *) + (* split. intros. *) + + + remove_get_in_lhs. + rewrite bind_assoc. + destruct c as [? []]. + destruct t as []. + + set (set_lhs _ _ _). + eapply r_bind with (mid := λ '(v0, h0) '(v1, h1), + (∃ o1 : (λ i : choice_type_choiceType, i) 'int, + v0 = [('int; o1)] ∧ repr o1 = v1) ∧ + p (h0, h1)) ; subst p. + { + set [ _ ]. + + replace (translate_call ssprove_jasmin_prog 12%positive + static_funs (s_id~1)%positive l) + with + (get_translated_static_fun ssprove_jasmin_prog 12%positive + static_funs (s_id~1)%positive l). + 2:{ + Transparent translate_call. + simpl. + cbn. + repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). + reflexivity. + Opaque translate_call. + } + subst l. + replace (totce _) + with (@existT choice_type (fun t : choice_type => Choice.sort (chElement t)) chInt (Pos.of_succ_nat k)). + 2:{ + cbn. + repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). + unfold totce. + rewrite Zpos_P_of_succ_nat. + reflexivity. + } + apply (rcon_eq (s_id~1)%positive k). + { + split ; [ | discriminate ]. + intros. + + destruct_pre. + eexists. + split. + 2:{ + rewrite ![set_heap _ (translate_var s_id' v) a]set_heap_commut ; + (reflexivity || + (apply injective_translate_var2 ; + red ; + intros ; + subst ; + apply (precneq_I s_id) ; + etransitivity ; [ apply H2 | apply H] )). + } + split. + { + set (set_lhs _ _ _ ) in *. + eapply rpre_weaken_rule. + apply H6. clear H6. + hnf. + intros. + apply H1 ; clear H1. + clear H7. + subst p. + destruct_pre. + eexists ; split. + 2:{ + rewrite set_heap_commut. + reflexivity. + (apply injective_translate_var2 ; + red ; + intros ; + subst ; + apply (precneq_I s_id)). + etransitivity. + apply H2. + apply H. + } + eexists ; split. + 2:{ + rewrite set_heap_commut. + reflexivity. + (apply injective_translate_var2 ; + red ; + intros ; + subst ; + apply (precneq_I s_id)). + etransitivity. + apply H2. + apply H. + } + eexists ; split. + 2:{ + reflexivity. + } + eexists ; split. + 2:{ + reflexivity. + } + eexists ; split. + 2:{ + reflexivity. + } + eexists ; split. + 2:{ + reflexivity. + } + split. + eexists ; split. + 2:{ + rewrite set_heap_commut. + reflexivity. + (apply injective_translate_var2 ; + red ; + intros ; + subst ; + apply (precneq_I s_id)). + etransitivity. + apply H2. + apply H. + } + eapply H_pdisj. + reflexivity. + etransitivity. + apply H. + etransitivity. + apply preceq_I. + apply H2. + eapply H18. + + simpl. + rewrite get_set_heap_neq. + reflexivity. + (apply injective_translate_var2 ; + red ; + intros ; + subst ; + apply (precneq_I s_id)). + etransitivity. + apply H2. + apply H. + } + destruct_pre. + eexists ; split. + 2:{ + rewrite <- set_heap_commut. + reflexivity. + (apply injective_translate_var2 ; + red ; + intros ; + subst ; + apply (precneq_I s_id)). + etransitivity. + apply H2. + apply H. + } + eexists ; split. + 2:{ + rewrite <- set_heap_commut. + reflexivity. + (apply injective_translate_var2 ; + red ; + intros ; + subst ; + apply (precneq_I s_id)). + etransitivity. + apply H2. + apply H. + } + eexists ; split. + 2:{ + reflexivity. + } + eexists ; split. + 2:{ + reflexivity. + } + eexists ; split. + 2:{ + reflexivity. + } + eexists ; split. + 2:{ + reflexivity. + } + split. + eexists ; split. + 2:{ + rewrite <- set_heap_commut. + reflexivity. + (apply injective_translate_var2 ; + red ; + intros ; + subst ; + apply (precneq_I s_id)). + etransitivity. + apply H2. + apply H. + } + pdisj_apply H_pdisj. + etransitivity. + apply H. + etransitivity. + apply preceq_I. + apply H2. + simpl. + rewrite get_set_heap_neq. + reflexivity. + (apply injective_translate_var2 ; + red ; + intros ; + subst ; + apply (precneq_I s_id)). + etransitivity. + apply H2. + apply H. + } + easy. } - eexists. - split. + + intros. + apply rpre_hypothesis_rule. + intros. + destruct H1. + destruct H1. + destruct H1. + eapply rpre_weaken_rule. 2:{ - rewrite [set_heap _ (translate_var s_id' v) a]set_heap_commut. - reflexivity. - (apply injective_translate_var2 ; - red ; - intros ; - subst ; - apply (precneq_I s_id)). - etransitivity. + intros ? ? []. subst. apply H2. - apply H. - } - eexists. - split. - 2:{ - rewrite [set_heap _ (translate_var s_id' v) a]set_heap_commut. + clear H2. + rewrite H1. + rewrite <- H3. + clear H1 H3. + apply better_r_put_lhs. + remove_get_in_lhs. + subst p0. + remove_get_in_lhs. + remove_get_in_lhs. fold @bind. + + rewrite bind_assoc. + set (set_lhs _ _ _). + eapply r_bind with (mid := λ '(v0, h0) '(v1, h1), + (∃ o1 o2 : 'word U128, + v0 = [('word U128; o1); ('word U128; o2)] ∧ (o1, o2) = v1) + ∧ p (h0, h1)). + { + + pose (key_expand_eq (s_id~0~1)%positive x0 t0 (mkWord (nbits:=U128) (toword:=toword) i) p). + unfold JKEY_EXPAND in r. + + replace (translate_call _ _ _ _ _) + with + (get_translated_static_fun ssprove_jasmin_prog 11%positive + static_funs (s_id~0~1)%positive [('int; x0); ('word U128; t0); ('word U128; (mkWord (nbits:=U128) (toword:=toword) i))]). + 2:{ + Transparent translate_call. + simpl. + cbn. + repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). + rewrite !zero_extend_u. + reflexivity. + Opaque translate_call. + } + unfold lift_to_both0. + + unfold is_pure. + unfold lift_to_both. + unfold repr. + apply r. + + split ; [ | discriminate]. + intros. + subst p. + destruct_pre. + eexists. + split. + 2:{ + rewrite [set_heap _ (translate_var s_id' v) a]set_heap_commut. + reflexivity. + (apply injective_translate_var2 ; + red ; + intros ; + subst ; + apply (precneq_O s_id)). + etransitivity. + apply preceq_I. + etransitivity. + apply H2. + apply H. + } + eexists. + split. + 2:{ + rewrite [set_heap _ (translate_var s_id' v) a]set_heap_commut. + reflexivity. + (apply injective_translate_var2 ; + red ; + intros ; + subst ; + apply (precneq_O s_id)). + etransitivity. + apply preceq_I. + etransitivity. + apply H2. + apply H. + } + split. + { + set (set_lhs _ _ _ ) in *. + eapply rpre_weaken_rule. + apply H8. clear H8. + hnf. + intros. + apply H1 ; clear H1. + subst p. + destruct_pre. + eexists ; split. + 2:{ + rewrite set_heap_commut. + reflexivity. + (apply injective_translate_var2 ; + red ; + intros ; + subst ; + apply (precneq_O s_id)). + etransitivity. + apply preceq_I. + etransitivity. + apply H2. + apply H. + } + eexists ; split. + 2:{ + rewrite set_heap_commut. + reflexivity. + (apply injective_translate_var2 ; + red ; + intros ; + subst ; + apply (precneq_O s_id)). + etransitivity. + apply preceq_I. + etransitivity. + apply H2. + apply H. + } + eexists ; split. + 2:{ + reflexivity. + } + eexists ; split. + 2:{ + reflexivity. + } + eexists ; split. + 2:{ + reflexivity. + } + eexists ; split. + 2:{ + reflexivity. + } + split. + eexists ; split. + 2:{ + rewrite set_heap_commut. + reflexivity. + (apply injective_translate_var2 ; + red ; + intros ; + subst ; + apply (precneq_O s_id)). + etransitivity. + apply preceq_I. + etransitivity. + apply H2. + apply H. + } + eapply H_pdisj. + reflexivity. + etransitivity. + apply H. + etransitivity. + apply preceq_O. + etransitivity. + apply preceq_I. + apply H2. + eapply H23. + + simpl. + rewrite get_set_heap_neq. + reflexivity. + (apply injective_translate_var2 ; + red ; + intros ; + subst ; + apply (precneq_O s_id)). + etransitivity. + apply preceq_I. + etransitivity. + apply H2. + apply H. + } + eexists. + split. + 2:{ + rewrite [set_heap _ (translate_var s_id' v) a]set_heap_commut. + reflexivity. + (apply injective_translate_var2 ; + red ; + intros ; + subst ; + apply (precneq_O s_id)). + etransitivity. + apply preceq_I. + etransitivity. + apply H2. + apply H. + } + eexists. + split. + 2:{ + rewrite [set_heap _ (translate_var s_id' v) a]set_heap_commut. + reflexivity. + (apply injective_translate_var2 ; + red ; + intros ; + subst ; + apply (precneq_O s_id)). + etransitivity. + apply preceq_I. + etransitivity. + apply H2. + apply H. + } + + eexists. + split. + 2:{ + reflexivity. + }. + + eexists. + split. + 2:{ + reflexivity. + }. + + eexists. + split. + 2:{ + reflexivity. + }. + + eexists. + split. + 2:{ + reflexivity. + } + + split. + eexists. + split. + 2:{ + rewrite [set_heap _ (translate_var s_id' v) a]set_heap_commut. + reflexivity. + (apply injective_translate_var2 ; + red ; + intros ; + subst ; + apply (precneq_O s_id)). + etransitivity. + apply preceq_I. + etransitivity. + apply H2. + apply H. + } + eapply H_pdisj. reflexivity. - (apply injective_translate_var2 ; - red ; - intros ; - subst ; - apply (precneq_I s_id)). etransitivity. - apply H2. apply H. - } - eexists. - split. - 2:{ - reflexivity. - } - eexists. - split. - 2:{ - reflexivity. - } - - split_post. - all: try reflexivity. - 2:{ - rewrite ![set_heap _ (translate_var s_id' v) a]set_heap_commut. - reflexivity. - (apply injective_translate_var2 ; - red ; - intros ; - subst ; - apply (precneq_I s_id)). etransitivity. + apply preceq_O. + etransitivity. + apply preceq_I. apply H2. - apply H. - } - 2:{ + apply H23. + rewrite ![set_heap _ (translate_var s_id' v) a]set_heap_commut. repeat (rewrite get_set_heap_neq ; [ | apply injective_translate_var3 ; reflexivity ]). symmetry. @@ -1953,259 +2396,181 @@ Section Hacspec. rewrite get_set_heap_neq. reflexivity. (apply injective_translate_var2 ; - red ; - intros ; - subst ; - apply (precneq_I s_id)). + red ; + intros ; + subst ; + apply (precneq_O s_id)). + etransitivity. + apply preceq_I. etransitivity. apply H2. apply H. (apply injective_translate_var2 ; - red ; - intros ; - subst ; - apply (precneq_I s_id)). + red ; + intros ; + subst ; + apply (precneq_O s_id)). + etransitivity. + apply preceq_I. etransitivity. apply H2. apply H. } - pdisj_apply H_pdisj. - etransitivity. - apply H. - etransitivity. - apply preceq_I. - apply H2. - } - easy. - } + intros. + apply rpre_hypothesis_rule. + intros. + destruct H1. + destruct H1. + destruct H1. + eapply rpre_weaken_rule. + 2:{ + intros ? ? []. subst. + apply H2. + } + clear H2. + destruct H1. + destruct a₁0. + rewrite ct_T_prod_propegate. + simpl. + inversion H2. + subst. + clear H2. + apply better_r_put_lhs ; fold @bind. + apply better_r_put_lhs ; fold @bind. + simpl in p. + subst p. + rewrite !coerce_to_choice_type_K. + (* rewrite !zero_extend_u. *) + remove_get_in_lhs. + apply better_r. eapply r_get_remember_lhs. intros. + remove_get_in_lhs. - intros. - apply rpre_hypothesis_rule. - intros. - destruct H1. - destruct H1. - destruct H1. - eapply rpre_weaken_rule. - 2:{ - intros ? ? []. subst. - apply H2. - } - clear H2. - rewrite H1. - rewrite <- H3. - clear H1 H3. - apply better_r_put_lhs. - remove_get_in_lhs. - remove_get_in_lhs. - remove_get_in_lhs. fold @bind. + rewrite !coerce_to_choice_type_K. + rewrite !zero_extend_u. + apply better_r_put_lhs. - rewrite bind_assoc. - set (set_lhs _ _ _). - eapply r_bind with (mid := λ '(v0, h0) '(v1, h1), - (∃ o1 o2 : 'word U128, - v0 = [('word U128; o1); ('word U128; o2)] ∧ (o1, o2) = v1) - ∧ p (h0, h1)). - { - pose key_expand_eq. - unfold JKEY_EXPAND in r. - specialize (r (s_id~0~1)%positive x0 t1 (mkWord (nbits:=U128) (toword:=toword) i) p). + apply better_r_put_rhs. + apply better_r_put_rhs. + apply better_r_put_rhs. - replace (translate_call _ _ _ _ _) - with - (get_translated_static_fun ssprove_jasmin_prog 11%positive - static_funs (s_id~0~1)%positive [('int; x0); ('word U128; t1); ('word U128; (mkWord (nbits:=U128) (toword:=toword) i))]). + apply r_ret. + intros. + destruct_pre. + rewrite !ct_T_id. + repeat remove_T_ct. + rewrite !zero_extend_u. + + destruct_pre. + split. + { + admit. + } + eexists. + split. 2:{ - Transparent translate_call. - simpl. - cbn. - repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). - rewrite !zero_extend_u. + rewrite set_heap_commut. reflexivity. - Opaque translate_call. + apply injective_translate_var3. + easy. + } + eexists. + split. + 2:{ + repeat (rewrite get_set_heap_neq ; [ | apply injective_translate_var3 ; reflexivity ]). + rewrite get_set_heap_eq. + admit. } - unfold lift_to_both0. - - unfold is_pure. - unfold lift_to_both. - unfold repr. - apply r. - - split ; [ | discriminate]. - intros. - subst p. - destruct_pre. eexists. split. 2:{ - rewrite [set_heap _ (translate_var s_id' v) a]set_heap_commut. reflexivity. - (apply injective_translate_var2 ; - red ; - intros ; - subst ; - apply (precneq_O s_id)). - etransitivity. - apply preceq_I. - etransitivity. - apply H2. - apply H. } + eexists. split. 2:{ - rewrite [set_heap _ (translate_var s_id' v) a]set_heap_commut. reflexivity. - (apply injective_translate_var2 ; - red ; - intros ; - subst ; - apply (precneq_O s_id)). - etransitivity. - apply preceq_I. - etransitivity. - apply H2. - apply H. - } + } eexists. split. 2:{ - rewrite [set_heap _ (translate_var s_id' v) a]set_heap_commut. reflexivity. + } + exists ( set_heap + (set_heap + ((set_heap H29 (int_choice; 277) t1) + ) (int_choice; 278) + (mkWord (nbits:=U128) (toword:=toword) i)) + (seq_choice int128; 279) t0). + split. + 2:{ + symmetry. + rewrite set_heap_commut. + f_equal. + rewrite set_heap_commut. + f_equal. + rewrite set_heap_commut. + reflexivity. + easy. + easy. + (apply injective_translate_var2 ; - red ; - intros ; - subst ; - apply (precneq_O s_id)). + red ; + intros ; + subst ; + apply (precneq_O s_id)). etransitivity. apply preceq_I. etransitivity. apply H2. apply H. - } - eexists. - split. - 2:{ - rewrite [set_heap _ (translate_var s_id' v) a]set_heap_commut. - reflexivity. (apply injective_translate_var2 ; - red ; - intros ; - subst ; - apply (precneq_O s_id)). + red ; + intros ; + subst ; + apply (precneq_O s_id)). etransitivity. apply preceq_I. etransitivity. apply H2. apply H. - } - - eexists. - split. - 2:{ - reflexivity. - }. - eexists. - split. - 2:{ - reflexivity. - }. - eexists. + } split. - 2:{ - reflexivity. - }. - eexists. split. 2:{ reflexivity. } - - split. - eexists. - split. 2:{ - rewrite [set_heap _ (translate_var s_id' v) a]set_heap_commut. + repeat (rewrite get_set_heap_neq ; [ | apply injective_translate_var3 ; reflexivity ]). reflexivity. - (apply injective_translate_var2 ; - red ; - intros ; - subst ; - apply (precneq_O s_id)). - etransitivity. - apply preceq_I. - etransitivity. - apply H2. - apply H. } - eapply H_pdisj. - reflexivity. - etransitivity. - apply H. - etransitivity. - apply preceq_O. - etransitivity. - apply preceq_I. - apply H2. - apply H22. - - all: try reflexivity. - apply H22. - admit. - } - intros. - apply rpre_hypothesis_rule. - intros. - destruct H1. - destruct H1. - destruct H1. - eapply rpre_weaken_rule. - 2:{ - intros ? ? []. subst. + + + (apply injective_translate_var2 ; + red ; + intros ; + subst ; + apply (precneq_O s_id)). + etransitivity. + apply preceq_I. + etransitivity. apply H2. + apply H. } - clear H2. - destruct H1. - destruct a₁0. - rewrite ct_T_prod_propegate. - simpl. - inversion H2. - subst. - clear H2. - apply better_r_put_lhs ; fold @bind. - apply better_r_put_lhs ; fold @bind. - simpl in p. - subst p. - rewrite !coerce_to_choice_type_K. - (* rewrite !zero_extend_u. *) - remove_get_in_lhs. - apply better_r. eapply r_get_remember_lhs. intros. - remove_get_in_lhs. - - rewrite !coerce_to_choice_type_K. - rewrite !zero_extend_u. - apply better_r_put_lhs. - apply better_r_put_rhs. - apply better_r_put_rhs. - apply better_r_put_rhs. - apply r_ret. - intros. - destruct_pre. - rewrite !ct_T_id. - repeat remove_T_ct. - rewrite !zero_extend_u. admit. } + Admitted. Lemma aes_enc_eq id0 state key (pre : precond) : From 4f68fcd62fe76d19416dc6c65fdc5ac70e5286ba Mon Sep 17 00:00:00 2001 From: "Benjamin S. Hvass" Date: Fri, 27 Jan 2023 08:23:53 +0100 Subject: [PATCH 356/383] fix xor example --- theories/Jasmin/examples/xor/xor.v | 210 +++++++++++++---------------- 1 file changed, 96 insertions(+), 114 deletions(-) diff --git a/theories/Jasmin/examples/xor/xor.v b/theories/Jasmin/examples/xor/xor.v index e8b186d0..67083828 100644 --- a/theories/Jasmin/examples/xor/xor.v +++ b/theories/Jasmin/examples/xor/xor.v @@ -540,117 +540,99 @@ Section Jasmin_OTP. Qed. End Jasmin_OTP. -(* From Hacspec Require Import Xor_Both. *) -(* From Hacspec Require Import Hacspec_Lib_Pre. *) -(* consider exporting this from Hacspec_Lib_Pre? Needed for int64 : Type coercion *) -(* From Hacspec Require Import ChoiceEquality. *) - -(* Section JasminHacspec. *) - -(* Definition state_xor (x y : int64) : raw_code int64 := *) -(* xor (x, y). *) - -(* Definition pure_xor (x y : int64) : raw_code int64 := *) -(* lift_to_code (L:=fset0) (I := [interface]) (is_pure (xor (x, y))). *) - -(* Definition state_pure_xor x y := code_eq_proof_statement (xor (x, y)). *) -(* Notation jazz_xor w1 w2 := ((snd tr_xor) 1%positive [('word U64; w1); ('word U64; w2)]). *) -(* Notation hdtc res := (coerce_to_choice_type ('word U64) (hd ('word U64 ; chCanonical _) res).π2). *) - -(* Lemma rxor_pure : forall w1 w2, *) -(* ⊢ ⦃ true_precond ⦄ *) -(* res ← jazz_xor w1 w2 ;; *) -(* ret (hdtc res) *) -(* ≈ *) -(* pure_xor w1 w2 *) -(* ⦃ fun '(a, h₀) '(b, h₁) => (a = b) ⦄. *) -(* Proof. *) -(* intros w1 w2. *) -(* simpl_fun. *) - -(* repeat setjvars. *) - -(* Ltac neq_loc_auto ::= eapply injective_translate_var3; auto. *) - -(* repeat clear_get. *) - -(* rewrite !zero_extend_u. *) -(* eapply r_put_lhs with (pre := fun _ => Logic.True). *) -(* repeat eapply r_put_lhs. *) -(* eapply r_ret. *) - -(* intros ? ? ?. *) -(* rewrite coerce_to_choice_type_K. *) -(* reflexivity. *) -(* Qed. *) - -(* Lemma rxor_state : forall w1 w2, *) -(* ⊢ ⦃ true_precond ⦄ *) -(* res ← ((snd tr_xor) 1%positive [('word U64; w1); ('word U64; w2)]) ;; *) -(* ret (coerce_to_choice_type ('word U64) (hd ('word U64 ; chCanonical _) res).π2) *) -(* ≈ *) -(* state_xor w1 w2 *) -(* ⦃ fun '(a, _) '(b, _) => (a = b) ⦄. *) -(* Proof. *) -(* intros w1 w2. *) -(* unfold state_xor. *) - -(* simpl_fun. *) -(* repeat setjvars. *) -(* repeat clear_get. *) - -(* rewrite !zero_extend_u. *) -(* rewrite coerce_to_choice_type_K. *) -(* eapply r_put_vs_put with (pre := fun _ => Logic.True). *) -(* repeat eapply r_put_vs_put. *) -(* repeat eapply r_put_rhs. *) -(* eapply r_ret. *) -(* easy. *) -(* Qed. *) - -(* Lemma val_sym : *) -(* ∀ {A : ord_choiceType} {pre : precond} *) -(* {c₀ : raw_code A} {c₁ : raw_code A}, *) -(* ⊢ ⦃ true_precond ⦄ *) -(* c₀ *) -(* ≈ *) -(* c₁ *) -(* ⦃ fun '(a, _) '(b, _) => a = b ⦄ -> *) -(* ⊢ ⦃ fun '(h0, h1) => true_precond (h0, h1) ⦄ *) -(* c₁ *) -(* ≈ *) -(* c₀ *) -(* ⦃ fun '(a, _) '(b, _) => a = b ⦄. *) -(* Proof. *) -(* intros. *) -(* eapply rsymmetry. *) -(* eapply rpost_weaken_rule. *) -(* 1: exact H. *) -(* intros [] []; auto. *) -(* Qed. *) - -(* Lemma rxor_pure_via_state : forall w1 w2, *) -(* ⊢ ⦃ true_precond ⦄ *) -(* res ← ((snd tr_xor) 1%positive [('word U64; w1); ('word U64; w2)]) ;; *) -(* ret (coerce_to_choice_type ('word U64) (hd ('word U64 ; chCanonical _) res).π2) *) -(* ≈ *) -(* pure_xor w1 w2 *) -(* ⦃ fun '(a, _) '(b, _) => (a = b) ⦄. *) -(* Proof. *) -(* intros w1 w2. *) -(* eapply @r_transL_val with (c₀ := state_xor w1 w2) (P := Logic.True). *) -(* - repeat constructor. *) -(* - repeat constructor. *) -(* - repeat constructor. *) -(* - eapply rsymmetry. *) -(* eapply rpost_weaken_rule. *) -(* 1: eapply rxor_state. *) -(* intros [] []; auto. *) -(* - pose proof state_pure_xor. *) -(* eapply rpre_weaken_rule. *) -(* 1: eapply rpost_weaken_rule. *) -(* 1: eapply state_pure_xor. *) -(* 2: auto. *) -(* intros [] []. unfold pre_to_post_ret; intuition subst. *) -(* Qed. *) -(* End JasminHacspec. *) +From Hacspec Require Import Hacspec_Xor. +From Hacspec Require Import Hacspec_Lib_Pre. +(* consider exporting this from Hacspec_Lib_Pre? Needed for int64 : Type coercion *) +From Hacspec Require Import ChoiceEquality. + +Section JasminHacspec. + + Definition state_xor (x y : int64) : raw_code int64 := + xor x y. + + Definition pure_xor (x y : int64) : raw_code int64 := + lift_to_code (L:=fset0) (I := [interface]) (is_pure (xor x y)). + + Definition state_pure_xor x y := code_eq_proof_statement (xor x y). + Notation hdtc res := (coerce_to_choice_type ('word U64) (hd ('word U64 ; chCanonical _) res).π2). + + Lemma rxor_pure : forall id0 w1 w2, + ⊢ ⦃ true_precond ⦄ + res ← JXOR id0 w1 w2 ;; + ret (hdtc res) + ≈ + pure_xor w1 w2 + ⦃ fun '(a, h₀) '(b, h₁) => (a = b) ⦄. + Proof. + intros id0 w1 w2. + simpl_fun. + + repeat setjvars. + + Ltac neq_loc_auto ::= eapply injective_translate_var3; auto. + + repeat clear_get. + + rewrite !zero_extend_u. + repeat eapply better_r_put_lhs. + repeat eapply r_put_lhs. + eapply r_ret. + + intros ? ? ?. + rewrite coerce_to_choice_type_K. + reflexivity. + Qed. + + Lemma rxor_state : forall id0 w1 w2, + ⊢ ⦃ fun '(_, _) => Logic.True ⦄ + res ← JXOR id0 w1 w2 ;; + ret (hdtc res) + ≈ + state_xor w1 w2 + ⦃ fun '(a, _) '(b, _) => (a = b) ⦄. + Proof. + intros id0 w1 w2. + unfold state_xor. + + simpl_fun. + repeat setjvars. + repeat clear_get. + + rewrite !zero_extend_u. + rewrite coerce_to_choice_type_K. + eapply r_put_vs_put with (pre := fun _ => _). + repeat eapply r_put_vs_put. + Transparent Hacspec_Lib.lift3_both. + simpl. + eapply r_put_rhs. + eapply r_ret. + easy. + Qed. + + Lemma rxor_pure_via_state : forall id0 w1 w2, + ⊢ ⦃ fun '(_, _) => Logic.True ⦄ + res ← JXOR id0 w1 w2 ;; + ret (hdtc res) + ≈ + pure_xor w1 w2 + ⦃ fun '(a, _) '(b, _) => (a = b) ⦄. + Proof. + intros id0 w1 w2. + unfold true_precond. + (* eapply rpre_weaken_rule. *) + eapply r_transL_val with (c₀ := state_xor w1 w2). + - repeat constructor. + - repeat constructor. + - repeat constructor. + - eapply rsymmetry. + eapply rpost_weaken_rule. + 1: eapply rxor_state. + intros [] []; auto. + - pose proof state_pure_xor. + eapply rpre_weaken_rule. + 1: eapply rpost_weaken_rule. + 1: eapply state_pure_xor. + 2: auto. + intros [] []. unfold pre_to_post_ret; intuition subst. + Qed. +End JasminHacspec. From 2d1bbf97ae89e23e2b0d309f692478626be88410 Mon Sep 17 00:00:00 2001 From: "Benjamin S. Hvass" Date: Fri, 27 Jan 2023 15:57:02 +0100 Subject: [PATCH 357/383] different formulation of valid stack --- theories/Jasmin/examples/xor/xor.v | 5 +- theories/Jasmin/jasmin_translate.v | 90 ++++++++++++++++++++++++++---- 2 files changed, 81 insertions(+), 14 deletions(-) diff --git a/theories/Jasmin/examples/xor/xor.v b/theories/Jasmin/examples/xor/xor.v index 67083828..4df570e6 100644 --- a/theories/Jasmin/examples/xor/xor.v +++ b/theories/Jasmin/examples/xor/xor.v @@ -600,11 +600,10 @@ Section JasminHacspec. rewrite !zero_extend_u. rewrite coerce_to_choice_type_K. - eapply r_put_vs_put with (pre := fun _ => _). - repeat eapply r_put_vs_put. + eapply r_put_lhs with (pre := fun _ => _). + repeat eapply r_put_lhs. Transparent Hacspec_Lib.lift3_both. simpl. - eapply r_put_rhs. eapply r_ret. easy. Qed. diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 0aa78a0a..c604cd5a 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -2194,6 +2194,35 @@ Definition stack_cons s_id (stf : stack_frame) : stack_frame := (stf.1.1.1, stf.1.1.2, s_id, stf.1.2 :: stf.2). Notation "s_id ⊔ stf" := (stack_cons s_id stf) (at level 60). +Definition stf_disjoint m_id s_id s_st := disj m_id s_id /\ forall s_id', List.In s_id' s_st -> disj m_id s_id'. + (* (forall stf : stack_frame, List.In stf st -> ). *) + +Definition valid_stack_frame '(vm, m_id, s_id, s_st) (h : heap) := + rel_vmap vm m_id h /\ + m_id ⪯ s_id /\ + valid s_id h /\ + ~ List.In s_id s_st /\ + List.NoDup s_st /\ + (forall s_id', List.In s_id' s_st -> valid s_id' h) /\ + (forall s_id', List.In s_id' s_st -> m_id ⪯ s_id') /\ + (forall s_id', List.In s_id' s_st -> disj s_id s_id') /\ + (forall s_id' s_id'', List.In s_id' s_st -> List.In s_id'' s_st -> s_id' <> s_id'' -> disj s_id' s_id''). + +(* Lemma valid_stack_frame_push '(vm, m_id, s_id, s_st) (h : heap) : *) + +(* valid_stack_frame (vm, m_id, s_id, s_st) h -> *) +(* valid_stack_frame (vm, m_id, s_id', s_id :: s_st). *) +(* cons *) + +Inductive valid_stack' : stack -> heap -> Prop := +| valid_stack'_nil : forall h, valid_stack' [::] h +| valid_stack'_cons : + forall h stf st, + valid_stack' st h -> + (forall stf' : stack_frame, List.In stf' st -> stf_disjoint stf.1.1.2 stf'.1.2 stf'.2) -> + valid_stack_frame stf h -> + valid_stack' (stf :: st) h. + Inductive valid_stack : stack -> heap -> Prop := | valid_stack_nil : forall h, valid_stack [::] h | valid_stack_new : forall st vm m_id s_id h, @@ -2212,17 +2241,6 @@ Inductive valid_stack : stack -> heap -> Prop := (forall s_id'', List.In s_id'' s_st -> disj s_id' s_id'') -> valid_stack ((vm, m_id, s_id', s_id :: s_st) :: st) h. -Definition valid_stack_frame '(vm, m_id, s_id, s_st) (h : heap) := - rel_vmap vm m_id h /\ - m_id ⪯ s_id /\ - valid s_id h /\ - ~ List.In s_id s_st /\ - List.NoDup s_st /\ - (forall s_id', List.In s_id' s_st -> valid s_id' h) /\ - (forall s_id', List.In s_id' s_st -> m_id ⪯ s_id') /\ - (forall s_id', List.In s_id' s_st -> disj s_id s_id') /\ - (forall s_id' s_id'', List.In s_id' s_st -> List.In s_id'' s_st -> s_id' <> s_id'' -> disj s_id' s_id''). - Lemma valid_stack_single vm m_id s_id s_st h : valid_stack_frame (vm, m_id, s_id, s_st) h -> valid_stack [::(vm, m_id, s_id, s_st)] h. @@ -2423,6 +2441,56 @@ Proof. eapply IHs_st; eauto. Qed. +Lemma valid_stack'_spec st h : + valid_stack' st h <-> valid_stack st h. +Proof. + split. + - intros. + induction st. + + constructor. + + inversion H; subst. + destruct a as [[[vm m_id] s_id] s_st]. + revert s_id H H3 H5. + induction s_st; intros; destruct H5 as [h1 [h2 [h3 [h4 [h5 [h6 [h7 [h8]]]]]]]]; auto. + * intros; constructor; auto; try easy. + * assert (valid_stack_frame (vm, m_id, a, s_st) h). + { repeat split; eauto. + { apply h7. left. auto. } + { apply h6; left; auto. } + { inversion h5; auto. } + { inversion h5; auto. } + { intros. eapply h6. right; auto. } + { intros; apply h7; right; auto. } + { intros. apply H0. 1: left; auto. + 1: right; auto. + inversion h5; subst. + intros contra; subst. auto. } + { intros. apply H0. 1: right; auto. + 1: right; auto. + auto. } } + constructor; auto. + ** apply IHs_st; auto. + constructor; auto. + ** intros contra. apply h4. right; auto. + ** apply disj_sym. eapply h8. + 1: left; auto. + ** intros. + apply h8. right; auto. + - intros. + induction st. + 1: constructor. + destruct a as [[[vm m_id] s_id] s_st]. + eapply invert_valid_stack in H as [H [H1]]. + constructor. + + apply IHst. easy. + + intros. + unfold stf_disjoint. + intros. + eapply H1. + easy. + + assumption. +Qed. + Ltac invert_stack st hst hdisj hevm hpre hvalid hnin hnodup hvalid1 hpre1 hdisj1 hdisj2 := apply invert_valid_stack in st as [hst [hdisj [hevm [hpre [hvalid [hnin [hnodup [hvalid1 [hpre1 [hdisj1 hdisj2]]]]]]]]]]. From 6983be837a60f45f35211e356637c35493d2d22b Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Mon, 30 Jan 2023 02:11:47 +0100 Subject: [PATCH 358/383] Keys expand done, few helper lemmas not done --- theories/Jasmin/examples/aes/aes_hac.v | 1319 +++++++++++++----------- 1 file changed, 693 insertions(+), 626 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes_hac.v b/theories/Jasmin/examples/aes/aes_hac.v index f8bd7d79..9f79f257 100644 --- a/theories/Jasmin/examples/aes/aes_hac.v +++ b/theories/Jasmin/examples/aes/aes_hac.v @@ -587,10 +587,10 @@ Section Hacspec. Theorem loop_eq : forall {acc : ChoiceEquality} v d (j : nat) id0 s_id id' y I L (y0 : @int U32 -> acc -> code L I acc) (pre : _ -> _ -> precond) (inv : _ -> _ -> precond) c, (0 < d) -> - (id0 ⪯ s_id) -> - (forall id, id ⪯ id' id) -> + (id0 ≺ s_id) -> + (forall id, id ≺ id' id) -> (forall k c s_id, - (id0 ⪯ s_id) -> + (id0 ≺ s_id) -> j <= k < j + d -> ⊢ ⦃ set_lhs (translate_var id0 (v_var v)) @@ -599,7 +599,9 @@ Section Hacspec. y s_id ≈ y0 (repr (Pos.of_succ_nat k)) c ⦃ λ '(_, h0) '(v1, h1), (inv (S k) (ct_T v1) (h0, h1)) /\ (pre (S k) (ct_T v1)) (h0, h1) ⦄) -> - (forall j c, pdisj (pre j c) id0 fset0) -> + (forall k c s_id, (id0 ≺ s_id) -> + (* j <= k < j + d -> *) + pdisj (pre k c) s_id fset0) -> ⊢ ⦃ fun '(h0, h1) => inv j c (h0, h1) /\ (pre j c) (h0, h1) ⦄ (translate_for v [seq (1 + Z.of_nat i)%Z | i <- iota j d] id0 (fun id => (id' id, y id)) s_id) ≈ @@ -661,25 +663,25 @@ Section Hacspec. now zify. } - assert (id0 ⪯ id' s_id). + assert (id0 ≺ id' s_id). { - etransitivity. - apply H0. - apply H1. + split. + - etransitivity. + apply H0. + apply H1. + - red ; intros. + clear -H0 H1 H4. + subst. + pose (prec_precneq (id' s_id) (s_id)). + apply n. + apply H0. + apply H1. } apply better_r. unfold ".1". - pose (IHd ltac:(easy) (id' s_id) H4 (ct_T a₁) j.+1 ). rewrite <- addSnnS. - - (* eapply rpre_weak_hypothesis_rule'. *) - (* intros ? ? []. *) - (* eapply rpre_weaken_rule. *) - (* 2:{ intros ? ? []. apply H8. }. *) - (* clear H6. *) - - apply r ; clear r. + apply (IHd ltac:(easy) (id' s_id) H4). (* (ct_T a₁) j.+1 ). *) { intros. apply H2. @@ -693,6 +695,93 @@ Section Hacspec. lia. Qed. + Theorem loop_eq_simpl : + forall {acc : ChoiceEquality} v d (j : nat) id0 s_id id' y I L (y0 : @int U32 -> acc -> code L I acc) (pre : _ -> precond) c, + (0 < d) -> + (forall k c s_id, + j <= k < j + d -> + ⊢ ⦃ set_lhs + (translate_var id0 (v_var v)) + (@truncate_el chInt (vtype (v_var v)) (S k)) + (pre c) ⦄ + y s_id + ≈ y0 (repr (Pos.of_succ_nat k)) c + ⦃ λ '(_, h0) '(v1, h1), (pre (ct_T v1)) (h0, h1) ⦄) -> + ⊢ ⦃ (pre c) ⦄ + (translate_for v + [seq (1 + Z.of_nat i)%Z | i <- iota j d] id0 (fun id => (id' id, y id)) s_id) ≈ + (foldi_ (I := I) (L := L) (d) (repr (S j)) y0 c ) + ⦃ fun '(v0, h0) '(v1, h1) => (pre (ct_T v1)) (h0, h1) ⦄ . + Proof. + intros. + generalize dependent j. + generalize dependent c. + generalize dependent s_id. + induction d ; intros. + discriminate. + + destruct d. + - rewrite unfold_translate_for. + simpl. + apply better_r_put_lhs. + setoid_rewrite T_ct_id. + (* apply rpre_hypothesis_rule'. *) + (* intros. *) + (* destruct_pre. *) + (* clear H7. *) + (* eapply rpre_weaken_rule. *) + (* 2:{ intros ? ? []. subst. eapply H3. reflexivity. easy. apply H8. } *) + eapply r_bind. + { + apply H0. + lia. + } + { + intros. + apply r_ret. + intros. apply H1. + } + - rewrite <- foldi__move_S. + rewrite unfold_translate_for. + + apply better_r_put_lhs. + setoid_rewrite bind_rewrite. + apply r_bind with (mid := λ '(_, h0) '(v1, h1), (pre (ct_T v1) (h0, h1))). + + 2:{ + intros. + replace (Hacspec_Lib_Pre.int_add (repr j.+1) one) + with + (@repr U32 j.+2). + 2:{ + simpl. + cbn. + unfold Hacspec_Lib_Pre.int_add, add_word. + rewrite mkwordK. + cbn. + apply word_ext. + rewrite Zplus_mod. + rewrite Zmod_mod. + rewrite <- Zplus_mod. + f_equal. + now zify. + } + + apply better_r. + unfold ".1". + epose (IHd (ltac:(easy)) (id' s_id) (ct_T a₁) (j.+1) ). + apply r. + { + intros. + apply H0. + lia. + } + } + unfold ".2". + apply H0. + lia. + Qed. + Lemma nat_to_be_range_is_subword : forall {WS : wsize.wsize} {WS_inp : wsize.wsize} (n : @int WS_inp) i `{H_WS : WS <= WS_inp} , (@repr WS (nat_be_range WS (toword n) i) = word.subword (i * WS) WS n). Proof. intros. @@ -1651,6 +1740,114 @@ Section Hacspec. | |- set_rhs _ _ _ _ => eexists end. + Definition seq_to_list_id : forall {A} (t : seq A), fmap_of_seq (seq_to_list A t) = t. + Proof. + Admitted. + + Definition fmap_of_seq_id : forall {A : ChoiceEquality} (t : list A), seq_to_list A (fmap_of_seq t) = t. + Proof. + Admitted. + + Definition seq_push_list_app : forall {A} (t : seq A) (s : A), (seq_to_list A (Hacspec_Lib_Pre.seq_push t s) = seq_to_list A t ++ [s]). + Proof. + intros. + pose (seq_to_list_id t). + replace (t) with (fmap_of_seq (seq_to_list _ t)) at 2. + replace (seq_to_list A (fmap_of_seq (seq_to_list A t)) ++ [s]) + with + (seq_to_list A (fmap_of_seq ((seq_to_list A t) ++ [s]))). + reflexivity. + rewrite e. + rewrite fmap_of_seq_id. + reflexivity. + Qed. + + Theorem chArray_set_idemp : ∀ (ws : wsize.wsize) (a : 'array) (i : Z) (w : word.word ws), chArray_set (chArray_set a AAscale i w) AAscale i w = chArray_set a AAscale i w. + Proof. + Admitted. + + Theorem chArray_set_neq : ∀ (ws : wsize.wsize) (a : 'array) (i j : Z) (v w : word.word ws), + i != j -> + chArray_set (chArray_set a AAscale i w) AAscale j v = + chArray_set (chArray_set a AAscale j v) AAscale i w. + Proof. + Admitted. + + + Definition seq_to_arr (X : seq uint128) : FMap.fmap_type Z_ordType U8.-word := + let l0 := (unzip2 X) in + mkfmap (zip (ziota 0 (size l0)) (seq.foldr (fun x y => y ++ (split_vec U8 x)) [] l0)). + + Definition seq_upd_from_arr (X : seq uint128) (v : 'array) : FMap.fmap_type Z_ordType U8.-word := + let l0 := (seq_to_list int128 X) in + foldr (fun kv m => (chArray_set m AAscale kv.1 kv.2)) v (rev (zip (ziota 0 (Z.of_nat (size l0))) (l0))). + + Lemma seq_udp_from_arr_push : forall a b c, + (seq_upd_from_arr (Hacspec_Lib_Pre.seq_push a b) c) + = + (chArray_set (seq_upd_from_arr a c) AAscale (Z.of_nat (size (seq_to_list int128 a))) b). + Proof. + intros. + unfold seq_upd_from_arr. + simpl. + + (* assert ((unzip2 (Hacspec_Lib_Pre.seq_push a b)) = unzip2 a ++ [b]) by admit. *) + (* rewrite H. *) + + rewrite seq_push_list_app. + rewrite size_cat. + rewrite Nat2Z.inj_add. + rewrite Z.add_1_r. + rewrite ziotaS_cat. + rewrite !Z.add_0_l. + + rewrite zip_cat. + rewrite rev_cat. + + unfold zip at 1. + unfold rev at 1, catrev. + rewrite foldr_cat. + + unfold foldr at 1. + reflexivity. + rewrite size_ziota. + rewrite Nat2Z.id. + reflexivity. + + lia. + Qed. + + Ltac solve_var_neq := + ((now apply injective_translate_var3) || + (apply injective_translate_var2 ; red ; intros ; subst)). + Ltac eexists_set_heap := + eexists ; split ; [ | + match goal with + | [ |- context [ + set_heap _ _ ?d + = set_heap _ _ ?d + ] ] => + reflexivity + end || + match goal with + | [ |- context [ + set_heap ?a ?b ?c + = set_heap _ _ ?e + ] ] => + rewrite [set_heap a b c]set_heap_commut ; [ reflexivity | + solve_var_neq ] + end]. + + Ltac solve_in_fset := + rewrite in_fset ; repeat (reflexivity || (rewrite mem_head) || (now rewrite Bool.orb_true_r) || (now rewrite Bool.orb_true_l) || rewrite in_cons ; simpl). + + Ltac remove_get_set_heap := + match goal with + | [ |- context [ get_heap (set_heap _ ?a _) ?a ] ] => + rewrite get_set_heap_eq + end || + rewrite get_set_heap_neq. + Lemma keys_expand_eq id0 rkey (pre : precond) : (pdisj pre id0 (fset ([(seq_choice int128; 279) ; (@int_choice U128; 278) ; (@int_choice U128; 277)]))) -> ⊢ ⦃ pre ⦄ @@ -1672,7 +1869,7 @@ Section Hacspec. subst r. rewrite !zero_extend_u. - apply better_r, r_put_lhs, better_r. + apply better_r_put_lhs. remove_get_in_lhs. apply better_r. eapply r_get_remember_lhs. intros. @@ -1734,49 +1931,97 @@ Section Hacspec. rewrite bind_assoc. - (* rewrite !coerce_to_choice_type_K. *) - (* rewrite !zero_extend_u. *) - set (set_lhs _ _ _). - set (gl := _). - - subst t. - (* set (set_lhs ($$"rkeys.335") _) in p. *) - (* pattern 0%Z in p0. *) - (* set 0%Z in p0. *) - (* subst p0. *) - pattern (rkey) in p. - set (fun _ => _) in p. set (rkeys := Hacspec_Lib_Pre.seq_push _ _) in *. - pattern (rkeys) in y. - set (fun _ => _) in y. - subst y. - pattern (temp2) in y0. - set (fun _ => _) in y0. - subst y0. - (* pattern (z) in y. *) - (* set (fun _ => _) in y. *) - (* subst y. *) - (* rename y into y0. *) - pose (p0 := fun (n : nat) '(rkeys, rkey, temp2) => y temp2 rkeys rkey). - (* subst y0. *) - subst y. + + (* epose (fun l n => foldl (fun y x => (chArray_set y AAscale (fst x) (snd x))) x (zip (ziota 0 n) l)). *) + + pose (p0 := (λ (n : nat) '(rkeys, rkey, temp2) '(h0, h1), + set_lhs (translate_var id0 {| vtype := sword U128; vname := "temp2.336" |}) temp2 + (set_lhs (translate_var id0 {| vtype := sarr 176; vname := "rkeys.335" |}) (seq_upd_from_arr rkeys x) + (set_rhs (seq_choice int128; 279) rkeys + (set_rhs (int_choice; 278) temp2 + (set_rhs (int_choice; 277) rkey + ( + (λ '(s₀, s₁), + (set_lhs (translate_var id0 {| vtype := sword U128; vname := "key.334" |}) rkey pre) + (s₀, s₁))))))) (h0, h1)) : nat -> key_list_t * 'word U128 * int → precond). + + (* pose (p0 := (λ (n : nat) '(rkeys, rkey, temp2) '(h0, h1), *) + (* set_lhs (translate_var id0 {| vtype := sword U128; vname := "temp2.336" |}) temp2 *) + (* (set_lhs (translate_var id0 {| vtype := sarr 176; vname := "rkeys.335" |}) (chArray_set x AAscale n rkey) *) + (* (set_rhs (seq_choice int128; 279) rkeys *) + (* (set_rhs (int_choice; 278) temp2 *) + (* (set_rhs (int_choice; 277) rkey *) + (* (set_rhs (seq_choice int128; 279) *) + (* (Hacspec_Lib_Pre.seq_new_ *) + (* (repr 0) (unsigned (lift_to_both0 (@repr U128 0)))) *) + (* (λ '(s₀, s₁), *) + (* (set_lhs (translate_var id0 {| vtype := sword U128; vname := "key.334" |}) rkey pre *) + (* ⋊ rem_lhs ($$"rkeys.335") x) *) + (* (s₀, s₁))))))) (h0, h1)) : nat -> key_list_t * 'word U128 * int → precond). *) + subst gl. - replace p with (p0 0 (rkeys, rkey, temp2)) by reflexivity. + + apply rpre_weaken_rule with (pre := (λ '(h0, h1), (p0 0 (rkeys, rkey, temp2)) (h0, h1))). + 2:{ + intros. + subst p. + subst p0. + + destruct_pre. + eexists_set_heap. + eexists ; split. + 2:{ + remove_get_set_heap. + subst rkeys. + unfold seq_upd_from_arr. + simpl. + reflexivity. + + solve_var_neq. + } + eexists ; split. + 2:{ + reflexivity. + } + eexists ; split. + 2:{ + reflexivity. + } + eexists ; split. + 2:{ + reflexivity. + } + eexists ; split. + 2:{ + reflexivity. + } + eapply H_pdisj. + solve_in_fset. + assumption. + } subst p. - pose (fun n v1 '(s₀, s₁) => - ⊢ ⦃ fun '(h0 , h1) => (p0 n v1) (s₀ , s₁) -> (p0 n v1) (h0 , h1) ⦄ - v ← get (translate_var id0 - {| vtype := sarr 176; vname := "rkeys.335" |}) ;; - ret (trunc_list [sarr 176] [totce v]) ≈ - ret ((fst (fst v1))) - ⦃ λ '(v0, h0) '(v1, h1), - (exists o1, v0 = [('array; o1)] - /\ (forall k, k <= n -> - ((chArray_get U128 o1 k (wsize_size U128)) - = is_pure (seq_index (A := @int U128) v1 (lift_to_both0 (repr k)))))) /\ pre (h0, h1) ⦄). + pose (P := fun (n : nat) (v0 : key_list_t * 'word U128 * @int U128) => fun '(h0, h1) => pre (h0, h1) /\ (forall i, i <= n -> (chArray_get U128 + (get_heap h0 + (translate_var id0 + {| vtype := sarr 176; vname := "rkeys.335" |})) i + (wsize_size U128)) = Hacspec_Lib_Pre.seq_index (fst (fst v0)) (repr (Z.of_nat i))) /\ size (Hacspec_Lib_Pre.seq_to_list _ (fst (fst v0))) = n.+1). + + (* /\ to_arr_int (get_heap h0 ($$"rkeys.335")) = (fst (fst v0))). *) + (* pose (P := fun n v1 '(s₀, s₁) => *) + (* ⊢ ⦃ fun '(h0 , h1) => (p0 n v1) (s₀ , s₁) -> (p0 n v1) (h0 , h1) ⦄ *) + (* v ← get (translate_var id0 *) + (* {| vtype := sarr 176; vname := "rkeys.335" |}) ;; *) + (* ret (trunc_list [sarr 176] [totce v]) ≈ *) + (* ret ((fst (fst v1))) *) + (* ⦃ λ '(v0, h0) '(v1, h1), *) + (* (exists o1, v0 = [('array; o1)] *) + (* /\ (forall k, k <= n -> *) + (* ((chArray_get U128 o1 k (wsize_size U128)) *) + (* = is_pure (seq_index (A := @int U128) v1 (lift_to_both0 (repr k)))))) /\ pre (h0, h1) ⦄). *) apply rpre_weaken_rule with (pre := (λ '(h0, h1), (P 0 (rkeys, rkey, temp2) (h0, h1)) /\ (p0 0 (rkeys, rkey, temp2)) (h0, h1))). 2:{ @@ -1784,39 +2029,11 @@ Section Hacspec. hnf. intros ? ? ?. split ; [ | apply H ]. - apply rpre_hypothesis_rule'. - intros ? ? ?. - eapply rpre_weaken_rule. - 2:{ intros ? ? []. subst. apply H0. apply H. } clear H. - subst p0 ; hnf. - - apply better_r. - apply r_get_remind_lhs with (v := chArray_set x AAscale 0 rkey). - unfold Remembers_lhs. - intros. - destruct_pre. - repeat (rewrite get_set_heap_neq ; [ | apply injective_translate_var3 ; reflexivity ]). - destruct_pre. - repeat (rewrite get_set_heap_neq ; [ | apply injective_translate_var3 ; reflexivity ]). - rewrite get_set_heap_eq. - reflexivity. - apply r_ret. - intros. - destruct_pre. - destruct_pre. - split. - - eexists. - split. - reflexivity. - intros [] ; [ | discriminate ]. intros _. - simpl. - repeat (rewrite get_set_heap_neq ; [ | apply injective_translate_var3 ; reflexivity ]). - rewrite !coerce_to_choice_type_K. - pose chArray_get_set_eq. - rewrite e. - subst rkeys. - reflexivity. - - pdisj_apply H_pdisj. + repeat split. + - subst p0. + hnf in H. + destruct_pre. + pdisj_apply H_pdisj. + rewrite in_fset. now rewrite mem_head. + rewrite in_fset. @@ -1827,10 +2044,22 @@ Section Hacspec. rewrite in_cons ; simpl. rewrite mem_head. now rewrite Bool.orb_true_r. - + rewrite in_fset. - now rewrite mem_head. + - intros. + simpl. + subst p0. + hnf in H. + destruct_pre. + repeat (rewrite get_set_heap_neq ; [ | apply injective_translate_var3 ; reflexivity ]) ; + rewrite get_set_heap_eq. + repeat (rewrite get_set_heap_neq ; [ | apply injective_translate_var3 ; reflexivity ]). + intros. + destruct i ; [ | easy ]. + simpl. + rewrite chArray_get_set_eq. + reflexivity. } + eapply (r_bind) with (mid := (λ '(v0, h0) '(v1, h1), P 10 v1 (h0, h1) /\ (p0 10 v1) (h0, h1))). 2:{ intros. @@ -1846,21 +2075,51 @@ Section Hacspec. eapply rpre_weak_hypothesis_rule'. intros ? ? []. - eapply rpre_weaken_rule. - 2:{ intros ? ? []. apply H2. }. - clear H0. - unfold ".1" in H. - set (set_lhs _ _ _) in *. - eapply rpre_hypothesis_rule'. - intros. - eapply rpre_weaken_rule. - apply H. - intros ? ? []. - subst. + (* eapply rpre_weaken_rule. *) + (* 2:{ intros ? ? []. apply H2. }. *) + (* clear H0. *) + (* unfold ".1" in H. *) + + + + destruct H. + eapply better_r_get_remind_lhs with (v := seq_upd_from_arr s x). + unfold Remembers_lhs , rem_lhs ; + [ intros ? ? ? ; + destruct_pre ; + repeat (rewrite get_set_heap_neq ; [ | apply injective_translate_var3 ; reflexivity ]) ; + rewrite get_set_heap_eq ]. + reflexivity. + + apply r_ret. intros. - apply H0. - } + destruct_pre. + split. + - eexists. + split. + reflexivity. + intros. + + simpl. + rewrite !coerce_to_choice_type_K. + rewrite <- H15. + repeat (rewrite get_set_heap_neq ; [ | apply injective_translate_var3 ; reflexivity ]). + rewrite get_set_heap_eq. + reflexivity. + assumption. + - pdisj_apply H_pdisj. + + rewrite in_fset. + now rewrite mem_head. + + rewrite in_fset. + rewrite in_cons ; simpl. + now rewrite mem_head. + + rewrite in_fset. + rewrite in_cons ; simpl. + rewrite in_cons ; simpl. + rewrite mem_head. + now rewrite Bool.orb_true_r. + } { (* simpl. *) @@ -1882,26 +2141,20 @@ Section Hacspec. apply (@loop_eq (seq int128 '× int '× int) _ 10 0 _ _ _ _ _ _ _ p0 P). { easy. } - { apply preceq_I. } - { intros. etransitivity. apply preceq_O. apply preceq_O. } + { apply prec_I. } + { intros. etransitivity. apply prec_O. apply prec_O. } { intros. + subst P. subst y. subst y0. hnf. - (* assert (pdisj (p0 k.+1 v1) id0 *) - (* (fset *) - (* [(seq_choice int128; 279); (@int_choice U128; 278); *) - (* (@int_choice U128; 277)])). *) - (* split. intros. *) - - remove_get_in_lhs. rewrite bind_assoc. destruct c as [? []]. - destruct t as []. + destruct t0 as []. set (set_lhs _ _ _). eapply r_bind with (mid := λ '(v0, h0) '(v1, h1), @@ -1935,188 +2188,10 @@ Section Hacspec. reflexivity. } apply (rcon_eq (s_id~1)%positive k). - { - split ; [ | discriminate ]. - intros. - destruct_pre. - eexists. - split. - 2:{ - rewrite ![set_heap _ (translate_var s_id' v) a]set_heap_commut ; - (reflexivity || - (apply injective_translate_var2 ; - red ; - intros ; - subst ; - apply (precneq_I s_id) ; - etransitivity ; [ apply H2 | apply H] )). - } - split. - { - set (set_lhs _ _ _ ) in *. - eapply rpre_weaken_rule. - apply H6. clear H6. - hnf. - intros. - apply H1 ; clear H1. - clear H7. - subst p. - destruct_pre. - eexists ; split. - 2:{ - rewrite set_heap_commut. - reflexivity. - (apply injective_translate_var2 ; - red ; - intros ; - subst ; - apply (precneq_I s_id)). - etransitivity. - apply H2. - apply H. - } - eexists ; split. - 2:{ - rewrite set_heap_commut. - reflexivity. - (apply injective_translate_var2 ; - red ; - intros ; - subst ; - apply (precneq_I s_id)). - etransitivity. - apply H2. - apply H. - } - eexists ; split. - 2:{ - reflexivity. - } - eexists ; split. - 2:{ - reflexivity. - } - eexists ; split. - 2:{ - reflexivity. - } - eexists ; split. - 2:{ - reflexivity. - } - split. - eexists ; split. - 2:{ - rewrite set_heap_commut. - reflexivity. - (apply injective_translate_var2 ; - red ; - intros ; - subst ; - apply (precneq_I s_id)). - etransitivity. - apply H2. - apply H. - } - eapply H_pdisj. - reflexivity. - etransitivity. - apply H. - etransitivity. - apply preceq_I. - apply H2. - eapply H18. - - simpl. - rewrite get_set_heap_neq. - reflexivity. - (apply injective_translate_var2 ; - red ; - intros ; - subst ; - apply (precneq_I s_id)). - etransitivity. - apply H2. - apply H. - } - destruct_pre. - eexists ; split. - 2:{ - rewrite <- set_heap_commut. - reflexivity. - (apply injective_translate_var2 ; - red ; - intros ; - subst ; - apply (precneq_I s_id)). - etransitivity. - apply H2. - apply H. - } - eexists ; split. - 2:{ - rewrite <- set_heap_commut. - reflexivity. - (apply injective_translate_var2 ; - red ; - intros ; - subst ; - apply (precneq_I s_id)). - etransitivity. - apply H2. - apply H. - } - eexists ; split. - 2:{ - reflexivity. - } - eexists ; split. - 2:{ - reflexivity. - } - eexists ; split. - 2:{ - reflexivity. - } - eexists ; split. - 2:{ - reflexivity. - } - split. - eexists ; split. - 2:{ - rewrite <- set_heap_commut. - reflexivity. - (apply injective_translate_var2 ; - red ; - intros ; - subst ; - apply (precneq_I s_id)). - etransitivity. - apply H2. - apply H. - } - pdisj_apply H_pdisj. - etransitivity. - apply H. - etransitivity. - apply preceq_I. - apply H2. - simpl. - rewrite get_set_heap_neq. - reflexivity. - (apply injective_translate_var2 ; - red ; - intros ; - subst ; - apply (precneq_I s_id)). - etransitivity. - apply H2. - apply H. - } - easy. - } + shelve. + easy. + } intros. apply rpre_hypothesis_rule. @@ -2147,13 +2222,13 @@ Section Hacspec. ∧ p (h0, h1)). { - pose (key_expand_eq (s_id~0~1)%positive x0 t0 (mkWord (nbits:=U128) (toword:=toword) i) p). + pose (key_expand_eq (s_id~0~1)%positive x0 t1 (mkWord (nbits:=U128) (toword:=toword) i) p). unfold JKEY_EXPAND in r. replace (translate_call _ _ _ _ _) with (get_translated_static_fun ssprove_jasmin_prog 11%positive - static_funs (s_id~0~1)%positive [('int; x0); ('word U128; t0); ('word U128; (mkWord (nbits:=U128) (toword:=toword) i))]). + static_funs (s_id~0~1)%positive [('int; x0); ('word U128; t1); ('word U128; (mkWord (nbits:=U128) (toword:=toword) i))]). 2:{ Transparent translate_call. simpl. @@ -2170,251 +2245,8 @@ Section Hacspec. unfold repr. apply r. - split ; [ | discriminate]. - intros. - subst p. - destruct_pre. - eexists. - split. - 2:{ - rewrite [set_heap _ (translate_var s_id' v) a]set_heap_commut. - reflexivity. - (apply injective_translate_var2 ; - red ; - intros ; - subst ; - apply (precneq_O s_id)). - etransitivity. - apply preceq_I. - etransitivity. - apply H2. - apply H. - } - eexists. - split. - 2:{ - rewrite [set_heap _ (translate_var s_id' v) a]set_heap_commut. - reflexivity. - (apply injective_translate_var2 ; - red ; - intros ; - subst ; - apply (precneq_O s_id)). - etransitivity. - apply preceq_I. - etransitivity. - apply H2. - apply H. - } - split. - { - set (set_lhs _ _ _ ) in *. - eapply rpre_weaken_rule. - apply H8. clear H8. - hnf. - intros. - apply H1 ; clear H1. - subst p. - destruct_pre. - eexists ; split. - 2:{ - rewrite set_heap_commut. - reflexivity. - (apply injective_translate_var2 ; - red ; - intros ; - subst ; - apply (precneq_O s_id)). - etransitivity. - apply preceq_I. - etransitivity. - apply H2. - apply H. - } - eexists ; split. - 2:{ - rewrite set_heap_commut. - reflexivity. - (apply injective_translate_var2 ; - red ; - intros ; - subst ; - apply (precneq_O s_id)). - etransitivity. - apply preceq_I. - etransitivity. - apply H2. - apply H. - } - eexists ; split. - 2:{ - reflexivity. - } - eexists ; split. - 2:{ - reflexivity. - } - eexists ; split. - 2:{ - reflexivity. - } - eexists ; split. - 2:{ - reflexivity. - } - split. - eexists ; split. - 2:{ - rewrite set_heap_commut. - reflexivity. - (apply injective_translate_var2 ; - red ; - intros ; - subst ; - apply (precneq_O s_id)). - etransitivity. - apply preceq_I. - etransitivity. - apply H2. - apply H. - } - eapply H_pdisj. - reflexivity. - etransitivity. - apply H. - etransitivity. - apply preceq_O. - etransitivity. - apply preceq_I. - apply H2. - eapply H23. - - simpl. - rewrite get_set_heap_neq. - reflexivity. - (apply injective_translate_var2 ; - red ; - intros ; - subst ; - apply (precneq_O s_id)). - etransitivity. - apply preceq_I. - etransitivity. - apply H2. - apply H. - } - eexists. - split. - 2:{ - rewrite [set_heap _ (translate_var s_id' v) a]set_heap_commut. - reflexivity. - (apply injective_translate_var2 ; - red ; - intros ; - subst ; - apply (precneq_O s_id)). - etransitivity. - apply preceq_I. - etransitivity. - apply H2. - apply H. - } - eexists. - split. - 2:{ - rewrite [set_heap _ (translate_var s_id' v) a]set_heap_commut. - reflexivity. - (apply injective_translate_var2 ; - red ; - intros ; - subst ; - apply (precneq_O s_id)). - etransitivity. - apply preceq_I. - etransitivity. - apply H2. - apply H. - } - - eexists. - split. - 2:{ - reflexivity. - }. + shelve. - eexists. - split. - 2:{ - reflexivity. - }. - - eexists. - split. - 2:{ - reflexivity. - }. - - eexists. - split. - 2:{ - reflexivity. - } - - split. - eexists. - split. - 2:{ - rewrite [set_heap _ (translate_var s_id' v) a]set_heap_commut. - reflexivity. - (apply injective_translate_var2 ; - red ; - intros ; - subst ; - apply (precneq_O s_id)). - etransitivity. - apply preceq_I. - etransitivity. - apply H2. - apply H. - } - eapply H_pdisj. - reflexivity. - etransitivity. - apply H. - etransitivity. - apply preceq_O. - etransitivity. - apply preceq_I. - apply H2. - apply H23. - - rewrite ![set_heap _ (translate_var s_id' v) a]set_heap_commut. - repeat (rewrite get_set_heap_neq ; [ | apply injective_translate_var3 ; reflexivity ]). - symmetry. - repeat (rewrite get_set_heap_neq ; [ | apply injective_translate_var3 ; reflexivity ]). - symmetry. - rewrite get_set_heap_neq. - reflexivity. - (apply injective_translate_var2 ; - red ; - intros ; - subst ; - apply (precneq_O s_id)). - etransitivity. - apply preceq_I. - etransitivity. - apply H2. - apply H. - (apply injective_translate_var2 ; - red ; - intros ; - subst ; - apply (precneq_O s_id)). - etransitivity. - apply preceq_I. - etransitivity. - apply H2. - apply H. } intros. @@ -2436,6 +2268,7 @@ Section Hacspec. inversion H2. subst. clear H2. + apply better_r_put_lhs ; fold @bind. apply better_r_put_lhs ; fold @bind. simpl in p. @@ -2443,7 +2276,13 @@ Section Hacspec. rewrite !coerce_to_choice_type_K. (* rewrite !zero_extend_u. *) remove_get_in_lhs. - apply better_r. eapply r_get_remember_lhs. intros. + apply better_r_get_remind_lhs with (v := seq_upd_from_arr t0 x). + unfold Remembers_lhs , rem_lhs ; + [ intros ? ? ? ; + destruct_pre ; + repeat (rewrite get_set_heap_neq ; [ | apply injective_translate_var3 ; reflexivity ]) ; + rewrite get_set_heap_eq ]. + reflexivity. remove_get_in_lhs. rewrite !coerce_to_choice_type_K. @@ -2457,121 +2296,336 @@ Section Hacspec. apply r_ret. intros. - destruct_pre. - rewrite !ct_T_id. - repeat remove_T_ct. - rewrite !zero_extend_u. + shelve. + } + shelve. + Unshelve. + { + split ; [ | discriminate]. + intros. destruct_pre. - split. - { - admit. - } - eexists. - split. - 2:{ - rewrite set_heap_commut. - reflexivity. - apply injective_translate_var3. - easy. - } - eexists. - split. + eexists_set_heap. 2:{ - repeat (rewrite get_set_heap_neq ; [ | apply injective_translate_var3 ; reflexivity ]). - rewrite get_set_heap_eq. - admit. - } - eexists. - split. - 2:{ - reflexivity. + apply (precneq_I s_id). + etransitivity. + apply H2. + apply H. } - eexists. - split. - 2:{ - reflexivity. + repeat split. + { + pdisj_apply H_pdisj. + etransitivity. + apply H. + etransitivity. + apply preceq_I. + apply H2. } - eexists. - split. - 2:{ + { + intros. + rewrite <- H6. + rewrite get_set_heap_neq. reflexivity. + solve_var_neq. + + apply (precneq_I s_id). + etransitivity. + apply H2. + apply H. + + apply H1. } - exists ( set_heap - (set_heap - ((set_heap H29 (int_choice; 277) t1) - ) (int_choice; 278) - (mkWord (nbits:=U128) (toword:=toword) i)) - (seq_choice int128; 279) t0). - split. - 2:{ - symmetry. - rewrite set_heap_commut. - f_equal. - rewrite set_heap_commut. - f_equal. - rewrite set_heap_commut. - reflexivity. - easy. + { easy. + } + { + destruct_pre. + eexists_set_heap. + eexists_set_heap. + eexists_set_heap. + eexists_set_heap. + eexists_set_heap. + eexists_set_heap. - (apply injective_translate_var2 ; - red ; - intros ; - subst ; - apply (precneq_O s_id)). + pdisj_apply H_pdisj. etransitivity. - apply preceq_I. + apply H. etransitivity. + apply preceq_I. apply H2. + all: try (apply (precneq_I s_id) ; etransitivity ; [ apply H2 | apply H ]). + } + } + { + split. + intros. + subst p. + destruct_pre. + destruct_pre. + eexists_set_heap. + eexists_set_heap. + repeat split. + { + pdisj_apply H_pdisj. + all: try solve_in_fset. + + etransitivity. apply H. - (apply injective_translate_var2 ; - red ; - intros ; - subst ; - apply (precneq_O s_id)). etransitivity. - apply preceq_I. + apply preceq_O. etransitivity. + apply preceq_I. apply H2. + } + { + intros. + rewrite <- H8. + rewrite get_set_heap_neq. + reflexivity. + solve_var_neq. + (apply (precneq_O s_id) ; etransitivity ; [apply preceq_I | etransitivity ; [ apply H2 | apply H ] ]). + apply H1. + } + { + assumption. + } + { + destruct_pre. + eexists_set_heap. + eexists_set_heap. + eexists_set_heap. + eexists_set_heap. + eexists_set_heap. + eexists_set_heap. + pdisj_apply H_pdisj. + etransitivity. apply H. + etransitivity. + apply preceq_O. + etransitivity. + apply preceq_I. + apply H2. - + all: (apply (precneq_O s_id) ; etransitivity ; [apply preceq_I | etransitivity ; [ apply H2 | apply H ] ]). } - split. - eexists. - split. - 2:{ - reflexivity. + { + (apply (precneq_O s_id) ; etransitivity ; [apply preceq_I | etransitivity ; [ apply H2 | apply H ] ]). } - 2:{ - repeat (rewrite get_set_heap_neq ; [ | apply injective_translate_var3 ; reflexivity ]). - reflexivity. + { + (apply (precneq_O s_id) ; etransitivity ; [apply preceq_I | etransitivity ; [ apply H2 | apply H ] ]). } + { + discriminate. + } + } + { + destruct_pre. + repeat split. + { + pdisj_apply H_pdisj ; solve_in_fset. + } + { + intros. + + remove_get_set_heap. + destruct (Nat.eq_dec i0 k.+1). + + subst. + unfold Hacspec_Lib_Pre.seq_index. + simpl. + unfold Hacspec_Lib_Pre.seq_push. + unfold seq_from_list. + simpl. + unfold fmap_of_seq. + rewrite size_cat. + rewrite H33. + replace (Z.to_nat _) with (k.+1). + 2:{ + cbn. + rewrite Zmod_small. + setoid_rewrite SuccNat2Pos.id_succ. + reflexivity. + do 10 (destruct k ; [ easy | ]) ; discriminate. + } + rewrite mkfmapfpE. + rewrite mem_iota. + replace (0 <= _ < _) with true . + 2:{ + simpl. + rewrite addn1. + rewrite leqnn. + reflexivity. + } + rewrite <- H33. + unfold mkfmapfp. + replace (size (seq_to_list int128 _)) with + ((size (seq_to_list int128 t0 ++ [s])%list).-1). + 2:{ + rewrite size_cat. + rewrite addn1. + simpl. reflexivity. + } + rewrite <- (size_map Some). + rewrite nth_last. + pose last_map. + rewrite map_cat. + rewrite last_cat. + simpl. + now rewrite chArray_get_set_eq. + + assert (i0 <= k) by lia. + specialize (H18 i0 H2). + assert (forall (A : ChoiceEquality) (H_default : Default A) t (s : A) i, (0 <= Z.of_nat i < modulus (wsize_size_minus_1 U32).+1)%Z -> i < size (Hacspec_Lib_Pre.seq_to_list _ t) -> Hacspec_Lib_Pre.seq_index (Hacspec_Lib_Pre.seq_push t s) (repr (Z.of_nat i)) = Hacspec_Lib_Pre.seq_index t (repr (Z.of_nat i))). + { + clear ; intros. + unfold Hacspec_Lib_Pre.seq_index. + rewrite fmap_of_seqE. + rewrite map_cat. + rewrite nth_cat. + replace (_ < _) with true. + 2:{ + rewrite (size_map). + simpl. + setoid_rewrite Zmod_small. + rewrite Nat2Z.id. + now rewrite H0. + apply H. + } + rewrite <- fmap_of_seqE. + simpl. + replace (fmap_of_seq _) with t. + reflexivity. + now rewrite seq_to_list_id. + } - (apply injective_translate_var2 ; - red ; - intros ; - subst ; - apply (precneq_O s_id)). - etransitivity. - apply preceq_I. - etransitivity. - apply H2. - apply H. - } + rewrite H3. + 2:{ + split. lia. + apply Z.lt_le_trans with (m := Z.of_nat 10). + 2: easy. + apply inj_lt. + lia. + } + 2:{ + now rewrite H33. + } + rewrite <- H18. + rewrite chArray_get_set_neq. + remove_get_set_heap. + remove_get_set_heap. + reflexivity. - admit. + { solve_var_neq. } + { lia. } + } + { + rewrite seq_push_list_app. + rewrite size_cat. + rewrite H33. + now rewrite addn1. + } + { + rewrite !zero_extend_u. + destruct_pre. + eexists_set_heap. + eexists ; split. + 2:{ + rewrite seq_udp_from_arr_push. + rewrite H33. + simpl. + reflexivity. + } + eexists ; split. + 2:{ + reflexivity. + } + eexists ; split. + 2:{ + reflexivity. + } + eexists ; split. + 2:{ + reflexivity. + } + eexists ; split. + 2:{ + reflexivity. + } + pdisj_apply H_pdisj ; solve_in_fset. + } + } + { + intros. + destruct c as [[]]. + destruct_pre. + subst p0. + hnf. + repeat split. + { + intros. + subst. + destruct_pre. + eexists ; split. + 2:{ + rewrite set_heap_commut. + reflexivity. + apply injective_translate_var2. + red ; intros. + subst. + eapply prec_precneq. + apply H. + apply H1. + } + eexists ; split. + 2:{ + rewrite set_heap_commut. + reflexivity. + apply injective_translate_var2. + red ; intros. + subst. + eapply prec_precneq. + apply H. + apply H1. + } + eexists ; split. + 2:{ + reflexivity. + } + eexists ; split. + 2:{ + reflexivity. + } + eexists ; split. + 2:{ + reflexivity. + } + eexists ; split. + 2:{ + rewrite set_heap_commut. + reflexivity. + apply injective_translate_var2. + red ; intros. + subst. + eapply prec_precneq. + apply H. + apply H1. + } + pdisj_apply H_pdisj. + etransitivity. + apply H. + apply H1. + } + { + discriminate. + } + } } - - Admitted. + Qed. Lemma aes_enc_eq id0 state key (pre : precond) : (pdisj pre id0 (fset [ (CE_loc_to_loc ( nseq int8 1 ; 0%nat ) : Location) ])) -> @@ -2671,8 +2725,21 @@ Section Hacspec. subst y0. subst p. - apply (@loop_eq int _ 9 0 _ _ _ _ _ _ _ y1) ; subst y1 ; hnf. + (* pose (P := fun (_ : nat) (_ : @int U128) (_ : heap * heap) => True). *) + (* eapply rpre_weaken_rule with (pre := (fun '(h0, h1) => (P a₁ _ (h0, h1) /\ y1 a₁ (h0, h1)))). *) + (* 2:{ *) + (* intros. *) + (* split. *) + (* - easy. *) + (* - apply H. *) + (* } *) + + epose (@loop_eq_simpl int _ 9 0 id0 id0~1 (fun id => id~1%positive) _ _ _ _ (y1) a₁ _ _). + + apply (@loop_eq_simpl int _ 9 0 id0 id0~1 (fun id => id~1%positive) _ _ _ _ y1 a₁) ; subst y1 ; hnf. { easy. } + { split. apply preceq_I. red ; intros. eapply (precneq_I id0). rewrite <- H. reflexivity. } + { intros. } { intros. remove_get_in_lhs. From 2a296fee4ee7e8678e6517fe3b4f9b75a2800978 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Mon, 30 Jan 2023 13:18:04 +0100 Subject: [PATCH 359/383] Only helper lemmas and aes_enc(_last) left --- theories/Jasmin/examples/aes/aes_hac.v | 381 +++++++++++++++++++++---- 1 file changed, 333 insertions(+), 48 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes_hac.v b/theories/Jasmin/examples/aes/aes_hac.v index 9f79f257..0d2c4470 100644 --- a/theories/Jasmin/examples/aes/aes_hac.v +++ b/theories/Jasmin/examples/aes/aes_hac.v @@ -588,7 +588,7 @@ Section Hacspec. forall {acc : ChoiceEquality} v d (j : nat) id0 s_id id' y I L (y0 : @int U32 -> acc -> code L I acc) (pre : _ -> _ -> precond) (inv : _ -> _ -> precond) c, (0 < d) -> (id0 ≺ s_id) -> - (forall id, id ≺ id' id) -> + (forall id, id ⪯ id' id) -> (forall k c s_id, (id0 ≺ s_id) -> j <= k < j + d -> @@ -696,22 +696,28 @@ Section Hacspec. Qed. Theorem loop_eq_simpl : - forall {acc : ChoiceEquality} v d (j : nat) id0 s_id id' y I L (y0 : @int U32 -> acc -> code L I acc) (pre : _ -> precond) c, + forall {acc : ChoiceEquality} v d (j : nat) id0 s_id id' y I L (y0 : @int U32 -> acc -> code L I acc) (pre : _ -> _ -> precond) c, (0 < d) -> + (id0 ≺ s_id) -> + (forall id, id ⪯ id' id) -> (forall k c s_id, + (id0 ≺ s_id) -> j <= k < j + d -> ⊢ ⦃ set_lhs (translate_var id0 (v_var v)) (@truncate_el chInt (vtype (v_var v)) (S k)) - (pre c) ⦄ + (pre k c) ⦄ y s_id ≈ y0 (repr (Pos.of_succ_nat k)) c - ⦃ λ '(_, h0) '(v1, h1), (pre (ct_T v1)) (h0, h1) ⦄) -> - ⊢ ⦃ (pre c) ⦄ + ⦃ λ '(_, h0) '(v1, h1), (pre (S k) (ct_T v1)) (h0, h1) ⦄) -> + (forall k c s_id, (id0 ≺ s_id) -> + (* j <= k < j + d -> *) + pdisj (pre k c) s_id fset0) -> + ⊢ ⦃ (pre j c) ⦄ (translate_for v [seq (1 + Z.of_nat i)%Z | i <- iota j d] id0 (fun id => (id' id, y id)) s_id) ≈ (foldi_ (I := I) (L := L) (d) (repr (S j)) y0 c ) - ⦃ fun '(v0, h0) '(v1, h1) => (pre (ct_T v1)) (h0, h1) ⦄ . + ⦃ fun '(v0, h0) '(v1, h1) => (pre (j + d) (ct_T v1)) (h0, h1) ⦄ . Proof. intros. generalize dependent j. @@ -733,20 +739,22 @@ Section Hacspec. (* 2:{ intros ? ? []. subst. eapply H3. reflexivity. easy. apply H8. } *) eapply r_bind. { + apply H2. + (* easy. *) apply H0. lia. } { intros. apply r_ret. - intros. apply H1. + intros. rewrite <- addSnnS. setoid_rewrite Nat.add_0_r. apply H4. } - rewrite <- foldi__move_S. rewrite unfold_translate_for. apply better_r_put_lhs. setoid_rewrite bind_rewrite. - apply r_bind with (mid := λ '(_, h0) '(v1, h1), (pre (ct_T v1) (h0, h1))). + apply r_bind with (mid := λ '(_, h0) '(v1, h1), (pre (S j) (ct_T v1) (h0, h1))). 2:{ intros. @@ -769,15 +777,23 @@ Section Hacspec. apply better_r. unfold ".1". - epose (IHd (ltac:(easy)) (id' s_id) (ct_T a₁) (j.+1) ). - apply r. + rewrite <- addSnnS. + eapply (IHd (ltac:(easy)) (id' s_id) ). { - intros. + eapply prec_preceq_trans. apply H0. + apply H1. + } + { + intros. + apply H2. + (* assumption. *) + apply H4. lia. } } unfold ".2". + apply H2. apply H0. lia. Qed. @@ -2651,8 +2667,8 @@ Section Hacspec. Lemma addroundkey_eq id0 (rkeys : 'array) (rkeys' : seq int128) m (pre : precond) : - (pdisj pre id0 (fset [ (@int_choice U128; 334) ])) -> - (forall k, ((chArray_get U128 rkeys k (wsize_size U128)) + (pdisj pre id0 (fset [ (@int_choice U128; 334) ; (chMap ('fin 1) (@int_choice U8); 0)])) -> + (forall k, k <= 10 -> ((chArray_get U128 rkeys k (wsize_size U128)) = is_pure (seq_index rkeys' (lift_to_both0 (repr k))))) -> (* ((forall (j : nat), *) (* forall (a : 'word U8) (b : 'word U128), *) @@ -2695,8 +2711,27 @@ Section Hacspec. Opaque is_state. Opaque is_pure. simpl. Transparent is_state. Transparent is_pure. + rewrite (rkeys_ext 0) ; [ | lia ]. + bind_jazz_bind. - { admit. (* xor *) } + { + (* xor *) + apply r_ret. + intros. + split. + reflexivity. + assumption. + } + + apply rpre_hypothesis_rule'. + intros ? ? []. + subst. + eapply rpre_weaken_rule. + 2:{ + intros ? ? []. subst. + apply H0. + } + clear H0. apply better_r_put_lhs. apply better_r_put_rhs. @@ -2719,33 +2754,52 @@ Section Hacspec. replace (Z.to_nat (10 - 1)) with 9 by reflexivity. replace (Pos.to_nat 9) with 9 by reflexivity. - set (set_rhs _ _ _). - pattern (a₁) in p. - set (fun _ => _) in p. - subst y0. - subst p. + (* set (set_rhs _ _ _). *) + (* pattern (a₁) in p. *) + (* set (fun _ => _) in p. *) + (* subst y0. *) + (* subst p. *) + + set (y1 := + fun H : int => + set_rhs (int_choice; 334) H + (set_lhs + (translate_var id0 + {| vtype := sword U128; vname := "state.327" |}) H + (set_lhs + (translate_var id0 + {| vtype := sword U128; vname := "in.326" |}) m + (set_lhs + (translate_var id0 + {| vtype := sarr 176; vname := "rkeys.325" |}) + rkeys pre)))). + eapply rpre_weaken_rule with (pre := y1 a₁). + 2:{ + intros. + subst y1 ; hnf. + destruct_pre. + eexists_set_heap. + eexists ; split. + 2:{ + rewrite set_heap_contract. + reflexivity. + } + eexists_set_heap. + eexists_set_heap. + assumption. + } - (* pose (P := fun (_ : nat) (_ : @int U128) (_ : heap * heap) => True). *) - (* eapply rpre_weaken_rule with (pre := (fun '(h0, h1) => (P a₁ _ (h0, h1) /\ y1 a₁ (h0, h1)))). *) - (* 2:{ *) - (* intros. *) - (* split. *) - (* - easy. *) - (* - apply H. *) - (* } *) - - epose (@loop_eq_simpl int _ 9 0 id0 id0~1 (fun id => id~1%positive) _ _ _ _ (y1) a₁ _ _). - - apply (@loop_eq_simpl int _ 9 0 id0 id0~1 (fun id => id~1%positive) _ _ _ _ y1 a₁) ; subst y1 ; hnf. + apply (@loop_eq_simpl int _ 9 0 _ _ _ _ _ _ _ (fun _ => y1) a₁) ; subst y1 ; hnf. { easy. } - { split. apply preceq_I. red ; intros. eapply (precneq_I id0). rewrite <- H. reflexivity. } - { intros. } + { apply prec_I. } + { reflexivity. } { intros. remove_get_in_lhs. remove_get_in_lhs. remove_get_in_lhs. + (* AES Enc loop *) bind_jazz_hac. - unfold sopn_sem. unfold sopn.get_instr_desc. @@ -2778,11 +2832,13 @@ Section Hacspec. unfold embed_tuple. unfold embed_ot. unfold unembed. + simpl set_lhs. unfold truncate_el. unfold totce. unfold ".π2". rewrite !coerce_to_choice_type_K. + set (truncate_chWord _ _). set (truncate_chWord _ _). cbn in s0. @@ -2791,28 +2847,185 @@ Section Hacspec. subst s. rewrite !zero_extend_u. - (* AES Enc loop *) + unfold seq_index. + unfold lift_to_both0. + unfold lift_to_both at 2. + unfold is_pure at 2. + unfold lift_to_both at 2. + unfold is_pure at 2. + pose (rkeys_ext (S k)). + simpl in e. + rewrite <- e ; [ | lia ]. + clear e. + + apply (aes_enc_eq s_id c (chArray_get U128 rkeys (Pos.of_succ_nat k) (wsize_size U128))). + + (* pdisj *) + { + simpl. + split. - rewrite <- rkeys_ext. - apply (aes_enc_eq id0 c (chArray_get U128 rkeys (Pos.of_succ_nat k) (wsize_size U128))). - admit. + { + intros. + destruct_pre. + eexists ; split. + 2:{ + rewrite set_heap_commut. + reflexivity. + solve_var_neq. + eapply prec_precneq. + apply H. + apply H2. + }. + + eexists_set_heap. + eexists_set_heap. + eexists_set_heap. + eexists_set_heap. + (* eexists_set_heap. *) + + pdisj_apply H_pdisj. + + etransitivity. + apply H. + apply H2. + + { + eapply prec_precneq. + apply H. + apply H2. + } + { + eapply prec_precneq. + apply H. + apply H2. + } + + { + eapply prec_precneq. + apply H. + apply H2. + } + } + { + intros. + destruct_pre. + rewrite in_fset in H1. + rewrite mem_seq1 in H1. + apply (ssrbool.elimT eqP) in H1. + subst. + destruct_pre. + eexists ; split. + 2:{ + reflexivity. + } + eexists ; split. + 2:{ + rewrite set_heap_commut. + reflexivity. + easy. + } + eexists ; split. + 2:{ + reflexivity. + } + eexists ; split. + 2:{ + reflexivity. + } + eexists ; split. + 2:{ + reflexivity. + } + eapply H_pdisj. + rewrite in_fset. + rewrite in_cons ; simpl. + now rewrite mem_head. + assumption. + } + } - apply better_r_put_rhs. apply better_r_put_lhs. + apply r_ret. intros. destruct_pre. - admit. + eexists ; split. + 2:{ + reflexivity. + } + eexists ; split. + 2:{ + reflexivity. + } + eexists ; split. + 2:{ + rewrite [set_heap (set_heap (set_heap H15 _ _) _ _) _ _]set_heap_commut. + rewrite set_heap_commut. + reflexivity. + solve_var_neq. + solve_var_neq. + } + eexists ; split. + 2:{ + rewrite [set_heap (set_heap H15 _ _) _ _]set_heap_commut. + rewrite [set_heap (set_heap (set_heap H15 _ _) _ _) _ _]set_heap_commut. + reflexivity. + solve_var_neq. + solve_var_neq. + } + pdisj_apply H_pdisj. + solve_in_fset. + } + (* pdisj *) + { + intros. + split. + { + intros. + destruct_pre. + eexists_set_heap. + eexists_set_heap. + eexists_set_heap. + eexists_set_heap. + pdisj_apply H_pdisj. + { + etransitivity. + apply H. + apply H1. + } + { + eapply prec_precneq. + apply H. + apply H1. + } + { + eapply prec_precneq. + apply H. + apply H1. + } + { + eapply prec_precneq. + apply H. + apply H1. + } + } + { + discriminate. + } } } intros. + hnf. remove_get_in_lhs. remove_get_in_lhs. rewrite <- bind_ret. bind_jazz_hac. - { + (* AES Enc last *) + unfold sopn_sem. unfold sopn.get_instr_desc. unfold asm_op_instr. @@ -2857,11 +3070,76 @@ Section Hacspec. subst s. rewrite !zero_extend_u. - rewrite <- rkeys_ext. + unfold seq_index. + unfold lift_to_both0. + unfold lift_to_both. + unfold is_pure. + pose (rkeys_ext 10). + simpl in e. + rewrite <- e ; [ | lia ]. + clear e. - apply (aes_enc_last_eq id0 a₁0 (chArray_get U128 rkeys 10 (wsize_size U128))). - pdisj_apply H_pdisj. - admit. (* AES Enc last *) } + apply (aes_enc_last_eq id0~1 a₁0 (chArray_get U128 rkeys 10 (wsize_size U128))). + + (* pdisj *) + { + split. + { + intros. + destruct_pre. + eexists ; split. + 2:{ + reflexivity. + } + eexists ; split. + 2:{ + rewrite set_heap_commut. + reflexivity. + solve_var_neq. + eapply precneq_I. + apply H0. + } + eexists_set_heap. + eexists_set_heap. + pdisj_apply H_pdisj. + + etransitivity. + apply preceq_I. + apply H0. + + { + eapply precneq_I. + apply H0. + } + { + eapply precneq_I. + apply H0. + } + } + { + intros. + destruct_pre. + rewrite in_fset in H. + rewrite mem_seq1 in H. + apply (ssrbool.elimT eqP) in H. + subst. + + eexists ; split. + 2:{ + rewrite set_heap_commut. + reflexivity. + easy. + } + eexists_set_heap. + eexists_set_heap. + eexists_set_heap. + + apply H_pdisj. + solve_in_fset. + apply H8. + } + } + } apply better_r_put_lhs. remove_get_in_lhs. @@ -2880,11 +3158,10 @@ Section Hacspec. - pdisj_apply H_pdisj. rewrite in_fset. now rewrite mem_head. - (* Qed. *) - Admitted. + Qed. Lemma aes_eq id0 key m (pre : precond) : - (pdisj pre id0 (fset [(@int_choice U128; 334) ; (@seq_choice int128; 279); (@int_choice U128; 278); + (pdisj pre id0 (fset [(@int_choice U128; 334) ; (chMap ('fin 1) (@int_choice U8); 0) ; (@seq_choice int128; 279); (@int_choice U128; 278); (@int_choice U128; 277)])) -> ⊢ ⦃ pre ⦄ JAES id0 key m @@ -2958,7 +3235,9 @@ Section Hacspec. rewrite in_fset. rewrite in_fset in H. rewrite in_cons ; simpl. + rewrite in_cons ; simpl. rewrite H. + rewrite Bool.orb_true_r. now rewrite Bool.orb_true_r. apply H4. } @@ -3022,8 +3301,12 @@ Section Hacspec. rewrite in_fset. rewrite in_cons ; simpl. + rewrite in_cons ; simpl. rewrite in_fset in H. - rewrite mem_seq1 in H. + rewrite in_cons in H ; simpl. + rewrite in_cons in H ; simpl. + rewrite Bool.orb_false_r in H. + rewrite orbA. rewrite H. now rewrite Bool.orb_true_l. apply H7. @@ -3031,7 +3314,9 @@ Section Hacspec. { intros. rewrite !coerce_to_choice_type_K. - apply H0. + specialize (H0 k H). + rewrite H0. + reflexivity. } intros. From 0296967bf80cd8ba5e936a8bfc2224b507cb237f Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Mon, 30 Jan 2023 14:07:35 +0100 Subject: [PATCH 360/383] Missing ShiftRows, SubBytes and MixColumns --- theories/Jasmin/examples/aes/aes_hac.v | 225 +++++++++++++++---------- 1 file changed, 137 insertions(+), 88 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes_hac.v b/theories/Jasmin/examples/aes/aes_hac.v index 0d2c4470..b1010d1a 100644 --- a/theories/Jasmin/examples/aes/aes_hac.v +++ b/theories/Jasmin/examples/aes/aes_hac.v @@ -1756,14 +1756,6 @@ Section Hacspec. | |- set_rhs _ _ _ _ => eexists end. - Definition seq_to_list_id : forall {A} (t : seq A), fmap_of_seq (seq_to_list A t) = t. - Proof. - Admitted. - - Definition fmap_of_seq_id : forall {A : ChoiceEquality} (t : list A), seq_to_list A (fmap_of_seq t) = t. - Proof. - Admitted. - Definition seq_push_list_app : forall {A} (t : seq A) (s : A), (seq_to_list A (Hacspec_Lib_Pre.seq_push t s) = seq_to_list A t ++ [s]). Proof. intros. @@ -1778,18 +1770,6 @@ Section Hacspec. reflexivity. Qed. - Theorem chArray_set_idemp : ∀ (ws : wsize.wsize) (a : 'array) (i : Z) (w : word.word ws), chArray_set (chArray_set a AAscale i w) AAscale i w = chArray_set a AAscale i w. - Proof. - Admitted. - - Theorem chArray_set_neq : ∀ (ws : wsize.wsize) (a : 'array) (i j : Z) (v w : word.word ws), - i != j -> - chArray_set (chArray_set a AAscale i w) AAscale j v = - chArray_set (chArray_set a AAscale j v) AAscale i w. - Proof. - Admitted. - - Definition seq_to_arr (X : seq uint128) : FMap.fmap_type Z_ordType U8.-word := let l0 := (unzip2 X) in mkfmap (zip (ziota 0 (size l0)) (seq.foldr (fun x y => y ++ (split_vec U8 x)) [] l0)). @@ -1807,9 +1787,6 @@ Section Hacspec. unfold seq_upd_from_arr. simpl. - (* assert ((unzip2 (Hacspec_Lib_Pre.seq_push a b)) = unzip2 a ++ [b]) by admit. *) - (* rewrite H. *) - rewrite seq_push_list_app. rewrite size_cat. rewrite Nat2Z.inj_add. @@ -1864,8 +1841,11 @@ Section Hacspec. end || rewrite get_set_heap_neq. + Notation rkeys_loc := (seq_choice int128; 70). + Notation temp2_loc := (@int_choice U128; 69). + Notation rkey_loc := (@int_choice U128; 68). Lemma keys_expand_eq id0 rkey (pre : precond) : - (pdisj pre id0 (fset ([(seq_choice int128; 279) ; (@int_choice U128; 278) ; (@int_choice U128; 277)]))) -> + (pdisj pre id0 (fset ([rkeys_loc ; temp2_loc ; rkey_loc ]))) -> ⊢ ⦃ pre ⦄ JKEYS_EXPAND id0 rkey ≈ @@ -1956,9 +1936,9 @@ Section Hacspec. pose (p0 := (λ (n : nat) '(rkeys, rkey, temp2) '(h0, h1), set_lhs (translate_var id0 {| vtype := sword U128; vname := "temp2.336" |}) temp2 (set_lhs (translate_var id0 {| vtype := sarr 176; vname := "rkeys.335" |}) (seq_upd_from_arr rkeys x) - (set_rhs (seq_choice int128; 279) rkeys - (set_rhs (int_choice; 278) temp2 - (set_rhs (int_choice; 277) rkey + (set_rhs rkeys_loc rkeys + (set_rhs temp2_loc temp2 + (set_rhs rkey_loc rkey ( (λ '(s₀, s₁), (set_lhs (translate_var id0 {| vtype := sword U128; vname := "key.334" |}) rkey pre) @@ -2000,7 +1980,9 @@ Section Hacspec. } eexists ; split. 2:{ + rewrite set_heap_commut. reflexivity. + easy. } eexists ; split. 2:{ @@ -2643,31 +2625,150 @@ Section Hacspec. } Qed. + Lemma shift_rows_eq id0 (state : 'word U128) (pre : precond) : + (pdisj pre id0 fset0) -> + ⊢ ⦃ pre ⦄ ret (waes.ShiftRows state) ≈ + prog (is_state (shiftrows state)) + ⦃ λ '(v0, h0) '(v1, h1), v0 = v1 ∧ pre (h0, h1) ⦄. + Admitted. + + Lemma sub_bytes_eq id0 (state : 'word U128) (pre : precond) : + (pdisj pre id0 fset0) -> + ⊢ ⦃ λ '(s₀0, s₁0), pre (s₀0, s₁0) ⦄ ret (waes.SubBytes state) ≈ + prog (is_state (subbytes (state))) + ⦃ λ '(v0, h0) '(v1, h1), v0 = v1 ∧ pre (h0, h1) ⦄. + Proof. + Admitted. + + Lemma mix_columns_eq id0 (state : 'word U128) (pre : precond) : + (pdisj pre id0 fset0) -> + ⊢ ⦃ λ '(s₀0, s₁0), pre (s₀0, s₁0) ⦄ ret (waes.MixColumns state) ≈ + prog (is_state (mixcolumns (state))) + ⦃ λ '(v0, h0) '(v1, h1), v0 = v1 ∧ pre (h0, h1) ⦄. + Proof. + Admitted. + Lemma aes_enc_eq id0 state key (pre : precond) : - (pdisj pre id0 (fset [ (CE_loc_to_loc ( nseq int8 1 ; 0%nat ) : Location) ])) -> + (pdisj pre id0 fset0) -> ⊢ ⦃ pre ⦄ ret (waes.wAESENC state key) ≈ prog (is_state (aesenc state key)) ⦃ fun '(v0, h0) '(v1, h1) => (v0 = v1) /\ pre (h0, h1) ⦄. Proof. + intros. + unfold waes.wAESENC. + unfold aesenc. - Admitted. + match_pattern_and_bind (waes.ShiftRows state). + { + Set Printing Coercions. + unfold lift_to_both0. + unfold lift_to_both. + unfold is_pure. + unfold lift_scope. + unfold is_state at 1. + unfold lift_code_scope. + + apply (shift_rows_eq id0). + apply H. + } + + subst. + + match_pattern_and_bind (waes.SubBytes a₁). + { + unfold lift_to_both0. + unfold lift_to_both. + unfold is_pure. + unfold lift_scope. + unfold is_state at 1. + unfold lift_code_scope. + + apply (sub_bytes_eq id0). + apply H. + } + + subst. + + match_pattern_and_bind (waes.MixColumns a₁0). + { + unfold lift_to_both0. + unfold lift_to_both. + unfold is_pure. + unfold lift_scope. + unfold is_state at 1. + unfold lift_code_scope. + + apply (mix_columns_eq id0). + apply H. + } + + subst. + + all: try (intros ? ? [] ; subst ; assumption). + + apply r_ret. + intros. + split. + - reflexivity. + - assumption. + Qed. Lemma aes_enc_last_eq id0 state key (pre : precond) : - (pdisj pre id0 (fset [ (CE_loc_to_loc ( nseq int8 1 ; 0%nat ) : Location) ])) -> + (pdisj pre id0 fset0) -> ⊢ ⦃ pre ⦄ ret (waes.wAESENCLAST state key) ≈ prog (is_state (aesenclast state key)) ⦃ fun '(v0, h0) '(v1, h1) => (v0 = v1) /\ pre (h0, h1) ⦄. Proof. + intros. + unfold waes.wAESENCLAST. + unfold aesenclast. - Admitted. + match_pattern_and_bind (waes.ShiftRows state). + { + unfold lift_to_both0. + unfold lift_to_both. + unfold is_pure. + unfold lift_scope. + unfold is_state at 1. + unfold lift_code_scope. + apply (shift_rows_eq id0). + apply H. + } + + subst. + match_pattern_and_bind (waes.SubBytes a₁). + { + unfold lift_to_both0. + unfold lift_to_both. + unfold is_pure. + unfold lift_scope. + unfold is_state at 1. + unfold lift_code_scope. + + apply (sub_bytes_eq id0). + apply H. + } + + subst. + + all: try (intros ? ? [] ; subst ; assumption). + apply r_ret. + intros. + split. + - reflexivity. + - assumption. + Qed. + + + Notation state_loc := (CE_loc_to_loc state_124_loc). Lemma addroundkey_eq id0 (rkeys : 'array) (rkeys' : seq int128) m (pre : precond) : - (pdisj pre id0 (fset [ (@int_choice U128; 334) ; (chMap ('fin 1) (@int_choice U8); 0)])) -> + (pdisj pre id0 (fset [ state_loc ])) -> (forall k, k <= 10 -> ((chArray_get U128 rkeys k (wsize_size U128)) = is_pure (seq_index rkeys' (lift_to_both0 (repr k))))) -> (* ((forall (j : nat), *) @@ -2762,7 +2863,7 @@ Section Hacspec. set (y1 := fun H : int => - set_rhs (int_choice; 334) H + set_rhs state_loc H (set_lhs (translate_var id0 {| vtype := sword U128; vname := "state.327" |}) H @@ -2911,38 +3012,7 @@ Section Hacspec. { intros. destruct_pre. - rewrite in_fset in H1. - rewrite mem_seq1 in H1. - apply (ssrbool.elimT eqP) in H1. - subst. - destruct_pre. - eexists ; split. - 2:{ - reflexivity. - } - eexists ; split. - 2:{ - rewrite set_heap_commut. - reflexivity. - easy. - } - eexists ; split. - 2:{ - reflexivity. - } - eexists ; split. - 2:{ - reflexivity. - } - eexists ; split. - 2:{ - reflexivity. - } - eapply H_pdisj. - rewrite in_fset. - rewrite in_cons ; simpl. - now rewrite mem_head. - assumption. + discriminate. } } - apply better_r_put_rhs. @@ -3119,24 +3189,7 @@ Section Hacspec. { intros. destruct_pre. - rewrite in_fset in H. - rewrite mem_seq1 in H. - apply (ssrbool.elimT eqP) in H. - subst. - - eexists ; split. - 2:{ - rewrite set_heap_commut. - reflexivity. - easy. - } - eexists_set_heap. - eexists_set_heap. - eexists_set_heap. - - apply H_pdisj. - solve_in_fset. - apply H8. + discriminate. } } } @@ -3161,8 +3214,7 @@ Section Hacspec. Qed. Lemma aes_eq id0 key m (pre : precond) : - (pdisj pre id0 (fset [(@int_choice U128; 334) ; (chMap ('fin 1) (@int_choice U8); 0) ; (@seq_choice int128; 279); (@int_choice U128; 278); - (@int_choice U128; 277)])) -> + (pdisj pre id0 (fset [state_loc ; rkeys_loc; temp2_loc; rkey_loc])) -> ⊢ ⦃ pre ⦄ JAES id0 key m ≈ @@ -3235,9 +3287,7 @@ Section Hacspec. rewrite in_fset. rewrite in_fset in H. rewrite in_cons ; simpl. - rewrite in_cons ; simpl. rewrite H. - rewrite Bool.orb_true_r. now rewrite Bool.orb_true_r. apply H4. } @@ -3304,7 +3354,6 @@ Section Hacspec. rewrite in_cons ; simpl. rewrite in_fset in H. rewrite in_cons in H ; simpl. - rewrite in_cons in H ; simpl. rewrite Bool.orb_false_r in H. rewrite orbA. rewrite H. From fc026aa8584ea73bec013a2f88555fb59f557842 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Mon, 30 Jan 2023 15:11:10 +0100 Subject: [PATCH 361/383] No more admits (only in hacspec_lib) --- theories/Jasmin/examples/aes/aes_hac.v | 94 ++++++++++++++++++-------- 1 file changed, 65 insertions(+), 29 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes_hac.v b/theories/Jasmin/examples/aes/aes_hac.v index b1010d1a..99ad6e95 100644 --- a/theories/Jasmin/examples/aes/aes_hac.v +++ b/theories/Jasmin/examples/aes/aes_hac.v @@ -1433,17 +1433,13 @@ Section Hacspec. destruct (is_pure (index_u8 _ _)). destruct toword. - reflexivity. - - (* SLOW! *)admit. - (* repeat (destruct p ; [ | | reflexivity ]) ; exfalso ; destruct p ; discriminate i0. *) - - (* easy. *) - Admitted. (* Qed. *) + - (* SLOW! *) (* admit. *) + repeat (destruct p ; [ | | reflexivity ]) ; exfalso ; destruct p ; discriminate i0. + - easy. + (* Admitted. *) Qed. - Lemma SubWord_eq id0 (n : int32) pre : - (pdisj pre id0 fset0) -> - ⊢ ⦃ pre ⦄ - ret (waes.SubWord n) ≈ - is_state (subword n) - ⦃ fun '(v0, h0) '(v1, h1) => (v0 = v1) /\ pre (h0, h1) ⦄. + Lemma SubWord_eq (n : int32) : + waes.SubWord n = is_pure (subword n). Proof. intros. unfold waes.SubWord. @@ -1457,8 +1453,7 @@ Section Hacspec. unfold subword. do 4 (rewrite <- sbox_eq ; [ | easy ]). - apply r_ret. - split ; easy. + easy. Qed. Lemma keygen_assist_eq id0 (v1 : 'word U128) (v2 : 'word U8) (pre : precond) : @@ -1503,8 +1498,8 @@ Section Hacspec. apply word_ext. now rewrite Zmod_small. } - eapply (SubWord_eq id0 (repr a₁) (λ '(s₀1, s₁1), pre (s₀1, s₁1))). - apply H. + rewrite (SubWord_eq (repr a₁)). + apply r_ret ; easy. } match_pattern_and_bind (word.wxor (wror (sz:=U32) a₀1 8) (zero_extend U32 (sz':=U8) v2)). @@ -1527,8 +1522,8 @@ Section Hacspec. apply word_ext. now rewrite Zmod_small. } - apply (SubWord_eq id0 (repr a₁0) (λ '(s₀1, s₁1), pre (s₀1, s₁1))). - apply H. + rewrite (SubWord_eq (repr a₁0)). + apply r_ret ; easy. } match_pattern_and_bind (word.wxor (wror (sz:=U32) a₀3 8) @@ -1741,11 +1736,11 @@ Section Hacspec. unfold array_index_clause_2_clause_1. simpl. - (* SLOW! *) admit. - (* do 10 (destruct j as [ | j ] ; [ simpl ; repeat (remove_get_in_lhs ; simpl) ; apply better_r_put_lhs ; remove_get_in_lhs ; apply r_ret ; intros ; destruct_pre ; split ; [ eexists ; split ; [ | reflexivity] ; f_equal ; unfold totce ; repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K) ; reflexivity | eapply H ; [ reflexivity | reflexivity | ] ; eapply H ; [ reflexivity | reflexivity | ] ; apply H5 ] | ]). *) - (* exfalso. *) - (* lia. *) - Admitted. (* Qed. *) + (* SLOW! *) (* admit. *) + do 10 (destruct j as [ | j ] ; [ simpl ; repeat (remove_get_in_lhs ; simpl) ; apply better_r_put_lhs ; remove_get_in_lhs ; apply r_ret ; intros ; destruct_pre ; split ; [ eexists ; split ; [ | reflexivity] ; f_equal ; unfold totce ; repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K) ; reflexivity | eapply H ; [ reflexivity | reflexivity | ] ; eapply H ; [ reflexivity | reflexivity | ] ; apply H5 ] | ]). + exfalso. + lia. + (* Admitted. *) Qed. Ltac split_post := repeat @@ -1841,9 +1836,9 @@ Section Hacspec. end || rewrite get_set_heap_neq. - Notation rkeys_loc := (seq_choice int128; 70). - Notation temp2_loc := (@int_choice U128; 69). - Notation rkey_loc := (@int_choice U128; 68). + Notation rkeys_loc := (CE_loc_to_loc rkeys_65_loc). + Notation temp2_loc := (CE_loc_to_loc temp2_67_loc). + Notation rkey_loc := (CE_loc_to_loc key_66_loc). Lemma keys_expand_eq id0 rkey (pre : precond) : (pdisj pre id0 (fset ([rkeys_loc ; temp2_loc ; rkey_loc ]))) -> ⊢ ⦃ pre ⦄ @@ -2630,7 +2625,34 @@ Section Hacspec. ⊢ ⦃ pre ⦄ ret (waes.ShiftRows state) ≈ prog (is_state (shiftrows state)) ⦃ λ '(v0, h0) '(v1, h1), v0 = v1 ∧ pre (h0, h1) ⦄. - Admitted. + intros. + unfold waes.ShiftRows. + unfold waes.to_matrix. + unfold waes.to_state. + rewrite rebuild_32_eq. + rewrite rebuild_32_eq. + rewrite rebuild_32_eq. + rewrite rebuild_32_eq. + rewrite rebuild_128_eq. + unfold shiftrows. + rewrite !index_32_eq. + rewrite !index_8_eq. + + set (rebuild_u32 _ _ _ _). + set (rebuild_u32 _ _ _ _). + set (rebuild_u32 _ _ _ _). + set (rebuild_u32 _ _ _ _). + + apply r_ret. + { + intros. + split. + - reflexivity. + - easy. + } + + all: lia. + Qed. Lemma sub_bytes_eq id0 (state : 'word U128) (pre : precond) : (pdisj pre id0 fset0) -> @@ -2638,16 +2660,30 @@ Section Hacspec. prog (is_state (subbytes (state))) ⦃ λ '(v0, h0) '(v1, h1), v0 = v1 ∧ pre (h0, h1) ⦄. Proof. - Admitted. + intros. + unfold waes.SubBytes. + unfold subbytes. + + simpl map. + rewrite rebuild_128_eq. + + rewrite !SubWord_eq. + rewrite !index_32_eq. + apply r_ret ; easy. + + all: lia. + Qed. Lemma mix_columns_eq id0 (state : 'word U128) (pre : precond) : (pdisj pre id0 fset0) -> ⊢ ⦃ λ '(s₀0, s₁0), pre (s₀0, s₁0) ⦄ ret (waes.MixColumns state) ≈ - prog (is_state (mixcolumns (state))) + prog (is_state (mixcolumns (state))) ⦃ λ '(v0, h0) '(v1, h1), v0 = v1 ∧ pre (h0, h1) ⦄. Proof. + (* Mix Columns is not defined in jasmin, + so we assume the equality for now *) Admitted. - + Lemma aes_enc_eq id0 state key (pre : precond) : (pdisj pre id0 fset0) -> ⊢ ⦃ pre ⦄ @@ -2766,7 +2802,7 @@ Section Hacspec. Qed. - Notation state_loc := (CE_loc_to_loc state_124_loc). + Notation state_loc := (CE_loc_to_loc state_120_loc). Lemma addroundkey_eq id0 (rkeys : 'array) (rkeys' : seq int128) m (pre : precond) : (pdisj pre id0 (fset [ state_loc ])) -> (forall k, k <= 10 -> ((chArray_get U128 rkeys k (wsize_size U128)) From 2084c801f7514613430b7b128cc9534c4dc7c1f3 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Mon, 30 Jan 2023 18:05:49 +0100 Subject: [PATCH 362/383] Update to changes in waes file --- theories/Jasmin/examples/aes/aes_hac.v | 50 +++++++++++++++----------- 1 file changed, 30 insertions(+), 20 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes_hac.v b/theories/Jasmin/examples/aes/aes_hac.v index 99ad6e95..85483803 100644 --- a/theories/Jasmin/examples/aes/aes_hac.v +++ b/theories/Jasmin/examples/aes/aes_hac.v @@ -16,7 +16,6 @@ Import ListNotations. Local Open Scope string. Set Bullet Behavior "Strict Subproofs". -(* Set Default Goal Selector "!". *) (* I give up on this for now. *) From Coq Require Import Utf8. From extructures Require Import ord fset fmap. @@ -30,8 +29,6 @@ Import PackageNotation. From Hacspec Require Import Hacspec_Aes_Jazz ChoiceEquality Hacspec_Lib Hacspec_Lib_Pre Hacspec_Lib_Comparable. Open Scope hacspec_scope. -(* Notation call fn := (translate_call _ fn _). *) - #[global] Hint Resolve preceq_I preceq_O preceq_refl : preceq. From Hacspec Require Import Hacspec_Lib. @@ -797,7 +794,7 @@ Section Hacspec. apply H0. lia. Qed. - + Lemma nat_to_be_range_is_subword : forall {WS : wsize.wsize} {WS_inp : wsize.wsize} (n : @int WS_inp) i `{H_WS : WS <= WS_inp} , (@repr WS (nat_be_range WS (toword n) i) = word.subword (i * WS) WS n). Proof. intros. @@ -1434,7 +1431,7 @@ Section Hacspec. destruct toword. - reflexivity. - (* SLOW! *) (* admit. *) - repeat (destruct p ; [ | | reflexivity ]) ; exfalso ; destruct p ; discriminate i0. + do 8 (destruct p ; [ | | reflexivity ]) ; exfalso ; destruct p ; discriminate i0. - easy. (* Admitted. *) Qed. @@ -1502,9 +1499,15 @@ Section Hacspec. apply r_ret ; easy. } - match_pattern_and_bind (word.wxor (wror (sz:=U32) a₀1 8) (zero_extend U32 (sz':=U8) v2)). + match_pattern_and_bind (word.wxor (waes.RotWord a₀1) (zero_extend U32 (sz':=U8) v2)). { subst. + + unfold waes.RotWord. + rewrite rebuild_32_eq. + rewrite !index_8_eq ; try lia. + unfold rotword. + apply r_ret. intros. split. @@ -1526,10 +1529,15 @@ Section Hacspec. apply r_ret ; easy. } - match_pattern_and_bind (word.wxor (wror (sz:=U32) a₀3 8) - (zero_extend U32 (sz':=U8) v2)). + match_pattern_and_bind (word.wxor (waes.RotWord a₀3) (zero_extend U32 (sz':=U8) v2)). { subst. + + unfold waes.RotWord. + rewrite rebuild_32_eq. + rewrite !index_8_eq ; try lia. + unfold rotword. + apply r_ret. intros. split. @@ -1760,8 +1768,9 @@ Section Hacspec. with (seq_to_list A (fmap_of_seq ((seq_to_list A t) ++ [s]))). reflexivity. + unfold seq_from_list in e. rewrite e. - rewrite fmap_of_seq_id. + rewrite seq_from_list_id. reflexivity. Qed. @@ -2490,7 +2499,8 @@ Section Hacspec. simpl. replace (fmap_of_seq _) with t. reflexivity. - now rewrite seq_to_list_id. + pose seq_to_list_id. unfold seq_from_list in e. + now rewrite e. } rewrite H3. @@ -2623,7 +2633,7 @@ Section Hacspec. Lemma shift_rows_eq id0 (state : 'word U128) (pre : precond) : (pdisj pre id0 fset0) -> ⊢ ⦃ pre ⦄ ret (waes.ShiftRows state) ≈ - prog (is_state (shiftrows state)) + prog (is_state (shiftrows state)) ⦃ λ '(v0, h0) '(v1, h1), v0 = v1 ∧ pre (h0, h1) ⦄. intros. unfold waes.ShiftRows. @@ -2637,7 +2647,7 @@ Section Hacspec. unfold shiftrows. rewrite !index_32_eq. rewrite !index_8_eq. - + set (rebuild_u32 _ _ _ _). set (rebuild_u32 _ _ _ _). set (rebuild_u32 _ _ _ _). @@ -2657,7 +2667,7 @@ Section Hacspec. Lemma sub_bytes_eq id0 (state : 'word U128) (pre : precond) : (pdisj pre id0 fset0) -> ⊢ ⦃ λ '(s₀0, s₁0), pre (s₀0, s₁0) ⦄ ret (waes.SubBytes state) ≈ - prog (is_state (subbytes (state))) + prog (is_state (subbytes (state))) ⦃ λ '(v0, h0) '(v1, h1), v0 = v1 ∧ pre (h0, h1) ⦄. Proof. intros. @@ -2670,7 +2680,7 @@ Section Hacspec. rewrite !SubWord_eq. rewrite !index_32_eq. apply r_ret ; easy. - + all: lia. Qed. @@ -2726,7 +2736,7 @@ Section Hacspec. } subst. - + match_pattern_and_bind (waes.MixColumns a₁0). { unfold lift_to_both0. @@ -2735,13 +2745,13 @@ Section Hacspec. unfold lift_scope. unfold is_state at 1. unfold lift_code_scope. - + apply (mix_columns_eq id0). apply H. } subst. - + all: try (intros ? ? [] ; subst ; assumption). apply r_ret. @@ -2849,7 +2859,7 @@ Section Hacspec. simpl. Transparent is_state. Transparent is_pure. rewrite (rkeys_ext 0) ; [ | lia ]. - + bind_jazz_bind. { (* xor *) @@ -3020,7 +3030,7 @@ Section Hacspec. eexists_set_heap. eexists_set_heap. (* eexists_set_heap. *) - + pdisj_apply H_pdisj. etransitivity. @@ -3196,7 +3206,7 @@ Section Hacspec. eexists ; split. 2:{ reflexivity. - } + } eexists ; split. 2:{ rewrite set_heap_commut. From 8019f5ac60b4a9a4a028a6457533cf760f47c16c Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Tue, 31 Jan 2023 17:20:24 +0100 Subject: [PATCH 363/383] add coq-mathcomp-word as dependency to opam --- ssprove.opam | 1 + 1 file changed, 1 insertion(+) diff --git a/ssprove.opam b/ssprove.opam index 85a3812b..e35e0139 100644 --- a/ssprove.opam +++ b/ssprove.opam @@ -12,6 +12,7 @@ depends: [ "coq-equations" {>= "1.3"} "coq-mathcomp-ssreflect" {(>= "1.13.0" & < "1.14~")} "coq-mathcomp-analysis" {= "0.3.13"} + "coq-mathcomp-word" {>= "2.0"} "coq-extructures" {(>= "0.3.1" & < "dev")} "coq-deriving" {(>= "0.1" & < "dev")} "coq-mathcomp-zify" {>= "1.2"} From 8ab3f1b1aa4132ec5fb80520f02db7cdbbe59af7 Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Tue, 31 Jan 2023 17:20:45 +0100 Subject: [PATCH 364/383] move lemma to fix one of the compilation errors --- theories/Jasmin/word.v | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/theories/Jasmin/word.v b/theories/Jasmin/word.v index dd443e0a..f046f9cb 100644 --- a/theories/Jasmin/word.v +++ b/theories/Jasmin/word.v @@ -145,6 +145,15 @@ Proof. zify. simpl. lia. Qed. +Lemma wbit_subword {ws1} i ws2 (w : word ws1) (j : 'I_ws2) : + wbit (subword i ws2 w) j = wbit w (i + j)%nat. +Proof. + intros. + unfold subword. + rewrite wbit_mkword. + apply wbit_lsr. +Qed. + Lemma subword_wshr {n} i j m (w : word n) : subword i m (lsr w j) = subword (j + i) m w. Proof. @@ -154,19 +163,9 @@ Proof. rewrite !wbit_subword. rewrite wbit_lsr. f_equal. - f_equal. lia. Qed. -Lemma wbit_subword {ws1} i ws2 (w : word ws1) (j : 'I_ws2) : - wbit (subword i ws2 w) j = wbit w (i + j)%nat. -Proof. - intros. - unfold subword. - rewrite wbit_mkword. - apply wbit_lsr. -Qed. - Lemma subword_xor {n} i ws (a b : n.-word) : (* I don't know if the assumption is necessary *) (* (ws <= n)%nat -> *) From 6caf9b52b1698293b40a995a58a35d1424f00203 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Thu, 2 Feb 2023 13:08:45 +0100 Subject: [PATCH 365/383] Moved equivalence proofs to the hacspec repository --- _CoqProject | 2 - theories/Jasmin/examples/aes/aes_hac.v | 3445 ------------------------ theories/Jasmin/examples/xor/xor.v | 637 ----- 3 files changed, 4084 deletions(-) delete mode 100644 theories/Jasmin/examples/aes/aes_hac.v delete mode 100644 theories/Jasmin/examples/xor/xor.v diff --git a/_CoqProject b/_CoqProject index 3f503ab0..22a7801d 100644 --- a/_CoqProject +++ b/_CoqProject @@ -108,8 +108,6 @@ theories/Jasmin/examples/aes/aes_utils.v theories/Jasmin/examples/aes/aes_valid.v theories/Jasmin/examples/aes/aes_spec.v -theories/Jasmin/examples/xor/xor.v - # Examples theories/Crypt/examples/package_usage_example.v theories/Crypt/examples/interpreter_test.v diff --git a/theories/Jasmin/examples/aes/aes_hac.v b/theories/Jasmin/examples/aes/aes_hac.v deleted file mode 100644 index 85483803..00000000 --- a/theories/Jasmin/examples/aes/aes_hac.v +++ /dev/null @@ -1,3445 +0,0 @@ -Set Warnings "-notation-overridden,-ambiguous-paths". -From mathcomp Require Import all_ssreflect all_algebra reals distr realsum - fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool - ssrnum eqtype choice seq. -Set Warnings "notation-overridden,ambiguous-paths". - -Require Import List. -Set Warnings "-notation-overridden". -From Jasmin Require Import expr. -Set Warnings "notation-overridden". -From Jasmin Require Import x86_instr_decl x86_extra. -From JasminSSProve Require Import jasmin_translate. -From Crypt Require Import Prelude Package. - -Import ListNotations. -Local Open Scope string. - -Set Bullet Behavior "Strict Subproofs". - -From Coq Require Import Utf8. -From extructures Require Import ord fset fmap. -Require Import micromega.Lia. -From mathcomp.word Require Import word ssrZ. -From JasminSSProve Require Import aes_jazz jasmin_utils. -From JasminSSProve Require Import aes_utils. -Import JasminNotation JasminCodeNotation. -Import PackageNotation. - -From Hacspec Require Import Hacspec_Aes_Jazz ChoiceEquality Hacspec_Lib Hacspec_Lib_Pre Hacspec_Lib_Comparable. -Open Scope hacspec_scope. - -#[global] Hint Resolve preceq_I preceq_O preceq_refl : preceq. - -From Hacspec Require Import Hacspec_Lib. - -From mathcomp Require Import zify_ssreflect zify_algebra zify. -Ltac Zify.zify_post_hook ::= Z.div_mod_to_equations. - -Section Hacspec. - -(*** Helper definitions *) - - (* NB: this redefines neq_loc_auto, which helps some tactics, since checking for inequality by computation is not feasible for translated variables *) - Ltac neq_loc_auto ::= solve [ eapply injective_translate_var3; auto | eapply injective_translate_var2; auto ]. - - Ltac destruct_pre := - repeat - match goal with - | [ H : set_lhs _ _ _ _ |- _ ] => - let sn := fresh in - let Hsn := fresh in - destruct H as [sn [Hsn]] - | [ H : set_rhs _ _ _ _ |- _ ] => - let sn := fresh in - let Hsn := fresh in - destruct H as [sn [Hsn]] - | [ H : _ /\ _ |- _ ] => - let H1 := fresh in - let H2 := fresh in - destruct H as [H1 H2] - | [ H : (_ ⋊ _) _ |- _ ] => - let H1 := fresh in - let H2 := fresh in - destruct H as [H1 H2] - | [ H : exists _, _ |- _ ] => - let o := fresh in - destruct H as [o] - end; simpl in *; subst. - - - Lemma det_jkey id0 rcon rkey temp2 : deterministic (JKEY_COMBINE id0 rcon rkey temp2). - Proof. - unfold translate_call, translate_call_body. - Opaque translate_call. - simpl. - - repeat (apply deterministic_put || (apply deterministic_get ; intros) || apply deterministic_ret). - Transparent translate_call. - Defined. - - - Lemma det_key_combine rcon rkey temp2 : deterministic (is_state (key_combine rcon rkey temp2)). - Proof. - repeat (apply deterministic_put || (apply deterministic_get ; intros) || apply deterministic_ret). - Defined. - - Lemma unfold_det_run : forall {A : choiceType} c [h : @deterministic A c] s, @det_run A c h s = match h with - | deterministic_ret x => (x, s) - | deterministic_get ℓ k hk => det_run (k (get_heap s ℓ)) (h := hk _) s - | deterministic_put ℓ v k hk => det_run k (h := hk) (set_heap s ℓ v) - end. - Proof. destruct h ; reflexivity. Qed. - - Ltac bind_jazz_hac := - match goal with - | [ |- context [ ⊢ ⦃ ?P ⦄ putr ?l ?jazz ?f ≈ _ ⦃ ?Q ⦄ ] ] => - eapply (@r_bind _ _ _ _ (ret jazz) _ (fun x => putr l x f) _ _ (fun '(v0, h0) '(v1, h1) => v0 = v1 /\ P (h0, h1)) _) ; [ try rewrite !zero_extend_u | intros ] - end. - - Ltac remove_get_in_lhs := - eapply better_r_get_remind_lhs ; - unfold Remembers_lhs , rem_lhs ; - [ intros ? ? ? ; - destruct_pre ; - repeat (rewrite get_set_heap_neq ; [ | apply injective_translate_var3 ; reflexivity ]) ; - rewrite get_set_heap_eq ; - reflexivity | ]. - - Theorem shiftr_bounds : forall x y z, - (0 <= y)%Z -> - (0 <= x < modulus (z+Z.to_nat y))%Z -> - (0 <= Z.shiftr x y < modulus z)%Z. - Proof. - intros. - rewrite Z.shiftr_div_pow2. - 2:{ cbn. lia. } - assert (modulus (z + Z.to_nat y) / 2 ^ y = modulus z)%Z. - { - unfold modulus. - rewrite two_power_nat_correct. - rewrite two_power_nat_correct. - rewrite Zpower_nat_Z. - rewrite Zpower_nat_Z. - rewrite Nat2Z.inj_add. - rewrite Z2Nat.id ; [ | assumption]. - - rewrite <- Z.pow_sub_r ; [ now rewrite Z.add_simpl_r | lia | ]. - split. assumption. - lia. - } - split. - - apply Z_div_nonneg_nonneg ; lia. - - apply (Z.div_lt_upper_bound). - lia. - eapply Z.lt_le_trans. - apply H0. - rewrite Z.mul_comm. - unfold modulus. - rewrite two_power_nat_correct. - rewrite two_power_nat_correct. - rewrite Zpower_nat_Z. - rewrite Zpower_nat_Z. - rewrite <- Z.pow_add_r. - cbn. - rewrite Nat2Z.inj_add. - rewrite Z2Nat.id. - lia. - cbn. lia. - cbn. lia. - cbn. lia. - Qed. - - Theorem shiftl_bounds : forall x (y z : nat), - (y <= z)%Z -> - (0 <= x < modulus (z - y))%Z -> - (0 <= Z.shiftl x y < modulus z)%Z. - Proof. - intros. - rewrite Z.shiftl_mul_pow2. - 2:{ cbn. lia. } - assert (modulus (z - y) * 2 ^ y = modulus z)%Z. - { - unfold modulus. - rewrite two_power_nat_correct. - rewrite two_power_nat_correct. - rewrite Zpower_nat_Z. - rewrite Zpower_nat_Z. - rewrite <- Z.pow_add_r ; [ | lia | cbn ; lia ]. - f_equal. - rewrite Nat2Z.inj_sub. - rewrite Z.sub_simpl_r. - reflexivity. - apply Nat2Z.inj_le. - apply H. - } - split. - - apply Z.mul_nonneg_nonneg ; lia. - - rewrite <- H1. - rewrite <- (Z.mul_lt_mono_pos_r). - lia. - cbn. - lia. - Qed. - - Theorem shiftr_smaller : forall x y n, - (0 <= y)%Z -> - (0 <= x < modulus (n + Z.to_nat y))%Z -> - Z.shiftr x y = (Z.shiftr x y mod modulus n)%Z. - Proof. - intros. - rewrite Zmod_small. - 2:{ - apply shiftr_bounds. - - apply H. - - apply H0. - } - reflexivity. - Qed. - - Notation JVSHUFPS i rkey temp1 temp2 := (trc VSHUFPS i [('word U128 ; rkey) ; ('word U128 ; temp1) ; ('word U128 ; temp2)]). - - Lemma modulus_gt0_Z : - forall n, (0 < modulus n)%Z. - Proof. easy. Qed. - - Lemma modulus_ge0_Z : - forall n, (0 <= modulus n)%Z. - Proof. easy. Qed. - - Lemma isword_Z : forall n k, (0 <= @toword n k < modulus n)%Z. - Proof. - apply (fun n k => ssrbool.elimT (iswordZP n (toword k)) (@isword_word n k)). - Qed. - - Lemma lt_add_right : forall n m p, (0 < p)%Z -> (n < m)%Z -> (n < m + p)%Z. - Proof. - intros. - eapply Z.lt_trans. - apply H0. - lia. - Qed. - - Lemma le_add_right : forall n m p, (0 <= p)%Z -> (n <= m)%Z -> (n <= m + p)%Z. - Proof. - intros. - eapply Z.le_trans. - apply H0. - lia. - Qed. - - Lemma modulusDZ : forall n m p, (n <= modulus (m + p)%nat)%Z = (n <= modulus m * modulus p)%Z . - Proof. - intros. - rewrite modulusD. - rewrite mulZE. - reflexivity. - Qed. - - Lemma modulus_add_r : forall n m p, (0 <= n < modulus m)%Z -> (0 <= n < modulus (m + p)%nat)%Z. - Proof. - intros. - destruct n as [ | n | ] ; [ easy | | easy ]. - rewrite modulusD. - rewrite <- mulZE. - split. easy. - induction p. - - rewrite Z.mul_1_r. - apply H. - - rewrite modulusS. - rewrite GRing.Theory.mulr2n. - rewrite <- addZE. - eapply Z.lt_trans. - apply IHp. - apply Zmult_lt_compat_l. - easy. - apply Z.lt_add_pos_r. - easy. - Qed. - - Lemma small_modulus_smaller : forall n m p, (0 <= n)%Z -> (0 < m <= p)%Z -> (0 <= n mod m < p)%Z. - Proof. - intros. - split. apply Z_mod_nonneg_nonneg. apply H. apply Z.lt_le_incl. apply H0. - eapply Z.lt_le_trans. - apply Z.mod_pos_bound. - lia. - apply H0. - Qed. - - Lemma mod_mod_larger : forall n m p, (0 <= n)%Z -> (0 < m <= p)%Z -> (n mod m mod p = n mod m)%Z. - Proof. - intros. - rewrite Zmod_small. - reflexivity. - apply small_modulus_smaller. - apply H. - apply H0. - Qed. - - Lemma mod_mod_divisable : forall n m p, (0 < p)%Z -> (exists k, m = k * p /\ 0 < k)%Z -> (n mod m mod p = n mod p)%Z. - Proof. - intros. - destruct H0 as [ ? [] ]. - subst. - now apply mod_pq_mod_q. - Qed. - - - Lemma Z_shiftl_mod_modulus_S : forall n (m p : nat), - (Z.shiftl n (Z.of_nat m.+1) mod modulus (p.+1) = 2 * (Z.shiftl n (Z.of_nat m) mod modulus p))%Z. - Proof. - intros. - rewrite <- Zmult_mod_distr_l. - - f_equal. - { - rewrite Z.shiftl_mul_pow2. - rewrite Nat2Z.inj_succ. - rewrite Z.pow_succ_r. - rewrite Z.mul_comm. - rewrite <- Z.mul_assoc. - rewrite <- (Z.mul_comm n). - rewrite <- Z.shiftl_mul_pow2. - reflexivity. - - lia. - lia. - lia. - } - Qed. - - Lemma Z_shiftl_mod_modulus_add : forall n (m p k : nat), - (Z.shiftl n (Z.of_nat (m + k)) mod modulus (p + k) = modulus k * (Z.shiftl n (Z.of_nat m) mod modulus p))%Z. - Proof. - intros. - induction k. - - rewrite !addn0. - rewrite Z.mul_1_l. - reflexivity. - - rewrite !addnS. - rewrite Z_shiftl_mod_modulus_S. - rewrite IHk. - rewrite Z.mul_assoc. - reflexivity. - Qed. - - Lemma subn_diag : forall p m, m <= p -> p = p - m + m. - Proof. - intros. - pose subn_eq0. - pose (@subnA p m m (leqnn m) H). - epose (addKn m 0). - setoid_rewrite addn0 in e1. - setoid_rewrite e1 in e0. - now rewrite (subn0 p) in e0. - Qed. - - Lemma Z_shiftl_mod_modulus : forall n (m p k : nat), (m <= p) -> (Z.shiftl n (Z.of_nat m) mod modulus p = modulus m * (n mod modulus (p - m)))%Z. - Proof. - intros. - replace p with (p - m + m) at 1 by now rewrite <- (subn_diag p m H). - replace (m) with (0 + m) at 1 by reflexivity. - apply Z_shiftl_mod_modulus_add. - Qed. - - Ltac solve_lower_bounds := - (simple apply Z.mul_nonneg_nonneg || simple apply Zle_0_pos || simple apply Z_mod_nonneg_nonneg || simple apply Nat2Z.is_nonneg || simple apply modulus_ge0_Z || simple apply (fun x y => proj2 (Z.shiftr_nonneg x y)) || simple apply (fun x y => proj2 (Z.shiftl_nonneg x y)) || simple apply word_geZ0 || (apply Z.lor_nonneg ; solve_upper_bound)) - with - solve_upper_bound := - ((split ; [ repeat solve_lower_bounds | ]) || (apply small_modulus_smaller ; now repeat solve_lower_bounds) || (rewrite <- (Z.mul_lt_mono_pos_l) ; [ | easy]) || apply isword_Z || (apply shiftr_bounds ; repeat solve_lower_bounds) || apply modulus_add_r || rewrite Z.shiftr_0_r || lia). - - Lemma shift_left_4_byte_ok : - (forall i (a : 'word U32), - i < 4 -> - (0 <= Z.shiftl (wunsigned a) (Z.of_nat (i * 32)) < - modulus (wsize_size_minus_1 U128).+1)%Z). - Proof. - clear. - destruct a. - unfold wunsigned, urepr, val, word_subType, word.toword. - apply (ssrbool.elimT (iswordZP _ _)) in i0. - split. apply Z.shiftl_nonneg. lia. - destruct i0. - rewrite Z.shiftl_mul_pow2 ; [ | lia]. - eapply Z.lt_le_trans. - rewrite <- (@Z.mul_lt_mono_pos_r (2 ^ Z.of_nat _) toword) ; [ | lia ]. - apply H1. - destruct i as [ | [ | [ | [ | []] ]] ] ; easy. - Qed. - - Lemma num_smaller_if_modulus_le : (forall {WS} (x : 'word WS) z, (modulus WS <= z)%Z -> (0 <= x < z)%Z). - Proof. - cbn. - intros. - split. - - apply isword_Z. - - eapply Z.lt_le_trans ; [ apply isword_Z | apply H ]. - Qed. - - Lemma Z_lor_pow2 : (forall (x y : Z) (k : nat), (0 <= x < 2 ^ k)%Z -> (0 <= y < 2 ^ k)%Z -> (0 <= Z.lor x y < 2 ^ k)%Z). - Proof. - clear. - intros. - - split. - apply Z.lor_nonneg ; easy. - destruct x as [ | x | x ]. - - apply H0. - - destruct y as [ | y | y ]. - + apply H. - + destruct H as [_ ?]. - destruct H0 as [_ ?]. - apply Z.log2_lt_pow2 in H ; [ | easy ]. - apply Z.log2_lt_pow2 in H0 ; [ | easy ]. - apply Z.log2_lt_pow2 ; [ easy | ]. - rewrite (Z.log2_lor) ; [ | easy | easy ]. - apply Z.max_lub_lt ; easy. - + easy. - - easy. - Qed. - - Definition pdisj (P : precond) (s_id : p_id) (rhs : {fset Location}) := - (forall h1 h2 l a v s_id', l = translate_var s_id' v -> (s_id ⪯ s_id') -> (P (h1, h2) -> P (set_heap h1 l a, h2))) /\ - (forall h1 h2 l a, l \in rhs -> (P (h1, h2) -> P (h1, set_heap h2 l a))). - - Ltac solve_in := - repeat match goal with - | |- is_true (?v \in fset1 ?v :|: _) => apply/fsetU1P; left; auto - | |- is_true (_ \in fsetU _ _) => apply/fsetU1P; right - end. - - Ltac pdisj_apply h := - lazymatch goal with - | |- ?pre (set_heap _ _ _, set_heap _ _ _) => eapply h; [ solve_in | pdisj_apply h ] - | |- ?pre (set_heap _ _ _, _) => - eapply h ; [ reflexivity | auto with preceq | pdisj_apply h ] - | |- _ => try assumption - end. - - - Ltac bind_jazz_bind := - match goal with - | [ |- context [ ⊢ ⦃ ?P ⦄ putr ?l ?y ?g ≈ bind ?a ?f ⦃ ?Q ⦄ ] ] => - let yv := fresh in - let gv := fresh in - let av := fresh in - let fv := fresh in - set l - ; set (yv := y) - ; set (gv := g) - ; set (av := a) - ; set (fv := f) - ; apply (r_bind (ret yv) (av) (fun x => putr l x gv) fv P (fun '(v0, h0) '(v1, h1) => v0 = v1 /\ P (h0, h1)) Q) ; [ | intros ] - ; subst yv gv av fv ; hnf - end. - - Theorem rpre_hypothesis_rule' : - ∀ {A₀ A₁ : _} {p₀ : raw_code A₀} {p₁ : raw_code A₁} - (pre : precond) post, - (∀ s₀ s₁, - pre (s₀, s₁) → ⊢ ⦃ λ '(s₀', s₁'), s₀' = s₀ ∧ s₁' = s₁ ⦄ p₀ ≈ p₁ ⦃ post ⦄ - ) → - ⊢ ⦃ pre ⦄ p₀ ≈ p₁ ⦃ post ⦄. - Proof. - intros A₀ A₁ p₀ p₁ pre post h. - eapply rpre_hypothesis_rule. - intros s0 s1 H. eapply rpre_weaken_rule. - eapply h. - eassumption. - easy. - Qed. - - Theorem rpre_weak_hypothesis_rule' : - ∀ {A₀ A₁ : _} {p₀ : raw_code A₀} {p₁ : raw_code A₁} - (pre : precond) post, - (∀ s₀ s₁, - pre (s₀, s₁) → ⊢ ⦃ λ '(s0, s1), pre (s0, s1) ⦄ p₀ ≈ p₁ ⦃ post ⦄ - ) → - ⊢ ⦃ pre ⦄ p₀ ≈ p₁ ⦃ post ⦄. - Proof. - intros A₀ A₁ p₀ p₁ pre post h. - eapply rpre_hypothesis_rule'. - intros. eapply rpre_weaken_rule. - eapply h. eassumption. - intros s0' s1' [H0 H1]. - subst. - assumption. - Qed. - - Corollary better_r_put_rhs : forall {A B : choice.Choice.type} (ℓ : Location) - (v : choice.Choice.sort (Value (projT1 ℓ))) (r₀ : raw_code A) - (r₁ : raw_code B) (pre : precond) - (post : postcond (choice.Choice.sort A) (choice.Choice.sort B)), - ⊢ ⦃ set_rhs ℓ v pre ⦄ r₀ ≈ r₁ ⦃ post ⦄ -> - ⊢ ⦃ pre ⦄ r₀ ≈ #put ℓ := v ;; r₁ ⦃ post ⦄. - Proof. - intros. - eapply rpre_hypothesis_rule. - intros. - eapply rpre_weaken_rule. - apply r_put_rhs. - apply H. - intuition. - Unshelve. - subst. - intuition. - Qed. - - Theorem modulus_exact : forall {WS : wsize.wsize} (x : 'word WS), (0 <= x < modulus WS)%Z. - Proof. - intros. - destruct x. - cbn. - apply (ssrbool.elimT (iswordZP _ _)) in i. - apply i. - Qed. - - Theorem modulus_smaller : forall (WS : wsize.wsize) (m : nat) {x : 'word WS}, (WS <= m)%Z -> (0 <= x < modulus m)%Z. - Proof. - intros. - destruct x. - cbn. - apply (ssrbool.elimT (iswordZP _ _)) in i. - split. - - easy. - - eapply Z.lt_le_trans. - apply i. - rewrite modulusZE. - rewrite modulusZE. - apply (Z.pow_le_mono_r 2). - reflexivity. - apply H. - Qed. - - Ltac match_pattern_and_bind_repr p := - unfold let_both at 1, is_state at 1, prog ; - match goal with - | [ |- context [ ⊢ ⦃ ?P ⦄ ?x ≈ _ ⦃ ?Q ⦄ ] ] => - let Hx := fresh in - set (Hx := x) ; - pattern p in Hx ; - subst Hx ; - - (* Match bind and apply *) - match goal with - | [ |- context [ ⊢ ⦃ ?P ⦄ _ ≈ bind ?a ?f ⦃ ?Q ⦄ ] ] => - let av := fresh in - let fv := fresh in - set (av := a) - ; set (fv := f) - ; eapply (r_bind (ret p) av _ fv P (fun '(v0, h0) '(v1, h1) => v0 = repr v1 /\ P (h0, h1)) Q) - ; subst av fv ; hnf ; [ | intros ; apply rpre_hypothesis_rule' ; intros ? ? [] ; apply rpre_weaken_rule with (pre := fun '(s₀, s₁) => P (s₀, s₁)) - ] - end - end. - - Ltac match_pattern_and_bind p := - unfold let_both at 1, is_state at 1, prog ; - match goal with - | [ |- context [ ⊢ ⦃ ?P ⦄ ?x ≈ _ ⦃ ?Q ⦄ ] ] => - let Hx := fresh in - set (Hx := x) ; - pattern p in Hx ; - subst Hx ; - - (* Match bind and apply *) - match goal with - | [ |- context [ ⊢ ⦃ ?P ⦄ _ ≈ bind ?a ?f ⦃ ?Q ⦄ ] ] => - let av := fresh in - let fv := fresh in - set (av := a) - ; set (fv := f) - ; eapply (r_bind (ret p) av _ fv P (fun '(v0, h0) '(v1, h1) => v0 = v1 /\ P (h0, h1)) Q) - ; subst av fv ; hnf ; [ | intros ; apply rpre_hypothesis_rule' ; intros ? ? [] ; apply rpre_weaken_rule with (pre := fun '(s₀, s₁) => P (s₀, s₁)) - ] - end - end. - - Definition unfold_translate_for : forall v j d id0 id' y, - (translate_for v [seq (1 + Z.of_nat i)%Z | i <- iota j (S d)] id0 y id') = - (translate_write_var id0 v (@existT choice_type (fun t : choice_type => Choice.sort (chElement t)) chInt (Z.of_nat (j.+1))) ;; - (snd (y id')) ;; - translate_for v [seq (1 + Z.of_nat i)%Z | i <- iota (S j) d] id0 y (fst (y id'))). - Proof. - intros. - assert (forall j n, [seq (1 + Z.of_nat i)%Z | i <- iota j (S n)] = - ((1 + Z.of_nat j)%Z :: [seq (1 + Z.of_nat i)%Z | i <- iota (S j) n])) by reflexivity. - rewrite H. - unfold translate_for ; fold translate_for. - destruct (y id'). - replace (totce (translate_value (values.Vint (1 + Z.of_nat j)))) - with (@existT choice_type (fun t : choice_type => Choice.sort (chElement t)) chInt (Z.of_nat (j.+1))). - 2:{ - cbn. - repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). - rewrite Zpos_P_of_succ_nat. - unfold Z.succ. - rewrite Z.add_comm. - reflexivity. - } - reflexivity. - Qed. - - Theorem loop_eq : - forall {acc : ChoiceEquality} v d (j : nat) id0 s_id id' y I L (y0 : @int U32 -> acc -> code L I acc) (pre : _ -> _ -> precond) (inv : _ -> _ -> precond) c, - (0 < d) -> - (id0 ≺ s_id) -> - (forall id, id ⪯ id' id) -> - (forall k c s_id, - (id0 ≺ s_id) -> - j <= k < j + d -> - ⊢ ⦃ set_lhs - (translate_var id0 (v_var v)) - (@truncate_el chInt (vtype (v_var v)) (S k)) - (fun '(h0, h1) => (inv k c) (h0, h1) /\ (pre k c) (h0, h1)) ⦄ - y s_id - ≈ y0 (repr (Pos.of_succ_nat k)) c - ⦃ λ '(_, h0) '(v1, h1), (inv (S k) (ct_T v1) (h0, h1)) /\ (pre (S k) (ct_T v1)) (h0, h1) ⦄) -> - (forall k c s_id, (id0 ≺ s_id) -> - (* j <= k < j + d -> *) - pdisj (pre k c) s_id fset0) -> - ⊢ ⦃ fun '(h0, h1) => inv j c (h0, h1) /\ (pre j c) (h0, h1) ⦄ - (translate_for v - [seq (1 + Z.of_nat i)%Z | i <- iota j d] id0 (fun id => (id' id, y id)) s_id) ≈ - (foldi_ (I := I) (L := L) (d) (repr (S j)) y0 c ) - ⦃ fun '(v0, h0) '(v1, h1) => (inv (j + d) (ct_T v1) (h0, h1)) /\ (pre (j + d) (ct_T v1)) (h0, h1) ⦄ . - Proof. - intros. - generalize dependent j. - generalize dependent c. - generalize dependent s_id. - induction d ; intros. - discriminate. - - destruct d. - - rewrite unfold_translate_for. - simpl. - apply better_r_put_lhs. - setoid_rewrite T_ct_id. - (* apply rpre_hypothesis_rule'. *) - (* intros. *) - (* destruct_pre. *) - (* clear H7. *) - (* eapply rpre_weaken_rule. *) - (* 2:{ intros ? ? []. subst. eapply H3. reflexivity. easy. apply H8. } *) - eapply r_bind. - { - apply H2. - apply H0. - lia. - } - { - intros. - apply r_ret. - intros. rewrite addn1. apply H4. - } - - rewrite <- foldi__move_S. - rewrite unfold_translate_for. - - apply better_r_put_lhs. - setoid_rewrite bind_rewrite. - apply r_bind with (mid := λ '(_, h0) '(v1, h1), (inv (j.+1) (ct_T v1) ((h0, h1)) /\ (pre (j.+1) (ct_T v1) (h0, h1)))). - - 2:{ - intros. - replace (Hacspec_Lib_Pre.int_add (repr j.+1) one) - with - (@repr U32 j.+2). - 2:{ - simpl. - cbn. - unfold Hacspec_Lib_Pre.int_add, add_word. - rewrite mkwordK. - cbn. - apply word_ext. - rewrite Zplus_mod. - rewrite Zmod_mod. - rewrite <- Zplus_mod. - f_equal. - now zify. - } - - assert (id0 ≺ id' s_id). - { - split. - - etransitivity. - apply H0. - apply H1. - - red ; intros. - clear -H0 H1 H4. - subst. - pose (prec_precneq (id' s_id) (s_id)). - apply n. - apply H0. - apply H1. - } - - apply better_r. - unfold ".1". - rewrite <- addSnnS. - apply (IHd ltac:(easy) (id' s_id) H4). (* (ct_T a₁) j.+1 ). *) - { - intros. - apply H2. - apply H5. - lia. - } - } - unfold ".2". - apply H2. - apply H0. - lia. - Qed. - - Theorem loop_eq_simpl : - forall {acc : ChoiceEquality} v d (j : nat) id0 s_id id' y I L (y0 : @int U32 -> acc -> code L I acc) (pre : _ -> _ -> precond) c, - (0 < d) -> - (id0 ≺ s_id) -> - (forall id, id ⪯ id' id) -> - (forall k c s_id, - (id0 ≺ s_id) -> - j <= k < j + d -> - ⊢ ⦃ set_lhs - (translate_var id0 (v_var v)) - (@truncate_el chInt (vtype (v_var v)) (S k)) - (pre k c) ⦄ - y s_id - ≈ y0 (repr (Pos.of_succ_nat k)) c - ⦃ λ '(_, h0) '(v1, h1), (pre (S k) (ct_T v1)) (h0, h1) ⦄) -> - (forall k c s_id, (id0 ≺ s_id) -> - (* j <= k < j + d -> *) - pdisj (pre k c) s_id fset0) -> - ⊢ ⦃ (pre j c) ⦄ - (translate_for v - [seq (1 + Z.of_nat i)%Z | i <- iota j d] id0 (fun id => (id' id, y id)) s_id) ≈ - (foldi_ (I := I) (L := L) (d) (repr (S j)) y0 c ) - ⦃ fun '(v0, h0) '(v1, h1) => (pre (j + d) (ct_T v1)) (h0, h1) ⦄ . - Proof. - intros. - generalize dependent j. - generalize dependent c. - generalize dependent s_id. - induction d ; intros. - discriminate. - - destruct d. - - rewrite unfold_translate_for. - simpl. - apply better_r_put_lhs. - setoid_rewrite T_ct_id. - (* apply rpre_hypothesis_rule'. *) - (* intros. *) - (* destruct_pre. *) - (* clear H7. *) - (* eapply rpre_weaken_rule. *) - (* 2:{ intros ? ? []. subst. eapply H3. reflexivity. easy. apply H8. } *) - eapply r_bind. - { - apply H2. - (* easy. *) - apply H0. - lia. - } - { - intros. - apply r_ret. - intros. rewrite <- addSnnS. setoid_rewrite Nat.add_0_r. apply H4. - } - - rewrite <- foldi__move_S. - rewrite unfold_translate_for. - - apply better_r_put_lhs. - setoid_rewrite bind_rewrite. - apply r_bind with (mid := λ '(_, h0) '(v1, h1), (pre (S j) (ct_T v1) (h0, h1))). - - 2:{ - intros. - replace (Hacspec_Lib_Pre.int_add (repr j.+1) one) - with - (@repr U32 j.+2). - 2:{ - simpl. - cbn. - unfold Hacspec_Lib_Pre.int_add, add_word. - rewrite mkwordK. - cbn. - apply word_ext. - rewrite Zplus_mod. - rewrite Zmod_mod. - rewrite <- Zplus_mod. - f_equal. - now zify. - } - - apply better_r. - unfold ".1". - rewrite <- addSnnS. - eapply (IHd (ltac:(easy)) (id' s_id) ). - { - eapply prec_preceq_trans. - apply H0. - apply H1. - } - { - intros. - apply H2. - (* assumption. *) - apply H4. - lia. - } - } - unfold ".2". - apply H2. - apply H0. - lia. - Qed. - - Lemma nat_to_be_range_is_subword : forall {WS : wsize.wsize} {WS_inp : wsize.wsize} (n : @int WS_inp) i `{H_WS : WS <= WS_inp} , (@repr WS (nat_be_range WS (toword n) i) = word.subword (i * WS) WS n). - Proof. - intros. - apply word_ext. - cbn. - unfold nat_be_range. - replace (_ ^ WS)%Z with (modulus WS)%Z by (destruct WS ; reflexivity). - replace (modulus WS_inp) with (modulus (WS_inp - WS) * modulus WS)%Z by (destruct WS , WS_inp ; easy). - rewrite mod_pq_mod_q ; [ | easy | easy ]. - rewrite !Zmod_mod. - f_equal. - rewrite <- Z.shiftr_div_pow2 ; [ | lia ]. - rewrite Nat2Z.inj_mul. - f_equal. now zify. - Qed. - - (*** Equality proofs *) - - Lemma rebuild_128_eq : - forall (v0 v1 v2 v3 : 'word U32) , - make_vec _ [v0 ; v1 ; v2 ; v3] = is_pure (rebuild_u128 v0 v1 v2 v3). - Proof. - intros. - simpl. - unfold "shift_left". - unfold Hacspec_Lib_Pre.shift_left_. - unfold is_pure. - unfold ".|". - unfold Hacspec_Lib_Pre.int_or. - rewrite !lift3_both_equation_1 ; simpl. - - unfold make_vec. - unfold wcat_r. - - apply word_ext. - - rewrite Z.shiftl_0_l. - rewrite Z.lor_0_r. - rewrite !Z.shiftl_lor. - simpl int_to_Z. - rewrite !Z.shiftl_shiftl ; try easy. - simpl (_ + _)%Z. - - unfold wshl, lsl. - setoid_rewrite wunsigned_repr. - rewrite Zmod_small. - rewrite Zmod_small. - rewrite mod_mod_larger. - rewrite Zmod_small. - rewrite Zmod_small. - rewrite mod_mod_larger. - rewrite Zmod_small. - rewrite Zmod_small. - rewrite mod_mod_larger. - rewrite Zmod_small. - rewrite Zmod_small. - unfold word.wor, wor, toword, mkword. - rewrite Zmod_small. - rewrite Zmod_small. - rewrite Zmod_small. - reflexivity. - - all: try apply shiftl_bounds. - all: try now apply (@num_smaller_if_modulus_le U32). - all: try easy. - repeat (rewrite modulusZE ; apply Z_lor_pow2 ; rewrite <- modulusZE). - all: try now apply (@num_smaller_if_modulus_le U32). - 1: replace 32%Z with (int_to_Z 32) by reflexivity. - 2: replace 64%Z with (int_to_Z 64) by reflexivity. - 3: replace 96%Z with (int_to_Z 96) by reflexivity. - all: apply shiftl_bounds ; [ easy | ]. - all: try now apply (@num_smaller_if_modulus_le U32). - Qed. - - Lemma rebuild_32_eq : - forall (v0 v1 v2 v3 : 'word U8) , - make_vec _ [v0 ; v1 ; v2 ; v3] = is_pure (rebuild_u32 v0 v1 v2 v3). - Proof. - intros. - simpl. - unfold "shift_left". - unfold Hacspec_Lib_Pre.shift_left_. - unfold is_pure. - unfold ".|". - unfold Hacspec_Lib_Pre.int_or. - rewrite !lift3_both_equation_1 ; simpl. - - unfold make_vec. - unfold wcat_r. - - apply word_ext. - - rewrite Z.shiftl_0_l. - rewrite Z.lor_0_r. - rewrite !Z.shiftl_lor. - simpl int_to_Z. - rewrite !Z.shiftl_shiftl ; try easy. - simpl (_ + _)%Z. - - unfold wshl, lsl. - setoid_rewrite wunsigned_repr. - rewrite Zmod_small. - rewrite Zmod_small. - rewrite mod_mod_larger. - rewrite Zmod_small. - rewrite Zmod_small. - rewrite mod_mod_larger. - rewrite Zmod_small. - rewrite Zmod_small. - rewrite mod_mod_larger. - rewrite Zmod_small. - rewrite Zmod_small. - unfold word.wor, wor, toword, mkword. - rewrite Zmod_small. - rewrite Zmod_small. - rewrite Zmod_small. - reflexivity. - - all: try apply shiftl_bounds. - all: try now apply (@num_smaller_if_modulus_le U8). - all: try easy. - repeat (rewrite modulusZE ; apply Z_lor_pow2 ; rewrite <- modulusZE). - all: try now apply (@num_smaller_if_modulus_le U8). - 1: replace 8%Z with (int_to_Z 8) by reflexivity. - 2: replace 16%Z with (int_to_Z 16) by reflexivity. - 3: replace 24%Z with (int_to_Z 24) by reflexivity. - all: apply shiftl_bounds ; [ easy | ]. - all: try now apply (@num_smaller_if_modulus_le U8). - Qed. - - Lemma index_32_eq : - forall (v : 'word U128) (i : nat), - i < 4 -> - word.subword (i * U32) U32 v = is_pure (index_u32 v (repr (Z.of_nat i))). - Proof. - intros. - unfold word.subword. - unfold index_u32. - simpl. - unfold "shift_left", Hacspec_Lib_Pre.shift_left_. - unfold "shift_right", Hacspec_Lib_Pre.shift_right_. - unfold ".%", Hacspec_Lib_Pre.int_mod. - unfold ".*", Hacspec_Lib_Pre.int_mul. - unfold is_pure. - rewrite !lift3_both_equation_1 ; simpl. - unfold wshl, lsl. - unfold wshr, lsr. - unfold wmod, mul_word. - apply word_ext. - simpl. - cbn. - - rewrite Z2Nat.id. - rewrite (Zmod_small (Z.of_nat i)). - rewrite (Zmod_small ( (Z.of_nat i) * _)). - rewrite (Zmod_small ( (Z.of_nat i) * _)). - rewrite (mod_mod_larger _ 4294967296). - rewrite (Zmod_mod _ (modulus U32)). - f_equal. - f_equal. - all: try now do 4 (destruct i as [ | i ] ; [ easy | ]). - repeat solve_lower_bounds. - Qed. - - - Lemma index_8_eq : - forall (v : 'word U32) (i : nat), - i < 4 -> - word.subword (i * U8) U8 v = is_pure (index_u8 v (repr (Z.of_nat i))). - Proof. - intros. - unfold word.subword. - unfold index_u32. - simpl. - unfold "shift_left", Hacspec_Lib_Pre.shift_left_. - unfold "shift_right", Hacspec_Lib_Pre.shift_right_. - unfold ".%", Hacspec_Lib_Pre.int_mod. - unfold ".*", Hacspec_Lib_Pre.int_mul. - unfold is_pure. - rewrite !lift3_both_equation_1 ; simpl. - unfold wshl, lsl. - unfold wshr, lsr. - unfold wmod, mul_word. - apply word_ext. - simpl. - cbn. - - rewrite Z2Nat.id. - rewrite (Zmod_small (Z.of_nat i)). - rewrite (Zmod_small ( (Z.of_nat i) * _)). - rewrite (Zmod_small ( (Z.of_nat i) * _)). - rewrite (mod_mod_larger _ 256). - rewrite (Zmod_mod _ (modulus U8)). - f_equal. - f_equal. - all: try now do 4 (destruct i as [ | i ] ; [ easy | ]). - repeat solve_lower_bounds. - Qed. - - Lemma wpshufd1_eq : - forall (rkey : 'word U128) (i : nat) (n : 'word U8), - i < 4 -> - wpshufd1 rkey n i = - is_pure (vpshufd1 rkey n (Hacspec_Lib_Pre.repr i)). - Proof. - Opaque Z.mul. - clear. - intros. - unfold vpshufd1. - unfold wpshufd1. - - Opaque index_u32. - unfold is_pure at 1, lift_scope ; simpl. - rewrite (index_32_eq _ 0). - f_equal. - f_equal. - unfold is_pure at 1, ".%" ; rewrite !lift3_both_equation_1 ; simpl. - simpl. - setoid_rewrite lift3_both_equation_1 ; simpl. - setoid_rewrite lift3_both_equation_1 ; simpl. - setoid_rewrite lift3_both_equation_1 ; simpl. - apply word_ext. - simpl. - f_equal. - f_equal. - f_equal. - f_equal. - rewrite Zmod_small. - unfold Hacspec_Lib_Pre.int_mul. - unfold mul_word. - unfold unsigned, wunsigned. - rewrite !mkwordK. - rewrite (Zmod_small _ (modulus U32)). - rewrite (Zmod_small _ (modulus U32)). - rewrite (Zmod_small _ (modulus U32)). - f_equal. - cbn. - replace (4 mod _)%Z with (modulus 2)%Z by reflexivity. - rewrite Z2Nat.id. - symmetry. - rewrite (Zmod_small _ (modulus nat7.+1)). - symmetry. - f_equal. - f_equal. - f_equal. - all: try now do 4 (destruct i as [ | i ] ; [ easy | ]). - apply small_modulus_smaller. - now repeat solve_lower_bounds. - easy. - - split ; [ cbn ; now repeat solve_lower_bounds | ]. - replace (modulus U32)%Z with (32 * modulus (U32 - 5))%Z by reflexivity. - apply Zmult_lt_compat_l. easy. - apply small_modulus_smaller. - cbn ; now repeat solve_lower_bounds. - easy. - - apply small_modulus_smaller. - cbn ; now repeat solve_lower_bounds. - easy. - - apply (@num_smaller_if_modulus_le U32). - easy. - Qed. - - Lemma wpshufd1_eq_state : - forall {H} (rkey : 'word U128) (n : 'word U8) (i : nat), - i < 4 -> - ⊢ ⦃ H ⦄ - ret (wpshufd1 rkey n i) ≈ - is_state (vpshufd1 rkey n (Hacspec_Lib_Pre.repr i)) - ⦃ λ '(v0, h0) '(v1, h1), v0 = v1 ∧ H (h0, h1) ⦄. - Proof. - intros. - rewrite (wpshufd1_eq _ i n) ; [ | apply H0 ]. - now apply r_ret. - Qed. - - Ltac match_wpshufd1_vpshufd1 i := - (let w := fresh in - let y := fresh in - let b := fresh in - set (w := wpshufd1 _ _ i) ; - set (y := fun _ : Hacspec_Lib_Pre.int32 => _) ; - set (b := vpshufd1 _ _ _); - let k := fresh in - let l := fresh in - match goal with - | [ |- context [ ⊢ ⦃ ?P ⦄ ?lhs ≈ _ ⦃ _ ⦄ ] ] => set (k := P) ; set (l := lhs) - end ; - pattern (w) in l ; - subst l ; - apply (@r_bind _ _ _ _ (ret w) (prog (is_state b)) _ y _ (fun '(v0, h0) '(v1, h1) => v0 = v1 /\ k (h0, h1))) ; subst w y b ; hnf). - - Ltac solve_wpshufd1_vpshufd1 i := - match_wpshufd1_vpshufd1 i ; [now apply wpshufd1_eq_state | intros ]. - - Lemma wpshufd_128_eq_state : - forall {H} (rkey : 'word U128) (n : nat), - ⊢ ⦃ H ⦄ - ret (wpshufd_128 rkey n) ≈ - is_state (vpshufd rkey (repr n)) - ⦃ λ '(v0, h0) '(v1, h1), v0 = v1 ∧ H (h0, h1) ⦄. - Proof. - intros. - unfold wpshufd_128. - unfold wpshufd_128. - unfold iota. - unfold map. - - setoid_rewrite rebuild_128_eq. - unfold vpshufd. - - solve_wpshufd1_vpshufd1 0. - solve_wpshufd1_vpshufd1 1. - solve_wpshufd1_vpshufd1 2. - solve_wpshufd1_vpshufd1 3. - - apply r_ret. - intros ? ? [? [? [? []]]]. - subst. - subst H4. - split ; [ clear | assumption ]. - reflexivity. - Qed. - - Lemma wshufps_128_eq_state : - forall {H} (a b : 'word U128) (n : nat), - ⊢ ⦃ H ⦄ - ret (wshufps_128 (wrepr U8 n) a b) ≈ - is_state (vshufps a b (Hacspec_Lib_Pre.repr n)) - ⦃ λ '(v0, h0) '(v1, h1), v0 = v1 ∧ H (h0, h1) ⦄. - Proof. - intros. - unfold wshufps_128. - unfold vshufps. - unfold iota. - unfold map. - unfold vpshufd. - - solve_wpshufd1_vpshufd1 0. - solve_wpshufd1_vpshufd1 1. - solve_wpshufd1_vpshufd1 2. - solve_wpshufd1_vpshufd1 3. - - rewrite rebuild_128_eq. - - intros. - apply r_ret. - intros ? ? [? [? [? []]]]. - subst. - subst H4. - split ; [ clear | assumption ]. - reflexivity. - Qed. - - Lemma key_combined_eq id0 rcon rkey temp2 (pre : precond) : - (pdisj pre id0 fset0) -> - ⊢ ⦃ pre ⦄ - JKEY_COMBINE id0 rcon rkey temp2 - ≈ - is_state (key_combine rcon rkey temp2) - ⦃ fun '(v0, h0) '(v1, h1) => - (exists o1 o2, v0 = [('word U128 ; o1) ; ('word U128 ; o2)] - /\ (o1, o2) = v1) /\ pre (h0, h1) ⦄. - Proof. - intros H_pdisj. - set (JKEY_COMBINE _ _ _ _). - unfold JKEY_COMBINE in r. - unfold get_translated_static_fun in r. - simpl in r. - unfold translate_call, translate_call_body in r |- *. - Opaque translate_call. - simpl in r. - - subst r. - rewrite !zero_extend_u. - unfold key_combine. - - apply better_r_put_lhs. - apply better_r_put_lhs. - apply better_r_put_lhs. - remove_get_in_lhs. - bind_jazz_hac ; [ shelve | ]. - do 5 (apply better_r_put_lhs ; do 2 remove_get_in_lhs ; bind_jazz_hac ; [shelve | ]). - apply better_r_put_lhs ; do 2 remove_get_in_lhs ; apply r_ret. - - intros. - split. - { - destruct_pre. - eexists. - eexists. - split ; [ reflexivity | ]. - cbn. - rewrite !zero_extend_u. - reflexivity. - } - { - destruct_pre. - pdisj_apply H_pdisj. - } - - Unshelve. - { - unfold tr_app_sopn_tuple. - unfold sopn_sem. - unfold sopn.get_instr_desc. - - set (chCanonical _). - cbn in s. - subst s. - - set (tr_app_sopn _ _ _ _). - cbn in y. - subst y. - hnf. - - replace (toword _) with (255)%Z by (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; now rewrite coerce_to_choice_type_K). - - replace (truncate_chWord U128 _) with rkey by (simpl ; now rewrite zero_extend_u). - - apply (wpshufd_128_eq_state rkey 255). - } - { - unfold tr_app_sopn_tuple. - unfold sopn_sem. - unfold sopn.get_instr_desc. - - set (totce _) at 2. - cbn in t. - unfold totce in t. - - set (chCanonical _). - cbn in s. - subst s. - - set (tr_app_sopn _ _ _ _). - cbn in y. - subst y. - hnf. - - unfold totce. - subst t. - unfold ".π2". - - unfold lift2_vec. - - unfold map2. - unfold split_vec. - unfold map. - unfold iota. - - set (nat_of_wsize U128 %/ nat_of_wsize U128 + - nat_of_wsize U128 %% nat_of_wsize U128). - cbn in n. - subst n. - hnf. - - replace (word.subword _ _ _) with temp2. - 2:{ - destruct temp2. - cbn. - apply word_ext. - cbn. - rewrite !Zmod_mod. - rewrite Zmod_small. - reflexivity. - apply (ssrbool.elimT (iswordZP _ _)). - apply i. - } - replace (word.subword _ _ _) with rcon. - 2:{ - destruct rcon. - cbn. - apply word_ext. - cbn. - rewrite !Zmod_mod. - rewrite Zmod_small. - reflexivity. - apply (ssrbool.elimT (iswordZP _ _)). - apply i. - } - - replace (truncate_chWord _ _) with (wrepr U8 16) by now do 2 (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). - - unfold make_vec. - unfold wcat_r. - rewrite Z.shiftl_0_l. - rewrite Z.lor_0_r. - - unfold mkword. - - epose (wshufps_128_eq_state temp2 rcon 16). - unfold lift_scope. - unfold is_state at 1. - unfold lift_code_scope. - unfold prog. - - rewrite <- bind_ret. - set (ret _). - pattern (wshufps_128 (wrepr U8 16) temp2 rcon) in r0. - subst r0. - - eapply (@r_bind _ _ _ _ (ret (wshufps_128 (wrepr U8 16) temp2 rcon))). - apply r. - intros. - apply r_ret. - intros ? ? []. - subst. - split. - destruct a₁0. cbn. unfold wrepr. cbn. apply word_ext. - rewrite Zmod_small. - reflexivity. - apply (ssrbool.elimT (iswordZP _ _)). - apply i. - apply H0. - } - { - cbn. - apply r_ret. - intros. - split. - reflexivity. - apply H. - } - { - - unfold tr_app_sopn_tuple. - unfold sopn_sem. - unfold sopn.get_instr_desc. - - set (totce _) at 2. - cbn in t. - unfold totce in t. - - set (chCanonical _). - cbn in s. - subst s. - - set (tr_app_sopn _ _ _ _). - cbn in y. - subst y. - hnf. - - unfold totce. - subst t. - unfold ".π2". - - unfold lift2_vec. - - unfold map2. - unfold split_vec. - unfold map. - unfold iota. - - set (nat_of_wsize U128 %/ nat_of_wsize U128 + - nat_of_wsize U128 %% nat_of_wsize U128). - cbn in n. - subst n. - hnf. - - replace (word.subword _ _ _) with a₁0. - 2:{ - destruct a₁0. - cbn. - apply word_ext. - cbn. - rewrite !Zmod_mod. - rewrite Zmod_small. - reflexivity. - apply (ssrbool.elimT (iswordZP _ _)). - apply i. - } - replace (word.subword _ _ _) with a₁1. - 2:{ - destruct a₁1. - cbn. - apply word_ext. - cbn. - rewrite !Zmod_mod. - rewrite Zmod_small. - reflexivity. - apply (ssrbool.elimT (iswordZP _ _)). - apply i. - } - - replace (truncate_chWord _ _) with (wrepr U8 140) by now repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). - - rewrite <- bind_ret. - set (ret _). - pattern (wshufps_128 (wrepr U8 140) a₁0 a₁1) in r. - subst r. - eapply (@r_bind _ _ _ _ (ret (wshufps_128 (wrepr U8 140) a₁0 a₁1))). - apply (wshufps_128_eq_state a₁0 a₁1 140). - - intros. - apply r_ret. - intros ? ? []. - subst. - split. - unfold make_vec. - cbn. - rewrite Z.lor_0_r. - destruct a₁2. cbn. unfold wrepr. cbn. apply word_ext. - rewrite Zmod_small. - cbn. - reflexivity. - apply (ssrbool.elimT (iswordZP _ _)). - apply i. - apply H0. - } - { - apply r_ret. - solve_post_from_pre. - } - { - apply r_ret. - solve_post_from_pre. - } - (* Cleanup *) - Transparent translate_call. - Qed. - - Lemma sbox_eq : - (forall n i, (i < 4)%nat -> - is_pure (array_index sbox_v - (index_u8 (lift_to_both0 n) (lift_to_both0 (usize i)))) = waes.Sbox (word.subword (i * U8) U8 n)). - Proof. - intros. - rewrite index_8_eq ; [ | apply H ]. - - destruct (is_pure (index_u8 _ _)). - destruct toword. - - reflexivity. - - (* SLOW! *) (* admit. *) - do 8 (destruct p ; [ | | reflexivity ]) ; exfalso ; destruct p ; discriminate i0. - - easy. - (* Admitted. *) Qed. - - Lemma SubWord_eq (n : int32) : - waes.SubWord n = is_pure (subword n). - Proof. - intros. - unfold waes.SubWord. - unfold split_vec. - replace (U32 %/ U8 + U32 %% U8) with 4 by reflexivity. - - unfold map. - unfold iota. - rewrite rebuild_32_eq. - - unfold subword. - do 4 (rewrite <- sbox_eq ; [ | easy ]). - - easy. - Qed. - - Lemma keygen_assist_eq id0 (v1 : 'word U128) (v2 : 'word U8) (pre : precond) : - (pdisj pre id0 fset0) -> - ⊢ ⦃ pre ⦄ - ret (waes.wAESKEYGENASSIST v1 v2) - ≈ - prog (is_state (aeskeygenassist v1 v2)) - ⦃ fun '(v0, h0) '(v1, h1) => (v0 = v1) /\ pre (h0, h1) ⦄. - Proof. - intros. - - unfold waes.wAESKEYGENASSIST. - - rewrite rebuild_128_eq. - - unfold aeskeygenassist. - - match_pattern_and_bind_repr (@word.subword (wsize_size_minus_1 U128).+1 (1 * U32) U32 v1). - { - apply r_ret. - intros. - rewrite index_32_eq ; [ | easy ]. - split. setoid_rewrite wrepr_unsigned. reflexivity. assumption. - } - - match_pattern_and_bind_repr (@word.subword (wsize_size_minus_1 U128).+1 (3 * U32) U32 v1). - { - apply r_ret. - intros. - rewrite index_32_eq ; [ | easy ]. - split ; [ setoid_rewrite wrepr_unsigned | ] ; easy. - } - - match_pattern_and_bind (waes.SubWord a₀). - { - subst. - replace (is_pure (lift_to_both0 _)) with (@repr U32 a₁). - 2:{ - pose (isword_Z _ a₁). - destruct a₁. - apply word_ext. - now rewrite Zmod_small. - } - rewrite (SubWord_eq (repr a₁)). - apply r_ret ; easy. - } - - match_pattern_and_bind (word.wxor (waes.RotWord a₀1) (zero_extend U32 (sz':=U8) v2)). - { - subst. - - unfold waes.RotWord. - rewrite rebuild_32_eq. - rewrite !index_8_eq ; try lia. - unfold rotword. - - apply r_ret. - intros. - split. - - reflexivity. - - apply H0. - } - - match_pattern_and_bind (waes.SubWord a₀0). - { - subst. - replace (is_pure (lift_to_both0 _)) with (@repr U32 a₁0). - 2:{ - pose (isword_Z _ a₁0). - destruct a₁0. - apply word_ext. - now rewrite Zmod_small. - } - rewrite (SubWord_eq (repr a₁0)). - apply r_ret ; easy. - } - - match_pattern_and_bind (word.wxor (waes.RotWord a₀3) (zero_extend U32 (sz':=U8) v2)). - { - subst. - - unfold waes.RotWord. - rewrite rebuild_32_eq. - rewrite !index_8_eq ; try lia. - unfold rotword. - - apply r_ret. - intros. - split. - - reflexivity. - - apply H0. - } - - subst. - apply r_ret. - intros. - subst. - all: try (intros ? ? [] ; subst ; assumption). - easy. - Qed. - - Lemma key_expand_eq id0 rcon rkey temp2 (pre : precond) : - (pdisj pre id0 fset0) -> - ⊢ ⦃ pre ⦄ - JKEY_EXPAND id0 rcon rkey temp2 - ≈ - key_expand (wrepr U8 rcon) rkey temp2 - ⦃ fun '(v0, h0) '(v1, h1) => - (exists o1 o2, v0 = [('word U128 ; o1) ; ('word U128 ; o2)] - /\ (o1, o2) = v1) /\ pre (h0, h1) ⦄. - Proof. - intros H_pdisj. - set (JKEY_EXPAND _ _ _ _). - unfold translate_call, translate_call_body in r |- *. - Opaque translate_call. - unfold JKEY_EXPAND in r. - cbn in r. - subst r. - rewrite !zero_extend_u. - - apply better_r_put_lhs. - apply better_r_put_lhs. - apply better_r_put_lhs. - - do 2 remove_get_in_lhs. - bind_jazz_hac ; [shelve | ]. - - eapply rpre_weak_hypothesis_rule'. - intros ? ? [? H]. - - apply better_r_put_lhs. - do 3 remove_get_in_lhs. - - rewrite bind_assoc. - rewrite bind_assoc. - rewrite <- bind_ret. - match goal with - | [ |- context [ ⊢ ⦃ ?pre ⦄ _ ≈ _ ⦃ _ ⦄ ] ] => set (P := pre) - end. - apply r_bind with (mid := λ '(v0, h0) '(v1, h1), - (∃ o1 o2 : 'word U128, - v0 = [('word U128; o1) ; ('word U128; o2)] ∧ (o1, o2) = v1) /\ P (h0, h1)). - 2:{ - intros. - subst P. - destruct a₁0. - destruct a₀0 as [ | ? [] ] ; simpl ; repeat apply better_r_put_lhs ; repeat remove_get_in_lhs ; apply r_ret ; intros ; destruct_pre ; try easy. - split. - eexists. - eexists. - split. - reflexivity. - rewrite !zero_extend_u. - inversion H25. - subst. - inversion H24. - subst. - cbn. - now rewrite !zero_extend_u. - - pdisj_apply H_pdisj. - } - - subst. - subst P. - - intros. - apply (key_combined_eq (id0~1)%positive rkey a₁ temp2). - - split. - - intros. - subst. - repeat destruct H. - subst. - cbn in H2. - subst. - unfold set_lhs. - - subst. - destruct_pre. - repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). - eexists. - split. - split ; [ reflexivity | ]. - eexists. - split ; [ | reflexivity ]. - eexists. - split ; [ | reflexivity ]. - exists (set_heap H9 (translate_var s_id' v) a). - split ; [ | reflexivity ]. - pdisj_apply H_pdisj. - etransitivity. - apply fresh2_weak. - assumption. - - rewrite ![set_heap _ (translate_var s_id' v) a]set_heap_commut - ; (reflexivity || - (apply injective_translate_var2 ; - red ; - intros ; - subst ; - now apply (precneq_I s_id'))). - - Unshelve. - { - - (* Keygen assist *) - - unfold tr_app_sopn_tuple. - unfold sopn_sem. - unfold sopn.get_instr_desc. - - - Opaque aeskeygenassist. - repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). - Transparent aeskeygenassist. - apply (keygen_assist_eq (id0~1)%positive ). - - split. - - intros. - subst. - destruct_pre. - unfold set_lhs. - eexists. - eexists. - eexists. - split. - exists (set_heap H5 (translate_var s_id' v) a). - split. - pdisj_apply H_pdisj. - - etransitivity. - apply fresh2_weak. - apply H0. - reflexivity. - reflexivity. - - rewrite ![set_heap _ (translate_var s_id' v) a]set_heap_commut ; - (reflexivity || - (apply injective_translate_var2 ; - red ; - intros ; - subst ; - now apply (precneq_I s_id'))). - - intros. - subst. - destruct_pre. - unfold set_lhs. - eexists. - split ; [ | reflexivity ]. - eexists. - split ; [ | reflexivity ]. - eexists. - split ; [ | reflexivity ]. - eapply H_pdisj. - apply H. - apply H6. - } - - - easy. - Transparent translate_call. - Qed. - - Lemma rcon_eq id0 (j : nat) (pre : precond) : - (pdisj pre id0 fset0) -> - (0 <= j < 10)%nat -> - ⊢ ⦃ pre ⦄ - JRCON id0 (Z.pos (Pos.of_succ_nat j)) - ≈ - is_state (array_index (rcon_v) (@repr U32 (S j))) - ⦃ fun '(v0, h0) '(v1, h1) => - (exists o1, v0 = [('int; o1)] /\ repr o1 = v1) /\ pre (h0, h1) ⦄. - Proof. - intros. - unfold JRCON. - unfold get_translated_static_fun. - simpl. - apply better_r_put_lhs. - remove_get_in_lhs. - fold @bind. - rewrite !coerce_to_choice_type_K. - repeat setoid_rewrite coerce_to_choice_type_K. - cbn. - rewrite !array_from_list_helper_equation_2. - simpl. - rewrite Hacspec_Lib_Pre.array_index_equation_2. - simpl. - cbn. - unfold array_index_clause_2. - unfold array_index_clause_2_clause_1. - simpl. - - (* SLOW! *) (* admit. *) - do 10 (destruct j as [ | j ] ; [ simpl ; repeat (remove_get_in_lhs ; simpl) ; apply better_r_put_lhs ; remove_get_in_lhs ; apply r_ret ; intros ; destruct_pre ; split ; [ eexists ; split ; [ | reflexivity] ; f_equal ; unfold totce ; repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K) ; reflexivity | eapply H ; [ reflexivity | reflexivity | ] ; eapply H ; [ reflexivity | reflexivity | ] ; apply H5 ] | ]). - exfalso. - lia. - (* Admitted. *) Qed. - - Ltac split_post := - repeat - match goal with - | |- (_ ⋊ _) _ => split - | |- _ /\ _ => split - | |- set_lhs _ _ _ _ => eexists - | |- set_rhs _ _ _ _ => eexists - end. - - Definition seq_push_list_app : forall {A} (t : seq A) (s : A), (seq_to_list A (Hacspec_Lib_Pre.seq_push t s) = seq_to_list A t ++ [s]). - Proof. - intros. - pose (seq_to_list_id t). - replace (t) with (fmap_of_seq (seq_to_list _ t)) at 2. - replace (seq_to_list A (fmap_of_seq (seq_to_list A t)) ++ [s]) - with - (seq_to_list A (fmap_of_seq ((seq_to_list A t) ++ [s]))). - reflexivity. - unfold seq_from_list in e. - rewrite e. - rewrite seq_from_list_id. - reflexivity. - Qed. - - Definition seq_to_arr (X : seq uint128) : FMap.fmap_type Z_ordType U8.-word := - let l0 := (unzip2 X) in - mkfmap (zip (ziota 0 (size l0)) (seq.foldr (fun x y => y ++ (split_vec U8 x)) [] l0)). - - Definition seq_upd_from_arr (X : seq uint128) (v : 'array) : FMap.fmap_type Z_ordType U8.-word := - let l0 := (seq_to_list int128 X) in - foldr (fun kv m => (chArray_set m AAscale kv.1 kv.2)) v (rev (zip (ziota 0 (Z.of_nat (size l0))) (l0))). - - Lemma seq_udp_from_arr_push : forall a b c, - (seq_upd_from_arr (Hacspec_Lib_Pre.seq_push a b) c) - = - (chArray_set (seq_upd_from_arr a c) AAscale (Z.of_nat (size (seq_to_list int128 a))) b). - Proof. - intros. - unfold seq_upd_from_arr. - simpl. - - rewrite seq_push_list_app. - rewrite size_cat. - rewrite Nat2Z.inj_add. - rewrite Z.add_1_r. - rewrite ziotaS_cat. - rewrite !Z.add_0_l. - - rewrite zip_cat. - rewrite rev_cat. - - unfold zip at 1. - unfold rev at 1, catrev. - rewrite foldr_cat. - - unfold foldr at 1. - reflexivity. - rewrite size_ziota. - rewrite Nat2Z.id. - reflexivity. - - lia. - Qed. - - Ltac solve_var_neq := - ((now apply injective_translate_var3) || - (apply injective_translate_var2 ; red ; intros ; subst)). - Ltac eexists_set_heap := - eexists ; split ; [ | - match goal with - | [ |- context [ - set_heap _ _ ?d - = set_heap _ _ ?d - ] ] => - reflexivity - end || - match goal with - | [ |- context [ - set_heap ?a ?b ?c - = set_heap _ _ ?e - ] ] => - rewrite [set_heap a b c]set_heap_commut ; [ reflexivity | - solve_var_neq ] - end]. - - Ltac solve_in_fset := - rewrite in_fset ; repeat (reflexivity || (rewrite mem_head) || (now rewrite Bool.orb_true_r) || (now rewrite Bool.orb_true_l) || rewrite in_cons ; simpl). - - Ltac remove_get_set_heap := - match goal with - | [ |- context [ get_heap (set_heap _ ?a _) ?a ] ] => - rewrite get_set_heap_eq - end || - rewrite get_set_heap_neq. - - Notation rkeys_loc := (CE_loc_to_loc rkeys_65_loc). - Notation temp2_loc := (CE_loc_to_loc temp2_67_loc). - Notation rkey_loc := (CE_loc_to_loc key_66_loc). - Lemma keys_expand_eq id0 rkey (pre : precond) : - (pdisj pre id0 (fset ([rkeys_loc ; temp2_loc ; rkey_loc ]))) -> - ⊢ ⦃ pre ⦄ - JKEYS_EXPAND id0 rkey - ≈ - is_state (keys_expand rkey) - ⦃ fun '(v0, h0) '(v1, h1) => - (exists o1, v0 = [('array; o1)] - /\ (forall k, k <= 10 -> ((chArray_get U128 o1 k (wsize_size U128)) - = is_pure (seq_index (A := @int U128) v1 (lift_to_both0 (repr k)))))) /\ pre (h0, h1) ⦄. - Proof. - intros H_pdisj. - set (JKEYS_EXPAND _ _). - unfold translate_call, translate_call_body in r |- *. - Opaque translate_call. - unfold JKEY_EXPAND in r. - unfold get_translated_static_fun, JAES_ROUNDS, get_translated_static_fun, translate_prog_static, translate_funs_static, translate_call_body in r. - simpl in r. - subst r. - rewrite !zero_extend_u. - - apply better_r_put_lhs. - remove_get_in_lhs. - apply better_r. eapply r_get_remember_lhs. intros. - - - unfold keys_expand. - - unfold let_mut_both at 1, is_state at 1, is_state at 1, is_state at 1. - Opaque is_state. Opaque is_pure. - match goal with - | [ |- context [ ⊢ ⦃ ?P ⦄ ?lhs ≈ ?rhs ⦃ ?Q ⦄ ] ] => - simpl rhs - end. - Transparent is_state. Transparent is_pure. - - rewrite bind_rewrite. - setoid_rewrite bind_rewrite. - apply better_r_put_rhs. - - unfold let_mut_both at 1, is_state at 1, is_state at 1, is_state at 1. - Opaque is_state. Opaque is_pure. - match goal with - | [ |- context [ ⊢ ⦃ ?P ⦄ ?lhs ≈ ?rhs ⦃ ?Q ⦄ ] ] => - simpl rhs - end. - Transparent is_state. Transparent is_pure. - - set (Hacspec_Lib_Pre.seq_new_ _ _). - - rewrite !zero_extend_u. - rewrite !coerce_to_choice_type_K. - - rewrite bind_rewrite. - apply better_r_put_rhs. - rewrite bind_rewrite. - - - apply better_r_put_rhs. - set (temp2 := repr 0) at 1 2. - apply better_r_put_rhs. - apply better_r_put_lhs. - - set (tr_app_sopn_tuple _ _ _). - cbn in s. - assert (s = temp2) by now apply word_ext. - generalize dependent s. - intros. - subst. - - apply better_r_put_lhs. - - - unfold let_mut_both at 1, is_state at 1, is_state at 1, is_state at 1. - Opaque is_state. Opaque is_pure. - match goal with - | [ |- context [ ⊢ ⦃ ?P ⦄ ?lhs ≈ ?rhs ⦃ ?Q ⦄ ] ] => - simpl rhs - end. - Transparent is_state. Transparent is_pure. - - rewrite bind_assoc. - - set (set_lhs _ _ _). - set (gl := _). - set (rkeys := Hacspec_Lib_Pre.seq_push _ _) in *. - - (* epose (fun l n => foldl (fun y x => (chArray_set y AAscale (fst x) (snd x))) x (zip (ziota 0 n) l)). *) - - pose (p0 := (λ (n : nat) '(rkeys, rkey, temp2) '(h0, h1), - set_lhs (translate_var id0 {| vtype := sword U128; vname := "temp2.336" |}) temp2 - (set_lhs (translate_var id0 {| vtype := sarr 176; vname := "rkeys.335" |}) (seq_upd_from_arr rkeys x) - (set_rhs rkeys_loc rkeys - (set_rhs temp2_loc temp2 - (set_rhs rkey_loc rkey - ( - (λ '(s₀, s₁), - (set_lhs (translate_var id0 {| vtype := sword U128; vname := "key.334" |}) rkey pre) - (s₀, s₁))))))) (h0, h1)) : nat -> key_list_t * 'word U128 * int → precond). - - (* pose (p0 := (λ (n : nat) '(rkeys, rkey, temp2) '(h0, h1), *) - (* set_lhs (translate_var id0 {| vtype := sword U128; vname := "temp2.336" |}) temp2 *) - (* (set_lhs (translate_var id0 {| vtype := sarr 176; vname := "rkeys.335" |}) (chArray_set x AAscale n rkey) *) - (* (set_rhs (seq_choice int128; 279) rkeys *) - (* (set_rhs (int_choice; 278) temp2 *) - (* (set_rhs (int_choice; 277) rkey *) - (* (set_rhs (seq_choice int128; 279) *) - (* (Hacspec_Lib_Pre.seq_new_ *) - (* (repr 0) (unsigned (lift_to_both0 (@repr U128 0)))) *) - (* (λ '(s₀, s₁), *) - (* (set_lhs (translate_var id0 {| vtype := sword U128; vname := "key.334" |}) rkey pre *) - (* ⋊ rem_lhs ($$"rkeys.335") x) *) - (* (s₀, s₁))))))) (h0, h1)) : nat -> key_list_t * 'word U128 * int → precond). *) - - subst gl. - - apply rpre_weaken_rule with (pre := (λ '(h0, h1), (p0 0 (rkeys, rkey, temp2)) (h0, h1))). - 2:{ - intros. - subst p. - subst p0. - - destruct_pre. - eexists_set_heap. - eexists ; split. - 2:{ - remove_get_set_heap. - subst rkeys. - unfold seq_upd_from_arr. - simpl. - reflexivity. - - solve_var_neq. - } - eexists ; split. - 2:{ - rewrite set_heap_commut. - reflexivity. - easy. - } - eexists ; split. - 2:{ - reflexivity. - } - eexists ; split. - 2:{ - reflexivity. - } - eexists ; split. - 2:{ - reflexivity. - } - eapply H_pdisj. - solve_in_fset. - assumption. - } - subst p. - - pose (P := fun (n : nat) (v0 : key_list_t * 'word U128 * @int U128) => fun '(h0, h1) => pre (h0, h1) /\ (forall i, i <= n -> (chArray_get U128 - (get_heap h0 - (translate_var id0 - {| vtype := sarr 176; vname := "rkeys.335" |})) i - (wsize_size U128)) = Hacspec_Lib_Pre.seq_index (fst (fst v0)) (repr (Z.of_nat i))) /\ size (Hacspec_Lib_Pre.seq_to_list _ (fst (fst v0))) = n.+1). - - (* /\ to_arr_int (get_heap h0 ($$"rkeys.335")) = (fst (fst v0))). *) - (* pose (P := fun n v1 '(s₀, s₁) => *) - (* ⊢ ⦃ fun '(h0 , h1) => (p0 n v1) (s₀ , s₁) -> (p0 n v1) (h0 , h1) ⦄ *) - (* v ← get (translate_var id0 *) - (* {| vtype := sarr 176; vname := "rkeys.335" |}) ;; *) - (* ret (trunc_list [sarr 176] [totce v]) ≈ *) - (* ret ((fst (fst v1))) *) - (* ⦃ λ '(v0, h0) '(v1, h1), *) - (* (exists o1, v0 = [('array; o1)] *) - (* /\ (forall k, k <= n -> *) - (* ((chArray_get U128 o1 k (wsize_size U128)) *) - (* = is_pure (seq_index (A := @int U128) v1 (lift_to_both0 (repr k)))))) /\ pre (h0, h1) ⦄). *) - - apply rpre_weaken_rule with (pre := (λ '(h0, h1), (P 0 (rkeys, rkey, temp2) (h0, h1)) /\ (p0 0 (rkeys, rkey, temp2)) (h0, h1))). - 2:{ - subst P. - hnf. - intros ? ? ?. - split ; [ | apply H ]. - repeat split. - - subst p0. - hnf in H. - destruct_pre. - pdisj_apply H_pdisj. - + rewrite in_fset. - now rewrite mem_head. - + rewrite in_fset. - rewrite in_cons ; simpl. - now rewrite mem_head. - + rewrite in_fset. - rewrite in_cons ; simpl. - rewrite in_cons ; simpl. - rewrite mem_head. - now rewrite Bool.orb_true_r. - - intros. - simpl. - subst p0. - hnf in H. - destruct_pre. - repeat (rewrite get_set_heap_neq ; [ | apply injective_translate_var3 ; reflexivity ]) ; - rewrite get_set_heap_eq. - repeat (rewrite get_set_heap_neq ; [ | apply injective_translate_var3 ; reflexivity ]). - intros. - destruct i ; [ | easy ]. - simpl. - rewrite chArray_get_set_eq. - reflexivity. - } - - - eapply (r_bind) with (mid := (λ '(v0, h0) '(v1, h1), P 10 v1 (h0, h1) /\ (p0 10 v1) (h0, h1))). - 2:{ - intros. - subst P. - destruct a₁. - destruct s. - rewrite ct_T_prod_propegate. - rewrite ct_T_prod_propegate. - subst p0. - hnf. - - rewrite bind_rewrite. - - eapply rpre_weak_hypothesis_rule'. - intros ? ? []. - (* eapply rpre_weaken_rule. *) - (* 2:{ intros ? ? []. apply H2. }. *) - (* clear H0. *) - (* unfold ".1" in H. *) - - - - destruct H. - eapply better_r_get_remind_lhs with (v := seq_upd_from_arr s x). - unfold Remembers_lhs , rem_lhs ; - [ intros ? ? ? ; - destruct_pre ; - repeat (rewrite get_set_heap_neq ; [ | apply injective_translate_var3 ; reflexivity ]) ; - rewrite get_set_heap_eq ]. - reflexivity. - - apply r_ret. - intros. - destruct_pre. - split. - - eexists. - split. - reflexivity. - intros. - - simpl. - rewrite !coerce_to_choice_type_K. - rewrite <- H15. - repeat (rewrite get_set_heap_neq ; [ | apply injective_translate_var3 ; reflexivity ]). - rewrite get_set_heap_eq. - reflexivity. - assumption. - - pdisj_apply H_pdisj. - + rewrite in_fset. - now rewrite mem_head. - + rewrite in_fset. - rewrite in_cons ; simpl. - now rewrite mem_head. - + rewrite in_fset. - rewrite in_cons ; simpl. - rewrite in_cons ; simpl. - rewrite mem_head. - now rewrite Bool.orb_true_r. - - } - { - (* simpl. *) - - intros. - - set (fun (_ : p_id) => _). - set (fun (_ : int_type) (_ : _ * _ * _) => _). - - rewrite !coerce_typed_code_K. - rewrite bind_rewrite. - rewrite bind_rewrite. - - unfold foldi_both', foldi_both, lift_scope, is_state at 1, lift_code_scope, prog, is_state at 1, foldi. - unfold foldi_pre ; replace (unsigned _ - unsigned _)%Z with 10%Z by reflexivity. - replace (Z.to_nat (11 - 1)) with 10 by reflexivity. - replace (Pos.to_nat 10) with 10 by reflexivity. - - (* subst rkeys. *) - - apply (@loop_eq (seq int128 '× int '× int) _ 10 0 _ _ _ _ _ _ _ p0 P). - { easy. } - { apply prec_I. } - { intros. etransitivity. apply prec_O. apply prec_O. } - { - intros. - - subst P. - subst y. - subst y0. - hnf. - - remove_get_in_lhs. - rewrite bind_assoc. - destruct c as [? []]. - destruct t0 as []. - - set (set_lhs _ _ _). - eapply r_bind with (mid := λ '(v0, h0) '(v1, h1), - (∃ o1 : (λ i : choice_type_choiceType, i) 'int, - v0 = [('int; o1)] ∧ repr o1 = v1) ∧ - p (h0, h1)) ; subst p. - { - set [ _ ]. - - replace (translate_call ssprove_jasmin_prog 12%positive - static_funs (s_id~1)%positive l) - with - (get_translated_static_fun ssprove_jasmin_prog 12%positive - static_funs (s_id~1)%positive l). - 2:{ - Transparent translate_call. - simpl. - cbn. - repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). - reflexivity. - Opaque translate_call. - } - subst l. - replace (totce _) - with (@existT choice_type (fun t : choice_type => Choice.sort (chElement t)) chInt (Pos.of_succ_nat k)). - 2:{ - cbn. - repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). - unfold totce. - rewrite Zpos_P_of_succ_nat. - reflexivity. - } - apply (rcon_eq (s_id~1)%positive k). - - shelve. - easy. - } - - intros. - apply rpre_hypothesis_rule. - intros. - destruct H1. - destruct H1. - destruct H1. - eapply rpre_weaken_rule. - 2:{ - intros ? ? []. subst. - apply H2. - } - clear H2. - rewrite H1. - rewrite <- H3. - clear H1 H3. - apply better_r_put_lhs. - remove_get_in_lhs. - subst p0. - remove_get_in_lhs. - remove_get_in_lhs. fold @bind. - - rewrite bind_assoc. - set (set_lhs _ _ _). - eapply r_bind with (mid := λ '(v0, h0) '(v1, h1), - (∃ o1 o2 : 'word U128, - v0 = [('word U128; o1); ('word U128; o2)] ∧ (o1, o2) = v1) - ∧ p (h0, h1)). - { - - pose (key_expand_eq (s_id~0~1)%positive x0 t1 (mkWord (nbits:=U128) (toword:=toword) i) p). - unfold JKEY_EXPAND in r. - - replace (translate_call _ _ _ _ _) - with - (get_translated_static_fun ssprove_jasmin_prog 11%positive - static_funs (s_id~0~1)%positive [('int; x0); ('word U128; t1); ('word U128; (mkWord (nbits:=U128) (toword:=toword) i))]). - 2:{ - Transparent translate_call. - simpl. - cbn. - repeat (cbn ; rewrite <- !coerce_to_choice_type_clause_1_equation_1; rewrite <- coerce_to_choice_type_equation_1; rewrite coerce_to_choice_type_K). - rewrite !zero_extend_u. - reflexivity. - Opaque translate_call. - } - unfold lift_to_both0. - - unfold is_pure. - unfold lift_to_both. - unfold repr. - apply r. - - shelve. - - } - - intros. - apply rpre_hypothesis_rule. - intros. - destruct H1. - destruct H1. - destruct H1. - eapply rpre_weaken_rule. - 2:{ - intros ? ? []. subst. - apply H2. - } - clear H2. - destruct H1. - destruct a₁0. - rewrite ct_T_prod_propegate. - simpl. - inversion H2. - subst. - clear H2. - - apply better_r_put_lhs ; fold @bind. - apply better_r_put_lhs ; fold @bind. - simpl in p. - subst p. - rewrite !coerce_to_choice_type_K. - (* rewrite !zero_extend_u. *) - remove_get_in_lhs. - apply better_r_get_remind_lhs with (v := seq_upd_from_arr t0 x). - unfold Remembers_lhs , rem_lhs ; - [ intros ? ? ? ; - destruct_pre ; - repeat (rewrite get_set_heap_neq ; [ | apply injective_translate_var3 ; reflexivity ]) ; - rewrite get_set_heap_eq ]. - reflexivity. - remove_get_in_lhs. - - rewrite !coerce_to_choice_type_K. - rewrite !zero_extend_u. - apply better_r_put_lhs. - - - apply better_r_put_rhs. - apply better_r_put_rhs. - apply better_r_put_rhs. - - apply r_ret. - intros. - shelve. - } - shelve. - - Unshelve. - { - split ; [ | discriminate]. - intros. - destruct_pre. - eexists_set_heap. - 2:{ - apply (precneq_I s_id). - etransitivity. - apply H2. - apply H. - } - - repeat split. - { - pdisj_apply H_pdisj. - etransitivity. - apply H. - etransitivity. - apply preceq_I. - apply H2. - } - { - intros. - rewrite <- H6. - rewrite get_set_heap_neq. - reflexivity. - solve_var_neq. - - apply (precneq_I s_id). - etransitivity. - apply H2. - apply H. - - apply H1. - } - { - easy. - } - { - destruct_pre. - eexists_set_heap. - eexists_set_heap. - eexists_set_heap. - eexists_set_heap. - eexists_set_heap. - eexists_set_heap. - - pdisj_apply H_pdisj. - etransitivity. - apply H. - etransitivity. - apply preceq_I. - apply H2. - all: try (apply (precneq_I s_id) ; etransitivity ; [ apply H2 | apply H ]). - } - } - { - split. - intros. - subst p. - destruct_pre. - destruct_pre. - eexists_set_heap. - eexists_set_heap. - repeat split. - { - pdisj_apply H_pdisj. - all: try solve_in_fset. - - etransitivity. - apply H. - etransitivity. - apply preceq_O. - etransitivity. - apply preceq_I. - apply H2. - } - { - intros. - rewrite <- H8. - rewrite get_set_heap_neq. - reflexivity. - solve_var_neq. - (apply (precneq_O s_id) ; etransitivity ; [apply preceq_I | etransitivity ; [ apply H2 | apply H ] ]). - apply H1. - } - { - assumption. - } - { - destruct_pre. - eexists_set_heap. - eexists_set_heap. - eexists_set_heap. - eexists_set_heap. - eexists_set_heap. - eexists_set_heap. - pdisj_apply H_pdisj. - etransitivity. - apply H. - etransitivity. - apply preceq_O. - etransitivity. - apply preceq_I. - apply H2. - - all: (apply (precneq_O s_id) ; etransitivity ; [apply preceq_I | etransitivity ; [ apply H2 | apply H ] ]). - } - { - (apply (precneq_O s_id) ; etransitivity ; [apply preceq_I | etransitivity ; [ apply H2 | apply H ] ]). - } - { - (apply (precneq_O s_id) ; etransitivity ; [apply preceq_I | etransitivity ; [ apply H2 | apply H ] ]). - } - { - discriminate. - } - } - { - destruct_pre. - repeat split. - { - pdisj_apply H_pdisj ; solve_in_fset. - } - { - intros. - - remove_get_set_heap. - - - destruct (Nat.eq_dec i0 k.+1). - + subst. - unfold Hacspec_Lib_Pre.seq_index. - simpl. - unfold Hacspec_Lib_Pre.seq_push. - unfold seq_from_list. - simpl. - unfold fmap_of_seq. - rewrite size_cat. - rewrite H33. - replace (Z.to_nat _) with (k.+1). - 2:{ - cbn. - rewrite Zmod_small. - setoid_rewrite SuccNat2Pos.id_succ. - reflexivity. - do 10 (destruct k ; [ easy | ]) ; discriminate. - } - rewrite mkfmapfpE. - rewrite mem_iota. - replace (0 <= _ < _) with true . - 2:{ - simpl. - rewrite addn1. - rewrite leqnn. - reflexivity. - } - rewrite <- H33. - unfold mkfmapfp. - replace (size (seq_to_list int128 _)) with - ((size (seq_to_list int128 t0 ++ [s])%list).-1). - 2:{ - rewrite size_cat. - rewrite addn1. - simpl. reflexivity. - } - rewrite <- (size_map Some). - rewrite nth_last. - pose last_map. - rewrite map_cat. - rewrite last_cat. - simpl. - now rewrite chArray_get_set_eq. - + assert (i0 <= k) by lia. - specialize (H18 i0 H2). - - assert (forall (A : ChoiceEquality) (H_default : Default A) t (s : A) i, (0 <= Z.of_nat i < modulus (wsize_size_minus_1 U32).+1)%Z -> i < size (Hacspec_Lib_Pre.seq_to_list _ t) -> Hacspec_Lib_Pre.seq_index (Hacspec_Lib_Pre.seq_push t s) (repr (Z.of_nat i)) = Hacspec_Lib_Pre.seq_index t (repr (Z.of_nat i))). - { - clear ; intros. - unfold Hacspec_Lib_Pre.seq_index. - rewrite fmap_of_seqE. - rewrite map_cat. - rewrite nth_cat. - replace (_ < _) with true. - 2:{ - rewrite (size_map). - simpl. - setoid_rewrite Zmod_small. - rewrite Nat2Z.id. - now rewrite H0. - apply H. - } - rewrite <- fmap_of_seqE. - simpl. - replace (fmap_of_seq _) with t. - reflexivity. - pose seq_to_list_id. unfold seq_from_list in e. - now rewrite e. - } - - rewrite H3. - 2:{ - split. lia. - apply Z.lt_le_trans with (m := Z.of_nat 10). - 2: easy. - apply inj_lt. - lia. - } - 2:{ - now rewrite H33. - } - rewrite <- H18. - - rewrite chArray_get_set_neq. - - remove_get_set_heap. - remove_get_set_heap. - - reflexivity. - - { solve_var_neq. } - { lia. } - } - { - rewrite seq_push_list_app. - rewrite size_cat. - rewrite H33. - now rewrite addn1. - } - { - rewrite !zero_extend_u. - destruct_pre. - eexists_set_heap. - eexists ; split. - 2:{ - rewrite seq_udp_from_arr_push. - rewrite H33. - simpl. - reflexivity. - } - eexists ; split. - 2:{ - reflexivity. - } - eexists ; split. - 2:{ - reflexivity. - } - eexists ; split. - 2:{ - reflexivity. - } - eexists ; split. - 2:{ - reflexivity. - } - pdisj_apply H_pdisj ; solve_in_fset. - } - } - { - intros. - destruct c as [[]]. - destruct_pre. - subst p0. - hnf. - repeat split. - { - intros. - subst. - destruct_pre. - eexists ; split. - 2:{ - rewrite set_heap_commut. - reflexivity. - apply injective_translate_var2. - red ; intros. - subst. - eapply prec_precneq. - apply H. - apply H1. - } - eexists ; split. - 2:{ - rewrite set_heap_commut. - reflexivity. - apply injective_translate_var2. - red ; intros. - subst. - eapply prec_precneq. - apply H. - apply H1. - } - eexists ; split. - 2:{ - reflexivity. - } - eexists ; split. - 2:{ - reflexivity. - } - eexists ; split. - 2:{ - reflexivity. - } - eexists ; split. - 2:{ - rewrite set_heap_commut. - reflexivity. - apply injective_translate_var2. - red ; intros. - subst. - eapply prec_precneq. - apply H. - apply H1. - } - pdisj_apply H_pdisj. - etransitivity. - apply H. - apply H1. - } - { - discriminate. - } - } - } - Qed. - - Lemma shift_rows_eq id0 (state : 'word U128) (pre : precond) : - (pdisj pre id0 fset0) -> - ⊢ ⦃ pre ⦄ ret (waes.ShiftRows state) ≈ - prog (is_state (shiftrows state)) - ⦃ λ '(v0, h0) '(v1, h1), v0 = v1 ∧ pre (h0, h1) ⦄. - intros. - unfold waes.ShiftRows. - unfold waes.to_matrix. - unfold waes.to_state. - rewrite rebuild_32_eq. - rewrite rebuild_32_eq. - rewrite rebuild_32_eq. - rewrite rebuild_32_eq. - rewrite rebuild_128_eq. - unfold shiftrows. - rewrite !index_32_eq. - rewrite !index_8_eq. - - set (rebuild_u32 _ _ _ _). - set (rebuild_u32 _ _ _ _). - set (rebuild_u32 _ _ _ _). - set (rebuild_u32 _ _ _ _). - - apply r_ret. - { - intros. - split. - - reflexivity. - - easy. - } - - all: lia. - Qed. - - Lemma sub_bytes_eq id0 (state : 'word U128) (pre : precond) : - (pdisj pre id0 fset0) -> - ⊢ ⦃ λ '(s₀0, s₁0), pre (s₀0, s₁0) ⦄ ret (waes.SubBytes state) ≈ - prog (is_state (subbytes (state))) - ⦃ λ '(v0, h0) '(v1, h1), v0 = v1 ∧ pre (h0, h1) ⦄. - Proof. - intros. - unfold waes.SubBytes. - unfold subbytes. - - simpl map. - rewrite rebuild_128_eq. - - rewrite !SubWord_eq. - rewrite !index_32_eq. - apply r_ret ; easy. - - all: lia. - Qed. - - Lemma mix_columns_eq id0 (state : 'word U128) (pre : precond) : - (pdisj pre id0 fset0) -> - ⊢ ⦃ λ '(s₀0, s₁0), pre (s₀0, s₁0) ⦄ ret (waes.MixColumns state) ≈ - prog (is_state (mixcolumns (state))) - ⦃ λ '(v0, h0) '(v1, h1), v0 = v1 ∧ pre (h0, h1) ⦄. - Proof. - (* Mix Columns is not defined in jasmin, - so we assume the equality for now *) - Admitted. - - Lemma aes_enc_eq id0 state key (pre : precond) : - (pdisj pre id0 fset0) -> - ⊢ ⦃ pre ⦄ - ret (waes.wAESENC state key) - ≈ - prog (is_state (aesenc state key)) - ⦃ fun '(v0, h0) '(v1, h1) => (v0 = v1) /\ pre (h0, h1) ⦄. - Proof. - intros. - unfold waes.wAESENC. - unfold aesenc. - - match_pattern_and_bind (waes.ShiftRows state). - { - Set Printing Coercions. - unfold lift_to_both0. - unfold lift_to_both. - unfold is_pure. - unfold lift_scope. - unfold is_state at 1. - unfold lift_code_scope. - - apply (shift_rows_eq id0). - apply H. - } - - subst. - - match_pattern_and_bind (waes.SubBytes a₁). - { - unfold lift_to_both0. - unfold lift_to_both. - unfold is_pure. - unfold lift_scope. - unfold is_state at 1. - unfold lift_code_scope. - - apply (sub_bytes_eq id0). - apply H. - } - - subst. - - match_pattern_and_bind (waes.MixColumns a₁0). - { - unfold lift_to_both0. - unfold lift_to_both. - unfold is_pure. - unfold lift_scope. - unfold is_state at 1. - unfold lift_code_scope. - - apply (mix_columns_eq id0). - apply H. - } - - subst. - - all: try (intros ? ? [] ; subst ; assumption). - - apply r_ret. - intros. - split. - - reflexivity. - - assumption. - Qed. - - Lemma aes_enc_last_eq id0 state key (pre : precond) : - (pdisj pre id0 fset0) -> - ⊢ ⦃ pre ⦄ - ret (waes.wAESENCLAST state key) - ≈ - prog (is_state (aesenclast state key)) - ⦃ fun '(v0, h0) '(v1, h1) => (v0 = v1) /\ pre (h0, h1) ⦄. - Proof. - intros. - unfold waes.wAESENCLAST. - unfold aesenclast. - - match_pattern_and_bind (waes.ShiftRows state). - { - unfold lift_to_both0. - unfold lift_to_both. - unfold is_pure. - unfold lift_scope. - unfold is_state at 1. - unfold lift_code_scope. - - apply (shift_rows_eq id0). - apply H. - } - - subst. - - match_pattern_and_bind (waes.SubBytes a₁). - { - unfold lift_to_both0. - unfold lift_to_both. - unfold is_pure. - unfold lift_scope. - unfold is_state at 1. - unfold lift_code_scope. - - apply (sub_bytes_eq id0). - apply H. - } - - subst. - - all: try (intros ? ? [] ; subst ; assumption). - apply r_ret. - intros. - split. - - reflexivity. - - assumption. - Qed. - - - Notation state_loc := (CE_loc_to_loc state_120_loc). - Lemma addroundkey_eq id0 (rkeys : 'array) (rkeys' : seq int128) m (pre : precond) : - (pdisj pre id0 (fset [ state_loc ])) -> - (forall k, k <= 10 -> ((chArray_get U128 rkeys k (wsize_size U128)) - = is_pure (seq_index rkeys' (lift_to_both0 (repr k))))) -> - (* ((forall (j : nat), *) - (* forall (a : 'word U8) (b : 'word U128), *) - (* (getm rkeys (Z.of_nat j) = Some a) -> *) - (* (getm rkeys' (j / 16) = Some b) -> *) - (* a = index_u8 (index_u32 b (repr ((j mod 16) / 4))) (repr (j mod 4)))) -> *) - ⊢ ⦃ pre ⦄ - JAES_ROUNDS id0 rkeys m - ≈ - is_state (aes_rounds rkeys' m) - ⦃ fun '(v0, h0) '(v1, h1) => (exists o1, v0 = [('word U128; o1)] /\ o1 = v1) /\ pre (h0, h1) ⦄. - Proof. - intros H_pdisj rkeys_ext. - set (JAES_ROUNDS _ _ _). - unfold JAES_ROUNDS in r. - Transparent translate_call. - unfold get_translated_static_fun in r. - simpl in r. - unfold translate_call_body in r. - Opaque translate_call. - simpl in r. - subst r. - rewrite !zero_extend_u. - - apply better_r, r_put_lhs, better_r. - apply better_r, r_put_lhs, better_r. - remove_get_in_lhs. - apply better_r, r_put_lhs, better_r. - remove_get_in_lhs. - remove_get_in_lhs. - rewrite !zero_extend_u. - - unfold aes_rounds. - - rewrite !coerce_to_choice_type_K. - - unfold lift_to_both0 at 1. - - unfold let_mut_both at 1, is_state at 1, is_state at 1, is_state at 1. - Opaque is_state. Opaque is_pure. - simpl. Transparent is_state. Transparent is_pure. - - rewrite (rkeys_ext 0) ; [ | lia ]. - - bind_jazz_bind. - { - (* xor *) - apply r_ret. - intros. - split. - reflexivity. - assumption. - } - - apply rpre_hypothesis_rule'. - intros ? ? []. - subst. - eapply rpre_weaken_rule. - 2:{ - intros ? ? []. subst. - apply H0. - } - clear H0. - - apply better_r_put_lhs. - apply better_r_put_rhs. - - rewrite bind_assoc. - rewrite bind_assoc. - rewrite <- bind_assoc. - - eapply r_bind. - { - set (fun (_ : p_id) => _). - set (fun (_ : int_type) (_ : _) => _). - - rewrite !coerce_typed_code_K. - rewrite bind_rewrite. - rewrite bind_rewrite. - - unfold foldi_both', foldi_both, lift_scope, is_state at 1, lift_code_scope, prog, is_state at 1, foldi. - unfold foldi_pre ; replace (unsigned _ - unsigned _)%Z with 9%Z by reflexivity. - replace (Z.to_nat (10 - 1)) with 9 by reflexivity. - replace (Pos.to_nat 9) with 9 by reflexivity. - - (* set (set_rhs _ _ _). *) - (* pattern (a₁) in p. *) - (* set (fun _ => _) in p. *) - (* subst y0. *) - (* subst p. *) - - set (y1 := - fun H : int => - set_rhs state_loc H - (set_lhs - (translate_var id0 - {| vtype := sword U128; vname := "state.327" |}) H - (set_lhs - (translate_var id0 - {| vtype := sword U128; vname := "in.326" |}) m - (set_lhs - (translate_var id0 - {| vtype := sarr 176; vname := "rkeys.325" |}) - rkeys pre)))). - eapply rpre_weaken_rule with (pre := y1 a₁). - 2:{ - intros. - subst y1 ; hnf. - destruct_pre. - eexists_set_heap. - eexists ; split. - 2:{ - rewrite set_heap_contract. - reflexivity. - } - eexists_set_heap. - eexists_set_heap. - assumption. - } - - apply (@loop_eq_simpl int _ 9 0 _ _ _ _ _ _ _ (fun _ => y1) a₁) ; subst y1 ; hnf. - { easy. } - { apply prec_I. } - { reflexivity. } - { - intros. - remove_get_in_lhs. - remove_get_in_lhs. - remove_get_in_lhs. - - (* AES Enc loop *) - bind_jazz_hac. - - unfold sopn_sem. - unfold sopn.get_instr_desc. - unfold asm_op_instr. - unfold asm_opI. - unfold arch_extra.get_instr_desc. - unfold semi. - unfold instr_desc. - unfold instr_desc_op. - unfold _asm_op_decl. - unfold _asm. - unfold x86_extra. - unfold x86.x86. - unfold x86_op_decl. - unfold x86_instr_desc. - unfold id_semi. - unfold Ox86_AESENC_instr. - unfold mk_instr_aes2. - unfold ".1". - unfold x86_AESENC. - unfold tr_app_sopn_tuple. - unfold encode_tuple. - unfold jasmin_translate.encode. - unfold w_ty. - unfold map. - unfold lchtuple. - unfold chCanonical. - unfold w2_ty. - unfold tr_app_sopn. - unfold embed_tuple. - unfold embed_ot. - unfold unembed. - simpl set_lhs. - unfold truncate_el. - unfold totce. - unfold ".π2". - - rewrite !coerce_to_choice_type_K. - - set (truncate_chWord _ _). - set (truncate_chWord _ _). - cbn in s0. - cbn in s. - subst s0. - subst s. - rewrite !zero_extend_u. - - unfold seq_index. - unfold lift_to_both0. - unfold lift_to_both at 2. - unfold is_pure at 2. - unfold lift_to_both at 2. - unfold is_pure at 2. - pose (rkeys_ext (S k)). - simpl in e. - rewrite <- e ; [ | lia ]. - clear e. - - apply (aes_enc_eq s_id c (chArray_get U128 rkeys (Pos.of_succ_nat k) (wsize_size U128))). - - (* pdisj *) - { - simpl. - split. - - { - intros. - destruct_pre. - eexists ; split. - 2:{ - rewrite set_heap_commut. - reflexivity. - solve_var_neq. - eapply prec_precneq. - apply H. - apply H2. - }. - - eexists_set_heap. - eexists_set_heap. - eexists_set_heap. - eexists_set_heap. - (* eexists_set_heap. *) - - pdisj_apply H_pdisj. - - etransitivity. - apply H. - apply H2. - - { - eapply prec_precneq. - apply H. - apply H2. - } - - { - eapply prec_precneq. - apply H. - apply H2. - } - - { - eapply prec_precneq. - apply H. - apply H2. - } - } - { - intros. - destruct_pre. - discriminate. - } - } - - apply better_r_put_rhs. - apply better_r_put_lhs. - - apply r_ret. - intros. - destruct_pre. - eexists ; split. - 2:{ - reflexivity. - } - eexists ; split. - 2:{ - reflexivity. - } - eexists ; split. - 2:{ - rewrite [set_heap (set_heap (set_heap H15 _ _) _ _) _ _]set_heap_commut. - rewrite set_heap_commut. - reflexivity. - solve_var_neq. - solve_var_neq. - } - eexists ; split. - 2:{ - rewrite [set_heap (set_heap H15 _ _) _ _]set_heap_commut. - rewrite [set_heap (set_heap (set_heap H15 _ _) _ _) _ _]set_heap_commut. - reflexivity. - solve_var_neq. - solve_var_neq. - } - pdisj_apply H_pdisj. - solve_in_fset. - } - (* pdisj *) - { - intros. - split. - { - intros. - destruct_pre. - eexists_set_heap. - eexists_set_heap. - eexists_set_heap. - eexists_set_heap. - pdisj_apply H_pdisj. - { - etransitivity. - apply H. - apply H1. - } - { - eapply prec_precneq. - apply H. - apply H1. - } - { - eapply prec_precneq. - apply H. - apply H1. - } - { - eapply prec_precneq. - apply H. - apply H1. - } - } - { - discriminate. - } - } - } - - intros. - hnf. - remove_get_in_lhs. - remove_get_in_lhs. - rewrite <- bind_ret. - bind_jazz_hac. - { - (* AES Enc last *) - - unfold sopn_sem. - unfold sopn.get_instr_desc. - unfold asm_op_instr. - unfold asm_opI. - unfold arch_extra.get_instr_desc. - unfold semi. - unfold instr_desc. - unfold instr_desc_op. - unfold _asm_op_decl. - unfold _asm. - unfold x86_extra. - unfold x86.x86. - unfold x86_op_decl. - unfold x86_instr_desc. - unfold id_semi. - unfold Ox86_AESENCLAST_instr. - unfold mk_instr_aes2. - unfold ".1". - unfold x86_AESENCLAST. - unfold tr_app_sopn_tuple. - unfold encode_tuple. - unfold jasmin_translate.encode. - unfold w_ty. - unfold map. - unfold lchtuple. - unfold chCanonical. - unfold w2_ty. - unfold tr_app_sopn. - unfold embed_tuple. - unfold embed_ot. - unfold unembed. - unfold truncate_el. - unfold totce. - unfold ".π2". - - rewrite !coerce_to_choice_type_K. - set (truncate_chWord _ _). - set (truncate_chWord _ _). - cbn in s0. - cbn in s. - subst s0. - subst s. - rewrite !zero_extend_u. - - unfold seq_index. - unfold lift_to_both0. - unfold lift_to_both. - unfold is_pure. - pose (rkeys_ext 10). - simpl in e. - rewrite <- e ; [ | lia ]. - clear e. - - apply (aes_enc_last_eq id0~1 a₁0 (chArray_get U128 rkeys 10 (wsize_size U128))). - - (* pdisj *) - { - split. - { - intros. - destruct_pre. - eexists ; split. - 2:{ - reflexivity. - } - eexists ; split. - 2:{ - rewrite set_heap_commut. - reflexivity. - solve_var_neq. - eapply precneq_I. - apply H0. - } - eexists_set_heap. - eexists_set_heap. - pdisj_apply H_pdisj. - - etransitivity. - apply preceq_I. - apply H0. - - { - eapply precneq_I. - apply H0. - } - { - eapply precneq_I. - apply H0. - } - } - { - intros. - destruct_pre. - discriminate. - } - } - } - - apply better_r_put_lhs. - remove_get_in_lhs. - - apply r_ret. - - intros. - - destruct_pre. - split. - - eexists. - split. - + reflexivity. - + setoid_rewrite zero_extend_u. - reflexivity. - - pdisj_apply H_pdisj. - rewrite in_fset. - now rewrite mem_head. - Qed. - - Lemma aes_eq id0 key m (pre : precond) : - (pdisj pre id0 (fset [state_loc ; rkeys_loc; temp2_loc; rkey_loc])) -> - ⊢ ⦃ pre ⦄ - JAES id0 key m - ≈ - is_state (aes key m) - ⦃ fun '(v0, h0) '(v1, h1) => (exists o1, v0 = [('word U128; o1)] /\ o1 = v1) /\ pre (h0, h1) ⦄. - Proof. - intros H_pdisj. - set (JAES _ _ _). - unfold JAES_ROUNDS in r. - unfold get_translated_static_fun, JAES_ROUNDS, get_translated_static_fun, translate_prog_static, translate_funs_static, translate_call_body in r. - Opaque translate_call. - simpl in r. - subst r. - rewrite !zero_extend_u. - - unfold aes. - - apply better_r_put_lhs. - apply better_r_put_lhs. - remove_get_in_lhs. - - rewrite bind_assoc. - rewrite bind_assoc. - - eapply r_bind. - apply keys_expand_eq. - - split. - { - intros. - destruct_pre. - unfold set_lhs. - eexists (set_heap (set_heap H4 ($$"key.314") _) (translate_var s_id' v) a). - split. - 2:{ - rewrite set_heap_commut. - f_equal. - f_equal. - apply f_equal. - reflexivity. - apply injective_translate_var2. - red ; intros. - subst. - now apply (precneq_I s_id'). - } - exists (set_heap H4 (translate_var s_id' v) a). - split. - 2:{ - rewrite set_heap_commut. - reflexivity. - apply injective_translate_var2. - red ; intros. - subst. - now apply (precneq_I s_id'). - } - pdisj_apply H_pdisj. - etransitivity. - apply preceq_I. - apply H0. - } - { - intros. - destruct_pre. - eexists. - split ; [ | reflexivity ]. - eexists. - split ; [ | reflexivity ]. - apply H_pdisj. - - rewrite in_fset. - rewrite in_fset in H. - rewrite in_cons ; simpl. - rewrite H. - now rewrite Bool.orb_true_r. - apply H4. - } - - intros. - apply rpre_hypothesis_rule. - intros ? ? []. - eapply rpre_weaken_rule. - 2:{ - intros ? ? []. subst. - apply H0. - } - clear H0. - destruct H. - destruct H. - subst. - apply better_r_put_lhs. - remove_get_in_lhs. fold @bind. - remove_get_in_lhs. - - rewrite bind_assoc. - rewrite bind_assoc. - - rewrite <- bind_ret. - eapply r_bind. - - apply addroundkey_eq. - { - split. - - intros. - destruct_pre. - eexists. - split. - 2:{ - rewrite ![set_heap _ (translate_var s_id' v) a]set_heap_commut - ; (reflexivity || - (apply injective_translate_var2 ; - red ; intros ; subst ; - apply (precneq_O s_id') ; - etransitivity ; [apply preceq_I | apply H1])). - } - eexists. - split ; [ | reflexivity ]. - eexists. - split ; [ | reflexivity ]. - pdisj_apply H_pdisj. - etransitivity. - apply preceq_O. - etransitivity. - apply preceq_I. - apply H1. - - intros. - destruct_pre. - eexists. - split ; [| reflexivity ]. - eexists. - split ; [ | reflexivity ]. - eexists. - split ; [ | reflexivity ]. - eapply H_pdisj. - - rewrite in_fset. - rewrite in_cons ; simpl. - rewrite in_cons ; simpl. - rewrite in_fset in H. - rewrite in_cons in H ; simpl. - rewrite Bool.orb_false_r in H. - rewrite orbA. - rewrite H. - now rewrite Bool.orb_true_l. - apply H7. - } - { - intros. - rewrite !coerce_to_choice_type_K. - specialize (H0 k H). - rewrite H0. - reflexivity. - } - - intros. - apply rpre_hypothesis_rule. - intros ? ? []. - eapply rpre_weaken_rule. - 2:{ - intros ? ? []. subst. - apply H1. - } - clear H1. - destruct H. - destruct H. - subst. - apply better_r_put_lhs. - rewrite bind_rewrite. - remove_get_in_lhs. - apply r_ret. - - intros. - destruct_pre. - split. - eexists. - split ; [reflexivity | ]. - rewrite !zero_extend_u. - setoid_rewrite zero_extend_u. - reflexivity. - pdisj_apply H_pdisj. - Qed. - -End Hacspec. diff --git a/theories/Jasmin/examples/xor/xor.v b/theories/Jasmin/examples/xor/xor.v deleted file mode 100644 index 4df570e6..00000000 --- a/theories/Jasmin/examples/xor/xor.v +++ /dev/null @@ -1,637 +0,0 @@ -Set Warnings "-notation-overridden,-ambiguous-paths". -From mathcomp Require Import all_ssreflect all_algebra reals distr realsum - fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool ssrnum - eqtype choice seq. -Set Warnings "notation-overridden,ambiguous-paths". - -Require Import List. -From Jasmin Require Import expr. -From Jasmin Require Import x86_extra. -From mathcomp.word Require Import word. -(* From Jasmin Require Import x86_extra. *) -From JasminSSProve Require Import jasmin_translate jasmin_utils. -From Crypt Require Import Prelude Package pkg_user_util. - -Import ListNotations. -Import JasminNotation JasminCodeNotation. -Import PackageNotation. - -Local Open Scope string. - -Definition ssprove_jasmin_prog : uprog. -Proof. - refine {| p_funcs := - [ ( (* xor *) xH, - {| f_info := FunInfo.witness - ; f_tyin := [(sword U64); (sword U64)] - ; f_params := - [{| v_var := {| vtype := (sword U64) - ; vname := "x.141" |} - ; v_info := dummy_var_info |}; - {| v_var := {| vtype := (sword U64) - ; vname := "y.142" |} - ; v_info := dummy_var_info |}] - ; f_body := - [ MkI InstrInfo.witness - (Cassgn - (Lvar - {| v_var := {| vtype := (sword U64) - ; vname := "r.143" |} - ; v_info := dummy_var_info |}) - AT_none ((sword U64)) - ((Pvar - {| gv := {| v_var := - {| vtype := (sword U64) - ; vname := "x.141" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}))); - MkI InstrInfo.witness - (Cassgn - (Lvar - {| v_var := {| vtype := (sword U64) - ; vname := "r.143" |} - ; v_info := dummy_var_info |}) - AT_none ((sword U64)) - ((Papp2 (Olxor U64) - (Pvar - {| gv := {| v_var := - {| vtype := (sword U64) - ; vname := "r.143" |} - ; v_info := dummy_var_info |} ; gs := Slocal |}) - (Pvar - {| gv := {| v_var := - {| vtype := (sword U64) - ; vname := "y.142" |} - ; v_info := dummy_var_info |} ; gs := Slocal |})))) ] - ; f_tyout := [(sword U64)] - ; f_res := - [{| v_var := {| vtype := (sword U64) - ; vname := "r.143" |} - ; v_info := dummy_var_info |}] - ; f_extra := tt - ; |} ) ] ; - p_globs := [] ; - p_extra := tt |}. - -Defined. -Notation XOR := ( xH ). - -Notation trp := (translate_prog' ssprove_jasmin_prog).1. -Notation trc := (fun fn i => translate_call ssprove_jasmin_prog fn trp i). -(* Notation funlist := [seq f.1 | f <- p_funcs ssprove_jasmin_prog]. *) - -(* Definition static_fun fn := (fn, match assoc trp fn with Some c => c | None => fun _ => ret tt end). *) - -(* Definition static_funs := [seq static_fun f | f <- funlist]. *) - -(* Definition strp := (translate_prog_static ssprove_jasmin_prog static_funs). *) -(* Opaque strp. *) - -Definition call fn i := trc fn i. - -Notation JXOR i a b := (call XOR i [('word U64 ; a) ; ('word U64 ; b)]). - -Opaque translate_for. - -Ltac neq_loc_auto ::= eapply injective_translate_var3; auto. - -Lemma f_xor_correct : forall id0 w1 w2, ⊢ ⦃ fun _ => True ⦄ JXOR id0 w1 w2 ⇓ [('word U64; wxor w1 w2)] ⦃ fun _ => True ⦄. -Proof. - (* preprocessing *) - intros id0 w1 w2. - unfold JXOR. - simpl_fun. - repeat setjvars. - - (* proof *) - unfold eval_jdg. - repeat clear_get. - - rewrite !zero_extend_u. - - repeat eapply u_put. - eapply u_ret. - easy. -Qed. - -(* - OTP example -*) - -From Relational Require Import OrderEnrichedCategory GenericRulesSimple. - -From Crypt Require Import Axioms ChoiceAsOrd SubDistr Couplings - UniformDistrLemmas FreeProbProg Theta_dens RulesStateProb UniformStateProb - pkg_composition pkg_rhl Package Prelude. - -From Coq Require Import Utf8 Lia. -From extructures Require Import ord fset fmap. - -From Equations Require Import Equations. -Require Equations.Prop.DepElim. - -Set Equations With UIP. - -Set Bullet Behavior "Strict Subproofs". -Set Default Goal Selector "!". -Set Primitive Projections. - -Import Num.Def. -Import Num.Theory. - -#[local] Open Scope ring_scope. -From mathcomp.word Require Import ssrZ. - -Import GRing Order TotalTheory. -(* We could just use these, but to get the proper size, we copy paste the proofs from ordinals *) -(* Definition word_finMixin n := Eval hnf in CanFinMixin (@ord_of_wordK n). *) -(* Canonical word_finType n := Eval hnf in FinType (n.-word) (word_finMixin n). *) -Section word_fin. - - Variable n : nat. - Notation word := (word n). - - Definition word_enum : seq word := pmap insub (ziota 0 (modulus n)). - - Lemma val_word_enum : map val word_enum = ziota 0 (modulus n). - Proof. - rewrite pmap_filter; last exact: insubK. - by apply/all_filterP/allP=> i; rewrite in_ziota isSome_insub. - Qed. - - From mathcomp Require Import zify. - - Lemma ltzS x y : (x < Z.succ y) = (x <= y). - Proof. zify; lia. Qed. - - Lemma ltSz x y : (Z.succ x <= y) = (x < y). - Proof. zify; lia. Qed. - - Lemma addzS x y : (x + Z.succ y) = Z.succ (x + y). - Proof. zify; lia. Qed. - - Lemma addSz x y : (Z.succ x + y) = Z.succ (x + y). - Proof. zify; lia. Qed. - - Lemma mem_ziota m k i : (i \in ziota m k) = (m <= i < m + k). - Proof. - destruct (Z.leb 0 k) eqn:E. - - move: m. eapply natlike_ind with (x:=k). - + intros m. by rewrite addr0 ltNge andbN. - + intros x Hx Hi m. - rewrite ziotaS_cons; [|assumption]. - apply Z.leb_le in Hx. - by rewrite in_cons Hi addzS addSz ltzS ltSz; case: ltgtP => //= ->; rewrite ler_addl. - + by apply Z.leb_le. - - rewrite ziota_neg. - + rewrite in_nil. - apply/idP. unfold le, lt=>//=. - destruct ((Z.leb m i) && (Z.ltb i (m + k)%R)%Z) eqn:E2=>//=. - unfold add in E2. simpl in E2. lia. - + lia. - Qed. - - Lemma ziota_uniq i j : uniq (ziota i j). - Proof. - unfold ziota. - rewrite map_inj_uniq. - - apply iota_uniq. - - intros x y. lia. - Qed. - - Lemma word_enum_uniq : uniq word_enum. - Proof. by rewrite pmap_sub_uniq ?ziota_uniq. Qed. - - Lemma word_inj : injective (@toword n). - Proof. exact val_inj. Qed. - - Lemma mem_word_enum i : i \in word_enum. - Proof. by rewrite -(mem_map word_inj) val_word_enum mem_ziota add0r; case: i. Qed. - - Definition word_finMixin := - Eval hnf in UniqFinMixin word_enum_uniq mem_word_enum. - Canonical word_finType := Eval hnf in FinType word word_finMixin. - Canonical word_subFinType := Eval hnf in [subFinType of word]. - Canonical finEnum_unlock := Unlockable Finite.EnumDef.enumDef. - - (* can't get `enum` in `val_enum_word` to work without this import *) - From mathcomp Require Import fintype. - - Lemma val_enum_word : map val (enum [finType of word]) = ziota 0 (modulus n). - Proof. by rewrite enumT unlock val_word_enum. Qed. - - Lemma size_enum_word : size (enum [finType of word]) = Z.to_nat (modulus n). - Proof. by rewrite -(size_map val) val_enum_word size_ziota. Qed. - -End word_fin. - -Section word_uniform. - - Definition fin_family_word (i : wsize.wsize) : finType := [finType of chWord i]. - Lemma F_w0_word : - forall i, fin_family_word i. - Proof. - intros i. unfold fin_family_word. cbn. - exists (word1 i). apply isword1. - Qed. - - Definition Uni_W_word : forall i, SDistr (fin_family_word i). - move=> i. apply (@uniform_F (fin_family_word i)). - apply F_w0_word. - Defined. - - Definition uniform_word (i : wsize.wsize) : Op := - existT _ ('word i) (Uni_W_word i). - - #[export] Instance LosslessOp_uniform_word i : LosslessOp (uniform_word i). - Proof. - unfold LosslessOp. - simpl. - unfold r. rewrite psumZ. 2: apply ler0n. - simpl. rewrite GRing.mul1r. - rewrite psum_fin. rewrite cardE. - rewrite size_enum_word. simpl. - rewrite GRing.sumr_const. rewrite cardE. rewrite size_enum_word. - rewrite -normrMn. - rewrite -GRing.Theory.mulr_natr. - rewrite GRing.mulVf. - 2:{ - apply /negP => e. - rewrite intr_eq0 in e. - move: e => /eqP e. - assert (forall p, Pos.to_nat p <> 0%nat). - { intros p. pose proof (Pos2Nat.is_pos p). lia. } - eapply H. injection e. intros ?. - eassumption. - } - rewrite normr1. reflexivity. - Qed. - -End word_uniform. - -Notation "m ⊕ k" := (@wxor _ m k) (at level 70). - -Section wxor. - - Context (n : wsize.wsize). - Notation word := (word n). - - Lemma wxor_involutive : ∀ m k : word, (m ⊕ k) ⊕ k = m. - Proof. - intros m k. - apply/eqP/eq_from_wbit=> i. - by rewrite !wxorE -addbA addbb addbF. - Qed. - - Lemma wxorC : ∀ m k : word, (m ⊕ k) = (k ⊕ m). - Proof. - intros m k. - apply/eqP/eq_from_wbit=> i. - by rewrite !wxorE addbC. - Qed. - - Lemma wxorA : ∀ m k l : word, ((m ⊕ k) ⊕ l) = (m ⊕ (k ⊕ l)). - Proof. - intros m k l. - apply/eqP/eq_from_wbit=> i. - by rewrite !wxorE addbA. - Qed. - -End wxor. - -Section OTP_example. - - Context (n : wsize.wsize). - Notation word := (word n). - - #[local] Open Scope package_scope. - - Definition i1 : nat := 0. - - Definition Enc {L : {fset Location}} (m : word) (k : word) : - code L [interface] ('word n) := - {code - ret (m ⊕ k) - }. - - Notation N := ((expn 2 n).-1.+1). - - #[export] Instance : Positive N. - Proof. red; by rewrite prednK_modulus expn_gt0. Qed. - - #[export] Instance word_pos (i : wsize.wsize) : Positive i. - Proof. by case i. Qed. - - Definition KeyGen {L : {fset Location}} : - code L [interface] ('word n) := - {code - k ← sample uniform N ;; - ret (word_of_ord k) - }. - - Definition dec {L : {fset Location }}(c : word) (k : word) : - code L [interface] 'word n := Enc k c. - - Definition IND_CPA_location : {fset Location} := fset0. - - (* REM: Key is always sampled at the side of the encrypter. *) - (* This assumption is stronger than usual crypto definitions. *) - (* We need control over the key to apply coupling. *) - Notation " 'word " := (chWord n) (in custom pack_type at level 2). - - Definition IND_CPA_real : - package IND_CPA_location - [interface] - [interface #val #[i1] : 'word → 'word ] := - [package - #def #[i1] (m : 'word) : 'word - { - k_val ← sample uniform N ;; - r ← Enc m (word_of_ord k_val) ;; - ret r - } - ]. - - Definition IND_CPA_ideal : - package IND_CPA_location - [interface ] - [interface #val #[i1] : 'word → 'word ] := - [package - #def #[i1] (m : 'word) : 'word - { - m' ← sample uniform N ;; - k_val ← sample uniform N ;; - r ← Enc (word_of_ord m') (word_of_ord k_val) ;; - ret r - } - ]. - - Definition IND_CPA : loc_GamePair [interface #val #[i1] : 'word → 'word ] := - λ b, if b then {locpackage IND_CPA_real } else {locpackage IND_CPA_ideal }. - - #[local] Open Scope ring_scope. - - From Crypt Require Import pkg_distr. - Notation IN := 'I_N. - Coercion word_of_ord : IN >-> word. - - Lemma IND_CPA_ideal_real : - IND_CPA false ≈₀ IND_CPA true. - Proof. - eapply eq_rel_perf_ind_eq. - simplify_eq_rel m. - (* TODO Why doesn't it infer this? *) - eapply r_const_sample_L with (op := uniform _). - 1: exact _. intro m_val. - pose (f := - λ (k : Arit (uniform N)), - ord_of_word ((word_of_ord k) ⊕ m ⊕ (word_of_ord m_val)) - ). - assert (bij_f : bijective f). - { subst f. - exists (λ x, ord_of_word ((word_of_ord x) ⊕ (word_of_ord m_val) ⊕ m)). - - intro x. by rewrite ord_of_wordK !wxor_involutive word_of_ordK. - - intro x. by rewrite ord_of_wordK !wxor_involutive word_of_ordK. - } - eapply r_uniform_bij with (1 := bij_f). intro k_val. - apply r_ret. intros s₀ s₁ e. intuition auto. - subst f. simpl. - rewrite ord_of_wordK. - rewrite !wxorA 2![_ m _]wxorC wxorA wxor_involutive. - by rewrite wxorC. - Qed. - - Theorem unconditional_secrecy : - ∀ LA A, - ValidPackage LA - [interface #val #[i1] : 'word → 'word ] A_export A → - Advantage IND_CPA A = 0. - Proof. - intros LA A vA. - rewrite Advantage_E. eapply IND_CPA_ideal_real. 1: eauto. - all: eapply fdisjoints0. - Qed. - -End OTP_example. - -Section Jasmin_OTP. - - (* Context (n : wsize.wsize). *) - Definition n := U64. - Notation word := (word n). - Notation " 'word " := (chWord n) : package_scope. - Notation " 'word " := (chWord n) (in custom pack_type at level 2) : package_scope. - Notation N := ((expn 2 n).-1.+1). - - (* Definition id0 : BinNums.positive := 1. *) - - Definition xor_locs id0 := - [fset - (translate_var id0 {| vtype := sword n ; vname := "x.141" |}) ; - (translate_var id0 {| vtype := sword n ; vname := "y.142" |}) ; - (translate_var id0 {| vtype := sword n ; vname := "r.143" |}) - ]. - - Ltac neq_loc_auto ::= eapply injective_translate_var3; auto. - - #[local] Open Scope package_scope. - - Program Definition JasminEnc id0 (m : 'word n) (k : 'word n) : (* why can't I just use 'word here? *) - code (xor_locs id0) [interface] ('word n) := - {code - e ← JXOR id0 m k ;; - ret (coerce_to_choice_type _ (hd (totce (chCanonical ('word n))) e).π2) - }. - Next Obligation. - unfold xor_locs. unfold n. - repeat constructor; repeat rewrite in_fset in_cons; - repeat match goal with - | [ |- is_true (orb (translate_var ?i1 ?v1 == translate_var ?i1 ?v1) _) ] => - apply/orP; left; by rewrite translate_var_eq eq_refl - | |- is_true (orb _ _) => apply/orP; right - end. - Defined. - - Program Definition JasminDec id0 {L : {fset Location }}(c : 'word n) (k : 'word n) : - code (xor_locs id0) [interface] 'word n := JasminEnc id0 k c. - - Program Definition IND_CPA_jasmin id0 : - package (xor_locs id0) - [interface] - [interface #val #[i1] : 'word → 'word ] := - [package - #def #[i1] (m : 'word) : 'word - { - k_val ← sample uniform N ;; - r ← JasminEnc id0 m (word_of_ord k_val) ;; - ret r - } - ]. - - Definition IND_CPA_jasmin_real_game id0 : loc_GamePair [interface #val #[i1] : 'word → 'word ] := - λ b, if b then {locpackage IND_CPA_jasmin id0 } else {locpackage (IND_CPA_real n) }. - Definition IND_CPA_jasmin_ideal_game id0 : loc_GamePair [interface #val #[i1] : 'word → 'word ] := - λ b, if b then {locpackage IND_CPA_jasmin id0 } else {locpackage (IND_CPA_ideal n) }. - - #[local] Open Scope ring_scope. - - From Crypt Require Import pkg_distr. - - Lemma IND_CPA_jasmin_real id0 : - IND_CPA_jasmin_real_game id0 false ≈₀ IND_CPA_jasmin_real_game id0 true. - Proof. - eapply eq_rel_perf_ind_ignore with (L := xor_locs id0); [apply fsubsetUr|]. - - Opaque n. - simplify_eq_rel m. - Transparent n. - - ssprove_sync. - intros x. - - (* note that this simpl chokes if called before ssprove_sync_eq *) - apply rsymmetry; repeat clear_get; apply rsymmetry. - rewrite !zero_extend_u. - - (* why is this not inferred? *) - repeat eapply r_put_rhs. - eapply r_ret. - - intros ? ? ?. - rewrite coerce_to_choice_type_K. - split; [reflexivity|]. - intros l lnin. - repeat destruct H. subst. - rewrite !get_set_heap_neq. - 1: eapply H; assumption. - Admitted. - - Theorem advantage_jas_real id0 : - ∀ LA A, - fdisjoint LA (xor_locs id0) -> - ValidPackage LA - [interface #val #[i1] : 'word → 'word ] A_export A → - Advantage (IND_CPA_jasmin_real_game id0) A = 0. - Proof. - intros LA A vA HA. - rewrite Advantage_E. - eapply IND_CPA_jasmin_real. 1: eauto. - 1: eapply fdisjoints0. - 1: assumption. - Qed. - - Theorem unconditional_secrecy_jas id0 : - ∀ LA A, - fdisjoint LA (xor_locs id0) -> - ValidPackage LA - [interface #val #[i1] : 'word → 'word ] A_export A → - Advantage (IND_CPA_jasmin_ideal_game id0) A = 0. - Proof. - intros LA A vA HA. - rewrite Advantage_E. - assert (AdvantageE (IND_CPA_jasmin_ideal_game id0 false) (IND_CPA_jasmin_ideal_game id0 true) A <= 0 + 0). - - rewrite -{2}(advantage_jas_real id0); [|assumption]. - rewrite -unconditional_secrecy. - rewrite !Advantage_E. - (* cbn [IND_CPA_jasmin_real_game IND_CPA IND_CPA_jasmin_ideal_game]. *) - eapply Advantage_triangle. - - rewrite add0r in H. - apply AdvantageE_le_0. - assumption. - Qed. -End Jasmin_OTP. - -From Hacspec Require Import Hacspec_Xor. -From Hacspec Require Import Hacspec_Lib_Pre. -(* consider exporting this from Hacspec_Lib_Pre? Needed for int64 : Type coercion *) -From Hacspec Require Import ChoiceEquality. - -Section JasminHacspec. - - Definition state_xor (x y : int64) : raw_code int64 := - xor x y. - - Definition pure_xor (x y : int64) : raw_code int64 := - lift_to_code (L:=fset0) (I := [interface]) (is_pure (xor x y)). - - Definition state_pure_xor x y := code_eq_proof_statement (xor x y). - Notation hdtc res := (coerce_to_choice_type ('word U64) (hd ('word U64 ; chCanonical _) res).π2). - - Lemma rxor_pure : forall id0 w1 w2, - ⊢ ⦃ true_precond ⦄ - res ← JXOR id0 w1 w2 ;; - ret (hdtc res) - ≈ - pure_xor w1 w2 - ⦃ fun '(a, h₀) '(b, h₁) => (a = b) ⦄. - Proof. - intros id0 w1 w2. - simpl_fun. - - repeat setjvars. - - Ltac neq_loc_auto ::= eapply injective_translate_var3; auto. - - repeat clear_get. - - rewrite !zero_extend_u. - repeat eapply better_r_put_lhs. - repeat eapply r_put_lhs. - eapply r_ret. - - intros ? ? ?. - rewrite coerce_to_choice_type_K. - reflexivity. - Qed. - - Lemma rxor_state : forall id0 w1 w2, - ⊢ ⦃ fun '(_, _) => Logic.True ⦄ - res ← JXOR id0 w1 w2 ;; - ret (hdtc res) - ≈ - state_xor w1 w2 - ⦃ fun '(a, _) '(b, _) => (a = b) ⦄. - Proof. - intros id0 w1 w2. - unfold state_xor. - - simpl_fun. - repeat setjvars. - repeat clear_get. - - rewrite !zero_extend_u. - rewrite coerce_to_choice_type_K. - eapply r_put_lhs with (pre := fun _ => _). - repeat eapply r_put_lhs. - Transparent Hacspec_Lib.lift3_both. - simpl. - eapply r_ret. - easy. - Qed. - - Lemma rxor_pure_via_state : forall id0 w1 w2, - ⊢ ⦃ fun '(_, _) => Logic.True ⦄ - res ← JXOR id0 w1 w2 ;; - ret (hdtc res) - ≈ - pure_xor w1 w2 - ⦃ fun '(a, _) '(b, _) => (a = b) ⦄. - Proof. - intros id0 w1 w2. - unfold true_precond. - (* eapply rpre_weaken_rule. *) - eapply r_transL_val with (c₀ := state_xor w1 w2). - - repeat constructor. - - repeat constructor. - - repeat constructor. - - eapply rsymmetry. - eapply rpost_weaken_rule. - 1: eapply rxor_state. - intros [] []; auto. - - pose proof state_pure_xor. - eapply rpre_weaken_rule. - 1: eapply rpost_weaken_rule. - 1: eapply state_pure_xor. - 2: auto. - intros [] []. unfold pre_to_post_ret; intuition subst. - Qed. -End JasminHacspec. From d0aedf5095b979897027789423d0f85b9646f591 Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Sat, 4 Feb 2023 13:43:49 +0100 Subject: [PATCH 366/383] anonymize, remove comments --- README.md | 2 +- theories/Jasmin/examples/aes.cprog | 2493 ---------------------------- theories/Jasmin/jasmin_translate.v | 135 +- theories/Jasmin/word.v | 13 - 4 files changed, 6 insertions(+), 2637 deletions(-) delete mode 100644 theories/Jasmin/examples/aes.cprog diff --git a/README.md b/README.md index 19177b2c..5869e8b7 100644 --- a/README.md +++ b/README.md @@ -58,7 +58,7 @@ cd jasmin opam install . ``` The last version of Jasmin that is known to work is `52624d84`, but we try to track `main`. -For all proofs to work and a pretty printer for Coq AST's, the version available at `https://github.com/bshvass/jasmin` is currently necessary. +For all proofs to work and a pretty printer for Coq AST's, a custom version is currently necessary. The pretty printer is available via the `-coq` compiler flag. To install a local copy of Jasmin, one may use diff --git a/theories/Jasmin/examples/aes.cprog b/theories/Jasmin/examples/aes.cprog deleted file mode 100644 index f269b824..00000000 --- a/theories/Jasmin/examples/aes.cprog +++ /dev/null @@ -1,2493 +0,0 @@ - {Jasmin.Expr.p_funcs = - [(Jasmin.BinNums.Coq_xH, - {Jasmin.Expr.f_info = Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH; - f_tyin = - [Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; - f_params = - [{Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = key.280}; - v_info = - {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); - loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}; - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = in.281}; - v_info = - {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); - loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; - f_body = - [Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 42; - base_loc = - {Jasmin.Location.loc_fname = "aes.jazz"; loc_start = (18, 3); - loc_end = (18, 24); loc_bchar = 396; loc_echar = 417}; - stack_loc = []}, - []), - Jasmin.Expr.Ccall (Jasmin.Expr.InlineFun, - [Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = out.282}; - v_info = - {Jasmin.Location.loc_fname = "aes.jazz"; loc_start = (18, 3); - loc_end = (18, 6); loc_bchar = 396; loc_echar = 399}}], - Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH, - [Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = key.280}; - v_info = - {Jasmin.Location.loc_fname = "aes.jazz"; - loc_start = (18, 16); loc_end = (18, 19); loc_bchar = 409; - loc_echar = 412}}; - gs = Jasmin.Expr.Slocal}; - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = in.281}; - v_info = - {Jasmin.Location.loc_fname = "aes.jazz"; - loc_start = (18, 20); loc_end = (18, 22); loc_bchar = 413; - loc_echar = 415}}; - gs = Jasmin.Expr.Slocal}]))]; - f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; - f_res = - [{Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = out.282}; - v_info = - {Jasmin.Location.loc_fname = "aes.jazz"; loc_start = (19, 10); - loc_end = (19, 13); loc_bchar = 428; loc_echar = 431}}]; - f_extra = ()}); - (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH), - {Jasmin.Expr.f_info = - Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH); - f_tyin = - [Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; - f_params = - [{Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = key.283}; - v_info = - {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); - loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}; - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = in.284}; - v_info = - {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); - loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; - f_body = - [Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 41; - base_loc = - {Jasmin.Location.loc_fname = "aes.jazz"; loc_start = (11, 3); - loc_end = (11, 21); loc_bchar = 276; loc_echar = 294}; - stack_loc = []}, - []), - Jasmin.Expr.Ccall (Jasmin.Expr.InlineFun, - [Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = out.285}; - v_info = - {Jasmin.Location.loc_fname = "aes.jazz"; loc_start = (11, 3); - loc_end = (11, 6); loc_bchar = 276; loc_echar = 279}}], - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH), - [Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = key.283}; - v_info = - {Jasmin.Location.loc_fname = "aes.jazz"; - loc_start = (11, 13); loc_end = (11, 16); loc_bchar = 286; - loc_echar = 289}}; - gs = Jasmin.Expr.Slocal}; - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = in.284}; - v_info = - {Jasmin.Location.loc_fname = "aes.jazz"; - loc_start = (11, 17); loc_end = (11, 19); loc_bchar = 290; - loc_echar = 292}}; - gs = Jasmin.Expr.Slocal}]))]; - f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; - f_res = - [{Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = out.285}; - v_info = - {Jasmin.Location.loc_fname = "aes.jazz"; loc_start = (12, 10); - loc_end = (12, 13); loc_bchar = 305; loc_echar = 308}}]; - f_extra = ()}); - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH, - {Jasmin.Expr.f_info = - Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH); - f_tyin = - [Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; - f_params = - [{Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = key.286}; - v_info = - {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); - loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}; - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = in.287}; - v_info = - {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); - loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; - f_body = - [Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 39; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (121, 2); loc_end = (121, 31); loc_bchar = 2902; - loc_echar = 2931}; - stack_loc = []}, - []), - Jasmin.Expr.Ccall (Jasmin.Expr.InlineFun, - [Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sarr - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))); - vname = rkeys.289}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (121, 2); loc_end = (121, 7); loc_bchar = 2902; - loc_echar = 2907}}], - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)), - [Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = key.286}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (121, 26); loc_end = (121, 29); - loc_bchar = 2926; loc_echar = 2929}}; - gs = Jasmin.Expr.Slocal}])); - Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 40; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (122, 2); loc_end = (122, 35); loc_bchar = 2934; - loc_echar = 2967}; - stack_loc = []}, - []), - Jasmin.Expr.Ccall (Jasmin.Expr.InlineFun, - [Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = out.288}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (122, 2); loc_end = (122, 5); loc_bchar = 2934; - loc_echar = 2937}}], - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)), - [Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sarr - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))); - vname = rkeys.289}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (122, 24); loc_end = (122, 29); - loc_bchar = 2956; loc_echar = 2961}}; - gs = Jasmin.Expr.Slocal}; - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = in.287}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (122, 31); loc_end = (122, 33); - loc_bchar = 2963; loc_echar = 2965}}; - gs = Jasmin.Expr.Slocal}]))]; - f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; - f_res = - [{Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = out.288}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (123, 9); loc_end = (123, 12); loc_bchar = 2977; - loc_echar = 2980}}]; - f_extra = ()}); - (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH), - {Jasmin.Expr.f_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)); - f_tyin = - [Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; - f_params = - [{Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = key.290}; - v_info = - {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); - loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}; - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = in.291}; - v_info = - {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); - loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; - f_body = - [Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 37; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (111, 2); loc_end = (111, 27); loc_bchar = 2727; - loc_echar = 2752}; - stack_loc = []}, - []), - Jasmin.Expr.Ccall (Jasmin.Expr.InlineFun, - [Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sarr - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))); - vname = rkeys.293}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (111, 2); loc_end = (111, 7); loc_bchar = 2727; - loc_echar = 2732}}], - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)), - [Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = key.290}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (111, 22); loc_end = (111, 25); - loc_bchar = 2747; loc_echar = 2750}}; - gs = Jasmin.Expr.Slocal}])); - Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 38; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (112, 2); loc_end = (112, 32); loc_bchar = 2755; - loc_echar = 2785}; - stack_loc = []}, - []), - Jasmin.Expr.Ccall (Jasmin.Expr.InlineFun, - [Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = out.292}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (112, 2); loc_end = (112, 5); loc_bchar = 2755; - loc_echar = 2758}}], - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)), - [Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sarr - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))); - vname = rkeys.293}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (112, 21); loc_end = (112, 26); - loc_bchar = 2774; loc_echar = 2779}}; - gs = Jasmin.Expr.Slocal}; - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = in.291}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (112, 28); loc_end = (112, 30); - loc_bchar = 2781; loc_echar = 2783}}; - gs = Jasmin.Expr.Slocal}]))]; - f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; - f_res = - [{Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = out.292}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (113, 9); loc_end = (113, 12); loc_bchar = 2795; - loc_echar = 2798}}]; - f_extra = ()}); - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)), - {Jasmin.Expr.f_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)); - f_tyin = - [Jasmin.Type.Coq_sarr - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))); - Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; - f_params = - [{Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sarr - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))); - vname = rkeys.294}; - v_info = - {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); - loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}; - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = in.295}; - v_info = - {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); - loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; - f_body = - [Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 31; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (93, 2); loc_end = (93, 13); loc_bchar = 2274; - loc_echar = 2285}; - stack_loc = []}, - []), - Jasmin.Expr.Cassgn - (Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = state.296}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (93, 2); loc_end = (93, 7); loc_bchar = 2274; - loc_echar = 2279}}, - Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U128, - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = in.295}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (93, 10); loc_end = (93, 12); loc_bchar = 2282; - loc_echar = 2284}}; - gs = Jasmin.Expr.Slocal})); - Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 32; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (94, 2); loc_end = (94, 17); loc_bchar = 2288; - loc_echar = 2303}; - stack_loc = []}, - []), - Jasmin.Expr.Cassgn - (Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = rk.297}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (94, 2); loc_end = (94, 4); loc_bchar = 2288; - loc_echar = 2290}}, - Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U128, - Jasmin.Expr.Pget (Jasmin.Warray_.AAscale, Jasmin.Wsize.U128, - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sarr - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))); - vname = rkeys.294}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (94, 7); loc_end = (94, 12); loc_bchar = 2293; - loc_echar = 2298}}; - gs = Jasmin.Expr.Slocal}, - Jasmin.Expr.Pconst - (Jasmin.BinNums.Zpos - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))); - Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 33; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (95, 2); loc_end = (95, 32); loc_bchar = 2306; - loc_echar = 2336}; - stack_loc = []}, - []), - Jasmin.Expr.Ccall (Jasmin.Expr.InlineFun, - [Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = state.296}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (95, 2); loc_end = (95, 7); loc_bchar = 2306; - loc_echar = 2311}}], - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)), - [Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = state.296}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (95, 22); loc_end = (95, 27); loc_bchar = 2326; - loc_echar = 2331}}; - gs = Jasmin.Expr.Slocal}; - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = rk.297}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (95, 28); loc_end = (95, 30); loc_bchar = 2332; - loc_echar = 2334}}; - gs = Jasmin.Expr.Slocal}])); - Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 35; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (96, 2); loc_end = (98, 3); loc_bchar = 2340; - loc_echar = 2411}; - stack_loc = []}, - []), - Jasmin.Expr.Cfor - ({Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = round.298}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (96, 6); loc_end = (96, 11); loc_bchar = 2344; - loc_echar = 2349}}, - ((Jasmin.Expr.DownTo, Jasmin.Expr.Pconst Jasmin.BinNums.Z0), - Jasmin.Expr.Pconst - (Jasmin.BinNums.Zpos - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), - [Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 34; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (97, 4); loc_end = (97, 41); loc_bchar = 2370; - loc_echar = 2407}; - stack_loc = []}, - []), - Jasmin.Expr.Copn - ([Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = state.296}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (97, 4); loc_end = (97, 9); loc_bchar = 2370; - loc_echar = 2375}}], - Jasmin.Expr.AT_keep, - Jasmin.Sopn.Oasm (Jasmin.Arch_extra.BaseOp (None, )), - [Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = state.296}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (97, 20); loc_end = (97, 25); - loc_bchar = 2386; loc_echar = 2391}}; - gs = Jasmin.Expr.Slocal}; - Jasmin.Expr.Pget (Jasmin.Warray_.AAscale, Jasmin.Wsize.U128, - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sarr - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - Jasmin.BinNums.Coq_xH))))))); - vname = rkeys.294}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (97, 27); loc_end = (97, 32); - loc_bchar = 2393; loc_echar = 2398}}; - gs = Jasmin.Expr.Slocal}, - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = round.298}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (97, 33); loc_end = (97, 38); - loc_bchar = 2399; loc_echar = 2404}}; - gs = Jasmin.Expr.Slocal})]))])); - Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 36; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (99, 2); loc_end = (99, 39); loc_bchar = 2414; - loc_echar = 2451}; - stack_loc = []}, - []), - Jasmin.Expr.Copn - ([Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = state.296}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (99, 2); loc_end = (99, 7); loc_bchar = 2414; - loc_echar = 2419}}], - Jasmin.Expr.AT_keep, - Jasmin.Sopn.Oasm (Jasmin.Arch_extra.BaseOp (None, )), - [Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = state.296}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (99, 22); loc_end = (99, 27); loc_bchar = 2434; - loc_echar = 2439}}; - gs = Jasmin.Expr.Slocal}; - Jasmin.Expr.Pget (Jasmin.Warray_.AAscale, Jasmin.Wsize.U128, - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sarr - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))); - vname = rkeys.294}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (99, 29); loc_end = (99, 34); loc_bchar = 2441; - loc_echar = 2446}}; - gs = Jasmin.Expr.Slocal}, - Jasmin.Expr.Pconst Jasmin.BinNums.Z0)]))]; - f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; - f_res = - [{Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = state.296}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (100, 9); loc_end = (100, 14); loc_bchar = 2461; - loc_echar = 2466}}]; - f_extra = ()}); - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)), - {Jasmin.Expr.f_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)); - f_tyin = - [Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; - f_params = - [{Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = state.299}; - v_info = - {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); - loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}; - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = rk.300}; - v_info = - {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); - loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; - f_body = - [Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 30; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (85, 3); loc_end = (85, 22); loc_bchar = 2105; - loc_echar = 2124}; - stack_loc = []}, - []), - Jasmin.Expr.Cassgn - (Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = state.299}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (85, 3); loc_end = (85, 8); loc_bchar = 2105; - loc_echar = 2110}}, - Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U128, - Jasmin.Expr.Papp2 (Jasmin.Expr.Olxor Jasmin.Wsize.U128, - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = state.299}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (85, 11); loc_end = (85, 16); loc_bchar = 2113; - loc_echar = 2118}}; - gs = Jasmin.Expr.Slocal}, - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = rk.300}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (85, 19); loc_end = (85, 21); loc_bchar = 2121; - loc_echar = 2123}}; - gs = Jasmin.Expr.Slocal})))]; - f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; - f_res = - [{Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = state.299}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (86, 10); loc_end = (86, 15); loc_bchar = 2135; - loc_echar = 2140}}]; - f_extra = ()}); - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)), - {Jasmin.Expr.f_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))); - f_tyin = - [Jasmin.Type.Coq_sarr - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))); - Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; - f_params = - [{Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sarr - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))); - vname = rkeys.301}; - v_info = - {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); - loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}; - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = in.302}; - v_info = - {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); - loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; - f_body = - [Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 25; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (75, 2); loc_end = (75, 13); loc_bchar = 1869; - loc_echar = 1880}; - stack_loc = []}, - []), - Jasmin.Expr.Cassgn - (Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = state.303}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (75, 2); loc_end = (75, 7); loc_bchar = 1869; - loc_echar = 1874}}, - Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U128, - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = in.302}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (75, 10); loc_end = (75, 12); loc_bchar = 1877; - loc_echar = 1879}}; - gs = Jasmin.Expr.Slocal})); - Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 26; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (76, 2); loc_end = (76, 20); loc_bchar = 1883; - loc_echar = 1901}; - stack_loc = []}, - []), - Jasmin.Expr.Cassgn - (Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = state.303}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (76, 2); loc_end = (76, 7); loc_bchar = 1883; - loc_echar = 1888}}, - Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U128, - Jasmin.Expr.Papp2 (Jasmin.Expr.Olxor Jasmin.Wsize.U128, - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = state.303}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (76, 2); loc_end = (76, 7); loc_bchar = 1883; - loc_echar = 1888}}; - gs = Jasmin.Expr.Slocal}, - Jasmin.Expr.Pget (Jasmin.Warray_.AAscale, Jasmin.Wsize.U128, - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sarr - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))); - vname = rkeys.301}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (76, 11); loc_end = (76, 16); loc_bchar = 1892; - loc_echar = 1897}}; - gs = Jasmin.Expr.Slocal}, - Jasmin.Expr.Pconst Jasmin.BinNums.Z0)))); - Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 28; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (77, 2); loc_end = (79, 3); loc_bchar = 1905; - loc_echar = 1973}; - stack_loc = []}, - []), - Jasmin.Expr.Cfor - ({Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = round.304}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (77, 6); loc_end = (77, 11); loc_bchar = 1909; - loc_echar = 1914}}, - ((Jasmin.Expr.UpTo, - Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos Jasmin.BinNums.Coq_xH)), - Jasmin.Expr.Pconst - (Jasmin.BinNums.Zpos - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), - [Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 27; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (78, 4); loc_end = (78, 41); loc_bchar = 1932; - loc_echar = 1969}; - stack_loc = []}, - []), - Jasmin.Expr.Copn - ([Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = state.303}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (78, 4); loc_end = (78, 9); loc_bchar = 1932; - loc_echar = 1937}}], - Jasmin.Expr.AT_keep, - Jasmin.Sopn.Oasm (Jasmin.Arch_extra.BaseOp (None, )), - [Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = state.303}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (78, 20); loc_end = (78, 25); - loc_bchar = 1948; loc_echar = 1953}}; - gs = Jasmin.Expr.Slocal}; - Jasmin.Expr.Pget (Jasmin.Warray_.AAscale, Jasmin.Wsize.U128, - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sarr - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - Jasmin.BinNums.Coq_xH))))))); - vname = rkeys.301}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (78, 27); loc_end = (78, 32); - loc_bchar = 1955; loc_echar = 1960}}; - gs = Jasmin.Expr.Slocal}, - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = round.304}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (78, 33); loc_end = (78, 38); - loc_bchar = 1961; loc_echar = 1966}}; - gs = Jasmin.Expr.Slocal})]))])); - Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 29; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (80, 2); loc_end = (80, 40); loc_bchar = 1976; - loc_echar = 2014}; - stack_loc = []}, - []), - Jasmin.Expr.Copn - ([Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = state.303}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (80, 2); loc_end = (80, 7); loc_bchar = 1976; - loc_echar = 1981}}], - Jasmin.Expr.AT_keep, - Jasmin.Sopn.Oasm (Jasmin.Arch_extra.BaseOp (None, )), - [Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = state.303}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (80, 22); loc_end = (80, 27); loc_bchar = 1996; - loc_echar = 2001}}; - gs = Jasmin.Expr.Slocal}; - Jasmin.Expr.Pget (Jasmin.Warray_.AAscale, Jasmin.Wsize.U128, - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sarr - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))); - vname = rkeys.301}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (80, 29); loc_end = (80, 34); loc_bchar = 2003; - loc_echar = 2008}}; - gs = Jasmin.Expr.Slocal}, - Jasmin.Expr.Pconst - (Jasmin.BinNums.Zpos - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))]))]; - f_tyout = [Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; - f_res = - [{Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = state.303}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (81, 9); loc_end = (81, 14); loc_bchar = 2024; - loc_echar = 2029}}]; - f_extra = ()}); - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)), - {Jasmin.Expr.f_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))); - f_tyin = [Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; - f_params = - [{Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = key.305}; - v_info = - {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); - loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; - f_body = - [Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 17; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (58, 2); loc_end = (58, 17); loc_bchar = 1487; - loc_echar = 1502}; - stack_loc = []}, - []), - Jasmin.Expr.Cassgn - (Jasmin.Expr.Laset (Jasmin.Warray_.AAscale, Jasmin.Wsize.U128, - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sarr - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))); - vname = rkeys.306}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (58, 2); loc_end = (58, 7); loc_bchar = 1487; - loc_echar = 1492}}, - Jasmin.Expr.Pconst Jasmin.BinNums.Z0), - Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U128, - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = key.305}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (58, 13); loc_end = (58, 16); loc_bchar = 1498; - loc_echar = 1501}}; - gs = Jasmin.Expr.Slocal})); - Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 18; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (59, 2); loc_end = (59, 25); loc_bchar = 1505; - loc_echar = 1528}; - stack_loc = []}, - []), - Jasmin.Expr.Copn - ([Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = temp2.307}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (59, 2); loc_end = (59, 7); loc_bchar = 1505; - loc_echar = 1510}}], - Jasmin.Expr.AT_keep, - Jasmin.Sopn.Oasm (Jasmin.Arch_extra.ExtOp ), [])); - Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 24; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (60, 2); loc_end = (68, 3); loc_bchar = 1531; - loc_echar = 1732}; - stack_loc = []}, - []), - Jasmin.Expr.Cfor - ({Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = round.308}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (60, 6); loc_end = (60, 11); loc_bchar = 1535; - loc_echar = 1540}}, - ((Jasmin.Expr.UpTo, - Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos Jasmin.BinNums.Coq_xH)), - Jasmin.Expr.Pconst - (Jasmin.BinNums.Zpos - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), - [Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 19; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (61, 4); loc_end = (61, 23); loc_bchar = 1557; - loc_echar = 1576}; - stack_loc = []}, - []), - Jasmin.Expr.Ccall (Jasmin.Expr.InlineFun, - [Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = rcon.309}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (61, 4); loc_end = (61, 8); loc_bchar = 1557; - loc_echar = 1561}}], - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), - [Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = round.308}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (61, 16); loc_end = (61, 21); - loc_bchar = 1569; loc_echar = 1574}}; - gs = Jasmin.Expr.Slocal}])); - Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 20; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (62, 4); loc_end = (62, 48); loc_bchar = 1581; - loc_echar = 1625}; - stack_loc = []}, - []), - Jasmin.Expr.Ccall (Jasmin.Expr.InlineFun, - [Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = key.305}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (62, 5); loc_end = (62, 8); loc_bchar = 1582; - loc_echar = 1585}}; - Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = temp2.307}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (62, 10); loc_end = (62, 15); - loc_bchar = 1587; loc_echar = 1592}}], - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), - [Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = rcon.309}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (62, 30); loc_end = (62, 34); - loc_bchar = 1607; loc_echar = 1611}}; - gs = Jasmin.Expr.Slocal}; - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = key.305}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (62, 36); loc_end = (62, 39); - loc_bchar = 1613; loc_echar = 1616}}; - gs = Jasmin.Expr.Slocal}; - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = temp2.307}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (62, 41); loc_end = (62, 46); - loc_bchar = 1618; loc_echar = 1623}}; - gs = Jasmin.Expr.Slocal}])); - Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 23; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (63, 4); loc_end = (67, 5); loc_bchar = 1630; - loc_echar = 1728}; - stack_loc = []}, - []), - Jasmin.Expr.Cif - (Jasmin.Expr.Papp2 (Jasmin.Expr.Oneq Jasmin.Expr.Op_int, - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = round.308}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (63, 8); loc_end = (63, 13); - loc_bchar = 1634; loc_echar = 1639}}; - gs = Jasmin.Expr.Slocal}, - Jasmin.Expr.Pconst - (Jasmin.BinNums.Zpos - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), - [Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 21; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (64, 6); loc_end = (64, 34); - loc_bchar = 1655; loc_echar = 1683}; - stack_loc = []}, - []), - Jasmin.Expr.Copn - ([Jasmin.Expr.Laset (Jasmin.Warray_.AAscale, - Jasmin.Wsize.U128, - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sarr - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - Jasmin.BinNums.Coq_xH))))))); - vname = rkeys.306}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (64, 6); loc_end = (64, 11); - loc_bchar = 1655; loc_echar = 1660}}, - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = round.308}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (64, 12); loc_end = (64, 17); - loc_bchar = 1661; loc_echar = 1666}}; - gs = Jasmin.Expr.Slocal})], - Jasmin.Expr.AT_keep, - Jasmin.Sopn.Oasm (Jasmin.Arch_extra.BaseOp (None, )), - [Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = key.305}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (64, 29); loc_end = (64, 32); - loc_bchar = 1678; loc_echar = 1681}}; - gs = Jasmin.Expr.Slocal}]))], - [Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 22; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (66, 6); loc_end = (66, 25); - loc_bchar = 1703; loc_echar = 1722}; - stack_loc = []}, - []), - Jasmin.Expr.Cassgn - (Jasmin.Expr.Laset (Jasmin.Warray_.AAscale, - Jasmin.Wsize.U128, - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sarr - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - Jasmin.BinNums.Coq_xH))))))); - vname = rkeys.306}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (66, 6); loc_end = (66, 11); - loc_bchar = 1703; loc_echar = 1708}}, - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = round.308}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (66, 12); loc_end = (66, 17); - loc_bchar = 1709; loc_echar = 1714}}; - gs = Jasmin.Expr.Slocal}), - Jasmin.Expr.AT_none, - Jasmin.Type.Coq_sword Jasmin.Wsize.U128, - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = key.305}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (66, 21); loc_end = (66, 24); - loc_bchar = 1718; loc_echar = 1721}}; - gs = Jasmin.Expr.Slocal}))]))]))]; - f_tyout = - [Jasmin.Type.Coq_sarr - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))))]; - f_res = - [{Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sarr - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))); - vname = rkeys.306}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (69, 9); loc_end = (69, 14); loc_bchar = 1745; - loc_echar = 1750}}]; - f_extra = ()}); - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)), - {Jasmin.Expr.f_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))); - f_tyin = [Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; - f_params = - [{Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = key.310}; - v_info = - {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); - loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; - f_body = - [Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 11; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (44, 2); loc_end = (44, 17); loc_bchar = 1167; - loc_echar = 1182}; - stack_loc = []}, - []), - Jasmin.Expr.Cassgn - (Jasmin.Expr.Laset (Jasmin.Warray_.AAscale, Jasmin.Wsize.U128, - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sarr - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))); - vname = rkeys.311}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (44, 2); loc_end = (44, 7); loc_bchar = 1167; - loc_echar = 1172}}, - Jasmin.Expr.Pconst Jasmin.BinNums.Z0), - Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U128, - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = key.310}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (44, 13); loc_end = (44, 16); loc_bchar = 1178; - loc_echar = 1181}}; - gs = Jasmin.Expr.Slocal})); - Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 12; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (45, 2); loc_end = (45, 25); loc_bchar = 1185; - loc_echar = 1208}; - stack_loc = []}, - []), - Jasmin.Expr.Copn - ([Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = temp2.312}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (45, 2); loc_end = (45, 7); loc_bchar = 1185; - loc_echar = 1190}}], - Jasmin.Expr.AT_keep, - Jasmin.Sopn.Oasm (Jasmin.Arch_extra.ExtOp ), [])); - Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 16; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (46, 2); loc_end = (50, 3); loc_bchar = 1211; - loc_echar = 1333}; - stack_loc = []}, - []), - Jasmin.Expr.Cfor - ({Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = round.313}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (46, 6); loc_end = (46, 11); loc_bchar = 1215; - loc_echar = 1220}}, - ((Jasmin.Expr.UpTo, - Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos Jasmin.BinNums.Coq_xH)), - Jasmin.Expr.Pconst - (Jasmin.BinNums.Zpos - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), - [Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 13; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (47, 4); loc_end = (47, 23); loc_bchar = 1237; - loc_echar = 1256}; - stack_loc = []}, - []), - Jasmin.Expr.Ccall (Jasmin.Expr.InlineFun, - [Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = rcon.314}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (47, 4); loc_end = (47, 8); loc_bchar = 1237; - loc_echar = 1241}}], - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), - [Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = round.313}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (47, 16); loc_end = (47, 21); - loc_bchar = 1249; loc_echar = 1254}}; - gs = Jasmin.Expr.Slocal}])); - Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 14; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (48, 4); loc_end = (48, 48); loc_bchar = 1261; - loc_echar = 1305}; - stack_loc = []}, - []), - Jasmin.Expr.Ccall (Jasmin.Expr.InlineFun, - [Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = key.310}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (48, 5); loc_end = (48, 8); loc_bchar = 1262; - loc_echar = 1265}}; - Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = temp2.312}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (48, 10); loc_end = (48, 15); - loc_bchar = 1267; loc_echar = 1272}}], - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), - [Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = rcon.314}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (48, 30); loc_end = (48, 34); - loc_bchar = 1287; loc_echar = 1291}}; - gs = Jasmin.Expr.Slocal}; - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = key.310}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (48, 36); loc_end = (48, 39); - loc_bchar = 1293; loc_echar = 1296}}; - gs = Jasmin.Expr.Slocal}; - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = temp2.312}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (48, 41); loc_end = (48, 46); - loc_bchar = 1298; loc_echar = 1303}}; - gs = Jasmin.Expr.Slocal}])); - Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 15; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (49, 4); loc_end = (49, 23); loc_bchar = 1310; - loc_echar = 1329}; - stack_loc = []}, - []), - Jasmin.Expr.Cassgn - (Jasmin.Expr.Laset (Jasmin.Warray_.AAscale, Jasmin.Wsize.U128, - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sarr - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))); - vname = rkeys.311}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (49, 4); loc_end = (49, 9); loc_bchar = 1310; - loc_echar = 1315}}, - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = round.313}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (49, 10); loc_end = (49, 15); - loc_bchar = 1316; loc_echar = 1321}}; - gs = Jasmin.Expr.Slocal}), - Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U128, - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = key.310}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (49, 19); loc_end = (49, 22); - loc_bchar = 1325; loc_echar = 1328}}; - gs = Jasmin.Expr.Slocal}))]))]; - f_tyout = - [Jasmin.Type.Coq_sarr - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))))]; - f_res = - [{Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sarr - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))); - vname = rkeys.311}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (51, 9); loc_end = (51, 14); loc_bchar = 1346; - loc_echar = 1351}}]; - f_extra = ()}); - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), - {Jasmin.Expr.f_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))); - f_tyin = - [Jasmin.Type.Coq_sint; Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; - f_params = - [{Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = rcon.315}; - v_info = - {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); - loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}; - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = rkey.316}; - v_info = - {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); - loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}; - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = temp2.317}; - v_info = - {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); - loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; - f_body = - [Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 9; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (35, 2); loc_end = (35, 40); loc_bchar = 932; - loc_echar = 970}; - stack_loc = []}, - []), - Jasmin.Expr.Copn - ([Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = temp1.318}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (35, 2); loc_end = (35, 7); loc_bchar = 932; - loc_echar = 937}}], - Jasmin.Expr.AT_keep, - Jasmin.Sopn.Oasm (Jasmin.Arch_extra.BaseOp (None, )), - [Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = rkey.316}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (35, 28); loc_end = (35, 32); loc_bchar = 958; - loc_echar = 962}}; - gs = Jasmin.Expr.Slocal}; - Jasmin.Expr.Papp1 (Jasmin.Expr.Oword_of_int Jasmin.Wsize.U8, - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = rcon.315}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (35, 34); loc_end = (35, 38); loc_bchar = 964; - loc_echar = 968}}; - gs = Jasmin.Expr.Slocal})])); - Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 10; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (36, 2); loc_end = (36, 48); loc_bchar = 973; - loc_echar = 1019}; - stack_loc = []}, - []), - Jasmin.Expr.Ccall (Jasmin.Expr.InlineFun, - [Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = rkey.316}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (36, 2); loc_end = (36, 6); loc_bchar = 973; - loc_echar = 977}}; - Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = temp2.317}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (36, 8); loc_end = (36, 13); loc_bchar = 979; - loc_echar = 984}}], - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), - [Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = rkey.316}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (36, 28); loc_end = (36, 32); loc_bchar = 999; - loc_echar = 1003}}; - gs = Jasmin.Expr.Slocal}; - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = temp1.318}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (36, 34); loc_end = (36, 39); loc_bchar = 1005; - loc_echar = 1010}}; - gs = Jasmin.Expr.Slocal}; - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = temp2.317}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (36, 41); loc_end = (36, 46); loc_bchar = 1012; - loc_echar = 1017}}; - gs = Jasmin.Expr.Slocal}]))]; - f_tyout = - [Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; - f_res = - [{Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = rkey.316}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (37, 9); loc_end = (37, 13); loc_bchar = 1029; - loc_echar = 1033}}; - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = temp2.317}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (37, 15); loc_end = (37, 20); loc_bchar = 1035; - loc_echar = 1040}}]; - f_extra = ()}); - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), - {Jasmin.Expr.f_info = - Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))); - f_tyin = - [Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; - f_params = - [{Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = rkey.319}; - v_info = - {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); - loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}; - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = temp1.320}; - v_info = - {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); - loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}; - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = temp2.321}; - v_info = - {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); - loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; - f_body = - [Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 3; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (23, 2); loc_end = (23, 42); loc_bchar = 588; - loc_echar = 628}; - stack_loc = []}, - []), - Jasmin.Expr.Copn - ([Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = temp1.320}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (23, 2); loc_end = (23, 7); loc_bchar = 588; - loc_echar = 593}}], - Jasmin.Expr.AT_keep, - Jasmin.Sopn.Oasm (Jasmin.Arch_extra.BaseOp (None, )), - [Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = temp1.320}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (23, 19); loc_end = (23, 24); loc_bchar = 605; - loc_echar = 610}}; - gs = Jasmin.Expr.Slocal}; - Jasmin.Expr.PappN - (Jasmin.Expr.Opack (Jasmin.Wsize.U8, Jasmin.Wsize.PE2), - [Jasmin.Expr.Pconst - (Jasmin.BinNums.Zpos - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)); - Jasmin.Expr.Pconst - (Jasmin.BinNums.Zpos - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)); - Jasmin.Expr.Pconst - (Jasmin.BinNums.Zpos - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)); - Jasmin.Expr.Pconst - (Jasmin.BinNums.Zpos - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))])])); - Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 4; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (24, 2); loc_end = (24, 48); loc_bchar = 631; - loc_echar = 677}; - stack_loc = []}, - []), - Jasmin.Expr.Copn - ([Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = temp2.321}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (24, 2); loc_end = (24, 7); loc_bchar = 631; - loc_echar = 636}}], - Jasmin.Expr.AT_keep, - Jasmin.Sopn.Oasm (Jasmin.Arch_extra.BaseOp (None, )), - [Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = temp2.321}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (24, 19); loc_end = (24, 24); loc_bchar = 648; - loc_echar = 653}}; - gs = Jasmin.Expr.Slocal}; - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = rkey.319}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (24, 26); loc_end = (24, 30); loc_bchar = 655; - loc_echar = 659}}; - gs = Jasmin.Expr.Slocal}; - Jasmin.Expr.PappN - (Jasmin.Expr.Opack (Jasmin.Wsize.U8, Jasmin.Wsize.PE2), - [Jasmin.Expr.Pconst Jasmin.BinNums.Z0; - Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos Jasmin.BinNums.Coq_xH); - Jasmin.Expr.Pconst Jasmin.BinNums.Z0; - Jasmin.Expr.Pconst Jasmin.BinNums.Z0])])); - Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 5; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (25, 2); loc_end = (25, 16); loc_bchar = 680; - loc_echar = 694}; - stack_loc = []}, - []), - Jasmin.Expr.Cassgn - (Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = rkey.319}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (25, 2); loc_end = (25, 6); loc_bchar = 680; - loc_echar = 684}}, - Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U128, - Jasmin.Expr.Papp2 (Jasmin.Expr.Olxor Jasmin.Wsize.U128, - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = rkey.319}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (25, 2); loc_end = (25, 6); loc_bchar = 680; - loc_echar = 684}}; - gs = Jasmin.Expr.Slocal}, - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = temp2.321}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (25, 10); loc_end = (25, 15); loc_bchar = 688; - loc_echar = 693}}; - gs = Jasmin.Expr.Slocal}))); - Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 6; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (26, 2); loc_end = (26, 48); loc_bchar = 697; - loc_echar = 743}; - stack_loc = []}, - []), - Jasmin.Expr.Copn - ([Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = temp2.321}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (26, 2); loc_end = (26, 7); loc_bchar = 697; - loc_echar = 702}}], - Jasmin.Expr.AT_keep, - Jasmin.Sopn.Oasm (Jasmin.Arch_extra.BaseOp (None, )), - [Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = temp2.321}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (26, 19); loc_end = (26, 24); loc_bchar = 714; - loc_echar = 719}}; - gs = Jasmin.Expr.Slocal}; - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = rkey.319}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (26, 26); loc_end = (26, 30); loc_bchar = 721; - loc_echar = 725}}; - gs = Jasmin.Expr.Slocal}; - Jasmin.Expr.PappN - (Jasmin.Expr.Opack (Jasmin.Wsize.U8, Jasmin.Wsize.PE2), - [Jasmin.Expr.Pconst - (Jasmin.BinNums.Zpos - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)); - Jasmin.Expr.Pconst Jasmin.BinNums.Z0; - Jasmin.Expr.Pconst - (Jasmin.BinNums.Zpos - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)); - Jasmin.Expr.Pconst Jasmin.BinNums.Z0])])); - Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 7; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (27, 2); loc_end = (27, 16); loc_bchar = 746; - loc_echar = 760}; - stack_loc = []}, - []), - Jasmin.Expr.Cassgn - (Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = rkey.319}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (27, 2); loc_end = (27, 6); loc_bchar = 746; - loc_echar = 750}}, - Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U128, - Jasmin.Expr.Papp2 (Jasmin.Expr.Olxor Jasmin.Wsize.U128, - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = rkey.319}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (27, 2); loc_end = (27, 6); loc_bchar = 746; - loc_echar = 750}}; - gs = Jasmin.Expr.Slocal}, - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = temp2.321}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (27, 10); loc_end = (27, 15); loc_bchar = 754; - loc_echar = 759}}; - gs = Jasmin.Expr.Slocal}))); - Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 8; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (28, 2); loc_end = (28, 16); loc_bchar = 764; - loc_echar = 778}; - stack_loc = []}, - []), - Jasmin.Expr.Cassgn - (Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = rkey.319}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (28, 2); loc_end = (28, 6); loc_bchar = 764; - loc_echar = 768}}, - Jasmin.Expr.AT_none, Jasmin.Type.Coq_sword Jasmin.Wsize.U128, - Jasmin.Expr.Papp2 (Jasmin.Expr.Olxor Jasmin.Wsize.U128, - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = rkey.319}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (28, 2); loc_end = (28, 6); loc_bchar = 764; - loc_echar = 768}}; - gs = Jasmin.Expr.Slocal}, - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = - Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = temp1.320}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (28, 10); loc_end = (28, 15); loc_bchar = 772; - loc_echar = 777}}; - gs = Jasmin.Expr.Slocal})))]; - f_tyout = - [Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - Jasmin.Type.Coq_sword Jasmin.Wsize.U128]; - f_res = - [{Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = rkey.319}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (29, 9); loc_end = (29, 13); loc_bchar = 788; - loc_echar = 792}}; - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sword Jasmin.Wsize.U128; - vname = temp2.321}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (29, 15); loc_end = (29, 20); loc_bchar = 794; - loc_echar = 799}}]; - f_extra = ()}); - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), - {Jasmin.Expr.f_info = - Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))); - f_tyin = [Jasmin.Type.Coq_sint]; - f_params = - [{Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = i.322}; - v_info = - {Jasmin.Location.loc_fname = ""; loc_start = (-1, -1); - loc_end = (-1, -1); loc_bchar = -1; loc_echar = -1}}]; - f_body = - [Jasmin.Expr.MkI - (({Jasmin.Location.uid_loc = 2; - base_loc = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (8, 2); loc_end = (17, 30); loc_bchar = 223; - loc_echar = 462}; - stack_loc = []}, - []), - Jasmin.Expr.Cassgn - (Jasmin.Expr.Lvar - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = c.323}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (8, 2); loc_end = (8, 3); loc_bchar = 223; - loc_echar = 224}}, - Jasmin.Expr.AT_inline, Jasmin.Type.Coq_sint, - Jasmin.Expr.Pif (Jasmin.Type.Coq_sint, - Jasmin.Expr.Papp2 (Jasmin.Expr.Oeq Jasmin.Expr.Op_int, - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = i.322}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (8, 8); loc_end = (8, 9); loc_bchar = 229; - loc_echar = 230}}; - gs = Jasmin.Expr.Slocal}, - Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos Jasmin.BinNums.Coq_xH)), - Jasmin.Expr.Pconst (Jasmin.BinNums.Zpos Jasmin.BinNums.Coq_xH), - Jasmin.Expr.Pif (Jasmin.Type.Coq_sint, - Jasmin.Expr.Papp2 (Jasmin.Expr.Oeq Jasmin.Expr.Op_int, - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = i.322}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (9, 8); loc_end = (9, 9); loc_bchar = 251; - loc_echar = 252}}; - gs = Jasmin.Expr.Slocal}, - Jasmin.Expr.Pconst - (Jasmin.BinNums.Zpos - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), - Jasmin.Expr.Pconst - (Jasmin.BinNums.Zpos - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)), - Jasmin.Expr.Pif (Jasmin.Type.Coq_sint, - Jasmin.Expr.Papp2 (Jasmin.Expr.Oeq Jasmin.Expr.Op_int, - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = i.322}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (10, 8); loc_end = (10, 9); loc_bchar = 273; - loc_echar = 274}}; - gs = Jasmin.Expr.Slocal}, - Jasmin.Expr.Pconst - (Jasmin.BinNums.Zpos - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))), - Jasmin.Expr.Pconst - (Jasmin.BinNums.Zpos - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))), - Jasmin.Expr.Pif (Jasmin.Type.Coq_sint, - Jasmin.Expr.Papp2 (Jasmin.Expr.Oeq Jasmin.Expr.Op_int, - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = i.322}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (11, 8); loc_end = (11, 9); - loc_bchar = 295; loc_echar = 296}}; - gs = Jasmin.Expr.Slocal}, - Jasmin.Expr.Pconst - (Jasmin.BinNums.Zpos - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))), - Jasmin.Expr.Pconst - (Jasmin.BinNums.Zpos - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))), - Jasmin.Expr.Pif (Jasmin.Type.Coq_sint, - Jasmin.Expr.Papp2 (Jasmin.Expr.Oeq Jasmin.Expr.Op_int, - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = i.322}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (12, 8); loc_end = (12, 9); - loc_bchar = 317; loc_echar = 318}}; - gs = Jasmin.Expr.Slocal}, - Jasmin.Expr.Pconst - (Jasmin.BinNums.Zpos - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))), - Jasmin.Expr.Pconst - (Jasmin.BinNums.Zpos - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), - Jasmin.Expr.Pif (Jasmin.Type.Coq_sint, - Jasmin.Expr.Papp2 (Jasmin.Expr.Oeq Jasmin.Expr.Op_int, - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = i.322}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (13, 8); loc_end = (13, 9); - loc_bchar = 340; loc_echar = 341}}; - gs = Jasmin.Expr.Slocal}, - Jasmin.Expr.Pconst - (Jasmin.BinNums.Zpos - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))), - Jasmin.Expr.Pconst - (Jasmin.BinNums.Zpos - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH)))))), - Jasmin.Expr.Pif (Jasmin.Type.Coq_sint, - Jasmin.Expr.Papp2 (Jasmin.Expr.Oeq Jasmin.Expr.Op_int, - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = i.322}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (14, 8); loc_end = (14, 9); - loc_bchar = 363; loc_echar = 364}}; - gs = Jasmin.Expr.Slocal}, - Jasmin.Expr.Pconst - (Jasmin.BinNums.Zpos - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))), - Jasmin.Expr.Pconst - (Jasmin.BinNums.Zpos - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))))), - Jasmin.Expr.Pif (Jasmin.Type.Coq_sint, - Jasmin.Expr.Papp2 (Jasmin.Expr.Oeq Jasmin.Expr.Op_int, - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = i.322}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (15, 8); loc_end = (15, 9); - loc_bchar = 393; loc_echar = 394}}; - gs = Jasmin.Expr.Slocal}, - Jasmin.Expr.Pconst - (Jasmin.BinNums.Zpos - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), - Jasmin.Expr.Pconst - (Jasmin.BinNums.Zpos - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO - Jasmin.BinNums.Coq_xH)))))))), - Jasmin.Expr.Pif (Jasmin.Type.Coq_sint, - Jasmin.Expr.Papp2 (Jasmin.Expr.Oeq Jasmin.Expr.Op_int, - Jasmin.Expr.Pvar - {Jasmin.Expr.gv = - {Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; - vname = i.322}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (16, 8); loc_end = (16, 9); - loc_bchar = 417; loc_echar = 418}}; - gs = Jasmin.Expr.Slocal}, - Jasmin.Expr.Pconst - (Jasmin.BinNums.Zpos - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xO Jasmin.BinNums.Coq_xH))))), - Jasmin.Expr.Pconst - (Jasmin.BinNums.Zpos - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH))))), - Jasmin.Expr.Pconst - (Jasmin.BinNums.Zpos - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xI - (Jasmin.BinNums.Coq_xO - (Jasmin.BinNums.Coq_xI Jasmin.BinNums.Coq_xH)))))))))))))))))]; - f_tyout = [Jasmin.Type.Coq_sint]; - f_res = - [{Jasmin.Expr.v_var = - {Jasmin.Var0.Var.vtype = Jasmin.Type.Coq_sint; vname = c.323}; - v_info = - {Jasmin.Location.loc_fname = - "/home/bshvass/ssprove/theories/Jasmin/examples/aes.jinc"; - loc_start = (18, 10); loc_end = (18, 11); loc_bchar = 473; - loc_echar = 474}}]; - f_extra = ()})]; - p_globs = []; p_extra = ()} diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index c604cd5a..a05845c6 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -901,8 +901,7 @@ Proof. - rewrite -mulP in e. rewrite -plusE in e. pose proof (nat_of_ident_pos x). micromega.Lia.lia. - - (* BSH: there is a more principled way of doing this, but this'll do for now *) - apply (f_equal (λ a, Nat.modulo a 256)) in e as xy_eq. + - apply (f_equal (λ a, Nat.modulo a 256)) in e as xy_eq. rewrite -Nat.add_mod_idemp_l in xy_eq. 2: micromega.Lia.lia. rewrite -Nat.mul_mod_idemp_l in xy_eq. 2: micromega.Lia.lia. rewrite Nat.mod_same in xy_eq. 2: micromega.Lia.lia. @@ -1310,17 +1309,11 @@ Definition translate_write_var (p : p_id) (x : var_i) (v : typed_chElement) := Definition translate_get_var (p : p_id) (x : var) : raw_code (encode x.(vtype)) := x ← get (translate_var p x) ;; ret x. -(* TW: We can remove it right? *) Fixpoint satisfies_globs (globs : glob_decls) : heap * heap → Prop. Proof. exact (λ '(x, y), False). (* TODO *) Defined. -(* Fixpoint collect_globs (globs : glob_decls) : seq Location. -Proof. - exact [::]. (* TODO *) -Defined. *) - Definition translate_gvar (p : p_id) (x : gvar) : raw_code (encode x.(gv).(vtype)) := if is_lvar x then translate_get_var p x.(gv).(v_var) @@ -1365,7 +1358,7 @@ Definition chArray_get_sub ws len (a : 'array) ptr scale := foldr (λ (i : Z) (data : 'array), match a (start + i)%Z with | Some w => setm data i w - | None => remm data i (* BSH: this should maybe not be done; I added it to simplify the proof of equivalence *) + | None => remm data i end ) emptym (ziota 0 size) ) @@ -1679,7 +1672,6 @@ End bind_list_alt. Context {fcp : FlagCombinationParams}. Definition embed_ot {t} : sem_ot t → encode t := match t with - (* BSH: I'm not sure this will be correct? In jasmin this is an Option bool, perhaps because you don't have to specify all output flags *) | sbool => λ x, match x with | Some b => b @@ -1773,8 +1765,8 @@ Fixpoint translate_pexpr (p : p_id) (e : pexpr) {struct e} : typed_code := | PappN op es => (* note that this is sligtly different from Papp2 and Papp1, in that we don't truncate when we bind, but when we apply (in app_sopn_list). - This made the proof easier, but is also more faithful(maybe?) to - how it is done in jasmin. Maybe we should change Papp1/2. + This made the proof easier, but is also more faithful to + how it is done in jasmin. *) totc _ ( vs ← bind_list [seq translate_pexpr p e | e <- es] ;; @@ -1789,46 +1781,6 @@ Fixpoint translate_pexpr (p : p_id) (e : pexpr) {struct e} : typed_code := ) end. -(* (* | Pget aa ws x e => *) - exists 'word ws. - (* Look up x amongst the evm part of the estate and the globals gd. Monadic - Let because we might find None. If (Some val) is found, fail with type - error unless (val = Varr n t). We obtain (n: positive) and (t: array n). *) - (* Let (n, t) := gd, s.[x] in *) - - pose (x' := translate_gvar p x). - pose (arr := y ← x'.π2 ;; @ret _ (coerce_to_choice_type 'array y)). - - (* Evaluate the indexing expression `e` and coerce it to Z. *) - (* Let i := sem_pexpr s e >>= to_int in *) - pose (i := coerce_typed_code 'int (translate_pexpr p e)). - - (* The actual array look-up, where - WArray.get aa ws t i = CoreMem.read t a (i * (mk_scale aa ws)) ws - and - mk_scale = (if aa == AAscale then (ws/8) else 1) *) - - (* Let w := WArray.get aa ws t i in *) - pose (scale := mk_scale aa ws). - - exact (a ← arr ;; ptr ← i ;; ret (chArray_get ws a ptr scale)). *) - - (* | PappN op es => *) - (* Let vs := mapM (sem_pexpr s) es in *) - (* sem_opN op vs *) - (* pose (vs := map (translate_pexpr p) l). - pose proof (sem_opN_typed o) as f. simpl in f. *) - -(* Fixpoint app_sopn T ts : sem_prod ts (exec T) → values → exec T := *) -(* match ts return sem_prod ts (exec T) → values → exec T with *) -(* | [::] => λ (o : exec T) (vs: values), if vs is [::] then o else type_error *) -(* | t :: ts => λ (o: sem_t t → sem_prod ts (exec T)) (vs: values), *) -(* if vs is v :: vs *) -(* then Let v := of_val t v in app_sopn (o v) vs *) -(* else type_error *) -(* end. *) - - (* pose (vs' := fold (fun x => y ← x ;; unembed y) f vs). *) Definition translate_write_lval (p : p_id) (l : lval) (v : typed_chElement) : raw_code 'unit @@ -1841,7 +1793,7 @@ Definition translate_write_lval (p : p_id) (l : lval) (v : typed_chElement) let vx : word _ := translate_to_pointer vx' in ve' ← (translate_pexpr p e).π2 ;; let ve := translate_to_pointer ve' in - let p := (vx + ve)%R in (* should we add the size of value, i.e vx + sz * se *) (* Is it from us or them? *) + let p := (vx + ve)%R in let w := truncate_chWord sz v.π2 in translate_write p w | Laset aa ws x i => @@ -1921,7 +1873,6 @@ Fixpoint foldr2 {A B R} (f : A → B → R → R) (la : seq A) (lb : seq B) r := end. Definition translate_write_lvals p ls vs := - (* foldl2 (λ c l v, translate_write_lval p l v ;; c) ls vs (ret tt). *) foldr2 (λ l v c, translate_write_lval p l v ;; c) ls vs (ret tt). Definition translate_write_vars p xs vs := @@ -1997,9 +1948,6 @@ Definition rel_mem (m : mem) (h : heap) := (* mem as array model: *) read m ptr U8 = ok v → (get_heap h mem_loc) ptr = Some v. - (* mem as locations model: *) - (* get_heap h (translate_ptr ptr) = *) - (* coerce_to_choice_type _ (translate_value (@to_val (sword U8) v)). *) Lemma translate_read : ∀ s ptr sz w m, @@ -2069,7 +2017,6 @@ Proof. Qed. (* Copy of write_read8 *) -(* BSH: i don't know if we need this any more (see write_mem_get) *) Lemma write_read_mem8 : ∀ m p ws w p', read_mem (write_mem (sz := ws) m p w) p' U8 = @@ -2195,7 +2142,6 @@ Definition stack_cons s_id (stf : stack_frame) : stack_frame := Notation "s_id ⊔ stf" := (stack_cons s_id stf) (at level 60). Definition stf_disjoint m_id s_id s_st := disj m_id s_id /\ forall s_id', List.In s_id' s_st -> disj m_id s_id'. - (* (forall stf : stack_frame, List.In stf st -> ). *) Definition valid_stack_frame '(vm, m_id, s_id, s_st) (h : heap) := rel_vmap vm m_id h /\ @@ -2208,12 +2154,6 @@ Definition valid_stack_frame '(vm, m_id, s_id, s_st) (h : heap) := (forall s_id', List.In s_id' s_st -> disj s_id s_id') /\ (forall s_id' s_id'', List.In s_id' s_st -> List.In s_id'' s_st -> s_id' <> s_id'' -> disj s_id' s_id''). -(* Lemma valid_stack_frame_push '(vm, m_id, s_id, s_st) (h : heap) : *) - -(* valid_stack_frame (vm, m_id, s_id, s_st) h -> *) -(* valid_stack_frame (vm, m_id, s_id', s_id :: s_st). *) -(* cons *) - Inductive valid_stack' : stack -> heap -> Prop := | valid_stack'_nil : forall h, valid_stack' [::] h | valid_stack'_cons : @@ -3402,7 +3342,6 @@ Proof. reflexivity. Qed. -(* BSH: I don't think these are necessary anymore *) Lemma list_tuple_cons_cons {t1 t2 : stype} {ts : seq stype} (p : sem_tuple (t1 :: t2 :: ts)) : list_ltuple p = (oto_val p.1) :: (list_ltuple (p.2 : sem_tuple (t2 :: ts))). Proof. reflexivity. Qed. @@ -3706,7 +3645,6 @@ Proof. unfold comp. eapply translate_pexprs_types. eassumption. - (* this should maybe be a lemma or the condition in bind_list_correct should be rewrote to match H *) * { clear -h2 H hcond. revert v' h2 H. @@ -3727,7 +3665,6 @@ Proof. intros. eapply H. { apply List.in_cons. assumption. } - (* { rewrite in_cons. rewrite H0. by apply /orP; right. } *) 1: eassumption. assumption. } @@ -4167,8 +4104,6 @@ Proof using P asm_op asmop pd. pose (trunc_list (f_tyin f) vargs') as vargs. apply (bind (translate_write_vars sid (f_params f) vargs)) => _. (* Perform the function body. *) - (* apply (bind (tr_f_body _ _ E)) => _. *) - (* pose (tr_f_body _ _ E) as tr_f. *) apply (bind (tr_f_body sid)) => _. eapply bind. - (* Look up the results in their locations... *) @@ -4252,51 +4187,6 @@ Proof using P asm_op asmop pd fcp. | _ => (s_id, unsupported.π2) end. Defined. -(* - Questions to answer for the translation of functions and function calls: - - When does argument truncation happen? - - What does each function get translated to? - - Idea 0: translate the function body each time it gets called. - This doesn't work if we look up the body in a dictionary à la `get_fundef`. If we try to apply `translate_cmd` to the result of a function call, - we have no guarantee this will terminate. - - Idea 1: - - Each jasmin function gets translated into a typed_raw_function - - The translation of a jasmin instruction is parametrised by a dictionary associating to each function name such a typed_raw_function. - - Each function call can then look up the translated function. - - The problem with this approach is that Jasmin functions don't expect their arguments to be of the right type. - Instead, they perform a truncation on the callee side. - To emulate this behaviour we would have to allow the application of a function to arguments of the wrong type. - This won't work with a `typed_raw_function = ∑ S T : choice_type, S → raw_code T` , as the arguments have to match the function type. - - A workaround would be to pack the arguments into a list of `typed_chElement`, i.e. `list (∑ t : choice_type, t)`, - but this type is too large to live inside `choice_type`. - Instead, we could translate each jasmin function to a "large" `Typed_Raw_Function = Π S T : choiceType, S → raw_code T`, - or more precisely `Π S T : list stype, [seq encode s | s <- S] → raw_code [seq encode t | t <- T]`, - or equivalently `list (Σ s : stype, encode s) → list (Σ t : stype, encode t)`. - - As a result, the translated functions do not fit `typed_raw_function`, - cannot directly be described by an `opsig`, - and thus can't be wrapped in a `raw_package`. - Question: Could we generalise the definition of `raw_package` to allow `Typed_Raw_Functions`? - - Instead of modifying `raw_package`, we could add Σ-types to `choice_type`. - This could be done using Paulin-Mohring's trick for representing inductive-recursive definitions in Coq. - As a first test we could use `boolp.choice_of_Type` to get the choice structure on the universe. - The `ordType` structure could come from `order.Order.SigmaOrder.le`. - Question: Do we rely on the computational properties of the choice structure of `choice_universe`? - - Idea 2: - - Each Jasmin function gets translated to a `'unit raw_code` corresponding to its body. - - translate_instr takes a map from p_ids to translated fun bodies. - - There is an additional wrapper function - `translate_call : p_id → (args : seq value) → (f_tyin : seq stype) -> (f_tr_body : 'unit raw_code) -> 'unit raw_code` - that does the work of truncating, and storing the function arguments as well as the returned results into their locations. - - the main theorem then talks not about running the translation of a function, but instead about translate_call - - *) (* translate_instr is blocked because it is a fixpoint *) Lemma translate_instr_unfold : @@ -4321,9 +4211,6 @@ Fixpoint translate_cmd (tr_f_body : fdefs) (c : cmd) (id : p_id) (sid : p_id) : End TranslateCMD. -(* PGH: CURRENTLY UNUSED. Keeping this around for when we want to package - functions into packages, as we'll have to bundle the arguments and results - into tuples. *) Record fdef := { ffun : typed_raw_function ; locs : {fset Location} ; @@ -4424,18 +4311,14 @@ Proof using asm_op asmop pd fcp. exact (f.1, translate_call prog f.1 (f::fs)). Defined. -(* PGH: TODO: do we need an ambient funname? *) Definition translate_funs (P : uprog) : seq _ufun_decl → fdefs * ssprove_prog := let fix translate_funs (fs : seq _ufun_decl) : fdefs * ssprove_prog := match fs with | [::] => ([::], [::]) | f :: fs' => - (* let '(tr_fs', tr_p') := translate_funs fs' in *) - (* let '(tr_fs', tr_p') := translate_funs fs' in *) let '(fn, f_extra) := f in let tr_body := fun sid => (translate_cmd P (translate_funs fs').1 (f_body f_extra) sid sid).2 in let tr_fs := (fn, tr_body) :: (translate_funs fs').1 in - (* let tr_p := (fn, translate_call P fn tr_fs) :: tr_p' in *) let tr_p := (fn, translate_call_body P fn tr_body) :: (translate_funs fs').2 in (tr_fs, tr_p) end @@ -4484,7 +4367,6 @@ Proof. noconf h. exists fs'. exists [::]. - (* exists (fun p => (translate_cmd P (translate_funs P fs').1 p (f_body f) p p)). *) simpl. destruct (translate_funs P fs') as [f_body f_prog] eqn:E2. simpl. @@ -4574,7 +4456,6 @@ Definition handled_cmd (c : cmd) := Definition handled_fundecl (f : _ufun_decl) := handled_cmd f.2.(f_body). -(* FIXME: bad naming *) Lemma lemma3 suf pre : (foldr (fun f '(b, l) => if b then (cmd_fs f.2.(f_body) l, f :: l) else (false, f :: l)) (true, [::]) (suf ++ pre)).1 -> (foldr (fun f '(b, l) => if b then (cmd_fs f.2.(f_body) l, f :: l) else (false, f :: l)) (true, [::]) pre).1. @@ -4590,7 +4471,6 @@ Proof. + easy. Qed. -(* FIXME: bad naming *) Lemma lemma4 pre : (foldr (fun f '(b, l) => if b then (cmd_fs f.2.(f_body) l, f :: l) else (false, f :: l)) (true, [::]) pre).2 = pre. Proof. @@ -4601,7 +4481,6 @@ Proof. destruct b; simpl in *; congruence. Qed. -(* FIXME: bad naming *) Lemma lemma2 g gn (pre suf : list _ufun_decl) : (foldr (fun f '(b, l) => if b then (cmd_fs f.2.(f_body) l, f :: l) else (false, f :: l)) (true, [::]) (suf ++ (gn,g) :: pre)).1 -> cmd_fs g.(f_body) pre. @@ -4874,7 +4753,6 @@ Qed. Definition Pfun (P : uprog) (fn : funname) scs m va scs' m' vr vm m_id s_id s_st st := ⊢ ⦃ rel_estate {| escs := scs ; emem := m; evm := vm |} m_id s_id s_st st ⦄ - (* translate_call P fn (translate_prog' P) [seq totce (translate_value v) | v <- va] *) get_translated_fun P fn s_id~1 [seq totce (translate_value v) | v <- va] ⇓ [seq totce (translate_value v) | v <- vr] ⦃ rel_estate {| escs := scs' ; emem := m' ; evm := vm |} m_id s_id~0 s_st st ⦄. @@ -4897,7 +4775,6 @@ Proof. reflexivity. Qed. -(* FIXME: bad naming *) Lemma hget_lemma2 l scs m vm vres m_id s_id s_st st : mapM (λ x : var_i, get_var vm x) l = ok vres -> List.Forall2 @@ -4921,7 +4798,6 @@ Proof. + eapply IHl. assumption. Qed. -(* FIXME: bad naming *) Lemma htrunc_lemma1 l vargs vargs': mapM2 ErrType truncate_val l vargs' = ok vargs -> (trunc_list l [seq totce (translate_value v) | v <- vargs']) = [seq totce (translate_value v) | v <- vargs]. @@ -4959,7 +4835,6 @@ Proof. rewrite IHl; auto. Qed. -(* FIXME: bad naming *) Lemma lemma1 P pre c suf m_id : uniq [seq p.1 | p <- suf ++ pre] -> forall s_id, diff --git a/theories/Jasmin/word.v b/theories/Jasmin/word.v index f046f9cb..588a36ba 100644 --- a/theories/Jasmin/word.v +++ b/theories/Jasmin/word.v @@ -167,11 +167,8 @@ Proof. Qed. Lemma subword_xor {n} i ws (a b : n.-word) : - (* I don't know if the assumption is necessary *) - (* (ws <= n)%nat -> *) subword i ws (a ⊕ b) = (subword i ws a) ⊕ (subword i ws b). Proof. - (* intros H. *) apply/eqP/eq_from_wbit. intros. rewrite !wbit_subword. rewrite !wxorE. @@ -534,8 +531,6 @@ Proof. Unshelve. exact word0. Qed. -(* Check SubBytes. *) - Lemma ShiftRows_SubBytes s : ShiftRows (SubBytes s) = SubBytes (ShiftRows s). Proof. unfold ShiftRows. simpl. @@ -560,14 +555,6 @@ Proof. reflexivity. Qed. -(* (* NOTE: This is only so simple because InvMixColumns is not properly implemented *) *) -(* Lemma AESDEC_AESDEC_ s k : wAESDEC s (InvMixColumns k) = wAESDEC_ s k. *) -(* Proof. *) -(* unfold wAESDEC, wAESDEC_. *) -(* unfold InvMixColumns. *) -(* reflexivity. *) -(* Qed. *) - Lemma wAESENCLAST_wAESENCLAST_ s k : wAESENCLAST s k = wAESENCLAST_ s k. Proof. unfold wAESENCLAST, wAESENCLAST_. From eb23fda3144cc0369c1e0f89a50ab9ee3e82a0fd Mon Sep 17 00:00:00 2001 From: "Benjamin S. Hvass" Date: Wed, 26 Apr 2023 15:08:28 +0200 Subject: [PATCH 367/383] change unsupported to ret dummy makes all translated programs deterministic --- theories/Jasmin/jasmin_translate.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index a05845c6..83f5a307 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1245,7 +1245,7 @@ Proof. Qed. #[local] Definition unsupported : typed_code := - ('unit ; assert false). + ('unit ; ret (chCanonical 'unit)). Lemma truncate_val_type : ∀ ty v v', From e262f06ecf560b6caef17b0bc2e7af44bb47109f Mon Sep 17 00:00:00 2001 From: "Benjamin S. Hvass" Date: Wed, 26 Apr 2023 15:09:08 +0200 Subject: [PATCH 368/383] prove `get_translated_fun` deterministic --- theories/Jasmin/jasmin_translate.v | 352 +++++++++++++++++++++++++++++ 1 file changed, 352 insertions(+) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 83f5a307..a52d9a1c 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -5363,3 +5363,355 @@ Proof. - destruct e ; simpl ; repeat constructor. destruct w ; repeat constructor. Qed. + +Lemma deterministic_seq {A} (c1 : raw_code A) {B} (c2 : raw_code B) : + deterministic c1 -> + deterministic c2 -> + deterministic (c1 ;; c2). +Proof. + intros. + revert X0. revert c2. (* generalize (B c1). *) + induction c1; eauto; intros. + - inversion X. + - simpl. constructor. inversion X. + noconf H1; subst; simpl in *. intros. eapply X0; eauto. + - simpl. constructor. inversion X. + noconf H1; subst; simpl in *. intros. eapply IHc1; eauto. + - inversion X. +Qed. + +Lemma deterministic_bind {A} (c1 : raw_code A) {B} (c2 : A -> raw_code B) : + deterministic c1 -> + (forall x, deterministic (c2 x)) -> + deterministic (x ← c1 ;; c2 x). +Proof. + intros. + revert X0. revert c2. (* generalize (B c1). *) + induction c1; eauto; intros. + - simpl. inversion X. + - simpl. constructor. inversion X. + noconf H1; subst; simpl in *. intros. eapply X0; eauto. + - simpl. constructor. inversion X. + noconf H1; subst; simpl in *. intros. eapply IHc1; eauto. + - inversion X. +Qed. + +Lemma translate_write_vars_deterministic i vs ts : + deterministic (translate_write_vars i vs ts). +Proof. + revert vs ts. + induction vs, ts. + 1,2,3: unfold translate_write_vars; simpl; econstructor. + unfold translate_write_vars in *. eapply deterministic_seq. + - unfold translate_write_var. constructor. constructor. + - eapply IHvs. +Qed. + +Lemma translate_gvar_deterministic g i v : + deterministic (translate_gvar g i v). +Proof. + unfold translate_gvar. destruct is_lvar. + * unfold translate_get_var. constructor. intros; constructor. + * destruct get_global; constructor. +Qed. + +Lemma translate_pexpr_deterministic g i e : + deterministic (translate_pexpr g i e).π2. +Proof. + revert i g. + refine ( + (fix aux (e1 : pexpr) := + match e1 with + | _ => _ end) e + ). + destruct e1; intros; simpl; try constructor. + - apply translate_gvar_deterministic. + - simpl. + eapply deterministic_bind. + + eapply translate_gvar_deterministic. + + intros. simpl. + rewrite bind_assoc. + eapply deterministic_bind. + * eapply aux. + * intros. constructor. + - eapply deterministic_bind. + + eapply translate_gvar_deterministic. + + intros. simpl. + rewrite bind_assoc. + eapply deterministic_bind. + * eapply aux. + * intros. constructor. + - intros. + rewrite bind_assoc. + eapply deterministic_bind; try constructor. + + eapply aux. + + intros. constructor. + - rewrite bind_assoc. + eapply deterministic_bind; try constructor. + eapply aux. + - rewrite !bind_assoc. + eapply deterministic_bind; try constructor. + + eapply aux. + + intros. + eapply deterministic_bind; try constructor. + intros. + eapply deterministic_bind; try constructor; auto. + eapply deterministic_bind; try constructor; auto. + - epose proof deterministic_bind (bind_list [seq translate_pexpr g i e0 | e0 <- l]) (fun vs => ret (tr_app_sopn_single (type_of_opN o).1 (sem_opN_typed o) vs)). + eapply X. + + clear -aux. induction l. + * constructor. + * simpl. eapply deterministic_bind. + ** eapply aux. + ** intros. + epose proof deterministic_bind (bind_list [seq translate_pexpr g i e0 | e0 <- l]). + eapply X. + *** assumption. + *** constructor. + + constructor. + - rewrite bind_assoc. + eapply deterministic_bind; try constructor. + + apply aux. + + intros. + eapply deterministic_bind; try constructor. + intros. + destruct x0. + * eapply deterministic_bind; try constructor; auto. + * eapply deterministic_bind; try constructor; auto. +Qed. + +Lemma translate_write_var_deterministic i H v : + deterministic (translate_write_var i H v). +Proof. + repeat constructor. +Qed. + +Lemma translate_write_lval_deterministic g i l v : + deterministic (translate_write_lval g i l v). +Proof. + destruct l; intros; simpl. + - constructor. + - eapply translate_write_var_deterministic. + - constructor; intros. + eapply deterministic_bind; try constructor; auto. + 1: eapply translate_pexpr_deterministic. intros. + repeat constructor. + - constructor; intros. + eapply deterministic_bind; try constructor; auto. + + eapply deterministic_bind; try constructor. + eapply translate_pexpr_deterministic. + + constructor. + - constructor; intros. + eapply deterministic_bind; try constructor; auto. + + eapply deterministic_bind; try constructor. + eapply translate_pexpr_deterministic. + + constructor. +Qed. + +Lemma translate_write_lvals_deterministic g i l vs : + deterministic (translate_write_lvals g i l vs). +Proof. + revert l vs. + induction l, vs. + 1,2,3: constructor. + unfold translate_write_lvals. + simpl. + eapply deterministic_seq. + 1: eapply translate_write_lval_deterministic. + eapply IHl. +Qed. + +Lemma translate_call_body_deterministic P f fd i vs : + deterministic (fd i) -> + deterministic (translate_call_body P f fd i vs). +Proof. + intros. + unfold translate_call_body. + induction p_funcs. + - constructor. + - simpl. destruct a. destruct (f == f0) eqn:E. + + eapply deterministic_seq. + 1: eapply translate_write_vars_deterministic. + eapply deterministic_seq. + 1: eapply X. + eapply deterministic_bind with (c2:= (fun vres => ret (trunc_list (f_tyout _f) vres))). + * clear -_f. induction f_res. + ** constructor. + ** simpl. constructor. + intros. eapply deterministic_bind with (c2 := (fun vs => ret (totce x :: vs))). + 1: eapply IHl. + constructor. + * constructor. + + eapply IHl. +Qed. + +Lemma translate_call_deterministic P f (fd : fdefs) i vs : + deterministic (match assoc fd f with Some f => f i | _ => ret tt end) -> + deterministic (translate_call P f fd i vs). +Proof. + intros. + unfold translate_call. + destruct assoc. + 2: constructor. + eapply translate_call_body_deterministic. + assumption. +Qed. + +Lemma coe_tyc_deterministic t c : + deterministic c.π2 -> deterministic (coe_tyc t c). +Proof. + destruct c. + intros. + destruct (x == t) eqn:E. + + move: E => /eqP. intros; subst. + rewrite coerce_typed_code_K; try constructor. + assumption. + + rewrite coerce_typed_code_neq; try constructor. + move: E => /eqP //. +Qed. + +Lemma translate_for_deterministic v l i0 f i1 : + (forall i, deterministic (f i).2) -> + deterministic (translate_for v l i0 f i1). +Proof. + intros. + revert i1. + induction l; intros. + - constructor. + - simpl. + specialize (X i1). + destruct (f i1). + simpl in *. + constructor. + eapply deterministic_seq. + 1: assumption. + eapply IHl. +Qed. + +Fixpoint translate_instr_deterministic p (fd : fdefs) i i1 i2 {struct i} : + (forall f i, deterministic (match assoc fd f with Some f => f i | _ => ret tt end)) -> + deterministic (translate_instr p fd i i1 i2).2. +Proof. + revert i1 i2. + intros. + epose proof (translate_cmd_deterministic := + (fix translate_cmd (c : cmd) (s_id : p_id) : deterministic (translate_cmd p fd c i1 s_id).2 := + match c with + | [::] => _ + | i :: c => _ + end + ) + ). + destruct i; destruct i0; simpl in *; intros. + - simpl. eapply deterministic_bind. + + eapply translate_pexpr_deterministic. + + intros. + eapply translate_write_lval_deterministic. + - eapply deterministic_bind with (c1 := bind_list _). + + clear -i1. + induction l0. + * constructor. + * simpl. + eapply deterministic_bind. + 1: eapply translate_pexpr_deterministic. + intros. + eapply deterministic_bind with (c1 := bind_list _). + 1: eapply IHl0. + constructor. + + intros. + eapply translate_write_lvals_deterministic. + - constructor. + - rewrite translate_instr_unfold. simpl. + rewrite translate_instr_r_if. + pose proof (translate_cmd_deterministic l i2). + destruct translate_cmd. simpl. + pose proof (translate_cmd_deterministic l0 p1). + destruct translate_cmd. simpl. + eapply deterministic_bind. + + eapply coe_tyc_deterministic with (t := 'bool). + eapply translate_pexpr_deterministic. + + destruct x; assumption. + - rewrite translate_instr_unfold. + rewrite translate_instr_r_for. + destruct r as [[d lo] hi]. + simpl. + eapply deterministic_bind. + 1: eapply coe_tyc_deterministic with (t:= 'int); eapply translate_pexpr_deterministic. + intros; eapply deterministic_bind. + 1: eapply coe_tyc_deterministic with (t:= 'int); eapply translate_pexpr_deterministic. + intros. + eapply translate_for_deterministic. + intros. + eapply translate_cmd_deterministic. + - constructor. + - eapply deterministic_bind with (c1 := bind_list _). + + clear -i1. + induction l0. + * constructor. + * simpl. + eapply deterministic_bind. + 1: eapply translate_pexpr_deterministic. + intros. + eapply deterministic_bind with (c1 := bind_list _). + 1: eapply IHl0. + constructor. + + intros; simpl. + eapply deterministic_bind with (c1 := translate_call _ _ _ _ _). + 1: eapply translate_call_deterministic. + 1: eapply X. + eapply translate_write_lvals_deterministic. + Unshelve. + 1: constructor. + simpl. + specialize (translate_instr_deterministic p fd i i1 s_id). + destruct translate_instr. + specialize (translate_cmd c p0). + destruct jasmin_translate.translate_cmd. + eapply deterministic_seq. + 1: eapply translate_instr_deterministic. + all: try assumption. +Qed. + +Lemma translate_cmd_deterministic p fd c i1 i2 : + (forall f i, deterministic (match assoc fd f with Some f => f i | _ => ret tt end)) -> + deterministic (translate_cmd p fd c i1 i2).2. +Proof. + revert i1 i2. + induction c; intros. + - constructor. + - simpl. + pose proof translate_instr_deterministic p fd a i1 i2 X. + destruct translate_instr. + specialize (IHc i1 p0 X). + destruct translate_cmd. + simpl in *. + eapply deterministic_seq; auto. +Qed. + +Lemma translate_funs_deterministic P fn : + forall f i, deterministic (match assoc (translate_funs P fn).1 f with Some f => f i | _ => ret tt end). +Proof. + induction fn; intros. + - constructor. + - simpl. destruct a. simpl. + destruct (f == f0). + + eapply translate_cmd_deterministic. + assumption. + + eapply IHfn. +Qed. + +Lemma get_translated_fun_deterministic P fn i vs : + deterministic (get_translated_fun P fn i vs). +Proof. + (* destruct P. *) + unfold get_translated_fun. + unfold translate_prog'. simpl. + induction p_funcs. + - simpl. constructor. + - simpl. destruct a. simpl. + destruct (fn == f). + + eapply translate_call_body_deterministic. + eapply translate_cmd_deterministic. + eapply translate_funs_deterministic. + + assumption. +Qed. From 96146e21bf13e006eb048fb418562b1ef6ee5ba0 Mon Sep 17 00:00:00 2001 From: "Benjamin S. Hvass" Date: Wed, 26 Apr 2023 16:26:38 +0200 Subject: [PATCH 369/383] mv x86_correct --- _CoqProject | 1 + theories/Jasmin/jasmin_translate.v | 77 +------------------- theories/Jasmin/jasmin_x86.v | 108 +++++++++++++++++++++++++++++ 3 files changed, 111 insertions(+), 75 deletions(-) create mode 100644 theories/Jasmin/jasmin_x86.v diff --git a/_CoqProject b/_CoqProject index 22a7801d..7f8bfe44 100644 --- a/_CoqProject +++ b/_CoqProject @@ -79,6 +79,7 @@ theories/Crypt/rules/UniformStateProb.v # Jasmin theories/Jasmin/jasmin_translate.v +theories/Jasmin/jasmin_x86.v theories/Jasmin/jasmin_utils.v theories/Jasmin/word.v diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index a52d9a1c..5e6f5613 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -5289,81 +5289,6 @@ Proof using gd asm_correct. - assumption. Qed. -End Translation. - -From Jasmin Require Import x86_instr_decl x86_extra (* x86_gen *) (* x86_linear_sem *). -Import arch_decl. - -Lemma id_tin_instr_desc : - ∀ (a : asm_op_msb_t), - id_tin (instr_desc a) = id_tin (x86_instr_desc a.2). -Proof. - intros [[ws|] a]. - - simpl. destruct (_ == _). all: reflexivity. - - reflexivity. -Qed. - -Definition cast_sem_prod_dom {ts tr} ts' (f : sem_prod ts tr) (e : ts = ts') : - sem_prod ts' tr. -Proof. - subst. exact f. -Defined. - -Lemma cast_sem_prod_dom_K : - ∀ ts tr f e, - @cast_sem_prod_dom ts tr ts f e = f. -Proof. - intros ts tr f e. - assert (e = erefl). - { apply eq_irrelevance. } - subst. reflexivity. -Qed. - -Lemma sem_correct_rewrite : - ∀ R ts ts' f e, - sem_correct ts' (cast_sem_prod_dom ts' f e) → - @sem_correct R ts f. -Proof. - intros R ts ts' f e h. - subst. rewrite cast_sem_prod_dom_K in h. - assumption. -Qed. - -Lemma no_arr_correct {R} ts s : - List.Forall (λ t, ∀ len, t != sarr len) ts → - @sem_correct R ts s. -Proof. - intros h. - induction h as [| t ts ht h ih]. - - constructor. - - constructor. - + intros v. - pose proof unembed_embed t v as e. - destruct t as [| | len |]. - 1,2,4: rewrite e ; reflexivity. - specialize (ht len). move: ht => /eqP. contradiction. - + intros v. - apply ih. -Qed. - -Lemma x86_correct : - ∀ (o : asm_op_t), - sem_correct (tin (sopn.get_instr_desc (Oasm o))) (sopn_sem (Oasm o)). -Proof. - intros o. - simpl. destruct o as [a | e]. - - Opaque instr_desc. simpl. - pose proof (id_tin_instr_desc a) as e. - eapply sem_correct_rewrite with (e := e). - destruct a as [o x]. simpl in *. - eapply no_arr_correct. - destruct x ; simpl. - all: repeat constructor. - Transparent instr_desc. - - destruct e ; simpl ; repeat constructor. - destruct w ; repeat constructor. -Qed. - Lemma deterministic_seq {A} (c1 : raw_code A) {B} (c2 : raw_code B) : deterministic c1 -> deterministic c2 -> @@ -5715,3 +5640,5 @@ Proof. eapply translate_funs_deterministic. + assumption. Qed. + +End Translation. diff --git a/theories/Jasmin/jasmin_x86.v b/theories/Jasmin/jasmin_x86.v new file mode 100644 index 00000000..20baceb9 --- /dev/null +++ b/theories/Jasmin/jasmin_x86.v @@ -0,0 +1,108 @@ +Set Warnings "-ambiguous-paths,-notation-overridden,-notation-incompatible-format". +From mathcomp Require Import all_ssreflect all_algebra. +From mathcomp.word Require Import ssrZ word. +From Jasmin Require Import expr compiler_util values sem. +Set Warnings "ambiguous-paths,notation-overridden,notation-incompatible-format". + +From extructures Require Import ord fset fmap. +Set Warnings "-ambiguous-paths". +(* Silencing the following warning: *) +(* New coercion path [Pbool] : bool >-> pexpr is ambiguous with existing *) +(* [nat_of_bool; Posz; int_to_Z; Pconst] : bool >-> pexpr. *) +From Jasmin Require Import expr_facts. +Set Warnings "ambiguous-paths". + +From Coq Require Import Utf8. + +From Crypt Require Import Prelude Package. +Import PackageNotation. + +From Equations Require Import Equations. +Set Equations With UIP. +Set Equations Transparent. + +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Set Bullet Behavior "Strict Subproofs". +Set Default Goal Selector "!". +Set Primitive Projections. +Set Default Proof Using "Type". +From JasminSSProve Require Import jasmin_translate. +From Jasmin Require Import x86_instr_decl x86_extra (* x86_gen *) (* x86_linear_sem *). + +Section x86_correct. + + Import arch_decl. + + Lemma id_tin_instr_desc : + ∀ (a : asm_op_msb_t), + id_tin (instr_desc a) = id_tin (x86_instr_desc a.2). + Proof. + intros [[ws|] a]. + - simpl. destruct (_ == _). all: reflexivity. + - reflexivity. + Qed. + + Definition cast_sem_prod_dom {ts tr} ts' (f : sem_prod ts tr) (e : ts = ts') : + sem_prod ts' tr. + Proof. + subst. exact f. + Defined. + + Lemma cast_sem_prod_dom_K : + ∀ ts tr f e, + @cast_sem_prod_dom ts tr ts f e = f. + Proof. + intros ts tr f e. + assert (e = erefl). + { apply eq_irrelevance. } + subst. reflexivity. + Qed. + + Lemma sem_correct_rewrite : + ∀ R ts ts' f e, + sem_correct ts' (cast_sem_prod_dom ts' f e) → + @sem_correct R ts f. + Proof. + intros R ts ts' f e h. + subst. rewrite cast_sem_prod_dom_K in h. + assumption. + Qed. + + Lemma no_arr_correct {R} ts s : + List.Forall (λ t, ∀ len, t != sarr len) ts → + @sem_correct R ts s. + Proof. + intros h. + induction h as [| t ts ht h ih]. + - constructor. + - constructor. + + intros v. + pose proof unembed_embed t v as e. + destruct t as [| | len |]. + 1,2,4: rewrite e ; reflexivity. + specialize (ht len). move: ht => /eqP. contradiction. + + intros v. + apply ih. + Qed. + + Lemma x86_correct : + ∀ (o : asm_op_t), + sem_correct (tin (sopn.get_instr_desc (Oasm o))) (sopn_sem (Oasm o)). + Proof. + intros o. + simpl. destruct o as [a | e]. + - Opaque instr_desc. simpl. + pose proof (id_tin_instr_desc a) as e. + eapply sem_correct_rewrite with (e := e). + destruct a as [o x]. simpl in *. + eapply no_arr_correct. + destruct x ; simpl. + all: repeat constructor. + Transparent instr_desc. + - destruct e ; simpl ; repeat constructor. + destruct w ; repeat constructor. + Qed. + +End x86_correct. From 56d986af198cece4dd796355a1db2fa579fffaaf Mon Sep 17 00:00:00 2001 From: "Benjamin S. Hvass" Date: Thu, 27 Apr 2023 13:14:46 +0200 Subject: [PATCH 370/383] fix aes_utils --- theories/Jasmin/examples/aes/aes_utils.v | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/theories/Jasmin/examples/aes/aes_utils.v b/theories/Jasmin/examples/aes/aes_utils.v index a128300c..1b4d5dab 100644 --- a/theories/Jasmin/examples/aes/aes_utils.v +++ b/theories/Jasmin/examples/aes/aes_utils.v @@ -5,6 +5,12 @@ Set Warnings "notation-overridden,ambiguous-paths". From Coq Require Import Utf8 ZArith micromega.Lia List. +From Jasmin Require Import sem. + +Context + {pd : PointerData} + {fcp : FlagCombinationParams}. + From Jasmin Require Import expr xseq. From JasminSSProve Require Import jasmin_translate. @@ -18,8 +24,8 @@ Import JasminNotation. Import PackageNotation. Set Bullet Behavior "Strict Subproofs". -Set Default Goal Selector "!". - +Set Default Goal Selector "!". + (** Notations *) Module AesNotation. @@ -292,12 +298,12 @@ Proof. Qed. Lemma in_ziota' i p z : - @in_mem (Ord.sort Z_ordType) i (@mem (Equality.sort (Ord.eqType Z_ordType)) (seq_predType (Ord.eqType Z_ordType)) (ziota p z)) = (p <=? i) && (i ∀ p : Z, @in_mem (Ord.sort Z_ordType) i (@mem (Equality.sort (Ord.eqType Z_ordType)) (seq_predType (Ord.eqType Z_ordType)) (ziota p z)) = (p <=? i) && (i ∀ p : Z, @in_mem (Ord.sort Z_ordType) i (@ssrbool.mem (Equality.sort (Ord.eqType Z_ordType)) (seq_predType (Ord.eqType Z_ordType)) (ziota p z)) = (p <=? i) && (i P z). 1: { apply natlike_ind. - unfold P. intros. rewrite in_nil. lia. From f0bc6f90ddd0c5abe2d24f1014384c8052bde881 Mon Sep 17 00:00:00 2001 From: "Benjamin S. Hvass" Date: Tue, 2 May 2023 09:31:03 +0200 Subject: [PATCH 371/383] add combined compiler/translation theorem --- _CoqProject | 1 + theories/Jasmin/jasmin_asm.v | 79 ++++++++++++++++++++++++++++++ theories/Jasmin/jasmin_translate.v | 4 +- theories/Jasmin/jasmin_x86.v | 33 +++++++++++-- 4 files changed, 110 insertions(+), 7 deletions(-) create mode 100644 theories/Jasmin/jasmin_asm.v diff --git a/_CoqProject b/_CoqProject index 7f8bfe44..92c03f74 100644 --- a/_CoqProject +++ b/_CoqProject @@ -80,6 +80,7 @@ theories/Crypt/rules/UniformStateProb.v # Jasmin theories/Jasmin/jasmin_translate.v theories/Jasmin/jasmin_x86.v +theories/Jasmin/jasmin_asm.v theories/Jasmin/jasmin_utils.v theories/Jasmin/word.v diff --git a/theories/Jasmin/jasmin_asm.v b/theories/Jasmin/jasmin_asm.v new file mode 100644 index 00000000..6c638e90 --- /dev/null +++ b/theories/Jasmin/jasmin_asm.v @@ -0,0 +1,79 @@ +From mathcomp Require Import all_ssreflect all_algebra. + +From Jasmin Require Import + arch_params_proof + compiler + compiler_proof. + +From Jasmin Require Import + arch_decl + arch_extra + arch_sem + asm_gen_proof. + +From Jasmin Require Import sem. + +From JasminSSProve Require Import jasmin_translate. +From Crypt Require Import Prelude Package. + +Import PackageNotation. +Import JasminNotation. +Import Utf8. + +Local Open Scope positive. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Section __. + +Context + {syscall_state : Type} {sc_sem : syscall.syscall_sem syscall_state} {gf : glob_decls} + `{asm_e : asm_extra} {call_conv : calling_convention} {asm_scsem : asm_syscall_sem} + {fresh_vars lowering_options : Type} + (aparams : architecture_params fresh_vars lowering_options) + (haparams : h_architecture_params aparams) + (cparams : compiler_params fresh_vars lowering_options). + +Hypothesis print_uprogP : forall s p, cparams.(print_uprog) s p = p. +Hypothesis print_sprogP : forall s p, cparams.(print_sprog) s p = p. +Hypothesis print_linearP : forall s p, cparams.(print_linear) s p = p. + +Context `(asm_correct : ∀ o, sem_correct (tin (get_instr_desc (Oasm o))) (sopn_sem (Oasm o))). + +Theorem equiv_to_asm subroutine p xp entries scs vm m fn scs' m' va vr xm m_id s_id s_st st : + compile_prog_to_asm aparams cparams entries subroutine p = ok xp + -> fn \in entries + -> sem.sem_call p scs m fn va scs' m' vr + -> handled_program p + -> mem_agreement m (asm_mem xm) (asm_rip xm) (asm_globs xp) + -> enough_stack_space xp fn (top_stack m) (asm_mem xm) + -> ⊢ ⦃ rel_estate (sem.Estate scs m vm) m_id s_id s_st st ⦄ + get_translated_fun p fn s_id~1 [seq totce (translate_value v) | v <- va] + ⇓ [seq totce (translate_value v) | v <- vr] + ⦃ rel_estate (sem.Estate scs' m' vm) m_id s_id~0 s_st st ⦄ + /\ exists xd : asm_fundef, + get_fundef (asm_funcs xp) fn = Some xd + /\ forall args', + asm_scs xm = scs + -> asm_reg xm ad_rsp = top_stack m + -> get_typed_reg_values xm (asm_fd_arg xd) = ok args' + -> List.Forall2 value_uincl va args' + -> exists xm' res', + get_typed_reg_values xm' (asm_fd_res xd) = ok res' + /\ List.Forall2 value_uincl vr res'. +Proof. + intros cmp fn_in sc hp mem ss. + split. + unshelve eapply translate_prog_correct; try eauto. + unshelve epose proof compile_prog_to_asmP haparams _ _ _ cmp fn_in sc mem ss as [xd [get_fd _ cmp_correct]]; eauto. + exists xd. split; eauto. + intros args'. + specialize (cmp_correct args'). + intros asm_scs asm_reg reg_args' args'_va. + specialize (cmp_correct asm_scs asm_reg reg_args' args'_va) as [xm' [res' []]]. + exists xm', res'; eauto. +Qed. + +End __. diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 5e6f5613..beb9f5a2 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -651,11 +651,8 @@ Import JasminNotation. Section Translation. Context `{asmop : asmOp}. - Context {pd : PointerData}. - Context (gd : glob_decls). - Context `{sc_sem : syscall_sem }. Definition mem_index : nat := 0. @@ -2595,6 +2592,7 @@ Qed. Definition rel_estate (s : estate) (m_id : p_id) (s_id : p_id) (s_st : list p_id) (st : stack) (h : heap) := rel_mem s.(emem) h /\ valid_stack ((s.(evm), m_id, s_id, s_st) :: st) h. + Lemma translate_read_estate : ∀ s ptr sz w m_id s_id s_st c_stack m, rel_estate s m_id s_id s_st c_stack m → diff --git a/theories/Jasmin/jasmin_x86.v b/theories/Jasmin/jasmin_x86.v index 20baceb9..a63dfced 100644 --- a/theories/Jasmin/jasmin_x86.v +++ b/theories/Jasmin/jasmin_x86.v @@ -28,12 +28,24 @@ Set Bullet Behavior "Strict Subproofs". Set Default Goal Selector "!". Set Primitive Projections. Set Default Proof Using "Type". -From JasminSSProve Require Import jasmin_translate. -From Jasmin Require Import x86_instr_decl x86_extra (* x86_gen *) (* x86_linear_sem *). -Section x86_correct. +From JasminSSProve Require Import jasmin_translate jasmin_asm. + +From Jasmin Require Import + x86_instr_decl + x86_extra + x86_params + x86_params_proof + x86_decl + x86_lowering + x86. - Import arch_decl. +From Jasmin Require Import + arch_sem + compiler + compiler_proof. + +Section x86_correct. Lemma id_tin_instr_desc : ∀ (a : asm_op_msb_t), @@ -105,4 +117,17 @@ Section x86_correct. destruct w ; repeat constructor. Qed. +Context + {syscall_state : Type} + {sc_sem : syscall.syscall_sem syscall_state} + {gf : glob_decls} + {asm_scsem : asm_syscall_sem (call_conv:=x86_linux_call_conv)} + (cparams : compiler_params fresh_vars lowering_options). + + Hypothesis print_uprogP : forall s p, cparams.(print_uprog) s p = p. + Hypothesis print_sprogP : forall s p, cparams.(print_sprog) s p = p. + Hypothesis print_linearP : forall s p, cparams.(print_linear) s p = p. + + Definition equiv_to_x86 := @equiv_to_asm syscall_state sc_sem gf _ _ _ _ _ _ _ _ x86_linux_call_conv _ _ _ _ x86_h_params cparams print_uprogP print_sprogP print_linearP x86_correct. + End x86_correct. From 85376217cf1875f0bbf04ae6cdd05874b34c238d Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Mon, 21 Aug 2023 14:36:39 +0200 Subject: [PATCH 372/383] fix PRF encryption to return nonce --- README.md | 3 +- theories/Jasmin/examples/aes/aes_prf.v | 53 +++++++++++++------------- 2 files changed, 28 insertions(+), 28 deletions(-) diff --git a/README.md b/README.md index 5869e8b7..c0862c71 100644 --- a/README.md +++ b/README.md @@ -83,7 +83,8 @@ Run `make graph` to build a graph of dependencies between sources. | [theories] | Root of all the Coq files | | [theories/Mon] | External development coming from "Dijkstra Monads For All" | | [theories/Relational] | External development coming from "The Next 700 Relational Program Logics"| -| [theories/Crypt] | This paper | +| [theories/Crypt] | The original SSProve paper | +| [theories/Jasmin] | This paper | Unless specified with a full path, all files considered in this README can safely be assumed to be in [theories/Crypt]. diff --git a/theories/Jasmin/examples/aes/aes_prf.v b/theories/Jasmin/examples/aes/aes_prf.v index 61b1585c..48918600 100644 --- a/theories/Jasmin/examples/aes/aes_prf.v +++ b/theories/Jasmin/examples/aes/aes_prf.v @@ -77,12 +77,12 @@ Section PRF_example. (chMap 'nat ('word n) ; 7). Definition enc (m : pt) (k : key) : - code fset0 [interface] ('word n) := + code fset0 [interface] ('fin N × 'word n) := {code r ← sample uniform N ;; let pad := f (word_of_ord r) k in let c := m ⊕ pad in - ret c + ret (r, c) }. Definition kgen : code (fset [:: key_location]) [interface] 'word n := @@ -137,31 +137,31 @@ Section PRF_example. Definition MOD_CPA_tt_pkg : package MOD_CPA_location [interface #val #[i0] : 'word → 'key ] - [interface #val #[i1] : 'word → 'word ] := + [interface #val #[i1] : 'word → ('fin N) × 'word ] := [package - #def #[i1] (m : 'word) : 'word + #def #[i1] (m : 'word) : ('fin N) × 'word { #import {sig #[i0] : 'word → 'key } as eval ;; r ← sample uniform N ;; pad ← eval (word_of_ord r) ;; let c := m ⊕ pad in - ret c + ret (r, c) } ]. Definition MOD_CPA_ff_pkg : package MOD_CPA_location [interface #val #[i0] : 'word → 'key] - [interface #val #[i1] : 'word → 'word]:= + [interface #val #[i1] : 'word → ('fin N) × 'word ]:= [package - #def #[i1] (m : 'word) : 'word + #def #[i1] (m : 'word) : ('fin N) × 'word { #import {sig #[i0] : 'word → 'key } as eval ;; r ← sample uniform N ;; m' ← sample uniform N ;; pad ← eval (word_of_ord r) ;; let c := (word_of_ord m' ⊕ pad) in - ret c + ret (r, c) } ]. @@ -170,9 +170,9 @@ Section PRF_example. Program Definition IND_CPA_pkg_tt : package IND_CPA_location [interface] - [interface #val #[i1] : 'word → 'word ] := + [interface #val #[i1] : 'word → ('fin N) × 'word ] := [package - #def #[i1] (m : 'word) : 'word + #def #[i1] (m : 'word) : ('fin N) × 'word { k_val ← kgen ;; enc m k_val @@ -196,9 +196,9 @@ Section PRF_example. Program Definition IND_CPA_pkg_ff : package IND_CPA_location [interface] - [interface #val #[i1] : 'word → 'word ] := + [interface #val #[i1] : 'word → ('fin N) × 'word ] := [package - #def #[i1] (m : 'word) : 'word + #def #[i1] (m : 'word) : ('fin N) × 'word { k_val ← kgen ;; m' ← sample uniform N ;; @@ -221,7 +221,7 @@ Section PRF_example. Defined. Program Definition IND_CPA : - loc_GamePair [interface #val #[i1] : 'word → 'word ] := + loc_GamePair [interface #val #[i1] : 'word → ('fin N) × 'word ] := λ b, if b then {locpackage IND_CPA_pkg_tt } else {locpackage IND_CPA_pkg_ff }. @@ -279,7 +279,7 @@ Section PRF_example. (** Security of PRF The bound is given by using the triangle inequality several times, - using the following chain: + using the following chain of computational indistinguishabilities: IND_CPA false ≈ MOD_CPA_ff_pkg ∘ EVAL true ≈ MOD_CPA_ff_pkg ∘ EVAL false ≈ MOD_CPA_tt_pkg ∘ EVAL false @@ -290,7 +290,7 @@ Section PRF_example. Theorem security_based_on_prf : ∀ LA A, ValidPackage LA - [interface #val #[i1] : 'word → 'word ] A_export A → + [interface #val #[i1] : 'word → ('fin N) × 'word ] A_export A → fdisjoint LA (IND_CPA false).(locs) → fdisjoint LA (IND_CPA true).(locs) → Advantage IND_CPA A <= @@ -346,17 +346,16 @@ Section JasminPRF. Notation key_location := (key_location U128). Definition Cenc (m : pt) (k : key) : - code (fset [:: state ; rkeys]) [interface] ('word n). + code (fset [:: state ; rkeys]) [interface] (('fin N) × 'word n). Proof. refine {code r ← sample uniform N ;; pad ← Caes (word_of_ord r) k ;; - ret (m ⊕ pad) + ret (r, (m ⊕ pad)) }. repeat constructor. all: auto_in_fset. - Unshelve. exact _. Defined. Opaque wrange. @@ -365,11 +364,11 @@ Section JasminPRF. Definition IND_CPA_pkg_Cenc : package (fset (key_location :: Cenc_locs)) [interface] - [interface #val #[i1] : 'word → 'word]. + [interface #val #[i1] : 'word → ('fin N) × 'word]. Proof. refine [package - #def #[i1] (m : 'word) : 'word + #def #[i1] (m : 'word) : ('fin N) × 'word { k_val ← kgen ;; Cenc m k_val @@ -394,16 +393,16 @@ Section JasminPRF. Definition IND_CPA_pkg_JENC (id0 : p_id) : package (fset (key_location :: (JENC_valid id0).π1)) [interface] - [interface #val #[i1] : 'word → 'word ]. + [interface #val #[i1] : 'word → ('fin N) × 'word ]. Proof. refine [package - #def #[i1] (m : 'word) : 'word + #def #[i1] (m : 'word) : ('fin N) × 'word { k_val ← kgen ;; r ← sample uniform N ;; res ← JENC id0 (word_of_ord r) k_val m ;; - ret (hdtc128 res) + ret (r, hdtc128 res) } ]. repeat constructor. @@ -460,12 +459,12 @@ Section JasminPRF. Qed. Definition IND_CPA_Cenc : - loc_GamePair [interface #val #[i1] : 'word → 'word ] := + loc_GamePair [interface #val #[i1] : 'word → ('fin N) × 'word ] := λ b, if b then {locpackage IND_CPA_pkg_Cenc } else (IND_CPA true). Definition IND_CPA_JENC id0 : - loc_GamePair [interface #val #[i1] : 'word → 'word ] := + loc_GamePair [interface #val #[i1] : 'word → ('fin N) × 'word ] := λ b, if b then {locpackage IND_CPA_pkg_JENC id0} else {locpackage IND_CPA_pkg_Cenc}. @@ -701,14 +700,14 @@ Section JasminPRF. Qed. Definition JIND_CPA id0 : - loc_GamePair [interface #val #[i1] : 'word → 'word ] := + loc_GamePair [interface #val #[i1] : 'word → ('fin N) × 'word ] := λ b, if b then {locpackage IND_CPA_pkg_JENC id0 } else (IND_CPA true). Theorem jasmin_security_based_on_prf id0 : ∀ LA A, ValidPackage LA - [interface #val #[i1] : 'word → 'word ] A_export A → + [interface #val #[i1] : 'word → ('fin N) × 'word ] A_export A → pdisjoint LA (λ l : Location, ∃ (s_id : p_id) (v : var), id0 ⪯ s_id ∧ l = translate_var s_id v) -> pdisjoint LA (λ l : Location, l \in fset Cenc_locs) -> fdisjoint LA (IND_CPA_Cenc false).(locs) → From fc11b36bf222b7348f997c472ecb58bc402274b0 Mon Sep 17 00:00:00 2001 From: "Benjamin S. Hvass" Date: Wed, 20 Sep 2023 07:32:16 +0200 Subject: [PATCH 373/383] prove concrete bounds and delete admitted things --- theories/Jasmin/examples/aes/aes_prf.v | 57 +- theories/Jasmin/examples/aes/prf.v | 697 ------------------------- theories/Jasmin/examples/aes/utils.v | 408 --------------- 3 files changed, 53 insertions(+), 1109 deletions(-) delete mode 100644 theories/Jasmin/examples/aes/prf.v delete mode 100644 theories/Jasmin/examples/aes/utils.v diff --git a/theories/Jasmin/examples/aes/aes_prf.v b/theories/Jasmin/examples/aes/aes_prf.v index 48918600..221f519f 100644 --- a/theories/Jasmin/examples/aes/aes_prf.v +++ b/theories/Jasmin/examples/aes/aes_prf.v @@ -435,7 +435,9 @@ Section JasminPRF. (* Notation KG_pkg := (KG_pkg U128). *) Notation IND_CPA_pkg_ff := (IND_CPA_pkg_ff U128 aes). + Notation IND_CPA_pkg_tt := (IND_CPA_pkg_tt U128 aes). Notation MOD_CPA_ff_pkg := (MOD_CPA_ff_pkg U128). + Notation MOD_CPA_tt_pkg := (MOD_CPA_tt_pkg U128). Notation IND_CPA := (IND_CPA U128 aes). Notation EVAL := (EVAL U128 aes). @@ -678,7 +680,6 @@ Section JasminPRF. - eapply r_ret. easy. - ssprove_sync. intros. ssprove_sync. - (* { intros h0 h1 H1 H2 H. rewrite !get_set_heap_neq. 1: eapply H1; eauto. 1-2: admit. } *) eapply r_ret. easy. } intros. simpl. (* TODO: find easier way to do next three lines *) @@ -703,7 +704,7 @@ Section JasminPRF. loc_GamePair [interface #val #[i1] : 'word → ('fin N) × 'word ] := λ b, if b then {locpackage IND_CPA_pkg_JENC id0 } else (IND_CPA true). - + Theorem jasmin_security_based_on_prf id0 : ∀ LA A, ValidPackage LA @@ -714,7 +715,7 @@ Section JasminPRF. fdisjoint LA (IND_CPA_Cenc true).(locs) → Advantage (JIND_CPA id0) A = 0%R. Proof. - intros LA A vA hd₀ hd₁ hd2 hd3. unfold prf_epsilon, statistical_gap. + intros LA A vA hd₀ hd₁ hd2 hd3. rewrite !Advantage_E. eapply AdvantageE_le_0. ssprove triangle (JIND_CPA id0 false) [:: @@ -735,6 +736,54 @@ Section JasminPRF. apply Order.POrderTheory.le_refl. Qed. - Print Assumptions jasmin_security_based_on_prf. + Notation prf_epsilon := (prf_epsilon U128 aes). + Notation statistical_gap := (statistical_gap U128 aes). + + Local Open Scope ring_scope. + + Program Definition JIND_CPA' id0 : + loc_GamePair [interface #val #[i1] : 'word → ('fin N) × 'word ] := + λ b, + if b then {locpackage IND_CPA_pkg_JENC id0 } else (IND_CPA false). + + Theorem jsecurity_based_on_prf (id0 : p_id) : + ∀ LA A, + ValidPackage LA + [interface #val #[i1] : 'word → ('fin N) × 'word ] A_export A → + pdisjoint LA (λ l : Location, ∃ (s_id : p_id) (v : var), id0 ⪯ s_id ∧ l = translate_var s_id v) -> + pdisjoint LA (λ l : Location, l \in fset Cenc_locs) -> + fdisjoint LA (IND_CPA_Cenc false).(locs) → + fdisjoint LA (IND_CPA_Cenc true).(locs) → + Advantage (JIND_CPA' id0) A <= + prf_epsilon (A ∘ MOD_CPA_ff_pkg) + + statistical_gap A + + prf_epsilon (A ∘ MOD_CPA_tt_pkg). + Proof. + intros LA A vA hd₀ hd₁ hd2 hd3. + rewrite !Advantage_E. + ssprove triangle (JIND_CPA' id0 true) [:: + IND_CPA_pkg_Cenc : raw_package ; + IND_CPA true : raw_package + ] (JIND_CPA' id0 false) A + as ineq. + rewrite Advantage_sym. + + eapply Order.POrderTheory.le_trans. 1: eapply ineq. + + erewrite IND_CPA_jazz_equiv_false. all: eauto. + rewrite IND_CPA_JENC_equiv_false. all: eauto. + + rewrite GRing.add0r. + rewrite GRing.add0r. + + unshelve epose proof security_based_on_prf n aes LA A vA hd2 _. + 1: { simpl. simpl in hd2. eauto. } + rewrite Advantage_E in H. + + rewrite Advantage_sym. + eapply H. + Qed. + + Print Assumptions jsecurity_based_on_prf. End JasminPRF. diff --git a/theories/Jasmin/examples/aes/prf.v b/theories/Jasmin/examples/aes/prf.v deleted file mode 100644 index 002531d8..00000000 --- a/theories/Jasmin/examples/aes/prf.v +++ /dev/null @@ -1,697 +0,0 @@ -(** PRF Example - - Inspired by "State Separation for Code-Based Game-Playing Proofs" - by Brzuska et al. - - Appendix A. - - "Given a pseudorandom function (PRF) we construct a symmetric encryption - scheme that is indistinguishable under chosen plaintext attacks (IND-CPA)." - -*) -From JasminSSProve Require Import jasmin_translate. - -From Relational Require Import OrderEnrichedCategory GenericRulesSimple. - -Set Warnings "-notation-overridden,-ambiguous-paths". -From mathcomp Require Import all_ssreflect all_algebra reals distr realsum - ssrnat ssreflect ssrfun ssrbool ssrnum eqtype choice seq word word.ssrZ. -Set Warnings "notation-overridden,ambiguous-paths". - -From Mon Require Import SPropBase. -From Crypt Require Import Axioms ChoiceAsOrd SubDistr Couplings - UniformDistrLemmas FreeProbProg Theta_dens RulesStateProb - pkg_core_definition choice_type pkg_composition pkg_rhl Package Prelude. - -From Coq Require Import Utf8. -From extructures Require Import ord fset fmap. - -Import SPropNotations. - -Import PackageNotation. - -From Equations Require Import Equations. -Require Equations.Prop.DepElim. - -Set Equations With UIP. - -Set Bullet Behavior "Strict Subproofs". -Set Default Goal Selector "!". -Set Primitive Projections. - -Import Num.Def. -Import Num.Theory. -Import Order.POrderTheory. - - -From Jasmin Require Import word. - -Section PRF_example. - - Context (n : wsize). - - Notation key := 'word n. - Notation pt := 'word n. - Notation ct := 'word n. - - Notation " 'word " := ('word n) (in custom pack_type at level 2). - Notation " 'key " := ('word n) (in custom pack_type at level 2). - - Context (f : key -> pt -> ct). - - Notation N := ((expn 2 n).-1.+1). - - #[export] Instance : Positive N. - Proof. red; by rewrite prednK_modulus expn_gt0. Qed. - - #[export] Instance word_pos (i : wsize.wsize) : Positive i. - Proof. by case i. Qed. - - Notation "m ⊕ k" := (wxor m k) (at level 70). - - #[local] Open Scope package_scope. - - Definition key_location : Location := ('option key ; 0). - Definition plain_location : Location := ( pt ; 1). - Definition cipher_location : Location := ( ct ; 2). - Definition i0 : nat := 3. - Definition i1 : nat := 4. - Definition i2 : nat := 5. - Definition salt_location : Location := ('nat ; 6). - Definition table_location : Location := - (chMap 'nat ('word n) ; 7). - - Definition rel_loc : {fset Location} := - fset [:: key_location ; table_location ]. - - Definition enc (m : pt) (k : key) : - code fset0 [interface] ('word n) := - {code - r ← sample uniform N ;; - let pad := f (word_of_ord r) k in - let c := m ⊕ pad in - ret c - }. - - Definition kgen : code (fset [:: key_location]) [interface] 'word n := - {code - k ← get key_location ;; - match k with - | None => - k_val ← sample uniform N ;; - #put key_location := Some (word_of_ord k_val) ;; - ret (word_of_ord k_val) - | Some k_val => - ret k_val - end - }. - - Definition dec (c : 'word n) (k : 'word n) : - code fset0 [interface] ('word n) := - enc k c. - - Definition EVAL_location_tt := (fset [:: key_location]). - Definition EVAL_location_ff := (fset [:: table_location]). - - Definition EVAL_pkg_tt : - package EVAL_location_tt [interface] - [interface #val #[i0] : 'word → 'key ] := - [package - #def #[i0] (r : 'word) : 'key - { - k_val ← kgen ;; - ret (f r k_val) - } - ]. - - Definition EVAL_pkg_ff : - package EVAL_location_ff [interface] - [interface #val #[i0] : 'word → 'key ] := - [package - #def #[i0] (r : 'word) : 'key - { - T ← get table_location ;; - match getm T (ord_of_word r) with - | None => - T_key ← sample uniform N ;; - #put table_location := (setm T (ord_of_word r) (word_of_ord T_key)) ;; - ret (word_of_ord T_key) - | Some T_key => ret T_key - end - } - ]. - - Definition EVAL : loc_GamePair [interface #val #[i0] : 'word → 'key ] := - λ b, if b then {locpackage EVAL_pkg_tt } else {locpackage EVAL_pkg_ff }. - - Definition MOD_CPA_location : {fset Location} := fset0. - - Definition MOD_CPA_tt_pkg : - package MOD_CPA_location - [interface #val #[i0] : 'word → 'key ] - [interface #val #[i1] : 'word → 'word ] := - [package - #def #[i1] (m : 'word) : 'word - { - #import {sig #[i0] : 'word → 'key } as eval ;; - r ← sample uniform N ;; - pad ← eval (word_of_ord r) ;; - let c := m ⊕ pad in - ret c - } - ]. - - Definition MOD_CPA_ff_pkg : - package MOD_CPA_location - [interface #val #[i0] : 'word → 'key] - [interface #val #[i1] : 'word → 'word]:= - [package - #def #[i1] (m : 'word) : 'word - { - #import {sig #[i0] : 'word → 'key } as eval ;; - r ← sample uniform N ;; - m' ← sample uniform N ;; - pad ← eval (word_of_ord r) ;; - let c := (word_of_ord m' ⊕ pad) in - ret c - } - ]. - - Definition IND_CPA_location : {fset Location} := fset [:: key_location]. - - Program Definition IND_CPA_pkg_tt : - package IND_CPA_location - [interface] - [interface #val #[i1] : 'word → 'word ] := - [package - #def #[i1] (m : 'word) : 'word - { - k_val ← kgen ;; - enc m k_val - } - ]. - (* why is this not inferred? *) - Next Obligation. - repeat constructor. red. - intros []. - rewrite in_fset in_cons. move=>/orP []. 2: easy. move=>/eqP H. noconf H. simpl. - eexists. - split. - 1: reflexivity. - intros. repeat constructor. - 1: auto_in_fset. destruct v. - 1: intros; repeat constructor. - 1: intros; repeat constructor. - auto_in_fset. - Defined. - - Program Definition IND_CPA_pkg_ff : - package IND_CPA_location - [interface] - [interface #val #[i1] : 'word → 'word ] := - [package - #def #[i1] (m : 'word) : 'word - { - k_val ← kgen ;; - m' ← sample uniform N ;; - enc (word_of_ord m') k_val - } - ]. - (* TODO: infer this *) - Next Obligation. - repeat constructor. red. - intros []. - rewrite in_fset in_cons. move=>/orP []. 2: easy. move=>/eqP H. noconf H. simpl. - eexists. - split. - 1: reflexivity. - intros. repeat constructor. - 1: auto_in_fset. destruct v. - 1: intros; repeat constructor. - 1: intros; repeat constructor. - auto_in_fset. - Defined. - - Program Definition IND_CPA : - loc_GamePair [interface #val #[i1] : 'word → 'word ] := - λ b, - if b then {locpackage IND_CPA_pkg_tt } else {locpackage IND_CPA_pkg_ff }. - - Local Open Scope ring_scope. - - Definition prf_epsilon A := Advantage EVAL A. - - Definition statistical_gap := - AdvantageE (MOD_CPA_ff_pkg ∘ EVAL false) (MOD_CPA_tt_pkg ∘ EVAL false). - - Lemma IND_CPA_equiv_false : - IND_CPA false ≈₀ MOD_CPA_ff_pkg ∘ (EVAL true). - Proof. - (* We go to the relation logic using equality as invariant. *) - eapply eq_rel_perf_ind_eq. - simplify_eq_rel m. - simplify_linking. - (* We now conduct the proof in relational logic. *) - ssprove_swap_rhs 1%N. - ssprove_swap_rhs 0%N. - ssprove_sync_eq. cbn -[expn]. intros [k|]. - - cbn -[expn]. ssprove_swap_rhs 0%N. - eapply rpost_weaken_rule. - 1: eapply rreflexivity_rule. - cbn. intros [? ?] [? ?] e. inversion e. intuition auto. - - cbn -[expn]. - ssprove_swap_rhs 0%N. - ssprove_swap_rhs 1%N. - ssprove_swap_rhs 0%N. - ssprove_swap_rhs 2%N. - ssprove_swap_rhs 1%N. - eapply rpost_weaken_rule. 1: eapply rreflexivity_rule. - cbn. intros [? ?] [? ?] e. inversion e. intuition auto. - Qed. - - Lemma IND_CPA_equiv_true : - MOD_CPA_tt_pkg ∘ (EVAL true) ≈₀ IND_CPA true. - Proof. - (* We go to the relation logic using equality as invariant. *) - eapply eq_rel_perf_ind_eq. - simplify_eq_rel m. - simplify_linking. - (* We now conduct the proof in relational logic. *) - ssprove_swap_lhs 0%N. - ssprove_sync_eq. cbn -[expn]. intros [k|]. - - cbn -[expn]. eapply rpost_weaken_rule. 1: eapply rreflexivity_rule. - cbn. intros [? ?] [? ?] e. inversion e. intuition auto. - - cbn -[expn]. - ssprove_swap_rhs 1%N. - ssprove_swap_rhs 0%N. - eapply rpost_weaken_rule. 1: eapply rreflexivity_rule. - cbn. intros [? ?] [? ?] e. inversion e. intuition auto. - Qed. - - (** Security of PRF - - The bound is given by using the triangle inequality several times, - using the following chain: - IND_CPA false ≈ MOD_CPA_ff_pkg ∘ EVAL true - ≈ MOD_CPA_ff_pkg ∘ EVAL false - ≈ MOD_CPA_tt_pkg ∘ EVAL false - ≈ MOD_CPA_tt_pkg ∘ EVAL true - ≈ IND_CPA true - - *) - Theorem security_based_on_prf : - ∀ LA A, - ValidPackage LA - [interface #val #[i1] : 'word → 'word ] A_export A → - fdisjoint LA (IND_CPA false).(locs) → - fdisjoint LA (IND_CPA true).(locs) → - Advantage IND_CPA A <= - prf_epsilon (A ∘ MOD_CPA_ff_pkg) + - statistical_gap A + - prf_epsilon (A ∘ MOD_CPA_tt_pkg). - Proof. - intros LA A vA hd₀ hd₁. unfold prf_epsilon, statistical_gap. - rewrite !Advantage_E. - ssprove triangle (IND_CPA false) [:: - MOD_CPA_ff_pkg ∘ EVAL true ; - MOD_CPA_ff_pkg ∘ EVAL false ; - MOD_CPA_tt_pkg ∘ EVAL false ; - MOD_CPA_tt_pkg ∘ EVAL true - ] (IND_CPA true) A - as ineq. - eapply le_trans. 1: exact ineq. - clear ineq. - erewrite IND_CPA_equiv_false. all: eauto. - 2:{ simpl. unfold MOD_CPA_location. rewrite fset0U. auto. } - erewrite IND_CPA_equiv_true. all: eauto. - 2:{ simpl. unfold MOD_CPA_location. rewrite fset0U. auto. } - rewrite GRing.add0r GRing.addr0. - rewrite !Advantage_link. rewrite Advantage_sym. auto. - Qed. -End PRF_example. - -From JasminSSProve Require Import aes.aes aes_jazz jasmin_utils aes_valid. -From Jasmin Require Import expr sem. - -Import JasminNotation JasminCodeNotation. - -(* From Jasmin Require Import expr. *) -Require Import String. -Local Open Scope string. - -Section JasminPRF. - - Ltac neq_loc_auto ::= solve [ eapply injective_translate_var3; auto | eapply injective_translate_var2; auto ]. - - Notation n := U128. - - Definition key := 'word n. - Definition pt := 'word n. - Definition ct := 'word n. - - Notation " 'word " := ('word n) (in custom pack_type at level 2). - Notation " 'key " := ('word n) (in custom pack_type at level 2). - Notation N := ((expn 2 n).-1.+1). - - Notation enc := (enc U128 aes). - Notation kgen := (kgen U128). - Notation key_location := (key_location U128). - - Definition ltup2 (l : tchlist) := - match l with - | [::] => (word0, word0) - | a1 :: l1 => - match l with - | [::] => (word0, word0) - | a2 :: l2 => (coerce_to_choice_type ('word n) a1.π2, coerce_to_choice_type ('word n) a2.π2) - end - end. - - Definition Cenc (m : pt) (k : key) : - code (fset [:: state ; rkeys]) [interface] ('word n). - Proof. - refine - {code - r ← sample uniform N ;; - pad ← Caes (word_of_ord r) k ;; - ret (m ⊕ pad) - }. - repeat constructor. - all: auto_in_fset. - Unshelve. exact _. - Defined. - - Definition Cenc_locs := [:: state ; rkeys]. - Opaque wrange. - Opaque expn. - - Definition IND_CPA_pkg_Cenc : - package (fset (key_location :: Cenc_locs)) - [interface] - [interface #val #[i1] : 'word → 'word]. - Proof. - refine - [package - #def #[i1] (m : 'word) : 'word - { - k_val ← kgen ;; - Cenc m k_val - } - ]. - (* infer this *) - repeat constructor. red. - intros []. - rewrite in_fset in_cons. move=>/orP []. 2: easy. move=>/eqP H. noconf H. simpl. - eexists. - split. - 1: reflexivity. - intros. repeat constructor. - all: auto_in_fset. - intros. destruct v. - 1: repeat constructor; auto_in_fset. - 1: repeat constructor; auto_in_fset. - Defined. - - Definition IND_CPA_pkg_JENC (id0 : p_id) : - package (fset (key_location :: (JENC_valid id0).π1)) - [interface] - [interface #val #[i1] : 'word → 'word ]. - Proof. - refine - [package - #def #[i1] (m : 'word) : 'word - { - k_val ← kgen ;; - r ← sample uniform N ;; - res ← JENC id0 (word_of_ord r) k_val m ;; - ret (hdtc128 res) - } - ]. - repeat constructor. - intros []. - rewrite in_fset in_cons => /orP []; [|easy]; move=> /eqP H; noconf H. - cbv zeta match. - eexists. - split. - 1: reflexivity. - intros x. - constructor. - 1: auto_in_fset. - intros. destruct v. - - constructor. intros. - eapply valid_bind. - + red. eapply valid_code_cons. - 1: eapply (JENC_valid id0).π2. - + constructor. - - constructor. - intros. - constructor. - 1: auto_in_fset. - constructor. intros. - eapply valid_bind. - + red. eapply valid_code_cons. - 1: eapply (JENC_valid id0).π2. - + constructor. - Unshelve. all: exact _. - Defined. - - (* Notation KG_pkg := (KG_pkg U128). *) - Notation IND_CPA_pkg_ff := (IND_CPA_pkg_ff U128 aes). - Notation MOD_CPA_ff_pkg := (MOD_CPA_ff_pkg U128). - Notation IND_CPA := (IND_CPA U128 aes). - Notation EVAL := (EVAL U128 aes). - - Lemma fsubset_ext2 : ∀ [T : ordType] (s1 s2 : {fset T}), fsubset s1 s2 -> (forall x, x \in s1 -> x \in s2). - Proof. - intros. - rewrite -fsub1set. - eapply fsubset_trans. 2: eassumption. - rewrite fsub1set. assumption. - Qed. - - Lemma fsubset_cons : ∀ [T : ordType] a (s1 s2 : {fset T}), fsubset s1 s2 -> fsubset s1 (a |: s2). - Proof. - intros. - apply fsubset_ext. - intros. rewrite in_fset in_cons. - apply/orP. right. - eapply fsubset_ext2. - 1: eassumption. - assumption. - Qed. - - Definition IND_CPA_Cenc : - loc_GamePair [interface #val #[i1] : 'word → 'word ] := - λ b, - if b then {locpackage IND_CPA_pkg_Cenc } else (IND_CPA true). - - Definition IND_CPA_JENC id0 : - loc_GamePair [interface #val #[i1] : 'word → 'word ] := - λ b, - if b then {locpackage IND_CPA_pkg_JENC id0} else {locpackage IND_CPA_pkg_Cenc}. - - (* TODO: move *) - Lemma JXOR_E pre id0 x y : - (pdisj pre id0 fset0) -> - ⊢ ⦃ fun '(h0, h1) => pre (h0, h1) ⦄ - JXOR id0 x y - ≈ - ret (chCanonical chUnit) - ⦃ fun '(v0, h0) '(v1, h1) => pre (h0, h1) /\ (exists o, (v0 = cons ('word U128 ; o ) nil ) /\ (o = x ⊕ y)) ⦄. - Proof. - unfold JXOR, get_translated_static_fun, translate_prog_static, translate_funs_static, translate_call_body. - intros disj. - simpl. simpl_fun. - repeat setjvars. - ssprove_code_simpl. - repeat clear_get. - repeat eapply r_put_lhs. - eapply r_ret. - rewrite !zero_extend_u. - intros. destruct_pre; split_post. - 1: pdisj_apply disj. - eexists; split; [reflexivity|]. reflexivity. - Qed. - - (* TODO: move *) - Arguments pheap_ignore : simpl never. - - Lemma IND_CPA_JENC_equiv_false id0 : - padv_equiv (fun l => exists s_id v, id0 ⪯ s_id /\ l = translate_var s_id v) (fun l => l = state \/ l = rkeys) (IND_CPA_JENC id0 true) (IND_CPA_JENC id0 false) (λ _ : raw_package, 0%R). - Proof. - eapply eq_rel_perf_ind'. - (* invariant *) - { eapply pInvariant_pheap_ignore with - (P := fun l => forall s_id v, id0 ⪯ s_id -> l != translate_var s_id v). - { intros. apply/eqP. intros contra. - destruct H. apply H. - exists s_id, v. split; auto. } } - unfold eq_up_to_inv, get_op_default, lookup_op, IND_CPA_JENC, IND_CPA_pkg_JENC. - Opaque Caes. - Opaque translate_call. - Opaque wrange. - Opaque expn. - simpl. - simplify_eq_rel m. - simplify_linking. - rewrite !cast_fun_K. - ssprove_sync. - { intros h0 h1 hpre. apply hpre. admit. } - intros. - eapply r_bind with (mid := fun '(a₀, s₀) '(a₁, s₁) => pheap_ignore (λ l : ∑ _ : choice_type, nat, ∀ (s_id : p_id) (v : var), id0 ⪯ s_id → l != translate_var s_id v) (s₀, s₁) /\ a₀ = a₁). - { destruct a. - - eapply r_ret. easy. - - ssprove_sync. intros. - ssprove_sync. - { intros h0 h1 Hh l H. - destruct (l == key_location) eqn:E. - - move: E => /eqP heq. subst. rewrite !get_set_heap_eq. reflexivity. - - move: E => /negP Hneq. rewrite !get_set_heap_neq; auto. 1-2: apply /negP; auto. } - eapply r_ret. easy. } - intros. - (* TODO: find easier way to do next three lines *) - eapply rpre_weak_hypothesis_rule'. - intros; destruct_pre. - eapply rpre_weaken_rule with (pre:= fun '(s₀, s₁) => pheap_ignore (λ l : ∑ _ : choice_type, nat, ∀ (s_id : p_id) (v : var), id0 ⪯ s_id → l != translate_var s_id v) (s₀, s₁)); try easy. - ssprove_code_simpl. - simpl. - ssprove_sync. intros. - rewrite !zero_extend_u. - repeat clear_get. - do 3 eapply r_put_lhs. - eapply r_bind. - - eapply aes_E; split. - + intros. - destruct_pre. - do 2 eexists. - 1: do 2 eexists. - 1: do 2 eexists. - 1: instantiate (1 := set_heap H7 (translate_var s_id' v) a1). - all: try reflexivity. - { intros l lnin. rewrite get_set_heap_neq. 1: eapply H8; auto. eapply lnin. admit. } - { repeat rewrite [set_heap _ _ a1]set_heap_commut; auto. 1-3: admit. } - + intros. - destruct_pre. - do 2 eexists. - 1: do 2 eexists. - 1: do 2 eexists. - 1: instantiate (1 := H6). - all: try reflexivity. - intros l2 lnin. - rewrite get_set_heap_neq. - 1: eapply H7. 1: assumption. - admit. - - simpl. intros. - eapply rpre_weak_hypothesis_rule'; intros. - destruct_pre. - simpl. - clear_get. - eapply r_put_lhs with (pre := fun _ => _). - eapply r_get_remember_lhs. intros. - eapply r_bind with (m₁ := ret (chCanonical chUnit)) (f₁ := fun _ => _). - 1: eapply JXOR_E; split. - + intros. - destruct_pre. - 1: do 1 eexists. - 1: do 2 eexists. - 1: do 7 eexists. - 1: instantiate (1:= (set_heap H14 (translate_var s_id' v) a1)). - all: try reflexivity. - { intros l hl. rewrite get_set_heap_neq. 1: eapply H15. 1: assumption. apply hl. admit. } - { repeat rewrite [set_heap _ _ a1]set_heap_commut; auto. 1-4: admit. } - { sheap. simpl. rewrite get_set_heap_neq. 1: sheap. 1: reflexivity. admit. } - + intros. easy. - + intros. - eapply rpre_weak_hypothesis_rule'; intros. - destruct_pre; simpl. - clear_get. - eapply r_put_lhs with (pre := fun _ => _). - eapply r_ret. - rewrite !coerce_to_choice_type_K. - rewrite !zero_extend_u. - intros. - destruct_pre; simpl; split_post. - { sheap. by rewrite wxorC. } - { intros l s_id. - rewrite !get_set_heap_neq. - 1: eapply H19; auto. - 1-5: apply s_id; reflexivity. - Admitted. - - Lemma IND_CPA_jazz_equiv_false : - (IND_CPA_Cenc) true ≈₀ (IND_CPA_Cenc) false. - Proof. - eapply eq_rel_perf_ind_ignore with (L := fset Cenc_locs). - { eapply fsubsetU. apply/orP; left. simpl. - rewrite [fset (key_location :: _)]fset_cons. - eapply fsubset_cons. - eapply fsubsetxx. } - unfold eq_up_to_inv. - Opaque Caes. - Opaque wrange. - Opaque expn. - simplify_eq_rel m. - ssprove_sync. intros. - eapply r_bind with (mid := fun '(a0, s0) '(a1, s1) => a0 = a1 /\ heap_ignore (fset Cenc_locs) (s0, s1)). - { destruct a. - - eapply r_ret. easy. - - ssprove_sync. intros. - ssprove_sync. - (* { intros h0 h1 H1 H2 H. rewrite !get_set_heap_neq. 1: eapply H1; eauto. 1-2: admit. } *) - eapply r_ret. easy. } - intros. simpl. - (* TODO: find easier way to do next three lines *) - eapply rpre_weak_hypothesis_rule'. - intros; destruct_pre. - eapply rpre_weaken_rule with (pre:= fun '(s₀, s₁) => heap_ignore (fset Cenc_locs) (s₀, s₁)); try easy. - ssprove_sync. intros. - eapply r_bind with (m₁ := ret (chCanonical chUnit)) (f₁ := fun _ => _). - - 1: eapply aes_h. - intros h1 h2 l a2 lin h. - intros l2 lnin. - unfold Cenc_locs in *. - rewrite get_set_heap_neq. - 1: apply h; auto. - admit. - - intros. eapply r_ret. - intros. destruct_pre; split_post; auto. - Admitted. - - Definition JIND_CPA id0 : - loc_GamePair [interface #val #[i1] : 'word → 'word ] := - λ b, - if b then {locpackage IND_CPA_pkg_JENC id0 } else (IND_CPA true). - - Theorem jasmin_security_based_on_prf id0 : - ∀ LA A, - ValidPackage LA - [interface #val #[i1] : 'word → 'word ] A_export A → - pdisjoint LA (λ l : Location, ∃ (s_id : p_id) (v : var), id0 ⪯ s_id ∧ l = translate_var s_id v) -> - pdisjoint LA (λ l : Location, l = state ∨ l = rkeys) -> - (* fdisjoint LA (JIND_CPA id0 false).(locs) → *) - (* fdisjoint LA (JIND_CPA id0 true).(locs) → *) - Advantage (JIND_CPA id0) A = 0%R. - Proof. - intros LA A vA hd₀ hd₁. unfold prf_epsilon, statistical_gap. - rewrite !Advantage_E. - eapply AdvantageE_le_0. - ssprove triangle (JIND_CPA id0 false) [:: - IND_CPA_pkg_Cenc : raw_package - ] (JIND_CPA id0 true) A - as ineq. - eapply Order.POrderTheory.le_trans. - 1: exact ineq. - clear ineq. - rewrite Advantage_sym. - erewrite IND_CPA_jazz_equiv_false. all: eauto. - 2-3: admit. - rewrite Advantage_sym. - pose proof IND_CPA_JENC_equiv_false id0. - unfold padv_equiv in H. - specialize (H LA A vA hd₀ hd₁). - rewrite H. - rewrite GRing.addr0. - apply Order.POrderTheory.le_refl. - Admitted. - -End JasminPRF. diff --git a/theories/Jasmin/examples/aes/utils.v b/theories/Jasmin/examples/aes/utils.v deleted file mode 100644 index e49ee6a9..00000000 --- a/theories/Jasmin/examples/aes/utils.v +++ /dev/null @@ -1,408 +0,0 @@ -Set Warnings "-notation-overridden,-ambiguous-paths". -From mathcomp Require Import all_ssreflect all_algebra zify. -From mathcomp.word Require Import word ssrZ. -Set Warnings "notation-overridden,ambiguous-paths". - -From Coq Require Import Utf8 ZArith micromega.Lia List. - -From Jasmin Require Import expr xseq. -From JasminSSProve Require Import jasmin_translate. - -From Relational Require Import OrderEnrichedCategory. -From Crypt Require Import Prelude Package ChoiceAsOrd. - -From extructures Require Import ord fset fmap. - -Import ListNotations. -Import JasminNotation. -Import PackageNotation. - -Set Bullet Behavior "Strict Subproofs". -Set Default Goal Selector "!". - -(** For loops *) - -Local Open Scope Z. - -Fixpoint for_list (c : Z → raw_code 'unit) (vs : seq Z) : raw_code 'unit := - match vs with - | [::] => ret tt - | v :: vs => c v ;; for_list c vs - end. - -Definition for_loop (c : Z -> raw_code 'unit) lo hi := for_list c (wrange UpTo lo hi). - -Lemma iota_aux {A} k c n (f : nat -> A) g : - (forall a, a \in (iota k n) -> f a = g (a + c)%nat) -> - [seq f i | i <- iota k n] = [seq g i | i <- iota (k + c) n]. -Proof. - revert k c. - induction n. - - reflexivity. - - intros k c ex. - simpl. rewrite -addSn -IHn. - + f_equal. - apply ex. - rewrite in_cons eq_refl => //=. - + intros a ain. apply ex. - simpl. rewrite in_cons. - apply/orP. right. assumption. -Qed. - -Lemma u_for_loop_rule I c lo hi : - lo <= hi -> - (∀ i, (lo <= i < hi)%Z -> - ⊢ ⦃ λ '(s₀, s₁), I i s₀ s₁ ⦄ - c i ≈ ret tt - ⦃ λ '(_, s₀) '(_, s₁), I (Z.succ i) s₀ s₁ ⦄) → - ⊢ ⦃ λ '(s₀, s₁), I lo s₀ s₁ ⦄ - for_loop c lo hi ≈ ret tt - ⦃ λ '(_,s₀) '(_,s₁), I hi s₀ s₁ ⦄. -Proof. - intros hle h. - remember (Z.to_nat (hi - lo)). - revert hle h Heqn. revert lo hi. - induction n as [| n ih]; intros. - - assert (hi = lo) by lia. - unfold for_loop=>/=. - rewrite -Heqn. - subst. - apply r_ret. easy. - - unfold for_loop=>/=. - rewrite -Heqn. simpl. rewrite Z.add_0_r. - eapply r_bind with (m₁ := ret tt) (f₁ := fun _ => _). - + eapply h. lia. - + intros a1 a2. - destruct a1, a2. - replace [seq lo + Z.of_nat i | i <- iota 1 n] with [seq (Z.succ lo) + Z.of_nat i | i <- iota 0 n]. - 2: { replace (iota 1 n) with (iota (0 + 1) n) by f_equal. apply iota_aux. intros. lia. } - replace n with (Z.to_nat (hi - Z.succ lo)) by lia. - eapply ih. - all: try lia. - intros i hi2. apply h. lia. -Qed. - -Lemma u_for_loop_rule_weaken (I : Z -> heap -> heap -> Prop) c lo hi (pre : precond) : - lo <= hi -> - (forall h1 h2, pre (h1, h2) -> I lo h1 h2) -> - (∀ i, (lo <= i < hi)%Z -> - ⊢ ⦃ λ '(s₀, s₁), I i s₀ s₁ ⦄ - c i ≈ ret tt - ⦃ λ '(_, s₀) '(_, s₁), I (Z.succ i) s₀ s₁ ⦄) → - ⊢ ⦃ pre ⦄ - for_loop c lo hi ≈ ret tt - ⦃ λ '(_,s₀) '(_,s₁), I hi s₀ s₁ ⦄. -Proof. - intros. - eapply rpre_weaken_rule. - 1: eapply u_for_loop_rule; eauto. - assumption. -Qed. - -Lemma for_loop_rule I c₀ c₁ lo hi : - lo <= hi -> - (∀ i, (lo <= i < hi)%Z -> ⊢ ⦃ λ '(s₀, s₁), I i (s₀, s₁) ⦄ c₀ i ≈ c₁ i ⦃ λ '(_, s₀) '(_, s₁), I (Z.succ i) (s₀,s₁) ⦄) → - ⊢ ⦃ λ '(s₀, s₁), I lo (s₀, s₁) ⦄ - for_loop c₀ lo hi ≈ for_loop c₁ lo hi - ⦃ λ '(_,s₀) '(_,s₁), I hi (s₀,s₁) ⦄. -Proof. - intros hle h. - remember (Z.to_nat (hi - lo)). - revert hle h Heqn. revert lo hi. - induction n as [| n ih]; intros. - - assert (hi = lo) by lia. - unfold for_loop=>/=. - rewrite -Heqn. - subst. - apply r_ret. easy. - - unfold for_loop=>/=. - rewrite -Heqn. simpl. rewrite Z.add_0_r. - eapply r_bind. - + eapply h. lia. - + intros a1 a2. - destruct a1, a2. - replace [seq lo + Z.of_nat i | i <- iota 1 n] with [seq (Z.succ lo) + Z.of_nat i | i <- iota 0 n]. - 2: { replace (iota 1 n) with (iota (0 + 1) n) by f_equal. apply iota_aux. intros. lia. } - replace n with (Z.to_nat (hi - Z.succ lo)) by lia. - eapply ih. - all: try lia. - intros i hi2. apply h. lia. -Qed. - -Lemma translate_for_rule I lo hi (v : var_i) m_id s_id (body1 : p_id -> p_id * raw_code 'unit) body2 : - (* it is annoying that this is a proof obligation, since its true for all translated programs, but I don't know how to prove the theorem without it *) - (forall s_id', s_id' ⪯ (body1 s_id').1) -> - lo <= hi -> - (forall i s_id', (s_id ⪯ s_id') -> (lo <= i < hi) -> - ⊢ ⦃ λ '(s₀, s₁), set_lhs (translate_var m_id v) (truncate_el (vtype v) (i : chInt)) (I i) (s₀, s₁) ⦄ - let (_, body1') := body1 s_id' in - body1' ≈ body2 i - ⦃ λ '(_, s₀) '(_, s₁), I (Z.succ i) (s₀,s₁) ⦄) → - ⊢ ⦃ λ '(s₀,s₁), I lo (s₀, s₁)⦄ - translate_for v (wrange UpTo lo hi) m_id body1 s_id - ≈ for_loop body2 lo hi - ⦃ λ '(_,s₀) '(_,s₁), I hi (s₀,s₁) ⦄. -Proof. - intros Hbody1 Hle ih. - remember (Z.to_nat (hi - lo)). - revert Heqn Hle ih. revert n lo hi s_id. - induction n as [|n ih2]; intros. - - assert (hi = lo). { zify. lia. } - subst. - unfold translate_for, for_loop. simpl. - rewrite -Heqn. - simpl. - apply r_ret. - easy. - - unfold translate_for, for_loop. - unfold wrange. - rewrite -Heqn. - simpl. - specialize (ih lo s_id) as ih''. - specialize (Hbody1 s_id). - destruct (body1 s_id). - eapply r_put_lhs. - eapply r_bind. - + eapply r_transL. - 2: rewrite Z.add_0_r; eapply ih''; [ reflexivity | lia ]. - eapply rreflexivity_rule. - + intros a0 a1. - replace (iota 1 n) with (iota (0 + 1) n) by f_equal. - rewrite <- iota_aux with (f := fun i => Z.succ lo + Z.of_nat i) by lia. - replace n with (Z.to_nat (hi - Z.succ lo)) by lia. - specialize (ih2 (Z.succ lo) hi p ltac:(lia) ltac:(lia)). - eapply ih2. - intros i s_id' Hs_id' ile. - specialize (ih i s_id'). - destruct (body1 s_id'). apply ih. - 1: etransitivity; eauto. - lia. -Qed. - -Lemma translate_for_rule_weaken (pre : precond) (I : Z -> heap * heap -> Prop) lo hi (v : var_i) m_id s_id (body1 : p_id -> p_id * raw_code 'unit) body2 : - (forall h0 h1, pre (h0, h1) -> I lo (h0, h1)) -> - (* it is annoying that this is a proof obligation, since its true for all translated programs, but I don't know how to prove the theorem without it *) - (forall s_id', s_id' ⪯ (body1 s_id').1) -> - lo <= hi -> - (forall i s_id', (s_id ⪯ s_id') -> (lo <= i < hi) -> - ⊢ ⦃ λ '(s₀, s₁), set_lhs (translate_var m_id v) (truncate_el (vtype v) (i : chInt)) (I i) (s₀, s₁) ⦄ - let (_, body1') := body1 s_id' in - body1' - ≈ body2 i ⦃ λ '(_, s₀) '(_, s₁), I (Z.succ i) (s₀,s₁) ⦄) → - ⊢ ⦃ pre ⦄ - translate_for v (wrange UpTo lo hi) m_id body1 s_id - ≈ for_loop body2 lo hi - ⦃ λ '(_,s₀) '(_,s₁), I hi (s₀,s₁) ⦄. -Proof. - intros. - eapply rpre_weaken_rule. - 1: eapply translate_for_rule. - all: easy. -Qed. - -(** Arrays *) - -Definition getmd {T S} m d i := match @getm T S m i with Some a => a | _ => d end. - -Definition to_oarr ws len (a : 'array) : (chMap (chFin len) ('word ws)) := - mkfmapf (fun (i : 'I_len) => chArray_get ws a (Z.of_nat i) (wsize_size ws)) (ord_enum len). -Definition to_arr ws len (a : 'array) := - mkfmapf (fun i => chArray_get ws a i (wsize_size ws)) (ziota 0 len). - -Lemma wsize_size_aux (ws : wsize.wsize) : - (ws %/ U8 + ws %% U8)%nat = Z.to_nat (wsize_size ws). -Proof. destruct ws; reflexivity. Qed. - -Lemma encode_aux {ws} (w : word.word ws) : - LE.encode w = [seq word.subword ((Z.to_nat i0) * U8) U8 w | i0 <- ziota 0 (wsize_size ws)]. -Proof. - unfold LE.encode. - unfold split_vec. - unfold ziota. - rewrite -wsize_size_aux. - simpl. - (* rewrite Z2Nat.inj_add. *) - (* rewrite !Nat2Z.id. *) - rewrite -map_comp. - unfold comp. - apply map_ext. - intros a Ha. - rewrite Nat2Z.id. - reflexivity. - (* apply Zle_0_nat. *) - (* apply Zle_0_nat. *) -Qed. - -Lemma wsize_size_bits ws: - wsize_size ws < wsize_bits ws. -Proof. - unfold wsize_size, wsize_bits. - destruct ws; simpl; lia. -Qed. - -Lemma chArray_get_set_eq ws a i w : - chArray_get ws (chArray_set a AAscale i w) i (wsize_size ws) = w. -Proof. - unfold chArray_get. - unfold chArray_set. - rewrite <- LE.decodeK. - f_equal. - rewrite encode_aux. - apply map_ext. - intros j Hj. - unfold chArray_get8. - rewrite chArray_write_get. - assert ((0 <=? i * wsize_size ws + j - i * mk_scale AAscale ws) && (i * wsize_size ws + j - i * mk_scale AAscale ws /InP. rewrite in_ziota=>/andP [] H1 h2. lia. } - rewrite H. - unfold LE.wread8. - unfold LE.encode. - unfold split_vec. - unshelve erewrite nth_map. 1: exact 0%nat. - { simpl. - rewrite nth_iota. - 1: f_equal; lia. - simpl. move: Hj=>/InP. rewrite in_ziota=>/andP [] H1 h2. - replace (ws %/ U8 + ws %% U8)%nat with (Z.to_nat (wsize_size ws)); [lia|]. - destruct ws; simpl; reflexivity. } - rewrite size_iota. - simpl. move: Hj=>/InP. rewrite in_ziota=>/andP [] H1 h2. - replace (ws %/ U8 + ws %% U8)%nat with (Z.to_nat (wsize_size ws)); [lia|]. - destruct ws; simpl; reflexivity. -Qed. - -Lemma chArray_get_set_neq ws a i j (w : 'word ws) : - i <> j -> - chArray_get ws (chArray_set a AAscale i w) j (wsize_size ws) = chArray_get ws a j (wsize_size ws). -Proof. - intros H. - unfold chArray_get. - unfold chArray_set. - f_equal. - apply map_ext. - intros a0 Ha0. - unfold chArray_get8. - rewrite chArray_write_get. - assert ((0 <=? j * wsize_size ws + a0 - i * mk_scale AAscale ws) && (j * wsize_size ws + a0 - i * mk_scale AAscale ws /InP. rewrite in_ziota=>/andP [] H1 h2. nia. } - rewrite H0. - reflexivity. -Qed. - -Lemma getm_to_arr_None' ws len a (i: Z) : - ((len <=? i) || (i - to_arr ws len a i = None. -Proof. - intros. unfold to_arr. - rewrite mkfmapfE. -Admitted. (* figure out a proof that is less stupid than the one for getm_to_arr *) - -Lemma getm_to_oarr ws len a (i : 'I_(pos len)) : - to_oarr ws len a i = Some (chArray_get ws a i (wsize_size ws)). -Proof. - unfold to_oarr. - rewrite mkfmapfE. - rewrite mem_ord_enum. - reflexivity. -Qed. - -Lemma getm_to_arr ws len a i : - (0 <= i < len) -> - to_arr ws len a i = Some (chArray_get ws a i (wsize_size ws)). -Proof. - unfold to_arr. - rewrite mkfmapfE. - intros H. - (* this is a stupid proof and should be true by in_ziota, though for some reason the \in's resolve differently (one uses Z_eqType the other Z_ordType) *) - assert (is_true (@in_mem (Ord.sort Z_ordType) i (@ssrbool.mem (Equality.sort (Ord.eqType Z_ordType)) (seq_predType (Ord.eqType Z_ordType)) (ziota Z0 len)))). - { assert (0 <= len) by lia. move: H. move: (Z.le_refl 0). replace len with (0 + len) at 1 by (now rewrite Z.add_0_l). generalize 0 at 2 3 4 5. - change (∀ z : Z, 0 <= z -> z <= i < z + len → - (is_true (@in_mem (Ord.sort Z_ordType) i (@ssrbool.mem (Equality.sort (Ord.eqType Z_ordType)) (seq_predType (Ord.eqType Z_ordType)) (ziota z len)))) - ) with ((fun len => ((forall z, 0 <= z -> z <= i < z + len -> - (is_true (@in_mem (Ord.sort Z_ordType) i (@ssrbool.mem (Equality.sort (Ord.eqType Z_ordType)) (seq_predType (Ord.eqType Z_ordType)) (ziota z len)))) - ))) len). - apply natlike_ind. - - intros z Hz Hz2. lia. - - intros x Hx Ih z Hz Hz2. rewrite ziotaS_cons. 2: lia. - destruct (Z.eq_dec z i). - + rewrite in_cons. apply/orP. left. apply/eqP. easy. - + rewrite in_cons. apply/orP. right. apply Ih. all: lia. - - assumption. } - rewrite H0. - reflexivity. -Qed. - -Lemma to_oarr_set_eq ws len a (i : 'I_(pos len)) w : - (to_oarr ws len (chArray_set a AAscale i w)) i = Some w. -Proof. - rewrite getm_to_oarr. - rewrite chArray_get_set_eq. - reflexivity. -Qed. - -Lemma to_arr_set_eq ws len a i w : - (0 <= i < len) -> - (to_arr ws len (chArray_set a AAscale i w)) i = Some w. -Proof. - intros H. - rewrite getm_to_arr; auto. - rewrite chArray_get_set_eq; auto. -Qed. - -Lemma to_arr_set_neq' ws len a i j (w : 'word ws) : - (i <> j) -> - (0 <= j < len) -> - (to_arr ws len (chArray_set a AAscale i w)) j = Some (chArray_get ws a j (wsize_size ws)). -Proof. - intros Hneq H. - rewrite getm_to_arr; auto. - rewrite chArray_get_set_neq; auto. -Qed. - -Lemma to_arr_set_neq ws len a i j (w : 'word ws) : - (i <> j) -> - (0 <= j < len) -> - (to_arr ws len (chArray_set a AAscale i w)) j = (to_arr ws len a) j. -Proof. - intros Hneq H. - rewrite !getm_to_arr; auto. - rewrite chArray_get_set_neq; auto. -Qed. - -(** Additional rules *) - -Theorem rpre_weak_hypothesis_rule : - ∀ {A₀ A₁ : ord_choiceType} {p₀ : raw_code A₀} {p₁ : raw_code A₁} - (pre : precond) post, - (∀ s₀ s₁, - pre (s₀, s₁) → ⊢ ⦃ λ '(s0, s1), pre (s0, s1) ⦄ p₀ ≈ p₁ ⦃ post ⦄ - ) → - ⊢ ⦃ pre ⦄ p₀ ≈ p₁ ⦃ post ⦄. -Proof. - intros A₀ A₁ p₀ p₁ pre post h. - eapply rpre_hypothesis_rule. - intros. eapply rpre_weaken_rule. - 1: eapply h; eauto. - intros s0' s1' [H0 H1]. - subst. - assumption. -Qed. - -(** Misc (TODO: move these) *) - -(* TODO: move these, note they are the same as fresh1 and fresh2 *) -Lemma prec_O : - forall i, i ≺ i~0. -Proof. - simpl; split. - - apply preceq_O. - - apply nesym. apply xO_neq. -Qed. - -Lemma prec_I : - forall i, i ≺ i~1. -Proof. - simpl; split. - - apply preceq_I. - - apply nesym. apply xI_neq. -Qed. From 3617a719235f50328fbca00004188a6d50d8e93f Mon Sep 17 00:00:00 2001 From: "Philipp G. Haselwarter" Date: Wed, 20 Sep 2023 10:00:16 +0200 Subject: [PATCH 374/383] update to coq-mathcomp-word.2.1 for coq-mathcomp-zify compatibility --- ssprove.opam | 2 +- theories/Crypt/choice_type.v | 2 +- theories/Crypt/package/pkg_heap.v | 2 +- theories/Crypt/package/pkg_interpreter.v | 2 +- theories/Jasmin/examples/aes/aes.v | 2 +- theories/Jasmin/examples/aes/aes_prf.v | 2 +- theories/Jasmin/examples/aes/aes_spec.v | 2 +- theories/Jasmin/examples/aes/aes_utils.v | 2 +- theories/Jasmin/examples/aes/prf.v | 2 +- theories/Jasmin/examples/aes/utils.v | 2 +- theories/Jasmin/jasmin_translate.v | 6 +++--- theories/Jasmin/jasmin_x86.v | 2 +- theories/Jasmin/word.v | 2 +- 13 files changed, 15 insertions(+), 15 deletions(-) diff --git a/ssprove.opam b/ssprove.opam index e35e0139..5823007c 100644 --- a/ssprove.opam +++ b/ssprove.opam @@ -12,7 +12,7 @@ depends: [ "coq-equations" {>= "1.3"} "coq-mathcomp-ssreflect" {(>= "1.13.0" & < "1.14~")} "coq-mathcomp-analysis" {= "0.3.13"} - "coq-mathcomp-word" {>= "2.0"} + "coq-mathcomp-word" {>= "2.1"} "coq-extructures" {(>= "0.3.1" & < "dev")} "coq-deriving" {(>= "0.1" & < "dev")} "coq-mathcomp-zify" {>= "1.2"} diff --git a/theories/Crypt/choice_type.v b/theories/Crypt/choice_type.v index 98e65df7..7217cbf5 100644 --- a/theories/Crypt/choice_type.v +++ b/theories/Crypt/choice_type.v @@ -18,7 +18,7 @@ From deriving Require Import deriving. Set Warnings "-ambiguous-paths,-notation-overridden,-notation-incompatible-format". From mathcomp Require Import ssrnat ssreflect ssrfun ssrbool ssrnum eqtype choice reals distr realsum seq all_algebra fintype. -From mathcomp.word Require Import word ssrZ. +From mathcomp Require Import word_ssrZ word. From Jasmin Require Import utils word. Set Warnings "ambiguous-paths,notation-overridden,notation-incompatible-format". From Crypt Require Import Prelude Axioms. diff --git a/theories/Crypt/package/pkg_heap.v b/theories/Crypt/package/pkg_heap.v index 2af8ac39..80b1b909 100644 --- a/theories/Crypt/package/pkg_heap.v +++ b/theories/Crypt/package/pkg_heap.v @@ -20,7 +20,7 @@ From Crypt Require Import Prelude Axioms ChoiceAsOrd SubDistr Couplings pkg_tactics pkg_composition. Require Import Equations.Prop.DepElim. From Equations Require Import Equations. -From mathcomp.word Require Import word. +From mathcomp Require Import word. (* Must come after importing Equations.Equations, who knows why. *) From Crypt Require Import FreeProbProg. diff --git a/theories/Crypt/package/pkg_interpreter.v b/theories/Crypt/package/pkg_interpreter.v index ec031639..892c977a 100644 --- a/theories/Crypt/package/pkg_interpreter.v +++ b/theories/Crypt/package/pkg_interpreter.v @@ -203,7 +203,7 @@ Section Interpreter. pose (word.modulus_gt0 (word.nat_of_wsize n)). apply / word.iswordZP. apply a. - move : i => / ssrZ.ltzP. + move : i => / word_ssrZ.ltzP. auto. Defined. diff --git a/theories/Jasmin/examples/aes/aes.v b/theories/Jasmin/examples/aes/aes.v index f34c373b..aaa30ea9 100644 --- a/theories/Jasmin/examples/aes/aes.v +++ b/theories/Jasmin/examples/aes/aes.v @@ -1,6 +1,6 @@ Set Warnings "-notation-overridden,-ambiguous-paths". From mathcomp Require Import all_ssreflect all_algebra zify. -From mathcomp.word Require Import word ssrZ. +From mathcomp Require Import word_ssrZ word. Set Warnings "notation-overridden,ambiguous-paths". From Coq Require Import Utf8 ZArith micromega.Lia List. diff --git a/theories/Jasmin/examples/aes/aes_prf.v b/theories/Jasmin/examples/aes/aes_prf.v index 48918600..9286375b 100644 --- a/theories/Jasmin/examples/aes/aes_prf.v +++ b/theories/Jasmin/examples/aes/aes_prf.v @@ -15,7 +15,7 @@ From Relational Require Import OrderEnrichedCategory GenericRulesSimple. Set Warnings "-notation-overridden,-ambiguous-paths". From mathcomp Require Import all_ssreflect all_algebra reals distr realsum - ssrnat ssreflect ssrfun ssrbool ssrnum eqtype choice seq word word.ssrZ. + ssrnat ssreflect ssrfun ssrbool ssrnum eqtype choice seq word word_ssrZ. Set Warnings "notation-overridden,ambiguous-paths". From Mon Require Import SPropBase. diff --git a/theories/Jasmin/examples/aes/aes_spec.v b/theories/Jasmin/examples/aes/aes_spec.v index 693428c0..06cae285 100644 --- a/theories/Jasmin/examples/aes/aes_spec.v +++ b/theories/Jasmin/examples/aes/aes_spec.v @@ -1,6 +1,6 @@ Set Warnings "-notation-overridden,-ambiguous-paths". From mathcomp Require Import all_ssreflect all_algebra zify. -From mathcomp.word Require Import word ssrZ. +From mathcomp Require Import word_ssrZ word. Set Warnings "notation-overridden,ambiguous-paths". From Coq Require Import Utf8 ZArith micromega.Lia List. diff --git a/theories/Jasmin/examples/aes/aes_utils.v b/theories/Jasmin/examples/aes/aes_utils.v index 1b4d5dab..4fb6157a 100644 --- a/theories/Jasmin/examples/aes/aes_utils.v +++ b/theories/Jasmin/examples/aes/aes_utils.v @@ -1,6 +1,6 @@ Set Warnings "-notation-overridden,-ambiguous-paths". From mathcomp Require Import all_ssreflect all_algebra zify. -From mathcomp.word Require Import word ssrZ. +From mathcomp Require Import word_ssrZ word. Set Warnings "notation-overridden,ambiguous-paths". From Coq Require Import Utf8 ZArith micromega.Lia List. diff --git a/theories/Jasmin/examples/aes/prf.v b/theories/Jasmin/examples/aes/prf.v index 002531d8..61f24a6f 100644 --- a/theories/Jasmin/examples/aes/prf.v +++ b/theories/Jasmin/examples/aes/prf.v @@ -15,7 +15,7 @@ From Relational Require Import OrderEnrichedCategory GenericRulesSimple. Set Warnings "-notation-overridden,-ambiguous-paths". From mathcomp Require Import all_ssreflect all_algebra reals distr realsum - ssrnat ssreflect ssrfun ssrbool ssrnum eqtype choice seq word word.ssrZ. + ssrnat ssreflect ssrfun ssrbool ssrnum eqtype choice seq word word_ssrZ. Set Warnings "notation-overridden,ambiguous-paths". From Mon Require Import SPropBase. diff --git a/theories/Jasmin/examples/aes/utils.v b/theories/Jasmin/examples/aes/utils.v index e49ee6a9..00556be8 100644 --- a/theories/Jasmin/examples/aes/utils.v +++ b/theories/Jasmin/examples/aes/utils.v @@ -1,6 +1,6 @@ Set Warnings "-notation-overridden,-ambiguous-paths". From mathcomp Require Import all_ssreflect all_algebra zify. -From mathcomp.word Require Import word ssrZ. +From mathcomp Require Import word_ssrZ word. Set Warnings "notation-overridden,ambiguous-paths". From Coq Require Import Utf8 ZArith micromega.Lia List. diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index beb9f5a2..68ae81ec 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1,6 +1,6 @@ Set Warnings "-ambiguous-paths,-notation-overridden,-notation-incompatible-format". From mathcomp Require Import all_ssreflect all_algebra. -From mathcomp.word Require Import ssrZ word. +From mathcomp Require Import word word_ssrZ. From Jasmin Require Import expr compiler_util values sem. Set Warnings "ambiguous-paths,notation-overridden,notation-incompatible-format". @@ -1992,7 +1992,7 @@ Proof. apply ziota_ind. - auto. - intros i l h Ih. - rewrite (@in_cons ssrZ.Z_eqType). + rewrite (@in_cons word_ssrZ.Z_eqType). simpl. rewrite <- addE. destruct (_ == _) eqn:eb. @@ -3063,7 +3063,7 @@ Proof. apply ziota_ind. - simpl. reflexivity. - simpl. intros k l h ih. - rewrite (@in_cons ssrZ.Z_eqType). + rewrite (@in_cons word_ssrZ.Z_eqType). destruct (_ == _) eqn:eb. + simpl. move: eb => /eqP eb. subst. unfold chArray_set8. diff --git a/theories/Jasmin/jasmin_x86.v b/theories/Jasmin/jasmin_x86.v index a63dfced..2c77289b 100644 --- a/theories/Jasmin/jasmin_x86.v +++ b/theories/Jasmin/jasmin_x86.v @@ -1,6 +1,6 @@ Set Warnings "-ambiguous-paths,-notation-overridden,-notation-incompatible-format". From mathcomp Require Import all_ssreflect all_algebra. -From mathcomp.word Require Import ssrZ word. +From mathcomp Require Import word_ssrZ word. From Jasmin Require Import expr compiler_util values sem. Set Warnings "ambiguous-paths,notation-overridden,notation-incompatible-format". diff --git a/theories/Jasmin/word.v b/theories/Jasmin/word.v index 588a36ba..082f292a 100644 --- a/theories/Jasmin/word.v +++ b/theories/Jasmin/word.v @@ -1,7 +1,7 @@ From Coq Require Import Utf8 ZArith micromega.Lia. From mathcomp Require Import all_ssreflect all_algebra. -From mathcomp.word Require Import word ssrZ. +From mathcomp Require Import word_ssrZ word. (* NB: This changes the behaviour of lia, making it work on goals with ssr types *) From mathcomp Require Import zify. From 0f611982d50a8a9fb28603c151dc46592705724f Mon Sep 17 00:00:00 2001 From: "Benjamin S. Hvass" Date: Wed, 20 Sep 2023 12:14:50 +0200 Subject: [PATCH 375/383] jasmin readme --- README.md | 62 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 62 insertions(+) diff --git a/README.md b/README.md index c0862c71..ad332b7d 100644 --- a/README.md +++ b/README.md @@ -27,6 +27,58 @@ A documentation is available in [DOC.md]. - [TYPES'21](https://youtu.be/FdMRB1mnyUA): Video focused on semantics and programming logic (speaker: Antoine Van Muylder) - [Coq Workshop '21](https://youtu.be/uYhItPhA-Y8): Video illustrating the formalisation (speaker: Théo Winterhalter) +## Jasmin translation and examples + +### Translation + +This branch contains a formally verified translation from Jasmin +programs to SSProve programs. The translation is defined and proven +correct in [theories/Jasmin/jasmin_translate.v]. The main theorem is +`translate_prog_correct` which states that a translated jasmin +function has the same input/output behavior as the original function. + +In [theories/Jasmin/jasmin_asm.v] we combine `translate_prog_correct` +and the correctness theorem of the Jasmin compiler to prove +`equiv_to_asm`, which states that if a Jasmin program compiles +correctly, then functions from the compiled assembly program have the +same input/output behavior as the corresponding functions from the +translated SSProve program. This is the theorem which justifies that +reasoning about the translated SSProve program gives guarantees about +the compiled assembly program. + +In [theories/Jasmin/jasmin_x86.v] `equiv_to_asm` is specialized to x86 architecture. + +### Examples + +[theories/Jasmin/examples/] contains a suite of Jasmin programs and +their translations to SSProve; the Jasmin programs are mainly from the +Jasmin repository. + +[theories/Jasmin/examples/aes/] contains a formal proof of IND-CPA +security of a symmetric encryption scheme using AES, where AES is +implemented in Jasmin and translated to SSProve. + +[theories/Jasmin/examples/aes/aes_jazz.v] contains the translated +SSProve program and some notations for handling it. + +[theories/Jasmin/examples/aes/aes_spec.v] contains a Coq +implementation (`aes`) of AES which we use as a spec. It also contains +a handwritten SSProve implementation (`Caes`) of AES which serves as +an intermediate implementation to make the proofs easier. Finally, it +contains the lemma `aes_h`, which relates the two. + +[theories/Jasmin/examples/aes/aes.v] relates the Jasmin implementation +of AES (`JAES`) to the intermediate SSProve implementation. The lemma +`aes_E` prove that they are equivalent. + +[theories/Jasmin/examples/aes/aes_prf.v] contains the proof of IND-CPA +security of a encryption scheme using a pseudo-random function +(PRF). This is the lemma `security_based_on_prf`; note that this is +almost verbatim taken from [examples/PRF.v]. Then we instantiate the +lemma with our translated Jasmin implementation AES and prove that the +same security notion holds for the efficient implementation. This is +`jsecurity_based_on_prf`. + ## Installation #### Prerequisites @@ -751,3 +803,13 @@ We do something similar for Schnorr's protocol. [rhl_semantics/state_prob/]: theories/Crypt/rhl_semantics/state_prob/ [Main.v]: theories/Crypt/Main.v [DOC.md]: ./DOC.md +[theories/Jasmin/jasmin_translate.v]: theories/Jasmin/jasmin_translate.v +[theories/Jasmin/jasmin_asm.v]: theories/Jasmin/jasmin_asm.v +[theories/Jasmin/jasmin_x86.v]: theories/Jasmin/jasmin_x86.v +[theories/Jasmin/examples/]: theories/Jasmin/examples/ +[theories/Jasmin/examples/aes/]: theories/Jasmin/examples/aes/ +[theories/Jasmin/examples/aes/aes.v]: theories/Jasmin/examples/aes/aes.v +[theories/Jasmin/examples/aes/aes_jazz.v]: theories/Jasmin/examples/aes/aes_jazz.v +[theories/Jasmin/examples/aes/aes_prf.v]: theories/Jasmin/examples/aes/aes_prf.v +[theories/Jasmin/examples/aes/aes_spec.v]: theories/Jasmin/examples/aes/aes_spec.v +[theories/Jasmin/examples/aes/aes_valid.v]: theories/Jasmin/examples/aes/aes_valid.v From 6aa247c422f1f0d62fdd94328fda99f2af4351a0 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Tue, 6 Jun 2023 13:42:53 +0200 Subject: [PATCH 376/383] Update to Mathcomp2 and Coq 8.18.0 --- Makefile | 207 ++- _CoqProject | 61 +- ssprove.opam | 16 +- theories/Crypt/Axioms.v | 2 +- theories/Crypt/Casts.v | 37 + theories/Crypt/Prelude.v | 7 +- theories/Crypt/choice_type.v | 76 +- theories/Crypt/examples/AsymScheme.v | 10 +- theories/Crypt/examples/DDH.v | 118 ++ theories/Crypt/examples/ElGamal.v | 51 +- theories/Crypt/examples/KEMDEM.v | 62 +- theories/Crypt/examples/OTP.v | 4 +- theories/Crypt/examples/PRF.v | 2 - theories/Crypt/examples/Schnorr.v | 428 ++++-- theories/Crypt/examples/SigmaProtocol.v | 656 ++++++-- theories/Crypt/examples/concrete_groups.v | 46 +- .../Crypt/examples/package_usage_example.v | 7 +- theories/Crypt/package/pkg_advantage.v | 75 +- theories/Crypt/package/pkg_composition.v | 6 +- theories/Crypt/package/pkg_core_definition.v | 3 +- theories/Crypt/package/pkg_distr.v | 10 +- theories/Crypt/package/pkg_invariants.v | 5 +- theories/Crypt/package/pkg_rhl.v | 156 +- theories/Crypt/rhl_semantics/ChoiceAsOrd.v | 4 +- .../rhl_semantics/free_monad/FreeProbProg.v | 2 +- .../more_categories/LaxFunctorsAndTransf.v | 2 +- .../LaxMorphismOfRelAdjunctions.v | 2 +- .../OrderEnrichedRelativeAdjunctions.v | 2 +- .../more_categories/TransformingLaxMorph.v | 2 +- .../rhl_semantics/only_prob/Theta_exCP.v | 26 +- ...OrderEnrichedRelativeAdjunctionsExamples.v | 2 +- .../state_prob/StateTransformingLaxMorph.v | 4 +- theories/Crypt/rules/RulesProb.v | 70 +- theories/Crypt/rules/RulesStateProb.v | 65 +- theories/Crypt/rules/UniformDistrLemmas.v | 22 +- theories/Crypt/rules/UniformStateProb.v | 8 +- theories/Jasmin/examples/aes/aes.v | 10 +- theories/Jasmin/examples/aes/aes_spec.v | 2 +- theories/Jasmin/examples/aes/aes_utils.v | 18 +- theories/Jasmin/jasmin_asm.v | 132 +- theories/Jasmin/jasmin_translate.v | 1339 +++++++---------- theories/Jasmin/jasmin_x86.v | 33 +- theories/Relational/GenericRulesSimple.v | 2 +- .../OrderEnrichedRelativeMonadExamples.v | 2 +- 44 files changed, 2297 insertions(+), 1497 deletions(-) create mode 100644 theories/Crypt/Casts.v create mode 100644 theories/Crypt/examples/DDH.v diff --git a/Makefile b/Makefile index ac7ef75f..42626b66 100644 --- a/Makefile +++ b/Makefile @@ -7,7 +7,7 @@ ## # GNU Lesser General Public License Version 2.1 ## ## # (see LICENSE file for the text of the license) ## ########################################################################## -## GNUMakefile for Coq 8.15.2 +## GNUMakefile for Coq 8.18.0 # For debugging purposes (must stay here, don't move below) INITIAL_VARS := $(.VARIABLES) @@ -26,6 +26,7 @@ MLFILES := $(COQMF_MLFILES) MLGFILES := $(COQMF_MLGFILES) MLPACKFILES := $(COQMF_MLPACKFILES) MLLIBFILES := $(COQMF_MLLIBFILES) +METAFILE := $(COQMF_METAFILE) CMDLINE_VFILES := $(COQMF_CMDLINE_VFILES) INSTALLCOQDOCROOT := $(COQMF_INSTALLCOQDOCROOT) OTHERFLAGS := $(COQMF_OTHERFLAGS) @@ -59,12 +60,12 @@ Makefile.conf: _CoqProject # practice is discouraged since _CoqProject better not contain make specific # code (be nice to user interfaces). -# set KEEP_ERROR to prevent make from deleting files produced by failing rules. -# For instance if coqc creates a .vo but then fails to native compile, -# the .vo will be deleted unless KEEP_ERROR is nonempty. +# Set KEEP_ERROR to have make keep files produced by failing rules. +# By default, KEEP_ERROR is empty. So for instance if coqc creates a .vo but +# then fails to native compile, the .vo will be deleted. # May confuse make so use only for debugging. KEEP_ERROR?= -ifneq (,$(KEEP_ERROR)) +ifeq (,$(KEEP_ERROR)) .DELETE_ON_ERROR: endif @@ -75,7 +76,7 @@ VERBOSE ?= TIMED?= TIMECMD?= # Use command time on linux, gtime on Mac OS -TIMEFMT?="$@ (real: %e, user: %U, sys: %S, mem: %M ko)" +TIMEFMT?="$(if $(findstring undefined, $(flavor 1)),$@,$(1)) (real: %e, user: %U, sys: %S, mem: %M ko)" ifneq (,$(TIMED)) ifeq (0,$(shell command time -f "" true >/dev/null 2>/dev/null; echo $$?)) STDTIME?=command time -f $(TIMEFMT) @@ -114,14 +115,11 @@ COQMAKE_BOTH_SINGLE_TIMING_FILES ?= "$(COQCORELIB)/tools/make-both-single-timing BEFORE ?= AFTER ?= -# FIXME this should be generated by Coq (modules already linked by Coq) -CAMLDONTLINK=str,unix,dynlink,threads,zarith - # OCaml binaries CAMLC ?= "$(OCAMLFIND)" ocamlc -c CAMLOPTC ?= "$(OCAMLFIND)" opt -c -CAMLLINK ?= "$(OCAMLFIND)" ocamlc -linkpkg -dontlink $(CAMLDONTLINK) -CAMLOPTLINK ?= "$(OCAMLFIND)" opt -linkpkg -dontlink $(CAMLDONTLINK) +CAMLLINK ?= "$(OCAMLFIND)" ocamlc -linkall +CAMLOPTLINK ?= "$(OCAMLFIND)" opt -linkall CAMLDOC ?= "$(OCAMLFIND)" ocamldoc CAMLDEP ?= "$(OCAMLFIND)" ocamldep -slash -ml-synonym .mlpack @@ -134,6 +132,7 @@ COQDEBUG ?= # Extra packages to be linked in (as in findlib -package) CAMLPKGS ?= +FINDLIBPKGS = -package coq-core.plugins.ltac $(CAMLPKGS) # Option for making timing files TIMING?= @@ -170,8 +169,30 @@ destination_path = $(if $(DESTDIR),$(DESTDIR)/$(call windrive_path,$(1)),$(1)) # Installation paths of libraries and documentation. COQLIBINSTALL ?= $(call destination_path,$(COQLIB)/user-contrib) COQDOCINSTALL ?= $(call destination_path,$(DOCDIR)/coq/user-contrib) +COQPLUGININSTALL ?= $(call destination_path,$(COQCORELIB)/..) COQTOPINSTALL ?= $(call destination_path,$(COQLIB)/toploop) # FIXME: Unused variable? +# findlib files installation +FINDLIBPREINST= mkdir -p "$(COQPLUGININSTALL)/" +FINDLIBDESTDIR= -destdir "$(COQPLUGININSTALL)/" + +# we need to move out of sight $(METAFILE) otherwise findlib thinks the +# package is already installed +findlib_install = \ + $(HIDE)if [ "$(METAFILE)" ]; then \ + $(FINDLIBPREINST) && \ + mv "$(METAFILE)" "$(METAFILE).skip" ; \ + "$(OCAMLFIND)" install $(2) $(FINDLIBDESTDIR) $(FINDLIBPACKAGE) $(1); \ + rc=$$?; \ + mv "$(METAFILE).skip" "$(METAFILE)"; \ + exit $$rc; \ + fi +findlib_remove = \ + $(HIDE)if [ ! -z "$(METAFILE)" ]; then\ + "$(OCAMLFIND)" remove $(FINDLIBDESTDIR) $(FINDLIBPACKAGE); \ + fi + + ########## End of parameters ################################################## # What follows may be relevant to you only if you need to # extend this Makefile. If so, look for 'Extension point' here and @@ -257,14 +278,14 @@ COQDOCLIBS?=$(COQLIBS_NOML) # The version of Coq being run and the version of coq_makefile that # generated this makefile COQ_VERSION:=$(shell $(COQC) --print-version | cut -d " " -f 1) -COQMAKEFILE_VERSION:=8.15.2 +COQMAKEFILE_VERSION:=8.18.0 # COQ_SRC_SUBDIRS is for user-overriding, usually to add # `user-contrib/Foo` to the includes, we keep COQCORE_SRC_SUBDIRS for # Coq's own core libraries, which should be replaced by ocamlfind # options at some point. COQ_SRC_SUBDIRS?= -COQSRCLIBS?= $(foreach d,$(COQCORE_SRC_SUBDIRS), -I "$(COQCORELIB)/$(d)") $(foreach d,$(COQ_SRC_SUBDIRS), -I "$(COQLIB)/$(d)") +COQSRCLIBS?= $(foreach d,$(COQ_SRC_SUBDIRS), -I "$(COQLIB)/$(d)") CAMLFLAGS+=$(OCAMLLIBS) $(COQSRCLIBS) # ocamldoc fails with unknown argument otherwise @@ -272,18 +293,18 @@ CAMLDOCFLAGS:=$(filter-out -annot, $(filter-out -bin-annot, $(CAMLFLAGS))) CAMLFLAGS+=$(OCAMLWARN) ifneq (,$(TIMING)) -TIMING_ARG=-time -ifeq (after,$(TIMING)) -TIMING_EXT=after-timing -else -ifeq (before,$(TIMING)) -TIMING_EXT=before-timing -else -TIMING_EXT=timing -endif -endif + ifeq (after,$(TIMING)) + TIMING_EXT=after-timing + else + ifeq (before,$(TIMING)) + TIMING_EXT=before-timing + else + TIMING_EXT=timing + endif + endif + TIMING_ARG=-time-file $<.$(TIMING_EXT) else -TIMING_ARG= + TIMING_ARG= endif # Files ####################################################################### @@ -358,6 +379,8 @@ ALLNATIVEFILES = \ $(OBJFILES:.o=.cmi) \ $(OBJFILES:.o=.cmx) \ $(OBJFILES:.o=.cmxs) +FINDLIBPACKAGE=$(patsubst .%,%,$(suffix $(METAFILE))) + # trick: wildcard filters out non-existing files, so that `install` doesn't show # warnings and `clean` doesn't pass to rm a list of files that is too long for # the shell. @@ -367,13 +390,12 @@ FILESTOINSTALL = \ $(VFILES) \ $(GLOBFILES) \ $(NATIVEFILES) \ + $(CMXSFILES) # to be removed when we remove legacy loading +FINDLIBFILESTOINSTALL = \ $(CMIFILESTOINSTALL) -BYTEFILESTOINSTALL = \ - $(CMOFILESTOINSTALL) \ - $(CMAFILES) ifeq '$(HASNATDYNLINK)' 'true' DO_NATDYNLINK = yes -FILESTOINSTALL += $(CMXSFILES) $(CMXAFILES) $(CMOFILESTOINSTALL:.cmo=.cmx) +FINDLIBFILESTOINSTALL += $(CMXSFILES) $(CMXAFILES) $(CMOFILESTOINSTALL:.cmo=.cmx) else DO_NATDYNLINK = endif @@ -529,12 +551,12 @@ mlihtml: $(MLIFILES:.mli=.cmi) $(SHOW)'CAMLDOC -d $@' $(HIDE)mkdir $@ || rm -rf $@/* $(HIDE)$(CAMLDOC) -html \ - -d $@ -m A $(CAMLDEBUG) $(CAMLDOCFLAGS) $(MLIFILES) + -d $@ -m A $(CAMLDEBUG) $(CAMLDOCFLAGS) $(MLIFILES) $(FINDLIBPKGS) all-mli.tex: $(MLIFILES:.mli=.cmi) $(SHOW)'CAMLDOC -latex $@' $(HIDE)$(CAMLDOC) -latex \ - -o $@ -m A $(CAMLDEBUG) $(CAMLDOCFLAGS) $(MLIFILES) + -o $@ -m A $(CAMLDEBUG) $(CAMLDOCFLAGS) $(MLIFILES) $(FINDLIBPKGS) all.ps: $(VFILES) $(SHOW)'COQDOC -ps $(GAL)' @@ -570,11 +592,24 @@ beautify: $(BEAUTYFILES) # There rules can be extended in Makefile.local # Extensions can't assume when they run. -install: - $(HIDE)code=0; for f in $(FILESTOINSTALL); do\ +# We use $(file) to avoid generating a very long command string to pass to the shell +# (cf https://coq.zulipchat.com/#narrow/stream/250632-Coq-Platform-devs-.26-users/topic/Strange.20command.20length.20limit.20on.20Linux) +# However Apple ships old make which doesn't have $(file) so we need a fallback +$(file >.hasfile,1) +HASFILE:=$(shell if [ -e .hasfile ]; then echo 1; rm .hasfile; fi) + +MKFILESTOINSTALL= $(if $(HASFILE),$(file >.filestoinstall,$(FILESTOINSTALL)),\ + $(shell rm -f .filestoinstall) \ + $(foreach x,$(FILESTOINSTALL),$(shell printf '%s\n' "$x" >> .filestoinstall))) + +# findlib needs the package to not be installed, so we remove it before +# installing it (see the call to findlib_remove) +install: META + @$(MKFILESTOINSTALL) + $(HIDE)code=0; for f in $$(cat .filestoinstall); do\ if ! [ -f "$$f" ]; then >&2 echo $$f does not exist; code=1; fi \ done; exit $$code - $(HIDE)for f in $(FILESTOINSTALL); do\ + $(HIDE)for f in $$(cat .filestoinstall); do\ df="`$(COQMKFILE) -destination-of "$$f" $(COQLIBS)`";\ if [ "$$?" != "0" -o -z "$$df" ]; then\ echo SKIP "$$f" since it has no logical path;\ @@ -584,22 +619,21 @@ install: echo INSTALL "$$f" "$(COQLIBINSTALL)/$$df";\ fi;\ done + $(call findlib_remove) + $(call findlib_install, META $(FINDLIBFILESTOINSTALL)) $(HIDE)$(MAKE) install-extra -f "$(SELF)" + @rm -f .filestoinstall install-extra:: @# Extension point .PHONY: install install-extra +META: $(METAFILE) + $(HIDE)if [ "$(METAFILE)" ]; then \ + cat "$(METAFILE)" | grep -v 'directory.*=.*' > META; \ + fi + install-byte: - $(HIDE)for f in $(BYTEFILESTOINSTALL); do\ - df="`$(COQMKFILE) -destination-of "$$f" $(COQLIBS)`";\ - if [ "$$?" != "0" -o -z "$$df" ]; then\ - echo SKIP "$$f" since it has no logical path;\ - else\ - install -d "$(COQLIBINSTALL)/$$df" &&\ - install -m 0644 "$$f" "$(COQLIBINSTALL)/$$df" &&\ - echo INSTALL "$$f" "$(COQLIBINSTALL)/$$df";\ - fi;\ - done + $(call findlib_install, $(CMAFILES) $(CMOFILESTOINSTALL), -add) install-doc:: html mlihtml @# Extension point @@ -620,13 +654,21 @@ install-doc:: html mlihtml uninstall:: @# Extension point - $(HIDE)for f in $(FILESTOINSTALL); do \ + @$(MKFILESTOINSTALL) + $(call findlib_remove) + $(HIDE)for f in $$(cat .filestoinstall); do \ df="`$(COQMKFILE) -destination-of "$$f" $(COQLIBS)`" &&\ instf="$(COQLIBINSTALL)/$$df/`basename $$f`" &&\ rm -f "$$instf" &&\ - echo RM "$$instf" &&\ + echo RM "$$instf" ;\ + done + $(HIDE)for f in $$(cat .filestoinstall); do \ + df="`$(COQMKFILE) -destination-of "$$f" $(COQLIBS)`" &&\ + echo RMDIR "$(COQLIBINSTALL)/$$df/" &&\ (rmdir "$(COQLIBINSTALL)/$$df/" 2>/dev/null || true); \ done + @rm -f .filestoinstall + .PHONY: uninstall uninstall-doc:: @@ -649,12 +691,14 @@ clean:: $(HIDE)rm -f $(CMOFILES) $(HIDE)rm -f $(CMIFILES) $(HIDE)rm -f $(CMAFILES) - $(HIDE)rm -f $(CMOFILES:.cmo=.cmx) + $(HIDE)rm -f $(CMXFILES) $(HIDE)rm -f $(CMXAFILES) $(HIDE)rm -f $(CMXSFILES) - $(HIDE)rm -f $(CMOFILES:.cmo=.o) + $(HIDE)rm -f $(OFILES) $(HIDE)rm -f $(CMXAFILES:.cmxa=.a) $(HIDE)rm -f $(MLGFILES:.mlg=.ml) + $(HIDE)rm -f $(CMXFILES:.cmx=.cmt) + $(HIDE)rm -f $(MLIFILES:.mli=.cmti) $(HIDE)rm -f $(ALLDFILES) $(HIDE)rm -f $(NATIVEFILES) $(HIDE)find . -name .coq-native -type d -empty -delete @@ -668,6 +712,7 @@ clean:: $(HIDE)rm -f $(VFILES:.v=.tex) $(HIDE)rm -f $(VFILES:.v=.g.tex) $(HIDE)rm -f pretty-timed-success.ok + $(HIDE)rm -f META $(HIDE)rm -rf html mlihtml .PHONY: clean @@ -695,7 +740,7 @@ archclean:: $(MLIFILES:.mli=.cmi): %.cmi: %.mli $(SHOW)'CAMLC -c $<' - $(HIDE)$(TIMER) $(CAMLC) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) $< + $(HIDE)$(TIMER) $(CAMLC) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) $< $(MLGFILES:.mlg=.ml): %.ml: %.mlg $(SHOW)'COQPP $<' @@ -704,72 +749,92 @@ $(MLGFILES:.mlg=.ml): %.ml: %.mlg # Stupid hack around a deficient syntax: we cannot concatenate two expansions $(filter %.cmo, $(MLFILES:.ml=.cmo) $(MLGFILES:.mlg=.cmo)): %.cmo: %.ml $(SHOW)'CAMLC -c $<' - $(HIDE)$(TIMER) $(CAMLC) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) $< + $(HIDE)$(TIMER) $(CAMLC) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) $< # Same hack $(filter %.cmx, $(MLFILES:.ml=.cmx) $(MLGFILES:.mlg=.cmx)): %.cmx: %.ml $(SHOW)'CAMLOPT -c $(FOR_PACK) $<' - $(HIDE)$(TIMER) $(CAMLOPTC) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) $(FOR_PACK) $< + $(HIDE)$(TIMER) $(CAMLOPTC) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) $(FOR_PACK) $< $(MLLIBFILES:.mllib=.cmxs): %.cmxs: %.cmxa $(SHOW)'CAMLOPT -shared -o $@' - $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) \ - -linkall -shared -o $@ $< + $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) \ + -shared -o $@ $< $(MLLIBFILES:.mllib=.cma): %.cma: | %.mllib $(SHOW)'CAMLC -a -o $@' - $(HIDE)$(TIMER) $(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) -a -o $@ $^ + $(HIDE)$(TIMER) $(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) -a -o $@ $^ $(MLLIBFILES:.mllib=.cmxa): %.cmxa: | %.mllib $(SHOW)'CAMLOPT -a -o $@' - $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) -a -o $@ $^ + $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) -a -o $@ $^ $(MLPACKFILES:.mlpack=.cmxs): %.cmxs: %.cmxa $(SHOW)'CAMLOPT -shared -o $@' - $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) \ - -shared -linkall -o $@ $< + $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) \ + -shared -o $@ $< -$(MLPACKFILES:.mlpack=.cmxa): %.cmxa: %.cmx +$(MLPACKFILES:.mlpack=.cmxa): %.cmxa: %.cmx | %.mlpack $(SHOW)'CAMLOPT -a -o $@' - $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) -a -o $@ $< + $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) -a -o $@ $< $(MLPACKFILES:.mlpack=.cma): %.cma: %.cmo | %.mlpack $(SHOW)'CAMLC -a -o $@' - $(HIDE)$(TIMER) $(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) -a -o $@ $^ + $(HIDE)$(TIMER) $(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) -a -o $@ $^ $(MLPACKFILES:.mlpack=.cmo): %.cmo: | %.mlpack $(SHOW)'CAMLC -pack -o $@' - $(HIDE)$(TIMER) $(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) -pack -o $@ $^ + $(HIDE)$(TIMER) $(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) -pack -o $@ $^ $(MLPACKFILES:.mlpack=.cmx): %.cmx: | %.mlpack $(SHOW)'CAMLOPT -pack -o $@' - $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) -pack -o $@ $^ + $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) -pack -o $@ $^ # This rule is for _CoqProject with no .mllib nor .mlpack $(filter-out $(MLLIBFILES:.mllib=.cmxs) $(MLPACKFILES:.mlpack=.cmxs) $(addsuffix .cmxs,$(PACKEDFILES)) $(addsuffix .cmxs,$(LIBEDFILES)),$(MLFILES:.ml=.cmxs) $(MLGFILES:.mlg=.cmxs)): %.cmxs: %.cmx $(SHOW)'[deprecated,use-mllib-or-mlpack] CAMLOPT -shared -o $@' - $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(CAMLPKGS) \ + $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) \ -shared -o $@ $< -ifneq (,$(TIMING)) -TIMING_EXTRA = > $<.$(TIMING_EXT) -else -TIMING_EXTRA = +# can't make +# https://www.gnu.org/software/make/manual/make.html#Static-Pattern +# work with multiple target rules +# so use eval in a loop instead +# with grouped targets https://www.gnu.org/software/make/manual/make.html#Multiple-Targets +# if available (GNU Make >= 4.3) +ifneq (,$(filter grouped-target,$(.FEATURES))) +define globvorule= + +# take care to $$ variables using $< etc + $(1).vo $(1).glob &: $(1).v | $(VDFILE) + $(SHOW)COQC $(1).v + $(HIDE)$$(TIMER) $(COQC) $(COQDEBUG) $$(TIMING_ARG) $(COQFLAGS) $(COQLIBS) $(1).v +ifeq ($(COQDONATIVE), "yes") + $(SHOW)COQNATIVE $(1).vo + $(HIDE)$(call TIMER,$(1).vo.native) $(COQNATIVE) $(COQLIBS) $(1).vo endif +endef +else + $(VOFILES): %.vo: %.v | $(VDFILE) $(SHOW)COQC $< - $(HIDE)$(TIMER) $(COQC) $(COQDEBUG) $(TIMING_ARG) $(COQFLAGS) $(COQLIBS) $< $(TIMING_EXTRA) + $(HIDE)$(TIMER) $(COQC) $(COQDEBUG) $(TIMING_ARG) $(COQFLAGS) $(COQLIBS) $< ifeq ($(COQDONATIVE), "yes") $(SHOW)COQNATIVE $@ - $(HIDE)$(COQNATIVE) $(COQLIBS) $@ + $(HIDE)$(call TIMER,$@.native) $(COQNATIVE) $(COQLIBS) $@ endif -# FIXME ?merge with .vo / .vio ? +# this is broken :( todo fix if we ever find a solution that doesn't need grouped targets $(GLOBFILES): %.glob: %.v - $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< + $(SHOW)'COQC $< (for .glob)' + $(HIDE)$(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< + +endif + +$(foreach vfile,$(VFILES:.v=),$(eval $(call globvorule,$(vfile)))) $(VFILES:.v=.vio): %.vio: %.v $(SHOW)COQC -vio $< @@ -851,7 +916,7 @@ VDFILE_FLAGS:=$(if _CoqProject,-f _CoqProject,) $(CMDLINE_COQLIBS) $(CMDLINE_VFI $(VDFILE): _CoqProject $(VFILES) $(SHOW)'COQDEP VFILES' - $(HIDE)$(COQDEP) -vos -dyndep var $(VDFILE_FLAGS) $(redir_if_ok) + $(HIDE)$(COQDEP) $(if $(strip $(METAFILE)),-m "$(METAFILE)") -vos -dyndep var $(VDFILE_FLAGS) $(redir_if_ok) # Misc ######################################################################## diff --git a/_CoqProject b/_CoqProject index 92c03f74..368ce895 100644 --- a/_CoqProject +++ b/_CoqProject @@ -77,38 +77,38 @@ theories/Crypt/rules/UniformStateProb.v #std. distributions # theories/Crypt/only_prob/SymmetricSchemeStateProbStdDistr.v -# Jasmin -theories/Jasmin/jasmin_translate.v -theories/Jasmin/jasmin_x86.v -theories/Jasmin/jasmin_asm.v -theories/Jasmin/jasmin_utils.v -theories/Jasmin/word.v +# # Jasmin +# theories/Jasmin/jasmin_translate.v +# theories/Jasmin/jasmin_x86.v +# theories/Jasmin/jasmin_asm.v +# theories/Jasmin/jasmin_utils.v +# theories/Jasmin/word.v -theories/Jasmin/examples/add1.v -theories/Jasmin/examples/aes.v -theories/Jasmin/examples/aes/aes_jazz.v -theories/Jasmin/examples/bigadd.v -theories/Jasmin/examples/ex.v -theories/Jasmin/examples/int_add.v -theories/Jasmin/examples/int_incr.v -theories/Jasmin/examples/int_reg.v -theories/Jasmin/examples/int_shift.v -theories/Jasmin/examples/liveness_bork.v -theories/Jasmin/examples/matrix_product.v -theories/Jasmin/examples/retz.v -theories/Jasmin/examples/test_for.v -theories/Jasmin/examples/test_inline_var.v -theories/Jasmin/examples/test_shift.v -theories/Jasmin/examples/three_functions.v -theories/Jasmin/examples/two_functions.v -theories/Jasmin/examples/u64_incr.v -theories/Jasmin/examples/xor.v +# theories/Jasmin/examples/add1.v +# theories/Jasmin/examples/aes.v +# theories/Jasmin/examples/aes/aes_jazz.v +# theories/Jasmin/examples/bigadd.v +# theories/Jasmin/examples/ex.v +# theories/Jasmin/examples/int_add.v +# theories/Jasmin/examples/int_incr.v +# theories/Jasmin/examples/int_reg.v +# theories/Jasmin/examples/int_shift.v +# theories/Jasmin/examples/liveness_bork.v +# theories/Jasmin/examples/matrix_product.v +# theories/Jasmin/examples/retz.v +# theories/Jasmin/examples/test_for.v +# theories/Jasmin/examples/test_inline_var.v +# theories/Jasmin/examples/test_shift.v +# theories/Jasmin/examples/three_functions.v +# theories/Jasmin/examples/two_functions.v +# theories/Jasmin/examples/u64_incr.v +# theories/Jasmin/examples/xor.v -theories/Jasmin/examples/aes/aes.v -theories/Jasmin/examples/aes/aes_prf.v -theories/Jasmin/examples/aes/aes_utils.v -theories/Jasmin/examples/aes/aes_valid.v -theories/Jasmin/examples/aes/aes_spec.v +# theories/Jasmin/examples/aes/aes.v +# theories/Jasmin/examples/aes/aes_prf.v +# theories/Jasmin/examples/aes/aes_utils.v +# theories/Jasmin/examples/aes/aes_valid.v +# theories/Jasmin/examples/aes/aes_spec.v # Examples theories/Crypt/examples/package_usage_example.v @@ -122,6 +122,7 @@ theories/Crypt/examples/KEMDEM.v theories/Crypt/examples/RandomOracle.v theories/Crypt/examples/SigmaProtocol.v theories/Crypt/examples/Schnorr.v +theories/Crypt/examples/DDH.v # Printing the axioms of all results from the paper theories/Crypt/Main.v diff --git a/ssprove.opam b/ssprove.opam index 5823007c..18402995 100644 --- a/ssprove.opam +++ b/ssprove.opam @@ -8,14 +8,14 @@ homepage: "https://github.com/SSProve/ssprove" bug-reports: "https://github.com/SSProve/ssprove/issues" license: "MIT" depends: [ - "coq" {>= "8.14"} - "coq-equations" {>= "1.3"} - "coq-mathcomp-ssreflect" {(>= "1.13.0" & < "1.14~")} - "coq-mathcomp-analysis" {= "0.3.13"} - "coq-mathcomp-word" {>= "2.1"} - "coq-extructures" {(>= "0.3.1" & < "dev")} - "coq-deriving" {(>= "0.1" & < "dev")} - "coq-mathcomp-zify" {>= "1.2"} + "coq" {>= "8.18"} + "coq-equations" {>= "1.3+8.18"} + "coq-mathcomp-ssreflect" {(>= "2.1.0")} + "coq-mathcomp-analysis" {= "1.0.0"} + "coq-mathcomp-word" {>= "3.0"} + "coq-extructures" {(>= "0.4.0" & < "dev")} + "coq-deriving" {(>= "0.2.0" & < "dev")} + "coq-mathcomp-zify" {>= "1.5.0+2.0+8.16"} ] build: [ [make "-j%{jobs}%"] diff --git a/theories/Crypt/Axioms.v b/theories/Crypt/Axioms.v index 6323481e..a1fd0a29 100644 --- a/theories/Crypt/Axioms.v +++ b/theories/Crypt/Axioms.v @@ -1,5 +1,5 @@ Set Warnings "-notation-overridden,-ambiguous-paths". -From mathcomp Require Import all_ssreflect all_algebra reals boolp. +From mathcomp Require Import all_ssreflect all_algebra reals classical.boolp. Set Warnings "notation-overridden,ambiguous-paths". Local Open Scope ring_scope. diff --git a/theories/Crypt/Casts.v b/theories/Crypt/Casts.v new file mode 100644 index 00000000..4efd278c --- /dev/null +++ b/theories/Crypt/Casts.v @@ -0,0 +1,37 @@ +Set Warnings "-ambiguous-paths,-notation-overridden,-notation-incompatible-format". +From mathcomp Require Import ssreflect ssrbool ssrnat choice fintype. +Set Warnings "ambiguous-paths,notation-overridden,notation-incompatible-format". + +From extructures Require Import ord fmap. +From Crypt Require Import Prelude. + +From HB Require Import structures. + + +(** + Note for any of these types it would also be okay to write the cast, e.g., [(nat:choiceType)%type], + directly in the term. + This (backward-compatibility) file just made porting to mathcomp 2.1.0 easier. + Just delete as soon as all references to the below casts are gone from the code base. + *) + +Definition unit_choiceType : choiceType := Datatypes.unit. +Definition nat_choiceType : choiceType := nat. +Definition bool_choiceType : choiceType := bool. +Definition prod_choiceType (A B: choiceType) : choiceType := prod A B. +Definition fmap_choiceType (A: ordType) (B: choiceType) : choiceType := {fmap A -> B}. +Definition option_choiceType (A: choiceType) : choiceType := option A. +Definition fin_choiceType (p: positive) : choiceType := ordinal p.(pos). +Definition sum_choiceType (A B: choiceType) : choiceType := (A + B)%type. + +Definition unit_ordType: ordType := Datatypes.unit. +Definition nat_ordType: ordType := nat. +Definition bool_ordType: ordType := bool. +Definition prod_ordType (A B: ordType) : ordType := prod A B. +Definition fmap_ordType (A B: ordType) : ordType := {fmap A -> B}. +Definition option_ordType (A: ordType) : ordType := option A. +Definition fin_ordType (p: positive) : ordType := ordinal p.(pos). +Definition sum_ordType (A B: ordType) : ordType := (A + B)%type. + + +Definition prod_finType (A B: finType) : finType := prod A B. diff --git a/theories/Crypt/Prelude.v b/theories/Crypt/Prelude.v index df763081..b8fd7e0b 100644 --- a/theories/Crypt/Prelude.v +++ b/theories/Crypt/Prelude.v @@ -180,9 +180,8 @@ Proof. intro h. apply e. inversion h. reflexivity. Qed. -Canonical positive_eqMixin := EqMixin positive_eqP. - Canonical positive_eqType := - Eval hnf in EqType positive positive_eqMixin. +From HB Require Import structures. +HB.instance Definition _ := hasDecEq.Build positive positive_eqP. (** Lt class, for finite types *) @@ -314,4 +313,4 @@ Definition testSome {A} (P : A → bool) (o : option A) : bool := match o with | Some a => P a | None => false - end. \ No newline at end of file + end. diff --git a/theories/Crypt/choice_type.v b/theories/Crypt/choice_type.v index 7217cbf5..2351af91 100644 --- a/theories/Crypt/choice_type.v +++ b/theories/Crypt/choice_type.v @@ -56,37 +56,42 @@ Inductive choice_type := Derive NoConfusion NoConfusionHom for choice_type. -Definition word_ordMixin nbits := [ ordMixin of word nbits by <: ]. -Canonical word_ordType nbits := Eval hnf in OrdType (word nbits) (word_ordMixin nbits). +From HB Require Import structures. + + +#[hnf] HB.instance Definition _ nbits := + [Ord of (word nbits) by <:]. + +(* Check ComRing_sort__canonical__Ord_Ord nbits. *) Fixpoint chElement_ordType (U : choice_type) : ordType := match U with - | chUnit => unit_ordType - | chNat => nat_ordType - | chInt => Z_ordType - | chBool => bool_ordType - | chProd U1 U2 => prod_ordType (chElement_ordType U1) (chElement_ordType U2) - | chMap U1 U2 => fmap_ordType (chElement_ordType U1) (chElement_ordType U2) - | chOption U => option_ordType (chElement_ordType U) - | chFin n => [ordType of ordinal n.(pos) ] - | chWord nbits => word_ordType nbits - | chList U => seq_ordType (chElement_ordType U) - | chSum U1 U2 => sum_ordType (chElement_ordType U1) (chElement_ordType U2) + | chUnit => Datatypes_unit__canonical__Ord_Ord + | chNat => Datatypes_nat__canonical__Ord_Ord + | chInt => BinNums_Z__canonical__Ord_Ord + | chBool => Datatypes_bool__canonical__Ord_Ord + | chProd U1 U2 => Datatypes_prod__canonical__Ord_Ord (chElement_ordType U1) (chElement_ordType U2) + | chMap U1 U2 => FMap_fmap_type__canonical__Ord_Ord (chElement_ordType U1) (chElement_ordType U2) + | chOption U => Datatypes_option__canonical__Ord_Ord (chElement_ordType U) + | chFin n => fintype_ordinal__canonical__Ord_Ord n.(pos) + | chWord nbits => ComRing_sort__canonical__Ord_Ord nbits + | chList U => Datatypes_list__canonical__Ord_Ord (chElement_ordType U) + | chSum U1 U2 => Datatypes_sum__canonical__Ord_Ord (chElement_ordType U1) (chElement_ordType U2) end. Fixpoint chElement (U : choice_type) : choiceType := match U with - | chUnit => unit_choiceType - | chNat => nat_choiceType - | chInt => Z_choiceType - | chBool => bool_choiceType - | chProd U1 U2 => prod_choiceType (chElement U1) (chElement U2) - | chMap U1 U2 => fmap_choiceType (chElement_ordType U1) (chElement U2) - | chOption U => option_choiceType (chElement U) - | chFin n => [choiceType of ordinal n.(pos) ] - | chWord nbits => word_choiceType nbits - | chList U => seq_choiceType (chElement U) - | chSum U1 U2 => sum_choiceType (chElement U1) (chElement U2) + | chUnit => Datatypes_unit__canonical__choice_Choice + | chNat => Datatypes_nat__canonical__choice_Choice + | chInt => BinNums_Z__canonical__choice_Choice + | chBool => Datatypes_bool__canonical__choice_Choice + | chProd U1 U2 => Datatypes_prod__canonical__choice_Choice (chElement U1) (chElement U2) + | chMap U1 U2 => FMap_fmap_type__canonical__choice_Choice (chElement_ordType U1) (chElement U2) + | chOption U => Datatypes_option__canonical__choice_Choice (chElement U) + | chFin n => fintype_ordinal__canonical__choice_Choice n.(pos) + | chWord nbits => ComRing_sort__canonical__Ord_Ord nbits + | chList U => Datatypes_list__canonical__choice_Choice (chElement U) + | chSum U1 U2 => Datatypes_sum__canonical__choice_Choice (chElement U1) (chElement U2) end. Coercion chElement : choice_type >-> choiceType. @@ -126,7 +131,7 @@ Section choice_typeTypes. (* | EqMixin op => op *) (* end. *) - + Fixpoint choice_type_test (u v : choice_type) : bool := match u, v with | chNat , chNat => true @@ -174,7 +179,7 @@ Section choice_typeTypes. + right. congruence. (* chFin *) - destruct (x1 == y1) eqn:e. - + move: e => /eqP e. subst. left. reflexivity. + + move: e => /eqP e. subst. left. reflexivity. + move: e => /eqP e. right. intro h. apply e. inversion h. reflexivity. (* chWord *) @@ -203,9 +208,7 @@ Section choice_typeTypes. - move: e => /choice_type_eqP []. reflexivity. Qed. - Canonical choice_type_eqMixin := EqMixin choice_type_eqP. - Canonical choice_type_eqType := - Eval hnf in EqType choice_type choice_type_eqMixin. + HB.instance Definition _ := hasDecEq.Build choice_type choice_type_eqP. Fixpoint choice_type_lt (t1 t2 : choice_type) := match t1, t2 with @@ -588,9 +591,9 @@ Section choice_typeTypes. intuition auto. move: H0. rewrite H. intuition auto. Qed. - Lemma choice_type_leqP : Ord.axioms choice_type_leq. + Lemma choice_type_leqP : hasOrd.axioms_ choice_type. Proof. - split => //. + apply (hasOrd.Axioms_ choice_type_leq). - intro x. unfold choice_type_leq. apply/orP. left. apply /eqP. reflexivity. - intros v u w h1 h2. @@ -704,12 +707,9 @@ Section choice_typeTypes. - rewrite IHt1. rewrite IHt2. reflexivity. Qed. - Definition choice_type_choiceMixin := PcanChoiceMixin codeK. - Canonical choice_type_choiceType := - ChoiceType choice_type choice_type_choiceMixin. - - Definition choice_type_ordMixin := OrdMixin choice_type_leqP. - Canonical choice_type_ordType := - Eval hnf in OrdType choice_type choice_type_ordMixin. + #[short(type="choice_type_choiceMixin")] + HB.instance Definition _ := PCanHasChoice codeK. + HB.instance Definition _ := + (@hasOrd.Build choice_type (hasOrd.leq choice_type_leqP) (hasOrd.leqxx choice_type_leqP) (@hasOrd.leq_trans _ choice_type_leqP) (@hasOrd.anti_leq _ choice_type_leqP) (hasOrd.leq_total choice_type_leqP)). End choice_typeTypes. diff --git a/theories/Crypt/examples/AsymScheme.v b/theories/Crypt/examples/AsymScheme.v index 139ecb8b..2d65eee1 100644 --- a/theories/Crypt/examples/AsymScheme.v +++ b/theories/Crypt/examples/AsymScheme.v @@ -121,7 +121,7 @@ Module AsymmetricScheme (π : AsymmetricSchemeParams) Definition i_cipher := #|Cipher|. Definition i_pk := #|PubKey|. Definition i_sk := #|SecKey|. - Definition i_bool := 2. + Definition i_bool : nat := 2. Local Open Scope package_scope. @@ -307,8 +307,8 @@ Module AsymmetricScheme (π : AsymmetricSchemeParams) #def #[challenge_id] (mL_mR : 'plain × 'plain) : 'cipher { count ← get counter_loc ;; - #assert (count == 0)%N ;; #put counter_loc := (count + 1)%N;; + #assert (count == 0)%N ;; '(pk, sk) ← KeyGen ;; #put pk_loc := pk ;; #put sk_loc := sk ;; @@ -334,8 +334,8 @@ Module AsymmetricScheme (π : AsymmetricSchemeParams) #def #[challenge_id] (mL_mR : 'plain × 'plain) : 'cipher { count ← get counter_loc ;; - #assert (count == 0)%N ;; #put counter_loc := (count + 1)%N;; + #assert (count == 0)%N ;; '(pk, sk) ← KeyGen ;; #put pk_loc := pk ;; #put sk_loc := sk ;; @@ -387,8 +387,8 @@ Module AsymmetricScheme (π : AsymmetricSchemeParams) #def #[challenge_id'] (m : 'plain) : 'cipher { count ← get counter_loc ;; - #assert (count == 0)%N ;; #put counter_loc := (count + 1)%N;; + #assert (count == 0)%N ;; '(pk, sk) ← KeyGen ;; #put pk_loc := pk ;; #put sk_loc := sk ;; @@ -415,8 +415,8 @@ Module AsymmetricScheme (π : AsymmetricSchemeParams) #def #[challenge_id'] (m : 'plain) : 'cipher { count ← get counter_loc ;; - #assert (count == 0)%N ;; #put counter_loc := (count + 1)%N;; + #assert (count == 0)%N ;; '(pk, sk) ← KeyGen ;; #put pk_loc := pk ;; #put sk_loc := sk ;; diff --git a/theories/Crypt/examples/DDH.v b/theories/Crypt/examples/DDH.v new file mode 100644 index 00000000..2585e24f --- /dev/null +++ b/theories/Crypt/examples/DDH.v @@ -0,0 +1,118 @@ +From Relational Require Import OrderEnrichedCategory GenericRulesSimple. + +Set Warnings "-notation-overridden,-ambiguous-paths,-notation-incompatible-format". +From mathcomp Require Import all_ssreflect all_algebra reals distr + fingroup.fingroup realsum ssrnat ssreflect ssrfun ssrbool ssrnum eqtype choice + seq. +Set Warnings "notation-overridden,ambiguous-paths,notation-incompatible-format". + +From Crypt Require Import Axioms ChoiceAsOrd SubDistr Couplings + UniformDistrLemmas FreeProbProg Theta_dens RulesStateProb UniformStateProb + Package Prelude pkg_composition. + +From Coq Require Import Utf8 Lia. +From extructures Require Import ord fset fmap. + +From Equations Require Import Equations. +Require Equations.Prop.DepElim. + +Set Equations With UIP. + +Set Bullet Behavior "Strict Subproofs". +Set Default Goal Selector "!". +Set Primitive Projections. + +Import Num.Def. +Import Num.Theory. +Import Order.POrderTheory. + +Import PackageNotation. + +#[local] Open Scope ring_scope. +#[local] Open Scope package_scope. +Import GroupScope GRing.Theory. + +Module Type GroupParam. + + Parameter gT : finGroupType. + Definition ζ : {set gT} := [set : gT]. + Parameter g : gT. + Parameter g_gen : ζ = <[g]>. + Parameter prime_order : prime #[g]. + +End GroupParam. + +Module Type DDHParams. + Parameter Space : finType. + Parameter Space_pos : Positive #|Space|. +End DDHParams. + +Module DDH (DDHP : DDHParams) (GP : GroupParam). + + Import DDHP. + Import GP. + + Definition SAMPLE := 0%N. + + #[local] Existing Instance Space_pos. + + Definition GroupSpace : finType := gT. + #[local] Instance GroupSpace_pos : Positive #|GroupSpace|. + Proof. + apply /card_gt0P; by exists g. + (* Needs to be transparent to unify with local positivity proof? *) + Defined. + + Definition chGroup : choice_type := 'fin #|GroupSpace|. + + Definition i_space := #|Space|. + Definition chElem : choice_type := 'fin #|Space|. + + Notation " 'group " := (chGroup) (in custom pack_type at level 2). + + Definition secret_loc1 : Location := (chElem ; 33%N). + Definition secret_loc2 : Location := (chElem ; 34%N). + Definition secret_loc3 : Location := (chElem ; 35%N). + + Definition DDH_locs := + fset [:: secret_loc1 ; secret_loc2 ; secret_loc3]. + + Definition DDH_real : + package DDH_locs [interface] + [interface #val #[ SAMPLE ] : 'unit → 'group × 'group × 'group ] := + [package + #def #[ SAMPLE ] (_ : 'unit) : 'group × 'group × 'group + { + a ← sample uniform i_space ;; + b ← sample uniform i_space ;; + #put secret_loc1 := a ;; + #put secret_loc2 := b ;; + ret (fto (g^+ a), (fto (g^+ b), fto (g^+(a * b)))) + } + ]. + + Definition DDH_E := [interface #val #[ SAMPLE ] : 'unit → 'group × 'group × 'group ]. + + Definition DDH_ideal : + package DDH_locs [interface] DDH_E := + [package + #def #[ SAMPLE ] (_ : 'unit) : 'group × 'group × 'group + { + a ← sample uniform i_space ;; + b ← sample uniform i_space ;; + c ← sample uniform i_space ;; + #put secret_loc1 := a ;; + #put secret_loc2 := b ;; + #put secret_loc3 := c ;; + ret (fto (g^+a), (fto (g^+b), fto (g^+c))) + } + ]. + + Definition DDH : + loc_GamePair [interface #val #[ SAMPLE ] : 'unit → 'group × 'group × 'group ] := + λ b, + if b then {locpackage DDH_real } else {locpackage DDH_ideal }. + + Definition ϵ_DDH := Advantage DDH. + +End DDH. diff --git a/theories/Crypt/examples/ElGamal.v b/theories/Crypt/examples/ElGamal.v index 8e8bbaf1..40a9829b 100644 --- a/theories/Crypt/examples/ElGamal.v +++ b/theories/Crypt/examples/ElGamal.v @@ -79,12 +79,11 @@ Qed. Module MyParam <: AsymmetricSchemeParams. - Definition SecurityParameter : choiceType := nat_choiceType. - Definition Plain : finType := FinGroup.arg_finType gT. - Definition Cipher : finType := - prod_finType (FinGroup.arg_finType gT) (FinGroup.arg_finType gT). - Definition PubKey : finType := FinGroup.arg_finType gT. - Definition SecKey : finType := [finType of 'Z_q]. + Definition SecurityParameter : choiceType := nat. + Definition Plain : finType := gT. + Definition Cipher : finType := prod (gT:finType) (gT:finType). + Definition PubKey : finType := gT. + Definition SecKey : finType := Finite.clone _ 'Z_q. Definition plain0 := g. Definition cipher0 := (g, g). @@ -134,13 +133,13 @@ Module MyAlg <: AsymmetricSchemeAlgorithms MyParam. Definition challenge_id : nat := 8. (*challenge for LR *) Definition challenge_id' : nat := 9. (*challenge for real rnd *) Definition getpk_id : nat := 42. (* routine to get the public key *) + Definition query_id : nat := 10. Definition i_plain := #|Plain|. Definition i_cipher := #|Cipher|. Definition i_pk := #|PubKey|. Definition i_sk := #|SecKey|. - Definition i_bool := 2. - + Definition i_bool : nat := 2. (** Key Generation algorithm *) Definition KeyGen {L : {fset Location}} : @@ -209,9 +208,9 @@ Definition DH_loc := fset [:: pk_loc ; sk_loc]. Definition DH_real : package DH_loc [interface] - [interface #val #[10] : 'unit → 'pubkey × 'cipher ] := + [interface #val #[query_id] : 'unit → 'pubkey × 'cipher ] := [package - #def #[10] (_ : 'unit) : 'pubkey × 'cipher + #def #[query_id] (_ : 'unit) : 'pubkey × 'cipher { a ← sample uniform i_sk ;; let a := otf a in @@ -225,9 +224,9 @@ Definition DH_real : Definition DH_rnd : package DH_loc [interface] - [interface #val #[10] : 'unit → 'pubkey × 'cipher ] := + [interface #val #[query_id] : 'unit → 'pubkey × 'cipher ] := [package - #def #[10] (_ : 'unit) : 'pubkey × 'cipher + #def #[query_id] (_ : 'unit) : 'pubkey × 'cipher { a ← sample uniform i_sk ;; let a := otf a in @@ -243,7 +242,7 @@ Definition DH_rnd : Definition Aux : package (fset [:: counter_loc ; pk_loc ]) - [interface #val #[10] : 'unit → 'pubkey × 'cipher] + [interface #val #[query_id] : 'unit → 'pubkey × 'cipher] [interface #val #[getpk_id] : 'unit → 'pubkey ; #val #[challenge_id'] : 'plain → 'cipher @@ -258,10 +257,10 @@ Definition Aux : #def #[challenge_id'] (m : 'plain) : 'cipher { - #import {sig #[10] : 'unit → 'pubkey × 'cipher } as query ;; + #import {sig #[query_id] : 'unit → 'pubkey × 'cipher } as query ;; count ← get counter_loc ;; - #assert (count == 0)%N ;; #put counter_loc := (count + 1)%N ;; + #assert (count == 0)%N ;; '(pk, c) ← query Datatypes.tt ;; @ret chCipher (fto ((otf c).1 , (otf m) * ((otf c).2))) } @@ -278,8 +277,8 @@ Proof. - eapply rpost_weaken_rule. 1: eapply rreflexivity_rule. move => [a1 h1] [a2 h2] [Heqa Heqh]. intuition auto. - ssprove_sync_eq. intro count. - ssprove_sync_eq. move => /eqP e. subst. ssprove_sync_eq. + ssprove_sync_eq. move => /eqP e. subst. ssprove_sync_eq. intro a. ssprove_swap_lhs 0%N. ssprove_sync_eq. @@ -390,9 +389,13 @@ Proof. cbn. intros [? ?] [? ?] e. inversion e. intuition auto. - ssprove_sync_eq. intro count. ssprove_sync_eq. - intros h. - ssprove_sync_eq. - ssprove_sync_eq. intros a. + destruct count. + 2:{ + cbn. eapply rpost_weaken_rule. 1: eapply rreflexivity_rule. + cbn. intros [? ?] [? ?] e. inversion e. intuition auto. + } + simpl. + ssprove_sync_eq. intro a. ssprove_swap_rhs 1%N. ssprove_swap_rhs 0%N. ssprove_sync_eq. @@ -407,10 +410,10 @@ Proof. simpl. intros x. unfold f'. set (z := ch2prod x). clearbody z. clear x. destruct z as [x y]. simpl. - rewrite !otf_fto. - eapply r_ret. - intros s ? e. - subst. simpl. easy. + eapply r_ret. intros s ? e. subst. + intuition auto. + rewrite !otf_fto. simpl. + reflexivity. Qed. Theorem ElGamal_OT : @@ -475,7 +478,7 @@ End ElGamal. Module EGP_Z3 <: ElGamalParam. - Definition gT : finGroupType := Zp_finGroupType 2. + Definition gT : finGroupType := 'Z_2. Definition ζ : {set gT} := [set : gT]. Definition g : gT := Zp1. diff --git a/theories/Crypt/examples/KEMDEM.v b/theories/Crypt/examples/KEMDEM.v index 4cb33ffc..9df1e822 100644 --- a/theories/Crypt/examples/KEMDEM.v +++ b/theories/Crypt/examples/KEMDEM.v @@ -316,9 +316,7 @@ Section KEMDEM. #assert (isSome sk) as skSome ;; let sk := getSome sk skSome in ek ← get ek_loc ;; - #assert (isSome ek) as ekSome ;; - let ek := getSome ek ekSome in - #assert (ek != ek') ;; + #assert (ek != Some ek') ;; ret (η.(KEM_decap) sk ek') } ]. @@ -406,9 +404,7 @@ Section KEMDEM. #def #[ DEC ] (c' : 'cipher) : 'plain { #import {sig #[ GET ] : 'unit → 'key } as GET ;; c ← get c_loc ;; - #assert (isSome c) as cSome ;; - let c := getSome c cSome in - #assert (c != c') ;; + #assert (c != Some c') ;; k ← GET Datatypes.tt ;; ret (θ.(DEM_dec) k c') } @@ -490,12 +486,8 @@ Section KEMDEM. #assert (isSome sk) as skSome ;; let sk := getSome sk skSome in ek ← get ek_loc ;; - #assert (isSome ek) as ekSome ;; - let ek := getSome ek ekSome in c ← get c_loc ;; - #assert (isSome c) as cSome ;; - let c := getSome c cSome in - #assert ((ek, c) != c') ;; + #assert ((ek, c) != (Some c'.1, Some c'.2)) ;; ret (ζ.(PKE_dec) sk c') } ]. @@ -550,13 +542,9 @@ Section KEMDEM. pk ← get pk_loc ;; #assert (isSome pk) ;; ek ← get ek_loc ;; - #assert (isSome ek) as ekSome ;; - let ek := getSome ek ekSome in c ← get c_loc ;; - #assert (isSome c) as cSome ;; - let c := getSome c cSome in - #assert ((ek, c) != (ek', c')) ;; - if ek == ek' + #assert ((ek, c) != (Some ek', Some c')) ;; + if ek == Some ek' then ( DEC c' ) @@ -616,7 +604,7 @@ Section KEMDEM. as ineq. eapply le_trans. 1: exact ineq. clear ineq. - eapply ler_add. + eapply lerD. (* Idealising the core keying package *) - replace (par CK₀ CD₀) with ((par (ID EK) CD₀) ∘ (par CK₀ (ID IGET))). 2:{ @@ -708,7 +696,7 @@ Section KEMDEM. as ineq. eapply le_trans. 1: exact ineq. clear ineq. - eapply ler_add. + eapply lerD. - eapply single_key_a. all: eauto. (* De-idealising the core keying package *) - replace (par CK₀ CD₁) with ((par (ID EK) CD₁) ∘ (par CK₀ (ID IGET))). @@ -944,11 +932,7 @@ Section KEMDEM. ssprove_swap_seq_rhs [:: 1 ; 0 ]%N. ssprove_swap_seq_lhs [:: 1 ; 0 ]%N. eapply r_get_vs_get_remember_rhs. 1: ssprove_invariant. intros ek. - ssprove_swap_seq_rhs [:: 1 ; 0 ]%N. - ssprove_swap_seq_lhs [:: 1 ; 0 ]%N. - ssprove_sync. intro ekSome. - destruct ek as [ek|]. 2: discriminate. - simpl. destruct (ek == ek') eqn:eek. + destruct (ek == Some ek') eqn:eek. + rewrite eek. ssprove_code_simpl_more. ssprove_code_simpl. ssprove_code_simpl_more. eapply r_get_remember_rhs. intro pk. @@ -962,16 +946,13 @@ Section KEMDEM. intro eps. eapply sameSomeRel_sameSome in eps as eps'. rewrite eps'. ssprove_sync. intro skSome. - ssprove_swap_seq_rhs [:: 2 ; 1 ; 0 ]%N. + ssprove_swap_seq_rhs [:: 1 ]%N. ssprove_contract_get_rhs. ssprove_sync. intro c. - ssprove_sync. intro cSome. - destruct c as [c|]. 2: discriminate. - simpl. - ssprove_sync. intro ee. - move: ee => /eqP ee. - move: eek => /eqP eek. subst ek'. - destruct (c != c') eqn:e. + ssprove_sync. intro neq. + move: neq => /eqP neq. + move: eek => /eqP eek. subst ek. + destruct (c != Some c') eqn:e. 2:{ move: e => /eqP e. subst. contradiction. } rewrite e. simpl. eapply r_get_remember_rhs. intro k. @@ -984,11 +965,10 @@ Section KEMDEM. ssprove_forget_all. apply r_ret. auto. + rewrite eek. ssprove_code_simpl_more. - ssprove_swap_seq_rhs [:: 6 ; 5 ; 4 ; 3 ; 2 ; 1 ; 0 ]%N. + ssprove_swap_seq_rhs [:: 5 ; 4 ; 3 ; 2 ; 1 ; 0 ]%N. eapply r_get_remind_rhs. 1: exact _. - simpl. ssprove_forget. - ssprove_swap_seq_rhs [:: 4 ; 3 ; 2 ; 1 ; 0 ]%N. + ssprove_swap_seq_rhs [:: 3 ; 2 ; 1 ; 0 ]%N. apply r_get_vs_get_remember. 1: ssprove_invariant. intros sk. apply r_get_remember_rhs. intro pk. eapply (r_rem_couple_lhs pk_loc sk_loc). 1,3: exact _. @@ -997,19 +977,11 @@ Section KEMDEM. ssprove_forget_all. ssprove_sync. intro skSome. ssprove_sync. intro c. - ssprove_sync. intro cSome. ssprove_sync. intro ee. destruct sk as [sk|]. 2: discriminate. simpl. - destruct c as [c|]. 2: discriminate. - simpl in ee. rewrite eek. simpl. - eapply @r_reflexivity_alt with (L := fset0). - * ssprove_valid. - * intros ℓ hℓ. eapply fromEmpty. eauto. - * intros ℓ v hℓ. eapply fromEmpty. eauto. - (* These remaining opsig are quite odd *) - Unshelve. all: exact ({sig #[ 0%N ] : 'unit → 'unit }). + apply r_ret. auto. Qed. Corollary PKE_CCA_perf_true : @@ -1093,4 +1065,4 @@ Section KEMDEM. all: fdisjoint_auto. Qed. -End KEMDEM. \ No newline at end of file +End KEMDEM. diff --git a/theories/Crypt/examples/OTP.v b/theories/Crypt/examples/OTP.v index 78e3315e..8cf2f8c5 100644 --- a/theories/Crypt/examples/OTP.v +++ b/theories/Crypt/examples/OTP.v @@ -63,9 +63,9 @@ Section OTP_example. Definition N_pos : Positive N := _. - Definition Words : finType := [finType of 'Z_N]. + Definition Words : finType := Finite.clone _ 'Z_N. - Definition Key : finType := [finType of 'Z_N]. + Definition Key : finType := Finite.clone _ 'Z_N. Definition w0 : Words := 0. diff --git a/theories/Crypt/examples/PRF.v b/theories/Crypt/examples/PRF.v index 5ecc3a7e..1487be96 100644 --- a/theories/Crypt/examples/PRF.v +++ b/theories/Crypt/examples/PRF.v @@ -184,7 +184,6 @@ Section PRF_example. Definition i_key : nat := 2^n. Definition i_words : nat := 2^n. - (* why does this allow an arbitrary set of Locations? Why not fset0? *) Definition enc {L : { fset Location }} (m : Words) (k : Key) : code L [interface] ('fin (2^n) × 'fin (2^n)) := {code @@ -200,7 +199,6 @@ Section PRF_example. ret k }. - (* why does this not use fset0 for its Locations? *) Definition dec (c : Words) (k : Key) : code (fset [:: key_location; table_location]) diff --git a/theories/Crypt/examples/Schnorr.v b/theories/Crypt/examples/Schnorr.v index 56f58da7..07b30635 100644 --- a/theories/Crypt/examples/Schnorr.v +++ b/theories/Crypt/examples/Schnorr.v @@ -50,13 +50,13 @@ Definition q : nat := #[g]. Module MyParam <: SigmaProtocolParams. - Definition Witness : finType := [finType of 'Z_q]. - Definition Statement : finType := FinGroup.arg_finType gT. - Definition Message : finType := FinGroup.arg_finType gT. - Definition Challenge : finType := [finType of 'Z_q]. - Definition Response : finType := [finType of 'Z_q]. - Definition Transcript := - prod_finType (prod_finType Message Challenge) Response. + Definition Witness : finType := Finite.clone _ 'Z_q. + Definition Statement : finType := gT. + Definition Message : finType := gT. + Definition Challenge : finType := Finite.clone _ 'Z_q. + Definition Response : finType := Finite.clone _ 'Z_q. + Definition Transcript : finType := + prod (prod Message Challenge) Response. Definition w0 : Witness := 0. Definition e0 : Challenge := 0. @@ -79,7 +79,7 @@ Module MyParam <: SigmaProtocolParams. Definition Message_pos : Positive #|Message| := _. Definition Challenge_pos : Positive #|Challenge| := _. Definition Response_pos : Positive #|Response| := _. - Definition Bool_pos : Positive #|bool_choiceType|. + Definition Bool_pos : Positive #|'bool|. Proof. rewrite card_bool. done. Defined. @@ -101,7 +101,7 @@ Module MyAlg <: SigmaProtocolAlgorithms MyParam. chProd (chProd (chProd choiceStatement choiceMessage) choiceChallenge) choiceResponse. - Definition choiceBool := 'fin #|bool_choiceType|. + Definition choiceBool := 'fin #|'bool|. Definition i_witness := #|Witness|. @@ -144,6 +144,8 @@ Module MyAlg <: SigmaProtocolAlgorithms MyParam. (z : choiceResponse) (z' : choiceResponse) : 'option choiceWitness := Some (fto ((otf z - otf z') / (otf e - otf e'))). + Definition KeyGen (w : choiceWitness) := fto (g ^+ w). + End MyAlg. @@ -283,7 +285,7 @@ Proof. Qed. Lemma neq_pos : - ∀ (q : nat) (a b : Zp_finZmodType q), + ∀ (q : nat) (a b : ('Z_q:finZmodType)), a != b → a - b != 0. Proof. @@ -303,34 +305,21 @@ Qed. protocol is perfectly indistinguishable from real protocol execution. *) Lemma extractor_success: - ∀ LA A LAdv Adv, + ∀ LA A, ValidPackage LA [interface - #val #[ SOUNDNESS ] : chStatement → 'bool + #val #[ SOUNDNESS ] : chSoundness → 'bool ] A_export A → - ValidPackage LAdv [interface] [interface - #val #[ ADV ] : chStatement → chSoundness - ] Adv → - fdisjoint LA (Sigma_locs :|: LAdv) → - ɛ_soundness A Adv = 0. + ɛ_soundness A = 0. Proof. - intros LA A LAdv Adv VA VAdv Hdisj. + intros LA A VA. apply: eq_rel_perf_ind_eq. - 2,3: apply Hdisj. + 2,3: apply fdisjoints0. simplify_eq_rel h. - (* This program is composed with abstract adversarial code. *) - (* We need to ensure that the composition is valid. *) - destruct (Adv ADV) as [[? []]|]. - 2:{ apply r_ret. auto. } - repeat destruct choice_type_eqP. - 2,3: apply r_ret ; auto. - apply rsame_head. intros [s [[s0 s3] [s1 s2]]]. - ssprove_code_simpl. simpl. - match goal with - | |- context [ if ?b then _ else _ ] => case b eqn:rel - end. - 2: apply r_ret ; intuition auto. - apply r_ret. - intros. intuition auto. + destruct h as [h [s [s0 [s1 [s2 ?]]]]]. + destruct s0 as [s0 s3]. + case [&& _ & _] eqn:rel. + all: apply r_ret; auto. + intros h1 h2 ->. (* Algebraic proof that the produced witness satisfies the relation. *) unfold R. unfold "&&" in rel. @@ -343,7 +332,7 @@ Proof. rewrite otf_fto in rel. apply reflection_nonsense in rel. apply reflection_nonsense in Heqs4. - rewrite H1. + rewrite H0. rewrite otf_fto expg_mod. 2: rewrite order_ge1 ; apply expg_order. rewrite expgM expg_mod. @@ -381,8 +370,7 @@ Proof. (modn (addn (@nat_of_ord (S (S (Zp_trunc q))) (@otf Challenge s0)) (@nat_of_ord (S (S (Zp_trunc q))) - (@GRing.opp (FinRing.Zmodule.zmodType (Zp_finZmodType (S (Zp_trunc q)))) - (@otf Challenge s1)))) q) = + (GRing.opp (@otf Challenge s1)))) q) = (@nat_of_ord (S (S (Zp_trunc q))) (@Zp_add (S (Zp_trunc q)) (@otf Challenge s0) (@Zp_opp (S (Zp_trunc q)) (@otf Challenge s1)))). { simpl. @@ -403,18 +391,18 @@ Proof. have -> : (modn (muln (@nat_of_ord (S (S (Zp_trunc q))) - (@GRing.inv (FinRing.UnitRing.unitRingType (Zp_finUnitRingType (Zp_trunc q))) - (@GRing.add (FinRing.Zmodule.zmodType (Zp_finZmodType (S (Zp_trunc q)))) + (GRing.inv + (GRing.add (@otf Challenge s0) - (@GRing.opp (FinRing.Zmodule.zmodType (Zp_finZmodType (S (Zp_trunc q)))) + (GRing.opp (@otf Challenge s1))))) (@nat_of_ord (S (S (Zp_trunc q))) (@Zp_add (S (Zp_trunc q)) (@otf Challenge s0) (@Zp_opp (S (Zp_trunc q)) (@otf Challenge s1))))) q) = (Zp_mul - (@GRing.inv (FinRing.UnitRing.unitRingType (Zp_finUnitRingType (Zp_trunc q))) - (@GRing.add (FinRing.Zmodule.zmodType (Zp_finZmodType (S (Zp_trunc q)))) + (GRing.inv + (GRing.add (@otf Challenge s0) - (@GRing.opp (FinRing.Zmodule.zmodType (Zp_finZmodType (S (Zp_trunc q)))) + (GRing.opp (@otf Challenge s1)))) (@Zp_add (S (Zp_trunc q)) (@otf Challenge s0) (@Zp_opp (S (Zp_trunc q)) (@otf Challenge s1)))). { simpl. @@ -442,111 +430,331 @@ Qed. Lemma hiding_adv : ∀ LA A, - ValidPackage LA [interface - #val #[ HIDING ] : chInput → chMessage - ] A_export A → + ValidPackage LA Hiding_E A_export (A ∘ par KEY (ID Hiding_E)) → fdisjoint LA Com_locs → - fdisjoint LA Sigma_locs → + (* fdisjoint LA Sigma_locs → *) + fdisjoint LA KEY_locs → ɛ_hiding A = 0. Proof. - intros LA A Va Hdisj0 Hdisj1. + intros LA A Va Hdisj0 Hdisj2. unfold ɛ_hiding. + apply: eq_rel_perf_ind_eq. + + (* eapply eq_rel_perf_ind_ignore. *) + (* 1,2: exact _. *) + (* 1:{ *) + (* ssprove_invariant. *) + (* unfold Sigma_locs. *) + (* rewrite !fset0U. *) + (* apply fsubsetU. *) + (* apply /orP. left. *) + (* apply fsubsetU. *) + (* apply /orP. left. *) + (* apply fsubsetU. *) + (* apply /orP. left. *) + (* apply fsubsetxx. *) + (* } *) + 2,3: rewrite ?fset0U ; unfold Sigma_locs + ; repeat rewrite fdisjointUr + ; repeat (apply /andP ; split) + ; (exact Hdisj0 || exact Hdisj2 || apply fdisjoints0). + (* 2: apply Va. *) + + simplify_eq_rel hwe. + ssprove_code_simpl. + ssprove_code_simpl_more. + simplify_linking. + destruct hwe as [h w]. + + apply r_const_sample_R. + 1: apply LosslessOp_uniform. + intros e_temp. + + apply r_const_sample_L. + 1: apply LosslessOp_uniform. + intros [ [] ? ] ; [ simpl; clear i | discriminate ]. + + simpl. + set (r := getm _ _). + destruct r ; [ | apply r_ret ; auto]. + destruct t, s. + destruct (choice_type_eqP _ _) ; [ | apply r_ret ; auto]. + destruct (choice_type_eqP _ _) ; [ | apply r_ret ; auto]. + subst. + + rewrite !cast_fun_K. + rewrite (@ord_inj #|'Z_q| h e_temp). + 2:{ + destruct h, e_temp ; simpl. + admit. + } + + replace _ with (eq : choiceMessage * heap → choiceMessage * heap → Prop). + 1:{ + apply (rreflexivity_rule (x0 ← r e_temp ;; ret x0)). + } + apply functional_extensionality. intros []. + apply functional_extensionality. intros []. + admit. +Admitted. + +(* Main theorem proving that the Schnorr protocol has perfect hiding. *) +Theorem schnorr_com_hiding : + ∀ LA A, + ValidPackage LA [interface + #val #[HIDING] : (chChallenge) × (chChallenge) → chMessage + ] A_export (A ∘ par KEY (ID Hiding_E)) -> + fdisjoint LA KEY_locs -> + fdisjoint LA Sigma_to_Com_locs -> + fdisjoint LA (fset [:: setup_loc]) -> + fdisjoint LA Sigma_locs -> + fdisjoint LA Simulator_locs -> + ɛ_hiding A <= 0. +Proof. + intros LA A VA Hd1 Hd2 Hd3 Hd4 Hd5. + eapply Order.le_trans. + 1: eapply commitment_hiding with (LA := LA). + all: try assumption. + 1: apply fdisjoint0s. + { + unfold Sigma_locs. + unfold commit_loc. + unfold statement_loc. + unfold witness_loc. + rewrite !fset_cons. + rewrite -fset0E. + rewrite fdisjointUr ; apply /andP ; split. + - rewrite fdisjoints1. + rewrite fset1E. + rewrite fsetU0. + rewrite -fset1E. + unfold "\notin". + rewrite in_fset1. + case (_ == _) eqn:e. + 2: done. + move: e => /eqP. + done. + - rewrite fdisjointUr ; apply /andP ; split. + + rewrite fdisjoints1. + rewrite fset1E. + rewrite fsetU0. + rewrite -fset1E. + unfold "\notin". + rewrite in_fset1. + case (_ == _) eqn:e. + 2: done. + move: e => /eqP. + done. + + apply fdisjoints0. + } + rewrite addr0. + rewrite add0r. + erewrite schnorr_SHVZK. + 2: { + ssprove_valid. + 1: instantiate (1 := (LA :|: (setup_loc |: Sigma_to_Com_locs))). + 3: apply fsubsetxx. + 2: apply fsub0set. + - apply fsubsetUl. + - apply fsubsetU ; apply /orP ; right. + apply fsubsetxx. + } + 2: { + (* unfold Sigma_locs. *) + unfold Sigma_to_Com_locs. + unfold Simulator_locs. + rewrite fsetU0. + rewrite fdisjointUl ; apply /andP ; split. + - assumption. + - unfold Sigma_locs. + rewrite fdisjointUl ; apply /andP ; split. + + rewrite fdisjoint1s. + unfold "\notin". + rewrite -fset1E. + rewrite in_fset1. + done. + + unfold Com_locs. + rewrite fset_cons. + rewrite fdisjointUl ; apply /andP ; split. + ++ rewrite fdisjoint1s. + rewrite -fset1E. + unfold "\notin". + rewrite in_fset1. + done. + ++ + rewrite -!fset1E. + rewrite fdisjoint1s. + unfold "\notin". + rewrite in_fset1. + done. + } + rewrite Advantage_sym. + erewrite schnorr_SHVZK. + 2: { + ssprove_valid. + 1: instantiate (1 := (LA :|: (setup_loc |: Sigma_to_Com_locs))). + 3: apply fsubsetxx. + 2: apply fsub0set. + - apply fsubsetUl. + - apply fsubsetU ; apply /orP ; right. + apply fsubsetxx. + } + 2: { + (* unfold Sigma_locs. *) + unfold Sigma_to_Com_locs. + unfold Simulator_locs. + rewrite fsetU0. + rewrite fdisjointUl ; apply /andP ; split. + - assumption. + - unfold Sigma_locs. + rewrite fdisjointUl ; apply /andP ; split. + + rewrite fdisjoint1s. + unfold "\notin". + rewrite -fset1E. + rewrite in_fset1. + done. + + unfold Com_locs. + rewrite fset_cons. + rewrite fdisjointUl ; apply /andP ; split. + ++ rewrite fdisjoint1s. + rewrite -fset1E. + unfold "\notin". + rewrite in_fset1. + done. + ++ + rewrite -!fset1E. + rewrite fdisjoint1s. + unfold "\notin". + rewrite in_fset1. + done. + } + rewrite addr0 add0r. + apply eq_ler. eapply eq_rel_perf_ind. 1,2: exact _. 1:{ instantiate (1 := (heap_ignore Com_locs)). ssprove_invariant. - unfold Sigma_locs. + unfold Sigma_to_Com_locs. rewrite !fset0U. - apply fsubsetU. - apply /orP. left. - apply fsubsetU. - apply /orP. left. + apply fsubsetU; apply /orP; left. + apply fsubsetU; apply /orP; left. + apply fsubsetU; apply /orP; right. + apply fsubsetU; apply /orP; left. apply fsubsetxx. } - 3,4: - rewrite ?fset0U ; unfold Sigma_locs; - repeat rewrite fdisjointUr ; - apply /andP ; split ; eassumption. - 2: apply Va. + 2: apply VA. + 3: { + rewrite fset0U. + rewrite fdisjointUr ; apply /andP ; split. + 2: assumption. + rewrite fdisjointUr ; apply /andP ; split. + 2: assumption. + rewrite fset1E. assumption. + } + 2: { + rewrite fset0U. + rewrite fdisjointUr ; apply /andP ; split. + 2: assumption. + rewrite fdisjointUr ; apply /andP ; split. + 2: assumption. + rewrite fset1E. assumption. + } + rewrite Sigma_to_Com_Aux_equation_1. simplify_eq_rel hwe. ssprove_code_simpl. simplify_linking. - destruct hwe as [[h w] e]. + destruct hwe as [e e']. apply r_const_sample_R. 1: apply LosslessOp_uniform. - intros e'. + intros e_rand. rewrite !cast_fun_K. ssprove_code_simpl. ssprove_code_simpl_more. - ssprove_sync_eq=> rel. - ssprove_sync=> x. - ssprove_contract_put_get_lhs. - ssprove_contract_put_get_rhs. - eapply r_put_vs_put. - eapply r_put_vs_put. - eapply r_put_vs_put. - ssprove_restore_pre. 1: ssprove_invariant. - apply r_ret. intuition auto. + apply r_const_sample_L. + 1: apply LosslessOp_uniform. + intros b. + simpl. + case (Nat.even b) eqn:hb. + - rewrite hb ; clear hb. + ssprove_code_simpl. + ssprove_code_simpl_more. + ssprove_code_simpl. + ssprove_code_simpl_more. + ssprove_sync=>setup. + apply r_assertD. + 1: done. + intros _ _. + ssprove_sync=> w. + apply r_assertD. + 1: done. + intros _ _. + ssprove_sync. + apply r_assertD. + 1: done. + intros _ rel. + ssprove_sync=>x. + ssprove_contract_put_get_lhs. + ssprove_contract_put_get_rhs. + eapply r_put_vs_put. + eapply r_put_vs_put. + eapply r_put_vs_put. + ssprove_restore_pre. 1: ssprove_invariant. + apply r_ret. intuition auto. + - rewrite hb ; clear hb. + ssprove_code_simpl. + ssprove_code_simpl_more. + ssprove_code_simpl. + ssprove_code_simpl_more. + ssprove_sync=>setup. + apply r_assertD. + 1: done. + intros _ _. + ssprove_sync=> w. + apply r_assertD. + 1: done. + intros _ _. + ssprove_sync. + apply r_assertD. + 1: done. + intros _ rel. + ssprove_sync=>x. + ssprove_contract_put_get_lhs. + ssprove_contract_put_get_rhs. + eapply r_put_vs_put. + eapply r_put_vs_put. + eapply r_put_vs_put. + ssprove_restore_pre. 1: ssprove_invariant. + apply r_ret. intuition auto. Qed. -(* Main theorem proving that the Schnorr protocol has perfect hiding. *) -Theorem schnorr_com_hiding : - ∀ LA A, - ValidPackage LA [interface - #val #[ HIDING ] : chInput → chMessage - ] A_export A → - fdisjoint LA Com_locs → - fdisjoint LA Sigma_locs → - AdvantageE (Hiding_real ∘ Sigma_to_Com ∘ SHVZK_ideal) (Hiding_ideal ∘ Sigma_to_Com ∘ SHVZK_ideal) A <= 0. -Proof. - intros LA A Va Hdisj0 Hdisj1. - have H := commitment_hiding LA A 0 Va. - rewrite !GRing.addr0 in H. - have HS := schnorr_SHVZK _ _ _. - rewrite hiding_adv in H. - 2,3: assumption. - apply AdvantageE_le_0 in H. - 1: rewrite H ; trivial. - intros B Vb. - have -> := HS _ B Vb. - 2:{ erewrite fdisjointUl. - apply /andP. - split. - - assumption. - - unfold Com_locs, Sigma_locs. - rewrite -fset1E. - rewrite fdisjoints1. - in_fset_auto. } - done. -Qed. (* Main theorem *) (* The commitment scheme instantiated from Schnorr' protocol *) (* is binding equal to the hardness of the relation *) (* (I.e. how hard is it to produce a valid witness for a fixed public input)*) Theorem schnorr_com_binding : - ∀ LA A LAdv Adv, + ∀ LA A, ValidPackage LA [interface - #val #[ SOUNDNESS ] : chStatement → 'bool + #val #[ SOUNDNESS ] : chSoundness → 'bool ] A_export A → - ValidPackage LAdv [interface] [interface - #val #[ ADV ] : chStatement → chSoundness - ] Adv → - fdisjoint LA (Sigma_locs :|: LAdv) → - AdvantageE (Com_Binding ∘ Adv) (Special_Soundness_f ∘ Adv) A <= 0. + fdisjoint LA (Sigma_to_Com_locs :|: KEY_locs) → + AdvantageE (Com_Binding ∘ Sigma_to_Com ∘ KEY) (Special_Soundness_f) A <= 0. Proof. - intros LA A LAdv Adv VA VAdv Hdisj. - have H := commitment_binding LA A LAdv Adv VA VAdv Hdisj. - rewrite extractor_success in H. 2: apply Hdisj. - apply H. + intros LA A VA Hdisj. + eapply Order.le_trans. + 1: apply Advantage_triangle. + instantiate (1 := Special_Soundness_t). + rewrite (commitment_binding LA A VA Hdisj). + setoid_rewrite (extractor_success LA A VA). + now setoid_rewrite GRing.isNmodule.add0r. Qed. End Schnorr. Module GP_Z3 <: GroupParam. - Definition gT : finGroupType := Zp_finGroupType 2. + Definition gT : finGroupType := 'Z_2. Definition ζ : {set gT} := [set : gT]. Definition g : gT := Zp1. diff --git a/theories/Crypt/examples/SigmaProtocol.v b/theories/Crypt/examples/SigmaProtocol.v index f1183cf4..d31d5df0 100644 --- a/theories/Crypt/examples/SigmaProtocol.v +++ b/theories/Crypt/examples/SigmaProtocol.v @@ -3,7 +3,8 @@ From Relational Require Import OrderEnrichedCategory GenericRulesSimple. Set Warnings "-notation-overridden,-ambiguous-paths". From mathcomp Require Import all_ssreflect all_algebra reals distr realsum - ssrnat ssreflect ssrfun ssrbool ssrnum eqtype choice seq. + fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool ssrnum + eqtype choice seq. Set Warnings "notation-overridden,ambiguous-paths". From Crypt Require Import Axioms ChoiceAsOrd SubDistr Couplings @@ -44,7 +45,7 @@ Module Type SigmaProtocolParams. Parameter Message_pos : Positive #|Message|. Parameter Challenge_pos : Positive #|Challenge|. Parameter Response_pos : Positive #|Response|. - Parameter Bool_pos : Positive #|bool_choiceType|. + Parameter Bool_pos : Positive #|'bool|. End SigmaProtocolParams. @@ -68,9 +69,10 @@ Module Type SigmaProtocolAlgorithms (π : SigmaProtocolParams). Definition choiceResponse := 'fin #|Response|. Definition choiceTranscript := chProd (chProd (chProd choiceStatement choiceMessage) choiceChallenge) choiceResponse. - Definition choiceBool := 'fin #|bool_choiceType|. + Definition choiceBool := 'fin #|'bool|. Parameter Sigma_locs : {fset Location}. + Parameter Simulator_locs : {fset Location}. Parameter Commit : @@ -97,6 +99,8 @@ Module Type SigmaProtocolAlgorithms (π : SigmaProtocolParams). (z : choiceResponse) (z' : choiceResponse), 'option choiceWitness. + Parameter KeyGen : ∀ (w : choiceWitness), choiceStatement. + End SigmaProtocolAlgorithms. Module SigmaProtocol (π : SigmaProtocolParams) @@ -107,20 +111,27 @@ Module SigmaProtocol (π : SigmaProtocolParams) Notation " 'chStatement' " := choiceStatement (in custom pack_type at level 2). + Notation " 'chWitness' " := + choiceWitness (in custom pack_type at level 2). + Notation " 'chChallenge' " := + choiceChallenge (in custom pack_type at level 2). Notation " 'chRelation' " := (chProd choiceStatement choiceWitness) (in custom pack_type at level 2). + Definition choiceInput := (chProd (chProd choiceStatement choiceWitness) choiceChallenge). Notation " 'chInput' " := - (chProd (chProd choiceStatement choiceWitness) choiceChallenge) + choiceInput (in custom pack_type at level 2). Notation " 'chMessage' " := choiceMessage (in custom pack_type at level 2). Notation " 'chTranscript' " := choiceTranscript (in custom pack_type at level 2). Definition Opening := chProd choiceChallenge choiceResponse. Notation " 'chSoundness' " := - (chProd choiceMessage (chProd Opening Opening)) + (chProd choiceStatement (chProd choiceMessage (chProd Opening Opening))) (in custom pack_type at level 2). Definition i_challenge := #|Challenge|. + Definition i_witness := #|Witness|. + Definition TRANSCRIPT : nat := 0. Definition COM : nat := 1. Definition VER : nat := 2. @@ -133,7 +144,14 @@ Module SigmaProtocol (π : SigmaProtocolParams) apply Challenge_pos. Qed. + Definition i_witness_pos : Positive i_witness. + Proof. + unfold i_witness. + apply Witness_pos. + Qed. + #[local] Existing Instance i_challenge_pos. + #[local] Existing Instance i_witness_pos. #[local] Open Scope package_scope. @@ -172,15 +190,14 @@ Module SigmaProtocol (π : SigmaProtocolParams) Definition ɛ_SHVZK A := AdvantageE SHVZK_real SHVZK_ideal A. Definition Special_Soundness_f : - package Sigma_locs - [interface #val #[ ADV ] : chStatement → chSoundness ] - [interface #val #[ SOUNDNESS ] : chStatement → 'bool ] + package fset0 + [interface] + [interface #val #[ SOUNDNESS ] : chSoundness → 'bool ] := [package - #def #[ SOUNDNESS ] (h : chStatement) : 'bool + #def #[ SOUNDNESS ] (t : chSoundness) : 'bool { - #import {sig #[ ADV ] : chStatement → chSoundness } as A ;; - '(a, ((e, z), (e', z'))) ← A h ;; + let '(h, (a, ((e, z), (e', z')))) := t in let v1 := Verify h a e z in let v2 := Verify h a e' z' in if [&& (e != e') , (otf v1) & (otf v2) ] then @@ -193,15 +210,14 @@ Module SigmaProtocol (π : SigmaProtocolParams) ]. Definition Special_Soundness_t : - package Sigma_locs - [interface #val #[ ADV ] : chStatement → chSoundness ] - [interface #val #[ SOUNDNESS ] : chStatement → 'bool ] + package fset0 + [interface] + [interface #val #[ SOUNDNESS ] : chSoundness → 'bool ] := [package - #def #[ SOUNDNESS ] (h : chStatement) : 'bool + #def #[ SOUNDNESS ] (t : chSoundness) : 'bool { - #import {sig #[ ADV ] : chStatement → chSoundness } as A ;; - '(a, ((e, z), (e', z'))) ← A(h) ;; + let '(h, (a, ((e, z), (e', z')))) := t in let v1 := Verify h a e z in let v2 := Verify h a e' z' in ret [&& (e != e') , (otf v1) & (otf v2) ] @@ -209,8 +225,8 @@ Module SigmaProtocol (π : SigmaProtocolParams) ]. (* Main security statement for 2-special soundness. *) - Definition ɛ_soundness A Adv := - AdvantageE (Special_Soundness_t ∘ Adv) (Special_Soundness_f ∘ Adv) A. + Definition ɛ_soundness A := + AdvantageE Special_Soundness_t Special_Soundness_f A. (**************************************) (* Start of Commitment Scheme Section *) @@ -219,15 +235,24 @@ Module SigmaProtocol (π : SigmaProtocolParams) Definition HIDING : nat := 5. Definition OPEN : nat := 6. + Definition INIT : nat := 7. + Definition GET : nat := 8. Definition challenge_loc : Location := ('option choiceChallenge; 7%N). Definition response_loc : Location := ('option choiceResponse; 8%N). Definition Com_locs : {fset Location} := - fset [:: challenge_loc ; response_loc]. + fset [:: challenge_loc ; response_loc ]. + + + Definition setup_loc : Location := ('bool; 10%N). + Definition statement_loc : Location := (choiceStatement; 11%N). + Definition witness_loc : Location := (choiceWitness; 12%N). + Definition KEY_locs : {fset Location} := fset [:: setup_loc; witness_loc ; statement_loc]. Definition choiceOpen := (chProd choiceChallenge choiceResponse). Notation " 'chOpen' " := choiceOpen (in custom pack_type at level 2). + Notation " 'chKeys' " := (chProd choiceStatement choiceWitness) (in custom pack_type at level 2). Lemma in_fset_left l (L1 L2 : {fset Location}) : is_true (l \in L1) → @@ -242,24 +267,67 @@ Module SigmaProtocol (π : SigmaProtocolParams) apply in_fset_left; solve [auto_in_fset] : typeclass_instances ssprove_valid_db. - Definition Sigma_to_Com: - package Com_locs - [interface #val #[ TRANSCRIPT ] : chInput → chTranscript] + Definition KEY: + package KEY_locs + [interface] + [interface + #val #[ INIT ] : 'unit → 'unit ; + #val #[ GET ] : 'unit → chStatement + ] + := + [package + #def #[ INIT ] (_ : 'unit) : 'unit + { + b ← get setup_loc ;; + #assert (negb b) ;; + w ← sample uniform i_witness ;; + let h := KeyGen w in + #assert (R (otf h) (otf w)) ;; + #put setup_loc := true ;; + #put statement_loc := h ;; + #put witness_loc := w ;; + @ret 'unit Datatypes.tt + } + ; + #def #[ GET ] (_ : 'unit) : chStatement + { + b ← get setup_loc ;; + if b then + h ← get statement_loc ;; + w ← get witness_loc ;; + ret h + else + fail + } + ]. + + Definition Sigma_to_Com_locs := (Com_locs :|: Simulator_locs). + + #[tactic=notac] Equations? Sigma_to_Com: + package Sigma_to_Com_locs [interface - #val #[ COM ] : chInput → chMessage ; + #val #[ INIT ] : 'unit → 'unit ; + #val #[ GET ] : 'unit → chStatement + ] + [interface + #val #[ COM ] : chChallenge → chMessage ; #val #[ OPEN ] : 'unit → chOpen ; #val #[ VER ] : chTranscript → 'bool ] - := + := Sigma_to_Com := [package - #def #[ COM ] (hwe : chInput) : chMessage + #def #[ COM ] (e : chChallenge) : chMessage { - #import {sig #[ TRANSCRIPT ] : chInput → chTranscript } as run ;; - '(h,a,e,z) ← run hwe ;; + #import {sig #[ INIT ] : 'unit → 'unit } as key_gen_init ;; + #import {sig #[ GET ] : 'unit → chStatement } as key_gen_get ;; + _ ← key_gen_init Datatypes.tt ;; + h ← key_gen_get Datatypes.tt ;; + '(h,a,e,z) ← Simulate h e ;; #put challenge_loc := Some e ;; #put response_loc := Some z ;; ret a - } ; + } + ; #def #[ OPEN ] (_ : 'unit) : chOpen { o_e ← get challenge_loc ;; @@ -276,23 +344,98 @@ Module SigmaProtocol (π : SigmaProtocolParams) ret (otf (Verify h a e z)) } ]. + Proof. + unfold Sigma_to_Com_locs. + ssprove_valid. + eapply valid_injectLocations. + 1: apply fsubsetUr. + eapply valid_injectMap. + 2: apply (Simulate x1 x). + rewrite -fset0E. + apply fsub0set. + Qed. + + #[tactic=notac] Equations? Sigma_to_Com_Aux: + package (setup_loc |: Sigma_to_Com_locs) + [interface + #val #[ TRANSCRIPT ] : chInput → chTranscript + ] + [interface + #val #[ COM ] : chChallenge → chMessage ; + #val #[ OPEN ] : 'unit → chOpen ; + #val #[ VER ] : chTranscript → 'bool + ] + := Sigma_to_Com_Aux := + [package + #def #[ COM ] (e : chChallenge) : chMessage + { + #import {sig #[ TRANSCRIPT ] : chInput → chTranscript } as RUN ;; + b ← get setup_loc ;; + #assert (negb b) ;; + w ← sample uniform i_witness ;; + let h := KeyGen w in + #assert (R (otf h) (otf w)) ;; + #put setup_loc := true ;; + '(h, a, e, z) ← RUN (h, w, e) ;; + #put challenge_loc := Some e ;; + #put response_loc := Some z ;; + @ret choiceMessage a + } + ; + #def #[ OPEN ] (_ : 'unit) : chOpen + { + o_e ← get challenge_loc ;; + o_z ← get response_loc ;; + match (o_e, o_z) with + | (Some e, Some z) => @ret choiceOpen (e, z) + | _ => fail + end + } + ; + #def #[ VER ] (t : chTranscript) : 'bool + { + let '(h,a,e,z) := t in + ret (otf (Verify h a e z)) + } + ]. + Proof. + unfold Sigma_to_Com_locs, Com_locs. + ssprove_valid. + all: rewrite in_fsetU ; apply /orP ; right. + all: rewrite in_fsetU ; apply /orP ; left. + all: rewrite !fset_cons. + 1,3 : rewrite in_fsetU ; apply /orP ; left ; rewrite in_fset1 ; done. + 1,2 : rewrite in_fsetU ; apply /orP ; right ; + rewrite in_fsetU ; apply /orP ; left ; + rewrite in_fset1 ; done. + Qed. + + Notation " 'chHiding' " := (chProd choiceChallenge choiceChallenge) (in custom pack_type at level 2). + + Definition Hiding_E := [interface #val #[ HIDING ] : chHiding → chMessage ]. (* Commitment to input value*) - Definition Hiding_real : + Definition Hiding_real: package fset0 [interface - #val #[ COM ] : chInput → chMessage ; + #val #[ COM ] : chChallenge → chMessage ; #val #[ OPEN ] : 'unit → chOpen ; #val #[ VER ] : chTranscript → 'bool ] - [interface #val #[ HIDING ] : chInput → chMessage ] + Hiding_E := [package - #def #[ HIDING ] (hwe : chInput) : chMessage + #def #[ HIDING ] (ms : chHiding) : chMessage { - #import {sig #[ COM ] : chInput → chMessage } as com ;; - a ← com hwe ;; - ret a + #import {sig #[ COM ] : chChallenge → chMessage } as com ;; + let '(m1, m2) := ms in + b ← sample uniform 1 ;; + if Nat.even b then + a ← com m1 ;; + ret a + else + a ← com m2 ;; + ret a } ]. @@ -300,131 +443,362 @@ Module SigmaProtocol (π : SigmaProtocolParams) Definition Hiding_ideal : package fset0 [interface - #val #[ COM ] : chInput → chMessage ; + #val #[ COM ] : chChallenge → chMessage ; #val #[ OPEN ] : 'unit → chOpen ; #val #[ VER ] : chTranscript → 'bool ] - [interface #val #[ HIDING ] : chInput → chMessage] + Hiding_E := [package - #def #[ HIDING ] (hwe : chInput) : chMessage + #def #[ HIDING ] (_ : chHiding) : chMessage { - #import {sig #[ COM ] : chInput → chMessage } as com ;; - let '(h,w,_) := hwe in + #import {sig #[ COM ] : chChallenge → chMessage } as com ;; e ← sample uniform i_challenge ;; - t ← com (h,w,e) ;; + t ← com e ;; ret t } ]. Definition ɛ_hiding A := AdvantageE - (Hiding_real ∘ Sigma_to_Com ∘ SHVZK_real) - (Hiding_ideal ∘ Sigma_to_Com ∘ SHVZK_real) A. + (Hiding_real ∘ Sigma_to_Com ∘ KEY) + (Hiding_ideal ∘ Sigma_to_Com ∘ KEY) (A ∘ (par KEY (ID Hiding_E))). + + Notation inv := ( + heap_ignore (fset [:: statement_loc ; witness_loc]) + ). + + Instance Invariant_inv : Invariant (Sigma_to_Com_locs :|: KEY_locs) (setup_loc |: Sigma_to_Com_locs) inv. + Proof. + ssprove_invariant. + unfold KEY_locs. + apply fsubsetU ; apply /orP ; left. + apply fsubsetU ; apply /orP ; right. + rewrite !fset_cons. + apply fsubsetU ; apply /orP ; right. + rewrite fsubUset ; apply /andP ; split. + - apply fsubsetU ; apply /orP ; right. + apply fsubsetU ; apply /orP ; left. + apply fsubsetxx. + - apply fsubsetU ; apply /orP ; left. + rewrite fsubUset ; apply /andP ; split. + + apply fsubsetxx. + + rewrite -fset0E. apply fsub0set. + Qed. + + Hint Extern 50 (_ = code_link _ _) => + rewrite code_link_scheme + : ssprove_code_simpl. Theorem commitment_hiding : - ∀ LA A eps, + ∀ LA A, ValidPackage LA [interface - #val #[ HIDING ] : chInput → chMessage - ] A_export A → - (∀ B, - ValidPackage (LA :|: Com_locs) [interface - #val #[ TRANSCRIPT ] : chInput → chTranscript - ] A_export B → - ɛ_SHVZK B <= eps - ) → - AdvantageE - (Hiding_real ∘ Sigma_to_Com ∘ SHVZK_ideal) - (Hiding_ideal ∘ Sigma_to_Com ∘ SHVZK_ideal) A - <= - (ɛ_hiding A) + eps + eps. + #val #[ HIDING ] : chHiding → chMessage + ] A_export (A ∘ (par KEY (ID Hiding_E))) → + fdisjoint LA KEY_locs -> + fdisjoint LA Sigma_to_Com_locs -> + fdisjoint LA (fset [:: setup_loc]) -> + fdisjoint LA Sigma_locs -> + fdisjoint LA Simulator_locs -> + fdisjoint Simulator_locs (fset [:: statement_loc ; witness_loc]) -> + fdisjoint Sigma_locs (fset [:: statement_loc ; witness_loc]) -> + (ɛ_hiding A) <= 0 + + AdvantageE SHVZK_ideal SHVZK_real (((A ∘ par KEY (ID Hiding_E)) ∘ Hiding_real) ∘ Sigma_to_Com_Aux) + + AdvantageE (Hiding_real ∘ Sigma_to_Com_Aux ∘ SHVZK_real) + (Hiding_ideal ∘ Sigma_to_Com_Aux ∘ SHVZK_real) (A ∘ par KEY (ID Hiding_E)) + + AdvantageE SHVZK_real SHVZK_ideal (((A ∘ par KEY (ID Hiding_E)) ∘ Hiding_ideal) ∘ Sigma_to_Com_Aux) + + 0. Proof. unfold ɛ_hiding, ɛ_SHVZK. - intros LA A eps Va Hadv. - ssprove triangle (Hiding_real ∘ Sigma_to_Com ∘ SHVZK_ideal) [:: - (Hiding_real ∘ Sigma_to_Com ∘ SHVZK_real) ; - (Hiding_ideal ∘ Sigma_to_Com ∘ SHVZK_real) - ] (Hiding_ideal ∘ Sigma_to_Com ∘ SHVZK_ideal) A + intros LA A VA Hd1 Hd2 Hd3 HdSigma HdSimulator Hd4 Hd5. + ssprove triangle (Hiding_real ∘ Sigma_to_Com ∘ KEY) [:: + (Hiding_real ∘ Sigma_to_Com_Aux ∘ SHVZK_ideal) ; + (Hiding_real ∘ Sigma_to_Com_Aux ∘ SHVZK_real) ; + (Hiding_ideal ∘ Sigma_to_Com_Aux ∘ SHVZK_real) ; + (Hiding_ideal ∘ Sigma_to_Com_Aux ∘ SHVZK_ideal) + ] (Hiding_ideal ∘ Sigma_to_Com ∘ KEY) (A ∘ (par KEY (ID Hiding_E))) as ineq. eapply le_trans. 1: exact ineq. clear ineq. - rewrite <- !Advantage_link. - eapply ler_add. - - rewrite GRing.addrC. eapply ler_add. 1: apply lexx. - specialize (Hadv (A ∘ Hiding_real ∘ Sigma_to_Com)). - rewrite <- link_assoc. rewrite Advantage_sym. - apply Hadv. ssprove_valid. - + apply fsub0set. - + apply fsubsetxx. - + apply fsubsetUl. - + apply fsubsetUr. - - specialize (Hadv (A ∘ Hiding_ideal ∘ Sigma_to_Com)). - rewrite <- link_assoc. - apply Hadv. ssprove_valid. - + apply fsub0set. - + apply fsubsetxx. - + apply fsubsetUl. - + apply fsubsetUr. + repeat eapply lerD. + - apply eq_ler. + eapply eq_rel_perf_ind with (inv := inv). + 5: apply VA. + 1:{ + ssprove_valid. + 3: apply fsub0set. + 3: apply fsubsetxx. + 1: instantiate (1 := (Sigma_to_Com_locs :|: KEY_locs)). + 1: apply fsubsetUl. + 1: apply fsubsetUr. + } + 1:{ + ssprove_valid. + 1: apply fsubsetxx. + 2: apply fsub0set. + 2: apply fsubsetxx. + unfold Sigma_to_Com_locs. + apply fsubsetU ; apply /orP ; right. + apply fsubsetUr. + } + 3,4: rewrite fdisjointUr ; apply /andP ; split. + 3-4,6: assumption. + 3: rewrite fset1E ; assumption. + 1: exact _. + rewrite Sigma_to_Com_equation_1. + rewrite Sigma_to_Com_Aux_equation_1. + simplify_eq_rel h. + ssprove_code_simpl. + destruct h. + ssprove_code_simpl. + ssprove_code_simpl_more. + ssprove_sync=>b. + case (Nat.even b) eqn:Hb ; rewrite Hb. + + ssprove_sync=> setup. + ssprove_code_simpl. + ssprove_code_simpl_more. + apply r_assertD. + 1: done. + intros _ _. + ssprove_sync=> w. + apply r_assertD. + 1: done. + intros _ Rel. + ssprove_swap_seq_lhs [:: 2 ; 1]%N. + ssprove_contract_put_get_lhs. + rewrite !cast_fun_K. + rewrite Rel. + ssprove_code_simpl. + ssprove_code_simpl_more. + ssprove_sync. + ssprove_swap_lhs 1%N. + ssprove_contract_put_get_lhs. + ssprove_swap_seq_lhs [:: 0 ; 1]%N. + ssprove_contract_put_get_lhs. + apply r_put_lhs. + apply r_put_lhs. + ssprove_restore_pre. + 1: ssprove_invariant. + eapply rsame_head_alt. + 1: exact _. + { + unfold inv. + intros l lin h1 s' h2. + apply h2. + move: Hd4 => /fdisjointP Hd4. + apply Hd4. + apply lin. + } + { + unfold inv. + intros l v lin. + apply put_pre_cond_heap_ignore. + } + intros t. + destruct t. + destruct s1. + destruct s1. + ssprove_sync. + ssprove_sync. + apply r_ret. + done. + + ssprove_sync=>setup. + ssprove_code_simpl. + ssprove_code_simpl_more. + apply r_assertD. + 1: done. + intros _ _. + ssprove_sync=>w. + apply r_assertD. + 1: done. + intros _ Rel. + ssprove_swap_seq_lhs [:: 2 ; 1]%N. + ssprove_contract_put_get_lhs. + rewrite !cast_fun_K. + rewrite Rel. + ssprove_code_simpl. + ssprove_code_simpl_more. + ssprove_sync. + ssprove_swap_lhs 1%N. + ssprove_contract_put_get_lhs. + ssprove_swap_seq_lhs [:: 0 ; 1]%N. + ssprove_contract_put_get_lhs. + apply r_put_lhs. + apply r_put_lhs. + ssprove_restore_pre. + 1: ssprove_invariant. + eapply rsame_head_alt. + 1: exact _. + { + unfold inv. + intros l lin h1 s' h2. + apply h2. + move: Hd4 => /fdisjointP Hd4. + apply Hd4. + apply lin. + } + { + unfold inv. + intros l v lin. + apply put_pre_cond_heap_ignore. + } + intros t. + destruct t. + destruct s1. + destruct s1. + ssprove_sync. + ssprove_sync. + apply r_ret. + done. + - rewrite -!Advantage_link. + 1: apply eq_ler ; done. + - done. + - rewrite -!Advantage_link. + 1: apply eq_ler ; done. + - apply eq_ler. + eapply eq_rel_perf_ind with (inv := inv). + 5: apply VA. + 1:{ + ssprove_valid. + 4: apply fsubsetxx. + 3: apply fsub0set. + 2: instantiate (1 := (Simulator_locs :|: (setup_loc |: Sigma_to_Com_locs))). + - apply fsubsetUr. + - apply fsubsetUl. + } + 1:{ + ssprove_valid. + 3: apply fsub0set. + 3: apply fsubsetxx. + 1: instantiate (1 := (Sigma_to_Com_locs :|: KEY_locs)). + - apply fsubsetUl. + - apply fsubsetUr. + } + 3,4: rewrite fdisjointUr ; apply /andP ; split. + 4: rewrite fdisjointUr ; apply /andP ; split. + 3,5-7: assumption. + 3: rewrite fset1E ; assumption. + { + ssprove_invariant. + unfold KEY_locs. + apply fsubsetU ; apply /orP ; right. + apply fsubsetU ; apply /orP ; right. + rewrite !fset_cons. + apply fsubsetU ; apply /orP ; right. + rewrite fsubUset ; apply /andP ; split. + - apply fsubsetU ; apply /orP ; right. + apply fsubsetU ; apply /orP ; left. + apply fsubsetxx. + - apply fsubsetU ; apply /orP ; left. + rewrite fsubUset ; apply /andP ; split. + + apply fsubsetxx. + + rewrite -fset0E. apply fsub0set. + } + rewrite Sigma_to_Com_equation_1. + rewrite Sigma_to_Com_Aux_equation_1. + simplify_eq_rel h. + ssprove_code_simpl. + destruct h. + ssprove_code_simpl. + ssprove_code_simpl_more. + ssprove_sync=>e. + ssprove_sync=> setup. + ssprove_code_simpl. + ssprove_code_simpl_more. + apply r_assertD. + 1: done. + intros _ _. + ssprove_sync=> w. + apply r_assertD. + 1: done. + intros _ Rel. + ssprove_swap_seq_rhs [:: 2 ; 1]%N. + ssprove_contract_put_get_rhs. + rewrite !cast_fun_K. + rewrite Rel. + ssprove_code_simpl. + ssprove_code_simpl_more. + ssprove_sync. + ssprove_swap_rhs 1%N. + ssprove_contract_put_get_rhs. + ssprove_swap_seq_rhs [:: 0 ; 1]%N. + ssprove_contract_put_get_rhs. + apply r_put_rhs. + apply r_put_rhs. + ssprove_restore_pre. + 1: ssprove_invariant. + eapply rsame_head_alt. + 1: exact _. + { + unfold inv. + intros l lin h1 s' h2. + apply h2. + move: Hd4 => /fdisjointP Hd4. + apply Hd4. + apply lin. + } + { + unfold inv. + intros l v lin. + apply put_pre_cond_heap_ignore. + } + intros t. + destruct t. + destruct s1. + destruct s1. + ssprove_sync. + ssprove_sync. + apply r_ret. + done. Qed. - Definition Com_Binding : - package Sigma_locs - [interface #val #[ ADV ] : chStatement → chSoundness ] - [interface #val #[ SOUNDNESS ] : chStatement → 'bool ] + Definition Com_Binding: + package fset0 + [interface + #val #[ COM ] : chChallenge → chMessage ; + #val #[ OPEN ] : 'unit → chOpen ; + #val #[ VER ] : chTranscript → 'bool + ] + [interface #val #[ SOUNDNESS ] : chSoundness → 'bool ] := [package - #def #[ SOUNDNESS ] (h : chStatement) : 'bool + #def #[ SOUNDNESS ] (t : chSoundness) : 'bool { - #import {sig #[ ADV ] : chStatement → chSoundness} as A ;; - '(a, ((e, z), (e', z'))) ← A h ;; - let v1 := Verify h a e z in - let v2 := Verify h a e' z' in - ret [&& (e != e') , (otf v1) & (otf v2) ] + #import {sig #[ VER ] : chTranscript → 'bool } as Ver ;; + let '(h, (a, ((e, z), (e', z')))) := t in + v1 ← Ver (h, a, e, z) ;; + v2 ← Ver (h, a, e', z') ;; + ret [&& (e != e'), v1 & v2] } ]. Lemma commitment_binding : - ∀ LA A LAdv Adv, + ∀ LA A, ValidPackage LA [interface - #val #[ SOUNDNESS ] : chStatement → 'bool + #val #[ SOUNDNESS ] : chSoundness → 'bool ] A_export A → - ValidPackage LAdv [interface] [interface - #val #[ ADV ] : chStatement → chSoundness - ] Adv → - fdisjoint LA (Sigma_locs :|: LAdv) → - AdvantageE (Com_Binding ∘ Adv) (Special_Soundness_f ∘ Adv) A <= - ɛ_soundness A Adv. + fdisjoint LA (Sigma_to_Com_locs :|: KEY_locs) → + AdvantageE (Com_Binding ∘ Sigma_to_Com ∘ KEY) (Special_Soundness_t) A = 0. Proof. - intros LA A LAdv Adv VA VAdv Hdisj. - ssprove triangle (Com_Binding ∘ Adv) [:: - (Special_Soundness_t ∘ Adv) - ] (Special_Soundness_f ∘ Adv) A as ineq. - eapply le_trans. 1: exact ineq. - clear ineq. - rewrite ger_addr. - apply eq_ler. + intros LA A VA Hdisj. eapply eq_rel_perf_ind_eq. 4: apply VA. 1:{ - eapply valid_link. 2: apply VAdv. - ssprove_valid. - } - 1:{ - eapply valid_link. 2: apply VAdv. ssprove_valid. + 3: apply fsub0set. + 1: instantiate (1 := (Sigma_to_Com_locs :|: KEY_locs)). + 2: apply fsubsetUr. + 1: apply fsubsetUl. + apply fsubsetxx. } - 2,3: assumption. + 1: ssprove_valid. + 2: assumption. + 2: apply fdisjoints0. + rewrite Sigma_to_Com_equation_1. simplify_eq_rel h. - - destruct (Adv ADV) as [[? []]|]. - 2:{ apply r_ret. intuition auto. } - - repeat destruct choice_type_eqP. - 2:{ apply r_ret. intuition auto. } - 2:{ apply r_ret. intuition auto. } - ssprove_code_simpl. - apply rsame_head. intros [? [[] []]]. + simpl. + destruct h, s0, s1, s1, s2. apply r_ret. auto. Qed. @@ -432,11 +806,10 @@ Module SigmaProtocol (π : SigmaProtocolParams) (* This section aim to prove an automatic conversation between the sampling of the random challenge and a random oracle. *) (* The main difference is that the random oracle is a query parametrized by the context of the execution. *) - Import RandomOracle. Module OracleParams <: ROParams. - Definition Query := prod_finType Statement Message. + Definition Query := Datatypes_prod__canonical__fintype_Finite Statement Message. Definition Random := Challenge. Definition Query_pos : Positive #|Query|. @@ -457,8 +830,12 @@ Module SigmaProtocol (π : SigmaProtocolParams) Section FiatShamir. - Definition RUN : nat := 6. - Definition VERIFY : nat := 7. + Definition RUN : nat := 7. + Definition VERIFY : nat := 8. + Definition SIM : nat := 9. + + Context (Sim_locs : {fset Location}). + Context (Sim : choiceStatement → code Sim_locs [interface] choiceTranscript). Definition prod_assoc : chProd choiceStatement choiceMessage → chQuery. Proof. @@ -468,7 +845,7 @@ Module SigmaProtocol (π : SigmaProtocolParams) Qed. (* TW: I moved it here because it might induce back-tracking and we want to - avoid it because of time-consumption. + avoid it because of time-consumption. *) Hint Extern 20 (ValidCode ?L ?I ?c.(prog)) => eapply valid_injectMap ; [| eapply c.(prog_valid) ] @@ -507,6 +884,33 @@ Module SigmaProtocol (π : SigmaProtocolParams) } ]. + Definition Fiat_Shamir_SIM : + package Sim_locs + [interface + #val #[ QUERY ] : 'query → 'random + ] + [interface + #val #[ VERIFY ] : chTranscript → 'bool ; + #val #[ RUN ] : chRelation → chTranscript + ] + := + [package + #def #[ VERIFY ] (t : chTranscript) : 'bool + { + #import {sig #[ QUERY ] : 'query → 'random } as RO_query ;; + let '(h,a,e,z) := t in + e ← RO_query (prod_assoc (h, a)) ;; + ret (otf (Verify h a e z)) + } ; + #def #[ RUN ] (hw : chRelation) : chTranscript + { + let '(h,w) := hw in + #assert (R (otf h) (otf w)) ;; + t ← Sim h ;; + ret t + } + ]. + Definition RUN_interactive : package Sigma_locs [interface] diff --git a/theories/Crypt/examples/concrete_groups.v b/theories/Crypt/examples/concrete_groups.v index a7c2874e..82b50cb0 100644 --- a/theories/Crypt/examples/concrete_groups.v +++ b/theories/Crypt/examples/concrete_groups.v @@ -6,7 +6,7 @@ Set Warnings "-notation-overridden,-ambiguous-paths,-notation-incompatible-forma From mathcomp Require Import all_ssreflect fingroup.fingroup fintype eqtype choice seq. Set Warnings "notation-overridden,ambiguous-paths,notation-incompatible-format". - +From HB Require Import structures. From deriving Require Import deriving. Set Bullet Behavior "Strict Subproofs". @@ -42,29 +42,45 @@ Module Z2_manual. ltac:(move => [|] [|]; try solve [ right ; discriminate ]; try solve [ left ; reflexivity ]). +(* Definition Z2_eqMixin := EqMixin Z2_eqP. Canonical Z2_eqType : eqType := Eval hnf in EqType Z2 Z2_eqMixin. +*) + Definition Z2_hasDecEq := hasDecEq.Build Z2 Z2_eqP. + HB.instance Definition _ := Z2_hasDecEq. Definition Z2_pickle x : nat := match x with z => 0 | o => 1 end. Definition Z2_unpickle (x : nat) := match x with 0 => Some z | 1 => Some o | _ => None end. Lemma Z2_p_u_cancel : @pcancel nat Z2 Z2_pickle Z2_unpickle. Proof. move => [|] //. Qed. + (* Definition Z2_choiceMixin := PcanChoiceMixin Z2_p_u_cancel. Canonical Z2_choiceType := ChoiceType Z2 Z2_choiceMixin. + *) + HB.instance Definition _ := Choice.copy Z2 (pcan_type Z2_p_u_cancel). + (* Definition Z2_countMixin := @choice.Countable.Mixin Z2 Z2_pickle Z2_unpickle Z2_p_u_cancel. Canonical Z2_countType := Eval hnf in CountType Z2 Z2_countMixin. + *) + Definition Z2_hasCountable := isCountable.Build Z2 Z2_p_u_cancel. + HB.instance Definition _ := Z2_hasCountable. Definition Z2_enum : seq Z2 := [:: z; o]. Lemma Z2_enum_uniq : uniq Z2_enum. Proof. reflexivity. Qed. Lemma mem_Z2_enum i : i \in Z2_enum. Proof. destruct i; reflexivity. Qed. + + (* Definition Z2_finMixin := Eval hnf in UniqFinMixin Z2_enum_uniq mem_Z2_enum. Canonical Z2_finType := Eval hnf in FinType Z2 Z2_finMixin. + *) + Definition Z2_isFinite := isFinite.Build Z2 (Finite.uniq_enumP Z2_enum_uniq mem_Z2_enum). + HB.instance Definition _ := Z2_isFinite. Lemma assoc_add : associative add. Proof. move => [|] [|] [|] //. Qed. @@ -75,16 +91,26 @@ Module Z2_manual. Lemma Z2_invgM : {morph inv : a b / add a b >-> add b a}. Proof. move => [|] [|] //. Qed. + (* Definition Z2_finGroupBaseMixin := FinGroup.BaseMixin assoc_add lid inv_inv Z2_invgM. Canonical Z2_BaseFinGroupType := BaseFinGroupType Z2 Z2_finGroupBaseMixin. + *) + + Definition Z2_isMulBaseGroup := isMulBaseGroup.Build Z2 assoc_add lid inv_inv Z2_invgM. + HB.instance Definition _ := Z2_isMulBaseGroup. Definition linv : left_inverse z inv add. Proof. move => [|] //. Qed. + (* Canonical Z2_finGroup : finGroupType := FinGroupType linv. + *) + + Definition Z2_BaseFinGroup_isGroup := BaseFinGroup_isGroup.Build Z2 linv. + HB.instance Definition _ := Z2_BaseFinGroup_isGroup. End Z2_manual. @@ -104,17 +130,30 @@ Module Z2_bool. Lemma bool_invgM : {morph invb : a b / addb a b >-> addb b a}. Proof. move => [|] [|] //. Qed. + (* Definition bool_finGroupBaseMixin := FinGroup.BaseMixin assoc_addb lidb inv_invb bool_invgM. Canonical bool_BaseFinGroupType := BaseFinGroupType bool bool_finGroupBaseMixin. + *) + + Definition bool_isMulBaseGroup := isMulBaseGroup.Build bool assoc_addb lidb inv_invb bool_invgM. + HB.instance Definition _ := bool_isMulBaseGroup. + Definition linvb : left_inverse false invb addb. Proof. move => [|] //. Qed. + (* Canonical bool_finGroup : finGroupType := FinGroupType linvb. + *) + + Definition bool_BaseFinGroup_isGroup := BaseFinGroup_isGroup.Build bool linvb. + HB.instance Definition _ := bool_BaseFinGroup_isGroup. + End Z2_bool. +(* TODO Section Z3_deriving. (* Construction of Z3 using deriving but not the fingroup mixin. *) Inductive Z3 := z | o | t. @@ -159,7 +198,9 @@ Section Z3_deriving. Canonical Z3_finGroup : finGroupType := FinGroupType linv. End Z3_deriving. +*) +(* TODO Is this still needed? - Update or delete. Module Z2. (* Minimal (?) construction of Z2 using the fingroup mixin. *) Definition invb x : bool := x. @@ -172,7 +213,9 @@ Module Z2. Canonical bool_finGroup := BaseFinGroupType _ (FinGroup.Mixin assoc_xorb lidb linvb). Canonical Z2_finGroup : finGroupType := FinGroupType linvb. End Z2. +*) +(* TODO Module Z3. (* Z3 using the fingroup mixin and deriving. *) Inductive Z3 := z | o | t. @@ -208,3 +251,4 @@ Module Z3. Canonical Z3_BaseFinGroupType := BaseFinGroupType _ (FinGroup.Mixin assoc_add lid linv). Canonical Z3_finGroup : finGroupType := FinGroupType linv. End Z3. +*) diff --git a/theories/Crypt/examples/package_usage_example.v b/theories/Crypt/examples/package_usage_example.v index 875f9499..1a5d04ce 100644 --- a/theories/Crypt/examples/package_usage_example.v +++ b/theories/Crypt/examples/package_usage_example.v @@ -59,10 +59,10 @@ Definition p1 : package fset0 [interface] I1 := } ]. -Definition foo (x : bool) : code fset0 [interface] bool_choiceType := +Definition foo (x : bool) : code fset0 [interface] bool := {code let u := x in ret u}. -Definition bar (b : bool) : code fset0 [interface] nat_choiceType := +Definition bar (b : bool) : code fset0 [interface] nat := {code if b then ret 0 else ret 1}. Definition p2 : package fset0 [interface] I2 := @@ -117,12 +117,13 @@ Definition sig := {sig #[0] : 'nat → 'nat }. } ; #def #[2] (_ : 'unit) : 'option ('fin 2) { #put ('nat ; 0) := 0 ;; - ret (Some (gfin 2)) + ret (Some (gfin 1)) } ; #def #[3] (m : {map 'nat → 'nat}) : 'option 'nat { ret (getm m 0) } ]. +Admit Obligations. (* Testing the #import notation *) Definition test₃ : diff --git a/theories/Crypt/package/pkg_advantage.v b/theories/Crypt/package/pkg_advantage.v index eab271fd..2914d74c 100644 --- a/theories/Crypt/package/pkg_advantage.v +++ b/theories/Crypt/package/pkg_advantage.v @@ -83,7 +83,7 @@ Definition Pr_op (p : raw_package) (o : opsig) (x : src o) : Arguments SDistr_bind {_ _}. Definition Pr (p : raw_package) : - SDistr (bool_choiceType) := + SDistr (Datatypes_bool__canonical__choice_Choice) := SDistr_bind (λ '(b, _), SDistr_unit _ b) (Pr_op p RUN Datatypes.tt empty_heap). @@ -152,7 +152,7 @@ Qed. *) : package_scope. *) Definition state_pass_ {A} (p : raw_code A) : - heap_choiceType → raw_code (prod_choiceType A heap_choiceType). + heap_choiceType → raw_code (Datatypes_prod__canonical__choice_Choice A heap_choiceType). Proof. induction p; intros h. - constructor. @@ -274,6 +274,75 @@ Proof. unfold AdvantageE. rewrite !link_assoc. reflexivity. Qed. +Lemma Advantage_par_empty : + ∀ G₀ G₁ A, + AdvantageE (par emptym G₀) (par emptym G₁) A = AdvantageE G₀ G₁ A. +Proof. + intros G₀ G₁ A. + unfold AdvantageE. + rewrite distrC. + reflexivity. +Qed. + +Lemma Advantage_par : + ∀ G₀ G₁ G₁' A L₀ L₁ L₁' E₀ E₁, + ValidPackage L₀ Game_import E₀ G₀ → + ValidPackage L₁ Game_import E₁ G₁ → + ValidPackage L₁' Game_import E₁ G₁' → + flat E₁ → + trimmed E₀ G₀ → + trimmed E₁ G₁ → + trimmed E₁ G₁' → + AdvantageE (par G₀ G₁) (par G₀ G₁') A = + AdvantageE G₁ G₁' (A ∘ par G₀ (ID E₁)). +Proof. + intros G₀ G₁ G₁' A L₀ L₁ L₁' E₀ E₁. + intros Va0 Va1 Va1' Fe0 Te0 Te1 Te1'. + replace (par G₀ G₁) with ((par G₀ (ID E₁)) ∘ (par (ID Game_import) G₁)). + 2:{ + erewrite <- interchange. + all: ssprove_valid. + 4:{ + ssprove_valid. + rewrite domm_ID_fset. + rewrite -fset0E. + apply fdisjoint0s. + } + 2:{ unfold Game_import. rewrite -fset0E. discriminate. } + 2: apply trimmed_ID. + rewrite link_id. + 2:{ unfold Game_import. rewrite -fset0E. discriminate. } + 2: assumption. + rewrite id_link. + 2: assumption. + reflexivity. + } + replace (par G₀ G₁') with ((par G₀ (ID E₁)) ∘ (par (ID Game_import) G₁')). + 2:{ + erewrite <- interchange. + all: ssprove_valid. + 4:{ + ssprove_valid. + rewrite domm_ID_fset. + rewrite -fset0E. + apply fdisjoint0s. + } + 2:{ unfold Game_import. rewrite -fset0E. discriminate. } + 2: apply trimmed_ID. + rewrite link_id. + 2:{ unfold Game_import. rewrite -fset0E. discriminate. } + 2: assumption. + rewrite id_link. + 2: assumption. + reflexivity. + } + rewrite -Advantage_link. + unfold Game_import. rewrite -fset0E. + rewrite Advantage_par_empty. + reflexivity. + Unshelve. all: auto. +Qed. + Lemma Advantage_sym : ∀ P Q A, AdvantageE P Q A = AdvantageE Q P A. @@ -397,4 +466,4 @@ Ltac ssprove_triangle_as p₀ l p₁ A ineq := Tactic Notation "ssprove" "triangle" constr(p₀) constr(l) constr(p₁) constr(A) "as" ident(ineq) := - ssprove_triangle_as p₀ l p₁ A ineq. \ No newline at end of file + ssprove_triangle_as p₀ l p₁ A ineq. diff --git a/theories/Crypt/package/pkg_composition.v b/theories/Crypt/package/pkg_composition.v index aef005cf..9dcaecec 100644 --- a/theories/Crypt/package/pkg_composition.v +++ b/theories/Crypt/package/pkg_composition.v @@ -431,7 +431,7 @@ Section fset_par_facts. - cbn. symmetry. apply h. auto. - cbn. reflexivity. } - rewrite h1. reflexivity. + rewrite h1. rewrite eqseqE. now rewrite eq_refl. Qed. End fset_par_facts. @@ -912,7 +912,7 @@ Proof. Qed. Lemma getm_def_in : - ∀ {A : eqType} n (x : A) (s : seq (nat_eqType * A)), + ∀ {A : eqType} n (x : A) (s : seq (Datatypes_nat__canonical__eqtype_Equality * A)), getm_def s n = Some x → (n,x) \in s. Proof. @@ -1106,4 +1106,4 @@ Proof. intro h. apply e. destruct h as [? h ?]. rewrite in_fset in h. eexists. all: eauto. -Qed. \ No newline at end of file +Qed. diff --git a/theories/Crypt/package/pkg_core_definition.v b/theories/Crypt/package/pkg_core_definition.v index c6070358..865c4191 100644 --- a/theories/Crypt/package/pkg_core_definition.v +++ b/theories/Crypt/package/pkg_core_definition.v @@ -54,6 +54,7 @@ Definition loc_type (l : Location) := l.π1. Coercion loc_type : Location >-> choice_type. Definition Value (t : choice_type) := chElement t. +From HB Require Import structures. Definition Interface := {fset opsig}. @@ -258,7 +259,7 @@ Section FreeModule. Inductive command : choiceType → Type := | cmd_op o (x : src o) : command (tgt o) | cmd_get (ℓ : Location) : command (Value ℓ.π1) - | cmd_put (ℓ : Location) (v : Value ℓ.π1) : command unit_choiceType + | cmd_put (ℓ : Location) (v : Value ℓ.π1) : command Datatypes_unit__canonical__choice_Choice | cmd_sample op : command (Arit op). Definition cmd_bind {A B} (c : command A) (k : A → raw_code B) := diff --git a/theories/Crypt/package/pkg_distr.v b/theories/Crypt/package/pkg_distr.v index ebbd1e59..8add5b29 100644 --- a/theories/Crypt/package/pkg_distr.v +++ b/theories/Crypt/package/pkg_distr.v @@ -87,7 +87,7 @@ Qed. Lemma card_prod_iprod : ∀ i j, - #|prod_finType (ordinal_finType i) (ordinal_finType j)| = (i * j)%N. + #|Datatypes_prod__canonical__fintype_Finite (fintype_ordinal__canonical__fintype_Finite i) (fintype_ordinal__canonical__fintype_Finite j)| = (i * j)%N. Proof. intros i j. rewrite card_prod. simpl. rewrite !card_ord. reflexivity. @@ -95,7 +95,7 @@ Qed. Definition ch2prod {i j} `{Positive i} `{Positive j} (x : Arit (uniform (i * j))) : - prod_choiceType (Arit (uniform i)) (Arit (uniform j)). + Datatypes_prod__canonical__fintype_Finite (Arit (uniform i)) (Arit (uniform j)). Proof. simpl in *. eapply otf. rewrite card_prod_iprod. @@ -103,7 +103,7 @@ Proof. Defined. Definition prod2ch {i j} `{Positive i} `{Positive j} - (x : prod_choiceType (Arit (uniform i)) (Arit (uniform j))) : + (x : Datatypes_prod__canonical__fintype_Finite (Arit (uniform i)) (Arit (uniform j))) : Arit (uniform (i * j)). Proof. simpl in *. @@ -114,7 +114,7 @@ Defined. Definition ch2prod_prod2ch : ∀ {i j} `{Positive i} `{Positive j} - (x : prod_choiceType (Arit (uniform i)) (Arit (uniform j))), + (x : Datatypes_prod__canonical__fintype_Finite (Arit (uniform i)) (Arit (uniform j))), ch2prod (prod2ch x) = x. Proof. intros i j hi hj x. @@ -148,7 +148,7 @@ Proof. Qed. Lemma ordinal_finType_inhabited : - ∀ i `{Positive i}, ordinal_finType i. + ∀ i `{Positive i}, fintype_ordinal__canonical__fintype_Finite i. Proof. intros i hi. exists 0%N. auto. diff --git a/theories/Crypt/package/pkg_invariants.v b/theories/Crypt/package/pkg_invariants.v index 552ac788..7f503c6a 100644 --- a/theories/Crypt/package/pkg_invariants.v +++ b/theories/Crypt/package/pkg_invariants.v @@ -1031,9 +1031,8 @@ Proof. all: intro h. all: inversion h. all: contradiction. Qed. -Canonical heap_val_eqMixin := EqMixin heap_val_eqP. -Canonical heap_val_eqType := - Eval hnf in EqType heap_val heap_val_eqMixin. +From HB Require Import structures. +HB.instance Definition _ := hasDecEq.Build heap_val heap_val_eqP. Derive NoConfusion for heap_val. diff --git a/theories/Crypt/package/pkg_rhl.v b/theories/Crypt/package/pkg_rhl.v index 6d35c83e..42e0078e 100644 --- a/theories/Crypt/package/pkg_rhl.v +++ b/theories/Crypt/package/pkg_rhl.v @@ -165,7 +165,7 @@ Proof. match goal with | |- realsum.summable ?f => eassert (f = _) as Hf end. { extensionality x. - apply (destruct_pair_eq (a:= f1 x) (b:=f3 x) (c:= f2 x) (d := f4 x)). } + exact (destruct_pair_eq (a:= f1 x) (b:=f3 x) (c:= f2 x) (d := f4 x)). } rewrite Hf. apply realsum.summableM. all: assumption. Qed. @@ -472,8 +472,8 @@ Proof. unfold SDistr_bind. unfold SDistr_unit. rewrite !dletE. assert ( - ∀ x : bool_choiceType * heap_choiceType, - ((let '(b, _) := x in dunit (R:=R) (T:=bool_choiceType) b) true) == + ∀ x : Datatypes_bool__canonical__choice_Choice * heap_choiceType, + ((let '(b, _) := x in dunit (R:=R) (T:=Datatypes_bool__canonical__choice_Choice) b) true) == (x.1 == true)%:R ) as h1. { intros [b s]. @@ -481,8 +481,8 @@ Proof. } assert ( ∀ y, - (λ x : prod_choiceType (tgt RUN) heap_choiceType, (y x) * (let '(b, _) := x in dunit (R:=R) (T:=tgt RUN) b) true) = - (λ x : prod_choiceType (tgt RUN) heap_choiceType, (x.1 == true)%:R * (y x)) + (λ x : Datatypes_prod__canonical__choice_Choice (tgt RUN) heap_choiceType, (y x) * (let '(b, _) := x in dunit (R:=R) (T:=tgt RUN) b) true) = + (λ x : Datatypes_prod__canonical__choice_Choice (tgt RUN) heap_choiceType, (x.1 == true)%:R * (y x)) ) as Hrew. { intros y. extensionality x. @@ -580,8 +580,8 @@ Proof. unfold SDistr_bind. unfold SDistr_unit. rewrite !dletE. assert ( - ∀ x : bool_choiceType * heap_choiceType, - ((let '(b, _) := x in dunit (R:=R) (T:=bool_choiceType) b) true) == + ∀ x : Datatypes_bool__canonical__choice_Choice * heap_choiceType, + ((let '(b, _) := x in dunit (R:=R) (T:=Datatypes_bool__canonical__choice_Choice) b) true) == (x.1 == true)%:R ) as h1. { intros [b s]. @@ -589,8 +589,8 @@ Proof. } assert ( ∀ y, - (λ x : prod_choiceType (tgt RUN) heap_choiceType, (y x) * (let '(b, _) := x in dunit (R:=R) (T:=tgt RUN) b) true) = - (λ x : prod_choiceType (tgt RUN) heap_choiceType, (x.1 == true)%:R * (y x)) + (λ x : Datatypes_prod__canonical__choice_Choice (tgt RUN) heap_choiceType, (y x) * (let '(b, _) := x in dunit (R:=R) (T:=tgt RUN) b) true) = + (λ x : Datatypes_prod__canonical__choice_Choice (tgt RUN) heap_choiceType, (x.1 == true)%:R * (y x)) ) as Hrew. { intros y. extensionality x. destruct x as [x1 x2]. @@ -984,6 +984,29 @@ Proof. eapply swap_ruleL. all: eauto. Qed. +Lemma rswap_helper : + forall {A₀ A₁ B : ord_choiceType} + (c₀ : raw_code A₀) (c₁ : raw_code A₁) (r : A₀ → A₁ → raw_code B), + ((a1 ∈ choice_incl A₀ <<- repr c₀;; + a2 ∈ choice_incl A₁ <<- repr c₁;; (λ (a₀ : A₀) (a₁ : A₁), repr (r a₀ a₁)) a1 a2) = + bindrFree (repr c₀) (λ a : A₀, repr (a₁ ← c₁ ;; r a a₁))). +Proof. + intros. + unfold RulesStateProb.bindF. + simpl. + unfold FreeProbProg.rFree_obligation_2. + + assert ((λ a1 : A₀, bindrFree (repr c₁) (λ a2 : A₁, repr (r a1 a2))) = (λ a : A₀, repr (a₁ ← c₁ ;; + r a a₁))). + { extensionality a. + rewrite repr_bind. + simpl. + reflexivity. + } + rewrite H. + reflexivity. +Qed. + Theorem rswap_ruleR : ∀ {A₀ A₁ B : ord_choiceType} {post : postcond B B} (c₀ : raw_code A₀) (c₁ : raw_code A₁) (r : A₀ → A₁ → raw_code B), @@ -1001,13 +1024,18 @@ Proof. intros A₀ A₁ B post c₀ c₁ r postr hr h. eapply from_sem_jdg. repeat setoid_rewrite repr_bind. simpl. - eapply (swap_ruleR (λ a₀ a₁, repr (r a₀ a₁)) (repr c₀) (repr c₁)). + rewrite <- rswap_helper. + rewrite <- rswap_helper. + apply (@swap_ruleR A₀ A₁ B _ post (λ a₀ a₁, repr (r a₀ a₁)) (repr c₀) (repr c₁)). - intros. eapply to_sem_jdg. apply hr. - apply postr. - - intro s. + - clear -h. + intro s. unshelve eapply coupling_eq. + exact (λ '(h₀, h₁), h₀ = h₁). + eapply to_sem_jdg in h. repeat setoid_rewrite repr_bind in h. + rewrite <- rswap_helper in h. + rewrite <- rswap_helper in h. apply h. + reflexivity. Qed. @@ -1958,6 +1986,30 @@ Proof. eapply restore_update_mem. all: eauto. Qed. +Lemma rswap_cmd_helper : + forall {A₀ A₁ B : ord_choiceType} + (c₀ : command A₀) (c₁ : command A₁) (r : A₀ → A₁ → raw_code B), + ((a1 ∈ choice_incl A₀ <<- repr_cmd c₀;; + a2 ∈ choice_incl A₁ <<- repr_cmd c₁;; (λ (a₀ : A₀) (a₁ : A₁), repr (r a₀ a₁)) a1 a2) = + bindrFree (repr_cmd c₀) (λ a : A₀, repr (a₁ ← cmd c₁ ;; r a a₁))). +Proof. + intros. + unfold RulesStateProb.bindF. + simpl. + unfold FreeProbProg.rFree_obligation_2. + + assert ((λ a1 : A₀, bindrFree (repr_cmd c₁) (λ a2 : A₁, repr (r a1 a2))) = (λ a : A₀, repr (a₁ ← cmd c₁ ;; + r a a₁))). + { extensionality a. + rewrite repr_cmd_bind. + simpl. + reflexivity. + } + rewrite H. + reflexivity. +Qed. + + Lemma rswap_cmd : ∀ (A₀ A₁ B : choiceType) (post : postcond B B) (c₀ : command A₀) (c₁ : command A₁) @@ -1976,6 +2028,8 @@ Proof. intros A₀ A₁ B post c₀ c₁ r hpost hr h. eapply from_sem_jdg. repeat setoid_rewrite repr_cmd_bind. + rewrite <- rswap_cmd_helper. + rewrite <- rswap_cmd_helper. eapply (swap_ruleR (λ a₀ a₁, repr (r a₀ a₁)) (repr_cmd c₀) (repr_cmd c₁)). - intros a₀ a₁. eapply to_sem_jdg. eapply hr. - intros ? ? []. eauto. @@ -1983,7 +2037,9 @@ Proof. + exact: (λ '(h1, h2), h1 = h2). + eapply to_sem_jdg in h. repeat (setoid_rewrite repr_cmd_bind in h). - auto. + rewrite <- rswap_cmd_helper in h. + rewrite <- rswap_cmd_helper in h. + apply h. + reflexivity. Qed. @@ -2009,6 +2065,53 @@ Proof. - auto. Qed. + +Lemma rswap_helper_cmd : + forall {A₀ A₁ B : ord_choiceType} + (c₀ : command A₀) (c₁ : raw_code A₁) (r : A₀ → A₁ → raw_code B), + ((a1 ∈ choice_incl A₀ <<- repr_cmd c₀;; + a2 ∈ choice_incl A₁ <<- repr c₁;; (λ (a₀ : A₀) (a₁ : A₁), repr (r a₀ a₁)) a1 a2) = + bindrFree (repr_cmd c₀) (λ a : A₀, repr (a₁ ← c₁ ;; r a a₁))). +Proof. + intros. + unfold RulesStateProb.bindF. + simpl. + unfold FreeProbProg.rFree_obligation_2. + + assert ((λ a1 : A₀, bindrFree (repr c₁) (λ a2 : A₁, repr (r a1 a2))) = (λ a : A₀, repr (a₁ ← c₁ ;; + r a a₁))). + { extensionality a. + rewrite repr_bind. + simpl. + reflexivity. + } + rewrite H. + reflexivity. +Qed. + +Lemma rswap_repr_cmd_helper : + forall {A₀ A₁ B : ord_choiceType} + (c₀ : raw_code A₀) (c₁ : command A₁) (r : A₀ → A₁ → raw_code B), + ((a1 ∈ choice_incl A₀ <<- repr c₀;; + a2 ∈ choice_incl A₁ <<- repr_cmd c₁;; (λ (a₀ : A₀) (a₁ : A₁), repr (r a₀ a₁)) a1 a2) = + bindrFree (repr c₀) (λ a : A₀, repr (a₁ ← cmd c₁ ;; r a a₁))). +Proof. + intros. + unfold RulesStateProb.bindF. + simpl. + unfold FreeProbProg.rFree_obligation_2. + + assert ((λ a1 : A₀, bindrFree (repr_cmd c₁) (λ a2 : A₁, repr (r a1 a2))) = (λ a : A₀, repr (a₁ ← cmd c₁ ;; + r a a₁))). + { extensionality a. + rewrite repr_cmd_bind. + simpl. + reflexivity. + } + rewrite H. + reflexivity. +Qed. + Lemma rswap_cmd_bind_eq : ∀ {A₀ A₁ B : choiceType} c₀ c₁ (r : A₀ → A₁ → raw_code B), ⊢ ⦃ λ '(h₀, h₁), h₀ = h₁ ⦄ @@ -2022,8 +2125,10 @@ Lemma rswap_cmd_bind_eq : Proof. intros A₀ A₁ B c₀ c₁ r h. eapply from_sem_jdg. simpl. - setoid_rewrite repr_cmd_bind. setoid_rewrite repr_bind. - simpl. setoid_rewrite repr_cmd_bind. + setoid_rewrite repr_cmd_bind. rewrite repr_bind. + rewrite <- rswap_helper_cmd. + rewrite <- rswap_repr_cmd_helper. + simpl. eapply (swap_ruleR (λ a₀ a₁, repr (r a₀ a₁)) (repr_cmd c₀) (repr c₁)). - intros a₀ a₁. eapply to_sem_jdg. apply rsym_pre. 1: auto. @@ -2033,8 +2138,10 @@ Proof. + exact: (λ '(h₀, h₁), h₀ = h₁). + eapply to_sem_jdg in h. setoid_rewrite repr_cmd_bind in h. simpl in h. + rewrite <- rswap_helper_cmd in h. setoid_rewrite repr_bind in h. simpl in h. - setoid_rewrite repr_cmd_bind in h. simpl in h. + rewrite <- rswap_repr_cmd_helper in h. + simpl in h. auto. + reflexivity. Qed. @@ -2064,7 +2171,18 @@ Proof. rewrite bind_assoc in h. rewrite bind_cmd_bind in h. setoid_rewrite bind_cmd_bind in h. - setoid_rewrite bind_assoc in h. + simpl in h. + replace + (x ← cmd _ ;; + pat ← (a₀ ← c₀ ;; + ret (a₀, x)) ;; + (let '(x0, y) := pat in ret (y, x0))) + with + (x ← cmd c₁ ;; + a₀ ← c₀ ;; + pat ← ret (a₀, x) ;; + (let '(x0, y) := pat in ret (y, x0))) in h by (f_equal ; extensionality x ; now rewrite bind_assoc). + (* setoid_rewrite bind_assoc in h. *) simpl in h. apply rsymmetry. apply rsym_pre. 1: auto. eapply rpost_weaken_rule. 1: eauto. @@ -2089,6 +2207,8 @@ Proof. intros A₀ A₁ B post c₀ c₁ r postr hr h. eapply from_sem_jdg. repeat setoid_rewrite repr_cmd_bind. simpl. + rewrite <- rswap_cmd_helper. + rewrite <- rswap_cmd_helper. eapply (swap_ruleR (λ a₀ a₁, repr (r a₀ a₁)) (repr_cmd c₀) (repr_cmd c₁)). - intros. eapply to_sem_jdg. apply hr. - apply postr. @@ -2096,6 +2216,8 @@ Proof. unshelve eapply coupling_eq. + exact (λ '(h₀, h₁), h₀ = h₁). + eapply to_sem_jdg in h. repeat setoid_rewrite repr_cmd_bind in h. + rewrite <- rswap_cmd_helper in h. + rewrite <- rswap_cmd_helper in h. apply h. + reflexivity. Qed. @@ -2382,7 +2504,7 @@ Section Uniform_prod. destruct (ch2prod u == (a,b)) eqn:e. 2:{ exfalso. - move: hu => /negP hu. apply hu. apply eqxx. + move: hu => /negP hu. apply hu. rewrite e. apply eqxx. } move: e => /eqP e. rewrite -e. rewrite inE. apply /eqP. symmetry. apply prod2ch_ch2prod. diff --git a/theories/Crypt/rhl_semantics/ChoiceAsOrd.v b/theories/Crypt/rhl_semantics/ChoiceAsOrd.v index 97ce586c..0dd21495 100644 --- a/theories/Crypt/rhl_semantics/ChoiceAsOrd.v +++ b/theories/Crypt/rhl_semantics/ChoiceAsOrd.v @@ -3,7 +3,7 @@ From Relational Require Import OrderEnrichedCategory OrderEnrichedRelativeMonadE Set Warnings "-notation-overridden". From mathcomp Require Import all_ssreflect. Set Warnings "notation-overridden". -From mathcomp Require boolp. +From mathcomp Require classical.boolp. Import SPropNotations. @@ -42,7 +42,7 @@ Section Prod_of_choiceTypes. Obj ord_choiceType. Proof. rewrite /prod_cat /=. move => [C1 C2]. - exact (prod_choiceType C1 C2). + exact (C1 * C2)%type. Defined. Definition F_choice_prod_morph : forall T1 T2 : (prod_cat ord_choiceType ord_choiceType), diff --git a/theories/Crypt/rhl_semantics/free_monad/FreeProbProg.v b/theories/Crypt/rhl_semantics/free_monad/FreeProbProg.v index 9c4cfb43..2f470398 100644 --- a/theories/Crypt/rhl_semantics/free_monad/FreeProbProg.v +++ b/theories/Crypt/rhl_semantics/free_monad/FreeProbProg.v @@ -1,5 +1,5 @@ Set Warnings "-notation-overridden". -From mathcomp Require Import all_ssreflect boolp. +From mathcomp Require Import all_ssreflect classical.boolp. Set Warnings "notation-overridden". From Relational Require Import OrderEnrichedCategory OrderEnrichedRelativeMonadExamples. From Crypt Require Import ChoiceAsOrd choice_type. diff --git a/theories/Crypt/rhl_semantics/more_categories/LaxFunctorsAndTransf.v b/theories/Crypt/rhl_semantics/more_categories/LaxFunctorsAndTransf.v index 9e4f59ad..bb763159 100644 --- a/theories/Crypt/rhl_semantics/more_categories/LaxFunctorsAndTransf.v +++ b/theories/Crypt/rhl_semantics/more_categories/LaxFunctorsAndTransf.v @@ -2,7 +2,7 @@ From Coq Require Import Morphisms. From Relational Require Import OrderEnrichedCategory. From Mon Require Import SPropBase. Set Warnings "-notation-overridden". -From mathcomp Require Import all_ssreflect boolp. +From mathcomp Require Import all_ssreflect classical.boolp. Set Warnings "notation-overridden". From Crypt Require Import Axioms. diff --git a/theories/Crypt/rhl_semantics/more_categories/LaxMorphismOfRelAdjunctions.v b/theories/Crypt/rhl_semantics/more_categories/LaxMorphismOfRelAdjunctions.v index 73cb3bb8..2881f328 100644 --- a/theories/Crypt/rhl_semantics/more_categories/LaxMorphismOfRelAdjunctions.v +++ b/theories/Crypt/rhl_semantics/more_categories/LaxMorphismOfRelAdjunctions.v @@ -1,7 +1,7 @@ From Relational Require Import OrderEnrichedCategory. From Mon Require Import SPropBase. Set Warnings "-notation-overridden,-ambiguous-paths". -From mathcomp Require Import all_ssreflect boolp. +From mathcomp Require Import all_ssreflect classical.boolp. Set Warnings "notation-overridden,ambiguous-paths". From Crypt Require Import Axioms OrderEnrichedRelativeAdjunctions LaxFunctorsAndTransf. diff --git a/theories/Crypt/rhl_semantics/more_categories/OrderEnrichedRelativeAdjunctions.v b/theories/Crypt/rhl_semantics/more_categories/OrderEnrichedRelativeAdjunctions.v index cf86188b..adad635a 100644 --- a/theories/Crypt/rhl_semantics/more_categories/OrderEnrichedRelativeAdjunctions.v +++ b/theories/Crypt/rhl_semantics/more_categories/OrderEnrichedRelativeAdjunctions.v @@ -2,7 +2,7 @@ From Coq Require Import Relation_Definitions Morphisms. From Relational Require Import OrderEnrichedCategory OrderEnrichedRelativeMonadExamples. From Mon Require Import SPropBase. Set Warnings "-notation-overridden". -From mathcomp Require Import all_ssreflect boolp. +From mathcomp Require Import all_ssreflect classical.boolp. Set Warnings "notation-overridden". Import SPropNotations. diff --git a/theories/Crypt/rhl_semantics/more_categories/TransformingLaxMorph.v b/theories/Crypt/rhl_semantics/more_categories/TransformingLaxMorph.v index 2f01d5ba..24c31bac 100644 --- a/theories/Crypt/rhl_semantics/more_categories/TransformingLaxMorph.v +++ b/theories/Crypt/rhl_semantics/more_categories/TransformingLaxMorph.v @@ -2,7 +2,7 @@ From Coq Require Import Relation_Definitions. From Relational Require Import OrderEnrichedCategory. From Mon Require Import SPropBase. Set Warnings "-notation-overridden,-ambiguous-paths". -From mathcomp Require Import all_ssreflect boolp. +From mathcomp Require Import all_ssreflect classical.boolp. Set Warnings "notation-overridden,ambiguous-paths". From Crypt Require Import Axioms OrderEnrichedRelativeAdjunctions LaxFunctorsAndTransf LaxMorphismOfRelAdjunctions. diff --git a/theories/Crypt/rhl_semantics/only_prob/Theta_exCP.v b/theories/Crypt/rhl_semantics/only_prob/Theta_exCP.v index fd4a705e..ef91e423 100644 --- a/theories/Crypt/rhl_semantics/only_prob/Theta_exCP.v +++ b/theories/Crypt/rhl_semantics/only_prob/Theta_exCP.v @@ -1,5 +1,5 @@ Set Warnings "-notation-overridden,-ambiguous-paths". -From mathcomp Require Import all_ssreflect all_algebra boolp distr reals realsum. +From mathcomp Require Import all_ssreflect all_algebra classical.boolp distr reals realsum. Set Warnings "notation-overridden,ambiguous-paths". From Mon Require Import SpecificationMonads SPropBase SPropMonadicStructures. From Relational Require Import OrderEnrichedCategory OrderEnrichedRelativeMonadExamples. @@ -90,11 +90,9 @@ Proof. apply: sig_eq. rewrite /=. apply: boolp.funext. by move => [c1 c2] /=. Defined. - - - -Definition θ0 (A1 A2 : Type) (ch1 : Choice.class_of A1) (ch2 : Choice.class_of A2): - (SDistr_carrier (Choice.Pack ch1)) × (SDistr_carrier (Choice.Pack ch2)) -> + +Definition θ0 (A1 A2 : Type) (ch1 : Choice A1 (* Choice.class_of A1 *)) (ch2 : Choice A2 (* Choice.class_of A2 *)): + (SDistr_carrier (Choice.Pack ch1) ) × (SDistr_carrier (Choice.Pack ch2)) -> WProp (A1 * A2)%type. Proof. rewrite /SDistr_carrier. move => [d1 d2]. @@ -116,8 +114,8 @@ Proof. inversion leq12. by subst. Defined. -Definition kd {A1 A2 B1 B2 : Type} {chA1 : Choice.class_of A1} {chA2 : Choice.class_of A2} - {chB1 : Choice.class_of B1} {chB2 : Choice.class_of B2} +Definition kd {A1 A2 B1 B2 : Type} {chA1 : Choice(* .class_of *) A1} {chA2 : Choice(* .class_of *) A2} + {chB1 : Choice(* .class_of *) B1} {chB2 : Choice(* .class_of *) B2} {f1 : TypeCat ⦅ nfst (prod_functor choice_incl choice_incl ⟨ Choice.Pack chA1, Choice.Pack chA2 ⟩); nfst (SDistr_squ ⟨Choice.Pack chB1, Choice.Pack chB2 ⟩) ⦆} @@ -151,7 +149,7 @@ Proof. - exists dnull. intro. inversion H. Defined. -Lemma extract_positive : forall {A1 A2 B1 B2 : Type} {chA1 : Choice.class_of A1} {chA2 : Choice.class_of A2} {chB1 : Choice.class_of B1} {chB2 : Choice.class_of B2} (dA : SDistr_carrier (F_choice_prod_obj ⟨ Choice.Pack chA1, Choice.Pack chA2 ⟩)) (FF1 : _ -> SDistr (F_choice_prod ⟨ Choice.Pack chB1, Choice.Pack chB2 ⟩)) b1 b2, 0 < (\dlet_(i <- dA) (FF1 i)) (b1, b2) -> exists (a1 : Choice.Pack chA1) (a2 : Choice.Pack chA2), 0 < dA (a1, a2) /\ 0 < FF1 (a1, a2) (b1, b2). +Lemma extract_positive : forall {A1 A2 B1 B2 : Type} {chA1 : Choice(* .class_of *) A1} {chA2 : Choice(* .class_of *) A2} {chB1 : Choice(* .class_of *) B1} {chB2 : Choice(* .class_of *) B2} (dA : SDistr_carrier (F_choice_prod_obj ⟨ Choice.Pack chA1, Choice.Pack chA2 ⟩)) (FF1 : _ -> SDistr (F_choice_prod ⟨ Choice.Pack chB1, Choice.Pack chB2 ⟩)) b1 b2, 0 < (\dlet_(i <- dA) (FF1 i)) (b1, b2) -> exists (a1 : Choice.Pack chA1) (a2 : Choice.Pack chA2), 0 < dA (a1, a2) /\ 0 < FF1 (a1, a2) (b1, b2). Proof. intuition. rewrite /(\dlet_(i <- _) _) in H. unlock in H. simpl in H. rewrite /mlet in H. @@ -174,7 +172,7 @@ Proof. apply FF1z. Qed. -Lemma distr_get : forall {A : Type} {chA : Choice.class_of A} x y, 0 < SDistr_unit (Choice.Pack chA) x y -> x = y. +Lemma distr_get : forall {A : Type} {chA : Choice(* .class_of *) A} x y, 0 < SDistr_unit (Choice.Pack chA) x y -> x = y. Proof. intuition. rewrite /SDistr_unit in H. rewrite dunit1E in H. case Hxy: (x==y). @@ -266,7 +264,7 @@ End SemanticNotation. Import SemanticNotation. #[local] Open Scope semantic_scope. -Definition flip (r : R) : SDistr (bool_choiceType). +Definition flip (r : R) : SDistr (bool). rewrite /SDistr_carrier. apply mkdistrd. intros b. destruct b. @@ -274,7 +272,7 @@ Definition flip (r : R) : SDistr (bool_choiceType). - exact (1 - r). Defined. -Lemma sample_rule : forall {A1 A2} {chA1 : Choice.class_of A1} {chA2 : Choice.class_of A2} +Lemma sample_rule : forall {A1 A2} {chA1 : Choice(* .class_of *) A1} {chA2 : Choice A2} (pre : Prop) (post : A1 -> A2 -> Prop) (d1 : SDistr (Choice.Pack chA1)) (d2 : SDistr (Choice.Pack chA2)) d (Hd : coupling d d1 d2) @@ -298,7 +296,7 @@ Qed. (* GENERIC MONADIC RULES *) -Theorem ret_rule {A1 A2 : Type} {chA1 : Choice.class_of A1} {chA2 : Choice.class_of A2} +Theorem ret_rule {A1 A2 : Type} {chA1 : Choice A1} {chA2 : Choice A2} (a1 : A1) (a2 : A2) : ⊨ (ord_relmon_unit SDistr (Choice.Pack chA1) a1) ≈ @@ -317,7 +315,7 @@ Proof. by rewrite -(distr_get _ _ Hb1b2). Qed. -Theorem weaken_rule {A1 A2 : Type} {chA1 : Choice.class_of A1} {chA2 : Choice.class_of A2} +Theorem weaken_rule {A1 A2 : Type} {chA1 : Choice A1} {chA2 : Choice A2} {d1 : SDistr (Choice.Pack chA1)} {d2 : SDistr (Choice.Pack chA2)} : forall w w', (⊨ d1 ≈ d2 [{ w }]) -> w ≤ w' -> (⊨ d1 ≈ d2 [{ w' }] ). diff --git a/theories/Crypt/rhl_semantics/state_prob/OrderEnrichedRelativeAdjunctionsExamples.v b/theories/Crypt/rhl_semantics/state_prob/OrderEnrichedRelativeAdjunctionsExamples.v index 0092f529..7fdde957 100644 --- a/theories/Crypt/rhl_semantics/state_prob/OrderEnrichedRelativeAdjunctionsExamples.v +++ b/theories/Crypt/rhl_semantics/state_prob/OrderEnrichedRelativeAdjunctionsExamples.v @@ -1,6 +1,6 @@ From Coq Require Import Morphisms. Set Warnings "-notation-overridden,-ambiguous-paths". -From mathcomp Require Import all_algebra all_ssreflect boolp. +From mathcomp Require Import all_algebra all_ssreflect classical.boolp. Set Warnings "notation-overridden,ambiguous-paths". From Mon Require Import SPropBase Base. From Relational Require Import OrderEnrichedCategory OrderEnrichedRelativeMonadExamples. diff --git a/theories/Crypt/rhl_semantics/state_prob/StateTransformingLaxMorph.v b/theories/Crypt/rhl_semantics/state_prob/StateTransformingLaxMorph.v index d3082192..667aca43 100644 --- a/theories/Crypt/rhl_semantics/state_prob/StateTransformingLaxMorph.v +++ b/theories/Crypt/rhl_semantics/state_prob/StateTransformingLaxMorph.v @@ -215,8 +215,8 @@ Section UnaryInterpretState. Definition getStP : stT_Frp S := fun s : S => retrFree_filled (F_choice_prod_obj ⟨ S, S ⟩) (s, s). - Definition putStP : S -> stT_Frp unit_choiceType := fun new_s old_s => - retrFree_filled (F_choice_prod ⟨ unit_choiceType, S ⟩) (tt, new_s). + Definition putStP : S -> stT_Frp Datatypes_unit__canonical__choice_Choice := fun new_s old_s => + retrFree_filled (F_choice_prod ⟨ Datatypes_unit__canonical__choice_Choice, S ⟩) (tt, new_s). Definition probopStP {T : choice_type} (sd: SDistr T) : stT_Frp (chElement T). diff --git a/theories/Crypt/rules/RulesProb.v b/theories/Crypt/rules/RulesProb.v index f5bf3a76..5ca34b40 100644 --- a/theories/Crypt/rules/RulesProb.v +++ b/theories/Crypt/rules/RulesProb.v @@ -150,7 +150,7 @@ End RulesNotation. Import RulesNotation. Open Scope Rules_scope. -Definition flip (r : R) : SDistr (bool_choiceType). +Definition flip (r : R) : SDistr (bool). rewrite /SDistr_carrier. apply mkdistrd. intros b. destruct b. @@ -162,7 +162,7 @@ Definition get_d { A : choiceType} (c : MFreePr A):= (Theta_dens.unary_theta_dens_obligation_1 A c). Lemma sample_rule : - ∀ {A1 A2} {chA1 : Choice.class_of A1} {chA2 : Choice.class_of A2} + ∀ {A1 A2} {chA1 : Choice(* .class_of *) A1} {chA2 : Choice(* .class_of *) A2} (pre : Prop) (post : A1 -> A2 -> Prop) (c1 : MFreePr (Choice.Pack chA1)) (c2 : MFreePr (Choice.Pack chA2)) @@ -205,7 +205,7 @@ Qed. (* GENERIC MONADIC RULES *) Theorem ret_ule {A1 A2 : Type} - {chA1 : Choice.class_of A1} {chA2 : Choice.class_of A2} + {chA1 : Choice(* .class_of *) A1} {chA2 : Choice(* .class_of *) A2} (a1 : A1) (a2 : A2) : ⊨ (ord_relmon_unit MFreePr (Choice.Pack chA1) a1) ≈ (ord_relmon_unit MFreePr (Choice.Pack chA2) a2) @@ -229,7 +229,7 @@ Proof. by apply: ret_rule. Qed. -Theorem weaken_rule {A1 A2 : Type} {chA1 : Choice.class_of A1} {chA2 : Choice.class_of A2} +Theorem weaken_rule {A1 A2 : Type} {chA1 : Choice(* .class_of *) A1} {chA2 : Choice(* .class_of *) A2} {d1 : MFreePr (Choice.Pack chA1)} {d2 : MFreePr (Choice.Pack chA2)} : forall w w', (⊨ d1 ≈ d2 [{ w }]) -> w ≤ w' -> (⊨ d1 ≈ d2 [{ w' }] ). @@ -243,8 +243,8 @@ Proof. Qed. -Theorem bind_rule {A1 A2 : Type} {chA1 : Choice.class_of A1} {chA2 : Choice.class_of A2} - {B1 B2 : Type} {chB1 : Choice.class_of B1} {chB2 : Choice.class_of B2} +Theorem bind_rule {A1 A2 : Type} {chA1 : Choice(* .class_of *) A1} {chA2 : Choice(* .class_of *) A2} + {B1 B2 : Type} {chB1 : Choice(* .class_of *) B1} {chB2 : Choice(* .class_of *) B2} {f1 : A1 -> MFreePr (Choice.Pack chB1)} {f2 : A2 -> MFreePr (Choice.Pack chB2)} (m1 : MFreePr (Choice.Pack chA1)) @@ -278,7 +278,7 @@ Qed. (* Pre-condition manipulating rules *) -Theorem pre_weaken_rule {A1 A2 : Type} {chA1 : Choice.class_of A1} {chA2 : Choice.class_of A2} +Theorem pre_weaken_rule {A1 A2 : Type} {chA1 : Choice(* .class_of *) A1} {chA2 : Choice(* .class_of *) A2} {d1 : MFreePr (Choice.Pack chA1)} {d2 : MFreePr (Choice.Pack chA2)} : forall (pre pre' : Prop) post, (⊨ ⦃ pre ⦄ d1 ≈ d2 ⦃ post ⦄) -> (pre' -> pre) -> (⊨ ⦃ pre' ⦄ d1 ≈ d2 ⦃ post ⦄). @@ -291,7 +291,7 @@ Proof. simpl; intuition. Qed. -Theorem pre_hypothesis_rule {A1 A2 : Type} {chA1 : Choice.class_of A1} {chA2 : Choice.class_of A2} +Theorem pre_hypothesis_rule {A1 A2 : Type} {chA1 : Choice(* .class_of *) A1} {chA2 : Choice(* .class_of *) A2} {d1 : MFreePr (Choice.Pack chA1)} {d2 : MFreePr (Choice.Pack chA2)} : forall (pre : Prop) post, (pre -> ⊨ ⦃ True ⦄ d1 ≈ d2 ⦃ post ⦄) -> (⊨ ⦃ pre ⦄ d1 ≈ d2 ⦃ post ⦄). @@ -323,7 +323,7 @@ Qed. (* post-condition manipulating rules *) -Theorem post_weaken_rule {A1 A2 : Type} {chA1 : Choice.class_of A1} {chA2 : Choice.class_of A2} +Theorem post_weaken_rule {A1 A2 : Type} {chA1 : Choice(* .class_of *) A1} {chA2 : Choice(* .class_of *) A2} {d1 : MFreePr (Choice.Pack chA1)} {d2 : MFreePr (Choice.Pack chA2)} : forall (pre : Prop) (post1 post2 : A1 -> A2 -> Prop), @@ -438,7 +438,7 @@ Proof. by apply: (seq_rule_ch m1 m2 P (fun _ _ => True) Q judge1 judge2). Qed. (* *) -Theorem if_rule {A1 A2 : Type} {chA1 : Choice.class_of A1} {chA2 : Choice.class_of A2} +Theorem if_rule {A1 A2 : Type} {chA1 : Choice(* .class_of *) A1} {chA2 : Choice(* .class_of *) A2} (c1 c2 : MFreePr (Choice.Pack chA1)) (c1' c2' : MFreePr (Choice.Pack chA2)) {b1 b2 : bool} @@ -463,7 +463,7 @@ Proof. - intuition. Qed. -Theorem if_rule_weak {A1 A2 : Type} {chA1 : Choice.class_of A1} {chA2 : Choice.class_of A2} +Theorem if_rule_weak {A1 A2 : Type} {chA1 : Choice(* .class_of *) A1} {chA2 : Choice(* .class_of *) A2} (c1 c2 : MFreePr (Choice.Pack chA1)) (c1' c2' : MFreePr (Choice.Pack chA2)) {b : bool} @@ -485,7 +485,7 @@ Axiom s_indefinite_description : -Definition judgement_d {A1 A2 : Type} {chA1 : Choice.class_of A1} {chA2 : Choice.class_of A2} +Definition judgement_d {A1 A2 : Type} {chA1 : Choice(* .class_of *) A1} {chA2 : Choice(* .class_of *) A2} {c1 : MFreePr (Choice.Pack chA1)} {c2 : MFreePr (Choice.Pack chA2)} {pre : Prop} {post : A1 -> A2 -> Prop} @@ -516,8 +516,8 @@ Fixpoint for_loop {A : choiceType} (c : A -> MFreePr A) (n : nat) (a : A) := end. (* Rem.: this is a bounded version of the iteration operator found in monads with iteration *) -Fixpoint bounded_iter {A B : choiceType} (n : nat) (c : A -> MFreePr (sum_choiceType A B)) (a : A) : - MFreePr (sum_choiceType unit_choiceType B) := +Fixpoint bounded_iter {A B : choiceType} (n : nat) (c : A -> MFreePr (A + B)%type) (a : A) : + MFreePr (Datatypes_unit__canonical__choice_Choice + B)%type := match n with | 0 => ord_relmon_unit MFreePr _ (inl Datatypes.tt) | S m => (ord_relmon_bind MFreePr) (fun v => match v with @@ -526,16 +526,16 @@ Fixpoint bounded_iter {A B : choiceType} (n : nat) (c : A -> MFreePr (sum_choice end) (c a) end. -Definition bounded_loop {A B : choiceType} (n : nat) (b : A -> MFreePr bool_choiceType) (c : A -> MFreePr A) (a : A) : - MFreePr (sum_choiceType unit_choiceType A) := +Definition bounded_loop {A B : choiceType} (n : nat) (b : A -> MFreePr bool) (c : A -> MFreePr A) (a : A) : + MFreePr (Datatypes_unit__canonical__choice_Choice + A)%type := bounded_iter n (fun a' => ord_relmon_bind MFreePr (fun b => match b with | true => ord_relmon_bind MFreePr (fun a2 => ord_relmon_unit MFreePr _ (inr a2)) (c a') | false => ord_relmon_unit MFreePr _ (inl a') end) (b a')) a. (* Rem.: this a variant following what's in The next 700... *) -Fixpoint bounded_do_while (n : nat) (c : MFreePr bool_choiceType) : - MFreePr bool_choiceType := +Fixpoint bounded_do_while (n : nat) (c : MFreePr bool) : + MFreePr bool := (* false means fuel emptied, true means execution finished *) match n with | 0 => ord_relmon_unit MFreePr _ false @@ -548,8 +548,8 @@ Fixpoint bounded_do_while (n : nat) (c : MFreePr bool_choiceType) : (* Rem.: maybe something like the rule in the paper can be proven? yes... but I do not have intuition of how it could be used... examples needed! *) -Theorem bounded_do_while_rule {A1 A2 : Type} {chA1 : Choice.class_of A1} {chA2 : Choice.class_of A2} {n : nat} - (c1 c2 : MFreePr bool_choiceType) +Theorem bounded_do_while_rule {A1 A2 : Type} {chA1 : Choice(* .class_of *) A1} {chA2 : Choice(* .class_of *) A2} {n : nat} + (c1 c2 : MFreePr bool) {inv : bool -> bool -> Prop} {H : ⊨ ⦃ inv true true ⦄ c1 ≈ c2 ⦃ fun b1 b2 => inv b1 b2 /\ b1 = b2 ⦄ } : ⊨ ⦃ inv true true ⦄ bounded_do_while n c1 ≈ bounded_do_while n c2 ⦃ fun l r => (l = false /\ r = false) \/ inv false false ⦄. @@ -614,7 +614,7 @@ Proof. rewrite HeqH11. assert ((fun x : X => (A x)%:R * psum (fun w : Choice.Pack chY => d (x, w))) = (fun x : X => psum (fun w : Choice.Pack chY => (A x)%:R * d (x, w)))) as H4. { extensionality k. rewrite -psumZ. reflexivity. - case (A k); intuition. by rewrite ler01. } + case (A k); intuition. (* by rewrite ler01. *) } rewrite H4. assert ((fun x : Y => (B x)%:R * dsnd d x) = (fun y : Y => (B y)%:R * psum (fun w => d (w, y)))) as HeqH12. { extensionality K. rewrite dsndE. reflexivity. } @@ -651,23 +651,23 @@ Proof. move: H. move/idP. intuition. by rewrite H !GRing.mulr0. (* summable B*) - assert ((fun x : (prod_choiceType (Choice.Pack chX) (Choice.Pack chY)) => + assert ((fun x : ( (Choice.Pack chX) * (Choice.Pack chY)) => (nat_of_bool (let '(_, y) := x in B y))%:R * d x) = (fun '(x, y) => (B y)%:R * d (x, y))) as Heq1. { extensionality k. destruct k as [k1 k2]. case (B k2). reflexivity. reflexivity. } rewrite -Heq1. - pose (@summable_pr R (prod_choiceType (Choice.Pack chX) (Choice.Pack chY)) + pose (@summable_pr R ((Choice.Pack chX) * (Choice.Pack chY))%type (fun '(x, y) => B y) d). simpl in *. unfold nat_of_bool in s. rewrite /nat_of_bool. exact s. (* summable A *) - assert ((fun x : (prod_choiceType (Choice.Pack chX) (Choice.Pack chY)) => + assert ((fun x : ((Choice.Pack chX) * (Choice.Pack chY))%type => (nat_of_bool (let '(x, _) := x in A x))%:R * d x) = (fun '(x, y) => (A x)%:R * d (x, y))) as Heq2. { extensionality k. destruct k as [k1 k2]. case (B k2). reflexivity. reflexivity. } rewrite -Heq2. - pose (@summable_pr R (prod_choiceType (Choice.Pack chX) (Choice.Pack chY)) + pose (@summable_pr R ((Choice.Pack chX) * (Choice.Pack chY))%type (fun '(x, y) => A x) d). simpl in *. unfold nat_of_bool in s. rewrite /nat_of_bool. exact s. Qed. @@ -722,7 +722,7 @@ Proof. rewrite HeqH11. assert ((fun x : X => (A x)%:R * psum (fun w : Choice.Pack chY => d (x, w))) = (fun x : X => psum (fun w : Choice.Pack chY => (A x)%:R * d (x, w)))) as H4. { extensionality k. rewrite -psumZ. reflexivity. - case (A k); intuition. by rewrite ler01. } + case (A k); intuition. (* by rewrite ler01. *) } rewrite H4. assert ((fun x : Y => (B x)%:R * dsnd d x) = (fun y : Y => (B y)%:R * psum (fun w => d (w, y)))) as HeqH12. { extensionality K. rewrite dsndE. reflexivity. } @@ -739,7 +739,7 @@ Proof. - move => [x1 x2] /=. apply /andP. split. -- apply: mulr_ge0. - --- case: (A x1); rewrite //=. exact ler01. + --- case: (A x1); rewrite //=. (* exact ler01. *) --- by inversion d. -- have Hd0 : 0 <= d(x1,x2) by inversion d. have [Hdor1 | Hdor2]: 0 == d(x1,x2) \/ 0 < d(x1,x2). @@ -748,42 +748,42 @@ Proof. --- move/eqP : Hdor1 => Hdor1. by rewrite -Hdor1 !GRing.mulr0. --- apply: ler_pmul. - + case: (A x1); rewrite //=. exact ler01. + + case: (A x1); rewrite //=. (* exact ler01. *) + by inversion d. + move: (H2 x1 x2 Hdor2) => HAB. destruct (A x1) eqn: Ax1; rewrite //=; destruct (B x2) eqn : Bx2; rewrite //=. exfalso. by apply: true_false_False. - exact ler01. + (* exact ler01. *) auto. (* summable B *) - assert ((fun x : (prod_choiceType (Choice.Pack chX) (Choice.Pack chY)) => + assert ((fun x : ((Choice.Pack chX) * (Choice.Pack chY)) => (nat_of_bool (let '(_, y) := x in B y))%:R * d x) = (fun '(x, y) => (B y)%:R * d (x, y))) as Heq1. { extensionality k. destruct k as [k1 k2]. case (B k2). reflexivity. reflexivity. } rewrite -Heq1. - pose (@summable_pr R (prod_choiceType (Choice.Pack chX) (Choice.Pack chY)) + pose (@summable_pr R ((Choice.Pack chX) * (Choice.Pack chY))%type (fun '(x, y) => B y) d). simpl in *. unfold nat_of_bool in s. rewrite /nat_of_bool. exact s. (* summable B *) - assert ((fun x : (prod_choiceType (Choice.Pack chX) (Choice.Pack chY)) => + assert ((fun x : ((Choice.Pack chX) * (Choice.Pack chY)) => (nat_of_bool (let '(_, y) := x in B y))%:R * d x) = (fun '(x, y) => (B y)%:R * d (x, y))) as Heq1. { extensionality k. destruct k as [k1 k2]. case (B k2). reflexivity. reflexivity. } rewrite -Heq1. - pose (@summable_pr R (prod_choiceType (Choice.Pack chX) (Choice.Pack chY)) + pose (@summable_pr R ((Choice.Pack chX) * (Choice.Pack chY))%type (fun '(x, y) => B y) d). simpl in *. unfold nat_of_bool in s. rewrite /nat_of_bool. exact s. (* summable A *) - assert ((fun x : (prod_choiceType (Choice.Pack chX) (Choice.Pack chY)) => + assert ((fun x : ((Choice.Pack chX) * (Choice.Pack chY)) => (nat_of_bool (let '(x, _) := x in A x))%:R * d x) = (fun '(x, y) => (A x)%:R * d (x, y))) as Heq2. { extensionality k. destruct k as [k1 k2]. case (B k2). reflexivity. reflexivity. } rewrite -Heq2. - pose (@summable_pr R (prod_choiceType (Choice.Pack chX) (Choice.Pack chY)) + pose (@summable_pr R ((Choice.Pack chX) * (Choice.Pack chY))%type (fun '(x, y) => A x) d). simpl in *. unfold nat_of_bool in s. rewrite /nat_of_bool. exact s. Qed. diff --git a/theories/Crypt/rules/RulesStateProb.v b/theories/Crypt/rules/RulesStateProb.v index 7f3b3a00..b039e698 100644 --- a/theories/Crypt/rules/RulesStateProb.v +++ b/theories/Crypt/rules/RulesStateProb.v @@ -8,7 +8,7 @@ From Relational Require Import OrderEnrichedCategory Set Warnings "-notation-overridden,-ambiguous-paths". From mathcomp Require Import all_ssreflect all_algebra reals distr realsum - finmap.set finmap.finmap xfinmap. + (* finmap.set *) finmap.finmap xfinmap. Set Warnings "notation-overridden,ambiguous-paths". From Crypt Require Import Axioms ChoiceAsOrd SubDistr Couplings Theta_dens @@ -126,7 +126,7 @@ End RSemanticNotation. Import RSemanticNotation. #[local] Open Scope rsemantic_scope. -Import finmap.set finmap.finmap xfinmap. +Import finmap(* .set *) finmap.finmap xfinmap. Open Scope fset_scope. @@ -174,7 +174,7 @@ Proof. rewrite /semantic_judgement /θ. unfold "≤". simpl. rewrite /MonoCont_order //=. move => [ss1 ss2] πa1a2 /=. - exists (SDistr_unit (F_choice_prod (npair (prod_choiceType A1 S1) (prod_choiceType A2 S2))) + exists (SDistr_unit (F_choice_prod (npair (Datatypes_prod__canonical__choice_Choice A1 S1) (Datatypes_prod__canonical__choice_Choice A2 S2))) ((a1, ss1), (a2, ss2))). split. - rewrite /SubDistr.SDistr_obligation_1 /=. @@ -548,8 +548,8 @@ Qed. (* TODO: asymmetric variants of if_rule: if_ruleL and if_ruleR *) -Fixpoint bounded_do_while {S : choiceType} (n : nat) (c : FrStP S bool_choiceType) : - FrStP S bool_choiceType := +Fixpoint bounded_do_while {S : choiceType} (n : nat) (c : FrStP S bool) : + FrStP S bool := (* false means fuel emptied, true means execution finished *) match n with | 0 => retF false @@ -562,8 +562,8 @@ Fixpoint bounded_do_while {S : choiceType} (n : nat) (c : FrStP S bool_choiceTy Theorem bounded_do_while_rule {A1 A2 : ord_choiceType} {S1 S2 : choiceType} {n : nat} - (c1 : FrStP S1 bool_choiceType) - (c2 : FrStP S2 bool_choiceType) + (c1 : FrStP S1 bool) + (c2 : FrStP S2 bool) {inv : bool -> bool -> (S1 * S2) -> Prop} {H : ⊨ ⦃ inv true true ⦄ c1 ≈ c2 ⦃ fun bs1 bs2 => (inv bs1.1 bs2.1) (bs1.2, bs2.2) /\ bs1.1 = bs2.1 ⦄ } : ⊨ ⦃ inv true true ⦄ @@ -623,7 +623,7 @@ Proof. rewrite HeqH11. simpl in HeqH11. assert ((fun x : X * S1 => (A x)%:R * psum (fun w => d (x, w))) = (fun x : X * S1 => psum (fun w => (A x)%:R * d (x, w)))) as H4. { extensionality k. rewrite -psumZ. reflexivity. - case (A k); intuition. by rewrite ler01. } + case (A k); intuition. (* by rewrite ler01. *) } rewrite H4. assert ((fun x : Y * S2 => (B x)%:R * dsnd d x) = (fun y : Y * S2 => (B y)%:R * psum (fun w => d (w, y)))) as HeqH12. { extensionality K. rewrite dsndE. reflexivity. } @@ -665,8 +665,7 @@ Proof. { extensionality k. destruct k as [k1 k2]. case (B k2). reflexivity. reflexivity. } rewrite -Heq1. - pose (@summable_pr R (prod_choiceType (prod_choiceType X S1) - (prod_choiceType Y S2)) + pose (@summable_pr R (Datatypes_prod__canonical__choice_Choice (Datatypes_prod__canonical__choice_Choice X S1) (Datatypes_prod__canonical__choice_Choice Y S2)) (fun '(x, y) => B y) d). simpl in *. unfold nat_of_bool in s. rewrite /nat_of_bool. exact s. (* summable A *) @@ -676,8 +675,7 @@ Proof. { extensionality k. destruct k as [k1 k2]. case (B k2). reflexivity. reflexivity. } rewrite -Heq2. - pose (@summable_pr R (prod_choiceType (prod_choiceType X S1) - (prod_choiceType Y S2)) + pose (@summable_pr R ((X * S1) *(Y * S2))%type (fun '(x, y) => A x) d). simpl in *. unfold nat_of_bool in s. rewrite /nat_of_bool. exact s. Qed. @@ -783,7 +781,7 @@ Proof. clear Hpsum. eapply neq0_psum in Hpsum'. destruct Hpsum'. apply aux_domain in H. - destruct (eqType_lem bool_eqType ((x,x) == (a1,a2)) true) as [Houi | Hnon]. + destruct (eqType_lem bool ((x,x) == (a1,a2)) true) as [Houi | Hnon]. move: Houi => /eqP Houi. move: Houi => [H1 H2]. rewrite -H1 -H2. reflexivity. have Hnon' : (x,x) == (a1,a2) = false. destruct ((x,x) == (a1,a2)). contradiction. reflexivity. @@ -806,19 +804,19 @@ Qed. Definition dsym { A B : ord_choiceType } { S1 S2 : choiceType } (d : SDistr_carrier (F_choice_prod_obj - ⟨ Choice.Pack {| Choice.base := prod_eqMixin B S2; Choice.mixin := prod_choiceMixin B S2 |}, - Choice.Pack {| Choice.base := prod_eqMixin A S1; Choice.mixin := prod_choiceMixin A S1 |} ⟩)) : + ⟨ Choice.Pack (Choice.class (Datatypes_prod__canonical__choice_Choice B S2)), + Choice.Pack (Choice.class (Datatypes_prod__canonical__choice_Choice A S1)) ⟩)) : SDistr_carrier (F_choice_prod_obj - ⟨ Choice.Pack {| Choice.base := prod_eqMixin A S1; Choice.mixin := prod_choiceMixin A S1 |}, - Choice.Pack {| Choice.base := prod_eqMixin B S2; Choice.mixin := prod_choiceMixin B S2 |} ⟩) := + ⟨ Choice.Pack (Choice.class (Datatypes_prod__canonical__choice_Choice A S1)), + Choice.Pack (Choice.class (Datatypes_prod__canonical__choice_Choice B S2)) ⟩) := dswap d. Lemma dsym_coupling { A B : ord_choiceType } { S1 S2 : choiceType } { d : SDistr_carrier (F_choice_prod_obj - ⟨ Choice.Pack {| Choice.base := prod_eqMixin B S2; Choice.mixin := prod_choiceMixin B S2 |}, - Choice.Pack {| Choice.base := prod_eqMixin A S1; Choice.mixin := prod_choiceMixin A S1 |} ⟩) } + ⟨ Choice.Pack (Choice.class (Datatypes_prod__canonical__choice_Choice B S2)), + Choice.Pack (Choice.class (Datatypes_prod__canonical__choice_Choice A S1)) ⟩) } {d1 d2 } (Hcoupling : coupling d d1 d2) : coupling (dsym d) d2 d1. Proof. @@ -899,7 +897,7 @@ Lemma smMonEqu1 (r : A1 -> A2 -> FrStP S B) (c1 : FrStP S A1) (c2 : FrStP S A2) : (a2 ∈ choice_incl A2 <<- c2;; a1 ∈ choice_incl A1 <<- c1;; (r a1 a2)) = -(a ∈ choice_incl (prod_choiceType A1 A2) <<- +(a ∈ choice_incl (Datatypes_prod__canonical__choice_Choice A1 A2) <<- (a2 ∈ choice_incl A2 <<- c2;; a1 ∈ choice_incl A1 <<- c1;; retF (a1, a2));; r a.1 a.2). Proof. @@ -929,7 +927,7 @@ Lemma smMonEqu2 (r : A1 -> A2 -> FrStP S B) (c1 : FrStP S A1) (c2 : FrStP S A2) : (a1 ∈ choice_incl A1 <<- c1;; a2 ∈ choice_incl A2 <<- c2;; (r a1 a2)) = -(a ∈ choice_incl (prod_choiceType A1 A2) <<- +(a ∈ choice_incl (Datatypes_prod__canonical__choice_Choice A1 A2) <<- (a1 ∈ choice_incl A1 <<- c1;; a2 ∈ choice_incl A2 <<- c2;; retF (a1, a2));; r a.1 a.2). Proof. @@ -990,12 +988,12 @@ Lemma some_commutativity (s : S) : θ_dens (θ0 - (a ∈ choice_incl (prod_choiceType A1 A2) <<- + (a ∈ choice_incl (Datatypes_prod__canonical__choice_Choice A1 A2) <<- (a1 ∈ choice_incl A1 <<- c1;; a2 ∈ choice_incl A2 <<- c2;; retF (a1, a2));; r a.1 a.2) s) = θ_dens (θ0 - (a ∈ choice_incl (prod_choiceType A1 A2) <<- + (a ∈ choice_incl (Datatypes_prod__canonical__choice_Choice A1 A2) <<- (a2 ∈ choice_incl A2 <<- c2;; a1 ∈ choice_incl A1 <<- c1;; retF (a1, a2));; r a.1 a.2) s). Proof. @@ -1003,7 +1001,7 @@ Proof. pose ( p12 := (a1 ∈ choice_incl A1 <<- c1;; a2 ∈ choice_incl A2 <<- c2;; retF (a1, a2)) ). assert (θ0_comm : -(θ0 (a ∈ choice_incl (prod_choiceType A1 A2) <<- p12 ;; r a.1 a.2) s) +(θ0 (a ∈ choice_incl (Datatypes_prod__canonical__choice_Choice A1 A2) <<- p12 ;; r a.1 a.2) s) = (ord_relmon_bind Frp_fld)^~(θ0 p12 s) (fun xs' => let (x,s'):= xs' in θ0 (r x.1 x.2) s') ). @@ -1024,7 +1022,7 @@ Proof. pose ( p21 := (a2 ∈ choice_incl A2 <<- c2;; a1 ∈ choice_incl A1 <<- c1;; retF (a1, a2)) ). assert (θ0_comm : -(θ0 (a ∈ choice_incl (prod_choiceType A1 A2) <<- p21 ;; r a.1 a.2) s) +(θ0 (a ∈ choice_incl (Datatypes_prod__canonical__choice_Choice A1 A2) <<- p21 ;; r a.1 a.2) s) = (ord_relmon_bind Frp_fld)^~(θ0 p21 s) (fun xs' => let (x,s'):= xs' in θ0 (r x.1 x.2) s') ). @@ -1045,7 +1043,7 @@ Proof. (*next we apply bind preservation of θ_dens*) unshelve etransitivity. cbn. unshelve eapply (ord_relmon_bind SDistr). - - exact ( prod_choiceType (prod_choiceType A1 A2 ) S ). + - exact ( Datatypes_prod__canonical__choice_Choice (Datatypes_prod__canonical__choice_Choice A1 A2 ) S ). - move=> [x s']. exact ( θ_dens (θ0 (r x.1 x.2) s' ) ). - exact (θ_dens (θ0 p12 s)). unfold θ_dens at 1. @@ -1131,6 +1129,7 @@ Proof. apply Hcomm. - rewrite (@smMonEqu2 A1 A2 B S r c1 c2). move=> s. + pose some_commutativity. unshelve erewrite <- some_commutativity. exact post. reflexivity. apply HR. @@ -1428,7 +1427,7 @@ Qed. Lemma θ_dens_vs_bind' {X Y : choiceType} (m : Frp X ) -(k : X -> Frp (prod_choiceType Y S)) : +(k : X -> Frp (Datatypes_prod__canonical__choice_Choice Y S)) : θ_dens (bindrFree m k) = (dnib SDistr) (fun xs => θ_dens (k xs)) (utheta_dens_fld _ m). Proof. @@ -1439,7 +1438,7 @@ Proof. pose bla := rmm_law2 _ _ _ _ (@Theta_dens.unary_theta_dens) -X (prod_choiceType Y S) k. +X (Datatypes_prod__canonical__choice_Choice Y S) k. rewrite /= in bla. unshelve eapply equal_f in bla. exact m. rewrite /=. assumption. @@ -1500,9 +1499,9 @@ unshelve eassert (eq_cont : (OrderEnrichedRelativeAdjunctions.KleisliLeftAdjoint Frp) A), utheta_dens_fld (F_choice_prod_obj - ⟨ ord_functor_id ord_choiceType (prod_choiceType A (Arst (op_iota o))), + ⟨ ord_functor_id ord_choiceType (Datatypes_prod__canonical__choice_Choice A (Arst (op_iota o))), OrderEnrichedRelativeAdjunctionsExamples.mkConstFunc ord_choiceType ord_choiceType S - (prod_choiceType A (Arst (op_iota o))) ⟩) + (Datatypes_prod__canonical__choice_Choice A (Arst (op_iota o))) ⟩) (let (a, sc) := x in bindrFree sploP (λ r : choice_incl (Ar o), retrFree (a, r, sc)))) = fun x => let (a,sc) := x in @@ -1534,7 +1533,7 @@ Proof. rewrite /mlet /=. transitivity (psum - (fun x0 : X => psum (fun x1 : Y => p x0 * q x1 * dunit (T:=prod_choiceType X Y) (x0, x1) (x, y)))). + (fun x0 : X => psum (fun x1 : Y => p x0 * q x1 * dunit (T:=Datatypes_prod__canonical__choice_Choice X Y) (x0, x1) (x, y)))). { apply eq_psum. move=> x0. rewrite -psumZ /=. apply eq_psum. move=> y0 /=. @@ -1544,7 +1543,7 @@ Proof. symmetry. transitivity (psum - (fun x0 : Y => psum (fun x1 : X => p x1 * q x0 * dunit (T:=prod_choiceType X Y) (x1, x0) (x, y)))). + (fun x0 : Y => psum (fun x1 : X => p x1 * q x0 * dunit (T:=Datatypes_prod__canonical__choice_Choice X Y) (x1, x0) (x, y)))). { apply eq_psum. move=> y0. rewrite -psumZ /=. apply eq_psum. move=> x0 /=. @@ -1586,7 +1585,7 @@ Proof. destruct p as [pmap p_0 p_sum p_1]. apply p_0. apply ( summable_mu_wgtd (T:=X) - (f:=fun x0 => psum (fun y0 : Y => q y0 * dunit (T:=prod_choiceType X Y) (x0, y0) (x, y))) p). + (f:=fun x0 => psum (fun y0 : Y => q y0 * dunit (T:=Datatypes_prod__canonical__choice_Choice X Y) (x0, y0) (x, y))) p). move=> x0. apply /andP. split. apply ge0_psum. unshelve eapply Order.POrderTheory.le_trans. diff --git a/theories/Crypt/rules/UniformDistrLemmas.v b/theories/Crypt/rules/UniformDistrLemmas.v index a051ac4a..27a15422 100644 --- a/theories/Crypt/rules/UniformDistrLemmas.v +++ b/theories/Crypt/rules/UniformDistrLemmas.v @@ -61,9 +61,9 @@ Qed. (* Rem.: TODO: generalize this *) Lemma sum_const_seq_finType { T : finType } ( J : seq T) (k : R) (Huniq : uniq J) : - \sum_(j <- J) k = \sum_(j in (seq_sub_finType J)) k. + \sum_(j <- J) k = \sum_(j in (fintype_seq_sub__canonical__fintype_Finite J)) k. Proof. - rewrite /seq_sub_finType. simpl. + rewrite /fintype_seq_sub__canonical__fintype_Finite. simpl. rewrite big_const. rewrite big_const_seq. rewrite card_seq_sub. @@ -81,11 +81,11 @@ Proof. rewrite sum_const_seq_finType. 2: { exact Huniq. } rewrite GRing.sumr_const pmulrn /=. - have hfoo' : k *~ #|seq_sub_finType (T:=T) J| = k * #|seq_sub_finType (T:=T) J|%:~R. + have hfoo' : k *~ #|fintype_seq_sub__canonical__fintype_Finite (T:=T) J| = k * #|fintype_seq_sub__canonical__fintype_Finite (T:=T) J|%:~R. { by rewrite mulrzr. } rewrite hfoo' /=. apply: ler_pmul; auto. - - rewrite ler0z. rewrite lez_nat. reflexivity. + (* - rewrite ler0z. rewrite lez_nat. reflexivity. *) - rewrite card_seq_sub. 2: eauto. rewrite cardT. rewrite ler_int. rewrite lez_nat. @@ -161,12 +161,12 @@ Qed. (* TODO RENAME *) Lemma sum_prod_bij {T : finType} {f : T -> T} - (π : (prod_finType T T) -> R) + (π : ( Datatypes_prod__canonical__fintype_Finite T T : finType) -> R) (π_geq0 : forall t, 0 <= π t) : - \sum_(jj <- enum (prod_finType T T)) (if f jj.1 == jj.2 then π jj else 0) = + \sum_(jj <- enum (Datatypes_prod__canonical__fintype_Finite T T)) (if f jj.1 == jj.2 then π jj else 0) = \sum_(j <- enum T) (π (j, f j)). Proof. - rewrite [X in X=_](bigID [pred jj : prod_finType T T | f jj.1 == jj.2]) /=. + rewrite [X in X=_](bigID [pred jj : Datatypes_prod__canonical__fintype_Finite T T | f jj.1 == jj.2]) /=. match goal with | |- _ + ?x = _ => assert (e : x == 0) @@ -300,7 +300,7 @@ Proof. Qed. Lemma support_sub_diag_mgs { A : choiceType } - ( d : SDistr (prod_choiceType A A) ) + ( d : SDistr (A * A)%type ) (Hsupp : forall a1 a2, 0 < d (a1, a2) -> a1 = a2) : forall a : A, lmg d a = d (a, a) /\ rmg d a = d (a, a). Proof. @@ -350,7 +350,7 @@ Section prod_uniform. Arguments r _ {_}. Lemma prod_uniform : - @uniform_F (prod_finType X Y) (x0,y0) = + @uniform_F (Datatypes_prod__canonical__fintype_Finite X Y) (x0,y0) = SD_bind (@uniform_F X x0) (fun x => SD_bind (@uniform_F Y y0) (fun y => SD_ret (x,y))). @@ -372,9 +372,9 @@ Section prod_uniform. { rewrite /SD_ret. pose hlp := ( @psum_pair _ X Y - (fun (x12 : prod_finType X Y) => + (fun (x12 : Datatypes_prod__canonical__fintype_Finite X Y) => let (x1,x2) := x12 in - SDistr_unit (prod_choiceType X Y) (x1,x2) (x,y)) + SDistr_unit (X * Y)%type (x1,x2) (x,y)) ). rewrite -hlp. - unshelve erewrite eq_psum. diff --git a/theories/Crypt/rules/UniformStateProb.v b/theories/Crypt/rules/UniformStateProb.v index b918d168..635e5fe8 100644 --- a/theories/Crypt/rules/UniformStateProb.v +++ b/theories/Crypt/rules/UniformStateProb.v @@ -117,7 +117,7 @@ Proof. rewrite Heq'. rewrite GRing.mulr1. reflexivity. - have Heq' : st == s = false. apply /eqP. move /eqP: Heq. congruence. rewrite Heq'. rewrite GRing.mulr0. reflexivity. - Unshelve. exact (Real.ringType R). + Unshelve. exact (reals_Real__to__GRing_SemiRing R). Qed. Definition f_dprod { F1 F2: finType } { S1 S2 : choiceType } { w0 : F1 } { w0' : F2 } {s1 : S1 } {s2 : S2} @@ -232,7 +232,7 @@ Proof. destruct #|F1| eqn:e. 1: contradiction. rewrite ltr0n. reflexivity. + unfold r. rewrite -[X in X <= _]mulrzr. rewrite GRing.div1r. - erewrite <- GRing.mulr1. rewrite -GRing.mulrA. + set (#|F1|%:~R) at 2 ; erewrite <- (GRing.mulr1 s) ; subst s. rewrite GRing.Theory.mulKf. * auto. * unshelve eapply card_non_zero. auto. @@ -241,8 +241,8 @@ Qed. Definition UniformFsq_f { F1 F2 : finType} { w0 : F1 } { w0' : F2 } { S1 S2 : choiceType } { s1 : S1 } { s2 : S2 } {f : F1 -> F2} (f_bij : bijective f): - SDistr (ChoiceAsOrd.F_choice_prod ⟨ ChoiceAsOrd.F_choice_prod ⟨ Finite.choiceType F1 , S1 ⟩ , - ChoiceAsOrd.F_choice_prod ⟨ Finite.choiceType F2 , S2 ⟩ ⟩ ). + SDistr (ChoiceAsOrd.F_choice_prod ⟨ ChoiceAsOrd.F_choice_prod ⟨ fintype_Finite__to__choice_Choice F1 , S1 ⟩ , + ChoiceAsOrd.F_choice_prod ⟨ fintype_Finite__to__choice_Choice F2 , S2 ⟩ ⟩ ). Proof. unshelve eapply mkdistr. 1:{ diff --git a/theories/Jasmin/examples/aes/aes.v b/theories/Jasmin/examples/aes/aes.v index aaa30ea9..39e06e55 100644 --- a/theories/Jasmin/examples/aes/aes.v +++ b/theories/Jasmin/examples/aes/aes.v @@ -25,12 +25,12 @@ Local Open Scope Z. Ltac neq_loc_auto ::= solve [ eapply injective_translate_var3; auto | eapply injective_translate_var2; auto ]. -Lemma rcon_E id0 pre i : +Lemma rcon_E (id0 : p_id) pre (i : Z) : (pdisj pre id0 fset0) -> (forall s0 s1, pre (s0, s1) -> (1 <= i < 11)%Z) -> ⊢ ⦃ fun '(s0, s1) => pre (s0, s1) ⦄ JRCON id0 i ≈ ret tt - ⦃ fun '(v0, s0) '(v1, s1) => pre (s0, s1) /\ exists o, v0 = [('int ; o)] /\ o = wunsigned (rcon i) ⦄. + ⦃ fun '(v0, s0) '(v1, s1) => pre (s0, s1) /\ exists (o : (λ i0 : Choice.sort choice_type_choiceType, Choice.sort (chElement i0)) 'int), v0 = [('int ; o)] /\ o = wunsigned (rcon i) ⦄. Proof. unfold JRCON. unfold get_translated_static_fun. @@ -263,7 +263,7 @@ Lemma keyExpansion_E pre id0 rkey : JKEYS_EXPAND id0 rkey ≈ keyExpansion rkey - ⦃ fun '(v0, h0) '(v1, h1) => pre (h0, h1) /\ exists o, v0 = [( 'array ; o)] /\ to_arr U128 (mkpos 11) o = v1 ⦄. + ⦃ fun '(v0, h0) '(v1, h1) => pre (h0, h1) /\ exists o, v0 = [( 'array ; o)] /\ to_arr U128 (Zpos 11) o = v1 ⦄. Proof. intros disj. unfold JKEYS_EXPAND, get_translated_static_fun, translate_prog_static, translate_funs_static, translate_call_body. @@ -294,7 +294,7 @@ Proof. (I := fun i => fun '(h0, h1) => pre (h0, h1) /\ word.subword 0 U32 (get_heap h0 temp2) = word.word0 /\ (get_heap h0 key = chArray_get U128 (get_heap h0 rkeys) (i - 1) 16) - /\ (forall j, (0 <= j < i) -> (to_arr U128 (mkpos 11) (get_heap h0 rkeys)) j = (get_heap h1 aes_spec.rkeys) j) + /\ (forall j, (0 <= j < i) -> (to_arr U128 (Zpos 11) (get_heap h0 rkeys)) j = (get_heap h1 aes_spec.rkeys) j) /\ (forall j, (j < 0) \/ (11 <= j) -> get_heap h1 aes_spec.rkeys j = None)). (* the two following bullets are small assumptions of the translate_for rule *) @@ -485,7 +485,7 @@ Lemma aes_rounds_E pre id0 rkeys msg : ⊢ ⦃ fun '(h0, h1) => pre (h0, h1) ⦄ JAES_ROUNDS id0 rkeys msg ≈ - aes_rounds (to_arr U128 (mkpos 11) rkeys) msg + aes_rounds (to_arr U128 (Zpos 11) rkeys) msg ⦃ fun '(v0, h0) '(v1, h1) => pre (h0, h1) /\ exists o, v0 = [ ('word U128 ; o) ] /\ o = v1 ⦄. Proof. unfold JAES_ROUNDS, get_translated_static_fun, translate_prog_static, translate_funs_static, translate_call_body. diff --git a/theories/Jasmin/examples/aes/aes_spec.v b/theories/Jasmin/examples/aes/aes_spec.v index 06cae285..a7a7c017 100644 --- a/theories/Jasmin/examples/aes/aes_spec.v +++ b/theories/Jasmin/examples/aes/aes_spec.v @@ -44,7 +44,7 @@ Definition key_expand (wn1 : u128) (rcon : u8) : 'word U128 := wcat [tuple w4; w5; w6; w7]. Definition key_i (k : u128) i := - iteri i (fun i ki => key_expand ki (rcon (i + 1))) k. + iteri i (fun i ki => key_expand ki (rcon ((Z_of_nat i) + 1))) k. Definition aes (key msg : u128) := let state := wxor msg (key_i key 0) in diff --git a/theories/Jasmin/examples/aes/aes_utils.v b/theories/Jasmin/examples/aes/aes_utils.v index 4fb6157a..fde3b376 100644 --- a/theories/Jasmin/examples/aes/aes_utils.v +++ b/theories/Jasmin/examples/aes/aes_utils.v @@ -5,12 +5,6 @@ Set Warnings "notation-overridden,ambiguous-paths". From Coq Require Import Utf8 ZArith micromega.Lia List. -From Jasmin Require Import sem. - -Context - {pd : PointerData} - {fcp : FlagCombinationParams}. - From Jasmin Require Import expr xseq. From JasminSSProve Require Import jasmin_translate. @@ -24,8 +18,8 @@ Import JasminNotation. Import PackageNotation. Set Bullet Behavior "Strict Subproofs". -Set Default Goal Selector "!". - +Set Default Goal Selector "!". + (** Notations *) Module AesNotation. @@ -298,12 +292,12 @@ Proof. Qed. Lemma in_ziota' i p z : - @in_mem (Ord.sort Z_ordType) i (@ssrbool.mem (Equality.sort (Ord.eqType Z_ordType)) (seq_predType (Ord.eqType Z_ordType)) (ziota p z)) = (p <=? i) && (i ∀ p : Z, @in_mem (Ord.sort Z_ordType) i (@ssrbool.mem (Equality.sort (Ord.eqType Z_ordType)) (seq_predType (Ord.eqType Z_ordType)) (ziota p z)) = (p <=? i) && (i ∀ p : Z, @in_mem (Ord.sort Z_ordType) i (@mem (Equality.sort (Ord.eqType Z_ordType)) (seq_predType (Ord.eqType Z_ordType)) (ziota p z)) = (p <=? i) && (i P z). 1: { apply natlike_ind. - unfold P. intros. rewrite in_nil. lia. @@ -349,7 +343,7 @@ Proof. Qed. Lemma getm_to_oarr ws len a (i : 'I_(pos len)) : - to_oarr ws len a i = Some (chArray_get ws a i (wsize_size ws)). + to_oarr ws len a i = Some (chArray_get ws a (Z.of_nat (nat_of_ord i)) (wsize_size ws)). Proof. unfold to_oarr. rewrite mkfmapfE. @@ -380,7 +374,7 @@ Proof. Qed. Lemma to_oarr_set_eq ws len a (i : 'I_(pos len)) w : - (to_oarr ws len (chArray_set a AAscale i w)) i = Some w. + (to_oarr ws len (chArray_set a AAscale (Z.of_nat (nat_of_ord i)) w)) i = Some w. Proof. rewrite getm_to_oarr. rewrite chArray_get_set_eq. diff --git a/theories/Jasmin/jasmin_asm.v b/theories/Jasmin/jasmin_asm.v index 6c638e90..5e318332 100644 --- a/theories/Jasmin/jasmin_asm.v +++ b/theories/Jasmin/jasmin_asm.v @@ -1,79 +1,79 @@ -From mathcomp Require Import all_ssreflect all_algebra. +(* From mathcomp Require Import all_ssreflect all_algebra. *) -From Jasmin Require Import - arch_params_proof - compiler - compiler_proof. +(* From Jasmin Require Import *) +(* arch_params_proof *) +(* compiler *) +(* compiler_proof. *) -From Jasmin Require Import - arch_decl - arch_extra - arch_sem - asm_gen_proof. +(* From Jasmin Require Import *) +(* arch_decl *) +(* arch_extra *) +(* arch_sem *) +(* asm_gen_proof. *) -From Jasmin Require Import sem. +(* From Jasmin Require Import sem. *) -From JasminSSProve Require Import jasmin_translate. -From Crypt Require Import Prelude Package. +(* From JasminSSProve Require Import jasmin_translate. *) +(* From Crypt Require Import Prelude Package. *) -Import PackageNotation. -Import JasminNotation. -Import Utf8. +(* Import PackageNotation. *) +(* Import JasminNotation. *) +(* Import Utf8. *) -Local Open Scope positive. +(* Local Open Scope positive. *) -Set Implicit Arguments. -Unset Strict Implicit. -Unset Printing Implicit Defensive. +(* Set Implicit Arguments. *) +(* Unset Strict Implicit. *) +(* Unset Printing Implicit Defensive. *) -Section __. +(* Section __. *) -Context - {syscall_state : Type} {sc_sem : syscall.syscall_sem syscall_state} {gf : glob_decls} - `{asm_e : asm_extra} {call_conv : calling_convention} {asm_scsem : asm_syscall_sem} - {fresh_vars lowering_options : Type} - (aparams : architecture_params fresh_vars lowering_options) - (haparams : h_architecture_params aparams) - (cparams : compiler_params fresh_vars lowering_options). +(* Context *) +(* {syscall_state : Type} {sc_sem : syscall.syscall_sem syscall_state} {gf : glob_decls} *) +(* `{asm_e : asm_extra} {call_conv : calling_convention} {asm_scsem : asm_syscall_sem} *) +(* {fresh_vars lowering_options : Type} *) +(* (aparams : architecture_params fresh_vars lowering_options) *) +(* (haparams : h_architecture_params aparams) *) +(* (cparams : compiler_params fresh_vars lowering_options). *) -Hypothesis print_uprogP : forall s p, cparams.(print_uprog) s p = p. -Hypothesis print_sprogP : forall s p, cparams.(print_sprog) s p = p. -Hypothesis print_linearP : forall s p, cparams.(print_linear) s p = p. +(* Hypothesis print_uprogP : forall s p, cparams.(print_uprog) s p = p. *) +(* Hypothesis print_sprogP : forall s p, cparams.(print_sprog) s p = p. *) +(* Hypothesis print_linearP : forall s p, cparams.(print_linear) s p = p. *) -Context `(asm_correct : ∀ o, sem_correct (tin (get_instr_desc (Oasm o))) (sopn_sem (Oasm o))). +(* Context `(asm_correct : ∀ o, sem_correct (tin (get_instr_desc (Oasm o))) (sopn_sem (Oasm o))). *) -Theorem equiv_to_asm subroutine p xp entries scs vm m fn scs' m' va vr xm m_id s_id s_st st : - compile_prog_to_asm aparams cparams entries subroutine p = ok xp - -> fn \in entries - -> sem.sem_call p scs m fn va scs' m' vr - -> handled_program p - -> mem_agreement m (asm_mem xm) (asm_rip xm) (asm_globs xp) - -> enough_stack_space xp fn (top_stack m) (asm_mem xm) - -> ⊢ ⦃ rel_estate (sem.Estate scs m vm) m_id s_id s_st st ⦄ - get_translated_fun p fn s_id~1 [seq totce (translate_value v) | v <- va] - ⇓ [seq totce (translate_value v) | v <- vr] - ⦃ rel_estate (sem.Estate scs' m' vm) m_id s_id~0 s_st st ⦄ - /\ exists xd : asm_fundef, - get_fundef (asm_funcs xp) fn = Some xd - /\ forall args', - asm_scs xm = scs - -> asm_reg xm ad_rsp = top_stack m - -> get_typed_reg_values xm (asm_fd_arg xd) = ok args' - -> List.Forall2 value_uincl va args' - -> exists xm' res', - get_typed_reg_values xm' (asm_fd_res xd) = ok res' - /\ List.Forall2 value_uincl vr res'. -Proof. - intros cmp fn_in sc hp mem ss. - split. - unshelve eapply translate_prog_correct; try eauto. - unshelve epose proof compile_prog_to_asmP haparams _ _ _ cmp fn_in sc mem ss as [xd [get_fd _ cmp_correct]]; eauto. - exists xd. split; eauto. - intros args'. - specialize (cmp_correct args'). - intros asm_scs asm_reg reg_args' args'_va. - specialize (cmp_correct asm_scs asm_reg reg_args' args'_va) as [xm' [res' []]]. - exists xm', res'; eauto. -Qed. +(* Theorem equiv_to_asm subroutine p xp entries scs vm m fn scs' m' va vr xm m_id s_id s_st st : *) +(* compile_prog_to_asm aparams cparams entries subroutine p = ok xp *) +(* -> fn \in entries *) +(* -> sem.sem_call p scs m fn va scs' m' vr *) +(* -> handled_program p *) +(* -> mem_agreement m (asm_mem xm) (asm_rip xm) (asm_globs xp) *) +(* -> enough_stack_space xp fn (top_stack m) (asm_mem xm) *) +(* -> ⊢ ⦃ rel_estate (sem.Estate scs m vm) m_id s_id s_st st ⦄ *) +(* get_translated_fun p fn s_id~1 [seq totce (translate_value v) | v <- va] *) +(* ⇓ [seq totce (translate_value v) | v <- vr] *) +(* ⦃ rel_estate (sem.Estate scs' m' vm) m_id s_id~0 s_st st ⦄ *) +(* /\ exists xd : asm_fundef, *) +(* get_fundef (asm_funcs xp) fn = Some xd *) +(* /\ forall args', *) +(* asm_scs xm = scs *) +(* -> asm_reg xm ad_rsp = top_stack m *) +(* -> get_typed_reg_values xm (asm_fd_arg xd) = ok args' *) +(* -> List.Forall2 value_uincl va args' *) +(* -> exists xm' res', *) +(* get_typed_reg_values xm' (asm_fd_res xd) = ok res' *) +(* /\ List.Forall2 value_uincl vr res'. *) +(* Proof. *) +(* intros cmp fn_in sc hp mem ss. *) +(* split. *) +(* unshelve eapply translate_prog_correct; try eauto. *) +(* unshelve epose proof compile_prog_to_asmP haparams _ _ _ cmp fn_in sc mem ss as [xd [get_fd _ cmp_correct]]; eauto. *) +(* exists xd. split; eauto. *) +(* intros args'. *) +(* specialize (cmp_correct args'). *) +(* intros asm_scs asm_reg reg_args' args'_va. *) +(* specialize (cmp_correct asm_scs asm_reg reg_args' args'_va) as [xm' [res' []]]. *) +(* exists xm', res'; eauto. *) +(* Qed. *) -End __. +(* End __. *) diff --git a/theories/Jasmin/jasmin_translate.v b/theories/Jasmin/jasmin_translate.v index 68ae81ec..31567252 100644 --- a/theories/Jasmin/jasmin_translate.v +++ b/theories/Jasmin/jasmin_translate.v @@ -1,7 +1,10 @@ Set Warnings "-ambiguous-paths,-notation-overridden,-notation-incompatible-format". From mathcomp Require Import all_ssreflect all_algebra. From mathcomp Require Import word word_ssrZ. -From Jasmin Require Import expr compiler_util values sem. +From Jasmin Require Import expr compiler_util values sem_params flag_combination sem_op_typed sopn low_memory psem_of_sem_proof varmap psem. +(* From Jasmin Require Import sem_one_varmap. *) +(* From Jasmin Require Import sem_one_varmap_facts. *) +(* From Jasmin Require Import sem_op_typed sem_params sem_params_of_arch_extra sem_type. *) Set Warnings "ambiguous-paths,notation-overridden,notation-incompatible-format". From extructures Require Import ord fset fmap. @@ -651,8 +654,11 @@ Import JasminNotation. Section Translation. Context `{asmop : asmOp}. + Context {pd : PointerData}. + Context (gd : glob_decls). + Context `{sc_sem : syscall_sem }. Definition mem_index : nat := 0. @@ -686,7 +692,7 @@ Proof. reflexivity. + move: H0 => /andP [H1 H2]. move: H1 => /in_map H3. - assert (negb (@eq_op Z_ordType k a.1)). { + assert (negb (@eq_op BinNums_Z__canonical__Ord_Ord k a.1)). { apply /eqP => contra; case: H3; exists (a.1, v); by move: contra <-. } rewrite setmE. @@ -705,7 +711,7 @@ Proof. - easy. - specialize (H a.2) as H0. simpl. apply List.not_in_cons in H0 as [H0 H1]. - assert (negb (@eq_op Z_ordType k a.1)). { + assert (negb (@eq_op BinNums_Z__canonical__Ord_Ord k a.1)). { apply /eqP => contra. apply H0. move: contra ->. symmetry. apply surjective_pairing. } rewrite setmE. rewrite <- negbK. @@ -756,7 +762,7 @@ Proof. Qed. Lemma eq_op_MzK : - ∀ (k x : Z_ordType), + ∀ (k x : BinNums_Z__canonical__Ord_Ord), @eq_op Mz.K.t k x = (k == x). Proof. intros k x. @@ -828,12 +834,15 @@ Definition unembed {t : stype} : encode t → sem_t t := | sword n => λ x, x end. -Fixpoint nat_of_ident (id : Ident.ident) : nat := - match id with +Fixpoint nat_of_string_name (s : string) : nat := + match s with | EmptyString => 1 - | String a s => 256 * nat_of_ident s + (Ascii.nat_of_ascii a) + | String a s => 256 * nat_of_string_name s + (Ascii.nat_of_ascii a) end. +Definition nat_of_ident (id : Ident.ident) : nat := + nat_of_string_name (Ident.string_of_name (Ident.id_name id)). + Definition nat_of_stype t : nat := match t with | sbool => 5 @@ -875,10 +884,12 @@ Qed. Lemma nat_of_ident_pos : ∀ x, (0 < nat_of_ident x)%coq_nat. Proof. - intros x. induction x as [| a s ih]. + intros x. + unfold nat_of_ident. + induction (Ident.string_of_name (Ident.id_name x)) as [| a s ih]. - auto. - simpl. - rewrite -mulP. rewrite -plusE. + rewrite -word_ssrZ.mulP. rewrite -plusE. micromega.Lia.lia. Qed. @@ -888,37 +899,45 @@ Lemma injective_nat_of_ident : x = y. Proof. intros x y e. - induction x as [| a x] in y, e |- *. - all: destruct y as [| b y]. - all: simpl in e. - - reflexivity. - - rewrite -mulP in e. rewrite -plusE in e. - pose proof (nat_of_ident_pos y). - micromega.Lia.lia. - - rewrite -mulP in e. rewrite -plusE in e. - pose proof (nat_of_ident_pos x). - micromega.Lia.lia. - - apply (f_equal (λ a, Nat.modulo a 256)) in e as xy_eq. - rewrite -Nat.add_mod_idemp_l in xy_eq. 2: micromega.Lia.lia. - rewrite -Nat.mul_mod_idemp_l in xy_eq. 2: micromega.Lia.lia. - rewrite Nat.mod_same in xy_eq. 2: micromega.Lia.lia. - rewrite Nat.mul_0_l in xy_eq. - rewrite Nat.mod_0_l in xy_eq. 2: micromega.Lia.lia. - rewrite Nat.add_0_l in xy_eq. - rewrite -Nat.add_mod_idemp_l in xy_eq. 2: micromega.Lia.lia. - rewrite -Nat.mul_mod_idemp_l in xy_eq. 2: micromega.Lia.lia. - rewrite Nat.mod_same in xy_eq. 2: micromega.Lia.lia. - rewrite Nat.mul_0_l in xy_eq. - rewrite Nat.mod_0_l in xy_eq. 2: micromega.Lia.lia. - rewrite Nat.add_0_l in xy_eq. - rewrite !Nat.mod_small in xy_eq. 2,3: apply Ascii.nat_ascii_bounded. - apply OrderedTypeEx.String_as_OT.nat_of_ascii_inverse in xy_eq. - subst. f_equal. - apply IHx. - rewrite -!addP in e. - rewrite -!mulP in e. - micromega.Lia.lia. -Qed. + unfold nat_of_ident in e. + destruct ident_eqType. + destruct class. + destruct eqtype_hasDecEq_mixin. + + admit. + (* induction (Ident.string_of_name (Ident.id_name x)) as [| a x_] in y, e |- *. *) + (* (* induction x as [| a x] in y, e |- *. *) *) + (* all: destruct (Ident.string_of_name (Ident.id_name y)) as [| b y_]. *) + (* all: simpl in e. *) + (* - reflexivity. *) + (* - rewrite -word_ssrZ.mulP in e. rewrite -plusE in e. *) + (* pose proof (nat_of_ident_pos y). *) + (* micromega.Lia.lia. *) + (* - rewrite -word_ssrZ.mulP in e. rewrite -plusE in e. *) + (* pose proof (nat_of_ident_pos x). *) + (* micromega.Lia.lia. *) + (* - apply (f_equal (λ a, Nat.modulo a 256)) in e as xy_eq. *) + (* rewrite -Nat.add_mod_idemp_l in xy_eq. 2: micromega.Lia.lia. *) + (* rewrite -Nat.mul_mod_idemp_l in xy_eq. 2: micromega.Lia.lia. *) + (* rewrite Nat.mod_same in xy_eq. 2: micromega.Lia.lia. *) + (* rewrite Nat.mul_0_l in xy_eq. *) + (* rewrite Nat.mod_0_l in xy_eq. 2: micromega.Lia.lia. *) + (* rewrite Nat.add_0_l in xy_eq. *) + (* rewrite -Nat.add_mod_idemp_l in xy_eq. 2: micromega.Lia.lia. *) + (* rewrite -Nat.mul_mod_idemp_l in xy_eq. 2: micromega.Lia.lia. *) + (* rewrite Nat.mod_same in xy_eq. 2: micromega.Lia.lia. *) + (* rewrite Nat.mul_0_l in xy_eq. *) + (* rewrite Nat.mod_0_l in xy_eq. 2: micromega.Lia.lia. *) + (* rewrite Nat.add_0_l in xy_eq. *) + (* rewrite !Nat.mod_small in xy_eq. 2,3: apply Ascii.nat_ascii_bounded. *) + (* apply OrderedTypeEx.String_as_OT.nat_of_ascii_inverse in xy_eq. *) + (* subst. f_equal. *) + (* apply IHx. *) + (* rewrite -!word_ssrZ.addP in e. *) + (* rewrite -!word_ssrZ.mulP in e. *) + (* micromega.Lia.lia. *) +(* Qed. *) +Admitted. Lemma injective_nat_of_p_id_ident : ∀ p x y, @@ -1104,25 +1123,25 @@ Proof. eapply coprime_neq. 3: eapply H. + reflexivity. - + unfold nat_of_stype. by rewrite Natpow_expn coprime_expr. - - intros ws H. + + unfold nat_of_stype. by rewrite Natpow_expn coprime_pexpr ; [ | apply is_positive ]. + - intros. exfalso. eapply coprime_neq. 3: eapply H. + reflexivity. - + unfold nat_of_stype. by rewrite Natpow_expn coprime_expr. + + unfold nat_of_stype. by rewrite Natpow_expn coprime_pexpr. - intros l H. exfalso. eapply coprime_neq. 3: eapply H. + reflexivity. - + unfold nat_of_stype. by rewrite Natpow_expn coprime_expr. + + unfold nat_of_stype. by rewrite Natpow_expn coprime_pexpr ; [ | apply is_positive ]. - intros ws H. exfalso. eapply coprime_neq. 3: eapply H. + reflexivity. - + unfold nat_of_stype. by rewrite Natpow_expn coprime_expr. + + unfold nat_of_stype. by rewrite Natpow_expn coprime_pexpr ; [ | apply is_positive ]. - intros l H. exfalso. eapply coprime_neq. @@ -1130,7 +1149,7 @@ Proof. + unfold nat_of_stype. apply/eqP. apply nesym. apply Nat.lt_neq. apply Nat.pow_gt_1. all: micromega.Lia.lia. - + unfold nat_of_stype. by rewrite Natpow_expn coprime_expl. + + unfold nat_of_stype. by rewrite Natpow_expn coprime_pexpl ; [ | apply is_positive ]. - intros l H. exfalso. eapply coprime_neq. @@ -1138,7 +1157,7 @@ Proof. + unfold nat_of_stype. apply/eqP. apply nesym. apply Nat.lt_neq. apply Nat.pow_gt_1. all: micromega.Lia.lia. - + unfold nat_of_stype. by rewrite Natpow_expn coprime_expl. + + unfold nat_of_stype. by rewrite Natpow_expn coprime_pexpl ; [ | apply is_positive ]. - intros l1 l2 H. destruct (l2 == l1) eqn:E. + by move: E=>/eqP ->. @@ -1153,8 +1172,8 @@ Proof. + unfold nat_of_stype. apply/eqP. apply nesym. apply Nat.lt_neq. apply Nat.pow_gt_1. all: micromega.Lia.lia. - + unfold nat_of_stype. rewrite !Natpow_expn coprime_expl; auto. - by rewrite coprime_expr. + + unfold nat_of_stype. rewrite !Natpow_expn coprime_pexpl; [ | apply is_positive ]. + by rewrite coprime_pexpr. - intros ws H. exfalso. eapply coprime_neq. @@ -1163,7 +1182,7 @@ Proof. apply Nat.pow_gt_1. 1: micromega.Lia.lia. apply/eqP. by case ws. - + unfold nat_of_stype. by rewrite Natpow_expn coprime_expl. + + unfold nat_of_stype. by rewrite Natpow_expn coprime_pexpl. - intros ws H. exfalso. eapply coprime_neq. @@ -1172,7 +1191,7 @@ Proof. apply Nat.pow_gt_1. 1: micromega.Lia.lia. apply/eqP. by case ws. - + unfold nat_of_stype. by rewrite Natpow_expn coprime_expl. + + unfold nat_of_stype. by rewrite Natpow_expn coprime_pexpl. - intros l ws H. exfalso. eapply coprime_neq. @@ -1181,8 +1200,8 @@ Proof. apply Nat.pow_gt_1. 1: micromega.Lia.lia. apply/eqP. by case ws. - + unfold nat_of_stype. rewrite !Natpow_expn coprime_expl; auto. - by rewrite coprime_expr. + + unfold nat_of_stype. rewrite !Natpow_expn coprime_pexpl; [ | apply is_positive ]. + by rewrite coprime_pexpr; [ | apply is_positive ]. - intros ws1 ws2 H. destruct (ws2 == ws1) eqn:E. + by move: E=>/eqP ->. @@ -1242,7 +1261,7 @@ Proof. Qed. #[local] Definition unsupported : typed_code := - ('unit ; ret (chCanonical 'unit)). + ('unit ; assert false). Lemma truncate_val_type : ∀ ty v v', @@ -1311,7 +1330,7 @@ Proof. exact (λ '(x, y), False). (* TODO *) Defined. -Definition translate_gvar (p : p_id) (x : gvar) : raw_code (encode x.(gv).(vtype)) := +Program Definition translate_gvar (p : p_id) (x : gvar) : raw_code (encode x.(gv).(vtype)) := if is_lvar x then translate_get_var p x.(gv).(v_var) else @@ -1499,13 +1518,15 @@ Proof. rewrite foldl_foldr_setm. 1: reflexivity. rewrite map_inj_uniq. - unfold ziota. - rewrite map_inj_uniq. - + apply iota_uniq. - + intros n m H. - micromega.Lia.lia. - - intros n m H. - micromega.Lia.lia. -Qed. + admit. + (* rewrite map_inj_uniq. *) + (* + apply iota_uniq. *) + (* + intros n m H. *) + (* micromega.Lia.lia. *) + (* - intros n m H. *) + (* micromega.Lia.lia. *) + (* Qed. *) +Admitted. (* From WArray.set *) Definition chArray_set {ws} (a : 'array) (aa : arr_access) (p : Z) (w : word ws) := @@ -1847,7 +1868,7 @@ Fixpoint list_lchtuple {ts} : lchtuple ([seq encode t | t <- ts]) → [choiceTyp (* corresponds to exec_sopn *) Definition translate_exec_sopn (o : sopn) (vs : seq typed_chElement) := - list_lchtuple (tr_app_sopn_tuple _ (sopn_sem o) vs). + list_lchtuple (tr_app_sopn_tuple _ (@sopn_sem _ (Build_MSFsize U32 (* TOOD: what size? *)) _ o) vs). Fixpoint foldl2 {A B R} (f : R → A → B → R) (la : seq A) (lb : seq B) r := match la with @@ -1992,7 +2013,7 @@ Proof. apply ziota_ind. - auto. - intros i l h Ih. - rewrite (@in_cons word_ssrZ.Z_eqType). + rewrite (@in_cons BinNums_Z__canonical__eqtype_Equality). simpl. rewrite <- addE. destruct (_ == _) eqn:eb. @@ -2048,11 +2069,11 @@ Proof. - apply hr. assumption. Qed. -#[local] Open Scope vmap_scope. +#[local] Open Scope vm_scope. -Definition rel_vmap (vm : vmap) (p : p_id) (h : heap) := +Definition rel_vmap (vm : Vm.t (wsw := nosubword) (* TODO: nosubword or withsubword *)) (p : p_id) (h : heap) := ∀ (i : var) (v : sem_t (vtype i)), - vm.[i] = ok v → + vm.[i] = to_val v → get_heap h (translate_var p i) = coerce_to_choice_type _ (embed v). Lemma rel_vmap_set_heap_neq vm m_id m_id' i v h : @@ -2080,11 +2101,11 @@ Proof. Qed. Lemma empty_stack_spec m_id : - forall h, empty_stack m_id h -> rel_vmap vmap0 m_id h. + forall h, empty_stack m_id h -> rel_vmap Vm.init m_id h. Proof. intros h emp i v hv. rewrite coerce_to_choice_type_K. - rewrite Fv.get0 in hv. + rewrite Vm.initP in hv. rewrite emp. unfold translate_var. destruct (vtype i); now inversion hv. @@ -2130,7 +2151,7 @@ Qed. Hint Resolve valid_prec : prefix. (* stack *) -Definition stack_frame := (vmap * p_id * p_id * list p_id)%type. +Definition stack_frame := (Vm.t (wsw := nosubword) (* TODO: nosubword or withsubword *) * p_id * p_id * list p_id)%type. Definition stack := list stack_frame. @@ -2484,7 +2505,7 @@ Qed. Lemma valid_stack_push vm m_id s_id s_st st : ∀ h, valid_stack ((vm, m_id, s_id, s_st) :: st) h -> - valid_stack ((vmap0, s_id~1, s_id~1, [::]) :: ((vm, m_id, s_id~0, s_st) :: st)) h. + valid_stack ((Vm.init, s_id~1, s_id~1, [::]) :: ((vm, m_id, s_id~0, s_st) :: st)) h. Proof. intros h vst. assert (vst2:=vst). @@ -2589,9 +2610,8 @@ Proof. easy. Qed. -Definition rel_estate (s : estate) (m_id : p_id) (s_id : p_id) (s_st : list p_id) (st : stack) (h : heap) := - rel_mem s.(emem) h /\ valid_stack ((s.(evm), m_id, s_id, s_st) :: st) h. - +Definition rel_estate (s : @estate (nosubword) (* TODO: nosubword or withsubword *) syscall_state {| _pd := pd ; _msf_size := (Build_MSFsize U32 (* TOOD: what size? *)) |}) (m_id : p_id) (s_id : p_id) (s_st : list p_id) (st : stack) (h : heap) := + (rel_mem (s.(emem)) h /\ valid_stack ((s.(evm), m_id, s_id, s_st) :: st) h). Lemma translate_read_estate : ∀ s ptr sz w m_id s_id s_st c_stack m, @@ -2668,24 +2688,27 @@ Proof. Qed. Lemma get_var_get_heap : - ∀ x s v m_id m, - get_var (evm s) x = ok v → + ∀ x (s : @estate (nosubword) (* TODO: nosubword or withsubword *) syscall_state {| _pd := pd; _msf_size := (Build_MSFsize U32 (* TOOD: what size? *)) |}) (v : value) m_id m, + get_var (true (* TODO: wdb *)) (evm s) x = ok v → rel_vmap (evm s) m_id m → get_heap m (translate_var m_id x) = coerce_to_choice_type _ (translate_value v). Proof. - intros x s v m c_stack ev hevm. - unfold get_var in ev. - eapply on_vuP. 3: exact ev. 2: discriminate. - intros sx esx esv. - eapply hevm in esx. subst. - rewrite coerce_to_choice_type_translate_value_to_val. - rewrite esx. rewrite coerce_to_choice_type_K. reflexivity. -Qed. +(* intros x s v m c_stack ev hevm. *) +(* intros. *) +(* unfold get_var in ev. *) +(* rewrite (@hevm x v). *) +(* + simpl. *) +(* rewrite coerce_to_choice_type_K. *) +(* rewrite <- coerce_to_choice_type_translate_value_to_val. *) +(* reflexivity. *) +(* + destruct ((evm s).[x]) ; [ .. | discriminate ] ; now apply ok_inj in ev. *) +(* Qed. *) +Admitted. Lemma translate_get_var_correct : - ∀ x s v m_id s_id s_st st (cond : heap → Prop), - get_var (evm s) x = ok v → + ∀ x s (v : value) m_id s_id s_st st (cond : heap → Prop), + get_var (true (* TODO: wdb *)) (evm s) x = ok v → (∀ m, cond m → rel_estate s m_id s_id s_st st m) → ⊢ ⦃ cond ⦄ translate_get_var m_id x ⇓ coerce_to_choice_type _ (translate_value v) @@ -2704,7 +2727,7 @@ Proof. Qed. Lemma translate_gvar_correct (x : gvar) (v : value) s (cond : heap → Prop) m_id s_id s_st st : - get_gvar gd (evm s) x = ok v → + get_gvar (true (* TODO: wdb *)) gd (evm s) x = ok v → (∀ m, cond m → rel_estate s m_id s_id s_st st m) → ⊢ ⦃ cond ⦄ translate_gvar m_id x ⇓ coerce_to_choice_type _ (translate_value v) @@ -2714,7 +2737,11 @@ Proof. unfold translate_gvar. unfold get_gvar in ev. destruct is_lvar. - - eapply translate_get_var_correct. all: eassumption. + - epose (translate_get_var_correct (x.(gv))). + unfold to_val in e. + simpl in e. + + eapply translate_get_var_correct. all: eassumption. - rewrite ev. apply u_ret. intros m hm. split. 1: assumption. @@ -2737,7 +2764,8 @@ Proof. - noconf e. simpl. rewrite !coerce_to_choice_type_K. reflexivity. - noconf e. simpl. rewrite !coerce_to_choice_type_K. reflexivity. - simpl. rewrite !coerce_to_choice_type_K. - unfold WArray.cast in e. destruct (_ <=? _)%Z. 2: discriminate. + unfold WArray.cast in e. + destruct (p == len) in e. 2: discriminate. noconf e. simpl. reflexivity. - simpl. rewrite !coerce_to_choice_type_K. rewrite e. reflexivity. @@ -2871,7 +2899,7 @@ Proof. Qed. Lemma translate_pexpr_type p s₁ e v : - sem_pexpr gd s₁ e = ok v → + @sem_pexpr (nosubword) (* TODO: nosubword or withsubword *) syscall_state {| _pd := pd; _msf_size := (Build_MSFsize U32 (* TOOD: what size? *)) |} mk_spp (true (* TODO: wdb *)) gd s₁ e = ok v → (translate_pexpr p e).π1 = choice_type_of_val v. Proof. intros. @@ -2880,9 +2908,8 @@ Proof. 1-3: noconf H; reflexivity. - eapply type_of_get_gvar in H. unfold choice_type_of_val. - rewrite H. - unfold translate_gvar. - reflexivity. + apply (ssrbool.elimT eqP) in H. + now rewrite H. - simpl in H. jbind H x h1. destruct x. all: try discriminate. @@ -2948,31 +2975,32 @@ Lemma chArray_get_correct (len : BinNums.positive) (a : WArray.array len) (z : Z WArray.get aa ws a z = ok s → chArray_get ws (translate_value (Varr a)) z (mk_scale aa ws) = translate_value (Vword s). Proof. - intros H. - simpl. - unfold WArray.get, read in H. - destruct is_align. 2: discriminate. - simpl in H. - jbind H l E. noconf H. - unfold chArray_get. - f_equal. - revert l E. - apply ziota_ind. - - intros l E. noconf E. reflexivity. - - intros i l E IH l0 H. - destruct l0. - { apply mapM_nil in H. discriminate. } - apply mapM_cons in H as [H H0]. - simpl. - rewrite (IH l0). 2: assumption. - apply f_equal2. 2: reflexivity. - apply chArray_get8_correct. - assumption. -Qed. +Admitted. +(* intros H. *) +(* simpl. *) +(* unfold WArray.get, read in H. *) +(* destruct is_align. 2: discriminate. *) +(* cbn in H. *) +(* jbind H l E. noconf H. *) +(* unfold chArray_get. *) +(* f_equal. *) +(* revert l E. *) +(* apply ziota_ind. *) +(* - intros l E. noconf E. reflexivity. *) +(* - intros i l E IH l0 H. *) +(* destruct l0. *) +(* { apply mapM_nil in H. discriminate. } *) +(* apply mapM_cons in H as [H H0]. *) +(* simpl. *) +(* rewrite (IH l0). 2: assumption. *) +(* apply f_equal2. 2: reflexivity. *) +(* apply chArray_get8_correct. *) +(* assumption. *) +(* Qed. *) Lemma chArray_write_correct : ∀ ws len (a : WArray.array len) i (w : word ws) t, - write a i w = ok t → + write (Pointer := WArray.PointerZ) a i w = ok t → chArray_write (translate_value (Varr a)) i w = translate_value (Varr t). Proof. intros. @@ -3063,7 +3091,7 @@ Proof. apply ziota_ind. - simpl. reflexivity. - simpl. intros k l h ih. - rewrite (@in_cons word_ssrZ.Z_eqType). + rewrite (@in_cons BinNums_Z__canonical__eqtype_Equality). destruct (_ == _) eqn:eb. + simpl. move: eb => /eqP eb. subst. unfold chArray_set8. @@ -3080,7 +3108,7 @@ Qed. Lemma embed_read8 : ∀ len (a : WArray.array len) (z : Z) v, - read a z U8 = ok v → + read (Pointer := WArray.PointerZ) a z U8 = ok v → chArray_get U8 (embed_array a) z 1 = translate_value (Vword v). Proof. intros len a z v h. @@ -3124,7 +3152,7 @@ Proof. Qed. Lemma translate_pexprs_types p s1 es vs : - mapM (sem_pexpr gd s1) es = ok vs → + mapM (@sem_pexpr (nosubword) (* TODO: nosubword or withsubword *) syscall_state {| _pd := pd; _msf_size := (Build_MSFsize U32 (* TOOD: what size? *)) |} mk_spp (true (* TODO: wdb *)) gd s1) es = ok vs → [seq (translate_pexpr p e).π1 | e <- es] = [seq choice_type_of_val v | v <- vs]. Proof. revert vs. induction es; intros. @@ -3208,7 +3236,7 @@ Proof. + move: E => /eqP ->. rewrite eq_refl. reflexivity. - + destruct (@eq_op (Ord.eqType Z_ordType) _ _)%B eqn:E2. + + destruct (@eq_op (BinNums_Z__canonical__Ord_Ord) _ _)%B eqn:E2. { move: E2 E => /eqP ->. rewrite eq_refl. easy. } apply IHfmval. eapply path_sorted. @@ -3262,11 +3290,11 @@ Proof. unfold WArray.get, read. rewrite Hij. destruct is_align. 2: reflexivity. - simpl. f_equal. - apply eq_mapM. intros. - rewrite H. - reflexivity. -Qed. + simpl. f_equal. Admitted. +(* apply eq_mapM. intros. *) +(* rewrite H. *) +(* reflexivity. *) +(* Qed. *) (* this should be moved to the jasmin repo *) Lemma in_rcons_r {S : eqType} (a : S) l : @@ -3387,10 +3415,10 @@ Proof. assumption. Qed. -Context `{asm_correct : ∀ o, sem_correct (tin (get_instr_desc (Oasm o))) (sopn_sem (Oasm o))}. +Context `{asm_correct : ∀ o, sem_correct (tin (get_instr_desc (Oasm o))) (@sopn_sem _ (Build_MSFsize U32 (* TOOD: what size? *)) _ (Oasm o))}. Lemma app_sopn_list_tuple_correct o vs vs' : - app_sopn of_val (sopn_sem o) vs = ok vs' → + app_sopn of_val (@sopn_sem _ (Build_MSFsize U32 (* TOOD: what size? *)) _ o) vs = ok vs' → tr_app_sopn_tuple _ (sopn_sem o) [seq to_typed_chElement (translate_value v) | v <- vs] = embed_tuple vs'. @@ -3400,20 +3428,19 @@ Proof using asm_correct. erewrite tr_app_sopn_correct. - reflexivity. - destruct o. - + repeat constructor. - cbn -[wsize_size WArray.copy unembed embed truncate_el] in *; intros. - rewrite (unembed_embed (sarr _)). - reflexivity. - + repeat constructor. - + repeat constructor. - + repeat constructor. - + repeat constructor. + + destruct p ; [ repeat constructor ; + cbn -[wsize_size WArray.copy unembed embed truncate_el] in *; intros ; + rewrite (unembed_embed (sarr _)) ; + reflexivity | .. ] ; repeat constructor. + + destruct s ; try now repeat constructor. + * admit. + * admit. + apply asm_correct. - assumption. -Qed. +Admitted. (* Qed. *) Lemma translate_exec_sopn_correct (o : sopn) (ins outs : values) : - exec_sopn o ins = ok outs → + @exec_sopn _ values {| _pd := pd; _msf_size := (Build_MSFsize U32 (* TOOD: what size? *)) |} _ o ins = ok outs → translate_exec_sopn o [seq totce (translate_value v) | v <- ins] = [seq totce (translate_value v) | v <- outs]. Proof using asm_correct. @@ -3468,7 +3495,7 @@ Qed. Lemma translate_pexpr_correct : ∀ (e : pexpr) s₁ v (cond : heap → Prop) m_id s_id s_st st, - sem_pexpr gd s₁ e = ok v → + (@sem_pexpr (nosubword) (* TODO: nosubword or withsubword *) syscall_state {| _pd := pd; _msf_size := (Build_MSFsize U32 (* TOOD: what size? *)) |} mk_spp (true (* TODO: wdb *)) gd s₁ e) = ok v → (∀ m, cond m → rel_estate s₁ m_id s_id s_st st m) → ⊢ ⦃ cond ⦄ (translate_pexpr m_id e).π2 ⇓ @@ -3495,20 +3522,20 @@ Proof. + destruct x as [gx gs]. simpl in *. unfold is_lvar in hlvar. simpl in hlvar. move: hlvar => /eqP hlvar. subst. unfold get_var in h1. - unfold on_vu in h1. destruct Fv.get as [sx | e] eqn:e1. - 2:{ destruct e. all: discriminate. } - noconf h1. - eapply u_get_remember. simpl. - intro v. apply u_ret. - intros m [hm e]. unfold u_get in e. subst. - split. 1: assumption. - apply hcond in hm. - destruct hm as [hm hst]. - invert_stack hst hst hdisj hevm hpre hvalid hnin hnodup hvalid1 hpre1 hdisj1 hdisj2; auto. - apply hevm in e1. rewrite e1. - simpl. rewrite coerce_to_choice_type_K. - rewrite coerce_to_choice_type_translate_value_to_val. - reflexivity. + admit. + (* 2:{ destruct e. all: discriminate. } *) + (* noconf h1. *) + (* eapply u_get_remember. simpl. *) + (* intro v. apply u_ret. *) + (* intros m [hm e]. unfold u_get in e. subst. *) + (* split. 1: assumption. *) + (* apply hcond in hm. *) + (* destruct hm as [hm hst]. *) + (* invert_stack hst hst hdisj hevm hpre hvalid hnin hnodup hvalid1 hpre1 hdisj1 hdisj2; auto. *) + (* apply hevm in e1. rewrite e1. *) + (* simpl. rewrite coerce_to_choice_type_K. *) + (* rewrite coerce_to_choice_type_translate_value_to_val. *) + (* reflexivity. *) + simpl. rewrite h1. apply u_ret. auto. @@ -3527,10 +3554,10 @@ Proof. split. 1: assumption. erewrite translate_pexpr_type. 2: eassumption. rewrite coerce_to_choice_type_K. - eapply type_of_get_gvar in ent as ety. rewrite <- ety. - rewrite !coerce_to_choice_type_K. - erewrite translate_to_int. 2: eassumption. - apply chArray_get_correct. assumption. + eapply type_of_get_gvar in ent as ety. admit. (* rewrite <- ety. *) + (* rewrite !coerce_to_choice_type_K. *) + (* erewrite translate_to_int. 2: eassumption. *) + (* apply chArray_get_correct. assumption. *) - (* Psub *) simpl. simpl in h1. jbind h1 nt hnt. destruct nt. all: try discriminate. @@ -3546,10 +3573,10 @@ Proof. erewrite translate_pexpr_type. 2: eassumption. rewrite coerce_to_choice_type_K. erewrite translate_to_int. 2: eassumption. - apply type_of_get_gvar in hnt. rewrite <- hnt. - rewrite !coerce_to_choice_type_K. - apply chArray_get_sub_correct. - assumption. + apply type_of_get_gvar in hnt. admit. (* rewrite <- hnt. *) + (* rewrite !coerce_to_choice_type_K. *) + (* apply chArray_get_sub_correct. *) + (* assumption. *) - (* Pload *) simpl in h1. jbind h1 w1 hw1. jbind hw1 vx hvx. jbind h1 w2 hw2. jbind hw2 v2 hv2. jbind h1 w hw. noconf h1. @@ -3575,10 +3602,10 @@ Proof. destruct hm2 as [hm2 hst]. invert_stack hst hst hdisj hevm hpre hvalid hnin hnodup hvalid1 hpre1 hdisj1 hdisj2; auto. erewrite get_var_get_heap. 2-3: eassumption. - simpl. erewrite <- type_of_get_var. 2: eassumption. - rewrite coerce_to_choice_type_K. - eapply translate_to_word in hw1 as e1. rewrite e1. clear e1. - eapply translate_read_estate. all: eassumption. + simpl. admit. (* erewrite <- type_of_get_var. 2: eassumption. *) + (* rewrite coerce_to_choice_type_K. *) + (* eapply translate_to_word in hw1 as e1. rewrite e1. clear e1. *) + (* eapply translate_read_estate. all: eassumption. *) - (* Papp1 *) simpl in *. jbind h1 v' h2. @@ -3697,10 +3724,10 @@ Proof. erewrite translate_pexpr_type. 2: eassumption. rewrite coerce_to_choice_type_K. apply translate_truncate_val. assumption. -Qed. +Admitted. (* Qed. *) Lemma translate_pexprs_correct s m_id s_id s_st st vs es : - sem_pexprs gd s es = ok vs → + @sem_pexprs (nosubword) (* TODO: nosubword or withsubword *) syscall_state {| _pd := pd; _msf_size := (Build_MSFsize U32 (* TOOD: what size? *)) |} mk_spp (true (* TODO: wdb *)) gd s es = ok vs → List.Forall2 (λ c v, ⊢ ⦃ rel_estate s m_id s_id s_st st ⦄ c.π2 @@ -3734,7 +3761,7 @@ Corollary bind_list_pexpr_correct (cond : heap → Prop) (es : pexprs) (vs : list value) (s1 : estate) m_id s_id s_st st (hc : ∀ m : heap, cond m → rel_estate s1 m_id s_id s_st st m) - (h : sem_pexprs gd s1 es = ok vs) : + (h : @sem_pexprs (nosubword) (* TODO: nosubword or withsubword *) syscall_state {| _pd := pd; _msf_size := (Build_MSFsize U32 (* TOOD: what size? *)) |} mk_spp (true (* TODO: wdb *)) gd s1 es = ok vs) : ⊢ ⦃ cond ⦄ bind_list [seq translate_pexpr m_id e | e <- es] ⇓ [seq totce (translate_value v) | v <- vs] @@ -3762,7 +3789,7 @@ Qed. Corollary translate_pexpr_correct_cast : ∀ (e : pexpr) s₁ v m_id s_id s_st st (cond : heap → Prop), - sem_pexpr gd s₁ e = ok v → + @sem_pexpr (nosubword) (* TODO: nosubword or withsubword *) syscall_state {| _pd := pd; _msf_size := (Build_MSFsize U32 (* TOOD: what size? *)) |} mk_spp (true (* TODO: wdb *)) gd s₁ e = ok v → (∀ m, cond m → rel_estate s₁ m_id s_id s_st st m) → ⊢ ⦃ cond ⦄ coerce_typed_code _ (translate_pexpr m_id e) ⇓ @@ -3795,70 +3822,72 @@ Proof. eapply translate_write_estate. all: assumption. Qed. -Lemma valid_stack_set_var i v vm s m_id s_id s_st st m : +Lemma valid_stack_set_var i v vm (s : @estate (nosubword) (* TODO: nosubword or withsubword *) syscall_state {| _pd := pd; _msf_size := (Build_MSFsize U32 (* TOOD: what size? *)) |}) m_id s_id s_st st m : valid_stack ((s.(evm), m_id, s_id, s_st) :: st) m -> - set_var (evm s) i v = ok vm -> + set_var (true (* TODO: wdb *)) (evm s) i v = ok vm -> valid_stack ((vm, m_id, s_id, s_st) :: st) (set_heap m (translate_var m_id i) (truncate_el (vtype i) (translate_value v))). Proof. intros vs hsv. assert (vs':=vs). invert_stack vs hst hdisj hevm hpre hvalid hnin hnodup hvalid1 hpre1 hdisj1 hdisj2; auto. - eapply set_varP. 3: exact hsv. - - intros v1 hv1 eyl; subst. - eapply valid_stack_cons; unfold valid_stack_frame; split_and; eauto. - + eapply valid_stack_set_heap. - eassumption. - + intros vi vt ev. - destruct (vi == i) eqn:evar. - all: move: evar => /eqP evar. - * subst. rewrite Fv.setP_eq in ev. noconf ev. - rewrite get_set_heap_eq. rewrite coerce_to_choice_type_K. - eapply translate_of_val in hv1 as e. - rewrite e. apply coerce_to_choice_type_translate_value_to_val. - * rewrite Fv.setP_neq in ev. - 2:{ apply /eqP. eauto. } - rewrite get_set_heap_neq. - 2:{ - apply /eqP. intro ee. - apply injective_translate_var in ee. - contradiction. - } - eapply hevm in ev. assumption. - + eapply valid_set_heap_prec; auto. - + intros s_id' s_in'. - eapply valid_set_heap_prec. - 1: apply hvalid1; auto. - apply hpre1. assumption. - - intros hbo hyl hset; subst. - eapply valid_stack_cons; unfold valid_stack_frame; split_and; auto. - + eapply valid_stack_set_heap. - eassumption. - + intros vi vt ev. - destruct (vi == i) eqn:evar. - all: move: evar => /eqP evar. - 1:{ - exfalso. subst. rewrite Fv.setP_eq in ev. - clear - ev hbo. destruct (vtype i). all: discriminate. - } - rewrite Fv.setP_neq in ev. - 2:{ apply /eqP. eauto. } - rewrite get_set_heap_neq. - 2:{ - apply /eqP. intro ee. - apply injective_translate_var in ee. - contradiction. - } - eapply hevm in ev. assumption. - + eapply valid_set_heap_prec; auto. - + intros s_id' s_in'. - eapply valid_set_heap_prec. - 1: apply hvalid1; auto. - apply hpre1. assumption. -Qed. + admit. +(* eapply set_varP. 3: exact hsv. *) +(* - intros v1 hv1 eyl; subst. *) +(* eapply valid_stack_cons; unfold valid_stack_frame; split_and; eauto. *) +(* + eapply valid_stack_set_heap. *) +(* eassumption. *) +(* + intros vi vt ev. *) +(* destruct (vi == i) eqn:evar. *) +(* all: move: evar => /eqP evar. *) +(* * subst. rewrite Fv.setP_eq in ev. noconf ev. *) +(* rewrite get_set_heap_eq. rewrite coerce_to_choice_type_K. *) +(* eapply translate_of_val in hv1 as e. *) +(* rewrite e. apply coerce_to_choice_type_translate_value_to_val. *) +(* * rewrite Fv.setP_neq in ev. *) +(* 2:{ apply /eqP. eauto. } *) +(* rewrite get_set_heap_neq. *) +(* 2:{ *) +(* apply /eqP. intro ee. *) +(* apply injective_translate_var in ee. *) +(* contradiction. *) +(* } *) +(* eapply hevm in ev. assumption. *) +(* + eapply valid_set_heap_prec; auto. *) +(* + intros s_id' s_in'. *) +(* eapply valid_set_heap_prec. *) +(* 1: apply hvalid1; auto. *) +(* apply hpre1. assumption. *) +(* - intros hbo hyl hset; subst. *) +(* eapply valid_stack_cons; unfold valid_stack_frame; split_and; auto. *) +(* + eapply valid_stack_set_heap. *) +(* eassumption. *) +(* + intros vi vt ev. *) +(* destruct (vi == i) eqn:evar. *) +(* all: move: evar => /eqP evar. *) +(* 1:{ *) +(* exfalso. subst. rewrite Fv.setP_eq in ev. *) +(* clear - ev hbo. destruct (vtype i). all: discriminate. *) +(* } *) +(* rewrite Fv.setP_neq in ev. *) +(* 2:{ apply /eqP. eauto. } *) +(* rewrite get_set_heap_neq. *) +(* 2:{ *) +(* apply /eqP. intro ee. *) +(* apply injective_translate_var in ee. *) +(* contradiction. *) +(* } *) +(* eapply hevm in ev. assumption. *) +(* + eapply valid_set_heap_prec; auto. *) +(* + intros s_id' s_in'. *) +(* eapply valid_set_heap_prec. *) +(* 1: apply hvalid1; auto. *) +(* apply hpre1. assumption. *) +(* Qed. *) +Admitted. Lemma translate_write_var_estate : ∀ i v s1 s2 m_id s_id s_st st m, - write_var i v s1 = ok s2 → + write_var (true (* TODO: wdb *)) i v s1 = ok s2 → rel_estate s1 m_id s_id s_st st m → rel_estate s2 m_id s_id s_st st (set_heap m (translate_var m_id i) (truncate_el i.(vtype) (translate_value v))). Proof using asm_correct gd. @@ -3875,7 +3904,7 @@ Qed. Lemma translate_write_var_correct : ∀ es₁ es₂ m_id s_id s_st st y v, - write_var y v es₁ = ok es₂ → + write_var (true (* TODO: wdb *)) y v es₁ = ok es₂ → ⊢ ⦃ rel_estate es₁ m_id s_id s_st st ⦄ translate_write_var m_id y (totce (translate_value v)) ⇓ tt @@ -3892,7 +3921,7 @@ Qed. Lemma translate_write_lval_correct : ∀ es₁ es₂ m_id s_id s_st st y v, - write_lval gd y v es₁ = ok es₂ → + @write_lval (nosubword) (* TODO: nosubword or withsubword *) syscall_state {| _pd := pd; _msf_size := (Build_MSFsize U32 (* TOOD: what size? *)) |} mk_spp (true (* TODO: wdb *)) gd y v es₁ = ok es₂ → ⊢ ⦃ rel_estate es₁ m_id s_id s_st st ⦄ translate_write_lval m_id y (totce (translate_value v)) ⇓ tt @@ -3903,11 +3932,12 @@ Proof using asm_correct. - simpl. apply u_ret_eq. intros hp hr. simpl in hw. unfold write_none in hw. - destruct is_sbool eqn:eb. - + unfold on_vu in hw. destruct of_val as [| []]. - all: noconf hw. all: assumption. - + unfold on_vu in hw. destruct of_val as [| []]. - all: noconf hw. assumption. + admit. + (* destruct is_sbool eqn:eb. *) + (* + unfold on_vu in hw. destruct of_val as [| []]. *) + (* all: noconf hw. all: assumption. *) + (* + unfold on_vu in hw. destruct of_val as [| []]. *) + (* all: noconf hw. assumption. *) - now eapply translate_write_var_correct. - simpl. simpl in hw. jbind hw vx hvx. jbind hvx vx' hvx'. jbind hw ve hve. @@ -3932,10 +3962,10 @@ Proof using asm_correct. erewrite get_var_get_heap. 3: eapply invert_valid_stack; apply hm'. 2: eassumption. - simpl. erewrite <- type_of_get_var. 2: eassumption. - rewrite coerce_to_choice_type_K. - eapply translate_to_word in hvx as ew. rewrite ew. clear ew. - assumption. + simpl. admit. (* erewrite <- type_of_get_var. 2: eassumption. *) + (* rewrite coerce_to_choice_type_K. *) + (* eapply translate_to_word in hvx as ew. rewrite ew. clear ew. *) + (* assumption. *) - simpl. simpl in hw. jbind hw nt hnt. destruct nt. all: try discriminate. jbind hw i hi. jbind hi i' hi'. @@ -3962,12 +3992,13 @@ Proof using asm_correct. 2: eassumption. Opaque translate_value. simpl. Transparent translate_value. eapply type_of_get_var in hnt as ety. simpl in ety. - apply (f_equal encode) in ety. simpl in ety. - rewrite -ety. rewrite !coerce_to_choice_type_K. - erewrite chArray_set_correct. 2: eassumption. - eapply translate_write_var_estate in hs. - 2: eassumption. - assumption. + admit. + (* apply (f_equal encode) in ety. simpl in ety. *) + (* rewrite -ety. rewrite !coerce_to_choice_type_K. *) + (* erewrite chArray_set_correct. 2: eassumption. *) + (* eapply translate_write_var_estate in hs. *) + (* 2: eassumption. *) + (* assumption. *) - simpl. simpl in hw. jbind hw nt hnt. destruct nt. all: try discriminate. jbind hw i hi. jbind hi i' hi'. @@ -3994,20 +4025,21 @@ Proof using asm_correct. 2: eassumption. Opaque translate_value. simpl. Transparent translate_value. eapply type_of_get_var in hnt as ety. simpl in ety. - apply (f_equal encode) in ety. simpl in ety. - rewrite -ety. rewrite !coerce_to_choice_type_K. - erewrite chArray_set_sub_correct. 2: eassumption. - eapply translate_write_var_estate in hs. - 2: eassumption. - assumption. -Qed. + admit. + (* apply (f_equal encode) in ety. simpl in ety. *) + (* rewrite -ety. rewrite !coerce_to_choice_type_K. *) + (* erewrite chArray_set_sub_correct. 2: eassumption. *) + (* eapply translate_write_var_estate in hs. *) + (* 2: eassumption. *) + (* assumption. *) +Admitted. (* Qed. *) Lemma translate_write_lvals_cons p l ls v vs : translate_write_lvals p (l :: ls) (v :: vs) = (translate_write_lval p l v ;; translate_write_lvals p ls vs). Proof. reflexivity. Qed. Lemma translate_write_lvals_correct m_id s_id s_st st s1 ls vs s2 : - write_lvals gd s1 ls vs = ok s2 → + @write_lvals (nosubword) (* TODO: nosubword or withsubword *) syscall_state {| _pd := pd; _msf_size := (Build_MSFsize U32 (* TOOD: what size? *)) |} mk_spp (true (* TODO: wdb *)) gd s1 ls vs = ok s2 → ⊢ ⦃ rel_estate s1 m_id s_id s_st st ⦄ translate_write_lvals m_id ls [seq totce (translate_value v) | v <- vs] ⇓ tt @@ -4038,7 +4070,7 @@ Proof. Qed. Lemma translate_write_vars_correct m_id s_id s_st st s1 ls vs s2 : - write_vars ls vs s1 = ok s2 → + write_vars (true (* TODO: wdb *)) ls vs s1 = ok s2 → ⊢ ⦃ rel_estate s1 m_id s_id s_st st ⦄ translate_write_vars m_id ls [seq totce (translate_value v) | v <- vs] ⇓ tt @@ -4174,7 +4206,7 @@ Proof using P asm_op asmop pd fcp. vlo ← loᵗ ;; vhi ← hiᵗ ;; translate_for i (wrange d vlo vhi) m_id cᵗ fresh) - | Ccall ii xs f args => + | Ccall (* ii *) xs f args => let (s_id', fresh) := fresh_id s_id in let cs := [seq (translate_pexpr (p_globs P) m_id e) | e <- args] in (s_id', @@ -4249,7 +4281,7 @@ Proof using P asm_op asmop pd fcp. apply (bind (translate_cmd tr_f_body f_body p p).2) => _. (* Look up the results in their locations and return them. *) - pose (map (λ x, totc _ (translate_get_var f (v_var x))) f_res) as cres. + pose (map (λ x, totc _ (translate_get_var p(* f *) (v_var x))) f_res) as cres. exact (bind_list' f_tyout cres). - exact fset0. - exact [interface]. @@ -4416,7 +4448,7 @@ Proof. | Cfor i r c => cmd_fs c fs | Cwhile _ c1 _ c2 => cmd_fs c1 fs && cmd_fs c2 fs - | Ccall ii xs f args => + | Ccall (* ii *) xs f args => f \in [seq p.1 | p <- fs] end. Defined. @@ -4445,7 +4477,7 @@ with handled_instr_r (i : instr_r) := | Cif e c₁ c₂ => List.forallb handled_instr c₁ && List.forallb handled_instr c₂ | Cfor i r c => List.forallb handled_instr c | Cwhile al cb e c => false - | Ccall ii l fn es => true + | Ccall (* ii *) l fn es => true end. Definition handled_cmd (c : cmd) := @@ -4498,7 +4530,8 @@ Definition handled_program (P : uprog) := Context `{sc_sem : syscall_sem }. Fact sem_call_get_some {P m1 scs1 gn vargs m2 scs2 vres} : - (sem_call P scs1 m1 gn vargs scs2 m2 vres → + (@sem_call (nosubword) (* TODO: nosubword or withsubword *) direct_c (* TODO: direct? *) asm_op syscall_state {| _pd := pd; _msf_size := (Build_MSFsize U32 (* TOOD: what size? *)); |} mk_spp {| + _asmop := asmop; _sc_sem := sc_sem |} _ (sCP_unit (* TODO *)) P (tt (* TODO *)) scs1 m1 gn vargs scs2 m2 vres → ∃ f, get_fundef (p_funcs P) gn = Some f ). Proof. intros H. inversion H. exists f. easy. Qed. @@ -4526,7 +4559,7 @@ Proof. now rewrite E. Qed. -Context `{asm_correct : ∀ o, sem_correct (tin (get_instr_desc (Oasm o))) (sopn_sem (Oasm o))}. +Context `{asm_correct : ∀ o, sem_correct (tin (get_instr_desc (Oasm o))) (@sopn_sem _ (Build_MSFsize U32 (* TOOD: what size? *)) _ (Oasm o))}. Context (gd : glob_decls). Lemma translate_instr_r_if P SP e c1 c2 id sid : @@ -4586,14 +4619,14 @@ Qed. Lemma rel_estate_prec : forall h s m_id s_id1 s_id2 s_st st, s_id1 ⪯ s_id2 -> rel_estate s m_id s_id1 s_st st h -> - rel_estate s m_id s_id2 s_st st h. + rel_estate (syscall_state := syscall_state) s m_id s_id2 s_st st h. Proof. intros h s m_id s_id1 s_id2 s_st st hpre12 [hmem hstack]; split; auto. eapply valid_stack_prec; eauto. Qed. Lemma rel_estate_pop_sub s m_id s_id s_id' s_st st : - ∀ h, rel_estate s m_id s_id (s_id' :: s_st) st h → rel_estate s m_id s_id' s_st st h. + ∀ h, rel_estate s m_id s_id (s_id' :: s_st) st h → rel_estate (syscall_state := syscall_state) s m_id s_id' s_st st h. Proof. intros h [hmem hstack]. split. @@ -4603,7 +4636,7 @@ Qed. Lemma rel_estate_pop scs m vm vm' m_id m_id' s_id s_id' s_st s_st' st : ∀ h, rel_estate {| escs := scs ; emem := m ; evm := vm |} m_id s_id s_st ((vm',m_id',s_id',s_st') :: st) h → - rel_estate {| escs := scs ; emem := m ; evm := vm' |} m_id' s_id' s_st' st h. + rel_estate (syscall_state := syscall_state) {| escs := scs ; emem := m ; evm := vm' |} m_id' s_id' s_st' st h. Proof. intros h [hmem hstack]. split. @@ -4613,7 +4646,7 @@ Qed. Lemma rel_estate_push_sub s m_id s_id s_st st : ∀ h : heap, rel_estate s m_id s_id s_st st h → - rel_estate s m_id s_id~1 (s_id~0 :: s_st) st h. + rel_estate (syscall_state := syscall_state) s m_id s_id~1 (s_id~0 :: s_st) st h. Proof. intros h [hmem hstack]; split. - assumption. @@ -4622,7 +4655,7 @@ Qed. Lemma rel_estate_push m vm scs m_id s_id s_st st : ∀ h : heap, rel_estate {| escs := scs ; emem := m ; evm := vm |} m_id s_id s_st st h → - rel_estate {| escs := scs ; emem := m ; evm := vmap0 |} s_id~1 s_id~1 [::] ((vm, m_id, s_id~0, s_st) :: st) h. + rel_estate (syscall_state := syscall_state) {| escs := scs ; emem := m ; evm := Vm.init |} s_id~1 s_id~1 [::] ((vm, m_id, s_id~0, s_st) :: st) h. Proof. intros h [hmem hstack]; split. - assumption. @@ -4675,7 +4708,7 @@ Proof. apply fresh1. - intros a c1 e c2 ihc1 ihc2 s_id. simpl; reflexivity. - - intros i xs f es st'. + - intros ? ? ? ?. simpl. apply fresh1. Qed. @@ -4726,14 +4759,14 @@ Proof. apply fresh1. - intros a c1 e c2 ihc1 ihc2 s_id. simpl; reflexivity. - - intros i' xs f es st'. + - intros ? ? ? ?. simpl. apply fresh1. Qed. Lemma translate_instr_r_pres P SP c s m_id s_id s_st st h : let (s_id', _) := translate_instr_r P SP c m_id s_id in - rel_estate s m_id s_id s_st st h -> rel_estate s m_id s_id' s_st st h. + rel_estate s m_id s_id s_st st h -> rel_estate (syscall_state := syscall_state) s m_id s_id' s_st st h. Proof. pose proof translate_instr_r_preceq P SP c m_id s_id. destruct translate_instr_r as [s_id' ?]. @@ -4742,7 +4775,7 @@ Qed. Lemma translate_cmd_pres P SP c s m_id s_id s_st st h : let (s_id', _) := translate_cmd P SP c m_id s_id in - rel_estate s m_id s_id s_st st h -> rel_estate s m_id s_id' s_st st h. + rel_estate s m_id s_id s_st st h -> rel_estate (syscall_state := syscall_state) s m_id s_id' s_st st h. Proof. pose proof translate_cmd_preceq P SP c m_id s_id. destruct translate_cmd as [s_id' ?]. @@ -4750,13 +4783,13 @@ Proof. Qed. Definition Pfun (P : uprog) (fn : funname) scs m va scs' m' vr vm m_id s_id s_st st := - ⊢ ⦃ rel_estate {| escs := scs ; emem := m; evm := vm |} m_id s_id s_st st ⦄ + ⊢ ⦃ rel_estate (syscall_state := syscall_state) {| escs := scs ; emem := m; evm := vm |} m_id s_id s_st st ⦄ get_translated_fun P fn s_id~1 [seq totce (translate_value v) | v <- va] ⇓ [seq totce (translate_value v) | v <- vr] - ⦃ rel_estate {| escs := scs' ; emem := m' ; evm := vm |} m_id s_id~0 s_st st ⦄. + ⦃ rel_estate (syscall_state := syscall_state) {| escs := scs' ; emem := m' ; evm := vm |} m_id s_id~0 s_st st ⦄. Lemma hget_lemma (l : seq var_i) vm vres : - mapM (λ x : var_i, get_var vm x) l = ok vres -> + mapM (λ x : var_i, get_var (wsw := (nosubword) (* TODO: nosubword or withsubword *)) (true (* TODO: wdb *)) vm x) l = ok vres -> [seq encode (vtype (v_var x)) | x <- l] = [seq choice_type_of_val v | v <- vres]. Proof. revert vres vm. @@ -4768,18 +4801,19 @@ Proof. noconf H1. simpl. unfold choice_type_of_val. - erewrite type_of_get_var by eassumption. - erewrite IHl by eassumption. - reflexivity. -Qed. + admit. + (* erewrite type_of_get_var by eassumption. *) + (* erewrite IHl by eassumption. *) + (* reflexivity. *) +Admitted. (* Qed. *) Lemma hget_lemma2 l scs m vm vres m_id s_id s_st st : - mapM (λ x : var_i, get_var vm x) l = ok vres -> + mapM (λ x : var_i, get_var (wsw := (nosubword) (* TODO: nosubword or withsubword *)) (true (* TODO: wdb *)) vm x) l = ok vres -> List.Forall2 (λ (c : ∑ a : choice_type, raw_code a) (v : value), ⊢ ⦃ rel_estate {| escs := scs ; emem := m; evm := vm |} m_id s_id s_st st ⦄ c.π2 ⇓ coe_cht c.π1 (translate_value v) - ⦃ rel_estate {| escs := scs ; emem := m; evm := vm |} m_id s_id s_st st ⦄) + ⦃ rel_estate (syscall_state := syscall_state) {| escs := scs ; emem := m; evm := vm |} m_id s_id s_st st ⦄) [seq totc (encode (vtype (v_var x))) (translate_get_var m_id x) | x <- l] vres. Proof. revert m vm vres m_id s_id s_st st. @@ -4836,23 +4870,23 @@ Qed. Lemma lemma1 P pre c suf m_id : uniq [seq p.1 | p <- suf ++ pre] -> forall s_id, - cmd_fs c pre -> - translate_cmd P (translate_funs P (suf ++ pre)).1 c m_id s_id - = translate_cmd P (translate_funs P pre).1 c m_id s_id. + cmd_fs c pre -> + translate_cmd P (translate_funs P (suf ++ pre)).1 c m_id s_id + = translate_cmd P (translate_funs P pre).1 c m_id s_id. Proof. intros huniq. set (Pr := fun (i : instr_r) => forall s_id, instr_r_fs i pre -> - translate_instr_r P (translate_funs P (suf ++ pre)).1 i m_id s_id - = translate_instr_r P (translate_funs P pre).1 i m_id s_id). + translate_instr_r P (translate_funs P (suf ++ pre)).1 i m_id s_id + = translate_instr_r P (translate_funs P pre).1 i m_id s_id). set (Pi := fun (i : instr) => Pr (instr_d i)). set (Pc := fun (c : cmd) => forall s_id, cmd_fs c pre -> - translate_cmd P (translate_funs P (suf ++ pre)).1 c m_id s_id - = translate_cmd P (translate_funs P pre).1 c m_id s_id). + translate_cmd P (translate_funs P (suf ++ pre)).1 c m_id s_id + = translate_cmd P (translate_funs P pre).1 c m_id s_id). eapply cmd_rect with (Pr := Pr) (Pi := Pi) @@ -4893,7 +4927,7 @@ Proof. apply functional_extensionality. intros ub. erewrite translate_for_ext; eauto. - - intros i lvals f es s_id hpre. + - intros (* i *) lvals f es s_id hpre. simpl in hpre. unfold translate_instr_r. simpl. @@ -4901,85 +4935,88 @@ Proof. unfold translate_call. symmetry; destruct assoc eqn:E. + assert (H2 : exists r', assoc pre f = Some r'). - * clear -E. - induction pre. 1: discriminate. - destruct a. - simpl in *. - destruct (f == s). - ** eexists. reflexivity. - ** apply IHpre; auto. - * destruct H2 as [r']. - assert (assoc (translate_funs P (suf ++ pre)).1 f = Some r). - ** eapply mem_uniq_assoc. - *** clear -E. - induction suf. - **** induction pre. - ***** discriminate. - ***** - destruct a. - simpl in *. - destruct (f==s) eqn:E2. - ****** - move: E2 => /eqP ->. left. noconf E. - reflexivity. - ****** right. - apply IHpre. assumption. - **** destruct a. - simpl. - right. - assumption. - *** clear -huniq. - induction suf. - **** induction pre. - ***** easy. - ***** destruct a. - simpl in *. - move: huniq => /andP [huniq1 huniq2]. - apply /andP; split. - ****** clear -huniq1. induction pre. - ******* easy. - ******* destruct a. - Check [eqType of BinNums.positive]. - simpl in huniq1. - pose proof notin_cons [eqType of BinNums.positive] p [seq p.1 | p <- pre] s. - rewrite H in huniq1. - move: huniq1 => /andP [huniq11 huniq12]. - simpl. - pose proof notin_cons [eqType of BinNums.positive] p [seq p.1 | p <- (translate_funs P pre).1] s. - rewrite H0. - apply /andP. - split; auto. - ****** apply IHpre. assumption. - **** destruct a. - simpl in *. - move: huniq => /andP [huniq1 huniq2]. - apply /andP. - split. - ****** clear -huniq1. induction suf. - ******* induction pre. - ******** easy. - ******** destruct a. - simpl in *. - pose proof notin_cons [eqType of BinNums.positive] p [seq p.1 | p <- pre] s. - rewrite H in huniq1. - move: huniq1 => /andP [huniq11 huniq12]. - simpl. - pose proof notin_cons [eqType of BinNums.positive] p [seq p.1 | p <- (translate_funs P pre).1] s. - rewrite H0. - apply /andP. - split; auto. - ******* - destruct a. - simpl in *. - pose proof notin_cons [eqType of BinNums.positive] p [seq p.1 | p <- suf ++ pre] s. - rewrite H in huniq1. - move: huniq1 => /andP [huniq11 huniq12]. - pose proof notin_cons [eqType of BinNums.positive] p [seq p.1 | p <- (translate_funs P (suf ++ pre)).1] s. - rewrite H0. - apply /andP. - split; auto. - ****** apply IHsuf; auto. - ** rewrite H0. reflexivity. + * clear -E. + induction pre. 1: discriminate. + destruct a. + simpl in *. + destruct (f == s). + ** eexists. reflexivity. + ** apply IHpre; auto. + * destruct H2 as [r']. + assert (assoc (translate_funs P (suf ++ pre)).1 f = Some r). + ** eapply mem_uniq_assoc. + *** clear -E. + induction suf. + **** induction pre. + ***** discriminate. + ***** + destruct a. + simpl in *. + destruct (f==s) eqn:E2. + ****** + move: E2 => /eqP ->. left. noconf E. + reflexivity. + ****** right. + apply IHpre. assumption. + **** destruct a. + simpl. + right. + assumption. + *** clear -huniq. + induction suf. + **** induction pre. + ***** easy. + ***** destruct a. + simpl in *. + move: huniq => /andP [huniq1 huniq2]. + apply /andP; split. + ****** clear -huniq1. induction pre. + ******* easy. + ******* destruct a. + Check [eqType of BinNums.positive]. + simpl in huniq1. + admit. + (* pose proof notin_cons [eqType of BinNums.positive] p [seq p.1 | p <- pre] s. *) + (* rewrite H in huniq1. *) + (* move: huniq1 => /andP [huniq11 huniq12]. *) + (* simpl. *) + (* pose proof notin_cons [eqType of BinNums.positive] p [seq p.1 | p <- (translate_funs P pre).1] s. *) + (* rewrite H0. *) + (* apply /andP. *) + (* split; auto. *) + ****** apply IHpre. assumption. + **** destruct a. + simpl in *. + move: huniq => /andP [huniq1 huniq2]. + apply /andP. + split. + ****** clear -huniq1. induction suf. + ******* induction pre. + ******** easy. + ******** destruct a. + simpl in *. + admit. + (* pose proof notin_cons [eqType of BinNums.positive] p [seq p.1 | p <- pre] s. *) + (* rewrite H in huniq1. *) + (* move: huniq1 => /andP [huniq11 huniq12]. *) + (* simpl. *) + (* pose proof notin_cons [eqType of BinNums.positive] p [seq p.1 | p <- (translate_funs P pre).1] s. *) + (* rewrite H0. *) + (* apply /andP. *) + (* split; auto. *) + ******* + destruct a. + simpl in *. + admit. + (* pose proof notin_cons [eqType of BinNums.positive] p [seq p.1 | p <- suf ++ pre] s. *) + (* rewrite H in huniq1. *) + (* move: huniq1 => /andP [huniq11 huniq12]. *) + (* pose proof notin_cons [eqType of BinNums.positive] p [seq p.1 | p <- (translate_funs P (suf ++ pre)).1] s. *) + (* rewrite H0. *) + (* apply /andP. *) + (* split; auto. *) + ****** apply IHsuf; auto. + ** rewrite H0. reflexivity. + exfalso. assert (H2 : assoc pre f = None). * clear -E. @@ -4988,7 +5025,7 @@ Proof. ** simpl in *. destruct a. simpl in *. - destruct (f == p). + destruct (f == t). *** discriminate. *** apply IHpre; auto. * clear -H2 hpre. @@ -5002,11 +5039,12 @@ Proof. discriminate. *** simpl in *. apply IHpre; auto. -Qed. +Admitted. (* Qed. *) Theorem translate_prog_correct P scs m vargs scs' m' vres : ∀ fn, - sem.sem_call (P : @uprog asm_op asmop) scs m fn vargs scs' m' vres → + @sem_call (nosubword) (* TODO: nosubword or withsubword *) direct_c (* TODO: direct? *) asm_op syscall_state {| _pd := pd; _msf_size := (Build_MSFsize U32 (* TOOD: what size? *)); |} mk_spp {| + _asmop := asmop; _sc_sem := sc_sem |} _ (sCP_unit (* TODO *)) (P : @uprog asm_op asmop) (tt (* TODO *)) scs m fn vargs scs' m' vres → handled_program P -> ∀ vm m_id s_id s_st st, Pfun P fn scs m vargs scs' m' vres vm m_id s_id s_st st. @@ -5021,29 +5059,31 @@ Proof using gd asm_correct. ∀ m_id s_id s_st st, handled_instr_r i → let (s_id', i') := translate_instr_r P SP i m_id s_id in - ⊢ ⦃ rel_estate s1 m_id s_id s_st st ⦄ + ⊢ ⦃ rel_estate (syscall_state := syscall_state) s1 m_id s_id s_st st ⦄ i' ⇓ tt - ⦃ rel_estate s2 m_id s_id' s_st st ⦄). + ⦃ rel_estate (syscall_state := syscall_state) s2 m_id s_id' s_st st ⦄). set (Pi := λ s1 i s2, Pi_r s1 (instr_d i) s2). set (Pc := λ (s1 : estate) (c : cmd) (s2 : estate), ∀ m_id s_id s_st st, handled_cmd c → let (s_id', c') := translate_cmd P SP c m_id s_id in - ⊢ ⦃ rel_estate s1 m_id s_id s_st st ⦄ + ⊢ ⦃ rel_estate (syscall_state := syscall_state) s1 m_id s_id s_st st ⦄ c' ⇓ tt - ⦃ rel_estate s2 m_id s_id' s_st st ⦄). + ⦃ rel_estate (syscall_state := syscall_state) s2 m_id s_id' s_st st ⦄). set (Pfor := λ (v : var_i) (ws : seq Z) (s1 : estate) (c : cmd) (s2 : estate), ∀ m_id s_id s_id' s_st st, handled_cmd c → s_id~1 ⪯ s_id' -> exists s_id'', - ⊢ ⦃ rel_estate s1 m_id s_id' (s_id~0 :: s_st) st ⦄ + ⊢ ⦃ rel_estate (syscall_state := syscall_state) s1 m_id s_id' (s_id~0 :: s_st) st ⦄ translate_for v ws m_id (translate_cmd P SP c m_id) s_id' ⇓ tt - ⦃ rel_estate s2 m_id s_id'' (s_id~0 :: s_st) st ⦄ - ). - unshelve eapply (@sem_call_Ind asm_op syscall_state mk_spp _ Pc Pi_r Pi Pfor Pfun _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H). + ⦃ rel_estate (syscall_state := syscall_state) s2 m_id s_id'' (s_id~0 :: s_st) st ⦄ + ). + + unshelve eapply (@sem_call_Ind _ _ asm_op syscall_state {| _pd := pd |} mk_spp {| + _asmop := asmop; _sc_sem := sc_sem |} _ _ _ _ Pc Pi_r Pi Pfor Pfun _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ H). - (* nil *) intros s m_id s_id s_st st _. simpl. eapply u_ret_eq. @@ -5182,11 +5222,12 @@ Proof using gd asm_correct. 1: eapply ihc. eapply ihfor. - (* call *) - intros s1 scs1 m2 s2 ii xs gn args vargs' vres' hargs hgn ihgn hwr_vres m_id s_id s_st st hdi. + intros s1 scs1 m2 s2 (* ii *) xs gn args vargs' vres' hargs hgn ihgn hwr_vres m_id s_id s_st st hdi. unfold Pfun, Translation.Pfun, get_translated_fun in ihgn. simpl. eapply u_bind. - 1: eapply bind_list_pexpr_correct with (s_id:=s_id) (s_st:=s_st) (st:=st); try eassumption; easy. + 1: admit. + (* 1: eapply bind_list_pexpr_correct with (s_id:=s_id) (s_st:=s_st) (st:=st); try eassumption; easy. *) eapply u_bind with (v₁ := [seq totce (translate_value v) | v <- vres']). 1: specialize (ihgn hP (evm s1) m_id s_id s_st st). 1: eapply u_pre_weaken_rule. @@ -5197,446 +5238,172 @@ Proof using gd asm_correct. pose (translate_call_head ef) as hc. rewrite hc. eapply ihgn. - * easy. + * admit. * eapply translate_write_lvals_correct. 1:assumption. - exact hwr_vres. + admit. + (* exact hwr_vres. *) - (* proc *) intros scs1 m1 scs2 m2 gn g vargs' vargs'' s1 vm2 vres' vres''. intros hg hvars hwr hbody ihbody hget htrunc. intros hp vm m_id s_id s_st st. unfold Translation.Pfun. unfold get_translated_fun. - destruct (tr_prog_inv hg) as [fs' [l [hl ]]]. - unfold Pc, SP, translate_prog' in ihbody. - unfold translate_prog' in *. - rewrite hl in ihbody. - rewrite hl. - destruct H0 as [ef ep]. - rewrite hl in ef. - rewrite hl in ep. - subst SP. - rewrite ep. - unfold translate_call. - simpl. - destruct (translate_funs P fs') as [tr_fs' tsp'] eqn:Efuns. - simpl. - assert (E : gn == gn) by now apply /eqP. - rewrite E; clear E. - unfold translate_call_body. - rewrite hg. - eapply u_bind. - 1: { - erewrite htrunc_lemma1 by eassumption. - eapply u_pre_weaken_rule. - 1: eapply translate_write_vars_correct; eassumption. - eapply rel_estate_push. - } - assert (handled_cmd (f_body g)) as hpbody. - { - clear -hg hp. - pose (gd := (gn, g)). - unfold handled_program in *. - move: hp => /andP [] /andP [] hp1 hp2 hp3. - pose (hh := (List.forallb_forall handled_fundecl (p_funcs P)).1 hp1 gd). - destruct g. - apply hh. simpl. - now apply (assoc_mem' hg). - } - specialize (ihbody s_id~1 s_id~1 [::] ((vm, m_id, s_id~0, s_st) :: st) hpbody). clear hpbody. - assert ((l ++ (gn,g) :: fs') = ((l ++ [:: (gn,g)]) ++ fs')) by (rewrite <- List.app_assoc; reflexivity). - assert (htr : translate_cmd P (translate_funs P (l ++ ((gn,g) :: fs'))).1 (f_body g) s_id~1 s_id~1 - = translate_cmd P (translate_funs P fs').1 (f_body g) s_id~1 s_id~1). - { rewrite H0. - eapply lemma1. - { clear -hp hl H0. - unfold handled_program in *. - move: hp => /andP [] /andP [_ _]. - now rewrite hl H0. - } - clear -hp hl. - move: hp => /andP [] /andP [_ hp2 _]. - rewrite hl in hp2. - eapply lemma2. - eassumption. - } - rewrite htr in ihbody. - rewrite Efuns in ihbody. - destruct (translate_cmd P tr_fs' (f_body g) s_id~1 s_id~1) as [s_id' c'] eqn:E. - rewrite E in ihbody. - rewrite E. - simpl. - - eapply u_bind with (v₁ := tt). - + eapply ihbody. - + eapply u_bind. - * eapply bind_list_correct. - ** rewrite <- map_comp. - unfold comp. - simpl. - eapply hget_lemma; eassumption. - ** eapply hget_lemma2. - assumption. - * clear -htrunc. - eapply u_ret. - split. - 1: eapply rel_estate_pop. - 1: eassumption. - eapply htrunc_lemma1. - eassumption. + admit. + (* destruct (tr_prog_inv hg) as [fs' [l [hl ]]]. *) + (* unfold Pc, SP, translate_prog' in ihbody. *) + (* unfold translate_prog' in *. *) + (* rewrite hl in ihbody. *) + (* rewrite hl. *) + (* destruct H0 as [ef ep]. *) + (* rewrite hl in ef. *) + (* rewrite hl in ep. *) + (* subst SP. *) + (* rewrite ep. *) + (* unfold translate_call. *) + (* simpl. *) + (* destruct (translate_funs P fs') as [tr_fs' tsp'] eqn:Efuns. *) + (* simpl. *) + (* assert (E : gn == gn) by now apply /eqP. *) + (* rewrite E; clear E. *) + (* unfold translate_call_body. *) + (* rewrite hg. *) + (* eapply u_bind. *) + (* 1: { *) + (* erewrite htrunc_lemma1 by eassumption. *) + (* eapply u_pre_weaken_rule. *) + (* 1: eapply translate_write_vars_correct; eassumption. *) + (* eapply rel_estate_push. *) + (* } *) + (* assert (handled_cmd (f_body g)) as hpbody. *) + (* { *) + (* clear -hg hp. *) + (* pose (gd := (gn, g)). *) + (* unfold handled_program in *. *) + (* move: hp => /andP [] /andP [] hp1 hp2 hp3. *) + (* pose (hh := (List.forallb_forall handled_fundecl (p_funcs P)).1 hp1 gd). *) + (* destruct g. *) + (* apply hh. simpl. *) + (* now apply (assoc_mem' hg). *) + (* } *) + (* specialize (ihbody s_id~1 s_id~1 [::] ((vm, m_id, s_id~0, s_st) :: st) hpbody). clear hpbody. *) + (* assert ((l ++ (gn,g) :: fs') = ((l ++ [:: (gn,g)]) ++ fs')) by (rewrite <- List.app_assoc; reflexivity). *) + (* assert (htr : translate_cmd P (translate_funs P (l ++ ((gn,g) :: fs'))).1 (f_body g) s_id~1 s_id~1 *) + (* = translate_cmd P (translate_funs P fs').1 (f_body g) s_id~1 s_id~1). *) + (* { rewrite H0. *) + (* eapply lemma1. *) + (* { clear -hp hl H0. *) + (* unfold handled_program in *. *) + (* move: hp => /andP [] /andP [_ _]. *) + (* now rewrite hl H0. *) + (* } *) + (* clear -hp hl. *) + (* move: hp => /andP [] /andP [_ hp2 _]. *) + (* rewrite hl in hp2. *) + (* eapply lemma2. *) + (* eassumption. *) + (* } *) + (* rewrite htr in ihbody. *) + (* rewrite Efuns in ihbody. *) + (* destruct (translate_cmd P tr_fs' (f_body g) s_id~1 s_id~1) as [s_id' c'] eqn:E. *) + (* rewrite E in ihbody. *) + (* rewrite E. *) + (* simpl. *) + + (* eapply u_bind with (v₁ := tt). *) + (* + eapply ihbody. *) + (* + eapply u_bind. *) + (* * eapply bind_list_correct. *) + (* ** rewrite <- map_comp. *) + (* unfold comp. *) + (* simpl. *) + (* eapply hget_lemma; eassumption. *) + (* ** eapply hget_lemma2. *) + (* assumption. *) + (* * clear -htrunc. *) + (* eapply u_ret. *) + (* split. *) + (* 1: eapply rel_estate_pop. *) + (* 1: eassumption. *) + (* eapply htrunc_lemma1. *) + (* eassumption. *) - assumption. -Qed. +Admitted. (* Qed. *) -Lemma deterministic_seq {A} (c1 : raw_code A) {B} (c2 : raw_code B) : - deterministic c1 -> - deterministic c2 -> - deterministic (c1 ;; c2). -Proof. - intros. - revert X0. revert c2. (* generalize (B c1). *) - induction c1; eauto; intros. - - inversion X. - - simpl. constructor. inversion X. - noconf H1; subst; simpl in *. intros. eapply X0; eauto. - - simpl. constructor. inversion X. - noconf H1; subst; simpl in *. intros. eapply IHc1; eauto. - - inversion X. -Qed. +End Translation. -Lemma deterministic_bind {A} (c1 : raw_code A) {B} (c2 : A -> raw_code B) : - deterministic c1 -> - (forall x, deterministic (c2 x)) -> - deterministic (x ← c1 ;; c2 x). -Proof. - intros. - revert X0. revert c2. (* generalize (B c1). *) - induction c1; eauto; intros. - - simpl. inversion X. - - simpl. constructor. inversion X. - noconf H1; subst; simpl in *. intros. eapply X0; eauto. - - simpl. constructor. inversion X. - noconf H1; subst; simpl in *. intros. eapply IHc1; eauto. - - inversion X. -Qed. - -Lemma translate_write_vars_deterministic i vs ts : - deterministic (translate_write_vars i vs ts). -Proof. - revert vs ts. - induction vs, ts. - 1,2,3: unfold translate_write_vars; simpl; econstructor. - unfold translate_write_vars in *. eapply deterministic_seq. - - unfold translate_write_var. constructor. constructor. - - eapply IHvs. -Qed. - -Lemma translate_gvar_deterministic g i v : - deterministic (translate_gvar g i v). -Proof. - unfold translate_gvar. destruct is_lvar. - * unfold translate_get_var. constructor. intros; constructor. - * destruct get_global; constructor. -Qed. - -Lemma translate_pexpr_deterministic g i e : - deterministic (translate_pexpr g i e).π2. -Proof. - revert i g. - refine ( - (fix aux (e1 : pexpr) := - match e1 with - | _ => _ end) e - ). - destruct e1; intros; simpl; try constructor. - - apply translate_gvar_deterministic. - - simpl. - eapply deterministic_bind. - + eapply translate_gvar_deterministic. - + intros. simpl. - rewrite bind_assoc. - eapply deterministic_bind. - * eapply aux. - * intros. constructor. - - eapply deterministic_bind. - + eapply translate_gvar_deterministic. - + intros. simpl. - rewrite bind_assoc. - eapply deterministic_bind. - * eapply aux. - * intros. constructor. - - intros. - rewrite bind_assoc. - eapply deterministic_bind; try constructor. - + eapply aux. - + intros. constructor. - - rewrite bind_assoc. - eapply deterministic_bind; try constructor. - eapply aux. - - rewrite !bind_assoc. - eapply deterministic_bind; try constructor. - + eapply aux. - + intros. - eapply deterministic_bind; try constructor. - intros. - eapply deterministic_bind; try constructor; auto. - eapply deterministic_bind; try constructor; auto. - - epose proof deterministic_bind (bind_list [seq translate_pexpr g i e0 | e0 <- l]) (fun vs => ret (tr_app_sopn_single (type_of_opN o).1 (sem_opN_typed o) vs)). - eapply X. - + clear -aux. induction l. - * constructor. - * simpl. eapply deterministic_bind. - ** eapply aux. - ** intros. - epose proof deterministic_bind (bind_list [seq translate_pexpr g i e0 | e0 <- l]). - eapply X. - *** assumption. - *** constructor. - + constructor. - - rewrite bind_assoc. - eapply deterministic_bind; try constructor. - + apply aux. - + intros. - eapply deterministic_bind; try constructor. - intros. - destruct x0. - * eapply deterministic_bind; try constructor; auto. - * eapply deterministic_bind; try constructor; auto. -Qed. +From Jasmin Require Import x86_instr_decl x86_extra (* x86_gen *) (* x86_linear_sem *). +Import arch_decl. -Lemma translate_write_var_deterministic i H v : - deterministic (translate_write_var i H v). +Lemma id_tin_instr_desc : + ∀ (a : asm_op_msb_t), + id_tin (instr_desc a) = id_tin (x86_instr_desc a.2). Proof. - repeat constructor. + intros [[ws|] a]. + - simpl. destruct (_ == _). all: reflexivity. + - reflexivity. Qed. -Lemma translate_write_lval_deterministic g i l v : - deterministic (translate_write_lval g i l v). +Definition cast_sem_prod_dom {ts tr} ts' (f : sem_prod ts tr) (e : ts = ts') : + sem_prod ts' tr. Proof. - destruct l; intros; simpl. - - constructor. - - eapply translate_write_var_deterministic. - - constructor; intros. - eapply deterministic_bind; try constructor; auto. - 1: eapply translate_pexpr_deterministic. intros. - repeat constructor. - - constructor; intros. - eapply deterministic_bind; try constructor; auto. - + eapply deterministic_bind; try constructor. - eapply translate_pexpr_deterministic. - + constructor. - - constructor; intros. - eapply deterministic_bind; try constructor; auto. - + eapply deterministic_bind; try constructor. - eapply translate_pexpr_deterministic. - + constructor. -Qed. + subst. exact f. +Defined. -Lemma translate_write_lvals_deterministic g i l vs : - deterministic (translate_write_lvals g i l vs). +Lemma cast_sem_prod_dom_K : + ∀ ts tr f e, + @cast_sem_prod_dom ts tr ts f e = f. Proof. - revert l vs. - induction l, vs. - 1,2,3: constructor. - unfold translate_write_lvals. - simpl. - eapply deterministic_seq. - 1: eapply translate_write_lval_deterministic. - eapply IHl. + intros ts tr f e. + assert (e = erefl). + { apply eq_irrelevance. } + subst. reflexivity. Qed. -Lemma translate_call_body_deterministic P f fd i vs : - deterministic (fd i) -> - deterministic (translate_call_body P f fd i vs). +Lemma sem_correct_rewrite : + ∀ R ts ts' f e, + sem_correct ts' (cast_sem_prod_dom ts' f e) → + @sem_correct R ts f. Proof. - intros. - unfold translate_call_body. - induction p_funcs. - - constructor. - - simpl. destruct a. destruct (f == f0) eqn:E. - + eapply deterministic_seq. - 1: eapply translate_write_vars_deterministic. - eapply deterministic_seq. - 1: eapply X. - eapply deterministic_bind with (c2:= (fun vres => ret (trunc_list (f_tyout _f) vres))). - * clear -_f. induction f_res. - ** constructor. - ** simpl. constructor. - intros. eapply deterministic_bind with (c2 := (fun vs => ret (totce x :: vs))). - 1: eapply IHl. - constructor. - * constructor. - + eapply IHl. -Qed. - -Lemma translate_call_deterministic P f (fd : fdefs) i vs : - deterministic (match assoc fd f with Some f => f i | _ => ret tt end) -> - deterministic (translate_call P f fd i vs). -Proof. - intros. - unfold translate_call. - destruct assoc. - 2: constructor. - eapply translate_call_body_deterministic. + intros R ts ts' f e h. + subst. rewrite cast_sem_prod_dom_K in h. assumption. Qed. -Lemma coe_tyc_deterministic t c : - deterministic c.π2 -> deterministic (coe_tyc t c). -Proof. - destruct c. - intros. - destruct (x == t) eqn:E. - + move: E => /eqP. intros; subst. - rewrite coerce_typed_code_K; try constructor. - assumption. - + rewrite coerce_typed_code_neq; try constructor. - move: E => /eqP //. -Qed. - -Lemma translate_for_deterministic v l i0 f i1 : - (forall i, deterministic (f i).2) -> - deterministic (translate_for v l i0 f i1). +Lemma no_arr_correct {R} ts s : + List.Forall (λ t, ∀ len, t != sarr len) ts → + @sem_correct R ts s. Proof. - intros. - revert i1. - induction l; intros. - - constructor. - - simpl. - specialize (X i1). - destruct (f i1). - simpl in *. - constructor. - eapply deterministic_seq. - 1: assumption. - eapply IHl. -Qed. - -Fixpoint translate_instr_deterministic p (fd : fdefs) i i1 i2 {struct i} : - (forall f i, deterministic (match assoc fd f with Some f => f i | _ => ret tt end)) -> - deterministic (translate_instr p fd i i1 i2).2. -Proof. - revert i1 i2. - intros. - epose proof (translate_cmd_deterministic := - (fix translate_cmd (c : cmd) (s_id : p_id) : deterministic (translate_cmd p fd c i1 s_id).2 := - match c with - | [::] => _ - | i :: c => _ - end - ) - ). - destruct i; destruct i0; simpl in *; intros. - - simpl. eapply deterministic_bind. - + eapply translate_pexpr_deterministic. - + intros. - eapply translate_write_lval_deterministic. - - eapply deterministic_bind with (c1 := bind_list _). - + clear -i1. - induction l0. - * constructor. - * simpl. - eapply deterministic_bind. - 1: eapply translate_pexpr_deterministic. - intros. - eapply deterministic_bind with (c1 := bind_list _). - 1: eapply IHl0. - constructor. - + intros. - eapply translate_write_lvals_deterministic. - - constructor. - - rewrite translate_instr_unfold. simpl. - rewrite translate_instr_r_if. - pose proof (translate_cmd_deterministic l i2). - destruct translate_cmd. simpl. - pose proof (translate_cmd_deterministic l0 p1). - destruct translate_cmd. simpl. - eapply deterministic_bind. - + eapply coe_tyc_deterministic with (t := 'bool). - eapply translate_pexpr_deterministic. - + destruct x; assumption. - - rewrite translate_instr_unfold. - rewrite translate_instr_r_for. - destruct r as [[d lo] hi]. - simpl. - eapply deterministic_bind. - 1: eapply coe_tyc_deterministic with (t:= 'int); eapply translate_pexpr_deterministic. - intros; eapply deterministic_bind. - 1: eapply coe_tyc_deterministic with (t:= 'int); eapply translate_pexpr_deterministic. - intros. - eapply translate_for_deterministic. - intros. - eapply translate_cmd_deterministic. - - constructor. - - eapply deterministic_bind with (c1 := bind_list _). - + clear -i1. - induction l0. - * constructor. - * simpl. - eapply deterministic_bind. - 1: eapply translate_pexpr_deterministic. - intros. - eapply deterministic_bind with (c1 := bind_list _). - 1: eapply IHl0. - constructor. - + intros; simpl. - eapply deterministic_bind with (c1 := translate_call _ _ _ _ _). - 1: eapply translate_call_deterministic. - 1: eapply X. - eapply translate_write_lvals_deterministic. - Unshelve. - 1: constructor. - simpl. - specialize (translate_instr_deterministic p fd i i1 s_id). - destruct translate_instr. - specialize (translate_cmd c p0). - destruct jasmin_translate.translate_cmd. - eapply deterministic_seq. - 1: eapply translate_instr_deterministic. - all: try assumption. -Qed. - -Lemma translate_cmd_deterministic p fd c i1 i2 : - (forall f i, deterministic (match assoc fd f with Some f => f i | _ => ret tt end)) -> - deterministic (translate_cmd p fd c i1 i2).2. -Proof. - revert i1 i2. - induction c; intros. + intros h. + induction h as [| t ts ht h ih]. - constructor. - - simpl. - pose proof translate_instr_deterministic p fd a i1 i2 X. - destruct translate_instr. - specialize (IHc i1 p0 X). - destruct translate_cmd. - simpl in *. - eapply deterministic_seq; auto. -Qed. - -Lemma translate_funs_deterministic P fn : - forall f i, deterministic (match assoc (translate_funs P fn).1 f with Some f => f i | _ => ret tt end). -Proof. - induction fn; intros. - constructor. - - simpl. destruct a. simpl. - destruct (f == f0). - + eapply translate_cmd_deterministic. - assumption. - + eapply IHfn. -Qed. - -Lemma get_translated_fun_deterministic P fn i vs : - deterministic (get_translated_fun P fn i vs). -Proof. - (* destruct P. *) - unfold get_translated_fun. - unfold translate_prog'. simpl. - induction p_funcs. - - simpl. constructor. - - simpl. destruct a. simpl. - destruct (fn == f). - + eapply translate_call_body_deterministic. - eapply translate_cmd_deterministic. - eapply translate_funs_deterministic. - + assumption. + + intros v. + pose proof unembed_embed t v as e. + destruct t as [| | len |]. + 1,2,4: rewrite e ; reflexivity. + specialize (ht len). move: ht => /eqP. contradiction. + + intros v. + apply ih. Qed. -End Translation. +Context `{asmop : asmOp}. +Lemma x86_correct : + ∀ (o : @asm_op_t asm_op _), + sem_correct (tin (sopn.get_instr_desc (Oasm o))) (@sopn_sem _ (Build_MSFsize U32 (* TOOD: what size? *)) _ (Oasm o)). +Proof. + intros o. + admit. + (* destruct o as [a | e]. *) + (* - Opaque instr_desc. simpl. *) + (* pose proof (id_tin_instr_desc a) as e. *) + (* eapply sem_correct_rewrite with (e := e). *) + (* destruct a as [o x]. simpl in *. *) + (* eapply no_arr_correct. *) + (* destruct x ; simpl. *) + (* all: repeat constructor. *) + (* Transparent instr_desc. *) + (* - destruct e ; simpl ; repeat constructor. *) + (* destruct w ; repeat constructor. *) + (* Qed. *) +Admitted. diff --git a/theories/Jasmin/jasmin_x86.v b/theories/Jasmin/jasmin_x86.v index 2c77289b..1a963da4 100644 --- a/theories/Jasmin/jasmin_x86.v +++ b/theories/Jasmin/jasmin_x86.v @@ -1,7 +1,7 @@ Set Warnings "-ambiguous-paths,-notation-overridden,-notation-incompatible-format". From mathcomp Require Import all_ssreflect all_algebra. From mathcomp Require Import word_ssrZ word. -From Jasmin Require Import expr compiler_util values sem. +From Jasmin Require Import expr compiler_util values expr compiler_util values sem_params flag_combination sem_op_typed sopn low_memory psem_of_sem_proof varmap psem lowering. Set Warnings "ambiguous-paths,notation-overridden,notation-incompatible-format". From extructures Require Import ord fset fmap. @@ -104,30 +104,31 @@ Section x86_correct. sem_correct (tin (sopn.get_instr_desc (Oasm o))) (sopn_sem (Oasm o)). Proof. intros o. - simpl. destruct o as [a | e]. - - Opaque instr_desc. simpl. - pose proof (id_tin_instr_desc a) as e. - eapply sem_correct_rewrite with (e := e). - destruct a as [o x]. simpl in *. - eapply no_arr_correct. - destruct x ; simpl. - all: repeat constructor. - Transparent instr_desc. - - destruct e ; simpl ; repeat constructor. - destruct w ; repeat constructor. - Qed. - + simpl. admit. (* destruct o as [a | e]. *) + (* - Opaque instr_desc. simpl. *) + (* pose proof (id_tin_instr_desc a) as e. *) + (* eapply sem_correct_rewrite with (e := e). *) + (* destruct a as [o x]. simpl in *. *) + (* eapply no_arr_correct. *) + (* destruct x ; simpl. *) + (* all: repeat constructor. *) + (* Transparent instr_desc. *) + (* - destruct e ; simpl ; repeat constructor. *) + (* destruct w ; repeat constructor. *) + (* Qed. *) + Admitted. + Context {syscall_state : Type} {sc_sem : syscall.syscall_sem syscall_state} {gf : glob_decls} {asm_scsem : asm_syscall_sem (call_conv:=x86_linux_call_conv)} - (cparams : compiler_params fresh_vars lowering_options). + (cparams : compiler_params fresh_vars (* lowering_options *)). Hypothesis print_uprogP : forall s p, cparams.(print_uprog) s p = p. Hypothesis print_sprogP : forall s p, cparams.(print_sprog) s p = p. Hypothesis print_linearP : forall s p, cparams.(print_linear) s p = p. - Definition equiv_to_x86 := @equiv_to_asm syscall_state sc_sem gf _ _ _ _ _ _ _ _ x86_linux_call_conv _ _ _ _ x86_h_params cparams print_uprogP print_sprogP print_linearP x86_correct. + (* Definition equiv_to_x86 := @equiv_to_asm syscall_state sc_sem gf _ _ _ _ _ _ _ _ x86_linux_call_conv _ _ _ _ x86_h_params cparams print_uprogP print_sprogP print_linearP x86_correct. *) End x86_correct. diff --git a/theories/Relational/GenericRulesSimple.v b/theories/Relational/GenericRulesSimple.v index 9fe9d4a7..acb584e8 100644 --- a/theories/Relational/GenericRulesSimple.v +++ b/theories/Relational/GenericRulesSimple.v @@ -208,7 +208,7 @@ Section GoingPractical. move=> H1 H2 ; apply weaken_rule2. enough (c2 = skip ;; c2) as ->. enough (c1 = bind c1 ret) as ->. - apply seq_rule=> // ? ?; eapply weaken_rule2; [apply H2| cbv ;intuition]. + apply seq_rule=> // ? ?; eapply weaken_rule2. rewrite /bind monad_law2 //. rewrite /bind monad_law1 //. Qed. diff --git a/theories/Relational/OrderEnrichedRelativeMonadExamples.v b/theories/Relational/OrderEnrichedRelativeMonadExamples.v index 26ce618c..0f5ba16e 100644 --- a/theories/Relational/OrderEnrichedRelativeMonadExamples.v +++ b/theories/Relational/OrderEnrichedRelativeMonadExamples.v @@ -82,7 +82,7 @@ Section OrdCat. apply Hx. apply GX. Qed. Next Obligation. cbv ; intuition. Qed. - Next Obligation. cbv ; intuition. apply H3; apply H2 => //. Qed. + Next Obligation. cbv ; intuition. apply H0; apply H => //. Qed. Next Obligation. cbv ; intuition; etransitivity; first (apply: x∙2; apply: H0). apply: H. From c747cdc03212dd20506206af5cfe047995d10c38 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Thu, 14 Mar 2024 13:13:37 +0100 Subject: [PATCH 377/383] remove jasmin dependency for now --- .github/workflows/build.yml | 4 +- .gitignore | 10 - DOC.md | 10 +- Makefile | 995 +-------------- README.md | 128 +- _CoqProject | 8 +- depgraph.sh | 2 +- flake.lock | 60 + flake.nix | 51 + theories/Crypt/Axioms.v | 2 +- theories/Crypt/Prelude.v | 4 +- theories/Crypt/choice_type.v | 117 +- theories/Crypt/examples/OVN.v | 2128 +++++++++++++++++++++++++++++++++ theories/Crypt/jasmin_util.v | 2023 +++++++++++++++++++++++++++++++ theories/Crypt/jasmin_word.v | 171 +++ 15 files changed, 4548 insertions(+), 1165 deletions(-) create mode 100644 flake.lock create mode 100644 flake.nix create mode 100644 theories/Crypt/examples/OVN.v create mode 100644 theories/Crypt/jasmin_util.v create mode 100644 theories/Crypt/jasmin_word.v diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 6cfa2c5c..46141271 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -35,7 +35,7 @@ jobs: - name: Install OCaml uses: avsm/setup-ocaml@v1 with: - ocaml-version: 4.07.1 + ocaml-version: 4.14.1 # Checks-out your repository under $GITHUB_WORKSPACE, so your job can access it - name: Checkout repo @@ -45,6 +45,6 @@ jobs: - name: Build run: | opam repo add coq-released https://coq.inria.fr/opam/released - opam install coq.8.15.2 coq-equations.1.3+8.15 coq-mathcomp-ssreflect.1.13.0 coq-mathcomp-analysis.0.3.13 coq-extructures.0.3.1 coq-deriving.0.1.0 + opam install coq.8.18.0 coq-equations.1.3+8.18 coq-mathcomp-ssreflect.2.1.0 coq-mathcomp-analysis.1.0.0 coq-extructures.0.4.0 coq-deriving.0.2.0 opam exec -- make -j4 diff --git a/.gitignore b/.gitignore index 6f6a2b0d..175b257e 100644 --- a/.gitignore +++ b/.gitignore @@ -11,7 +11,6 @@ _namecheck_ssprove_csf2021/ *.vos *.glob .coqdeps.d -.coq-native/ # coq_makefile .Makefile.d @@ -56,12 +55,3 @@ Makefile.coq.conf .DS_store .Makefile.coq 2.d - -# OCaml -*.cmo -*.cmi - -# Assembly (ignored because we expect them to be jasminc generated) -*.s - -.Makefile.coq 3.d diff --git a/DOC.md b/DOC.md index 8aff46d2..30829a04 100644 --- a/DOC.md +++ b/DOC.md @@ -421,7 +421,7 @@ Proof. (* Now deal with the goals *) ``` -Finally the identity package is defined as `ID I` where `I` is an interface. +Finally, the identity package is defined as `ID I` where `I` is an interface. It both imports and exports `I` by simply forwarding the calls. It is valid as long as `I` does not include two signatures sharing the same identifier, as overloading is not possible in our packages. This property is @@ -790,7 +790,7 @@ then applying `ssprove_swap_lhs 0%N` will leave us to prove ``` instead. -Not any two commands are swappable however. The tactic will try to infer the +However, not any two commands are swappable. The tactic will try to infer the swappability condition automatically, this is the case for sampling which can always be swapped (if dependencies permit), or for `get`/`put` when they talk about distinct locations. If automation proves insufficient, the user will have @@ -900,7 +900,7 @@ and turn it into #### Remember after reading Sometimes, swapping and contracting is not possible, even when the code makes -two reads to the same location. It can happen for instance if the the value read +two reads to the same location. It can happen for instance if the value read is branched upon before being read again. For this we have several rules that will *remember* which location was read. @@ -978,7 +978,7 @@ Dually to how we *remember* read values, we propose a way to write to a memory location, even when it might temporarily break the invariant. As we will se in [[Crafting invariants]], a lot of invariants will involve several locations at once, meaning the most of the time, writing a value will break them. -Thus our machinery to write to the memory freely and then, at the user's +Thus, our machinery to write to the memory freely and then, at the user's command, to restore the invariant. These debts to the precondition are incurred by using one of the following @@ -1060,7 +1060,7 @@ where `L₀` and `L₁` represent the sets of memory locations of both programs. While it can be enough for a lot of examples (our own examples mostly use equality as an invariant), it is not always sufficient. -Another invariant the we propose is called `heap_ignore` and is defined as +Another invariant we propose is called `heap_ignore` and is defined as ```coq Definition heap_ignore (L : {fset Location}) := λ '(h₀, h₁), diff --git a/Makefile b/Makefile index 42626b66..99a8fbe2 100644 --- a/Makefile +++ b/Makefile @@ -1,989 +1,14 @@ -########################################################################## -## # The Coq Proof Assistant / The Coq Development Team ## -## v # Copyright INRIA, CNRS and contributors ## -## /dev/null 2>/dev/null; echo $$?)) -STDTIME?=command time -f $(TIMEFMT) -else -ifeq (0,$(shell gtime -f "" true >/dev/null 2>/dev/null; echo $$?)) -STDTIME?=gtime -f $(TIMEFMT) -else -STDTIME?=command time -endif -endif -else -STDTIME?=command time -f $(TIMEFMT) -endif - -COQBIN?= -ifneq (,$(COQBIN)) -# add an ending / -COQBIN:=$(COQBIN)/ -endif - -# Coq binaries -COQC ?= "$(COQBIN)coqc" -COQTOP ?= "$(COQBIN)coqtop" -COQCHK ?= "$(COQBIN)coqchk" -COQNATIVE ?= "$(COQBIN)coqnative" -COQDEP ?= "$(COQBIN)coqdep" -COQDOC ?= "$(COQBIN)coqdoc" -COQPP ?= "$(COQBIN)coqpp" -COQMKFILE ?= "$(COQBIN)coq_makefile" -OCAMLLIBDEP ?= "$(COQBIN)ocamllibdep" - -# Timing scripts -COQMAKE_ONE_TIME_FILE ?= "$(COQCORELIB)/tools/make-one-time-file.py" -COQMAKE_BOTH_TIME_FILES ?= "$(COQCORELIB)/tools/make-both-time-files.py" -COQMAKE_BOTH_SINGLE_TIMING_FILES ?= "$(COQCORELIB)/tools/make-both-single-timing-files.py" -BEFORE ?= -AFTER ?= - -# OCaml binaries -CAMLC ?= "$(OCAMLFIND)" ocamlc -c -CAMLOPTC ?= "$(OCAMLFIND)" opt -c -CAMLLINK ?= "$(OCAMLFIND)" ocamlc -linkall -CAMLOPTLINK ?= "$(OCAMLFIND)" opt -linkall -CAMLDOC ?= "$(OCAMLFIND)" ocamldoc -CAMLDEP ?= "$(OCAMLFIND)" ocamldep -slash -ml-synonym .mlpack - -# DESTDIR is prepended to all installation paths -DESTDIR ?= - -# Debug builds, typically -g to OCaml, -debug to Coq. -CAMLDEBUG ?= -COQDEBUG ?= - -# Extra packages to be linked in (as in findlib -package) -CAMLPKGS ?= -FINDLIBPKGS = -package coq-core.plugins.ltac $(CAMLPKGS) - -# Option for making timing files -TIMING?= -# Option for changing sorting of timing output file -TIMING_SORT_BY ?= auto -# Option for changing the fuzz parameter on the output file -TIMING_FUZZ ?= 0 -# Option for changing whether to use real or user time for timing tables -TIMING_REAL?= -# Option for including the memory column(s) -TIMING_INCLUDE_MEM?= -# Option for sorting by the memory column -TIMING_SORT_BY_MEM?= -# Output file names for timed builds -TIME_OF_BUILD_FILE ?= time-of-build.log -TIME_OF_BUILD_BEFORE_FILE ?= time-of-build-before.log -TIME_OF_BUILD_AFTER_FILE ?= time-of-build-after.log -TIME_OF_PRETTY_BUILD_FILE ?= time-of-build-pretty.log -TIME_OF_PRETTY_BOTH_BUILD_FILE ?= time-of-build-both.log -TIME_OF_PRETTY_BUILD_EXTRA_FILES ?= - # also output to the command line - -TGTS ?= - -# Retro compatibility (DESTDIR is standard on Unix, DSTROOT is not) -ifdef DSTROOT -DESTDIR := $(DSTROOT) -endif - -# Substitution of the path by appending $(DESTDIR) if needed. -# The variable $(COQMF_WINDRIVE) can be needed for Cygwin environments. -windrive_path = $(if $(COQMF_WINDRIVE),$(subst $(COQMF_WINDRIVE),/,$(1)),$(1)) -destination_path = $(if $(DESTDIR),$(DESTDIR)/$(call windrive_path,$(1)),$(1)) - -# Installation paths of libraries and documentation. -COQLIBINSTALL ?= $(call destination_path,$(COQLIB)/user-contrib) -COQDOCINSTALL ?= $(call destination_path,$(DOCDIR)/coq/user-contrib) -COQPLUGININSTALL ?= $(call destination_path,$(COQCORELIB)/..) -COQTOPINSTALL ?= $(call destination_path,$(COQLIB)/toploop) # FIXME: Unused variable? - -# findlib files installation -FINDLIBPREINST= mkdir -p "$(COQPLUGININSTALL)/" -FINDLIBDESTDIR= -destdir "$(COQPLUGININSTALL)/" - -# we need to move out of sight $(METAFILE) otherwise findlib thinks the -# package is already installed -findlib_install = \ - $(HIDE)if [ "$(METAFILE)" ]; then \ - $(FINDLIBPREINST) && \ - mv "$(METAFILE)" "$(METAFILE).skip" ; \ - "$(OCAMLFIND)" install $(2) $(FINDLIBDESTDIR) $(FINDLIBPACKAGE) $(1); \ - rc=$$?; \ - mv "$(METAFILE).skip" "$(METAFILE)"; \ - exit $$rc; \ - fi -findlib_remove = \ - $(HIDE)if [ ! -z "$(METAFILE)" ]; then\ - "$(OCAMLFIND)" remove $(FINDLIBDESTDIR) $(FINDLIBPACKAGE); \ - fi - - -########## End of parameters ################################################## -# What follows may be relevant to you only if you need to -# extend this Makefile. If so, look for 'Extension point' here and -# put in Makefile.local double colon rules accordingly. -# E.g. to perform some work after the all target completes you can write -# -# post-all:: -# echo "All done!" -# -# in Makefile.local -# -############################################################################### - - - - -# Flags ####################################################################### -# -# We define a bunch of variables combining the parameters. -# To add additional flags to coq, coqchk or coqdoc, set the -# {COQ,COQCHK,COQDOC}EXTRAFLAGS variable to whatever you want to add. -# To overwrite the default choice and set your own flags entirely, set the -# {COQ,COQCHK,COQDOC}FLAGS variable. - -SHOW := $(if $(VERBOSE),@true "",@echo "") -HIDE := $(if $(VERBOSE),,@) - -TIMER=$(if $(TIMED), $(STDTIME), $(TIMECMD)) - -OPT?= - -# The DYNOBJ and DYNLIB variables are used by "coqdep -dyndep var" in .v.d -ifeq '$(OPT)' '-byte' -USEBYTE:=true -DYNOBJ:=.cma -DYNLIB:=.cma -else -USEBYTE:= -DYNOBJ:=.cmxs -DYNLIB:=.cmxs -endif - -# these variables are meant to be overridden if you want to add *extra* flags -COQEXTRAFLAGS?= -COQCHKEXTRAFLAGS?= -COQDOCEXTRAFLAGS?= - -# Find the last argument of the form "-native-compiler FLAG" -COQUSERNATIVEFLAG:=$(strip \ -$(subst -native-compiler-,,\ -$(lastword \ -$(filter -native-compiler-%,\ -$(subst -native-compiler ,-native-compiler-,\ -$(strip $(COQEXTRAFLAGS))))))) - -COQFILTEREDEXTRAFLAGS:=$(strip \ -$(filter-out -native-compiler-%,\ -$(subst -native-compiler ,-native-compiler-,\ -$(strip $(COQEXTRAFLAGS))))) - -COQACTUALNATIVEFLAG:=$(lastword $(COQMF_COQ_NATIVE_COMPILER_DEFAULT) $(COQMF_COQPROJECTNATIVEFLAG) $(COQUSERNATIVEFLAG)) - -ifeq '$(COQACTUALNATIVEFLAG)' 'yes' - COQNATIVEFLAG="-w" "-deprecated-native-compiler-option" "-native-compiler" "ondemand" - COQDONATIVE="yes" -else -ifeq '$(COQACTUALNATIVEFLAG)' 'ondemand' - COQNATIVEFLAG="-w" "-deprecated-native-compiler-option" "-native-compiler" "ondemand" - COQDONATIVE="no" -else - COQNATIVEFLAG="-w" "-deprecated-native-compiler-option" "-native-compiler" "no" - COQDONATIVE="no" -endif -endif - -# these flags do NOT contain the libraries, to make them easier to overwrite -COQFLAGS?=-q $(OTHERFLAGS) $(COQFILTEREDEXTRAFLAGS) $(COQNATIVEFLAG) -COQCHKFLAGS?=-silent -o $(COQCHKEXTRAFLAGS) -COQDOCFLAGS?=-interpolate -utf8 $(COQDOCEXTRAFLAGS) - -COQDOCLIBS?=$(COQLIBS_NOML) - -# The version of Coq being run and the version of coq_makefile that -# generated this makefile -COQ_VERSION:=$(shell $(COQC) --print-version | cut -d " " -f 1) -COQMAKEFILE_VERSION:=8.18.0 - -# COQ_SRC_SUBDIRS is for user-overriding, usually to add -# `user-contrib/Foo` to the includes, we keep COQCORE_SRC_SUBDIRS for -# Coq's own core libraries, which should be replaced by ocamlfind -# options at some point. -COQ_SRC_SUBDIRS?= -COQSRCLIBS?= $(foreach d,$(COQ_SRC_SUBDIRS), -I "$(COQLIB)/$(d)") - -CAMLFLAGS+=$(OCAMLLIBS) $(COQSRCLIBS) -# ocamldoc fails with unknown argument otherwise -CAMLDOCFLAGS:=$(filter-out -annot, $(filter-out -bin-annot, $(CAMLFLAGS))) -CAMLFLAGS+=$(OCAMLWARN) - -ifneq (,$(TIMING)) - ifeq (after,$(TIMING)) - TIMING_EXT=after-timing - else - ifeq (before,$(TIMING)) - TIMING_EXT=before-timing - else - TIMING_EXT=timing - endif - endif - TIMING_ARG=-time-file $<.$(TIMING_EXT) -else - TIMING_ARG= -endif - -# Files ####################################################################### -# -# We here define a bunch of variables about the files being part of the -# Coq project in order to ease the writing of build target and build rules - -VDFILE := .Makefile.d - -ALLSRCFILES := \ - $(MLGFILES) \ - $(MLFILES) \ - $(MLPACKFILES) \ - $(MLLIBFILES) \ - $(MLIFILES) - -# helpers -vo_to_obj = $(addsuffix .o,\ - $(filter-out Warning: Error:,\ - $(shell $(COQTOP) -q -noinit -batch -quiet -print-mod-uid $(1)))) -strip_dotslash = $(patsubst ./%,%,$(1)) - -# without this we get undefined variables in the expansion for the -# targets of the [deprecated,use-mllib-or-mlpack] rule -with_undef = $(if $(filter-out undefined, $(origin $(1))),$($(1))) - -VO = vo -VOS = vos - -VOFILES = $(VFILES:.v=.$(VO)) -GLOBFILES = $(VFILES:.v=.glob) -HTMLFILES = $(VFILES:.v=.html) -GHTMLFILES = $(VFILES:.v=.g.html) -BEAUTYFILES = $(addsuffix .beautified,$(VFILES)) -TEXFILES = $(VFILES:.v=.tex) -GTEXFILES = $(VFILES:.v=.g.tex) -CMOFILES = \ - $(MLGFILES:.mlg=.cmo) \ - $(MLFILES:.ml=.cmo) \ - $(MLPACKFILES:.mlpack=.cmo) -CMXFILES = $(CMOFILES:.cmo=.cmx) -OFILES = $(CMXFILES:.cmx=.o) -CMAFILES = $(MLLIBFILES:.mllib=.cma) $(MLPACKFILES:.mlpack=.cma) -CMXAFILES = $(CMAFILES:.cma=.cmxa) -CMIFILES = \ - $(CMOFILES:.cmo=.cmi) \ - $(MLIFILES:.mli=.cmi) -# the /if/ is because old _CoqProject did not list a .ml(pack|lib) but just -# a .mlg file -CMXSFILES = \ - $(MLPACKFILES:.mlpack=.cmxs) \ - $(CMXAFILES:.cmxa=.cmxs) \ - $(if $(MLPACKFILES)$(CMXAFILES),,\ - $(MLGFILES:.mlg=.cmxs) $(MLFILES:.ml=.cmxs)) - -# files that are packed into a plugin (no extension) -PACKEDFILES = \ - $(call strip_dotslash, \ - $(foreach lib, \ - $(call strip_dotslash, \ - $(MLPACKFILES:.mlpack=_MLPACK_DEPENDENCIES)),$(call with_undef,$(lib)))) -# files that are archived into a .cma (mllib) -LIBEDFILES = \ - $(call strip_dotslash, \ - $(foreach lib, \ - $(call strip_dotslash, \ - $(MLLIBFILES:.mllib=_MLLIB_DEPENDENCIES)),$(call with_undef,$(lib)))) -CMIFILESTOINSTALL = $(filter-out $(addsuffix .cmi,$(PACKEDFILES)),$(CMIFILES)) -CMOFILESTOINSTALL = $(filter-out $(addsuffix .cmo,$(PACKEDFILES)),$(CMOFILES)) -OBJFILES = $(call vo_to_obj,$(VOFILES)) -ALLNATIVEFILES = \ - $(OBJFILES:.o=.cmi) \ - $(OBJFILES:.o=.cmx) \ - $(OBJFILES:.o=.cmxs) -FINDLIBPACKAGE=$(patsubst .%,%,$(suffix $(METAFILE))) - -# trick: wildcard filters out non-existing files, so that `install` doesn't show -# warnings and `clean` doesn't pass to rm a list of files that is too long for -# the shell. -NATIVEFILES = $(wildcard $(ALLNATIVEFILES)) -FILESTOINSTALL = \ - $(VOFILES) \ - $(VFILES) \ - $(GLOBFILES) \ - $(NATIVEFILES) \ - $(CMXSFILES) # to be removed when we remove legacy loading -FINDLIBFILESTOINSTALL = \ - $(CMIFILESTOINSTALL) -ifeq '$(HASNATDYNLINK)' 'true' -DO_NATDYNLINK = yes -FINDLIBFILESTOINSTALL += $(CMXSFILES) $(CMXAFILES) $(CMOFILESTOINSTALL:.cmo=.cmx) -else -DO_NATDYNLINK = -endif - -ALLDFILES = $(addsuffix .d,$(ALLSRCFILES)) $(VDFILE) - -# Compilation targets ######################################################### - -all: - $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" pre-all - $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" real-all - $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" post-all -.PHONY: all - -all.timing.diff: - $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" pre-all - $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" real-all.timing.diff TIME_OF_PRETTY_BUILD_EXTRA_FILES="" - $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" post-all -.PHONY: all.timing.diff - -ifeq (0,$(TIMING_REAL)) -TIMING_REAL_ARG := -TIMING_USER_ARG := --user -else -ifeq (1,$(TIMING_REAL)) -TIMING_REAL_ARG := --real -TIMING_USER_ARG := -else -TIMING_REAL_ARG := -TIMING_USER_ARG := -endif -endif - -ifeq (0,$(TIMING_INCLUDE_MEM)) -TIMING_INCLUDE_MEM_ARG := --no-include-mem -else -TIMING_INCLUDE_MEM_ARG := -endif - -ifeq (1,$(TIMING_SORT_BY_MEM)) -TIMING_SORT_BY_MEM_ARG := --sort-by-mem -else -TIMING_SORT_BY_MEM_ARG := -endif - -make-pretty-timed-before:: TIME_OF_BUILD_FILE=$(TIME_OF_BUILD_BEFORE_FILE) -make-pretty-timed-after:: TIME_OF_BUILD_FILE=$(TIME_OF_BUILD_AFTER_FILE) -make-pretty-timed make-pretty-timed-before make-pretty-timed-after:: - $(HIDE)rm -f pretty-timed-success.ok - $(HIDE)($(MAKE) --no-print-directory -f "$(PARENT)" $(TGTS) TIMED=1 2>&1 && touch pretty-timed-success.ok) | tee -a $(TIME_OF_BUILD_FILE) - $(HIDE)rm pretty-timed-success.ok # must not be -f; must fail if the touch failed -print-pretty-timed:: - $(HIDE)$(COQMAKE_ONE_TIME_FILE) $(TIMING_INCLUDE_MEM_ARG) $(TIMING_SORT_BY_MEM_ARG) $(TIMING_REAL_ARG) $(TIME_OF_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) -print-pretty-timed-diff:: - $(HIDE)$(COQMAKE_BOTH_TIME_FILES) --sort-by=$(TIMING_SORT_BY) $(TIMING_INCLUDE_MEM_ARG) $(TIMING_SORT_BY_MEM_ARG) $(TIMING_REAL_ARG) $(TIME_OF_BUILD_AFTER_FILE) $(TIME_OF_BUILD_BEFORE_FILE) $(TIME_OF_PRETTY_BOTH_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) -ifeq (,$(BEFORE)) -print-pretty-single-time-diff:: - @echo 'Error: Usage: $(MAKE) print-pretty-single-time-diff AFTER=path/to/file.v.after-timing BEFORE=path/to/file.v.before-timing' - $(HIDE)false -else -ifeq (,$(AFTER)) -print-pretty-single-time-diff:: - @echo 'Error: Usage: $(MAKE) print-pretty-single-time-diff AFTER=path/to/file.v.after-timing BEFORE=path/to/file.v.before-timing' - $(HIDE)false -else -print-pretty-single-time-diff:: - $(HIDE)$(COQMAKE_BOTH_SINGLE_TIMING_FILES) --fuzz=$(TIMING_FUZZ) --sort-by=$(TIMING_SORT_BY) $(TIMING_USER_ARG) $(AFTER) $(BEFORE) $(TIME_OF_PRETTY_BUILD_FILE) $(TIME_OF_PRETTY_BUILD_EXTRA_FILES) -endif -endif -pretty-timed: - $(HIDE)$(MAKE) --no-print-directory -f "$(PARENT)" make-pretty-timed - $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" print-pretty-timed -.PHONY: pretty-timed make-pretty-timed make-pretty-timed-before make-pretty-timed-after print-pretty-timed print-pretty-timed-diff print-pretty-single-time-diff - -# Extension points for actions to be performed before/after the all target -pre-all:: - @# Extension point - $(HIDE)if [ "$(COQMAKEFILE_VERSION)" != "$(COQ_VERSION)" ]; then\ - echo "W: This Makefile was generated by Coq $(COQMAKEFILE_VERSION)";\ - echo "W: while the current Coq version is $(COQ_VERSION)";\ - fi -.PHONY: pre-all - -post-all:: - @# Extension point -.PHONY: post-all - -real-all: $(VOFILES) $(if $(USEBYTE),bytefiles,optfiles) -.PHONY: real-all - -real-all.timing.diff: $(VOFILES:.vo=.v.timing.diff) -.PHONY: real-all.timing.diff - -bytefiles: $(CMOFILES) $(CMAFILES) -.PHONY: bytefiles - -optfiles: $(if $(DO_NATDYNLINK),$(CMXSFILES)) -.PHONY: optfiles - -# FIXME, see Ralf's bugreport -# quick is deprecated, now renamed vio -vio: $(VOFILES:.vo=.vio) -.PHONY: vio -quick: vio - $(warning "'make quick' is deprecated, use 'make vio' or consider using 'vos' files") -.PHONY: quick - -vio2vo: - $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) \ - -schedule-vio2vo $(J) $(VOFILES:%.vo=%.vio) -.PHONY: vio2vo - -# quick2vo is undocumented -quick2vo: - $(HIDE)make -j $(J) vio - $(HIDE)VIOFILES=$$(for vofile in $(VOFILES); do \ - viofile="$$(echo "$$vofile" | sed "s/\.vo$$/.vio/")"; \ - if [ "$$vofile" -ot "$$viofile" -o ! -e "$$vofile" ]; then printf "$$viofile "; fi; \ - done); \ - echo "VIO2VO: $$VIOFILES"; \ - if [ -n "$$VIOFILES" ]; then \ - $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) -schedule-vio2vo $(J) $$VIOFILES; \ - fi -.PHONY: quick2vo - -checkproofs: - $(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) \ - -schedule-vio-checking $(J) $(VOFILES:%.vo=%.vio) -.PHONY: checkproofs - -vos: $(VOFILES:%.vo=%.vos) -.PHONY: vos - -vok: $(VOFILES:%.vo=%.vok) -.PHONY: vok - -validate: $(VOFILES) - $(TIMER) $(COQCHK) $(COQCHKFLAGS) $(COQLIBS_NOML) $^ -.PHONY: validate - -only: $(TGTS) -.PHONY: only - -# Documentation targets ####################################################### - -html: $(GLOBFILES) $(VFILES) - $(SHOW)'COQDOC -d html $(GAL)' - $(HIDE)mkdir -p html - $(HIDE)$(COQDOC) \ - -toc $(COQDOCFLAGS) -html $(GAL) $(COQDOCLIBS) -d html $(VFILES) - -mlihtml: $(MLIFILES:.mli=.cmi) - $(SHOW)'CAMLDOC -d $@' - $(HIDE)mkdir $@ || rm -rf $@/* - $(HIDE)$(CAMLDOC) -html \ - -d $@ -m A $(CAMLDEBUG) $(CAMLDOCFLAGS) $(MLIFILES) $(FINDLIBPKGS) - -all-mli.tex: $(MLIFILES:.mli=.cmi) - $(SHOW)'CAMLDOC -latex $@' - $(HIDE)$(CAMLDOC) -latex \ - -o $@ -m A $(CAMLDEBUG) $(CAMLDOCFLAGS) $(MLIFILES) $(FINDLIBPKGS) - -all.ps: $(VFILES) - $(SHOW)'COQDOC -ps $(GAL)' - $(HIDE)$(COQDOC) \ - -toc $(COQDOCFLAGS) -ps $(GAL) $(COQDOCLIBS) \ - -o $@ `$(COQDEP) -sort $(VFILES)` - -all.pdf: $(VFILES) - $(SHOW)'COQDOC -pdf $(GAL)' - $(HIDE)$(COQDOC) \ - -toc $(COQDOCFLAGS) -pdf $(GAL) $(COQDOCLIBS) \ - -o $@ `$(COQDEP) -sort $(VFILES)` - -# FIXME: not quite right, since the output name is different -gallinahtml: GAL=-g -gallinahtml: html - -all-gal.ps: GAL=-g -all-gal.ps: all.ps - -all-gal.pdf: GAL=-g -all-gal.pdf: all.pdf - -# ? -beautify: $(BEAUTYFILES) - for file in $^; do mv $${file%.beautified} $${file%beautified}old && mv $${file} $${file%.beautified}; done - @echo 'Do not do "make clean" until you are sure that everything went well!' - @echo 'If there were a problem, execute "for file in $$(find . -name \*.v.old -print); do mv $${file} $${file%.old}; done" in your shell/' -.PHONY: beautify - -# Installation targets ######################################################## -# -# There rules can be extended in Makefile.local -# Extensions can't assume when they run. - -# We use $(file) to avoid generating a very long command string to pass to the shell -# (cf https://coq.zulipchat.com/#narrow/stream/250632-Coq-Platform-devs-.26-users/topic/Strange.20command.20length.20limit.20on.20Linux) -# However Apple ships old make which doesn't have $(file) so we need a fallback -$(file >.hasfile,1) -HASFILE:=$(shell if [ -e .hasfile ]; then echo 1; rm .hasfile; fi) - -MKFILESTOINSTALL= $(if $(HASFILE),$(file >.filestoinstall,$(FILESTOINSTALL)),\ - $(shell rm -f .filestoinstall) \ - $(foreach x,$(FILESTOINSTALL),$(shell printf '%s\n' "$x" >> .filestoinstall))) - -# findlib needs the package to not be installed, so we remove it before -# installing it (see the call to findlib_remove) -install: META - @$(MKFILESTOINSTALL) - $(HIDE)code=0; for f in $$(cat .filestoinstall); do\ - if ! [ -f "$$f" ]; then >&2 echo $$f does not exist; code=1; fi \ - done; exit $$code - $(HIDE)for f in $$(cat .filestoinstall); do\ - df="`$(COQMKFILE) -destination-of "$$f" $(COQLIBS)`";\ - if [ "$$?" != "0" -o -z "$$df" ]; then\ - echo SKIP "$$f" since it has no logical path;\ - else\ - install -d "$(COQLIBINSTALL)/$$df" &&\ - install -m 0644 "$$f" "$(COQLIBINSTALL)/$$df" &&\ - echo INSTALL "$$f" "$(COQLIBINSTALL)/$$df";\ - fi;\ - done - $(call findlib_remove) - $(call findlib_install, META $(FINDLIBFILESTOINSTALL)) - $(HIDE)$(MAKE) install-extra -f "$(SELF)" - @rm -f .filestoinstall -install-extra:: - @# Extension point -.PHONY: install install-extra - -META: $(METAFILE) - $(HIDE)if [ "$(METAFILE)" ]; then \ - cat "$(METAFILE)" | grep -v 'directory.*=.*' > META; \ - fi - -install-byte: - $(call findlib_install, $(CMAFILES) $(CMOFILESTOINSTALL), -add) - -install-doc:: html mlihtml - @# Extension point - $(HIDE)install -d "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/html" - $(HIDE)for i in html/*; do \ - dest="$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/$$i";\ - install -m 0644 "$$i" "$$dest";\ - echo INSTALL "$$i" "$$dest";\ - done - $(HIDE)install -d \ - "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/mlihtml" - $(HIDE)for i in mlihtml/*; do \ - dest="$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/$$i";\ - install -m 0644 "$$i" "$$dest";\ - echo INSTALL "$$i" "$$dest";\ - done -.PHONY: install-doc - -uninstall:: - @# Extension point - @$(MKFILESTOINSTALL) - $(call findlib_remove) - $(HIDE)for f in $$(cat .filestoinstall); do \ - df="`$(COQMKFILE) -destination-of "$$f" $(COQLIBS)`" &&\ - instf="$(COQLIBINSTALL)/$$df/`basename $$f`" &&\ - rm -f "$$instf" &&\ - echo RM "$$instf" ;\ - done - $(HIDE)for f in $$(cat .filestoinstall); do \ - df="`$(COQMKFILE) -destination-of "$$f" $(COQLIBS)`" &&\ - echo RMDIR "$(COQLIBINSTALL)/$$df/" &&\ - (rmdir "$(COQLIBINSTALL)/$$df/" 2>/dev/null || true); \ - done - @rm -f .filestoinstall - -.PHONY: uninstall - -uninstall-doc:: - @# Extension point - $(SHOW)'RM $(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/html' - $(HIDE)rm -rf "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/html" - $(SHOW)'RM $(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/mlihtml' - $(HIDE)rm -rf "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/mlihtml" - $(HIDE) rmdir "$(COQDOCINSTALL)/$(INSTALLCOQDOCROOT)/" || true -.PHONY: uninstall-doc - -# Cleaning #################################################################### -# -# There rules can be extended in Makefile.local -# Extensions can't assume when they run. - -clean:: - @# Extension point - $(SHOW)'CLEAN' - $(HIDE)rm -f $(CMOFILES) - $(HIDE)rm -f $(CMIFILES) - $(HIDE)rm -f $(CMAFILES) - $(HIDE)rm -f $(CMXFILES) - $(HIDE)rm -f $(CMXAFILES) - $(HIDE)rm -f $(CMXSFILES) - $(HIDE)rm -f $(OFILES) - $(HIDE)rm -f $(CMXAFILES:.cmxa=.a) - $(HIDE)rm -f $(MLGFILES:.mlg=.ml) - $(HIDE)rm -f $(CMXFILES:.cmx=.cmt) - $(HIDE)rm -f $(MLIFILES:.mli=.cmti) - $(HIDE)rm -f $(ALLDFILES) - $(HIDE)rm -f $(NATIVEFILES) - $(HIDE)find . -name .coq-native -type d -empty -delete - $(HIDE)rm -f $(VOFILES) - $(HIDE)rm -f $(VOFILES:.vo=.vio) - $(HIDE)rm -f $(VOFILES:.vo=.vos) - $(HIDE)rm -f $(VOFILES:.vo=.vok) - $(HIDE)rm -f $(BEAUTYFILES) $(VFILES:=.old) - $(HIDE)rm -f all.ps all-gal.ps all.pdf all-gal.pdf all.glob all-mli.tex - $(HIDE)rm -f $(VFILES:.v=.glob) - $(HIDE)rm -f $(VFILES:.v=.tex) - $(HIDE)rm -f $(VFILES:.v=.g.tex) - $(HIDE)rm -f pretty-timed-success.ok - $(HIDE)rm -f META - $(HIDE)rm -rf html mlihtml -.PHONY: clean - -cleanall:: clean - @# Extension point - $(SHOW)'CLEAN *.aux *.timing' - $(HIDE)rm -f $(foreach f,$(VFILES:.v=),$(dir $(f)).$(notdir $(f)).aux) - $(HIDE)rm -f $(TIME_OF_BUILD_FILE) $(TIME_OF_BUILD_BEFORE_FILE) $(TIME_OF_BUILD_AFTER_FILE) $(TIME_OF_PRETTY_BUILD_FILE) $(TIME_OF_PRETTY_BOTH_BUILD_FILE) - $(HIDE)rm -f $(VOFILES:.vo=.v.timing) - $(HIDE)rm -f $(VOFILES:.vo=.v.before-timing) - $(HIDE)rm -f $(VOFILES:.vo=.v.after-timing) - $(HIDE)rm -f $(VOFILES:.vo=.v.timing.diff) - $(HIDE)rm -f .lia.cache .nia.cache -.PHONY: cleanall - -archclean:: - @# Extension point - $(SHOW)'CLEAN *.cmx *.o' - $(HIDE)rm -f $(NATIVEFILES) - $(HIDE)rm -f $(CMOFILES:%.cmo=%.cmx) -.PHONY: archclean - - -# Compilation rules ########################################################### - -$(MLIFILES:.mli=.cmi): %.cmi: %.mli - $(SHOW)'CAMLC -c $<' - $(HIDE)$(TIMER) $(CAMLC) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) $< - -$(MLGFILES:.mlg=.ml): %.ml: %.mlg - $(SHOW)'COQPP $<' - $(HIDE)$(COQPP) $< - -# Stupid hack around a deficient syntax: we cannot concatenate two expansions -$(filter %.cmo, $(MLFILES:.ml=.cmo) $(MLGFILES:.mlg=.cmo)): %.cmo: %.ml - $(SHOW)'CAMLC -c $<' - $(HIDE)$(TIMER) $(CAMLC) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) $< - -# Same hack -$(filter %.cmx, $(MLFILES:.ml=.cmx) $(MLGFILES:.mlg=.cmx)): %.cmx: %.ml - $(SHOW)'CAMLOPT -c $(FOR_PACK) $<' - $(HIDE)$(TIMER) $(CAMLOPTC) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) $(FOR_PACK) $< - - -$(MLLIBFILES:.mllib=.cmxs): %.cmxs: %.cmxa - $(SHOW)'CAMLOPT -shared -o $@' - $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) \ - -shared -o $@ $< - -$(MLLIBFILES:.mllib=.cma): %.cma: | %.mllib - $(SHOW)'CAMLC -a -o $@' - $(HIDE)$(TIMER) $(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) -a -o $@ $^ - -$(MLLIBFILES:.mllib=.cmxa): %.cmxa: | %.mllib - $(SHOW)'CAMLOPT -a -o $@' - $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) -a -o $@ $^ - - -$(MLPACKFILES:.mlpack=.cmxs): %.cmxs: %.cmxa - $(SHOW)'CAMLOPT -shared -o $@' - $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) \ - -shared -o $@ $< - -$(MLPACKFILES:.mlpack=.cmxa): %.cmxa: %.cmx | %.mlpack - $(SHOW)'CAMLOPT -a -o $@' - $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) -a -o $@ $< - -$(MLPACKFILES:.mlpack=.cma): %.cma: %.cmo | %.mlpack - $(SHOW)'CAMLC -a -o $@' - $(HIDE)$(TIMER) $(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) -a -o $@ $^ - -$(MLPACKFILES:.mlpack=.cmo): %.cmo: | %.mlpack - $(SHOW)'CAMLC -pack -o $@' - $(HIDE)$(TIMER) $(CAMLLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) -pack -o $@ $^ - -$(MLPACKFILES:.mlpack=.cmx): %.cmx: | %.mlpack - $(SHOW)'CAMLOPT -pack -o $@' - $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) -pack -o $@ $^ - -# This rule is for _CoqProject with no .mllib nor .mlpack -$(filter-out $(MLLIBFILES:.mllib=.cmxs) $(MLPACKFILES:.mlpack=.cmxs) $(addsuffix .cmxs,$(PACKEDFILES)) $(addsuffix .cmxs,$(LIBEDFILES)),$(MLFILES:.ml=.cmxs) $(MLGFILES:.mlg=.cmxs)): %.cmxs: %.cmx - $(SHOW)'[deprecated,use-mllib-or-mlpack] CAMLOPT -shared -o $@' - $(HIDE)$(TIMER) $(CAMLOPTLINK) $(CAMLDEBUG) $(CAMLFLAGS) $(FINDLIBPKGS) \ - -shared -o $@ $< - -# can't make -# https://www.gnu.org/software/make/manual/make.html#Static-Pattern -# work with multiple target rules -# so use eval in a loop instead -# with grouped targets https://www.gnu.org/software/make/manual/make.html#Multiple-Targets -# if available (GNU Make >= 4.3) -ifneq (,$(filter grouped-target,$(.FEATURES))) -define globvorule= - -# take care to $$ variables using $< etc - $(1).vo $(1).glob &: $(1).v | $(VDFILE) - $(SHOW)COQC $(1).v - $(HIDE)$$(TIMER) $(COQC) $(COQDEBUG) $$(TIMING_ARG) $(COQFLAGS) $(COQLIBS) $(1).v -ifeq ($(COQDONATIVE), "yes") - $(SHOW)COQNATIVE $(1).vo - $(HIDE)$(call TIMER,$(1).vo.native) $(COQNATIVE) $(COQLIBS) $(1).vo -endif - -endef -else - -$(VOFILES): %.vo: %.v | $(VDFILE) - $(SHOW)COQC $< - $(HIDE)$(TIMER) $(COQC) $(COQDEBUG) $(TIMING_ARG) $(COQFLAGS) $(COQLIBS) $< -ifeq ($(COQDONATIVE), "yes") - $(SHOW)COQNATIVE $@ - $(HIDE)$(call TIMER,$@.native) $(COQNATIVE) $(COQLIBS) $@ -endif - -# this is broken :( todo fix if we ever find a solution that doesn't need grouped targets -$(GLOBFILES): %.glob: %.v - $(SHOW)'COQC $< (for .glob)' - $(HIDE)$(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< - -endif - -$(foreach vfile,$(VFILES:.v=),$(eval $(call globvorule,$(vfile)))) - -$(VFILES:.v=.vio): %.vio: %.v - $(SHOW)COQC -vio $< - $(HIDE)$(TIMER) $(COQC) -vio $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< - -$(VFILES:.v=.vos): %.vos: %.v - $(SHOW)COQC -vos $< - $(HIDE)$(TIMER) $(COQC) -vos $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< - -$(VFILES:.v=.vok): %.vok: %.v - $(SHOW)COQC -vok $< - $(HIDE)$(TIMER) $(COQC) -vok $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< - -$(addsuffix .timing.diff,$(VFILES)): %.timing.diff : %.before-timing %.after-timing - $(SHOW)PYTHON TIMING-DIFF $*.{before,after}-timing - $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" print-pretty-single-time-diff BEFORE=$*.before-timing AFTER=$*.after-timing TIME_OF_PRETTY_BUILD_FILE="$@" - -$(BEAUTYFILES): %.v.beautified: %.v - $(SHOW)'BEAUTIFY $<' - $(HIDE)$(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) -beautify $< - -$(TEXFILES): %.tex: %.v - $(SHOW)'COQDOC -latex $<' - $(HIDE)$(COQDOC) $(COQDOCFLAGS) -latex $< -o $@ - -$(GTEXFILES): %.g.tex: %.v - $(SHOW)'COQDOC -latex -g $<' - $(HIDE)$(COQDOC) $(COQDOCFLAGS) -latex -g $< -o $@ - -$(HTMLFILES): %.html: %.v %.glob - $(SHOW)'COQDOC -html $<' - $(HIDE)$(COQDOC) $(COQDOCFLAGS) -html $< -o $@ - -$(GHTMLFILES): %.g.html: %.v %.glob - $(SHOW)'COQDOC -html -g $<' - $(HIDE)$(COQDOC) $(COQDOCFLAGS) -html -g $< -o $@ - -# Dependency files ############################################################ - -ifndef MAKECMDGOALS - -include $(ALLDFILES) -else - ifneq ($(filter-out archclean clean cleanall printenv make-pretty-timed make-pretty-timed-before make-pretty-timed-after print-pretty-timed print-pretty-timed-diff print-pretty-single-time-diff,$(MAKECMDGOALS)),) - -include $(ALLDFILES) - endif -endif - -.SECONDARY: $(ALLDFILES) - -redir_if_ok = > "$@" || ( RV=$$?; rm -f "$@"; exit $$RV ) - -GENMLFILES:=$(MLGFILES:.mlg=.ml) -$(addsuffix .d,$(ALLSRCFILES)): $(GENMLFILES) - -$(addsuffix .d,$(MLIFILES)): %.mli.d: %.mli - $(SHOW)'CAMLDEP $<' - $(HIDE)$(CAMLDEP) $(OCAMLLIBS) "$<" $(redir_if_ok) - -$(addsuffix .d,$(MLGFILES)): %.mlg.d: %.ml - $(SHOW)'CAMLDEP $<' - $(HIDE)$(CAMLDEP) $(OCAMLLIBS) "$<" $(redir_if_ok) - -$(addsuffix .d,$(MLFILES)): %.ml.d: %.ml - $(SHOW)'CAMLDEP $<' - $(HIDE)$(CAMLDEP) $(OCAMLLIBS) "$<" $(redir_if_ok) - -$(addsuffix .d,$(MLLIBFILES)): %.mllib.d: %.mllib - $(SHOW)'OCAMLLIBDEP $<' - $(HIDE)$(OCAMLLIBDEP) -c $(OCAMLLIBS) "$<" $(redir_if_ok) - -$(addsuffix .d,$(MLPACKFILES)): %.mlpack.d: %.mlpack - $(SHOW)'OCAMLLIBDEP $<' - $(HIDE)$(OCAMLLIBDEP) -c $(OCAMLLIBS) "$<" $(redir_if_ok) - -# If this makefile is created using a _CoqProject we have coqdep get -# options from it. This avoids argument length limits for pathological -# projects. Note that extra options might be on the command line. -VDFILE_FLAGS:=$(if _CoqProject,-f _CoqProject,) $(CMDLINE_COQLIBS) $(CMDLINE_VFILES) - -$(VDFILE): _CoqProject $(VFILES) - $(SHOW)'COQDEP VFILES' - $(HIDE)$(COQDEP) $(if $(strip $(METAFILE)),-m "$(METAFILE)") -vos -dyndep var $(VDFILE_FLAGS) $(redir_if_ok) - -# Misc ######################################################################## - -byte: - $(HIDE)$(MAKE) all "OPT:=-byte" -f "$(SELF)" -.PHONY: byte - -opt: - $(HIDE)$(MAKE) all "OPT:=-opt" -f "$(SELF)" -.PHONY: opt - -# This is deprecated. To extend this makefile use -# extension points and Makefile.local -printenv:: - $(warning printenv is deprecated) - $(warning write extensions in Makefile.local or include Makefile.conf) - @echo 'COQLIB = $(COQLIB)' - @echo 'COQCORELIB = $(COQCORELIB)' - @echo 'DOCDIR = $(DOCDIR)' - @echo 'OCAMLFIND = $(OCAMLFIND)' - @echo 'HASNATDYNLINK = $(HASNATDYNLINK)' - @echo 'SRC_SUBDIRS = $(SRC_SUBDIRS)' - @echo 'COQ_SRC_SUBDIRS = $(COQ_SRC_SUBDIRS)' - @echo 'COQCORE_SRC_SUBDIRS = $(COQCORE_SRC_SUBDIRS)' - @echo 'OCAMLFIND = $(OCAMLFIND)' - @echo 'PP = $(PP)' - @echo 'COQFLAGS = $(COQFLAGS)' - @echo 'COQLIB = $(COQLIBS)' - @echo 'COQLIBINSTALL = $(COQLIBINSTALL)' - @echo 'COQDOCINSTALL = $(COQDOCINSTALL)' -.PHONY: printenv - -# Generate a .merlin file. If you need to append directives to this -# file you can extend the merlin-hook target in Makefile.local -.merlin: - $(SHOW)'FILL .merlin' - $(HIDE)echo 'FLG $(COQMF_CAMLFLAGS)' > .merlin - $(HIDE)echo 'B $(COQCORELIB)' >> .merlin - $(HIDE)echo 'S $(COQCORELIB)' >> .merlin - $(HIDE)$(foreach d,$(COQCORE_SRC_SUBDIRS), \ - echo 'B $(COQCORELIB)$(d)' >> .merlin;) - $(HIDE)$(foreach d,$(COQ_SRC_SUBDIRS), \ - echo 'S $(COQLIB)$(d)' >> .merlin;) - $(HIDE)$(foreach d,$(SRC_SUBDIRS), echo 'B $(d)' >> .merlin;) - $(HIDE)$(foreach d,$(SRC_SUBDIRS), echo 'S $(d)' >> .merlin;) - $(HIDE)$(MAKE) merlin-hook -f "$(SELF)" -.PHONY: merlin - -merlin-hook:: - @# Extension point -.PHONY: merlin-hook - -# prints all variables -debug: - $(foreach v,\ - $(sort $(filter-out $(INITIAL_VARS) INITIAL_VARS,\ - $(.VARIABLES))),\ - $(info $(v) = $($(v)))) -.PHONY: debug - -.DEFAULT_GOAL := all - -# Users can create Makefile.local-late to hook into double-colon rules -# or add other needed Makefile code, using defined -# variables if necessary. --include Makefile.local-late - -# Local Variables: -# mode: makefile-gmake -# End: +install: + $(MAKE) -f Makefile.coq install diff --git a/README.md b/README.md index ad332b7d..f4d9120b 100644 --- a/README.md +++ b/README.md @@ -2,15 +2,15 @@ This repository contains the Coq formalisation of the paper:\ **SSProve: A Foundational Framework for Modular Cryptographic Proofs in Coq** -- Conference version published at CSF 2021 (distinguished paper award). +- Extended journal version published at TOPLAS ([DOI](https://dl.acm.org/doi/10.1145/3594735)). + Philipp G. Haselwarter, Exequiel Rivas, Antoine Van Muylder, Théo Winterhalter, + Carmine Abate, Nikolaj Sidorenco, Cătălin Hrițcu, Kenji Maillard, and + Bas Spitters. ([eprint](https://eprint.iacr.org/2021/397)) +- Conference version published at CSF 2021 (**distinguished paper award**). Carmine Abate, Philipp G. Haselwarter, Exequiel Rivas, Antoine Van Muylder, Théo Winterhalter, Cătălin Hrițcu, Kenji Maillard, and Bas Spitters. ([ieee](https://www.computer.org/csdl/proceedings-article/csf/2021/760700a608/1uvIdwNa5Ne), [eprint](https://eprint.iacr.org/2021/397/20210526:113037)) -- Extended version under journal review. - Carmine Abate, Philipp G. Haselwarter, Exequiel Rivas, Antoine Van Muylder, - Théo Winterhalter, Nikolaj Sidorenco, Cătălin Hrițcu, Kenji Maillard, and - Bas Spitters. ([eprint](https://eprint.iacr.org/2021/397)) This README serves as a guide to running verification and finding the correspondence between the claims in the paper and the formal proofs in Coq, as @@ -27,99 +27,28 @@ A documentation is available in [DOC.md]. - [TYPES'21](https://youtu.be/FdMRB1mnyUA): Video focused on semantics and programming logic (speaker: Antoine Van Muylder) - [Coq Workshop '21](https://youtu.be/uYhItPhA-Y8): Video illustrating the formalisation (speaker: Théo Winterhalter) -## Jasmin translation and examples - -### Translation - -This branch contains a formally verified translation from Jasmin -programs to SSProve programs. The translation is defined and proven -correct in [theories/Jasmin/jasmin_translate.v]. The main theorem is -`translate_prog_correct` which states that a translated jasmin -function has the same input/output behavior as the original function. - -In [theories/Jasmin/jasmin_asm.v] we combine `translate_prog_correct` -and the correctness theorem of the Jasmin compiler to prove -`equiv_to_asm`, which states that if a Jasmin program compiles -correctly, then functions from the compiled assembly program have the -same input/output behavior as the corresponding functions from the -translated SSProve program. This is the theorem which justifies that -reasoning about the translated SSProve program gives guarantees about -the compiled assembly program. - -In [theories/Jasmin/jasmin_x86.v] `equiv_to_asm` is specialized to x86 architecture. - -### Examples - -[theories/Jasmin/examples/] contains a suite of Jasmin programs and -their translations to SSProve; the Jasmin programs are mainly from the -Jasmin repository. - -[theories/Jasmin/examples/aes/] contains a formal proof of IND-CPA -security of a symmetric encryption scheme using AES, where AES is -implemented in Jasmin and translated to SSProve. - -[theories/Jasmin/examples/aes/aes_jazz.v] contains the translated -SSProve program and some notations for handling it. - -[theories/Jasmin/examples/aes/aes_spec.v] contains a Coq -implementation (`aes`) of AES which we use as a spec. It also contains -a handwritten SSProve implementation (`Caes`) of AES which serves as -an intermediate implementation to make the proofs easier. Finally, it -contains the lemma `aes_h`, which relates the two. - -[theories/Jasmin/examples/aes/aes.v] relates the Jasmin implementation -of AES (`JAES`) to the intermediate SSProve implementation. The lemma -`aes_E` prove that they are equivalent. - -[theories/Jasmin/examples/aes/aes_prf.v] contains the proof of IND-CPA -security of a encryption scheme using a pseudo-random function -(PRF). This is the lemma `security_based_on_prf`; note that this is -almost verbatim taken from [examples/PRF.v]. Then we instantiate the -lemma with our translated Jasmin implementation AES and prove that the -same security notion holds for the efficient implementation. This is -`jsecurity_based_on_prf`. - ## Installation #### Prerequisites -- OCaml `>=4.05.0 & <4.13.0` -- Coq `8.15.2` -- Equations `1.3+8.15` -- Mathcomp `1.13.0` -- Mathcomp analysis `0.3.13` +- OCaml `>=4.05.0 & <5` +- Coq `>=8.16.0 & <8.18.0` +- Equations `1.3` +- Mathcomp `>=1.15.0` +- Mathcomp analysis `>=0.5.3` - Coq Extructures `0.3.1` - Coq Deriving `0.1` -- mczify 1.2.0+1.12+8.13 You can get them all from the `opam` package manager for OCaml: ```sh opam repo add coq-released https://coq.inria.fr/opam/released opam update -opam install ./ssprove-opam +opam install ./ssprove.opam ``` To build the dependency graph, you can optionally install `graphviz`. On macOS, `gsed` is additionally required for this. -#### Jasmin - -In order to build the `jasmin` branch, a recent version of `https://github.com/jasmin-lang/jasmin` should be installed. This can be done via `opam`, by cloning the `jasmin` repo and running -```sh -cd jasmin -opam install . -``` -The last version of Jasmin that is known to work is `52624d84`, but we try to track `main`. -For all proofs to work and a pretty printer for Coq AST's, a custom version is currently necessary. -The pretty printer is available via the `-coq` compiler flag. - -To install a local copy of Jasmin, one may use -```sh -cd jasmin -make -opam install --assume-built --working-dir ./opam -``` - #### Running verification Run `make` from this directory to verify all the Coq files. @@ -135,8 +64,7 @@ Run `make graph` to build a graph of dependencies between sources. | [theories] | Root of all the Coq files | | [theories/Mon] | External development coming from "Dijkstra Monads For All" | | [theories/Relational] | External development coming from "The Next 700 Relational Program Logics"| -| [theories/Crypt] | The original SSProve paper | -| [theories/Jasmin] | This paper | +| [theories/Crypt] | This paper | Unless specified with a full path, all files considered in this README can safely be assumed to be in [theories/Crypt]. @@ -149,10 +77,14 @@ The formalisation of packages can be found in the [package] directory. The definition of packages can be found in [pkg_core_definition.v]. Herein, `package L I E` is the type of packages with set of locations `L`, -import interface `I` and export interface `E`. +import interface `I` and export interface `E`. It is defined on top of +`raw_package` which does not contain the information about its interfaces +and the locations it uses. Package laws, as introduced in the paper, are all stated and proven in -[pkg_composition.v] directly on raw packages. +[pkg_composition.v] directly on raw packages. This technical detail is not +mentioned in the paper, but we are nonetheless only interested in these +laws over proper packages whose interfaces match. #### Sequential composition @@ -267,7 +199,7 @@ more. Packages created through our operations always verify this property #### Interchange between sequential and parallel composition -Finally we prove a law involving sequential and parallel composition +Finally, we prove a law involving sequential and parallel composition stating how we can interchange them: ```coq Lemma interchange : @@ -403,7 +335,7 @@ Theorem commitment_binding : ɛ_soundness A Adv. ``` -Combining the above theorems with the instatiation of Schnorr's protocol we get a commitment scheme given by: +Combining the above theorems with the instantiation of Schnorr's protocol we get a commitment scheme given by: ```coq Theorem schnorr_com_hiding : @@ -460,7 +392,7 @@ We separate by a slash (/) rule names that differ in the CSF (left) and journal | async-put-lhs | `r_put_lhs` | | restore-pre-lhs | `r_restore_lhs` | -Finally the "bwhile" / "do-while" rule is proven as +Finally, the "bwhile" / "do-while" rule is proven as `bounded_do_while_rule` in [rules/RulesStateProb.v]. ### More Lemmas and Theorems for packages @@ -561,7 +493,7 @@ This relational effect observation is called file [rhl_semantics/only_prob/ThetaDex.v] as a composition: FreeProb² ---`unary_theta_dens²`---> SDistr² ---`θ_morph`---> Wrelprop -The first part `unary_theta_dens²` consists in intepreting pairs +The first part `unary_theta_dens²` consists in interpreting pairs of probabilistic programs into pairs of actual subdistributions. This unary semantics for probabilistic programs `unary_theta_dens` is defined in [rhl_semantics/only_prob/Theta_dens.v]. @@ -584,7 +516,7 @@ It is defined in the file [rhl_semantics/only_prob/Theta_exCP.v]. up to inequalities. The definition of `θ_morph` relies on the notion of couplings, defined in this file [rhl_semantics/only_prob/Couplings.v]. -The prove that it constitutes a lax morphism depends on lemmas +The proof that it constitutes a lax morphism depends on lemmas for couplings that can be found in the same file. @@ -657,8 +589,8 @@ a lax morphism Kl(θ) between those Kleisli adjunctions. Kl(θ) is a lax morphism between left relative adjunctions, (see [LaxMorphismOfRelAdjunctions.v]) and we can transform such morphisms of adjunctions using -the theory developped in [TransformingLaxMorph.v]. -Finallly, out of this transformed morphism of adjunctions we can +the theory developed in [TransformingLaxMorph.v]. +Finally, out of this transformed morphism of adjunctions we can extract a lax morphism between monads Tθ : T M1 → T M2, as expected. This last step is also performed in [TransformingLaxMorph.v]. @@ -803,13 +735,3 @@ We do something similar for Schnorr's protocol. [rhl_semantics/state_prob/]: theories/Crypt/rhl_semantics/state_prob/ [Main.v]: theories/Crypt/Main.v [DOC.md]: ./DOC.md -[theories/Jasmin/jasmin_translate.v]: theories/Jasmin/jasmin_translate.v -[theories/Jasmin/jasmin_asm.v]: theories/Jasmin/jasmin_asm.v -[theories/Jasmin/jasmin_x86.v]: theories/Jasmin/jasmin_x86.v -[theories/Jasmin/examples/]: theories/Jasmin/examples/ -[theories/Jasmin/examples/aes/]: theories/Jasmin/examples/aes/ -[theories/Jasmin/examples/aes/aes.v]: theories/Jasmin/examples/aes/aes.v -[theories/Jasmin/examples/aes/aes_jazz.v]: theories/Jasmin/examples/aes/aes_jazz.v -[theories/Jasmin/examples/aes/aes_prf.v]: theories/Jasmin/examples/aes/aes_prf.v -[theories/Jasmin/examples/aes/aes_spec.v]: theories/Jasmin/examples/aes/aes_spec.v -[theories/Jasmin/examples/aes/aes_valid.v]: theories/Jasmin/examples/aes/aes_valid.v diff --git a/_CoqProject b/_CoqProject index 368ce895..acaf984d 100644 --- a/_CoqProject +++ b/_CoqProject @@ -1,7 +1,7 @@ -Q theories/Mon Mon -Q theories/Relational Relational -Q theories/Crypt Crypt --Q theories/Jasmin JasminSSProve +# -Q theories/Jasmin JasminSSProve theories/Mon/Base.v theories/Mon/SPropBase.v @@ -23,6 +23,9 @@ theories/Relational/Commutativity.v theories/Crypt/Prelude.v theories/Crypt/Axioms.v +theories/Crypt/Casts.v +theories/Crypt/jasmin_util.v +theories/Crypt/jasmin_word.v theories/Crypt/choice_type.v # Categorical semantics @@ -116,13 +119,14 @@ theories/Crypt/examples/interpreter_test.v theories/Crypt/examples/concrete_groups.v theories/Crypt/examples/PRF.v theories/Crypt/examples/AsymScheme.v +theories/Crypt/examples/DDH.v theories/Crypt/examples/ElGamal.v theories/Crypt/examples/OTP.v theories/Crypt/examples/KEMDEM.v theories/Crypt/examples/RandomOracle.v theories/Crypt/examples/SigmaProtocol.v theories/Crypt/examples/Schnorr.v -theories/Crypt/examples/DDH.v +theories/Crypt/examples/OVN.v # Printing the axioms of all results from the paper theories/Crypt/Main.v diff --git a/depgraph.sh b/depgraph.sh index addb5e94..0dadadbc 100755 --- a/depgraph.sh +++ b/depgraph.sh @@ -61,6 +61,6 @@ fi # fat border around modules without clients gvpr -c 'N[indegree == 0]{penwidth=3}' > $fn_out.dot -dot -T pdf $fn_out.dot > ${fn_out}.pdf +dot -T svg $fn_out.dot > $fn_out.svg # dot -T png $fn_out.dot > $fn_out.png # dot -T cmap $fn_out.dot | $SED -e 's,>$,/>,' > $fn_out.map diff --git a/flake.lock b/flake.lock new file mode 100644 index 00000000..49c856c9 --- /dev/null +++ b/flake.lock @@ -0,0 +1,60 @@ +{ + "nodes": { + "flake-utils": { + "inputs": { + "systems": "systems" + }, + "locked": { + "lastModified": 1705309234, + "narHash": "sha256-uNRRNRKmJyCRC/8y1RqBkqWBLM034y4qN7EprSdmgyA=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "1ef2e671c3b0c19053962c07dbda38332dcebf26", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "nixpkgs": { + "locked": { + "lastModified": 1707824078, + "narHash": "sha256-Au3wLi2d06bU7TDvahP2jIEeKwmjAxKHqi8l2uiBkGA=", + "owner": "nixos", + "repo": "nixpkgs", + "rev": "99d7b32e4cfdaf763d9335b4d9ecf4415cbdc405", + "type": "github" + }, + "original": { + "owner": "nixos", + "repo": "nixpkgs", + "type": "github" + } + }, + "root": { + "inputs": { + "flake-utils": "flake-utils", + "nixpkgs": "nixpkgs" + } + }, + "systems": { + "locked": { + "lastModified": 1681028828, + "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", + "owner": "nix-systems", + "repo": "default", + "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", + "type": "github" + }, + "original": { + "owner": "nix-systems", + "repo": "default", + "type": "github" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 00000000..f54ddbc3 --- /dev/null +++ b/flake.nix @@ -0,0 +1,51 @@ +{ + inputs = { + nixpkgs.url = github:nixos/nixpkgs; + flake-utils.url = github:numtide/flake-utils; + }; + outputs = { self, nixpkgs, flake-utils }: + flake-utils.lib.eachDefaultSystem (system: + let + pkgs = nixpkgs.legacyPackages.${system}; + in + rec { + mkDrv = { stdenv, which, coqPackages, coq } : + let + extructures' = coqPackages.extructures.override { version = "0.4.0"; }; + in + stdenv.mkDerivation { + pname = "ssprove"; + version = "0.0.1"; + src = ./.; + nativeBuildInputs = [ which coq.ocamlPackages.findlib ] ++ + (with coqPackages; [ + equations + mathcomp-analysis + mathcomp-ssreflect + deriving + ]) + ++ [extructures']; + buildInputs = [ coq ]; + }; + + devShell = + let + args = { + inherit (pkgs) stdenv which; + coq = pkgs.coq_8_18; + coqPackages = pkgs.coqPackages_8_18.overrideScope + (self: super: { + mathcomp = super.mathcomp.override { version = "2.1.0"; }; + mathcomp-analysis = super.mathcomp-analysis.override { version = "1.0.0"; }; + }); + }; + ssprove' = mkDrv args; + in + pkgs.mkShell { + packages = + (with pkgs; [ coq gnumake ]) + ++ + (with ssprove'; nativeBuildInputs); + }; + }); +} diff --git a/theories/Crypt/Axioms.v b/theories/Crypt/Axioms.v index a1fd0a29..6323481e 100644 --- a/theories/Crypt/Axioms.v +++ b/theories/Crypt/Axioms.v @@ -1,5 +1,5 @@ Set Warnings "-notation-overridden,-ambiguous-paths". -From mathcomp Require Import all_ssreflect all_algebra reals classical.boolp. +From mathcomp Require Import all_ssreflect all_algebra reals boolp. Set Warnings "notation-overridden,ambiguous-paths". Local Open Scope ring_scope. diff --git a/theories/Crypt/Prelude.v b/theories/Crypt/Prelude.v index b8fd7e0b..7898b94b 100644 --- a/theories/Crypt/Prelude.v +++ b/theories/Crypt/Prelude.v @@ -5,6 +5,7 @@ From Coq Require Import Utf8 Lia. Set Warnings "-notation-overridden". From mathcomp Require Import ssreflect eqtype ssrbool ssrnat. Set Warnings "notation-overridden". +From HB Require Import structures. From extructures Require Import ord fset. From Equations Require Import Equations. From Mon Require SPropBase. @@ -180,8 +181,7 @@ Proof. intro h. apply e. inversion h. reflexivity. Qed. -From HB Require Import structures. -HB.instance Definition _ := hasDecEq.Build positive positive_eqP. +HB.instance Definition _ := hasDecEq.Build _ positive_eqP. (** Lt class, for finite types *) diff --git a/theories/Crypt/choice_type.v b/theories/Crypt/choice_type.v index 2351af91..bd909f17 100644 --- a/theories/Crypt/choice_type.v +++ b/theories/Crypt/choice_type.v @@ -19,9 +19,13 @@ Set Warnings "-ambiguous-paths,-notation-overridden,-notation-incompatible-forma From mathcomp Require Import ssrnat ssreflect ssrfun ssrbool ssrnum eqtype choice reals distr realsum seq all_algebra fintype. From mathcomp Require Import word_ssrZ word. -From Jasmin Require Import utils word. +(* From Jasmin Require Import utils word. *) +From Crypt Require Import jasmin_word jasmin_util. Set Warnings "ambiguous-paths,notation-overridden,notation-incompatible-format". -From Crypt Require Import Prelude Axioms. +From HB Require Import structures. +From mathcomp Require Import all_ssreflect all_algebra. + +From Crypt Require Import Prelude Axioms Casts. From extructures Require Import ord fset fmap. From Mon Require Import SPropBase. Require Equations.Prop.DepElim. @@ -39,8 +43,6 @@ Open Scope fset. Open Scope fset_scope. Open Scope type_scope. -(* Basic structure *) - Inductive choice_type := | chUnit | chNat @@ -56,14 +58,10 @@ Inductive choice_type := Derive NoConfusion NoConfusionHom for choice_type. -From HB Require Import structures. - #[hnf] HB.instance Definition _ nbits := [Ord of (word nbits) by <:]. -(* Check ComRing_sort__canonical__Ord_Ord nbits. *) - Fixpoint chElement_ordType (U : choice_type) : ordType := match U with | chUnit => Datatypes_unit__canonical__Ord_Ord @@ -130,7 +128,6 @@ Section choice_typeTypes. (* match choice_type_eqMixin with *) (* | EqMixin op => op *) (* end. *) - Fixpoint choice_type_test (u v : choice_type) : bool := match u, v with @@ -142,7 +139,8 @@ Section choice_typeTypes. | chMap a b , chMap a' b' => choice_type_test a a' && choice_type_test b b' | chOption a, chOption a' => choice_type_test a a' | chFin n, chFin n' => n == n' - | chWord nbits, chWord nbits' => nbits == nbits' + | chWord nbits, chWord nbits' => + nbits == nbits' | chList a, chList b => choice_type_test a b | chSum a b, chSum a' b' => choice_type_test a a' && choice_type_test b b' | _ , _ => false @@ -591,52 +589,63 @@ Section choice_typeTypes. intuition auto. move: H0. rewrite H. intuition auto. Qed. - Lemma choice_type_leqP : hasOrd.axioms_ choice_type. + Lemma choice_type_leqxx : reflexive (T:=choice_type) choice_type_leq. Proof. - apply (hasOrd.Axioms_ choice_type_leq). - - intro x. unfold choice_type_leq. - apply/orP. left. apply /eqP. reflexivity. - - intros v u w h1 h2. - move: h1 h2. unfold choice_type_leq. - move /orP => h1. move /orP => h2. - destruct h1. - + move: H. move /eqP => H. destruct H. - apply/orP. assumption. - + destruct h2. - * move: H0. move /eqP => H0. destruct H0. - apply/orP. right. assumption. - * apply/orP. right. exact (choice_type_lt_transitive _ _ _ H H0). - - unfold antisymmetric. - move => x y. unfold choice_type_leq. move/andP => [h1 h2]. - move: h1 h2. unfold choice_type_leq. - move /orP => h1. move /orP => h2. - destruct h1. - 1:{ move: H. move /eqP. intuition auto. } - destruct h2. - 1:{ move: H0. move /eqP. intuition auto. } - destruct (~~ (choice_type_test x y)) eqn:Heq. - + move: Heq. move /idP => Heq. - pose (choice_type_lt_total_not_holds x y) as Hp. - move: Hp. move /implyP => Hp. specialize (Hp Heq). - move: Hp. move /nandP => Hp. - destruct Hp. - * move: H. move /eqP /eqP => H. rewrite H in H1. simpl in H1. - discriminate. - * move: H0. move /eqP /eqP => H0. rewrite H0 in H1. simpl in H1. - discriminate. - + move: Heq. move /eqP. auto. - - unfold total. - intros x y. unfold choice_type_leq. - pose (choice_type_lt_tot x y). - move: i. move /orP => H. - destruct H. - + move: H. move /orP => H. - destruct H. - * apply/orP. left. apply/orP. right. assumption. - * apply/orP. right. apply/orP. right. assumption. - + apply/orP. left. apply/orP. left. assumption. + intro x. unfold choice_type_leq. + apply/orP. left. apply /eqP. reflexivity. Qed. + Lemma choice_type_leq_transitive : transitive (T:=choice_type) choice_type_leq. + Proof. + intros v u w h1 h2. + move: h1 h2. unfold choice_type_leq. + move /orP => h1. move /orP => h2. + destruct h1. + + move: H. move /eqP => H. destruct H. + apply/orP. assumption. + + destruct h2. + * move: H0. move /eqP => H0. destruct H0. + apply/orP. right. assumption. + * apply/orP. right. exact (choice_type_lt_transitive _ _ _ H H0). + Qed. + + Lemma choice_type_leq_asym : antisymmetric (T:=choice_type) choice_type_leq. + Proof. + + unfold antisymmetric. + move => x y. unfold choice_type_leq. move/andP => [h1 h2]. + move: h1 h2. unfold choice_type_leq. + move /orP => h1. move /orP => h2. + destruct h1. + 1:{ move: H. move /eqP. intuition auto. } + destruct h2. + 1:{ move: H0. move /eqP. intuition auto. } + destruct (~~ (choice_type_test x y)) eqn:Heq. + + move: Heq. move /idP => Heq. + pose (choice_type_lt_total_not_holds x y) as Hp. + move: Hp. move /implyP => Hp. specialize (Hp Heq). + move: Hp. move /nandP => Hp. + destruct Hp. + * move: H. move /eqP /eqP => H. rewrite H in H1. simpl in H1. + discriminate. + * move: H0. move /eqP /eqP => H0. rewrite H0 in H1. simpl in H1. + discriminate. + + move: Heq. move /eqP. auto. + + Qed. + + Lemma choice_type_leq_total : total (T:=choice_type) choice_type_leq. + unfold total. + intros x y. unfold choice_type_leq. + pose (choice_type_lt_tot x y). + move: i. move /orP => H. + destruct H. + + move: H. move /orP => H. + destruct H. + * apply/orP. left. apply/orP. right. assumption. + * apply/orP. right. apply/orP. right. assumption. + + apply/orP. left. apply/orP. left. assumption. + Qed. Fixpoint encode (t : choice_type) : GenTree.tree nat := match t with @@ -711,5 +720,5 @@ Section choice_typeTypes. HB.instance Definition _ := PCanHasChoice codeK. HB.instance Definition _ := - (@hasOrd.Build choice_type (hasOrd.leq choice_type_leqP) (hasOrd.leqxx choice_type_leqP) (@hasOrd.leq_trans _ choice_type_leqP) (@hasOrd.anti_leq _ choice_type_leqP) (hasOrd.leq_total choice_type_leqP)). + (@hasOrd.Build choice_type (choice_type_leq) (choice_type_leqxx) (choice_type_leq_transitive) (choice_type_leq_asym) (choice_type_leq_total)). End choice_typeTypes. diff --git a/theories/Crypt/examples/OVN.v b/theories/Crypt/examples/OVN.v new file mode 100644 index 00000000..87f1aa19 --- /dev/null +++ b/theories/Crypt/examples/OVN.v @@ -0,0 +1,2128 @@ + +From Relational Require Import OrderEnrichedCategory GenericRulesSimple. + +Set Warnings "-notation-overridden,-ambiguous-paths". +From mathcomp Require Import all_ssreflect all_algebra reals distr realsum + fingroup.fingroup solvable.cyclic prime ssrnat ssreflect ssrfun ssrbool ssrnum + eqtype choice seq. +Set Warnings "notation-overridden,ambiguous-paths". + +From Crypt Require Import Axioms ChoiceAsOrd SubDistr Couplings + UniformDistrLemmas FreeProbProg Theta_dens RulesStateProb UniformStateProb + pkg_composition Package Prelude SigmaProtocol Schnorr DDH. + +From Coq Require Import Utf8 Lia. +From extructures Require Import ord fset fmap. + +From Equations Require Import Equations. +Require Equations.Prop.DepElim. + +Set Equations With UIP. + +Set Bullet Behavior "Strict Subproofs". +Set Default Goal Selector "!". +Set Primitive Projections. + +Import Num.Def. +Import Num.Theory. +Import Order.POrderTheory. + +#[local] Open Scope ring_scope. +Import GroupScope GRing.Theory. + +Import PackageNotation. + +Module Type GroupParam. + + Parameter n : nat. + Parameter n_pos : Positive n. + + Parameter gT : finGroupType. + Definition ζ : {set gT} := [set : gT]. + Parameter g : gT. + Parameter g_gen : ζ = <[g]>. + Parameter prime_order : prime #[g]. + +End GroupParam. + +Module Type OVNParam. + + Parameter N : nat. + Parameter N_pos : Positive N. + +End OVNParam. + +Module OVN (GP : GroupParam) (OP : OVNParam). +Import GP. +Import OP. + +Set Equations Transparent. + +Lemma cyclic_zeta: cyclic ζ. +Proof. + apply /cyclicP. exists g. exact: g_gen. +Qed. + +(* order of g *) +Definition q' := Zp_trunc (pdiv #[g]). +Definition q : nat := q'.+2. + +Lemma q_order_g : q = #[g]. +Proof. + unfold q, q'. + apply Fp_cast. + apply prime_order. +Qed. + +Lemma q_field : (Zp_trunc #[g]) = q'. +Proof. + unfold q'. + rewrite pdiv_id. + 2: apply prime_order. + reflexivity. +Qed. + +Lemma expg_g : forall x, exists ix, x = g ^+ ix. +Proof. + intros. + apply /cycleP. + rewrite -g_gen. + apply: in_setT. +Qed. + +Lemma group_prodC : + @commutative gT gT mulg. +Proof. + move => x y. + destruct (expg_g x) as [ix ->]. + destruct (expg_g y) as [iy ->]. + repeat rewrite -expgD addnC. + reflexivity. +Qed. + +Definition Pid : finType := Finite.clone _ 'I_n. +Definition Secret : finType := FinRing_ComRing__to__fintype_Finite (fintype_ordinal__canonical__FinRing_ComRing (Zp_trunc #[g])). (* Zp_finComRingType (Zp_trunc #[g]). *) +Definition Public : finType := gT. +Definition s0 : Secret := 0. + +Definition Pid_pos : Positive #|Pid|. +Proof. + rewrite card_ord. + eapply PositiveInFin. + apply n_pos. +Qed. + +Definition Secret_pos : Positive #|Secret|. +Proof. + apply /card_gt0P. exists s0. auto. +Qed. + +Definition Public_pos : Positive #|Public|. +Proof. + apply /card_gt0P. exists g. auto. +Defined. + +#[local] Existing Instance Pid_pos. +#[local] Existing Instance Secret_pos. +#[local] Existing Instance Public_pos. + +Definition pid : choice_type := 'fin #|Pid|. +Definition secret : choice_type := 'fin #|Secret|. +Definition public: choice_type := 'fin #|Public|. + +Definition nat_to_pid : nat → pid. +Proof. + move=> n. + eapply give_fin. +Defined. + +Definition i_secret := #|Secret|. +Definition i_public := #|Public|. + +Module Type CDSParams <: SigmaProtocolParams. + Definition Witness : finType := Secret. + Definition Statement : finType := prod (prod Public Public) Public. + + Definition Witness_pos : Positive #|Witness| := Secret_pos. + Definition Statement_pos : Positive #|Statement|. + Proof. + unfold Statement. + rewrite !card_prod. + repeat apply Positive_prod. + all: apply Public_pos. + Qed. + + Definition R : Statement -> Witness -> bool := + λ (h : Statement) (x : Witness), + let '(gx, gy, gyxv) := h in + (gy^+x * g^+0 == gyxv) || (gy^+x * g^+1 == gyxv). + + Lemma relation_valid_left: + ∀ (x : Secret) (gy : Public), + R (g^+x, gy, gy^+x * g^+ 0) x. + Proof. + intros x gy. + unfold R. + apply /orP ; left. + done. + Qed. + + Lemma relation_valid_right: + ∀ (x : Secret) (gy : Public), + R (g^+x, gy, gy^+x * g^+ 1) x. + Proof. + intros x y. + unfold R. + apply /orP ; right. + done. + Qed. + + Parameter Message Challenge Response State : finType. + Parameter w0 : Witness. + Parameter e0 : Challenge. + Parameter z0 : Response. + + Parameter Message_pos : Positive #|Message|. + Parameter Challenge_pos : Positive #|Challenge|. + Parameter Response_pos : Positive #|Response|. + Parameter State_pos : Positive #|State|. + Parameter Bool_pos : Positive #|'bool|. +End CDSParams. + +Module OVN (π2 : CDSParams) (Alg2 : SigmaProtocolAlgorithms π2). + + Module Sigma1 := Schnorr GP. + Module Sigma2 := SigmaProtocol π2 Alg2. + + Obligation Tactic := idtac. + Set Equations Transparent. + + Definition skey_loc (i : nat) : Location := (secret; (100+i)%N). + Definition ckey_loc (i : nat) : Location := (public; (101+i)%N). + + Definition P_i_locs (i : nat) : {fset Location} := fset [:: skey_loc i ; ckey_loc i]. + + Notation choiceStatement1 := Sigma1.MyAlg.choiceStatement. + Notation choiceWitness1 := Sigma1.MyAlg.choiceWitness. + Notation choiceTranscript1 := Sigma1.MyAlg.choiceTranscript. + + Notation " 'pid " := pid (in custom pack_type at level 2). + Notation " 'pids " := (chProd pid pid) (in custom pack_type at level 2). + Notation " 'public " := public (in custom pack_type at level 2). + Notation " 'public " := public (at level 2) : package_scope. + + Notation " 'chRelation1' " := (chProd choiceStatement1 choiceWitness1) (in custom pack_type at level 2). + Notation " 'chTranscript1' " := choiceTranscript1 (in custom pack_type at level 2). + Notation " 'public_key " := (chProd public choiceTranscript1) (in custom pack_type at level 2). + Notation " 'public_keys " := (chMap pid (chProd public choiceTranscript1)) (in custom pack_type at level 2). + + Notation " 'chRelation2' " := (chProd Alg2.choiceStatement Alg2.choiceWitness) (in custom pack_type at level 2). + Notation " 'chTranscript2' " := Alg2.choiceTranscript (in custom pack_type at level 2). + Notation " 'vote " := (chProd public Alg2.choiceTranscript) (in custom pack_type at level 2). + + Definition INIT : nat := 4. + Definition VOTE : nat := 5. + Definition CONSTRUCT : nat := 6. + + Definition P (i : nat) : nat := 14 + i. + Definition Exec (i : nat) : nat := 15 + i. + + Lemma not_in_domm {T S} : + ∀ i m, + i \notin @domm T S m :\ i. + Proof. + intros. + apply /negPn. + rewrite in_fsetD. + move=> /andP [H _]. + move: H => /negPn H. + apply H. + by rewrite in_fset1. + Qed. + + Lemma not_in_fsetU : + ∀ (l : Location) L0 L1, + l \notin L0 → + l \notin L1 → + l \notin L0 :|: L1. + Proof. + intros l L0 L1 h1 h2. + rewrite -fdisjoints1 fset1E. + rewrite fdisjointUl. + apply /andP ; split. + + rewrite -fdisjoints1 fset1E in h1. apply h1. + + rewrite -fdisjoints1 fset1E in h2. apply h2. + Qed. + + #[local] Hint Extern 3 (is_true (?l \notin ?L0 :|: ?L1)) => + apply not_in_fsetU : typeclass_instances ssprove_valid_db ssprove_invariant. + + Definition get_value (m : chMap pid (chProd public choiceTranscript1)) (i : pid) := + match m i with + | Some (v, _) => otf v + | _ => 1 + end. + + From HB Require Import structures. + From mathcomp Require Import ssreflect.bigop. + Import Monoid. + HB.instance Definition _ := isCommutativeLaw.Build _ _ group_prodC. + + Definition compute_key + (m : chMap pid (chProd public choiceTranscript1)) + (i : pid) + := + let low := \prod_(k <- domm m | (k < i)%ord) (get_value m k) in + let high := \prod_(k <- domm m | (i < k)%ord) (get_value m k) in + low * invg high. + + Definition compute_key' + (m : chMap pid (chProd public choiceTranscript1)) + (i j : pid) + (x : Secret) + := + if (j < i)%ord then + let low := \prod_(k <- domm m | (k < i)%ord) (get_value m k) in + let high := \prod_(k <- domm m | (i < k)%ord) (get_value m k) in + (g ^+ x) * low * invg high + else + let low := \prod_(k <- domm m | (k < i)%ord) (get_value m k) in + let high := \prod_(k <- domm m | (i < k)%ord) (get_value m k) in + low * invg (high * (g ^+ x)). + + Lemma compute_key'_equiv + (i j : pid) + (x : Secret) + (zk : choiceTranscript1) + (keys : chMap pid (chProd public choiceTranscript1)): + (i != j) → + compute_key (setm keys j (fto (g ^+ x), zk)) i = compute_key' (remm keys j) i j x. + Proof. + intro ij_neq. + unfold compute_key, compute_key'. + simpl. + rewrite <- setm_rem. + rewrite domm_set domm_rem. + set X := domm _. + rewrite !big_fsetU1. + 2-3: subst X; apply not_in_domm. + rewrite setm_rem. + + have set_rem_eq : forall P x, + \big[Notations_mulg__canonical__Monoid_ComLaw/1]_(k <- X :\ j | P k) + get_value (setm keys j x) k = + \prod_(k <- X :\ j | P k) + get_value (remm keys j) k. + { intros. + rewrite big_seq_cond. + rewrite [RHS] big_seq_cond. + unfold get_value. + erewrite eq_bigr. + 1: done. + intros k. + move => /andP [k_in _]. + simpl. + rewrite setmE remmE. + case (k == j) eqn:eq. + - move: eq => /eqP eq. + rewrite eq in_fsetD1 in k_in. + move: k_in => /andP [contra]. + rewrite eq_refl in contra. + discriminate. + - reflexivity. + } + + case (j < i)%ord eqn:e. + - rewrite !e. + rewrite -2!mulgA. + f_equal. + 1: unfold get_value ; by rewrite setmE eq_refl otf_fto. + f_equal. + + apply set_rem_eq. + + rewrite Ord.ltNge Ord.leq_eqVlt in e. + rewrite negb_or in e. + move: e => /andP [_ e]. + apply negbTE in e. + rewrite e. + f_equal. + apply set_rem_eq. + - rewrite e. + rewrite Ord.ltNge in e. + apply negbT in e. + apply negbNE in e. + rewrite Ord.leq_eqVlt in e. + move: e => /orP [contra|e]. + 1: by rewrite contra in ij_neq. + rewrite e !invMg. + f_equal. + { apply set_rem_eq. } + rewrite group_prodC. + f_equal. + { unfold get_value. by rewrite setmE eq_refl otf_fto. } + f_equal. + apply set_rem_eq. + Qed. + + Lemma compute_key_bij: + ∀ (m : chMap pid (chProd public choiceTranscript1)) (i j: pid), + (i != j)%ord → + exists (a b : nat), + (a != 0)%N /\ (a < q)%N /\ + (∀ (x : Secret) zk, + compute_key (setm m j (fto (g ^+ x), zk)) i = g ^+ ((a * x + b) %% q)). + Proof. + intros m i j ne. + simpl. + pose low := \prod_(k <- domm m :\ j| (k < i)%ord) get_value m k. + pose hi := \prod_(k <- domm m :\ j| (i < k)%ord) get_value m k. + have Hlow : exists ilow, low = g ^+ ilow by apply expg_g. + have Hhi : exists ihi, hi = g ^+ ihi by apply expg_g. + destruct Hlow as [ilow Hlow]. + destruct Hhi as [ihi Hhi]. + + have getv_remm_eq : forall P j m, + \prod_(k <- domm m :\ j | P k) get_value (remm m j) k = + \prod_(k <- domm m :\ j | P k) get_value m k. + { + clear low hi ilow ihi Hlow Hhi ne i j m. + intros. + rewrite big_seq_cond. + rewrite [RHS] big_seq_cond. + erewrite eq_bigr. + 1: done. + intros k. + move => /andP [k_in _]. + simpl. + unfold get_value. + rewrite remmE. + case (k == j) eqn:eq. + ++ move: eq => /eqP eq. + rewrite eq in_fsetD1 in k_in. + move: k_in => /andP [contra]. + rewrite eq_refl in contra. + discriminate. + ++ reflexivity. + } + + case (j < i)%ord eqn:ij_rel. + - exists 1%N. + exists (ilow + (ihi * #[g ^+ ihi].-1))%N. + do 2 split. + 1: rewrite q_order_g ; apply (prime_gt1 prime_order). + intros x zk. + rewrite compute_key'_equiv. + 2: assumption. + unfold compute_key'. + simpl. + rewrite ij_rel. + rewrite domm_rem. + set low' := \prod_(k0 <- _ | _) _. + set hi' := \prod_(k0 <- _ | _) _. + have -> : low' = low by apply getv_remm_eq. + have -> : hi' = hi by apply getv_remm_eq. + clear low' hi'. + rewrite Hhi Hlow. + rewrite invg_expg. + rewrite -!expgM. + rewrite -!expgD. + rewrite !addnA. + rewrite -expg_mod_order. + f_equal. + f_equal. + 2: { + unfold q. rewrite Fp_cast; + [reflexivity | apply prime_order]. + } + rewrite mul1n. + done. + - exists #[g].-1. + exists (ilow + (ihi * #[g ^+ ihi].-1))%N. + repeat split. + { unfold negb. + rewrite -leqn0. + case (#[g].-1 <= 0)%N eqn:e. + 2: done. + have Hgt1 := (prime_gt1 prime_order). + rewrite -ltn_predRL in Hgt1. + rewrite -ltnS in Hgt1. + rewrite -addn1 in Hgt1. + rewrite leq_add2l in Hgt1. + eapply leq_trans in e. + 2: apply Hgt1. + discriminate. + } + { + rewrite q_order_g. + rewrite ltn_predL. + apply (prime_gt0 prime_order). + } + intros x zk. + rewrite compute_key'_equiv. + 2: assumption. + unfold compute_key'. + simpl. + rewrite ij_rel. + rewrite domm_rem. + set low' := \prod_(k0 <- _ | _) _. + set hi' := \prod_(k0 <- _ | _) _. + have -> : low' = low by apply getv_remm_eq. + have -> : hi' = hi by apply getv_remm_eq. + clear low' hi'. + rewrite Hhi Hlow. + rewrite invMg. + rewrite -expgVn. + rewrite !invg_expg. + rewrite -!expgM. + rewrite mulgA. + rewrite -!expgD. + rewrite !addnA. + rewrite -expg_mod_order. + f_equal. + f_equal. + 2: { + unfold q. rewrite Fp_cast; + [reflexivity | apply prime_order]. + } + rewrite addnAC. + rewrite addnC. + rewrite addnA. + done. + Qed. + + Lemma compute_key_set_i + (i : pid) + (v : (chProd public choiceTranscript1)) + (m : chMap pid (chProd public choiceTranscript1)): + compute_key (setm m i v) i = compute_key m i. + Proof. + unfold compute_key. + simpl. + case (i \in domm m) eqn:i_in. + all: simpl in i_in. + - have -> : forall v, domm (setm m i v) = domm m. + { intros. + simpl. + rewrite domm_set. + rewrite -eq_fset. + intro k. + rewrite in_fsetU1. + case (eq_op) eqn:e. + + move: e => /eqP ->. + by rewrite i_in. + + done. + } + simpl. + f_equal. + + apply eq_big. + 1: done. + intros k k_lt. + unfold get_value. + rewrite setmE. + rewrite Ord.lt_neqAle in k_lt. + move: k_lt => /andP [k_lt _]. + move: k_lt => /negbTE ->. + done. + + f_equal. + apply eq_big. + 1: done. + intros k k_lt. + unfold get_value. + rewrite setmE. + rewrite Ord.lt_neqAle in k_lt. + move: k_lt => /andP [k_lt _]. + rewrite eq_sym. + move: k_lt => /negbTE ->. + done. + - have -> : domm m = domm (remm m i). + { + simpl. + rewrite -eq_fset. + intro k. + rewrite domm_rem. + rewrite in_fsetD1. + case (eq_op) eqn:e. + + simpl. + move: e => /eqP ->. + assumption. + + done. + } + simpl. + f_equal. + + rewrite -setm_rem domm_set domm_rem. + rewrite big_fsetU1. + all: simpl. + 2: by rewrite in_fsetD1 eq_refl. + rewrite Ord.ltxx. + apply eq_big. + 1: done. + intros k k_lt. + unfold get_value. + rewrite setmE remmE. + rewrite Ord.lt_neqAle in k_lt. + move: k_lt => /andP [k_lt _]. + move: k_lt => /negbTE ->. + done. + + f_equal. + rewrite -setm_rem domm_set domm_rem. + rewrite big_fsetU1. + all: simpl. + 2: by rewrite in_fsetD1 eq_refl. + rewrite Ord.ltxx. + apply eq_big. + 1: done. + intros k k_lt. + unfold get_value. + rewrite setmE remmE. + rewrite Ord.lt_neqAle in k_lt. + move: k_lt => /andP [k_lt _]. + rewrite eq_sym. + move: k_lt => /negbTE ->. + done. + Qed. + + Lemma test_bij + (i j : pid) + (m : chMap pid (chProd public choiceTranscript1)) + : + (i != j)%N → + ∃ (f : Secret → Secret), + ∀ (x : Secret), + bijective f /\ + (∀ zk, compute_key (setm m j (fto (g ^+ x), zk)) i = g ^+ (f x)). + Proof. + simpl. + intros ne. + have H := compute_key_bij m i j ne. + simpl in H. + destruct H as [a [b [a_pos [a_leq_q H]]]]. + set a_ord := @inZp ((Zp_trunc #[g]).+1) a. + set b_ord := @inZp ((Zp_trunc #[g]).+1) b. + pose f' := (fun (x : Secret) => Zp_add (Zp_mul x a_ord) b_ord). + exists f'. + unfold f'. clear f'. + intros x. + have := q_order_g. + unfold q. + intros Hq. + split. + 2: { + intro zk. + rewrite (H x zk). + apply /eqP. + rewrite eq_expg_mod_order. + apply /eqP. + simpl. + rewrite modn_small. + 2: { + rewrite q_order_g. + apply ltn_pmod. + apply (prime_gt0 prime_order). + } + repeat rewrite -> Zp_cast at 3. + 2-5: apply (prime_gt1 prime_order). + symmetry. + rewrite modn_small. + 2: { + apply ltn_pmod. + apply (prime_gt0 prime_order). + } + simpl. + unfold q, q'. + rewrite Fp_cast. + 2: apply prime_order. + rewrite modnMmr. + rewrite modnDm. + rewrite mulnC. + reflexivity. + } + assert (coprime q'.+2 a_ord) as a_ord_coprime. + { + rewrite -unitFpE. + 2: rewrite Hq ; apply prime_order. + rewrite unitfE. simpl. + rewrite Zp_cast. + 2: apply (prime_gt1 prime_order). + unfold q, q' in a_leq_q. + rewrite Fp_cast in a_leq_q. + 2: apply prime_order. + rewrite modn_small. + 2: apply a_leq_q. + erewrite <- inj_eq. + 2: apply ord_inj. + rewrite val_Zp_nat. + 2: { + rewrite pdiv_id. + 1: apply prime_gt1. + 1,2: rewrite Hq ; apply prime_order. + } + rewrite -> pdiv_id at 1. + 1,2: rewrite Hq. + 2: apply prime_order. + unfold q in a_leq_q. + rewrite modn_small. + 2: apply a_leq_q. + assumption. + } + pose f' := (fun (x : Secret) => Zp_mul (Zp_add (Zp_opp b_ord) x) (Zp_inv a_ord)). + exists f'. + - intro z. + unfold f'. clear f'. + simpl. + rewrite Zp_addC. + rewrite -Zp_addA. + have -> : (Zp_add b_ord (Zp_opp b_ord)) = Zp0. + 1: by rewrite Zp_addC Zp_addNz. + rewrite Zp_addC. + rewrite Zp_add0z. + rewrite -Zp_mulA. + rewrite Zp_mulzV. + 2: { + rewrite -> q_field at 1. + assumption. + } + rewrite Zp_mulz1. + reflexivity. + - intro z. + unfold f'. clear f'. + simpl. + rewrite Zp_addC. + rewrite -Zp_mulA. + rewrite Zp_mul_addl. + have -> : (Zp_mul (Zp_inv a_ord) a_ord) = Zp1. + { + rewrite Zp_mulC. + rewrite Zp_mulzV. + + reflexivity. + + rewrite -> q_field at 1. + assumption. + } + rewrite -Zp_mul_addl. + rewrite Zp_mulz1. + rewrite Zp_addA. + have -> : (Zp_add b_ord (Zp_opp b_ord)) = Zp0. + 1: by rewrite Zp_addC Zp_addNz. + rewrite Zp_add0z. + reflexivity. + Qed. + + Lemma test_bij' + (i j : pid) + (m : chMap pid (chProd public choiceTranscript1)) + : + (i != j)%N → + ∃ (f : secret → secret), + ∀ (x : secret), + bijective f /\ + (∀ zk, compute_key (setm m j (fto (g ^+ otf x), zk)) i = g ^+ (otf (f x))). + Proof. + simpl. + intros ne. + have [f H] := test_bij i j m ne. + simpl in H. + exists (fun (x : secret) => fto (f (otf x))). + intro x. + destruct (H (otf x)) as [f_bij H'] ; clear H. + split. + - exists (fun z => fto ((finv f) (otf z))). + + apply bij_inj in f_bij. + intro z. + rewrite otf_fto. + apply finv_f in f_bij. + rewrite f_bij fto_otf. + reflexivity. + + apply bij_inj in f_bij. + intro z. + rewrite otf_fto. + apply f_finv in f_bij. + rewrite f_bij fto_otf. + reflexivity. + - intro zk. + specialize (H' zk). + rewrite otf_fto. + apply H'. + Qed. + + Definition P_i_E := + [interface + #val #[ INIT ] : 'unit → 'public_key ; + #val #[ CONSTRUCT ] : 'public_keys → 'unit ; + #val #[ VOTE ] : 'bool → 'public + ]. + + Definition Sigma1_I := + [interface + #val #[ Sigma1.Sigma.VERIFY ] : chTranscript1 → 'bool ; + #val #[ Sigma1.Sigma.RUN ] : chRelation1 → chTranscript1 + ]. + + Definition P_i (i : pid) (b : bool): + package (P_i_locs i) + Sigma1_I + P_i_E := + [package + #def #[ INIT ] (_ : 'unit) : 'public_key + { + #import {sig #[ Sigma1.Sigma.RUN ] : chRelation1 → chTranscript1} as ZKP ;; + #import {sig #[ Sigma1.Sigma.VERIFY ] : chTranscript1 → 'bool} as VER ;; + x ← sample uniform i_secret ;; + #put (skey_loc i) := x ;; + let y := (fto (g ^+ (otf x))) : public in + zkp ← ZKP (y, x) ;; + ret (y, zkp) + } + ; + #def #[ CONSTRUCT ] (m : 'public_keys) : 'unit + { + #import {sig #[ Sigma1.Sigma.VERIFY ] : chTranscript1 → 'bool} as VER ;; + #assert (size (domm m) == n) ;; + let key := fto (compute_key m i) in + #put (ckey_loc i) := key ;; + @ret 'unit Datatypes.tt + } + ; + #def #[ VOTE ] (v : 'bool) : 'public + { + skey ← get (skey_loc i) ;; + ckey ← get (ckey_loc i) ;; + if b then + let vote := (otf ckey ^+ skey * g ^+ v) in + @ret 'public (fto vote) + else + let vote := (otf ckey ^+ skey * g ^+ (negb v)) in + @ret 'public (fto vote) + } + ]. + + Definition EXEC_i_I := + [interface + #val #[ INIT ] : 'unit → 'public_key ; + #val #[ CONSTRUCT ] : 'public_keys → 'unit ; + #val #[ VOTE ] : 'bool → 'public ; + #val #[ Sigma1.Sigma.RUN ] : chRelation1 → chTranscript1 + ]. + + Definition Exec_i_E i := [interface #val #[ Exec i ] : 'bool → 'public]. + + Definition Exec_i (i j : pid) (m : chMap pid (chProd public choiceTranscript1)): + package fset0 + EXEC_i_I + (Exec_i_E i) + := + [package + #def #[ Exec i ] (v : 'bool) : 'public + { + #import {sig #[ INIT ] : 'unit → 'public_key} as Init ;; + #import {sig #[ CONSTRUCT ] : 'public_keys → 'unit} as Construct ;; + #import {sig #[ VOTE ] : 'bool → 'public} as Vote ;; + #import {sig #[ Sigma1.Sigma.RUN ] : chRelation1 → chTranscript1} as ZKP ;; + pk ← Init Datatypes.tt ;; + x ← sample uniform i_secret ;; + let y := (fto (g ^+ (otf x))) : public in + zkp ← ZKP (y, x) ;; + let m' := setm (setm m j (y, zkp)) i pk in + Construct m' ;; + vote ← Vote v ;; + @ret 'public vote + } + ]. + + Module DDHParams <: DDHParams. + Definition Space := Secret. + Definition Space_pos := Secret_pos. + End DDHParams. + + Module DDH := DDH DDHParams GP. + + #[tactic=notac] Equations? Aux (b : bool) (i j : pid) m f': + package DDH.DDH_locs + (DDH.DDH_E :|: + [interface #val #[ Sigma1.Sigma.RUN ] : chRelation1 → chTranscript1] + ) + [interface #val #[ Exec i ] : 'bool → 'public] + := Aux b i j m f' := + [package + #def #[ Exec i ] (v : 'bool) : 'public + { + #import {sig #[ DDH.SAMPLE ] : 'unit → 'public × 'public × 'public} as DDH ;; + #import {sig #[ Sigma1.Sigma.RUN ] : chRelation1 → chTranscript1} as ZKP ;; + abc ← DDH Datatypes.tt ;; + x_i ← get DDH.secret_loc1 ;; + x_j ← get DDH.secret_loc2 ;; + let '(y_i, (y_j, c)) := abc in + let y_j' := fto (g ^+ ((finv f') x_j)) in + zkp1 ← ZKP (y_i, x_i) ;; + zkp2 ← ZKP (y_j', (finv f') x_j) ;; + let m' := (setm (setm m j (y_j', zkp2)) i (y_i, zkp1)) in + #assert (size (domm m') == n) ;; + @ret 'public (fto ((otf c) * g ^+ (if b then v else (negb v)))) + } + ]. + Proof. + ssprove_valid. + all: rewrite in_fsetU. + all: apply /orP. + { + left. + unfold DDH.DDH_E. + rewrite fset_cons -fset0E fsetU0. + by apply /fset1P. + } + { + right. + rewrite fset_cons -fset0E fsetU0. + by apply /fset1P. + } + { + right. + rewrite fset_cons -fset0E fsetU0. + by apply /fset1P. + } + Qed. + + Module RO1 := Sigma1.Sigma.Oracle. + Module RO2 := Sigma2.Oracle. + + Definition combined_locations := + (Sigma1.MyAlg.Sigma_locs :|: RO1.RO_locs). + + Equations? Exec_i_realised b m (i j : pid) : package (P_i_locs i :|: combined_locations) [interface] (Exec_i_E i) := + Exec_i_realised b m i j := + {package (Exec_i i j m) ∘ (par ((P_i i b) ∘ (Sigma1.Sigma.Fiat_Shamir ∘ RO1.RO)) + (Sigma1.Sigma.Fiat_Shamir ∘ RO1.RO))}. + Proof. + ssprove_valid. + 10: apply fsub0set. + 8:{ rewrite fsetUid. apply fsubsetxx. } + 9: apply fsubsetxx. + 7:{ erewrite fsetUid. apply fsubsetxx. } + 4: apply fsubsetUr. + 3: apply fsubsetUl. + all: unfold combined_locations. + - apply fsubsetUl. + - apply fsubsetUr. + - eapply fsubset_trans. 2: eapply fsubsetUr. + apply fsubsetUl. + - eapply fsubset_trans. 2: eapply fsubsetUr. + apply fsubsetUr. + - unfold EXEC_i_I, P_i_E, Sigma1_I. + rewrite !fset_cons. + rewrite -!fsetUA. + repeat apply fsetUS. + rewrite -fset0E fsetU0 fset0U. + apply fsubsetUr. + Qed. + + + Lemma loc_helper_commit i: + Sigma1.MyAlg.commit_loc \in P_i_locs i :|: combined_locations. + Proof. + unfold combined_locations. + unfold Sigma1.MyAlg.Sigma_locs. + rewrite in_fsetU. + apply /orP ; right. + rewrite fset_cons. + rewrite in_fsetU. + apply /orP ; left. + rewrite in_fsetU1. + apply /orP ; left. + done. + Qed. + + Lemma loc_helper_queries i: + RO1.queries_loc \in P_i_locs i :|: combined_locations. + Proof. + unfold combined_locations. + unfold RO1.RO_locs. + rewrite in_fsetU. + apply /orP ; right. + rewrite fset_cons. + rewrite in_fsetU. + apply /orP ; right. + rewrite in_fsetU1. + apply /orP ; left. + done. + Qed. + + Lemma loc_helper_skey i: + skey_loc i \in P_i_locs i :|: combined_locations. + Proof. + unfold P_i_locs. + rewrite in_fsetU. + apply /orP ; left. + rewrite fset_cons. + rewrite in_fsetU1. + apply /orP ; left. + done. + Qed. + + Lemma loc_helper_ckey i: + ckey_loc i \in P_i_locs i :|: combined_locations. + Proof. + unfold P_i_locs. + rewrite in_fsetU. + apply /orP ; left. + rewrite !fset_cons. + rewrite in_fsetU1. + apply /orP ; right. + rewrite in_fsetU1. + apply /orP ; left. + done. + Qed. + + #[local] Hint Resolve loc_helper_commit : loc_db. + #[local] Hint Resolve loc_helper_queries : loc_db. + #[local] Hint Resolve loc_helper_skey: loc_db. + #[local] Hint Resolve loc_helper_ckey: loc_db. + + #[program] Definition Exec_i_realised_code m (i j : pid) (vote : 'bool): + code (P_i_locs i :|: combined_locations) [interface] 'public := + {code + x ← sample uniform i_secret ;; + #put skey_loc i := x ;; + #assert Sigma1.MyParam.R (otf (fto (expgn_rec (T:=gT) g (otf x)))) (otf x) ;; + x1 ← sample uniform Sigma1.MyAlg.i_witness ;; + #put Sigma1.MyAlg.commit_loc := x1 ;; + x2 ← get RO1.queries_loc ;; + match x2 (Sigma1.Sigma.prod_assoc (fto (expgn_rec (T:=gT) g (otf x)), fto (expgn_rec (T:=gT) g (otf x1)))) with + | Some a => + v ← get Sigma1.MyAlg.commit_loc ;; + x3 ← sample uniform i_secret ;; + #assert Sigma1.MyParam.R (otf (fto (expgn_rec (T:=gT) g (otf x3)))) (otf x3) ;; + x5 ← sample uniform Sigma1.MyAlg.i_witness ;; + #put Sigma1.MyAlg.commit_loc := x5 ;; + v0 ← get RO1.queries_loc ;; + match v0 (Sigma1.Sigma.prod_assoc (fto (expgn_rec (T:=gT) g (otf x3)), fto (expgn_rec (T:=gT) g (otf x5)))) with + | Some a0 => + x6 ← get Sigma1.MyAlg.commit_loc ;; + let x4 := + (fto (expgn_rec (T:=gT) g (otf x3)), fto (expgn_rec (T:=gT) g (otf x5)), a0, fto (Zp_add (otf x6) (Zp_mul (otf a0) (otf x3)))) + in + #assert eqn + (size + (domm (T:='I_#|'I_n|) (S:='I_#|gT| * ('I_#|gT| * 'I_#|gT| * 'I_#|'Z_Sigma1.q| * 'I_#|'Z_Sigma1.q|)) + (setm (T:='I_#|'I_n|) (setm (T:='I_#|'I_n|) m j (fto (expgn_rec (T:=gT) g (otf x3)), x4)) i + (fto (expgn_rec (T:=gT) g (otf x)), + (fto (expgn_rec (T:=gT) g (otf x)), fto (expgn_rec (T:=gT) g (otf x1)), a, fto (Zp_add (otf v) (Zp_mul (otf a) (otf x)))))))) n ;; + #put ckey_loc i := fto + (compute_key + (setm (T:='I_#|'I_n|) (setm (T:='I_#|'I_n|) m j (fto (expgn_rec (T:=gT) g (otf x3)), x4)) i + (fto (expgn_rec (T:=gT) g (otf x)), + (fto (expgn_rec (T:=gT) g (otf x)), fto (expgn_rec (T:=gT) g (otf x1)), a, + fto (Zp_add (otf v) (Zp_mul (otf a) (otf x)))))) i) ;; + v0 ← get skey_loc i ;; + v1 ← get ckey_loc i ;; + @ret 'public (fto (expgn_rec (T:=gT) (otf v1) v0 * expgn_rec (T:=gT) g vote)) + | None => + a0 ← sample uniform RO1.i_random ;; + #put RO1.queries_loc := setm v0 + (Sigma1.Sigma.prod_assoc (fto (expgn_rec (T:=gT) g (otf x3)), fto (expgn_rec (T:=gT) g (otf x5)))) a0 ;; + x6 ← get Sigma1.MyAlg.commit_loc ;; + let x4 := (fto (expgn_rec (T:=gT) g (otf x3)), fto (expgn_rec (T:=gT) g (otf x5)), a0, fto (Zp_add (otf x6) (Zp_mul (otf a0) (otf x3)))) in + #assert eqn + (size + (domm (T:='I_#|'I_n|) (S:='I_#|gT| * ('I_#|gT| * 'I_#|gT| * 'I_#|'Z_Sigma1.q| * 'I_#|'Z_Sigma1.q|)) + (setm (T:='I_#|'I_n|) (setm (T:='I_#|'I_n|) m j (fto (expgn_rec (T:=gT) g (otf x3)), x4)) i + (fto (expgn_rec (T:=gT) g (otf x)), + (fto (expgn_rec (T:=gT) g (otf x)), fto (expgn_rec (T:=gT) g (otf x1)), a, fto (Zp_add (otf v) (Zp_mul (otf a) (otf x)))))))) n ;; + #put ckey_loc i := fto + (compute_key + (setm (T:='I_#|'I_n|) (setm (T:='I_#|'I_n|) m j (fto (expgn_rec (T:=gT) g (otf x3)), x4)) i + (fto (expgn_rec (T:=gT) g (otf x)), + (fto (expgn_rec (T:=gT) g (otf x)), fto (expgn_rec (T:=gT) g (otf x1)), a, + fto (Zp_add (otf v) (Zp_mul (otf a) (otf x)))))) i) ;; + v0 ← get skey_loc i ;; + v1 ← get ckey_loc i ;; + @ret 'public (fto (expgn_rec (T:=gT) (otf v1) v0 * expgn_rec (T:=gT) g vote)) + end + | None => + a ← sample uniform RO1.i_random ;; + #put RO1.queries_loc := setm x2 + (Sigma1.Sigma.prod_assoc (fto (expgn_rec (T:=gT) g (otf x)), fto (expgn_rec (T:=gT) g (otf x1)))) a ;; + v ← get Sigma1.MyAlg.commit_loc ;; + x3 ← sample uniform i_secret ;; + #assert Sigma1.MyParam.R (otf (fto (expgn_rec (T:=gT) g (otf x3)))) (otf x3) ;; + x5 ← sample uniform Sigma1.MyAlg.i_witness ;; + #put Sigma1.MyAlg.commit_loc := x5 ;; + v0 ← get RO1.queries_loc ;; + match v0 (Sigma1.Sigma.prod_assoc (fto (expgn_rec (T:=gT) g (otf x3)), fto (expgn_rec (T:=gT) g (otf x5)))) with + | Some a0 => + x6 ← get Sigma1.MyAlg.commit_loc ;; + let x4 := (fto (expgn_rec (T:=gT) g (otf x3)), fto (expgn_rec (T:=gT) g (otf x5)), a0, fto (Zp_add (otf x6) (Zp_mul (otf a0) (otf x3)))) in + #assert eqn + (size + (domm (T:='I_#|'I_n|) (S:='I_#|gT| * ('I_#|gT| * 'I_#|gT| * 'I_#|'Z_Sigma1.q| * 'I_#|'Z_Sigma1.q|)) + (setm (T:='I_#|'I_n|) (setm (T:='I_#|'I_n|) m j (fto (expgn_rec (T:=gT) g (otf x3)), x4)) i + (fto (expgn_rec (T:=gT) g (otf x)), + (fto (expgn_rec (T:=gT) g (otf x)), fto (expgn_rec (T:=gT) g (otf x1)), a, fto (Zp_add (otf v) (Zp_mul (otf a) (otf x)))))))) n ;; + #put ckey_loc i := fto + (compute_key + (setm (T:='I_#|'I_n|) (setm (T:='I_#|'I_n|) m j (fto (expgn_rec (T:=gT) g (otf x3)), x4)) i + (fto (expgn_rec (T:=gT) g (otf x)), + (fto (expgn_rec (T:=gT) g (otf x)), fto (expgn_rec (T:=gT) g (otf x1)), a, + fto (Zp_add (otf v) (Zp_mul (otf a) (otf x)))))) i) ;; + v0 ← get skey_loc i ;; + v1 ← get ckey_loc i ;; + @ret 'public (fto (expgn_rec (T:=gT) (otf v1) v0 * expgn_rec (T:=gT) g vote)) + | None => + a0 ← sample uniform RO1.i_random ;; + #put RO1.queries_loc := setm v0 + (Sigma1.Sigma.prod_assoc (fto (expgn_rec (T:=gT) g (otf x3)), fto (expgn_rec (T:=gT) g (otf x5)))) a0 ;; + x6 ← get Sigma1.MyAlg.commit_loc ;; + let x4 := (fto (expgn_rec (T:=gT) g (otf x3)), fto (expgn_rec (T:=gT) g (otf x5)), a0, fto (Zp_add (otf x6) (Zp_mul (otf a0) (otf x3)))) in + #assert eqn + (size + (domm (T:='I_#|'I_n|) (S:='I_#|gT| * ('I_#|gT| * 'I_#|gT| * 'I_#|'Z_Sigma1.q| * 'I_#|'Z_Sigma1.q|)) + (setm (T:='I_#|'I_n|) (setm (T:='I_#|'I_n|) m j (fto (expgn_rec (T:=gT) g (otf x3)), x4)) i + (fto (expgn_rec (T:=gT) g (otf x)), + (fto (expgn_rec (T:=gT) g (otf x)), fto (expgn_rec (T:=gT) g (otf x1)), a, fto (Zp_add (otf v) (Zp_mul (otf a) (otf x)))))))) n ;; + #put ckey_loc i := fto + (compute_key + (setm (T:='I_#|'I_n|) (setm (T:='I_#|'I_n|) m j (fto (expgn_rec (T:=gT) g (otf x3)), x4)) i + (fto (expgn_rec (T:=gT) g (otf x)), + (fto (expgn_rec (T:=gT) g (otf x)), fto (expgn_rec (T:=gT) g (otf x1)), a, + fto (Zp_add (otf v) (Zp_mul (otf a) (otf x)))))) i) ;; + v0 ← get skey_loc i ;; + v1 ← get ckey_loc i ;; + @ret 'public (fto (expgn_rec (T:=gT) (otf v1) v0 * expgn_rec (T:=gT) g vote)) + end + end + }. + Next Obligation. + intros. + ssprove_valid ; auto with loc_db. + destruct (v1 _) ; ssprove_valid ; auto with loc_db. + - destruct (v5 _) ; ssprove_valid ; auto with loc_db. + - destruct (v6 _) ; ssprove_valid ; auto with loc_db. + Qed. + + #[program] Definition Exec_i_realised_code_runnable m (i j : pid) (vote : 'bool): + code (P_i_locs i :|: combined_locations) [interface] 'public := + {code + x ← sample uniform i_secret ;; + #put skey_loc i := x ;; + #assert Sigma1.MyParam.R (otf (fto (expgn_rec (T:=gT) g (otf x)))) (otf x) ;; + x1 ← sample uniform Sigma1.MyAlg.i_witness ;; + #put Sigma1.MyAlg.commit_loc := x1 ;; + x2 ← get RO1.queries_loc ;; + a ← sample uniform RO1.i_random ;; + #put RO1.queries_loc := setm x2 + (Sigma1.Sigma.prod_assoc (fto (expgn_rec (T:=gT) g (otf x)), fto (expgn_rec (T:=gT) g (otf x1)))) a ;; + v ← get Sigma1.MyAlg.commit_loc ;; + x3 ← sample uniform i_secret ;; + #assert Sigma1.MyParam.R (otf (fto (expgn_rec (T:=gT) g (otf x3)))) (otf x3) ;; + x5 ← sample uniform Sigma1.MyAlg.i_witness ;; + #put Sigma1.MyAlg.commit_loc := x5 ;; + v0 ← get RO1.queries_loc ;; + a0 ← sample uniform RO1.i_random ;; + #put RO1.queries_loc := setm v0 + (Sigma1.Sigma.prod_assoc (fto (expgn_rec (T:=gT) g (otf x3)), fto (expgn_rec (T:=gT) g (otf x5)))) a0 ;; + x6 ← get Sigma1.MyAlg.commit_loc ;; + let x4 := (fto (expgn_rec (T:=gT) g (otf x3)), fto (expgn_rec (T:=gT) g (otf x5)), a0, fto (Zp_add (otf x6) (Zp_mul (otf a0) (otf x3)))) in + #assert eqn + (size + (domm (T:='I_#|'I_n|) (S:='I_#|gT| * ('I_#|gT| * 'I_#|gT| * 'I_#|'Z_Sigma1.q| * 'I_#|'Z_Sigma1.q|)) + (setm (T:='I_#|'I_n|) (setm (T:='I_#|'I_n|) m j (fto (expgn_rec (T:=gT) g (otf x3)), x4)) i + (fto (expgn_rec (T:=gT) g (otf x)), + (fto (expgn_rec (T:=gT) g (otf x)), fto (expgn_rec (T:=gT) g (otf x1)), a, fto (Zp_add (otf v) (Zp_mul (otf a) (otf x)))))))) n ;; + #put ckey_loc i := fto + (compute_key + (setm (T:='I_#|'I_n|) (setm (T:='I_#|'I_n|) m j (fto (expgn_rec (T:=gT) g (otf x3)), x4)) i + (fto (expgn_rec (T:=gT) g (otf x)), + (fto (expgn_rec (T:=gT) g (otf x)), fto (expgn_rec (T:=gT) g (otf x1)), a, + fto (Zp_add (otf v) (Zp_mul (otf a) (otf x)))))) i) ;; + v0 ← get skey_loc i ;; + v1 ← get ckey_loc i ;; + @ret 'public (fto (expgn_rec (T:=gT) (otf v1) v0 * expgn_rec (T:=gT) g vote)) + }. + Next Obligation. + intros. + ssprove_valid ; auto with loc_db. + Qed. + + Lemma code_pkg_equiv m i j (vote : 'bool): + ⊢ + ⦃ λ '(h₀, h₁), h₀ = h₁ ⦄ + get_op_default (Exec_i_realised true m i j) ((Exec i), ('bool, 'public)) vote + ≈ + Exec_i_realised_code m i j vote + ⦃ eq ⦄. + Proof. + unfold Exec_i_realised. + rewrite get_op_default_link. + erewrite get_op_default_spec. + 2: { + cbn. + rewrite eqnE eq_refl. + done. + } + ssprove_code_simpl. + simpl. + repeat choice_type_eqP_handle. + rewrite !cast_fun_K. + ssprove_code_simpl. + simpl. + ssprove_code_simpl. + ssprove_code_simpl_more. + simpl. + ssprove_sync_eq=>x. + simpl. + ssprove_code_simpl_more. + ssprove_sync_eq. + ssprove_sync_eq=>rel1. + ssprove_sync_eq=>r1. + ssprove_sync_eq. + + (* ssprove_sync_eq=>queries. + destruct (queries (Sigma1.Sigma.prod_assoc (fto (g ^+ otf x), fto (g ^+ otf r1)))) eqn:e. + all: rewrite e. + - simpl. + ssprove_code_simpl. + ssprove_sync_eq=>?. *) + Admitted. + + #[tactic=notac] Equations? Aux_realised (b : bool) (i j : pid) m f' : + package (DDH.DDH_locs :|: P_i_locs i :|: combined_locations) Game_import [interface #val #[ Exec i ] : 'bool → 'public] := + Aux_realised b i j m f' := {package Aux b i j m f' ∘ (par DDH.DDH_real (Sigma1.Sigma.Fiat_Shamir ∘ RO1.RO)) }. + Proof. + ssprove_valid. + 4:{ rewrite fsetUid. rewrite -fset0E. apply fsub0set. } + 6: apply fsubsetxx. + 3:{ rewrite -fsetUA. apply fsubsetxx. } + 4:{ rewrite -fsetUA. apply fsubsetUl. } + all: unfold combined_locations. + - eapply fsubset_trans. 2: apply fsubsetUr. + apply fsubsetUl. + - eapply fsubset_trans. 2: apply fsubsetUr. + apply fsubsetUr. + - unfold DDH.DDH_E. + apply fsetUS. + rewrite !fset_cons. + apply fsubsetUr. + Qed. + + #[tactic=notac] Equations? Aux_ideal_realised (b : bool) (i j : pid) m f' : + package (DDH.DDH_locs :|: P_i_locs i :|: combined_locations) Game_import [interface #val #[ Exec i ] : 'bool → 'public] := + Aux_ideal_realised b i j m f' := {package Aux b i j m f' ∘ (par DDH.DDH_ideal (Sigma1.Sigma.Fiat_Shamir ∘ RO1.RO)) }. + Proof. + ssprove_valid. + 4:{ rewrite fsetUid. rewrite -fset0E. apply fsub0set. } + 6: apply fsubsetxx. + 3:{ rewrite -fsetUA. apply fsubsetxx. } + 4:{ rewrite -fsetUA. apply fsubsetUl. } + all: unfold combined_locations. + - eapply fsubset_trans. 2: apply fsubsetUr. + apply fsubsetUl. + - eapply fsubset_trans. 2: apply fsubsetUr. + apply fsubsetUr. + - unfold DDH.DDH_E. + apply fsetUS. + rewrite !fset_cons. + apply fsubsetUr. + Qed. + + Notation inv i := (heap_ignore (P_i_locs i :|: DDH.DDH_locs)). + + #[local] Hint Extern 50 (_ = code_link _ _) => + rewrite code_link_scheme + : ssprove_code_simpl. + + (** We extend swapping to schemes. + This means that the ssprove_swap tactic will be able to swap any command + with a scheme without asking a proof from the user. + *) + #[local] Hint Extern 40 (⊢ ⦃ _ ⦄ x ← ?s ;; y ← cmd _ ;; _ ≈ _ ⦃ _ ⦄) => + eapply r_swap_scheme_cmd ; ssprove_valid + : ssprove_swap. + + Lemma P_i_aux_equiv (i j : pid) m: + fdisjoint Sigma1.MyAlg.Sigma_locs DDH.DDH_locs → + i != j → + (∃ f, + bijective f ∧ + (∀ b, (Exec_i_realised b m i j) ≈₀ Aux_realised b i j m f)). + Proof. + intros Hdisj ij_neq. + have [f' Hf] := test_bij' i j m ij_neq. + simpl in Hf. + exists f'. + split. + { + assert ('I_#|'Z_#[g]|) as x. + { rewrite card_ord. + eapply Ordinal. + rewrite ltnS. + apply ltnSn. + } + specialize (Hf x). + destruct Hf. + assumption. + } + intro b. + eapply eq_rel_perf_ind with (inv := inv i). + { + ssprove_invariant. + rewrite -!fsetUA. + apply fsetUS. + do 2 (apply fsubsetU ; apply /orP ; right). + apply fsubsetUl. + } + simplify_eq_rel v. + rewrite !setmE. + rewrite !eq_refl. + ssprove_code_simpl. + repeat simplify_linking. + ssprove_sync => x_i. + + rewrite !cast_fun_K. + ssprove_code_simpl. + ssprove_code_simpl_more. + + ssprove_swap_seq_rhs [:: 4 ; 5 ; 6 ; 7]%N. + ssprove_swap_seq_rhs [:: 2 ; 3 ; 4 ; 5 ; 6]%N. + ssprove_swap_seq_rhs [:: 0 ; 1 ; 2 ; 3 ; 4 ; 5]%N. + ssprove_contract_put_get_rhs. + apply r_put_rhs. + ssprove_swap_seq_lhs [:: 0 ; 1 ; 2 ; 3]%N. + unfold Sigma1.MyParam.R. + have Hord : ∀ x, (nat_of_ord x) = (nat_of_ord (otf x)). + { + unfold otf. + intros n x. + rewrite enum_val_ord. + done. + } + rewrite -Hord otf_fto eq_refl. + simpl. + ssprove_sync => r_i. + apply r_put_vs_put. + ssprove_restore_pre. + { ssprove_invariant. + apply preserve_update_r_ignored_heap_ignore. + - unfold DDH.DDH_locs. + rewrite in_fsetU. + apply /orP ; right. + rewrite fset_cons. + rewrite in_fsetU. + apply /orP ; left. + by apply /fset1P. + - apply preserve_update_mem_nil. + } + eapply (@rsame_head_cmd_alt _ _ (λ z, _) (λ z, _) (cmd_put _ _)) ; [eapply cmd_put_preserve_pre ; ssprove_invariant | intros ]. + ssprove_swap_seq_lhs [:: 0 ]%N. + ssprove_swap_seq_rhs [:: 2 ; 1 ; 0]%N. + ssprove_sync => queries. + destruct (queries (Sigma1.Sigma.prod_assoc (fto (g ^+ x_i), fto (g ^+ otf r_i)))) eqn:e. + all: rewrite e; simpl. + all: ssprove_code_simpl_more. + - ssprove_swap_seq_lhs [:: 0 ; 1 ; 2 ; 3 ; 4 ; 5]%N. + ssprove_swap_seq_lhs [:: 0 ; 1 ]%N. + eapply r_uniform_bij. + { apply Hf. + + rewrite card_ord. + rewrite Zp_cast. + 2: apply (prime_gt1 prime_order). + eapply Ordinal. + apply (prime_gt1 prime_order). + } + intro x. + specialize (Hf x). + destruct Hf as [bij_f Hf]. + apply bij_inj in bij_f. + apply finv_f in bij_f. + ssprove_contract_put_get_rhs. + rewrite bij_f. + rewrite -Hord !otf_fto !eq_refl. + simpl. + apply r_put_rhs. + ssprove_restore_pre. + { + apply preserve_update_r_ignored_heap_ignore. + - unfold DDH.DDH_locs. + rewrite !fset_cons. + rewrite !in_fsetU. + apply /orP ; right. + apply /orP ; right. + apply /orP ; left. + by apply /fset1P. + - apply preserve_update_mem_nil. + } + apply r_get_remember_lhs. + intros ?. + apply r_get_remember_rhs. + intros ?. + ssprove_forget_all. + ssprove_sync=>r_j. + apply r_put_vs_put. + ssprove_restore_pre. + 1: ssprove_invariant. + clear e queries. + ssprove_sync. + ssprove_swap_seq_lhs [:: 0]%N. + ssprove_sync=>queries. + destruct (queries (Sigma1.Sigma.prod_assoc (fto (g ^+ x), fto (g ^+ otf r_j)))) eqn:e. + all: rewrite e. + all: ssprove_code_simpl. + all: ssprove_code_simpl_more. + + ssprove_swap_seq_lhs [:: 0 ; 1]%N. + simpl. + apply r_get_remember_lhs. + intros ?. + apply r_get_remember_rhs. + intros ?. + ssprove_forget_all. + apply r_assertD. + { + intros ??. + rewrite !domm_set. + done. + } + intros _ _. + ssprove_swap_lhs 1%N. + { + move: H0 => /eqP. + erewrite eqn_add2r. + intros contra. + discriminate. + } + ssprove_contract_put_get_lhs. + apply r_put_lhs. + ssprove_contract_put_get_lhs. + apply r_put_lhs. + ssprove_restore_pre. + { + repeat apply preserve_update_l_ignored_heap_ignore. + 1,2: unfold P_i_locs ; rewrite in_fsetU. + 1,2: apply /orP ; left ; rewrite !fset_cons ; + rewrite -fset0E fsetU0 ; rewrite in_fsetU. + - apply /orP ; right. + by apply /fset1P. + - apply /orP ; left. + by apply /fset1P. + - apply preserve_update_mem_nil. + } + rewrite otf_fto. + rewrite compute_key_set_i. + set zk := (fto (g ^+ x), fto (g ^+ otf r_j), s1, fto (otf x2 + otf s1 * otf x)). + clearbody zk. + specialize (Hf zk). + rewrite !Hord. + rewrite Hf. + rewrite -!Hord. + rewrite -expgM. + rewrite mulnC. + case b; apply r_ret ; done. + + ssprove_swap_seq_lhs [:: 0 ; 1 ; 2 ; 3]%N. + simpl. + ssprove_sync=>e_j. + apply r_put_vs_put. + apply r_get_remember_lhs. + intros ?. + apply r_get_remember_rhs. + intros ?. + ssprove_forget_all. + apply r_assertD. + { + intros ??. + rewrite !domm_set. + done. + } + intros _ _. + ssprove_swap_lhs 1%N. + { + move: H0 => /eqP. + erewrite eqn_add2r. + intros contra. + discriminate. + } + ssprove_contract_put_get_lhs. + apply r_put_lhs. + ssprove_contract_put_get_lhs. + apply r_put_lhs. + ssprove_restore_pre. + { + repeat apply preserve_update_l_ignored_heap_ignore. + 1,2: unfold P_i_locs ; rewrite in_fsetU. + 1,2: apply /orP ; left ; rewrite !fset_cons ; + rewrite -fset0E fsetU0 ; rewrite in_fsetU. + - apply /orP ; right. + by apply /fset1P. + - apply /orP ; left. + by apply /fset1P. + - ssprove_invariant. + } + rewrite otf_fto. + rewrite compute_key_set_i. + set zk := (fto (g ^+ x), fto (g ^+ otf r_j), e_j, fto (otf x2 + otf e_j * otf x)). + clearbody zk. + specialize (Hf zk). + rewrite !Hord. + rewrite Hf. + rewrite -!Hord. + rewrite -expgM. + rewrite mulnC. + case b; apply r_ret ; done. + - ssprove_swap_seq_lhs [:: 0 ; 1 ; 2 ; 3 ; 4 ; 5 ; 6 ; 7]%N. + ssprove_swap_seq_lhs [:: 2 ; 1 ; 0 ]%N. + eapply r_uniform_bij. + { apply Hf. + + rewrite card_ord. + rewrite Zp_cast. + 2: apply (prime_gt1 prime_order). + eapply Ordinal. + apply (prime_gt1 prime_order). + } + intro x. + specialize (Hf x). + destruct Hf as [bij_f Hf]. + apply bij_inj in bij_f. + apply finv_f in bij_f. + ssprove_contract_put_get_rhs. + rewrite bij_f. + rewrite -Hord !otf_fto !eq_refl. + simpl. + apply r_put_rhs. + ssprove_restore_pre. + { + apply preserve_update_r_ignored_heap_ignore. + - unfold DDH.DDH_locs. + rewrite !fset_cons. + rewrite !in_fsetU. + apply /orP ; right. + apply /orP ; right. + apply /orP ; left. + by apply /fset1P. + - apply preserve_update_mem_nil. + } + ssprove_sync=>e_i. + apply r_put_vs_put. + apply r_get_remember_lhs. + intros ?. + apply r_get_remember_rhs. + intros ?. + ssprove_forget_all. + rewrite -Hord eq_refl. + simpl. + ssprove_sync=>r_j. + apply r_put_vs_put. + ssprove_restore_pre. + 1: ssprove_invariant. + clear e queries. + ssprove_sync. + ssprove_swap_seq_lhs [:: 0]%N. + ssprove_sync=>queries. + destruct (queries (Sigma1.Sigma.prod_assoc (fto (g ^+ x), fto (g ^+ otf r_j)))) eqn:e. + all: rewrite e. + all: ssprove_code_simpl. + all: ssprove_code_simpl_more. + + ssprove_swap_seq_lhs [:: 0 ; 1]%N. + simpl. + apply r_get_remember_lhs. + intros ?. + apply r_get_remember_rhs. + intros ?. + ssprove_forget_all. + apply r_assertD. + { + intros ??. + rewrite !domm_set. + done. + } + intros _ _. + ssprove_swap_lhs 1%N. + { + move: H0 => /eqP. + erewrite eqn_add2r. + intros contra. + discriminate. + } + ssprove_contract_put_get_lhs. + apply r_put_lhs. + ssprove_contract_put_get_lhs. + apply r_put_lhs. + ssprove_restore_pre. + { + repeat apply preserve_update_l_ignored_heap_ignore. + 1,2: unfold P_i_locs ; rewrite in_fsetU. + 1,2: apply /orP ; left ; rewrite !fset_cons ; + rewrite -fset0E fsetU0 ; rewrite in_fsetU. + - apply /orP ; right. + by apply /fset1P. + - apply /orP ; left. + by apply /fset1P. + - apply preserve_update_mem_nil. + } + rewrite otf_fto. + rewrite compute_key_set_i. + set zk := (fto (g ^+ x), fto (g ^+ otf r_j), s, fto (otf x2 + otf s * otf x)). + clearbody zk. + specialize (Hf zk). + rewrite !Hord. + rewrite Hf. + rewrite -!Hord. + rewrite -expgM. + rewrite mulnC. + case b; apply r_ret ; done. + + ssprove_swap_seq_lhs [:: 0 ; 1 ; 2 ; 3]%N. + simpl. + ssprove_sync=>e_j. + apply r_put_vs_put. + apply r_get_remember_lhs. + intros ?. + apply r_get_remember_rhs. + intros ?. + ssprove_forget_all. + apply r_assertD. + { + intros ??. + rewrite !domm_set. + done. + } + intros _ _. + ssprove_swap_lhs 1%N. + { + move: H0 => /eqP. + erewrite eqn_add2r. + intros contra. + discriminate. + } + ssprove_contract_put_get_lhs. + apply r_put_lhs. + ssprove_contract_put_get_lhs. + apply r_put_lhs. + ssprove_restore_pre. + { + repeat apply preserve_update_l_ignored_heap_ignore. + 1,2: unfold P_i_locs ; rewrite in_fsetU. + 1,2: apply /orP ; left ; rewrite !fset_cons ; + rewrite -fset0E fsetU0 ; rewrite in_fsetU. + - apply /orP ; right. + by apply /fset1P. + - apply /orP ; left. + by apply /fset1P. + - ssprove_invariant. + } + rewrite otf_fto. + rewrite compute_key_set_i. + set zk := (fto (g ^+ x), fto (g ^+ otf r_j), e_j, fto (otf x2 + otf e_j * otf x)). + clearbody zk. + specialize (Hf zk). + rewrite !Hord. + rewrite Hf. + rewrite -!Hord. + rewrite -expgM. + rewrite mulnC. + case b; apply r_ret ; done. + Qed. + + Lemma Hord (x : secret): (nat_of_ord x) = (nat_of_ord (otf x)). + Proof. + unfold otf. + rewrite enum_val_ord. + done. + Qed. + + Lemma vote_hiding_bij (c : secret) (v : bool): + fto (otf (fto (g ^+ c)) * g ^+ v) = + fto + (otf (fto (g ^+ (if v then fto (Zp_add (otf c) Zp1) else fto (Zp_add (otf c) (Zp_opp Zp1))))) * + g ^+ (~~ v)). + Proof. + f_equal. + rewrite !otf_fto. + rewrite -!expgD. + have h' : ∀ (x : Secret), nat_of_ord x = (nat_of_ord (fto x)). + { + unfold fto. + intros k. + rewrite enum_rank_ord. + done. + } + case v. + ++ apply /eqP. + rewrite eq_expg_mod_order. + rewrite addn0. + have h : ∀ (x : secret), (((nat_of_ord x) + 1) %% q'.+2)%N = (nat_of_ord (Zp_add (otf x) Zp1)). + { + intro k. + unfold Zp_add. + simpl. + rewrite -Hord. + apply /eqP. + rewrite eq_sym. + apply /eqP. + rewrite -> Zp_cast at 2. + 2: apply (prime_gt1 prime_order). + rewrite -> Zp_cast at 1. + 2: apply (prime_gt1 prime_order). + rewrite modnDmr. + rewrite Fp_cast. + 2: apply prime_order. + reflexivity. + } + rewrite -h'. + rewrite -h. + rewrite -modn_mod. + rewrite Fp_cast. + 2: apply prime_order. + 1: apply eq_refl. + ++ apply /eqP. + rewrite eq_expg_mod_order. + rewrite addn0. + unfold Zp_add, Zp_opp, Zp1. + simpl. + repeat rewrite -> Zp_cast at 12. + 2-4: apply (prime_gt1 prime_order). + rewrite -!Hord. + have -> : (#[g] - 1 %% #[g])%N = #[g].-1. + { rewrite modn_small. + 2: apply (prime_gt1 prime_order). + by rewrite -subn1. + } + rewrite modn_small. + 2:{ + destruct c as [c Hc]. + move: Hc. + simpl. + unfold DDH.i_space, DDHParams.Space, Secret. + rewrite card_ord. + rewrite Zp_cast. + 2: apply (prime_gt1 prime_order). + done. + } + have -> : (#[g].-1 %% #[g])%N = #[g].-1. + { + rewrite modn_small. + 1: reflexivity. + apply ltnSE. + rewrite -subn1 -2!addn1. + rewrite subnK. + 2: apply (prime_gt0 prime_order). + rewrite addn1. + apply ltnSn. + } + rewrite -h'. + simpl. + rewrite -> Zp_cast at 9. + 2: apply (prime_gt1 prime_order). + rewrite modnDml. + rewrite -subn1. + rewrite -addnA. + rewrite subnK. + 2: apply (prime_gt0 prime_order). + rewrite -modnDmr. + rewrite modnn. + rewrite addn0. + rewrite modn_small. + 1: apply eq_refl. + destruct c as [h Hc]. + move: Hc. + unfold DDH.i_space, DDHParams.Space, Secret. + simpl. + rewrite card_ord. + rewrite Zp_cast. + 2: apply (prime_gt1 prime_order). + done. + Qed. + + Lemma vote_hiding (i j : pid) m: + i != j → + ∀ LA A ϵ_DDH, + ValidPackage LA [interface #val #[ Exec i ] : 'bool → 'public] A_export A → + fdisjoint Sigma1.MyAlg.Sigma_locs DDH.DDH_locs → + fdisjoint LA DDH.DDH_locs → + fdisjoint LA (P_i_locs i) → + fdisjoint LA combined_locations → + (∀ D, DDH.ϵ_DDH D <= ϵ_DDH) → + AdvantageE (Exec_i_realised true m i j) (Exec_i_realised false m i j) A <= ϵ_DDH + ϵ_DDH. + Proof. + intros ij_neq LA A ϵ_DDH Va Hdisj Hdisj2 Hdisj3 Hdisj4 Dadv. + have [f' [bij_f Hf]] := P_i_aux_equiv i j m Hdisj ij_neq. + ssprove triangle (Exec_i_realised true m i j) [:: + (Aux_realised true i j m f').(pack) ; + (Aux true i j m f') ∘ (par DDH.DDH_ideal (Sigma1.Sigma.Fiat_Shamir ∘ RO1.RO)) ; + (Aux false i j m f') ∘ (par DDH.DDH_ideal (Sigma1.Sigma.Fiat_Shamir ∘ RO1.RO)) ; + (Aux_realised false i j m f').(pack) + ] (Exec_i_realised false m i j) A as ineq. + eapply le_trans. + 2: { + instantiate (1 := 0 + ϵ_DDH + 0 + ϵ_DDH + 0). + by rewrite ?GRing.addr0 ?GRing.add0r. + } + eapply le_trans. 1: exact ineq. + clear ineq. + repeat eapply ler_add. + { + apply eq_ler. + specialize (Hf true LA A Va). + apply Hf. + - rewrite fdisjointUr. + apply /andP ; split ; assumption. + - rewrite fdisjointUr. + apply /andP ; split. + 2: assumption. + rewrite fdisjointUr. + apply /andP ; split ; assumption. + } + { + unfold Aux_realised. + rewrite -Advantage_link. + rewrite par_commut. + have -> : (par DDH.DDH_ideal (Sigma1.Sigma.Fiat_Shamir ∘ RO1.RO)) = + (par (Sigma1.Sigma.Fiat_Shamir ∘ RO1.RO) DDH.DDH_ideal). + { apply par_commut. ssprove_valid. } + erewrite Advantage_par. + 3: apply DDH.DDH_real. + 3: apply DDH.DDH_ideal. + 2: { + ssprove_valid. + - eapply fsubsetUr. + - apply fsubsetUl. + } + 1: rewrite Advantage_sym ; apply Dadv. + - ssprove_valid. + - unfold trimmed. + rewrite -link_trim_commut. + f_equal. + unfold trim. + rewrite !fset_cons -fset0E fsetU0. + rewrite !filterm_set. + simpl. + rewrite !in_fsetU !in_fset1 !eq_refl. + rewrite filterm0. + done. + - unfold trimmed. + unfold trim. + rewrite !fset_cons -fset0E fsetU0. + rewrite !filterm_set. + simpl. + rewrite !in_fset1 !eq_refl. + rewrite filterm0. + done. + - unfold trimmed. + unfold trim. + rewrite !fset_cons -fset0E fsetU0. + rewrite !filterm_set. + simpl. + rewrite !in_fset1 !eq_refl. + rewrite filterm0. + done. + } + 2:{ + unfold Aux_realised. + rewrite -Advantage_link. + rewrite par_commut. + have -> : (par DDH.DDH_real (Sigma1.Sigma.Fiat_Shamir ∘ RO1.RO)) = + (par (Sigma1.Sigma.Fiat_Shamir ∘ RO1.RO) DDH.DDH_real). + { apply par_commut. ssprove_valid. } + erewrite Advantage_par. + 3: apply DDH.DDH_ideal. + 3: apply DDH.DDH_real. + 2: { + ssprove_valid. + - eapply fsubsetUr. + - apply fsubsetUl. + } + 1: apply Dadv. + - ssprove_valid. + - unfold trimmed. + rewrite -link_trim_commut. + f_equal. + unfold trim. + rewrite !fset_cons -fset0E fsetU0. + rewrite !filterm_set. + simpl. + rewrite !in_fsetU !in_fset1 !eq_refl. + rewrite filterm0. + done. + - unfold trimmed. + unfold trim. + unfold DDH.DDH_E. + rewrite !fset_cons -fset0E fsetU0. + rewrite !filterm_set. + simpl. + rewrite !in_fset1 !eq_refl. + rewrite filterm0. + done. + - unfold trimmed. + unfold trim. + unfold DDH.DDH_E. + rewrite !fset_cons -fset0E fsetU0. + rewrite !filterm_set. + simpl. + rewrite !in_fset1 !eq_refl. + rewrite filterm0. + done. + } + 2: { + apply eq_ler. + specialize (Hf false LA A Va). + rewrite Advantage_sym. + apply Hf. + - rewrite fdisjointUr. + apply /andP ; split ; assumption. + - rewrite fdisjointUr. + apply /andP ; split. + 2: assumption. + rewrite fdisjointUr. + apply /andP ; split ; assumption. + } + apply eq_ler. + eapply eq_rel_perf_ind with (inv := inv i). + 5: apply Va. + 1,2: apply Aux_ideal_realised. + 3: { + rewrite fdisjointUr. + apply /andP ; split. + 2: assumption. + rewrite fdisjointUr. + apply /andP ; split ; assumption. + } + 3: { + rewrite fdisjointUr. + apply /andP ; split. + 2: assumption. + rewrite fdisjointUr. + apply /andP ; split ; assumption. + } + { + ssprove_invariant. + rewrite fsetUC. + rewrite -!fsetUA. + apply fsetUS. + apply fsubsetUl. + } + simplify_eq_rel v. + rewrite !setmE. + rewrite !eq_refl. + simpl. + repeat simplify_linking. + rewrite !cast_fun_K. + ssprove_code_simpl. + ssprove_code_simpl_more. + ssprove_sync=>x_i. + ssprove_sync=>x_j. + pose f_v := (fun (x : secret) => + if v then + fto (Zp_add (otf x) Zp1) + else + fto (Zp_add (otf x) (Zp_opp Zp1)) + ). + assert (bijective f_v) as bij_fv. + { + exists (fun x => + if v then + fto (Zp_add (otf x) (Zp_opp Zp1)) + else + fto (Zp_add (otf x) Zp1) + ). + - intro x. + unfold f_v. + case v. + + rewrite otf_fto. + rewrite -Zp_addA. + rewrite Zp_addC. + have -> : (Zp_add Zp1 (Zp_opp Zp1)) = (Zp_add (Zp_opp Zp1) Zp1). + { intro n. by rewrite Zp_addC. } + rewrite Zp_addNz. + rewrite Zp_add0z. + by rewrite fto_otf. + + rewrite otf_fto. + rewrite -Zp_addA. + rewrite Zp_addC. + rewrite Zp_addNz. + rewrite Zp_add0z. + by rewrite fto_otf. + - intro x. + unfold f_v. + case v. + + rewrite otf_fto. + rewrite -Zp_addA. + rewrite Zp_addNz. + rewrite Zp_addC. + rewrite Zp_add0z. + by rewrite fto_otf. + + rewrite otf_fto. + rewrite -Zp_addA. + rewrite Zp_addC. + have -> : (Zp_add Zp1 (Zp_opp Zp1)) = (Zp_add (Zp_opp Zp1) Zp1). + { intro n. by rewrite Zp_addC. } + rewrite Zp_addNz. + rewrite Zp_add0z. + by rewrite fto_otf. + } + eapply r_uniform_bij. + 1: apply bij_fv. + intro c. + ssprove_swap_seq_rhs [:: 1 ; 2]%N. + ssprove_swap_seq_rhs [:: 0 ]%N. + ssprove_swap_seq_lhs [:: 1 ; 2]%N. + ssprove_swap_seq_lhs [:: 0 ]%N. + apply r_put_vs_put. + ssprove_contract_put_get_lhs. + ssprove_contract_put_get_rhs. + apply r_put_vs_put. + ssprove_contract_put_get_lhs. + ssprove_contract_put_get_rhs. + apply r_put_vs_put. + unfold Sigma1.MyParam.R. + rewrite -Hord otf_fto eq_refl. + simpl. + ssprove_sync=>r_i. + apply r_put_vs_put. + ssprove_restore_pre. + { + ssprove_invariant. + apply preserve_update_r_ignored_heap_ignore. + { + rewrite in_fsetU. + apply /orP ; right. + unfold DDH.DDH_locs. + rewrite !fset_cons -fset0E fsetU0. + rewrite in_fsetU. + apply /orP ; right. + rewrite in_fsetU. + apply /orP ; right. + by apply /fset1P. + } + apply preserve_update_l_ignored_heap_ignore. + 2: apply preserve_update_mem_nil. + rewrite in_fsetU. + apply /orP ; right. + unfold DDH.DDH_locs. + rewrite !fset_cons -fset0E fsetU0. + rewrite in_fsetU. + apply /orP ; right. + rewrite in_fsetU. + apply /orP ; right. + by apply /fset1P. + } + ssprove_sync. + ssprove_sync=>queries. + case (queries (Sigma1.Sigma.prod_assoc (fto (g ^+ x_i), fto (g ^+ otf r_i)))) eqn:e. + all: rewrite e. + all: ssprove_code_simpl ; simpl. + all: ssprove_code_simpl_more ; simpl. + - apply r_get_remember_lhs. + intros ?. + apply r_get_remember_rhs. + intros ?. + ssprove_forget_all. + rewrite -Hord otf_fto eq_refl. + simpl. + ssprove_sync=>e_j. + apply r_put_lhs. + apply r_put_rhs. + clear e queries. + ssprove_restore_pre. + 1: ssprove_invariant. + ssprove_sync. + ssprove_sync=>queries. + case (queries (Sigma1.Sigma.prod_assoc (fto (g ^+ finv f' x_j), fto (g ^+ otf e_j)))) eqn:e. + all: rewrite e. + all: simpl; ssprove_code_simpl. + all: ssprove_code_simpl_more. + + apply r_get_remember_lhs. + intros ?. + apply r_get_remember_rhs. + intros ?. + ssprove_forget_all. + apply r_assertD. + { + intros ??. + rewrite !domm_set. + done. + } + intros _ _. + apply r_ret. + intros ???. + split. + 2: assumption. + unfold f_v. + apply vote_hiding_bij. + + ssprove_sync=>e_i. + apply r_put_vs_put. + apply r_get_remember_lhs. + intros ?. + apply r_get_remember_rhs. + intros ?. + ssprove_forget_all. + apply r_assertD. + { + intros ??. + rewrite !domm_set. + done. + } + intros _ _. + ssprove_restore_pre. + 1: ssprove_invariant. + apply r_ret. + intros ???. + split. + 2: assumption. + unfold f_v. + apply vote_hiding_bij. + - ssprove_sync=>e_i. + apply r_put_vs_put. + apply r_get_remember_lhs. + intros ?. + apply r_get_remember_rhs. + intros ?. + ssprove_forget_all. + rewrite -Hord otf_fto. + rewrite -Hord eq_refl. + simpl. + ssprove_sync=>r_j. + apply r_put_lhs. + apply r_put_rhs. + ssprove_restore_pre. + 1: ssprove_invariant. + ssprove_sync. + ssprove_sync=>queries'. + case (queries' (Sigma1.Sigma.prod_assoc (fto (g ^+ finv f' x_j), fto (g ^+ otf r_j)))) eqn:e'. + all: rewrite e'. + all: simpl; ssprove_code_simpl. + all: ssprove_code_simpl_more. + + apply r_get_remember_lhs. + intros ?. + apply r_get_remember_rhs. + intros ?. + ssprove_forget_all. + apply r_assertD. + { + intros ??. + rewrite !domm_set. + done. + } + intros _ _. + apply r_ret. + intros ???. + split. + 2: assumption. + unfold f_v. + apply vote_hiding_bij. + + ssprove_sync=>e_j. + apply r_put_vs_put. + apply r_get_remember_lhs. + intros ?. + apply r_get_remember_rhs. + intros ?. + ssprove_forget_all. + apply r_assertD. + { + intros ??. + rewrite !domm_set. + done. + } + intros _ _. + ssprove_restore_pre. + 1: ssprove_invariant. + apply r_ret. + intros ???. + split. + 2: assumption. + unfold f_v. + apply vote_hiding_bij. + Qed. + +End OVN. +End OVN. diff --git a/theories/Crypt/jasmin_util.v b/theories/Crypt/jasmin_util.v new file mode 100644 index 00000000..eaab7e9f --- /dev/null +++ b/theories/Crypt/jasmin_util.v @@ -0,0 +1,2023 @@ +(* ** Imports and settings *) +From HB Require Import structures. +From mathcomp Require Import all_ssreflect. +From Coq.Unicode Require Import Utf8. +From Coq Require Import ZArith Zwf Setoid Morphisms CMorphisms CRelationClasses Psatz. +(* Require Import xseq oseq. *) +From mathcomp Require Import word_ssrZ. + + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Local Open Scope Z_scope. + +Lemma eq_axiom_of_scheme X (beq : X -> X -> bool) : + (forall x y : X, beq x y -> x = y) -> + (forall x y : X, x = y -> beq x y) -> + Equality.axiom beq. +Proof. move=> hbl hlb x y. apply: (iffP idP); first exact: hbl. exact: hlb. Qed. + +(* -------------------------------------------------------------------- *) +Module FinIsCount. +Section FinIsCount. +Variable (T : eqType) (enum : seq T) (A : Finite.axiom enum). + +Definition pickle (x : T) := + seq.index x enum. + +Definition unpickle (n : nat) := + nth None [seq some x | x <- enum] n. + +Definition pickleK : pcancel pickle unpickle. +Proof. +move=> x; have xE: x \in enum by apply/count_memPn; rewrite (A x). +by rewrite /pickle /unpickle (nth_map x) ?(nth_index, index_mem). +Qed. +End FinIsCount. +End FinIsCount. + +Class eqTypeC (T:Type) := + { beq : T -> T -> bool + ; ceqP: Equality.axiom beq }. + +Module EqType. +Section EqType. + +Context {T:Type} {ceqT : eqTypeC T}. +HB.instance Definition _ := hasDecEq.Build T ceqP. +Definition ceqT_eqType : eqType := T. + +End EqType. +End EqType. +Definition ceqT_eqType {T} {ceqT} := @EqType.ceqT_eqType T ceqT. + +Notation "x == y ::> T" := (@eq_op (@ceqT_eqType T _) x y) + (at level 70, y at next level) : bool_scope. + +Notation "x == y ::>" := (@eq_op (@ceqT_eqType _ _) x y) + (at level 70, y at next level) : bool_scope. + +Class finTypeC (T:Type) := + { _eqC : eqTypeC T + ; cenum : seq T + ; cenumP : @Finite.axiom ceqT_eqType cenum + }. + +#[global] +Existing Instance _eqC. + +Module FinType. +Section FinType. + +Context `{cfinT:finTypeC}. + +HB.instance Definition _ := Equality.copy T ceqT_eqType. +HB.instance Definition _ : isCountable T := + PCanIsCountable (FinIsCount.pickleK cenumP). +HB.instance Definition _ := isFinite.Build T cenumP. +Definition cfinT_finType : finType := T. + +Lemma mem_cenum : cenum =i ceqT_eqType. +Proof. + move=> x. rewrite -has_pred1 has_count. by rewrite cenumP. +Qed. + +End FinType. +End FinType. +Definition cfinT_finType {T} {cfinT} := @FinType.cfinT_finType T cfinT. +Definition mem_cenum {T} {cfinT} := @FinType.mem_cenum T cfinT. + +Module FinMap. + +Section Section. + +Context `{cfinT:finTypeC} (U:Type). + +(* Map from T -> U *) + +Definition map := @finfun_of cfinT_finType (fun _ => U) (Phant _). + +Definition of_fun := + @finfun.finfun cfinT_finType (fun _ => U). + +Definition set (m:map) (x: T) (y:U) : map := + of_fun (fun z : T => if z == x ::> then y else m z). + +End Section. + +End FinMap. + +(* -------------------------------------------------------------------- *) +Lemma reflect_inj (T:eqType) (U:Type) (f:T -> U) a b : + injective f -> reflect (a = b) (a == b) -> reflect (f a = f b) (a == b). +Proof. by move=> hinj heq; apply: (iffP heq) => [| /hinj ] ->. Qed. + +(* -------------------------------------------------------------------- *) +(* Missing Instance in ssreflect for setoid rewrite *) + +#[global] +Instance and3_impl_morphism : + Proper (Basics.impl ==> Basics.impl ==> Basics.impl ==> Basics.impl) and3 | 1. +Proof. by move=> ?? h1 ?? h2 ?? h3 [/h1 ? /h2 ? /h3 ?]. Qed. + +#[global] +Instance and3_iff_morphism : + Proper (iff ==> iff ==> iff ==> iff) and3. +Proof. by move=> ?? h1 ?? h2 ?? h3; split => -[] /h1 ? /h2 ? /h3. Qed. + +(* ** Result monad + * -------------------------------------------------------------------- *) + +Variant result (E : Type) (A : Type) : Type := +| Ok of A +| Error of E. + +Arguments Error {E} {A} s. + +Definition is_ok (E A:Type) (r:result E A) := if r is Ok a then true else false. + +Lemma is_ok_ok (E A:Type) (a:A) : is_ok (Ok E a). +Proof. done. Qed. +#[global] +Hint Resolve is_ok_ok : core. + +Lemma is_okP (E A:Type) (r:result E A) : reflect (exists (a:A), r = Ok E a) (is_ok r). +Proof. + case: r => /=; constructor; first by eauto. + by move=> []. +Qed. + +Module Result. + +Definition apply eT aT rT (f : aT -> rT) (x : rT) (u : result eT aT) := + if u is Ok y then f y else x. + +Definition bind eT aT rT (f : aT -> result eT rT) g := + match g with + | Ok x => f x + | Error s => Error s + end. + +Definition map eT aT rT (f : aT -> rT) := bind (fun x => Ok eT (f x)). +Definition default eT aT := @apply eT aT aT (fun x => x). + +End Result. + +Definition o2r eT aT (e : eT) (o : option aT) := + match o with + | None => Error e + | Some x => Ok eT x + end. + +Notation rapp := Result.apply. +Notation rdflt := Result.default. +Notation rbind := Result.bind. +Notation rmap := Result.map. +Notation ok := (@Ok _). + +Notation "m >>= f" := (rbind f m) (at level 25, left associativity). +Notation "'Let' x ':=' m 'in' body" := (m >>= (fun x => body)) (x name, at level 25). +Notation "'Let:' x ':=' m 'in' body" := (m >>= (fun x => body)) (x strict pattern, at level 25). +Notation "m >> n" := (rbind (λ _, n) m) (at level 30, right associativity, n at next level). + +Lemma bindA eT aT bT cT (f : aT -> result eT bT) (g: bT -> result eT cT) m: + m >>= f >>= g = m >>= (fun a => f a >>= g). +Proof. case:m => //=. Qed. + +Lemma bind_eq eT aT rT (f1 f2 : aT -> result eT rT) m1 m2 : + m1 = m2 -> f1 =1 f2 -> m1 >>= f1 = m2 >>= f2. +Proof. move=> <- Hf; case m1 => //=. Qed. + +Definition ok_inj {E A} {a a': A} (H: Ok E a = ok a') : a = a' := + let 'Logic.eq_refl := H in Logic.eq_refl. + +Definition Error_inj {E A} (a a': E) (H: @Error E A a = Error a') : a = a' := + let 'Logic.eq_refl := H in Logic.eq_refl. + +Definition assert E (b: bool) (e: E) : result E unit := + if b then ok tt else Error e. + +Lemma assertP E b e u : + @assert E b e = ok u → b. +Proof. by case: b. Qed. + +Arguments assertP {E b e u} _. + +Variant error := + | ErrOob | ErrAddrUndef | ErrAddrInvalid | ErrStack | ErrType | ErrArith. + +Definition exec t := result error t. + +Definition type_error {t} := @Error _ t ErrType. +Definition undef_error {t} := @Error error t ErrAddrUndef. + +Lemma bindW {T U} (v : exec T) (f : T -> exec U) r : + v >>= f = ok r -> exists2 a, v = ok a & f a = ok r. +Proof. by case E: v => [a|//] /= <-; exists a. Qed. + +Lemma rbindP eT aT rT (e:result eT aT) (body:aT -> result eT rT) v (P:Type): + (forall z, e = ok z -> body z = Ok _ v -> P) -> + e >>= body = Ok _ v -> P. +Proof. by case: e=> //= a H /H H';apply H'. Qed. + +Ltac t_rbindP := do? (apply: rbindP => ??). + +Ltac t_xrbindP := + match goal with + | [ |- Result.bind _ _ = Ok _ _ -> _ ] => + apply: rbindP; t_xrbindP + | [ |- Result.map _ _ = Ok _ _ -> _ ] => + rewrite /rmap; t_xrbindP + | [ |- assert _ _ = Ok _ _ -> _ ] => + move=> /assertP; t_xrbindP + | [ |- unit -> _ ] => + case; t_xrbindP + | [ |- ok _ = ok _ -> _ ] => + case; t_xrbindP + | [ |- forall h, _ ] => + let hh := fresh h in move=> hh; t_xrbindP; move: hh + | _ => idtac + end. + +Ltac clarify := + repeat match goal with + | H : ?a = ?b |- _ => subst a || subst b + | H : ok _ = ok _ |- _ => apply ok_inj in H + | H : Some _ = Some _ |- _ => move: H => /Some_inj H + | H : ?a = _, K : ?a = _ |- _ => rewrite H in K + end. + +Lemma Let_Let {eT A B C} (a:result eT A) (b:A -> result eT B) (c: B -> result eT C) : + ((a >>= b) >>= c) = a >>= (fun a => b a >>= c). +Proof. by case: a. Qed. + +Lemma LetK {eT T} (r : result eT T) : Let x := r in ok x = r. +Proof. by case: r. Qed. + +Definition mapM eT aT bT (f : aT -> result eT bT) : seq aT → result eT (seq bT) := + fix mapM xs := + match xs with + | [::] => + Ok eT [::] + | [:: x & xs] => + f x >>= fun y => + mapM xs >>= fun ys => + Ok eT [:: y & ys] + end. + +Lemma mapM_cons aT eT bT x xs y ys (f : aT -> result eT bT): + f x = ok y /\ mapM f xs = ok ys + <-> mapM f (x :: xs) = ok (y :: ys). +Proof. + split. + by move => [] /= -> ->. + by simpl; t_xrbindP => y0 -> h0 -> -> ->. +Qed. + +Lemma map_ext aT bT f g m : + (forall a, List.In a m -> f a = g a) -> + @map aT bT f m = map g m. +Proof. +elim: m => //= a m ih ext. +rewrite ext; [ f_equal | ]; eauto. +Qed. + +Lemma mapM_ext eT aT bT (f1 f2: aT → result eT bT) (m: seq aT) : + (∀ a, List.In a m → f1 a = f2 a) → + mapM f1 m = mapM f2 m. +Proof. + elim: m => // a m ih ext /=. + rewrite (ext a); last by left. + case: (f2 _) => //= b; rewrite ih //. + by move => ? h; apply: ext; right. +Qed. + +Lemma eq_mapM eT (aT: eqType) bT (f1 f2: aT -> result eT bT) (l:list aT) : + (forall a, a \in l -> f1 a = f2 a) -> + mapM f1 l = mapM f2 l. +Proof. + elim: l => //= a l hrec hf; rewrite hf ? hrec //. + + by move=> ? h; apply/hf; rewrite in_cons h orbT. + by apply mem_head. +Qed. + +Lemma size_mapM eT aT bT f xs ys : + @mapM eT aT bT f xs = ok ys -> + size xs = size ys. +Proof. +elim: xs ys. +- by move => ys [<-]. +move => x xs ih ys /=; case: (f _) => //= y. +by case: (mapM f xs) ih => //= ys' ih [] ?; subst; rewrite (ih _ erefl). +Qed. + +Local Close Scope Z_scope. + +Lemma mapM_nth eT aT bT f xs ys d d' n : + @mapM eT aT bT f xs = ok ys -> + n < size xs -> + f (nth d xs n) = ok (nth d' ys n). +Proof. +elim: xs ys n. +- by move => ys n [<-]. +move => x xs ih ys n /=; case h: (f _) => [ y | ] //=. +case: (mapM f xs) ih => //= ys' /(_ _ _ erefl) ih [] <- {ys}. +by case: n ih => // n /(_ n). +Qed. + +Local Open Scope Z_scope. + +(* Lemma mapM_onth eT aT bT (f: aT → result eT bT) (xs: seq aT) ys n x : *) +(* mapM f xs = ok ys → *) +(* onth xs n = Some x → *) +(* ∃ y, onth ys n = Some y ∧ f x = ok y. *) +(* Proof. *) +(* move => ok_ys. *) +(* case: (leqP (size xs) n) => hsz; first by rewrite (onth_default hsz). *) +(* elim: xs ys ok_ys n hsz. *) +(* - by move => ys [<-]. *) +(* move => y xs ih ys' /=; t_xrbindP => z ok_z ys ok_ys <- [| n ] hsz /= ok_y. *) +(* - by exists z; case: ok_y => <-. *) +(* exact: (ih _ ok_ys n hsz ok_y). *) +(* Qed. *) + +(* Lemma mapM_onth' eT aT bT (f: aT → result eT bT) (xs: seq aT) ys n y : *) +(* mapM f xs = ok ys → *) +(* onth ys n = Some y → *) +(* ∃ x, onth xs n = Some x ∧ f x = ok y. *) +(* Proof. *) +(* move => ok_ys. *) +(* case: (leqP (size ys) n) => hsz; first by rewrite (onth_default hsz). *) +(* elim: xs ys ok_ys n hsz. *) +(* - by move => ys [<-]. *) +(* move => x xs ih ys' /=; t_xrbindP => z ok_z ys ok_ys <- [| n ] hsz /= ok_y. *) +(* - by exists x; case: ok_y => <-. *) +(* exact: (ih _ ok_ys n hsz ok_y). *) +(* Qed. *) + +Lemma mapMP {eT} {aT bT: eqType} (f: aT -> result eT bT) (s: seq aT) (s': seq bT) y: + mapM f s = ok s' -> + reflect (exists2 x, x \in s & f x = ok y) (y \in s'). +Proof. +elim: s s' => /= [s' [] <-|x s IHs s']; first by right; case. +apply: rbindP=> y0 Hy0. +apply: rbindP=> ys Hys []<-. +have IHs' := (IHs _ Hys). +rewrite /= in_cons eq_sym; case Hxy: (y0 == y). + by left; exists x; [rewrite mem_head | rewrite -(eqP Hxy)]. +apply: (iffP IHs')=> [[x' Hx' <-]|[x' Hx' Dy]]. + by exists x'; first by apply: predU1r. +rewrite -Dy. +case/predU1P: Hx'=> [Hx|]. ++ exfalso. + move: Hxy=> /negP Hxy. + apply: Hxy. + rewrite Hx Hy0 in Dy. + by move: Dy=> [] ->. ++ by exists x'. +Qed. + +Lemma mapM_In {aT bT eT} (f: aT -> result eT bT) (s: seq aT) (s': seq bT) x: + mapM f s = ok s' -> + List.In x s -> exists y, List.In y s' /\ f x = ok y. +Proof. +elim: s s'=> // a l /= IH s'. +apply: rbindP=> y Hy. +apply: rbindP=> ys Hys []<-. +case. ++ by move=> <-; exists y; split=> //; left. ++ move=> Hl; move: (IH _ Hys Hl)=> [y0 [Hy0 Hy0']]. + by exists y0; split=> //; right. +Qed. + +Lemma mapM_In' {aT bT eT} (f: aT -> result eT bT) (s: seq aT) (s': seq bT) y: + mapM f s = ok s' -> + List.In y s' -> exists2 x, List.In x s & f x = ok y. +Proof. +elim: s s'. ++ by move => _ [<-]. +move => a s ih s'' /=; t_xrbindP => b ok_b s' rec <- {s''} /=. +case. ++ by move=> <-; exists a => //; left. +by move => h; case: (ih _ rec h) => x hx ok_y; eauto. +Qed. + +Lemma mapM_map {aT bT cT eT} (f: aT → bT) (g: bT → result eT cT) (xs: seq aT) : + mapM g (map f xs) = mapM (g \o f) xs. +Proof. by elim: xs => // x xs ih /=; case: (g (f x)) => // y /=; rewrite ih. Qed. + +Lemma mapM_cat {eT aT bT} (f: aT → result eT bT) (s1 s2: seq aT) : + mapM f (s1 ++ s2) = Let r1 := mapM f s1 in Let r2 := mapM f s2 in ok (r1 ++ r2). +Proof. + elim: s1 s2; first by move => s /=; case (mapM f s). + move => a s1 ih s2 /=. + case: (f _) => // b; rewrite /= ih{ih}. + case: (mapM f s1) => // bs /=. + by case: (mapM f s2). +Qed. + +Corollary mapM_rcons {eT aT bT} (f: aT → result eT bT) (s: seq aT) (a: aT) : + mapM f (rcons s a) = Let r1 := mapM f s in Let r2 := f a in ok (rcons r1 r2). +Proof. by rewrite -cats1 mapM_cat /=; case: (f a) => // b; case: (mapM _ _) => // bs; rewrite /= cats1. Qed. + +Lemma mapM_Forall2 {eT aT bT} (f: aT → result eT bT) (s: seq aT) (s': seq bT) : + mapM f s = ok s' → + List.Forall2 (λ a b, f a = ok b) s s'. +Proof. + elim: s s'. + - by move => _ [] <-; constructor. + move => a s ih s'' /=; t_xrbindP => b ok_b s' /ih{ih}ih <-{s''}. + by constructor. +Qed. + +Lemma mapM_factorization {aT bT cT eT fT} (f: aT → result fT bT) (g: aT → result eT cT) (h: bT → result eT cT) xs ys: + (∀ a b, f a = ok b → g a = h b) → + mapM f xs = ok ys → + mapM g xs = mapM h ys. +Proof. + move => E. + elim: xs ys; first by case. + by move => x xs ih ys' /=; t_xrbindP => y /E -> ys /ih -> <-. +Qed. + +(* Lemma mapM_assoc {eT} {aT:eqType} {bT cT} (f : aT * bT -> result eT (aT * cT)) l1 l2 a b : *) +(* (forall x y, f x = ok y -> x.1 = y.1) -> *) +(* mapM f l1 = ok l2 -> *) +(* assoc l1 a = Some b -> *) +(* exists2 c, f (a, b) = ok (a, c) & assoc l2 a = Some c. *) +(* Proof. *) +(* move=> hfst. *) +(* elim: l1 l2 => //. *) +(* move=> [a' b'] l1 ih /=. *) +(* t_xrbindP=> _ [a'' c] h l2 /ih{ih}ih <- /=. *) +(* have /= ? := hfst _ _ h; subst a''. *) +(* case: eqP => [->|_]; last by apply ih. *) +(* move=> [<-]. *) +(* by exists c. *) +(* Qed. *) + +(* Lemma mapM_assoc' {eT} {aT:eqType} {bT cT} (f : aT * bT -> result eT (aT * cT)) l1 l2 a c : *) +(* (forall x y, f x = ok y -> x.1 = y.1) -> *) +(* mapM f l1 = ok l2 -> *) +(* assoc l2 a = Some c -> *) +(* exists2 b, f (a, b) = ok (a, c) & assoc l1 a = Some b. *) +(* Proof. *) +(* move=> hfst. *) +(* elim: l2 l1 => //. *) +(* move=> [a' c'] l2 ih [//|[a'' b] l1] /=. *) +(* t_xrbindP=> y h l2' hmap ??; subst y l2'. *) +(* have /= ? := hfst _ _ h; subst a''. *) +(* case: eqP => [->|_]; last by apply ih. *) +(* move=> [<-]. *) +(* by exists b. *) +(* Qed. *) + +(* Lemma mapM_take eT aT bT (f: aT → result eT bT) (xs: seq aT) ys n : *) +(* mapM f xs = ok ys → *) +(* mapM f (take n xs) = ok (take n ys). *) +(* Proof. *) +(* elim: xs ys n => [ | x xs hrec] ys n /=; first by move => /ok_inj<-. *) +(* t_xrbindP => y hy ys' /hrec h ?; subst ys; case: n; first by rewrite take0. *) +(* by move => n; rewrite /= (h n) /= hy. *) +(* Qed. *) + +(* Lemma mapM_ok {eT} {A B:Type} (f: A -> B) (l:list A) : *) +(* mapM (eT:=eT) (fun x => ok (f x)) l = ok (map f l). *) +(* Proof. by elim l => //= ?? ->. Qed. *) + +Section FOLDM. + + Context (eT aT bT:Type) (f:aT -> bT -> result eT bT). + + Fixpoint foldM (acc : bT) (l : seq aT) := + match l with + | [::] => Ok eT acc + | [:: a & la ] => f a acc >>= fun acc => foldM acc la + end. + + Fixpoint foldrM (acc : bT) (l : seq aT) := + match l with + | [::] => Ok eT acc + | [:: a & la ] => foldrM acc la >>= f a + end. + + Lemma foldM_cat acc l1 l2 : + foldM acc (l1 ++ l2) = + Let acc1 := foldM acc l1 in + foldM acc1 l2. + Proof. by elim: l1 acc => //= x l hrec acc; case: f. Qed. + +End FOLDM. + +Section FOLD2. + + Variable A B E R:Type. + Variable e: E. + Variable f : A -> B -> R -> result E R. + + Fixpoint fold2 (la:seq A) (lb: seq B) r := + match la, lb with + | [::] , [::] => Ok E r + | a::la, b::lb => + f a b r >>= (fold2 la lb) + | _ , _ => Error e + end. + + Lemma size_fold2 xs ys x0 v: + fold2 xs ys x0 = ok v -> size xs = size ys. + Proof. + by elim : xs ys x0 => [|x xs ih] [|y ys] x0 //= ; t_xrbindP => // t _ /ih ->. + Qed. + + Lemma cat_fold2 ha ta hb tb x v v' : + fold2 ha hb x = ok v -> fold2 ta tb v = ok v' -> + fold2 (ha ++ ta) (hb ++ tb) x = ok v'. + Proof. + elim: ha hb x v => [[] // > [<-] | > hrec []] //= >. + by t_xrbindP => ? -> /hrec{hrec}h/h{h}. + Qed. + +End FOLD2. + +(* ---------------------------------------------------------------- *) +(* ALLM *) +Section ALLM. + Context (A E: Type) (check: A → result E unit) (m: seq A). + Definition allM := foldM (λ a _, check a) tt m. + + Lemma allMP a : List.In a m → allM = ok tt → check a = ok tt. + Proof. + rewrite /allM. + by elim: m => // a' m' ih /= [ ->{a'} | /ih ]; t_xrbindP. + Qed. + +End ALLM. +Arguments allMP {A E check m a} _ _. + +(* Forall3 *) +(* -------------------------------------------------------------- *) + +Inductive Forall3 (A B C : Type) (R : A -> B -> C -> Prop) : seq A -> seq B -> seq C -> Prop := +| Forall3_nil : Forall3 R [::] [::] [::] +| Forall3_cons : forall a b c la lb lc, R a b c -> Forall3 R la lb lc -> Forall3 R (a :: la) (b :: lb) (c :: lc). + +Section MAP2. + + Variable A B E R:Type. + Variable e: E. + + Variable f : A -> B -> result E R. + + Fixpoint mapM2 (la:seq A) (lb: seq B) := + match la, lb with + | [::] , [::] => Ok E [::] + | a::la, b::lb => + Let c := f a b in + Let lc := mapM2 la lb in + ok (c::lc) + | _ , _ => Error e + end. + + Lemma size_mapM2 ma mb mr : + mapM2 ma mb = ok mr -> + size ma = size mb /\ size ma = size mr. + Proof. + elim: ma mb mr. + + by move=> [|//] _ [<-]. + move=> a ma ih [//|b mb] /=. + t_xrbindP=> _ r hf lr /ih{ih}ih <- /=. + by Lia.lia. + Qed. + + Lemma mapM2_Forall2 (P: R → B → Prop) ma mb mr : + (∀ a b r, List.In (a, b) (zip ma mb) → f a b = ok r → P r b) → + mapM2 ma mb = ok mr → + List.Forall2 P mr mb. + Proof. + elim: ma mb mr. + + move => [] // mr _ [<-]; constructor. + move => a ma ih [] // b mb mr' h /=; t_xrbindP => r ok_r mr rec <- {mr'}. + constructor. + + by apply: (h _ _ _ _ ok_r); left. + by apply: ih => // a' b' r' h' ok_r'; apply: (h a' b' r' _ ok_r'); right. + Qed. + + Lemma mapM2_Forall3 ma mb mr : + mapM2 ma mb = ok mr -> + Forall3 (fun a b r => f a b = ok r) ma mb mr. + Proof. + elim: ma mb mr. + + by move=> [|//] [|//] _; constructor. + move=> a ma ih [//|b mb] /=. + t_xrbindP=> _ r h mr /ih{ih}ih <-. + by constructor. + Qed. + + Lemma cat_mapM2 ha ta hb tb hl tl : + mapM2 ha hb = ok hl -> mapM2 ta tb = ok tl -> + mapM2 (ha ++ ta) (hb ++ tb) = ok (hl ++ tl). + Proof. + elim: ha hb hl => [[]//?[<-]|> hrec []] //=. + by t_xrbindP=> > -> ? /hrec{hrec}hrec <- /hrec{hrec} ->. + Qed. + +End MAP2. + +Section FMAP. + + Context (A B C:Type) (f : A -> B -> A * C). + + Fixpoint fmap (a:A) (bs:seq B) : A * seq C := + match bs with + | [::] => (a, [::]) + | b::bs => + let (a, c) := f a b in + let (a, cs) := fmap a bs in + (a, c :: cs) + end. + +End FMAP. + +Definition fmapM {eT aT bT cT} (f : aT -> bT -> result eT (aT * cT)) : aT -> seq bT -> result eT (aT * seq cT) := + fix mapM a xs := + match xs with + | [::] => Ok eT (a, [::]) + | [:: x & xs] => + Let y := f a x in + Let ys := mapM y.1 xs in + Ok eT (ys.1, y.2 :: ys.2) + end. + +Definition fmapM2 {eT aT bT cT dT} (e:eT) (f : aT -> bT -> cT -> result eT (aT * dT)) : + aT -> seq bT -> seq cT -> result eT (aT * seq dT) := + fix mapM a lb lc := + match lb, lc with + | [::], [::] => Ok eT (a, [::]) + | [:: b & bs], [:: c & cs] => + Let y := f a b c in + Let ys := mapM y.1 bs cs in + Ok eT (ys.1, y.2 :: ys.2) + | _, _ => Error e + end. + +Lemma size_fmapM2 {eT aT bT cT dT} e (f : aT -> bT -> cT -> result eT (aT * dT)) a lb lc a2 ld : + fmapM2 e f a lb lc = ok (a2, ld) -> + size lb = size lc /\ size lb = size ld. +Proof. + elim: lb lc a a2 ld. + + by move=> [|//] _ _ _ [_ <-]. + move=> b lb ih [//|c lc] a /=. + t_xrbindP=> _ _ _ _ [_ ld] /ih{ih}ih _ <- /=. + by Lia.lia. +Qed. + +(* Forall and size *) +(* -------------------------------------------------------------- *) + +Lemma Forall2_size A B (R : A -> B -> Prop) la lb : + List.Forall2 R la lb -> size la = size lb. +Proof. by elim {la lb} => // a b la lb _ _ /= ->. Qed. + +Lemma Forall3_size A B C (R : A -> B -> C -> Prop) l1 l2 l3 : + Forall3 R l1 l2 l3 -> + size l1 = size l2 /\ size l1 = size l3. +Proof. by elim {l1 l2 l3} => // a b c l1 l2 l3 _ _ /= [<- <-]. Qed. + +(* Reasoning with Forall *) +(* -------------------------------------------------------------- *) + +Lemma Forall_nth A (R : A -> Prop) l : + List.Forall R l -> + forall d i, (i < size l)%nat -> R (nth d l i). +Proof. + elim {l} => // a l h _ ih d [//|i]. + by apply ih. +Qed. + +Lemma Forall2_nth A B (R : A -> B -> Prop) la lb : + List.Forall2 R la lb -> + forall a b i, (i < size la)%nat -> + R (nth a la i) (nth b lb i). +Proof. + elim {la lb} => // a b la lb h _ ih a0 b0 [//|i]. + by apply ih. +Qed. + +Lemma Forall2_forall A B (R : A -> B -> Prop) la lb : + List.Forall2 R la lb -> + forall a b, List.In (a, b) (zip la lb) -> + R a b. +Proof. + elim {la lb} => // a b la lb h _ ih a0 b0 /=. + case. + + by move=> [<- <-]. + by apply ih. +Qed. + +Lemma Forall2_impl A B (R1 R2 : A -> B -> Prop) : + (forall a b, R1 a b -> R2 a b) -> + forall la lb, + List.Forall2 R1 la lb -> + List.Forall2 R2 la lb. +Proof. by move=> himpl l1 l2; elim; eauto. Qed. + +Lemma Forall2_impl_in A B (R1 R2 : A -> B -> Prop) la lb : + (forall a b, List.In a la -> List.In b lb -> R1 a b -> R2 a b) -> + List.Forall2 R1 la lb -> + List.Forall2 R2 la lb. +Proof. + move=> himpl hforall. + elim: {la lb} hforall himpl. + + by constructor. + move=> a b la lb h _ ih himpl. + constructor. + + by apply himpl; [left; reflexivity..|]. + apply ih. + by move=> ?????; apply himpl; [right..|]. +Qed. + +Lemma Forall3_nth A B C (R : A -> B -> C -> Prop) la lb lc : + Forall3 R la lb lc -> + forall a b c i, + (i < size la)%nat -> + R (nth a la i) (nth b lb i) (nth c lc i). +Proof. + elim {la lb lc} => // a b c la lb lc hr _ ih a0 b0 c0 [//|i]. + by apply ih. +Qed. + +Lemma nth_Forall3 A B C (R : A -> B -> C -> Prop) la lb lc a b c: + size la = size lb -> size la = size lc -> + (forall i, (i < size la)%nat -> R (nth a la i) (nth b lb i) (nth c lc i)) -> + Forall3 R la lb lc. +Proof. + elim: la lb lc. + + by move=> [|//] [|//] _ _ _; constructor. + move=> a0 l1 ih [//|b0 l2] [//|c0 l3] [hsize1] [hsize2] h. + constructor. + + by apply (h 0%nat). + apply ih => //. + by move=> i; apply (h i.+1). +Qed. +Arguments nth_Forall3 [A B C R la lb lc]. + +Lemma Forall3_forall A B C (R : A -> B -> C -> Prop) la lb lc : + Forall3 R la lb lc -> + forall a b c, List.In (a, (b, c)) (zip la (zip lb lc)) -> R a b c. +Proof. + elim {la lb lc} => // a b c la lb lc h _ ih a0 b0 c0 /=. + case. + + by move=> [<- <- <-]. + by apply ih. +Qed. + +Lemma Forall3_impl A B C (R1 R2 : A -> B -> C -> Prop) : + (forall a b c, R1 a b c -> R2 a b c) -> + forall la lb lc, + Forall3 R1 la lb lc -> + Forall3 R2 la lb lc. +Proof. by move=> himpl l1 l2 l3; elim; eauto using Forall3. Qed. + +Lemma Forall3_impl_in A B C (R1 R2 : A -> B -> C -> Prop) la lb lc : + (forall a b c, List.In a la -> List.In b lb -> List.In c lc -> R1 a b c -> R2 a b c) -> + Forall3 R1 la lb lc -> + Forall3 R2 la lb lc. +Proof. + move=> himpl hforall. + elim: {la lb lc} hforall himpl. + + by constructor. + move=> a b c la lb lc h _ ih himpl. + constructor. + + by apply himpl; [left; reflexivity..|]. + apply ih. + by move=> ???????; apply himpl; [right..|]. +Qed. + +(* Inversion lemmas *) +(* -------------------------------------------------------------- *) +Lemma seq_eq_injL A (m n: seq A) (h: m = n) : + match m with + | [::] => if n is [::] then True else False + | a :: m' => if n is b :: n' then a = b ∧ m' = n' else False + end. +Proof. by subst n; case: m. Qed. + +Lemma List_Forall_inv A (P: A → Prop) m : + List.Forall P m → + match m with [::] => True | x :: m' => P x ∧ List.Forall P m' end. +Proof. by case. Qed. + +Lemma List_Forall2_refl A (R:A->A->Prop) l : (forall a, R a a) -> List.Forall2 R l l. +Proof. by move=> HR;elim: l => // a l Hrec;constructor. Qed. + +Lemma List_Forall2_inv_l A B (R: A → B → Prop) m n : + List.Forall2 R m n → + match m with + | [::] => n = [::] + | a :: m' => ∃ b n', n = b :: n' ∧ R a b ∧ List.Forall2 R m' n' + end. +Proof. case; eauto. Qed. + +Lemma List_Forall2_inv_r A B (R: A → B → Prop) m n : + List.Forall2 R m n → + match n with + | [::] => m = [::] + | b :: n' => ∃ a m', m = a :: m' ∧ R a b ∧ List.Forall2 R m' n' + end. +Proof. case; eauto. Qed. + +Lemma List_Forall2_inv A B (R: A → B → Prop) m n : + List.Forall2 R m n → + if m is a :: m' then if n is b :: n' then R a b ∧ List.Forall2 R m' n' else False else if n is [::] then True else False. +Proof. case; auto. Qed. + +Lemma List_Forall3_inv A B C (R : A -> B -> C -> Prop) l1 l2 l3 : + Forall3 R l1 l2 l3 -> + match l1, l2, l3 with + | [::], [::], [::] => True + | a :: l1, b :: l2, c :: l3 => R a b c /\ Forall3 R l1 l2 l3 + | _, _, _ => False + end. +Proof. by case. Qed. + +Section Subseq. + + Context (T : eqType). + Context (p : T -> bool). + + Lemma subseq_has s1 s2 : subseq s1 s2 -> has p s1 -> has p s2. + Proof. + move=> /mem_subseq hsub /hasP [x /hsub hin hp]. + apply /hasP. + by exists x. + Qed. + + Lemma subseq_all s1 s2 : subseq s1 s2 -> all p s2 -> all p s1. + Proof. + move=> /mem_subseq hsub /allP hall. + by apply /allP => x /hsub /hall. + Qed. + +End Subseq. + +Section All2. + +Section DifferentTypes. + + Context (S T : Type). + Context (p : S -> T -> bool). + + Lemma all2P l1 l2 : reflect (List.Forall2 p l1 l2) (all2 p l1 l2). + Proof. + elim: l1 l2 => [ | a l1 hrec] [ | b l2] /=;try constructor. + + by constructor. + + by move/List_Forall2_inv_l. + + by move/List_Forall2_inv_r. + apply: equivP;first apply /andP. + split => [[]h1 /hrec h2 |];first by constructor. + by case/List_Forall2_inv_l => b' [n] [] [-> ->] [->] /hrec. + Qed. + + Section Ind. + + Context (P : list S -> list T -> Prop). + + Lemma list_all2_ind : + P [::] [::] -> + (forall x1 l1 x2 l2, p x1 x2 -> all2 p l1 l2 -> P l1 l2 -> P (x1::l1) (x2::l2)) -> + forall l1 l2, all2 p l1 l2 -> P l1 l2. + Proof. + move=> hnil hcons; elim => /=; first by case. + move=> x1 l1 ih [//|x2 l2] /andP [hf hall2]. + by apply hcons => //; apply ih. + Qed. + + End Ind. + + Lemma all2_nth s t n ss ts : + (n < size ss)%nat || (n < size ts)%nat -> + all2 p ss ts -> + p (nth s ss n) (nth t ts n). + Proof. + move=> hn; rewrite all2E => /andP [] /eqP hsz. + move: hn; rewrite -hsz orbb => hn. + move=> /(all_nthP (s, t)) -/(_ n). + by rewrite size_zip -hsz minnn nth_zip //; apply. + Qed. + +End DifferentTypes. + +Section SameType. + + Context (T : Type). + + Section AnyRelation. + + Context (p : rel T). + + Lemma all2_refl : ssrbool.reflexive p -> ssrbool.reflexive (all2 p). + Proof. + move=> hrefl. + by elim=> //= a l ih; apply /andP. + Qed. + + Lemma all2_trans : ssrbool.transitive p -> ssrbool.transitive (all2 p). + Proof. + move=> htrans s1 s2 s3 hall2; move: hall2 s3. + elim/list_all2_ind {s1 s2} => //= x1 s1 x2 s2 hp12 _ ih [//|x3 s3] /andP [hp23 hall2]. + by apply /andP; eauto. + Qed. + + End AnyRelation. + + Section Eqb. + + Variable eqb: T -> T -> bool. + Variable Heq : forall (x y:T), reflect (x = y) (eqb x y). + + Lemma reflect_all2_eqb l1 l2 : reflect (l1 = l2) (all2 eqb l1 l2). + Proof. + elim: l1 l2 => [|e1 l1 Hrec1] [|e2 l2] /=; try by constructor. + by apply (iffP andP) => -[] /Heq -> /Hrec1 ->. + Defined. + + End Eqb. + +End SameType. + +End All2. + +Section Map2. + + Context (A B C : Type) (f : A -> B -> C). + + Fixpoint map2 la lb := + match la, lb with + | a::la, b::lb => f a b :: map2 la lb + | _, _ => [::] + end. + + Lemma map2E ma mb : + map2 ma mb = map (λ ab, f ab.1 ab.2) (zip ma mb). + Proof. + elim: ma mb; first by case. + by move => a ma ih [] // b mb /=; f_equal. + Qed. + +End Map2. + +Section Map3. + + Context (A B C D : Type) (f : A -> B -> C -> D). + + Fixpoint map3 ma mb mc := + match ma, mb, mc with + | a :: ma', b :: mb', c :: mc' => f a b c :: map3 ma' mb' mc' + | _, _, _ => [::] + end. + + Lemma map3E ma mb mc : + map3 ma mb mc = map2 (λ ab, f ab.1 ab.2) (zip ma mb) mc. + Proof. + elim: ma mb mc; first by case. + by move => a ma ih [] // b mb [] // c mc /=; f_equal. + Qed. + +End Map3. + +Section MAPI. + + Context (A : Type) (a : A) (B:Type) (b : B) (f : nat -> A -> B). + + Fixpoint mapi_aux k l := + match l with + | [::] => [::] + | a::l=> f k a :: mapi_aux k.+1 l + end. + + Definition mapi := mapi_aux 0. + + Lemma size_mapi_aux k l : size (mapi_aux k l) = size l. + Proof. + elim: l k => //= a' l ih k. + by rewrite ih. + Qed. + + Lemma size_mapi l : size (mapi l) = size l. + Proof. exact: size_mapi_aux. Qed. + + Lemma nth_mapi_aux n k l : + (n < size l)%nat -> nth b (mapi_aux k l) n = f (k+n) (nth a l n). + Proof. + elim: l n k => //= a' l ih n k hlt. + case: n hlt => /=. + + by move=> _; rewrite addn0. + by move=> n hlt; rewrite ih // addSnnS. + Qed. + + Lemma nth_mapi n l : + (n < size l)%nat -> nth b (mapi l) n = f n (nth a l n). + Proof. exact: nth_mapi_aux. Qed. + +End MAPI. + +Section FIND_MAP. + +(* The name comes from OCaml. *) +Fixpoint find_map {A B: Type} (f: A → option B) l := + match l with + | [::] => None + | a::l => + let fa := f a in + if fa is None then find_map f l else fa + end. + +Lemma find_map_correct {A: eqType} {B: Type} {f: A → option B} {l b} : + find_map f l = Some b -> exists2 a, a \in l & f a = Some b. +Proof. + elim: l => //= a l ih. + case heq: (f a) => [b'|]. + + by move=> [<-]; exists a => //; rewrite mem_head. + move=> /ih [a' h1 h2]; exists a'=> //. + by rewrite in_cons; apply /orP; right. +Qed. + +End FIND_MAP. + +(* ** Misc functions + * -------------------------------------------------------------------- *) + +Definition isSome aT (o : option aT) := + if o is Some _ then true else false. + +(* Lemma isSome_obind (aT bT: Type) (f: aT → option bT) (o: option aT) : *) +(* reflect (exists2 a, o = Some a & isSome (f a)) (isSome (o >>= f)%O). *) +(* Proof. *) +(* apply: Bool.iff_reflect; split. *) +(* - by case => a ->. *) +(* by case: o => // a h; exists a. *) +(* Qed. *) + +Definition omap_dflt {aT bT} (d : bT) (f : aT -> bT) (oa : option aT) := + if oa is Some x then f x else d. + +Fixpoint list_to_rev (ub : nat) := + match ub with + | O => [::] + | x.+1 => [:: x & list_to_rev x ] + end. + +Definition list_to ub := rev (list_to_rev ub). + +Lemma Forall2_trans (A B C:Type) l2 (R1:A->B->Prop) (R2:B->C->Prop) + l1 l3 (R3:A->C->Prop) : + (forall b a c, R1 a b -> R2 b c -> R3 a c) -> + List.Forall2 R1 l1 l2 -> + List.Forall2 R2 l2 l3 -> + List.Forall2 R3 l1 l3. +Proof. + move=> H hr1;elim: hr1 l3 => {l1 l2} [ | a b l1 l2 hr1 _ hrec] l3 /List_Forall2_inv_l. + + by move => ->. + by case => ? [?] [->] [??]; constructor; eauto. +Qed. + +Definition conc_map aT bT (f : aT -> seq bT) (l : seq aT) := + flatten (map f l). + +(* -------------------------------------------------------------------------- *) +(* Operators to build comparison *) +(* ---------------------------------------------------------------------------*) + +Section CTRANS. + + Definition ctrans c1 c2 := nosimpl ( + match c1, c2 with + | Eq, _ => Some c2 + | _ , Eq => Some c1 + | Lt, Lt => Some Lt + | Gt, Gt => Some Gt + | _ , _ => None + end). + + Lemma ctransI c : ctrans c c = Some c. + Proof. by case: c. Qed. + + Lemma ctransC c1 c2 : ctrans c1 c2 = ctrans c2 c1. + Proof. by case: c1 c2 => -[]. Qed. + + Lemma ctrans_Eq c1 c2 : ctrans Eq c1 = Some c2 <-> c1 = c2. + Proof. by rewrite /ctrans;case:c1=> //=;split=>[[]|->]. Qed. + + Lemma ctrans_Lt c1 c2 : ctrans Lt c1 = Some c2 -> Lt = c2. + Proof. by rewrite /ctrans;case:c1=> //= -[] <-. Qed. + + Lemma ctrans_Gt c1 c2 : ctrans Gt c1 = Some c2 -> Gt = c2. + Proof. by rewrite /ctrans;case:c1=> //= -[] <-. Qed. + +End CTRANS. + +Notation Lex u v := + match u with + | Lt => Lt + | Eq => v + | Gt => Gt + end. + +(* -------------------------------------------------------------------- *) + +Scheme Equality for comparison. + +Lemma comparison_beqP : Equality.axiom comparison_beq. +Proof. + exact: + (eq_axiom_of_scheme internal_comparison_dec_bl internal_comparison_dec_lb). +Qed. + +HB.instance Definition _ := hasDecEq.Build comparison comparison_beqP. + +(* -------------------------------------------------------------------- *) + +Class Cmp {T:Type} (cmp:T -> T -> comparison) := { + cmp_sym : forall x y, cmp x y = CompOpp (cmp y x); + cmp_ctrans : forall y x z c, ctrans (cmp x y) (cmp y z) = Some c -> cmp x z = c; + cmp_eq : forall {x y}, cmp x y = Eq -> x = y; + }. + +Definition gcmp {T:Type} {cmp:T -> T -> comparison} {C:Cmp cmp} := cmp. + +Section CMP. + + Context {T:Type} {cmp:T -> T -> comparison} {C:Cmp cmp}. + + Lemma cmp_trans y x z c: + cmp x y = c -> cmp y z = c -> cmp x z = c. + Proof. + by move=> H1 H2;apply (@cmp_ctrans _ _ C y);rewrite H1 H2 ctransI. + Qed. + + Lemma cmp_refl x : cmp x x = Eq. + Proof. by have := @cmp_sym _ _ C x x;case: (cmp x x). Qed. + + Definition cmp_lt x1 x2 := gcmp x1 x2 == Lt. + + Definition cmp_le x1 x2 := gcmp x2 x1 != Lt. + + Lemma cmp_le_refl x : cmp_le x x. + Proof. by rewrite /cmp_le /gcmp cmp_refl. Qed. + + Lemma cmp_lt_trans y x z : cmp_lt x y -> cmp_lt y z -> cmp_lt x z. + Proof. + rewrite /cmp_lt /gcmp => /eqP h1 /eqP h2;apply /eqP;apply (@cmp_ctrans _ _ C y). + by rewrite h1 h2. + Qed. + + Lemma cmp_le_trans y x z : cmp_le x y -> cmp_le y z -> cmp_le x z. + Proof. + rewrite /cmp_le /gcmp => h1 h2;have := (@cmp_ctrans _ _ C y z x). + by case: cmp h1 => // _;case: cmp h2 => //= _;rewrite /ctrans => /(_ _ erefl) ->. + Qed. + + Lemma cmp_nle_lt x y: ~~ (cmp_le x y) = cmp_lt y x. + Proof. by rewrite /cmp_le /cmp_lt /gcmp Bool.negb_involutive. Qed. + + Lemma cmp_nlt_le x y: ~~ (cmp_lt x y) = cmp_le y x. + Proof. done. Qed. + + Lemma cmp_lt_le_trans y x z: cmp_lt x y -> cmp_le y z -> cmp_lt x z. + Proof. + rewrite /cmp_le /cmp_lt /gcmp (cmp_sym z) => h1 h2. + have := (@cmp_ctrans _ _ C y x z). + by case: cmp h1 => // _;case: cmp h2 => //= _;rewrite /ctrans => /(_ _ erefl) ->. + Qed. + + Lemma cmp_le_lt_trans y x z: cmp_le x y -> cmp_lt y z -> cmp_lt x z. + Proof. + rewrite /cmp_le /cmp_lt /gcmp (cmp_sym y) => h1 h2. + have := (@cmp_ctrans _ _ C y x z). + by case: cmp h1 => // _;case: cmp h2 => //= _;rewrite /ctrans => /(_ _ erefl) ->. + Qed. + + Lemma cmp_lt_le x y : cmp_lt x y -> cmp_le x y. + Proof. + rewrite /cmp_lt /cmp_le /gcmp => /eqP h. + by rewrite cmp_sym h. + Qed. + + Lemma cmp_nle_le x y : ~~ (cmp_le x y) -> cmp_le y x. + Proof. by rewrite cmp_nle_lt; apply: cmp_lt_le. Qed. + +End CMP. + +Declare Scope cmp_scope. +Notation "m < n" := (cmp_lt m n) : cmp_scope. +Notation "m <= n" := (cmp_le m n) : cmp_scope. +Notation "m ≤ n" := (cmp_le m n) : cmp_scope. +Delimit Scope cmp_scope with CMP. + +#[global] +Hint Resolve cmp_le_refl : core. + +Section EqCMP. + + Context {T:eqType} {cmp:T -> T -> comparison} {C:Cmp cmp}. + + Lemma cmp_le_eq_lt (s1 s2:T): cmp_le s1 s2 = cmp_lt s1 s2 || (s1 == s2). + Proof. + rewrite /cmp_le /cmp_lt cmp_sym /gcmp. + case heq: cmp => //=. + + by rewrite (cmp_eq heq) eqxx. + case: eqP => // ?;subst. + by rewrite cmp_refl in heq. + Qed. + + Lemma cmp_le_antisym x y : + cmp_le x y → cmp_le y x → x = y. + Proof. + by rewrite -cmp_nlt_le (cmp_le_eq_lt y) => /negbTE -> /eqP. + Qed. + +End EqCMP. + +Section LEX. + + Variables (T1 T2:Type) (cmp1:T1 -> T1 -> comparison) (cmp2:T2 -> T2 -> comparison). + + Definition lex x y := Lex (cmp1 x.1 y.1) (cmp2 x.2 y.2). + + Lemma Lex_lex x1 x2 y1 y2 : Lex (cmp1 x1 y1) (cmp2 x2 y2) = lex (x1,x2) (y1,y2). + Proof. done. Qed. + + Lemma lex_sym x y : + cmp1 x.1 y.1 = CompOpp (cmp1 y.1 x.1) -> + cmp2 x.2 y.2 = CompOpp (cmp2 y.2 x.2) -> + lex x y = CompOpp (lex y x). + Proof. + by move=> H1 H2;rewrite /lex H1;case: cmp1=> //=;apply H2. + Qed. + + Lemma lex_trans y x z: + (forall c, ctrans (cmp1 x.1 y.1) (cmp1 y.1 z.1) = Some c -> cmp1 x.1 z.1 = c) -> + (forall c, ctrans (cmp2 x.2 y.2) (cmp2 y.2 z.2) = Some c -> cmp2 x.2 z.2 = c) -> + forall c, ctrans (lex x y) (lex y z) = Some c -> lex x z = c. + Proof. + rewrite /lex=> Hr1 Hr2 c;case: cmp1 Hr1. + + move=> H;rewrite (H (cmp1 y.1 z.1));last by rewrite ctrans_Eq. + (case: cmp1;first by apply Hr2); + rewrite ctransC; [apply ctrans_Lt | apply ctrans_Gt]. + + move=> H1 H2;rewrite (H1 Lt);move:H2;first by apply: ctrans_Lt. + by case: cmp1. + move=> H1 H2;rewrite (H1 Gt);move:H2;first by apply: ctrans_Gt. + by case: cmp1. + Qed. + + Lemma lex_eq x y : + lex x y = Eq -> cmp1 x.1 y.1 = Eq /\ cmp2 x.2 y.2 = Eq. + Proof. + case: x y => [x1 x2] [y1 y2] /=. + by rewrite /lex;case:cmp1 => //;case:cmp2. + Qed. + + Lemma LexO (C1:Cmp cmp1) (C2:Cmp cmp2) : Cmp lex. + Proof. + constructor=> [x y | y x z | x y]. + + by apply /lex_sym;apply /cmp_sym. + + by apply /lex_trans;apply /cmp_ctrans. + by case: x y => ?? [??] /lex_eq /= [] /(@cmp_eq _ _ C1) -> /(@cmp_eq _ _ C2) ->. + Qed. + +End LEX. + +Section MIN. + Context T (cmp: T → T → comparison) (O: Cmp cmp). + Definition cmp_min (x y: T) : T := + if (x ≤ y)%CMP then x else y. + + Lemma cmp_minP x y (P: T → Prop) : + ((x ≤ y)%CMP → P x) → + ((y < x)%CMP → P y) → + P (cmp_min x y). + Proof. + rewrite /cmp_min; case: ifP. + - by move => _ /(_ erefl). + by rewrite -cmp_nle_lt => -> _ /(_ erefl). + Qed. + + Lemma cmp_min_leL x y : + (cmp_min x y ≤ x)%CMP. + Proof. + apply: (@cmp_minP x y (λ z, z ≤ x)%CMP) => //. + apply: cmp_lt_le. + Qed. + + Lemma cmp_min_leR x y : + (cmp_min x y ≤ y)%CMP. + Proof. exact: (@cmp_minP x y (λ z, z ≤ y)%CMP). Qed. + + Lemma cmp_le_min x y : + (x ≤ y)%CMP → cmp_min x y = x. + Proof. by rewrite /cmp_min => ->. Qed. + +End MIN. + +Arguments cmp_min {T cmp O} x y. + +Section MAX. + Context T (cmp: T → T → comparison) (O: Cmp cmp). + Definition cmp_max (x y: T) : T := + if (x ≤ y)%CMP then y else x. + + Lemma cmp_maxP x y (P: T → Prop) : + ((x ≤ y)%CMP → P y) → + ((y < x)%CMP → P x) → + P (cmp_max x y). + Proof. + rewrite /cmp_max; case: ifP. + - by move => _ /(_ erefl). + by rewrite -cmp_nle_lt => -> _ /(_ erefl). + Qed. + + Lemma cmp_max_geL x y : + (x <= cmp_max x y)%CMP. + Proof. exact: (@cmp_maxP x y (λ z, x ≤ z)%CMP). Qed. + + Lemma cmp_max_geR x y : + (y <= cmp_max x y)%CMP. + Proof. + apply: (@cmp_maxP x y (λ z, y ≤ z)%CMP) => //. + apply: cmp_lt_le. + Qed. + + Lemma cmp_le_max x y : + (x ≤ y)%CMP → cmp_max x y = y. + Proof. by rewrite /cmp_max => ->. Qed. + +End MAX. + +Arguments cmp_max {T cmp O} x y. + +Definition bool_cmp b1 b2 := + match b1, b2 with + | false, true => Lt + | false, false => Eq + | true , true => Eq + | true , false => Gt + end. + +#[global] +Instance boolO : Cmp bool_cmp. +Proof. + constructor=> [[] [] | [] [] [] c | [] []] //=; apply ctrans_Eq. +Qed. + +#[global] +Polymorphic Instance subrelation_iff_flip_arrow : subrelation iffT (flip arrow). +Proof. by move=> ?? []. Qed. + +#[global] +Instance reflect_m: Proper (iff ==> (@eq bool) ==> iffT) reflect. +Proof. by move=> P1 P2 Hiff b1 b2 ->; split=> H; apply (equivP H);rewrite Hiff. Qed. + +Coercion Zpos : positive >-> Z. + +Lemma P_leP (x y:positive) : reflect (x <= y)%Z (x <=? y)%positive. +Proof. apply: (@equivP (Pos.le x y)) => //;rewrite -Pos.leb_le;apply idP. Qed. + +Lemma P_ltP (x y:positive) : reflect (x < y)%Z (x //;rewrite -Pos.ltb_lt;apply idP. Qed. + +Lemma Pos_leb_trans y x z: + (x <=? y)%positive -> (y <=? z)%positive -> (x <=? z)%positive. +Proof. move=> /P_leP ? /P_leP ?;apply /P_leP; Lia.lia. Qed. + +Lemma Pos_lt_leb_trans y x z: + (x (y <=? z)%positive -> (x /P_ltP ? /P_leP ?;apply /P_ltP; Lia.lia. Qed. + +Lemma pos_eqP : Equality.axiom Pos.eqb. +Proof. by move=> p1 p2;apply:(iffP idP);rewrite -Pos.eqb_eq. Qed. + +HB.instance Definition _ := hasDecEq.Build positive pos_eqP. + +#[global] +Instance positiveO : Cmp Pos.compare. +Proof. + constructor. + + by move=> ??;rewrite Pos.compare_antisym. + + move=> ????;case:Pos.compare_spec=> [->|H1|H1]; + case:Pos.compare_spec=> H2 //= -[] <- //;subst; + rewrite ?Pos.compare_lt_iff ?Pos.compare_gt_iff //. + + by apply: Pos.lt_trans H1 H2. + by apply: Pos.lt_trans H2 H1. + apply Pos.compare_eq. +Qed. + +#[global] +Instance ZO : Cmp Z.compare. +Proof. + constructor. + + by move=> ??;rewrite Z.compare_antisym. + + move=> ????;case:Z.compare_spec=> [->|H1|H1]; + case:Z.compare_spec=> H2 //= -[] <- //;subst; + rewrite ?Z.compare_lt_iff ?Z.compare_gt_iff //. + + by apply: Z.lt_trans H1 H2. + by apply: Z.lt_trans H2 H1. + apply Z.compare_eq. +Qed. + +Lemma Z_to_nat_le0 z : z <= 0 -> Z.to_nat z = 0%N. +Proof. by rewrite /Z.to_nat; case: z => //=; rewrite /Z.le. Qed. + +Lemma Z_odd_pow_2 n x : + (0 < n)%Z + -> Z.odd (2 ^ n * x) = false. +Proof. + move=> hn. + rewrite Z.odd_mul. + by rewrite (Z.odd_pow _ _ hn). +Qed. + +(* ** Some Extra tactics + * -------------------------------------------------------------------- *) + +(* -------------------------------------------------------------------- *) +Variant dup_spec (P : Prop) := +| Dup of P & P. + +Lemma dup (P : Prop) : P -> dup_spec P. +Proof. by move=> ?; split. Qed. + +(* -------------------------------------------------------------------- *) +Definition ZleP : ∀ x y, reflect (x <= y) (x <=? y) := Z.leb_spec0. +Definition ZltP : ∀ x y, reflect (x < y) (x /leP /Nat2Z.inj_le. + all: by constructor. +Qed. + +Lemma ZNltP x y : + reflect (Z.of_nat x < Z.of_nat y)%Z (x < y). +Proof. + case h: (x < y). + all: move: h => /ZNleP. + all: rewrite Nat2Z.inj_succ. + all: move=> /Z.le_succ_l. + all: by constructor. +Qed. + +Lemma lt_nm_n n m : + n + m < n = false. +Proof. + rewrite -{2}(addn0 n). + rewrite ltn_add2l. + exact: ltn0. +Qed. + +Lemma sub_nmn n m : + n + m - n = m. +Proof. + elim: n => //. + by rewrite add0n subn0. +Qed. + +End NAT. + +(* ------------------------------------------------------------------------- *) + +Lemma rwR1 (A:Type) (P:A->Prop) (f:A -> bool) : + (forall a, reflect (P a) (f a)) -> + forall a, (f a) <-> (P a). +Proof. by move=> h a; rewrite (rwP (h _)). Qed. + +Lemma rwR2 (A B:Type) (P:A->B->Prop) (f:A -> B -> bool) : + (forall a b, reflect (P a b) (f a b)) -> + forall a b, (f a b) <-> (P a b). +Proof. by move=> h a b; rewrite (rwP (h _ _)). Qed. + +Notation pify := + (rwR2 (@andP), rwR2 (@orP), rwR2 (@implyP), rwR1 (@forallP _), rwR1 (@negP)). + +Lemma Zcmp_le i1 i2 : (i1 <= i2)%CMP = (i1 <=? i2)%Z. +Proof. + rewrite /cmp_le /gcmp /Z.leb -Zcompare_antisym. + by case: Z.compare. +Qed. + +Lemma Zcmp_lt i1 i2 : (i1 < i2)%CMP = (i1 // p; red; Lia.lia. Qed. + +Fixpoint ziota_rec (first z: Z) (H: Acc (Zwf 0) z) : seq Z := + let: Acc_intro REC := H in + match z as z' return (∀ x : Z, Zwf 0 x z' → @Acc Z (Zwf 0) x) -> Zwf0_pred_t z' -> seq Z with + | Zpos p => λ REC h, first :: ziota_rec (Z.succ first) (REC (Z.pred p) h) + | _ => λ _ _, [::] + end REC (Zwf0_pred z). + +Definition ziota p z : seq Z := + ziota_rec p (Acc_intro_generator 2 (Zwf_well_founded 0) z). + +Fixpoint ziota_recP p z H : + @ziota_rec p z H = [seq p + Z.of_nat i | i <- iota 0 (Z.to_nat z)]. +Proof. + case: H => REC. + rewrite /ziota_rec. + case: z REC => // z' REC. + rewrite -/(@ziota_rec (Z.succ p) (Z.pred z')). + have -> : Z.to_nat z' = (Z.to_nat (Z.pred z')).+1 by Lia.lia. + rewrite map_cons -/(iota _ _) Z.add_0_r; congr (_ :: _). + rewrite (iotaDl 1) -map_comp. + rewrite ziota_recP. + apply: eq_map => i /=. + Lia.lia. +Qed. + +Lemma ziotaE p z : + ziota p z = [seq p + Z.of_nat i | i <- iota 0 (Z.to_nat z)]. +Proof. exact: ziota_recP. Qed. + +Lemma ziota0 p : ziota p 0 = [::]. +Proof. done. Qed. + +Lemma ziota_neg p z: z <= 0 -> ziota p z = [::]. +Proof. by case: z. Qed. + +Lemma ziotaS_cons p z: 0 <= z -> ziota p (Z.succ z) = p :: ziota (p+1) z. +Proof. + rewrite !ziotaE. + move=> hz;rewrite /ziota Z2Nat.inj_succ //= Z.add_0_r; f_equal. + rewrite -addn1 addnC iotaDl -map_comp. + by apply eq_map => i /=; rewrite Zpos_P_of_succ_nat; Lia.lia. +Qed. + +Lemma ziotaS_cat p z: 0 <= z -> ziota p (Z.succ z) = ziota p z ++ [:: p + z]. +Proof. + rewrite !ziotaE. + by move=> hz;rewrite Z2Nat.inj_succ // -addn1 iotaD map_cat /= add0n Z2Nat.id. +Qed. + +Lemma ziota_cat p y z: 0 <= y -> 0 <= z -> + ziota p y ++ ziota (p + y) z = ziota p (y + z). +Proof. + move=> ? /Z2Nat.id <-; elim: (Z.to_nat _). + + by rewrite Z.add_0_r /= cats0. + move=> ? hrw; rewrite Nat2Z.inj_succ Z.add_succ_r !ziotaS_cat; last 2 first. + + exact: (Ztac.add_le _ _ _ (Zle_0_nat _)). + + exact: Zle_0_nat. + by rewrite catA hrw Z.add_assoc. +Qed. + +Lemma in_ziota (p z i:Z) : (i \in ziota p z) = ((p <=? i) && (i hz. + + move: p; pattern z; apply natlike_ind => [ p | {z hz} z hz hrec p| //]. + + by rewrite ziota0 in_nil; case: andP => // -[/ZleP ? /ZltP ?]; Lia.lia. + rewrite ziotaS_cons // in_cons; case: eqP => [-> | ?] /=. + + by rewrite Z.leb_refl /=; symmetry; apply /ZltP; Lia.lia. + by rewrite hrec; apply Bool.eq_iff_eq_true;split=> /andP [/ZleP ? /ZltP ?]; + (apply /andP;split;[apply /ZleP| apply /ZltP]); Lia.lia. + rewrite ziota_neg;last Lia.lia. + rewrite in_nil;symmetry;apply /negP => /andP [/ZleP ? /ZltP ?]; Lia.lia. +Qed. + +Lemma size_ziota p z: size (ziota p z) = Z.to_nat z. +Proof. by rewrite ziotaE size_map size_iota. Qed. + +Lemma nth_ziota p (i:nat) z : leq (S i) (Z.to_nat z) -> + nth 0%Z (ziota p z) i = (p + Z.of_nat i)%Z. +Proof. + by move=> hi; rewrite ziotaE (nth_map O) ?size_iota // nth_iota. +Qed. + +Lemma list_all_ind (Q : Z -> bool) (P : list Z -> Prop): + P [::] -> + (forall i l, Q i -> all Q l -> P l -> P (i::l))-> + (forall l, all Q l -> P l). +Proof. + move=> hnil hcons; elim => //= a l hrec /andP [hQ hall]. + by apply hcons => //; apply hrec. +Qed. + +Lemma ziota_ind (P : list Z -> Prop) p1 p2: + P [::] -> + (forall i l, p1 <= i < p1 + p2 -> P l -> P (i::l))-> + P (ziota p1 p2). +Proof. + move=> hnil hcons. + have: all (fun i => (p1 <=? i) && (i i; rewrite in_ziota !zify. + by elim/list_all_ind => // i l; rewrite !zify => *;apply hcons. +Qed. + +Lemma all_ziota p1 p2 (f1 f2: Z -> bool) : + (forall i, (p1 <= i < p1 + p2)%Z -> f1 i = f2 i) -> + all f1 (ziota p1 p2) = all f2 (ziota p1 p2). +Proof. by move => h; apply ziota_ind => //= i l /h -> ->. Qed. + +Lemma ziota_shift i p : ziota i p = map (fun k => i + k)%Z (ziota 0 p). +Proof. by rewrite !ziotaE -map_comp /comp. Qed. + +Section ZNTH. + Context {A: Type} (dfl: A). + + Fixpoint pnth (m: list A) (p: positive) := + match m with + | [::] => dfl + | a :: m => + match p with + | 1 => a + | q~1 => pnth m q~0 + | q~0 => pnth m (Pos.pred_double q) + end%positive + end. + + Definition znth m (z: Z) : A := + if m is a :: m then + match z with + | Z0 => a + | Zpos p => pnth m p + | Zneg _ => dfl + end + else dfl. + +End ZNTH. + +(* Warning : this is not efficient, it should be used only for proof *) +Definition zindex (T:eqType) (t:T) l := + Z.of_nat (seq.index t l). + +Lemma znthE (A:Type) dfl (l:list A) i : + (0 <= i)%Z -> + znth dfl l i = nth dfl l (Z.to_nat i). +Proof. + case: l; first by rewrite nth_nil. + case: i => // p a m _. + elim/Pos.peano_ind: p a m; first by move => ? []. + move => p /= ih a; rewrite Pos2Nat.inj_succ /=. + case; first by rewrite nth_nil. + move => /= b m. + by case: Pos.succ (Pos.succ_not_1 p) (Pos.pred_succ p) => // _ _ /= ->. +Qed. + +Lemma mem_znth (A:eqType) dfl (l:list A) i : + [&& 0 <=? i & i + znth dfl l i \in l. +Proof. + move=> /andP []/ZleP h0i /ZltP hi. + by rewrite znthE //; apply/mem_nth/ZNltP; rewrite Z2Nat.id. +Qed. + +Lemma znth_index (T : eqType) (x0 x : T) (s : seq T): + x \in s → znth x0 s (zindex x s) = x. +Proof. + move=> hin; rewrite /zindex znthE; last by apply Zle_0_nat. + by rewrite Nat2Z.id nth_index. +Qed. + +(* ------------------------------------------------------------------------- *) +Lemma sumbool_of_boolET (b: bool) (h: b) : + Sumbool.sumbool_of_bool b = left h. +Proof. by move: h; rewrite /is_true => ?; subst. Qed. + +Lemma sumbool_of_boolEF (b: bool) (h: b = false) : + Sumbool.sumbool_of_bool b = right h. +Proof. by move: h; rewrite /is_true => ?; subst. Qed. + + +(* ------------------------------------------------------------------------- *) + +Definition lprod ts tr := + foldr (fun t tr => t -> tr) tr ts. + +Fixpoint ltuple (ts:list Type) : Type := + match ts with + | [::] => unit + | [::t1] => t1 + | t1::ts => t1 * ltuple ts + end. + +Notation "(:: x , .. , y & z )" := (pair x .. (pair y z) ..) (only parsing). + +Fixpoint merge_tuple (l1 l2: list Type) : ltuple l1 -> ltuple l2 -> ltuple (l1 ++ l2) := + match l1 return ltuple l1 -> ltuple l2 -> ltuple (l1 ++ l2) with + | [::] => fun _ p => p + | t1 :: l1 => + let rec := @merge_tuple l1 l2 in + match l1 return (ltuple l1 -> ltuple l2 -> ltuple (l1 ++ l2)) -> + ltuple (t1::l1) -> ltuple l2 -> ltuple (t1 :: l1 ++ l2) with + | [::] => fun _ (x:t1) => + match l2 return ltuple l2 -> ltuple (t1::l2) with + | [::] => fun _ => x + | t2::l2 => fun (p:ltuple (t2::l2)) => (x, p) + end + | t1' :: l1' => fun rec (x:t1 * ltuple (t1'::l1')) p => + (x.1, rec x.2 p) + end rec + end. + +(* ------------------------------------------------------------------------- *) +Lemma neq_sym (T: eqType) (x y: T) : + (x != y) = (y != x). +Proof. apply/eqP; case: eqP => //; exact: not_eq_sym. Qed. + +(* ------------------------------------------------------------------------- *) +Lemma nth_not_default T x0 (s:seq T) n x : + nth x0 s n = x -> + x0 <> x -> + (n < size s)%nat. +Proof. + move=> hnth hneq. + rewrite ltnNge; apply /negP => hle. + by rewrite nth_default in hnth. +Qed. + +Lemma all_behead {A} {p : A -> bool} {xs : seq A} : + all p xs -> all p (behead xs). +Proof. + case: xs => // x xs. + by move=> /andP [] _. +Qed. + +Lemma all2_behead {A B} {p: A -> B -> bool} {xs: seq A} {ys: seq B} : + all2 p xs ys + -> all2 p (behead xs) (behead ys). +Proof. + case: xs; case: ys => //= y ys x xs. + by move=> /andP [] _. +Qed. + +Lemma notin_cons (T : eqType) (x y : T) (s : seq T) : + (x \notin y :: s) = (x != y) && (x \notin s). +Proof. by rewrite in_cons negb_or. Qed. + +(* Convert [ C |- uniq xs -> P ] into + [ C, ? : x0 <> x1, ? : x0 <> x2, ... |- P ]. *) +Ltac t_elim_uniq := + repeat ( + move=> /andP []; + repeat (rewrite notin_cons; move=> /andP [] /eqP ?); + move=> _ + ); + move=> _. + +Variant and6 (P1 P2 P3 P4 P5 P6 : Prop) : Prop := + And6 of P1 & P2 & P3 & P4 & P5 & P6. +Variant and7 (P1 P2 P3 P4 P5 P6 P7 : Prop) : Prop := + And7 of P1 & P2 & P3 & P4 & P5 & P6 & P7. +Variant and8 (P1 P2 P3 P4 P5 P6 P7 P8 : Prop) : Prop := + And8 of P1 & P2 & P3 & P4 & P5 & P6 & P7 & P8. +Variant and9 (P1 P2 P3 P4 P5 P6 P7 P8 P9 : Prop) : Prop := + And9 of P1 & P2 & P3 & P4 & P5 & P6 & P7 & P8 & P9. +Variant and10 (P1 P2 P3 P4 P5 P6 P7 P8 P9 P10 : Prop) : Prop := + And10 of P1 & P2 & P3 & P4 & P5 & P6 & P7 & P8 & P9 & P10. + +Notation "[ /\ P1 , P2 , P3 , P4 , P5 & P6 ]" := + (and6 P1 P2 P3 P4 P5 P6) : type_scope. +Notation "[ /\ P1 , P2 , P3 , P4 , P5 & P6 ]" := + (and6 P1 P2 P3 P4 P5 P6) : type_scope. +Notation "[ /\ P1 , P2 , P3 , P4 , P5 , P6 & P7 ]" := + (and7 P1 P2 P3 P4 P5 P6 P7) : type_scope. +Notation "[ /\ P1 , P2 , P3 , P4 , P5 , P6 , P7 & P8 ]" := + (and8 P1 P2 P3 P4 P5 P6 P7 P8) : type_scope. +Notation "[ /\ P1 , P2 , P3 , P4 , P5 , P6 , P7 , P8 & P9 ]" := + (and9 P1 P2 P3 P4 P5 P6 P7 P8 P9) : type_scope. +Notation "[ /\ P1 , P2 , P3 , P4 , P5 , P6 , P7 , P8 , P9 & P10 ]" := + (and10 P1 P2 P3 P4 P5 P6 P7 P8 P9 P10) : type_scope. + +Tactic Notation "have!" ":= " constr(x) := + let h := fresh "h" in + (assert (h := x); move: h). + +Tactic Notation "have!" simple_intropattern(ip) ":= " constr(x) := + let h := fresh "h" in + (assert (h := x); move: h => ip). + +#[local] +Ltac t_do_rewrites tac := + repeat + match goal with + | [ h : ?lhs = ?rhs |- _ ] => tac h lhs rhs + | [ h : is_true (?lhs == ?rhs) |- _ ] => move: h => /eqP h; tac h lhs rhs + | [ h : is_true ?lhs |- _ ] => tac h lhs true + end. + +#[local] +Ltac head_term e := + match e with + | ?a _ => head_term a + | _ => e + end. + +#[local] +Ltac is_simpl e := + is_var e + || let x := head_term e in is_constructor x. + +#[local] +Ltac simpl_rewrite h lhs rhs := + (is_simpl lhs; rewrite -!h) || (is_simpl rhs; rewrite !h). + +Ltac t_simpl_rewrites := t_do_rewrites simpl_rewrite. + +#[local] +Ltac eq_rewrite h _ _ := + (rewrite !h || rewrite -!h); clear h. + +Ltac t_eq_rewrites := t_do_rewrites eq_rewrite. + +Ltac destruct_opn_args := + repeat (t_xrbindP=> -[|?]; first done); + (t_xrbindP=> -[]; last done). + +(* Attempt to prove [injective f] on [eqType]s by case analysis on the + arguments. *) +Ltac t_inj_cases := + move=> [] [] /eqP h; + apply/eqP. + +(* ------------------------------------------------------------------------- *) + +Module Option. + +Variant option_spec X A o xs xn : option A -> X -> Prop := +| OptionSpecSome : forall a, o = Some a -> option_spec o xs xn (Some a) (xs a) +| OptionSpecNone : o = None -> option_spec o xs xn None xn. + +Lemma oappP R A (f : A -> R) x u : option_spec u f x u (oapp f x u). +Proof. by case: u; constructor. Qed. + +Lemma odfltP T (x : T) u : option_spec u id x u (odflt x u). +Proof. by case: u; constructor. Qed. + +Lemma obindP A R (f : A -> option R) u : option_spec u f None u (obind f u). +Proof. by case: u; constructor. Qed. + +Lemma omapP A R (f : A -> R) u : + option_spec u (fun x => Some (f x)) None u (Option.map f u). +Proof. by case: u; constructor. Qed. + +End Option. + +Notation "'let%opt' x ':=' ox 'in' body" := + (if ox is Some x then body else None) + (x strict pattern, at level 25). + +Notation "'let%opt '_' ':=' ox 'in' body" := + (if ox is Some tt then body else None) + (at level 25). + +Lemma obindP aT bT oa (f : aT -> option bT) a (P : Type) : + (forall z, oa = Some z -> f z = Some a -> P) -> + (let%opt a' := oa in f a') = Some a -> + P. +Proof. case: oa => // a' h h'. exact: (h _ _ h'). Qed. + +Definition oassert (b : bool) : option unit := + if b then Some tt else None. + +Lemma oassertP {A b a} {oa : option A} : + (let%opt _ := oassert b in oa) = Some a -> + b /\ oa = Some a. +Proof. by case: b. Qed. + +Lemma oassertP_isSome {A b} {oa : option A} : + isSome (let%opt _ := oassert b in oa) -> + b /\ isSome oa. +Proof. by case: b. Qed. + +Lemma isSomeP {A : Type} {oa : option A} : + isSome oa -> + exists a, oa = Some a. +Proof. case: oa; by [|eexists]. Qed. + +Lemma o2rP {eT A} {err : eT} {oa : option A} {a} : + o2r err oa = ok a -> + oa = Some a. +Proof. by case: oa => //= ? [->]. Qed. + +Lemma cat_inj_head T (x y z : seq T) : x ++ y = x ++ z -> y = z. +Proof. by elim: x y z => // > hrec >; rewrite !cat_cons => -[/hrec]. Qed. + +Lemma cat_inj_tail T (x y z : seq T) : x ++ z = y ++ z -> x = y. +Proof. + elim: z x y => >; first by rewrite !cats0. + by move=> hrec >; rewrite -!cat_rcons => /hrec /rcons_inj[]. +Qed. + +Lemma map_const_nseq A B (l : list A) (c : B) : map (fun=> c) l = nseq (size l) c. +Proof. by elim: l => // > ? /=; f_equal. Qed. + + +Section RT_TRANSN. + +Context + {A : Type} + {R Rstep : A -> A -> Prop} +. + +Fixpoint transn_spec_aux (a0 an : A) (l : list A) : Prop := + match l with + | [::] => R a0 an + | an1 :: l => Rstep an an1 -> transn_spec_aux a0 an1 l + end. + +Definition transn_spec (l : list A) : Prop := + match l with + | [::] => True + | a0 :: l => transn_spec_aux a0 a0 l + end. + + Section SPEC. + + Context + (htrans : forall x y z, R x y -> R y z -> R x z) + (hstep : forall x y, Rstep x y -> R x y) + (hrefl : forall x, R x x) + . + + Lemma transn_spec_auxP a0 an l : + R a0 an -> + transn_spec_aux a0 an l. + Proof. + elim: l an => //= an1 l hrec an h0n hnn1. + apply: hrec. + apply: (htrans h0n). + exact: hstep. + Qed. + + Lemma transn_specP l : transn_spec l. + Proof. + case: l => [// | a0 [// | a1 l ?]]. + apply: transn_spec_auxP. + exact: hstep. + Qed. + + End SPEC. + +Context (hspec : forall l, transn_spec l). + +Lemma transn2 a0 a1 a2 : + Rstep a0 a1 -> + Rstep a1 a2 -> + R a0 a2. +Proof. exact: (hspec [:: _; _; _ ]). Qed. + +Lemma transn3 a0 a1 a2 a3 : + Rstep a0 a1 -> + Rstep a1 a2 -> + Rstep a2 a3 -> + R a0 a3. +Proof. exact: (hspec [:: _; _; _; _ ]). Qed. + +Lemma transn4 a0 a1 a3 a2 a4 : + Rstep a0 a1 -> + Rstep a1 a2 -> + Rstep a2 a3 -> + Rstep a3 a4 -> + R a0 a4. +Proof. exact: (hspec [:: _; _; _; _; _ ]). Qed. + +Lemma transn5 a0 a1 a3 a2 a4 a5 : + Rstep a0 a1 -> + Rstep a1 a2 -> + Rstep a2 a3 -> + Rstep a3 a4 -> + Rstep a4 a5 -> + R a0 a5. +Proof. exact: (hspec [:: _; _; _; _; _; _ ]). Qed. + +Lemma transn6 a0 a1 a3 a2 a4 a5 a6 : + Rstep a0 a1 -> + Rstep a1 a2 -> + Rstep a2 a3 -> + Rstep a3 a4 -> + Rstep a4 a5 -> + Rstep a5 a6 -> + R a0 a6. +Proof. exact: (hspec [:: _; _; _; _; _; _; _ ]). Qed. + +End RT_TRANSN. diff --git a/theories/Crypt/jasmin_word.v b/theories/Crypt/jasmin_word.v new file mode 100644 index 00000000..32ad4a6b --- /dev/null +++ b/theories/Crypt/jasmin_word.v @@ -0,0 +1,171 @@ +(* ** Machine word *) + +(* ** Imports and settings *) + +From HB Require Import structures. +From mathcomp Require Import all_ssreflect all_algebra. +From Crypt Require Import jasmin_util. +Require Import (* strings *) ZArith (* utils *). +(* Import Utf8. *) +(* Import word_ssrZ. *) + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +(* -------------------------------------------------------------- *) +Variant wsize := + | U8 + | U16 + | U32 + | U64 + | U128 + | U256. + +(* Size in bits of the elements of a vector. *) +Variant velem := VE8 | VE16 | VE32 | VE64. + +Coercion wsize_of_velem (ve: velem) : wsize := + match ve with + | VE8 => U8 + | VE16 => U16 + | VE32 => U32 + | VE64 => U64 + end. + +(* Size in bits of the elements of a pack. *) +Variant pelem := +| PE1 | PE2 | PE4 | PE8 | PE16 | PE32 | PE64 | PE128. + +Variant signedness := + | Signed + | Unsigned. + +(* -------------------------------------------------------------------- *) +Scheme Equality for wsize. + +Lemma wsize_axiom : Equality.axiom wsize_beq. +Proof. + exact: (eq_axiom_of_scheme internal_wsize_dec_bl internal_wsize_dec_lb). +Qed. + +HB.instance Definition _ := hasDecEq.Build wsize wsize_axiom. + +Definition wsizes := + [:: U8 ; U16 ; U32 ; U64 ; U128 ; U256 ]. + +Lemma wsize_fin_axiom : Finite.axiom wsizes. +Proof. by case. Qed. + +(* ** Comparison + * -------------------------------------------------------------------- *) +Definition wsize_cmp s s' := + match s, s' with + | U8, U8 => Eq + | U8, (U16 | U32 | U64 | U128 | U256) => Lt + | U16, U8 => Gt + | U16, U16 => Eq + | U16, (U32 | U64 | U128 | U256) => Lt + | U32, (U8 | U16) => Gt + | U32, U32 => Eq + | U32, (U64 | U128 | U256) => Lt + | U64, (U8 | U16 | U32) => Gt + | U64, U64 => Eq + | U64, ( U128 | U256) => Lt + | U128, (U8 | U16 | U32 | U64) => Gt + | U128, U128 => Eq + | U128, U256 => Lt + | U256, (U8 | U16 | U32 | U64 | U128) => Gt + | U256, U256 => Eq + end. + +#[export] +Instance wsizeO : Cmp wsize_cmp. +Proof. + constructor. + + by move=> [] []. + + by move=> [] [] [] //= ? []. + by move=> [] []. +Qed. + +Lemma wsize_le_U8 s: (U8 <= s)%CMP. +Proof. by case: s. Qed. + +Lemma wsize_ge_U256 s: (s <= U256)%CMP. +Proof. by case s. Qed. + +#[global]Hint Resolve wsize_le_U8 wsize_ge_U256: core. + +(* -------------------------------------------------------------------- *) +Definition check_size_8_64 sz := assert (sz ≤ U64)%CMP ErrType. +Definition check_size_8_32 sz := assert (sz ≤ U32)%CMP ErrType. +Definition check_size_16_32 sz := assert ((U16 ≤ sz) && (sz ≤ U32))%CMP ErrType. +Definition check_size_16_64 sz := assert ((U16 ≤ sz) && (sz ≤ U64))%CMP ErrType. +Definition check_size_32_64 sz := assert ((U32 ≤ sz) && (sz ≤ U64))%CMP ErrType. +Definition check_size_128_256 sz := assert ((U128 ≤ sz) && (sz ≤ U256))%CMP ErrType. + + + +(* -------------------------------------------------------------- *) +Definition nat7 : nat := 7. +Definition nat15 : nat := nat7.+4.+4. +Definition nat31 : nat := nat15.+4.+4.+4.+4. +Definition nat63 : nat := nat31.+4.+4.+4.+4.+4.+4.+4.+4. +Definition nat127 : nat := nat63.+4.+4.+4.+4.+4.+4.+4.+4.+4.+4.+4.+4.+4.+4.+4.+4. +Definition nat255 : nat := nat127.+4.+4.+4.+4.+4.+4.+4.+4.+4.+4.+4.+4.+4.+4.+4.+4.+4.+4.+4.+4.+4.+4.+4.+4.+4.+4.+4.+4.+4.+4.+4.+4. + +Definition wsize_size_minus_1 (s: wsize) : nat := + match s with + | U8 => nat7 + | U16 => nat15 + | U32 => nat31 + | U64 => nat63 + | U128 => nat127 + | U256 => nat255 + end. + +Coercion nat_of_wsize (sz : wsize) := + (wsize_size_minus_1 sz).+1. + +(* -------------------------------------------------------------- *) +From mathcomp Require Import all_ssreflect all_algebra. +From mathcomp Require Import word_ssrZ word. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +Ltac elim_div := + unfold Z.div, Z.modulo; + match goal with + | H : context[ Z.div_eucl ?X ?Y ] |- _ => + generalize (Z_div_mod_full X Y) ; case: (Z.div_eucl X Y) + | |- context[ Z.div_eucl ?X ?Y ] => + generalize (Z_div_mod_full X Y) ; case: (Z.div_eucl X Y) + end; unfold Remainder. + +Coercion nat_of_pelem (pe: pelem) : nat := + match pe with + | PE1 => 1 + | PE2 => 2 + | PE4 => 4 + | PE8 => nat_of_wsize U8 + | PE16 => nat_of_wsize U16 + | PE32 => nat_of_wsize U32 + | PE64 => nat_of_wsize U64 + | PE128 => nat_of_wsize U128 + end. + +Definition word sz : comRingType := (wsize_size_minus_1 sz).+1.-word. + +Global Opaque word. + +Definition wsize_log2 sz : nat := + match sz with + | U8 => 0 + | U16 => 1 + | U32 => 2 + | U64 => 3 + | U128 => 4 + | U256 => 5 + end. From bcc05330b04be851abb9d52bffe23b7b2432f019 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Thu, 14 Mar 2024 13:27:24 +0100 Subject: [PATCH 378/383] remove jasmin dependency for now --- theories/Crypt/Casts.v | 10 ++++++- theories/Crypt/choice_type.v | 6 ++--- theories/Crypt/jasmin_word.v | 33 ++++++++++++++++++++++++ theories/Crypt/package/pkg_interpreter.v | 3 ++- 4 files changed, 47 insertions(+), 5 deletions(-) diff --git a/theories/Crypt/Casts.v b/theories/Crypt/Casts.v index 4efd278c..5a9a96f4 100644 --- a/theories/Crypt/Casts.v +++ b/theories/Crypt/Casts.v @@ -2,12 +2,14 @@ Set Warnings "-ambiguous-paths,-notation-overridden,-notation-incompatible-forma From mathcomp Require Import ssreflect ssrbool ssrnat choice fintype. Set Warnings "ambiguous-paths,notation-overridden,notation-incompatible-format". +From deriving Require Import deriving. +From Coq Require Import ZArith. + From extructures Require Import ord fmap. From Crypt Require Import Prelude. From HB Require Import structures. - (** Note for any of these types it would also be okay to write the cast, e.g., [(nat:choiceType)%type], directly in the term. @@ -15,8 +17,13 @@ From HB Require Import structures. Just delete as soon as all references to the below casts are gone from the code base. *) +(* From mathcomp Require Import *) +(* ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype generic_quotient *) +(* tuple. *) + Definition unit_choiceType : choiceType := Datatypes.unit. Definition nat_choiceType : choiceType := nat. +Definition int_choiceType : choiceType := Z. Definition bool_choiceType : choiceType := bool. Definition prod_choiceType (A B: choiceType) : choiceType := prod A B. Definition fmap_choiceType (A: ordType) (B: choiceType) : choiceType := {fmap A -> B}. @@ -26,6 +33,7 @@ Definition sum_choiceType (A B: choiceType) : choiceType := (A + B)%type. Definition unit_ordType: ordType := Datatypes.unit. Definition nat_ordType: ordType := nat. +Definition int_ordType: ordType := Z. Definition bool_ordType: ordType := bool. Definition prod_ordType (A B: ordType) : ordType := prod A B. Definition fmap_ordType (A B: ordType) : ordType := {fmap A -> B}. diff --git a/theories/Crypt/choice_type.v b/theories/Crypt/choice_type.v index bd909f17..723b106e 100644 --- a/theories/Crypt/choice_type.v +++ b/theories/Crypt/choice_type.v @@ -128,7 +128,7 @@ Section choice_typeTypes. (* match choice_type_eqMixin with *) (* | EqMixin op => op *) (* end. *) - + Fixpoint choice_type_test (u v : choice_type) : bool := match u, v with | chNat , chNat => true @@ -579,7 +579,7 @@ Section choice_typeTypes. Proof. intros x y. destruct (choice_type_eq x y) eqn:H. - - apply/orP. intuition auto. + - apply/orP. intuition auto. - apply/orP. left. unfold choice_type_eq in H. @@ -608,7 +608,7 @@ Section choice_typeTypes. apply/orP. right. assumption. * apply/orP. right. exact (choice_type_lt_transitive _ _ _ H H0). Qed. - + Lemma choice_type_leq_asym : antisymmetric (T:=choice_type) choice_type_leq. Proof. diff --git a/theories/Crypt/jasmin_word.v b/theories/Crypt/jasmin_word.v index 32ad4a6b..718ddb76 100644 --- a/theories/Crypt/jasmin_word.v +++ b/theories/Crypt/jasmin_word.v @@ -169,3 +169,36 @@ Definition wsize_log2 sz : nat := | U128 => 4 | U256 => 5 end. + +Local Open Scope Z_scope. + +Definition wunsigned {s} (w: word s) : Z := + urepr w. + +Definition wsigned {s} (w: word s) : Z := + srepr w. + +Definition wrepr s (z: Z) : word s := + mkword (wsize_size_minus_1 s).+1 z. + +Lemma word_ext n x y h h' : + x = y -> + @mkWord n x h = @mkWord n y h'. +Proof. by move => e; apply/val_eqP/eqP. Qed. + +Lemma wunsigned_inj sz : injective (@wunsigned sz). +Proof. by move => x y /eqP /val_eqP. Qed. + +Lemma wunsigned1 ws : + @wunsigned ws 1 = 1%Z. +Proof. by case: ws. Qed. + +Lemma wrepr_unsigned s (w: word s) : wrepr s (wunsigned w) = w. +Proof. by rewrite /wrepr /wunsigned ureprK. Qed. + +Lemma wrepr_signed s (w: word s) : wrepr s (wsigned w) = w. +Proof. by rewrite /wrepr /wsigned sreprK. Qed. + +Lemma wunsigned_repr s z : + wunsigned (wrepr s z) = z mod modulus (wsize_size_minus_1 s).+1. +Proof. done. Qed. diff --git a/theories/Crypt/package/pkg_interpreter.v b/theories/Crypt/package/pkg_interpreter.v index 892c977a..74c76d5e 100644 --- a/theories/Crypt/package/pkg_interpreter.v +++ b/theories/Crypt/package/pkg_interpreter.v @@ -9,7 +9,8 @@ From Crypt Require Import Prelude choice_type From Coq Require Import Utf8. From extructures Require Import ord fset fmap. -From Jasmin Require Import word. +(* From Jasmin Require Import word. *) +From Crypt Require Import jasmin_word. From Equations Require Import Equations. From 9e8dbbf16f7dce2c0baf936f30d49ed68fce2775 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Thu, 14 Mar 2024 13:56:27 +0100 Subject: [PATCH 379/383] remove jasmin dependency for now --- _CoqProject | 1 + theories/Crypt/jasmin_word.v | 130 ++++------------------- theories/Crypt/jasmin_wsize.v | 107 +++++++++++++++++++ theories/Crypt/package/pkg_interpreter.v | 6 +- 4 files changed, 131 insertions(+), 113 deletions(-) create mode 100644 theories/Crypt/jasmin_wsize.v diff --git a/_CoqProject b/_CoqProject index acaf984d..008e3e9f 100644 --- a/_CoqProject +++ b/_CoqProject @@ -25,6 +25,7 @@ theories/Crypt/Prelude.v theories/Crypt/Axioms.v theories/Crypt/Casts.v theories/Crypt/jasmin_util.v +theories/Crypt/jasmin_wsize.v theories/Crypt/jasmin_word.v theories/Crypt/choice_type.v diff --git a/theories/Crypt/jasmin_word.v b/theories/Crypt/jasmin_word.v index 718ddb76..6e5fe54b 100644 --- a/theories/Crypt/jasmin_word.v +++ b/theories/Crypt/jasmin_word.v @@ -4,108 +4,17 @@ From HB Require Import structures. From mathcomp Require Import all_ssreflect all_algebra. -From Crypt Require Import jasmin_util. +From mathcomp Require Import word_ssrZ word. +From Crypt Require Import jasmin_util jasmin_wsize. Require Import (* strings *) ZArith (* utils *). (* Import Utf8. *) (* Import word_ssrZ. *) +Export jasmin_wsize. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. -(* -------------------------------------------------------------- *) -Variant wsize := - | U8 - | U16 - | U32 - | U64 - | U128 - | U256. - -(* Size in bits of the elements of a vector. *) -Variant velem := VE8 | VE16 | VE32 | VE64. - -Coercion wsize_of_velem (ve: velem) : wsize := - match ve with - | VE8 => U8 - | VE16 => U16 - | VE32 => U32 - | VE64 => U64 - end. - -(* Size in bits of the elements of a pack. *) -Variant pelem := -| PE1 | PE2 | PE4 | PE8 | PE16 | PE32 | PE64 | PE128. - -Variant signedness := - | Signed - | Unsigned. - -(* -------------------------------------------------------------------- *) -Scheme Equality for wsize. - -Lemma wsize_axiom : Equality.axiom wsize_beq. -Proof. - exact: (eq_axiom_of_scheme internal_wsize_dec_bl internal_wsize_dec_lb). -Qed. - -HB.instance Definition _ := hasDecEq.Build wsize wsize_axiom. - -Definition wsizes := - [:: U8 ; U16 ; U32 ; U64 ; U128 ; U256 ]. - -Lemma wsize_fin_axiom : Finite.axiom wsizes. -Proof. by case. Qed. - -(* ** Comparison - * -------------------------------------------------------------------- *) -Definition wsize_cmp s s' := - match s, s' with - | U8, U8 => Eq - | U8, (U16 | U32 | U64 | U128 | U256) => Lt - | U16, U8 => Gt - | U16, U16 => Eq - | U16, (U32 | U64 | U128 | U256) => Lt - | U32, (U8 | U16) => Gt - | U32, U32 => Eq - | U32, (U64 | U128 | U256) => Lt - | U64, (U8 | U16 | U32) => Gt - | U64, U64 => Eq - | U64, ( U128 | U256) => Lt - | U128, (U8 | U16 | U32 | U64) => Gt - | U128, U128 => Eq - | U128, U256 => Lt - | U256, (U8 | U16 | U32 | U64 | U128) => Gt - | U256, U256 => Eq - end. - -#[export] -Instance wsizeO : Cmp wsize_cmp. -Proof. - constructor. - + by move=> [] []. - + by move=> [] [] [] //= ? []. - by move=> [] []. -Qed. - -Lemma wsize_le_U8 s: (U8 <= s)%CMP. -Proof. by case: s. Qed. - -Lemma wsize_ge_U256 s: (s <= U256)%CMP. -Proof. by case s. Qed. - -#[global]Hint Resolve wsize_le_U8 wsize_ge_U256: core. - -(* -------------------------------------------------------------------- *) -Definition check_size_8_64 sz := assert (sz ≤ U64)%CMP ErrType. -Definition check_size_8_32 sz := assert (sz ≤ U32)%CMP ErrType. -Definition check_size_16_32 sz := assert ((U16 ≤ sz) && (sz ≤ U32))%CMP ErrType. -Definition check_size_16_64 sz := assert ((U16 ≤ sz) && (sz ≤ U64))%CMP ErrType. -Definition check_size_32_64 sz := assert ((U32 ≤ sz) && (sz ≤ U64))%CMP ErrType. -Definition check_size_128_256 sz := assert ((U128 ≤ sz) && (sz ≤ U256))%CMP ErrType. - - - (* -------------------------------------------------------------- *) Definition nat7 : nat := 7. Definition nat15 : nat := nat7.+4.+4. @@ -128,12 +37,6 @@ Coercion nat_of_wsize (sz : wsize) := (wsize_size_minus_1 sz).+1. (* -------------------------------------------------------------- *) -From mathcomp Require Import all_ssreflect all_algebra. -From mathcomp Require Import word_ssrZ word. - -Set Implicit Arguments. -Unset Strict Implicit. -Unset Printing Implicit Defensive. Ltac elim_div := unfold Z.div, Z.modulo; @@ -144,6 +47,19 @@ Ltac elim_div := generalize (Z_div_mod_full X Y) ; case: (Z.div_eucl X Y) end; unfold Remainder. +Definition wsize_log2 sz : nat := + match sz with + | U8 => 0 + | U16 => 1 + | U32 => 2 + | U64 => 3 + | U128 => 4 + | U256 => 5 + end. + +Definition wbase (s: wsize) : Z := + modulus (wsize_size_minus_1 s).+1. + Coercion nat_of_pelem (pe: pelem) : nat := match pe with | PE1 => 1 @@ -160,16 +76,6 @@ Definition word sz : comRingType := (wsize_size_minus_1 sz).+1.-word. Global Opaque word. -Definition wsize_log2 sz : nat := - match sz with - | U8 => 0 - | U16 => 1 - | U32 => 2 - | U64 => 3 - | U128 => 4 - | U256 => 5 - end. - Local Open Scope Z_scope. Definition wunsigned {s} (w: word s) : Z := @@ -202,3 +108,7 @@ Proof. by rewrite /wrepr /wsigned sreprK. Qed. Lemma wunsigned_repr s z : wunsigned (wrepr s z) = z mod modulus (wsize_size_minus_1 s).+1. Proof. done. Qed. + +Lemma wunsigned_range sz (p: word sz) : + 0 <= wunsigned p < wbase sz. +Proof. by have /iswordZP := isword_word p. Qed. diff --git a/theories/Crypt/jasmin_wsize.v b/theories/Crypt/jasmin_wsize.v new file mode 100644 index 00000000..e31ff2d6 --- /dev/null +++ b/theories/Crypt/jasmin_wsize.v @@ -0,0 +1,107 @@ +(* ** Machine word *) + +(* ** Imports and settings *) + +From HB Require Import structures. +From mathcomp Require Import all_ssreflect all_algebra. +From Crypt Require Import jasmin_util. +Require Import (* strings *) ZArith (* utils *). +(* Import Utf8. *) +(* Import word_ssrZ. *) +From mathcomp Require Import word_ssrZ word. + +Set Implicit Arguments. +Unset Strict Implicit. +Unset Printing Implicit Defensive. + +(* -------------------------------------------------------------- *) +Variant wsize := + | U8 + | U16 + | U32 + | U64 + | U128 + | U256. + +(* Size in bits of the elements of a vector. *) +Variant velem := VE8 | VE16 | VE32 | VE64. + +Coercion wsize_of_velem (ve: velem) : wsize := + match ve with + | VE8 => U8 + | VE16 => U16 + | VE32 => U32 + | VE64 => U64 + end. + +(* Size in bits of the elements of a pack. *) +Variant pelem := +| PE1 | PE2 | PE4 | PE8 | PE16 | PE32 | PE64 | PE128. + +Variant signedness := + | Signed + | Unsigned. + +(* -------------------------------------------------------------------- *) +Scheme Equality for wsize. + +Lemma wsize_axiom : Equality.axiom wsize_beq. +Proof. + exact: (eq_axiom_of_scheme internal_wsize_dec_bl internal_wsize_dec_lb). +Qed. + +HB.instance Definition _ := hasDecEq.Build wsize wsize_axiom. + +Definition wsizes := + [:: U8 ; U16 ; U32 ; U64 ; U128 ; U256 ]. + +Lemma wsize_fin_axiom : Finite.axiom wsizes. +Proof. by case. Qed. + +(* ** Comparison + * -------------------------------------------------------------------- *) +Definition wsize_cmp s s' := + match s, s' with + | U8, U8 => Eq + | U8, (U16 | U32 | U64 | U128 | U256) => Lt + | U16, U8 => Gt + | U16, U16 => Eq + | U16, (U32 | U64 | U128 | U256) => Lt + | U32, (U8 | U16) => Gt + | U32, U32 => Eq + | U32, (U64 | U128 | U256) => Lt + | U64, (U8 | U16 | U32) => Gt + | U64, U64 => Eq + | U64, ( U128 | U256) => Lt + | U128, (U8 | U16 | U32 | U64) => Gt + | U128, U128 => Eq + | U128, U256 => Lt + | U256, (U8 | U16 | U32 | U64 | U128) => Gt + | U256, U256 => Eq + end. + +#[export] +Instance wsizeO : Cmp wsize_cmp. +Proof. + constructor. + + by move=> [] []. + + by move=> [] [] [] //= ? []. + by move=> [] []. +Qed. + +Lemma wsize_le_U8 s: (U8 <= s)%CMP. +Proof. by case: s. Qed. + +Lemma wsize_ge_U256 s: (s <= U256)%CMP. +Proof. by case s. Qed. + +#[global]Hint Resolve wsize_le_U8 wsize_ge_U256: core. + +(* -------------------------------------------------------------------- *) +Definition check_size_8_64 sz := assert (sz ≤ U64)%CMP ErrType. +Definition check_size_8_32 sz := assert (sz ≤ U32)%CMP ErrType. +Definition check_size_16_32 sz := assert ((U16 ≤ sz) && (sz ≤ U32))%CMP ErrType. +Definition check_size_16_64 sz := assert ((U16 ≤ sz) && (sz ≤ U64))%CMP ErrType. +Definition check_size_32_64 sz := assert ((U32 ≤ sz) && (sz ≤ U64))%CMP ErrType. +Definition check_size_128_256 sz := assert ((U128 ≤ sz) && (sz ≤ U256))%CMP ErrType. + diff --git a/theories/Crypt/package/pkg_interpreter.v b/theories/Crypt/package/pkg_interpreter.v index 74c76d5e..1786f32e 100644 --- a/theories/Crypt/package/pkg_interpreter.v +++ b/theories/Crypt/package/pkg_interpreter.v @@ -42,7 +42,7 @@ Section Interpreter. nat_ch_aux (NSProd a b) (l1 × l2) (Some v1, Some v2) := Some (v1, v2) ; nat_ch_aux (NSProd a b) (l1 × l2) _ := None ; } ; - nat_ch_aux (NSNat n) 'word u := Some _ ; + nat_ch_aux (NSNat n) ('word u) := Some _ ; nat_ch_aux _ _ := None. Proof. - eapply @Ordinal. @@ -75,7 +75,7 @@ Section Interpreter. | _ => None end ; ch_nat 'option l None := Some (NSOption None) ; - ch_nat 'word u x := Some (NSNat (BinInt.Z.to_nat (word.wunsigned x))) ; + ch_nat 'word u x := Some (NSNat (BinInt.Z.to_nat (wunsigned x))) ; ch_nat _ _ := None. Lemma ch_nat_ch l v: @@ -201,7 +201,7 @@ Section Interpreter. instantiate (1 := ((Z.of_nat seed) mod (word.modulus (nat_of_wsize n) ))%Z). pose (Z.mod_bound_pos (Z.of_nat seed) (word.modulus n) (Zle_0_nat seed)). - pose (word.modulus_gt0 (word.nat_of_wsize n)). + pose (word.modulus_gt0 (nat_of_wsize n)). apply / word.iswordZP. apply a. move : i => / word_ssrZ.ltzP. From ae1f7e64bafb0253ca7f7db5d2028e650486a521 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Thu, 14 Mar 2024 15:45:08 +0100 Subject: [PATCH 380/383] include more of jasmin word --- theories/Crypt/jasmin_word.v | 1836 ++++++++++++++++++++++++++++++++++ 1 file changed, 1836 insertions(+) diff --git a/theories/Crypt/jasmin_word.v b/theories/Crypt/jasmin_word.v index 6e5fe54b..083add90 100644 --- a/theories/Crypt/jasmin_word.v +++ b/theories/Crypt/jasmin_word.v @@ -36,6 +36,9 @@ Definition wsize_size_minus_1 (s: wsize) : nat := Coercion nat_of_wsize (sz : wsize) := (wsize_size_minus_1 sz).+1. +Definition wsize_bits (s:wsize) : Z := + Zpos (Pos.of_succ_nat (wsize_size_minus_1 s)). + (* -------------------------------------------------------------- *) Ltac elim_div := @@ -78,6 +81,34 @@ Global Opaque word. Local Open Scope Z_scope. + +Definition winit (ws : wsize) (f : nat -> bool) : word ws := + let bits := map f (iota 0 (wsize_size_minus_1 ws).+1) in + t2w (Tuple (tval := bits) ltac:(by rewrite size_map size_iota)). + +Definition wand {s} (x y: word s) : word s := wand x y. +Definition wor {s} (x y: word s) : word s := wor x y. +Definition wxor {s} (x y: word s) : word s := wxor x y. + +Definition wlt {sz} (sg: signedness) : word sz -> word sz -> bool := + match sg with + | Unsigned => fun x y=> (urepr x < urepr y)%R + | Signed => fun x y=> (srepr x < srepr y)%R + end. + +Definition wle sz (sg: signedness) : word sz -> word sz -> bool := + match sg with + | Unsigned => fun x y=> (urepr x <= urepr y)%R + | Signed => fun x y=> (srepr x <= srepr y)%R + end. + +Definition wnot sz (w: word sz) : word sz := + wxor w (-1)%R. + +Arguments wnot {sz} w. + +Definition wandn sz (x y: word sz) : word sz := wand (wnot x) y. + Definition wunsigned {s} (w: word s) : Z := urepr w. @@ -109,6 +140,1811 @@ Lemma wunsigned_repr s z : wunsigned (wrepr s z) = z mod modulus (wsize_size_minus_1 s).+1. Proof. done. Qed. +Lemma wrepr0 sz : wrepr sz 0 = 0%R. +Proof. by apply/eqP. Qed. + +Lemma wrepr1 sz : wrepr sz 1 = 1%R. +Proof. by apply/eqP;case sz. Qed. + +Lemma wreprB sz : wrepr sz (wbase sz) = 0%R. +Proof. by apply/eqP;case sz. Qed. + Lemma wunsigned_range sz (p: word sz) : 0 <= wunsigned p < wbase sz. Proof. by have /iswordZP := isword_word p. Qed. + +Lemma wrepr_mod ws k : wrepr ws (k mod wbase ws) = wrepr ws k. +Proof. by apply wunsigned_inj; rewrite !wunsigned_repr Zmod_mod. Qed. + +Lemma wunsigned_repr_small ws z : 0 <= z < wbase ws -> wunsigned (wrepr ws z) = z. +Proof. move=> h; rewrite wunsigned_repr; apply: Zmod_small h. Qed. + +Lemma wrepr_add sz (x y: Z) : + wrepr sz (x + y) = (wrepr sz x + wrepr sz y)%R. +Proof. by apply: word_ext; rewrite /wrepr !mkwordK Zplus_mod. Qed. + +Lemma wrepr_sub sz (x y: Z) : + wrepr sz (x - y) = (wrepr sz x - wrepr sz y)%R. +Proof. by apply: word_ext; rewrite /wrepr !mkwordK -Zminus_mod_idemp_r -Z.add_opp_r Zplus_mod. Qed. + +Lemma wrepr_mul sz (x y: Z) : + wrepr sz (x * y) = (wrepr sz x * wrepr sz y)%R. +Proof. by apply: word_ext; rewrite /wrepr !mkwordK Zmult_mod. Qed. + +Lemma wrepr_m1 sz : + wrepr sz (-1) = (-1)%R. +Proof. by apply /eqP; case sz. Qed. + +Lemma wunsigned0 ws : @wunsigned ws 0 = 0. +Proof. by rewrite -wrepr0 wunsigned_repr Zmod_0_l. Qed. + +Lemma wunsigned_add sz (p: word sz) (n: Z) : + 0 <= wunsigned p + n < wbase sz -> + wunsigned (p + wrepr sz n) = wunsigned p + n. +Proof. + move=> h. + rewrite -{1}(wrepr_unsigned p). + by rewrite -wrepr_add wunsigned_repr Z.mod_small. +Qed. + +Lemma wunsigned_add_if ws (a b : word ws) : + wunsigned (a + b) = + if wunsigned a + wunsigned b ha hb. + case: ZltP => hlt. + + by rewrite Zmod_small //;Psatz.lia. + by rewrite -(Z_mod_plus_full _ (-1)) Zmod_small;Psatz.lia. +Qed. + +Lemma wunsigned_sub (sz : wsize) (p : word sz) (n : Z): + 0 <= wunsigned p - n < wbase sz -> wunsigned (p - wrepr sz n) = wunsigned p - n. +Proof. + move=> h. + rewrite -{1}(wrepr_unsigned p). + by rewrite -wrepr_sub wunsigned_repr Z.mod_small. +Qed. + +Lemma wunsigned_sub_if ws (a b : word ws) : + wunsigned (a - b) = + if wunsigned b <=? wunsigned a then wunsigned a - wunsigned b + else wbase ws + wunsigned a - wunsigned b. +Proof. + move: (wunsigned_range a) (wunsigned_range b). + rewrite /wunsigned mathcomp.word.word.subwE -/(wbase ws) => ha hb. + have -> : (word.urepr a - word.urepr b)%R = word.urepr a - word.urepr b by done. + case: ZleP => hle. + + by rewrite Zmod_small //;Psatz.lia. + by rewrite -(Z_mod_plus_full _ 1) Zmod_small;Psatz.lia. +Qed. + +Lemma wunsigned_opp_if ws (a : word ws) : + wunsigned (-a) = if wunsigned a == 0 then 0 else wbase ws - wunsigned a. +Proof. + have ha := wunsigned_range a. + rewrite -(GRing.add0r (-a)%R) wunsigned_sub_if wunsigned0. + by case: ZleP; case: eqP => //; Psatz.lia. +Qed. + +Lemma wlt_irrefl sz sg (w: word sz) : + wlt sg w w = false. +Proof. case: sg; exact: Z.ltb_irrefl. Qed. + +Lemma wle_refl sz sg (w: word sz) : + wle sg w w = true. +Proof. case: sg; exact: Z.leb_refl. Qed. + +Definition wshr sz (x: word sz) (n: Z) : word sz := + mkword sz (Z.shiftr (wunsigned x) n). + +Definition wshl sz (x: word sz) (n: Z) : word sz := + mkword sz (Z.shiftl (wunsigned x) n). + +Definition wsar sz (x: word sz) (n: Z) : word sz := + mkword sz (Z.shiftr (wsigned x) n). + +Definition high_bits sz (n : Z) : word sz := + wrepr sz (Z.shiftr n (wsize_bits sz)). + +Definition wmulhu sz (x y: word sz) : word sz := + high_bits sz (wunsigned x * wunsigned y). + +Definition wmulhs sz (x y: word sz) : word sz := + high_bits sz (wsigned x * wsigned y). + +Definition wmulhrs sz (x y: word sz) : word sz := + let: p := Z.shiftr (wsigned x * wsigned y) (wsize_size_minus_1 sz).-1 + 1 in + wrepr sz (Z.shiftr p 1). + +Definition wmax_unsigned sz := wbase sz - 1. +Definition wmin_signed (sz: wsize) : Z := - modulus (wsize_size_minus_1 sz). +Definition wmax_signed (sz: wsize) : Z := modulus (wsize_size_minus_1 sz) - 1. + +Section wsigned_range. +Local Arguments Z.add: simpl never. +Local Arguments Z.sub: simpl never. +Local Arguments Z.opp: simpl never. + +End wsigned_range. + +Notation u8 := (word U8). +Notation u16 := (word U16). +Notation u32 := (word U32). +Notation u64 := (word U64). +Notation u128 := (word U128). +Notation u256 := (word U256). + +Definition wbit_n sz (w:word sz) (n:nat) : bool := + wbit (wunsigned w) n. + +Lemma wbit_nE ws (w : word ws) i : + wbit_n w i = Z.odd (wunsigned w / 2 ^ i)%Z. +Proof. + have [hlo _] := wunsigned_range w. + rewrite /wbit_n. + rewrite word.wbitE; last by rewrite !zify. + + rewrite -(Nat2Z.id (_ %/ _)). + + rewrite -oddZE; last first. + - rewrite !zify. exact: Zle_0_nat. + + rewrite divnZE; first last. + - apply: lt0n_neq0. by rewrite expn_gt0. + + rewrite Z2Nat.id; last done. + by rewrite Nat2Z.n2zX expZE. +Qed. + +Lemma eq_from_wbit_n s (w1 w2: word s) : + reflect (forall i : 'I_(wsize_size_minus_1 s).+1, wbit_n w1 i = wbit_n w2 i) (w1 == w2). +Proof. apply/eq_from_wbit. Qed. + +Lemma wandE s (w1 w2: word s) i : + wbit_n (wand w1 w2) i = wbit_n w1 i && wbit_n w2 i. +Proof. by rewrite /wbit_n /wand wandE. Qed. + +Lemma worE s (w1 w2 : word s) i : + wbit_n (wor w1 w2) i = wbit_n w1 i || wbit_n w2 i. +Proof. by rewrite /wbit_n /wor worE. Qed. + +Lemma wxorE s (w1 w2: word s) i : + wbit_n (wxor w1 w2) i = wbit_n w1 i (+) wbit_n w2 i. +Proof. by rewrite /wbit_n /wxor wxorE. Qed. + +Lemma wN1E sz i : + @wbit_n sz (-1)%R i = leq (S i) (wsize_size_minus_1 sz).+1. +Proof. exact: wN1E. Qed. + +Lemma w0E sz i : + @wbit_n sz 0%R i = false. +Proof. exact: Z.testbit_0_l. Qed. + +Lemma wnotE sz (w: word sz) (i: 'I_(wsize_size_minus_1 sz).+1) : + wbit_n (wnot w) i = ~~ wbit_n w i. +Proof. + rewrite /wnot wxorE wN1E. + case: i => i /= ->. + exact: addbT. +Qed. + +Lemma wshrE sz (x: word sz) c i : + 0 <= c -> + wbit_n (wshr x c) i = wbit_n x (Z.to_nat c + i). +Proof. + move/Z2Nat.id => {1}<-. + exact: wbit_lsr. +Qed. + +Lemma wunsigned_wshr sz (x: word sz) c : + wunsigned (wshr x (Z.of_nat c)) = wunsigned x / 2 ^ Z.of_nat c. +Proof. + have rhs_range : 0 <= wunsigned x / 2 ^ Z.of_nat c /\ wunsigned x / 2 ^ Z.of_nat c < modulus sz. + - have x_range := wunsigned_range x. + split. + + apply: Z.div_pos; first Lia.lia. + apply: Z.pow_pos_nonneg; Lia.lia. + change (modulus sz) with (wbase sz). + elim_div => ? ? []; last Lia.nia. + apply: Z.pow_nonzero; Lia.lia. + rewrite -(Z.mod_small (wunsigned x / 2 ^ Z.of_nat c) (modulus sz)) //. + rewrite -wunsigned_repr. + congr wunsigned. + apply/eqP/eq_from_wbit_n => i. + rewrite /wbit_n wbit_lsr wunsigned_repr /wbit. + rewrite Z.mod_small //. + rewrite Z.div_pow2_bits. + 2-3: Lia.lia. + by rewrite Nat2Z.n2zD Z.add_comm. +Qed. + +Lemma wshlE sz (w: word sz) c i : + 0 <= c -> + wbit_n (wshl w c) i = (Z.to_nat c <= i <= wsize_size_minus_1 sz)%nat && wbit_n w (i - Z.to_nat c). +Proof. + move/Z2Nat.id => {1}<-. + rewrite /wbit_n /wshl /=. + case: leP => hic /=; + last (rewrite wbit_lsl_lo //; apply/leP; Lia.lia). + have eqi : (Z.to_nat c + (i - Z.to_nat c))%nat = i. + * by rewrite /addn /addn_rec; zify; rewrite Nat2Z.inj_sub; Lia.lia. + have := wbit_lsl w (Z.to_nat c) (i - Z.to_nat c). + by rewrite eqi => ->. +Qed. + +Local Ltac lia := + rewrite /addn /addn_rec /subn /subn_rec; Psatz.lia. + +Lemma wunsigned_wshl sz (x: word sz) c : + wunsigned (wshl x (Z.of_nat c)) = (wunsigned x * 2 ^ Z.of_nat c) mod wbase sz. +Proof. + rewrite -wunsigned_repr. + congr wunsigned. + apply/eqP/eq_from_wbit_n => i. + rewrite /wbit_n wunsigned_repr /modulus two_power_nat_equiv. + rewrite {2}/wbit Z.mod_pow2_bits_low; last first. + - move/ltP: (ltn_ord i); Lia.lia. + case: (@ltP i c); last first. + - move => c_le_i. + have i_eq : nat_of_ord i = (c + (i - c))%nat by lia. + rewrite i_eq wbit_lsl -i_eq ltn_ord /wbit. + rewrite Z.mul_pow2_bits; last by lia. + congr Z.testbit. + lia. + move => l_lt_c. + rewrite wbit_lsl_lo; last by apply/ltP. + rewrite Z.mul_pow2_bits_low //; lia. +Qed. + +Lemma wshl_sem ws w n : + (0 <= n)%Z + -> wshl w n = (wrepr ws (2 ^ n) * w)%R. +Proof. + move=> hlo. + apply: wunsigned_inj. + + rewrite -(Z2Nat.id _ hlo). + rewrite wunsigned_wshl. + rewrite (Z2Nat.id _ hlo). + + rewrite -(wrepr_unsigned w). + rewrite -wrepr_mul. + rewrite !wunsigned_repr. + + rewrite Zmult_mod_idemp_l. + by rewrite Z.mul_comm. +Qed. + +Lemma wshl_ovf sz (w: word sz) c : + 0 <= c -> + (wsize_size_minus_1 sz < Z.to_nat c)%coq_nat -> + wshl w c = 0%R. +Proof. + move => c_not_neg hc; apply/eqP/eq_from_wbit_n => i. + rewrite wshlE // {2}/wbit_n wbit0. + case: i => i /= /leP /le_S_n hi. + have /leP -> := hi. + case: leP => //; lia. +Qed. + +Definition lsb {s} (w: word s) : bool := wbit_n w 0. +Definition msb {s} (w: word s) : bool := wbit_n w (wsize_size_minus_1 s). + +Lemma msb_wordE {s} (w : word s) : msb w = mathcomp.word.word.msb w. +Proof. by []. Qed. + +Definition wdwordu sz (hi lo: word sz) : Z := + wunsigned hi * wbase sz + wunsigned lo. + +Definition wdwords sz (hi lo: word sz) : Z := + wsigned hi * wbase sz + wunsigned lo. + +Definition waddcarry sz (x y: word sz) (c: bool) := + let n := wunsigned x + wunsigned y + Z.b2z c in + (wbase sz <=? n, wrepr sz n). + +Definition wdaddu sz (hi_1 lo_1 hi_2 lo_2: word sz) := + let n := (wdwordu hi_1 lo_1) + (wdwordu hi_2 lo_2) in + (wrepr sz n, high_bits sz n). + +Definition wdadds sz (hi_1 lo_1 hi_2 lo_2: word sz) := + let n := (wdwords hi_1 lo_1) + (wdwords hi_2 lo_2) in + (wrepr sz n, high_bits sz n). + +Definition wsubcarry sz (x y: word sz) (c: bool) := + let n := wunsigned x - wunsigned y - Z.b2z c in + (n exec (word s) with + | Eq => fun h => ok (ecast s (word s) (esym (cmp_eq h)) w) + | Lt => fun _ => ok (zero_extend s w) + | Gt => fun _ => type_error + end erefl. + +Variant truncate_word_spec s s' (w: word s') : exec (word s) -> Type := + | TruncateWordEq (h: s' = s) : truncate_word_spec w (ok (ecast s (word s) h w)) + | TruncateWordLt (h: (s < s')%CMP) : truncate_word_spec w (ok (zero_extend s w)) + | TruncateWordGt : (s' < s)%CMP -> truncate_word_spec w type_error + . + +Lemma truncate_wordP' s s' (w: word s') : truncate_word_spec w (truncate_word s w). +Proof. + rewrite /truncate_word/gcmp. + case: {2 3} (wsize_cmp s s') erefl. + - move => /cmp_eq ?; exact: TruncateWordEq. + - move => h; apply: TruncateWordLt. + by rewrite /cmp_lt /gcmp h. + rewrite -/(gcmp s s') => h. + apply: TruncateWordGt. + by rewrite /cmp_lt cmp_sym h. +Qed. + +Definition wbit sz (w i: word sz) : bool := + wbit_n w (Z.to_nat (wunsigned i mod wsize_bits sz)). + +Definition wror sz (w:word sz) (z:Z) := + let i := z mod wsize_bits sz in + wor (wshr w i) (wshl w (wsize_bits sz - i)). + +Definition wrol sz (w:word sz) (z:Z) := + let i := z mod wsize_bits sz in + wor (wshl w i) (wshr w (wsize_bits sz - i)). + +(* -------------------------------------------------------------------*) +Lemma wsignedE sz (w: word sz) : + wsigned w = if msb w then wunsigned w - wbase sz else wunsigned w. +Proof. done. Qed. + +(* Lemma wsigned_repr sz z : *) +(* wmin_signed sz <= z <= wmax_signed sz -> *) +(* wsigned (wrepr sz z) = z. *) +(* Proof. *) +(* rewrite wsignedE msb_wordE msbE /= wunsigned_repr -/(wbase _) => z_range. *) +(* elim_div => a b [] // ? [] b_range; last by have := wbase_pos sz; lia. *) +(* subst z. *) +(* case: ifP => /ZleP. *) +(* all: move: sz z_range b_range. *) +(* all: move: {-2} Z.mul (erefl Z.mul) => K ?. *) +(* all: rewrite /wmin_signed /wmax_signed /wbase /modulus /two_power_nat. *) +(* all: case => /=; subst K; lia. *) +(* Qed. *) + +(* (* -------------------------------------------------------------------*) *) +(* Lemma wsmulP sz (x y: word sz) : *) +(* let: (hi, lo) := wsmul x y in *) +(* wdwords hi lo = wsigned x * wsigned y. *) +(* Proof. *) +(* have x_range := wsigned_range x. *) +(* have y_range := wsigned_range y. *) +(* rewrite /wsmul /wdwords high_bits_wbase. *) +(* set p := _ * wsigned _. *) +(* have p_range : wmin_signed sz * wmax_signed sz <= p <= wmin_signed sz * wmin_signed sz. *) +(* { subst p; case: sz x y x_range y_range => x y; *) +(* rewrite /wmin_signed /wmax_signed /=; *) +(* nia. } *) +(* have hi_range : wmin_signed sz <= p / wbase sz <= wmax_signed sz. *) +(* { move: sz {x y x_range y_range} p p_range => sz p p_range. *) +(* elim_div => a b [] // ? [] b_range; last by have := wbase_pos sz; lia. *) +(* subst p. *) +(* move: sz p_range b_range. *) +(* move: {-2} Z.mul (erefl Z.mul) => K ?. *) +(* rewrite /wmin_signed /wmax_signed /wbase /modulus /two_power_nat. *) +(* case => /=; subst K; lia. } *) +(* rewrite wsigned_repr; last exact: hi_range. *) +(* rewrite wunsigned_repr -/(wbase _). *) +(* have := Z_div_mod_eq_full p (wbase sz). *) +(* lia. *) +(* Qed. *) + +(* -------------------------------------------------------------------*) +Lemma msb0 sz : @msb sz 0 = false. +Proof. by case: sz. Qed. + +Lemma wshr0 sz (w: word sz) : wshr w 0 = w. +Proof. by rewrite /wshr /lsr Z.shiftr_0_r ureprK. Qed. + +Lemma wshr_full sz (w : word sz) : wshr w (wsize_bits sz) = 0%R. +Proof. + apply/eqP/eq_from_wbit_n. + move=> i. + rewrite w0E. + rewrite wshrE //. + rewrite /wsize_bits /=. + rewrite SuccNat2Pos.id_succ. + rewrite /wbit_n. + rewrite wbit_word_ovf; first done. + apply: ltn_addr. + exact: ltnSn. +Qed. + +Lemma wshl0 sz (w: word sz) : wshl w 0 = w. +Proof. by rewrite /wshl /lsl Z.shiftl_0_r ureprK. Qed. + +(* Lemma wshl_full sz (w : word sz) : wshl w (wsize_bits sz) = 0%R. *) +(* Proof. *) +(* apply/eqP/eq_from_wbit_n. *) +(* move=> i. *) +(* rewrite wshlE; last by []. *) +(* rewrite /wsize_bits /=. *) +(* rewrite SuccNat2Pos.id_succ. *) +(* case hi: (_ <= _ <= _)%N; last by rewrite w0E. *) +(* by move: hi => /andP [] /ltn_geF ->. *) +(* Qed. *) + +Lemma wsar0 sz (w: word sz) : wsar w 0 = w. +Proof. by rewrite /wsar /asr Z.shiftr_0_r sreprK. Qed. + +(* -------------------------------------------------------------------*) +Lemma zero_extend0 sz sz' : + @zero_extend sz sz' 0%R = 0%R. +Proof. by apply/eqP/eq_from_wbit. Qed. + +Lemma zero_extend_u sz (w:word sz) : zero_extend sz w = w. +Proof. by rewrite /zero_extend wrepr_unsigned. Qed. + +(* Lemma zero_extend_sign_extend sz sz' s (w: word s) : *) +(* (sz ≤ sz')%CMP -> *) +(* zero_extend sz (sign_extend sz' w) = sign_extend sz w. *) +(* Proof. *) +(* move => hsz; rewrite /sign_extend; apply: word_ext. *) +(* move: (wsigned w) => {w} z. *) +(* rewrite wunsigned_repr. *) +(* case: (modulus_m (wsize_size_m hsz)) => n hn. *) +(* by rewrite hn mod_pq_mod_q. *) +(* Qed. *) + +(* Lemma zero_extend_wrepr sz sz' z : *) +(* (sz <= sz')%CMP -> *) +(* zero_extend sz (wrepr sz' z) = wrepr sz z. *) +(* Proof. *) +(* move/wsize_size_m => hle. *) +(* apply: word_ext. *) +(* rewrite /wunsigned /urepr /wrepr /=. *) +(* case: (modulus_m hle) => n -> {hle}. *) +(* exact: mod_pq_mod_q. *) +(* Qed. *) + +(* Lemma zero_extend_idem s s1 s2 (w:word s) : *) +(* (s1 <= s2)%CMP -> zero_extend s1 (zero_extend s2 w) = zero_extend s1 w. *) +(* Proof. *) +(* by move=> hle;rewrite [X in (zero_extend _ X) = _]/zero_extend zero_extend_wrepr. *) +(* Qed. *) + +(* Lemma zero_extend_cut (s1 s2 s3: wsize) (w: word s3) : *) +(* (s3 ≤ s2)%CMP -> *) +(* zero_extend s1 (zero_extend s2 w) = zero_extend s1 w. *) +(* Proof. *) +(* move => /wbase_m hle. *) +(* rewrite /zero_extend wunsigned_repr_small //. *) +(* have := wunsigned_range w. *) +(* lia. *) +(* Qed. *) + +Lemma wbit_zero_extend s s' (w: word s') i : + wbit_n (zero_extend s w) i = (i <= wsize_size_minus_1 s)%nat && wbit_n w i. +Proof. +rewrite /zero_extend /wbit_n /wunsigned /wrepr. +move: (urepr w) => {w} z. +rewrite mkwordK. +set m := wsize_size_minus_1 _. +rewrite /mathcomp.word.word.wbit /=. +rewrite /modulus two_power_nat_equiv. +case: leP => hi. ++ rewrite Z.mod_pow2_bits_low //; lia. +rewrite Z.mod_pow2_bits_high //; lia. +Qed. + +Lemma zero_extend1 sz sz' : + @zero_extend sz sz' 1%R = 1%R. +Proof. + apply/eqP/eq_from_wbit => -[i hi]. + have := @wbit_zero_extend sz sz' 1%R i. + by rewrite /wbit_n => ->; rewrite -ltnS hi. +Qed. + +(* Lemma sign_extend_truncate s s' (w: word s') : *) +(* (s ≤ s')%CMP -> *) +(* sign_extend s w = zero_extend s w. *) +(* Proof. *) +(* rewrite /sign_extend /zero_extend /wsigned /wunsigned. *) +(* rewrite mathcomp.word.word.sreprE /= /wrepr. *) +(* move: (mathcomp.word.word.urepr w) => z hle. *) +(* apply/word_ext. *) +(* have [n ->] := modulus_m (wsize_size_m hle). *) +(* case: word_ssrZ.ltzP => // hgt. *) +(* by rewrite Zminus_mod Z_mod_mult Z.sub_0_r Zmod_mod. *) +(* Qed. *) + +Lemma sign_extend_u sz (w: word sz) : sign_extend sz w = w. +Proof. exact: sreprK. Qed. + +Lemma truncate_word_le s s' (w: word s') : + (s ≤ s')%CMP -> + truncate_word s w = ok (zero_extend s w). + case: truncate_wordP' => //. + - by move => ?; subst; rewrite zero_extend_u. + by rewrite -cmp_nle_lt => /negbTE ->. +Qed. + +Lemma truncate_wordP s1 s2 (w1:word s1) (w2:word s2) : + truncate_word s1 w2 = ok w1 -> (s1 <= s2)%CMP /\ w1 = zero_extend s1 w2. +Proof. + case: truncate_wordP'; last by []. + - move => ?; subst => /ok_inj ->{w2}. + by rewrite cmp_le_refl zero_extend_u. + by move => /(@cmp_lt_le _ _ _ _ _) -> /ok_inj ->. +Qed. + +(* Lemma truncate_word_errP s1 s2 (w: word s2) e : *) +(* truncate_word s1 w = Error e -> e = ErrType ∧ (s2 < s1)%CMP. *) +(* Proof. by case: truncate_wordP' => // -> [] <-. Qed. *) + +Global Opaque truncate_word. + +Lemma truncate_word_u s (a : word s) : truncate_word s a = ok a. +Proof. by rewrite truncate_word_le ?zero_extend_u ?cmp_refl. Qed. + +Lemma wbase_n0 sz : wbase sz <> 0%Z. +Proof. by case sz. Qed. + +Lemma wsigned0 sz : @wsigned sz 0%R = 0%Z. +Proof. by case: sz. Qed. + +Lemma wsigned1 sz : @wsigned sz 1%R = 1%Z. +Proof. by case: sz. Qed. + +Lemma wsignedN1 sz : @wsigned sz (-1)%R = (-1)%Z. +Proof. by case: sz. Qed. + +Lemma sign_extend0 sz sz' : + @sign_extend sz sz' 0%R = 0%R. +Proof. by rewrite /sign_extend wsigned0 wrepr0. Qed. + +Lemma wandC sz : commutative (@wand sz). +Proof. + by move => x y; apply/eqP/eq_from_wbit => i; + rewrite /wand !mathcomp.word.word.wandE andbC. +Qed. + +Lemma wandA sz : associative (@wand sz). +Proof. + by move => x y z; apply/eqP/eq_from_wbit_n => i; + rewrite !wandE andbA. +Qed. + +Lemma wand0 sz (x: word sz) : wand 0 x = 0%R. +Proof. by apply/eqP. Qed. + +Lemma wand_xx sz (x: word sz) : wand x x = x. +Proof. by apply/eqP/eq_from_wbit; rewrite /= Z.land_diag. Qed. + +Lemma wandN1 sz (x: word sz) : wand (-1) x = x. +Proof. + apply/eqP/eq_from_wbit_n => i. + by rewrite wandE wN1E ltn_ord. +Qed. + +(* Lemma wand_small n : *) +(* (0 <= n < wbase U16) *) +(* -> wand (wrepr U32 n) (zero_extend U32 (wrepr U16 (-1))) = wrepr U32 n. *) +(* Proof. *) +(* move=> [hlo hhi]. *) +(* apply/eqP/eq_from_wbit_n. *) +(* move=> [i hrangei] /=. *) + +(* case hi: (i < 16)%nat. *) + +(* - rewrite wandE. *) +(* rewrite wrepr_m1 wbit_zero_extend. *) +(* rewrite wN1E. *) + +(* have -> : (i <= wsize_size_minus_1 U32)%nat. *) +(* - by apply: (ltnSE hrangei). *) +(* rewrite andTb. *) + +(* rewrite hi. *) +(* by rewrite andbT. *) + +(* have -> : wbit_n (wrepr U32 n) i = false. *) +(* - rewrite -(Nat2Z.id i). *) +(* apply: (wbit_higher_bits_0 (n := 16) _ _) => //=. *) +(* move: hi => /ZNltP hi. *) +(* move: hrangei => /ZNleP /= h. *) +(* lia. *) + +(* rewrite wandE. *) +(* rewrite wrepr_m1 wbit_zero_extend. *) +(* rewrite wN1E. *) +(* rewrite hi /=. *) +(* by rewrite !andbF. *) +(* Qed. *) + +Lemma worC sz : commutative (@wor sz). +Proof. + by move => x y; apply/eqP/eq_from_wbit => i; + rewrite /wor !mathcomp.word.word.worE orbC. +Qed. + +Lemma wor0 sz (x: word sz) : wor 0 x = x. +Proof. by apply/eqP/eq_from_wbit. Qed. + +Lemma wor_xx sz (x: word sz) : wor x x = x. +Proof. by apply/eqP/eq_from_wbit; rewrite /= Z.lor_diag. Qed. + +Lemma wxor0 sz (x: word sz) : wxor 0 x = x. +Proof. by apply/eqP/eq_from_wbit. Qed. + +Lemma wxor_xx sz (x: word sz) : wxor x x = 0%R. +Proof. by apply/eqP/eq_from_wbit; rewrite /= Z.lxor_nilpotent. Qed. + +Lemma wmulE sz (x y: word sz) : (x * y)%R = wrepr sz (wunsigned x * wunsigned y). +Proof. by rewrite /wunsigned /wrepr; apply: word_ext. Qed. + +(* Lemma wror0 sz (w : word sz) : wror w 0 = w. *) +(* Proof. *) +(* rewrite /wror. *) +(* rewrite wshr0. *) +(* rewrite Zmod_0_l Z.sub_0_r. *) +(* rewrite wshl_full. *) +(* by rewrite worC wor0. *) +(* Qed. *) + +Lemma wrol0 sz (w : word sz) : wrol w 0 = w. +Proof. + rewrite /wrol. + rewrite wshl0. + rewrite Zmod_0_l Z.sub_0_r. + rewrite wshr_full. + by rewrite worC wor0. +Qed. + +(* Lemma wadd_zero_extend sz sz' (x y: word sz') : *) +(* (sz ≤ sz')%CMP -> *) +(* zero_extend sz (x + y) = (zero_extend sz x + zero_extend sz y)%R. *) +(* Proof. *) +(* move => hle; apply: word_ext. *) +(* rewrite /wrepr !mkwordK -Zplus_mod. *) +(* rewrite /wunsigned /urepr /=. *) +(* change (x + y)%R with (add_word x y). *) +(* rewrite /add_word /= /urepr /=. *) +(* case: (modulus_m (wsize_size_m hle)) => n -> {hle}. *) +(* by rewrite mod_pq_mod_q. *) +(* Qed. *) + +(* Lemma wmul_zero_extend sz sz' (x y: word sz') : *) +(* (sz ≤ sz')%CMP -> *) +(* zero_extend sz (x * y) = (zero_extend sz x * zero_extend sz y)%R. *) +(* Proof. *) +(* move => hle; apply: word_ext. *) +(* rewrite /wrepr !mkwordK -Zmult_mod. *) +(* rewrite /wunsigned /urepr /=. *) +(* change (x * y)%R with (mul_word x y). *) +(* rewrite /mul_word /= /urepr /=. *) +(* case: (modulus_m (wsize_size_m hle)) => n -> {hle}. *) +(* by rewrite mod_pq_mod_q. *) +(* Qed. *) + +(* Lemma zero_extend_m1 sz sz' : *) +(* (sz ≤ sz')%CMP -> *) +(* @zero_extend sz sz' (-1) = (-1)%R. *) +(* Proof. exact: zero_extend_wrepr. Qed. *) + +(* Lemma wopp_zero_extend sz sz' (x: word sz') : *) +(* (sz ≤ sz')%CMP -> *) +(* zero_extend sz (-x) = (- zero_extend sz x)%R. *) +(* Proof. *) +(* by move=> hsz; rewrite -(mulN1r x) wmul_zero_extend // zero_extend_m1 // mulN1r. *) +(* Qed. *) + +(* Lemma wsub_zero_extend sz sz' (x y : word sz'): *) +(* (sz ≤ sz')%CMP -> *) +(* zero_extend sz (x - y) = (zero_extend sz x - zero_extend sz y)%R. *) +(* Proof. *) +(* by move=> hsz; rewrite wadd_zero_extend // wopp_zero_extend. *) +(* Qed. *) + +(* Lemma zero_extend_wshl sz sz' (x: word sz') c : *) +(* (sz ≤ sz')%CMP -> *) +(* 0 <= c -> *) +(* zero_extend sz (wshl x c) = wshl (zero_extend sz x) c. *) +(* Proof. *) +(* move => hle hc; apply/eqP/eq_from_wbit_n => i. *) +(* rewrite !(wbit_zero_extend, wshlE) //. *) +(* have := wsize_size_m hle. *) +(* move: i. *) +(* set m := wsize_size_minus_1 _. *) +(* set m' := wsize_size_minus_1 _. *) +(* case => i /= /leP hi hm. *) +(* have him : (i <= m)%nat by apply/leP; lia. *) +(* rewrite him andbT /=. *) +(* have him' : (i <= m')%nat by apply/leP; lia. *) +(* rewrite him' andbT. *) +(* case: leP => //= hci. *) +(* have -> // : (i - Z.to_nat c <= m)%nat. *) +(* apply/leP; rewrite /subn /subn_rec; lia. *) +(* Qed. *) + +Lemma wand_zero_extend sz sz' (x y: word sz') : + (sz ≤ sz')%CMP -> + wand (zero_extend sz x) (zero_extend sz y) = zero_extend sz (wand x y). +Proof. +move => hle. +apply/eqP/eq_from_wbit_n => i. +rewrite !(wbit_zero_extend, wandE). +by case: (_ <= _)%nat. +Qed. + +Lemma wor_zero_extend sz sz' (x y : word sz') : + (sz <= sz')%CMP + -> wor (zero_extend sz x) (zero_extend sz y) = zero_extend sz (wor x y). +Proof. + move=> hws. + apply/eqP. + apply/eq_from_wbit_n. + move=> i. + rewrite !(wbit_zero_extend, worE). + by case: (_ <= _)%nat. +Qed. + +Lemma wxor_zero_extend sz sz' (x y: word sz') : + (sz ≤ sz')%CMP -> + wxor (zero_extend sz x) (zero_extend sz y) = zero_extend sz (wxor x y). +Proof. +move => hle. +apply/eqP/eq_from_wbit_n => i. +rewrite !(wbit_zero_extend, wxorE). +by case: (_ <= _)%nat. +Qed. + +(* Lemma wnot_zero_extend sz sz' (x : word sz') : *) +(* (sz ≤ sz')%CMP -> *) +(* wnot (zero_extend sz x) = zero_extend sz (wnot x). *) +(* Proof. *) +(* move => hle. *) +(* apply/eqP/eq_from_wbit_n => i. *) +(* rewrite !(wbit_zero_extend, wnotE). *) +(* have := wsize_size_m hle. *) +(* move: i. *) +(* set m := wsize_size_minus_1 _. *) +(* set m' := wsize_size_minus_1 _. *) +(* case => i /= /leP hi hm. *) +(* have him : (i <= m)%nat. by apply/leP; lia. *) +(* rewrite him /=. *) +(* have hi' : (i < m'.+1)%nat. apply /ltP. lia. *) +(* by have /= -> := @wnotE sz' x (Ordinal hi') . *) +(* Qed. *) + + +(* -------------------------------------------------------------------*) + +(* Lemma wleuE sz (w1 w2: word sz) : *) +(* (wunsigned (w2 - w1) == (wunsigned w2 - wunsigned w1))%Z = wle Unsigned w1 w2. *) +(* Proof. by rewrite /= leNgt wltuE negbK. Qed. *) + +(* Lemma wleuE' sz (w1 w2 : word sz) : *) +(* (wunsigned (w1 - w2) != (wunsigned w1 - wunsigned w2)%Z) || (w1 == w2) *) +(* = wle Unsigned w1 w2. *) +(* Proof. by rewrite -wltuE /= le_eqVlt orbC. Qed. *) + +(* Lemma wltsE_aux sz (α β: word sz) : α <> β -> *) +(* wlt Signed α β = (msb (α - β) != (wsigned (α - β) != (wsigned α - wsigned β)%Z)). *) +(* Proof. *) +(* move=> ne_ab; rewrite /= !msb_wordE /wsigned /srepr. *) +(* rewrite !mathcomp.word.word.msbE /= !subZE; set w := (_ sz); *) +(* case: (lerP (modulus _) (val α)) => ha; *) +(* case: (lerP (modulus _) (val β)) => hb; *) +(* case: (lerP (modulus _) (val _)) => hab. *) +(* + rewrite ltrD2r eq_sym eqb_id negbK opprB !addrA subrK. *) +(* rewrite [val (α - β)%R]subw_modE /urepr /= -/w. *) +(* case: ltrP; first by rewrite addrK eqxx. *) +(* by rewrite addr0 lt_eqF // ltrBlDr ltrDl modulus_gt0. *) +(* + rewrite ltrD2r opprB !addrA subrK eq_sym eqbF_neg negbK. *) +(* rewrite [val (α - β)%R]subw_modE /urepr -/w /=; case: ltrP. *) +(* + by rewrite mulr1n gt_eqF // ltrDl modulus_gt0. *) +(* + by rewrite addr0 eqxx. *) +(* + rewrite ltrBlDr (lt_le_trans (urepr_ltmod _)); last first. *) +(* by rewrite lerDr urepr_ge0. *) +(* rewrite eq_sym eqb_id negbK; apply/esym. *) +(* rewrite [val _]subw_modE /urepr -/w /= ltNge ltW /=. *) +(* * by rewrite addr0 addrAC eqxx. *) +(* * by rewrite (lt_le_trans hb). *) +(* + rewrite ltrBlDr (lt_le_trans (urepr_ltmod _)); last first. *) +(* by rewrite lerDr urepr_ge0. *) +(* rewrite eq_sym eqbF_neg negbK [val _]subw_modE /urepr -/w /=. *) +(* rewrite ltNge ltW ?addr0; last first. *) +(* by rewrite (lt_le_trans hb). *) +(* by rewrite addrAC gt_eqF // ltrBlDr ltrDl modulus_gt0. *) +(* + rewrite ltrBrDl ltNge ltW /=; last first. *) +(* by rewrite (lt_le_trans (urepr_ltmod _)) // lerDl urepr_ge0. *) +(* apply/esym/negbTE; rewrite negbK; apply/eqP/esym. *) +(* rewrite [val _]subw_modE /urepr /= -/w; have ->/=: (val α < val β)%R. *) +(* by have := ltr_leD ha hb; rewrite addrC ltrD2l. *) +(* rewrite mulr1n addrK opprD addrA lt_eqF //= opprK. *) +(* by rewrite ltrDl modulus_gt0. *) +(* + rewrite ltrBrDl ltNge ltW /=; last first. *) +(* by rewrite (lt_le_trans (urepr_ltmod _)) // lerDl urepr_ge0. *) +(* apply/esym/negbTE; rewrite negbK eq_sym eqbF_neg negbK. *) +(* rewrite [val _]subw_modE /urepr -/w /= opprD addrA opprK. *) +(* by have ->//: (val α < val β)%R; apply/(lt_le_trans ha). *) +(* + rewrite [val (α - β)%R](subw_modE α β) -/w /urepr /=. *) +(* rewrite eq_sym eqb_id negbK; case: ltrP. *) +(* * by rewrite mulr1n addrK eqxx. *) +(* * by rewrite addr0 lt_eqF // ltrBlDr ltrDl modulus_gt0. *) +(* + rewrite [val (α - β)%R](subw_modE α β) -/w /urepr /=. *) +(* rewrite eq_sym eqbF_neg negbK; case: ltrP. *) +(* * by rewrite mulr1n gt_eqF // ltrDl modulus_gt0. *) +(* * by rewrite addr0 eqxx. *) +(* Qed. *) + +Section WCMPE. + +#[local] +Notation wle_msb x y := + (msb (x - y) == (wsigned (x - y) != (wsigned x - wsigned y)%Z)) + (only parsing, x in scope ring_scope, y in scope ring_scope). + +#[local] +Notation wlt_msb x y := (~~ wle_msb x y) (only parsing). + +(* Lemma wltsE ws (x y : word ws) : *) +(* wlt_msb x y = wlt Signed x y. *) +(* Proof. *) +(* case: (x =P y) => [<- | ?]; last by rewrite wltsE_aux. *) +(* by rewrite /= ltxx GRing.subrr Z.sub_diag wsigned0 msb0. *) +(* Qed. *) + +(* Lemma wlesE ws (x y : word ws) : *) +(* wle_msb x y = wle Signed y x. *) +(* Proof. by rewrite -[_ == _]negbK wltsE /= leNgt. Qed. *) + +(* Lemma wltsE' ws (x y : word ws): *) +(* ((x != y) && wle_msb x y) = wlt Signed y x. *) +(* Proof. *) +(* by rewrite wlesE /= lt_def eqtype.inj_eq; last exact: word.srepr_inj. *) +(* Qed. *) + +(* Lemma wlesE' ws (x y : word ws) : *) +(* ((x == y) || wlt_msb x y) = wle Signed x y. *) +(* Proof. by rewrite -[_ || _]negbK negb_or negbK wltsE' /= leNgt. Qed. *) + +End WCMPE. + +(* -------------------------------------------------------------------*) +Lemma wdwordu0 sz (w:word sz) : wdwordu 0 w = wunsigned w. +Proof. done. Qed. + +Lemma wdwords0 sz (w:word sz) : + wdwords (if msb w then (-1)%R else 0%R) w = wsigned w. +Proof. + rewrite wsignedE /wdwords; case: msb; rewrite ?wsigned0 ?wsignedN1; ring. +Qed. + +(* -------------------------------------------------------------------*) +Lemma lsr0 n (w: n.-word) : lsr w 0 = w. +Proof. by rewrite /lsr Z.shiftr_0_r ureprK. Qed. + +Lemma subword0 (ws ws' :wsize) (w: word ws') : + mathcomp.word.word.subword 0 ws w = zero_extend ws w. +Proof. + apply/eqP/eq_from_wbit_n => i. + rewrite wbit_zero_extend. + have := ltn_ord i. + rewrite ltnS => -> /=. + rewrite /subword lsr0. + rewrite {1}/wbit_n /wunsigned mkwordK. + rewrite /mathcomp.word.word.wbit /modulus two_power_nat_equiv. + rewrite Z.mod_pow2_bits_low //. + have /leP := ltn_ord i. + lia. +Qed. + +(* -------------------------------------------------------------------*) +Definition check_scale (s:Z) := + (s == 1%Z) || (s == 2%Z) || (s == 4%Z) || (s == 8%Z). + +(* -------------------------------------------------------------------*) +Definition mask_word (sz:wsize) : u64 := + match sz with + | U8 | U16 => wshl (-1)%R (wsize_bits sz) + | _ => 0%R + end. + +Definition merge_word (wr: u64) (sz:wsize) (w:word sz) := + wxor (wand (mask_word sz) wr) (zero_extend U64 w). + +(* -------------------------------------------------------------------*) +Definition split_vec {sz} ve (w : word sz) := + let wsz := (sz %/ ve + sz %% ve)%nat in + [seq subword (i * ve)%nat ve w | i <- iota 0 wsz]. + +Definition make_vec {sz} sz' (s : seq (word sz)) := + wrepr sz' (wcat_r s). + +Lemma make_vec_split_vec sz w : + make_vec sz (split_vec U8 w) = w. +Proof. +have mod0: sz %% U8 = 0%nat by case: {+}sz. +have sz_even: sz = (U8 * (sz %/ U8))%nat :> nat. ++ by rewrite [LHS](divn_eq _ U8) mod0 addn0 mulnC. +rewrite /make_vec /split_vec mod0 addn0; set s := map _ _. +pose wt := (ecast ws (ws.-word) sz_even w). +pose t := [tuple subword (i * U8) U8 wt | i < sz %/ U8]. +have eq_st: wcat_r s = wcat t. ++ rewrite {}/s {}/t /=; pose F i := subword (i * U8) U8 wt. + rewrite (map_comp F val) val_enum_ord {}/F. + congr wcat_r; apply/eq_map => i; apply/eqP/eq_from_wbit. + move=> j; rewrite !subwordE; congr (mathcomp.word.word.wbit (t2w _) _). + apply/val_eqP/eqP => /=; apply/eq_map=> k. + suff ->: val wt = val w by done. + by rewrite {}/wt; case: _ / sz_even. +rewrite {}eq_st wcat_subwordK {s t}/wt; case: _ / sz_even. +by rewrite /wrepr /= ureprK. +Qed. + +Lemma mkwordI n x y : + (0 <= x < modulus n)%R -> + (0 <= y < modulus n)%R -> + mkword n x = mkword n y -> x = y. +Proof. +by case/andP => /ZleP ? /ZltP ? /andP[] /ZleP ? /ZltP ? []; + rewrite !Z.mod_small. +Qed. + +(* -------------------------------------------------------------------*) +Definition lift1_vec' ve ve' (op : word ve -> word ve') + (sz sz': wsize) (w: word sz) : word sz' := + make_vec sz' (map op (split_vec ve w)). + +Definition lift1_vec ve (op : word ve -> word ve) + (sz:wsize) (w:word sz) : word sz := + lift1_vec' op sz w. +Arguments lift1_vec : clear implicits. + +Definition lift2_vec ve (op : word ve -> word ve -> word ve) + (sz:wsize) (w1 w2:word sz) : word sz := + make_vec sz (map2 op (split_vec ve w1) (split_vec ve w2)). +Arguments lift2_vec : clear implicits. + +(* -------------------------------------------------------------------*) +Definition wbswap sz (w: word sz) : word sz := + make_vec sz (rev (split_vec U8 w)). + +(* -------------------------------------------------------------------*) +Definition popcnt sz (w: word sz) := + wrepr sz (count id (w2t w)). + +(* -------------------------------------------------------------------*) +Definition pextr sz (w1 w2: word sz) := + wrepr sz (t2w (in_tuple (mask (w2t w2) (w2t w1)))). + +(* -------------------------------------------------------------------*) + +Fixpoint bitpdep sz (w:word sz) (i:nat) (mask:bitseq) := + match mask with + | [::] => [::] + | b :: mask => + if b then wbit_n w i :: bitpdep w (i.+1) mask + else false :: bitpdep w i mask + end. + +Definition pdep sz (w1 w2: word sz) := + wrepr sz (t2w (in_tuple (bitpdep w1 0 (w2t w2)))). + +(* -------------------------------------------------------------------*) + +Fixpoint leading_zero_aux (n : Z) (res sz : nat) : nat := + if (n O + | S res' => leading_zero_aux n res' sz + end. + +Definition leading_zero (sz : wsize) (w : word sz) : word sz := + wrepr sz (leading_zero_aux (wunsigned w) sz sz). + +(* -------------------------------------------------------------------*) +Definition halve_list A : seq A -> seq A := + fix loop m := if m is a :: _ :: m' then a :: loop m' else m. + +Definition wpmul sz (x y: word sz) : word sz := + let xs := halve_list (split_vec U32 x) in + let ys := halve_list (split_vec U32 y) in + let f (a b: u32) : u64 := wrepr U64 (wsigned a * wsigned b) in + make_vec sz (map2 f xs ys). + +Definition wpmulu sz (x y: word sz) : word sz := + let xs := halve_list (split_vec U32 x) in + let ys := halve_list (split_vec U32 y) in + let f (a b: u32) : u64 := wrepr U64 (wunsigned a * wunsigned b) in + make_vec sz (map2 f xs ys). + +(* -------------------------------------------------------------------*) +Definition wpshufb1 (s : seq u8) (idx : u8) := + if msb idx then 0%R else + let off := wunsigned (wand idx (wshl 1 4%Z - 1)) in + (s`_(Z.to_nat off))%R. + +Definition wpshufb (sz: wsize) (w idx: word sz) : word sz := + let s := split_vec 8 w in + let i := split_vec 8 idx in + let r := map (wpshufb1 s) i in + make_vec sz r. + +(* -------------------------------------------------------------------*) +Definition wpshufd1 (s : u128) (o : u8) (i : nat) := + subword 0 32 (wshr s (32 * urepr (subword (2 * i) 2 o))). + +Definition wpshufd_128 (s : u128) (o : Z) : u128 := + let o := wrepr U8 o in + let d := [seq wpshufd1 s o i | i <- iota 0 4] in + wrepr U128 (wcat_r d). + +Definition wpshufd_256 (s : u256) (o : Z) : u256 := + make_vec U256 (map (fun w => wpshufd_128 w o) (split_vec U128 s)). + +Definition wpshufd sz : word sz -> Z -> word sz := + match sz with + | U128 => wpshufd_128 + | U256 => wpshufd_256 + | _ => fun w _ => w end. + +(* -------------------------------------------------------------------*) + +Definition wpshufl_u64 (w:u64) (z:Z) : u64 := + let v := split_vec U16 w in + let j := split_vec 2 (wrepr U8 z) in + make_vec U64 (map (fun n => v`_(Z.to_nat (urepr n)))%R j). + +Definition wpshufl_u128 (w:u128) (z:Z) := + match split_vec 64 w with + | [::l;h] => make_vec U128 [::wpshufl_u64 l z; (h:u64)] + | _ => w + end. + +Definition wpshufh_u128 (w:u128) (z:Z) := + match split_vec 64 w with + | [::l;h] => make_vec U128 [::(l:u64); wpshufl_u64 h z] + | _ => w + end. + +Definition wpshufl_u256 (s:u256) (z:Z) := + make_vec U256 (map (fun w => wpshufl_u128 w z) (split_vec U128 s)). + +Definition wpshufh_u256 (s:u256) (z:Z) := + make_vec U256 (map (fun w => wpshufh_u128 w z) (split_vec U128 s)). + +Definition wpshuflw sz : word sz -> Z -> word sz := + match sz with + | U128 => wpshufl_u128 + | U256 => wpshufl_u256 + | _ => fun w _ => w end. + +Definition wpshufhw sz : word sz -> Z -> word sz := + match sz with + | U128 => wpshufh_u128 + | U256 => wpshufh_u256 + | _ => fun w _ => w end. + +(* -------------------------------------------------------------------*) + +(*Section UNPCK. + (* Interleaves two even-sized lists. *) + Context (T: Type). + Fixpoint unpck (qs xs ys: seq T) : seq T := + match xs, ys with + | [::], _ | _, [::] + | [:: _], _ | _, [:: _] + => qs + | x :: _ :: xs', y :: _ :: ys' => unpck (x :: y :: qs) xs' ys' + end. +End UNPCK. + +Definition wpunpckl sz (ve: velem) (x y: word sz) : word sz := + let xv := split_vec ve x in + let yv := split_vec ve y in + let zv := unpck [::] xv yv in + make_vec sz (rev zv). + +Definition wpunpckh sz (ve: velem) (x y: word sz) : word sz := + let xv := split_vec ve x in + let yv := split_vec ve y in + let zv := unpck [::] (rev xv) (rev yv) in + make_vec sz zv. +*) + +Fixpoint interleave {A:Type} (l1 l2: list A) := + match l1, l2 with + | [::], _ => l2 + | _, [::] => l1 + | a1::l1, a2::l2 => a1::a2::interleave l1 l2 + end. + +Definition interleave_gen (get:u128 -> u64) (ve:velem) (src1 src2: u128) := + let ve : nat := wsize_of_velem ve in + let l1 := split_vec ve (get src1) in + let l2 := split_vec ve (get src2) in + make_vec U128 (interleave l1 l2). + +Definition wpunpckl_128 := interleave_gen (subword 0 64). + +Definition wpunpckl_256 ve (src1 src2 : u256) := + make_vec U256 + (map2 (wpunpckl_128 ve) (split_vec U128 src1) (split_vec U128 src2)). + +Definition wpunpckh_128 := interleave_gen (subword 64 64). + +Definition wpunpckh_256 ve (src1 src2 : u256) := + make_vec U256 + (map2 (wpunpckh_128 ve) (split_vec U128 src1) (split_vec U128 src2)). + +Definition wpunpckl (sz:wsize) : velem -> word sz -> word sz -> word sz := + match sz with + | U128 => wpunpckl_128 + | U256 => wpunpckl_256 + | _ => fun ve w1 w2 => w1 + end. + +Definition wpunpckh (sz:wsize) : velem -> word sz -> word sz -> word sz := + match sz with + | U128 => wpunpckh_128 + | U256 => wpunpckh_256 + | _ => fun ve w1 w2 => w1 + end. + +(* -------------------------------------------------------------------*) +Section UPDATE_AT. + Context (T: Type) (t: T). + + Fixpoint update_at (xs: seq T) (i: nat) : seq T := + match xs with + | [::] => [::] + | x :: xs' => if i is S i' then x :: update_at xs' i' else t :: xs' + end. + +End UPDATE_AT. + +Definition wpinsr ve (v: u128) (w: word ve) (i: u8) : u128 := + let v := split_vec ve v in + let i := Z.to_nat (wunsigned i) in + make_vec U128 (update_at w v i). + +(* -------------------------------------------------------------------*) +Definition winserti128 (v: u256) (w: u128) (i: u8) : u256 := + let v := split_vec U128 v in + make_vec U256 (if lsb i then [:: v`_0 ; w ] else [:: w ; v`_1 ])%R. + +(* -------------------------------------------------------------------*) +Definition wpblendd sz (w1 w2: word sz) (m: u8) : word sz := + let v1 := split_vec U32 w1 in + let v2 := split_vec U32 w2 in + let b := split_vec 1 m in + let r := map3 (fun b v1 v2 => if b == 1%R then v2 else v1) b v1 v2 in + make_vec sz r. + +(* -------------------------------------------------------------------*) +Definition wpbroadcast ve sz (w: word ve) : word sz := + let r := nseq (sz %/ ve) w in + make_vec sz r. + +Lemma wpbroadcast0 ve sz : + @wpbroadcast ve sz 0%R = 0%R. +Proof. + rewrite /wpbroadcast/make_vec. + suff -> : wcat_r (nseq _ 0%R) = 0. + - by rewrite wrepr0. + by move => q; elim => // n /= ->; rewrite Z.shiftl_0_l. +Qed. + +(* -------------------------------------------------------------------*) +Fixpoint seq_dup_hi T (m: seq T) : seq T := + if m is _ :: a :: m' then a :: a :: seq_dup_hi m' else [::]. + +Fixpoint seq_dup_lo T (m: seq T) : seq T := + if m is a :: _ :: m' then a :: a :: seq_dup_lo m' else [::]. + +Definition wdup_hi ve sz (w: word sz) : word sz := + let v : seq (word ve) := split_vec ve w in + make_vec sz (seq_dup_hi v). + +Definition wdup_lo ve sz (w: word sz) : word sz := + let v : seq (word ve) := split_vec ve w in + make_vec sz (seq_dup_lo v). + +(* -------------------------------------------------------------------*) +Definition wperm2i128 (w1 w2: u256) (i: u8) : u256 := + let choose (n: nat) := + match urepr (subword n 2 i) with + | 0 => subword 0 U128 w1 + | 1 => subword U128 U128 w1 + | 2 => subword 0 U128 w2 + | _ => subword U128 U128 w2 + end in + let lo := if wbit_n i 3 then 0%R else choose 0%nat in + let hi := if wbit_n i 7 then 0%R else choose 4%nat in + make_vec U256 [:: lo ; hi ]. + +(* -------------------------------------------------------------------*) +Definition wpermd1 (v: seq u32) (idx: u32) := + let off := wunsigned idx mod 8 in + (v`_(Z.to_nat off))%R. + +Definition wpermd sz (idx w: word sz) : word sz := + let v := split_vec U32 w in + let i := split_vec U32 idx in + make_vec sz (map (wpermd1 v) i). + +(* -------------------------------------------------------------------*) +Definition wpermq (w: u256) (i: u8) : u256 := + let v := split_vec U64 w in + let j := split_vec 2 i in + make_vec U256 (map (fun n => v`_(Z.to_nat (urepr n)))%R j). + +(* -------------------------------------------------------------------*) +Definition wpsxldq op sz (w: word sz) (i: u8) : word sz := + let n : Z := (Z.min 16 (wunsigned i)) * 8 in + lift1_vec U128 (fun w => op w n) sz w. + +Definition wpslldq := wpsxldq (@wshl _). +Definition wpsrldq := wpsxldq (@wshr _). + +(* -------------------------------------------------------------------*) +Definition wpcmps1 (cmp: Z -> Z -> bool) ve (x y: word ve) : word ve := + if cmp (wsigned x) (wsigned y) then (-1)%R else 0%R. +Arguments wpcmps1 cmp {ve} _ _. + +Definition wpcmpeq ve sz (w1 w2: word sz) : word sz := + lift2_vec ve (wpcmps1 Z.eqb) sz w1 w2. + +Definition wpcmpgt ve sz (w1 w2: word sz) : word sz := + lift2_vec ve (wpcmps1 Z.gtb) sz w1 w2. + +(* -------------------------------------------------------------------*) +Definition wminmax1 ve (cmp : word ve -> word ve -> bool) (x y : word ve) : word ve := + if cmp x y then x else y. + +Definition wmin sg ve sz (x y : word sz) := + lift2_vec ve (wminmax1 (wlt sg)) sz x y. + +Definition wmax sg ve sz (x y : word sz) := + lift2_vec ve (wminmax1 (fun u v => wlt sg v u)) sz x y. + +(* -------------------------------------------------------------------*) +Definition saturated_signed (sz: wsize) (x: Z): Z := + Z.max (wmin_signed sz) (Z.min (wmax_signed sz) x). + +Definition wrepr_saturated_signed (sz: wsize) (x: Z) : word sz := + wrepr sz (saturated_signed sz x). + +Fixpoint add_pairs (m: seq Z) : seq Z := + if m is x :: y :: z then x + y :: add_pairs z + else [::]. + +Definition wpmaddubsw sz (v1 v2: word sz) : word sz := + let w1 := map wunsigned (split_vec U8 v1) in + let w2 := map wsigned (split_vec U8 v2) in + let result := [seq wrepr_saturated_signed U16 z | z <- add_pairs (map2 *%R w1 w2) ] in + make_vec sz result. + +Definition wpmaddwd sz (v1 v2: word sz) : word sz := + let w1 := map wsigned (split_vec U16 v1) in + let w2 := map wsigned (split_vec U16 v2) in + let result := [seq wrepr U32 z | z <- add_pairs (map2 *%R w1 w2) ] in + make_vec sz result. + +(* Test case from the documentation: VPMADDWD wraps when all inputs are min-signed *) +Local Lemma test_wpmaddwd_wraps : + let: s16 := wrepr U16 (wmin_signed U16) in + let: s32 := make_vec U32 [:: s16 ; s16 ] in + let: res := wpmaddwd s32 s32 in + let: expected := wrepr U32 (wmin_signed U32) in + res = expected. +Proof. vm_compute. by apply/eqP. Qed. + +(* -------------------------------------------------------------------*) +Definition wpack sz pe (arg: seq Z) : word sz := + let w := map (mathcomp.word.word.mkword pe) arg in + wrepr sz (word.wcat_r w). + +(* -------------------------------------------------------------------*) +Definition wpmovmskb (dsz ssz: wsize) (w : word ssz) : word dsz := + wrepr dsz (t2w_def [tuple of map msb (split_vec U8 w)]). + +(* -------------------------------------------------------------------*) +Definition wpblendvb sz (w1 w2 m: word sz): word sz := + let v1 := split_vec U8 w1 in + let v2 := split_vec U8 w2 in + let b := map msb (split_vec U8 m) in + let r := map3 (fun bi v1i v2i => if bi then v2i else v1i) b v1 v2 in + make_vec sz r. + +(* -------------------------------------------------------------------*) +Lemma pow2pos q : 0 < 2 ^ Z.of_nat q. +Proof. by rewrite -two_power_nat_equiv. Qed. + +Lemma pow2nz q : 2 ^ Z.of_nat q <> 0. +Proof. have := pow2pos q; lia. Qed. + +Lemma wbit_n_pow2m1 sz (n i: nat) : + wbit_n (wrepr sz (2 ^ Z.of_nat n - 1)) i = (i < Nat.min n (wsize_size_minus_1 sz).+1)%nat. +Proof. + rewrite /wbit_n /mathcomp.word.word.wbit wunsigned_repr /modulus two_power_nat_equiv. + case: (le_lt_dec (wsize_size_minus_1 sz).+1 i) => hi. + - rewrite Z.mod_pow2_bits_high; last lia. + symmetry; apply/negbTE/negP => /ltP. + lia. + rewrite Z.mod_pow2_bits_low; last lia. + rewrite /Z.sub -/(Z.pred (2 ^ Z.of_nat n)) -Z.ones_equiv. + case: ltP => i_n. + - apply: Z.ones_spec_low; lia. + apply: Z.ones_spec_high; lia. +Qed. + +Lemma wand_pow2nm1 sz (x: word sz) n : + let: k := ((wsize_size_minus_1 sz).+1 - n)%nat in + wand x (wrepr sz (2 ^ Z.of_nat n - 1)) = wshr (wshl x (Z.of_nat k)) (Z.of_nat k). +Proof. + set k := (_ - _)%nat. + have k_ge0 := Nat2Z.is_nonneg k. + apply/eqP/eq_from_wbit_n => i. + rewrite wandE wshrE // wshlE // wbit_n_pow2m1. + have := ltn_ord i. + move: (nat_of_ord i) => {i} i i_bounded. + replace (i < _)%nat with (i < n)%nat; last first. + - apply Nat.min_case_strong => // n_large. + rewrite i_bounded. + apply/ltP. + move/ltP: i_bounded. + Psatz.lia. + move: i_bounded. + subst k. + move: (wsize_size_minus_1 _) => w. + rewrite ltnS => /leP i_bounded. + rewrite Nat2Z.id. + case: ltP => i_n. + - rewrite (andbC (_ && _)); congr andb. + + congr (wbit_n x); lia. + symmetry; apply/andP; split; apply/leP; lia. + rewrite andbF. + replace (w.+1 - n + i <= w)%nat with false; first by rewrite andbF. + symmetry; apply/leP. + lia. +Qed. + +Section FORALL_NAT_BELOW. + Context (P: nat -> bool). + + Fixpoint forallnat_below (n: nat) : bool := + if n is S n' then if P n' then forallnat_below n' else false else true. + + Lemma forallnat_belowP n : + reflect (forall i, (i < n)%coq_nat -> P i) (forallnat_below n). + Proof. + elim: n. + - by constructor => i /Nat.nlt_0_r. + move => n ih /=; case hn: P; last first. + - constructor => /(_ n (Nat.lt_succ_diag_r n)). + by rewrite hn. + case: ih => ih; constructor. + - move => i i_le_n. + case: (i =P n); first by move => ->. + move => i_neq_n; apply: ih; lia. + move => K; apply: ih => i i_lt_n; apply: K; lia. + Qed. + +End FORALL_NAT_BELOW. + +(* Lemma wbit_n_Npow2n sz n (i: 'I_(wsize_size_minus_1 sz).+1) : *) +(* wbit_n (wrepr sz (-2 ^ Z.of_nat n)) i = (n <= i)%nat. *) +(* Proof. *) +(* move: (i: nat) (ltn_ord i) => {i} i /ltP i_bounded. *) +(* case: (@ltP n (wsize_size_minus_1 sz).+1) => hn. *) +(* + apply/eqP. *) +(* apply/forallnat_belowP: i i_bounded. *) +(* change ( *) +(* let k := wrepr sz (- 2 ^ Z.of_nat n) in *) +(* forallnat_below (fun i : nat => wbit_n k i == (n <= i)%nat) (wsize_size_minus_1 sz).+1 *) +(* ). *) +(* apply/forallnat_belowP: n hn. *) +(* by case: sz; vm_cast_no_check (erefl true). *) +(* replace (wrepr _ _) with (0%R : word sz). *) +(* rewrite w0E; symmetry; apply/leP; lia. *) +(* rewrite wrepr_opp -oppr0. *) +(* congr (-_)%R. *) +(* apply/word_eqP. *) +(* rewrite mkword_valK. *) +(* apply/eqP; symmetry. *) +(* rewrite /modulus two_power_nat_equiv. *) +(* apply/Z.mod_divide; first exact: pow2nz. *) +(* exists (2 ^ (Z.of_nat (n - (wsize_size_minus_1 sz).+1))). *) +(* rewrite -Z.pow_add_r; *) +(* first congr (2 ^ _). *) +(* all: lia. *) +(* Qed. *) + +(* Lemma wand_Npow2n sz (x: word sz) n : *) +(* wand x (wrepr sz (- 2 ^ Z.of_nat n)) = wshl (wshr x (Z.of_nat n)) (Z.of_nat n). *) +(* Proof. *) +(* apply/eqP/eq_from_wbit_n => i. *) +(* have n_ge0 := Nat2Z.is_nonneg n. *) +(* rewrite wandE wshlE // wshrE // Nat2Z.id wbit_n_Npow2n. *) +(* move: (nat_of_ord i) (ltn_ord i) => {i} i. *) +(* rewrite ltnS => i_bounded. *) +(* rewrite i_bounded andbT andbC. *) +(* case: (@leP n i) => hni //=. *) +(* congr (wbit_n x). *) +(* lia. *) +(* Qed. *) + +Lemma an_mod_bn_divn (a b n: Z) : + n <> 0 -> + a * n mod (b * n) / n = a mod b. +Proof. + by move => nnz; rewrite Zmult_mod_distr_r Z.div_mul. +Qed. + +Lemma wand_modulo sz (x: word sz) n : + wunsigned (wand x (wrepr sz (2 ^ Z.of_nat n - 1))) = wunsigned x mod 2 ^ Z.of_nat n. +Proof. + rewrite wand_pow2nm1 wunsigned_wshr wunsigned_wshl /wbase /modulus two_power_nat_equiv. + case: (@leP n (wsize_size_minus_1 sz).+1); last first. + - move => k_lt_n. + replace (_.+1 - n)%nat with 0%nat by lia. + have [ x_pos x_bounded ] := wunsigned_range x. + rewrite Z.mul_1_r Z.div_1_r !Z.mod_small //; split. + 1, 3: lia. + + apply: Z.lt_trans; first exact: x_bounded. + rewrite /wbase /modulus two_power_nat_equiv. + apply: Z.pow_lt_mono_r; lia. + by rewrite -two_power_nat_equiv. + set k := _.+1. + move => n_le_k. + have := an_mod_bn_divn (wunsigned x) (2 ^ Z.of_nat n) (@pow2nz (k - n)%nat). + rewrite -Z.pow_add_r. + 2-3: lia. + replace (Z.of_nat n + Z.of_nat (k - n)) with (Z.of_nat k) by lia. + done. +Qed. + +Lemma div_mul_in_range a b m : + 0 < b -> + 0 <= a < m -> + 0 <= a / b * b < m. +Proof. + move => b_pos a_range; split. + * suff : 0 <= a / b by Lia.nia. + apply: Z.div_pos; lia. + elim_div; lia. +Qed. + +(* Lemma wand_align sz (x: word sz) n : *) +(* wunsigned (wand x (wrepr sz (-2 ^ Z.of_nat n))) = wunsigned x / 2 ^ Z.of_nat n * 2 ^ Z.of_nat n. *) +(* Proof. *) +(* rewrite wand_Npow2n wunsigned_wshl wunsigned_wshr. *) +(* apply: Z.mod_small. *) +(* apply: div_mul_in_range. *) +(* - exact: pow2pos. *) +(* exact: wunsigned_range. *) +(* Qed. *) + +(* (** Round to the multiple of [sz'] below. *) *) +(* Definition align_word (sz sz': wsize) (p: word sz) : word sz := *) +(* wand p (wrepr sz (-wsize_size sz')). *) + +(* Lemma align_word_U8 sz (p: word sz) : *) +(* align_word U8 p = p. *) +(* Proof. by rewrite /align_word wandC wandN1. Qed. *) + +(* Lemma align_word_aligned (sz sz': wsize) (p: word sz) : *) +(* wunsigned (align_word sz' p) mod wsize_size sz' == 0. *) +(* Proof. *) +(* rewrite /align_word wsize_size_is_pow2 wand_align Z.mod_mul //. *) +(* exact: pow2nz. *) +(* Qed. *) + +(* Lemma align_word_range sz sz' (p: word sz) : *) +(* wunsigned p - wsize_size sz' < wunsigned (align_word sz' p) <= wunsigned p. *) +(* Proof. *) +(* rewrite /align_word wsize_size_is_pow2 wand_align. *) +(* have ? := wunsigned_range p. *) +(* have ? := pow2pos (wsize_log2 sz'). *) +(* elim_div; Psatz.lia. *) +(* Qed. *) + +(* Lemma align_wordE sz sz' (p: word sz) : *) +(* wunsigned (align_word sz' p) = wunsigned p - (wunsigned p mod wsize_size sz'). *) +(* Proof. *) +(* have nz := wsize_size_pos sz'. *) +(* rewrite {1}(Z.div_mod (wunsigned p) (wsize_size sz')); last lia. *) +(* rewrite /align_word wsize_size_is_pow2 wand_align. *) +(* lia. *) +(* Qed. *) + +(* (* ------------------------------------------------------------------------- *) *) +(* Lemma wror_opp sz (x: word sz) c : *) +(* wror x (wsize_bits sz - c) = wrol x c. *) +(* Proof. *) +(* rewrite /wror /wrol. *) +(* have : 0 < wsize_bits sz by []. *) +(* move: (wsize_bits _) (wshr_full x) (wshl_full x) => n R L n_pos. *) +(* have nnz : n ≠ 0 by lia. *) +(* rewrite Zminus_mod Z_mod_same_full Z.sub_0_l. *) +(* have : c mod n = 0 ∨ 0 < c mod n < n. *) +(* - move: (Z.mod_pos_bound c n n_pos); lia. *) +(* case => c_mod_n. *) +(* - by rewrite c_mod_n Z.sub_0_r Zmod_0_l wshr0 wshl0 R L. *) +(* rewrite !Z.mod_opp_l_nz // Zmod_mod; last lia. *) +(* rewrite worC; do 2 f_equal. *) +(* lia. *) +(* Qed. *) + +Lemma wror_m sz (x: word sz) y y' : + y mod wsize_bits sz = y' mod wsize_bits sz -> + wror x y = wror x y'. +Proof. by rewrite /wror => ->. Qed. + +(* ------------------------------------------------------------------------- *) + +Definition word_uincl sz1 sz2 (w1:word sz1) (w2:word sz2) := + (sz1 <= sz2)%CMP && (w1 == zero_extend sz1 w2). + +Lemma word_uincl_refl s (w : word s): word_uincl w w. +Proof. by rewrite /word_uincl zero_extend_u cmp_le_refl eqxx. Qed. +#[global] +Hint Resolve word_uincl_refl : core. + +Lemma word_uincl_eq s (w w': word s): + word_uincl w w' -> w = w'. +Proof. by move=> /andP [] _ /eqP; rewrite zero_extend_u. Qed. + +(* Lemma word_uincl_trans s2 w2 s1 s3 w1 w3 : *) +(* @word_uincl s1 s2 w1 w2 -> @word_uincl s2 s3 w2 w3 -> word_uincl w1 w3. *) +(* Proof. *) +(* rewrite /word_uincl => /andP [hle1 /eqP ->] /andP [hle2 /eqP ->]. *) +(* by rewrite (cmp_le_trans hle1 hle2) zero_extend_idem // eqxx. *) +(* Qed. *) + +Lemma word_uincl_zero_ext sz sz' (w':word sz') : (sz ≤ sz')%CMP -> word_uincl (zero_extend sz w') w'. +Proof. by move=> ?;apply /andP. Qed. + +(* Lemma word_uincl_zero_extR sz sz' (w: word sz) : *) +(* (sz ≤ sz')%CMP -> *) +(* word_uincl w (zero_extend sz' w). *) +(* Proof. *) +(* move => hle; apply /andP; split; first exact: hle. *) +(* by rewrite zero_extend_idem // zero_extend_u. *) +(* Qed. *) + +Lemma truncate_word_uincl sz1 sz2 w1 (w2: word sz2) : + truncate_word sz1 w2 = ok w1 -> word_uincl w1 w2. +Proof. by move=> /truncate_wordP[? ->]; exact: word_uincl_zero_ext. Qed. + +(* Lemma word_uincl_truncate sz1 (w1: word sz1) sz2 (w2: word sz2) sz w: *) +(* word_uincl w1 w2 -> truncate_word sz w1 = ok w -> truncate_word sz w2 = ok w. *) +(* Proof. *) +(* rewrite /word_uincl => /andP[hc1 /eqP ->] /truncate_wordP[hc2 ->]. *) +(* rewrite (zero_extend_idem _ hc2) truncate_word_le //. *) +(* exact: (cmp_le_trans hc2 hc1). *) +(* Qed. *) + +(* -------------------------------------------------------------------- *) +(* TODO_ARM: Move? *) + +Lemma ZlnotE (x : Z) : + Z.lnot x = (- (x + 1))%Z. +Proof. have := Z.add_lnot_diag x. lia. Qed. + +Lemma Zlxor_mod (a b n : Z) : + (0 <= n)%Z + -> ((Z.lxor a b) mod 2^n)%Z = (Z.lxor (a mod 2^n) (b mod 2^n))%Z. +Proof. + move=> hn. + apply: Z.bits_inj'. + move=> i _. + rewrite Z.lxor_spec. + + case: (Z.lt_ge_cases i n) => [hlt | hge]. + - rewrite 3!(Z.mod_pow2_bits_low _ _ _ hlt). exact: Z.lxor_spec. + + have hrange: (0 <= n <= i)%Z. + - by split. + by rewrite 3!(Z.mod_pow2_bits_high _ _ _ hrange). +Qed. + +(* -------------------------------------------------------------------- *) + +Lemma wrepr_xor ws (x y : Z) : + wxor (wrepr ws x) (wrepr ws y) = wrepr ws (Z.lxor x y). +Proof. + apply: word_ext. + rewrite /wrepr /=. + set wsz := (wsize_size_minus_1 ws).+1. + change (word.modulus wsz) with (two_power_nat wsz). + rewrite two_power_nat_equiv. + by rewrite Zlxor_mod. +Qed. + +Lemma wrepr_wnot ws z : + wnot (wrepr ws z) = wrepr ws (Z.lnot z). +Proof. by rewrite /wnot wrepr_xor Z.lxor_m1_r. Qed. + +Lemma wnot_wnot ws (x : word ws) : + wnot (wnot x) = x. +Proof. by rewrite -(wrepr_unsigned x) 2!wrepr_wnot Z.lnot_involutive. Qed. + +Lemma wnotP ws (x : word ws) : + wnot x = wrepr ws (Z.lnot (wunsigned x)). +Proof. by rewrite -{1}(wrepr_unsigned x) wrepr_wnot. Qed. + +Lemma msb_wnot ws (x : word ws) : + msb (wnot x) = ~~ msb x. +Proof. rewrite /msb. by have /= -> := wnotE x (Ordinal (ltnSn _)). Qed. + +(* Lemma wnot1_wopp ws (x : word ws) : *) +(* (wnot x + 1)%R = (- x)%R. *) +(* Proof. *) +(* rewrite wnotP. *) +(* rewrite wrepr_add. *) +(* rewrite wrepr_opp. *) +(* rewrite wrepr_unsigned. *) +(* rewrite wrepr_m1. *) +(* exact: GRing.Theory.addrNK. *) +(* Qed. *) + +(* Lemma wsub_wnot1 ws (x y : word ws) : *) +(* (x + wnot y + 1)%R = (x - y)%R . *) +(* Proof. by rewrite -GRing.Theory.addrA wnot1_wopp. Qed. *) + +Lemma wunsigned_wnot ws (x : word ws) : + wunsigned (wnot x) = (wbase ws - wunsigned x - 1)%Z. +Proof. + rewrite wnotP wunsigned_repr. + change (word.modulus (wsize_size_minus_1 ws).+1) with (wbase ws). + rewrite ZlnotE. + rewrite -(Z.mod_add _ 1 _); last exact: wbase_n0. + rewrite Zmod_small; first lia. + have := wunsigned_range x. + lia. +Qed. + +Lemma wsigned_wnot ws (x : word ws) : + (wsigned (wnot x))%Z = (- wsigned x - 1)%Z. +Proof. + rewrite 2!wsignedE. + rewrite msb_wnot. + case: msb => /=; + rewrite wunsigned_wnot; + lia. +Qed. + +Lemma wsigned_wsub_wnot1 ws (x y : word ws) : + (wsigned x + wsigned (wnot y) + 1)%Z = (wsigned x - wsigned y)%Z. +Proof. rewrite -Z.add_assoc wsigned_wnot. lia. Qed. + +Lemma unsigned_overflow sz (z: Z): + (0 <= z)%Z -> + (wunsigned (wrepr sz z) != z) = (wbase sz <=? z)%Z. +Proof. + move => hz. + rewrite wunsigned_repr; apply/idP/idP. + * apply: contraR => /negbTE /Z.leb_gt lt; apply/eqP. + by rewrite Z.mod_small //; lia. + * apply: contraL => /eqP <-; apply/negbT/Z.leb_gt. + by case: (Z_mod_lt z (wbase sz)). +Qed. + +Lemma add_overflow sz (w1 w2: word sz) : + (wbase sz <=? wunsigned w1 + wunsigned w2)%Z = + (wunsigned (w1 + w2) != (wunsigned w1 + wunsigned w2)%Z). +Proof. + rewrite unsigned_overflow //; rewrite -!/(wunsigned _). + have := wunsigned_range w1; have := wunsigned_range w2. + lia. +Qed. + +Lemma wbit_pow_2 ws n x (i : nat) : + 0 <= n + -> (Z.to_nat n <= i <= wsize_size_minus_1 ws)%nat + -> wbit_n (wrepr ws (2 ^ n * x)) i = wbit_n (wrepr ws x) (i - Z.to_nat n). +Proof. + move=> h0n hrange. + rewrite wrepr_mul. + rewrite -(wshl_sem _ h0n). + rewrite wshlE //. + by rewrite hrange. +Qed. + +(* Notation pointer := (word Uptr) (only parsing). *) + +Lemma subword_make_vec_bits_low (n m : nat) x y : + (n < m)%Z -> + word.subword 0 n (word.mkword m (wcat_r [:: x; y ])) = x. +Proof. + move=> h. + apply/eqP/word.eq_from_wbit => i. + rewrite subwordE wbit_t2wE /word.word.wbit /=. + rewrite (nth_map i); last by rewrite size_enum_ord. + rewrite addn0 nth_ord_enum modulusZE. + rewrite Z.shiftl_0_l Z.lor_0_r. + rewrite Z.mod_pow2_bits_low. + - rewrite Z.lor_spec Z.shiftl_spec_low; first by rewrite orbF. + by apply/ZNltP. + apply: (Z.lt_trans _ _ _ _ h). + by apply/ZNltP. +Qed. + +Lemma Z_lor_le x y ws : + (0 <= x < wbase ws)%Z -> + (0 <= y < wbase ws)%Z -> + (0 <= Z.lor x y < wbase ws)%Z. +Proof. + move=> /iswordZP hx /iswordZP hy. + rewrite -[x]/(urepr (mkWord hx)) -[y]/(urepr (mkWord hy)). + apply/iswordZP. + exact: word.wor_subproof. +Qed. + +(* Lemma make_vec_4x64 (w : word.word U64) : *) +(* make_vec U256 [:: make_vec U128 [:: w; w ]; make_vec U128 [:: w; w ]] *) +(* = make_vec U256 [:: w; w; w; w ]. *) +(* Proof. *) +(* rewrite /make_vec /wcat_r. *) +(* rewrite !Z.shiftl_0_l !Z.lor_0_r. *) +(* f_equal. *) +(* rewrite Z.shiftl_lor. *) +(* rewrite Z.lor_assoc. *) +(* rewrite Z.shiftl_shiftl; last done. *) +(* rewrite -![urepr _]/(wunsigned _). *) +(* rewrite wunsigned_repr_small; first done. *) + +(* have [hw0 hwn] := wunsigned_range w. *) + +(* apply: Z_lor_le. *) +(* - have := @wbase_m U64 U128 refl_equal. Psatz.lia. *) + +(* rewrite Z.shiftl_mul_pow2; last done. *) +(* split; first Psatz.lia. *) +(* rewrite /wbase (modulusD 64 64) modulusE -expZE. *) +(* apply: ltZE; rewrite mulZE !rmorphM/= ltr_pM2r//. *) +(* by rewrite -[ltRHS]/(Z_to_int 18446744073709551616); apply/ltZE. *) +(* Qed. *) + +(******************************) From cba2823ef64aa76f1db2dd3c1395100f5bcfc16b Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Thu, 14 Mar 2024 17:28:04 +0100 Subject: [PATCH 381/383] cleanup --- _CoqProject | 2 +- theories/Crypt/Casts.v | 32 ++++++-- theories/Crypt/choice_type.v | 151 ++++++++++++++++------------------- 3 files changed, 97 insertions(+), 88 deletions(-) diff --git a/_CoqProject b/_CoqProject index 008e3e9f..59e64d6a 100644 --- a/_CoqProject +++ b/_CoqProject @@ -23,10 +23,10 @@ theories/Relational/Commutativity.v theories/Crypt/Prelude.v theories/Crypt/Axioms.v -theories/Crypt/Casts.v theories/Crypt/jasmin_util.v theories/Crypt/jasmin_wsize.v theories/Crypt/jasmin_word.v +theories/Crypt/Casts.v theories/Crypt/choice_type.v # Categorical semantics diff --git a/theories/Crypt/Casts.v b/theories/Crypt/Casts.v index 5a9a96f4..402733b6 100644 --- a/theories/Crypt/Casts.v +++ b/theories/Crypt/Casts.v @@ -1,5 +1,5 @@ Set Warnings "-ambiguous-paths,-notation-overridden,-notation-incompatible-format". -From mathcomp Require Import ssreflect ssrbool ssrnat choice fintype. +From mathcomp Require Import ssreflect ssrbool ssrnat choice fintype eqtype all_algebra. Set Warnings "ambiguous-paths,notation-overridden,notation-incompatible-format". From deriving Require Import deriving. @@ -10,6 +10,25 @@ From Crypt Require Import Prelude. From HB Require Import structures. +From mathcomp Require Import word_ssrZ word. +From Crypt Require Import jasmin_word jasmin_util. + +Check jasmin_word.word. + +Set Equations With UIP. + +Set Bullet Behavior "Strict Subproofs". +Set Default Goal Selector "!". +Set Primitive Projections. + +Open Scope type_scope. + +HB.instance Definition _ nbits := + [Ord of (word nbits) by <:]. + +HB.instance Definition _ nbits := + [Choice of (word nbits) by <:]. + (** Note for any of these types it would also be okay to write the cast, e.g., [(nat:choiceType)%type], directly in the term. @@ -17,10 +36,6 @@ From HB Require Import structures. Just delete as soon as all references to the below casts are gone from the code base. *) -(* From mathcomp Require Import *) -(* ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype generic_quotient *) -(* tuple. *) - Definition unit_choiceType : choiceType := Datatypes.unit. Definition nat_choiceType : choiceType := nat. Definition int_choiceType : choiceType := Z. @@ -29,6 +44,9 @@ Definition prod_choiceType (A B: choiceType) : choiceType := prod A B. Definition fmap_choiceType (A: ordType) (B: choiceType) : choiceType := {fmap A -> B}. Definition option_choiceType (A: choiceType) : choiceType := option A. Definition fin_choiceType (p: positive) : choiceType := ordinal p.(pos). +Definition word_choiceType (nbits : wsize) : choiceType := word nbits. +Definition list_choiceType (A : choiceType) : choiceType := list A. + Definition sum_choiceType (A B: choiceType) : choiceType := (A + B)%type. Definition unit_ordType: ordType := Datatypes.unit. @@ -39,6 +57,10 @@ Definition prod_ordType (A B: ordType) : ordType := prod A B. Definition fmap_ordType (A B: ordType) : ordType := {fmap A -> B}. Definition option_ordType (A: ordType) : ordType := option A. Definition fin_ordType (p: positive) : ordType := ordinal p.(pos). +Definition word_ordType (nbits : wsize) : ordType := word nbits. +Definition list_ordType (A : ordType) : ordType := list A. + + Definition sum_ordType (A B: ordType) : ordType := (A + B)%type. diff --git a/theories/Crypt/choice_type.v b/theories/Crypt/choice_type.v index 723b106e..6417c21a 100644 --- a/theories/Crypt/choice_type.v +++ b/theories/Crypt/choice_type.v @@ -58,38 +58,34 @@ Inductive choice_type := Derive NoConfusion NoConfusionHom for choice_type. - -#[hnf] HB.instance Definition _ nbits := - [Ord of (word nbits) by <:]. - Fixpoint chElement_ordType (U : choice_type) : ordType := match U with - | chUnit => Datatypes_unit__canonical__Ord_Ord - | chNat => Datatypes_nat__canonical__Ord_Ord - | chInt => BinNums_Z__canonical__Ord_Ord - | chBool => Datatypes_bool__canonical__Ord_Ord - | chProd U1 U2 => Datatypes_prod__canonical__Ord_Ord (chElement_ordType U1) (chElement_ordType U2) - | chMap U1 U2 => FMap_fmap_type__canonical__Ord_Ord (chElement_ordType U1) (chElement_ordType U2) - | chOption U => Datatypes_option__canonical__Ord_Ord (chElement_ordType U) - | chFin n => fintype_ordinal__canonical__Ord_Ord n.(pos) - | chWord nbits => ComRing_sort__canonical__Ord_Ord nbits - | chList U => Datatypes_list__canonical__Ord_Ord (chElement_ordType U) - | chSum U1 U2 => Datatypes_sum__canonical__Ord_Ord (chElement_ordType U1) (chElement_ordType U2) + | chUnit => unit_ordType + | chNat => nat_ordType + | chInt => int_ordType + | chBool => bool_ordType + | chProd U1 U2 => prod_ordType (chElement_ordType U1) (chElement_ordType U2) + | chMap U1 U2 => fmap_ordType (chElement_ordType U1) (chElement_ordType U2) + | chOption U => option_ordType (chElement_ordType U) + | chFin n => fin_ordType n + | chWord nbits => word_ordType nbits + | chList U => list_ordType (chElement_ordType U) + | chSum U1 U2 => sum_ordType (chElement_ordType U1) (chElement_ordType U2) end. Fixpoint chElement (U : choice_type) : choiceType := match U with - | chUnit => Datatypes_unit__canonical__choice_Choice - | chNat => Datatypes_nat__canonical__choice_Choice - | chInt => BinNums_Z__canonical__choice_Choice - | chBool => Datatypes_bool__canonical__choice_Choice - | chProd U1 U2 => Datatypes_prod__canonical__choice_Choice (chElement U1) (chElement U2) - | chMap U1 U2 => FMap_fmap_type__canonical__choice_Choice (chElement_ordType U1) (chElement U2) - | chOption U => Datatypes_option__canonical__choice_Choice (chElement U) - | chFin n => fintype_ordinal__canonical__choice_Choice n.(pos) - | chWord nbits => ComRing_sort__canonical__Ord_Ord nbits - | chList U => Datatypes_list__canonical__choice_Choice (chElement U) - | chSum U1 U2 => Datatypes_sum__canonical__choice_Choice (chElement U1) (chElement U2) + | chUnit => unit_choiceType + | chNat => nat_choiceType + | chInt => int_choiceType + | chBool => bool_choiceType + | chProd U1 U2 => prod_choiceType (chElement U1) (chElement U2) + | chMap U1 U2 => fmap_choiceType (chElement_ordType U1) (chElement U2) + | chOption U => option_choiceType (chElement U) + | chFin n => fin_choiceType n + | chWord nbits => word_choiceType nbits + | chList U => list_choiceType (chElement U) + | chSum U1 U2 => sum_choiceType (chElement U1) (chElement U2) end. Coercion chElement : choice_type >-> choiceType. @@ -119,16 +115,6 @@ Defined. Section choice_typeTypes. - (* Definition choice_type_indDef := [indDef for choice_type_rect]. *) - (* Canonical choice_type_indType := IndType choice_type choice_type_indDef. *) - (* Definition choice_type_eqMixin := [derive eqMixin for choice_type]. *) - (* Canonical choice_type_eqType := EqType choice_type choice_type_eqMixin. *) - - (* Definition choice_type_eq := *) - (* match choice_type_eqMixin with *) - (* | EqMixin op => op *) - (* end. *) - Fixpoint choice_type_test (u v : choice_type) : bool := match u, v with | chNat , chNat => true @@ -230,7 +216,7 @@ Section choice_typeTypes. | chProd _ _, chInt => false | chProd u1 u2, chProd w1 w2 => (choice_type_lt u1 w1) || - (choice_type_test u1 w1 && choice_type_lt u2 w2) + (eq_op u1 w1 && choice_type_lt u2 w2) | chProd _ _, _ => true | chMap _ _, chUnit => false | chMap _ _, chBool => false @@ -239,7 +225,7 @@ Section choice_typeTypes. | chMap _ _, chProd _ _ => false | chMap u1 u2, chMap w1 w2 => (choice_type_lt u1 w1) || - (choice_type_test u1 w1 && choice_type_lt u2 w2) + (eq_op u1 w1 && choice_type_lt u2 w2) | chMap _ _, _ => true | chOption _, chUnit => false | chOption _, chBool => false @@ -291,11 +277,11 @@ Section choice_typeTypes. | chSum _ _, chList _ => false | chSum u1 u2, chSum w1 w2 => (choice_type_lt u1 w1) || - (choice_type_test u1 w1 && choice_type_lt u2 w2) + (eq_op u1 w1 && choice_type_lt u2 w2) end. Definition choice_type_leq (t1 t2 : choice_type) := - choice_type_eq t1 t2 || choice_type_lt t1 t2. + eq_op t1 t2 || choice_type_lt t1 t2. Lemma choice_type_lt_transitive : transitive (T:=choice_type) choice_type_lt. Proof. @@ -389,7 +375,7 @@ Section choice_typeTypes. Proof. intros x. induction x as [ | | | | x1 ih1 x2 ih2 | x1 ih1 x2 ih2 | x ih | x | x | x ih | x1 ih1 x2 ih2] in |- *. - all: intuition auto; simpl. + all: intuition; simpl. - simpl. apply/norP. split. + apply ih1. @@ -412,31 +398,30 @@ Section choice_typeTypes. Lemma choice_type_lt_total_holds : ∀ x y, - ~~ (choice_type_test x y) ==> (choice_type_lt x y || choice_type_lt y x). + ~~ (eq_op x y) ==> (choice_type_lt x y || choice_type_lt y x). Proof. - intros x y. - induction x as [ | | | | x1 ih1 x2 ih2| x1 ih1 x2 ih2| x ih| x | x | x ih | x1 ih1 x2 ih2] - in y |- *. - all: try solve [ destruct y ; intuition eauto ; reflexivity ]. + intros x. + induction x as [ | | | | x1 ih1 x2 ih2| x1 ih1 x2 ih2| x ih| x | x | x ih | x1 ih1 x2 ih2]. + all: try solve [ destruct y ; auto with solve_subterm ; reflexivity ]. (* chProd *) - - destruct y. all: try (intuition auto; reflexivity). + - destruct y. all: try (intuition; reflexivity). cbn. specialize (ih1 y1). specialize (ih2 y2). apply/implyP. move /nandP => H. apply/orP. - destruct (choice_type_test x1 y1) eqn:Heq. - + destruct H. 1: discriminate. + destruct (eq_op x1 y1) eqn:Heq. + + destruct H. 1: now setoid_rewrite Heq in H. move: ih2. move /implyP => ih2. specialize (ih2 H). move: ih2. move /orP => ih2. destruct ih2. * left. apply/orP. right. apply/andP. split. - all: intuition auto. - * right. apply/orP. right. apply/andP. intuition auto. + all: intuition. + * right. apply/orP. right. apply/andP. intuition. move: Heq. move /eqP => Heq. rewrite Heq. apply/eqP. reflexivity. + destruct H. - * move: ih1. move /implyP => ih1. + * move: ih1. rewrite -Heq; move /implyP => ih1. specialize (ih1 H). move: ih1. move /orP => ih1. destruct ih1. @@ -455,25 +440,25 @@ Section choice_typeTypes. +++ left. apply/orP. left. assumption. +++ right. apply/orP. left. assumption. (* chMap *) - - destruct y. all: try (intuition auto; reflexivity). + - destruct y. all: try (intuition; reflexivity). cbn. specialize (ih1 y1). specialize (ih2 y2). apply/implyP. move /nandP => H. apply/orP. - destruct (choice_type_test x1 y1) eqn:Heq. - + destruct H. 1: discriminate. + destruct (eq_op x1 y1) eqn:Heq. + + destruct H. 1: now setoid_rewrite Heq in H. move: ih2. move /implyP => ih2. specialize (ih2 H). move: ih2. move /orP => ih2. destruct ih2. * left. apply/orP. right. apply/andP. split. - all: intuition auto. - * right. apply/orP. right. apply/andP. intuition auto. + all: intuition. + * right. apply/orP. right. apply/andP. intuition. move: Heq. move /eqP => Heq. rewrite Heq. apply/eqP. reflexivity. + destruct H. * move: ih1. move /implyP => ih1. - specialize (ih1 H). + specialize (ih1 isT). move: ih1. move /orP => ih1. destruct ih1. -- left. apply/orP. left. assumption. @@ -491,15 +476,13 @@ Section choice_typeTypes. +++ left. apply/orP. left. assumption. +++ right. apply/orP. left. assumption. (* chFin *) - - destruct y. all: try (intuition auto; reflexivity). + - destruct y. all: try (intuition; reflexivity). unfold choice_type_lt. - unfold choice_type_test. rewrite -neq_ltn. apply /implyP. auto. (* chWord *) - - destruct y. all: try (intuition auto; reflexivity). + - destruct y. all: try (intuition; reflexivity). unfold choice_type_lt. - unfold choice_type_test. apply /implyP. move => H. apply /orP. destruct (gcmp x nbits) eqn:E. @@ -507,25 +490,25 @@ Section choice_typeTypes. + left. by apply /eqP. + right. unfold cmp_lt. rewrite cmp_sym. by move: E => ->. (* chSum *) - - destruct y. all: try (intuition auto; reflexivity). + - destruct y. all: try (intuition; reflexivity). cbn. specialize (ih1 y1). specialize (ih2 y2). apply/implyP. move /nandP => H. apply/orP. - destruct (choice_type_test x1 y1) eqn:Heq. - + destruct H. 1: discriminate. + destruct (eq_op x1 y1) eqn:Heq. + + destruct H. 1: now setoid_rewrite Heq in H. move: ih2. move /implyP => ih2. specialize (ih2 H). move: ih2. move /orP => ih2. destruct ih2. * left. apply/orP. right. apply/andP. split. - all: intuition auto. - * right. apply/orP. right. apply/andP. intuition auto. + all: intuition. + * right. apply/orP. right. apply/andP. intuition. move: Heq. move /eqP => Heq. rewrite Heq. apply/eqP. reflexivity. + destruct H. * move: ih1. move /implyP => ih1. - specialize (ih1 H). + specialize (ih1 isT). move: ih1. move /orP => ih1. destruct ih1. -- left. apply/orP. left. assumption. @@ -551,7 +534,7 @@ Section choice_typeTypes. intros x y. apply /implyP. move => H. destruct (~~ choice_type_lt y x) eqn:Heq. - - intuition auto. + - intuition. - move: Heq. move /negP /negP => Heq. pose (choice_type_lt_areflexive x) as Harefl. move: Harefl. apply /implyP. rewrite implyNb. @@ -561,7 +544,7 @@ Section choice_typeTypes. Lemma choice_type_lt_total_not_holds : ∀ x y, - ~~ (choice_type_test x y) ==> (~~ (choice_type_lt x y && choice_type_lt y x)). + ~~ (eq_op x y) ==> (~~ (choice_type_lt x y && choice_type_lt y x)). Proof. intros x y. apply /implyP. intros Hneq. pose (choice_type_lt_total_holds x y) as Htot. @@ -575,27 +558,27 @@ Section choice_typeTypes. Lemma choice_type_lt_tot : ∀ x y, - (choice_type_lt x y || choice_type_lt y x || choice_type_eq x y). + (choice_type_lt x y || choice_type_lt y x || eq_op x y). Proof. intros x y. - destruct (choice_type_eq x y) eqn:H. - - apply/orP. intuition auto. + destruct (eq_op x y) eqn:H. + - apply/orP. by right. - apply/orP. left. unfold choice_type_eq in H. pose (choice_type_lt_total_holds x y). move: i. move /implyP => i. apply i. apply/negP. - intuition auto. move: H0. rewrite H. intuition auto. + intuition. move: H0. rewrite H. intuition. Qed. - Lemma choice_type_leqxx : reflexive (T:=choice_type) choice_type_leq. + Lemma choice_type_leqxx : reflexive choice_type_leq. Proof. intro x. unfold choice_type_leq. apply/orP. left. apply /eqP. reflexivity. Qed. - Lemma choice_type_leq_transitive : transitive (T:=choice_type) choice_type_leq. + Lemma choice_type_leq_trans : transitive choice_type_leq. Proof. intros v u w h1 h2. move: h1 h2. unfold choice_type_leq. @@ -609,7 +592,7 @@ Section choice_typeTypes. * apply/orP. right. exact (choice_type_lt_transitive _ _ _ H H0). Qed. - Lemma choice_type_leq_asym : antisymmetric (T:=choice_type) choice_type_leq. + Lemma choice_type_leq_asym : antisymmetric choice_type_leq. Proof. unfold antisymmetric. @@ -617,10 +600,10 @@ Section choice_typeTypes. move: h1 h2. unfold choice_type_leq. move /orP => h1. move /orP => h2. destruct h1. - 1:{ move: H. move /eqP. intuition auto. } + 1:{ move: H. move /eqP. intuition. } destruct h2. - 1:{ move: H0. move /eqP. intuition auto. } - destruct (~~ (choice_type_test x y)) eqn:Heq. + 1:{ move: H0. move /eqP. intuition. } + destruct (~~ (eq_op x y)) eqn:Heq. + move: Heq. move /idP => Heq. pose (choice_type_lt_total_not_holds x y) as Hp. move: Hp. move /implyP => Hp. specialize (Hp Heq). @@ -634,7 +617,7 @@ Section choice_typeTypes. Qed. - Lemma choice_type_leq_total : total (T:=choice_type) choice_type_leq. + Lemma choice_type_leq_total : total choice_type_leq. unfold total. intros x y. unfold choice_type_leq. pose (choice_type_lt_tot x y). @@ -720,5 +703,9 @@ Section choice_typeTypes. HB.instance Definition _ := PCanHasChoice codeK. HB.instance Definition _ := - (@hasOrd.Build choice_type (choice_type_leq) (choice_type_leqxx) (choice_type_leq_transitive) (choice_type_leq_asym) (choice_type_leq_total)). + hasOrd.Build choice_type + (choice_type_leqxx) + (choice_type_leq_trans) + (choice_type_leq_asym) + (choice_type_leq_total). End choice_typeTypes. From fbb670ca1241e62adb150039cb887deb94e08f19 Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Thu, 5 Sep 2024 03:04:30 +0200 Subject: [PATCH 382/383] Removed location from aux protocol --- theories/Crypt/examples/SigmaProtocol.v | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/theories/Crypt/examples/SigmaProtocol.v b/theories/Crypt/examples/SigmaProtocol.v index d31d5df0..186bde49 100644 --- a/theories/Crypt/examples/SigmaProtocol.v +++ b/theories/Crypt/examples/SigmaProtocol.v @@ -224,6 +224,7 @@ Module SigmaProtocol (π : SigmaProtocolParams) } ]. + (* Simulation Sound Extractability *) (* Main security statement for 2-special soundness. *) Definition ɛ_soundness A := AdvantageE Special_Soundness_t Special_Soundness_f A. @@ -937,7 +938,7 @@ Module SigmaProtocol (π : SigmaProtocolParams) ]. Definition SHVZK_real_aux : - package Sigma_locs + package fset0 [interface #val #[ TRANSCRIPT ] : chInput → chTranscript ] [interface #val #[ RUN ] : chRelation → chTranscript ] := @@ -966,7 +967,9 @@ Module SigmaProtocol (π : SigmaProtocolParams) 2:{ rewrite <- fsetUid. eapply valid_link. - - apply SHVZK_real_aux. + - eapply (valid_package_inject_locations). + 2: apply SHVZK_real_aux. + apply fsub0set. - apply SHVZK_real. } 1:{ From 1646b52dfc3e0327dc439b0770d0d941f8cac8fe Mon Sep 17 00:00:00 2001 From: Lasse Letager Hansen Date: Fri, 6 Sep 2024 12:12:14 +0200 Subject: [PATCH 383/383] Update opam file --- ssprove.opam | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ssprove.opam b/ssprove.opam index 18402995..a56f190c 100644 --- a/ssprove.opam +++ b/ssprove.opam @@ -12,7 +12,7 @@ depends: [ "coq-equations" {>= "1.3+8.18"} "coq-mathcomp-ssreflect" {(>= "2.1.0")} "coq-mathcomp-analysis" {= "1.0.0"} - "coq-mathcomp-word" {>= "3.0"} + "coq-mathcomp-word" {>= "3.0" & < "3.2"} "coq-extructures" {(>= "0.4.0" & < "dev")} "coq-deriving" {(>= "0.2.0" & < "dev")} "coq-mathcomp-zify" {>= "1.5.0+2.0+8.16"}