refactor: simp Step and Simproc types
Before this commit, `Simproc`s were defined as `Expr -> SimpM (Option Step)`, where `Step` is inductively defined as follows: ``` inductive Step where | visit : Result → Step | done : Result → Step ``` Here, `Result` is a structure containing the resulting expression and a proof demonstrating its equality to the input. Notably, the proof is optional; in its absence, `simp` assumes reflexivity. A simproc can: - Fail by returning `none`, indicating its inapplicability. In this case, the next suitable simproc is attempted, along with other simp extensions. - Succeed and invoke further simplifications using the `.visit` constructor. This action returns control to the beginning of the simplification loop. - Succeed and indicate that the result should not undergo further simplifications. However, I find the current approach unsatisfactory, as it does not align with the methodology employed in `Transform.lean`, where we have the type: ``` inductive TransformStep where /-- Return expression without visiting any subexpressions. -/ | done (e : Expr) /-- Visit expression (which should be different from current expression) instead. The new expression `e` is passed to `pre` again. -/ | visit (e : Expr) /-- Continue transformation with the given expression (defaults to current expression). For `pre`, this means visiting the children of the expression. For `post`, this is equivalent to returning `done`. -/ | continue (e? : Option Expr := none) ``` This type makes it clearer what is going on. The new `Simp.Step` type is similar but use `Result` instead of `Expr` because we need a proof.
This commit is contained in:
Leonardo de Moura
Scott Morrison
parent
03f344a35f
commit
b4a290a203
15 changed files with 312 additions and 287 deletions
|
|
@ -49,14 +49,12 @@ def simpMatchWF? (mvarId : MVarId) : MetaM (Option MVarId) :=
|
|||
if mvarId != mvarIdNew then return some mvarIdNew else return none
|
||||
where
|
||||
pre (e : Expr) : SimpM Simp.Step := do
|
||||
let some app ← matchMatcherApp? e | return Simp.Step.visit { expr := e }
|
||||
let some app ← matchMatcherApp? e
|
||||
| return Simp.Step.continue
|
||||
-- First try to reduce matcher
|
||||
match (← reduceRecMatcher? e) with
|
||||
| some e' => return Simp.Step.done { expr := e' }
|
||||
| none =>
|
||||
match (← Simp.simpMatchCore? app.matcherName e SplitIf.discharge?) with
|
||||
| some r => return r
|
||||
| none => return Simp.Step.visit { expr := e }
|
||||
| none => Simp.simpMatchCore app.matcherName SplitIf.discharge? e
|
||||
|
||||
/--
|
||||
Given a goal of the form `|- f.{us} a_1 ... a_n b_1 ... b_m = ...`, return `(us, #[a_1, ..., a_n])`
|
||||
|
|
|
|||
|
|
@ -82,7 +82,7 @@ end PatternMatchState
|
|||
|
||||
private def pre (pattern : AbstractMVarsResult) (state : IO.Ref PatternMatchState) (e : Expr) : SimpM Simp.Step := do
|
||||
if (← state.get).isDone then
|
||||
return Simp.Step.visit { expr := e }
|
||||
return Simp.Step.done { expr := e }
|
||||
else if let some (e, extraArgs) ← matchPattern? pattern e then
|
||||
if (← state.get).isReady then
|
||||
let (rhs, newGoal) ← mkConvGoalFor e
|
||||
|
|
@ -97,9 +97,9 @@ private def pre (pattern : AbstractMVarsResult) (state : IO.Ref PatternMatchStat
|
|||
-- it is possible for skipping an earlier match to affect what later matches
|
||||
-- refer to. For example, matching `f _` in `f (f a) = f b` with occs `[1, 2]`
|
||||
-- yields `[f (f a), f b]`, but `[2, 3]` yields `[f a, f b]`, and `[1, 3]` is an error.
|
||||
return Simp.Step.visit { expr := e }
|
||||
return Simp.Step.continue
|
||||
else
|
||||
return Simp.Step.visit { expr := e }
|
||||
return Simp.Step.continue
|
||||
|
||||
@[builtin_tactic Lean.Parser.Tactic.Conv.pattern] def evalPattern : Tactic := fun stx => withMainContext do
|
||||
match stx with
|
||||
|
|
|
|||
|
|
@ -123,6 +123,17 @@ def mkEqTrans (h₁ h₂ : Expr) : MetaM Expr := do
|
|||
| none, _ => throwAppBuilderException ``Eq.trans ("equality proof expected" ++ hasTypeMsg h₁ hType₁)
|
||||
| _, none => throwAppBuilderException ``Eq.trans ("equality proof expected" ++ hasTypeMsg h₂ hType₂)
|
||||
|
||||
/--
|
||||
Similar to `mkEqTrans`, but arguments can be `none`.
|
||||
`none` is treated as a reflexivity proof.
|
||||
-/
|
||||
def mkEqTrans? (h₁? h₂? : Option Expr) : MetaM (Option Expr) :=
|
||||
match h₁?, h₂? with
|
||||
| none, none => return none
|
||||
| none, some h => return h
|
||||
| some h, none => return h
|
||||
| some h₁, some h₂ => mkEqTrans h₁ h₂
|
||||
|
||||
/-- Given `h : HEq a b`, returns a proof of `HEq b a`. -/
|
||||
def mkHEqSymm (h : Expr) : MetaM Expr := do
|
||||
if h.isAppOf ``HEq.refl then
|
||||
|
|
|
|||
|
|
@ -7,8 +7,8 @@ import Lean.Meta.Tactic.Simp.Simproc
|
|||
|
||||
open Lean Meta Simp
|
||||
|
||||
builtin_simproc ↓ reduceIte (ite _ _ _) := fun e => OptionT.run do
|
||||
guard (e.isAppOfArity ``ite 5)
|
||||
builtin_simproc ↓ reduceIte (ite _ _ _) := fun e => do
|
||||
unless e.isAppOfArity ``ite 5 do return .continue
|
||||
let c := e.getArg! 1
|
||||
let r ← simp c
|
||||
if r.expr.isConstOf ``True then
|
||||
|
|
@ -19,10 +19,10 @@ builtin_simproc ↓ reduceIte (ite _ _ _) := fun e => OptionT.run do
|
|||
let eNew := e.getArg! 4
|
||||
let pr := mkApp (mkAppN (mkConst ``ite_cond_eq_false e.getAppFn.constLevels!) e.getAppArgs) (← r.getProof)
|
||||
return .visit { expr := eNew, proof? := pr }
|
||||
failure
|
||||
return .continue
|
||||
|
||||
builtin_simproc ↓ reduceDite (dite _ _ _) := fun e => OptionT.run do
|
||||
guard (e.isAppOfArity ``dite 5)
|
||||
builtin_simproc ↓ reduceDite (dite _ _ _) := fun e => do
|
||||
unless e.isAppOfArity ``dite 5 do return .continue
|
||||
let c := e.getArg! 1
|
||||
let r ← simp c
|
||||
if r.expr.isConstOf ``True then
|
||||
|
|
@ -37,4 +37,4 @@ builtin_simproc ↓ reduceDite (dite _ _ _) := fun e => OptionT.run do
|
|||
let eNew := mkApp (e.getArg! 4) h |>.headBeta
|
||||
let prNew := mkApp (mkAppN (mkConst ``dite_cond_eq_false e.getAppFn.constLevels!) e.getAppArgs) pr
|
||||
return .visit { expr := eNew, proof? := prNew }
|
||||
failure
|
||||
return .continue
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ structure Value where
|
|||
size : Nat
|
||||
value : Nat
|
||||
|
||||
def fromExpr? (e : Expr) : OptionT SimpM Value := do
|
||||
def fromExpr? (e : Expr) : SimpM (Option Value) := OptionT.run do
|
||||
guard (e.isAppOfArity ``OfNat.ofNat 3)
|
||||
let type ← whnf e.appFn!.appFn!.appArg!
|
||||
guard (type.isAppOfArity ``Fin 1)
|
||||
|
|
@ -28,18 +28,18 @@ def Value.toExpr (v : Value) : Expr :=
|
|||
let vExpr := mkRawNatLit v.value
|
||||
mkApp2 v.ofNatFn vExpr (mkApp2 (mkConst ``Fin.instOfNat) (Lean.toExpr (v.size - 1)) vExpr)
|
||||
|
||||
@[inline] def reduceBin (declName : Name) (arity : Nat) (op : Nat → Nat → Nat) (e : Expr) : OptionT SimpM Step := do
|
||||
guard (e.isAppOfArity declName arity)
|
||||
let v₁ ← fromExpr? e.appFn!.appArg!
|
||||
let v₂ ← fromExpr? e.appArg!
|
||||
guard (v₁.size == v₂.size)
|
||||
@[inline] def reduceBin (declName : Name) (arity : Nat) (op : Nat → Nat → Nat) (e : Expr) : SimpM Step := do
|
||||
unless e.isAppOfArity declName arity do return .continue
|
||||
let some v₁ ← fromExpr? e.appFn!.appArg! | return .continue
|
||||
let some v₂ ← fromExpr? e.appArg! | return .continue
|
||||
unless v₁.size == v₂.size do return .continue
|
||||
let v := { v₁ with value := op v₁.value v₂.value % v₁.size }
|
||||
return .done { expr := v.toExpr }
|
||||
|
||||
@[inline] def reduceBinPred (declName : Name) (arity : Nat) (op : Nat → Nat → Bool) (e : Expr) : OptionT SimpM Step := do
|
||||
guard (e.isAppOfArity declName arity)
|
||||
let v₁ ← fromExpr? e.appFn!.appArg!
|
||||
let v₂ ← fromExpr? e.appArg!
|
||||
@[inline] def reduceBinPred (declName : Name) (arity : Nat) (op : Nat → Nat → Bool) (e : Expr) : SimpM Step := do
|
||||
unless e.isAppOfArity declName arity do return .continue
|
||||
let some v₁ ← fromExpr? e.appFn!.appArg! | return .continue
|
||||
let some v₂ ← fromExpr? e.appArg! | return .continue
|
||||
let d ← mkDecide e
|
||||
if op v₁.value v₂.value then
|
||||
return .done { expr := mkConst ``True, proof? := mkAppN (mkConst ``eq_true_of_decide) #[e, d.appArg!, (← mkEqRefl (mkConst ``true))] }
|
||||
|
|
@ -63,8 +63,8 @@ builtin_simproc reduceGT (( _ : Fin _) > _) := reduceBinPred ``GT.gt 4 (. > .)
|
|||
builtin_simproc reduceGE (( _ : Fin _) ≥ _) := reduceBinPred ``GE.ge 4 (. ≥ .)
|
||||
|
||||
/-- Return `.done` for Fin values. We don't want to unfold them when `ground := true`. -/
|
||||
builtin_simproc isValue ((OfNat.ofNat _ : Fin _)) := fun e => OptionT.run do
|
||||
guard (e.isAppOfArity ``OfNat.ofNat 3)
|
||||
builtin_simproc isValue ((OfNat.ofNat _ : Fin _)) := fun e => do
|
||||
unless e.isAppOfArity ``OfNat.ofNat 3 do return .continue
|
||||
return .done { expr := e }
|
||||
|
||||
end Fin
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ import Lean.Meta.Tactic.Simp.BuiltinSimprocs.Nat
|
|||
namespace Int
|
||||
open Lean Meta Simp
|
||||
|
||||
def fromExpr? (e : Expr) : OptionT SimpM Int := do
|
||||
def fromExpr? (e : Expr) : SimpM (Option Int) := OptionT.run do
|
||||
let mut e := e
|
||||
let mut isNeg := false
|
||||
if e.isAppOfArity ``Neg.neg 3 then
|
||||
|
|
@ -32,21 +32,21 @@ def toExpr (v : Int) : Expr :=
|
|||
else
|
||||
e
|
||||
|
||||
@[inline] def reduceUnary (declName : Name) (arity : Nat) (op : Int → Int) (e : Expr) : OptionT SimpM Step := do
|
||||
guard (e.isAppOfArity declName arity)
|
||||
let n ← fromExpr? e.appArg!
|
||||
@[inline] def reduceUnary (declName : Name) (arity : Nat) (op : Int → Int) (e : Expr) : SimpM Step := do
|
||||
unless e.isAppOfArity declName arity do return .continue
|
||||
let some n ← fromExpr? e.appArg! | return .continue
|
||||
return .done { expr := toExpr (op n) }
|
||||
|
||||
@[inline] def reduceBin (declName : Name) (arity : Nat) (op : Int → Int → Int) (e : Expr) : OptionT SimpM Step := do
|
||||
guard (e.isAppOfArity declName arity)
|
||||
let v₁ ← fromExpr? e.appFn!.appArg!
|
||||
let v₂ ← fromExpr? e.appArg!
|
||||
@[inline] def reduceBin (declName : Name) (arity : Nat) (op : Int → Int → Int) (e : Expr) : SimpM Step := do
|
||||
unless e.isAppOfArity declName arity do return .continue
|
||||
let some v₁ ← fromExpr? e.appFn!.appArg! | return .continue
|
||||
let some v₂ ← fromExpr? e.appArg! | return .continue
|
||||
return .done { expr := toExpr (op v₁ v₂) }
|
||||
|
||||
@[inline] def reduceBinPred (declName : Name) (arity : Nat) (op : Int → Int → Bool) (e : Expr) : OptionT SimpM Step := OptionT.run do
|
||||
guard (e.isAppOfArity declName arity)
|
||||
let v₁ ← fromExpr? e.appFn!.appArg!
|
||||
let v₂ ← fromExpr? e.appArg!
|
||||
@[inline] def reduceBinPred (declName : Name) (arity : Nat) (op : Int → Int → Bool) (e : Expr) : SimpM Step := do
|
||||
unless e.isAppOfArity declName arity do return .continue
|
||||
let some v₁ ← fromExpr? e.appFn!.appArg! | return .continue
|
||||
let some v₂ ← fromExpr? e.appArg! | return .continue
|
||||
let d ← mkDecide e
|
||||
if op v₁ v₂ then
|
||||
return .done { expr := mkConst ``True, proof? := mkAppN (mkConst ``eq_true_of_decide) #[e, d.appArg!, (← mkEqRefl (mkConst ``true))] }
|
||||
|
|
@ -58,23 +58,23 @@ The following code assumes users did not override the `Int` instances for the ar
|
|||
If they do, they must disable the following `simprocs`.
|
||||
-/
|
||||
|
||||
builtin_simproc reduceNeg ((- _ : Int)) := fun e => OptionT.run do
|
||||
guard (e.isAppOfArity ``Neg.neg 3)
|
||||
builtin_simproc reduceNeg ((- _ : Int)) := fun e => do
|
||||
unless e.isAppOfArity ``Neg.neg 3 do return .continue
|
||||
let arg := e.appArg!
|
||||
if arg.isAppOfArity ``OfNat.ofNat 3 then
|
||||
-- We return .done to ensure `Neg.neg` is not unfolded even when `ground := true`.
|
||||
guard (← getContext).unfoldGround
|
||||
unless (← getContext).unfoldGround do return .continue
|
||||
return .done { expr := e }
|
||||
else
|
||||
let v ← fromExpr? arg
|
||||
let some v ← fromExpr? arg | return .continue
|
||||
if v < 0 then
|
||||
return .done { expr := toExpr (- v) }
|
||||
else
|
||||
return .done { expr := toExpr v }
|
||||
|
||||
/-- Return `.done` for positive Int values. We don't want to unfold them when `ground := true`. -/
|
||||
builtin_simproc isPosValue ((OfNat.ofNat _ : Int)) := fun e => OptionT.run do
|
||||
guard (e.isAppOfArity ``OfNat.ofNat 3)
|
||||
builtin_simproc isPosValue ((OfNat.ofNat _ : Int)) := fun e => do
|
||||
unless e.isAppOfArity ``OfNat.ofNat 3 do return .continue
|
||||
return .done { expr := e }
|
||||
|
||||
builtin_simproc reduceAdd ((_ + _ : Int)) := reduceBin ``HAdd.hAdd 6 (· + ·)
|
||||
|
|
@ -83,15 +83,15 @@ builtin_simproc reduceSub ((_ - _ : Int)) := reduceBin ``HSub.hSub 6 (· - ·)
|
|||
builtin_simproc reduceDiv ((_ / _ : Int)) := reduceBin ``HDiv.hDiv 6 (· / ·)
|
||||
builtin_simproc reduceMod ((_ % _ : Int)) := reduceBin ``HMod.hMod 6 (· % ·)
|
||||
|
||||
builtin_simproc reducePow ((_ : Int) ^ (_ : Nat)) := fun e => OptionT.run do
|
||||
guard (e.isAppOfArity ``HPow.hPow 6)
|
||||
let v₁ ← fromExpr? e.appFn!.appArg!
|
||||
let v₂ ← Nat.fromExpr? e.appArg!
|
||||
builtin_simproc reducePow ((_ : Int) ^ (_ : Nat)) := fun e => do
|
||||
unless e.isAppOfArity ``HPow.hPow 6 do return .continue
|
||||
let some v₁ ← fromExpr? e.appFn!.appArg! | return .continue
|
||||
let some v₂ ← Nat.fromExpr? e.appArg! | return .continue
|
||||
return .done { expr := toExpr (v₁ ^ v₂) }
|
||||
|
||||
builtin_simproc reduceAbs (natAbs _) := fun e => OptionT.run do
|
||||
guard (e.isAppOfArity ``natAbs 1)
|
||||
let v ← fromExpr? e.appArg!
|
||||
builtin_simproc reduceAbs (natAbs _) := fun e => do
|
||||
unless e.isAppOfArity ``natAbs 1 do return .continue
|
||||
let some v ← fromExpr? e.appArg! | return .continue
|
||||
return .done { expr := mkNatLit (natAbs v) }
|
||||
|
||||
builtin_simproc reduceLT (( _ : Int) < _) := reduceBinPred ``LT.lt 4 (. < .)
|
||||
|
|
|
|||
|
|
@ -13,21 +13,21 @@ def fromExpr? (e : Expr) : SimpM (Option Nat) := do
|
|||
let some n ← evalNat e |>.run | return none
|
||||
return n
|
||||
|
||||
@[inline] def reduceUnary (declName : Name) (arity : Nat) (op : Nat → Nat) (e : Expr) : OptionT SimpM Step := do
|
||||
guard (e.isAppOfArity declName arity)
|
||||
let n ← fromExpr? e.appArg!
|
||||
@[inline] def reduceUnary (declName : Name) (arity : Nat) (op : Nat → Nat) (e : Expr) : SimpM Step := do
|
||||
unless e.isAppOfArity declName arity do return .continue
|
||||
let some n ← fromExpr? e.appArg! | return .continue
|
||||
return .done { expr := mkNatLit (op n) }
|
||||
|
||||
@[inline] def reduceBin (declName : Name) (arity : Nat) (op : Nat → Nat → Nat) (e : Expr) : OptionT SimpM Step := do
|
||||
guard (e.isAppOfArity declName arity)
|
||||
let n ← fromExpr? e.appFn!.appArg!
|
||||
let m ← fromExpr? e.appArg!
|
||||
@[inline] def reduceBin (declName : Name) (arity : Nat) (op : Nat → Nat → Nat) (e : Expr) : SimpM Step := do
|
||||
unless e.isAppOfArity declName arity do return .continue
|
||||
let some n ← fromExpr? e.appFn!.appArg! | return .continue
|
||||
let some m ← fromExpr? e.appArg! | return .continue
|
||||
return .done { expr := mkNatLit (op n m) }
|
||||
|
||||
@[inline] def reduceBinPred (declName : Name) (arity : Nat) (op : Nat → Nat → Bool) (e : Expr) : OptionT SimpM Step := do
|
||||
guard (e.isAppOfArity declName arity)
|
||||
let n ← fromExpr? e.appFn!.appArg!
|
||||
let m ← fromExpr? e.appArg!
|
||||
@[inline] def reduceBinPred (declName : Name) (arity : Nat) (op : Nat → Nat → Bool) (e : Expr) : SimpM Step := do
|
||||
unless e.isAppOfArity declName arity do return .continue
|
||||
let some n ← fromExpr? e.appFn!.appArg! | return .continue
|
||||
let some m ← fromExpr? e.appArg! | return .continue
|
||||
let d ← mkDecide e
|
||||
if op n m then
|
||||
return .done { expr := mkConst ``True, proof? := mkAppN (mkConst ``eq_true_of_decide) #[e, d.appArg!, (← mkEqRefl (mkConst ``true))] }
|
||||
|
|
@ -55,9 +55,9 @@ builtin_simproc reduceGT (( _ : Nat) > _) := reduceBinPred ``GT.gt 4 (. > .)
|
|||
builtin_simproc reduceGE (( _ : Nat) ≥ _) := reduceBinPred ``GE.ge 4 (. ≥ .)
|
||||
|
||||
/-- Return `.done` for Nat values. We don't want to unfold them when `ground := true`. -/
|
||||
builtin_simproc isValue ((OfNat.ofNat _ : Nat)) := fun e => OptionT.run do
|
||||
guard (← getContext).unfoldGround
|
||||
guard (e.isAppOfArity ``OfNat.ofNat 3)
|
||||
builtin_simproc isValue ((OfNat.ofNat _ : Nat)) := fun e => do
|
||||
unless (← getContext).unfoldGround do return .continue
|
||||
unless e.isAppOfArity ``OfNat.ofNat 3 do return .continue
|
||||
return .done { expr := e }
|
||||
|
||||
end Nat
|
||||
|
|
|
|||
|
|
@ -30,17 +30,17 @@ def $toExpr (v : Value) : Expr :=
|
|||
let vExpr := mkRawNatLit v.value.val
|
||||
mkApp2 v.ofNatFn vExpr (mkApp (mkConst $(quote (typeName.getId ++ `instOfNat))) vExpr)
|
||||
|
||||
@[inline] def reduceBin (declName : Name) (arity : Nat) (op : $typeName → $typeName → $typeName) (e : Expr) : OptionT SimpM Step := do
|
||||
guard (e.isAppOfArity declName arity)
|
||||
let n ← ($fromExpr e.appFn!.appArg!)
|
||||
let m ← ($fromExpr e.appArg!)
|
||||
@[inline] def reduceBin (declName : Name) (arity : Nat) (op : $typeName → $typeName → $typeName) (e : Expr) : SimpM Step := do
|
||||
unless e.isAppOfArity declName arity do return .continue
|
||||
let some n ← ($fromExpr e.appFn!.appArg!) | return .continue
|
||||
let some m ← ($fromExpr e.appArg!) | return .continue
|
||||
let r := { n with value := op n.value m.value }
|
||||
return .done { expr := $toExpr r }
|
||||
|
||||
@[inline] def reduceBinPred (declName : Name) (arity : Nat) (op : $typeName → $typeName → Bool) (e : Expr) : OptionT SimpM Step := do
|
||||
guard (e.isAppOfArity declName arity)
|
||||
let n ← ($fromExpr e.appFn!.appArg!)
|
||||
let m ← ($fromExpr e.appArg!)
|
||||
@[inline] def reduceBinPred (declName : Name) (arity : Nat) (op : $typeName → $typeName → Bool) (e : Expr) : SimpM Step := do
|
||||
unless e.isAppOfArity declName arity do return .continue
|
||||
let some n ← ($fromExpr e.appFn!.appArg!) | return .continue
|
||||
let some m ← ($fromExpr e.appArg!) | return .continue
|
||||
let d ← mkDecide e
|
||||
if op n.value m.value then
|
||||
return .done { expr := mkConst ``True, proof? := mkAppN (mkConst ``eq_true_of_decide) #[e, d.appArg!, (← mkEqRefl (mkConst ``true))] }
|
||||
|
|
@ -59,9 +59,9 @@ builtin_simproc $(mkIdent `reduceGT):ident (( _ : $typeName) > _) := reduceBin
|
|||
builtin_simproc $(mkIdent `reduceGE):ident (( _ : $typeName) ≥ _) := reduceBinPred ``GE.ge 4 (. ≥ .)
|
||||
|
||||
/-- Return `.done` for UInt values. We don't want to unfold them when `ground := true`. -/
|
||||
builtin_simproc isValue ((OfNat.ofNat _ : $typeName)) := fun e => OptionT.run do
|
||||
guard (← getContext).unfoldGround
|
||||
guard (e.isAppOfArity ``OfNat.ofNat 3)
|
||||
builtin_simproc isValue ((OfNat.ofNat _ : $typeName)) := fun e => do
|
||||
unless (← getContext).unfoldGround do return .continue
|
||||
unless (e.isAppOfArity ``OfNat.ofNat 3) do return .continue
|
||||
return .done { expr := e }
|
||||
|
||||
end $typeName
|
||||
|
|
|
|||
|
|
@ -403,12 +403,12 @@ private partial def dsimpImpl (e : Expr) : SimpM Expr := do
|
|||
unless cfg.dsimp do
|
||||
return e
|
||||
let pre (e : Expr) : SimpM TransformStep := do
|
||||
if let Step.visit r ← rewritePre e (fun _ => pure none) (rflOnly := true) then
|
||||
if let Step.visit r ← rewritePre (discharge? := fun _ => pure none) (rflOnly := true) e then
|
||||
if r.expr != e then
|
||||
return .visit r.expr
|
||||
return .continue
|
||||
let post (e : Expr) : SimpM TransformStep := do
|
||||
if let some r ← rewritePost? e (fun _ => pure none) (rflOnly := true) then
|
||||
if let Step.visit r ← rewritePost (discharge? := fun _ => pure none) (rflOnly := true) e then
|
||||
if r.expr != e then
|
||||
return .visit r.expr
|
||||
let mut eNew ← reduce e
|
||||
|
|
@ -433,7 +433,7 @@ def visitFn (e : Expr) : SimpM Result := do
|
|||
|
||||
def congrDefault (e : Expr) : SimpM Result := do
|
||||
if let some result ← tryAutoCongrTheorem? e then
|
||||
mkEqTrans result (← visitFn result.expr)
|
||||
result.mkEqTrans (← visitFn result.expr)
|
||||
else
|
||||
withParent e <| e.withApp fun f args => do
|
||||
congrArgs (← simp f) args
|
||||
|
|
@ -533,14 +533,11 @@ def congr (e : Expr) : SimpM Result := do
|
|||
congrDefault e
|
||||
|
||||
def simpApp (e : Expr) : SimpM Result := do
|
||||
let e' ← reduceStep e
|
||||
if e' != e then
|
||||
simp e'
|
||||
else if isOfNatNatLit e' then
|
||||
if isOfNatNatLit e then
|
||||
-- Recall that we expand "orphan" kernel nat literals `n` into `ofNat n`
|
||||
return { expr := e' }
|
||||
return { expr := e }
|
||||
else
|
||||
congr e'
|
||||
congr e
|
||||
|
||||
def simpStep (e : Expr) : SimpM Result := do
|
||||
match e with
|
||||
|
|
@ -567,26 +564,36 @@ def cacheResult (e : Expr) (cfg : Config) (r : Result) : SimpM Result := do
|
|||
modify fun s => { s with cache := s.cache.insert e { r with dischargeDepth } }
|
||||
return r
|
||||
|
||||
partial def simpLoop (e : Expr) (r : Result) : SimpM Result := do
|
||||
partial def simpLoop (e : Expr) : SimpM Result := do
|
||||
let cfg ← getConfig
|
||||
if (← get).numSteps > cfg.maxSteps then
|
||||
throwError "simp failed, maximum number of steps exceeded"
|
||||
else
|
||||
let init := r.expr
|
||||
modify fun s => { s with numSteps := s.numSteps + 1 }
|
||||
match (← pre r.expr) with
|
||||
| Step.done r' => cacheResult e cfg (← mkEqTrans r r')
|
||||
| Step.visit r' =>
|
||||
let r ← mkEqTrans r r'
|
||||
let r ← mkEqTrans r (← simpStep r.expr)
|
||||
match (← post r.expr) with
|
||||
| Step.done r' => cacheResult e cfg (← mkEqTrans r r')
|
||||
| Step.visit r' =>
|
||||
let r ← mkEqTrans r r'
|
||||
if cfg.singlePass || init == r.expr then
|
||||
cacheResult e cfg r
|
||||
else
|
||||
simpLoop e r
|
||||
match (← pre e) with
|
||||
| .done r => cacheResult e cfg r
|
||||
| .visit r => cacheResult e cfg (← r.mkEqTrans (← simpLoop r.expr))
|
||||
| .continue none => visitPreContinue cfg { expr := e }
|
||||
| .continue (some r) => visitPreContinue cfg r
|
||||
where
|
||||
visitPreContinue (cfg : Config) (r : Result) : SimpM Result := do
|
||||
let eNew ← reduceStep r.expr
|
||||
if eNew != r.expr then
|
||||
let r := { r with expr := eNew }
|
||||
cacheResult e cfg (← r.mkEqTrans (← simpLoop r.expr))
|
||||
else
|
||||
let r ← r.mkEqTrans (← simpStep r.expr)
|
||||
visitPost cfg r
|
||||
visitPost (cfg : Config) (r : Result) : SimpM Result := do
|
||||
match (← post r.expr) with
|
||||
| .done r' => cacheResult e cfg (← r.mkEqTrans r')
|
||||
| .continue none => visitPostContinue cfg r
|
||||
| .visit r' | .continue (some r') => visitPostContinue cfg (← r.mkEqTrans r')
|
||||
visitPostContinue (cfg : Config) (r : Result) : SimpM Result := do
|
||||
let mut r := r
|
||||
unless cfg.singlePass || e == r.expr do
|
||||
r ← r.mkEqTrans (← simpLoop r.expr)
|
||||
cacheResult e cfg r
|
||||
|
||||
@[export lean_simp]
|
||||
def simpImpl (e : Expr) : SimpM Result := withIncRecDepth do
|
||||
|
|
@ -594,7 +601,6 @@ def simpImpl (e : Expr) : SimpM Result := withIncRecDepth do
|
|||
if (← isProof e) then
|
||||
return { expr := e }
|
||||
let ctx ← getContext
|
||||
trace[Meta.debug] "visit [{ctx.unfoldGround}]: {e}"
|
||||
if ctx.unfoldGround then
|
||||
if (← isType e) then
|
||||
unless (← isProp e) do
|
||||
|
|
@ -614,7 +620,7 @@ where
|
|||
if result.dischargeDepth ≤ (← readThe Simp.Context).dischargeDepth then
|
||||
return result
|
||||
trace[Meta.Tactic.simp.heads] "{repr e.toHeadIndex}"
|
||||
simpLoop e { expr := e }
|
||||
simpLoop e
|
||||
|
||||
@[inline] def withSimpConfig (ctx : Context) (x : MetaM α) : MetaM α :=
|
||||
withConfig (fun c => { c with etaStruct := ctx.config.etaStruct }) <| withReducible x
|
||||
|
|
|
|||
|
|
@ -14,13 +14,6 @@ import Lean.Meta.Tactic.Simp.Simproc
|
|||
|
||||
namespace Lean.Meta.Simp
|
||||
|
||||
def mkEqTrans (r₁ r₂ : Result) : MetaM Result := do
|
||||
match r₁.proof? with
|
||||
| none => return r₂
|
||||
| some p₁ => match r₂.proof? with
|
||||
| none => return { r₂ with proof? := r₁.proof? }
|
||||
| some p₂ => return { r₂ with proof? := (← Meta.mkEqTrans p₁ p₂) }
|
||||
|
||||
def synthesizeArgs (thmId : Origin) (xs : Array Expr) (bis : Array BinderInfo) (discharge? : Expr → SimpM (Option Expr)) : SimpM Bool := do
|
||||
for x in xs, bi in bis do
|
||||
let type ← inferType x
|
||||
|
|
@ -162,71 +155,53 @@ where
|
|||
inErasedSet (thm : SimpTheorem) : Bool :=
|
||||
erased.contains thm.origin
|
||||
|
||||
@[inline] def andThen' (s : Step) (f? : Expr → SimpM Step) : SimpM Step := do
|
||||
match s with
|
||||
| Step.done _ => return s
|
||||
| Step.visit r =>
|
||||
let s' ← f? r.expr
|
||||
return s'.updateResult (← mkEqTrans r s'.result)
|
||||
-- TODO: workaround for `Expr.constructorApp?` limitations. We should handle `OfNat.ofNat` there
|
||||
private def reduceOfNatNat (e : Expr) : MetaM Expr := do
|
||||
unless e.isAppOfArity ``OfNat.ofNat 3 do
|
||||
return e
|
||||
unless (← whnfD (e.getArg! 0)).isConstOf ``Nat do
|
||||
return e
|
||||
return e.getArg! 1
|
||||
|
||||
@[inline] def andThen (s : Step) (f? : Expr → SimpM (Option Step)) : SimpM Step := do
|
||||
match s with
|
||||
| Step.done _ => return s
|
||||
| Step.visit r =>
|
||||
if let some s' ← f? r.expr then
|
||||
return s'.updateResult (← mkEqTrans r s'.result)
|
||||
else
|
||||
return s
|
||||
|
||||
def rewriteCtorEq? (e : Expr) : MetaM (Option Result) := withReducibleAndInstances do
|
||||
def simpCtorEq : Simproc := fun e => do
|
||||
match e.eq? with
|
||||
| none => return none
|
||||
| none => return .continue
|
||||
| some (_, lhs, rhs) =>
|
||||
let lhs ← whnf lhs
|
||||
let rhs ← whnf rhs
|
||||
let lhs ← reduceOfNatNat (← whnf lhs)
|
||||
let rhs ← reduceOfNatNat (← whnf rhs)
|
||||
let env ← getEnv
|
||||
match lhs.constructorApp? env, rhs.constructorApp? env with
|
||||
| some (c₁, _), some (c₂, _) =>
|
||||
if c₁.name != c₂.name then
|
||||
withLocalDeclD `h e fun h =>
|
||||
return some { expr := mkConst ``False, proof? := (← mkEqFalse' (← mkLambdaFVars #[h] (← mkNoConfusion (mkConst ``False) h))) }
|
||||
return .done { expr := mkConst ``False, proof? := (← withDefault <| mkEqFalse' (← mkLambdaFVars #[h] (← mkNoConfusion (mkConst ``False) h))) }
|
||||
else
|
||||
return none
|
||||
| _, _ => return none
|
||||
return .continue
|
||||
| _, _ => return .continue
|
||||
|
||||
@[inline] def tryRewriteCtorEq? (e : Expr) : SimpM (Option Step) := do
|
||||
match (← rewriteCtorEq? e) with
|
||||
| some r => return Step.done r
|
||||
| none => return none
|
||||
|
||||
def rewriteUsingDecide? (e : Expr) : MetaM (Option Result) := withReducibleAndInstances do
|
||||
@[inline] def simpUsingDecide : Simproc := fun e => do
|
||||
unless (← getConfig).decide do
|
||||
return .continue
|
||||
if e.hasFVar || e.hasMVar || e.consumeMData.isConstOf ``True || e.consumeMData.isConstOf ``False then
|
||||
return none
|
||||
else
|
||||
try
|
||||
let d ← mkDecide e
|
||||
let r ← withDefault <| whnf d
|
||||
if r.isConstOf ``true then
|
||||
return some { expr := mkConst ``True, proof? := mkAppN (mkConst ``eq_true_of_decide) #[e, d.appArg!, (← mkEqRefl (mkConst ``true))] }
|
||||
else if r.isConstOf ``false then
|
||||
return some { expr := mkConst ``False, proof? := mkAppN (mkConst ``eq_false_of_decide) #[e, d.appArg!, (← mkEqRefl (mkConst ``false))] }
|
||||
else
|
||||
return none
|
||||
catch _ =>
|
||||
return none
|
||||
return .continue
|
||||
try
|
||||
let d ← mkDecide e
|
||||
let r ← withDefault <| whnf d
|
||||
if r.isConstOf ``true then
|
||||
return .done { expr := mkConst ``True, proof? := mkAppN (mkConst ``eq_true_of_decide) #[e, d.appArg!, (← mkEqRefl (mkConst ``true))] }
|
||||
else if r.isConstOf ``false then
|
||||
return .done { expr := mkConst ``False, proof? := mkAppN (mkConst ``eq_false_of_decide) #[e, d.appArg!, (← mkEqRefl (mkConst ``false))] }
|
||||
else
|
||||
return .continue
|
||||
catch _ =>
|
||||
return .continue
|
||||
|
||||
@[inline] def tryRewriteUsingDecide? (e : Expr) : SimpM (Option Step) := do
|
||||
if (← getConfig).decide then
|
||||
match (← rewriteUsingDecide? e) with
|
||||
| some r => return Step.done r
|
||||
| none => return none
|
||||
else
|
||||
return none
|
||||
|
||||
def simpArith? (e : Expr) : SimpM (Option Step) := do
|
||||
if !(← getConfig).arith then return none
|
||||
let some (e', h) ← Linear.simp? e (← getContext).parent? | return none
|
||||
return Step.visit { expr := e', proof? := h }
|
||||
def simpArith (e : Expr) : SimpM Step := do
|
||||
unless (← getConfig).arith do
|
||||
return .continue
|
||||
let some (e', h) ← Linear.simp? e (← getContext).parent?
|
||||
| return .continue
|
||||
return .visit { expr := e', proof? := h }
|
||||
|
||||
/--
|
||||
Given a match-application `e` with `MatcherInfo` `info`, return `some result`
|
||||
|
|
@ -264,122 +239,88 @@ def simpMatchDiscrs? (info : MatcherInfo) (e : Expr) : SimpM (Option Result) :=
|
|||
r ← mkCongrFun r arg
|
||||
return some r
|
||||
|
||||
def simpMatchCore? (matcherName : Name) (e : Expr) (discharge? : Expr → SimpM (Option Expr)) : SimpM (Option Step) := do
|
||||
def simpMatchCore (matcherName : Name) (discharge? : Expr → SimpM (Option Expr)) (e : Expr) : SimpM Step := do
|
||||
for matchEq in (← Match.getEquationsFor matcherName).eqnNames do
|
||||
-- Try lemma
|
||||
match (← withReducible <| Simp.tryTheorem? e { origin := .decl matchEq, proof := mkConst matchEq, rfl := (← isRflTheorem matchEq) } discharge?) with
|
||||
| none => pure ()
|
||||
| some r => return some (Simp.Step.done r)
|
||||
return none
|
||||
| some r => return .visit r
|
||||
return .continue
|
||||
|
||||
def simpMatch? (discharge? : Expr → SimpM (Option Expr)) (e : Expr) : SimpM (Option Step) := do
|
||||
if (← getConfig).iota then
|
||||
if let some e ← reduceRecMatcher? e then
|
||||
return some (.visit { expr := e })
|
||||
let .const declName _ := e.getAppFn
|
||||
| return none
|
||||
if let some info ← getMatcherInfo? declName then
|
||||
if let some r ← simpMatchDiscrs? info e then
|
||||
return some (.visit r)
|
||||
simpMatchCore? declName e discharge?
|
||||
else
|
||||
return none
|
||||
else
|
||||
return none
|
||||
def simpMatch (discharge? : Expr → SimpM (Option Expr)) : Simproc := fun e => do
|
||||
unless (← getConfig).iota do
|
||||
return .continue
|
||||
if let some e ← reduceRecMatcher? e then
|
||||
return .visit { expr := e }
|
||||
let .const declName _ := e.getAppFn
|
||||
| return .continue
|
||||
let some info ← getMatcherInfo? declName
|
||||
| return .continue
|
||||
if let some r ← simpMatchDiscrs? info e then
|
||||
return .visit r
|
||||
simpMatchCore declName discharge? e
|
||||
|
||||
def rewritePre (e : Expr) (discharge? : Expr → SimpM (Option Expr)) (rflOnly := false) : SimpM Step := do
|
||||
def rewritePre (discharge? : Expr → SimpM (Option Expr)) (rflOnly := false) : Simproc := fun e => do
|
||||
for thms in (← getContext).simpTheorems do
|
||||
if let some r ← rewrite? e thms.pre thms.erased discharge? (tag := "pre") (rflOnly := rflOnly) then
|
||||
return Step.visit r
|
||||
return Step.visit { expr := e }
|
||||
return .visit r
|
||||
return .continue
|
||||
|
||||
partial def preDefault (e : Expr) (discharge? : Expr → SimpM (Option Expr)) : SimpM Step := do
|
||||
let s ← rewritePre e discharge?
|
||||
let s ← andThen s (simpMatch? discharge?)
|
||||
let s ← andThen s preSimproc?
|
||||
let s ← andThen s tryRewriteUsingDecide?
|
||||
if s.result.expr == e then
|
||||
return s
|
||||
else
|
||||
andThen s (preDefault · discharge?)
|
||||
|
||||
def rewritePost? (e : Expr) (discharge? : Expr → SimpM (Option Expr)) (rflOnly := false) : SimpM (Option Result) := do
|
||||
def rewritePost (discharge? : Expr → SimpM (Option Expr)) (rflOnly := false) : Simproc := fun e => do
|
||||
for thms in (← getContext).simpTheorems do
|
||||
if let some r ← rewrite? e thms.post thms.erased discharge? (tag := "post") (rflOnly := rflOnly) then
|
||||
return r
|
||||
return none
|
||||
return .visit r
|
||||
return .continue
|
||||
|
||||
/--
|
||||
Try to unfold ground term when `Context.unfoldGround := true`.
|
||||
-/
|
||||
def unfoldGround? (discharge? : Expr → SimpM (Option Expr)) (e : Expr) : SimpM (Option Step) := do
|
||||
def simpGround (discharge? : Expr → SimpM (Option Expr)) : Simproc := fun e => do
|
||||
-- Ground term unfolding is disabled.
|
||||
unless (← getContext).unfoldGround do return none
|
||||
unless (← getContext).unfoldGround do return .continue
|
||||
-- `e` is not a ground term.
|
||||
unless !e.hasExprMVar && !e.hasFVar do return none
|
||||
trace[Meta.debug] "unfoldGround? {e}"
|
||||
unless !e.hasExprMVar && !e.hasFVar do return .continue
|
||||
-- Check whether `e` is a constant application
|
||||
let f := e.getAppFn
|
||||
let .const declName lvls := f | return none
|
||||
let .const declName lvls := f | return .continue
|
||||
-- If declaration has been marked to not be unfolded, return none.
|
||||
let ctx ← getContext
|
||||
if ctx.simpTheorems.isErased (.decl declName) then return none
|
||||
if ctx.simpTheorems.isErased (.decl declName) then return .continue
|
||||
-- Matcher applications should have been reduced before we get here.
|
||||
if (← isMatcher declName) then return none
|
||||
if (← isMatcher declName) then return .continue
|
||||
if let some eqns ← withDefault <| getEqnsFor? declName then
|
||||
-- `declName` has equation theorems associated with it.
|
||||
for eqn in eqns do
|
||||
-- TODO: cache SimpTheorem to avoid calls to `isRflTheorem`
|
||||
if let some result ← Simp.tryTheorem? e { origin := .decl eqn, proof := mkConst eqn, rfl := (← isRflTheorem eqn) } discharge? then
|
||||
trace[Meta.Tactic.simp.ground] "unfolded, {e} => {result.expr}"
|
||||
return some (.visit result)
|
||||
return none
|
||||
return .visit result
|
||||
return .continue
|
||||
-- `declName` does not have equation theorems associated with it.
|
||||
if e.isConst then
|
||||
-- We don't unfold constants that take arguments
|
||||
if let .forallE .. ← whnfD (← inferType e) then
|
||||
return none
|
||||
return .continue
|
||||
let info ← getConstInfo declName
|
||||
unless info.hasValue && info.levelParams.length == lvls.length do return none
|
||||
unless info.hasValue && info.levelParams.length == lvls.length do return .continue
|
||||
let fBody ← instantiateValueLevelParams info lvls
|
||||
let eNew := fBody.betaRev e.getAppRevArgs (useZeta := true)
|
||||
trace[Meta.Tactic.simp.ground] "delta, {e} => {eNew}"
|
||||
return some (.visit { expr := eNew })
|
||||
return .visit { expr := eNew }
|
||||
|
||||
def postDefault (e : Expr) (discharge? : Expr → SimpM (Option Expr)) : SimpM Step := do
|
||||
/-
|
||||
Remark 1:
|
||||
`rewritePost?` used to return a `Step`, and we would try other methods even if it succeeded in rewriting the term.
|
||||
This behavior was problematic, especially when `ground := true`, because we have rewriting rules such as
|
||||
`List.append as bs = as ++ bs`, which are rules for folding polymorphic functions.
|
||||
This type of rule can trigger nontermination in the context of `ground := true`.
|
||||
For example, the method `unfoldGround?` would reduce `[] ++ [1]` to `List.append [] [1]`, and
|
||||
`rewritePost` would refold it back to `[] ++ [1]`, leading to an endless loop.
|
||||
partial def preDefault (s : Simprocs) (discharge? : Expr → SimpM (Option Expr)) : Simproc :=
|
||||
rewritePre discharge? >>
|
||||
simpMatch discharge? >>
|
||||
userPreSimprocs s >>
|
||||
simpUsingDecide
|
||||
|
||||
Initially, we considered always reducing ground terms first. However, this approach would
|
||||
prevent us from adding auxiliary lemmas that could short-circuit the evaluation.
|
||||
Ultimately, we settled on the following compromise: if a `rewritePost?` succeeds and produces a result `r`,
|
||||
we return with `.visit r`. This allows pre-methods to be applied again along with other rewriting rules.
|
||||
This strategy helps avoid non-termination, as we have `[simp]` theorems specifically for reducing `List.append`
|
||||
```lean
|
||||
@[simp] theorem nil_append (as : List α) : [] ++ as = as := ...
|
||||
@[simp] theorem cons_append (a : α) (as bs : List α) : (a::as) ++ bs = a::(as ++ bs) := ...
|
||||
```
|
||||
|
||||
Remark 2:
|
||||
In the simplifier, the ground value for some inductive types is *not* a constructor application.
|
||||
Examples: `Nat`, `Int`, `Fin _`, `UInt?`. These types are represented using `OfNat.ofNat`.
|
||||
To ensure `unfoldGround?` does not unfold `OfNat.ofNat` applications for these types, we
|
||||
have `simproc` that return `.done ..` for these ground values. Thus, `unfoldGround?` is not
|
||||
even tried. Alternative design: we could add an extensible ground value predicate.
|
||||
-/
|
||||
if let some r ← rewritePost? e discharge? then
|
||||
return .visit r
|
||||
let s ← andThen (.visit { expr := e }) postSimproc?
|
||||
let s ← andThen s (unfoldGround? discharge?)
|
||||
let s ← andThen s simpArith?
|
||||
let s ← andThen s tryRewriteUsingDecide?
|
||||
andThen s tryRewriteCtorEq?
|
||||
def postDefault (s : Simprocs) (discharge? : Expr → SimpM (Option Expr)) : Simproc :=
|
||||
rewritePost discharge? >>
|
||||
userPostSimprocs s >>
|
||||
simpGround discharge? >>
|
||||
simpArith >>
|
||||
simpCtorEq >>
|
||||
simpUsingDecide
|
||||
|
||||
/--
|
||||
Return true if `e` is of the form `(x : α) → ... → s = t → ... → False`
|
||||
|
|
@ -469,11 +410,10 @@ def dischargeDefault? (e : Expr) : SimpM (Option Expr) := do
|
|||
|
||||
abbrev Discharge := Expr → SimpM (Option Expr)
|
||||
|
||||
def mkMethods (simprocs : Simprocs) (discharge? : Discharge) : Methods := {
|
||||
pre := (preDefault · discharge?)
|
||||
post := (postDefault · discharge?)
|
||||
def mkMethods (s : Simprocs) (discharge? : Discharge) : Methods := {
|
||||
pre := preDefault s discharge?
|
||||
post := postDefault s discharge?
|
||||
discharge? := discharge?
|
||||
simprocs := simprocs
|
||||
}
|
||||
|
||||
def mkDefaultMethodsCore (simprocs : Simprocs) : Methods :=
|
||||
|
|
|
|||
|
|
@ -154,45 +154,62 @@ def Simprocs.add (s : Simprocs) (declName : Name) (post : Bool) : CoreM Simprocs
|
|||
else
|
||||
return { s with pre := s.pre.insertCore keys { declName, keys, post, proc } }
|
||||
|
||||
def SimprocEntry.try? (s : SimprocEntry) (numExtraArgs : Nat) (e : Expr) : SimpM (Option Step) := do
|
||||
def SimprocEntry.try (s : SimprocEntry) (numExtraArgs : Nat) (e : Expr) : SimpM Step := do
|
||||
let mut extraArgs := #[]
|
||||
let mut e := e
|
||||
for _ in [:numExtraArgs] do
|
||||
extraArgs := extraArgs.push e.appArg!
|
||||
e := e.appFn!
|
||||
extraArgs := extraArgs.reverse
|
||||
match (← s.proc e) with
|
||||
| none => return none
|
||||
| some step => return some (← step.addExtraArgs extraArgs)
|
||||
let s ← s.proc e
|
||||
s.addExtraArgs extraArgs
|
||||
|
||||
def simproc? (post : Bool) (s : SimprocTree) (erased : PHashSet Name) (e : Expr) : SimpM (Option Step) := do
|
||||
def simprocCore (post : Bool) (s : SimprocTree) (erased : PHashSet Name) (e : Expr) : SimpM Step := do
|
||||
let candidates ← s.getMatchWithExtra e (getDtConfig (← getConfig))
|
||||
if candidates.isEmpty then
|
||||
let tag := if post then "post" else "pre"
|
||||
trace[Debug.Meta.Tactic.simp] "no {tag}-simprocs found for {e}"
|
||||
return none
|
||||
return .continue
|
||||
else
|
||||
let mut e := e
|
||||
let mut proof? : Option Expr := none
|
||||
let mut found := false
|
||||
for (simprocEntry, numExtraArgs) in candidates do
|
||||
unless erased.contains simprocEntry.declName do
|
||||
if let some step ← simprocEntry.try? numExtraArgs e then
|
||||
trace[Debug.Meta.Tactic.simp] "simproc result {e} => {step.result.expr}"
|
||||
let s ← simprocEntry.try numExtraArgs e
|
||||
match s with
|
||||
| .visit r =>
|
||||
trace[Debug.Meta.Tactic.simp] "simproc result {e} => {r.expr}"
|
||||
recordSimpTheorem (.decl simprocEntry.declName post)
|
||||
return some step
|
||||
return none
|
||||
return .visit (← mkEqTransOptProofResult proof? r)
|
||||
| .done r =>
|
||||
trace[Debug.Meta.Tactic.simp] "simproc result {e} => {r.expr}"
|
||||
recordSimpTheorem (.decl simprocEntry.declName post)
|
||||
return .done (← mkEqTransOptProofResult proof? r)
|
||||
| Step.continue (some r) =>
|
||||
trace[Debug.Meta.Tactic.simp] "simproc result {e} => {r.expr}"
|
||||
recordSimpTheorem (.decl simprocEntry.declName post)
|
||||
e := r.expr
|
||||
proof? ← mkEqTrans? proof? r.proof?
|
||||
found := true
|
||||
| Step.continue none =>
|
||||
pure ()
|
||||
if found then
|
||||
return .continue (some { expr := e, proof? })
|
||||
else
|
||||
return .continue
|
||||
|
||||
register_builtin_option simprocs : Bool := {
|
||||
defValue := true
|
||||
descr := "Enable/disable `simproc`s (simplification procedures)."
|
||||
}
|
||||
|
||||
def preSimproc? (e : Expr) : SimpM (Option Step) := do
|
||||
unless simprocs.get (← getOptions) do return none
|
||||
let s := (← getMethods).simprocs
|
||||
simproc? (post := false) s.pre s.erased e
|
||||
def userPreSimprocs (s : Simprocs) : Simproc := fun e => do
|
||||
unless simprocs.get (← getOptions) do return .continue
|
||||
simprocCore (post := false) s.pre s.erased e
|
||||
|
||||
def postSimproc? (e : Expr) : SimpM (Option Step) := do
|
||||
unless simprocs.get (← getOptions) do return none
|
||||
let s := (← getMethods).simprocs
|
||||
simproc? (post := true) s.post s.erased e
|
||||
def userPostSimprocs (s : Simprocs) : Simproc := fun e => do
|
||||
unless simprocs.get (← getOptions) do return .continue
|
||||
simprocCore (post := true) s.post s.erased e
|
||||
|
||||
end Lean.Meta.Simp
|
||||
|
|
|
|||
|
|
@ -19,6 +19,16 @@ structure Result where
|
|||
dischargeDepth : UInt32 := 0
|
||||
deriving Inhabited
|
||||
|
||||
def mkEqTransOptProofResult (h? : Option Expr) (r : Result) : MetaM Result :=
|
||||
match h? with
|
||||
| none => return r
|
||||
| some p₁ => match r.proof? with
|
||||
| none => return { r with proof? := some p₁ }
|
||||
| some p₂ => return { r with proof? := (← Meta.mkEqTrans p₁ p₂) }
|
||||
|
||||
def Result.mkEqTrans (r₁ r₂ : Result) : MetaM Result :=
|
||||
mkEqTransOptProofResult r₁.proof? r₂
|
||||
|
||||
abbrev Cache := ExprMap Result
|
||||
|
||||
abbrev CongrCache := ExprMap (Option CongrTheorem)
|
||||
|
|
@ -78,20 +88,63 @@ opaque dsimp (e : Expr) : SimpM Expr
|
|||
def withoutUnfoldGround (x : SimpM α) : SimpM α :=
|
||||
withTheReader Context (fun ctx => { ctx with unfoldGround := false }) x
|
||||
|
||||
/--
|
||||
Result type for a simplification procedure. We have `pre` and `post` simplication procedures.
|
||||
-/
|
||||
inductive Step where
|
||||
| visit : Result → Step
|
||||
| done : Result → Step
|
||||
/--
|
||||
For `pre` procedures, it returns the result without visiting any subexpressions.
|
||||
|
||||
For `post` procedures, it returns the result.
|
||||
-/
|
||||
| done (r : Result)
|
||||
/--
|
||||
For `pre` procedures, the resulting expression is passed to `pre` again.
|
||||
|
||||
For `post` procedures, the resulting expression is passed to `pre` again IF
|
||||
`Simp.Config.singlePass := false` and resulting expression is not equal to initial expression.
|
||||
-/
|
||||
| visit (e : Result)
|
||||
/--
|
||||
For `pre` procedures, continue transformation by visiting subexpressions, and then
|
||||
executing `post` procedures.
|
||||
|
||||
For `post` procedures, this is equivalent to returning `visit`.
|
||||
-/
|
||||
| continue (e? : Option Result := none)
|
||||
deriving Inhabited
|
||||
|
||||
def Step.result : Step → Result
|
||||
| Step.visit r => r
|
||||
| Step.done r => r
|
||||
/--
|
||||
A simplification procedure. Recall that we have `pre` and `post` procedures.
|
||||
See `Step`.
|
||||
-/
|
||||
abbrev Simproc := Expr → SimpM Step
|
||||
|
||||
def Step.updateResult : Step → Result → Step
|
||||
| Step.visit _, r => Step.visit r
|
||||
| Step.done _, r => Step.done r
|
||||
def mkEqTransResultStep (r : Result) (s : Step) : MetaM Step :=
|
||||
match s with
|
||||
| .done r' => return .done (← mkEqTransOptProofResult r.proof? r')
|
||||
| .visit r' => return .visit (← mkEqTransOptProofResult r.proof? r')
|
||||
| .continue none => return .continue r
|
||||
| .continue (some r') => return .continue (some (← mkEqTransOptProofResult r.proof? r'))
|
||||
|
||||
abbrev Simproc := Expr → SimpM (Option Step)
|
||||
|
||||
/--
|
||||
"Compose" the two given simplification procedures. We use the following semantics.
|
||||
- If `f` produces `done` or `visit`, then return `f`'s result.
|
||||
- If `f` produces `continue`, then apply `g` to new expression returned by `f`.
|
||||
|
||||
See `Simp.Step` type.
|
||||
-/
|
||||
@[always_inline]
|
||||
def andThen (f g : Simproc) : Simproc := fun e => do
|
||||
match (← f e) with
|
||||
| .done r => return .done r
|
||||
| .continue none => g e
|
||||
| .continue (some r) => mkEqTransResultStep r (← g r.expr)
|
||||
| .visit r => return .visit r
|
||||
|
||||
instance : AndThen Simproc where
|
||||
andThen s₁ s₂ := andThen s₁ (s₂ ())
|
||||
|
||||
/--
|
||||
`Simproc` .olean entry.
|
||||
|
|
@ -123,10 +176,9 @@ structure Simprocs where
|
|||
deriving Inhabited
|
||||
|
||||
structure Methods where
|
||||
pre : Expr → SimpM Step := fun e => return Step.visit { expr := e }
|
||||
post : Expr → SimpM Step := fun e => return Step.done { expr := e }
|
||||
pre : Simproc := fun _ => return .continue
|
||||
post : Simproc := fun e => return .done { expr := e }
|
||||
discharge? : Expr → SimpM (Option Expr) := fun _ => return none
|
||||
simprocs : Simprocs := {}
|
||||
deriving Inhabited
|
||||
|
||||
unsafe def Methods.toMethodsRefImpl (m : Methods) : MethodsRef :=
|
||||
|
|
@ -259,8 +311,8 @@ def congrArgs (r : Result) (args : Array Expr) : SimpM Result := do
|
|||
let mut r := r
|
||||
let mut i := 0
|
||||
for arg in args do
|
||||
trace[Debug.Meta.Tactic.simp] "app [{i}] {infos.size} {arg} hasFwdDeps: {infos[i]!.hasFwdDeps}"
|
||||
if h : i < infos.size then
|
||||
trace[Debug.Meta.Tactic.simp] "app [{i}] {infos.size} {arg} hasFwdDeps: {infos[i].hasFwdDeps}"
|
||||
let info := infos[i]
|
||||
let go : SimpM Result := do
|
||||
if !info.hasFwdDeps then
|
||||
|
|
@ -433,6 +485,8 @@ def Step.addExtraArgs (s : Step) (extraArgs : Array Expr) : MetaM Step := do
|
|||
match s with
|
||||
| .visit r => return .visit (← r.addExtraArgs extraArgs)
|
||||
| .done r => return .done (← r.addExtraArgs extraArgs)
|
||||
| .continue none => return .continue none
|
||||
| .continue (some r) => return .continue (← r.addExtraArgs extraArgs)
|
||||
|
||||
end Simp
|
||||
|
||||
|
|
|
|||
|
|
@ -23,15 +23,12 @@ def simpMatch (e : Expr) : MetaM Simp.Result := do
|
|||
where
|
||||
pre (e : Expr) : SimpM Simp.Step := do
|
||||
unless (← isMatcherApp e) do
|
||||
return Simp.Step.visit { expr := e }
|
||||
return Simp.Step.continue
|
||||
let matcherDeclName := e.getAppFn.constName!
|
||||
-- First try to reduce matcher
|
||||
match (← reduceRecMatcher? e) with
|
||||
| some e' => return Simp.Step.done { expr := e' }
|
||||
| none =>
|
||||
match (← Simp.simpMatchCore? matcherDeclName e SplitIf.discharge?) with
|
||||
| some r => return r
|
||||
| none => return Simp.Step.visit { expr := e }
|
||||
| none => Simp.simpMatchCore matcherDeclName SplitIf.discharge? e
|
||||
|
||||
def simpMatchTarget (mvarId : MVarId) : MetaM MVarId := mvarId.withContext do
|
||||
let target ← instantiateMVars (← mvarId.getType)
|
||||
|
|
@ -45,7 +42,7 @@ where
|
|||
if e.isAppOf matchDeclName then
|
||||
-- First try to reduce matcher
|
||||
match (← reduceRecMatcher? e) with
|
||||
| some e' => return Simp.Step.done { expr := e' }
|
||||
| some e' => return .done { expr := e' }
|
||||
| none =>
|
||||
-- Try lemma
|
||||
let simpTheorem := {
|
||||
|
|
@ -54,10 +51,10 @@ where
|
|||
rfl := (← isRflTheorem matchEqDeclName)
|
||||
}
|
||||
match (← withReducible <| Simp.tryTheorem? e simpTheorem SplitIf.discharge?) with
|
||||
| none => return Simp.Step.visit { expr := e }
|
||||
| some r => return Simp.Step.done r
|
||||
| none => return .continue
|
||||
| some r => return .done r
|
||||
else
|
||||
return Simp.Step.visit { expr := e }
|
||||
return .continue
|
||||
|
||||
private def simpMatchTargetCore (mvarId : MVarId) (matchDeclName : Name) (matchEqDeclName : Name) : MetaM MVarId := do
|
||||
mvarId.withContext do
|
||||
|
|
|
|||
|
|
@ -25,9 +25,9 @@ where
|
|||
match (← withReducible <| Simp.tryTheorem? e { origin := .decl unfoldThm, proof := mkConst unfoldThm, rfl := (← isRflTheorem unfoldThm) } (fun _ => return none)) with
|
||||
| none => pure ()
|
||||
| some r => match (← reduceMatcher? r.expr) with
|
||||
| .reduced e' => return Simp.Step.done { r with expr := e' }
|
||||
| _ => return Simp.Step.done r
|
||||
return Simp.Step.visit { expr := e }
|
||||
| .reduced e' => return .done { r with expr := e' }
|
||||
| _ => return .done r
|
||||
return .continue
|
||||
|
||||
def unfoldTarget (mvarId : MVarId) (declName : Name) : MetaM MVarId := mvarId.withContext do
|
||||
let target ← instantiateMVars (← mvarId.getType)
|
||||
|
|
|
|||
|
|
@ -131,6 +131,8 @@ is `ConstructorVal` for `Nat.succ`, and the array `#[1]`. The parameter `useRaw`
|
|||
numeral is represented. If `useRaw := false`, then `mkNatLit` is used, otherwise `mkRawNatLit`.
|
||||
Recall that `mkNatLit` uses the `OfNat.ofNat` application which is the canonical way of representing numerals
|
||||
in the elaborator and tactic framework. We `useRaw := false` in the compiler (aka code generator).
|
||||
|
||||
Remark: This function does not treat `(ofNat 0 : Nat)` applications as constructors.
|
||||
-/
|
||||
def constructorApp? (env : Environment) (e : Expr) (useRaw := false) : Option (ConstructorVal × Array Expr) := do
|
||||
match e with
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue