Add specs: loop, Array.eq

lean/CoreModels.lean

@@ -3,3 +3,4 @@ import CoreModels.Core
 import CoreModels.Alloc
 import CoreModels.HaxLib
 import CoreModels.RustPrimitives
+import CoreModels.Spec

lean/CoreModels/Spec.lean

@@ -0,0 +1,2 @@
+import CoreModels.Spec.Aeneas
+import CoreModels.Spec.Array

lean/CoreModels/Spec/Aeneas.lean

@@ -0,0 +1,107 @@
+import CoreModels.Core.Funs
+
+namespace Aeneas.Std
+open Std.Do WP Std.Do Result
+
+set_option mvcgen.warning false
+
+@[spec]
+theorem Result.ok_spec {α : Type} {a : α} {Q} (hQ : (Q.1 a).down) :
+  ⦃ ⌜ True ⌝ ⦄ Result.ok a ⦃ Q ⦄ := by simpa [Triple]
+
+@[spec]
+theorem Result.fail_spec {α : Type} {e : Error} {Q} (hQ : (Q.2.1 e).down) :
+  ⦃ ⌜ True ⌝ ⦄ (Result.fail e : Result α) ⦃ Q ⦄ := by simpa [Triple]
+
+attribute [spec] Function.uncurry lift
+
+@[spec]
+theorem loop_spec
+  {α β γ : Type}
+  {P : PostCond β (PostShape.except Error (PostShape.except PUnit.{1} PostShape.pure))}
+  (body : α → Result (ControlFlow α β)) (init : α)
+  (inv : α → Prop)
+  (rel : γ → γ → Prop)
+  (termination : α → γ)
+  (hwf : WellFounded rel)
+  (h_inv_init : inv init)
+  (h_body : ∀ x, inv x → ⦃ ⌜ True ⌝ ⦄ body x ⦃ post⟨
+    fun cf => match cf with
+      | .cont r => ⌜ inv r ∧ (rel (termination r) (termination x) ∨ (P.2.2.1 ()).down) ⌝
+      | .done r => P.1 r,
+    P.2.1, P.2.2.1⟩ ⦄) :
+  ⦃ ⌜ True ⌝ ⦄ loop body init ⦃ P ⦄ := by
+  suffices h : ∀ x, inv x → (wp⟦loop body x⟧ P).down by
+    unfold Triple
+    intro _
+    exact h init h_inv_init
+  by_cases hdiv : (P.2.2.1 ()).down
+  · -- Divergence permitted: use partial-fixpoint induction.
+    intro x hinv
+    delta loop
+    refine Lean.Order.fix_induct (loop._proof_1 body)
+      (motive := fun g => ∀ x, inv x → (wp⟦g x⟧ P).down) ?_ ?_ x hinv
+    · apply Lean.Order.admissible_pi
+      intro y
+      apply Lean.Order.admissible_pi
+      intro _
+      apply Lean.Order.admissible_apply (β := fun _ => Result β)
+        (P := fun y r => (wp⟦r⟧ P).down) y
+      exact Lean.Order.admissible_flatOrder _ hdiv
+    · intro g IH y hinvy
+      have hb : (wp⟦body y⟧ _).down := h_body y hinvy trivial
+      cases hbe : body y with
+      | ok cf =>
+        rw [hbe] at hb
+        cases cf with
+        | cont r => exact IH r hb.1
+        | done r => exact hb
+      | fail e => rw [hbe] at hb; exact hb
+      | div => rw [hbe] at hb; exact hb
+  · -- Termination via WF induction on `rel`.
+    intro x hinv
+    induction hg : termination x using hwf.induction generalizing x
+    rename_i g IH
+    have hb : (wp⟦body x⟧ _).down := h_body x hinv trivial
+    rw [loop.eq_1]
+    cases hbe : body x with
+    | ok cf =>
+      rw [hbe] at hb
+      cases cf with
+      | cont r =>
+        obtain ⟨hinvr, hrel | hd⟩ := hb
+        · subst hg
+          exact IH (termination r) hrel r hinvr rfl
+        · exact absurd hd hdiv
+      | done r => exact hb
+    | fail e => rw [hbe] at hb; exact hb
+    | div => rw [hbe] at hb; exact hb
+
+open ScalarElab
+
+iscalar_no_isize @[spec] theorem  «%S».hShiftRight_I8_spec (a : «%S») (b : I8) (hmin : b.val ≥ 0) (hmax : b.val < %Size) :
+    ⦃ ⌜ True ⌝ ⦄ (a >>> b) ⦃ ⇓ r => ⌜ r.val = a.val / (2 ^ b.val.toNat) ⌝ ⦄ := by
+  mvcgen [HShiftRight.hShiftRight, IScalar.shiftRight_IScalar, IScalar.shiftRight]
+    <;> grind [IScalar.val, Int.shiftRight_eq_div_pow]
+
+iscalar_no_isize @[spec] theorem  «%S».hShiftRight_I16_spec (a : «%S») (b : I16) (hmin : b.val ≥ 0) (hmax : b.val < %Size) :
+    ⦃ ⌜ True ⌝ ⦄ (a >>> b) ⦃ ⇓ r => ⌜ r.val = a.val / (2 ^ b.val.toNat) ⌝ ⦄ := by
+  mvcgen [HShiftRight.hShiftRight, IScalar.shiftRight_IScalar, IScalar.shiftRight]
+    <;> grind [IScalar.val, Int.shiftRight_eq_div_pow]
+
+iscalar_no_isize @[spec] theorem  «%S».hShiftRight_I32_spec (a : «%S») (b : I32) (hmin : b.val ≥ 0) (hmax : b.val < %Size) :
+    ⦃ ⌜ True ⌝ ⦄ (a >>> b) ⦃ ⇓ r => ⌜ r.val = a.val / (2 ^ b.val.toNat) ⌝ ⦄ := by
+  mvcgen [HShiftRight.hShiftRight, IScalar.shiftRight_IScalar, IScalar.shiftRight]
+    <;> grind [IScalar.val, Int.shiftRight_eq_div_pow]
+
+iscalar_no_isize @[spec] theorem  «%S».hShiftRight_I64_spec (a : «%S») (b : I64) (hmin : b.val ≥ 0) (hmax : b.val < %Size) :
+    ⦃ ⌜ True ⌝ ⦄ (a >>> b) ⦃ ⇓ r => ⌜ r.val = a.val / (2 ^ b.val.toNat) ⌝ ⦄ := by
+  mvcgen [HShiftRight.hShiftRight, IScalar.shiftRight_IScalar, IScalar.shiftRight]
+    <;> grind [IScalar.val, Int.shiftRight_eq_div_pow]
+
+iscalar_no_isize @[spec] theorem  «%S».hShiftRight_I128_spec (a : «%S») (b : I128) (hmin : b.val ≥ 0) (hmax : b.val < %Size) :
+    ⦃ ⌜ True ⌝ ⦄ (a >>> b) ⦃ ⇓ r => ⌜ r.val = a.val / (2 ^ b.val.toNat) ⌝ ⦄ := by
+  mvcgen [HShiftRight.hShiftRight, IScalar.shiftRight_IScalar, IScalar.shiftRight]
+    <;> grind [IScalar.val, Int.shiftRight_eq_div_pow]
+
+end Aeneas.Std

