(** * Push-Button Synthesis of Word-By-Word Montgomery *)
Require Import Coq.Strings.String.
Require Import Coq.micromega.Lia.
Require Import Coq.ZArith.ZArith.
Require Import Coq.MSets.MSetPositive.
Require Import Coq.Lists.List.
Require Import Coq.QArith.QArith_base Coq.QArith.Qround.
Require Import Coq.Program.Tactics. (* For WBW Montgomery proofs *)
Require Import Coq.derive.Derive.
Require Import Crypto.Util.ErrorT.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.ListUtil.FoldBool.
Require Import Crypto.Util.Strings.Decimal.
Require Import Crypto.Util.ZRange.
Require Import Crypto.Util.ZUtil.Definitions.
Require Import Crypto.Util.ZUtil.Zselect.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Util.ZUtil.ModInv. (* Only needed for WBW Montgomery *)
Require Import Crypto.Util.ZUtil.Modulo. (* Only needed for WBW Montgomery proofs *)
Require Import Crypto.Util.ZUtil.Le. (* Only needed for WBW Montgomery proofs *)
Require Import Crypto.Util.Prod. (* For WBW Montgomery proofs *)
Require Import Crypto.Util.ZUtil.Tactics.PullPush.Modulo. (* For WBW montgomery proofs *)
Require Import Crypto.Util.ZUtil.Tactics.RewriteModSmall. (* For WBW montgomery proofs *)
Require Import Crypto.Util.ZUtil.Div. (* For WBW Montgomery proofs *)
Require Import Crypto.Util.ZUtil.Tactics.DivModToQuotRem. (* For WBW Montgomery proofs *)
Require Import Crypto.Util.ZUtil.Ones. (* For WBW montgomery proofs *)
Require Import Crypto.Util.ZUtil.Shift. (* For WBW montgomery proofs *)
Require Import Crypto.Util.ZUtil.ModExp.
Require Import Crypto.Util.Tactics.HasBody.
Require Import Crypto.Util.Tactics.Head.
Require Import Crypto.Util.Tactics.SpecializeBy.
Require Import Rewriter.Language.Wf.
Require Import Crypto.Language.WfExtra.
Require Import Rewriter.Language.Language.
Require Import Crypto.Language.API.
Require Import Crypto.AbstractInterpretation.AbstractInterpretation.
Require Import Crypto.Stringification.Language.
Require Import Crypto.Arithmetic.Core.
Require Import Crypto.Arithmetic.ModOps.
Require Import Crypto.Arithmetic.Freeze.
Require Import Crypto.Arithmetic.Partition.
Require Import Crypto.Arithmetic.WordByWordMontgomery.
Require Import Crypto.Arithmetic.UniformWeight.
Require Import Crypto.Arithmetic.BYInv.
Require Import Crypto.BoundsPipeline.
Require Import Crypto.COperationSpecifications.
Require Import Crypto.PushButtonSynthesis.ReificationCache.
Require Import Crypto.PushButtonSynthesis.Primitives.
Require Import Crypto.PushButtonSynthesis.WordByWordMontgomeryReificationCache.
Require Import Crypto.PushButtonSynthesis.BYInversionReificationCache.
Require Import Crypto.Assembly.Equivalence.
Import ListNotations.
Local Open Scope string_scope. Local Open Scope Z_scope. Local Open Scope list_scope. Local Open Scope bool_scope.

Import
  Language.Wf.Compilers
  Language.WfExtra.Compilers
  Language.Compilers
  AbstractInterpretation.Compilers
  Stringification.Language.Compilers.
Import Compilers.API.

Import COperationSpecifications.Primitives.
Import COperationSpecifications.Solinas.
Import COperationSpecifications.WordByWordMontgomery.

Import Associational Positional.
Import Arithmetic.WordByWordMontgomery.WordByWordMontgomery.

Import WordByWordMontgomeryReificationCache.WordByWordMontgomery.
Import BYInversionReificationCache.WordByWordMontgomeryInversion.

Local Coercion Z.of_nat : nat >-> Z.
Local Coercion QArith_base.inject_Z : Z >-> Q.
Local Coercion Z.pos : positive >-> Z.

