diff --git a/src/Bedrock/End2End/X25519/GarageDoor.v b/src/Bedrock/End2End/X25519/GarageDoor.v index aabbc6ab22..1b5d202965 100644 --- a/src/Bedrock/End2End/X25519/GarageDoor.v +++ b/src/Bedrock/End2End/X25519/GarageDoor.v @@ -220,7 +220,7 @@ Definition garagedoor_iteration : state -> list (lightbulb_spec.OP _) -> state - udp_local ++ udp_remote ++ be2 udp_length ++ be2 0 ++ garagedoor_header ++ - le_split 32 (F.to_Z (x25519_gallina (le_combine sk) (F.of_Z Field.M_pos 9))))) + le_split 32 (F.to_Z (x25519_gallina (le_combine sk) (F.of_Z _ 9))))) ioh /\ SEED=seed /\ SK=sk. Local Instance spec_of_recvEthernet : spec_of "recvEthernet" := spec_of_recvEthernet. @@ -387,7 +387,7 @@ Proof. subst pPPP. seprewrite_in_by (Array.bytearray_append cmp1) H33 SepAutoArray.listZnWords. - remember (le_split 32 (F.to_Z (x25519_gallina (le_combine sk) (Field.feval_bytes _)))) as vv. + set (k := (Field.feval_bytes _)); remember (le_split 32 (F.to_Z (x25519_gallina (le_combine sk) k))) as vv; subst k. repeat straightline. pose proof (List.firstn_skipn 16 vv) as Hvv. pose proof (@firstn_length_le _ vv 16 ltac:(subst vv; rewrite ?length_le_split; ZnWords)). @@ -852,7 +852,7 @@ Optimize Proof. Optimize Heap. { rewrite ?app_length, ?length_le_split. SepAutoArray.listZnWords. } { ZnWords. } - pose proof length_le_split 32 (F.to_Z (x25519_gallina (le_combine sk) (F.of_Z Field.M_pos 9))) as Hpkl. + pose proof length_le_split 32 (F.to_Z (x25519_gallina (le_combine sk) (F.of_Z _ 9))) as Hpkl. seprewrite_in_by (fun xs ys=>@bytearray_address_merge _ _ _ _ _ xs ys buf) H37 SepAutoArray.listZnWords. seprewrite_in_by (fun xs ys=>@bytearray_address_merge _ _ _ _ _ xs ys buf) H37 SepAutoArray.listZnWords. diff --git a/src/Bedrock/End2End/X25519/MontgomeryLadder.v b/src/Bedrock/End2End/X25519/MontgomeryLadder.v index e2e2ee4e35..bd86664336 100644 --- a/src/Bedrock/End2End/X25519/MontgomeryLadder.v +++ b/src/Bedrock/End2End/X25519/MontgomeryLadder.v @@ -53,7 +53,9 @@ Require Import coqutil.Map.OfListWord Coq.Init.Byte coqutil.Byte. Import ProgramLogic.Coercions. Local Notation "m =* P" := ((P%sep) m) (at level 70, only parsing) (* experiment*). Local Notation "xs $@ a" := (Array.array ptsto (word.of_Z 1) a xs) (at level 10, format "xs $@ a"). -Definition x25519_gallina := montladder_gallina (Field.M_pos(FieldParameters:=field_parameters)) Field.a24 (Z.to_nat (Z.log2 (Z.pos order))). +Definition x25519_gallina K U : F (2^255-19) := + @XZ.M.montladder _ F.zero F.one F.add F.sub F.mul F.inv (F.div (F.of_Z _ 486662 - F.of_Z _ 2) (F.of_Z _ 4)) + (Z.to_nat (Z.log2 (Z.pos order))) (Z.testbit K) U. Global Instance spec_of_x25519 : spec_of "x25519" := fnspec! "x25519" out sk pk / (o s p : list Byte.byte) (R : _ -> Prop), { requires t m := m =* s$@sk * p$@pk * o$@out * R /\ diff --git a/src/Bedrock/End2End/X25519/MontgomeryLadderProperties.v b/src/Bedrock/End2End/X25519/MontgomeryLadderProperties.v index cf491b9cea..5e44c09f16 100644 --- a/src/Bedrock/End2End/X25519/MontgomeryLadderProperties.v +++ b/src/Bedrock/End2End/X25519/MontgomeryLadderProperties.v @@ -42,7 +42,7 @@ Definition montladder_post (pOUT pK pU : word.rep (word:=Naive.word32)) (BW:=BW32) (field_representaton:=field_representation n s c) (Some Field.tight_bounds) pOUT - (montladder_gallina Field.M_pos Field.a24 (Z.to_nat (Z.log2 Curve25519.order)) K U) + (@XZ.M.montladder _ F.zero F.one F.add F.sub F.mul F.inv a24 (Z.log2 Curve25519.order) (Z.testbit K) U) ⋆ Array.array ptsto (word.of_Z 1) pK Kbytes ⋆ FElem (BW:=BW32) (field_representaton:=field_representation n s c) diff --git a/src/Bedrock/Group/ScalarMult/MontgomeryEquivalence.v b/src/Bedrock/Group/ScalarMult/MontgomeryEquivalence.v deleted file mode 100644 index b5eab9abab..0000000000 --- a/src/Bedrock/Group/ScalarMult/MontgomeryEquivalence.v +++ /dev/null @@ -1,83 +0,0 @@ -Require Import Coq.micromega.Lia. -Require Import Coq.ZArith.ZArith. -Require Import Rupicola.Lib.Api. -Require Import Crypto.Bedrock.Group.ScalarMult.CSwap. -Require Import bedrock2.Semantics. -Require Import coqutil.Tactics.Tactics. -Require Import Crypto.Arithmetic.PrimeFieldTheorems. -Require Import Crypto.Bedrock.Specs.Field. -Require Import Crypto.Bedrock.Group.Loops. -Require Import Crypto.Bedrock.Group.ScalarMult.LadderStep. -Require Import Crypto.Bedrock.Group.ScalarMult.MontgomeryLadder. -Require Import Crypto.Curves.Montgomery.XZ. -Require Import Crypto.Curves.Montgomery.XZProofs. -Require Import Crypto.Util.Loops. - -Section Equivalence. - Context {field_parameters : FieldParameters}. - - (*TODO: which of ladderstep_gallina and M.xzladderstep should we change? either?*) - Definition reorder_pairs {A B C D} (p : \<>) : (A*B)*(C*D) := - (P2.car p, P2.car (P2.cdr p),((P2.car (P2.cdr (P2.cdr p))),(P2.cdr (P2.cdr (P2.cdr p))))). - - (* TODO: should M.montladder change to accomodate this? *) - Definition to_pair {A B} p : A*B := (P2.car p, P2.cdr p). - - Lemma invert_reorder_pairs {A B C D} (p : \<>) w x y z - : reorder_pairs p = (w,x, (y,z)) <-> p = \. - Proof. - destruct p as [? [? [? ?]]]. - cbv. - intuition congruence. - Qed. - - Lemma ladderstep_gallina_equiv X1 P1 P2 : - reorder_pairs (ladderstep_gallina _ a24 X1 (fst P1) (snd P1) (fst P2) (snd P2)) = - @M.xzladderstep - _ F.add F.sub F.mul a24 X1 P1 P2. - Proof. - intros. cbv [ladderstep_gallina M.xzladderstep]. - destruct P1 as [x1 z1]. destruct P2 as [x2 z2]. - cbv [Rewriter.Util.LetIn.Let_In nlet]. cbn [fst snd]. - rewrite !F.pow_2_r; trivial. - Qed. - - Lemma montladder_gallina_equiv scalarbits n point : - montladder_gallina _ a24 scalarbits n point = - @M.montladder _ F.zero F.one F.add F.sub F.mul F.inv - a24 (fun b x y => to_pair (cswap b x y)) (Z.of_nat scalarbits) (Z.testbit n) point. - Proof. - cbv [montladder_gallina M.montladder Rewriter.Util.LetIn.Let_In stack]. - do 5 (unfold nlet at 1); cbn [fst snd P2.car P2.cdr]. - rewrite downto_while. - match goal with - | |- ?lhs = ?rhs => - match lhs with context [while ?ltest ?lbody ?fuel ?linit] => - match rhs with context [while ?rtest ?rbody ?fuel ?rinit] => - rewrite (while.preservation ltest lbody rtest rbody - (fun s1 s2 => s1 = let '(x2, z2, x3, z3, swap, i) := s2 in - (\, i))) with (init2:=rinit) - end end end. - { rewrite !Nat2Z.id. destruct (while _ _ _ _) eqn:? at 1 2. - destruct_products; reflexivity. } - { intros. destruct_products. congruence. } - { intros. destruct_products. Prod.inversion_prod. LtbToLt.Z.ltb_to_lt. subst. - rewrite !Z2Nat.id by lia. - cbv [nlet]. - repeat match goal with - | H : (_,_) = (_,_) |- _ => inversion H; subst; clear H - | _ => progress BreakMatch.break_match - | _ => progress BreakMatch.break_match_hyps - end. - rewrite <- ladderstep_gallina_equiv, invert_reorder_pairs in Heqp2. - cbn [fst snd] in Heqp2. - unfold to_pair in Heqp0; - inversion Heqp0; subst; clear Heqp0. - unfold to_pair in Heqp1; - inversion Heqp1; subst; clear Heqp1. - set (ladderstep_gallina _ _ _ _ _ _ _) in *. - rewrite Heqp2. reflexivity. } - { reflexivity. } - Qed. - -End Equivalence. diff --git a/src/Bedrock/Group/ScalarMult/MontgomeryLadder.v b/src/Bedrock/Group/ScalarMult/MontgomeryLadder.v index fa6f90ad80..7f389934e6 100644 --- a/src/Bedrock/Group/ScalarMult/MontgomeryLadder.v +++ b/src/Bedrock/Group/ScalarMult/MontgomeryLadder.v @@ -1,3 +1,5 @@ +Require Crypto.Bedrock.Group.Loops. +Require Import Crypto.Curves.Montgomery.XZ. Require Import Rupicola.Lib.Api. Require Import Rupicola.Lib.Alloc. Require Import Rupicola.Lib.SepLocals. @@ -43,7 +45,8 @@ Notation "'let/n' ( v , w , x , y , z ) := val 'in' body" := Section Gallina. Local Open Scope F_scope. - Definition montladder_gallina (m : positive) (a24 : F m) (count : nat) (k : Z) (u : F m) + Context (m : positive) (a24 : F m) (count : nat). + Definition montladder_gallina (k : Z) (u : F m) : F m := let/n X1 := stack 1 in let/n Z1 := stack 0 in @@ -69,6 +72,62 @@ Section Gallina. let/n OUT := (F.inv Z1) in let/n OUT := (X1 * OUT) in OUT. + + (*TODO: which of ladderstep_gallina and M.xzladderstep should we change? either?*) + Definition reorder_pairs {A B C D} (p : \<>) : (A*B)*(C*D) := + (P2.car p, P2.car (P2.cdr p),((P2.car (P2.cdr (P2.cdr p))),(P2.cdr (P2.cdr (P2.cdr p))))). + + (* TODO: should M.montladder change to accomodate this? *) + Definition to_pair {A B} p : A*B := (P2.car p, P2.cdr p). + + Lemma invert_reorder_pairs {A B C D} (p : \<>) w x y z + : reorder_pairs p = (w,x, (y,z)) <-> p = \. + Proof. + destruct p as [? [? [? ?]]]. + cbv. + intuition congruence. + Qed. + + Lemma ladderstep_gallina_equiv X1 P1 P2 : + reorder_pairs (ladderstep_gallina _ a24 X1 (fst P1) (snd P1) (fst P2) (snd P2)) = + @M.xzladderstep _ F.add F.sub F.mul a24 X1 P1 P2. + Proof. + intros. cbv [ladderstep_gallina M.xzladderstep]. + destruct P1 as [x1 z1]. destruct P2 as [x2 z2]. + cbv [Rewriter.Util.LetIn.Let_In nlet]. cbn [fst snd]. + rewrite !F.pow_2_r; trivial. + Qed. + + Lemma montladder_gallina_equiv n point : + montladder_gallina n point = + @M.montladder _ F.zero F.one F.add F.sub F.mul F.inv a24 (Z.of_nat count) (Z.testbit n) point. + Proof. + cbv [montladder_gallina M.montladder Rewriter.Util.LetIn.Let_In stack]. + do 5 (unfold nlet at 1); cbn [fst snd P2.car P2.cdr]. + rewrite Loops.downto_while. + match goal with + | |- ?lhs = ?rhs => + match lhs with context [Loops.while ?ltest ?lbody ?fuel ?linit] => + match rhs with context [Loops.while ?rtest ?rbody ?fuel ?rinit] => + rewrite (Loops.while.preservation ltest lbody rtest rbody + (fun s1 s2 => s1 = let '(x2, z2, x3, z3, swap, i) := s2 in + (\, i))) with (init2:=rinit) + end end end. + { rewrite !Nat2Z.id. destruct (Loops.while _ _ _ _) eqn:? at 1 2. + destruct_products. case b; reflexivity. } + { intros. destruct_products. congruence. } + { intros. destruct_products. Prod.inversion_prod. LtbToLt.Z.ltb_to_lt. subst. + rewrite !Z2Nat.id by lia. + cbv [nlet M.cswap]. + repeat match goal with + | H : (_,_) = (_,_) |- _ => inversion H; subst; clear H + | _ => progress BreakMatch.break_match + | _ => progress BreakMatch.break_match_hyps + end; + rewrite <- ladderstep_gallina_equiv, invert_reorder_pairs in Heqp0; + cbn [fst snd to_pair] in Heqp0; inversion_clear Heqp0; trivial. } + { reflexivity. } + Qed. End Gallina. Section __. @@ -101,7 +160,7 @@ Section __. * R)%sep mem; ensures tr' mem' := tr' = tr - /\ (let OUT := montladder_gallina M_pos a24 scalarbits K U in + /\ (let OUT := @M.montladder _ F.zero F.one F.add F.sub F.mul F.inv a24 (Z.of_nat scalarbits) (Z.testbit K) U in (FElem (Some tight_bounds) pOUT OUT * Kbytes$@pK * FElem (Some tight_bounds) pU U * R)%sep mem') }. @@ -311,6 +370,9 @@ Section __. As montladder_correct. Proof. pose proof scalarbits_bound. + cbv [spec_of_montladder]; intros; eapply Semantics.weaken_call; cycle 1; intros. + { rewrite <-montladder_gallina_equiv. match goal with H : ?e t' m' rets |- _ => exact H end. } + compile_setup. repeat compile_step. eapply compile_nlet_as_nlet_eq. diff --git a/src/Bedrock/Group/ScalarMult/ScalarMult.v b/src/Bedrock/Group/ScalarMult/ScalarMult.v index 549170c033..ab26c0b28b 100644 --- a/src/Bedrock/Group/ScalarMult/ScalarMult.v +++ b/src/Bedrock/Group/ScalarMult/ScalarMult.v @@ -4,7 +4,6 @@ Require Import coqutil.Byte. Require Import Crypto.Algebra.Hierarchy. Require Import Crypto.Algebra.ScalarMult. Require Import Crypto.Arithmetic.PrimeFieldTheorems. -Require Import Crypto.Bedrock.Group.ScalarMult.MontgomeryEquivalence. Require Import Crypto.Bedrock.Group.ScalarMult.MontgomeryLadder. Require Import Crypto.Bedrock.Specs.Field. Require Import Crypto.Bedrock.Specs.Group. diff --git a/src/Curves/Montgomery/XZ.v b/src/Curves/Montgomery/XZ.v index 5b6a965497..237db72b4f 100644 --- a/src/Curves/Montgomery/XZ.v +++ b/src/Curves/Montgomery/XZ.v @@ -113,7 +113,7 @@ Module M. ((x2, z2), (x3, z3))%core end. - Context {cswap:bool->F->F->F*F}. + Definition cswap (b : bool) (x y : F) := if b then pair y x else pair x y. Local Notation xor := Coq.Init.Datatypes.xorb. Local Open Scope core_scope. diff --git a/src/Curves/Montgomery/XZProofs.v b/src/Curves/Montgomery/XZProofs.v index 331288596d..495c249a36 100644 --- a/src/Curves/Montgomery/XZProofs.v +++ b/src/Curves/Montgomery/XZProofs.v @@ -257,7 +257,7 @@ Module M. Global Instance Proper_ladder_invariant : Proper (Feq ==> MontgomeryCurve.M.eq ==> MontgomeryCurve.M.eq ==> iff) ladder_invariant. Proof. t. Qed. - Local Notation montladder := (M.montladder(a24:=a24)(Fadd:=Fadd)(Fsub:=Fsub)(Fmul:=Fmul)(Fzero:=Fzero)(Fone:=Fone)(Finv:=Finv)(cswap:=fun b x y => if b then pair y x else pair x y)). + Local Notation montladder := (M.montladder(a24:=a24)(Fadd:=Fadd)(Fsub:=Fsub)(Fmul:=Fmul)(Fzero:=Fzero)(Fone:=Fone)(Finv:=Finv)). Local Notation scalarmult := (@ScalarMult.scalarmult_ref Mpoint Madd M.zero Mopp). Import Crypto.Util.Loops. @@ -310,7 +310,7 @@ Module M. { (* measure decreases *) cbv [Let_In]; break_match; cbn; rewrite Z.succ_pred; apply Znat.Z2Nat.inj_lt; lia. } } { (* if loop exited, invariant implies postcondition *) - break_match; break_match_hyps; setoid_subst_rel Feq; fsatz. } } + cbv [M.cswap]; break_match; break_match_hyps; setoid_subst_rel Feq; fsatz. } } Qed. Lemma montladder_correct_nz @@ -384,6 +384,7 @@ Module M. destruct_head' @and; autorewrite with cancel_pair in *. replace i with ((-(1))%Z) in * by lia; clear Hi Hbranch. rewrite Z.succ_m1, Z.shiftr_0_r in *. + cbv [M.cswap]; destruct swap eqn:Hswap; rewrite <-!to_x_inv00 by assumption; eauto using projective_to_xz, proper_to_x_projective. } } Qed.