Danila Fedorin
86bc33ee26
Tag the finite lattice carrier types with `@[aesop safe cases]` (`AboveBelow`, `Sign`) so aesop performs the dominant proof step in this framework -- case-splitting a lattice element -- automatically. Combined with the existing `@[simp]` operation lemmas, this collapses the recurring "case-split then reduce" proofs to a bare `aesop`: * AboveBelow's six lattice axioms drop their explicit `rcases` * Sign/Constant `plus_mono₂`/`minus_mono₂` become `by aesop` * Constant `plus_valid`/`minus_valid` shrink to a 2-line `rcases <;> simp_all` * `not_mk_lt_mk` is reexpressed via `le_cases` Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
143 lines
4.6 KiB
Lean4
143 lines
4.6 KiB
Lean4
import Spa.Analysis.Forward
|
||
import Spa.Analysis.Utils
|
||
import Spa.Interp
|
||
import Spa.Showable
|
||
|
||
namespace Spa
|
||
|
||
open Forward
|
||
|
||
abbrev ConstLattice : Type := AboveBelow ℤ
|
||
|
||
namespace ConstAnalysis
|
||
|
||
open AboveBelow in
|
||
def plus : ConstLattice → ConstLattice → ConstLattice
|
||
| bot, _ => bot
|
||
| _, bot => bot
|
||
| top, _ => top
|
||
| _, top => top
|
||
| mk z₁, mk z₂ => mk (z₁ + z₂)
|
||
|
||
open AboveBelow in
|
||
def minus : ConstLattice → ConstLattice → ConstLattice
|
||
| bot, _ => bot
|
||
| _, bot => bot
|
||
| top, _ => top
|
||
| _, top => top
|
||
| mk z₁, mk z₂ => mk (z₁ - z₂)
|
||
|
||
lemma plus_mono₂ : Monotone₂ plus :=
|
||
AboveBelow.monotone₂_of_strict plus
|
||
(fun y => by aesop) (fun x => by aesop)
|
||
(fun y hy => by aesop) (fun x hx => by aesop)
|
||
|
||
lemma minus_mono₂ : Monotone₂ minus :=
|
||
AboveBelow.monotone₂_of_strict minus
|
||
(fun y => by aesop) (fun x => by aesop)
|
||
(fun y hy => by aesop) (fun x hx => by aesop)
|
||
|
||
def interpConst : ConstLattice → Value → Prop
|
||
| .bot, _ => False
|
||
| .top, _ => True
|
||
| .mk z, v => v = .int z
|
||
|
||
lemma interpConst_mk_disjoint {z₁ z₂ : ℤ} (hne : z₁ ≠ z₂) {v : Value} :
|
||
¬(interpConst (.mk z₁) v ∧ interpConst (.mk z₂) v) := by
|
||
rintro ⟨h₁, h₂⟩
|
||
rw [h₁] at h₂
|
||
injection h₂ with hz
|
||
exact hne hz
|
||
|
||
instance constInterpretation : LatticeInterpretation ConstLattice where
|
||
interp := interpConst
|
||
interp_sup := fun v h => AboveBelow.interp_sup_of (fun _ h => h) (fun _ => trivial) v h
|
||
interp_inf := fun v h => AboveBelow.interp_inf_of (fun hne _ => interpConst_mk_disjoint hne) v h
|
||
|
||
variable (prog : Program)
|
||
|
||
def eval : Expr → VariableValues ConstLattice prog → ConstLattice
|
||
| .add e₁ e₂, vs => plus (eval e₁ vs) (eval e₂ vs)
|
||
| .sub e₁ e₂, vs => minus (eval e₁ vs) (eval e₂ vs)
|
||
| .var k, vs =>
|
||
if h : FiniteMap.MemKey k vs then (FiniteMap.locate h).1 else .top
|
||
| .num n, _ => .mk n
|
||
|
||
lemma eval_mono (e : Expr) : Monotone (eval prog e) := by
|
||
induction e with
|
||
| add e₁ e₂ ih₁ ih₂ =>
|
||
intro vs₁ vs₂ h
|
||
exact eval_combine₂ plus_mono₂ (ih₁ h) (ih₂ h)
|
||
| sub e₁ e₂ ih₁ ih₂ =>
|
||
intro vs₁ vs₂ h
|
||
exact eval_combine₂ minus_mono₂ (ih₁ h) (ih₂ h)
|
||
| var k =>
|
||
intro vs₁ vs₂ h
|
||
simp only [eval]
|
||
by_cases hk : k ∈ prog.vars
|
||
· rw [dif_pos (FiniteMap.MemKey_iff.mpr hk),
|
||
dif_pos (FiniteMap.MemKey_iff.mpr hk)]
|
||
exact FiniteMap.le_of_mem_mem prog.vars_nodup h
|
||
(FiniteMap.locate _).2 (FiniteMap.locate _).2
|
||
· rw [dif_neg (fun hm => hk (FiniteMap.MemKey_iff.mp hm)),
|
||
dif_neg (fun hm => hk (FiniteMap.MemKey_iff.mp hm))]
|
||
| num n =>
|
||
intro vs₁ vs₂ _
|
||
exact le_refl _
|
||
|
||
instance exprEvaluator : ExprEvaluator ConstLattice prog :=
|
||
⟨eval prog, eval_mono prog⟩
|
||
|
||
def output : String :=
|
||
show' (result ConstLattice prog)
|
||
|
||
lemma plus_valid {g₁ g₂ : ConstLattice} {z₁ z₂ : ℤ}
|
||
(h₁ : ⟦g₁⟧ (.int z₁)) (h₂ : ⟦g₂⟧ (.int z₂)) :
|
||
⟦plus g₁ g₂⟧ (.int (z₁ + z₂)) := by
|
||
rcases g₁ with _ | _ | c₁ <;> rcases g₂ with _ | _ | c₂ <;>
|
||
simp_all [plus, constInterpretation, interpConst]
|
||
|
||
lemma minus_valid {g₁ g₂ : ConstLattice} {z₁ z₂ : ℤ}
|
||
(h₁ : ⟦g₁⟧ (.int z₁)) (h₂ : ⟦g₂⟧ (.int z₂)) :
|
||
⟦minus g₁ g₂⟧ (.int (z₁ - z₂)) := by
|
||
rcases g₁ with _ | _ | c₁ <;> rcases g₂ with _ | _ | c₂ <;>
|
||
simp_all [minus, constInterpretation, interpConst]
|
||
|
||
instance eval_valid : ValidExprEvaluator ConstLattice prog := by
|
||
constructor
|
||
intro vs ρ e v hev
|
||
induction hev with
|
||
| num n =>
|
||
intro _
|
||
show ⟦eval prog (.num n) vs⟧ (.int n)
|
||
rfl
|
||
| var x v hxv =>
|
||
intro hvs
|
||
show ⟦eval prog (.var x) vs⟧ v
|
||
simp only [eval]
|
||
by_cases hk : FiniteMap.MemKey x vs
|
||
· rw [dif_pos hk]
|
||
exact hvs _ _ (FiniteMap.locate hk).2 _ hxv
|
||
· rw [dif_neg hk]
|
||
exact trivial
|
||
| add e₁ e₂ z₁ z₂ _ _ ih₁ ih₂ =>
|
||
intro hvs
|
||
have h₁ : ⟦eval prog e₁ vs⟧ (.int z₁) := ih₁ hvs
|
||
have h₂ : ⟦eval prog e₂ vs⟧ (.int z₂) := ih₂ hvs
|
||
show ⟦eval prog (.add e₁ e₂) vs⟧ (.int (z₁ + z₂))
|
||
exact plus_valid h₁ h₂
|
||
| sub e₁ e₂ z₁ z₂ _ _ ih₁ ih₂ =>
|
||
intro hvs
|
||
have h₁ : ⟦eval prog e₁ vs⟧ (.int z₁) := ih₁ hvs
|
||
have h₂ : ⟦eval prog e₂ vs⟧ (.int z₂) := ih₂ hvs
|
||
show ⟦eval prog (.sub e₁ e₂) vs⟧ (.int (z₁ - z₂))
|
||
exact minus_valid h₁ h₂
|
||
|
||
theorem analyze_correct {ρ : Env} (hrun : EvalStmt [] prog.rootStmt ρ) :
|
||
⟦ variablesAt prog.finalState (result ConstLattice prog) ⟧ ρ () :=
|
||
Forward.analyze_correct ConstLattice prog hrun
|
||
|
||
end ConstAnalysis
|
||
|
||
end Spa
|