Local Set Keyed Unification. (* needed for making [autorewrite] fast, c.f. COQBUG(https://github.com/coq/coq/issues/9283) *)

(* needed for making [autorewrite] not take a very long time *)
Local Opaque
      reified_mul_gen
      reified_square_gen
      reified_add_gen
      reified_sub_gen
      reified_opp_gen
      reified_from_montgomery_gen
      reified_to_montgomery_gen
      reified_to_bytes_gen
      reified_from_bytes_gen
      reified_encode_gen
      reified_zero_gen
      reified_one_gen
      reified_eval_gen
      reified_bytes_eval_gen
      reified_eval_twos_complement_gen
      reified_msat_gen
      reified_encode_gen
      reified_divstep_gen
      reified_nonzero_gen
      expr.Interp.

Section __.
  Context {output_language_api : ToString.OutputLanguageAPI}
          {pipeline_opts : PipelineOptions}
          {pipeline_to_string_opts : PipelineToStringOptions}
          {synthesis_opts : SynthesisOptions}
          (m : Z)
          (machine_wordsize : machine_wordsize_opt).

  Definition s := 2^Z.log2_up m.
  Definition c := s - m.
  Definition n : nat := Z.to_nat (Qceiling (Z.log2_up s / machine_wordsize)).
  Definition sat_limbs := (n + 1)%nat.   (* to represent m in twos complement we might need another bit *)
  Definition r := 2^machine_wordsize.
  Definition r' := Z.modinv r m.
  Definition m' := Z.modinv (-m) r.
  Definition n_bytes := bytes_n s.

  Definition divstep_precompmod :=
    let bits := (Z.log2 m) + 1 in
    let i := if bits <? 46 then (49 * bits + 80) / 17 else (49 * bits + 57) / 17 in
    let k := (m + 1) / 2 in
    (Z.modexp k i m).

  Definition prime_upperbound_list : list Z
    := Partition.partition (uweight machine_wordsize) n (s-1).
  Definition prime_bytes_upperbound_list : list Z
    := Partition.partition (weight 8 1) n_bytes (s-1).
  Definition upperbounds : list Z := prime_upperbound_list.
  Definition prime_bound : ZRange.type.interp (base.type.Z)
    := r[0~>m-1]%zrange.
  Definition prime_word_bound : ZRange.type.interp (base.type.Z) (* a word that's guaranteed to be smaller than the prime *)
    := r[0 ~> Z.min m (2^machine_wordsize) - 1]%zrange.
  Definition prime_bounds : list (ZRange.type.option.interp base.type.Z)
    := List.map (fun v => Some r[0 ~> v]%zrange) prime_upperbound_list.
  Definition prime_bytes_bounds : list (ZRange.type.option.interp (base.type.Z))
    := List.map (fun v => Some r[0 ~> v]%zrange) prime_bytes_upperbound_list.
  Local Notation word_bound := (word_bound machine_wordsize).
  Local Notation saturated_bounds := (saturated_bounds n machine_wordsize).
  Local Notation larger_saturated_bounds := (Primitives.saturated_bounds sat_limbs machine_wordsize).

  Definition divstep_input :=
    (Some r[0~>2^machine_wordsize-1],
     (Some (repeat (Some r[0 ~> 2^machine_wordsize-1]) sat_limbs),
      (Some (repeat (Some r[0 ~> 2^machine_wordsize-1]) sat_limbs),
       (Some (repeat (Some r[0 ~> 2^machine_wordsize-1]) n),
        (Some (repeat (Some r[0 ~> 2^machine_wordsize-1]) n),tt)))))%zrange.

  Definition divstep_output :=
    (Some r[0~>2^machine_wordsize-1],
     Some (repeat (Some r[0 ~> 2^machine_wordsize-1]) sat_limbs),
     Some (repeat (Some r[0 ~> 2^machine_wordsize-1]) sat_limbs),
     Some (repeat (Some r[0 ~> 2^machine_wordsize-1]) n),
     Some (repeat (Some r[0 ~> 2^machine_wordsize-1]) n))%zrange.

  Local Notation possible_values := (possible_values_of_machine_wordsize machine_wordsize).
  Local Notation possible_values_with_bytes := (possible_values_of_machine_wordsize_with_bytes machine_wordsize).

  Definition bounds : list (ZRange.type.option.interp base.type.Z)
    := saturated_bounds (*List.map (fun u => Some r[0~>u]%zrange) upperbounds*).
  Definition larger_bounds : list (ZRange.type.option.interp base.type.Z)
    := larger_saturated_bounds (*List.map (fun u => Some r[0~>u]%zrange) upperbounds*).
  Definition montgomery_domain_bounds := saturated_bounds.
  Definition non_montgomery_domain_bounds := saturated_bounds.
  Typeclasses Opaque montgomery_domain_bounds.
  Typeclasses Opaque non_montgomery_domain_bounds.
  Global Instance montgomery_domain_bounds_typedef : typedef (t:=base.type.list base.type.Z) (Some montgomery_domain_bounds)
    := { name := "montgomery_domain_field_element"
         ; description name := (text_before_type_name ++ name ++ " is a field element in the Montgomery domain.")%string }.
  Global Instance non_montgomery_domain_bounds_typedef : typedef (t:=base.type.list base.type.Z) (Some non_montgomery_domain_bounds)
    := { name := "non_montgomery_domain_field_element"
         ; description name := (text_before_type_name ++ name ++ " is a field element NOT in the Montgomery domain.")%string }.

  Local Existing Instance default_translate_to_fancy.
  Local Instance no_select_size : no_select_size_opt := no_select_size_of_no_select machine_wordsize.
  Local Instance split_mul_to : split_mul_to_opt := split_mul_to_of_should_split_mul machine_wordsize possible_values.
  Local Instance split_multiret_to : split_multiret_to_opt := split_multiret_to_of_should_split_multiret machine_wordsize possible_values.

  (** Note: If you change the name or type signature of this
        function, you will need to update the code in CLI.v *)
  Definition check_args {T} (requests : list string) (res : Pipeline.ErrorT T)
    : Pipeline.ErrorT T
    := check_args_of_list
         (List.map
            (fun v => (true, v))
            [((1 <? machine_wordsize)%Z, Pipeline.Value_not_ltZ "machine_wordsize <= 1" 1 machine_wordsize)
             ; ((0 <? c)%Z, Pipeline.Value_not_ltZ "c ≤ 0" 0 c)
             ; ((1 <? m)%Z, Pipeline.Value_not_ltZ "m ≤ 1" 1 m)
             ; (negb (n =? 0)%nat, Pipeline.Values_not_provably_distinctZ "n = 0" n 0%nat)
             ; (negb (r' =? 0)%Z, Pipeline.No_modular_inverse "r⁻¹ mod m" r m)
             ; (((r * r') mod m =? 1)%Z, Pipeline.Values_not_provably_equalZ "(r * r') mod m ≠ 1" ((r * r') mod m) 1)
             ; (((m * m') mod r =? (-1) mod r)%Z, Pipeline.Values_not_provably_equalZ "(m * m') mod r ≠ (-1) mod r" ((m * m') mod r) ((-1) mod r))
             ; (s <=? r^n, Pipeline.Value_not_leZ "r^n ≤ s" s (r^n))
             ; (s <=? uweight machine_wordsize n, Pipeline.Value_not_leZ "weight n < s (needed for from_bytes)" s (uweight machine_wordsize n))
             ; (s <=? uweight 8 n_bytes, Pipeline.Value_not_leZ "bytes_weight n_bytes < s (needed for from_bytes)" s (uweight 8 n_bytes))
         ])
         res.

  Local Arguments Z.mul !_ !_.

  Local Ltac use_curve_good_t :=
    repeat first [ use_requests_to_prove_curve_good_t_step
                 | assumption
                 | lia
                 | progress autorewrite with distr_length
                 | progress distr_length
                 | solve [ auto with zarith ]
                 | rewrite Z.log2_pow2 by use_curve_good_t ].

  Context (requests : list string)
          (curve_good : check_args requests (Success tt) = Success tt).

  Lemma use_curve_good
    : Z.pos (Z.to_pos m) = m
      /\ m = s - c
      /\ Z.pos (Z.to_pos m) <> 0
      /\ s - c <> 0
      /\ 0 < s
      /\ s <> 0
      /\ 0 < machine_wordsize
      /\ n <> 0%nat
      /\ List.length bounds = n
      /\ 0 < 1 <= machine_wordsize
      /\ 0 < c < s
      /\ (r * r') mod m = 1
      /\ (m * m') mod r = (-1) mod r
      /\ 0 < machine_wordsize
      /\ 1 < m
      /\ m < r^n
      /\ s = 2^Z.log2 s
      /\ s <= uweight machine_wordsize n
      /\ s <= uweight 8 n_bytes.
  Proof using curve_good.
    prepare_use_curve_good (); cbv [s c] in *.
    { destruct m eqn:?; cbn; lia. }
    { use_curve_good_t. }
    { use_curve_good_t. }
    { use_curve_good_t. }
    { use_curve_good_t. }
    { use_curve_good_t. }
    { use_curve_good_t. }
    { use_curve_good_t. }
    { use_curve_good_t. }
    { use_curve_good_t. }
    { use_curve_good_t. }
    { use_curve_good_t. }
    { use_curve_good_t. }
  Qed.

  Local Notation valid := (valid machine_wordsize n m).
  Local Notation bytes_valid := (WordByWordMontgomery.valid 8 n_bytes m).

  Local Notation from_montgomery_res := (from_montgomerymod machine_wordsize n m m').

  Local Notation notations_for_docstring prefix
    := ((CorrectnessStringification.dyn_context.cons
           m "m"
           (CorrectnessStringification.dyn_context.cons
              r' ("((2^" ++ Decimal.Z.to_string machine_wordsize ++ ")⁻¹ mod m)")
              (CorrectnessStringification.dyn_context.cons
                 from_montgomery_res "from_montgomery"
                 (CorrectnessStringification.dyn_context.cons
                    (@eval machine_wordsize n) "eval"
                    (CorrectnessStringification.dyn_context.cons
                       (@eval 8 n_bytes) "bytes_eval"
                            (CorrectnessStringification.dyn_context.cons
                               (Z.log2 m) "⌊log2 m⌋"
                               (CorrectnessStringification.dyn_context.cons
                                  (@eval_twos_complement machine_wordsize n) "twos_complement_eval"
                                  CorrectnessStringification.dyn_context.nil)))))))%string)
         (only parsing).
  Local Notation "'docstring_with_summary_from_lemma!' prefix summary correctness"
    := (docstring_with_summary_from_lemma_with_ctx!
          (notations_for_docstring prefix)
          summary
          correctness)
         (only parsing, at level 10, prefix at next level, summary at next level, correctness at next level).

  Definition mul
    := Pipeline.BoundsPipeline
         false (* subst01 *)
         possible_values
         (reified_mul_gen
            @ GallinaReify.Reify (machine_wordsize:Z) @ GallinaReify.Reify n @ GallinaReify.Reify m @ GallinaReify.Reify m')
         (Some montgomery_domain_bounds, (Some montgomery_domain_bounds, tt))
         (Some montgomery_domain_bounds).

  Definition smul (prefix : string)
    : string * (Pipeline.M (Pipeline.ExtendedSynthesisResult _))
    := Eval cbv beta in
        FromPipelineToString!
          machine_wordsize prefix "mul" mul
          (docstring_with_summary_from_lemma!
             prefix
             (fun fname : string => [text_before_function_name ++ fname ++ " multiplies two field elements in the Montgomery domain."]%string)
             (mul_correct machine_wordsize n m valid from_montgomery_res)).

  Definition square
    := Pipeline.BoundsPipeline
         false (* subst01 *)
         possible_values
         (reified_square_gen
            @ GallinaReify.Reify (machine_wordsize:Z) @ GallinaReify.Reify n @ GallinaReify.Reify m @ GallinaReify.Reify m')
         (Some montgomery_domain_bounds, tt)
         (Some montgomery_domain_bounds).

  Definition ssquare (prefix : string)
    : string * (Pipeline.M (Pipeline.ExtendedSynthesisResult _))
    := Eval cbv beta in
        FromPipelineToString!
          machine_wordsize prefix "square" square
          (docstring_with_summary_from_lemma!
             prefix
             (fun fname : string => [text_before_function_name ++ fname ++ " squares a field element in the Montgomery domain."]%string)
             (square_correct machine_wordsize n m valid from_montgomery_res)).

  Definition add
    := Pipeline.BoundsPipeline
         true (* subst01 *)
         possible_values
         (reified_add_gen
            @ GallinaReify.Reify (machine_wordsize:Z) @ GallinaReify.Reify n @ GallinaReify.Reify m)
         (Some montgomery_domain_bounds, (Some montgomery_domain_bounds, tt))
         (Some montgomery_domain_bounds).

  Definition sadd (prefix : string)
    : string * (Pipeline.M (Pipeline.ExtendedSynthesisResult _))
    := Eval cbv beta in
        FromPipelineToString!
          machine_wordsize prefix "add" add
          (docstring_with_summary_from_lemma!
             prefix
             (fun fname : string => [text_before_function_name ++ fname ++ " adds two field elements in the Montgomery domain."]%string)
             (add_correct machine_wordsize n m valid from_montgomery_res)).

  Definition sub
    := Pipeline.BoundsPipeline
         true (* subst01 *)
         possible_values
         (reified_sub_gen
            @ GallinaReify.Reify (machine_wordsize:Z) @ GallinaReify.Reify n @ GallinaReify.Reify m)
         (Some montgomery_domain_bounds, (Some montgomery_domain_bounds, tt))
         (Some montgomery_domain_bounds).

  Definition ssub (prefix : string)
    : string * (Pipeline.M (Pipeline.ExtendedSynthesisResult _))
    := Eval cbv beta in
        FromPipelineToString!
          machine_wordsize prefix "sub" sub
          (docstring_with_summary_from_lemma!
             prefix
             (fun fname : string => [text_before_function_name ++ fname ++ " subtracts two field elements in the Montgomery domain."]%string)
             (sub_correct machine_wordsize n m valid from_montgomery_res)).

  Definition opp
    := Pipeline.BoundsPipeline
         true (* subst01 *)
         possible_values
         (reified_opp_gen
            @ GallinaReify.Reify (machine_wordsize:Z) @ GallinaReify.Reify n @ GallinaReify.Reify m)
         (Some montgomery_domain_bounds, tt)
         (Some montgomery_domain_bounds).

  Definition sopp (prefix : string)
    : string * (Pipeline.M (Pipeline.ExtendedSynthesisResult _))
    := Eval cbv beta in
        FromPipelineToString!
          machine_wordsize prefix "opp" opp
          (docstring_with_summary_from_lemma!
             prefix
             (fun fname : string => [text_before_function_name ++ fname ++ " negates a field element in the Montgomery domain."]%string)
             (opp_correct machine_wordsize n m valid from_montgomery_res)).

  Definition from_montgomery
    := Pipeline.BoundsPipeline
         true (* subst01 *)
         possible_values
         (reified_from_montgomery_gen
            @ GallinaReify.Reify (machine_wordsize:Z) @ GallinaReify.Reify n @ GallinaReify.Reify m @ GallinaReify.Reify m')
         (Some montgomery_domain_bounds, tt)
         (Some non_montgomery_domain_bounds).

  Definition sfrom_montgomery (prefix : string)
    : string * (Pipeline.M (Pipeline.ExtendedSynthesisResult _))
    := Eval cbv beta in
        FromPipelineToString!
          machine_wordsize prefix "from_montgomery" from_montgomery
          (docstring_with_summary_from_lemma!
             prefix
             (fun fname : string => [text_before_function_name ++ fname ++ " translates a field element out of the Montgomery domain."]%string)
             (from_montgomery_correct machine_wordsize n m r' valid)).

  Definition to_montgomery
    := Pipeline.BoundsPipeline
         true (* subst01 *)
         possible_values
         (reified_to_montgomery_gen
            @ GallinaReify.Reify (machine_wordsize:Z) @ GallinaReify.Reify n @ GallinaReify.Reify m @ GallinaReify.Reify m')
         (Some non_montgomery_domain_bounds, tt)
         (Some montgomery_domain_bounds).

  Definition sto_montgomery (prefix : string)
    : string * (Pipeline.M (Pipeline.ExtendedSynthesisResult _))
    := Eval cbv beta in
        FromPipelineToString!
          machine_wordsize prefix "to_montgomery" to_montgomery
          (docstring_with_summary_from_lemma!
             prefix
             (fun fname : string => [text_before_function_name ++ fname ++ " translates a field element into the Montgomery domain."]%string)
             (to_montgomery_correct machine_wordsize n m valid from_montgomery_res)).

  Definition nonzero
    := Pipeline.BoundsPipeline
         true (* subst01 *)
         possible_values
         reified_nonzero_gen
         (Some bounds, tt)
         (Some r[0~>r-1]%zrange).

  Definition snonzero (prefix : string)
    : string * (Pipeline.M (Pipeline.ExtendedSynthesisResult _))
    := Eval cbv beta in
        FromPipelineToString!
          machine_wordsize prefix "nonzero" nonzero
          (docstring_with_summary_from_lemma!
             prefix
             (fun fname : string => [text_before_function_name ++ fname ++ " outputs a single non-zero word if the input is non-zero and zero otherwise."]%string)
             (nonzero_correct machine_wordsize n m valid from_montgomery_res)).

  Definition to_bytes
    := Pipeline.BoundsPipeline
         false (* subst01 *)
         possible_values_with_bytes
         (reified_to_bytes_gen
            @ GallinaReify.Reify (machine_wordsize:Z) @ GallinaReify.Reify n @ GallinaReify.Reify m)
         (Some prime_bounds, tt)
         (Some prime_bytes_bounds).

  Definition sto_bytes (prefix : string)
    : string * (Pipeline.M (Pipeline.ExtendedSynthesisResult _))
    := Eval cbv beta in
        FromPipelineToString!
          machine_wordsize prefix "to_bytes" to_bytes
          (docstring_with_summary_from_lemma!
             prefix
             (fun fname : string => [text_before_function_name ++ fname ++ " serializes a field element NOT in the Montgomery domain to bytes in little-endian order."]%string)
             (to_bytes_correct machine_wordsize n n_bytes m valid)).

  Definition from_bytes
    := Pipeline.BoundsPipeline
         false (* subst01 *)
         possible_values_with_bytes
         (reified_from_bytes_gen
            @ GallinaReify.Reify (machine_wordsize:Z) @ GallinaReify.Reify 1 @ GallinaReify.Reify s @ GallinaReify.Reify n)
         (Some prime_bytes_bounds, tt)
         (Some prime_bounds).

  Definition sfrom_bytes (prefix : string)
    : string * (Pipeline.M (Pipeline.ExtendedSynthesisResult _))
    := Eval cbv beta in
        FromPipelineToString!
          machine_wordsize prefix "from_bytes" from_bytes
          (docstring_with_summary_from_lemma!
             prefix
             (fun fname : string => [text_before_function_name ++ fname ++ " deserializes a field element NOT in the Montgomery domain from bytes in little-endian order."]%string)
             (from_bytes_correct machine_wordsize n n_bytes m valid bytes_valid)).

  Definition encode
    := Pipeline.BoundsPipeline
         true (* subst01 *)
         possible_values
         (reified_encode_gen
            @ GallinaReify.Reify (machine_wordsize:Z) @ GallinaReify.Reify n @ GallinaReify.Reify m @ GallinaReify.Reify m')
         (Some prime_bound, tt)
         (Some montgomery_domain_bounds).

  Definition sencode (prefix : string)
    : string * (Pipeline.M (Pipeline.ExtendedSynthesisResult _))
    := Eval cbv beta in
        FromPipelineToString!
          machine_wordsize prefix "encode" encode
          (docstring_with_summary_from_lemma!
             prefix
             (fun fname : string => [text_before_function_name ++ fname ++ " encodes an integer as a field element in the Montgomery domain."]%string)
             (encode_correct machine_wordsize n m valid from_montgomery_res)).

  Definition encode_word
    := Pipeline.BoundsPipeline
         true (* subst01 *)
         possible_values
         (reified_encode_gen
            @ GallinaReify.Reify (machine_wordsize:Z) @ GallinaReify.Reify n @ GallinaReify.Reify m @ GallinaReify.Reify m')
         (Some prime_word_bound, tt)
         (Some saturated_bounds).

  Definition sencode_word (prefix : string)
    : string * (Pipeline.M (Pipeline.ExtendedSynthesisResult _))
    := Eval cbv beta in
        FromPipelineToString!
          machine_wordsize prefix "encode_word" encode_word
          (docstring_with_summary_from_lemma!
             prefix
             (fun fname : string => [text_before_function_name ++ fname ++ " encodes an integer as a field element in the Montgomery domain."]%string)
             (encode_word_correct machine_wordsize n m valid from_montgomery_res)).

  Definition zero
    := Pipeline.BoundsPipeline
         true (* subst01 *)
         possible_values
         (reified_zero_gen
            @ GallinaReify.Reify (machine_wordsize:Z) @ GallinaReify.Reify n @ GallinaReify.Reify m @ GallinaReify.Reify m')
         tt
         (Some montgomery_domain_bounds).

  Definition szero (prefix : string)
    : string * (Pipeline.M (Pipeline.ExtendedSynthesisResult _))
    := Eval cbv beta in
        FromPipelineToString!
          machine_wordsize prefix "zero" zero
          (docstring_with_summary_from_lemma!
             prefix
             (fun fname => [text_before_function_name ++ fname ++ " returns the field element zero in the Montgomery domain."]%string)
             (zero_correct machine_wordsize n m valid from_montgomery_res)).

  Definition one
    := Pipeline.BoundsPipeline
         true (* subst01 *)
         possible_values
         (reified_one_gen
            @ GallinaReify.Reify (machine_wordsize:Z) @ GallinaReify.Reify n @ GallinaReify.Reify m @ GallinaReify.Reify m')
         tt
         (Some montgomery_domain_bounds).

  Definition sone (prefix : string)
    : string * (Pipeline.M (Pipeline.ExtendedSynthesisResult _))
    := Eval cbv beta in
        FromPipelineToString!
          machine_wordsize prefix "set_one" one (* to avoid conflict with boringSSL *)
          (docstring_with_summary_from_lemma!
             prefix
             (fun fname => [text_before_function_name ++ fname ++ " returns the field element one in the Montgomery domain."]%string)
             (one_correct machine_wordsize n m valid from_montgomery_res)).

  Definition reval (* r for reified *)
    := Pipeline.RepeatRewriteAddAssocLeftAndFlattenThunkedRects
         n
         (Pipeline.PreBoundsPipeline
            true (* subst01 *)
            false (* let_bind_return *)
            (reified_eval_gen
               @ GallinaReify.Reify (machine_wordsize:Z) @ GallinaReify.Reify n)
            (Some montgomery_domain_bounds, tt)).

  Definition seval (arg_name : string) (* s for string *)
    := Show.show (invert_expr.smart_App_curried (reval _) (arg_name, tt)).

  Definition rbytes_eval (* r for reified *)
    := Pipeline.RepeatRewriteAddAssocLeftAndFlattenThunkedRects
         n_bytes
         (Pipeline.PreBoundsPipeline
            true (* subst01 *)
            false (* let_bind_return *)
            (reified_bytes_eval_gen
               @ GallinaReify.Reify s)
            (Some prime_bytes_bounds, tt)).

  Definition sbytes_eval (arg_name : string) (* s for string *)
    := Show.show (invert_expr.smart_App_curried (rbytes_eval _) (arg_name, tt)).

  Definition reval_twos_complement (* r for reified *)
    := Pipeline.RepeatRewriteAddAssocLeftAndFlattenThunkedRects
         n
         (Pipeline.PreBoundsPipeline
            true (* subst01 *)
            false (* let_bind_return *)
            (reified_eval_twos_complement_gen
               @ GallinaReify.Reify (machine_wordsize:Z)
               @ GallinaReify.Reify n)
            (Some bounds, tt)).

  Definition seval_twos_complement (arg_name : string) (* s for string *)
    := Show.show (invert_expr.smart_App_curried (reval_twos_complement _) (arg_name, tt)).

  Definition selectznz : Pipeline.ErrorT _ := Primitives.selectznz n machine_wordsize.
  Definition sselectznz (prefix : string)
    : string * (Pipeline.M (Pipeline.ExtendedSynthesisResult _))
    := Primitives.sselectznz n machine_wordsize prefix.

  Definition copy : Pipeline.ErrorT _ := Primitives.copy n machine_wordsize.
  Definition scopy (prefix : string)
    : string * (Pipeline.M (Pipeline.ExtendedSynthesisResult _))
    := Primitives.scopy n machine_wordsize prefix.

  Definition msat
    := Pipeline.BoundsPipeline
         true (* subst01 *)
         possible_values
         (reified_msat_gen
            @ GallinaReify.Reify (machine_wordsize:Z) @ GallinaReify.Reify sat_limbs @ GallinaReify.Reify m)
         tt
         (Some larger_bounds).

 Definition smsat (prefix : string)
    : string * (Pipeline.M (Pipeline.ExtendedSynthesisResult _))
    := Eval cbv beta in
        FromPipelineToString!
          machine_wordsize prefix "msat" msat
          (docstring_with_summary_from_lemma!
             prefix
             (fun fname => [text_before_function_name ++ fname ++ " returns the saturated representation of the prime modulus."]%string)
             (msat_correct machine_wordsize n m valid)).

  Definition divstep_precomp
    := Pipeline.BoundsPipeline
         true (* subst01 *)
         possible_values
         (reified_encode_gen
            @ GallinaReify.Reify (machine_wordsize:Z) @ GallinaReify.Reify n @ GallinaReify.Reify m @ GallinaReify.Reify m' @ GallinaReify.Reify divstep_precompmod)
         tt
         (Some bounds).

  Definition sdivstep_precomp (prefix : string)
    : string * (Pipeline.M (Pipeline.ExtendedSynthesisResult _))
    := Eval cbv beta in
        FromPipelineToString!
          machine_wordsize prefix "divstep_precomp" divstep_precomp
          (docstring_with_summary_from_lemma!
             prefix
             (fun fname => [text_before_function_name ++ fname ++ " returns the precomputed value for Bernstein-Yang-inversion (in montgomery form)."]%string)
             (divstep_precomp_correct machine_wordsize n m valid from_montgomery_res)).

  Definition divstep
    := Pipeline.BoundsPipeline
         false (* subst01 *)
         possible_values
         (reified_divstep_gen
            @ GallinaReify.Reify (machine_wordsize:Z) @ GallinaReify.Reify sat_limbs @ GallinaReify.Reify n @ GallinaReify.Reify m)
         (divstep_input)
         (divstep_output).

  Definition sdivstep (prefix : string)
    : string * (Pipeline.M (Pipeline.ExtendedSynthesisResult _))
    := Eval cbv beta in
        FromPipelineToString!
          machine_wordsize prefix "divstep" divstep
          (docstring_with_summary_from_lemma!
             prefix
             (fun fname : string => [text_before_function_name ++ fname ++ " computes a divstep."]%string)
             (divstep_correct machine_wordsize n m valid from_montgomery_res)).

  Lemma bounded_by_of_valid x
        (H : valid x)
    : ZRange.type.base.option.is_bounded_by (t:=base.type.list base.type.Z) (Some bounds) x = true.
  Proof using curve_good.
    pose proof use_curve_good as use_curve_good.
    clear -H use_curve_good curve_good.
    destruct H as [H _]; destruct_head'_and.
    cbv [small] in H.
    cbv [ZRange.type.base.option.is_bounded_by bounds saturated_bounds word_bound].
    replace n with (List.length x) by now rewrite H, Partition.length_partition.
    rewrite <- map_const, fold_andb_map_map1, fold_andb_map_iff.
    cbv [ZRange.type.base.is_bounded_by is_bounded_by_bool lower upper type_base].
    split; [ reflexivity | ].
    intros *; rewrite combine_same, in_map_iff, Bool.andb_true_iff, !Z.leb_le.
    intros; destruct_head'_ex; destruct_head'_and; subst *; cbn [fst snd].
    match goal with
    | [ H : In ?v x |- _ ] => revert v H
    end.
    rewrite H.
    generalize (eval (n:=n) machine_wordsize x).
    cbn [base.interp base.base_interp].
    generalize n.
    intro n'.
    induction n' as [|n' IHn'].
    { cbv [Partition.partition seq List.map In]; tauto. }
    { intros *; rewrite Partition.partition_step, in_app_iff; cbn [List.In].
      intros; destruct_head'_or; subst *; eauto; try tauto; [].
      rewrite uweight_S by lia.
      assert (0 < uweight machine_wordsize n') by now apply uwprops.
      assert (0 < 2 ^ machine_wordsize) by auto with zarith.
      assert (0 < 2 ^ machine_wordsize * uweight machine_wordsize n') by nia.
      rewrite <- Z.mod_pull_div by lia.
      rewrite Z.le_sub_1_iff.
      auto with zarith. }
  Qed.

  (* XXX FIXME *)
  Lemma bounded_by_prime_bounds_of_valid_gen lgr n' x
        (Hlgr : 0 < lgr)
        (Hs : s = 2^Z.log2 s)
        (Hs' : s <= uweight lgr n')
        (H : WordByWordMontgomery.valid lgr n' m x)
    : ZRange.type.base.option.is_bounded_by (t:=base.type.list base.type.Z) (Some (List.map (fun v => Some r[0~>v]%zrange) (Partition.partition (uweight lgr) n' (s-1)))) x = true.
  Proof using curve_good.
    pose proof use_curve_good as use_curve_good.
    clear -H use_curve_good curve_good Hlgr Hs Hs'.
    destruct H as [H ?]; destruct_head'_and.
    cbv [small] in H.
    cbv [ZRange.type.base.option.is_bounded_by].
    replace n' with (List.length x) by now rewrite H, Partition.length_partition.
    rewrite fold_andb_map_map1, fold_andb_map_iff.
    split; [ now autorewrite with distr_length | ].
    cbv [ZRange.type.base.is_bounded_by is_bounded_by_bool lower upper].
    rewrite H; autorewrite with distr_length.
    intros [v1 v0]; cbn [fst snd].
    rename x into x'.
    generalize dependent (eval (n:=n') lgr x').
    replace m with (s - c) in * by easy.
    intro x; intros ??? H; subst x'.
    eapply In_nth_error in H; destruct H as [i H].
    rewrite nth_error_combine in H.
    break_match_hyps; try discriminate; []; Option.inversion_option; Prod.inversion_prod; subst.
    cbv [Partition.partition] in *.
    apply nth_error_map_ex in Heqo; apply nth_error_map_ex in Heqo0; destruct Heqo as (?&?&?), Heqo0 as (?&?&?).
    rewrite nth_error_seq in *.
    break_match_hyps; try discriminate; Option.inversion_option; Prod.inversion_prod; subst.
    rewrite ?Nat.add_0_l.
    assert (0 <= x < s) by lia.
    replace s with (2^Z.log2 s) by easy.
    assert (1 < s) by lia.
    assert (0 < Z.log2 s) by now apply Z.log2_pos.
    assert (1 < 2^Z.log2 s) by auto with zarith.
    generalize dependent (Z.log2 s); intro lgs; intros.

    edestruct (uwprops lgr); try lia.
    assert (forall i : nat, 0 <= uweight lgr i) by (intro z; specialize (weight_positive z); lia).
    apply Bool.andb_true_intro; split; apply OrdersEx.Z_as_OT.leb_le;
      [apply Z.div_nonneg | apply Z.div_le_mono_nonneg]; trivial.
    apply Z.mod_pos_bound; trivial.

    cbv [uweight].
    cbv [weight].
    rewrite Z.div_1_r.
    rewrite Z.opp_involutive.
    rewrite <-2Z.land_ones by nia.
    rewrite Z.sub_1_r, <-Z.ones_equiv.
    rewrite Z.land_ones_ones.
    destruct ((lgs <? 0) || (lgr * Z.of_nat (S i) <? 0)) eqn:?.
    { rewrite Z.land_ones, Z.ones_equiv, <-Z.sub_1_r by nia.
      pose proof Z.le_max_r lgs (lgr*Z.of_nat (S i)).
      etransitivity.
      2:rewrite <- Z.sub_le_mono_r.
      2:eapply Z.pow_le_mono_r; try lia; eassumption.
      eapply Z.le_sub_1_iff, Z.mod_pos_bound, Z.pow_pos_nonneg; nia. }
    rewrite (Z.ones_equiv (Z.min _ _)), <-Z.sub_1_r.
    enough (Z.land x (Z.ones (lgr * Z.of_nat (S i))) < 2 ^ Z.min lgs (lgr * Z.of_nat (S i))) by lia.
    eapply Testbit.Z.testbit_false_bound. nia.
    intros j ?; assert (Z.min lgs (lgr * Z.of_nat (S i)) <= j) by lia.
    rewrite Hs in *. revert H; intros.
    rewrite <-(Z.mod_small x (2^lgs)) by lia.
    rewrite OrdersEx.Z_as_OT.land_spec.
    destruct (Zmin_irreducible lgs (lgr * Z.of_nat (S i))) as [HH|HH]; rewrite HH in *; clear HH.
    { rewrite Z.mod_pow2_bits_high; trivial; lia. }
    { rewrite OrdersEx.Z_as_DT.ones_spec_high, Bool.andb_false_r; trivial; nia. }
  Qed.

  Lemma length_of_valid lgr n' x
        (H : WordByWordMontgomery.valid lgr n' m x)
    : List.length x = n'.
  Proof using Type.
    destruct H as [H _]; rewrite H.
    now autorewrite with distr_length.
  Qed.

  Lemma bounded_by_prime_bounds_of_valid x
        (H : valid x)
    : ZRange.type.base.option.is_bounded_by (t:=base.type.list base.type.Z) (Some prime_bounds) x = true.
  Proof using curve_good.
    pose proof use_curve_good as use_curve_good.
    destruct_head'_and.
    now apply bounded_by_prime_bounds_of_valid_gen.
  Qed.

  Lemma bounded_by_prime_bytes_bounds_of_bytes_valid x
        (H : bytes_valid x)
    : ZRange.type.base.option.is_bounded_by (t:=base.type.list base.type.Z) (Some prime_bytes_bounds) x = true.
  Proof using curve_good.
    pose proof use_curve_good as use_curve_good.
    destruct_head'_and.
    now apply bounded_by_prime_bounds_of_valid_gen.
  Qed.

  Lemma weight_bounded_of_bytes_valid x
        (H : bytes_valid x)
    : 0 <= eval 8 (n:=n_bytes) x < weight machine_wordsize 1 n.
  Proof using curve_good.
    cbv [bytes_valid] in H.
    destruct H as [_ H].
    pose proof use_curve_good.
    cbv [uweight] in *; destruct_head'_and; lia.
  Qed.

  Local Ltac solve_extra_bounds_side_conditions :=
    solve [ cbn [lower upper fst snd] in *; Bool.split_andb; Z.ltb_to_lt; lia
          | cbv [valid small eval uweight n_bytes] in *; destruct_head'_and; auto
          | now apply weight_bounded_of_bytes_valid
          | eapply length_of_valid; eassumption ].

  Hint Rewrite
       (@eval_mulmod machine_wordsize n m r' m')
       (@eval_squaremod machine_wordsize n m r' m')
       (@eval_addmod machine_wordsize n m r' m')
       (@eval_submod machine_wordsize n m r' m')
       (@eval_oppmod machine_wordsize n m r' m')
       (@eval_from_montgomerymod machine_wordsize n m r' m')
       (@eval_to_montgomerymod machine_wordsize n m r' m')
       (@eval_encodemod machine_wordsize n m r' m')
       eval_to_bytesmod
       eval_from_bytesmod
       using solve [ eauto using length_of_valid | congruence | solve_extra_bounds_side_conditions ] : push_eval.
  (* needed for making [autorewrite] fast enough *)
  Local Opaque
        WordByWordMontgomery.WordByWordMontgomery.onemod
        WordByWordMontgomery.WordByWordMontgomery.from_montgomerymod
        WordByWordMontgomery.WordByWordMontgomery.to_montgomerymod
        WordByWordMontgomery.WordByWordMontgomery.mulmod
        WordByWordMontgomery.WordByWordMontgomery.squaremod
        WordByWordMontgomery.WordByWordMontgomery.encodemod
        WordByWordMontgomery.WordByWordMontgomery.addmod
        WordByWordMontgomery.WordByWordMontgomery.submod
        WordByWordMontgomery.WordByWordMontgomery.oppmod
        WordByWordMontgomery.WordByWordMontgomery.to_bytesmod.
  Hint Unfold eval zeromod onemod : push_eval.

  Local Ltac prove_correctness op_correct :=
    let dont_clear H := first [ constr_eq H curve_good ] in
    let Hres := match goal with H : _ = Success _ |- _ => H end in
    let H := fresh in
    pose proof use_curve_good as H;
    (* I want to just use [clear -H Hres], but then I can't use any lemmas in the section because of COQBUG(https://github.com/coq/coq/issues/8153) *)
    repeat match goal with
           | [ H' : _ |- _ ]
             => tryif first [ has_body H' | constr_eq H' H | constr_eq H' Hres | dont_clear H' ]
             then fail
             else clear H'
           end;
    cbv zeta in *;
    destruct_head'_and;
    let f := match type of Hres with ?f = _ => head f end in
    try cbv [f] in *;
    hnf;
    PipelineTactics.do_unfolding;
    try (let m := match goal with m := _ - Associational.eval _ |- _ => m end in
         cbv [m] in * );
    intros;
    lazymatch goal with
    | [ |- _ <-> _ ] => idtac
    | [ |- _ = _ ] => idtac
    | _ => split; [ | try split ];
           cbv [small]
    end;
    PipelineTactics.use_compilers_correctness Hres;
    repeat first [ reflexivity
                 | now apply bounded_by_of_valid
                 | now apply bounded_by_prime_bounds_of_valid
                 | now apply bounded_by_prime_bytes_bounds_of_bytes_valid
                 | now apply weight_bounded_of_bytes_valid
                 | solve [ eapply op_correct; try eassumption; solve_extra_bounds_side_conditions ]
                 | progress autorewrite with interp_gen_cache interp_extra
                 | progress autorewrite with push_eval
                 | progress autounfold with push_eval
                 | progress autorewrite with distr_length in *
                 | solve [ cbv [valid small eval uweight n_bytes] in *; destruct_head'_and; auto ] ].

  (** TODO: DESIGN DECISION:

        The correctness lemmas for most of the montgomery things are
        parameterized over a `from_montgomery`.  When filling this in
        for, e.g., mul-correctness, should I use `from_montgomery`
        from arithmetic, or should I use `Interp
        reified_from_montgomery` (the post-pipeline version), and take
        in success of the pipeline on `from_montgomery` as well? *)

  Lemma mul_correct res
        (Hres : mul = Success res)
    : mul_correct machine_wordsize n m valid from_montgomery_res (Interp res).
  Proof using curve_good. prove_correctness mulmod_correct. Qed.

  Lemma Wf_mul res (Hres : mul = Success res) : Wf res.
  Proof using Type. prove_pipeline_wf (). Qed.

  Lemma square_correct res
        (Hres : square = Success res)
    : square_correct machine_wordsize n m valid from_montgomery_res (Interp res).
  Proof using curve_good. prove_correctness squaremod_correct. Qed.

  Lemma Wf_square res (Hres : square = Success res) : Wf res.
  Proof using Type. prove_pipeline_wf (). Qed.

  Lemma add_correct res
        (Hres : add = Success res)
    : add_correct machine_wordsize n m valid from_montgomery_res (Interp res).
  Proof using curve_good. prove_correctness addmod_correct. Qed.

  Lemma Wf_add res (Hres : add = Success res) : Wf res.
  Proof using Type. prove_pipeline_wf (). Qed.

  Lemma sub_correct res
        (Hres : sub = Success res)
    : sub_correct machine_wordsize n m valid from_montgomery_res (Interp res).
  Proof using curve_good. prove_correctness submod_correct. Qed.

  Lemma Wf_sub res (Hres : sub = Success res) : Wf res.
  Proof using Type. prove_pipeline_wf (). Qed.

  Lemma opp_correct res
        (Hres : opp = Success res)
    : opp_correct machine_wordsize n m valid from_montgomery_res (Interp res).
  Proof using curve_good. prove_correctness oppmod_correct. Qed.

  Lemma Wf_opp res (Hres : opp = Success res) : Wf res.
  Proof using Type. prove_pipeline_wf (). Qed.

  Lemma from_montgomery_correct res
        (Hres : from_montgomery = Success res)
    : from_montgomery_correct machine_wordsize n m r' valid (Interp res).
  Proof using curve_good. prove_correctness from_montgomerymod_correct. Qed.

  Lemma Wf_from_montgomery res (Hres : from_montgomery = Success res) : Wf res.
  Proof using Type. prove_pipeline_wf (). Qed.

  Lemma to_montgomery_correct res
        (Hres : to_montgomery = Success res)
    : to_montgomery_correct machine_wordsize n m valid from_montgomery_res (Interp res).
  Proof using curve_good. prove_correctness to_montgomerymod_correct. Qed.

  Lemma Wf_to_montgomery res (Hres : to_montgomery = Success res) : Wf res.
  Proof using Type. prove_pipeline_wf (). Qed.

  Lemma nonzero_correct res
        (Hres : nonzero = Success res)
    : nonzero_correct machine_wordsize n m valid from_montgomery_res (Interp res).
  Proof using curve_good. prove_correctness nonzeromod_correct. Qed.

  Lemma Wf_nonzero res (Hres : nonzero = Success res) : Wf res.
  Proof using Type. prove_pipeline_wf (). Qed.

  Lemma to_bytes_correct res
        (Hres : to_bytes = Success res)
    : to_bytes_correct machine_wordsize n n_bytes m valid (Interp res).
  Proof using curve_good. prove_correctness to_bytesmod_correct. Qed.

  Lemma Wf_to_bytes res (Hres : to_bytes = Success res) : Wf res.
  Proof using Type. prove_pipeline_wf (). Qed.

  Lemma from_bytes_correct res
        (Hres : from_bytes = Success res)
    : from_bytes_correct machine_wordsize n n_bytes m valid bytes_valid (Interp res).
  Proof using curve_good. prove_correctness eval_from_bytesmod_and_partitions. Qed.

  Lemma Wf_from_bytes res (Hres : from_bytes = Success res) : Wf res.
  Proof using Type. prove_pipeline_wf (). Qed.

  Strategy -1000 [encode]. (* if we don't tell the kernel to unfold this early, then [Qed] seems to run off into the weeds *)
  Lemma encode_correct res
        (Hres : encode = Success res)
    : encode_correct machine_wordsize n m valid from_montgomery_res (Interp res).
  Proof using curve_good. prove_correctness encodemod_correct. Qed.

  Lemma Wf_encode res (Hres : encode = Success res) : Wf res.
  Proof using Type. prove_pipeline_wf (). Qed.

  Strategy -1000 [encode_word]. (* if we don't tell the kernel to unfold this early, then [Qed] seems to run off into the weeds *)
  Lemma encode_word_correct res
        (Hres : encode_word = Success res)
    : encode_word_correct machine_wordsize n m valid from_montgomery_res (Interp res).
  Proof using curve_good. prove_correctness encodemod_correct. Qed.

  Lemma Wf_encode_word res (Hres : encode_word = Success res) : Wf res.
  Proof using Type. prove_pipeline_wf (). Qed.

  Strategy -1000 [zero]. (* if we don't tell the kernel to unfold this early, then [Qed] seems to run off into the weeds *)
  Lemma zero_correct res
        (Hres : zero = Success res)
    : zero_correct machine_wordsize n m valid from_montgomery_res (Interp res).
  Proof using curve_good. prove_correctness encodemod_correct. Qed.

  Lemma Wf_zero res (Hres : zero = Success res) : Wf res.
  Proof using Type. prove_pipeline_wf (). Qed.

  Strategy -1000 [one]. (* if we don't tell the kernel to unfold this early, then [Qed] seems to run off into the weeds *)
  Lemma one_correct res
        (Hres : one = Success res)
    : one_correct machine_wordsize n m valid from_montgomery_res (Interp res).
  Proof using curve_good. prove_correctness encodemod_correct. Qed.

  Lemma Wf_one res (Hres : one = Success res) : Wf res.
  Proof using Type. prove_pipeline_wf (). Qed.

  Local Opaque Pipeline.BoundsPipeline. (* need this or else [eapply Pipeline.BoundsPipeline_correct in Hres] takes forever *)

  Lemma selectznz_correct res
        (Hres : selectznz = Success res)
    : selectznz_correct saturated_bounds (Interp res).
  Proof using curve_good. apply Primitives.selectznz_correct, Hres. Qed.

  Lemma Wf_selectznz res (Hres : selectznz = Success res) : Wf res.
  Proof using Type. revert Hres; cbv [selectznz]; apply Wf_selectznz. Qed.

  Lemma copy_correct res
        (Hres : copy = Success res)
    : copy_correct saturated_bounds (Interp res).
  Proof using curve_good. Primitives.prove_correctness use_curve_good. Qed.

  Lemma Wf_copy res (Hres : copy = Success res) : Wf res.
  Proof using Type. revert Hres; cbv [copy]; apply Wf_copy. Qed.

  Section ring.
    Context from_montgomery_res (Hfrom_montgomery : from_montgomery = Success from_montgomery_res)
            mul_res    (Hmul    : mul    = Success mul_res)
            add_res    (Hadd    : add    = Success add_res)
            sub_res    (Hsub    : sub    = Success sub_res)
            opp_res    (Hopp    : opp    = Success opp_res)
            encode_res (Hencode : encode = Success encode_res)
            zero_res   (Hzero   : zero   = Success zero_res)
            one_res    (Hone    : one    = Success one_res).

    Definition GoodT : Prop
      := GoodT
           machine_wordsize n m valid
           (Interp from_montgomery_res)
           (Interp mul_res)
           (Interp add_res)
           (Interp sub_res)
           (Interp opp_res)
           (Interp encode_res)
           (Interp zero_res)
           (Interp one_res).

    Theorem Good : GoodT.
    Proof using curve_good Hfrom_montgomery Hmul Hadd Hsub Hopp Hencode Hzero Hone.
      pose proof use_curve_good; cbv zeta in *; destruct_head'_and.
      eapply Good.
      all: repeat first [ assumption
                        | apply from_montgomery_correct
                        | lia ].
      all: hnf; intros.
      all: push_Zmod; erewrite !(fun v Hv => proj1 (from_montgomery_correct _ Hfrom_montgomery v Hv)), <- !eval_from_montgomerymod; try eassumption; pull_Zmod.
      all: repeat first [ assumption
                        | lazymatch goal with
                          | [ |- context[mul_res] ] => apply mul_correct
                          | [ |- context[add_res] ] => apply add_correct
                          | [ |- context[sub_res] ] => apply sub_correct
                          | [ |- context[opp_res] ] => apply opp_correct
                          | [ |- context[encode_res] ] => apply encode_correct
                          | [ |- context[zero_res] ] => apply zero_correct
                          | [ |- context[one_res] ] => apply one_correct
                          end ].
    Qed.
  End ring.

  Section for_stringification.
    Local Open Scope string_scope.
    Local Open Scope list_scope.

    Definition known_functions
      := [("mul", wrap_s smul);
            ("square", wrap_s ssquare);
            ("add", wrap_s sadd);
            ("sub", wrap_s ssub);
            ("opp", wrap_s sopp);
            ("from_montgomery", wrap_s sfrom_montgomery);
            ("to_montgomery", wrap_s sto_montgomery);
            ("nonzero", wrap_s snonzero);
            ("selectznz", wrap_s sselectznz);
            ("to_bytes", wrap_s sto_bytes);
            ("from_bytes", wrap_s sfrom_bytes);
            ("one", wrap_s sone);
            ("msat", wrap_s smsat);
            ("divstep_precomp", wrap_s sdivstep_precomp);
            ("divstep", wrap_s sdivstep)].

    Definition valid_names : string := Eval compute in String.concat ", " (List.map (@fst _ _) known_functions).

    (** Note: If you change the name or type signature of this
          function, you will need to update the code in CLI.v *)
    Definition Synthesize (comment_header : list string) (function_name_prefix : string) (requests : list string)
      : list (synthesis_output_kind * string * Pipeline.M (list string))
      := Primitives.Synthesize
           machine_wordsize valid_names known_functions (fun _ => nil) all_typedefs!
           check_args
           (ToString.comment_file_header_block
              (comment_header
                 ++ [""
                     ; "Computed values:"]
                 ++ (List.map
                       (fun s => "  " ++ s)%string
                       ((ToString.prefix_and_indent "eval z = " [seval "z"])
                          ++ (ToString.prefix_and_indent "bytes_eval z = " [sbytes_eval "z"])
                          ++ (ToString.prefix_and_indent "twos_complement_eval z = " [seval_twos_complement "z"])))))
           function_name_prefix requests.
  End for_stringification.
End __.

Module Export Hints.
#[global]
  Hint Opaque
       mul
       square
       add
       sub
       opp
       from_montgomery
       to_montgomery
       nonzero
       to_bytes
       from_bytes
       encode
       encode_word
       zero
       one
       selectznz
       copy
  : wf_op_cache.
#[global]
  Hint Immediate
       Wf_mul
       Wf_square
       Wf_add
       Wf_sub
       Wf_opp
       Wf_from_montgomery
       Wf_to_montgomery
       Wf_nonzero
       Wf_to_bytes
       Wf_from_bytes
       Wf_encode
       Wf_encode_word
       Wf_zero
       Wf_one
       Wf_selectznz
       Wf_copy
  : wf_op_cache.
End Hints.


From program_logic Require Export global_functor.
From heap_lang Require Export heap.
From heap_lang Require Import wp_tactics notation.
Import uPred.

Definition spawn : val :=
  λ: "f",
    let: "c" := ref (InjL #0) in
    Fork ('"c" <- InjR ('"f" #())) ;; '"c".
Definition join : val :=
  rec: "join" "c" :=
    match: !'"c" with
      InjR "x" => '"x"
    | InjL <>  => '"join" '"c"
    end.

(** The CMRA we need. *)
(* Not bundling heapG, as it may be shared with other users. *)
Class spawnG Σ := SpawnG {
  spawn_tokG :> inG heap_lang Σ (exclR unitC);
}.
(** The functor we need. *)
Definition spawnGF : gFunctorList := [GFunctor (constRF (exclR unitC))].
(* Show and register that they match. *)
Instance inGF_spawnG
  `{H : inGFs heap_lang Σ spawnGF} : spawnG Σ.
Proof. destruct H as (?&?). split. apply: inGF_inG. Qed.

(** Now we come to the Iris part of the proof. *)
Section proof.
Context {Σ : gFunctors} `{!heapG Σ, !spawnG Σ}.
Context (heapN N : namespace).
Local Notation iProp := (iPropG heap_lang Σ).

Definition spawn_inv (γ : gname) (l : loc) (Ψ : val → iProp) : iProp :=
  (∃ lv, l ↦ lv ★ (lv = InjLV #0 ∨ ∃ v, lv = InjRV v ★ (Ψ v ∨ own γ (Excl ()))))%I.

Definition join_handle (l : loc) (Ψ : val → iProp) : iProp :=
  (■ (heapN ⊥ N) ★ ∃ γ, heap_ctx heapN ★ own γ (Excl ()) ★
                        inv N (spawn_inv γ l Ψ))%I.

Global Instance spawn_inv_ne n γ l :
  Proper (pointwise_relation val (dist n) ==> dist n) (spawn_inv γ l).
Proof. solve_proper. Qed.
Global Instance join_handle_ne n l :
  Proper (pointwise_relation val (dist n) ==> dist n) (join_handle l).
Proof. solve_proper. Qed.

(** The main proofs. *)
Lemma spawn_spec (Ψ : val → iProp) e (f : val) (Φ : val → iProp) :
  to_val e = Some f →
  heapN ⊥ N →
  (heap_ctx heapN ★ #> f #() {{ Ψ }} ★ ∀ l, join_handle l Ψ -★ Φ (%l))
  ⊑ #> spawn e {{ Φ }}.
Proof.
  intros Hval Hdisj. rewrite /spawn. ewp (by eapply wp_value). wp_let.
  wp eapply wp_alloc; eauto with I.
  apply forall_intro=>l. apply wand_intro_l. wp_let.
  rewrite (forall_elim l). eapply sep_elim_True_l.
  { by eapply (own_alloc (Excl ())). }
  rewrite !pvs_frame_r. eapply wp_strip_pvs. rewrite !sep_exist_r.
  apply exist_elim=>γ.
  (* TODO: Figure out a better way to say "I want to establish ▷ spawn_inv". *)
  trans (heap_ctx heapN ★ #> f #() {{ Ψ }} ★ (join_handle l Ψ -★ Φ (%l)%V) ★
         own γ (Excl ()) ★ ▷ (spawn_inv γ l Ψ))%I.
  { ecancel [ #> _ {{ _ }}; _ -★ _; heap_ctx _; own _ _]%I.
    rewrite -later_intro /spawn_inv -(exist_intro (InjLV #0)).
    cancel [l ↦ InjLV #0]%I. by apply or_intro_l', const_intro. }
  rewrite (inv_alloc N) // !pvs_frame_l. eapply wp_strip_pvs.
  ewp eapply wp_fork. rewrite [heap_ctx _]always_sep_dup [inv _ _]always_sep_dup.
  sep_split left: [_ -★ _; inv _ _; own _ _; heap_ctx _]%I.
  - wp_seq. eapply wand_apply_l; [done..|].
    rewrite /join_handle. rewrite const_equiv // left_id -(exist_intro γ).
    solve_sep_entails.
  - wp_focus (f _). rewrite wp_frame_r wp_frame_l.
    rewrite (of_to_val e) //. apply wp_mono=>v.
    eapply (inv_fsa (wp_fsa _)) with (N0:=N); simpl;
      (* TODO: Collect these in some Hint DB? Or add to an existing one? *)
      eauto using to_val_InjR,to_val_InjL,to_of_val with I ndisj.
    apply wand_intro_l. rewrite /spawn_inv {1}later_exist !sep_exist_r.
    apply exist_elim=>lv. rewrite later_sep.
    eapply wp_store; eauto using to_val_InjR,to_val_InjL,to_of_val with I ndisj.
    cancel [▷ (l ↦ lv)]%I. strip_later. apply wand_intro_l.
    rewrite right_id -later_intro -{2}[(∃ _, _ ↦ _ ★ _)%I](exist_intro (InjRV v)).
    ecancel [l ↦ _]%I. apply or_intro_r'. rewrite sep_elim_r sep_elim_r sep_elim_l.
    rewrite -(exist_intro v). rewrite const_equiv // left_id. apply or_intro_l.
Qed.

Lemma join_spec (Ψ : val → iProp) l (Φ : val → iProp) :
  (join_handle l Ψ ★ ∀ v, Ψ v -★ Φ v)
  ⊑ #> join (%l) {{ Φ }}.
Proof.
  wp_rec. wp_focus (! _)%E.
  rewrite {1}/join_handle sep_exist_l !sep_exist_r. apply exist_elim=>γ.
  rewrite -!assoc. apply const_elim_sep_l=>Hdisj.
  eapply (inv_fsa (wp_fsa _)) with (N0:=N); simpl; eauto with I ndisj.
  apply wand_intro_l. rewrite /spawn_inv {1}later_exist !sep_exist_r.
  apply exist_elim=>lv. rewrite later_sep.
  eapply wp_load; eauto with I ndisj. cancel [▷ (l ↦ lv)]%I. strip_later.
  apply wand_intro_l. rewrite -later_intro -[X in _ ⊑ (X ★ _)](exist_intro lv).
  cancel [l ↦ lv]%I. rewrite sep_or_r. apply or_elim.
  - (* Case 1 : nothing sent yet, we wait. *)
    rewrite -or_intro_l. apply const_elim_sep_l=>-> {lv}.
    do 2 rewrite const_equiv // left_id. wp_case.
    wp_seq. rewrite -always_wand_impl always_elim.
    rewrite !assoc. eapply wand_apply_r'; first done.
    rewrite -(exist_intro γ). solve_sep_entails.
  - rewrite [(_ ★ □ _)%I]sep_elim_l -or_intro_r !sep_exist_r. apply exist_mono=>v.
    rewrite -!assoc. apply const_elim_sep_l=>->{lv}. rewrite const_equiv // left_id.
    rewrite sep_or_r. apply or_elim; last first.
    { (* contradiction: we have the token twice. *)
      rewrite [(heap_ctx _ ★ _)%I]sep_elim_r !assoc. rewrite -own_op own_valid_l.
      rewrite -!assoc discrete_valid. apply const_elim_sep_l=>-[]. }
    rewrite -or_intro_r. ecancel [own _ _].
    wp_case. wp_let. ewp (eapply wp_value; wp_done).
    rewrite (forall_elim v). rewrite !assoc. eapply wand_apply_r'; eauto with I.
Qed.

End proof.


From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import Loc.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Language.
From PromisingLib Require Import Event.

Require Import Time.
Require Import View.
Require Import BoolMap.
Require Import Promises.
Require Import Cell.
Require Import Memory.
Require Import Global.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.

Require Import SimLocal.
Require Import SimMemory.
Require Import SimGlobal.
Require Import SimThread.
Require Import Compatibility.

Require Import ITreeLang.
Require Import ITreeLib.

Set Implicit Arguments.

Lemma intro_load_sim_itree
      loc ord:
  sim_itree eq
            (Ret tt)
            (ITree.trigger (MemE.read loc ord);; Ret tt).
Proof.
  unfold trigger. rewrite bind_vis.
  pcofix CIH. ii. subst. pfold. ii. splits; i.
  { inv TERMINAL_TGT. eapply f_equal with (f:=observe) in H; ss. }
  { right. esplits; eauto.
    rewrite sim_local_promises_bot; eauto.
  }
  ii. right.
  inv STEP_TGT; ss.
  - (* internal *)
    exploit sim_local_internal; eauto. i. des.
    esplits; try exact GL2; eauto. inv LOCAL0; ss.
  - (* load *)
    dependent destruction STATE.
    esplits; [|refl|econs 1|..]; eauto.
    + destruct e_tgt; ss.
    + destruct e_tgt; ss.
    + by inv LOCAL0.
    + left. rewrite bind_ret_l. eapply paco9_mon; [apply sim_itree_ret|]; ss.
      inv LOCAL. inv LOCAL0; ss. inv LOCAL. econs; ss.
      etrans; eauto. apply TViewFacts.read_tview_incr.
Qed.


Require Import VST.floyd.proofauto.
Require Import VST.msl.iter_sepcon.
Require Import malloc_lemmas.
Require Import malloc_sep.
Require Import malloc.
Require Import spec_malloc.
Require Import linking.

Definition Gprog : funspecs := user_specs_R ++ private_specs.

Lemma body_pre_fill:  semax_body Vprog Gprog f_pre_fill pre_fill_spec'.
Proof.
start_function.
rewrite <- seq_assoc.
forward_call n. (*! b = size2bin(n) *)
destruct H as [[Hn_lo Hn_hi] Hp].
rep_omega.
forward.
set (b:=size2binZ n).
assert (Hb: 0 <= b < BINS) by (apply size2bin_range; rep_omega).
forward_call b. (*! t2 = bin2size(b) *)
rewrite (mem_mgr_split_R gv b rvec) by apply Hb.
Intros bins idxs lens.
freeze [1; 3] Otherlists.
deadvars!.
destruct H as [[Hn_lo Hn_hi] Hp].
forward. (*! t4 = bin[b] *)
forward_call ((bin2sizeZ b), p, (Znth b bins), (Znth b lens), b). (*! t3 = list_from_block(t2,p,t4) *)
Intros q.
forward. (*! bin[b] = t3 *)
thaw Otherlists.

(* fold lists into mem_mgr_R *)
replace (size2binZ (bin2sizeZ b)) with b
  by (subst b; rewrite claim3; try rep_omega).
unfold mem_mgr_R.
set (bins':= upd_Znth b bins q).
set (lens':= map Z.to_nat (add_resvec rvec b (chunks_from_block b))).
assert (Hrveclen: Zlength rvec = BINS) by
    (subst lens; rewrite Zlength_map in H1; rep_omega).
Exists bins'. Exists idxs. Exists lens'.
entailer!.
{ split. unfold lens'. rewrite Zlength_map. rewrite Zlength_add_resvec; assumption.
  apply add_resvec_no_neg; try assumption.
  pose proof (chunks_from_block_nonneg (size2binZ n)).
  assert (0 <= Znth (size2binZ n) rvec)
    by (apply Forall_Znth; try rep_omega; try unfold no_neg in *; auto).
  rep_omega.
}
set (idxs:= (map Z.of_nat (seq 0 (Z.to_nat BINS)))).
set (lens:= (map Z.to_nat rvec)).
assert (Zlength lens = BINS) by (unfold lens; rewrite Zlength_map; rep_omega).
assert (Zlength idxs = BINS) by auto.
repeat (rewrite sublist_zip3; try rep_omega).
replace (sublist 0 b bins) with (sublist 0 b bins')
  by (unfold bins'; rewrite sublist_upd_Znth_l; try reflexivity; try rep_omega).
replace (sublist (b+1) BINS bins) with (sublist (b+1) BINS bins')
  by (unfold bins'; rewrite sublist_upd_Znth_r; try reflexivity; try rep_omega).
replace (sublist 0 b lens) with (sublist 0 b lens').
2: { unfold lens'. unfold lens.  do 2 rewrite sublist_map. f_equal.
     unfold add_resvec. simple_if_tac''; auto.
     rewrite sublist_upd_Znth_l; try rep_omega; reflexivity. }
replace (sublist (b + 1) BINS lens) with (sublist (b + 1) BINS lens').
2: { unfold lens'. unfold lens.  do 2 rewrite sublist_map. f_equal.
     unfold add_resvec. simple_if_tac''; auto.
     rewrite sublist_upd_Znth_r; try rep_omega; reflexivity. }
assert (Zlength bins' = BINS) by auto.
assert (Zlength lens' = BINS)
  by (unfold lens'; rewrite Zlength_map; rewrite Zlength_add_resvec; auto).
repeat (rewrite <- sublist_zip3; try rep_omega); try rep_omega.
replace (Z.to_nat (chunks_from_block b) + Znth b lens)%nat with (Znth b lens').
2: {unfold lens'.  rewrite Znth_map.
    unfold add_resvec. simple_if_tac' Hcond.
    2: { assert (Zlength rvec = BINS) by auto.
         bdestruct(Zlength rvec =? BINS); simpl in Hcond; try contradiction.
         bdestruct(0 <=? b); simpl in Hcond; try contradiction.
         bdestruct(b<?BINS); simpl in Hcond; try contradiction.
         discriminate.
         rep_omega.
         destruct Hb; contradiction.
    }
    rewrite upd_Znth_same; try rep_omega.
    replace (Znth b lens) with (Z.to_nat (Znth b rvec))
      by (unfold lens; rewrite Znth_map; rep_omega).
    rewrite <- Z2Nat.inj_add. f_equal. rep_omega.
    apply chunks_from_block_nonneg.
    apply Forall_Znth; try rep_omega; try unfold no_neg in *; auto.
    rewrite Zlength_add_resvec; rep_omega.
}
replace
 (mmlist (bin2sizeZ b) (Znth b lens') q nullval * TT *
  iter_sepcon mmlist' (sublist 0 b (zip3 lens' bins' idxs)) *
  iter_sepcon mmlist' (sublist (b + 1) BINS (zip3 lens' bins' idxs)) * TT)
with
 (iter_sepcon mmlist' (sublist 0 b (zip3 lens' bins' idxs)) *
  iter_sepcon mmlist' (sublist (b + 1) BINS (zip3 lens' bins' idxs)) *
  mmlist (bin2sizeZ b) (Znth b lens') q nullval * TT)
by (apply pred_ext; entailer!).
replace q with (Znth b bins').
2: (unfold bins'; rewrite upd_Znth_same; auto; rep_omega).
rewrite mem_mgr_split'; try entailer!; auto.
Qed.

Definition module := [mk_body body_pre_fill].


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
From mathcomp Require Import ssreflect eqtype ssrbool eqtype ssrnat seq.
Require Import ssrZ ZArith_ext seq_ext ssrnat_ext machine_int uniq_tac.
Require Import multi_int integral_type.
Import MachineInt.
Require Import mips_bipl mips_seplog mips_mint mips_frame.
Import expr_m.
Require Import simu.
Import simu_m.
Require Import multi_add_s_s_u_prg multi_add_s_s_u_triple.

Local Open Scope machine_int_scope.
Local Open Scope asm_expr_scope.
Local Open Scope zarith_ext_scope.
Local Open Scope assoc_scope.
Local Open Scope uniq_scope.
Local Open Scope heap_scope.
Local Open Scope simu_scope.
Local Open Scope asm_cmd_scope.
Local Open Scope multi_int_scope.

Import assert_m.

(** z <- x + y, z signed, x signed, y unsigned *)

Lemma pfwd_sim_multi_add_s_s_u_wo_overflow (z x y : assoc.l) d k rk rz rx ry a0 a1 a2 a3 a4 ret X Y :
  uniq(z, x, y) ->
  uniq(rk, rz, rx, ry, a0, a1, a2, a3, a4, ret, X, Y, r0) ->
  disj (mints_regs (assoc.cdom d)) (a0 :: a1 :: a2 :: a3 :: a4 :: ret :: X :: Y :: nil) ->
  z \notin assoc.dom d -> x \notin assoc.dom d -> y \notin assoc.dom d ->
  signed k rz \notin assoc.cdom d -> signed k rx \notin assoc.cdom d -> unsign rk ry \notin assoc.cdom d ->
  (z <- (var_e x \+ var_e y)%pseudo_expr)%pseudo_cmd
    <=p( state_mint (z |=> signed k rz \U+ (x |=> signed k rx \U+ (y |=> unsign rk ry \U+ d))),
         (fun s st _ => [rk ]_ st <> zero32 /\
                       u2Z ([rk ]_ st) < 2 ^^ 31 /\
                       k = '|u2Z ([rk ]_ st)| /\
                       `| ([x ]_ s)%pseudo_expr | < \B^(k - 1) /\
                       0 <= ([y ]_ s)%pseudo_expr < \B^(k - 1))%asm_expr )
  multi_add_s_s_u rk rz rx ry a0 a1 a2 a3 a4 ret X Y.
Proof.
move=> Hvars Hregs Disj z_d x_d y_d rz_d rx_d ry_d.
rewrite /pfwd_sim => s st h [s_st_h [rk_0 [rk_231 [Hk [x_fit y_fit]]]]] s' exec_pseudo st' h' exec_asm.

move: (proj1 s_st_h z (signed k rz)).
rewrite assoc.get_union_sing_eq.
case/(_ Logic.eq_refl) => lz pz Z rz_fit [Z_k lz_k lz_z z_Z] pz_fit mem_z.

move: (proj1 s_st_h x (signed k rx)).
rewrite assoc.get_union_sing_neq; last by Uniq_neq.
rewrite assoc.get_union_sing_eq.
case/(_ Logic.eq_refl) => lx px X_ rx_fit [X_k lx_k lx_x x_X] px_fit mem_x.

move: (proj1 s_st_h y (unsign rk ry)).
rewrite assoc.get_union_sing_neq; last by Uniq_neq.
rewrite assoc.get_union_sing_neq; last by Uniq_neq.
rewrite assoc.get_union_sing_eq.
case/(_ Logic.eq_refl).
move=> ry_fit _ (*y_fit: superseded by y_fit*) mem_y.
have Htmp : 0 < Z_of_nat k < 2 ^^ 31.
  rewrite Hk Z_of_nat_Zabs_nat; last exact: min_u2Z.
  split => //.
  rewrite ltZ_neqAle; split; last exact: min_u2Z.
  contradict rk_0.
  by apply u2Z_inj; rewrite -rk_0 Z2uK.
move/multi_add_s_s_u_triple : (Hregs).
rewrite -Hk in ry_fit.
move/(_ k [rz]_st [rx]_st [ry]_st Htmp pz px pz_fit px_fit ry_fit Z X_
  (Z2ints 32 '|u2Z [rk ]_ st| ([y ]_ s)%pseudo_expr) Z_k X_k) => {Htmp}.
rewrite size_Z2ints Hk.
move/(_ Logic.eq_refl).
rewrite -Hk.
move/( _ _ _ lx_k lz_k).
rewrite -x_X lx_x.
move/(_ Logic.eq_refl) => hoare_triple.

have [st'' [h'' exec_asm_proj]] : exists st'' h'',
  (Some (st, h |P| heap.dom (heap_mint (signed k rz) st h \U
    heap_mint (signed k rx) st h \U heap_mint (unsign rk ry) st h))
    -- multi_add_s_s_u rk rz rx ry a0 a1 a2 a3 a4 ret X Y --->
    Some (st'', h''))%mips_cmd.
  exists st', (h' |P| heap.dom (heap_mint (signed k rz) st h \U
    heap_mint (signed k rx) st h \U heap_mint (unsign rk ry) st h)).
  rewrite conCE in hoare_triple.
  rewrite [in X in ({{ _ }} _ {{ X }} )%asm_hoare]conCE in hoare_triple.
  apply (mips_syntax.triple_exec_proj _ _ _ hoare_triple) => {hoare_triple} //.
  repeat (split; first reflexivity).
  split.
    rewrite Hk Z_of_nat_Zabs_nat //; exact: min_u2Z.
  rewrite conCE.
  rewrite -conAE.
  rewrite heap.proj_dom_union; last first.
    apply heap.disjUh.
    apply (proj2 s_st_h z y); by [Uniq_neq | assoc_get_Some | assoc_get_Some].
    apply (proj2 s_st_h x y); by [Uniq_neq | assoc_get_Some | assoc_get_Some].
  apply con_cons.
    apply heap.dis_disj_proj.
    rewrite -heap.disjE.
    apply heap.disjUh.
    apply (proj2 s_st_h z y); by [Uniq_neq | assoc_get_Some | assoc_get_Some].
    apply (proj2 s_st_h x y); by [Uniq_neq | assoc_get_Some | assoc_get_Some].
  rewrite heap.proj_dom_union; last first.
    apply (proj2 s_st_h z x); by [Uniq_neq | assoc_get_Some | assoc_get_Some].
  apply con_cons.
    apply heap.dis_disj_proj.
    rewrite -heap.disjE.
    apply (proj2 s_st_h z x); by [Uniq_neq | assoc_get_Some | assoc_get_Some].
  move: (heap_inclu_heap_mint_signed h st k rz).
  by move/heap.incluE => ->.
  move: (heap_inclu_heap_mint_signed h st k rx).
  by move/heap.incluE => ->.
  move: (heap_inclu_heap_mint_unsign h st rk ry).
  move/heap.incluE => ->. by rewrite Hk.

set postcond := (fun s h => exists _, _)%asm_assert in hoare_triple.
have {hoare_triple}hoare_triple_post_cond : (postcond ** TT)%asm_assert st' h'.
  move: {hoare_triple}(mips_frame.frame_rule_R _ _ _ hoare_triple TT (inde_TT _) (mips_frame.inde_cmd_mult_TT _)).
    move/mips_seplog.hoare_prop_m.soundness.
    rewrite /while.hoare_semantics.
    move/(_ st h) => Hmulti_add_s_s_u.
    lapply Hmulti_add_s_s_u; last first.
      exists (heap_mint (signed k rz) st h \U heap_mint (signed k rx) st h \U heap_mint (unsign rk ry) st h),
       (h \D\ heap.dom (heap_mint (signed k rz) st h \U heap_mint (signed k rx) st h \Uheap_mint (unsign rk ry) st h)).
      split; first by apply heap.disj_difs', seq_ext.inc_refl.
      split.
        apply heap.union_difsK; last by [].
        apply heap_prop_m.inclu_union.
        apply heap_prop_m.inclu_union; by [apply heap_inclu_heap_mint_signed | apply heap.inclu_proj].
        by apply heap_inclu_heap_mint_unsign.
      split; last by [].
      repeat (split=> //).
      rewrite Hk Z_of_nat_Zabs_nat //; exact: min_u2Z.
      rewrite -conAE.
      apply con_cons => //.
      + apply heap.disjUh.
        apply (proj2 s_st_h z y); by [Uniq_neq | assoc_get_Some | assoc_get_Some].
        apply (proj2 s_st_h x y); by [Uniq_neq | assoc_get_Some | assoc_get_Some].
      + apply con_cons => //.
        apply (proj2 s_st_h z x); by [Uniq_neq | assoc_get_Some | assoc_get_Some].
        by rewrite Hk.
    case=> _.
    by move/(_ _ _ exec_asm).

have rz_st_st' : [ rz ]_ st = [ rz ]_ st'.
  mips_syntax.Reg_unchanged. simpl mips_frame.modified_regs. by Uniq_not_In.
have rx_st_st' : [ rx ]_ st = [ rx ]_ st'.
  mips_syntax.Reg_unchanged. simpl mips_frame.modified_regs. by Uniq_not_In.
have rk_st_st' : [ rk ]_ st = [ rk ]_ st'.
  mips_syntax.Reg_unchanged. simpl mips_frame.modified_regs. by Uniq_not_In.

split.
- move=> x0 mx0 x0_mx0.
  case/assoc.get_union_Some_inv : x0_mx0.
  + case/assoc.get_sing_inv => ? ?; subst x0 mx0.
    case: hoare_triple_post_cond => h1 [h2 [h1dh2 [h1Uh2 [Hh1 _]]]].
    case: Hh1 => Z' [lz' [Z'_k [ry_st'_st [lz'_k [lz'_x_y [Hh1 [Ha3 Z'_x_y]]]]]]].
        have Hk' : k <> O.
          move=> abs.
          rewrite Hk in abs.
          move: abs.
          contradict rk_0.
          apply Zabs_nat_0_inv in rk_0.
          rewrite (_ : 0 = u2Z zero32) in rk_0; last by rewrite Z2uK.
          by move/u2Z_inj : rk_0.
    apply mkVarSigned with lz' pz Z' => //.
    * by rewrite -rz_st_st'.
    * apply mkSignMagn => //.
      - rewrite lz'_k Zsgn_Zmult ZsgnK.
        have -> : sgZ (Z_of_nat k) = 1.
          apply Z.sgn_pos.
          rewrite Hk Z_of_nat_Zabs_nat; last exact: min_u2Z.
          rewrite ltZ_neqAle; split; last exact: min_u2Z.
          contradict rk_0.
          apply u2Z_inj; by rewrite -rk_0 Z2uK.
        rewrite mulZ1.
        move/syntax_m.seplog_m.semop_prop_m.exec_cmd0_inv : exec_pseudo.
        case/syntax_m.seplog_m.exec0_assign_inv => _ ->.
        repeat syntax_m.seplog_m.assert_m.expr_m.Store_upd.
        rewrite lz'_x_y.
        rewrite lSum_Z2ints; last first.
          apply/ltZ_norml; split.
            apply: (@ltZ_leZ_trans 0); [rewrite ltZ_oppl oppZ0; exact: expZ_gt0|tauto].
          case: y_fit => _ y_fit.
          apply/(ltZ_leZ_trans y_fit)/leZP; rewrite ZbetaE Zpower_2_le; ssromega.
        rewrite /= /ZIT.add geZ0_norm //; tauto.
      - move/syntax_m.seplog_m.semop_prop_m.exec_cmd0_inv : exec_pseudo.
        case/syntax_m.seplog_m.exec0_assign_inv => _ ->.
        repeat syntax_m.seplog_m.assert_m.expr_m.Store_upd.
        rewrite lSum_Z2ints geZ0_norm in Z'_x_y; last  tauto.
        + case: (Z_zerop (s2Z lz')) => lz'_neq0.
            by rewrite lz'_neq0 /= /ZIT.add /= -Z'_x_y lz'_neq0.
          have {}Ha3 : u2Z [a3]_st' = 0.
            have Htmp : `|u2Z [a3 ]_ st' * \B^k + \S_{ k } Z'| < \B^k.
              apply Zabs_Zsgn_1 in lz'_neq0.
              rewrite -[X in X < _]mul1Z -lz'_neq0 -normZM addZC Z'_x_y.
              apply: leZ_ltZ_trans; first exact: Z.abs_triangle.
              apply: (@ltZ_leZ_trans (\B^(k - 1) + \B^(k - 1))).
              apply Z.add_le_lt_mono => //; first exact: ltZW.
              rewrite geZ0_norm; tauto.
              apply/leZP; rewrite /Zbeta Zpower_plus Zpower_2_le; ssromega.
            eapply poly_Zlt1_Zabs_inv; last by apply Htmp.
            exact: min_lSum.
            exact: min_u2Z.
            by [].
          rewrite /= /ZIT.add -Z'_x_y Ha3; ring.
        + tauto.
        + case: y_fit => _ y_fit; apply (ltZ_trans y_fit).
          rewrite /Zbeta; apply expZ_2_lt; ssromega.
    * case: Hh1 => h11 [h12 [h11dh12 [h11Uh12 [Hh11 Hh12]]]].
       apply con_heap_mint_signed_cons with h11 => //.
      - rewrite h1Uh2.
        apply heap.inclu_union_L => //.
        rewrite h11Uh12.
        apply heap.inclu_union_L => //.
        exact: heap.inclu_refl.
      - by rewrite -rz_st_st'.
      - by rewrite Z'_k.
  + move=> x0_mx0.
    have x0z : x0 <> z.
      move=> ?; subst x0.
      case/assoc.get_union_Some_inv : x0_mx0.
        case/assoc.get_sing_inv => abs _; move: abs.
        rewrite -/(z <> x); by Uniq_neq.
      case/assoc.get_union_Some_inv.
        case/assoc.get_sing_inv => abs _; move: abs.
        rewrite -/(z <> y); by Uniq_neq.
      move/assoc.get_Some_in_dom => abs; by rewrite abs in z_d.

have Hd_unchanged : forall v r, assoc.get v d = Some r ->
  disj (mint_regs r) (mips_frame.modified_regs (multi_add_s_s_u rk rz rx ry a0 a1 a2 a3 a4 ret X Y)).
  move=> v r Hvr; rewrite [mips_frame.modified_regs _]/=; Disj_remove_dup.
  apply (disj_incl_LR Disj); last by apply incl_refl_Permutation; PermutProve.
  apply/incP/inc_mint_regs.
  by move/assoc.get_Some_in_cdom : Hvr.

    apply var_mint_invariant with s st.
    - move=> rx0 Hrx0.
      mips_syntax.Reg_unchanged.
      apply (@disj_not_In _ (mint_regs mx0)); last by [].
      case/assoc.get_union_Some_inv : x0_mx0.
        case/assoc.get_sing_inv => ? ?; subst x0 mx0.
        simpl mint_regs. simpl modified_regs. Disj_remove_dup. simpl. apply uniq_disj.
        simpl cat. by Uniq_uniq r0.
      case/assoc.get_union_Some_inv.
        case/assoc.get_sing_inv => ? ?; subst x0 mx0.
        simpl mint_regs. simpl modified_regs. Disj_remove_dup. simpl. apply uniq_disj.
        simpl cat. by Uniq_uniq r0.
      move=> x0_mx0.
      by apply disj_sym, (Hd_unchanged x0).
    - Var_unchanged. rewrite /= mem_seq1; exact/negP/eqP.
    - suff -> : heap_mint mx0 st' h' = heap_mint mx0 st h.
        apply (proj1 s_st_h); by rewrite assoc.get_union_sing_neq.
      symmetry.
      case: hoare_triple_post_cond => h1 [h2 [h1dh2 [h1Uh2 [Hh1 _]]]].
      case: Hh1 => Z' [lz' [Z'_k [ry_st'_st [lz'_k [sgn_lz' [Hh1 [Ha3 HSum]]]]]]].
      case: Hh1 => h11 [h12 [h11dh12 [h11Uh12 [Hh11 Hh12]]]].
      case: Hh12 => h121 [h122 [h121dh122 [h121Uh122 [Hh121 Hh122]]]].
      case/assoc.get_union_Some_inv : (x0_mx0).
        case/assoc.get_sing_inv => ? ?; subst x0 mx0.
        have Htmp : (strictly_exact (var_e%asm_expr rx |--> lx :: px ::nil ** int_e px |--> X_))%asm_assert.
          apply strictly_exact_con; by apply strictly_exact_mapstos.
        apply: Htmp (conj mem_x _).
        suff : (var_e%asm_expr rx |--> lx :: px :: nil ** int_e px |--> X_)%asm_assert st'
          (heap_mint (signed k rx) st' h').
          apply monotony => ?; by apply mapstos_ext.
        apply con_heap_mint_signed_cons with h121 => //.
        rewrite h1Uh2 h11Uh12 h121Uh122.
        apply heap.inclu_union_L.
        by map_tac_m.Disj.
        apply heap.inclu_union_R.
        by map_tac_m.Disj.
        apply heap.inclu_union_L.
        assumption.
        by apply heap.inclu_refl.
        by rewrite -rx_st_st'.
        by rewrite X_k.
      case/assoc.get_union_Some_inv.
        case/assoc.get_sing_inv => ? ?; subst x0 mx0.
        have Htmp : (strictly_exact (var_e%asm_expr ry |--> Z2ints 32 k ([y ]_ s)%pseudo_expr))%asm_assert.
          by apply strictly_exact_mapstos.
        rewrite -Hk in mem_y.
        apply: Htmp (conj mem_y _).
        suff : (var_e%asm_expr ry |--> Z2ints 32 k ([y ]_ s)%pseudo_expr)%asm_assert st'
          (heap_mint (unsign rk ry) st' h').
          by apply mapstos_ext.

        apply con_heap_mint_unsign_cons with h122 => //.
        rewrite h1Uh2 h11Uh12 h121Uh122.
        apply heap.inclu_union_L.
        by map_tac_m.Disj.
        apply heap.inclu_union_R.
        by map_tac_m.Disj.
        apply heap.inclu_union_R.
        assumption.
        by apply heap.inclu_refl.
        rewrite size_Z2ints.
        by rewrite ry_st'_st.
        rewrite size_Z2ints.
        by rewrite -rk_st_st'.
      move=> x0_d_mx0.

      apply (heap_mint_state_invariant (heap_mint (signed k rz) st h \U
        heap_mint (signed k rx) st h \U heap_mint (unsign rk ry) st h) x0 s) => //.
      + move=> x1 Hx1.
        mips_syntax.Reg_unchanged.
        apply (@disj_not_In _ (mint_regs mx0)); last by [].
        exact/disj_sym/(Hd_unchanged x0).
      + apply (proj1 s_st_h).
        rewrite assoc.get_union_sing_neq //; by auto.
      + move: (mips_syntax.exec_deter_proj _ _ _ _ _ exec_asm _ _ _ exec_asm_proj).
        tauto.
      + apply heap.disjhU.
        * apply heap.disjhU.
          - apply (proj2 s_st_h x0 z) => //.
            rewrite assoc.get_union_sing_neq //; by auto.
            by assoc_get_Some.
          - case/orP : (orbN (x0 == x)).
            + move/eqP => ?; subst x0.
              apply assoc.get_Some_in_dom in x0_d_mx0.
              by rewrite x0_d_mx0 in x_d.
            + move=> x0x.
              apply (proj2 s_st_h x0 x) => //.
              by apply/eqP.
              rewrite assoc.get_union_sing_neq //; by auto.
              by assoc_get_Some.
        * case/orP : (orbN (x0 == y)).
          - move/eqP => ?; subst x0.
            apply assoc.get_Some_in_dom in x0_d_mx0.
            by rewrite x0_d_mx0 in y_d.
          - move=> x0y.
            apply (proj2 s_st_h x0 y) => //.
            by apply/eqP.
            rewrite assoc.get_union_sing_neq //; by auto.
            by assoc_get_Some.
- case: hoare_triple_post_cond => h1 [h2 [h1dh2 [h1Uh2 [Hh1 _]]]].
  case: Hh1 => Z' [lz' [Z'_k [ry_st'_st [lz'_k [sgn_lz' [Hh1 [Ha3 HSum]]]]]]].
  case: Hh1 => h11 [h12 [h11dh12 [h11Uh12 [Hh11 Hh12]]]].
  case: Hh12 => h121 [h122 [h121dh122 [h121Uh122 [Hh121 Hh122]]]].
  apply state_mint_part2_three_variables with s st h => //.
  + symmetry.
    apply dom_heap_mint_sign_state_invariant with z s lz lz' => //.
    move/mapstos_get1 : mem_z.
    by apply heap_get_heap_mint_inv.
    move/mapstos_get1 in Hh11.
    rewrite h1Uh2 h11Uh12.
    apply heap.get_union_L.
    by map_tac_m.Disj.
    by apply heap.get_union_L.
    move/mapstos_get2 : mem_z.
    move/heap_get_heap_mint_inv => ->.
    symmetry.
    move/mapstos_get2 in Hh11.
    rewrite h1Uh2 h11Uh12.
    apply heap.get_union_L.
    by map_tac_m.Disj.
    by apply heap.get_union_L.
    apply (proj1 s_st_h z) => //.
    by assoc_get_Some.
    by apply (mips_syntax.dom_heap_invariant _ _ _ _ _ exec_asm).
  + symmetry.
    apply dom_heap_mint_sign_state_invariant with x s lx lx => //.
    move/mapstos_get1 : mem_x.
    by apply heap_get_heap_mint_inv.
    move/mapstos_get1 in Hh121.
    rewrite h1Uh2 h11Uh12 h121Uh122.
    apply heap.get_union_L.
    by map_tac_m.Disj.
    apply heap.get_union_R.
    by map_tac_m.Disj.
    by apply heap.get_union_L.
    move/mapstos_get2 : mem_x.
    move/heap_get_heap_mint_inv => ->.
    symmetry.
    move/mapstos_get2 in Hh121.
    rewrite h1Uh2 h11Uh12 h121Uh122.
    apply heap.get_union_L.
    by map_tac_m.Disj.
    apply heap.get_union_R.
    by map_tac_m.Disj.
    by apply heap.get_union_L.
    apply (proj1 s_st_h x) => //.
    by assoc_get_Some.
    by apply (mips_syntax.dom_heap_invariant _ _ _ _ _ exec_asm).
  + symmetry.
    apply dom_heap_mint_unsign_state_invariant with y s => //.
    apply (proj1 s_st_h y) => //.
    by assoc_get_Some.
    by apply (mips_syntax.dom_heap_invariant _ _ _ _ _ exec_asm).
  + move=> t Ht x0 Hx0.
    mips_syntax.Reg_unchanged. simpl mips_frame.modified_regs.
    case/assoc.in_cdom_union_inv : Ht.
    * rewrite assoc.cdom_sing seq.mem_seq1.
      move/eqP=> ?; subst t.
      apply (@disj_not_In _ (mint_regs (signed k rz))); last by [].
      Disj_remove_dup.
      rewrite /=.
      apply uniq_disj. rewrite [cat _ _]/=. by Uniq_uniq r0.
    * case/assoc.in_cdom_union_inv.
      - rewrite assoc.cdom_sing seq.mem_seq1.
        move/eqP=> ?; subst t.
        apply (@disj_not_In _ (mint_regs (signed k rx))); last by [].
        Disj_remove_dup.
        rewrite /=.
        apply uniq_disj. rewrite [cat _ _]/=. by Uniq_uniq r0.
      - case/assoc.in_cdom_union_inv.
        * rewrite assoc.cdom_sing seq.mem_seq1.
          move/eqP=> ?; subst t.
          apply (@disj_not_In _ (mint_regs (unsign rk ry))); last by [].
          Disj_remove_dup.
          rewrite /=.
          apply uniq_disj. rewrite [cat _ _]/=. by Uniq_uniq r0.
        * move=> Ht; apply (@disj_not_In _ (mint_regs t)); last by [].
          Disj_remove_dup.
          apply disj_sym.
          apply (disj_incl_LR Disj); last by apply incl_refl_Permutation; PermutProve.
          exact/incP/inc_mint_regs.
- move: (mips_syntax.exec_deter_proj _ _ _ _ _ exec_asm _ _ _ exec_asm_proj); tauto.
Qed.


(* Non-determinism *)

From Coq Require Import Utf8 RelationClasses List.
From PDM Require Import util structures guarded PURE GuardedPDM.

Import ListNotations.

Set Default Goal Selector "!".
Set Printing Projections.
Set Universe Polymorphism.
Unset Universe Minimization ToSet.

(* Computation monad *)

Definition M A :=
  list A.

#[export] Instance Monad_M : Monad M := {|
  ret A x := [ x ] ;
  bind A B c f := concat (map f c)
|}.

(* Effect observation *)

Definition θ : observation M pure_wp.
Proof.
  intros A c.
  exists (λ post, ∀ x, In x c → post x).
  intros P Q hPQ h. intros x hx.
  apply hPQ. apply h. apply hx.
Defined.

(* LeafPred *)

#[local] Instance leafpred : LeafPred M :=
  λ A x c, In x c.

Fixpoint leafine [A] (c : M A) : M { x : A | x ∈ c }.
Proof.
  destruct c as [| x c].
  - exact [].
  - refine (⟨ x ⟩ :: map (λ x, ⟨ val x ⟩) (leafine _ c)).
    + left. reflexivity.
    + destruct x. right. assumption.
Defined.

#[local] Instance hleaf : Leafine M leafpred :=
  leafine.

(* Partial DM *)

Definition D A (w : pure_wp A) : Type :=
  GuardedPDM.D (M := M) (θ := θ) (λ A w, w) A w.

Definition liftᵂ : spec_lift_pure pure_wp :=
  λ A w, w.

#[local] Instance LaxMorphism_θᴳ :
  @LaxMorphism _ _ (Monad_Mᴳ _ _) _ _ (θᴳ (θ := θ) liftᵂ).
Proof.
  constructor.
  - intros A x. intros post h.
    cbv - [In] in *.
    exists I. intros y hy. destruct hy. 2: contradiction.
    subst. apply h.
  - intros A B c f. intros post h.
    destruct c as [p c].
    hnf. hnf in h.
    destruct h as [hp h]. simpl in hp, h.
    unshelve eexists.
    + simpl. exists hp.
      intros x hx. apply h. apply hx.
    + hnf. simpl. intros y hy.
      apply in_concat in hy. destruct hy as [l [hl hy]].
      apply in_map_iff in hl. destruct hl as [x [e hxc]].
      destruct x as [x hx].
      set (h' := h x hx) in *. clearbody h'. clear h.
      destruct h' as [hf h]. subst l.
      apply h. assumption.
Qed.

#[export] Instance DijkstraMonad_D : DijkstraMonad D :=
  GuardedPDM.DijkstraMonad_D _ _ _ _ _.

(* Lift from PURE *)

#[local] Instance ReqLaxMorphism_θᴳ :
  @ReqLaxMorphism _ _ _ (ReqMonad_Mᴳ _ _) _ _ pure_wp_ord (θᴳ (θ := θ) liftᵂ) LaxMorphism_θᴳ.
Proof.
  constructor.
  intro p. intros post h.
  cbv - [In]. cbv - [In] in h. destruct h as [hp h].
  unshelve eexists.
  { exists hp. auto. }
  simpl. intros ? [? | bot]. 2: contradiction.
  subst. assumption.
Qed.

Definition liftᴾ [A w] (f : PURE A w) : D A w :=
  liftᴾ MonoSpec_pure leafpred hleaf (λ A w, w) _ _ _ A w f.