Compare commits

...

4 Commits

Author SHA1 Message Date
Leonardo de Moura
c08f9df147 chore: update stage0 2024-03-02 09:37:46 -08:00
Leonardo de Moura
5fbb4f5f10 fix: propagate expected type at do-match_expr 2024-03-02 09:35:35 -08:00
Leonardo de Moura
efe5fe74a9 chore: use __do_jp workaround, and "implementation detail" variables at match_expr macro 2024-03-02 09:27:45 -08:00
Leonardo de Moura
124505e27a chore: use let_expr to cleanup code 2024-03-02 08:58:26 -08:00
37 changed files with 119 additions and 111 deletions

View File

@@ -1157,7 +1157,7 @@ where
let d' `(discr)
let mut termAlts := #[]
for alt in alts do
let rhs toTerm alt.rhs
let rhs `(($( toTerm alt.rhs) : $(( read).m) _))
let optVar := if let some var := alt.var? then mkNullNode #[var, mkAtomFrom var "@"] else mkNullNode #[]
let pat := mkNode ``Parser.Term.matchExprPat #[optVar, alt.funName, mkNullNode alt.pvars]
let termAlt := mkNode ``Parser.Term.matchExprAlt #[mkAtomFrom alt.ref "|", pat, mkAtomFrom alt.ref "=>", rhs]

View File

@@ -112,7 +112,10 @@ Creates a fresh identifier for representing the continuation function used to
execute the RHS of the given alternative, and stores it in the field `k`.
-/
def initK (alt : Alt) : MacroM Alt := withFreshMacroScope do
let k : Ident `(k)
-- Remark: the compiler frontend implemented in C++ currently detects jointpoints created by
-- the "do" notation by testing the name. See hack at method `visit_let` at `lcnf.cpp`
-- We will remove this hack when we re-implement the compiler frontend in Lean.
let k : Ident `(__do_jp)
return { alt with k }
/--
@@ -153,8 +156,11 @@ alternatives `alts`, and else-alternative `elseAlt`.
-/
partial def generate (discr : Term) (alts : List Alt) (elseAlt : ElseAlt) : MacroM Syntax := do
let alts alts.mapM initK
let discr' `(discr)
let kElse `(ke)
let discr' `(__discr)
-- Remark: the compiler frontend implemented in C++ currently detects jointpoints created by
-- the "do" notation by testing the name. See hack at method `visit_let` at `lcnf.cpp`
-- We will remove this hack when we re-implement the compiler frontend in Lean.
let kElse `(__do_jp)
let rec loop (discr : Term) (alts : List Alt) : MacroM Term := withFreshMacroScope do
let funNamesToMatch := getFunNamesToMatch alts
let saveActual := shouldSaveActual alts
@@ -163,12 +169,12 @@ partial def generate (discr : Term) (alts : List Alt) (elseAlt : ElseAlt) : Macr
let body if altsNext.isEmpty then
`($kElse ())
else
let discr' `(discr)
let discr' `(__discr)
let body loop discr' altsNext
if saveActual then
`(if h : ($discr).isApp then let a := Expr.appArg $discr h; let discr := Expr.appFnCleanup $discr h; $body else $kElse ())
`(if h : ($discr).isApp then let a := Expr.appArg $discr h; let __discr := Expr.appFnCleanup $discr h; $body else $kElse ())
else
`(if h : ($discr).isApp then let discr := Expr.appFnCleanup $discr h; $body else $kElse ())
`(if h : ($discr).isApp then let __discr := Expr.appFnCleanup $discr h; $body else $kElse ())
let mut result := body
for funName in funNamesToMatch do
if let some alt := getAltFor? alts funName then
@@ -176,7 +182,7 @@ partial def generate (discr : Term) (alts : List Alt) (elseAlt : ElseAlt) : Macr
result `(if ($discr).isConstOf $(toDoubleQuotedName funName) then $alt.k $actuals* else $result)
return result
let body loop discr' alts
let mut result `(let_delayed ke := fun (_ : Unit) => $(elseAlt.rhs):term; let discr := Expr.cleanupAnnotations $discr:term; $body:term)
let mut result `(let_delayed __do_jp := fun (_ : Unit) => $(elseAlt.rhs):term; let __discr := Expr.cleanupAnnotations $discr:term; $body:term)
for alt in alts do
let params getParams alt
result `(let_delayed $alt.k:ident := fun $params:term* => $(alt.rhs):term; $result:term)

