1+ Require Crypto.Bedrock.Group.Loops.
2+ Require Import Crypto.Curves.Montgomery.XZ.
13Require Import Rupicola.Lib.Api.
24Require Import Rupicola.Lib.Alloc.
35Require Import Rupicola.Lib.SepLocals.
@@ -43,7 +45,8 @@ Notation "'let/n' ( v , w , x , y , z ) := val 'in' body" :=
4345
4446Section Gallina.
4547 Local Open Scope F_scope.
46- Definition montladder_gallina (m : positive) (a24 : F m) (count : nat) (k : Z) (u : F m)
48+ Context (m : positive) (a24 : F m) (count : nat).
49+ Definition montladder_gallina (k : Z) (u : F m)
4750 : F m :=
4851 let /n X1 := stack 1 in
4952 let /n Z1 := stack 0 in
@@ -69,6 +72,62 @@ Section Gallina.
6972 let /n OUT := (F.inv Z1) in
7073 let /n OUT := (X1 * OUT) in
7174 OUT.
75+
76+ (*TODO: which of ladderstep_gallina and M.xzladderstep should we change? either? *)
77+ Definition reorder_pairs {A B C D} (p : \<<A , B , C , D\>>) : (A*B)*(C*D) :=
78+ (P2.car p, P2.car (P2.cdr p),((P2.car (P2.cdr (P2.cdr p))),(P2.cdr (P2.cdr (P2.cdr p))))).
79+
80+ (* TODO: should M.montladder change to accomodate this? *)
81+ Definition to_pair {A B} p : A*B := (P2.car p, P2.cdr p).
82+
83+ Lemma invert_reorder_pairs {A B C D} (p : \<<A , B , C , D\>>) w x y z
84+ : reorder_pairs p = (w,x, (y,z)) <-> p = \<w,x,y,z\>.
85+ Proof .
86+ destruct p as [? [? [? ?]]].
87+ cbv.
88+ intuition congruence.
89+ Qed .
90+
91+ Lemma ladderstep_gallina_equiv X1 P1 P2 :
92+ reorder_pairs (ladderstep_gallina _ a24 X1 (fst P1) (snd P1) (fst P2) (snd P2)) =
93+ @M.xzladderstep _ F.add F.sub F.mul a24 X1 P1 P2.
94+ Proof .
95+ intros. cbv [ladderstep_gallina M.xzladderstep].
96+ destruct P1 as [x1 z1]. destruct P2 as [x2 z2].
97+ cbv [Rewriter.Util.LetIn.Let_In nlet]. cbn [fst snd].
98+ rewrite !F.pow_2_r; trivial.
99+ Qed .
100+
101+ Lemma montladder_gallina_equiv n point :
102+ montladder_gallina n point =
103+ @M.montladder _ F.zero F.one F.add F.sub F.mul F.inv a24 (Z.of_nat count) (Z.testbit n) point.
104+ Proof .
105+ cbv [montladder_gallina M.montladder Rewriter.Util.LetIn.Let_In stack].
106+ do 5 (unfold nlet at 1); cbn [fst snd P2.car P2.cdr].
107+ rewrite Loops.downto_while.
108+ match goal with
109+ | |- ?lhs = ?rhs =>
110+ match lhs with context [Loops.while ?ltest ?lbody ?fuel ?linit] =>
111+ match rhs with context [Loops.while ?rtest ?rbody ?fuel ?rinit] =>
112+ rewrite (Loops.while.preservation ltest lbody rtest rbody
113+ (fun s1 s2 => s1 = let '(x2, z2, x3, z3, swap, i) := s2 in
114+ (\<x2, z2, x3, z3, swap\>, i))) with (init2:=rinit)
115+ end end end.
116+ { rewrite !Nat2Z.id. destruct (Loops.while _ _ _ _) eqn:? at 1 2.
117+ destruct_products. case b; reflexivity. }
118+ { intros. destruct_products. congruence. }
119+ { intros. destruct_products. Prod.inversion_prod. LtbToLt.Z.ltb_to_lt. subst.
120+ rewrite !Z2Nat.id by lia.
121+ cbv [nlet M.cswap].
122+ repeat match goal with
123+ | H : (_,_) = (_,_) |- _ => inversion H; subst; clear H
124+ | _ => progress BreakMatch.break_match
125+ | _ => progress BreakMatch.break_match_hyps
126+ end;
127+ rewrite <- ladderstep_gallina_equiv, invert_reorder_pairs in Heqp0;
128+ cbn [fst snd to_pair] in Heqp0; inversion_clear Heqp0; trivial. }
129+ { reflexivity. }
130+ Qed .
72131End Gallina.
73132
74133Section __.
@@ -101,7 +160,7 @@ Section __.
101160 * R)%sep mem;
102161 ensures tr' mem' :=
103162 tr' = tr
104- /\ (let OUT := montladder_gallina M_pos a24 scalarbits K U in
163+ /\ (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
105164 (FElem (Some tight_bounds) pOUT OUT * Kbytes$@pK
106165 * FElem (Some tight_bounds) pU U
107166 * R)%sep mem') }.
@@ -311,6 +370,9 @@ Section __.
311370 As montladder_correct.
312371 Proof .
313372 pose proof scalarbits_bound.
373+ cbv [spec_of_montladder]; intros; eapply Semantics.weaken_call; cycle 1; intros.
374+ { rewrite <-montladder_gallina_equiv. match goal with H : ?e t' m' rets |- _ => exact H end. }
375+
314376 compile_setup.
315377 repeat compile_step.
316378 eapply compile_nlet_as_nlet_eq.
0 commit comments