241 lines
8.1 KiB
Lean4
241 lines
8.1 KiB
Lean4
import Spa.Analysis.Forward
|
||
import Spa.Analysis.Utils
|
||
import Spa.Interp
|
||
import Spa.Showable
|
||
|
||
namespace Spa
|
||
|
||
inductive Sign where
|
||
| plus
|
||
| minus
|
||
| zero
|
||
deriving DecidableEq
|
||
|
||
instance : Showable Sign :=
|
||
⟨fun
|
||
| .plus => "+"
|
||
| .minus => "-"
|
||
| .zero => "0"⟩
|
||
|
||
instance : Inhabited Sign := ⟨.zero⟩
|
||
|
||
abbrev SignLattice : Type := AboveBelow Sign
|
||
|
||
open AboveBelow in
|
||
def plus : SignLattice → SignLattice → SignLattice
|
||
| bot, _ => bot
|
||
| _, bot => bot
|
||
| top, _ => top
|
||
| _, top => top
|
||
| mk .plus, mk .plus => mk .plus
|
||
| mk .plus, mk .minus => top
|
||
| mk .plus, mk .zero => mk .plus
|
||
| mk .minus, mk .plus => top
|
||
| mk .minus, mk .minus => mk .minus
|
||
| mk .minus, mk .zero => mk .minus
|
||
| mk .zero, mk .plus => mk .plus
|
||
| mk .zero, mk .minus => mk .minus
|
||
| mk .zero, mk .zero => mk .zero
|
||
|
||
open AboveBelow in
|
||
def minus : SignLattice → SignLattice → SignLattice
|
||
| bot, _ => bot
|
||
| _, bot => bot
|
||
| top, _ => top
|
||
| _, top => top
|
||
| mk .plus, mk .plus => top
|
||
| mk .plus, mk .minus => mk .plus
|
||
| mk .plus, mk .zero => mk .plus
|
||
| mk .minus, mk .plus => mk .minus
|
||
| mk .minus, mk .minus => top
|
||
| mk .minus, mk .zero => mk .minus
|
||
| mk .zero, mk .plus => mk .minus
|
||
| mk .zero, mk .minus => mk .plus
|
||
| mk .zero, mk .zero => mk .zero
|
||
|
||
theorem plus_mono₂ : Monotone₂ plus :=
|
||
AboveBelow.monotone₂_of_strict plus
|
||
(fun y => by cases y <;> rfl)
|
||
(fun x => by rcases x with _ | _ | s <;> first | rfl | (cases s <;> rfl))
|
||
(fun y hy => by cases y <;> first | exact absurd rfl hy | rfl)
|
||
(fun x hx => by
|
||
rcases x with _ | _ | s <;>
|
||
first | exact absurd rfl hx | rfl | (cases s <;> rfl))
|
||
|
||
theorem plus_mono_left (s₂ : SignLattice) : Monotone (plus · s₂) := plus_mono₂.1 s₂
|
||
|
||
theorem plus_mono_right (s₁ : SignLattice) : Monotone (plus s₁) := plus_mono₂.2 s₁
|
||
|
||
theorem minus_mono₂ : Monotone₂ minus :=
|
||
AboveBelow.monotone₂_of_strict minus
|
||
(fun y => by cases y <;> rfl)
|
||
(fun x => by rcases x with _ | _ | s <;> first | rfl | (cases s <;> rfl))
|
||
(fun y hy => by cases y <;> first | exact absurd rfl hy | rfl)
|
||
(fun x hx => by
|
||
rcases x with _ | _ | s <;>
|
||
first | exact absurd rfl hx | rfl | (cases s <;> rfl))
|
||
|
||
theorem minus_mono_left (s₂ : SignLattice) : Monotone (minus · s₂) := minus_mono₂.1 s₂
|
||
|
||
theorem minus_mono_right (s₁ : SignLattice) : Monotone (minus s₁) := minus_mono₂.2 s₁
|
||
|
||
def interpSign : SignLattice → Value → Prop
|
||
| .bot, _ => False
|
||
| .top, _ => True
|
||
| .mk .plus, v => ∃ n : ℕ, v = .int (n + 1)
|
||
| .mk .zero, v => v = .int 0
|
||
| .mk .minus, v => ∃ n : ℕ, v = .int (-(n + 1))
|
||
|
||
instance signInterp : Interp SignLattice (Value → Prop) := ⟨interpSign⟩
|
||
|
||
theorem interpSign_mk_disjoint {s₁ s₂ : Sign} (hne : s₁ ≠ s₂) {v : Value} :
|
||
¬(⟦(.mk s₁ : SignLattice)⟧ v ∧ ⟦(.mk s₂ : SignLattice)⟧ v) := by
|
||
rintro ⟨h₁, h₂⟩
|
||
rcases s₁ <;> rcases s₂ <;> try exact hne rfl
|
||
all_goals simp only [signInterp, interpSign] at h₁ h₂
|
||
· obtain ⟨n₁, rfl⟩ := h₁
|
||
obtain ⟨n₂, hv⟩ := h₂
|
||
injection hv with hz
|
||
omega
|
||
· obtain ⟨n₁, rfl⟩ := h₁
|
||
injection h₂ with hz
|
||
omega
|
||
· obtain ⟨n₁, rfl⟩ := h₁
|
||
obtain ⟨n₂, hv⟩ := h₂
|
||
injection hv with hz
|
||
omega
|
||
· obtain ⟨n₁, rfl⟩ := h₁
|
||
injection h₂ with hz
|
||
omega
|
||
· subst h₁
|
||
obtain ⟨n₂, hv⟩ := h₂
|
||
injection hv with hz
|
||
omega
|
||
· subst h₁
|
||
obtain ⟨n₂, hv⟩ := h₂
|
||
injection hv with hz
|
||
omega
|
||
|
||
theorem interpSign_sup {s₁ s₂ : SignLattice} (v : Value)
|
||
(h : ⟦s₁⟧ v ∨ ⟦s₂⟧ v) : ⟦s₁ ⊔ s₂⟧ v :=
|
||
AboveBelow.interp_sup_of (fun _ h => h) (fun _ => trivial) v h
|
||
|
||
theorem interpSign_inf {s₁ s₂ : SignLattice} (v : Value)
|
||
(h : ⟦s₁⟧ v ∧ ⟦s₂⟧ v) : ⟦s₁ ⊓ s₂⟧ v :=
|
||
AboveBelow.interp_inf_of (fun hne _ => interpSign_mk_disjoint hne) v h
|
||
|
||
instance signInterpretation : LatticeInterpretation SignLattice where
|
||
interp := interpSign
|
||
interp_sup := fun {l₁ l₂} v h => interpSign_sup (s₁ := l₁) (s₂ := l₂) v h
|
||
interp_inf := fun {l₁ l₂} v h => interpSign_inf (s₁ := l₁) (s₂ := l₂) v h
|
||
|
||
namespace SignAnalysis
|
||
|
||
variable (prog : Program)
|
||
|
||
def eval : Expr → VariableValues SignLattice prog → SignLattice
|
||
| .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 0, _ => .mk .zero
|
||
| .num (_ + 1), _ => .mk .plus
|
||
|
||
theorem 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₂ _
|
||
cases n <;> exact le_refl _
|
||
|
||
instance exprEvaluator : ExprEvaluator SignLattice prog :=
|
||
⟨eval prog, eval_mono prog⟩
|
||
|
||
def output : String :=
|
||
show' (result SignLattice prog)
|
||
|
||
/-- A nonneg-shifted interpretation `∃ n : ℕ, z = n + 1` just means `z` is positive. -/
|
||
private theorem int_pos_iff (z : ℤ) : (∃ n : ℕ, z = (n : ℤ) + 1) ↔ 0 < z := by
|
||
constructor
|
||
· rintro ⟨n, rfl⟩; omega
|
||
· intro h; exact ⟨(z - 1).toNat, by omega⟩
|
||
|
||
/-- Dually, `∃ n : ℕ, z = -(n + 1)` just means `z` is negative. -/
|
||
private theorem int_neg_iff (z : ℤ) : (∃ n : ℕ, z = -((n : ℤ) + 1)) ↔ z < 0 := by
|
||
constructor
|
||
· rintro ⟨n, rfl⟩; omega
|
||
· intro h; exact ⟨(-z - 1).toNat, by omega⟩
|
||
|
||
theorem plus_valid {g₁ g₂ : SignLattice} {z₁ z₂ : ℤ}
|
||
(h₁ : ⟦g₁⟧ (.int z₁)) (h₂ : ⟦g₂⟧ (.int z₂)) :
|
||
⟦plus g₁ g₂⟧ (.int (z₁ + z₂)) := by
|
||
rcases g₁ with _ | _ | s₁ <;> rcases g₂ with _ | _ | s₂ <;>
|
||
(try rcases s₁) <;> (try rcases s₂) <;>
|
||
simp only [plus, signInterp, interpSign, Value.int.injEq, int_pos_iff, int_neg_iff]
|
||
at h₁ h₂ ⊢ <;>
|
||
omega
|
||
|
||
theorem minus_valid {g₁ g₂ : SignLattice} {z₁ z₂ : ℤ}
|
||
(h₁ : ⟦g₁⟧ (.int z₁)) (h₂ : ⟦g₂⟧ (.int z₂)) :
|
||
⟦minus g₁ g₂⟧ (.int (z₁ - z₂)) := by
|
||
rcases g₁ with _ | _ | s₁ <;> rcases g₂ with _ | _ | s₂ <;>
|
||
(try rcases s₁) <;> (try rcases s₂) <;>
|
||
simp only [minus, signInterp, interpSign, Value.int.injEq, int_pos_iff, int_neg_iff]
|
||
at h₁ h₂ ⊢ <;>
|
||
omega
|
||
|
||
instance eval_valid : ValidExprEvaluator SignLattice prog := by
|
||
constructor
|
||
intro vs ρ e v hev
|
||
induction hev with
|
||
| num n =>
|
||
intro _
|
||
show ⟦eval prog (.num n) vs⟧ (.int n)
|
||
cases n with
|
||
| zero => rfl
|
||
| succ n' => exact ⟨n', congrArg Value.int (by norm_cast)⟩
|
||
| 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 ρ) :
|
||
interpV (variablesAt prog.finalState (result SignLattice prog)) ρ :=
|
||
Spa.analyze_correct SignLattice prog hrun
|
||
|
||
end SignAnalysis
|
||
|
||
end Spa
|