View File

@@ -802,10 +802,8 @@ partial def mkDefaultValueAux? (struct : Struct) : Expr → TermElabM (Option Ex
let arg mkFreshExprMVar d
mkDefaultValueAux? struct (b.instantiate1 arg)
| e =>
if e.isAppOfArity ``id 2 then
return some e.appArg!
else
return some e
let_expr id _ a := e | return some e
return some a
def mkDefaultValue? (struct : Struct) (cinfo : ConstantInfo) : TermElabM (Option Expr) :=
withRef struct.ref do

View File

@@ -1075,33 +1075,6 @@ def isAppOfArity' : Expr → Name → Nat → Bool
| app f _, n, a+1 => isAppOfArity' f n a
| _, _, _ => false
/--
Checks if an expression is a "natural number numeral in normal form",
i.e. of type `Nat`, and explicitly of the form `OfNat.ofNat n`
where `n` matches `.lit (.natVal n)` for some literal natural number `n`.
and if so returns `n`.
-/
-- Note that `Expr.lit (.natVal n)` is not considered in normal form!
def nat? (e : Expr) : Option Nat := do
guard <| e.isAppOfArity ``OfNat.ofNat 3
let lit (.natVal n) := e.appFn!.appArg! | none
n
/--
Checks if an expression is an "integer numeral in normal form",
i.e. of type `Nat` or `Int`, and either a natural number numeral in normal form (as specified by `nat?`),
or the negation of a positive natural number numberal in normal form,
and if so returns the integer.
-/
def int? (e : Expr) : Option Int :=
if e.isAppOfArity ``Neg.neg 3 then
match e.appArg!.nat? with
| none => none
| some 0 => none
| some n => some (-n)
else
e.nat?
private def getAppNumArgsAux : Expr Nat Nat
| app f _, n => getAppNumArgsAux f (n+1)
| _, n => n
@@ -1638,6 +1611,31 @@ def isFalse (e : Expr) : Bool :=
def isTrue (e : Expr) : Bool :=
e.cleanupAnnotations.isConstOf ``True
/--
Checks if an expression is a "natural number numeral in normal form",
i.e. of type `Nat`, and explicitly of the form `OfNat.ofNat n`
where `n` matches `.lit (.natVal n)` for some literal natural number `n`.
and if so returns `n`.
-/
-- Note that `Expr.lit (.natVal n)` is not considered in normal form!
def nat? (e : Expr) : Option Nat := do
let_expr OfNat.ofNat _ n _ := e | failure
let lit (.natVal n) := n | failure
n
/--
Checks if an expression is an "integer numeral in normal form",
i.e. of type `Nat` or `Int`, and either a natural number numeral in normal form (as specified by `nat?`),
or the negation of a positive natural number numberal in normal form,
and if so returns the integer.
-/
def int? (e : Expr) : Option Int :=
let_expr Neg.neg _ _ a := e | e.nat?
match a.nat? with
| none => none
| some 0 => none
| some n => some (-n)
/-- Return true iff `e` contains a free variable which satisfies `p`. -/
@[inline] def hasAnyFVar (e : Expr) (p : FVarId Bool) : Bool :=
let rec @[specialize] visit (e : Expr) := if !e.hasFVar then false else

View File

@@ -26,10 +26,8 @@ private def mkAnd? (args : Array Expr) : Option Expr := Id.run do
def elimOptParam (type : Expr) : CoreM Expr := do
Core.transform type fun e =>
if e.isAppOfArity ``optParam 2 then
return TransformStep.visit (e.getArg! 0)
else
return .continue
let_expr optParam _ a := e | return .continue
return TransformStep.visit a
private partial def mkInjectiveTheoremTypeCore? (ctorVal : ConstructorVal) (useEq : Bool) : MetaM (Option Expr) := do
let us := ctorVal.levelParams.map mkLevelParam

View File

@@ -27,11 +27,10 @@ def getRawNatValue? (e : Expr) : Option Nat :=
/-- Return `some (n, type)` if `e` is an `OfNat.ofNat`-application encoding `n` for a type with name `typeDeclName`. -/
def getOfNatValue? (e : Expr) (typeDeclName : Name) : MetaM (Option (Nat × Expr)) := OptionT.run do
let e := e.consumeMData
guard <| e.isAppOfArity' ``OfNat.ofNat 3
let type whnfD (e.getArg!' 0)
let_expr OfNat.ofNat type n _ e | failure
let type whnfD type
guard <| type.getAppFn.isConstOf typeDeclName
let .lit (.natVal n) := (e.getArg!' 1).consumeMData | failure
let .lit (.natVal n) := n.consumeMData | failure
return (n, type)
/-- Return `some n` if `e` is a raw natural number or an `OfNat.ofNat`-application encoding `n`. -/
@@ -46,16 +45,15 @@ def getNatValue? (e : Expr) : MetaM (Option Nat) := do
def getIntValue? (e : Expr) : MetaM (Option Int) := do
if let some (n, _) getOfNatValue? e ``Int then
return some n
if e.isAppOfArity' ``Neg.neg 3 then
let some (n, _) getOfNatValue? (e.getArg!' 2) ``Int | return none
return some (-n)
return none
let_expr Neg.neg _ _ a e | return none
let some (n, _) getOfNatValue? a ``Int | return none
return some (-n)
/-- Return `some c` if `e` is a `Char.ofNat`-application encoding character `c`. -/
def getCharValue? (e : Expr) : MetaM (Option Char) := OptionT.run do
guard <| e.isAppOfArity' ``Char.ofNat 1
let n getNatValue? (e.getArg!' 0)
return Char.ofNat n
def getCharValue? (e : Expr) : MetaM (Option Char) := do
let_expr Char.ofNat n e | return none
let some n getNatValue? n | return none
return some (Char.ofNat n)
/-- Return `some s` if `e` is of the form `.lit (.strVal s)`. -/
def getStringValue? (e : Expr) : (Option String) :=

View File

@@ -162,42 +162,42 @@ builtin_simproc [simp, seval] reduceRotateRight (BitVec.rotateRight _ _) :=
/-- Simplification procedure for append on `BitVec`. -/
builtin_simproc [simp, seval] reduceAppend ((_ ++ _ : BitVec _)) := fun e => do
unless e.isAppOfArity ``HAppend.hAppend 6 do return .continue
let some v₁ fromExpr? e.appFn!.appArg! | return .continue
let some v₂ fromExpr? e.appArg! | return .continue
let_expr HAppend.hAppend _ _ _ _ a b e | return .continue
let some v₁ fromExpr? a | return .continue
let some v₂ fromExpr? b | return .continue
return .done { expr := toExpr (v₁.value ++ v₂.value) }
/-- Simplification procedure for casting `BitVec`s along an equality of the size. -/
builtin_simproc [simp, seval] reduceCast (cast _ _) := fun e => do
unless e.isAppOfArity ``cast 4 do return .continue
let some v fromExpr? e.appArg! | return .continue
let some m Nat.fromExpr? e.appFn!.appFn!.appArg! | return .continue
let_expr cast _ m _ v e | return .continue
let some v fromExpr? v | return .continue
let some m Nat.fromExpr? m | return .continue
return .done { expr := toExpr (BitVec.ofNat m v.value.toNat) }
/-- Simplification procedure for `BitVec.toNat`. -/
builtin_simproc [simp, seval] reduceToNat (BitVec.toNat _) := fun e => do
unless e.isAppOfArity ``BitVec.toNat 2 do return .continue
let some v fromExpr? e.appArg! | return .continue
let_expr BitVec.toNat _ v e | return .continue
let some v fromExpr? v | return .continue
return .done { expr := mkNatLit v.value.toNat }
/-- Simplification procedure for `BitVec.toInt`. -/
builtin_simproc [simp, seval] reduceToInt (BitVec.toInt _) := fun e => do
unless e.isAppOfArity ``BitVec.toInt 2 do return .continue
let some v fromExpr? e.appArg! | return .continue
let_expr BitVec.toInt _ v e | return .continue
let some v fromExpr? v | return .continue
return .done { expr := toExpr v.value.toInt }
/-- Simplification procedure for `BitVec.ofInt`. -/
builtin_simproc [simp, seval] reduceOfInt (BitVec.ofInt _ _) := fun e => do
unless e.isAppOfArity ``BitVec.ofInt 2 do return .continue
let some n Nat.fromExpr? e.appFn!.appArg! | return .continue
let some i Int.fromExpr? e.appArg! | return .continue
let_expr BitVec.ofInt n i e | return .continue
let some n Nat.fromExpr? n | return .continue
let some i Int.fromExpr? i | return .continue
return .done { expr := toExpr (BitVec.ofInt n i) }
/-- Simplification procedure for ensuring `BitVec.ofNat` literals are normalized. -/
builtin_simproc [simp, seval] reduceOfNat (BitVec.ofNat _ _) := fun e => do
unless e.isAppOfArity ``BitVec.ofNat 2 do return .continue
let some n Nat.fromExpr? e.appFn!.appArg! | return .continue
let some v Nat.fromExpr? e.appArg! | return .continue
let_expr BitVec.ofNat n v e | return .continue
let some n Nat.fromExpr? n | return .continue
let some v Nat.fromExpr? v | return .continue
let bv := BitVec.ofNat n v
if bv.toNat == v then return .continue -- already normalized
return .done { expr := toExpr (BitVec.ofNat n v) }
@@ -226,9 +226,9 @@ builtin_simproc [simp, seval] reduceSLE (BitVec.sle _ _) :=
/-- Simplification procedure for `zeroExtend'` on `BitVec`s. -/
builtin_simproc [simp, seval] reduceZeroExtend' (zeroExtend' _ _) := fun e => do
unless e.isAppOfArity ``zeroExtend' 4 do return .continue
let some v fromExpr? e.appArg! | return .continue
let some w Nat.fromExpr? e.appFn!.appFn!.appArg! | return .continue
let_expr zeroExtend' _ w _ v e | return .continue
let some v fromExpr? v | return .continue
let some w Nat.fromExpr? w | return .continue
if h : v.n w then
return .done { expr := toExpr (v.value.zeroExtend' h) }
else
@@ -236,25 +236,25 @@ builtin_simproc [simp, seval] reduceZeroExtend' (zeroExtend' _ _) := fun e => do
/-- Simplification procedure for `shiftLeftZeroExtend` on `BitVec`s. -/
builtin_simproc [simp, seval] reduceShiftLeftZeroExtend (shiftLeftZeroExtend _ _) := fun e => do
unless e.isAppOfArity ``shiftLeftZeroExtend 3 do return .continue
let some v fromExpr? e.appFn!.appArg! | return .continue
let some m Nat.fromExpr? e.appArg! | return .continue
let_expr shiftLeftZeroExtend _ v m e | return .continue
let some v fromExpr? v | return .continue
let some m Nat.fromExpr? m | return .continue
return .done { expr := toExpr (v.value.shiftLeftZeroExtend m) }
/-- Simplification procedure for `extractLsb'` on `BitVec`s. -/
builtin_simproc [simp, seval] reduceExtracLsb' (extractLsb' _ _ _) := fun e => do
unless e.isAppOfArity ``extractLsb' 4 do return .continue
let some v fromExpr? e.appArg! | return .continue
let some start Nat.fromExpr? e.appFn!.appFn!.appArg! | return .continue
let some len Nat.fromExpr? e.appFn!.appArg! | return .continue
let_expr extractLsb' _ start len v e | return .continue
let some v fromExpr? v | return .continue
let some start Nat.fromExpr? start | return .continue
let some len Nat.fromExpr? len | return .continue
return .done { expr := toExpr (v.value.extractLsb' start len) }
/-- Simplification procedure for `replicate` on `BitVec`s. -/
builtin_simproc [simp, seval] reduceReplicate (replicate _ _) := fun e => do
unless e.isAppOfArity ``replicate 3 do return .continue
let some v fromExpr? e.appArg! | return .continue
let some w Nat.fromExpr? e.appFn!.appArg! | return .continue
return .done { expr := toExpr (v.value.replicate w) }
let_expr replicate _ i v e | return .continue
let some v fromExpr? v | return .continue
let some i Nat.fromExpr? i | return .continue
return .done { expr := toExpr (v.value.replicate i) }
/-- Simplification procedure for `zeroExtend` on `BitVec`s. -/
builtin_simproc [simp, seval] reduceZeroExtend (zeroExtend _ _) := reduceExtend ``zeroExtend zeroExtend
@@ -264,8 +264,8 @@ builtin_simproc [simp, seval] reduceSignExtend (signExtend _ _) := reduceExtend
/-- Simplification procedure for `allOnes` -/
builtin_simproc [simp, seval] reduceAllOnes (allOnes _) := fun e => do
unless e.isAppOfArity ``allOnes 1 do return .continue
let some n Nat.fromExpr? e.appArg! | return .continue
let_expr allOnes n e | return .continue
let some n Nat.fromExpr? n | return .continue
return .done { expr := toExpr (allOnes n) }
end BitVec

View File

@@ -42,8 +42,8 @@ builtin_simproc [simp, seval] reduceIsDigit (Char.isDigit _) := reduceUnary ``Ch
builtin_simproc [simp, seval] reduceIsAlphaNum (Char.isAlphanum _) := reduceUnary ``Char.isAlphanum Char.isAlphanum
builtin_simproc [simp, seval] reduceToString (toString (_ : Char)) := reduceUnary ``toString toString 3
builtin_simproc [simp, seval] reduceVal (Char.val _) := fun e => do
unless e.isAppOfArity ``Char.val 1 do return .continue
let some c fromExpr? e.appArg! | return .continue
let_expr Char.val arg e | return .continue
let some c fromExpr? arg | return .continue
return .done { expr := toExpr c.val }
builtin_simproc [simp, seval] reduceEq (( _ : Char) = _) := reduceBinPred ``Eq 3 (. = .)
builtin_simproc [simp, seval] reduceNe (( _ : Char) _) := reduceBinPred ``Ne 3 (. .)
@@ -60,12 +60,12 @@ builtin_simproc ↓ [simp, seval] isValue (Char.ofNat _ ) := fun e => do
return .done { expr := e }
builtin_simproc [simp, seval] reduceOfNatAux (Char.ofNatAux _ _) := fun e => do
unless e.isAppOfArity ``Char.ofNatAux 2 do return .continue
let some n Nat.fromExpr? e.appFn!.appArg! | return .continue
let_expr Char.ofNatAux n _ e | return .continue
let some n Nat.fromExpr? n | return .continue
return .done { expr := toExpr (Char.ofNat n) }
builtin_simproc [simp, seval] reduceDefault ((default : Char)) := fun e => do
unless e.isAppOfArity ``default 2 do return .continue
let_expr default _ _ e | return .continue
return .done { expr := toExpr (default : Char) }
end Char

View File

@@ -10,33 +10,29 @@ import Lean.Meta.Tactic.Simp.Simproc
open Lean Meta Simp
builtin_simproc [simp, seval] reduceIte (ite _ _ _) := fun e => do
unless e.isAppOfArity ``ite 5 do return .continue
let c := e.getArg! 1
let_expr f@ite α c i tb eb e | return .continue
let r simp c
if r.expr.isTrue then
let eNew := e.getArg! 3
let pr := mkApp (mkAppN (mkConst ``ite_cond_eq_true e.getAppFn.constLevels!) e.getAppArgs) ( r.getProof)
return .visit { expr := eNew, proof? := pr }
let pr := mkApp (mkApp5 (mkConst ``ite_cond_eq_true f.constLevels!) α c i tb eb) ( r.getProof)
return .visit { expr := tb, proof? := pr }
if r.expr.isFalse then
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 }
let pr := mkApp (mkApp5 (mkConst ``ite_cond_eq_false f.constLevels!) α c i tb eb) ( r.getProof)
return .visit { expr := eb, proof? := pr }
return .continue
builtin_simproc [simp, seval] reduceDite (dite _ _ _) := fun e => do
unless e.isAppOfArity ``dite 5 do return .continue
let c := e.getArg! 1
let_expr f@dite α c i tb eb e | return .continue
let r simp c
if r.expr.isTrue then
let pr r.getProof
let h := mkApp2 (mkConst ``of_eq_true) c pr
let eNew := mkApp (e.getArg! 3) h |>.headBeta
let prNew := mkApp (mkAppN (mkConst ``dite_cond_eq_true e.getAppFn.constLevels!) e.getAppArgs) pr
let eNew := mkApp tb h |>.headBeta
let prNew := mkApp (mkApp5 (mkConst ``dite_cond_eq_true f.constLevels!) α c i tb eb) pr
return .visit { expr := eNew, proof? := prNew }
if r.expr.isFalse then
let pr r.getProof
let h := mkApp2 (mkConst ``of_eq_false) c pr
let eNew := mkApp (e.getArg! 4) h |>.headBeta
let prNew := mkApp (mkAppN (mkConst ``dite_cond_eq_false e.getAppFn.constLevels!) e.getAppArgs) pr
let eNew := mkApp eb h |>.headBeta
let prNew := mkApp (mkApp5 (mkConst ``dite_cond_eq_false f.constLevels!) α c i tb eb) pr
return .visit { expr := eNew, proof? := prNew }
return .continue

View File

@@ -57,7 +57,7 @@ builtin_simproc [simp, seval] reduceNeg ((- _ : Int)) := fun e => do
/-- Return `.done` for positive Int values. We don't want to unfold in the symbolic evaluator. -/
builtin_simproc [seval] isPosValue ((OfNat.ofNat _ : Int)) := fun e => do
unless e.isAppOfArity ``OfNat.ofNat 3 do return .continue
let_expr OfNat.ofNat _ _ _ e | return .continue
return .done { expr := e }
builtin_simproc [simp, seval] reduceAdd ((_ + _ : Int)) := reduceBin ``HAdd.hAdd 6 (· + ·)
@@ -67,9 +67,9 @@ builtin_simproc [simp, seval] reduceDiv ((_ / _ : Int)) := reduceBin ``HDiv.hDiv
builtin_simproc [simp, seval] reduceMod ((_ % _ : Int)) := reduceBin ``HMod.hMod 6 (· % ·)
builtin_simproc [simp, seval] 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
let_expr HPow.hPow _ _ _ _ a b e | return .continue
let some v₁ fromExpr? a | return .continue
let some v₂ Nat.fromExpr? b | return .continue
return .done { expr := toExpr (v₁ ^ v₂) }
builtin_simproc [simp, seval] reduceLT (( _ : Int) < _) := reduceBinPred ``LT.lt 4 (. < .)

View File

@@ -65,7 +65,7 @@ builtin_simproc [simp, seval] reduceBNe (( _ : Nat) != _) := reduceBoolPred ``
/-- Return `.done` for Nat values. We don't want to unfold in the symbolic evaluator. -/
builtin_simproc [seval] isValue ((OfNat.ofNat _ : Nat)) := fun e => do
unless e.isAppOfArity ``OfNat.ofNat 3 do return .continue
let_expr OfNat.ofNat _ _ _ e | return .continue
return .done { expr := e }
end Nat

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

View File

@@ -0,0 +1,14 @@
import Lean
open Lean Meta Simp
def foo' (e : Expr) : SimpM Step := do
let_expr Neg.neg _ _ arg e | return .continue
match_expr arg with
| OfNat.ofNat _ _ _ => return .done { expr := e }
| _ =>
let some v getIntValue? arg | return .continue
if v < 0 then
return .done { expr := toExpr (- v) }
else
return .done { expr := toExpr v }