lean/CoreModels/Spec/Array.lean

@@ -0,0 +1,144 @@
+import CoreModels.Core.Funs
+import CoreModels.Spec.Aeneas
+
+
+namespace CoreModels
+
+open Aeneas
+open Aeneas.Std hiding namespace core alloc
+open Std.Do WP Std.Do Result
+set_option mvcgen.warning false
+
+open ScalarElab
+
+uscalar @[spec] theorem «%S».Core_modelsCmpPartialEqArray.eq_spec {N : Std.Usize} {Q}
+  (a : Array «%S» N) (b : Array «%S» N) (h : (Q.1 (a.val == b.val)).down) :
+  ⦃ ⌜ True ⌝ ⦄
+  core.Array.Insts.CoreCmpPartialEqArray.eq core.«%S».Insts.CoreCmpPartialEq'S a b
+  ⦃ Q ⦄ := by
+  mvcgen -trivial [core.Array.Insts.CoreCmpPartialEqArray.eq,
+    core.Array.Insts.CoreCmpPartialEqArray.eq_loop,
+    core.Array.Insts.CoreCmpPartialEqArray.eq_loop.body, rust_primitives.slice.array_index,
+    core.«%S».Insts.CoreCmpPartialEq'S]
+  case vc1.γ => exact Nat
+  case vc4.termination => exact fun i => N.val - i.val
+  case vc3.rel => exact (· < ·)
+  case vc5.hwf => exact wellFounded_lt
+  case vc2.inv => exact fun i => a.val.take i.val = b.val.take i.val
+  case vc10 =>
+    constructor
+    · simp_all [@List.take_add, @List.take_one, -List.take_append_getElem]
+    · grind
+  · grind
+  · grind
+  · grind
+  · grind
+  · convert h; grind
+  · convert h; grind [List.take_eq_self_iff, List.Vector.length_val]
+
+@[spec]
+theorem core_models_Array_Insts_index_RangeUsize_spec
+      {T : Type} {N : Std.Usize} (arr : Std.Array T N)
+      (r : core.ops.range.Range Std.Usize)
+      (h0 : r.start.val < r.end.val) -- TODO: We should be able to allow "≤" here
+      (h1 : r.end.val ≤ N.val) :
+    ⦃ ⌜ True ⌝ ⦄
+    core.Array.Insts.CoreOpsIndexIndexRangeUsizeSlice.index arr r
+    ⦃ ⇓ r' => ⌜ r'.val = arr.val.slice r.start.val r.end.val ∧
+                r'.val.length + r.start.val = r.end.val ⌝ ⦄ := by
+  mvcgen [core.Array.Insts.CoreOpsIndexIndexRangeUsizeSlice.index,
+    rust_primitives.slice.array_slice, -Array.subslice_spec.mvcgen_spec, Array.subslice]
+    <;> grind
+
+
+/-! ## A generic `from_fn` pure-closure spec.
+
+Analogous to `createi_pure_spec` (HacspecBridge.lean:663) but takes
+a `FnMut` instance directly (no `Fn` wrapper). Required because
+`sponge.xor_block_into_state` calls `CoreModels.core.array.from_fn` directly
+with the `FnMut` instance of its closure. -/
+
+private theorem from_fn_foldlM_pure_aux
+    {T F : Type}
+    (inst : CoreModels.core.ops.function.FnMut F Std.Usize T) (c : F) (f : Nat → T)
+    (l : List Nat) (acc : List T)
+    (hpure : ∀ k ∈ l,
+      inst.call_mut c ⟨BitVec.ofNat _ k⟩ = .ok (f k, c)) :
+    l.foldlM
+      (fun (s : List T × F) (i : Nat) => do
+        let (v, f') ← inst.call_mut s.2 ⟨BitVec.ofNat _ i⟩
+        Result.ok (s.1 ++ [v], f'))
+      (acc, c) = .ok (acc ++ l.map f, c) := by
+  induction l generalizing acc with
+  | nil =>
+      simp only [List.foldlM_nil, List.map_nil, List.append_nil]; rfl
+  | cons h t ih =>
+      have hh : inst.call_mut c ⟨BitVec.ofNat _ h⟩ = .ok (f h, c) :=
+        hpure h List.mem_cons_self
+      have ht : ∀ k ∈ t, inst.call_mut c ⟨BitVec.ofNat _ k⟩ = .ok (f k, c) :=
+        fun k hk => hpure k (List.mem_cons_of_mem _ hk)
+      have hih := ih (acc ++ [f h]) ht
+      simp only [List.foldlM_cons, hh, bind_tc_ok, List.map_cons]
+      rw [hih]
+      simp [List.append_assoc]
+
+/-- Lean-level equation for `from_fn` over pure closures. -/
+private theorem from_fn_pure_eq
+    {T F : Type} (N : Std.Usize)
+    (inst : CoreModels.core.ops.function.FnMut F Std.Usize T) (c : F) (f : Nat → T)
+    (hpure : ∀ k : Nat, k < N.val →
+      inst.call_mut c ⟨BitVec.ofNat _ k⟩ = .ok (f k, c)) :
+    CoreModels.core.array.from_fn N inst c =
+      .ok ⟨(List.range N.val).map f,
+           by simp [List.length_map, List.length_range]⟩ := by
+  have hf : ∀ k ∈ List.range N.val,
+      inst.call_mut c ⟨BitVec.ofNat _ k⟩ = .ok (f k, c) := by
+    intro k hk; exact hpure k (List.mem_range.mp hk)
+  have h_fold :=
+    from_fn_foldlM_pure_aux inst c f (List.range N.val) [] hf
+  simp only [List.nil_append] at h_fold
+  unfold CoreModels.core.array.from_fn CoreModels.rust_primitives.slice.array_from_fn
+  split
+  · rename_i e heq
+    rw [h_fold] at heq; exact absurd heq (by simp)
+  · rename_i heq
+    rw [h_fold] at heq; exact absurd heq (by simp)
+  · rename_i result heq
+    rw [h_fold] at heq
+    have hres : result = ((List.range N.val).map f, c) :=
+      (Result.ok.inj heq).symm
+    subst hres
+    rfl
+
+
+/-- **Generic pure-closure `[spec]` for `core_models.array.from_fn`.**
+
+For any closure whose `call_mut` is pure (doesn't mutate state),
+`from_fn N inst c` succeeds and its `i`-th cell is `f i`. `hpure` is a
+Triple over each `call_mut` so `hax_mvcgen` can recurse through it via
+per-closure `@[spec]` lemmas. -/
+@[spec]
+theorem from_fn_pure_spec
+    {T F : Type} [Inhabited T] (N : Std.Usize)
+    (inst : core.ops.function.FnMut F Std.Usize T) (c : F) (f : Nat → T)
+    (hpure : ∀ k : Nat, k < N.val →
+      ⦃ ⌜ True ⌝ ⦄
+      inst.call_mut c ⟨BitVec.ofNat _ k⟩
+      ⦃ ⇓ r => ⌜ r = (f k, c) ⌝ ⦄) :
+    ⦃ ⌜ True ⌝ ⦄
+    core.array.from_fn N inst c
+    ⦃ ⇓ a => ⌜ ∀ i : Nat, i < N.val → a.val[i]! = f i ⌝ ⦄ := by
+  have hpure_eq : ∀ k : Nat, k < N.val →
+      inst.call_mut c ⟨BitVec.ofNat _ k⟩ = .ok (f k, c) :=
+    sorry -- fun k hk => result_eq_of_triple (hpure k hk)
+  have heq := from_fn_pure_eq N inst c f hpure_eq
+  rw [heq]
+  simp only [Triple, WP.wp]
+  apply SPred.pure_intro
+  intro i hi
+  show ((List.range N.val).map f)[i]! = f i
+  rw [List.getElem!_eq_getElem?_getD, List.getElem?_map,
+      List.getElem?_range hi]
+  rfl
+
+end CoreModels

lean/CoreModels/Spec/Iterator.lean

@@ -0,0 +1,29 @@
+import CoreModels.Core.Funs
+import CoreModels.Alloc.Funs
+import CoreModels.Spec.Aeneas
+
+namespace CoreModels
+
+open Aeneas
+open Aeneas.Std hiding namespace core alloc
+open Std.Do WP Std.Do Result
+
+set_option mvcgen.warning false
+
+@[spec]
+theorem IteratorRange_next_CoreIterRangeStep_spec (i e : Usize) {Q}
+      (h_lt : (h : i.val < e.val) →
+        ∀ (s : Usize), s.val = i.val + 1 → (Q.1 (some i, { start := s, «end» := e })).down)
+      (h_ge : i.val ≥ e.val → (Q.1 (none, { start := i, «end» := e })).down) :
+    ⦃ ⌜ True ⌝ ⦄
+    core.IteratorRange.next core.Usize.Insts.CoreIterRangeStep
+      { start := i, «end» := e }
+    ⦃ Q ⦄ := by
+  unfold core.IteratorRange.next core.Usize.Insts.CoreIterRangeStep
+  simp only [core.Usize.Insts.CoreCmpPartialOrdUsize, core.mkUPartialOrd,
+    core.Usize.Insts.CoreCloneClone.clone, core.Usize.Insts.CoreIterRangeStep.forward_checked,
+    core.convert.TryFromUTInfallible.Blanket.try_from, core.convert.From.Blanket.from,
+    core.num.Usize.checked_add, core.num.Usize.overflowing_add,
+    rust_primitives.arithmetic.overflowing_add_usize]
+  mvcgen [uncurry]
+    <;> grind [UScalar.overflowing_add, BitVec.uaddOverflow, UScalar.overflowing_add_eq]