Add files using upload-large-folder tool

.gitattributes

@@ -4387,3 +4387,5 @@ backend/core/leanprover--lean4---v4.22.0/lib/lean/Std/Tactic/BVDecide/Bitblast/B
 backend/core/leanprover--lean4---v4.22.0/lib/lean/Std/Tactic/BVDecide/Reflect.olean filter=lfs diff=lfs merge=lfs -text
 backend/core/leanprover--lean4---v4.22.0/lib/lean/Std/Tactic/BVDecide/LRAT/Internal/Convert.olean filter=lfs diff=lfs merge=lfs -text
 backend/core/leanprover--lean4---v4.22.0/lib/lean/Std/Data/HashSet/Raw.olean filter=lfs diff=lfs merge=lfs -text
+external/alphageometry/.venv-ag/Lib/site-packages/numpy.libs/libscipy_openblas64_-13e2df515630b4a41f92893938845698.dll filter=lfs diff=lfs merge=lfs -text
+external/alphageometry/.venv-ag/Lib/site-packages/numpy.libs/msvcp140-263139962577ecda4cd9469ca360a746.dll filter=lfs diff=lfs merge=lfs -text

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/Boxing.lean

@@ -0,0 +1,346 @@
+/-
+Copyright (c) 2019 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Runtime
+import Lean.Compiler.ClosedTermCache
+import Lean.Compiler.ExternAttr
+import Lean.Compiler.IR.Basic
+import Lean.Compiler.IR.CompilerM
+import Lean.Compiler.IR.FreeVars
+import Lean.Compiler.IR.ElimDeadVars
+import Lean.Data.AssocList
+
+namespace Lean.IR.ExplicitBoxing
+/-!
+Add explicit boxing and unboxing instructions.
+Recall that the Lean to λ_pure compiler produces code without these instructions.
+
+Assumptions:
+- This transformation is applied before explicit RC instructions (`inc`, `dec`) are inserted.
+- This transformation is applied before `FnBody.case` has been simplified and `Alt.default` is used.
+  Reason: if there is no `Alt.default` branch, then we can decide whether `x` at `FnBody.case x alts` is an
+  enumeration type by simply inspecting the `CtorInfo` values at `alts`.
+- This transformation is applied before lower level optimizations are applied which use
+  `Expr.isShared`, `Expr.isTaggedPtr`, and `FnBody.set`.
+- This transformation is applied after `reset` and `reuse` instructions have been added.
+  Reason: `resetreuse.lean` ignores `box` and `unbox` instructions.
+-/
+
+def mkBoxedName (n : Name) : Name :=
+  Name.mkStr n "_boxed"
+
+def isBoxedName (name : Name) : Bool :=
+  name matches .str _ "_boxed"
+
+abbrev N := StateM Nat
+
+private def N.mkFresh : N VarId :=
+  modifyGet fun n => ({ idx := n }, n + 1)
+
+def requiresBoxedVersion (env : Environment) (decl : Decl) : Bool :=
+  let ps := decl.params
+  (ps.size > 0 && (decl.resultType.isScalar || ps.any (fun p => p.ty.isScalar || p.borrow) || isExtern env decl.name))
+  || ps.size > closureMaxArgs
+
+def mkBoxedVersionAux (decl : Decl) : N Decl := do
+  let ps := decl.params
+  let qs ← ps.mapM fun _ => do let x ← N.mkFresh; pure { x := x, ty := IRType.object, borrow := false : Param }
+  let (newVDecls, xs) ← qs.size.foldM (init := (#[], #[])) fun i _ (newVDecls, xs) => do
+    let p := ps[i]!
+    let q := qs[i]
+    if !p.ty.isScalar then
+      pure (newVDecls, xs.push (Arg.var q.x))
+    else
+      let x ← N.mkFresh
+      pure (newVDecls.push (FnBody.vdecl x p.ty (Expr.unbox q.x) default), xs.push (Arg.var x))
+  let r ← N.mkFresh
+  let newVDecls := newVDecls.push (FnBody.vdecl r decl.resultType (Expr.fap decl.name xs) default)
+  let body ← if !decl.resultType.isScalar then
+    pure <| reshape newVDecls (FnBody.ret (Arg.var r))
+  else
+    let newR ← N.mkFresh
+    let newVDecls := newVDecls.push (FnBody.vdecl newR IRType.object (Expr.box decl.resultType r) default)
+    pure <| reshape newVDecls (FnBody.ret (Arg.var newR))
+  return Decl.fdecl (mkBoxedName decl.name) qs IRType.object body decl.getInfo
+
+def mkBoxedVersion (decl : Decl) : Decl :=
+  (mkBoxedVersionAux decl).run' 1
+
+def addBoxedVersions (env : Environment) (decls : Array Decl) : Array Decl :=
+  let boxedDecls := decls.foldl (init := #[]) fun newDecls decl =>
+    if requiresBoxedVersion env decl then newDecls.push (mkBoxedVersion decl) else newDecls
+  decls ++ boxedDecls
+
+/-- Infer scrutinee type using `case` alternatives.
+   This can be done whenever `alts` does not contain an `Alt.default _` value. -/
+def getScrutineeType (alts : Array Alt) : IRType :=
+  let isScalar :=
+     alts.size > 1 && -- Recall that we encode Unit and PUnit using `object`.
+     alts.all fun
+      | Alt.ctor c _  => c.isScalar
+      | Alt.default _ => false
+  match isScalar with
+  | false => IRType.object
+  | true  =>
+    let n := alts.size
+    if n < 256 then IRType.uint8
+    else if n < 65536 then IRType.uint16
+    else if n < 4294967296 then IRType.uint32
+    else IRType.object -- in practice this should be unreachable
+
+def eqvTypes (t₁ t₂ : IRType) : Bool :=
+  (t₁.isScalar == t₂.isScalar) && (!t₁.isScalar || t₁ == t₂)
+
+structure BoxingContext where
+  f : FunId := default
+  localCtx : LocalContext := {}
+  resultType : IRType := IRType.irrelevant
+  decls : Array Decl
+  env : Environment
+
+structure BoxingState where
+  nextIdx : Index
+  /-- We create auxiliary declarations when boxing constant and literals.
+     The idea is to avoid code such as
+     ```
+     let x1 := Uint64.inhabited;
+     let x2 := box x1;
+     ...
+     ```
+     We currently do not cache these declarations in an environment extension, but
+     we use auxDeclCache to avoid creating equivalent auxiliary declarations more than once when
+     processing the same IR declaration.
+  -/
+  auxDecls : Array Decl := #[]
+  auxDeclCache : AssocList FnBody Expr := AssocList.empty
+  nextAuxId : Nat := 1
+
+abbrev M := ReaderT BoxingContext (StateT BoxingState Id)
+
+private def M.mkFresh : M VarId := do
+  let oldS ← getModify fun s => { s with nextIdx := s.nextIdx + 1 }
+  pure { idx := oldS.nextIdx }
+
+def getEnv : M Environment := BoxingContext.env <$> read
+def getLocalContext : M LocalContext := BoxingContext.localCtx <$> read
+def getResultType : M IRType := BoxingContext.resultType <$> read
+
+def getVarType (x : VarId) : M IRType := do
+  let localCtx ← getLocalContext
+  match localCtx.getType x with
+  | some t => pure t
+  | none   => pure IRType.object -- unreachable, we assume the code is well formed
+
+def getJPParams (j : JoinPointId) : M (Array Param) := do
+  let localCtx ← getLocalContext
+  match localCtx.getJPParams j with
+  | some ys => pure ys
+  | none    => pure #[] -- unreachable, we assume the code is well formed
+
+def getDecl (fid : FunId) : M Decl := do
+  let ctx ← read
+  match findEnvDecl' ctx.env fid ctx.decls with
+  | some decl => pure decl
+  | none      => pure default -- unreachable if well-formed
+
+@[inline] def withParams {α : Type} (xs : Array Param) (k : M α) : M α :=
+  withReader (fun ctx => { ctx with localCtx := ctx.localCtx.addParams xs }) k
+
+@[inline] def withVDecl {α : Type} (x : VarId) (ty : IRType) (v : Expr) (k : M α) : M α :=
+  withReader (fun ctx => { ctx with localCtx := ctx.localCtx.addLocal x ty v }) k
+
+@[inline] def withJDecl {α : Type} (j : JoinPointId) (xs : Array Param) (v : FnBody) (k : M α) : M α :=
+  withReader (fun ctx => { ctx with localCtx := ctx.localCtx.addJP j xs v }) k
+
+/-- If `x` declaration is of the form `x := Expr.lit _` or `x := Expr.fap c #[]`,
+   and `x`'s type is not cheap to box (e.g., it is `UInt64), then return its value. -/
+private def isExpensiveConstantValueBoxing (x : VarId) (xType : IRType) : M (Option Expr) :=
+  if !xType.isScalar then
+    return none -- We assume unboxing is always cheap
+  else match xType with
+    | IRType.uint8  => return none
+    | IRType.uint16 => return none
+    | _ => do
+      let localCtx ← getLocalContext
+      match localCtx.getValue x with
+      | some val =>
+        match val with
+        | Expr.lit _ => return some val
+        | Expr.fap _ args => return if args.size == 0 then some val else none
+        | _ => return none
+      | _ => return none
+
+/-- Auxiliary function used by castVarIfNeeded.
+   It is used when the expected type does not match `xType`.
+   If `xType` is scalar, then we need to "box" it. Otherwise, we need to "unbox" it. -/
+def mkCast (x : VarId) (xType : IRType) (expectedType : IRType) : M Expr := do
+  match (← isExpensiveConstantValueBoxing x xType) with
+  | some v => do
+    let ctx ← read
+    let s ← get
+    /- Create auxiliary FnBody
+    ```
+    let x_1 : xType := v;
+    let x_2 : expectedType := Expr.box xType x_1;
+    ret x_2
+    ```
+    -/
+    let body : FnBody :=
+      FnBody.vdecl { idx := 1 } xType v $
+      FnBody.vdecl { idx := 2 } expectedType (Expr.box xType { idx := 1 }) $
+      FnBody.ret (mkVarArg { idx := 2 })
+    match s.auxDeclCache.find? body with
+    | some v => pure v
+    | none   => do
+      let auxName  := ctx.f ++ ((`_boxed_const).appendIndexAfter s.nextAuxId)
+      let auxConst := Expr.fap auxName #[]
+      let auxDecl  := Decl.fdecl auxName #[] expectedType body {}
+      modify fun s => { s with
+       auxDecls     := s.auxDecls.push auxDecl
+       auxDeclCache := s.auxDeclCache.cons body auxConst
+       nextAuxId    := s.nextAuxId + 1
+      }
+      pure auxConst
+  | none => pure $ if xType.isScalar then Expr.box xType x else Expr.unbox x
+
+@[inline] def castVarIfNeeded (x : VarId) (expected : IRType) (k : VarId → M FnBody) : M FnBody := do
+  let xType ← getVarType x
+  if eqvTypes xType expected then
+    k x
+  else
+    let y ← M.mkFresh
+    let v ← mkCast x xType expected
+    FnBody.vdecl y expected v <$> k y
+
+@[inline] def castArgIfNeeded (x : Arg) (expected : IRType) (k : Arg → M FnBody) : M FnBody :=
+  match x with
+  | Arg.var x => castVarIfNeeded x expected (fun x => k (Arg.var x))
+  | _         => k x
+
+def castArgsIfNeededAux (xs : Array Arg) (typeFromIdx : Nat → IRType) : M (Array Arg × Array FnBody) := do
+  let mut xs' := #[]
+  let mut bs  := #[]
+  let mut i   := 0
+  for x in xs do
+    let expected := typeFromIdx i
+    match x with
+    | Arg.irrelevant =>
+      xs' := xs'.push x
+    | Arg.var x =>
+      let xType ← getVarType x
+      if eqvTypes xType expected then
+        xs' := xs'.push (Arg.var x)
+      else
+        let y ← M.mkFresh
+        let v ← mkCast x xType expected
+        let b := FnBody.vdecl y expected v FnBody.nil
+        xs' := xs'.push (Arg.var y)
+        bs := bs.push b
+    i := i + 1
+  return (xs', bs)
+
+@[inline] def castArgsIfNeeded (xs : Array Arg) (ps : Array Param) (k : Array Arg → M FnBody) : M FnBody := do
+  let (ys, bs) ← castArgsIfNeededAux xs fun i => ps[i]!.ty
+  let b ← k ys
+  pure (reshape bs b)
+
+@[inline] def boxArgsIfNeeded (xs : Array Arg) (k : Array Arg → M FnBody) : M FnBody := do
+  let (ys, bs) ← castArgsIfNeededAux xs (fun _ => IRType.object)
+  let b ← k ys
+  pure (reshape bs b)
+
+def unboxResultIfNeeded (x : VarId) (ty : IRType) (e : Expr) (b : FnBody) : M FnBody := do
+  if ty.isScalar then
+    let y ← M.mkFresh
+    return FnBody.vdecl y IRType.object e (FnBody.vdecl x ty (Expr.unbox y) b)
+  else
+    return FnBody.vdecl x ty e b
+
+def castResultIfNeeded (x : VarId) (ty : IRType) (e : Expr) (eType : IRType) (b : FnBody) : M FnBody := do
+  if eqvTypes ty eType then
+    return FnBody.vdecl x ty e b
+  else
+    let y ← M.mkFresh
+    let v ← mkCast y eType ty
+    return FnBody.vdecl y eType e (FnBody.vdecl x ty v b)
+
+def visitVDeclExpr (x : VarId) (ty : IRType) (e : Expr) (b : FnBody) : M FnBody :=
+  match e with
+  | Expr.ctor c ys =>
+    if c.isScalar && ty.isScalar then
+      return FnBody.vdecl x ty (Expr.lit (LitVal.num c.cidx)) b
+    else
+      boxArgsIfNeeded ys fun ys => return FnBody.vdecl x ty (Expr.ctor c ys) b
+  | Expr.reuse w c u ys =>
+    boxArgsIfNeeded ys fun ys => return FnBody.vdecl x ty (Expr.reuse w c u ys) b
+  | Expr.fap f ys => do
+    let decl ← getDecl f
+    castArgsIfNeeded ys decl.params fun ys =>
+    castResultIfNeeded x ty (Expr.fap f ys) decl.resultType b
+  | Expr.pap f ys => do
+    let env ← getEnv
+    let decl ← getDecl f
+    let f := if requiresBoxedVersion env decl then mkBoxedName f else f
+    boxArgsIfNeeded ys fun ys => return FnBody.vdecl x ty (Expr.pap f ys) b
+  | Expr.ap f ys =>
+    boxArgsIfNeeded ys fun ys =>
+    unboxResultIfNeeded x ty (Expr.ap f ys) b
+  | _     =>
+    return FnBody.vdecl x ty e b
+
+partial def visitFnBody : FnBody → M FnBody
+  | FnBody.vdecl x t v b     => do
+    let b ← withVDecl x t v (visitFnBody b)
+    visitVDeclExpr x t v b
+  | FnBody.jdecl j xs v b    => do
+    let v ← withParams xs (visitFnBody v)
+    let b ← withJDecl j xs v (visitFnBody b)
+    return FnBody.jdecl j xs v b
+  | FnBody.uset x i y b      => do
+    let b ← visitFnBody b
+    castVarIfNeeded y IRType.usize fun y =>
+      return FnBody.uset x i y b
+  | FnBody.sset x i o y ty b => do
+    let b ← visitFnBody b
+    castVarIfNeeded y ty fun y =>
+      return FnBody.sset x i o y ty b
+  | FnBody.mdata d b         =>
+    FnBody.mdata d <$> visitFnBody b
+  | FnBody.case tid x _ alts   => do
+    let expected := getScrutineeType alts
+    let alts ← alts.mapM fun alt => alt.mmodifyBody visitFnBody
+    castVarIfNeeded x expected fun x => do
+      return FnBody.case tid x expected alts
+  | FnBody.ret x             => do
+    let expected ← getResultType
+    castArgIfNeeded x expected (fun x => return FnBody.ret x)
+  | FnBody.jmp j ys          => do
+    let ps ← getJPParams j
+    castArgsIfNeeded ys ps fun ys => return FnBody.jmp j ys
+  | other                    =>
+    pure other
+
+def run (env : Environment) (decls : Array Decl) : Array Decl :=
+  let ctx : BoxingContext := { decls := decls, env := env }
+  let decls := decls.foldl (init := #[]) fun newDecls decl =>
+    match decl with
+    | .fdecl (f := f) (xs := xs) (type := t) (body := b) .. =>
+      let nextIdx  := decl.maxIndex + 1
+      let (b, s)   := (withParams xs (visitFnBody b) { ctx with f := f, resultType := t }).run { nextIdx := nextIdx }
+      let newDecls := newDecls ++ s.auxDecls
+      let newDecl  := decl.updateBody! b
+      let newDecl  := newDecl.elimDead
+      newDecls.push newDecl
+    | d => newDecls.push d
+  addBoxedVersions env decls
+
+end ExplicitBoxing
+
+def explicitBoxing (decls : Array Decl) : CompilerM (Array Decl) := do
+  let env ← getEnv
+  return ExplicitBoxing.run env decls
+
+end Lean.IR

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/Checker.lean

@@ -0,0 +1,192 @@
+/-
+Copyright (c) 2019 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Compiler.IR.CompilerM
+import Lean.Compiler.IR.Format
+
+namespace Lean.IR.Checker
+
+@[extern "lean_get_max_ctor_fields"]
+opaque getMaxCtorFields : Unit → Nat
+def maxCtorFields := getMaxCtorFields ()
+
+@[extern "lean_get_max_ctor_scalars_size"]
+opaque getMaxCtorScalarsSize : Unit → Nat
+def maxCtorScalarsSize := getMaxCtorScalarsSize ()
+
+@[extern "lean_get_max_ctor_tag"]
+opaque getMaxCtorTag : Unit → Nat
+def maxCtorTag := getMaxCtorTag ()
+
+@[extern "lean_get_usize_size"]
+opaque getUSizeSize : Unit → Nat
+def usizeSize := getUSizeSize ()
+
+structure CheckerContext where
+  env : Environment
+  localCtx : LocalContext := {}
+  decls : Array Decl
+
+structure CheckerState where
+  foundVars : IndexSet := {}
+
+abbrev M := ReaderT CheckerContext (ExceptT String (StateT CheckerState Id))
+
+def markIndex (i : Index) : M Unit := do
+  let s ← get
+  if s.foundVars.contains i then
+    throw s!"variable / joinpoint index {i} has already been used"
+  modify fun s => { s with foundVars := s.foundVars.insert i }
+
+def markVar (x : VarId) : M Unit :=
+  markIndex x.idx
+
+def markJP (j : JoinPointId) : M Unit :=
+  markIndex j.idx
+
+def getDecl (c : Name) : M Decl := do
+  let ctx ← read
+  match findEnvDecl' ctx.env c ctx.decls with
+  | none   => throw s!"depends on declaration '{c}', which has no executable code; consider marking definition as 'noncomputable'"
+  | some d => pure d
+
+def checkVar (x : VarId) : M Unit := do
+  let ctx ← read
+  unless ctx.localCtx.isLocalVar x.idx || ctx.localCtx.isParam x.idx do
+   throw s!"unknown variable '{x}'"
+
+def checkJP (j : JoinPointId) : M Unit := do
+  let ctx ← read
+  unless ctx.localCtx.isJP j.idx do
+   throw s!"unknown join point '{j}'"
+
+def checkArg (a : Arg) : M Unit :=
+  match a with
+  | Arg.var x => checkVar x
+  | _ => pure ()
+
+def checkArgs (as : Array Arg) : M Unit :=
+  as.forM checkArg
+
+@[inline] def checkEqTypes (ty₁ ty₂ : IRType) : M Unit := do
+  unless ty₁ == ty₂ do
+    throw "unexpected type '{ty₁}' != '{ty₂}'"
+
+@[inline] def checkType (ty : IRType) (p : IRType → Bool) (suffix? : Option String := none): M Unit := do
+  unless p ty do
+   let mut msg := s!"unexpected type '{ty}'"
+   if let some suffix := suffix? then
+     msg := s!"{msg}, {suffix}"
+   throw msg
+
+def checkObjType (ty : IRType) : M Unit := checkType ty IRType.isObj "object expected"
+
+def checkScalarType (ty : IRType) : M Unit := checkType ty IRType.isScalar "scalar expected"
+
+def getType (x : VarId) : M IRType := do
+  let ctx ← read
+  match ctx.localCtx.getType x with
+  | some ty => pure ty
+  | none    => throw s!"unknown variable '{x}'"
+
+@[inline] def checkVarType (x : VarId) (p : IRType → Bool) (suffix? : Option String := none) : M Unit := do
+  let ty ← getType x; checkType ty p suffix?
+
+def checkObjVar (x : VarId) : M Unit :=
+  checkVarType x IRType.isObj "object expected"
+
+def checkScalarVar (x : VarId) : M Unit :=
+  checkVarType x IRType.isScalar "scalar expected"
+
+def checkFullApp (c : FunId) (ys : Array Arg) : M Unit := do
+  let decl ← getDecl c
+  unless ys.size == decl.params.size do
+    throw s!"incorrect number of arguments to '{c}', {ys.size} provided, {decl.params.size} expected"
+  checkArgs ys
+
+def checkPartialApp (c : FunId) (ys : Array Arg) : M Unit := do
+  let decl ← getDecl c
+  unless ys.size < decl.params.size do
+    throw s!"too many arguments to partial application '{c}', num. args: {ys.size}, arity: {decl.params.size}"
+  checkArgs ys
+
+def checkExpr (ty : IRType) : Expr → M Unit
+  | Expr.pap f ys           => checkPartialApp f ys *> checkObjType ty -- partial applications should always produce a closure object
+  | Expr.ap x ys            => checkObjVar x *> checkArgs ys
+  | Expr.fap f ys           => checkFullApp f ys
+  | Expr.ctor c ys          => do
+    if c.cidx > maxCtorTag && (c.size > 0 || c.usize > 0 || c.ssize > 0) then
+      throw s!"tag for constructor '{c.name}' is too big, this is a limitation of the current runtime"
+    if c.size > maxCtorFields then
+      throw s!"constructor '{c.name}' has too many fields"
+    if c.ssize + c.usize * usizeSize > maxCtorScalarsSize then
+      throw s!"constructor '{c.name}' has too many scalar fields"
+    if !ty.isStruct && !ty.isUnion && c.isRef then
+      (checkObjType ty) *> checkArgs ys
+  | Expr.reset _ x          => checkObjVar x *> checkObjType ty
+  | Expr.reuse x _ _ ys     => checkObjVar x *> checkArgs ys *> checkObjType ty
+  | Expr.box xty x          => checkObjType ty *> checkScalarVar x *> checkVarType x (fun t => t == xty)
+  | Expr.unbox x            => checkScalarType ty *> checkObjVar x
+  | Expr.proj i x           => do
+    let xType ← getType x;
+    match xType with
+    | IRType.object       => checkObjType ty
+    | IRType.tobject      => checkObjType ty
+    | IRType.struct _ tys => if h : i < tys.size then checkEqTypes (tys[i]) ty else throw "invalid proj index"
+    | IRType.union _ tys  => if h : i < tys.size then checkEqTypes (tys[i]) ty else throw "invalid proj index"
+    | _                   => throw s!"unexpected IR type '{xType}'"
+  | Expr.uproj _ x          => checkObjVar x *> checkType ty (fun t => t == IRType.usize)
+  | Expr.sproj _ _ x        => checkObjVar x *> checkScalarType ty
+  | Expr.isShared x         => checkObjVar x *> checkType ty (fun t => t == IRType.uint8)
+  | Expr.lit (LitVal.str _) => checkObjType ty
+  | Expr.lit _              => pure ()
+
+@[inline] def withParams (ps : Array Param) (k : M Unit) : M Unit := do
+  let ctx ← read
+  let localCtx ← ps.foldlM (init := ctx.localCtx) fun (ctx : LocalContext) p => do
+     markVar p.x
+     pure $ ctx.addParam p
+  withReader (fun _ => { ctx with localCtx := localCtx }) k
+
+partial def checkFnBody : FnBody → M Unit
+  | .vdecl x t v b    => do
+    checkExpr t v
+    markVar x
+    withReader (fun ctx => { ctx with localCtx := ctx.localCtx.addLocal x t v }) (checkFnBody b)
+  | .jdecl j ys v b => do
+    markJP j
+    withParams ys (checkFnBody v)
+    withReader (fun ctx => { ctx with localCtx := ctx.localCtx.addJP j ys v }) (checkFnBody b)
+  | .set x _ y b      => checkVar x *> checkArg y *> checkFnBody b
+  | .uset x _ y b     => checkVar x *> checkVar y *> checkFnBody b
+  | .sset x _ _ y _ b => checkVar x *> checkVar y *> checkFnBody b
+  | .setTag x _ b     => checkVar x *> checkFnBody b
+  | .inc x _ _ _ b    => checkVar x *> checkFnBody b
+  | .dec x _ _ _ b    => checkVar x *> checkFnBody b
+  | .del x b          => checkVar x *> checkFnBody b
+  | .mdata _ b        => checkFnBody b
+  | .jmp j ys         => checkJP j *> checkArgs ys
+  | .ret x            => checkArg x
+  | .case _ x _ alts  => checkVar x *> alts.forM (fun alt => checkFnBody alt.body)
+  | .unreachable      => pure ()
+
+def checkDecl : Decl → M Unit
+  | .fdecl (xs := xs) (body := b) .. => withParams xs (checkFnBody b)
+  | .extern (xs := xs) .. => withParams xs (pure ())
+
+end Checker
+
+def checkDecl (decls : Array Decl) (decl : Decl) : CompilerM Unit := do
+  let env ← getEnv
+  match (Checker.checkDecl decl { env := env, decls := decls }).run' {} with
+  | .error msg => throw s!"failed to compile definition, compiler IR check failed at '{decl.name}'. Error: {msg}"
+  | _ => pure ()
+
+def checkDecls (decls : Array Decl) : CompilerM Unit :=
+  decls.forM (checkDecl decls)
+
+end IR
+end Lean

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/CompilerM.lean

@@ -0,0 +1,239 @@
+/-
+Copyright (c) 2019 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Environment
+import Lean.Compiler.IR.Basic
+import Lean.Compiler.IR.Format
+import Lean.Compiler.MetaAttr
+import Lean.Compiler.ExportAttr
+
+namespace Lean.IR
+
+inductive LogEntry where
+  | step (cls : Name) (decls : Array Decl)
+  | message (msg : Format)
+
+namespace LogEntry
+protected def fmt : LogEntry → Format
+  | step cls decls => Format.bracket "[" (format cls) "]" ++ decls.foldl (fun fmt decl => fmt ++ Format.line ++ format decl) Format.nil
+  | message msg    => msg
+
+instance : ToFormat LogEntry := ⟨LogEntry.fmt⟩
+end LogEntry
+
+abbrev Log := Array LogEntry
+
+def Log.format (log : Log) : Format :=
+  log.foldl (init := Format.nil) fun fmt entry =>
+    f!"{fmt}{Format.line}{entry}"
+
+@[export lean_ir_log_to_string]
+def Log.toString (log : Log) : String :=
+  log.format.pretty
+
+structure CompilerState where
+  env : Environment
+  log : Log := #[]
+
+abbrev CompilerM := ReaderT Options (EStateM String CompilerState)
+
+def log (entry : LogEntry) : CompilerM Unit :=
+  modify fun s => { s with log := s.log.push entry }
+
+def tracePrefixOptionName := `trace.compiler.ir
+
+private def isLogEnabledFor (opts : Options) (optName : Name) : Bool :=
+  match opts.find optName with
+  | some (DataValue.ofBool v) => v
+  | _     => opts.getBool tracePrefixOptionName
+
+private def logDeclsAux (optName : Name) (cls : Name) (decls : Array Decl) : CompilerM Unit := do
+  let opts ← read
+  if isLogEnabledFor opts optName then
+    log (LogEntry.step cls decls)
+
+@[inline] def logDecls (cls : Name) (decl : Array Decl) : CompilerM Unit :=
+  logDeclsAux (tracePrefixOptionName ++ cls) cls decl
+
+private def logMessageIfAux {α : Type} [ToFormat α] (optName : Name) (a : α) : CompilerM Unit := do
+  let opts ← read
+  if isLogEnabledFor opts optName then
+    log (LogEntry.message (format a))
+
+@[inline] def logMessageIf {α : Type} [ToFormat α] (cls : Name) (a : α) : CompilerM Unit :=
+  logMessageIfAux (tracePrefixOptionName ++ cls) a
+
+@[inline] def logMessage {α : Type} [ToFormat α] (a : α) : CompilerM Unit :=
+  logMessageIfAux tracePrefixOptionName a
+
+@[inline] def modifyEnv (f : Environment → Environment) : CompilerM Unit :=
+  modify fun s => { s with env := f s.env }
+
+abbrev DeclMap := PHashMap Name Decl
+
+private abbrev declLt (a b : Decl) :=
+  Name.quickLt a.name b.name
+
+private abbrev sortDecls (decls : Array Decl) : Array Decl :=
+  decls.qsort declLt
+
+private abbrev findAtSorted? (decls : Array Decl) (declName : Name) : Option Decl :=
+  let tmpDecl := Decl.extern declName #[] default default
+  decls.binSearch tmpDecl declLt
+
+namespace CollectUsedFDecls
+
+abbrev M := StateM NameSet
+
+@[inline] def collect (f : FunId) : M Unit :=
+  modify fun s => s.insert f
+
+partial def collectFnBody : FnBody → M Unit
+  | .vdecl _ _ v b   =>
+    match v with
+    | .fap f _ => collect f *> collectFnBody b
+    | .pap f _ => collect f *> collectFnBody b
+    | _        => collectFnBody b
+  | .jdecl _ _ v b   => collectFnBody v *> collectFnBody b
+  | .case _ _ _ alts => alts.forM fun alt => collectFnBody alt.body
+  | e => unless e.isTerminal do collectFnBody e.body
+
+def collectDecl : Decl → M NameSet
+  | .fdecl (body := b) .. => collectFnBody b *> get
+  | .extern .. => get
+
+end CollectUsedFDecls
+
+/-- Adds to `used` all `Decl.fdecl`s referenced directly by `decl`. -/
+def collectUsedFDecls (decl : Decl) (used : NameSet := {}) : NameSet :=
+  (CollectUsedFDecls.collectDecl decl).run' used
+
+/-- Computes the closure of `Decl.fdecl`s referenced by `decl`. -/
+def getFDeclClosure (m : DeclMap) (decls : Array Decl) : NameSet := Id.run do
+  let mut toVisit := decls.map (·.name) |>.toList
+  let mut res : NameSet := .ofList toVisit
+  while !toVisit.isEmpty do
+    let n :: toVisit' := toVisit | continue
+    toVisit := toVisit'
+    let some d := m.find? n | continue
+    for d' in collectUsedFDecls d do
+      if !res.contains d' then
+        res := res.insert d'
+        toVisit := d' :: toVisit
+  return res
+
+builtin_initialize declMapExt : SimplePersistentEnvExtension Decl DeclMap ←
+  registerSimplePersistentEnvExtension {
+    addImportedFn := fun _ => {}
+    addEntryFn    := fun s d => s.insert d.name d
+    -- Store `meta` closure only in `.olean`, turn all other decls into opaque externs.
+    -- Leave storing the remainder for `meta import` and server `#eval` to `exportIREntries` below.
+    exportEntriesFnEx? := some fun env s entries level =>
+      let decls := entries.foldl (init := #[]) fun decls decl => decls.push decl
+      let entries := sortDecls decls
+      let metaClosure := getFDeclClosure s (decls.filter (isMeta env ·.name))
+      if env.header.isModule then
+        entries.map fun
+          | d@(.fdecl f xs ty b info) =>
+            -- The interpreter may call the boxed variant even if the IR does not directly reference
+            -- it.
+            let n := match f with
+              | .str n "_boxed" => n
+              | n => n
+            if metaClosure.contains n then
+              d
+            else if let some (.str _ s) := getExportNameFor? env n then
+              .extern f xs ty { arity? := xs.size, entries := [.standard `all s] }
+            else
+              .extern f xs ty { arity? := xs.size, entries := [.opaque f] }
+          | d => d
+      else entries
+    -- Written to on codegen environment branch but accessed from other elaboration branches when
+    -- calling into the interpreter. We cannot use `async` as the IR declarations added may not
+    -- share a name prefix with the top-level Lean declaration being compiled, e.g. from
+    -- specialization.
+    asyncMode     := .sync
+    replay?       := some <| SimplePersistentEnvExtension.replayOfFilter (!·.contains ·.name) (fun s d => s.insert d.name d)
+  }
+
+@[export lean_ir_export_entries]
+private def exportIREntries (env : Environment) : Array (Name × Array EnvExtensionEntry) :=
+  let decls := declMapExt.getEntries env |>.foldl (init := #[]) fun decls decl => decls.push decl
+  -- safety: cast to erased type
+  let entries : Array EnvExtensionEntry := unsafe unsafeCast <| sortDecls decls
+  #[(``declMapExt, entries)]
+
+/-- Retrieves IR for codegen purposes, i.e. independent of `meta import`. -/
+def findEnvDecl (env : Environment) (declName : Name) : Option Decl :=
+  match env.getModuleIdxFor? declName with
+  | some modIdx => findAtSorted? (declMapExt.getModuleEntries env modIdx) declName
+  | none        => declMapExt.getState env |>.find? declName
+
+@[export lean_ir_find_env_decl]
+private def findInterpreterDecl (env : Environment) (declName : Name) : Option Decl :=
+  match env.getModuleIdxFor? declName with
+  | some modIdx => do
+    let decl ←
+      -- `meta import` and server `#eval`
+      findAtSorted? (declMapExt.getModuleIREntries env modIdx) declName <|>
+      -- (closure of) `meta def`; will report `.extern`s for other `def`s so needs to come second
+      findAtSorted? (declMapExt.getModuleEntries env modIdx) declName
+    guard !decl matches .extern _ _ _ { entries := [.opaque _], .. }
+    return decl
+  | none => declMapExt.getState env |>.find? declName
+
+def findDecl (n : Name) : CompilerM (Option Decl) :=
+  return findEnvDecl (← get).env n
+
+def containsDecl (n : Name) : CompilerM Bool :=
+  return (← findDecl n).isSome
+
+def getDecl (n : Name) : CompilerM Decl := do
+  let (some decl) ← findDecl n | throw s!"unknown declaration '{n}'"
+  return decl
+
+@[export lean_ir_add_decl]
+def addDeclAux (env : Environment) (decl : Decl) : Environment :=
+  declMapExt.addEntry (env.addExtraName decl.name) decl
+
+def getDecls (env : Environment) : List Decl :=
+  declMapExt.getEntries env
+
+def getEnv : CompilerM Environment := do
+  let s ← get; pure s.env
+
+def addDecl (decl : Decl) : CompilerM Unit :=
+  modifyEnv fun env => declMapExt.addEntry (env.addExtraName decl.name) decl
+
+def addDecls (decls : Array Decl) : CompilerM Unit :=
+  decls.forM addDecl
+
+def findEnvDecl' (env : Environment) (n : Name) (decls : Array Decl) : Option Decl :=
+  match decls.find? (fun decl => decl.name == n) with
+  | some decl => some decl
+  | none      => findEnvDecl env n
+
+def findDecl' (n : Name) (decls : Array Decl) : CompilerM (Option Decl) :=
+  return findEnvDecl' (← get).env n decls
+
+def containsDecl' (n : Name) (decls : Array Decl) : CompilerM Bool := do
+  if decls.any fun decl => decl.name == n then
+    return true
+  else
+    containsDecl n
+
+def getDecl' (n : Name) (decls : Array Decl) : CompilerM Decl := do
+  let (some decl) ← findDecl' n decls | throw s!"unknown declaration '{n}'"
+  return decl
+
+@[export lean_decl_get_sorry_dep]
+def getSorryDep (env : Environment) (declName : Name) : Option Name :=
+  match findEnvDecl env declName with
+  | some (.fdecl (info := { sorryDep? := dep?, .. }) ..) => dep?
+  | _ => none
+
+end IR
+end Lean

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/ElimDeadBranches.lean

@@ -0,0 +1,351 @@
+/-
+Copyright (c) 2019 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Compiler.IR.Format
+import Lean.Compiler.IR.Basic
+import Lean.Compiler.IR.CompilerM
+
+namespace Lean.IR.UnreachableBranches
+
+/-- Value used in the abstract interpreter -/
+inductive Value where
+  | bot -- undefined
+  | top -- any value
+  | ctor (i : CtorInfo) (vs : Array Value)
+  | choice (vs : List Value)
+  deriving Inhabited, Repr
+
+protected partial def Value.toFormat : Value → Format
+  | Value.bot => "⊥"
+  | Value.top => "⊤"
+  | Value.ctor info vs =>
+    if vs.isEmpty then
+      format info.name
+    else
+      Format.paren <| format info.name ++ Std.Format.join (vs.toList.map fun v => " " ++ Value.toFormat v)
+  | Value.choice vs =>
+    Format.paren <| Std.Format.joinSep (vs.map Value.toFormat) " | "
+
+instance : ToFormat Value where
+  format := Value.toFormat
+
+instance : ToString Value where
+  toString v := toString (format v)
+
+namespace Value
+
+protected partial def beq : Value → Value → Bool
+  | bot, bot => true
+  | top, top => true
+  | ctor i₁ vs₁, ctor i₂ vs₂ => i₁ == i₂ && Array.isEqv vs₁ vs₂ Value.beq
+  | choice vs₁, choice vs₂ =>
+    vs₁.all (fun v₁ => vs₂.any fun v₂ => Value.beq v₁ v₂)
+    &&
+    vs₂.all (fun v₂ => vs₁.any fun v₁ => Value.beq v₁ v₂)
+  | _, _ => false
+
+instance : BEq Value := ⟨Value.beq⟩
+
+partial def addChoice (merge : Value → Value → Value) : List Value → Value → List Value
+  | [], v => [v]
+  | v₁@(ctor i₁ _) :: cs, v₂@(ctor i₂ _) =>
+    if i₁ == i₂ then merge v₁ v₂ :: cs
+    else v₁ :: addChoice merge cs v₂
+  | _, _ => panic! "invalid addChoice"
+
+partial def merge (v₁ v₂ : Value) : Value :=
+  match v₁, v₂ with
+  | bot, v => v
+  | v, bot => v
+  | top, _ => top
+  | _, top => top
+  | v₁@(ctor i₁ vs₁), v₂@(ctor i₂ vs₂) =>
+    if i₁ == i₂ then ctor i₁ <| vs₁.size.fold (init := #[]) fun i _ r => r.push (merge vs₁[i] vs₂[i]!)
+    else choice [v₁, v₂]
+  | choice vs₁, choice vs₂ => choice <| vs₁.foldl (addChoice merge) vs₂
+  | choice vs, v => choice <| addChoice merge vs v
+  | v, choice vs => choice <| addChoice merge vs v
+
+/--
+  In `truncate`, we approximate a value as `top` if depth > `truncateMaxDepth`.
+  TODO: add option to control this parameter.
+-/
+def truncateMaxDepth := 8
+
+/--
+  Make sure constructors of recursive inductive datatypes can only occur once in each path.
+  Values at depth > truncateMaxDepth are also approximated at `top`.
+  We use this function this function to implement a simple widening operation for our abstract
+  interpreter.
+  Recall the widening functions is used to ensure termination in abstract interpreters.
+-/
+partial def truncate (env : Environment) (v : Value) (s : NameSet) : Value :=
+  go v s truncateMaxDepth
+where
+  go (v : Value) (s : NameSet) (depth : Nat) : Value :=
+    match depth with
+    | 0 => top
+    | depth+1 =>
+      match v, s with
+      | ctor i vs, found =>
+        let I := i.name.getPrefix
+        if found.contains I then
+          top
+        else
+          let cont (found' : NameSet) : Value :=
+            ctor i (vs.map fun v => go v found' depth)
+          match env.find? I with
+          | some (ConstantInfo.inductInfo d) =>
+            if d.isRec then cont (found.insert I)
+            else cont found
+          | _ => cont found
+      | choice vs, found =>
+        let newVs := vs.map fun v => go v found depth
+        if newVs.elem top then top
+        else choice newVs
+      | v, _ => v
+
+/-- Widening operator that guarantees termination in our abstract interpreter. -/
+def widening (env : Environment) (v₁ v₂ : Value) : Value :=
+  truncate env (merge v₁ v₂) {}
+
+end Value
+
+abbrev FunctionSummaries := PHashMap FunId Value
+
+private abbrev declLt (a b : FunId × Value) :=
+  Name.quickLt a.1 b.1
+
+private abbrev sortEntries (entries : Array (FunId × Value)) : Array (FunId × Value) :=
+  entries.qsort declLt
+
+private abbrev findAtSorted? (entries : Array (FunId × Value)) (fid : FunId) : Option Value :=
+  if let some (_, value) := entries.binSearch (fid, default) declLt then
+    some value
+  else
+    none
+
+builtin_initialize functionSummariesExt : SimplePersistentEnvExtension (FunId × Value) FunctionSummaries ←
+  registerSimplePersistentEnvExtension {
+    addImportedFn := fun _ => {}
+    addEntryFn := fun s ⟨e, n⟩ => s.insert e n
+    toArrayFn := fun s => sortEntries s.toArray
+    asyncMode := .sync  -- compilation is non-parallel anyway
+    replay? := some <| SimplePersistentEnvExtension.replayOfFilter (!·.contains ·.1) (fun s ⟨e, n⟩ => s.insert e n)
+  }
+
+def addFunctionSummary (env : Environment) (fid : FunId) (v : Value) : Environment :=
+  functionSummariesExt.addEntry (env.addExtraName fid) (fid, v)
+
+def getFunctionSummary? (env : Environment) (fid : FunId) : Option Value :=
+  match env.getModuleIdxFor? fid with
+  | some modIdx => findAtSorted? (functionSummariesExt.getModuleEntries env modIdx) fid
+  | none        => functionSummariesExt.getState env |>.find? fid
+
+abbrev Assignment := Std.HashMap VarId Value
+
+structure InterpContext where
+  currFnIdx : Nat := 0
+  decls     : Array Decl
+  env       : Environment
+  lctx      : LocalContext := {}
+
+structure InterpState where
+  assignments : Array Assignment
+  funVals     : PArray Value -- we take snapshots during fixpoint computations
+  visitedJps  : Array (Std.HashSet JoinPointId)
+
+abbrev M := ReaderT InterpContext (StateM InterpState)
+
+open Value
+
+def findVarValue (x : VarId) : M Value := do
+  let ctx ← read
+  let s ← get
+  let assignment := s.assignments[ctx.currFnIdx]!
+  return assignment.getD x bot
+
+def findArgValue (arg : Arg) : M Value :=
+  match arg with
+  | Arg.var x => findVarValue x
+  | _         => pure top
+
+def updateVarAssignment (x : VarId) (v : Value) : M Unit := do
+  let v' ← findVarValue x
+  let ctx ← read
+  modify fun s => { s with assignments := s.assignments.modify ctx.currFnIdx fun a => a.insert x (merge v v') }
+
+def resetVarAssignment (x : VarId) : M Unit := do
+  let ctx ← read
+  modify fun s => { s with assignments := s.assignments.modify ctx.currFnIdx fun a => a.insert x Value.bot }
+
+def resetParamAssignment (y : Param) : M Unit :=
+  resetVarAssignment y.x
+
+partial def projValue : Value → Nat → Value
+  | ctor _ vs, i => vs.getD i bot
+  | choice vs, i => vs.foldl (fun r v => merge r (projValue v i)) bot
+  | v, _         => v
+
+def interpExpr : Expr → M Value
+  | Expr.ctor i ys => return ctor i (← ys.mapM fun y => findArgValue y)
+  | Expr.proj i x  => return projValue (← findVarValue x) i
+  | Expr.fap fid _  => do
+    let ctx ← read
+    match getFunctionSummary? ctx.env fid with
+    | some v => pure v
+    | none   => do
+      let s ← get
+      match ctx.decls.findIdx? (fun decl => decl.name == fid) with
+      | some idx => pure s.funVals[idx]!
+      | none     => pure top
+  | _ => pure top
+
+partial def containsCtor : Value → CtorInfo → Bool
+  | top,       _ => true
+  | ctor i _,  j => i == j
+  | choice vs, j => vs.any fun v => containsCtor v j
+  | _,         _ => false
+
+def updateCurrFnSummary (v : Value) : M Unit := do
+  let ctx ← read
+  let currFnIdx := ctx.currFnIdx
+  modify fun s => { s with funVals := s.funVals.modify currFnIdx (fun v' => widening ctx.env v v') }
+
+def markJPVisited (j : JoinPointId) : M Bool := do
+  let currFnIdx := (← read).currFnIdx
+  modifyGet fun s =>
+    ⟨!(s.visitedJps[currFnIdx]!.contains j),
+     { s with visitedJps := s.visitedJps.modify currFnIdx fun a => a.insert j }⟩
+
+/-- Return true if the assignment of at least one parameter has been updated. -/
+def updateJPParamsAssignment (j : JoinPointId) (ys : Array Param) (xs : Array Arg) : M Bool := do
+  let ctx ← read
+  let currFnIdx := ctx.currFnIdx
+  let isFirstVisit ← markJPVisited j
+  ys.size.foldM (init := isFirstVisit) fun i _ r => do
+    let y := ys[i]
+    let x := xs[i]!
+    let yVal ← findVarValue y.x
+    let xVal ← findArgValue x
+    let newVal := merge yVal xVal
+    if newVal == yVal then
+      pure r
+    else
+      modify fun s => { s with assignments := s.assignments.modify currFnIdx fun a => a.insert y.x newVal }
+      pure true
+
+private partial def resetNestedJPParams : FnBody → M Unit
+  | FnBody.jdecl _ ys _ k => do
+    ys.forM resetParamAssignment
+    /- Remark we don't need to reset the parameters of joint-points
+      nested in `b` since they will be reset if this JP is used. -/
+    resetNestedJPParams k
+  | FnBody.case _ _ _ alts =>
+    alts.forM fun alt => match alt with
+      | Alt.ctor _ b  => resetNestedJPParams b
+      | Alt.default b => resetNestedJPParams b
+  | e => do unless e.isTerminal do resetNestedJPParams e.body
+
+partial def interpFnBody : FnBody → M Unit
+  | FnBody.vdecl x _ e b => do
+    let v ← interpExpr e
+    updateVarAssignment x v
+    interpFnBody b
+  | FnBody.jdecl j ys v b =>
+    withReader (fun ctx => { ctx with lctx := ctx.lctx.addJP j ys v }) do
+      interpFnBody b
+  | FnBody.case _ x _ alts => do
+    let v ← findVarValue x
+    alts.forM fun alt => do
+      match alt with
+      | Alt.ctor i b  => if containsCtor v i then interpFnBody b
+      | Alt.default b => interpFnBody b
+  | FnBody.ret x => do
+    let v ← findArgValue x
+    updateCurrFnSummary v
+  | FnBody.jmp j xs => do
+    let ctx ← read
+    let ys := (ctx.lctx.getJPParams j).get!
+    let b  := (ctx.lctx.getJPBody j).get!
+    let updated ← updateJPParamsAssignment j ys xs
+    if updated then
+      -- We must reset the value of nested join-point parameters since they depend on `ys` values
+      resetNestedJPParams b
+      interpFnBody b
+  | e => do
+    unless e.isTerminal do
+      interpFnBody e.body
+
+def inferStep : M Bool := do
+  let ctx ← read
+  modify fun s => { s with assignments := ctx.decls.map fun _ => {},
+                           visitedJps := ctx.decls.map fun _ => {} }
+  ctx.decls.size.foldM (init := false) fun idx _ modified => do
+    match ctx.decls[idx] with
+    | .fdecl (xs := ys) (body := b) .. => do
+      let s ← get
+      let currVals := s.funVals[idx]!
+      withReader (fun ctx => { ctx with currFnIdx := idx }) do
+        ys.forM fun y => updateVarAssignment y.x top
+        interpFnBody b
+        let s ← get
+        let newVals := s.funVals[idx]!
+        pure (modified || currVals != newVals)
+    | .extern .. => do
+      let currVals := (← get).funVals[idx]!
+      updateCurrFnSummary .top
+      let newVals := (← get).funVals[idx]!
+      pure (modified || currVals != newVals)
+
+partial def inferMain : M Unit := do
+  let modified ← inferStep
+  if modified then inferMain else pure ()
+
+partial def elimDeadAux (assignment : Assignment) : FnBody → FnBody
+  | FnBody.vdecl x t e b  => FnBody.vdecl x t e (elimDeadAux assignment b)
+  | FnBody.jdecl j ys v b => FnBody.jdecl j ys (elimDeadAux assignment v) (elimDeadAux assignment b)
+  | FnBody.case tid x xType alts =>
+    let v := assignment.getD x bot
+    let alts := alts.map fun alt =>
+      match alt with
+      | Alt.ctor i b  => Alt.ctor i <| if containsCtor v i then elimDeadAux assignment b else FnBody.unreachable
+      | Alt.default b => Alt.default (elimDeadAux assignment b)
+    FnBody.case tid x xType alts
+  | e =>
+    if e.isTerminal then e
+    else
+      let (instr, b) := e.split
+      let b := elimDeadAux assignment b
+      instr.setBody b
+
+partial def elimDead (assignment : Assignment) (d : Decl) : Decl :=
+  match d with
+  | .fdecl (body := b) .. => d.updateBody! <| elimDeadAux assignment b
+  | other => other
+
+end UnreachableBranches
+
+open UnreachableBranches
+
+def elimDeadBranches (decls : Array Decl) : CompilerM (Array Decl) := do
+  let s ← get
+  let env := s.env
+  let assignments : Array Assignment := decls.map fun _ => {}
+  let funVals := mkPArray decls.size Value.bot
+  let visitedJps := decls.map fun _ => {}
+  let ctx : InterpContext := { decls := decls, env := env }
+  let s : InterpState := { assignments, funVals, visitedJps }
+  let (_, s) := (inferMain ctx).run s
+  let funVals := s.funVals
+  let assignments := s.assignments
+  modify fun s =>
+    let env := decls.size.fold (init := s.env) fun i _ env =>
+      addFunctionSummary env decls[i].name funVals[i]!
+    { s with env := env }
+  return decls.mapIdx fun i decl => elimDead assignments[i]! decl
+
+end Lean.IR

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/ElimDeadVars.lean

@@ -0,0 +1,48 @@
+/-
+Copyright (c) 2019 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Compiler.IR.Basic
+import Lean.Compiler.IR.FreeVars
+
+namespace Lean.IR
+
+partial def reshapeWithoutDead (bs : Array FnBody) (term : FnBody) : FnBody :=
+  let rec reshape (bs : Array FnBody) (b : FnBody) (used : IndexSet) :=
+    if bs.isEmpty then b
+    else
+      let curr := bs.back!
+      let bs   := bs.pop
+      let keep (_ : Unit) :=
+        let used := curr.collectFreeIndices used
+        let b    := curr.setBody b
+        reshape bs b used
+      let keepIfUsed (vidx : Index) :=
+        if used.contains vidx then keep ()
+        else reshape bs b used
+      match curr with
+      | FnBody.vdecl x _ _ _  => keepIfUsed x.idx
+      -- TODO: we should keep all struct/union projections because they are used to ensure struct/union values are fully consumed.
+      | FnBody.jdecl j _ _ _  => keepIfUsed j.idx
+      | _                     => keep ()
+  reshape bs term term.freeIndices
+
+partial def FnBody.elimDead (b : FnBody) : FnBody :=
+  let (bs, term) := b.flatten
+  let bs         := modifyJPs bs elimDead
+  let term       := match term with
+    | FnBody.case tid x xType alts =>
+      let alts := alts.map fun alt => alt.modifyBody elimDead
+      FnBody.case tid x xType alts
+    | other => other
+  reshapeWithoutDead bs term
+
+/-- Eliminate dead let-declarations and join points -/
+def Decl.elimDead (d : Decl) : Decl :=
+  match d with
+  | .fdecl (body := b) .. => d.updateBody! b.elimDead
+  | other => other
+
+end Lean.IR

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/EmitC.lean

@@ -0,0 +1,775 @@
+/-
+Copyright (c) 2019 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Runtime
+import Lean.Compiler.NameMangling
+import Lean.Compiler.ExportAttr
+import Lean.Compiler.InitAttr
+import Lean.Compiler.IR.CompilerM
+import Lean.Compiler.IR.EmitUtil
+import Lean.Compiler.IR.NormIds
+import Lean.Compiler.IR.SimpCase
+import Lean.Compiler.IR.Boxing
+
+namespace Lean.IR.EmitC
+open ExplicitBoxing (requiresBoxedVersion mkBoxedName isBoxedName)
+
+def leanMainFn := "_lean_main"
+
+structure Context where
+  env        : Environment
+  modName    : Name
+  jpMap      : JPParamsMap := {}
+  mainFn     : FunId := default
+  mainParams : Array Param := #[]
+
+abbrev M := ReaderT Context (EStateM String String)
+
+def getEnv : M Environment := Context.env <$> read
+def getModName : M Name := Context.modName <$> read
+def getDecl (n : Name) : M Decl := do
+  let env ← getEnv
+  match findEnvDecl env n with
+  | some d => pure d
+  | none   => throw s!"unknown declaration '{n}'"
+
+@[inline] def emit {α : Type} [ToString α] (a : α) : M Unit :=
+  modify fun out => out ++ toString a
+
+@[inline] def emitLn {α : Type} [ToString α] (a : α) : M Unit := do
+  emit a; emit "\n"
+
+def emitLns {α : Type} [ToString α] (as : List α) : M Unit :=
+  as.forM fun a => emitLn a
+
+def argToCString (x : Arg) : String :=
+  match x with
+  | Arg.var x => toString x
+  | _         => "lean_box(0)"
+
+def emitArg (x : Arg) : M Unit :=
+  emit (argToCString x)
+
+def toCType : IRType → String
+  | IRType.float      => "double"
+  | IRType.float32    => "float"
+  | IRType.uint8      => "uint8_t"
+  | IRType.uint16     => "uint16_t"
+  | IRType.uint32     => "uint32_t"
+  | IRType.uint64     => "uint64_t"
+  | IRType.usize      => "size_t"
+  | IRType.object     => "lean_object*"
+  | IRType.tobject    => "lean_object*"
+  | IRType.irrelevant => "lean_object*"
+  | IRType.struct _ _ => panic! "not implemented yet"
+  | IRType.union _ _  => panic! "not implemented yet"
+
+def throwInvalidExportName {α : Type} (n : Name) : M α :=
+  throw s!"invalid export name '{n}'"
+
+def toCName (n : Name) : M String := do
+  let env ← getEnv;
+  -- TODO: we should support simple export names only
+  match getExportNameFor? env n with
+  | some (.str .anonymous s) => pure s
+  | some _                   => throwInvalidExportName n
+  | none                     => if n == `main then pure leanMainFn else pure n.mangle
+
+def emitCName (n : Name) : M Unit :=
+  toCName n >>= emit
+
+def toCInitName (n : Name) : M String := do
+  let env ← getEnv;
+  -- TODO: we should support simple export names only
+  match getExportNameFor? env n with
+  | some (.str .anonymous s) => return "_init_" ++ s
+  | some _                   => throwInvalidExportName n
+  | none                     => pure ("_init_" ++ n.mangle)
+
+def emitCInitName (n : Name) : M Unit :=
+  toCInitName n >>= emit
+
+def emitFnDeclAux (decl : Decl) (cppBaseName : String) (isExternal : Bool) : M Unit := do
+  let ps := decl.params
+  let env ← getEnv
+  if ps.isEmpty then
+    if isClosedTermName env decl.name then emit "static "
+    else if isExternal then emit "extern "
+    else emit "LEAN_EXPORT "
+  else
+    if !isExternal then emit "LEAN_EXPORT "
+  emit (toCType decl.resultType ++ " " ++ cppBaseName)
+  unless ps.isEmpty do
+    emit "("
+    -- We omit irrelevant parameters for extern constants
+    let ps := if isExternC env decl.name then ps.filter (fun p => !p.ty.isIrrelevant) else ps
+    if ps.size > closureMaxArgs && isBoxedName decl.name then
+      emit "lean_object**"
+    else
+      ps.size.forM fun i _ => do
+        if i > 0 then emit ", "
+        emit (toCType ps[i].ty)
+    emit ")"
+  emitLn ";"
+
+def emitFnDecl (decl : Decl) (isExternal : Bool) : M Unit := do
+  let cppBaseName ← toCName decl.name
+  emitFnDeclAux decl cppBaseName isExternal
+
+def emitExternDeclAux (decl : Decl) (cNameStr : String) : M Unit := do
+  let env ← getEnv
+  let extC := isExternC env decl.name
+  emitFnDeclAux decl cNameStr extC
+
+def emitFnDecls : M Unit := do
+  let env ← getEnv
+  let decls := getDecls env
+  let modDecls  : NameSet := decls.foldl (fun s d => s.insert d.name) {}
+  let usedDecls : NameSet := decls.foldl (fun s d => collectUsedDecls env d (s.insert d.name)) {}
+  let usedDecls := usedDecls.toList
+  usedDecls.forM fun n => do
+    let decl ← getDecl n;
+    match getExternNameFor env `c decl.name with
+    | some cName => emitExternDeclAux decl cName
+    | none       => emitFnDecl decl (!modDecls.contains n)
+
+def emitMainFn : M Unit := do
+  let d ← getDecl `main
+  match d with
+  | .fdecl (xs := xs) .. => do
+    unless xs.size == 2 || xs.size == 1 do throw "invalid main function, incorrect arity when generating code"
+    let env ← getEnv
+    let usesLeanAPI := usesModuleFrom env `Lean
+    emitLn "char ** lean_setup_args(int argc, char ** argv);";
+    if usesLeanAPI then
+       emitLn "void lean_initialize();"
+    else
+       emitLn "void lean_initialize_runtime_module();";
+    emitLn "
+  #if defined(WIN32) || defined(_WIN32)
+  #include <windows.h>
+  #endif
+
+  int main(int argc, char ** argv) {
+  #if defined(WIN32) || defined(_WIN32)
+  SetErrorMode(SEM_FAILCRITICALERRORS);
+  SetConsoleOutputCP(CP_UTF8);
+  #endif
+  lean_object* in; lean_object* res;";
+    emitLn "argv = lean_setup_args(argc, argv);";
+    if usesLeanAPI then
+      emitLn "lean_initialize();"
+    else
+      emitLn "lean_initialize_runtime_module();"
+    let modName ← getModName
+    /- We disable panic messages because they do not mesh well with extracted closed terms.
+       See issue #534. We can remove this workaround after we implement issue #467. -/
+    emitLn "lean_set_panic_messages(false);"
+    emitLn ("res = " ++ mkModuleInitializationFunctionName modName ++ "(1 /* builtin */, lean_io_mk_world());")
+    emitLn "lean_set_panic_messages(true);"
+    emitLns ["lean_io_mark_end_initialization();",
+             "if (lean_io_result_is_ok(res)) {",
+             "lean_dec_ref(res);",
+             "lean_init_task_manager();"];
+    if xs.size == 2 then
+      emitLns ["in = lean_box(0);",
+               "int i = argc;",
+               "while (i > 1) {",
+               " lean_object* n;",
+               " i--;",
+               " n = lean_alloc_ctor(1,2,0); lean_ctor_set(n, 0, lean_mk_string(argv[i])); lean_ctor_set(n, 1, in);",
+               " in = n;",
+              "}"]
+      emitLn ("res = " ++ leanMainFn ++ "(in, lean_io_mk_world());")
+    else
+      emitLn ("res = " ++ leanMainFn ++ "(lean_io_mk_world());")
+    emitLn "}"
+    -- `IO _`
+    let retTy := env.find? `main |>.get! |>.type |>.getForallBody
+    -- either `UInt32` or `(P)Unit`
+    let retTy := retTy.appArg!
+    -- finalize at least the task manager to avoid leak sanitizer false positives from tasks outliving the main thread
+    emitLns ["lean_finalize_task_manager();",
+             "if (lean_io_result_is_ok(res)) {",
+             "  int ret = " ++ if retTy.constName? == some ``UInt32 then "lean_unbox_uint32(lean_io_result_get_value(res));" else "0;",
+             "  lean_dec_ref(res);",
+             "  return ret;",
+             "} else {",
+             "  lean_io_result_show_error(res);",
+             "  lean_dec_ref(res);",
+             "  return 1;",
+             "}"]
+    emitLn "}"
+  | _     => throw "function declaration expected"
+
+def hasMainFn : M Bool := do
+  let env ← getEnv
+  let decls := getDecls env
+  return decls.any (fun d => d.name == `main)
+
+def emitMainFnIfNeeded : M Unit := do
+  if (← hasMainFn) then emitMainFn
+
+def emitFileHeader : M Unit := do
+  let env ← getEnv
+  let modName ← getModName
+  emitLn "// Lean compiler output"
+  emitLn ("// Module: " ++ toString modName)
+  emit "// Imports:"
+  env.imports.forM fun m => emit (" " ++ toString m)
+  emitLn ""
+  emitLn "#include <lean/lean.h>"
+  emitLns [
+    "#if defined(__clang__)",
+    "#pragma clang diagnostic ignored \"-Wunused-parameter\"",
+    "#pragma clang diagnostic ignored \"-Wunused-label\"",
+    "#elif defined(__GNUC__) && !defined(__CLANG__)",
+    "#pragma GCC diagnostic ignored \"-Wunused-parameter\"",
+    "#pragma GCC diagnostic ignored \"-Wunused-label\"",
+    "#pragma GCC diagnostic ignored \"-Wunused-but-set-variable\"",
+    "#endif",
+    "#ifdef __cplusplus",
+    "extern \"C\" {",
+    "#endif"
+  ]
+
+def emitFileFooter : M Unit :=
+  emitLns [
+   "#ifdef __cplusplus",
+   "}",
+   "#endif"
+  ]
+
+def throwUnknownVar {α : Type} (x : VarId) : M α :=
+  throw s!"unknown variable '{x}'"
+
+def getJPParams (j : JoinPointId) : M (Array Param) := do
+  let ctx ← read;
+  match ctx.jpMap[j]? with
+  | some ps => pure ps
+  | none    => throw "unknown join point"
+
+def declareVar (x : VarId) (t : IRType) : M Unit := do
+  emit (toCType t); emit " "; emit x; emit "; "
+
+def declareParams (ps : Array Param) : M Unit :=
+  ps.forM fun p => declareVar p.x p.ty
+
+partial def declareVars : FnBody → Bool → M Bool
+  | e@(FnBody.vdecl x t _ b), d => do
+    let ctx ← read
+    if isTailCallTo ctx.mainFn e then
+      pure d
+    else
+      declareVar x t; declareVars b true
+  | FnBody.jdecl _ xs _ b,    d => do declareParams xs; declareVars b (d || xs.size > 0)
+  | e,                        d => if e.isTerminal then pure d else declareVars e.body d
+
+def emitTag (x : VarId) (xType : IRType) : M Unit := do
+  if xType.isObj then do
+    emit "lean_obj_tag("; emit x; emit ")"
+  else
+    emit x
+
+def isIf (alts : Array Alt) : Option (Nat × FnBody × FnBody) :=
+  if h : alts.size ≠ 2 then none
+  else match alts[0] with
+    | Alt.ctor c b => some (c.cidx, b, alts[1].body)
+    | _            => none
+
+def emitInc (x : VarId) (n : Nat) (checkRef : Bool) : M Unit := do
+  emit $
+    if checkRef then (if n == 1 then "lean_inc" else "lean_inc_n")
+    else (if n == 1 then "lean_inc_ref" else "lean_inc_ref_n")
+  emit "("; emit x
+  if n != 1 then emit ", "; emit n
+  emitLn ");"
+
+def emitDec (x : VarId) (n : Nat) (checkRef : Bool) : M Unit := do
+  emit (if checkRef then "lean_dec" else "lean_dec_ref");
+  emit "("; emit x;
+  if n != 1 then emit ", "; emit n
+  emitLn ");"
+
+def emitDel (x : VarId) : M Unit := do
+  emit "lean_free_object("; emit x; emitLn ");"
+
+def emitSetTag (x : VarId) (i : Nat) : M Unit := do
+  emit "lean_ctor_set_tag("; emit x; emit ", "; emit i; emitLn ");"
+
+def emitSet (x : VarId) (i : Nat) (y : Arg) : M Unit := do
+  emit "lean_ctor_set("; emit x; emit ", "; emit i; emit ", "; emitArg y; emitLn ");"
+
+def emitOffset (n : Nat) (offset : Nat) : M Unit := do
+  if n > 0 then
+    emit "sizeof(void*)*"; emit n;
+    if offset > 0 then emit " + "; emit offset
+  else
+    emit offset
+
+def emitUSet (x : VarId) (n : Nat) (y : VarId) : M Unit := do
+  emit "lean_ctor_set_usize("; emit x; emit ", "; emit n; emit ", "; emit y; emitLn ");"
+
+def emitSSet (x : VarId) (n : Nat) (offset : Nat) (y : VarId) (t : IRType) : M Unit := do
+  match t with
+  | IRType.float   => emit "lean_ctor_set_float"
+  | IRType.float32 => emit "lean_ctor_set_float32"
+  | IRType.uint8   => emit "lean_ctor_set_uint8"
+  | IRType.uint16  => emit "lean_ctor_set_uint16"
+  | IRType.uint32  => emit "lean_ctor_set_uint32"
+  | IRType.uint64  => emit "lean_ctor_set_uint64"
+  | _              => throw "invalid instruction";
+  emit "("; emit x; emit ", "; emitOffset n offset; emit ", "; emit y; emitLn ");"
+
+def emitJmp (j : JoinPointId) (xs : Array Arg) : M Unit := do
+  let ps ← getJPParams j
+  if h : xs.size = ps.size then
+    xs.size.forM fun i _ => do
+      let p := ps[i]
+      let x := xs[i]
+      emit p.x; emit " = "; emitArg x; emitLn ";"
+    emit "goto "; emit j; emitLn ";"
+  else
+    do throw "invalid goto"
+
+def emitLhs (z : VarId) : M Unit := do
+  emit z; emit " = "
+
+def emitArgs (ys : Array Arg) : M Unit :=
+  ys.size.forM fun i _ => do
+    if i > 0 then emit ", "
+    emitArg ys[i]
+
+def emitCtorScalarSize (usize : Nat) (ssize : Nat) : M Unit := do
+  if usize == 0 then emit ssize
+  else if ssize == 0 then emit "sizeof(size_t)*"; emit usize
+  else emit "sizeof(size_t)*"; emit usize; emit " + "; emit ssize
+
+def emitAllocCtor (c : CtorInfo) : M Unit := do
+  emit "lean_alloc_ctor("; emit c.cidx; emit ", "; emit c.size; emit ", "
+  emitCtorScalarSize c.usize c.ssize; emitLn ");"
+
+def emitCtorSetArgs (z : VarId) (ys : Array Arg) : M Unit :=
+  ys.size.forM fun i _ => do
+    emit "lean_ctor_set("; emit z; emit ", "; emit i; emit ", "; emitArg ys[i]; emitLn ");"
+
+def emitCtor (z : VarId) (c : CtorInfo) (ys : Array Arg) : M Unit := do
+  emitLhs z;
+  if c.size == 0 && c.usize == 0 && c.ssize == 0 then do
+    emit "lean_box("; emit c.cidx; emitLn ");"
+  else do
+    emitAllocCtor c; emitCtorSetArgs z ys
+
+def emitReset (z : VarId) (n : Nat) (x : VarId) : M Unit := do
+  emit "if (lean_is_exclusive("; emit x; emitLn ")) {";
+  n.forM fun i _ => do
+    emit " lean_ctor_release("; emit x; emit ", "; emit i; emitLn ");"
+  emit " "; emitLhs z; emit x; emitLn ";";
+  emitLn "} else {";
+  emit " lean_dec_ref("; emit x; emitLn ");";
+  emit " "; emitLhs z; emitLn "lean_box(0);";
+  emitLn "}"
+
+def emitReuse (z : VarId) (x : VarId) (c : CtorInfo) (updtHeader : Bool) (ys : Array Arg) : M Unit := do
+  emit "if (lean_is_scalar("; emit x; emitLn ")) {";
+  emit " "; emitLhs z; emitAllocCtor c;
+  emitLn "} else {";
+  emit " "; emitLhs z; emit x; emitLn ";";
+  if updtHeader then emit " lean_ctor_set_tag("; emit z; emit ", "; emit c.cidx; emitLn ");"
+  emitLn "}";
+  emitCtorSetArgs z ys
+
+def emitProj (z : VarId) (i : Nat) (x : VarId) : M Unit := do
+  emitLhs z; emit "lean_ctor_get("; emit x; emit ", "; emit i; emitLn ");"
+
+def emitUProj (z : VarId) (i : Nat) (x : VarId) : M Unit := do
+  emitLhs z; emit "lean_ctor_get_usize("; emit x; emit ", "; emit i; emitLn ");"
+
+def emitSProj (z : VarId) (t : IRType) (n offset : Nat) (x : VarId) : M Unit := do
+  emitLhs z;
+  match t with
+  | IRType.float    => emit "lean_ctor_get_float"
+  | IRType.float32  => emit "lean_ctor_get_float32"
+  | IRType.uint8    => emit "lean_ctor_get_uint8"
+  | IRType.uint16   => emit "lean_ctor_get_uint16"
+  | IRType.uint32   => emit "lean_ctor_get_uint32"
+  | IRType.uint64   => emit "lean_ctor_get_uint64"
+  | _               => throw "invalid instruction"
+  emit "("; emit x; emit ", "; emitOffset n offset; emitLn ");"
+
+def toStringArgs (ys : Array Arg) : List String :=
+  ys.toList.map argToCString
+
+def emitSimpleExternalCall (f : String) (ps : Array Param) (ys : Array Arg) : M Unit := do
+  emit f; emit "("
+  -- We must remove irrelevant arguments to extern calls.
+  discard <| ys.size.foldM
+    (fun i _ (first : Bool) =>
+      if ps[i]!.ty.isIrrelevant then
+        pure first
+      else do
+        unless first do emit ", "
+        emitArg ys[i]
+        pure false)
+    true
+  emitLn ");"
+  pure ()
+
+def emitExternCall (f : FunId) (ps : Array Param) (extData : ExternAttrData) (ys : Array Arg) : M Unit :=
+  match getExternEntryFor extData `c with
+  | some (ExternEntry.standard _ extFn) => emitSimpleExternalCall extFn ps ys
+  | some (ExternEntry.inline _ pat)     => do emit (expandExternPattern pat (toStringArgs ys)); emitLn ";"
+  | _ => throw s!"failed to emit extern application '{f}'"
+
+def emitFullApp (z : VarId) (f : FunId) (ys : Array Arg) : M Unit := do
+  emitLhs z
+  let decl ← getDecl f
+  match decl with
+  | .fdecl .. | .extern _ _ _ { entries := [.opaque _], .. } =>
+    emitCName f
+    if ys.size > 0 then emit "("; emitArgs ys; emit ")"
+    emitLn ";"
+  | Decl.extern _ ps _ extData => emitExternCall f ps extData ys
+
+def emitPartialApp (z : VarId) (f : FunId) (ys : Array Arg) : M Unit := do
+  let decl ← getDecl f
+  let arity := decl.params.size;
+  emitLhs z; emit "lean_alloc_closure((void*)("; emitCName f; emit "), "; emit arity; emit ", "; emit ys.size; emitLn ");";
+  ys.size.forM fun i _ => do
+    let y := ys[i]
+    emit "lean_closure_set("; emit z; emit ", "; emit i; emit ", "; emitArg y; emitLn ");"
+
+def emitApp (z : VarId) (f : VarId) (ys : Array Arg) : M Unit :=
+  if ys.size > closureMaxArgs then do
+    emit "{ lean_object* _aargs[] = {"; emitArgs ys; emitLn "};";
+    emitLhs z; emit "lean_apply_m("; emit f; emit ", "; emit ys.size; emitLn ", _aargs); }"
+  else do
+    emitLhs z; emit "lean_apply_"; emit ys.size; emit "("; emit f; emit ", "; emitArgs ys; emitLn ");"
+
+def emitBoxFn (xType : IRType) : M Unit :=
+  match xType with
+  | IRType.usize   => emit "lean_box_usize"
+  | IRType.uint32  => emit "lean_box_uint32"
+  | IRType.uint64  => emit "lean_box_uint64"
+  | IRType.float   => emit "lean_box_float"
+  | IRType.float32 => emit "lean_box_float32"
+  | _              => emit "lean_box"
+
+def emitBox (z : VarId) (x : VarId) (xType : IRType) : M Unit := do
+  emitLhs z; emitBoxFn xType; emit "("; emit x; emitLn ");"
+
+def emitUnbox (z : VarId) (t : IRType) (x : VarId) : M Unit := do
+  emitLhs z
+  emit (getUnboxOpName t)
+  emit "("; emit x; emitLn ");"
+
+def emitIsShared (z : VarId) (x : VarId) : M Unit := do
+  emitLhs z; emit "!lean_is_exclusive("; emit x; emitLn ");"
+
+def toHexDigit (c : Nat) : String :=
+  String.singleton c.digitChar
+
+def quoteString (s : String) : String :=
+  let q := "\"";
+  let q := s.foldl
+    (fun q c => q ++
+      if c == '\n' then "\\n"
+      else if c == '\r' then "\\r"
+      else if c == '\t' then "\\t"
+      else if c == '\\' then "\\\\"
+      else if c == '\"' then "\\\""
+      else if c == '?' then "\\?" -- avoid trigraphs
+      else if c.toNat <= 31 then
+        "\\x" ++ toHexDigit (c.toNat / 16) ++ toHexDigit (c.toNat % 16)
+      -- TODO(Leo): we should use `\unnnn` for escaping unicode characters.
+      else String.singleton c)
+    q;
+  q ++ "\""
+
+def emitNumLit (t : IRType) (v : Nat) : M Unit := do
+  if t.isObj then
+    if v < UInt32.size then
+      emit "lean_unsigned_to_nat("; emit v; emit "u)"
+    else
+      emit "lean_cstr_to_nat(\""; emit v; emit "\")"
+  else
+    if v < UInt32.size then
+      emit v
+    else if t == .usize then
+      emit "((size_t)"
+      emit v
+      emit "ULL)"
+    else
+      emit v
+      emit "ULL"
+
+def emitLit (z : VarId) (t : IRType) (v : LitVal) : M Unit := do
+  emitLhs z;
+  match v with
+  | LitVal.num v => emitNumLit t v; emitLn ";"
+  | LitVal.str v =>
+    emit "lean_mk_string_unchecked(";
+    emit (quoteString v); emit ", ";
+    emit v.utf8ByteSize; emit ", ";
+    emit v.length; emitLn ");"
+
+def emitVDecl (z : VarId) (t : IRType) (v : Expr) : M Unit :=
+  match v with
+  | Expr.ctor c ys      => emitCtor z c ys
+  | Expr.reset n x      => emitReset z n x
+  | Expr.reuse x c u ys => emitReuse z x c u ys
+  | Expr.proj i x       => emitProj z i x
+  | Expr.uproj i x      => emitUProj z i x
+  | Expr.sproj n o x    => emitSProj z t n o x
+  | Expr.fap c ys       => emitFullApp z c ys
+  | Expr.pap c ys       => emitPartialApp z c ys
+  | Expr.ap x ys        => emitApp z x ys
+  | Expr.box t x        => emitBox z x t
+  | Expr.unbox x        => emitUnbox z t x
+  | Expr.isShared x     => emitIsShared z x
+  | Expr.lit v          => emitLit z t v
+
+def isTailCall (x : VarId) (v : Expr) (b : FnBody) : M Bool := do
+  let ctx ← read;
+  match v, b with
+  | Expr.fap f _, FnBody.ret (Arg.var y) => return f == ctx.mainFn && x == y
+  | _, _ => pure false
+
+def paramEqArg (p : Param) (x : Arg) : Bool :=
+  match x with
+  | Arg.var x => p.x == x
+  | _ => false
+
+/--
+Given `[p_0, ..., p_{n-1}]`, `[y_0, ..., y_{n-1}]`, representing the assignments
+```
+p_0 := y_0,
+...
+p_{n-1} := y_{n-1}
+```
+Return true iff we have `(i, j)` where `j > i`, and `y_j == p_i`.
+That is, we have
+```
+      p_i := y_i,
+      ...
+      p_j := p_i, -- p_i was overwritten above
+```
+-/
+def overwriteParam (ps : Array Param) (ys : Array Arg) : Bool :=
+  let n := ps.size;
+  n.any fun i _ =>
+    let p := ps[i]
+    (i+1, n).anyI fun j _ _ => paramEqArg p ys[j]!
+
+def emitTailCall (v : Expr) : M Unit :=
+  match v with
+  | Expr.fap _ ys => do
+    let ctx ← read
+    let ps := ctx.mainParams
+    if h : ps.size = ys.size then
+      if overwriteParam ps ys then
+        emitLn "{"
+        ps.size.forM fun i _ => do
+          let p := ps[i]
+          let y := ys[i]
+          unless paramEqArg p y do
+            emit (toCType p.ty); emit " _tmp_"; emit i; emit " = "; emitArg y; emitLn ";"
+        ps.size.forM fun i _ => do
+          let p := ps[i]
+          let y := ys[i]
+          unless paramEqArg p y do emit p.x; emit " = _tmp_"; emit i; emitLn ";"
+        emitLn "}"
+      else
+        ys.size.forM fun i _ => do
+          let p := ps[i]
+          let y := ys[i]
+          unless paramEqArg p y do emit p.x; emit " = "; emitArg y; emitLn ";"
+      emitLn "goto _start;"
+    else
+      throw "invalid tail call"
+  | _ => throw "bug at emitTailCall"
+
+mutual
+
+partial def emitIf (x : VarId) (xType : IRType) (tag : Nat) (t : FnBody) (e : FnBody) : M Unit := do
+  emit "if ("; emitTag x xType; emit " == "; emit tag; emitLn ")";
+  emitFnBody t;
+  emitLn "else";
+  emitFnBody e
+
+partial def emitCase (x : VarId) (xType : IRType) (alts : Array Alt) : M Unit :=
+  match isIf alts with
+  | some (tag, t, e) => emitIf x xType tag t e
+  | _ => do
+    emit "switch ("; emitTag x xType; emitLn ") {";
+    let alts := ensureHasDefault alts;
+    alts.forM fun alt => do
+      match alt with
+      | Alt.ctor c b  => emit "case "; emit c.cidx; emitLn ":"; emitFnBody b
+      | Alt.default b => emitLn "default: "; emitFnBody b
+    emitLn "}"
+
+partial def emitBlock (b : FnBody) : M Unit := do
+  match b with
+  | FnBody.jdecl _ _  _ b      => emitBlock b
+  | d@(FnBody.vdecl x t v b)   =>
+    let ctx ← read
+    if isTailCallTo ctx.mainFn d then
+      emitTailCall v
+    else
+      emitVDecl x t v
+      emitBlock b
+  | FnBody.inc x n c p b       =>
+    unless p do emitInc x n c
+    emitBlock b
+  | FnBody.dec x n c p b       =>
+    unless p do emitDec x n c
+    emitBlock b
+  | FnBody.del x b             => emitDel x; emitBlock b
+  | FnBody.setTag x i b        => emitSetTag x i; emitBlock b
+  | FnBody.set x i y b         => emitSet x i y; emitBlock b
+  | FnBody.uset x i y b        => emitUSet x i y; emitBlock b
+  | FnBody.sset x i o y t b    => emitSSet x i o y t; emitBlock b
+  | FnBody.mdata _ b           => emitBlock b
+  | FnBody.ret x               => emit "return "; emitArg x; emitLn ";"
+  | FnBody.case _ x xType alts => emitCase x xType alts
+  | FnBody.jmp j xs            => emitJmp j xs
+  | FnBody.unreachable         => emitLn "lean_internal_panic_unreachable();"
+
+partial def emitJPs : FnBody → M Unit
+  | FnBody.jdecl j _  v b => do emit j; emitLn ":"; emitFnBody v; emitJPs b
+  | e                     => do unless e.isTerminal do emitJPs e.body
+
+partial def emitFnBody (b : FnBody) : M Unit := do
+  emitLn "{"
+  let declared ← declareVars b false
+  if declared then emitLn ""
+  emitBlock b
+  emitJPs b
+  emitLn "}"
+
+end
+
+def emitDeclAux (d : Decl) : M Unit := do
+  let env ← getEnv
+  let (_, jpMap) := mkVarJPMaps d
+  withReader (fun ctx => { ctx with jpMap := jpMap }) do
+  unless hasInitAttr env d.name do
+    match d with
+    | .fdecl (f := f) (xs := xs) (type := t) (body := b) .. =>
+      let baseName ← toCName f;
+      if xs.size == 0 then
+        emit "static "
+      else
+        emit "LEAN_EXPORT "  -- make symbol visible to the interpreter
+      emit (toCType t); emit " ";
+      if xs.size > 0 then
+        emit baseName;
+        emit "(";
+        if xs.size > closureMaxArgs && isBoxedName d.name then
+          emit "lean_object** _args"
+        else
+          xs.size.forM fun i _ => do
+            if i > 0 then emit ", "
+            let x := xs[i]
+            emit (toCType x.ty); emit " "; emit x.x
+        emit ")"
+      else
+        emit ("_init_" ++ baseName ++ "()")
+      emitLn " {";
+      if xs.size > closureMaxArgs && isBoxedName d.name then
+        xs.size.forM fun i _ => do
+          let x := xs[i]!
+          emit "lean_object* "; emit x.x; emit " = _args["; emit i; emitLn "];"
+      emitLn "_start:";
+      withReader (fun ctx => { ctx with mainFn := f, mainParams := xs }) (emitFnBody b);
+      emitLn "}"
+    | _ => pure ()
+
+def emitDecl (d : Decl) : M Unit := do
+  let d := d.normalizeIds; -- ensure we don't have gaps in the variable indices
+  try
+    emitDeclAux d
+  catch err =>
+    throw s!"{err}\ncompiling:\n{d}"
+
+def emitFns : M Unit := do
+  let env ← getEnv;
+  let decls := getDecls env;
+  decls.reverse.forM emitDecl
+
+def emitMarkPersistent (d : Decl) (n : Name) : M Unit := do
+  if d.resultType.isObj then
+    emit "lean_mark_persistent("
+    emitCName n
+    emitLn ");"
+
+def emitDeclInit (d : Decl) : M Unit := do
+  let env ← getEnv
+  let n := d.name
+  if isIOUnitInitFn env n then
+    if isIOUnitBuiltinInitFn env n then
+      emit "if (builtin) {"
+    emit "res = "; emitCName n; emitLn "(lean_io_mk_world());"
+    emitLn "if (lean_io_result_is_error(res)) return res;"
+    emitLn "lean_dec_ref(res);"
+    if isIOUnitBuiltinInitFn env n then
+      emit "}"
+  else if d.params.size == 0 then
+    match getInitFnNameFor? env d.name with
+    | some initFn =>
+      if getBuiltinInitFnNameFor? env d.name |>.isSome then
+        emit "if (builtin) {"
+      emit "res = "; emitCName initFn; emitLn "(lean_io_mk_world());"
+      emitLn "if (lean_io_result_is_error(res)) return res;"
+      emitCName n
+      if d.resultType.isScalar then
+        emitLn (" = " ++ getUnboxOpName d.resultType ++ "(lean_io_result_get_value(res));")
+      else
+        emitLn " = lean_io_result_get_value(res);"
+        emitMarkPersistent d n
+      emitLn "lean_dec_ref(res);"
+      if getBuiltinInitFnNameFor? env d.name |>.isSome then
+        emit "}"
+    | _ =>
+      emitCName n; emit " = "; emitCInitName n; emitLn "();"; emitMarkPersistent d n
+
+def emitInitFn : M Unit := do
+  let env ← getEnv
+  let modName ← getModName
+  env.imports.forM fun imp => emitLn ("lean_object* " ++ mkModuleInitializationFunctionName imp.module ++ "(uint8_t builtin, lean_object*);")
+  emitLns [
+    "static bool _G_initialized = false;",
+    "LEAN_EXPORT lean_object* " ++ mkModuleInitializationFunctionName modName ++ "(uint8_t builtin, lean_object* w) {",
+    "lean_object * res;",
+    "if (_G_initialized) return lean_io_result_mk_ok(lean_box(0));",
+    "_G_initialized = true;"
+  ]
+  env.imports.forM fun imp => emitLns [
+    "res = " ++ mkModuleInitializationFunctionName imp.module ++ "(builtin, lean_io_mk_world());",
+    "if (lean_io_result_is_error(res)) return res;",
+    "lean_dec_ref(res);"]
+  let decls := getDecls env
+  decls.reverse.forM emitDeclInit
+  emitLns ["return lean_io_result_mk_ok(lean_box(0));", "}"]
+
+def main : M Unit := do
+  emitFileHeader
+  emitFnDecls
+  emitFns
+  emitInitFn
+  emitMainFnIfNeeded
+  emitFileFooter
+
+end EmitC
+
+@[export lean_ir_emit_c]
+def emitC (env : Environment) (modName : Name) : Except String String :=
+  match (EmitC.main { env := env, modName := modName }).run "" with
+  | EStateM.Result.ok    _   s => Except.ok s
+  | EStateM.Result.error err _ => Except.error err
+
+end Lean.IR

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/EmitLLVM.lean

@@ -0,0 +1,1657 @@
+/-
+Copyright (c) 2022 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Siddharth Bhat
+-/
+prelude
+import Lean.Runtime
+import Lean.Compiler.NameMangling
+import Lean.Compiler.ExportAttr
+import Lean.Compiler.InitAttr
+import Lean.Compiler.IR.CompilerM
+import Lean.Compiler.IR.EmitUtil
+import Lean.Compiler.IR.NormIds
+import Lean.Compiler.IR.SimpCase
+import Lean.Compiler.IR.Boxing
+import Lean.Compiler.IR.ResetReuse
+import Lean.Compiler.IR.LLVMBindings
+
+open Lean.IR.ExplicitBoxing (isBoxedName)
+
+namespace Lean.IR
+
+def leanMainFn := "_lean_main"
+
+namespace LLVM
+-- TODO(bollu): instantiate target triple and find out what size_t is.
+def size_tType (llvmctx : LLVM.Context) : BaseIO (LLVM.LLVMType llvmctx) :=
+  LLVM.i64Type llvmctx
+
+-- TODO(bollu): instantiate target triple and find out what unsigned is.
+def unsignedType (llvmctx : LLVM.Context) : BaseIO (LLVM.LLVMType llvmctx) :=
+  LLVM.i32Type llvmctx
+
+-- Helper to add a function if it does not exist, and to return the function handle if it does.
+def getOrAddFunction (m : LLVM.Module ctx) (name : String) (type : LLVM.LLVMType ctx) : BaseIO (LLVM.Value ctx) :=  do
+  match (← LLVM.getNamedFunction m name) with
+  | some fn => return fn
+  | none =>
+    /-
+    By the evidence shown in: https://github.com/leanprover/lean4/issues/2373#issuecomment-1658743284
+    this is how clang implements `-fstack-clash-protection` in the LLVM IR, we want this feature
+    for robust stack overflow detection.
+    -/
+    let fn ← LLVM.addFunction m name type
+    let attr ← LLVM.createStringAttribute "probe-stack" "inline-asm"
+    LLVM.addAttributeAtIndex fn LLVM.AttributeIndex.AttributeFunctionIndex attr
+    return fn
+
+def getOrAddGlobal (m : LLVM.Module ctx) (name : String) (type : LLVM.LLVMType ctx) : BaseIO (LLVM.Value ctx) :=  do
+  match (← LLVM.getNamedGlobal m name) with
+  | .some fn => return fn
+  | .none => LLVM.addGlobal m name type
+
+end LLVM
+
+namespace EmitLLVM
+
+structure Context (llvmctx : LLVM.Context) where
+  env        : Environment
+  modName    : Name
+  jpMap      : JPParamsMap := {}
+  mainFn     : FunId := default
+  mainParams : Array Param := #[]
+  llvmmodule : LLVM.Module llvmctx
+
+structure State (llvmctx : LLVM.Context) where
+  var2val : Std.HashMap VarId (LLVM.LLVMType llvmctx × LLVM.Value llvmctx)
+  jp2bb   : Std.HashMap JoinPointId (LLVM.BasicBlock llvmctx)
+
+abbrev Error := String
+
+abbrev M (llvmctx : LLVM.Context) :=
+  StateRefT (State llvmctx) (ReaderT (Context llvmctx) (ExceptT Error IO))
+
+instance : Inhabited (M llvmctx α) where
+  default := throw "Error: inhabitant"
+
+def addVartoState (x : VarId) (v : LLVM.Value llvmctx) (ty : LLVM.LLVMType llvmctx) : M llvmctx Unit := do
+  modify (fun s => { s with var2val := s.var2val.insert x (ty, v) }) -- add new variable
+
+def addJpTostate (jp : JoinPointId) (bb : LLVM.BasicBlock llvmctx) : M llvmctx Unit :=
+  modify (fun s => { s with jp2bb := s.jp2bb.insert jp bb })
+
+def emitJp (jp : JoinPointId) : M llvmctx (LLVM.BasicBlock llvmctx) := do
+  let state ← get
+  match state.jp2bb[jp]? with
+  | .some bb => return bb
+  | .none => throw s!"unable to find join point {jp}"
+
+def getLLVMModule : M llvmctx (LLVM.Module llvmctx) := Context.llvmmodule <$> read
+
+def getEnv : M llvmctx Environment := Context.env <$> read
+
+def getModName : M llvmctx  Name := Context.modName <$> read
+
+def getDecl (n : Name) : M llvmctx Decl := do
+  let env ← getEnv
+  match findEnvDecl env n with
+  | some d => pure d
+  | none   => throw s!"unknown declaration {n}"
+
+def constInt8 (n : Nat) : M llvmctx (LLVM.Value llvmctx) :=  do
+    LLVM.constInt8 llvmctx (UInt64.ofNat n)
+
+def constInt64 (n : Nat) : M llvmctx (LLVM.Value llvmctx) :=  do
+    LLVM.constInt64 llvmctx (UInt64.ofNat n)
+
+def constIntSizeT (n : Nat) : M llvmctx (LLVM.Value llvmctx) :=  do
+    LLVM.constIntSizeT llvmctx (UInt64.ofNat n)
+
+def constIntUnsigned (n : Nat) : M llvmctx (LLVM.Value llvmctx) :=  do
+    LLVM.constIntUnsigned llvmctx (UInt64.ofNat n)
+
+def getOrCreateFunctionPrototype (mod : LLVM.Module llvmctx)
+    (retty : LLVM.LLVMType llvmctx) (name : String) (args : Array (LLVM.LLVMType llvmctx)) : M llvmctx  (LLVM.Value llvmctx) := do
+  LLVM.getOrAddFunction mod name $ ← LLVM.functionType retty args (isVarArg := false)
+
+def callLeanBox (builder : LLVM.Builder llvmctx)
+    (arg : LLVM.Value llvmctx) (name : String := "") : M llvmctx (LLVM.Value llvmctx) := do
+  let fnName :=  "lean_box"
+  let retty ← LLVM.voidPtrType llvmctx
+  let argtys := #[ ← LLVM.size_tType llvmctx ]
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+  let fnty ← LLVM.functionType retty argtys
+  LLVM.buildCall2 builder fnty fn  #[arg] name
+
+def callLeanMarkPersistentFn (builder : LLVM.Builder llvmctx) (arg : LLVM.Value llvmctx) : M llvmctx  Unit := do
+  let fnName :=  "lean_mark_persistent"
+  let retty ← LLVM.voidType llvmctx
+  let argtys := #[ ← LLVM.voidPtrType llvmctx ]
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+  let fnty ← LLVM.functionType retty argtys
+  let _ ←   LLVM.buildCall2 builder fnty fn  #[arg]
+
+-- `lean_{inc, dec}_{ref?}_{1,n}`
+inductive RefcountKind where
+  | inc | dec
+
+instance : ToString RefcountKind where
+  toString
+    | .inc => "inc"
+    | .dec => "dec"
+
+def callLeanRefcountFn (builder : LLVM.Builder llvmctx)
+    (kind : RefcountKind) (checkRef? : Bool) (arg : LLVM.Value llvmctx)
+    (delta : Option (LLVM.Value llvmctx) := Option.none) : M llvmctx Unit := do
+  let fnName :=  s!"lean_{kind}{if checkRef? then "" else "_ref"}{if delta.isNone then "" else "_n"}"
+  let retty ← LLVM.voidType llvmctx
+  let argtys ← if delta.isNone then pure #[← LLVM.voidPtrType llvmctx] else pure #[← LLVM.voidPtrType llvmctx, ← LLVM.size_tType llvmctx]
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+  let fnty ← LLVM.functionType retty argtys
+  match delta with
+  | .none => do
+    -- since refcount δ is 1, we only supply the pointer.
+    let _ ← LLVM.buildCall2 builder fnty fn #[arg]
+  | .some n => do
+    let _ ← LLVM.buildCall2 builder fnty fn #[arg, n]
+
+-- `decRef1`
+-- Do NOT attempt to merge this code with callLeanRefcountFn, because of the uber confusing
+-- semantics of 'ref?'. If 'ref?' is true, it calls the version that is lean_dec
+def callLeanDecRef (builder : LLVM.Builder llvmctx) (res : LLVM.Value llvmctx) : M llvmctx Unit := do
+  let fnName :=  "lean_dec_ref"
+  let retty ← LLVM.voidType llvmctx
+  let argtys := #[ ← LLVM.i8PtrType llvmctx ]
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+  let fnty ← LLVM.functionType retty argtys
+  let _ ← LLVM.buildCall2 builder fnty fn  #[res]
+
+def callLeanUnsignedToNatFn (builder : LLVM.Builder llvmctx)
+    (n : Nat) (name : String := "") : M llvmctx (LLVM.Value llvmctx) := do
+  let mod ← getLLVMModule
+  let argtys := #[← LLVM.i32Type llvmctx]
+  let retty ← LLVM.voidPtrType llvmctx
+  let f ←   getOrCreateFunctionPrototype mod retty "lean_unsigned_to_nat"  argtys
+  let fnty ← LLVM.functionType retty argtys
+  let nv ← constIntUnsigned n
+  LLVM.buildCall2 builder fnty f #[nv] name
+
+def callLeanMkStringUncheckedFn (builder : LLVM.Builder llvmctx)
+    (strPtr nBytes nChars : LLVM.Value llvmctx) (name : String) : M llvmctx (LLVM.Value llvmctx) := do
+  let fnName :=  "lean_mk_string_unchecked"
+  let retty ← LLVM.voidPtrType llvmctx
+  let argtys :=  #[← LLVM.voidPtrType llvmctx, ← LLVM.size_tType llvmctx, ← LLVM.size_tType llvmctx]
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+  let fnty ← LLVM.functionType retty argtys
+  LLVM.buildCall2 builder fnty fn #[strPtr, nBytes, nChars] name
+
+def callLeanMkString (builder : LLVM.Builder llvmctx)
+    (strPtr : LLVM.Value llvmctx) (name : String) : M llvmctx (LLVM.Value llvmctx) := do
+  let retty ← LLVM.voidPtrType llvmctx
+  let argtys :=  #[← LLVM.voidPtrType llvmctx]
+  let fn ←  getOrCreateFunctionPrototype (← getLLVMModule) retty "lean_mk_string" argtys
+  let fnty ← LLVM.functionType retty argtys
+  LLVM.buildCall2 builder fnty fn #[strPtr] name
+
+def callLeanCStrToNatFn (builder : LLVM.Builder llvmctx)
+    (n : Nat) (name : String := "") : M llvmctx (LLVM.Value llvmctx) := do
+  let fnName :=  "lean_cstr_to_nat"
+  let retty ← LLVM.voidPtrType llvmctx
+  let argtys :=  #[← LLVM.voidPtrType llvmctx]
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+  let fnty ← LLVM.functionType retty argtys
+  let s ← LLVM.buildGlobalString builder (value := toString n)
+  LLVM.buildCall2 builder fnty fn #[s] name
+
+def callLeanIOMkWorld (builder : LLVM.Builder llvmctx) : M llvmctx (LLVM.Value llvmctx) := do
+  let fnName :=  "lean_io_mk_world"
+  let retty ← LLVM.voidPtrType llvmctx
+  let argtys :=  #[]
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+  let fnty ← LLVM.functionType retty argtys
+  LLVM.buildCall2 builder fnty fn #[] "mk_io_out"
+
+def callLeanIOResultIsError (builder : LLVM.Builder llvmctx)
+    (arg : LLVM.Value llvmctx) (name : String := "") : M llvmctx (LLVM.Value llvmctx) := do
+  let fnName :=  "lean_io_result_is_error"
+  let retty ← LLVM.i1Type llvmctx
+  let argtys :=  #[← LLVM.voidPtrType llvmctx]
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+  let fnty ← LLVM.functionType retty argtys
+  LLVM.buildCall2 builder fnty fn #[arg] name
+
+def callLeanAllocCtor (builder : LLVM.Builder llvmctx)
+    (tag num_objs scalar_sz : Nat) (name : String := "") : M llvmctx (LLVM.Value llvmctx) := do
+  let fnName :=  "lean_alloc_ctor"
+  let retty ← LLVM.voidPtrType llvmctx
+  let i32 ← LLVM.i32Type llvmctx
+  let argtys :=  #[i32, i32, i32]
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+  let fnty ← LLVM.functionType retty argtys
+
+  let tag ← constIntUnsigned tag
+  let num_objs ← constIntUnsigned num_objs
+  let scalar_sz ← constIntUnsigned scalar_sz
+  LLVM.buildCall2 builder fnty fn #[tag, num_objs, scalar_sz] name
+
+def callLeanCtorSet (builder : LLVM.Builder llvmctx)
+    (o i v : LLVM.Value llvmctx) : M llvmctx Unit := do
+  let fnName := "lean_ctor_set"
+  let retty ← LLVM.voidType llvmctx
+  let voidptr ← LLVM.voidPtrType llvmctx
+  let unsigned ← LLVM.unsignedType llvmctx
+  let argtys :=  #[voidptr, unsigned, voidptr]
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+  let fnty ← LLVM.functionType retty argtys
+  _ <- LLVM.buildCall2 builder fnty fn  #[o, i, v]
+
+def callLeanIOResultMKOk (builder : LLVM.Builder llvmctx)
+    (v : LLVM.Value llvmctx) (name : String := "") : M llvmctx (LLVM.Value llvmctx) := do
+  let fnName :=  "lean_io_result_mk_ok"
+  let voidptr ← LLVM.voidPtrType llvmctx
+  let retty := voidptr
+  let argtys :=  #[voidptr]
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+  let fnty ← LLVM.functionType retty argtys
+  LLVM.buildCall2 builder fnty fn #[v] name
+
+def callLeanAllocClosureFn (builder : LLVM.Builder llvmctx)
+    (f arity nys : LLVM.Value llvmctx) (retName : String := "") : M llvmctx (LLVM.Value llvmctx) := do
+  let fnName :=  "lean_alloc_closure"
+  let retty ← LLVM.voidPtrType llvmctx
+  let argtys := #[ ← LLVM.voidPtrType llvmctx, ← LLVM.unsignedType llvmctx, ← LLVM.unsignedType llvmctx]
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+  let fnty ← LLVM.functionType retty argtys
+  LLVM.buildCall2 builder fnty fn  #[f, arity, nys] retName
+
+def callLeanClosureSetFn (builder : LLVM.Builder llvmctx)
+    (closure ix arg : LLVM.Value llvmctx) (retName : String := "") : M llvmctx Unit := do
+  let fnName :=  "lean_closure_set"
+  let retty ← LLVM.voidType llvmctx
+  let argtys := #[ ← LLVM.voidPtrType llvmctx, ← LLVM.unsignedType llvmctx, ← LLVM.voidPtrType llvmctx]
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+  let fnty ← LLVM.functionType retty argtys
+  let _ ← LLVM.buildCall2 builder fnty fn  #[closure, ix, arg] retName
+
+def callLeanObjTag (builder : LLVM.Builder llvmctx)
+    (closure : LLVM.Value llvmctx) (retName : String := "") : M llvmctx (LLVM.Value llvmctx) := do
+  let fnName :=  "lean_obj_tag"
+  let retty ← LLVM.i32Type llvmctx
+  let argtys := #[ ← LLVM.voidPtrType llvmctx]
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+  let fnty ← LLVM.functionType retty argtys
+  let out ← LLVM.buildCall2 builder fnty fn  #[closure] retName
+  LLVM.buildSextOrTrunc builder out (← LLVM.i64Type llvmctx)
+
+def callLeanIOResultGetValue (builder : LLVM.Builder llvmctx)
+    (v : LLVM.Value llvmctx) (name : String := "") : M llvmctx (LLVM.Value llvmctx) := do
+  let fnName :=  "lean_io_result_get_value"
+  let retty ← LLVM.voidPtrType llvmctx
+  let argtys := #[ ← LLVM.voidPtrType llvmctx]
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+  let fnty ← LLVM.functionType retty argtys
+  LLVM.buildCall2 builder fnty fn #[v] name
+
+def callLeanCtorRelease (builder : LLVM.Builder llvmctx)
+    (closure i : LLVM.Value llvmctx) (retName : String := "") : M llvmctx Unit := do
+  let fnName :=  "lean_ctor_release"
+  let retty ← LLVM.voidType llvmctx
+  let argtys := #[ ← LLVM.voidPtrType llvmctx, ← LLVM.unsignedType llvmctx]
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+  let fnty ← LLVM.functionType retty argtys
+  let _ ← LLVM.buildCall2 builder fnty fn  #[closure, i] retName
+
+def callLeanCtorSetTag (builder : LLVM.Builder llvmctx)
+    (closure i : LLVM.Value llvmctx) (retName : String := "") : M llvmctx Unit := do
+  let fnName :=  "lean_ctor_set_tag"
+  let retty ← LLVM.voidType llvmctx
+  let argtys := #[ ← LLVM.voidPtrType llvmctx, ← LLVM.i8Type llvmctx]
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+  let fnty ← LLVM.functionType retty argtys
+  let _ ← LLVM.buildCall2 builder fnty fn  #[closure, i] retName
+
+def toLLVMType (t : IRType) : M llvmctx (LLVM.LLVMType llvmctx) := do
+  match t with
+  | IRType.float      => LLVM.doubleTypeInContext llvmctx
+  | IRType.float32    => LLVM.floatTypeInContext llvmctx
+  | IRType.uint8      => LLVM.intTypeInContext llvmctx 8
+  | IRType.uint16     => LLVM.intTypeInContext llvmctx 16
+  | IRType.uint32     => LLVM.intTypeInContext llvmctx 32
+  | IRType.uint64     => LLVM.intTypeInContext llvmctx 64
+  -- TODO: how to cleanly size_t in LLVM? We can do eg. instantiate the current target and query for size.
+  | IRType.usize      => LLVM.size_tType llvmctx
+  | IRType.object     => do LLVM.pointerType (← LLVM.i8Type llvmctx)
+  | IRType.tobject    => do LLVM.pointerType (← LLVM.i8Type llvmctx)
+  | IRType.irrelevant => do LLVM.pointerType (← LLVM.i8Type llvmctx)
+  | IRType.struct _ _ => panic! "not implemented yet"
+  | IRType.union _ _  => panic! "not implemented yet"
+
+def throwInvalidExportName {α : Type} (n : Name) : M llvmctx α := do
+  throw s!"invalid export name {n.toString}"
+
+def toCName (n : Name) : M llvmctx String := do
+  match getExportNameFor? (← getEnv) n with
+  | some (.str .anonymous s) => pure s
+  | some _                   => throwInvalidExportName n
+  | none                     => if n == `main then pure leanMainFn else pure n.mangle
+
+def toCInitName (n : Name) : M llvmctx String := do
+  match getExportNameFor? (← getEnv) n with
+  | some (.str .anonymous s) => return "_init_" ++ s
+  | some _                   => throwInvalidExportName n
+  | none                     => pure ("_init_" ++ n.mangle)
+
+/--
+## LLVM Control flow Utilities
+-/
+
+-- Indicates whether the API for building the blocks for then/else should
+-- forward the control flow to the merge block.
+inductive ShouldForwardControlFlow where
+| yes | no
+
+-- Get the function we are currently inserting into.
+def builderGetInsertionFn (builder : LLVM.Builder llvmctx) : M llvmctx (LLVM.Value llvmctx) := do
+  let builderBB ← LLVM.getInsertBlock builder
+  LLVM.getBasicBlockParent builderBB
+
+def builderAppendBasicBlock (builder : LLVM.Builder llvmctx) (name : String) : M llvmctx (LLVM.BasicBlock llvmctx) := do
+  let fn ← builderGetInsertionFn builder
+  LLVM.appendBasicBlockInContext llvmctx fn name
+
+/--
+Add an alloca to the first BB of the current function. The builders final position
+will be the end of the BB that we came from.
+
+If it is possible to put an alloca in the first BB this approach is to be preferred
+over putting it in other BBs. This is because mem2reg only inspects allocas in the first BB,
+leading to missed optimizations for allocas in other BBs.
+-/
+def buildPrologueAlloca (builder : LLVM.Builder llvmctx) (ty : LLVM.LLVMType llvmctx) (name : @&String := "") : M llvmctx (LLVM.Value llvmctx) := do
+  let origBB ← LLVM.getInsertBlock builder
+
+  let fn ← builderGetInsertionFn builder
+  if (← LLVM.countBasicBlocks fn) == 0 then
+    throw "Attempt to obtain first BB of function without BBs"
+
+  let entryBB ← LLVM.getEntryBasicBlock fn
+  match ← LLVM.getFirstInstruction entryBB with
+  | some instr => LLVM.positionBuilderBefore builder instr
+  | none => LLVM.positionBuilderAtEnd builder entryBB
+
+  let alloca ← LLVM.buildAlloca builder ty name
+  LLVM.positionBuilderAtEnd builder origBB
+  return alloca
+
+
+def buildWhile_ (builder : LLVM.Builder llvmctx) (name : String)
+    (condcodegen : LLVM.Builder llvmctx → M llvmctx (LLVM.Value llvmctx))
+    (bodycodegen : LLVM.Builder llvmctx → M llvmctx Unit) : M llvmctx Unit := do
+  let fn ← builderGetInsertionFn builder
+
+  let nameHeader := name ++ "header"
+  let nameBody := name ++ "body"
+  let nameMerge := name ++ "merge"
+
+  -- cur → header
+  let headerbb ← LLVM.appendBasicBlockInContext llvmctx fn nameHeader
+  let _ ← LLVM.buildBr builder headerbb
+
+  let bodybb ← LLVM.appendBasicBlockInContext llvmctx fn nameBody
+  let mergebb ← LLVM.appendBasicBlockInContext llvmctx fn nameMerge
+
+  -- header → {body, merge}
+  LLVM.positionBuilderAtEnd builder headerbb
+  let cond ← condcodegen builder
+  let _ ← LLVM.buildCondBr builder cond bodybb mergebb
+
+  -- body → header
+  LLVM.positionBuilderAtEnd builder bodybb
+  bodycodegen builder
+  let _ ← LLVM.buildBr builder headerbb
+
+  -- merge
+  LLVM.positionBuilderAtEnd builder mergebb
+
+-- build an if, and position the builder at the merge basic block after execution.
+-- The '_' denotes that we return Unit on each branch.
+def buildIfThen_ (builder : LLVM.Builder llvmctx) (name : String) (brval : LLVM.Value llvmctx)
+    (thencodegen : LLVM.Builder llvmctx → M llvmctx ShouldForwardControlFlow) : M llvmctx Unit := do
+  let fn ← builderGetInsertionFn builder
+
+  let nameThen := name ++ "Then"
+  let nameElse := name ++ "Else"
+  let nameMerge := name ++ "Merge"
+
+  let thenbb ← LLVM.appendBasicBlockInContext llvmctx fn nameThen
+  let elsebb ← LLVM.appendBasicBlockInContext llvmctx fn nameElse
+  let mergebb ← LLVM.appendBasicBlockInContext llvmctx fn nameMerge
+  let _ ← LLVM.buildCondBr builder brval thenbb elsebb
+  -- then
+  LLVM.positionBuilderAtEnd builder thenbb
+  let fwd? ← thencodegen builder
+  match fwd? with
+  | .yes => let _ ← LLVM.buildBr builder mergebb
+  | .no => pure ()
+  -- else
+  LLVM.positionBuilderAtEnd builder elsebb
+  let _ ← LLVM.buildBr builder mergebb
+  -- merge
+  LLVM.positionBuilderAtEnd builder mergebb
+
+def buildIfThenElse_ (builder : LLVM.Builder llvmctx)  (name : String) (brval : LLVM.Value llvmctx)
+    (thencodegen : LLVM.Builder llvmctx → M llvmctx ShouldForwardControlFlow)
+    (elsecodegen : LLVM.Builder llvmctx → M llvmctx ShouldForwardControlFlow) : M llvmctx Unit := do
+  let fn ← LLVM.getBasicBlockParent (← LLVM.getInsertBlock builder)
+  let thenbb ← LLVM.appendBasicBlockInContext llvmctx fn (name ++ "Then")
+  let elsebb ← LLVM.appendBasicBlockInContext llvmctx fn (name ++ "Else")
+  let mergebb ← LLVM.appendBasicBlockInContext llvmctx fn (name ++ "Merge")
+  let _ ← LLVM.buildCondBr builder brval thenbb elsebb
+  -- then
+  LLVM.positionBuilderAtEnd builder thenbb
+  let fwd? ← thencodegen builder
+  match fwd? with
+  | .yes => let _ ← LLVM.buildBr builder mergebb
+  | .no => pure ()
+  -- else
+  LLVM.positionBuilderAtEnd builder elsebb
+  let fwd? ← elsecodegen builder
+  match fwd? with
+  | .yes => let _ ← LLVM.buildBr builder mergebb
+  | .no => pure ()
+  -- merge
+  LLVM.positionBuilderAtEnd builder mergebb
+
+-- Recall that lean uses `i8` for booleans, not `i1`, so we need to compare with `true`.
+def buildLeanBoolTrue? (builder : LLVM.Builder llvmctx)
+    (b : LLVM.Value llvmctx) (name : String := "") : M llvmctx (LLVM.Value llvmctx) := do
+  LLVM.buildICmp builder LLVM.IntPredicate.NE b (← constInt8 0) name
+
+def emitFnDeclAux (mod : LLVM.Module llvmctx)
+    (decl : Decl) (cppBaseName : String) (isExternal : Bool) : M llvmctx (LLVM.Value llvmctx) := do
+  let ps := decl.params
+  let env ← getEnv
+  -- bollu: if we have a declaration with no parameters, then we emit it as a global pointer.
+  -- bollu: Otherwise, we emit it as a function
+  let global ←
+    if ps.isEmpty then
+        let retty ← (toLLVMType decl.resultType)
+        let global ← LLVM.getOrAddGlobal mod cppBaseName retty
+        if !isExternal then
+          LLVM.setInitializer global (← LLVM.getUndef retty)
+        pure global
+    else
+        let retty ← (toLLVMType decl.resultType)
+        let mut argtys := #[]
+        for p in ps do
+          -- if it is extern, then we must not add irrelevant args
+          if !(isExternC env decl.name) || !p.ty.isIrrelevant then
+            argtys := argtys.push (← toLLVMType p.ty)
+        -- TODO (bollu): simplify this API, this code of `closureMaxArgs` is duplicated in multiple places.
+        if argtys.size > closureMaxArgs && isBoxedName decl.name then
+          argtys := #[← LLVM.pointerType (← LLVM.voidPtrType llvmctx)]
+        let fnty ← LLVM.functionType retty argtys (isVarArg := false)
+        LLVM.getOrAddFunction mod cppBaseName fnty
+  -- we must now set symbol visibility for global.
+  if ps.isEmpty then
+    if isClosedTermName env decl.name then LLVM.setVisibility global LLVM.Visibility.hidden -- static
+    else if isExternal then pure () -- extern (Recall that C/LLVM funcs are extern linkage by default.)
+    else LLVM.setDLLStorageClass global LLVM.DLLStorageClass.export  -- LEAN_EXPORT
+  else if !isExternal
+    -- An extern decl might be linked in from a different translation unit.
+    -- Thus, we cannot export an external declaration as we do not define it,
+    -- only declare its presence.
+    -- So, we only export non-external definitions.
+    then LLVM.setDLLStorageClass global LLVM.DLLStorageClass.export
+  return global
+
+
+def emitFnDecl (decl : Decl) (isExternal : Bool) : M llvmctx Unit := do
+  let cppBaseName ← toCName decl.name
+  let _ ← emitFnDeclAux (← getLLVMModule) decl cppBaseName isExternal
+
+def emitExternDeclAux (decl : Decl) (cNameStr : String) : M llvmctx Unit := do
+  let env ← getEnv
+  let extC := isExternC env decl.name
+  let _ ← emitFnDeclAux (← getLLVMModule) decl cNameStr extC
+
+def emitFnDecls : M llvmctx Unit := do
+  let env ← getEnv
+  let decls := getDecls env
+  let modDecls  : NameSet := decls.foldl (fun s d => s.insert d.name) {}
+  let usedDecls : NameSet := decls.foldl (fun s d => collectUsedDecls env d (s.insert d.name)) {}
+  let usedDecls := usedDecls.toList
+  for n in usedDecls do
+    let decl ← getDecl n
+    match getExternNameFor env `c decl.name with
+    | some cName => emitExternDeclAux decl cName
+    | none       => emitFnDecl decl (!modDecls.contains n)
+  return ()
+
+def emitLhsSlot_ (x : VarId) : M llvmctx (LLVM.LLVMType llvmctx × LLVM.Value llvmctx) := do
+  let state ← get
+  match state.var2val[x]? with
+  | .some v => return v
+  | .none => throw s!"unable to find variable {x}"
+
+def emitLhsVal (builder : LLVM.Builder llvmctx)
+    (x : VarId) (name : String := "") : M llvmctx (LLVM.Value llvmctx) := do
+  let (xty, xslot) ← emitLhsSlot_ x
+  LLVM.buildLoad2 builder xty xslot name
+
+def emitLhsSlotStore (builder : LLVM.Builder llvmctx)
+    (x : VarId) (v : LLVM.Value llvmctx) : M llvmctx Unit := do
+  let (_, slot) ← emitLhsSlot_ x
+  LLVM.buildStore builder v slot
+
+def emitArgSlot_ (builder : LLVM.Builder llvmctx)
+    (x : Arg) : M llvmctx (LLVM.LLVMType llvmctx × LLVM.Value llvmctx) := do
+  match x with
+  | Arg.var x => emitLhsSlot_ x
+  | _ => do
+    let slotty ← LLVM.voidPtrType llvmctx
+    let slot ← buildPrologueAlloca builder slotty "irrelevant_slot"
+    let v ← callLeanBox builder (← constIntSizeT 0) "irrelevant_val"
+    let _ ← LLVM.buildStore builder v slot
+    return (slotty, slot)
+
+def emitArgVal (builder : LLVM.Builder llvmctx)
+    (x : Arg) (name : String := "") : M llvmctx (LLVM.LLVMType llvmctx × LLVM.Value llvmctx) := do
+  let (xty, xslot) ← emitArgSlot_ builder x
+  let xval ← LLVM.buildLoad2 builder xty xslot name
+  return (xty, xval)
+
+def emitAllocCtor (builder : LLVM.Builder llvmctx)
+    (c : CtorInfo) : M llvmctx (LLVM.Value llvmctx) := do
+  -- TODO(bollu) : find the correct size, don't assume 'void*' size is 8
+  let hackSizeofVoidPtr := 8
+  let scalarSize := hackSizeofVoidPtr * c.usize + c.ssize
+  callLeanAllocCtor builder c.cidx c.size scalarSize "lean_alloc_ctor_out"
+
+def emitCtorSetArgs (builder : LLVM.Builder llvmctx)
+    (z : VarId) (ys : Array Arg) : M llvmctx Unit := do
+  ys.size.forM fun i _ => do
+    let zv ← emitLhsVal builder z
+    let (_yty, yv) ← emitArgVal builder ys[i]
+    let iv ← constIntUnsigned i
+    callLeanCtorSet builder zv iv yv
+    emitLhsSlotStore builder z zv
+    pure ()
+
+def emitCtor (builder : LLVM.Builder llvmctx)
+    (z : VarId) (c : CtorInfo) (ys : Array Arg) : M llvmctx Unit := do
+  let (_llvmty, slot) ← emitLhsSlot_ z
+  if c.size == 0 && c.usize == 0 && c.ssize == 0 then do
+    let v ← callLeanBox builder (← constIntSizeT c.cidx) "lean_box_outv"
+    let _ ← LLVM.buildStore builder v slot
+  else do
+    let v ← emitAllocCtor builder c
+    let _ ← LLVM.buildStore builder v slot
+    emitCtorSetArgs builder z ys
+
+def emitInc (builder : LLVM.Builder llvmctx)
+    (x : VarId) (n : Nat) (checkRef? : Bool) : M llvmctx Unit := do
+  let xv ← emitLhsVal builder x
+  if n != 1
+  then do
+     let nv ← constIntSizeT n
+     callLeanRefcountFn builder (kind := RefcountKind.inc) (checkRef? := checkRef?) (delta := nv) xv
+  else callLeanRefcountFn builder (kind := RefcountKind.inc) (checkRef? := checkRef?) xv
+
+def emitDec (builder : LLVM.Builder llvmctx)
+    (x : VarId) (n : Nat) (checkRef? : Bool) : M llvmctx Unit := do
+  let xv ← emitLhsVal builder x
+  if n != 1
+  then throw "expected n = 1 for emitDec"
+  else callLeanRefcountFn builder (kind := RefcountKind.dec) (checkRef? := checkRef?) xv
+
+def emitNumLit (builder : LLVM.Builder llvmctx)
+    (t : IRType) (v : Nat) : M llvmctx (LLVM.Value llvmctx) := do
+  if t.isObj then
+    if v < UInt32.size then
+      callLeanUnsignedToNatFn builder v
+    else
+      callLeanCStrToNatFn builder v
+  else
+    LLVM.constInt (← toLLVMType t) (UInt64.ofNat v)
+
+def toHexDigit (c : Nat) : String :=
+  String.singleton c.digitChar
+
+-- TODO(bollu) : Setup code sharing between 'EmitC' and 'EmitLLVM'
+def quoteString (s : String) : String :=
+  let q := "\"";
+  let q := s.foldl
+    (fun q c => q ++
+      if c == '\n' then "\\n"
+      else if c == '\r' then "\\r"
+      else if c == '\t' then "\\t"
+      else if c == '\\' then "\\\\"
+      else if c == '\"' then "\\\""
+      else if c.toNat <= 31 then
+        "\\x" ++ toHexDigit (c.toNat / 16) ++ toHexDigit (c.toNat % 16)
+      -- TODO(Leo) : we should use `\unnnn` for escaping unicode characters.
+      else String.singleton c)
+    q;
+  q ++ "\""
+
+def emitSimpleExternalCall (builder : LLVM.Builder llvmctx)
+    (f : String)
+    (ps : Array Param)
+    (ys : Array Arg)
+    (retty : IRType)
+    (name : String) : M llvmctx (LLVM.Value llvmctx) := do
+  let mut args := #[]
+  let mut argTys := #[]
+  for (p, y) in ps.zip ys do
+    if !p.ty.isIrrelevant then
+      let (_yty, yv) ← emitArgVal builder y ""
+      argTys := argTys.push (← toLLVMType p.ty)
+      args := args.push yv
+  let fnty ← LLVM.functionType (← toLLVMType retty) argTys
+  let fn ← LLVM.getOrAddFunction (← getLLVMModule) f fnty
+  LLVM.buildCall2 builder fnty fn args name
+
+-- TODO: if the external call is one that we cannot code generate, give up and
+-- generate fallback code.
+def emitExternCall (builder : LLVM.Builder llvmctx)
+    (f : FunId)
+    (ps : Array Param)
+    (extData : ExternAttrData)
+    (ys : Array Arg) (retty : IRType)
+    (name : String := "") : M llvmctx (LLVM.Value llvmctx) :=
+  match getExternEntryFor extData `c with
+  | some (ExternEntry.standard _ extFn) => emitSimpleExternalCall builder extFn ps ys retty name
+  | some (ExternEntry.inline `llvm _pat) => throw "Unimplemented codegen of inline LLVM"
+  | some (ExternEntry.inline _ pat) => throw s!"Cannot codegen non-LLVM inline code '{pat}'."
+  | some (ExternEntry.opaque _)  => unreachable!
+  | _ => throw s!"Failed to emit extern application '{f}'."
+
+def getFunIdTy (f : FunId) : M llvmctx (LLVM.LLVMType llvmctx) := do
+  let decl ← getDecl f
+  let retty ← toLLVMType decl.resultType
+  let argtys ← decl.params.mapM (fun p => do toLLVMType p.ty)
+  LLVM.functionType retty argtys
+
+/--
+Create a function declaration and return a pointer to the function.
+If the function actually takes arguments, then we must have a function pointer in scope.
+If the function takes no arguments, then it is a top-level closed term, and its value will
+be stored in a global pointer. So, we load from the global pointer. The type of the global is function pointer pointer.
+This returns a *function pointer.*
+-/
+def getOrAddFunIdValue (builder : LLVM.Builder llvmctx) (f : FunId) : M llvmctx (LLVM.Value llvmctx) := do
+  let decl ← getDecl f
+  let fcname ← toCName f
+  let retty �� toLLVMType decl.resultType
+  if decl.params.isEmpty then
+     let gslot ← LLVM.getOrAddGlobal (← getLLVMModule) fcname retty
+     LLVM.buildLoad2 builder retty gslot
+  else
+    let argtys ← decl.params.mapM (fun p => do toLLVMType p.ty)
+    let fnty ← LLVM.functionType retty argtys
+    LLVM.getOrAddFunction (← getLLVMModule) fcname fnty
+
+def emitPartialApp (builder : LLVM.Builder llvmctx) (z : VarId) (f : FunId) (ys : Array Arg) : M llvmctx Unit := do
+  let decl ← getDecl f
+  let fv ← getOrAddFunIdValue builder f
+  let arity := decl.params.size
+  let (_zty, zslot) ← emitLhsSlot_ z
+  let zval ← callLeanAllocClosureFn builder fv
+                                    (← constIntUnsigned arity)
+                                    (← constIntUnsigned ys.size)
+  LLVM.buildStore builder zval zslot
+  ys.size.forM fun i _ => do
+    let (yty, yslot) ← emitArgSlot_ builder ys[i]
+    let yval ← LLVM.buildLoad2 builder yty yslot
+    callLeanClosureSetFn builder zval (← constIntUnsigned i) yval
+
+def emitApp (builder : LLVM.Builder llvmctx) (z : VarId) (f : VarId) (ys : Array Arg) : M llvmctx Unit := do
+  if ys.size > closureMaxArgs then do
+    let aargs ← buildPrologueAlloca builder (← LLVM.arrayType (← LLVM.voidPtrType llvmctx) (UInt64.ofNat ys.size)) "aargs"
+    for i in List.range ys.size do
+      let (yty, yv) ← emitArgVal builder ys[i]!
+      let aslot ← LLVM.buildInBoundsGEP2 builder yty aargs #[← constIntUnsigned 0, ← constIntUnsigned i] s!"param_{i}_slot"
+      LLVM.buildStore builder yv aslot
+    let fnName :=  s!"lean_apply_m"
+    let retty ← LLVM.voidPtrType llvmctx
+    let args := #[← emitLhsVal builder f, ← constIntUnsigned ys.size, aargs]
+    -- '1 + ...'. '1' for the fn and 'args' for the arguments
+    let argtys := #[← LLVM.voidPtrType llvmctx, ← LLVM.unsignedType llvmctx, ← LLVM.voidPtrType llvmctx]
+    let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+    let fnty ← LLVM.functionType retty argtys
+    let zv ← LLVM.buildCall2 builder fnty fn args
+    emitLhsSlotStore builder z zv
+  else do
+
+    let fnName :=  s!"lean_apply_{ys.size}"
+    let retty ← LLVM.voidPtrType llvmctx
+    let args : Array (LLVM.Value llvmctx) := #[← emitLhsVal builder f] ++ (← ys.mapM (fun y => Prod.snd <$> (emitArgVal builder y)))
+    -- '1 + ...'. '1' for the fn and 'args' for the arguments
+    let argtys := (List.replicate (1 + ys.size) (← LLVM.voidPtrType llvmctx)).toArray
+    let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+    let fnty ← LLVM.functionType retty argtys
+    let zv ← LLVM.buildCall2 builder fnty fn args
+    emitLhsSlotStore builder z zv
+
+def emitFullApp (builder : LLVM.Builder llvmctx)
+    (z : VarId) (f : FunId) (ys : Array Arg) : M llvmctx Unit := do
+  let (__zty, zslot) ← emitLhsSlot_ z
+  let decl ← getDecl f
+  match decl with
+  | .fdecl .. | .extern _ _ _ { entries := [.opaque _] } =>
+    if ys.size > 0 then
+        let fv ← getOrAddFunIdValue builder f
+        let ys ←  ys.mapM (fun y => do
+            let (yty, yslot) ← emitArgSlot_ builder y
+            let yv ← LLVM.buildLoad2 builder yty yslot
+            return yv)
+        let zv ← LLVM.buildCall2 builder (← getFunIdTy f) fv ys
+        LLVM.buildStore builder zv zslot
+    else
+       let zv ← getOrAddFunIdValue builder f
+       LLVM.buildStore builder zv zslot
+  | Decl.extern _ ps retty extData =>
+     let zv ← emitExternCall builder f ps extData ys retty
+     LLVM.buildStore builder zv zslot
+
+-- Note that this returns a *slot*, just like `emitLhsSlot_`.
+def emitLit (builder : LLVM.Builder llvmctx)
+    (z : VarId) (t : IRType) (v : LitVal) : M llvmctx (LLVM.Value llvmctx) := do
+  let llvmty ← toLLVMType t
+  let zslot ← buildPrologueAlloca builder llvmty
+  addVartoState z zslot llvmty
+  let zv ← match v with
+            | LitVal.num v => emitNumLit builder t v
+            | LitVal.str v =>
+                 let zero ← constIntUnsigned 0
+                 let str_global ← LLVM.buildGlobalString builder v
+                 -- access through the global, into the 0th index of the array
+                 let strPtr ← LLVM.buildInBoundsGEP2 builder
+                                (← LLVM.opaquePointerTypeInContext llvmctx)
+                                str_global #[zero] ""
+                 let nbytes ← constIntSizeT v.utf8ByteSize
+                 let nchars ← constIntSizeT v.length
+                 callLeanMkStringUncheckedFn builder strPtr nbytes nchars ""
+  LLVM.buildStore builder zv zslot
+  return zslot
+
+def callLeanCtorGet (builder : LLVM.Builder llvmctx)
+    (x i : LLVM.Value llvmctx) (retName : String) : M llvmctx (LLVM.Value llvmctx) := do
+  let fnName :=  "lean_ctor_get"
+  let retty ← LLVM.voidPtrType llvmctx
+  let argtys := #[ ← LLVM.voidPtrType llvmctx, ← LLVM.i32Type llvmctx]
+  let fnty ← LLVM.functionType retty argtys
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+  let i ← LLVM.buildSextOrTrunc builder i (← LLVM.i32Type llvmctx)
+  LLVM.buildCall2 builder fnty fn  #[x, i] retName
+
+def emitProj (builder : LLVM.Builder llvmctx) (z : VarId) (i : Nat) (x : VarId) : M llvmctx Unit := do
+  let xval ← emitLhsVal builder x
+  let zval ← callLeanCtorGet builder xval (← constIntUnsigned i) ""
+  emitLhsSlotStore builder z zval
+
+def callLeanCtorGetUsize (builder : LLVM.Builder llvmctx)
+    (x i : LLVM.Value llvmctx) (retName : String) : M llvmctx (LLVM.Value llvmctx) := do
+  let fnName :=  "lean_ctor_get_usize"
+  let retty ← LLVM.size_tType llvmctx
+  let argtys := #[ ← LLVM.voidPtrType llvmctx, ← LLVM.unsignedType llvmctx]
+  let fnty ← LLVM.functionType retty argtys
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+  LLVM.buildCall2 builder fnty fn  #[x, i] retName
+
+def emitUProj (builder : LLVM.Builder llvmctx) (z : VarId) (i : Nat) (x : VarId) : M llvmctx Unit := do
+  let xval ← emitLhsVal builder x
+  let zval ← callLeanCtorGetUsize builder xval (← constIntUnsigned i) ""
+  emitLhsSlotStore builder z zval
+
+def emitOffset (builder : LLVM.Builder llvmctx)
+    (n : Nat) (offset : Nat) : M llvmctx (LLVM.Value llvmctx) := do
+   -- TODO(bollu) : replace 8 with sizeof(void*)
+   let out ← constIntUnsigned 8
+   let out ← LLVM.buildMul builder out (← constIntUnsigned n) "" -- sizeof(void*)*n
+   LLVM.buildAdd builder out (← constIntUnsigned offset) "" -- sizeof(void*)*n+offset
+
+def emitSProj (builder : LLVM.Builder llvmctx)
+    (z : VarId) (t : IRType) (n offset : Nat) (x : VarId) : M llvmctx Unit := do
+  let (fnName, retty) ←
+    match t with
+    | IRType.float   => pure ("lean_ctor_get_float", ← LLVM.doubleTypeInContext llvmctx)
+    | IRType.float32 => pure ("lean_ctor_get_float32", ← LLVM.floatTypeInContext llvmctx)
+    | IRType.uint8   => pure ("lean_ctor_get_uint8", ← LLVM.i8Type llvmctx)
+    | IRType.uint16  => pure ("lean_ctor_get_uint16", ←  LLVM.i16Type llvmctx)
+    | IRType.uint32  => pure ("lean_ctor_get_uint32", ← LLVM.i32Type llvmctx)
+    | IRType.uint64  => pure ("lean_ctor_get_uint64", ← LLVM.i64Type llvmctx)
+    | _              => throw s!"Invalid type for lean_ctor_get: '{t}'"
+  let argtys := #[ ← LLVM.voidPtrType llvmctx, ← LLVM.unsignedType llvmctx]
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+  let xval ← emitLhsVal builder x
+  let offset ← emitOffset builder n offset
+  let fnty ← LLVM.functionType retty argtys
+  let zval ← LLVM.buildCall2 builder fnty fn  #[xval, offset]
+  emitLhsSlotStore builder z zval
+
+def callLeanIsExclusive (builder : LLVM.Builder llvmctx)
+    (closure : LLVM.Value llvmctx) (retName : String := "") : M llvmctx (LLVM.Value llvmctx) := do
+  let fnName :=  "lean_is_exclusive"
+  let retty ← LLVM.i1Type llvmctx
+  let argtys := #[ ← LLVM.voidPtrType llvmctx]
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+  let fnty ← LLVM.functionType retty argtys
+  let out ← LLVM.buildCall2 builder fnty fn  #[closure] retName
+  LLVM.buildSextOrTrunc builder out (← LLVM.i8Type llvmctx)
+
+def callLeanIsScalar (builder : LLVM.Builder llvmctx)
+    (closure : LLVM.Value llvmctx) (retName : String := "") : M llvmctx (LLVM.Value llvmctx) := do
+  let fnName :=  "lean_is_scalar"
+  let retty ← LLVM.i8Type llvmctx
+  let argtys := #[ ← LLVM.voidPtrType llvmctx]
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+  let fnty ← LLVM.functionType retty argtys
+  LLVM.buildCall2 builder fnty fn  #[closure] retName
+
+def emitIsShared (builder : LLVM.Builder llvmctx) (z : VarId) (x : VarId) : M llvmctx Unit := do
+    let xv ← emitLhsVal builder x
+    let exclusive? ← callLeanIsExclusive builder xv
+    let exclusive? ← LLVM.buildSextOrTrunc builder exclusive? (← LLVM.i1Type llvmctx)
+    let shared? ← LLVM.buildNot builder exclusive?
+    let shared? ← LLVM.buildSext builder shared? (← LLVM.i8Type llvmctx)
+    emitLhsSlotStore builder z shared?
+
+def emitBox (builder : LLVM.Builder llvmctx) (z : VarId) (x : VarId) (xType : IRType) : M llvmctx Unit := do
+  let xv ← emitLhsVal builder x
+  let (fnName, argTy, xv) ←
+    match xType with
+    | IRType.usize   => pure ("lean_box_usize", ← LLVM.size_tType llvmctx, xv)
+    | IRType.uint32  => pure ("lean_box_uint32", ← LLVM.i32Type llvmctx, xv)
+    | IRType.uint64  => pure ("lean_box_uint64", ← LLVM.size_tType llvmctx, xv)
+    | IRType.float   => pure ("lean_box_float", ← LLVM.doubleTypeInContext llvmctx, xv)
+    | IRType.float32 => pure ("lean_box_float32", ← LLVM.floatTypeInContext llvmctx, xv)
+    | _              =>
+         -- sign extend smaller values into i64
+         let xv ← LLVM.buildSext builder xv (← LLVM.size_tType llvmctx)
+         pure ("lean_box", ← LLVM.size_tType llvmctx, xv)
+  let retty ← LLVM.voidPtrType llvmctx
+  let argtys := #[argTy]
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+  let fnty ← LLVM.functionType retty argtys
+  let zv ← LLVM.buildCall2 builder fnty fn  #[xv]
+  emitLhsSlotStore builder z zv
+
+def IRType.isIntegerType (t : IRType) : Bool :=
+  match t with
+  | .uint8 => true
+  | .uint16 => true
+  | .uint32 => true
+  | .uint64 => true
+  | .usize => true
+  | _ => false
+
+def callUnboxForType (builder : LLVM.Builder llvmctx)
+    (t : IRType)
+    (v : LLVM.Value llvmctx)
+    (retName : String := "") : M llvmctx (LLVM.Value llvmctx) := do
+  let (fnName, retty) ←
+     match t with
+     | IRType.usize   => pure ("lean_unbox_usize", ← toLLVMType t)
+     | IRType.uint32  => pure ("lean_unbox_uint32", ← toLLVMType t)
+     | IRType.uint64  => pure ("lean_unbox_uint64", ← toLLVMType t)
+     | IRType.float   => pure ("lean_unbox_float", ← toLLVMType t)
+     | IRType.float32 => pure ("lean_unbox_float32", ← toLLVMType t)
+     | _              => pure ("lean_unbox", ← LLVM.size_tType llvmctx)
+  let argtys := #[← LLVM.voidPtrType llvmctx ]
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+  let fnty ← LLVM.functionType retty argtys
+  LLVM.buildCall2 builder fnty fn #[v] retName
+
+
+
+def emitUnbox (builder : LLVM.Builder llvmctx)
+    (z : VarId) (t : IRType) (x : VarId) (retName : String := "") : M llvmctx Unit := do
+  let zval ← callUnboxForType builder t (← emitLhsVal builder x) retName
+  -- NOTE(bollu) : note that lean_unbox only returns an i64, but we may need to truncate to
+  -- smaller widths. see `phashmap` for an example of this occurring at calls to `lean_unbox`
+  let zval ←
+    if IRType.isIntegerType t
+    then LLVM.buildSextOrTrunc builder zval (← toLLVMType t)
+    else pure zval
+  emitLhsSlotStore builder z zval
+
+def emitReset (builder : LLVM.Builder llvmctx) (z : VarId) (n : Nat) (x : VarId) : M llvmctx Unit := do
+  let xv ← emitLhsVal builder x
+  let isExclusive ← callLeanIsExclusive builder xv
+  let isExclusive ← buildLeanBoolTrue? builder isExclusive
+  buildIfThenElse_ builder "isExclusive" isExclusive
+   (fun builder => do
+     let xv ← emitLhsVal builder x
+     n.forM fun i _ => do
+         callLeanCtorRelease builder xv (← constIntUnsigned i)
+     emitLhsSlotStore builder z xv
+     return ShouldForwardControlFlow.yes
+   )
+   (fun builder => do
+      let xv ← emitLhsVal builder x
+      callLeanDecRef builder xv
+      let box0 ← callLeanBox builder (← constIntSizeT 0) "box0"
+      emitLhsSlotStore builder z box0
+      return ShouldForwardControlFlow.yes
+   )
+
+def emitReuse (builder : LLVM.Builder llvmctx)
+    (z : VarId) (x : VarId) (c : CtorInfo) (updtHeader : Bool) (ys : Array Arg) : M llvmctx Unit := do
+  let xv ← emitLhsVal builder x
+  let isScalar ← callLeanIsScalar builder xv
+  let isScalar ← buildLeanBoolTrue? builder isScalar
+  buildIfThenElse_ builder  "isScalar" isScalar
+    (fun builder => do
+      let cv ← emitAllocCtor builder c
+      emitLhsSlotStore builder z cv
+      return ShouldForwardControlFlow.yes
+   )
+   (fun builder => do
+       let xv ← emitLhsVal builder x
+       emitLhsSlotStore builder z xv
+       if updtHeader then
+          let zv ← emitLhsVal builder z
+          callLeanCtorSetTag builder zv (← constInt8 c.cidx)
+       return ShouldForwardControlFlow.yes
+   )
+  emitCtorSetArgs builder z ys
+
+def emitVDecl (builder : LLVM.Builder llvmctx) (z : VarId) (t : IRType) (v : Expr) : M llvmctx Unit := do
+  match v with
+  | Expr.ctor c ys      => emitCtor builder z c ys
+  | Expr.reset n x      => emitReset builder z n x
+  | Expr.reuse x c u ys => emitReuse builder z x c u ys
+  | Expr.proj i x       => emitProj builder z i x
+  | Expr.uproj i x      => emitUProj builder z i x
+  | Expr.sproj n o x    => emitSProj builder z t n o x
+  | Expr.fap c ys       => emitFullApp builder z c ys
+  | Expr.pap c ys       => emitPartialApp builder z c ys
+  | Expr.ap x ys        => emitApp builder z x ys
+  | Expr.box t x        => emitBox builder z x t
+  | Expr.unbox x        => emitUnbox builder z t x
+  | Expr.isShared x     => emitIsShared builder z x
+  | Expr.lit v          => let _ ← emitLit builder z t v
+
+def declareVar (builder : LLVM.Builder llvmctx) (x : VarId) (t : IRType) : M llvmctx Unit := do
+  let llvmty ← toLLVMType t
+  let alloca ← buildPrologueAlloca builder llvmty "varx"
+  addVartoState x alloca llvmty
+
+partial def declareVars (builder : LLVM.Builder llvmctx) (f : FnBody) : M llvmctx Unit := do
+  match f with
+  | FnBody.vdecl x t _ b => do
+      declareVar builder x t
+      declareVars builder b
+  | FnBody.jdecl _ xs _ b => do
+      for param in xs do declareVar builder param.x param.ty
+      declareVars builder b
+  | e => do
+      if e.isTerminal then pure () else declareVars builder e.body
+
+def emitTag (builder : LLVM.Builder llvmctx) (x : VarId) (xType : IRType) : M llvmctx (LLVM.Value llvmctx) := do
+  if xType.isObj then do
+    let xval ← emitLhsVal builder x
+    callLeanObjTag builder xval
+  else if xType.isScalar then do
+    emitLhsVal builder x
+  else
+    throw "Do not know how to `emitTag` in general."
+
+def emitSet (builder : LLVM.Builder llvmctx) (x : VarId) (i : Nat) (y : Arg) : M llvmctx Unit := do
+  let fnName :=  "lean_ctor_set"
+  let retty ← LLVM.voidType llvmctx
+  let argtys := #[ ← LLVM.voidPtrType llvmctx, ← LLVM.unsignedType llvmctx , ← LLVM.voidPtrType llvmctx]
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+  let fnty ← LLVM.functionType retty argtys
+  let _ ← LLVM.buildCall2 builder fnty fn  #[← emitLhsVal builder x, ← constIntUnsigned i, (← emitArgVal builder y).2]
+
+def emitUSet (builder : LLVM.Builder llvmctx) (x : VarId) (i : Nat) (y : VarId) : M llvmctx Unit := do
+  let fnName :=  "lean_ctor_set_usize"
+  let retty ← LLVM.voidType llvmctx
+  let argtys := #[ ← LLVM.voidPtrType llvmctx, ← LLVM.unsignedType llvmctx, ← LLVM.size_tType llvmctx]
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+  let fnty ← LLVM.functionType retty argtys
+  let _ ← LLVM.buildCall2 builder fnty fn  #[← emitLhsVal builder x, ← constIntUnsigned i, (← emitLhsVal builder y)]
+
+def emitTailCall (builder : LLVM.Builder llvmctx) (f : FunId) (v : Expr) : M llvmctx Unit := do
+   match v with
+  | Expr.fap _ ys => do
+    let llvmctx ← read
+    let ps := llvmctx.mainParams
+    unless ps.size == ys.size do throw s!"Invalid tail call. f:'{f}' v:'{v}'"
+    let args ← ys.mapM (fun y => Prod.snd <$> emitArgVal builder y)
+    let fn ← builderGetInsertionFn builder
+    let call ← LLVM.buildCall2 builder (← getFunIdTy f) fn args
+    -- TODO (bollu) : add 'musttail' attribute using the C API.
+    LLVM.setTailCall call true -- mark as tail call
+    let _ ← LLVM.buildRet builder call
+  | _ => throw s!"EmitTailCall expects function application, found '{v}'"
+
+def emitJmp (builder : LLVM.Builder llvmctx) (jp : JoinPointId) (xs : Array Arg) : M llvmctx Unit := do
+ let llvmctx ← read
+  let ps ← match llvmctx.jpMap[jp]? with
+  | some ps => pure ps
+  | none    => throw s!"Unknown join point {jp}"
+  unless xs.size == ps.size do throw s!"Invalid goto, mismatched sizes between arguments, formal parameters."
+  for (p, x)  in ps.zip xs do
+    let (_xty, xv) ← emitArgVal builder x
+    emitLhsSlotStore builder p.x xv
+  let _ ← LLVM.buildBr builder (← emitJp jp)
+
+def emitSSet (builder : LLVM.Builder llvmctx) (x : VarId) (n : Nat) (offset : Nat) (y : VarId) (t : IRType) : M llvmctx Unit := do
+  let (fnName, setty) ←
+  match t with
+  | IRType.float   => pure ("lean_ctor_set_float", ← LLVM.doubleTypeInContext llvmctx)
+  | IRType.float32 => pure ("lean_ctor_set_float32", ← LLVM.floatTypeInContext llvmctx)
+  | IRType.uint8   => pure ("lean_ctor_set_uint8", ← LLVM.i8Type llvmctx)
+  | IRType.uint16  => pure ("lean_ctor_set_uint16", ← LLVM.i16Type llvmctx)
+  | IRType.uint32  => pure ("lean_ctor_set_uint32", ← LLVM.i32Type llvmctx)
+  | IRType.uint64  => pure ("lean_ctor_set_uint64", ← LLVM.i64Type llvmctx)
+  | _              => throw s!"invalid type for 'lean_ctor_set': '{t}'"
+  let argtys := #[ ← LLVM.voidPtrType llvmctx, ← LLVM.unsignedType llvmctx, setty]
+  let retty  ← LLVM.voidType llvmctx
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+  let xv ← emitLhsVal builder x
+  let offset ← emitOffset builder n offset
+  let yv ← emitLhsVal builder y
+  let fnty ← LLVM.functionType retty argtys
+  let _ ← LLVM.buildCall2 builder fnty fn  #[xv, offset, yv]
+
+def emitDel (builder : LLVM.Builder llvmctx) (x : VarId) : M llvmctx Unit := do
+  let argtys := #[ ← LLVM.voidPtrType llvmctx]
+  let retty  ← LLVM.voidType llvmctx
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty "lean_free_object" argtys
+  let xv ← emitLhsVal builder x
+  let fnty ← LLVM.functionType retty argtys
+  let _ ← LLVM.buildCall2 builder fnty fn  #[xv]
+
+def emitSetTag (builder : LLVM.Builder llvmctx) (x : VarId) (i : Nat) : M llvmctx Unit := do
+  let argtys := #[← LLVM.voidPtrType llvmctx, ← LLVM.i8Type llvmctx]
+  let retty  ← LLVM.voidType llvmctx
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty "lean_ctor_set_tag" argtys
+  let xv ← emitLhsVal builder x
+  let fnty ← LLVM.functionType retty argtys
+  let _ ← LLVM.buildCall2 builder fnty fn  #[xv, ← constInt8 i]
+
+def ensureHasDefault' (alts : Array Alt) : Array Alt :=
+  if alts.any Alt.isDefault then alts
+  else
+    let last := alts.back!
+    let alts := alts.pop
+    alts.push (Alt.default last.body)
+
+mutual
+partial def emitCase (builder : LLVM.Builder llvmctx)
+    (x : VarId) (xType : IRType) (alts : Array Alt) : M llvmctx Unit := do
+  let oldBB ← LLVM.getInsertBlock builder
+  -- NOTE: In this context, 'Zext' versus 'Sext' have a meaningful semantic difference.
+  --       We perform a zero extend so that one-bit tags of `0/-1` actually extend to `0/1`
+  --       in 64-bit space.
+  let tag ← emitTag builder x xType
+  let tag ← LLVM.buildZext builder tag (← LLVM.i64Type llvmctx)
+  let alts := ensureHasDefault' alts
+  let defaultBB ← builderAppendBasicBlock builder s!"case_{xType}_default"
+  let numCasesHint := alts.size
+  let switch ← LLVM.buildSwitch builder tag defaultBB (UInt64.ofNat numCasesHint)
+  alts.forM fun alt => do
+    match alt with
+    | Alt.ctor c b  =>
+       let destbb ← builderAppendBasicBlock builder s!"case_{xType}_{c.name}_{c.cidx}"
+       LLVM.addCase switch (← constIntSizeT c.cidx) destbb
+       LLVM.positionBuilderAtEnd builder destbb
+       emitFnBody builder b
+    | Alt.default b =>
+       LLVM.positionBuilderAtEnd builder defaultBB
+       emitFnBody builder b
+  LLVM.clearInsertionPosition builder
+  LLVM.positionBuilderAtEnd builder oldBB -- reset state to previous insertion point.
+
+-- NOTE:  emitJP promises to keep the builder context untouched.
+partial def emitJDecl (builder : LLVM.Builder llvmctx)
+    (jp : JoinPointId) (_ps : Array Param) (b : FnBody) : M llvmctx Unit := do
+  let oldBB ← LLVM.getInsertBlock builder
+  let jpbb ← builderAppendBasicBlock builder s!"jp_{jp.idx}"
+  addJpTostate jp jpbb
+  LLVM.positionBuilderAtEnd builder jpbb
+  -- NOTE(bollu) : Note that we declare the slots for the variables that are inside
+  --              the join point body before emitting the join point body.
+  --              This ensures reachability via dominance.
+  -- TODO(bollu) : Eliminate the need entirely for 'alloca'/slots by generating SSA phi nodes
+  --              directly as discussed with digamma(Mario Carneiro <di.gama@gmail.com>)
+  declareVars builder b
+  emitBlock builder b
+  LLVM.positionBuilderAtEnd builder oldBB -- reset state
+
+partial def emitUnreachable (builder : LLVM.Builder llvmctx) : M llvmctx Unit := do
+  let retty ← LLVM.voidType llvmctx
+  let argtys := #[]
+  let fn ← getOrCreateFunctionPrototype  (← getLLVMModule) retty "lean_internal_panic_unreachable" argtys
+  let fnty ← LLVM.functionType retty argtys
+  let _ ← LLVM.buildCall2 builder fnty fn #[]
+  let _ ← LLVM.buildUnreachable builder
+
+partial def emitBlock (builder : LLVM.Builder llvmctx) (b : FnBody) : M llvmctx Unit := do
+  match b with
+  | FnBody.jdecl j xs  v b      =>
+       emitJDecl builder j xs v
+       emitBlock builder b
+  | d@(FnBody.vdecl x t v b)   => do
+    let llvmctx ← read
+    if isTailCallTo llvmctx.mainFn d then
+      emitTailCall builder llvmctx.mainFn v
+    else
+      emitVDecl builder x t v
+      emitBlock builder b
+  | FnBody.inc x n c p b       =>
+    unless p do emitInc builder x n c
+    emitBlock builder b
+  | FnBody.dec x n c p b       =>
+    unless p do emitDec builder x n c
+    emitBlock builder b
+  | FnBody.del x b             =>  emitDel builder x; emitBlock builder b
+  | FnBody.setTag x i b        =>  emitSetTag builder x i; emitBlock builder b
+  | FnBody.set x i y b         => emitSet builder x i y; emitBlock builder b
+  | FnBody.uset x i y b        => emitUSet builder x i y; emitBlock builder b
+  | FnBody.sset x i o y t b    => emitSSet builder x i o y t; emitBlock builder b
+  | FnBody.mdata _ b           => emitBlock builder b
+  | FnBody.ret x               => do
+      let (_xty, xv) ← emitArgVal builder x "ret_val"
+      let _ ← LLVM.buildRet builder xv
+  | FnBody.case _ x xType alts =>
+     emitCase builder x xType alts
+  | FnBody.jmp j xs            =>
+     emitJmp builder j xs
+  | FnBody.unreachable         => emitUnreachable builder
+
+partial def emitFnBody  (builder : LLVM.Builder llvmctx)  (b : FnBody) : M llvmctx Unit := do
+  declareVars builder b
+  emitBlock builder b
+
+end
+
+def emitFnArgs (builder : LLVM.Builder llvmctx)
+    (needsPackedArgs? : Bool)  (llvmfn : LLVM.Value llvmctx) (params : Array Param) : M llvmctx Unit := do
+  if needsPackedArgs? then do
+      let argsp ← LLVM.getParam llvmfn 0 -- lean_object **args
+      for h : i in [:params.size] do
+          let param := params[i]
+          -- argsi := (args + i)
+          let argsi ← LLVM.buildGEP2 builder (← LLVM.voidPtrType llvmctx) argsp #[← constIntUnsigned i] s!"packed_arg_{i}_slot"
+          let llvmty ← toLLVMType param.ty
+          -- pv := *(argsi) = *(args + i)
+          let pv ← LLVM.buildLoad2 builder llvmty argsi
+          -- slot for arg[i] which is always void* ?
+          let alloca ← buildPrologueAlloca builder llvmty s!"arg_{i}"
+          LLVM.buildStore builder pv alloca
+          addVartoState param.x alloca llvmty
+  else
+      let n ← LLVM.countParams llvmfn
+      for i in [:n.toNat] do
+        let param := params[i]!
+        let llvmty ← toLLVMType param.ty
+        let alloca ← buildPrologueAlloca builder  llvmty s!"arg_{i}"
+        let arg ← LLVM.getParam llvmfn (UInt64.ofNat i)
+        let _ ← LLVM.buildStore builder arg alloca
+        addVartoState param.x alloca llvmty
+
+def emitDeclAux (mod : LLVM.Module llvmctx) (builder : LLVM.Builder llvmctx) (d : Decl) : M llvmctx Unit := do
+  let env ← getEnv
+  let (_, jpMap) := mkVarJPMaps d
+  withReader (fun llvmctx => { llvmctx with jpMap := jpMap }) do
+  unless hasInitAttr env d.name do
+    match d with
+    | .fdecl (f := f) (xs := xs) (type := t) (body := b) .. =>
+      let baseName ← toCName f
+      let name := if xs.size > 0 then baseName else "_init_" ++ baseName
+      let retty ← toLLVMType t
+      let mut argtys := #[]
+      let needsPackedArgs? := xs.size > closureMaxArgs && isBoxedName d.name
+      if needsPackedArgs? then
+          argtys := #[← LLVM.pointerType (← LLVM.voidPtrType llvmctx)]
+      else
+        for x in xs do
+          argtys := argtys.push (← toLLVMType x.ty)
+      let fnty ← LLVM.functionType retty argtys (isVarArg := false)
+      let llvmfn ← LLVM.getOrAddFunction mod name fnty
+      -- set linkage and visibility
+      -- TODO: consider refactoring these into a separate concept (e.g. 'setLinkageAndVisibility')
+      --       Find the spots where this refactor needs to happen by grepping for 'LEAN_EXPORT'
+      --       in the C backend
+      if xs.size == 0 then
+        LLVM.setVisibility llvmfn LLVM.Visibility.hidden -- "static "
+      else
+        LLVM.setDLLStorageClass llvmfn LLVM.DLLStorageClass.export  -- LEAN_EXPORT: make symbol visible to the interpreter
+      withReader (fun llvmctx => { llvmctx with mainFn := f, mainParams := xs }) do
+        set { var2val := default, jp2bb := default : EmitLLVM.State llvmctx } -- flush variable map
+        let bb ← LLVM.appendBasicBlockInContext llvmctx llvmfn "entry"
+        LLVM.positionBuilderAtEnd builder bb
+        emitFnArgs builder needsPackedArgs? llvmfn xs
+        emitFnBody builder b
+      pure ()
+    | _ => pure ()
+
+def emitDecl (mod : LLVM.Module llvmctx) (builder : LLVM.Builder llvmctx) (d : Decl) : M llvmctx Unit := do
+  let d := d.normalizeIds -- ensure we don't have gaps in the variable indices
+  try
+    emitDeclAux mod builder d
+    return ()
+  catch err =>
+    throw (s!"emitDecl:\ncompiling:\n{d}\nerr:\n{err}\n")
+
+def emitFns (mod : LLVM.Module llvmctx) (builder : LLVM.Builder llvmctx) : M llvmctx Unit := do
+  let env ← getEnv
+  let decls := getDecls env
+  decls.reverse.forM (emitDecl mod builder)
+
+def callIODeclInitFn (builder : LLVM.Builder llvmctx)
+    (initFnName : String)
+    (world : LLVM.Value llvmctx): M llvmctx (LLVM.Value llvmctx) := do
+  let retty ← LLVM.voidPtrType llvmctx
+  let argtys := #[← LLVM.voidPtrType llvmctx]
+  let fn ← getOrCreateFunctionPrototype  (← getLLVMModule) retty initFnName argtys
+  let fnty ← LLVM.functionType retty argtys
+  LLVM.buildCall2 builder fnty fn #[world]
+
+def callPureDeclInitFn (builder : LLVM.Builder llvmctx)
+    (initFnName : String)
+    (retty : LLVM.LLVMType llvmctx): M llvmctx (LLVM.Value llvmctx) := do
+  let argtys := #[]
+  let fn ← getOrCreateFunctionPrototype  (← getLLVMModule) retty initFnName argtys
+  let fnty ← LLVM.functionType retty argtys
+  LLVM.buildCall2 builder fnty fn #[]
+
+def emitDeclInit (builder : LLVM.Builder llvmctx)
+    (parentFn : LLVM.Value llvmctx) (d : Decl) : M llvmctx Unit := do
+  let env ← getEnv
+  if isIOUnitInitFn env d.name then do
+    let world ← callLeanIOMkWorld builder
+    let resv ← callIODeclInitFn builder (← toCName d.name) world
+    let err? ← callLeanIOResultIsError builder resv "is_error"
+    buildIfThen_ builder s!"init_{d.name}_isError" err?
+      (fun builder => do
+        let _ ← LLVM.buildRet builder resv
+        pure ShouldForwardControlFlow.no)
+    -- TODO (bollu) : emit lean_dec_ref. For now, it does not matter.
+  else if d.params.size == 0 then
+    match getInitFnNameFor? env d.name with
+    | some initFn =>
+      let llvmty ← toLLVMType d.resultType
+      let dslot ←  LLVM.getOrAddGlobal (← getLLVMModule) (← toCName d.name) llvmty
+      LLVM.setInitializer dslot (← LLVM.getUndef llvmty)
+      let initBB ← builderAppendBasicBlock builder s!"do_{d.name}_init"
+      let restBB ← builderAppendBasicBlock builder s!"post_{d.name}_init"
+      let checkBuiltin? := getBuiltinInitFnNameFor? env d.name |>.isSome
+      if checkBuiltin? then
+        -- `builtin` is set to true if the initializer is part of the executable,
+        -- and not loaded dynamically.
+        let builtinParam ← LLVM.getParam parentFn 0
+        let cond ← buildLeanBoolTrue? builder builtinParam "is_builtin_true"
+        let _ ← LLVM.buildCondBr builder cond initBB restBB
+       else
+        let _ ← LLVM.buildBr builder initBB
+      LLVM.positionBuilderAtEnd builder initBB
+      let world ← callLeanIOMkWorld builder
+      let resv ← callIODeclInitFn builder (← toCName initFn) world
+      let err? ← callLeanIOResultIsError builder resv s!"{d.name}_is_error"
+      buildIfThen_ builder s!"init_{d.name}_isError" err?
+        (fun builder => do
+          let _ ← LLVM.buildRet builder resv
+          pure ShouldForwardControlFlow.no)
+      if d.resultType.isScalar then
+        let dval ← callLeanIOResultGetValue builder resv s!"{d.name}_res"
+        let dval ← callUnboxForType builder d.resultType dval
+        LLVM.buildStore builder dval dslot
+      else
+         let dval ← callLeanIOResultGetValue builder resv s!"{d.name}_res"
+         LLVM.buildStore builder dval dslot
+         callLeanMarkPersistentFn builder dval
+      let _ ← LLVM.buildBr builder restBB
+      LLVM.positionBuilderAtEnd builder restBB
+    | none => do
+      let llvmty ← toLLVMType d.resultType
+      let dslot ←  LLVM.getOrAddGlobal (← getLLVMModule) (← toCName d.name) llvmty
+      LLVM.setInitializer dslot (← LLVM.getUndef llvmty)
+      let dval ← callPureDeclInitFn builder (← toCInitName d.name) (← toLLVMType d.resultType)
+      LLVM.buildStore builder dval dslot
+      if d.resultType.isObj then
+         callLeanMarkPersistentFn builder dval
+
+def callModInitFn (builder : LLVM.Builder llvmctx)
+    (modName : Name) (input world : LLVM.Value llvmctx) (retName : String): M llvmctx (LLVM.Value llvmctx) := do
+  let fnName := mkModuleInitializationFunctionName modName
+  let retty ← LLVM.voidPtrType llvmctx
+  let argtys := #[ (← LLVM.i8Type llvmctx), (← LLVM.voidPtrType llvmctx)]
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+  let fnty ← LLVM.functionType retty argtys
+  LLVM.buildCall2 builder fnty fn #[input, world] retName
+
+def emitInitFn (mod : LLVM.Module llvmctx) (builder : LLVM.Builder llvmctx) : M llvmctx Unit := do
+  let env ← getEnv
+  let modName ← getModName
+
+  let initFnTy ← LLVM.functionType (← LLVM.voidPtrType llvmctx) #[ (← LLVM.i8Type llvmctx), (← LLVM.voidPtrType llvmctx)] (isVarArg := false)
+  let initFn ← LLVM.getOrAddFunction mod (mkModuleInitializationFunctionName modName) initFnTy
+  LLVM.setDLLStorageClass initFn LLVM.DLLStorageClass.export  -- LEAN_EXPORT
+  let entryBB ← LLVM.appendBasicBlockInContext llvmctx initFn "entry"
+  LLVM.positionBuilderAtEnd builder entryBB
+  let ginit?ty := ← LLVM.i1Type llvmctx
+  let ginit?slot ← LLVM.getOrAddGlobal mod (modName.mangle ++ "_G_initialized") ginit?ty
+  LLVM.setVisibility ginit?slot LLVM.Visibility.hidden -- static
+  LLVM.setInitializer ginit?slot (← LLVM.constFalse llvmctx)
+  let ginit?v ← LLVM.buildLoad2 builder ginit?ty ginit?slot "init_v"
+  buildIfThen_ builder "isGInitialized" ginit?v
+    (fun builder => do
+      let box0 ← callLeanBox builder (← constIntSizeT 0) "box0"
+      let out ← callLeanIOResultMKOk builder box0 "retval"
+      let _ ← LLVM.buildRet builder out
+      pure ShouldForwardControlFlow.no)
+  LLVM.buildStore builder (← LLVM.constTrue llvmctx) ginit?slot
+
+  env.imports.forM fun import_ => do
+    let builtin ← LLVM.getParam initFn 0
+    let world ← callLeanIOMkWorld builder
+    let res ← callModInitFn builder import_.module builtin world ("res_" ++ import_.module.mangle)
+    let err? ← callLeanIOResultIsError builder res ("res_is_error_"  ++ import_.module.mangle)
+    buildIfThen_ builder ("IsError" ++ import_.module.mangle) err?
+      (fun builder => do
+        let _ ← LLVM.buildRet builder res
+        pure ShouldForwardControlFlow.no)
+    callLeanDecRef builder res
+  let decls := getDecls env
+  decls.reverse.forM (emitDeclInit builder initFn)
+  let box0 ← callLeanBox builder (← constIntSizeT 0) "box0"
+  let out ← callLeanIOResultMKOk builder box0 "retval"
+  let _ ← LLVM.buildRet builder out
+
+def callLeanInitialize (builder : LLVM.Builder llvmctx) : M llvmctx Unit := do
+  let fnName :=  "lean_initialize"
+  let retty ← LLVM.voidType llvmctx
+  let argtys := #[]
+  let fnty ← LLVM.functionType retty argtys
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+  let _ ← LLVM.buildCall2 builder fnty fn #[]
+
+def callLeanSetupLibUV (builder : LLVM.Builder llvmctx) (argc argv : LLVM.Value llvmctx) : M llvmctx (LLVM.Value llvmctx) := do
+  let fnName := "lean_setup_args"
+  let intTy ← LLVM.i32Type llvmctx
+  let charPtrPtrTy ← LLVM.pointerType (← LLVM.pointerType (← LLVM.i8Type llvmctx))
+  let argtys := #[intTy, charPtrPtrTy]
+  let fnty ← LLVM.functionType charPtrPtrTy argtys
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) intTy fnName argtys
+  LLVM.buildCall2 builder fnty fn #[argc, argv]
+
+def callLeanInitializeRuntimeModule (builder : LLVM.Builder llvmctx) : M llvmctx Unit := do
+  let fnName :=  "lean_initialize_runtime_module"
+  let retty ← LLVM.voidType llvmctx
+  let argtys := #[]
+  let fnty ← LLVM.functionType retty argtys
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+  let _ ← LLVM.buildCall2 builder fnty fn #[]
+
+def callLeanSetPanicMessages (builder : LLVM.Builder llvmctx)
+    (enable? : LLVM.Value llvmctx) : M llvmctx Unit := do
+  let fnName :=  "lean_set_panic_messages"
+  let retty ← LLVM.voidType llvmctx
+  let argtys := #[ ← LLVM.i1Type llvmctx ]
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+  let fnty ← LLVM.functionType retty argtys
+  let _ ← LLVM.buildCall2 builder fnty fn #[enable?]
+
+def callLeanIOMarkEndInitialization (builder : LLVM.Builder llvmctx) : M llvmctx Unit := do
+  let fnName :=  "lean_io_mark_end_initialization"
+  let retty ← LLVM.voidType llvmctx
+  let argtys := #[]
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+  let fnty ← LLVM.functionType retty argtys
+  let _ ← LLVM.buildCall2 builder fnty fn #[]
+
+def callLeanIOResultIsOk (builder : LLVM.Builder llvmctx)
+    (arg : LLVM.Value llvmctx) (name : String := "") : M llvmctx (LLVM.Value llvmctx) := do
+  let fnName :=  "lean_io_result_is_ok"
+  let retty ← LLVM.i1Type llvmctx
+  let argtys := #[ ← LLVM.voidPtrType llvmctx ]
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+  let fnty ← LLVM.functionType retty argtys
+  LLVM.buildCall2 builder fnty fn #[arg] name
+
+def callLeanInitTaskManager (builder : LLVM.Builder llvmctx) : M llvmctx Unit := do
+  let fnName :=  "lean_init_task_manager"
+  let retty ← LLVM.voidType llvmctx
+  let argtys := #[]
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+  let fnty ← LLVM.functionType retty argtys
+   let _ ← LLVM.buildCall2 builder fnty fn #[]
+
+def callLeanFinalizeTaskManager (builder : LLVM.Builder llvmctx) : M llvmctx Unit := do
+  let fnName :=  "lean_finalize_task_manager"
+  let retty ← LLVM.voidPtrType llvmctx
+  let argtys := #[]
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+  let fnty ← LLVM.functionType retty argtys
+   let _ ← LLVM.buildCall2 builder fnty fn #[]
+
+def callLeanUnboxUint32 (builder : LLVM.Builder llvmctx)
+    (v : LLVM.Value llvmctx) (name : String := "") : M llvmctx (LLVM.Value llvmctx) := do
+  let fnName :=  "lean_unbox_uint32"
+  let retty ← LLVM.i32Type llvmctx
+  let argtys := #[ ← LLVM.voidPtrType llvmctx ]
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+  let fnty ← LLVM.functionType retty argtys
+  LLVM.buildCall2 builder fnty fn  #[v] name
+
+def callLeanIOResultShowError (builder : LLVM.Builder llvmctx)
+    (v : LLVM.Value llvmctx) (name : String := "") : M llvmctx Unit := do
+  let fnName :=  "lean_io_result_show_error"
+  let retty ← LLVM.voidType llvmctx
+  let argtys := #[ ← LLVM.voidPtrType llvmctx ]
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
+  let fnty ← LLVM.functionType retty argtys
+  let _ ← LLVM.buildCall2 builder fnty fn #[v] name
+
+def callLeanMainFn (builder : LLVM.Builder llvmctx)
+    (argv? : Option (LLVM.Value llvmctx))
+    (world : LLVM.Value llvmctx)
+    (name : String) : M llvmctx (LLVM.Value llvmctx) := do
+  let retty ← LLVM.voidPtrType llvmctx
+  let voidptr ← LLVM.voidPtrType llvmctx
+  let argtys := if argv?.isSome then #[ voidptr, voidptr ] else #[ voidptr ]
+  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty leanMainFn argtys
+  let fnty ← LLVM.functionType retty argtys
+  let args := match argv? with
+              | .some argv => #[argv, world]
+              | .none => #[world]
+  LLVM.buildCall2 builder fnty fn args name
+
+def emitMainFn (mod : LLVM.Module llvmctx) (builder : LLVM.Builder llvmctx) : M llvmctx Unit := do
+  let d ← getDecl `main
+  let xs ← match d with
+   | .fdecl (xs := xs) .. => pure xs
+   | _ =>  throw "Function declaration expected for 'main'"
+
+  unless xs.size == 2 || xs.size == 1 do throw s!"Invalid main function, main expected to have '2' or '1' arguments, found '{xs.size}' arguments"
+  let env ← getEnv
+  let usesLeanAPI := usesModuleFrom env `Lean
+  let mainTy ← LLVM.functionType (← LLVM.i64Type llvmctx)
+      #[(← LLVM.i64Type llvmctx), (← LLVM.pointerType (← LLVM.voidPtrType llvmctx))]
+  let main ← LLVM.getOrAddFunction mod "main" mainTy
+  let entry ← LLVM.appendBasicBlockInContext llvmctx main "entry"
+  LLVM.positionBuilderAtEnd builder entry
+  /-
+  #if defined(WIN32) || defined(_WIN32)
+  SetErrorMode(SEM_FAILCRITICALERRORS);
+  #endif
+  -/
+  let inty ← LLVM.voidPtrType llvmctx
+  let inslot ← buildPrologueAlloca builder (← LLVM.pointerType inty) "in"
+  let resty ← LLVM.voidPtrType llvmctx
+  let res ← buildPrologueAlloca builder (← LLVM.pointerType resty) "res"
+
+  let argcval ← LLVM.getParam main 0
+  let argvval ← LLVM.getParam main 1
+  let truncArgcval ← LLVM.buildSextOrTrunc builder argcval (← LLVM.i32Type llvmctx)
+  let argvval ← callLeanSetupLibUV builder truncArgcval argvval
+
+  if usesLeanAPI then callLeanInitialize builder else callLeanInitializeRuntimeModule builder
+    /- We disable panic messages because they do not mesh well with extracted closed terms.
+        See issue #534. We can remove this workaround after we implement issue #467. -/
+  callLeanSetPanicMessages builder (← LLVM.constFalse llvmctx)
+  let world ← callLeanIOMkWorld builder
+  let resv ← callModInitFn builder (← getModName) (← constInt8 1) world ((← getModName).toString ++ "_init_out")
+  let _ ← LLVM.buildStore builder resv res
+
+  callLeanSetPanicMessages builder (← LLVM.constTrue llvmctx)
+  callLeanIOMarkEndInitialization builder
+
+  let resv ← LLVM.buildLoad2 builder resty res "resv"
+  let res_is_ok ← callLeanIOResultIsOk builder resv "res_is_ok"
+  buildIfThen_ builder "resIsOkBranches"  res_is_ok
+    (fun builder => do -- then clause of the builder)
+      callLeanDecRef builder resv
+      callLeanInitTaskManager builder
+      if xs.size == 2 then
+        let inv ← callLeanBox builder (← constIntSizeT 0) "inv"
+        let _ ← LLVM.buildStore builder inv inslot
+        let ity ← LLVM.size_tType llvmctx
+        let islot ← buildPrologueAlloca builder ity "islot"
+        LLVM.buildStore builder argcval islot
+        buildWhile_ builder "argv"
+          (condcodegen := fun builder => do
+            let iv ← LLVM.buildLoad2 builder ity islot "iv"
+            let i_gt_1 ← LLVM.buildICmp builder LLVM.IntPredicate.UGT iv (← constIntSizeT 1) "i_gt_1"
+            return i_gt_1)
+          (bodycodegen := fun builder => do
+            let iv ← LLVM.buildLoad2 builder ity islot "iv"
+            let iv_next ← LLVM.buildSub builder iv (← constIntSizeT 1) "iv.next"
+            LLVM.buildStore builder iv_next islot
+            let nv ← callLeanAllocCtor builder 1 2 0 "nv"
+            let argv_i_next_slot ← LLVM.buildGEP2 builder (← LLVM.voidPtrType llvmctx) argvval #[iv_next] "argv.i.next.slot"
+            let argv_i_next_val ← LLVM.buildLoad2 builder (← LLVM.voidPtrType llvmctx) argv_i_next_slot "argv.i.next.val"
+            let argv_i_next_val_str ← callLeanMkString builder argv_i_next_val "arg.i.next.val.str"
+            callLeanCtorSet builder nv (← constIntUnsigned 0) argv_i_next_val_str
+            let inv ← LLVM.buildLoad2 builder inty inslot "inv"
+            callLeanCtorSet builder nv (← constIntUnsigned 1) inv
+            LLVM.buildStore builder nv inslot)
+        let world ← callLeanIOMkWorld builder
+        let inv ← LLVM.buildLoad2 builder inty inslot "inv"
+        let resv ← callLeanMainFn builder (argv? := .some inv) (world := world) "resv"
+        let _ ← LLVM.buildStore builder resv res
+        pure ShouldForwardControlFlow.yes
+      else
+          let world ← callLeanIOMkWorld builder
+          let resv ← callLeanMainFn builder (argv? := .none) (world := world) "resv"
+          let _ ← LLVM.buildStore builder resv res
+          pure ShouldForwardControlFlow.yes
+  )
+
+  -- `IO _`
+  let retTy := env.find? `main |>.get! |>.type |>.getForallBody
+  -- either `UInt32` or `(P)Unit`
+  let retTy := retTy.appArg!
+  -- finalize at least the task manager to avoid leak sanitizer false positives
+  -- from tasks outliving the main thread
+  callLeanFinalizeTaskManager builder
+  let resv ← LLVM.buildLoad2 builder resty res "resv"
+  let res_is_ok ← callLeanIOResultIsOk builder resv "res_is_ok"
+  buildIfThenElse_ builder "res.is.ok" res_is_ok
+    (fun builder => -- then builder
+      if retTy.constName? == some ``UInt32 then do
+        let resv ← LLVM.buildLoad2 builder resty res "resv"
+        let retv ← callLeanUnboxUint32 builder (← callLeanIOResultGetValue builder resv "io_val") "retv"
+        let retv ← LLVM.buildSext builder retv (← LLVM.i64Type llvmctx) "retv_sext"
+        callLeanDecRef builder resv
+        let _ ← LLVM.buildRet builder retv
+        pure ShouldForwardControlFlow.no
+      else do
+        callLeanDecRef builder resv
+        let _ ← LLVM.buildRet builder (← constInt64 0)
+        pure ShouldForwardControlFlow.no
+
+    )
+    (fun builder => do -- else builder
+        let resv ← LLVM.buildLoad2 builder resty res "resv"
+        callLeanIOResultShowError builder resv
+        callLeanDecRef builder resv
+        let _ ← LLVM.buildRet builder (← constInt64 1)
+        pure ShouldForwardControlFlow.no)
+  -- at the merge
+  let _ ← LLVM.buildUnreachable builder
+
+def hasMainFn : M llvmctx Bool := do
+  let env ← getEnv
+  let decls := getDecls env
+  return decls.any (fun d => d.name == `main)
+
+def emitMainFnIfNeeded (mod : LLVM.Module llvmctx) (builder : LLVM.Builder llvmctx) : M llvmctx Unit := do
+  if (← hasMainFn) then emitMainFn mod builder
+
+def main : M llvmctx Unit := do
+  emitFnDecls
+  let builder ← LLVM.createBuilderInContext llvmctx
+  emitFns (← getLLVMModule) builder
+  emitInitFn (← getLLVMModule) builder
+  emitMainFnIfNeeded (← getLLVMModule) builder
+end EmitLLVM
+
+def getLeanHBcPath : IO System.FilePath := do
+  return (← getLibDir (← getBuildDir)) / "lean.h.bc"
+
+/-- Get the names of all global symbols in the module -/
+partial def getModuleGlobals (mod : LLVM.Module llvmctx) : IO (Array (LLVM.Value llvmctx)) := do
+  let rec go (v : LLVM.Value llvmctx) (acc : Array (LLVM.Value llvmctx)) : IO (Array (LLVM.Value llvmctx)) := do
+    if v.isNull then return acc
+    else go (← LLVM.getNextGlobal v) (acc.push v)
+  go (← LLVM.getFirstGlobal mod) #[]
+
+/-- Get the names of all global functions in the module -/
+partial def getModuleFunctions (mod : LLVM.Module llvmctx) : IO (Array (LLVM.Value llvmctx)) := do
+  let rec go (v : LLVM.Value llvmctx) (acc : Array (LLVM.Value llvmctx)) : IO (Array (LLVM.Value llvmctx)) := do
+    if v.isNull then return acc
+    else go (← LLVM.getNextFunction v) (acc.push v)
+  go (← LLVM.getFirstFunction mod) #[]
+
+/--
+`emitLLVM` is the entrypoint for the lean shell to code generate LLVM.
+-/
+@[export lean_ir_emit_llvm]
+def emitLLVM (env : Environment) (modName : Name) (filepath : String) : IO Unit := do
+  LLVM.llvmInitializeTargetInfo
+  let llvmctx ← LLVM.createContext
+  let module ← LLVM.createModule llvmctx modName.toString
+  let emitLLVMCtx : EmitLLVM.Context llvmctx := {env := env, modName := modName, llvmmodule := module}
+  let initState := { var2val := default, jp2bb := default : EmitLLVM.State llvmctx}
+  let out? ← ((EmitLLVM.main (llvmctx := llvmctx)).run initState).run emitLLVMCtx
+  match out? with
+  | .ok _ => do
+         let membuf ← LLVM.createMemoryBufferWithContentsOfFile (← getLeanHBcPath).toString
+         let modruntime ← LLVM.parseBitcode llvmctx membuf
+         /- It is important that we extract the names here because
+            pointers into modruntime get invalidated by linkModules -/
+         let runtimeGlobals ← (← getModuleGlobals modruntime).mapM (·.getName)
+         let filter func := do
+           -- | Do not insert internal linkage for
+           -- intrinsics such as `@llvm.umul.with.overflow.i64` which clang generates, and also
+           -- for declarations such as `lean_inc_ref_cold` which are externally defined.
+           if (← LLVM.isDeclaration func) then
+             return none
+           else
+             return some (← func.getName)
+         let runtimeFunctions ← (← getModuleFunctions modruntime).filterMapM filter
+         LLVM.linkModules (dest := emitLLVMCtx.llvmmodule) (src := modruntime)
+         -- Mark every global and function as having internal linkage.
+         for name in runtimeGlobals do
+           let some global ← LLVM.getNamedGlobal emitLLVMCtx.llvmmodule name
+              | throw <| IO.Error.userError s!"ERROR: linked module must have global from runtime module: '{name}'"
+           LLVM.setLinkage global LLVM.Linkage.internal
+         for name in runtimeFunctions do
+           let some fn ← LLVM.getNamedFunction emitLLVMCtx.llvmmodule name
+              | throw <| IO.Error.userError s!"ERROR: linked module must have function from runtime module: '{name}'"
+           LLVM.setLinkage fn LLVM.Linkage.internal
+         if let some err ← LLVM.verifyModule emitLLVMCtx.llvmmodule then
+           throw <| .userError err
+         LLVM.writeBitcodeToFile emitLLVMCtx.llvmmodule filepath
+         LLVM.disposeModule emitLLVMCtx.llvmmodule
+  | .error err => throw (IO.Error.userError err)
+end Lean.IR

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/EmitUtil.lean

@@ -0,0 +1,86 @@
+/-
+Copyright (c) 2019 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Compiler.InitAttr
+import Lean.Compiler.IR.CompilerM
+
+/-! # Helper functions for backend code generators -/
+
+namespace Lean.IR
+/-- Return true iff `b` is of the form `let x := g ys; ret x` -/
+def isTailCallTo (g : Name) (b : FnBody) : Bool :=
+  match b with
+  | FnBody.vdecl x _ (Expr.fap f _) (FnBody.ret (Arg.var y)) => x == y && f == g
+  | _  => false
+
+def usesModuleFrom (env : Environment) (modulePrefix : Name) : Bool :=
+  env.allImportedModuleNames.toList.any fun modName => modulePrefix.isPrefixOf modName
+
+namespace CollectUsedDecls
+
+abbrev M := ReaderT Environment (StateM NameSet)
+
+@[inline] def collect (f : FunId) : M Unit :=
+  modify fun s => s.insert f
+
+partial def collectFnBody : FnBody → M Unit
+  | .vdecl _ _ v b   =>
+    match v with
+    | .fap f _ => collect f *> collectFnBody b
+    | .pap f _ => collect f *> collectFnBody b
+    | _        => collectFnBody b
+  | .jdecl _ _ v b   => collectFnBody v *> collectFnBody b
+  | .case _ _ _ alts => alts.forM fun alt => collectFnBody alt.body
+  | e => do unless e.isTerminal do collectFnBody e.body
+
+def collectInitDecl (fn : Name) : M Unit := do
+  let env ← read
+  match getInitFnNameFor? env fn with
+  | some initFn => collect initFn
+  | _           => pure ()
+
+def collectDecl : Decl → M NameSet
+  | .fdecl (f := f) (body := b) .. => collectInitDecl f *> CollectUsedDecls.collectFnBody b *> get
+  | .extern (f := f) .. => collectInitDecl f *> get
+
+end CollectUsedDecls
+
+def collectUsedDecls (env : Environment) (decl : Decl) (used : NameSet := {}) : NameSet :=
+  (CollectUsedDecls.collectDecl decl env).run' used
+
+abbrev VarTypeMap  := Std.HashMap VarId IRType
+abbrev JPParamsMap := Std.HashMap JoinPointId (Array Param)
+
+namespace CollectMaps
+abbrev Collector := (VarTypeMap × JPParamsMap) → (VarTypeMap × JPParamsMap)
+@[inline] def collectVar (x : VarId) (t : IRType) : Collector
+  | (vs, js) => (vs.insert x t, js)
+def collectParams (ps : Array Param) : Collector :=
+  fun s => ps.foldl (fun s p => collectVar p.x p.ty s) s
+@[inline] def collectJP (j : JoinPointId) (xs : Array Param) : Collector
+  | (vs, js) => (vs, js.insert j xs)
+
+/-- `collectFnBody` assumes the variables in -/
+partial def collectFnBody : FnBody → Collector
+  | .vdecl x t _ b    => collectVar x t ∘ collectFnBody b
+  | .jdecl j xs v b   => collectJP j xs ∘ collectParams xs ∘ collectFnBody v ∘ collectFnBody b
+  | .case _ _ _ alts  => fun s => alts.foldl (fun s alt => collectFnBody alt.body s) s
+  | e                 => if e.isTerminal then id else collectFnBody e.body
+
+def collectDecl : Decl → Collector
+  | .fdecl (xs := xs) (body := b) .. => collectParams xs ∘ collectFnBody b
+  | _ => id
+
+end CollectMaps
+
+/-- Return a pair `(v, j)`, where `v` is a mapping from variable/parameter to type,
+   and `j` is a mapping from join point to parameters.
+   This function assumes `d` has normalized indexes (see `normids.lean`). -/
+def mkVarJPMaps (d : Decl) : VarTypeMap × JPParamsMap :=
+  CollectMaps.collectDecl d ({}, {})
+
+end IR
+end Lean

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/ExpandResetReuse.lean

@@ -0,0 +1,281 @@
+/-
+Copyright (c) 2019 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Compiler.IR.CompilerM
+import Lean.Compiler.IR.NormIds
+import Lean.Compiler.IR.FreeVars
+
+namespace Lean.IR.ExpandResetReuse
+/-- Mapping from variable to projections -/
+abbrev ProjMap  := Std.HashMap VarId Expr
+namespace CollectProjMap
+abbrev Collector := ProjMap → ProjMap
+@[inline] def collectVDecl (x : VarId) (v : Expr) : Collector := fun m =>
+  match v with
+  | .proj ..  => m.insert x v
+  | .sproj .. => m.insert x v
+  | .uproj .. => m.insert x v
+  | _         => m
+
+partial def collectFnBody : FnBody → Collector
+  | .vdecl x _ v b   => collectVDecl x v ∘ collectFnBody b
+  | .jdecl _ _ v b   => collectFnBody v ∘ collectFnBody b
+  | .case _ _ _ alts => fun s => alts.foldl (fun s alt => collectFnBody alt.body s) s
+  | e                => if e.isTerminal then id else collectFnBody e.body
+end CollectProjMap
+
+/-- Create a mapping from variables to projections.
+   This function assumes variable ids have been normalized -/
+def mkProjMap (d : Decl) : ProjMap :=
+  match d with
+  | .fdecl (body := b) .. => CollectProjMap.collectFnBody b {}
+  | _ => {}
+
+structure Context where
+  projMap : ProjMap
+
+/-- Return true iff `x` is consumed in all branches of the current block.
+   Here consumption means the block contains a `dec x` or `reuse x ...`. -/
+partial def consumed (x : VarId) : FnBody → Bool
+  | .vdecl _ _ v b   =>
+    match v with
+    | Expr.reuse y _ _ _ => x == y || consumed x b
+    | _                  => consumed x b
+  | .dec y _ _ _ b   => x == y || consumed x b
+  | .case _ _ _ alts => alts.all fun alt => consumed x alt.body
+  | e => !e.isTerminal && consumed x e.body
+
+abbrev Mask := Array (Option VarId)
+
+/-- Auxiliary function for eraseProjIncFor -/
+partial def eraseProjIncForAux (y : VarId) (bs : Array FnBody) (mask : Mask) (keep : Array FnBody) : Array FnBody × Mask :=
+  let done (_ : Unit)        := (bs ++ keep.reverse, mask)
+  let keepInstr (b : FnBody) := eraseProjIncForAux y bs.pop mask (keep.push b)
+  if h : bs.size < 2 then done ()
+  else
+    let b := bs.back!
+    match b with
+    | .vdecl _ _ (.sproj _ _ _) _ => keepInstr b
+    | .vdecl _ _ (.uproj _ _) _   => keepInstr b
+    | .inc z n c p _ =>
+      if n == 0 then done () else
+      let b' := bs[bs.size - 2]
+      match b' with
+      | .vdecl w _ (.proj i x) _ =>
+        if w == z && y == x then
+          /- Found
+             ```
+             let z := proj[i] y
+             inc z n c
+             ```
+             We keep `proj`, and `inc` when `n > 1`
+          -/
+          let bs   := bs.pop.pop
+          let mask := mask.set! i (some z)
+          let keep := keep.push b'
+          let keep := if n == 1 then keep else keep.push (FnBody.inc z (n-1) c p FnBody.nil)
+          eraseProjIncForAux y bs mask keep
+        else done ()
+      | _ => done ()
+    | _ => done ()
+
+/-- Try to erase `inc` instructions on projections of `y` occurring in the tail of `bs`.
+   Return the updated `bs` and a bit mask specifying which `inc`s have been removed. -/
+def eraseProjIncFor (n : Nat) (y : VarId) (bs : Array FnBody) : Array FnBody × Mask :=
+  eraseProjIncForAux y bs (.replicate n none) #[]
+
+/-- Replace `reuse x ctor ...` with `ctor ...`, and remove `dec x` -/
+partial def reuseToCtor (x : VarId) : FnBody → FnBody
+  | FnBody.dec y n c p b   =>
+    if x == y then b -- n must be 1 since `x := reset ...`
+    else FnBody.dec y n c p (reuseToCtor x b)
+  | FnBody.vdecl z t v b   =>
+    match v with
+    | Expr.reuse y c _ xs =>
+      if x == y then FnBody.vdecl z t (Expr.ctor c xs) b
+      else FnBody.vdecl z t v (reuseToCtor x b)
+    | _ =>
+      FnBody.vdecl z t v (reuseToCtor x b)
+  | FnBody.case tid y yType alts   =>
+    let alts := alts.map fun alt => alt.modifyBody (reuseToCtor x)
+    FnBody.case tid y yType alts
+  | e =>
+    if e.isTerminal then
+      e
+    else
+      let (instr, b) := e.split
+      let b := reuseToCtor x b
+      instr.setBody b
+
+/--
+replace
+```
+x := reset y; b
+```
+with
+```
+inc z_1; ...; inc z_i; dec y; b'
+```
+where `z_i`'s are the variables in `mask`,
+and `b'` is `b` where we removed `dec x` and replaced `reuse x ctor_i ...` with `ctor_i ...`.
+-/
+def mkSlowPath (x y : VarId) (mask : Mask) (b : FnBody) : FnBody :=
+  let b := reuseToCtor x b
+  let b := FnBody.dec y 1 true false b
+  mask.foldl (init := b) fun b m => match m with
+      | some z => FnBody.inc z 1 true false b
+      | none   => b
+
+abbrev M := ReaderT Context (StateM Nat)
+  def mkFresh : M VarId :=
+  modifyGet fun n => ({ idx := n }, n + 1)
+
+def releaseUnreadFields (y : VarId) (mask : Mask) (b : FnBody) : M FnBody :=
+  mask.size.foldM (init := b) fun i _ b =>
+    match mask[i] with
+    | some _ => pure b -- code took ownership of this field
+    | none   => do
+      let fld ← mkFresh
+      pure (FnBody.vdecl fld IRType.object (Expr.proj i y) (FnBody.dec fld 1 true false b))
+
+def setFields (y : VarId) (zs : Array Arg) (b : FnBody) : FnBody :=
+  zs.size.fold (init := b) fun i _ b => FnBody.set y i zs[i] b
+
+/-- Given `set x[i] := y`, return true iff `y := proj[i] x` -/
+def isSelfSet (ctx : Context) (x : VarId) (i : Nat) (y : Arg) : Bool :=
+  match y with
+  | Arg.var y =>
+    match ctx.projMap[y]? with
+    | some (Expr.proj j w) => j == i && w == x
+    | _ => false
+  | _ => false
+
+/-- Given `uset x[i] := y`, return true iff `y := uproj[i] x` -/
+def isSelfUSet (ctx : Context) (x : VarId) (i : Nat) (y : VarId) : Bool :=
+  match ctx.projMap[y]? with
+  | some (Expr.uproj j w) => j == i && w == x
+  | _                     => false
+
+/-- Given `sset x[n, i] := y`, return true iff `y := sproj[n, i] x` -/
+def isSelfSSet (ctx : Context) (x : VarId) (n : Nat) (i : Nat) (y : VarId) : Bool :=
+  match ctx.projMap[y]? with
+  | some (Expr.sproj m j w) => n == m && j == i && w == x
+  | _                       => false
+
+/-- Remove unnecessary `set/uset/sset` operations -/
+partial def removeSelfSet (ctx : Context) : FnBody → FnBody
+  | FnBody.set x i y b   =>
+    if isSelfSet ctx x i y then removeSelfSet ctx b
+    else FnBody.set x i y (removeSelfSet ctx b)
+  | FnBody.uset x i y b   =>
+    if isSelfUSet ctx x i y then removeSelfSet ctx b
+    else FnBody.uset x i y (removeSelfSet ctx b)
+  | FnBody.sset x n i y t b   =>
+    if isSelfSSet ctx x n i y then removeSelfSet ctx b
+    else FnBody.sset x n i y t (removeSelfSet ctx b)
+  | FnBody.case tid y yType alts   =>
+    let alts := alts.map fun alt => alt.modifyBody (removeSelfSet ctx)
+    FnBody.case tid y yType alts
+  | e =>
+    if e.isTerminal then e
+    else
+      let (instr, b) := e.split
+      let b := removeSelfSet ctx b
+      instr.setBody b
+
+partial def reuseToSet (ctx : Context) (x y : VarId) : FnBody → FnBody
+  | FnBody.dec z n c p b   =>
+    if x == z then FnBody.del y b
+    else FnBody.dec z n c p (reuseToSet ctx x y b)
+  | FnBody.vdecl z t v b   =>
+    match v with
+    | Expr.reuse w c u zs =>
+      if x == w then
+        let b := setFields y zs (b.replaceVar z y)
+        let b := if u then FnBody.setTag y c.cidx b else b
+        removeSelfSet ctx b
+      else FnBody.vdecl z t v (reuseToSet ctx x y b)
+    | _ => FnBody.vdecl z t v (reuseToSet ctx x y b)
+  | FnBody.case tid z zType alts   =>
+    let alts := alts.map fun alt => alt.modifyBody (reuseToSet ctx x y)
+    FnBody.case tid z zType alts
+  | e =>
+    if e.isTerminal then e
+    else
+      let (instr, b) := e.split
+      let b := reuseToSet ctx x y b
+      instr.setBody b
+
+/--
+replace
+```
+x := reset y; b
+```
+with
+```
+let f_i_1 := proj[i_1] y;
+...
+let f_i_k := proj[i_k] y;
+b'
+```
+where `i_j`s are the field indexes
+that the code did not touch immediately before the reset.
+That is `mask[j] == none`.
+`b'` is `b` where `y` `dec x` is replaced with `del y`,
+and `z := reuse x ctor_i ws; F` is replaced with
+`set x i ws[i]` operations, and we replace `z` with `x` in `F`
+-/
+def mkFastPath (x y : VarId) (mask : Mask) (b : FnBody) : M FnBody := do
+  let ctx ← read
+  let b := reuseToSet ctx x y b
+  releaseUnreadFields y mask b
+
+-- Expand `bs; x := reset[n] y; b`
+partial def expand (mainFn : FnBody → Array FnBody → M FnBody)
+    (bs : Array FnBody) (x : VarId) (n : Nat) (y : VarId) (b : FnBody) : M FnBody := do
+  let (bs, mask) := eraseProjIncFor n y bs
+  /- Remark: we may be duplicating variable/JP indices. That is, `bSlow` and `bFast` may
+     have duplicate indices. We run `normalizeIds` to fix the ids after we have expand them. -/
+  let bSlow      := mkSlowPath x y mask b
+  let bFast ← mkFastPath x y mask b
+  /- We only optimize recursively the fast. -/
+  let bFast ← mainFn bFast #[]
+  let c ← mkFresh
+  let b := FnBody.vdecl c IRType.uint8 (Expr.isShared y) (mkIf c bSlow bFast)
+  return reshape bs b
+
+partial def searchAndExpand : FnBody → Array FnBody → M FnBody
+  | d@(FnBody.vdecl x _ (Expr.reset n y) b), bs =>
+    if consumed x b then do
+      expand searchAndExpand bs x n y b
+    else
+      searchAndExpand b (push bs d)
+  | FnBody.jdecl j xs v b,   bs => do
+    let v ← searchAndExpand v #[]
+    searchAndExpand b (push bs (FnBody.jdecl j xs v FnBody.nil))
+  | FnBody.case tid x xType alts,   bs => do
+    let alts ← alts.mapM fun alt => alt.mmodifyBody fun b => searchAndExpand b #[]
+    return reshape bs (FnBody.case tid x xType alts)
+  | b, bs =>
+    if b.isTerminal then return reshape bs b
+    else searchAndExpand b.body (push bs b)
+
+def main (d : Decl) : Decl :=
+  match d with
+  | .fdecl (body := b) .. =>
+    let m := mkProjMap d
+    let nextIdx := d.maxIndex + 1
+    let bNew := (searchAndExpand b #[] { projMap := m }).run' nextIdx
+    d.updateBody! bNew
+  | d => d
+
+end ExpandResetReuse
+
+/-- (Try to) expand `reset` and `reuse` instructions. -/
+def Decl.expandResetReuse (d : Decl) : Decl :=
+  (ExpandResetReuse.main d).normalizeIds
+
+end Lean.IR

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/Format.lean

@@ -0,0 +1,143 @@
+/-
+Copyright (c) 2019 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Compiler.IR.Basic
+
+namespace Lean
+namespace IR
+
+private def formatArg : Arg → Format
+  | Arg.var id     => format id
+  | Arg.irrelevant => "◾"
+
+instance : ToFormat Arg := ⟨formatArg⟩
+
+def formatArray {α : Type} [ToFormat α] (args : Array α) : Format :=
+  args.foldl (fun r a => r ++ " " ++ format a) Format.nil
+
+private def formatLitVal : LitVal → Format
+  | LitVal.num v => format v
+  | LitVal.str v => format (repr v)
+
+instance : ToFormat LitVal := ⟨formatLitVal⟩
+
+private def formatCtorInfo : CtorInfo → Format
+  | { name := name, cidx := cidx, usize := usize, ssize := ssize, .. } => Id.run do
+    let mut r := f!"ctor_{cidx}"
+    if usize > 0 || ssize > 0 then
+      r := f!"{r}.{usize}.{ssize}"
+    if name != Name.anonymous then
+      r := f!"{r}[{name}]"
+    r
+
+instance : ToFormat CtorInfo := ⟨formatCtorInfo⟩
+
+private def formatExpr : Expr → Format
+  | Expr.ctor i ys      => format i ++ formatArray ys
+  | Expr.reset n x      => "reset[" ++ format n ++ "] " ++ format x
+  | Expr.reuse x i u ys => "reuse" ++ (if u then "!" else "") ++ " " ++ format x ++ " in " ++ format i ++ formatArray ys
+  | Expr.proj i x       => "proj[" ++ format i ++ "] " ++ format x
+  | Expr.uproj i x      => "uproj[" ++ format i ++ "] " ++ format x
+  | Expr.sproj n o x    => "sproj[" ++ format n ++ ", " ++ format o ++ "] " ++ format x
+  | Expr.fap c ys       => format c ++ formatArray ys
+  | Expr.pap c ys       => "pap " ++ format c ++ formatArray ys
+  | Expr.ap x ys        => "app " ++ format x ++ formatArray ys
+  | Expr.box _ x        => "box " ++ format x
+  | Expr.unbox x        => "unbox " ++ format x
+  | Expr.lit v          => format v
+  | Expr.isShared x     => "isShared " ++ format x
+
+instance : ToFormat Expr := ⟨formatExpr⟩
+instance : ToString Expr := ⟨fun e => Format.pretty (format e)⟩
+
+private partial def formatIRType : IRType → Format
+  | IRType.float        => "float"
+  | IRType.float32      => "float32"
+  | IRType.uint8        => "u8"
+  | IRType.uint16       => "u16"
+  | IRType.uint32       => "u32"
+  | IRType.uint64       => "u64"
+  | IRType.usize        => "usize"
+  | IRType.irrelevant   => "◾"
+  | IRType.object       => "obj"
+  | IRType.tobject      => "tobj"
+  | IRType.struct _ tys =>
+    let _ : ToFormat IRType := ⟨formatIRType⟩
+    "struct " ++ Format.bracket "{" (Format.joinSep tys.toList ", ") "}"
+  | IRType.union _ tys  =>
+    let _ : ToFormat IRType := ⟨formatIRType⟩
+    "union " ++ Format.bracket "{" (Format.joinSep  tys.toList ", ") "}"
+
+instance : ToFormat IRType := ⟨formatIRType⟩
+instance : ToString IRType := ⟨toString ∘ format⟩
+
+private def formatParam : Param → Format
+  | { x := name, borrow := b, ty := ty } => "(" ++ format name ++ " : " ++ (if b then "@& " else "") ++ format ty ++ ")"
+
+instance : ToFormat Param := ⟨formatParam⟩
+
+def formatAlt (fmt : FnBody → Format) (indent : Nat) : Alt → Format
+  | Alt.ctor i b  => format i.name ++ " →" ++ Format.nest indent (Format.line ++ fmt b)
+  | Alt.default b => "default →" ++ Format.nest indent (Format.line ++ fmt b)
+
+def formatParams (ps : Array Param) : Format :=
+  formatArray ps
+
+def formatFnBodyHead : FnBody → Format
+  | FnBody.vdecl x ty e _      => "let " ++ format x ++ " : " ++ format ty ++ " := " ++ format e
+  | FnBody.jdecl j xs _ _      => format j ++ formatParams xs ++ " := ..."
+  | FnBody.set x i y _         => "set " ++ format x ++ "[" ++ format i ++ "] := " ++ format y
+  | FnBody.uset x i y _        => "uset " ++ format x ++ "[" ++ format i ++ "] := " ++ format y
+  | FnBody.sset x i o y ty _   => "sset " ++ format x ++ "[" ++ format i ++ ", " ++ format o ++ "] : " ++ format ty ++ " := " ++ format y
+  | FnBody.setTag x cidx _     => "setTag " ++ format x ++ " := " ++ format cidx
+  | FnBody.inc x n _ _ _       => "inc" ++ (if n != 1 then Format.sbracket (format n) else "") ++ " " ++ format x
+  | FnBody.dec x n _ _ _       => "dec" ++ (if n != 1 then Format.sbracket (format n) else "") ++ " " ++ format x
+  | FnBody.del x _             => "del " ++ format x
+  | FnBody.mdata d _           => "mdata " ++ format d
+  | FnBody.case _   x _     _  => "case " ++ format x ++ " of ..."
+  | FnBody.jmp j ys            => "jmp " ++ format j ++ formatArray ys
+  | FnBody.ret x               => "ret " ++ format x
+  | FnBody.unreachable         => "⊥"
+
+@[export lean_ir_format_fn_body_head]
+private def formatFnBodyHead' (fn : FnBody) : String :=
+  formatFnBodyHead fn |>.pretty
+
+partial def formatFnBody (fnBody : FnBody) (indent : Nat := 2) : Format :=
+  let rec loop : FnBody → Format
+    | FnBody.vdecl x ty e b      => "let " ++ format x ++ " : " ++ format ty ++ " := " ++ format e ++ ";" ++ Format.line ++ loop b
+    | FnBody.jdecl j xs v b      => format j ++ formatParams xs ++ " :=" ++ Format.nest indent (Format.line ++ loop v) ++ ";" ++ Format.line ++ loop b
+    | FnBody.set x i y b         => "set " ++ format x ++ "[" ++ format i ++ "] := " ++ format y ++ ";" ++ Format.line ++ loop b
+    | FnBody.uset x i y b        => "uset " ++ format x ++ "[" ++ format i ++ "] := " ++ format y ++ ";" ++ Format.line ++ loop b
+    | FnBody.sset x i o y ty b   => "sset " ++ format x ++ "[" ++ format i ++ ", " ++ format o ++ "] : " ++ format ty ++ " := " ++ format y ++ ";" ++ Format.line ++ loop b
+    | FnBody.setTag x cidx b     => "setTag " ++ format x ++ " := " ++ format cidx ++ ";" ++ Format.line ++ loop b
+    | FnBody.inc x n _ _ b       => "inc" ++ (if n != 1 then Format.sbracket (format n) else "") ++ " " ++ format x ++ ";" ++ Format.line ++ loop b
+    | FnBody.dec x n _ _ b       => "dec" ++ (if n != 1 then Format.sbracket (format n) else "") ++ " " ++ format x ++ ";" ++ Format.line ++ loop b
+    | FnBody.del x b             => "del " ++ format x ++ ";" ++ Format.line ++ loop b
+    | FnBody.mdata d b           => "mdata " ++ format d ++ ";" ++ Format.line ++ loop b
+    | FnBody.case _ x xType cs   => "case " ++ format x ++ " : " ++ format xType ++ " of" ++ cs.foldl (fun r c => r ++ Format.line ++ formatAlt loop indent c) Format.nil
+    | FnBody.jmp j ys            => "jmp " ++ format j ++ formatArray ys
+    | FnBody.ret x               => "ret " ++ format x
+    | FnBody.unreachable         => "⊥"
+  loop fnBody
+
+instance : ToFormat FnBody := ⟨formatFnBody⟩
+instance : ToString FnBody := ⟨fun b => (format b).pretty⟩
+
+def formatDecl (decl : Decl) (indent : Nat := 2) : Format :=
+  match decl with
+  | Decl.fdecl f xs ty b _  => "def " ++ format f ++ formatParams xs ++ format " : " ++ format ty ++ " :=" ++ Format.nest indent (Format.line ++ formatFnBody b indent)
+  | Decl.extern f xs ty _   => "extern " ++ format f ++ formatParams xs ++ format " : " ++ format ty
+
+instance : ToFormat Decl := ⟨formatDecl⟩
+
+@[export lean_ir_decl_to_string]
+def declToString (d : Decl) : String :=
+  (format d).pretty
+
+instance : ToString Decl := ⟨declToString⟩
+
+end Lean.IR

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/FreeVars.lean

@@ -0,0 +1,233 @@
+/-
+Copyright (c) 2019 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Compiler.IR.Basic
+
+namespace Lean.IR
+
+namespace MaxIndex
+/-! Compute the maximum index `M` used in a declaration.
+   We `M` to initialize the fresh index generator used to create fresh
+   variable and join point names.
+
+   Recall that we variable and join points share the same namespace in
+   our implementation.
+-/
+
+abbrev Collector := Index → Index
+
+@[inline] private def skip : Collector := id
+@[inline] private def collect (x : Index) : Collector := fun y => if x > y then x else y
+@[inline] private def collectVar (x : VarId) : Collector := collect x.idx
+@[inline] private def collectJP (j : JoinPointId) : Collector := collect j.idx
+@[inline] private def seq (k₁ k₂ : Collector) : Collector := k₂ ∘ k₁
+instance : AndThen Collector where
+  andThen a b := seq a (b ())
+
+private def collectArg : Arg → Collector
+  | Arg.var x  => collectVar x
+  | _          => skip
+
+private def collectArray {α : Type} (as : Array α) (f : α → Collector) : Collector :=
+  fun m => as.foldl (fun m a => f a m) m
+
+private def collectArgs (as : Array Arg) : Collector := collectArray as collectArg
+private def collectParam (p : Param) : Collector := collectVar p.x
+private def collectParams (ps : Array Param) : Collector := collectArray ps collectParam
+
+private def collectExpr : Expr → Collector
+  | Expr.ctor _ ys      => collectArgs ys
+  | Expr.reset _ x      => collectVar x
+  | Expr.reuse x _ _ ys => collectVar x >> collectArgs ys
+  | Expr.proj _ x       => collectVar x
+  | Expr.uproj _ x      => collectVar x
+  | Expr.sproj _ _ x    => collectVar x
+  | Expr.fap _ ys       => collectArgs ys
+  | Expr.pap _ ys       => collectArgs ys
+  | Expr.ap x ys        => collectVar x >> collectArgs ys
+  | Expr.box _ x        => collectVar x
+  | Expr.unbox x        => collectVar x
+  | Expr.lit _          => skip
+  | Expr.isShared x     => collectVar x
+
+private def collectAlts (f : FnBody → Collector) (alts : Array Alt) : Collector :=
+  collectArray alts fun alt => f alt.body
+
+partial def collectFnBody : FnBody → Collector
+  | FnBody.vdecl x _ v b    => collectVar x >> collectExpr v >> collectFnBody b
+  | FnBody.jdecl j ys v b   => collectJP j >> collectFnBody v >> collectParams ys >> collectFnBody b
+  | FnBody.set x _ y b      => collectVar x >> collectArg y >> collectFnBody b
+  | FnBody.uset x _ y b     => collectVar x >> collectVar y >> collectFnBody b
+  | FnBody.sset x _ _ y _ b => collectVar x >> collectVar y >> collectFnBody b
+  | FnBody.setTag x _ b     => collectVar x >> collectFnBody b
+  | FnBody.inc x _ _ _ b    => collectVar x >> collectFnBody b
+  | FnBody.dec x _ _ _ b    => collectVar x >> collectFnBody b
+  | FnBody.del x b          => collectVar x >> collectFnBody b
+  | FnBody.mdata _ b        => collectFnBody b
+  | FnBody.case _ x _ alts  => collectVar x >> collectAlts collectFnBody alts
+  | FnBody.jmp j ys         => collectJP j >> collectArgs ys
+  | FnBody.ret x            => collectArg x
+  | FnBody.unreachable      => skip
+
+partial def collectDecl : Decl → Collector
+  | .fdecl (xs := xs) (body := b) .. => collectParams xs >> collectFnBody b
+  | .extern (xs := xs) ..            => collectParams xs
+
+end MaxIndex
+
+def FnBody.maxIndex (b : FnBody) : Index :=
+  MaxIndex.collectFnBody b 0
+
+def Decl.maxIndex (d : Decl) : Index :=
+  MaxIndex.collectDecl d 0
+
+namespace FreeIndices
+/-! We say a variable (join point) index (aka name) is free in a function body
+   if there isn't a `FnBody.vdecl` (`Fnbody.jdecl`) binding it. -/
+
+abbrev Collector := IndexSet → IndexSet → IndexSet
+
+@[inline] private def skip : Collector :=
+  fun _ fv => fv
+
+@[inline] private def collectIndex (x : Index) : Collector :=
+  fun bv fv => if bv.contains x then fv else fv.insert x
+
+@[inline] private def collectVar (x : VarId) : Collector :=
+  collectIndex x.idx
+
+@[inline] private def collectJP (x : JoinPointId) : Collector :=
+  collectIndex x.idx
+
+@[inline] private def withIndex (x : Index) : Collector → Collector :=
+  fun k bv fv => k (bv.insert x) fv
+
+@[inline] private def withVar (x : VarId) : Collector → Collector :=
+  withIndex x.idx
+
+@[inline] private def withJP (x : JoinPointId) : Collector → Collector :=
+  withIndex x.idx
+
+def insertParams (s : IndexSet) (ys : Array Param) : IndexSet :=
+  ys.foldl (init := s) fun s p => s.insert p.x.idx
+
+@[inline] private def withParams (ys : Array Param) : Collector → Collector :=
+  fun k bv fv => k (insertParams bv ys) fv
+
+@[inline] private def seq : Collector → Collector → Collector :=
+  fun k₁ k₂ bv fv => k₂ bv (k₁ bv fv)
+
+instance : AndThen Collector where
+  andThen a b := seq a (b ())
+
+private def collectArg : Arg → Collector
+  | Arg.var x  => collectVar x
+  | _          => skip
+
+private def collectArray {α : Type} (as : Array α) (f : α → Collector) : Collector :=
+  fun bv fv => as.foldl (fun fv a => f a bv fv) fv
+
+private def collectArgs (as : Array Arg) : Collector :=
+  collectArray as collectArg
+
+private def collectExpr : Expr → Collector
+  | Expr.ctor _ ys      => collectArgs ys
+  | Expr.reset _ x      => collectVar x
+  | Expr.reuse x _ _ ys => collectVar x >> collectArgs ys
+  | Expr.proj _ x       => collectVar x
+  | Expr.uproj _ x      => collectVar x
+  | Expr.sproj _ _ x    => collectVar x
+  | Expr.fap _ ys       => collectArgs ys
+  | Expr.pap _ ys       => collectArgs ys
+  | Expr.ap x ys        => collectVar x >> collectArgs ys
+  | Expr.box _ x        => collectVar x
+  | Expr.unbox x        => collectVar x
+  | Expr.lit _          => skip
+  | Expr.isShared x     => collectVar x
+
+private def collectAlts (f : FnBody → Collector) (alts : Array Alt) : Collector :=
+  collectArray alts fun alt => f alt.body
+
+partial def collectFnBody : FnBody → Collector
+  | FnBody.vdecl x _ v b    => collectExpr v >> withVar x (collectFnBody b)
+  | FnBody.jdecl j ys v b   => withParams ys (collectFnBody v) >> withJP j (collectFnBody b)
+  | FnBody.set x _ y b      => collectVar x >> collectArg y >> collectFnBody b
+  | FnBody.uset x _ y b     => collectVar x >> collectVar y >> collectFnBody b
+  | FnBody.sset x _ _ y _ b => collectVar x >> collectVar y >> collectFnBody b
+  | FnBody.setTag x _ b     => collectVar x >> collectFnBody b
+  | FnBody.inc x _ _ _ b    => collectVar x >> collectFnBody b
+  | FnBody.dec x _ _ _ b    => collectVar x >> collectFnBody b
+  | FnBody.del x b          => collectVar x >> collectFnBody b
+  | FnBody.mdata _ b        => collectFnBody b
+  | FnBody.case _ x _ alts  => collectVar x >> collectAlts collectFnBody alts
+  | FnBody.jmp j ys         => collectJP j >> collectArgs ys
+  | FnBody.ret x            => collectArg x
+  | FnBody.unreachable      => skip
+
+end FreeIndices
+
+def FnBody.collectFreeIndices (b : FnBody) (vs : IndexSet) : IndexSet :=
+  FreeIndices.collectFnBody b {} vs
+
+def FnBody.freeIndices (b : FnBody) : IndexSet :=
+  b.collectFreeIndices {}
+
+namespace HasIndex
+/-! In principle, we can check whether a function body `b` contains an index `i` using
+   `b.freeIndices.contains i`, but it is more efficient to avoid the construction
+   of the set of freeIndices and just search whether `i` occurs in `b` or not.
+-/
+def visitVar (w : Index) (x : VarId) : Bool := w == x.idx
+def visitJP (w : Index) (x : JoinPointId) : Bool := w == x.idx
+
+def visitArg (w : Index) : Arg → Bool
+  | Arg.var x => visitVar w x
+  | _         => false
+
+def visitArgs (w : Index) (xs : Array Arg) : Bool :=
+  xs.any (visitArg w)
+
+def visitParams (w : Index) (ps : Array Param) : Bool :=
+  ps.any (fun p => w == p.x.idx)
+
+def visitExpr (w : Index) : Expr → Bool
+  | Expr.ctor _ ys      => visitArgs w ys
+  | Expr.reset _ x      => visitVar w x
+  | Expr.reuse x _ _ ys => visitVar w x || visitArgs w ys
+  | Expr.proj _ x       => visitVar w x
+  | Expr.uproj _ x      => visitVar w x
+  | Expr.sproj _ _ x    => visitVar w x
+  | Expr.fap _ ys       => visitArgs w ys
+  | Expr.pap _ ys       => visitArgs w ys
+  | Expr.ap x ys        => visitVar w x || visitArgs w ys
+  | Expr.box _ x        => visitVar w x
+  | Expr.unbox x        => visitVar w x
+  | Expr.lit _          => false
+  | Expr.isShared x     => visitVar w x
+
+partial def visitFnBody (w : Index) : FnBody → Bool
+  | FnBody.vdecl _ _ v b    => visitExpr w v || visitFnBody w b
+  | FnBody.jdecl _ _  v b   => visitFnBody w v || visitFnBody w b
+  | FnBody.set x _ y b      => visitVar w x || visitArg w y || visitFnBody w b
+  | FnBody.uset x _ y b     => visitVar w x || visitVar w y || visitFnBody w b
+  | FnBody.sset x _ _ y _ b => visitVar w x || visitVar w y || visitFnBody w b
+  | FnBody.setTag x _ b     => visitVar w x || visitFnBody w b
+  | FnBody.inc x _ _ _ b    => visitVar w x || visitFnBody w b
+  | FnBody.dec x _ _ _ b    => visitVar w x || visitFnBody w b
+  | FnBody.del x b          => visitVar w x || visitFnBody w b
+  | FnBody.mdata _ b        => visitFnBody w b
+  | FnBody.jmp j ys         => visitJP w j || visitArgs w ys
+  | FnBody.ret x            => visitArg w x
+  | FnBody.case _ x _ alts  => visitVar w x || alts.any (fun alt => visitFnBody w alt.body)
+  | FnBody.unreachable      => false
+
+end HasIndex
+
+def Arg.hasFreeVar (arg : Arg) (x : VarId) : Bool := HasIndex.visitArg x.idx arg
+def Expr.hasFreeVar (e : Expr) (x : VarId) : Bool := HasIndex.visitExpr x.idx e
+def FnBody.hasFreeVar (b : FnBody) (x : VarId) : Bool := HasIndex.visitFnBody x.idx b
+
+end Lean.IR

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/LLVMBindings.lean

@@ -0,0 +1,470 @@
+/-
+Copyright (c) 2022 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Siddharth Bhat
+-/
+prelude
+import Init.System.IO
+
+namespace LLVM
+/-!
+This file defines bindings for LLVM. The main mechanisms
+are to:
+- Mirror the values of C enumerations.
+- Create opaque values for LLVM's pointer based API
+- Write bindings that are `IO` based, which mutate the underlying in-memory
+  data structures to build IR.
+-/
+
+-- https://github.com/llvm/llvm-project/blob/c3e073bcbdc523b0f758d44a89a6333e38bff863/llvm/include/llvm-c/TargetMachine.h#L64
+structure CodegenFileType where
+  private mk :: val : UInt64
+
+def CodegenFileType.AssemblyFile : CodegenFileType := { val := 0 }
+def CodegenFileType.ObjectFile : CodegenFileType := { val := 1 }
+
+-- https://github.com/llvm/llvm-project/blob/c3e073bcbdc523b0f758d44a89a6333e38bff863/llvm/include/llvm-c/Core.h#L290
+structure IntPredicate where
+  private mk :: val : UInt64
+
+def IntPredicate.EQ : IntPredicate := { val := 32 }
+def IntPredicate.NE : IntPredicate := { val := IntPredicate.EQ.val + 1 }
+def IntPredicate.UGT : IntPredicate := { val := IntPredicate.NE.val + 1 }
+
+-- https://github.com/llvm/llvm-project/blob/c3e073bcbdc523b0f758d44a89a6333e38bff863/llvm/include/llvm-c/Core.h#L457
+structure AttributeIndex where
+  private mk :: val : UInt64
+
+def AttributeIndex.AttributeReturnIndex : AttributeIndex := { val := 0 }
+-- This value is ~0 for 64 bit
+def AttributeIndex.AttributeFunctionIndex : AttributeIndex := { val := 18446744073709551615 }
+
+structure BasicBlock (ctx : Context)  where
+  private mk :: ptr : USize
+instance : Nonempty (BasicBlock ctx) := ⟨{ ptr := default }⟩
+
+structure Builder (ctx : Context) where
+  private mk :: ptr : USize
+instance : Nonempty (Builder ctx) := ⟨{ ptr := default }⟩
+
+structure Context where
+  private mk :: ptr : USize
+instance : Nonempty Context := ⟨{ ptr := default }⟩
+
+structure LLVMType (ctx : Context) where
+  private mk :: ptr : USize
+instance : Nonempty (LLVMType ctx) := ⟨{ ptr := default }⟩
+
+structure MemoryBuffer (ctx : Context) where
+  private mk :: ptr : USize
+instance : Nonempty (MemoryBuffer ctx) := ⟨{ ptr := default }⟩
+
+structure Module (ctx : Context) where
+  private mk :: ptr : USize
+instance : Nonempty (Module ctx) := ⟨{ ptr := default }⟩
+
+/-
+structure PassManager (ctx : Context) where
+  private mk :: ptr : USize
+instance : Nonempty (PassManager ctx) := ⟨{ ptr := default }⟩
+
+structure PassManagerBuilder (ctx : Context) where
+  private mk :: ptr : USize
+instance : Nonempty (PassManagerBuilder ctx) := ⟨{ ptr := default }⟩
+-/
+
+structure Target (ctx : Context) where
+  private mk :: ptr : USize
+instance : Nonempty (Target ctx) := ⟨{ ptr := default }⟩
+
+structure TargetMachine (ctx : Context) where
+  private mk :: ptr : USize
+instance : Nonempty (TargetMachine ctx) := ⟨{ ptr := default }⟩
+
+structure Value (ctx : Context) where
+  private mk :: ptr : USize
+instance : Nonempty (Value ctx) := ⟨{ ptr := default }⟩
+
+/-- Check if the value is a null pointer. --/
+def Value.isNull (v : Value ctx) : Bool := v.ptr == 0
+
+@[extern "lean_llvm_get_value_name2"]
+opaque Value.getName {ctx : Context} (value : Value ctx) : BaseIO String
+
+structure Attribute (ctx : Context) where
+  private mk :: ptr : USize
+instance : Nonempty (Attribute ctx) := ⟨{ ptr := default }⟩
+
+@[extern "lean_llvm_initialize_target_info"]
+opaque llvmInitializeTargetInfo : BaseIO (Unit)
+
+@[extern "lean_llvm_create_context"]
+opaque createContext : BaseIO (Context)
+
+@[extern "lean_llvm_create_module"]
+opaque createModule (ctx : Context) (name : @&String) : BaseIO (Module ctx)
+
+@[extern "lean_llvm_module_to_string"]
+opaque moduleToString (m : Module ctx) : BaseIO String
+
+@[extern "lean_llvm_write_bitcode_to_file"]
+opaque writeBitcodeToFile (m : Module ctx) (path : @&String) : BaseIO Unit
+
+@[extern "lean_llvm_add_function"]
+opaque addFunction (m : Module ctx) (name : @&String) (type : LLVMType ctx) : BaseIO (Value ctx)
+
+@[extern "lean_llvm_get_first_function"]
+opaque getFirstFunction (m : Module ctx) : BaseIO (Value ctx)
+
+@[extern "lean_llvm_get_next_function"]
+opaque getNextFunction (glbl : Value ctx) : BaseIO (Value ctx)
+
+@[extern "lean_llvm_get_named_function"]
+opaque getNamedFunction (m : Module ctx) (name : @&String) : BaseIO (Option (Value ctx))
+
+@[extern "lean_llvm_add_global"]
+opaque addGlobal (m : Module ctx) (name : @&String) (type : LLVMType ctx) : BaseIO (Value ctx)
+
+@[extern "lean_llvm_get_named_global"]
+opaque getNamedGlobal (m : Module ctx) (name : @&String) : BaseIO (Option (Value ctx))
+
+@[extern "lean_llvm_get_first_global"]
+opaque getFirstGlobal (m : Module ctx) : BaseIO (Value ctx)
+
+@[extern "lean_llvm_get_next_global"]
+opaque getNextGlobal (glbl : Value ctx) : BaseIO (Value ctx)
+
+@[extern "lean_llvm_build_global_string"]
+opaque buildGlobalString (builder : Builder ctx) (value : @&String) (name : @&String := "") : BaseIO (Value ctx)
+
+@[extern "llvm_is_declaration"]
+opaque isDeclaration (global : Value ctx) : BaseIO Bool
+
+@[extern "lean_llvm_set_initializer"]
+opaque setInitializer (glbl : Value ctx) (val : Value ctx) : BaseIO Unit
+
+@[extern "lean_llvm_function_type"]
+opaque functionType (retty : LLVMType ctx) (args : @&Array (LLVMType ctx)) (isVarArg : Bool := false) : BaseIO (LLVMType ctx)
+
+@[extern "lean_llvm_void_type_in_context"]
+opaque voidType (ctx : Context) : BaseIO (LLVMType ctx)
+
+@[extern "lean_llvm_int_type_in_context"]
+opaque intTypeInContext (ctx : Context) (width : UInt64) : BaseIO (LLVMType ctx)
+
+@[extern "lean_llvm_opaque_pointer_type_in_context"]
+opaque opaquePointerTypeInContext (ctx : Context) (addrspace: UInt64 := 0) : BaseIO (LLVMType ctx)
+
+@[extern "lean_llvm_float_type_in_context"]
+opaque floatTypeInContext (ctx : Context) : BaseIO (LLVMType ctx)
+
+@[extern "lean_llvm_double_type_in_context"]
+opaque doubleTypeInContext (ctx : Context) : BaseIO (LLVMType ctx)
+
+@[extern "lean_llvm_pointer_type"]
+opaque pointerType (elemty : LLVMType ctx) : BaseIO (LLVMType ctx)
+
+@[extern "lean_llvm_array_type"]
+opaque arrayType (elemty : LLVMType ctx) (nelem : UInt64) : BaseIO (LLVMType ctx)
+
+@[extern "lean_llvm_const_array"]
+opaque constArray (elemty : LLVMType ctx) (vals : @&Array (Value ctx)) : BaseIO (LLVMType ctx)
+
+-- `constString` provides a `String` as a constant array of element type `i8`
+@[extern "lean_llvm_const_string"]
+opaque constString (ctx : Context) (str : @&String) : BaseIO (Value ctx)
+
+@[extern "lean_llvm_const_pointer_null"]
+opaque constPointerNull (elemty : LLVMType ctx) : BaseIO (Value ctx)
+
+@[extern "lean_llvm_get_undef"]
+opaque getUndef (elemty : LLVMType ctx) : BaseIO (Value ctx)
+
+@[extern "lean_llvm_create_builder_in_context"]
+opaque createBuilderInContext (ctx : Context) : BaseIO (Builder ctx)
+
+@[extern "lean_llvm_append_basic_block_in_context"]
+opaque appendBasicBlockInContext (ctx : Context) (fn :  Value ctx) (name :  @&String) : BaseIO (BasicBlock ctx)
+
+@[extern "lean_llvm_count_basic_blocks"]
+opaque countBasicBlocks (fn : Value ctx) : BaseIO UInt64
+
+@[extern "lean_llvm_get_entry_basic_block"]
+opaque getEntryBasicBlock (fn : Value ctx) : BaseIO (BasicBlock ctx)
+
+@[extern "lean_llvm_get_first_instruction"]
+opaque getFirstInstruction (bb : BasicBlock ctx) : BaseIO (Option (Value ctx))
+
+@[extern "lean_llvm_position_builder_before"]
+opaque positionBuilderBefore (builder : Builder ctx) (instr : Value ctx) : BaseIO Unit
+
+@[extern "lean_llvm_position_builder_at_end"]
+opaque positionBuilderAtEnd (builder : Builder ctx) (bb :  BasicBlock ctx) : BaseIO Unit
+
+@[extern "lean_llvm_build_call2"]
+opaque buildCall2 (builder : Builder ctx) (ty: LLVMType ctx) (fn : Value ctx) (args : @&Array (Value ctx)) (name :  @&String := "") : BaseIO (Value ctx)
+
+@[extern "lean_llvm_set_tail_call"]
+opaque setTailCall (fn : Value ctx) (istail : Bool) : BaseIO Unit
+
+@[extern "lean_llvm_build_cond_br"]
+opaque buildCondBr (builder : Builder ctx) (if_ : Value ctx) (thenbb : BasicBlock ctx) (elsebb : BasicBlock ctx) : BaseIO (Value ctx)
+
+@[extern "lean_llvm_build_br"]
+opaque buildBr (builder : Builder ctx) (bb : BasicBlock ctx) : BaseIO (Value ctx)
+
+@[extern "lean_llvm_build_alloca"]
+opaque buildAlloca (builder : Builder ctx) (ty : LLVMType ctx) (name : @&String := "") : BaseIO (Value ctx)
+
+@[extern "lean_llvm_build_load2"]
+opaque buildLoad2 (builder : Builder ctx) (ty: LLVMType ctx) (val : Value ctx) (name : @&String := "") : BaseIO (Value ctx)
+
+@[extern "lean_llvm_build_store"]
+opaque buildStore (builder : Builder ctx) (val : Value ctx) (store_loc_ptr : Value ctx) : BaseIO Unit
+
+@[extern "lean_llvm_build_ret"]
+opaque buildRet (builder : Builder ctx) (val : Value ctx) : BaseIO (Value ctx)
+
+@[extern "lean_llvm_build_unreachable"]
+opaque buildUnreachable (builder : Builder ctx) : BaseIO (Value ctx)
+
+@[extern "lean_llvm_build_gep2"]
+opaque buildGEP2 (builder : Builder ctx) (ty: LLVMType ctx) (base : Value ctx) (ixs : @&Array (Value ctx)) (name : @&String := "") : BaseIO (Value ctx)
+
+@[extern "lean_llvm_build_inbounds_gep2"]
+opaque buildInBoundsGEP2 (builder : Builder ctx) (ty: LLVMType ctx) (base : Value ctx) (ixs : @&Array (Value ctx)) (name : @&String := "") : BaseIO (Value ctx)
+
+@[extern "lean_llvm_build_sext"]
+opaque buildSext (builder : Builder ctx) (val : Value ctx) (destTy : LLVMType ctx) (name : @&String := "") : BaseIO (Value ctx)
+
+@[extern "lean_llvm_build_zext"]
+opaque buildZext (builder : Builder ctx) (val : Value ctx) (destTy : LLVMType ctx) (name : @&String := "") : BaseIO (Value ctx)
+
+@[extern "lean_llvm_build_sext_or_trunc"]
+opaque buildSextOrTrunc (builder : Builder ctx) (val : Value ctx) (destTy : LLVMType ctx) (name : @&String := "") : BaseIO (Value ctx)
+
+@[extern "lean_llvm_build_switch"]
+opaque buildSwitch (builder : Builder ctx) (val : Value ctx) (elseBB : BasicBlock ctx) (numCasesHint : UInt64) : BaseIO (Value ctx)
+
+@[extern "lean_llvm_build_ptr_to_int"]
+opaque buildPtrToInt (builder : Builder ctx) (ptr : Value ctx) (destTy : LLVMType ctx) (name : @&String := "") : BaseIO (Value ctx)
+
+@[extern "lean_llvm_build_mul"]
+opaque buildMul (builder : Builder ctx) (x y : Value ctx) (name : @&String := "") : BaseIO (Value ctx)
+
+@[extern "lean_llvm_build_add"]
+opaque buildAdd (builder : Builder ctx) (x y : Value ctx) (name : @&String := "") : BaseIO (Value ctx)
+
+@[extern "lean_llvm_build_sub"]
+opaque buildSub (builder : Builder ctx) (x y : Value ctx) (name : @&String := "") : BaseIO (Value ctx)
+
+@[extern "lean_llvm_build_not"]
+opaque buildNot (builder : Builder ctx) (x : Value ctx) (name : @&String := "") : BaseIO (Value ctx)
+
+@[extern "lean_llvm_build_icmp"]
+opaque buildICmp (builder : Builder ctx) (predicate : IntPredicate) (x y : Value ctx) (name : @&String := "") : BaseIO (Value ctx)
+
+@[extern "lean_llvm_add_case"]
+opaque addCase (switch onVal : Value ctx) (destBB : BasicBlock ctx) : BaseIO Unit
+
+@[extern "lean_llvm_get_insert_block"]
+opaque getInsertBlock (builder : Builder ctx) : BaseIO (BasicBlock ctx)
+
+@[extern "lean_llvm_clear_insertion_position"]
+opaque clearInsertionPosition (builder : Builder ctx) : BaseIO Unit
+
+@[extern "lean_llvm_get_basic_block_parent"]
+opaque getBasicBlockParent (bb : BasicBlock ctx) : BaseIO (Value ctx)
+
+@[extern "lean_llvm_type_of"]
+opaque typeOf (val : Value ctx) : BaseIO (LLVMType ctx)
+
+@[extern "lean_llvm_const_int"]
+opaque constInt (intty : LLVMType ctx) (value : UInt64) (signExtend : @Bool := false) : BaseIO (Value ctx)
+
+@[extern "lean_llvm_print_module_to_string"]
+opaque printModuletoString (mod : Module ctx) : BaseIO (String)
+
+@[extern "lean_llvm_print_module_to_file"]
+opaque printModuletoFile (mod : Module ctx) (file : @&String) : BaseIO Unit
+
+@[extern "llvm_count_params"]
+opaque countParams (fn : Value ctx) : BaseIO UInt64
+
+@[extern "llvm_get_param"]
+opaque getParam (fn : Value ctx) (ix : UInt64) : BaseIO (Value ctx)
+
+@[extern "lean_llvm_create_memory_buffer_with_contents_of_file"]
+opaque createMemoryBufferWithContentsOfFile (path : @&String) : BaseIO (MemoryBuffer ctx)
+
+@[extern "lean_llvm_parse_bitcode"]
+opaque parseBitcode (ctx : Context) (membuf : MemoryBuffer ctx) : BaseIO (Module ctx)
+
+@[extern "lean_llvm_link_modules"]
+opaque linkModules (dest : Module ctx) (src : Module ctx) : BaseIO Unit
+
+@[extern "lean_llvm_get_default_target_triple"]
+opaque getDefaultTargetTriple : BaseIO String
+
+@[extern "lean_llvm_get_target_from_triple"]
+opaque getTargetFromTriple (triple : @&String) : BaseIO (Target ctx)
+
+@[extern "lean_llvm_create_target_machine"]
+opaque createTargetMachine (target : Target ctx) (tripleStr : @&String) (cpu : @&String) (features : @&String) : BaseIO (TargetMachine ctx)
+
+@[extern "lean_llvm_target_machine_emit_to_file"]
+opaque targetMachineEmitToFile (targetMachine : TargetMachine ctx) (module : Module ctx) (filepath : @&String) (codegenType : LLVM.CodegenFileType) : BaseIO Unit
+
+/-
+@[extern "lean_llvm_create_pass_manager"]
+opaque createPassManager : BaseIO (PassManager ctx)
+
+@[extern "lean_llvm_dispose_pass_manager"]
+opaque disposePassManager (pm : PassManager ctx) : BaseIO Unit
+
+@[extern "lean_llvm_run_pass_manager"]
+opaque runPassManager (pm : PassManager ctx) (mod : Module ctx): BaseIO Unit
+
+@[extern "lean_llvm_create_pass_manager_builder"]
+opaque createPassManagerBuilder : BaseIO (PassManagerBuilder ctx)
+
+@[extern "lean_llvm_dispose_pass_manager_builder"]
+opaque disposePassManagerBuilder (pmb : PassManagerBuilder ctx) : BaseIO Unit
+
+@[extern "lean_llvm_pass_manager_builder_set_opt_level"]
+opaque PassManagerBuilder.setOptLevel (pmb : PassManagerBuilder ctx) (optLevel : unsigned) : BaseIO Unit
+
+@[extern "lean_llvm_pass_manager_builder_populate_module_pass_manager"]
+opaque PassManagerBuilder.populateModulePassManager (pmb : PassManagerBuilder ctx) (pm : PassManager ctx): BaseIO Unit
+-/
+
+@[extern "lean_llvm_dispose_target_machine"]
+opaque disposeTargetMachine (tm : TargetMachine ctx) : BaseIO Unit
+
+@[extern "lean_llvm_dispose_module"]
+opaque disposeModule (m : Module ctx) : BaseIO Unit
+
+@[extern "lean_llvm_verify_module"]
+opaque verifyModule (m : Module ctx) : BaseIO (Option String)
+
+@[extern "lean_llvm_create_string_attribute"]
+opaque createStringAttribute (key : String) (value : String) : BaseIO (Attribute ctx)
+
+@[extern "lean_llvm_add_attribute_at_index"]
+opaque addAttributeAtIndex (fn : Value ctx) (idx: AttributeIndex) (attr: Attribute ctx) : BaseIO Unit
+
+
+-- https://github.com/llvm/llvm-project/blob/c3e073bcbdc523b0f758d44a89a6333e38bff863/llvm/include/llvm-c/Core.h#L198
+structure Visibility where
+  private mk :: val : UInt64
+
+def Visibility.default   : Visibility := { val := 0 }
+def Visibility.hidden    : Visibility := { val := 1 }
+def Visibility.protected : Visibility := { val := 2 }
+
+@[extern "lean_llvm_set_visibility"]
+opaque setVisibility {ctx : Context} (value : Value ctx) (visibility : Visibility) : BaseIO Unit
+
+-- https://github.com/llvm/llvm-project/blob/c3e073bcbdc523b0f758d44a89a6333e38bff863/llvm/include/llvm-c/Core.h#L210
+structure DLLStorageClass where
+  private mk :: val : UInt64
+
+def DLLStorageClass.default : DLLStorageClass := { val := 0 }
+def DLLStorageClass.import  : DLLStorageClass := { val := 1 }
+def DLLStorageClass.export  : DLLStorageClass := { val := 2 }
+
+@[extern "lean_llvm_set_dll_storage_class"]
+opaque setDLLStorageClass {ctx : Context} (value : Value ctx) (dllStorageClass : DLLStorageClass) : BaseIO Unit
+
+-- https://github.com/llvm/llvm-project/blob/c3e073bcbdc523b0f758d44a89a6333e38bff863/llvm/include/llvm-c/Core.h#L192
+structure Linkage where
+  private mk :: val : UInt64
+
+/-- Externally visible function -/
+def Linkage.external : Linkage := { val := 0 }
+def Linkage.availableExternally : Linkage := { val := 1 }
+/-- Keep one copy of function when linking (inline) -/
+def Linkage.linkOnceAny : Linkage := { val := 2 }
+/-- Same, but only replaced by something equivalent  -/
+def Linkage.linkOnceODR : Linkage := { val := 3 }
+/-- Obsolete -/
+def Linkage.linkOnceODRAutoHide : Linkage := { val := 4 }
+/-- Keep one copy of function when linking (weak) -/
+def Linkage.weakAny : Linkage := { val := 5 }
+/-- Same, but only replaced by something equivalent -/
+def Linkage.weakODR : Linkage := { val := 6 }
+/-- Special purpose, only applies to global arrays -/
+def Linkage.appending : Linkage := { val := 7 }
+/-- Rename collisions when linking (static functions) -/
+def Linkage.internal : Linkage := { val := 8 }
+/-- Like Internal, but omit from symbol table -/
+def Linkage.private : Linkage := { val := 9 }
+/-- Obsolete -/
+def Linkage.dllImport : Linkage := { val := 10 }
+/-- Obsolete -/
+def Linkage.dllExport : Linkage := { val := 11 }
+/-- ExternalWeak linkage description -/
+def Linkage.externalWeak : Linkage := { val := 12 }
+/-- Obsolete -/
+def Linkage.ghost : Linkage := { val := 13 }
+/-- Tentative definitions -/
+def Linkage.common : Linkage := { val := 14 }
+/-- Like Private, but linker removes. -/
+def Linkage.linkerPrivate : Linkage := { val := 15 }
+/-- Like LinkerPrivate, but is weak. -/
+def Linkage.linkerPrivateWeak : Linkage := { val := 16 }
+
+@[extern "lean_llvm_set_linkage"]
+opaque setLinkage {ctx : Context} (value : Value ctx) (linkage : Linkage) : BaseIO Unit
+
+
+def i1Type (ctx : LLVM.Context) : BaseIO (LLVM.LLVMType ctx) :=
+  LLVM.intTypeInContext ctx 1
+
+def i8Type (ctx : LLVM.Context) : BaseIO (LLVM.LLVMType ctx) :=
+  LLVM.intTypeInContext ctx 8
+
+def i16Type (ctx : LLVM.Context) : BaseIO (LLVM.LLVMType ctx) :=
+  LLVM.intTypeInContext ctx 16
+
+def i32Type (ctx : LLVM.Context) : BaseIO (LLVM.LLVMType ctx) :=
+  LLVM.intTypeInContext ctx 32
+
+def i64Type (ctx : LLVM.Context) : BaseIO (LLVM.LLVMType ctx) :=
+  LLVM.intTypeInContext ctx 64
+
+def voidPtrType (ctx : LLVM.Context) : BaseIO (LLVM.LLVMType ctx) :=
+  do LLVM.pointerType (← LLVM.intTypeInContext ctx 8)
+
+def i8PtrType (ctx : LLVM.Context) : BaseIO (LLVM.LLVMType ctx) :=
+  voidPtrType ctx
+
+def constTrue (ctx : Context) : BaseIO (Value ctx) :=
+  do constInt (← i1Type ctx) 1 (signExtend := false)
+
+def constFalse (ctx : Context) : BaseIO (Value ctx) :=
+  do constInt (← i1Type ctx) 0 (signExtend := false)
+
+def constInt' (ctx : Context) (width : UInt64) (value : UInt64) (signExtend : Bool := false) : BaseIO (Value ctx) :=
+ do constInt (← LLVM.intTypeInContext ctx width) value signExtend
+
+def constInt1 (ctx : Context) (value : UInt64) (signExtend : Bool := false) : BaseIO (Value ctx) :=
+  constInt' ctx 1 value signExtend
+
+def constInt8 (ctx : Context) (value : UInt64) (signExtend : Bool := false) : BaseIO (Value ctx) :=
+  constInt' ctx 8 value signExtend
+
+def constInt32 (ctx : Context) (value : UInt64) (signExtend : Bool := false) : BaseIO (Value ctx) :=
+  constInt' ctx 32 value signExtend
+
+def constInt64 (ctx : Context) (value : UInt64) (signExtend : Bool := false) : BaseIO (Value ctx) :=
+  constInt' ctx 64 value signExtend
+
+def constIntSizeT (ctx : Context) (value : UInt64) (signExtend : Bool := false) : BaseIO (Value ctx) :=
+  -- TODO: make this stick to the actual size_t of the target machine
+  constInt' ctx 64 value signExtend
+
+def constIntUnsigned (ctx : Context) (value : UInt64) (signExtend : Bool := false) : BaseIO (Value ctx) :=
+  -- TODO: make this stick to the actual unsigned of the target machine
+  constInt' ctx 32 value signExtend
+end LLVM

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/LiveVars.lean

@@ -0,0 +1,170 @@
+/-
+Copyright (c) 2019 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Compiler.IR.Basic
+import Lean.Compiler.IR.FreeVars
+
+namespace Lean.IR
+
+/-! Remark: in the paper "Counting Immutable Beans" the concepts of
+   free and live variables coincide because the paper does *not* consider
+   join points. For example, consider the function body `B`
+   ```
+   let x := ctor_0;
+   jmp block_1 x
+   ```
+   in a context where we have the join point `block_1` defined as
+   ```
+   block_1 (x : obj) : obj :=
+   let z := ctor_0 x y;
+   ret z
+   ```
+   The variable `y` is live in the function body `B` since it occurs in
+   `block_1` which is "invoked" by `B`.
+-/
+
+namespace IsLive
+/--
+  We use `State Context` instead of `ReaderT Context Id` because we remove
+  non local joint points from `Context` whenever we visit them instead of
+  maintaining a set of visited non local join points.
+
+  Remark: we don't need to track local join points because we assume there is
+  no variable or join point shadowing in our IR.
+-/
+abbrev M := StateM LocalContext
+
+abbrev visitVar (w : Index) (x : VarId) : M Bool := pure (HasIndex.visitVar w x)
+abbrev visitJP (w : Index) (x : JoinPointId) : M Bool := pure (HasIndex.visitJP w x)
+abbrev visitArg (w : Index) (a : Arg) : M Bool := pure (HasIndex.visitArg w a)
+abbrev visitArgs (w : Index) (as : Array Arg) : M Bool := pure (HasIndex.visitArgs w as)
+abbrev visitExpr (w : Index) (e : Expr) : M Bool := pure (HasIndex.visitExpr w e)
+
+partial def visitFnBody (w : Index) : FnBody → M Bool
+  | FnBody.vdecl _ _ v b    => visitExpr w v <||> visitFnBody w b
+  | FnBody.jdecl _ _  v b   => visitFnBody w v <||> visitFnBody w b
+  | FnBody.set x _ y b      => visitVar w x <||> visitArg w y <||> visitFnBody w b
+  | FnBody.uset x _ y b     => visitVar w x <||> visitVar w y <||> visitFnBody w b
+  | FnBody.sset x _ _ y _ b => visitVar w x <||> visitVar w y <||> visitFnBody w b
+  | FnBody.setTag x _ b     => visitVar w x <||> visitFnBody w b
+  | FnBody.inc x _ _ _ b    => visitVar w x <||> visitFnBody w b
+  | FnBody.dec x _ _ _ b    => visitVar w x <||> visitFnBody w b
+  | FnBody.del x b          => visitVar w x <||> visitFnBody w b
+  | FnBody.mdata _ b        => visitFnBody w b
+  | FnBody.jmp j ys         => visitArgs w ys <||> do
+      let ctx ← get
+      match ctx.getJPBody j with
+      | some b =>
+        -- `j` is not a local join point since we assume we cannot shadow join point declarations.
+        -- Instead of marking the join points that we have already been visited, we permanently remove `j` from the context.
+        set (ctx.eraseJoinPointDecl j) *> visitFnBody w b
+      | none   =>
+        -- `j` must be a local join point. So do nothing since we have already visite its body.
+        pure false
+  | FnBody.ret x            => visitArg w x
+  | FnBody.case _ x _ alts  => visitVar w x <||> alts.anyM (fun alt => visitFnBody w alt.body)
+  | FnBody.unreachable      => pure false
+
+end IsLive
+
+/-- Return true if `x` is live in the function body `b` in the context `ctx`.
+
+   Remark: the context only needs to contain all (free) join point declarations.
+
+   Recall that we say that a join point `j` is free in `b` if `b` contains
+   `FnBody.jmp j ys` and `j` is not local. -/
+def FnBody.hasLiveVar (b : FnBody) (ctx : LocalContext) (x : VarId) : Bool :=
+  (IsLive.visitFnBody x.idx b).run' ctx
+
+abbrev LiveVarSet   := VarIdSet
+abbrev JPLiveVarMap := RBMap JoinPointId LiveVarSet (fun j₁ j₂ => compare j₁.idx j₂.idx)
+
+instance : Inhabited LiveVarSet where
+  default := {}
+
+def mkLiveVarSet (x : VarId) : LiveVarSet :=
+  RBTree.empty.insert x
+
+namespace LiveVars
+
+abbrev Collector := LiveVarSet → LiveVarSet
+
+@[inline] private def skip : Collector := fun s => s
+@[inline] private def collectVar (x : VarId) : Collector := fun s => s.insert x
+
+private def collectArg : Arg → Collector
+  | Arg.var x  => collectVar x
+  | _          => skip
+
+private def collectArray {α : Type} (as : Array α) (f : α → Collector) : Collector := fun s =>
+  as.foldl (fun s a => f a s) s
+
+private def collectArgs (as : Array Arg) : Collector :=
+  collectArray as collectArg
+
+private def accumulate (s' : LiveVarSet) : Collector :=
+  fun s => s'.fold (fun s x => s.insert x) s
+
+private def collectJP (m : JPLiveVarMap) (j : JoinPointId) : Collector :=
+  match m.find? j with
+  | some xs => accumulate xs
+  | none    => skip -- unreachable for well-formed code
+
+private def bindVar (x : VarId) : Collector := fun s =>
+  s.erase x
+
+private def bindParams (ps : Array Param) : Collector := fun s =>
+  ps.foldl (fun s p => s.erase p.x) s
+
+def collectExpr : Expr → Collector
+  | Expr.ctor _ ys      => collectArgs ys
+  | Expr.reset _ x      => collectVar x
+  | Expr.reuse x _ _ ys => collectVar x ∘ collectArgs ys
+  | Expr.proj _ x       => collectVar x
+  | Expr.uproj _ x      => collectVar x
+  | Expr.sproj _ _ x    => collectVar x
+  | Expr.fap _ ys       => collectArgs ys
+  | Expr.pap _ ys       => collectArgs ys
+  | Expr.ap x ys        => collectVar x ∘ collectArgs ys
+  | Expr.box _ x        => collectVar x
+  | Expr.unbox x        => collectVar x
+  | Expr.lit _          => skip
+  | Expr.isShared x     => collectVar x
+
+partial def collectFnBody : FnBody → JPLiveVarMap → Collector
+  | FnBody.vdecl x _ v b,    m => collectExpr v ∘ bindVar x ∘ collectFnBody b m
+  | FnBody.jdecl j ys v b,   m =>
+    let jLiveVars := (bindParams ys ∘ collectFnBody v m) {};
+    let m         := m.insert j jLiveVars;
+    collectFnBody b m
+  | FnBody.set x _ y b,      m => collectVar x ∘ collectArg y ∘ collectFnBody b m
+  | FnBody.setTag x _ b,     m => collectVar x ∘ collectFnBody b m
+  | FnBody.uset x _ y b,     m => collectVar x ∘ collectVar y ∘ collectFnBody b m
+  | FnBody.sset x _ _ y _ b, m => collectVar x ∘ collectVar y ∘ collectFnBody b m
+  | FnBody.inc x _ _ _ b,    m => collectVar x ∘ collectFnBody b m
+  | FnBody.dec x _ _ _ b,    m => collectVar x ∘ collectFnBody b m
+  | FnBody.del x b,          m => collectVar x ∘ collectFnBody b m
+  | FnBody.mdata _ b,        m => collectFnBody b m
+  | FnBody.ret x,            _ => collectArg x
+  | FnBody.case _ x _ alts,  m => collectVar x ∘ collectArray alts (fun alt => collectFnBody alt.body m)
+  | FnBody.unreachable,      _ => skip
+  | FnBody.jmp j xs,         m => collectJP m j ∘ collectArgs xs
+
+def updateJPLiveVarMap (j : JoinPointId) (ys : Array Param) (v : FnBody) (m : JPLiveVarMap) : JPLiveVarMap :=
+  let jLiveVars := (bindParams ys ∘ collectFnBody v m) {};
+  m.insert j jLiveVars
+
+end LiveVars
+
+def updateLiveVars (e : Expr) (v : LiveVarSet) : LiveVarSet :=
+  LiveVars.collectExpr e v
+
+def collectLiveVars (b : FnBody) (m : JPLiveVarMap) (v : LiveVarSet := {}) : LiveVarSet :=
+  LiveVars.collectFnBody b m v
+
+export LiveVars (updateJPLiveVarMap)
+
+end Lean.IR

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/NormIds.lean

@@ -0,0 +1,177 @@
+/-
+Copyright (c) 2019 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Compiler.IR.Basic
+
+namespace Lean.IR.UniqueIds
+
+abbrev M := StateT IndexSet Id
+
+def checkId (id : Index) : M Bool :=
+  modifyGet fun s =>
+    if s.contains id then (false, s)
+    else (true, s.insert id)
+
+def checkParams (ps : Array Param) : M Bool :=
+  ps.allM fun p => checkId p.x.idx
+
+partial def checkFnBody : FnBody → M Bool
+  | .vdecl x _ _ b    => checkId x.idx <&&> checkFnBody b
+  | .jdecl j ys _ b   => checkId j.idx <&&> checkParams ys <&&> checkFnBody b
+  | .case _ _ _ alts  => alts.allM fun alt => checkFnBody alt.body
+  | b                 => if b.isTerminal then pure true else checkFnBody b.body
+
+partial def checkDecl : Decl → M Bool
+  | .fdecl (xs := xs) (body := b) .. => checkParams xs <&&> checkFnBody b
+  | .extern (xs := xs) .. => checkParams xs
+
+end UniqueIds
+
+/-- Return true if variable, parameter and join point ids are unique -/
+def Decl.uniqueIds (d : Decl) : Bool :=
+  (UniqueIds.checkDecl d).run' {}
+
+namespace NormalizeIds
+
+abbrev M := ReaderT IndexRenaming Id
+
+def normIndex (x : Index) : M Index := fun m =>
+  match m.find? x with
+  | some y => y
+  | none   => x
+
+def normVar (x : VarId) : M VarId :=
+  VarId.mk <$> normIndex x.idx
+
+def normJP (x : JoinPointId) : M JoinPointId :=
+  JoinPointId.mk <$> normIndex x.idx
+
+def normArg : Arg → M Arg
+  | Arg.var x => Arg.var <$> normVar x
+  | other     => pure other
+
+def normArgs (as : Array Arg) : M (Array Arg) := fun m =>
+  as.map fun a => normArg a m
+
+def normExpr : Expr → M Expr
+  | Expr.ctor c ys,      m => Expr.ctor c (normArgs ys m)
+  | Expr.reset n x,      m => Expr.reset n (normVar x m)
+  | Expr.reuse x c u ys, m => Expr.reuse (normVar x m) c u (normArgs ys m)
+  | Expr.proj i x,       m => Expr.proj i (normVar x m)
+  | Expr.uproj i x,      m => Expr.uproj i (normVar x m)
+  | Expr.sproj n o x,    m => Expr.sproj n o (normVar x m)
+  | Expr.fap c ys,       m => Expr.fap c (normArgs ys m)
+  | Expr.pap c ys,       m => Expr.pap c (normArgs ys m)
+  | Expr.ap x ys,        m => Expr.ap (normVar x m) (normArgs ys m)
+  | Expr.box t x,        m => Expr.box t (normVar x m)
+  | Expr.unbox x,        m => Expr.unbox (normVar x m)
+  | Expr.isShared x,     m => Expr.isShared (normVar x m)
+  | e@(Expr.lit _),      _ =>  e
+
+abbrev N := ReaderT IndexRenaming (StateM Nat)
+
+@[inline] def withVar {α : Type} (x : VarId) (k : VarId → N α) : N α := fun m => do
+  let n ← getModify (fun n => n + 1)
+  k { idx := n } (m.insert x.idx n)
+
+@[inline] def withJP {α : Type} (x : JoinPointId) (k : JoinPointId → N α) : N α := fun m => do
+  let n ← getModify (fun n => n + 1)
+  k { idx := n } (m.insert x.idx n)
+
+@[inline] def withParams {α : Type} (ps : Array Param) (k : Array Param → N α) : N α := fun m => do
+  let m ← ps.foldlM (init := m) fun m p => do
+    let n ← getModify fun n => n + 1
+    return m.insert p.x.idx n
+  let ps := ps.map fun p => { p with x := normVar p.x m }
+  k ps m
+
+instance : MonadLift M N :=
+  ⟨fun x m => return x m⟩
+
+partial def normFnBody : FnBody → N FnBody
+  | FnBody.vdecl x t v b    => do let v ← normExpr v; withVar x fun x => return FnBody.vdecl x t v (← normFnBody b)
+  | FnBody.jdecl j ys v b   => do
+    let (ys, v) ← withParams ys fun ys => do let v ← normFnBody v; pure (ys, v)
+    withJP j fun j => return FnBody.jdecl j ys v (← normFnBody b)
+  | FnBody.set x i y b      => return FnBody.set (← normVar x) i (← normArg y) (← normFnBody b)
+  | FnBody.uset x i y b     => return FnBody.uset (← normVar x) i (← normVar y) (← normFnBody b)
+  | FnBody.sset x i o y t b => return FnBody.sset (← normVar x) i o (← normVar y) t (← normFnBody b)
+  | FnBody.setTag x i b     => return FnBody.setTag (← normVar x) i (← normFnBody b)
+  | FnBody.inc x n c p b    => return FnBody.inc (← normVar x) n c p (← normFnBody b)
+  | FnBody.dec x n c p b    => return FnBody.dec (← normVar x) n c p (← normFnBody b)
+  | FnBody.del x b          => return FnBody.del (← normVar x) (← normFnBody b)
+  | FnBody.mdata d b        => return FnBody.mdata d (← normFnBody b)
+  | FnBody.case tid x xType alts => do
+    let x ← normVar x
+    let alts ← alts.mapM fun alt => alt.mmodifyBody normFnBody
+    return FnBody.case tid x xType alts
+  | FnBody.jmp j ys        => return FnBody.jmp (← normJP j) (← normArgs ys)
+  | FnBody.ret x           => return FnBody.ret (← normArg x)
+  | FnBody.unreachable     => pure FnBody.unreachable
+
+def normDecl (d : Decl) : N Decl :=
+  match d with
+  | Decl.fdecl (xs := xs) (body := b) .. => withParams xs fun _ => return d.updateBody! (← normFnBody b)
+  | other => pure other
+
+end NormalizeIds
+
+/-- Create a declaration equivalent to `d` s.t. `d.normalizeIds.uniqueIds == true` -/
+def Decl.normalizeIds (d : Decl) : Decl :=
+  (NormalizeIds.normDecl d {}).run' 1
+
+/-! Apply a function `f : VarId → VarId` to variable occurrences.
+   The following functions assume the IR code does not have variable shadowing. -/
+namespace MapVars
+
+@[inline] def mapArg (f : VarId → VarId) : Arg → Arg
+  | Arg.var x => Arg.var (f x)
+  | a         => a
+
+def mapArgs (f : VarId → VarId) (as : Array Arg) : Array Arg :=
+  as.map (mapArg f)
+
+def mapExpr (f : VarId → VarId) : Expr → Expr
+  | Expr.ctor c ys      => Expr.ctor c (mapArgs f ys)
+  | Expr.reset n x      => Expr.reset n (f x)
+  | Expr.reuse x c u ys => Expr.reuse (f x) c u (mapArgs f ys)
+  | Expr.proj i x       => Expr.proj i (f x)
+  | Expr.uproj i x      => Expr.uproj i (f x)
+  | Expr.sproj n o x    => Expr.sproj n o (f x)
+  | Expr.fap c ys       => Expr.fap c (mapArgs f ys)
+  | Expr.pap c ys       => Expr.pap c (mapArgs f ys)
+  | Expr.ap x ys        => Expr.ap (f x) (mapArgs f ys)
+  | Expr.box t x        => Expr.box t (f x)
+  | Expr.unbox x        => Expr.unbox (f x)
+  | Expr.isShared x     => Expr.isShared (f x)
+  | e@(Expr.lit _)      =>  e
+
+partial def mapFnBody (f : VarId → VarId) : FnBody → FnBody
+  | FnBody.vdecl x t v b         => FnBody.vdecl x t (mapExpr f v) (mapFnBody f b)
+  | FnBody.jdecl j ys v b        => FnBody.jdecl j ys (mapFnBody f v) (mapFnBody f b)
+  | FnBody.set x i y b           => FnBody.set (f x) i (mapArg f y) (mapFnBody f b)
+  | FnBody.setTag x i b          => FnBody.setTag (f x) i (mapFnBody f b)
+  | FnBody.uset x i y b          => FnBody.uset (f x) i (f y) (mapFnBody f b)
+  | FnBody.sset x i o y t b      => FnBody.sset (f x) i o (f y) t (mapFnBody f b)
+  | FnBody.inc x n c p b         => FnBody.inc (f x) n c p (mapFnBody f b)
+  | FnBody.dec x n c p b         => FnBody.dec (f x) n c p (mapFnBody f b)
+  | FnBody.del x b               => FnBody.del (f x) (mapFnBody f b)
+  | FnBody.mdata d b             => FnBody.mdata d (mapFnBody f b)
+  | FnBody.case tid x xType alts => FnBody.case tid (f x) xType (alts.map fun alt => alt.modifyBody (mapFnBody f))
+  | FnBody.jmp j ys              => FnBody.jmp j (mapArgs f ys)
+  | FnBody.ret x                 => FnBody.ret (mapArg f x)
+  | FnBody.unreachable           => FnBody.unreachable
+
+end MapVars
+
+@[inline] def FnBody.mapVars (f : VarId → VarId) (b : FnBody) : FnBody :=
+  MapVars.mapFnBody f b
+
+/-- Replace `x` with `y` in `b`. This function assumes `b` does not shadow `x` -/
+def FnBody.replaceVar (x y : VarId) (b : FnBody) : FnBody :=
+  b.mapVars fun z => if x == z then y else z
+
+end Lean.IR

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/PushProj.lean

@@ -0,0 +1,57 @@
+/-
+Copyright (c) 2019 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Compiler.IR.Basic
+import Lean.Compiler.IR.FreeVars
+import Lean.Compiler.IR.NormIds
+
+namespace Lean.IR
+
+partial def pushProjs (bs : Array FnBody) (alts : Array Alt) (altsF : Array IndexSet) (ctx : Array FnBody) (ctxF : IndexSet) : Array FnBody × Array Alt :=
+  if bs.isEmpty then (ctx.reverse, alts)
+  else
+    let b    := bs.back!
+    let bs   := bs.pop
+    let done (_ : Unit) := (bs.push b ++ ctx.reverse, alts)
+    let skip (_ : Unit) := pushProjs bs alts altsF (ctx.push b) (b.collectFreeIndices ctxF)
+    let push (x : VarId) :=
+        if !ctxF.contains x.idx then
+          let alts := alts.mapIdx fun i alt => alt.modifyBody fun b' =>
+             if altsF[i]!.contains x.idx then b.setBody b'
+             else b'
+          let altsF  := altsF.map fun s => if s.contains x.idx then b.collectFreeIndices s else s
+          pushProjs bs alts altsF ctx ctxF
+        else
+          skip ()
+    match b with
+    | FnBody.vdecl x _ v _ =>
+      match v with
+      | Expr.proj _ _      => push x
+      | Expr.uproj _ _     => push x
+      | Expr.sproj _ _ _   => push x
+      | Expr.isShared _    => skip ()
+      | _                  => done ()
+    | _ => done ()
+
+partial def FnBody.pushProj (b : FnBody) : FnBody :=
+  let (bs, term) := b.flatten
+  let bs         := modifyJPs bs pushProj
+  match term with
+  | .case tid x xType alts =>
+    let altsF      := alts.map fun alt => alt.body.freeIndices
+    let (bs, alts) := pushProjs bs alts altsF #[] (mkIndexSet x.idx)
+    let alts       := alts.map fun alt => alt.modifyBody pushProj
+    let term       := FnBody.case tid x xType alts
+    reshape bs term
+  | _     => reshape bs term
+
+/-- Push projections inside `case` branches. -/
+def Decl.pushProj (d : Decl) : Decl :=
+  match d with
+  | .fdecl (body := b) .. => d.updateBody! b.pushProj |>.normalizeIds
+  | other => other
+
+end Lean.IR

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/RC.lean

@@ -0,0 +1,285 @@
+/-
+Copyright (c) 2019 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Runtime
+import Lean.Compiler.IR.CompilerM
+import Lean.Compiler.IR.LiveVars
+
+namespace Lean.IR.ExplicitRC
+/-!
+Insert explicit RC instructions. So, it assumes the input code does not contain `inc` nor `dec` instructions.
+This transformation is applied before lower level optimizations
+that introduce the instructions `release` and `set`
+-/
+
+structure VarInfo where
+  ref        : Bool := true  -- true if the variable may be a reference (aka pointer) at runtime
+  persistent : Bool := false -- true if the variable is statically known to be marked a Persistent at runtime
+  consume    : Bool := false -- true if the variable RC must be "consumed"
+  deriving Inhabited
+
+abbrev VarMap := RBMap VarId VarInfo (fun x y => compare x.idx y.idx)
+
+structure Context where
+  env            : Environment
+  decls          : Array Decl
+  varMap         : VarMap := {}
+  jpLiveVarMap   : JPLiveVarMap := {} -- map: join point => live variables
+  localCtx       : LocalContext := {} -- we use it to store the join point declarations
+
+def getDecl (ctx : Context) (fid : FunId) : Decl :=
+  match findEnvDecl' ctx.env fid ctx.decls with
+  | some decl => decl
+  | none      => unreachable!
+
+def getVarInfo (ctx : Context) (x : VarId) : VarInfo :=
+  match ctx.varMap.find? x with
+  | some info => info
+  | none      => unreachable!
+
+def getJPParams (ctx : Context) (j : JoinPointId) : Array Param :=
+  match ctx.localCtx.getJPParams j with
+  | some ps => ps
+  | none    => unreachable!
+
+def getJPLiveVars (ctx : Context) (j : JoinPointId) : LiveVarSet :=
+  match ctx.jpLiveVarMap.find? j with
+  | some s => s
+  | none   => {}
+
+def mustConsume (ctx : Context) (x : VarId) : Bool :=
+  let info := getVarInfo ctx x
+  info.ref && info.consume
+
+@[inline] def addInc (ctx : Context) (x : VarId) (b : FnBody) (n := 1) : FnBody :=
+  let info := getVarInfo ctx x
+  if n == 0 then b else FnBody.inc x n true info.persistent b
+
+@[inline] def addDec (ctx : Context) (x : VarId) (b : FnBody) : FnBody :=
+  let info := getVarInfo ctx x
+  FnBody.dec x 1 true info.persistent b
+
+private def updateRefUsingCtorInfo (ctx : Context) (x : VarId) (c : CtorInfo) : Context :=
+  if c.isRef then
+    ctx
+  else
+    let m := ctx.varMap
+    { ctx with
+      varMap := match m.find? x with
+      | some info => m.insert x { info with ref := false } -- I really want a Lenses library + notation
+      | none      => m }
+
+private def addDecForAlt (ctx : Context) (caseLiveVars altLiveVars : LiveVarSet) (b : FnBody) : FnBody :=
+  caseLiveVars.fold (init := b) fun b x =>
+    if !altLiveVars.contains x && mustConsume ctx x then addDec ctx x b else b
+
+/-- `isFirstOcc xs x i = true` if `xs[i]` is the first occurrence of `xs[i]` in `xs` -/
+private def isFirstOcc (xs : Array Arg) (i : Nat) : Bool :=
+  let x := xs[i]!
+  i.all fun j _ => xs[j]! != x
+
+/-- Return true if `x` also occurs in `ys` in a position that is not consumed.
+   That is, it is also passed as a borrow reference. -/
+private def isBorrowParamAux (x : VarId) (ys : Array Arg) (consumeParamPred : Nat → Bool) : Bool :=
+  ys.size.any fun i _ =>
+    let y := ys[i]
+    match y with
+    | Arg.irrelevant => false
+    | Arg.var y      => x == y && !consumeParamPred i
+
+private def isBorrowParam (x : VarId) (ys : Array Arg) (ps : Array Param) : Bool :=
+  isBorrowParamAux x ys fun i => ! ps[i]!.borrow
+
+/--
+Return `n`, the number of times `x` is consumed.
+- `ys` is a sequence of instruction parameters where we search for `x`.
+- `consumeParamPred i = true` if parameter `i` is consumed.
+-/
+private def getNumConsumptions (x : VarId) (ys : Array Arg) (consumeParamPred : Nat → Bool) : Nat :=
+  ys.size.fold (init := 0) fun i _ n =>
+    let y := ys[i]
+    match y with
+    | Arg.irrelevant => n
+    | Arg.var y      => if x == y && consumeParamPred i then n+1 else n
+
+private def addIncBeforeAux (ctx : Context) (xs : Array Arg) (consumeParamPred : Nat → Bool) (b : FnBody) (liveVarsAfter : LiveVarSet) : FnBody :=
+  xs.size.fold (init := b) fun i _ b =>
+    let x := xs[i]
+    match x with
+    | Arg.irrelevant => b
+    | Arg.var x =>
+      let info := getVarInfo ctx x
+      if !info.ref || !isFirstOcc xs i then b
+      else
+        let numConsuptions := getNumConsumptions x xs consumeParamPred -- number of times the argument is
+        let numIncs :=
+          if !info.consume ||                     -- `x` is not a variable that must be consumed by the current procedure
+             liveVarsAfter.contains x ||          -- `x` is live after executing instruction
+             isBorrowParamAux x xs consumeParamPred  -- `x` is used in a position that is passed as a borrow reference
+          then numConsuptions
+          else numConsuptions - 1
+        addInc ctx x b numIncs
+
+private def addIncBefore (ctx : Context) (xs : Array Arg) (ps : Array Param) (b : FnBody) (liveVarsAfter : LiveVarSet) : FnBody :=
+  addIncBeforeAux ctx xs (fun i => ! ps[i]!.borrow) b liveVarsAfter
+
+/-- See `addIncBeforeAux`/`addIncBefore` for the procedure that inserts `inc` operations before an application.  -/
+private def addDecAfterFullApp (ctx : Context) (xs : Array Arg) (ps : Array Param) (b : FnBody) (bLiveVars : LiveVarSet) : FnBody :=
+xs.size.fold (init := b) fun i _ b =>
+  match xs[i] with
+  | Arg.irrelevant => b
+  | Arg.var x      =>
+    /- We must add a `dec` if `x` must be consumed, it is alive after the application,
+       and it has been borrowed by the application.
+       Remark: `x` may occur multiple times in the application (e.g., `f x y x`).
+       This is why we check whether it is the first occurrence. -/
+    if mustConsume ctx x && isFirstOcc xs i && isBorrowParam x xs ps && !bLiveVars.contains x then
+      addDec ctx x b
+    else b
+
+private def addIncBeforeConsumeAll (ctx : Context) (xs : Array Arg) (b : FnBody) (liveVarsAfter : LiveVarSet) : FnBody :=
+  addIncBeforeAux ctx xs (fun _ => true) b liveVarsAfter
+
+/-- Add `dec` instructions for parameters that are references, are not alive in `b`, and are not borrow.
+   That is, we must make sure these parameters are consumed. -/
+private def addDecForDeadParams (ctx : Context) (ps : Array Param) (b : FnBody) (bLiveVars : LiveVarSet) : FnBody :=
+  ps.foldl (init := b) fun b p =>
+    if !p.borrow && p.ty.isObj && !bLiveVars.contains p.x then addDec ctx p.x b else b
+
+private def isPersistent : Expr → Bool
+  | Expr.fap _ xs => xs.isEmpty -- all global constants are persistent objects
+  | _             => false
+
+/-- We do not need to consume the projection of a variable that is not consumed -/
+private def consumeExpr (m : VarMap) : Expr → Bool
+  | Expr.proj _ x   => match m.find? x with
+    | some info => info.consume
+    | none      => true
+  | _     => true
+
+/-- Return true iff `v` at runtime is a scalar value stored in a tagged pointer.
+   We do not need RC operations for this kind of value. -/
+private def isScalarBoxedInTaggedPtr (v : Expr) : Bool :=
+  match v with
+  | Expr.ctor c _           => c.size == 0 && c.ssize == 0 && c.usize == 0
+  | Expr.lit (LitVal.num n) => n ≤ maxSmallNat
+  | _ => false
+
+private def updateVarInfo (ctx : Context) (x : VarId) (t : IRType) (v : Expr) : Context :=
+  { ctx with
+    varMap := ctx.varMap.insert x {
+        ref := t.isObj && !isScalarBoxedInTaggedPtr v,
+        persistent := isPersistent v,
+        consume := consumeExpr ctx.varMap v
+    }
+  }
+
+private def addDecIfNeeded (ctx : Context) (x : VarId) (b : FnBody) (bLiveVars : LiveVarSet) : FnBody :=
+  if mustConsume ctx x && !bLiveVars.contains x then addDec ctx x b else b
+
+private def processVDecl (ctx : Context) (z : VarId) (t : IRType) (v : Expr) (b : FnBody) (bLiveVars : LiveVarSet) : FnBody × LiveVarSet :=
+  let b := match v with
+    | (Expr.ctor _ ys)       => addIncBeforeConsumeAll ctx ys (FnBody.vdecl z t v b) bLiveVars
+    | (Expr.reuse _ _ _ ys)  => addIncBeforeConsumeAll ctx ys (FnBody.vdecl z t v b) bLiveVars
+    | (Expr.proj _ x)        =>
+      let b := addDecIfNeeded ctx x b bLiveVars
+      let b := if (getVarInfo ctx x).consume then addInc ctx z b else b
+      (FnBody.vdecl z t v b)
+    | (Expr.uproj _ x)       => FnBody.vdecl z t v (addDecIfNeeded ctx x b bLiveVars)
+    | (Expr.sproj _ _ x)     => FnBody.vdecl z t v (addDecIfNeeded ctx x b bLiveVars)
+    | (Expr.fap f ys)        =>
+      let ps := (getDecl ctx f).params
+      let b  := addDecAfterFullApp ctx ys ps b bLiveVars
+      let b  := FnBody.vdecl z t v b
+      addIncBefore ctx ys ps b bLiveVars
+    | (Expr.pap _ ys)        => addIncBeforeConsumeAll ctx ys (FnBody.vdecl z t v b) bLiveVars
+    | (Expr.ap x ys)         =>
+      let ysx := ys.push (Arg.var x) -- TODO: avoid temporary array allocation
+      addIncBeforeConsumeAll ctx ysx (FnBody.vdecl z t v b) bLiveVars
+    | (Expr.unbox x)         => FnBody.vdecl z t v (addDecIfNeeded ctx x b bLiveVars)
+    | _                      => FnBody.vdecl z t v b  -- Expr.reset, Expr.box, Expr.lit are handled here
+  let liveVars := updateLiveVars v bLiveVars
+  let liveVars := liveVars.erase z
+  (b, liveVars)
+
+def updateVarInfoWithParams (ctx : Context) (ps : Array Param) : Context :=
+  let m := ps.foldl (init := ctx.varMap) fun m p =>
+    m.insert p.x { ref := p.ty.isObj, consume := !p.borrow }
+  { ctx with varMap := m }
+
+partial def visitFnBody : FnBody → Context → (FnBody × LiveVarSet)
+  | FnBody.vdecl x t v b,      ctx =>
+    let ctx := updateVarInfo ctx x t v
+    let (b, bLiveVars) := visitFnBody b ctx
+    processVDecl ctx x t v b bLiveVars
+  | FnBody.jdecl j xs v b,     ctx =>
+    let ctxAtV := updateVarInfoWithParams ctx xs
+    let (v, vLiveVars) := visitFnBody v ctxAtV
+    let v   := addDecForDeadParams ctxAtV xs v vLiveVars
+    let ctx := { ctx with
+      localCtx     := ctx.localCtx.addJP j xs v
+      jpLiveVarMap := updateJPLiveVarMap j xs v ctx.jpLiveVarMap
+    }
+    let (b, bLiveVars) := visitFnBody b ctx
+    (FnBody.jdecl j xs v b, bLiveVars)
+  | FnBody.uset x i y b,       ctx =>
+    let (b, s) := visitFnBody b ctx
+    -- We don't need to insert `y` since we only need to track live variables that are references at runtime
+    let s      := s.insert x
+    (FnBody.uset x i y b, s)
+  | FnBody.sset x i o y t b,   ctx =>
+    let (b, s) := visitFnBody b ctx
+    -- We don't need to insert `y` since we only need to track live variables that are references at runtime
+    let s      := s.insert x
+    (FnBody.sset x i o y t b, s)
+  | FnBody.mdata m b,          ctx =>
+    let (b, s) := visitFnBody b ctx
+    (FnBody.mdata m b, s)
+  | b@(FnBody.case tid x xType alts), ctx =>
+    let caseLiveVars := collectLiveVars b ctx.jpLiveVarMap
+    let alts         := alts.map fun alt => match alt with
+      | Alt.ctor c b  =>
+        let ctx              := updateRefUsingCtorInfo ctx x c
+        let (b, altLiveVars) := visitFnBody b ctx
+        let b                := addDecForAlt ctx caseLiveVars altLiveVars b
+        Alt.ctor c b
+      | Alt.default b =>
+        let (b, altLiveVars) := visitFnBody b ctx
+        let b                := addDecForAlt ctx caseLiveVars altLiveVars b
+        Alt.default b
+    (FnBody.case tid x xType alts, caseLiveVars)
+  | b@(FnBody.ret x), ctx =>
+    match x with
+    | Arg.var x =>
+      let info := getVarInfo ctx x
+      if info.ref && !info.consume then (addInc ctx x b, mkLiveVarSet x) else (b, mkLiveVarSet x)
+    | _         => (b, {})
+  | b@(FnBody.jmp j xs), ctx =>
+    let jLiveVars := getJPLiveVars ctx j
+    let ps        := getJPParams ctx j
+    let b         := addIncBefore ctx xs ps b jLiveVars
+    let bLiveVars := collectLiveVars b ctx.jpLiveVarMap
+    (b, bLiveVars)
+  | FnBody.unreachable, _ => (FnBody.unreachable, {})
+  | other, _ => (other, {}) -- unreachable if well-formed
+
+partial def visitDecl (env : Environment) (decls : Array Decl) (d : Decl) : Decl :=
+  match d with
+  | .fdecl (xs := xs) (body := b) .. =>
+    let ctx : Context  := { env := env, decls := decls }
+    let ctx := updateVarInfoWithParams ctx xs
+    let (b, bLiveVars) := visitFnBody b ctx
+    let b := addDecForDeadParams ctx xs b bLiveVars
+    d.updateBody! b
+  | other => other
+
+end ExplicitRC
+
+def explicitRC (decls : Array Decl) : CompilerM (Array Decl) := do
+  let env ← getEnv
+  return decls.map (ExplicitRC.visitDecl env decls)
+
+end Lean.IR

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/ResetReuse.lean

@@ -0,0 +1,246 @@
+/-
+Copyright (c) 2019 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Compiler.IR.Basic
+import Lean.Compiler.IR.LiveVars
+import Lean.Compiler.IR.Format
+
+namespace Lean.IR.ResetReuse
+/-!
+Remark: the insertResetReuse transformation is applied before we have
+inserted `inc/dec` instructions, and performed lower level optimizations
+that introduce the instructions `release` and `set`.
+-/
+
+/-!
+Remark: the functions `S`, `D` and `R` defined here implement the
+corresponding functions in the paper "Counting Immutable Beans"
+
+Here are the main differences:
+- We use the State monad to manage the generation of fresh variable names.
+- Support for join points, and `uset` and `sset` instructions for unboxed data.
+- `D` uses the auxiliary function `Dmain`.
+- `Dmain` returns a pair `(b, found)` to avoid quadratic behavior when checking
+  the last occurrence of the variable `x`.
+- Because we have join points in the actual implementation, a variable may be live even if it
+  does not occur in a function body. See example at `livevars.lean`.
+-/
+
+private def mayReuse (c₁ c₂ : CtorInfo) (relaxedReuse : Bool) : Bool :=
+  c₁.size == c₂.size && c₁.usize == c₂.usize && c₁.ssize == c₂.ssize &&
+  /- The following condition is a heuristic.
+     If `relaxedReuse := false`, then we don't want to reuse cells from
+     different constructors even when they are compatible
+     because it produces counterintuitive behavior. -/
+  (relaxedReuse || c₁.name.getPrefix == c₂.name.getPrefix)
+
+/--
+Replace `ctor` applications with `reuse` applications if compatible.
+`w` contains the "memory cell" being reused.
+-/
+private partial def S (w : VarId) (c : CtorInfo) (relaxedReuse : Bool) (b : FnBody) : FnBody :=
+  go b
+where
+  go : FnBody → FnBody
+  | .vdecl x t v@(.ctor c' ys) b   =>
+    if mayReuse c c' relaxedReuse then
+      let updtCidx := c.cidx != c'.cidx
+      .vdecl x t (.reuse w c' updtCidx ys) b
+    else
+      .vdecl x t v (go b)
+  | .jdecl j ys v b   =>
+    let v' := go v
+    if v == v' then
+      .jdecl j ys v (go b)
+    else
+      .jdecl j ys v' b
+  | .case tid x xType alts =>
+    .case tid x xType <| alts.map fun alt => alt.modifyBody go
+  | b =>
+    if b.isTerminal then
+      b
+    else
+      let (instr, b) := b.split
+      instr.setBody (go b)
+
+structure Context where
+  lctx      : LocalContext := {}
+  /--
+  Contains all variables in `cases` statements in the current path
+  and variables that are already in `reset` statements when we
+  invoke `R`.
+
+  We use this information to prevent double-reset in code such as
+  ```
+  case x_i : obj of
+  Prod.mk →
+    case x_i : obj of
+    Prod.mk →
+    ...
+  ```
+
+  A variable can already be in a `reset` statement when we
+  invoke `R` because we execute it with and without `relaxedReuse`.
+  -/
+  alreadyFound : PHashSet VarId := {}
+  /--
+  If `relaxedReuse := true`, then allow memory cells from different
+  constructors to be reused. For example, we can reuse a `PSigma.mk`
+  to allocate a `Prod.mk`. To avoid counterintuitive behavior,
+  we first try `relaxedReuse := false`, and then `relaxedReuse := true`.
+  -/
+  relaxedReuse : Bool := false
+
+/-- We use `Context` to track join points in scope. -/
+abbrev M := ReaderT Context (StateT Index Id)
+
+private def mkFresh : M VarId := do
+  let idx ← getModify fun n => n + 1
+  return { idx := idx }
+
+/--
+Helper function for applying `S`. We only introduce a `reset` if we managed
+to replace a `ctor` with `reuse` in `b`.
+-/
+private def tryS (x : VarId) (c : CtorInfo) (b : FnBody) : M FnBody := do
+  let w ← mkFresh
+  let b' := S w c (← read).relaxedReuse b
+  if b == b' then
+    return b
+  else
+    return .vdecl w IRType.object (.reset c.size x) b'
+
+private def Dfinalize (x : VarId) (c : CtorInfo) : FnBody × Bool → M FnBody
+  | (b, true)  => return b
+  | (b, false) => tryS x c b
+
+private def argsContainsVar (ys : Array Arg) (x : VarId) : Bool :=
+  ys.any fun arg => match arg with
+    | .var y => x == y
+    | _      => false
+
+private def isCtorUsing (b : FnBody) (x : VarId) : Bool :=
+  match b with
+  | .vdecl _ _ (.ctor _ ys) _ => argsContainsVar ys x
+  | _ => false
+
+/--
+Given `Dmain b`, the resulting pair `(new_b, flag)` contains the new body `new_b`,
+and `flag == true` if `x` is live in `b`.
+
+Note that, in the function `D` defined in the paper, for each `let x := e; F`,
+`D` checks whether `x` is live in `F` or not. This is great for clarity but it
+is expensive: `O(n^2)` where `n` is the size of the function body. -/
+private partial def Dmain (x : VarId) (c : CtorInfo) (e : FnBody) : M (FnBody × Bool) := do
+  match e with
+  | .case tid y yType alts =>
+    if e.hasLiveVar (← read).lctx x then
+      /- If `x` is live in `e`, we recursively process each branch. -/
+      let alts ← alts.mapM fun alt => alt.mmodifyBody fun b => Dmain x c b >>= Dfinalize x c
+      return (.case tid y yType alts, true)
+    else
+      return (e, false)
+  | .jdecl j ys v b =>
+    let (b, found) ← withReader (fun ctx => { ctx with lctx := ctx.lctx.addJP j ys v }) (Dmain x c b)
+    let (v, _ /- found' -/) ← Dmain x c v
+    /- If `found' == true`, then `Dmain b` must also have returned `(b, true)` since
+       we assume the IR does not have dead join points. So, if `x` is live in `j` (i.e., `v`),
+       then it must also live in `b` since `j` is reachable from `b` with a `jmp`.
+       On the other hand, `x` may be live in `b` but dead in `j` (i.e., `v`). -/
+    return (.jdecl j ys v b, found)
+  | e =>
+    if e.isTerminal then
+      return (e, e.hasLiveVar (← read).lctx x)
+    else do
+      let (instr, b) := e.split
+      if isCtorUsing instr x then
+        /- If the scrutinee `x` (the one that is providing memory) is being
+           stored in a constructor, then reuse will probably not be able to reuse memory at runtime.
+           It may work only if the new cell is consumed, but we ignore this case. -/
+        return (e, true)
+      else
+        let (b, found) ← Dmain x c b
+        /- Remark: it is fine to use `hasFreeVar` instead of `hasLiveVar`
+           since `instr` is not a `FnBody.jmp` (it is not a terminal) nor
+           it is a `FnBody.jdecl`. -/
+        if found || !instr.hasFreeVar x then
+          return (instr.setBody b, found)
+        else
+          let b ← tryS x c b
+          return (instr.setBody b, true)
+
+private def D (x : VarId) (c : CtorInfo) (b : FnBody) : M FnBody :=
+  Dmain x c b >>= Dfinalize x c
+
+partial def R (e : FnBody) : M FnBody := do
+  match e with
+  | .case tid x xType alts =>
+    let alreadyFound := (← read).alreadyFound.contains x
+    withReader (fun ctx => { ctx with alreadyFound := ctx.alreadyFound.insert x }) do
+      let alts ← alts.mapM fun alt => do
+        let alt ← alt.mmodifyBody R
+        match alt with
+        | .ctor c b =>
+          if c.isScalar || alreadyFound then
+            -- If `alreadyFound`, then we don't try to reuse memory cell to avoid
+            -- double reset.
+            return alt
+          else
+            .ctor c <$> D x c b
+        | .default _ => return alt
+      return .case tid x xType alts
+  | .jdecl j ys v b =>
+    let v ← R v
+    let b ← withReader (fun ctx => { ctx with lctx := ctx.lctx.addJP j ys v }) (R b)
+    return .jdecl j ys v b
+  | e =>
+    if e.isTerminal then
+      return e
+    else
+      let (instr, b) := e.split
+      let b ← R b
+      return instr.setBody b
+
+abbrev N := StateT (PHashSet VarId) Id
+
+partial def collectResets (e : FnBody) : N Unit := do
+  match e with
+  | .case _ _ _ alts => alts.forM fun alt => collectResets alt.body
+  | .jdecl _ _ v b => collectResets v; collectResets b
+  | .vdecl _ _ (.reset _ x) b => modify fun s => s.insert x; collectResets b
+  | e => unless e.isTerminal do
+    let (_, b) := e.split
+    collectResets b
+
+end ResetReuse
+open ResetReuse
+
+
+def Decl.insertResetReuseCore (d : Decl) (relaxedReuse : Bool) : Decl :=
+  match d with
+  | .fdecl (body := b) .. =>
+    let nextIndex := d.maxIndex + 1
+    -- First time we execute `insertResetReuseCore`, `relaxedReuse := false`.
+    let alreadyFound : PHashSet VarId := if relaxedReuse then (collectResets b *> get).run' {} else {}
+    let bNew := R b { relaxedReuse, alreadyFound } |>.run' nextIndex
+    d.updateBody! bNew
+  | other => other
+
+def Decl.insertResetReuse (d : Decl) : Decl :=
+  /-
+  We execute the reset/reuse algorithm twice. The first time, we only reuse memory cells
+  between identical constructor memory cells. That is, we do not reuse a `PSigma.mk` memory cell
+  when allocating a `Prod.mk` memory cell, even though they have the same layout. Recall
+  that the reset/reuse placement algorithm is a heuristic, and the first pass prevents reuses
+  that are unlikely to be useful at runtime. Then, we run the procedure again,
+  relaxing this restriction. If there are still opportunities for reuse, we will take advantage of them.
+
+  The second pass addresses issue #4089.
+  -/
+  d.insertResetReuseCore (relaxedReuse := false)
+  |>.insertResetReuseCore (relaxedReuse := true)
+
+end Lean.IR

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/SimpCase.lean

@@ -0,0 +1,78 @@
+/-
+Copyright (c) 2019 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Compiler.IR.Basic
+import Lean.Compiler.IR.Format
+
+namespace Lean.IR
+
+def ensureHasDefault (alts : Array Alt) : Array Alt :=
+  if alts.any Alt.isDefault then alts
+  else if alts.size < 2 then alts
+  else
+    let last := alts.back!
+    let alts := alts.pop
+    alts.push (Alt.default last.body)
+
+private def getOccsOf (alts : Array Alt) (i : Nat) : Nat := Id.run do
+  let aBody := alts[i]!.body
+  let mut n := 1
+  for h : j in [i+1:alts.size] do
+    if alts[j].body == aBody then
+      n := n+1
+  return n
+
+private def maxOccs (alts : Array Alt) : Alt × Nat := Id.run do
+  let mut maxAlt := alts[0]!
+  let mut max    := getOccsOf alts 0
+  for h : i in [1:alts.size] do
+    let curr := getOccsOf alts i
+    if curr > max then
+       maxAlt := alts[i]
+       max    := curr
+  return (maxAlt, max)
+
+private def addDefault (alts : Array Alt) : Array Alt :=
+  if alts.size <= 1 || alts.any Alt.isDefault then alts
+  else
+    let (max, noccs) := maxOccs alts
+    if noccs == 1 then alts
+    else
+      let alts := alts.filter fun alt => alt.body != max.body
+      alts.push (Alt.default max.body)
+
+private def filterUnreachable (alts : Array Alt) : Array Alt :=
+  alts.filter fun alt => alt.body != FnBody.unreachable
+
+private def mkSimpCase (tid : Name) (x : VarId) (xType : IRType) (alts : Array Alt) : FnBody :=
+  let alts := filterUnreachable alts
+  let alts := addDefault alts;
+  if alts.size == 0 then
+    FnBody.unreachable
+  else if _ : alts.size = 1 then
+    alts[0].body
+  else
+    FnBody.case tid x xType alts
+
+partial def FnBody.simpCase (b : FnBody) : FnBody :=
+  let (bs, term) := b.flatten;
+  let bs         := modifyJPs bs simpCase;
+  match term with
+  | FnBody.case tid x xType alts =>
+    let alts := alts.map fun alt => alt.modifyBody simpCase;
+    reshape bs (mkSimpCase tid x xType alts)
+  | _     => reshape bs term
+
+/-- Simplify `case`
+  - Remove unreachable branches.
+  - Remove `case` if there is only one branch.
+  - Merge most common branches using `Alt.default`. -/
+def Decl.simpCase (d : Decl) : Decl :=
+  match d with
+  | .fdecl (body := b) .. => d.updateBody! b.simpCase
+  | other => other
+
+end Lean.IR

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/Sorry.lean

@@ -0,0 +1,80 @@
+/-
+Copyright (c) 2021 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Compiler.IR.CompilerM
+
+namespace Lean.IR
+namespace Sorry
+
+structure State where
+  localSorryMap : NameMap Name := {}
+  modified : Bool := false
+
+abbrev M := StateT State CompilerM
+
+def visitExpr : Expr → ExceptT Name M Unit
+  | Expr.fap f _  => getSorryDepFor? f
+  | Expr.pap f _  => getSorryDepFor? f
+  | _             => return ()
+where
+  getSorryDepFor? (f : Name) : ExceptT Name M Unit := do
+    let found (g : Name) :=
+      if g == ``sorryAx then
+        throw f
+      else
+        throw g
+    if f == ``sorryAx then
+      throw f
+    else if let some g := (← get).localSorryMap.find? f then
+      found g
+    else match (← findDecl f) with
+      | some (.fdecl (info := { sorryDep? := some g, .. }) ..) => found g
+      | _ => return ()
+
+partial def visitFndBody (b : FnBody) : ExceptT Name M Unit := do
+  match b with
+  | .vdecl _ _ v b   => visitExpr v; visitFndBody b
+  | .jdecl _ _ v b   => visitFndBody v; visitFndBody b
+  | .case _ _ _ alts => alts.forM fun alt => visitFndBody alt.body
+  | _ =>
+    unless b.isTerminal do
+      let (_, b) := b.split
+      visitFndBody b
+
+def visitDecl (d : Decl) : M Unit := do
+  match d with
+  | .fdecl (f := f) (body := b) .. =>
+    match (← get).localSorryMap.find? f with
+    | some _ => return ()
+    | none =>
+      match (← visitFndBody b |>.run) with
+      | .ok _    => return ()
+      | .error g =>
+        modify fun s => {
+          localSorryMap := s.localSorryMap.insert f g
+          modified      := true
+        }
+  | _ => return ()
+
+partial def collect (decls : Array Decl) : M Unit := do
+  modify fun s => { s with modified := false }
+  decls.forM visitDecl
+  if (← get).modified then
+    collect decls
+
+end Sorry
+
+def updateSorryDep (decls : Array Decl) : CompilerM (Array Decl) := do
+  let (_, s) ← Sorry.collect decls |>.run {}
+  return decls.map fun decl =>
+    match decl with
+    | Decl.fdecl f xs t b _    =>
+      match s.localSorryMap.find? f with
+      | some g => Decl.fdecl f xs t b { sorryDep? := some g }
+      | _ => decl
+    | _ => decl
+
+end Lean.IR

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/ToIR.lean

@@ -0,0 +1,350 @@
+/-
+Copyright (c) 2024 Lean FRO, LLC. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Cameron Zwarich
+-/
+prelude
+import Lean.Compiler.LCNF.Basic
+import Lean.Compiler.LCNF.CompilerM
+import Lean.Compiler.LCNF.PhaseExt
+import Lean.Compiler.IR.Basic
+import Lean.Compiler.IR.CompilerM
+import Lean.Compiler.IR.ToIRType
+import Lean.CoreM
+import Lean.Environment
+
+namespace Lean.IR
+
+open Lean.Compiler (LCNF.Alt LCNF.Arg LCNF.Code LCNF.Decl LCNF.DeclValue LCNF.LCtx LCNF.LetDecl
+                    LCNF.LetValue LCNF.LitValue LCNF.Param LCNF.getMonoDecl?)
+
+namespace ToIR
+
+inductive FVarClassification where
+  | var (id : VarId)
+  | joinPoint (id : JoinPointId)
+  | erased
+
+structure BuilderState where
+  fvars : Std.HashMap FVarId FVarClassification := {}
+  nextId : Nat := 1
+
+abbrev M := StateRefT BuilderState CoreM
+
+def M.run (x : M α) : CoreM α := do
+  x.run' {}
+
+def bindVar (fvarId : FVarId) : M VarId := do
+  modifyGet fun s =>
+    let varId := { idx := s.nextId }
+    ⟨varId, { s with fvars := s.fvars.insertIfNew fvarId (.var varId),
+                     nextId := s.nextId + 1 }⟩
+
+def bindVarToVarId (fvarId : FVarId) (varId : VarId) : M Unit := do
+  modify fun s => { s with fvars := s.fvars.insertIfNew fvarId (.var varId) }
+
+def newVar : M VarId := do
+  modifyGet fun s =>
+    let varId := { idx := s.nextId }
+    ⟨varId, { s with nextId := s.nextId + 1 }⟩
+
+def bindJoinPoint (fvarId : FVarId) : M JoinPointId := do
+  modifyGet fun s =>
+    let joinPointId := { idx := s.nextId }
+    ⟨joinPointId, { s with fvars := s.fvars.insertIfNew fvarId (.joinPoint joinPointId),
+                           nextId := s.nextId + 1 }⟩
+
+def bindErased (fvarId : FVarId) : M Unit := do
+  modify fun s => { s with fvars := s.fvars.insertIfNew fvarId .erased }
+
+def findDecl (n : Name) : M (Option Decl) :=
+  return findEnvDecl (← Lean.getEnv) n
+
+def addDecl (d : Decl) : M Unit :=
+  Lean.modifyEnv fun env => declMapExt.addEntry (env.addExtraName d.name) d
+
+def lowerLitValue (v : LCNF.LitValue) : LitVal :=
+  match v with
+  | .nat n => .num n
+  | .str s => .str s
+  | .uint8 v => .num (UInt8.toNat v)
+  | .uint16 v => .num (UInt16.toNat v)
+  | .uint32 v => .num (UInt32.toNat v)
+  | .uint64 v | .usize v => .num (UInt64.toNat v)
+
+def lowerArg (a : LCNF.Arg) : M Arg := do
+  match a with
+  | .fvar fvarId =>
+    match (← get).fvars[fvarId]? with
+    | some (.var varId) => return .var varId
+    | some .erased => return .irrelevant
+    | some (.joinPoint ..) | none => panic! "unexpected value"
+  | .erased | .type .. => return .irrelevant
+
+inductive TranslatedProj where
+  | expr (e : Expr)
+  | erased
+  deriving Inhabited
+
+def lowerProj (base : VarId) (ctorInfo : CtorInfo) (field : CtorFieldInfo)
+    : TranslatedProj × IRType :=
+  match field with
+  | .object i => ⟨.expr (.proj i base), .object⟩
+  | .usize i => ⟨.expr (.uproj i base), .usize⟩
+  | .scalar _ offset irType => ⟨.expr (.sproj (ctorInfo.size + ctorInfo.usize) offset base), irType⟩
+  | .irrelevant => ⟨.erased, .irrelevant⟩
+
+def lowerParam (p : LCNF.Param) : M Param := do
+  let x ← bindVar p.fvarId
+  let ty ← toIRType p.type
+  return { x, borrow := p.borrow, ty }
+
+mutual
+partial def lowerCode (c : LCNF.Code) : M FnBody := do
+  match c with
+  | .let decl k => lowerLet decl k
+  | .jp decl k =>
+    let joinPoint ← bindJoinPoint decl.fvarId
+    let params ← decl.params.mapM lowerParam
+    let body ← lowerCode decl.value
+    return .jdecl joinPoint params body (← lowerCode k)
+  | .jmp fvarId args =>
+    match (← get).fvars[fvarId]? with
+    | some (.joinPoint joinPointId) =>
+      return .jmp joinPointId (← args.mapM lowerArg)
+    | some (.var ..) | some .erased | none => panic! "unexpected value"
+  | .cases cases =>
+    match (← get).fvars[cases.discr]? with
+    | some (.var varId) =>
+      return .case cases.typeName
+                   varId
+                   (← toIRType cases.resultType)
+                   (← cases.alts.mapM (lowerAlt varId))
+    | some (.joinPoint ..) | some .erased | none => panic! "unexpected value"
+  | .return fvarId =>
+    let arg := match (← get).fvars[fvarId]? with
+    | some (.var varId) => .var varId
+    | some .erased => .irrelevant
+    | some (.joinPoint ..) | none => panic! "unexpected value"
+    return .ret arg
+  | .unreach .. => return .unreachable
+  | .fun .. => panic! "all local functions should be λ-lifted"
+
+partial def lowerLet (decl : LCNF.LetDecl) (k : LCNF.Code) : M FnBody := do
+  -- temporary fix: the old compiler inlines these too much as regular `let`s
+  let rec mkVar (v : VarId) : M FnBody := do
+    bindVarToVarId decl.fvarId v
+    lowerCode k
+  let rec mkExpr (e : Expr) : M FnBody := do
+    let var ← bindVar decl.fvarId
+    let type ← match e with
+    | .ctor .. | .pap .. | .proj .. => pure <| .object
+    | _ => toIRType decl.type
+    return .vdecl var type e (← lowerCode k)
+  let rec mkErased (_ : Unit) : M FnBody := do
+    bindErased decl.fvarId
+    lowerCode k
+  let rec mkPartialApp (e : Expr) (restArgs : Array Arg) : M FnBody := do
+    let var ← bindVar decl.fvarId
+    let tmpVar ← newVar
+    let type ← match e with
+    | .ctor .. | .pap .. | .proj .. => pure <| .object
+    | _ => toIRType decl.type
+    return .vdecl tmpVar .object e (.vdecl var type (.ap tmpVar restArgs) (← lowerCode k))
+  let rec tryIrDecl? (name : Name) (args : Array Arg) : M (Option FnBody) := do
+    if let some decl ← LCNF.getMonoDecl? name then
+      let numArgs := args.size
+      let numParams := decl.params.size
+      if numArgs < numParams then
+        return some (← mkExpr (.pap name args))
+      else if numArgs == numParams then
+        return some (← mkExpr (.fap name args))
+      else
+        let firstArgs := args.extract 0 numParams
+        let restArgs := args.extract numParams numArgs
+        return some (← mkPartialApp (.fap name firstArgs) restArgs)
+    else
+      return none
+
+  match decl.value with
+  | .lit litValue =>
+    mkExpr (.lit (lowerLitValue litValue))
+  | .proj typeName i fvarId =>
+    match (← get).fvars[fvarId]? with
+    | some (.var varId) =>
+      -- TODO: have better pattern matching here
+      let some (.inductInfo { ctors, .. }) := (← Lean.getEnv).find? typeName
+        | panic! "projection of non-inductive type"
+      let ctorName := ctors[0]!
+      let ⟨ctorInfo, fields⟩ ← getCtorInfo ctorName
+      let ⟨result, type⟩ := lowerProj varId ctorInfo fields[i]!
+      match result with
+      | .expr e =>
+        let var ← bindVar decl.fvarId
+        return .vdecl var type e (← lowerCode k)
+      | .erased =>
+        bindErased decl.fvarId
+        lowerCode k
+    | some .erased =>
+      bindErased decl.fvarId
+      lowerCode k
+    | some (.joinPoint ..) | none => panic! "unexpected value"
+  | .const ``Nat.succ _ args =>
+    let irArgs ← args.mapM lowerArg
+    let var ← bindVar decl.fvarId
+    let tmpVar ← newVar
+    let k := (.vdecl var .object (.fap ``Nat.add #[irArgs[0]!, (.var tmpVar)]) (← lowerCode k))
+    return .vdecl tmpVar .object (.lit (.num 1)) k
+  | .const name _ args =>
+    let irArgs ← args.mapM lowerArg
+    if let some code ← tryIrDecl? name irArgs then
+      return code
+    else
+      let env ← Lean.getEnv
+      match env.find? name with
+      | some (.ctorInfo ctorVal) =>
+        if isExtern env name then
+          if let some code ← tryIrDecl? name irArgs then
+            return code
+          else
+            mkExpr (.fap name irArgs)
+        else if let some scalarType ← lowerEnumToScalarType? ctorVal.name then
+          assert! args.isEmpty
+          let var ← bindVar decl.fvarId
+          return .vdecl var scalarType (.lit (.num ctorVal.cidx)) (← lowerCode k)
+        else
+          let ⟨ctorInfo, fields⟩ ← getCtorInfo name
+          let irArgs := irArgs.extract (start := ctorVal.numParams)
+          let objArgs : Array Arg ← do
+            let mut result : Array Arg := #[]
+            for h : i in [:fields.size] do
+              if fields[i] matches .object .. then
+                result := result.push irArgs[i]!
+            pure result
+          let objVar ← bindVar decl.fvarId
+          let rec lowerNonObjectFields (_ : Unit) : M FnBody :=
+            let rec loop (usizeCount : Nat) (i : Nat) : M FnBody := do
+              match irArgs[i]? with
+              | some (.var varId) =>
+                match fields[i]! with
+                | .usize .. =>
+                  let k ← loop (usizeCount + 1) (i + 1)
+                  return .uset objVar (ctorInfo.size + usizeCount) varId k
+                | .scalar _ offset argType =>
+                  let k ← loop usizeCount (i + 1)
+                  return .sset objVar (ctorInfo.size + ctorInfo.usize) offset varId argType k
+                | .object .. | .irrelevant => loop usizeCount (i + 1)
+              | some .irrelevant => loop usizeCount (i + 1)
+              | none => lowerCode k
+            loop 0 0
+          return .vdecl objVar .object (.ctor ctorInfo objArgs) (← lowerNonObjectFields ())
+      | some (.axiomInfo ..) =>
+        if name == ``Quot.lcInv then
+          match irArgs[2]! with
+          | .var varId => mkVar varId
+          | .irrelevant => mkErased ()
+        else if name == ``lcUnreachable then
+          return .unreachable
+        else if let some irDecl ← findDecl name then
+          let numArgs := irArgs.size
+          let numParams := irDecl.params.size
+          if numArgs < numParams then
+            mkExpr (.pap name irArgs)
+          else if numArgs == numParams then
+            mkExpr (.fap name irArgs)
+          else
+            let firstArgs := irArgs.extract 0 numParams
+            let restArgs := irArgs.extract numParams irArgs.size
+            mkPartialApp (.fap name firstArgs) restArgs
+        else
+          throwNamedError lean.dependsOnNoncomputable f!"axiom '{name}' not supported by code generator; consider marking definition as 'noncomputable'"
+      | some (.quotInfo ..) =>
+        if name == ``Quot.mk then
+          match irArgs[2]! with
+          | .var varId => mkVar varId
+          | .irrelevant => mkErased ()
+        else
+          throwError f!"quot {name} unsupported by code generator"
+      | some (.defnInfo ..) | some (.opaqueInfo ..) =>
+        if let some code ← tryIrDecl? name irArgs then
+          return code
+        else
+          mkExpr (.fap name irArgs)
+      | some (.recInfo ..) =>
+        throwError f!"code generator does not support recursor '{name}' yet, consider using 'match ... with' and/or structural recursion"
+      | some (.inductInfo ..) => panic! "induct unsupported by code generator"
+      | some (.thmInfo ..) => panic! "thm unsupported by code generator"
+      | none => panic! "reference to unbound name"
+  | .fvar fvarId args =>
+    match (← get).fvars[fvarId]? with
+    | some (.var id) =>
+      let irArgs ← args.mapM lowerArg
+      mkExpr (.ap id irArgs)
+    | some .erased => mkErased ()
+    | some (.joinPoint ..) | none => panic! "unexpected value"
+  | .erased => mkErased ()
+
+partial def lowerAlt (discr : VarId) (a : LCNF.Alt) : M Alt := do
+  match a with
+  | .alt ctorName params code =>
+    let ⟨ctorInfo, fields⟩ ← getCtorInfo ctorName
+    let lowerParams (params : Array LCNF.Param) (fields : Array CtorFieldInfo) : M FnBody := do
+      let rec loop (i : Nat) : M FnBody := do
+        match params[i]?, fields[i]? with
+        | some param, some field =>
+          let ⟨result, type⟩ := lowerProj discr ctorInfo field
+          match result with
+          | .expr e =>
+            return .vdecl (← bindVar param.fvarId)
+                          type
+                          e
+                          (← loop (i + 1))
+          | .erased =>
+            bindErased param.fvarId
+            loop (i + 1)
+        | none, none => lowerCode code
+        | _, _ => panic! "mismatched fields and params"
+      loop 0
+    let body ← lowerParams params fields
+    return .ctor ctorInfo body
+  | .default code =>
+    return .default (← lowerCode code)
+end
+
+def lowerResultType (type : Lean.Expr) (arity : Nat) : M IRType :=
+  toIRType (resultTypeForArity type arity)
+where resultTypeForArity (type : Lean.Expr) (arity : Nat) : Lean.Expr :=
+  if arity == 0 then
+    type
+  else
+    match type with
+    | .forallE _ _ b _ => resultTypeForArity b (arity - 1)
+    | .const ``lcErased _ => mkConst ``lcErased
+    | _ => panic! "invalid arity"
+
+def lowerDecl (d : LCNF.Decl) : M (Option Decl) := do
+  let params ← d.params.mapM lowerParam
+  let resultType ← lowerResultType d.type d.params.size
+  match d.value with
+  | .code code =>
+    let body ← lowerCode code
+    pure <| some <| .fdecl d.name params resultType body {}
+  | .extern externAttrData =>
+    if externAttrData.entries.isEmpty then
+      -- TODO: This matches the behavior of the old compiler, but we should
+      -- find a better way to handle this.
+      addDecl (mkDummyExternDecl d.name params resultType)
+      pure <| none
+    else
+      pure <| some <| .extern d.name params resultType externAttrData
+
+end ToIR
+
+def toIR (decls: Array LCNF.Decl) : CoreM (Array Decl) := do
+  let mut irDecls := #[]
+  for decl in decls do
+    if let some irDecl ← ToIR.lowerDecl decl |>.run then
+      irDecls := irDecls.push irDecl
+  return irDecls
+
+end Lean.IR

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/ToIRType.lean

@@ -0,0 +1,126 @@
+/-
+Copyright (c) 2019 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Environment
+import Lean.Compiler.IR.Format
+import Lean.Compiler.LCNF.CompilerM
+
+namespace Lean
+namespace IR
+
+open Lean.Compiler (LCNF.CacheExtension)
+
+builtin_initialize scalarTypeExt : LCNF.CacheExtension Name (Option IRType) ←
+  LCNF.CacheExtension.register
+
+def lowerEnumToScalarType? (name : Name) : CoreM (Option IRType) := do
+  match (← scalarTypeExt.find? name) with
+  | some info? => return info?
+  | none =>
+    let info? ← fillCache
+    scalarTypeExt.insert name info?
+    return info?
+where fillCache : CoreM (Option IRType) := do
+  let env ← Lean.getEnv
+  let some (.inductInfo inductiveVal) := env.find? name | return none
+  let ctorNames := inductiveVal.ctors
+  let numCtors := ctorNames.length
+  for ctorName in ctorNames do
+    let some (.ctorInfo ctorVal) := env.find? ctorName | panic! "expected valid constructor name"
+    if ctorVal.type.isForall then return none
+  return if numCtors == 1 then
+    none
+  else if numCtors < Nat.pow 2 8 then
+    some .uint8
+  else if numCtors < Nat.pow 2 16 then
+    some .uint16
+  else if numCtors < Nat.pow 2 32 then
+    some .uint32
+  else
+    none
+
+def toIRType (e : Lean.Expr) : CoreM IRType := do
+  match e with
+  | .const name .. =>
+    match name with
+    | ``UInt8 | ``Bool => return .uint8
+    | ``UInt16 => return .uint16
+    | ``UInt32 => return .uint32
+    | ``UInt64 => return .uint64
+    | ``USize => return .usize
+    | ``Float => return .float
+    | ``Float32 => return .float32
+    | ``lcErased => return .irrelevant
+    | _ =>
+      if let some scalarType ← lowerEnumToScalarType? name then
+        return scalarType
+      else
+        return .object
+  | .app f _ =>
+    -- All mono types are in headBeta form.
+    if let .const name _ := f then
+      if let some scalarType ← lowerEnumToScalarType? name then
+        return scalarType
+      else
+        return .object
+    else
+      return .object
+  | .forallE .. => return .object
+  | _ => panic! "invalid type"
+
+inductive CtorFieldInfo where
+  | irrelevant
+  | object (i : Nat)
+  | usize  (i : Nat)
+  | scalar (sz : Nat) (offset : Nat) (type : IRType)
+  deriving Inhabited
+
+namespace CtorFieldInfo
+
+def format : CtorFieldInfo → Format
+  | irrelevant => "◾"
+  | object i   => f!"obj@{i}"
+  | usize i    => f!"usize@{i}"
+  | scalar sz offset type => f!"scalar#{sz}@{offset}:{type}"
+
+instance : ToFormat CtorFieldInfo := ⟨format⟩
+
+end CtorFieldInfo
+
+structure CtorLayout where
+  cidx       : Nat
+  fieldInfo  : List CtorFieldInfo
+  numObjs    : Nat
+  numUSize   : Nat
+  scalarSize : Nat
+
+@[extern "lean_ir_get_ctor_layout"]
+opaque getCtorLayout (env : @& Environment) (ctorName : @& Name) : Except String CtorLayout
+
+builtin_initialize ctorInfoExt : LCNF.CacheExtension Name (CtorInfo × (Array CtorFieldInfo)) ←
+  LCNF.CacheExtension.register
+
+def getCtorInfo (name : Name) : CoreM (CtorInfo × (Array CtorFieldInfo)) := do
+  match (← ctorInfoExt.find? name) with
+  | some info => return info
+  | none =>
+    let info ← fillCache
+    ctorInfoExt.insert name info
+    return info
+where fillCache := do
+  match getCtorLayout (← Lean.getEnv) name with
+  | .ok ctorLayout =>
+    return ⟨{
+      name,
+      cidx := ctorLayout.cidx,
+      size := ctorLayout.numObjs,
+      usize := ctorLayout.numUSize,
+      ssize := ctorLayout.scalarSize
+    }, ctorLayout.fieldInfo.toArray⟩
+  | .error .. => panic! "unrecognized constructor"
+
+end IR
+end Lean

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/UnboxResult.lean

@@ -0,0 +1,30 @@
+/-
+Copyright (c) 2019 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Data.Format
+import Lean.Compiler.IR.Basic
+
+namespace Lean.IR.UnboxResult
+
+/--
+Tags types that the compiler should unbox if they occur in result values.
+
+This attribute currently has no effect.
+-/
+@[builtin_doc]
+builtin_initialize unboxAttr : TagAttribute ←
+  registerTagAttribute `unbox "compiler tries to unbox result values if their types are tagged with `[unbox]`" fun declName => do
+    let cinfo ← getConstInfo declName;
+    match cinfo with
+    | ConstantInfo.inductInfo v =>
+      if v.isRec then throwError "recursive inductive datatypes are not supported"
+      else pure ()
+    | _ => throwError "constant must be an inductive type"
+
+def hasUnboxAttr (env : Environment) (n : Name) : Bool :=
+  unboxAttr.hasTag env n
+
+end Lean.IR.UnboxResult

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/AlphaEqv.lean

@@ -0,0 +1,137 @@
+/-
+Copyright (c) 2022 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Compiler.LCNF.Basic
+
+namespace Lean.Compiler.LCNF
+
+/-!
+Alpha equivalence for LCNF Code
+-/
+
+namespace AlphaEqv
+
+abbrev EqvM := ReaderM (FVarIdMap FVarId)
+
+def eqvFVar (fvarId₁ fvarId₂ : FVarId) : EqvM Bool := do
+  let fvarId₂ := (← read).find? fvarId₂ |>.getD fvarId₂
+  return fvarId₁ == fvarId₂
+
+def eqvType (e₁ e₂ : Expr) : EqvM Bool := do
+  match e₁, e₂ with
+  | .app f₁ a₁, .app f₂ a₂ => eqvType a₁ a₂ <&&> eqvType f₁ f₂
+  | .fvar fvarId₁, .fvar fvarId₂ => eqvFVar fvarId₁ fvarId₂
+  | .forallE _ d₁ b₁ _, .forallE _ d₂ b₂ _ => eqvType d₁ d₂ <&&> eqvType b₁ b₂
+  | _, _ => return e₁ == e₂
+
+def eqvTypes (es₁ es₂ : Array Expr) : EqvM Bool := do
+  if es₁.size = es₂.size then
+    for e₁ in es₁, e₂ in es₂ do
+      unless (← eqvType e₁ e₂) do
+        return false
+    return true
+  else
+    return false
+
+def eqvArg (a₁ a₂ : Arg) : EqvM Bool := do
+  match a₁, a₂ with
+  | .type e₁, .type e₂ => eqvType e₁ e₂
+  | .fvar x₁, .fvar x₂ => eqvFVar x₁ x₂
+  | .erased, .erased => return true
+  | _, _ => return false
+
+def eqvArgs (as₁ as₂ : Array Arg) : EqvM Bool := do
+  if as₁.size = as₂.size then
+    for a₁ in as₁, a₂ in as₂ do
+      unless (← eqvArg a₁ a₂) do
+        return false
+    return true
+  else
+    return false
+
+def eqvLetValue (e₁ e₂ : LetValue) : EqvM Bool := do
+  match e₁, e₂ with
+  | .lit v₁, .lit v₂ => return v₁ == v₂
+  | .erased, .erased => return true
+  | .proj s₁ i₁ x₁, .proj s₂ i₂ x₂ => pure (s₁ == s₂ && i₁ == i₂) <&&> eqvFVar x₁ x₂
+  | .const n₁ us₁ as₁, .const n₂ us₂ as₂ => pure (n₁ == n₂ && us₁ == us₂) <&&> eqvArgs as₁ as₂
+  | .fvar f₁ as₁, .fvar f₂ as₂ => eqvFVar f₁ f₂ <&&> eqvArgs as₁ as₂
+  | _, _ => return false
+
+@[inline] def withFVar (fvarId₁ fvarId₂ : FVarId) (x : EqvM α) : EqvM α :=
+  withReader (·.insert fvarId₂ fvarId₁) x
+
+@[inline] def withParams (params₁ params₂ : Array Param) (x : EqvM Bool) : EqvM Bool := do
+  if h : params₂.size = params₁.size then
+    let rec @[specialize] go (i : Nat) : EqvM Bool := do
+      if h : i < params₁.size then
+        let p₁ := params₁[i]
+        have : i < params₂.size := by simp_all +arith
+        let p₂ := params₂[i]
+        unless (← eqvType p₁.type p₂.type) do return false
+        withFVar p₁.fvarId p₂.fvarId do
+          go (i+1)
+      else
+        x
+      termination_by params₁.size - i
+    go 0
+  else
+    return false
+
+def sortAlts (alts : Array Alt) : Array Alt :=
+  alts.qsort fun
+    | .alt .., .default .. => true
+    | .alt ctorName₁ .., .alt ctorName₂ .. => Name.lt ctorName₁ ctorName₂
+    | _, _  => false
+
+mutual
+
+partial def eqvAlts (alts₁ alts₂ : Array Alt) : EqvM Bool := do
+  if alts₁.size = alts₂.size then
+    let alts₁ := sortAlts alts₁
+    let alts₂ := sortAlts alts₂
+    for alt₁ in alts₁, alt₂ in alts₂ do
+      match alt₁, alt₂ with
+      | .alt ctorName₁ ps₁ k₁, .alt ctorName₂ ps₂ k₂ =>
+        unless ctorName₁ == ctorName₂ do return false
+        unless (← withParams ps₁ ps₂ (eqv k₁ k₂)) do return false
+      | .default k₁, .default k₂ => unless (← eqv k₁ k₂) do return false
+      | _, _ => return false
+    return true
+  else
+    return false
+
+partial def eqv (code₁ code₂ : Code) : EqvM Bool := do
+  match code₁, code₂ with
+  | .let decl₁ k₁, .let decl₂ k₂ =>
+    eqvType decl₁.type decl₂.type <&&>
+    eqvLetValue decl₁.value decl₂.value <&&>
+    withFVar decl₁.fvarId decl₂.fvarId (eqv k₁ k₂)
+  | .fun decl₁ k₁, .fun decl₂ k₂
+  | .jp decl₁ k₁, .jp decl₂ k₂ =>
+    eqvType decl₁.type decl₂.type <&&>
+    withParams decl₁.params decl₂.params (eqv decl₁.value decl₂.value) <&&>
+    withFVar decl₁.fvarId decl₂.fvarId (eqv k₁ k₂)
+  | .return fvarId₁, .return fvarId₂ => eqvFVar fvarId₁ fvarId₂
+  | .unreach type₁, .unreach type₂ => eqvType type₁ type₂
+  | .jmp fvarId₁ args₁, .jmp fvarId₂ args₂ => eqvFVar fvarId₁ fvarId₂ <&&> eqvArgs args₁ args₂
+  | .cases c₁, .cases c₂ =>
+    eqvFVar c₁.discr c₂.discr <&&>
+    eqvType c₁.resultType c₂.resultType <&&>
+    eqvAlts c₁.alts c₂.alts
+  | _, _ => return false
+
+end
+
+end AlphaEqv
+
+/--
+Return `true` if `c₁` and `c₂` are alpha equivalent.
+-/
+def Code.alphaEqv (c₁ c₂ : Code) : Bool :=
+  AlphaEqv.eqv c₁ c₂ |>.run {}
+
+end Lean.Compiler.LCNF

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/AuxDeclCache.lean

@@ -0,0 +1,29 @@
+/-
+Copyright (c) 2022 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Compiler.LCNF.CompilerM
+import Lean.Compiler.LCNF.DeclHash
+import Lean.Compiler.LCNF.Internalize
+
+namespace Lean.Compiler.LCNF
+
+builtin_initialize auxDeclCacheExt : CacheExtension Decl Name ← CacheExtension.register
+
+inductive CacheAuxDeclResult where
+  | new
+  | alreadyCached (declName : Name)
+
+def cacheAuxDecl (decl : Decl) : CompilerM CacheAuxDeclResult := do
+  let key := { decl with name := .anonymous }
+  let key ← normalizeFVarIds key
+  match (← auxDeclCacheExt.find? key) with
+  | some declName =>
+    return .alreadyCached declName
+  | none =>
+    auxDeclCacheExt.insert key decl.name
+    return .new
+
+end Lean.Compiler.LCNF

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/BaseTypes.lean

@@ -0,0 +1,29 @@
+/-
+Copyright (c) 2022 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Compiler.LCNF.CompilerM
+import Lean.Compiler.LCNF.Types
+
+namespace Lean.Compiler.LCNF
+
+/--
+State for the environment extension used to save the LCNF base phase type for declarations
+that do not have code associated with them.
+Example: constructors, inductive types, foreign functions.
+-/
+builtin_initialize baseTypeExt : CacheExtension Name Expr ← CacheExtension.register
+
+def getOtherDeclBaseType (declName : Name) (us : List Level) : CoreM Expr := do
+  let info ← getConstInfo declName
+  let type ← match (← baseTypeExt.find? declName) with
+    | some type => pure type
+    | none =>
+      let type ← Meta.MetaM.run' <| toLCNFType info.type
+      baseTypeExt.insert declName type
+      pure type
+  return type.instantiateLevelParamsNoCache info.levelParams us
+
+end Lean.Compiler.LCNF

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/Basic.lean

@@ -0,0 +1,755 @@
+/-
+Copyright (c) 2022 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Init.Data.List.BasicAux
+import Lean.Expr
+import Lean.Meta.Instances
+import Lean.Compiler.ExternAttr
+import Lean.Compiler.InlineAttrs
+import Lean.Compiler.Specialize
+import Lean.Compiler.LCNF.Types
+
+namespace Lean.Compiler.LCNF
+
+/-!
+# Lean Compiler Normal Form (LCNF)
+
+It is based on the [A-normal form](https://en.wikipedia.org/wiki/A-normal_form),
+and the approach described in the paper
+[Compiling  without continuations](https://www.microsoft.com/en-us/research/wp-content/uploads/2016/11/compiling-without-continuations.pdf).
+
+-/
+
+structure Param where
+  fvarId     : FVarId
+  binderName : Name
+  type       : Expr
+  borrow     : Bool
+  deriving Inhabited, BEq
+
+def Param.toExpr (p : Param) : Expr :=
+  .fvar p.fvarId
+
+inductive LitValue where
+  | nat (val : Nat)
+  | str (val : String)
+  | uint8 (val : UInt8)
+  | uint16 (val : UInt16)
+  | uint32 (val : UInt32)
+  | uint64 (val : UInt64)
+  -- USize has a maximum size of 64 bits
+  | usize (val : UInt64)
+  -- TODO: add constructors for `Int`, `Float`, ...
+  deriving Inhabited, BEq, Hashable
+
+def LitValue.toExpr : LitValue → Expr
+  | .nat v => .lit (.natVal v)
+  | .str v => .lit (.strVal v)
+  | .uint8 v => .app (.const ``UInt8.ofNat []) (.lit (.natVal (UInt8.toNat v)))
+  | .uint16 v => .app (.const ``UInt16.ofNat []) (.lit (.natVal (UInt16.toNat v)))
+  | .uint32 v => .app (.const ``UInt32.ofNat []) (.lit (.natVal (UInt32.toNat v)))
+  | .uint64 v => .app (.const ``UInt64.ofNat []) (.lit (.natVal (UInt64.toNat v)))
+  | .usize v => .app (.const ``USize.ofNat []) (.lit (.natVal (UInt64.toNat v)))
+
+inductive Arg where
+  | erased
+  | fvar (fvarId : FVarId)
+  | type (expr : Expr)
+  deriving Inhabited, BEq, Hashable
+
+def Param.toArg (p : Param) : Arg :=
+  .fvar p.fvarId
+
+def Arg.toExpr (arg : Arg) : Expr :=
+  match arg with
+  | .erased => erasedExpr
+  | .fvar fvarId => .fvar fvarId
+  | .type e => e
+
+private unsafe def Arg.updateTypeImp (arg : Arg) (type' : Expr) : Arg :=
+  match arg with
+  | .type ty => if ptrEq ty type' then arg else .type type'
+  | _ => unreachable!
+
+@[implemented_by Arg.updateTypeImp] opaque Arg.updateType! (arg : Arg) (type : Expr) : Arg
+
+private unsafe def Arg.updateFVarImp (arg : Arg) (fvarId' : FVarId) : Arg :=
+  match arg with
+  | .fvar fvarId => if fvarId' == fvarId then arg else .fvar fvarId'
+  | _ => unreachable!
+
+@[implemented_by Arg.updateFVarImp] opaque Arg.updateFVar! (arg : Arg) (fvarId' : FVarId) : Arg
+
+inductive LetValue where
+  | lit (value : LitValue)
+  | erased
+  | proj (typeName : Name) (idx : Nat) (struct : FVarId)
+  | const (declName : Name) (us : List Level) (args : Array Arg)
+  | fvar (fvarId : FVarId) (args : Array Arg)
+  deriving Inhabited, BEq, Hashable
+
+def Arg.toLetValue (arg : Arg) : LetValue :=
+  match arg with
+  | .fvar fvarId => .fvar fvarId #[]
+  | .erased | .type .. => .erased
+
+private unsafe def LetValue.updateProjImp (e : LetValue) (fvarId' : FVarId) : LetValue :=
+  match e with
+  | .proj s i fvarId => if fvarId == fvarId' then e else .proj s i fvarId'
+  | _ => unreachable!
+
+@[implemented_by LetValue.updateProjImp] opaque LetValue.updateProj! (e : LetValue) (fvarId' : FVarId) : LetValue
+
+private unsafe def LetValue.updateConstImp (e : LetValue) (declName' : Name) (us' : List Level) (args' : Array Arg) : LetValue :=
+  match e with
+  | .const declName us args => if declName == declName' && ptrEq us us' && ptrEq args args' then e else .const declName' us' args'
+  | _ => unreachable!
+
+@[implemented_by LetValue.updateConstImp] opaque LetValue.updateConst! (e : LetValue) (declName' : Name) (us' : List Level) (args' : Array Arg) : LetValue
+
+private unsafe def LetValue.updateFVarImp (e : LetValue) (fvarId' : FVarId) (args' : Array Arg) : LetValue :=
+  match e with
+  | .fvar fvarId args => if fvarId == fvarId' && ptrEq args args' then e else .fvar fvarId' args'
+  | _ => unreachable!
+
+@[implemented_by LetValue.updateFVarImp] opaque LetValue.updateFVar! (e : LetValue) (fvarId' : FVarId) (args' : Array Arg) : LetValue
+
+private unsafe def LetValue.updateArgsImp (e : LetValue) (args' : Array Arg) : LetValue :=
+  match e with
+  | .const declName us args => if ptrEq args args' then e else .const declName us args'
+  | .fvar fvarId args => if ptrEq args args' then e else .fvar fvarId args'
+  | _ => unreachable!
+
+@[implemented_by LetValue.updateArgsImp] opaque LetValue.updateArgs! (e : LetValue) (args' : Array Arg) : LetValue
+
+def LetValue.toExpr (e : LetValue) : Expr :=
+  match e with
+  | .lit v => v.toExpr
+  | .erased => erasedExpr
+  | .proj n i s => .proj n i (.fvar s)
+  | .const n us as => mkAppN (.const n us) (as.map Arg.toExpr)
+  | .fvar fvarId as => mkAppN (.fvar fvarId) (as.map Arg.toExpr)
+
+structure LetDecl where
+  fvarId : FVarId
+  binderName : Name
+  type : Expr
+  value : LetValue
+  deriving Inhabited, BEq
+
+mutual
+
+inductive Alt where
+  | alt (ctorName : Name) (params : Array Param) (code : Code)
+  | default (code : Code)
+
+structure FunDecl where
+  fvarId : FVarId
+  binderName : Name
+  params : Array Param
+  type : Expr
+  value : Code
+
+structure Cases where
+  typeName : Name
+  resultType : Expr
+  discr : FVarId
+  alts : Array Alt
+  deriving Inhabited
+
+inductive Code where
+  | let (decl : LetDecl) (k : Code)
+  | fun (decl : FunDecl) (k : Code)
+  | jp (decl : FunDecl) (k : Code)
+  | jmp (fvarId : FVarId) (args : Array Arg)
+  | cases (cases : Cases)
+  | return (fvarId : FVarId)
+  | unreach (type : Expr)
+  deriving Inhabited
+
+end
+
+deriving instance Inhabited for Alt
+deriving instance Inhabited for FunDecl
+
+def FunDecl.getArity (decl : FunDecl) : Nat :=
+  decl.params.size
+
+/--
+Return the constructor names that have an explicit (non-default) alternative.
+-/
+def Cases.getCtorNames (c : Cases) : NameSet :=
+  c.alts.foldl (init := {}) fun ctorNames alt =>
+    match alt with
+    | .default _ => ctorNames
+    | .alt ctorName .. => ctorNames.insert ctorName
+
+inductive CodeDecl where
+  | let (decl : LetDecl)
+  | fun (decl : FunDecl)
+  | jp (decl : FunDecl)
+  deriving Inhabited
+
+def CodeDecl.fvarId : CodeDecl → FVarId
+  | .let decl | .fun decl | .jp decl => decl.fvarId
+
+def attachCodeDecls (decls : Array CodeDecl) (code : Code) : Code :=
+  go decls.size code
+where
+  go (i : Nat) (code : Code) : Code :=
+    if i > 0 then
+      match decls[i-1]! with
+      | .let decl => go (i-1) (.let decl code)
+      | .fun decl => go (i-1) (.fun decl code)
+      | .jp decl => go (i-1) (.jp decl code)
+    else
+      code
+
+mutual
+  private unsafe def eqImp (c₁ c₂ : Code) : Bool :=
+    if ptrEq c₁ c₂ then
+      true
+    else match c₁, c₂ with
+      | .let d₁ k₁, .let d₂ k₂ => d₁ == d₂ && eqImp k₁ k₂
+      | .fun d₁ k₁, .fun d₂ k₂
+      | .jp d₁ k₁, .jp d₂ k₂ => eqFunDecl d₁ d₂ && eqImp k₁ k₂
+      | .cases c₁, .cases c₂ => eqCases c₁ c₂
+      | .jmp j₁ as₁, .jmp j₂ as₂ => j₁ == j₂ && as₁ == as₂
+      | .return r₁, .return r₂ => r₁ == r₂
+      | .unreach t₁, .unreach t₂ => t₁ == t₂
+      | _, _ => false
+
+  private unsafe def eqFunDecl (d₁ d₂ : FunDecl) : Bool :=
+    if ptrEq d₁ d₂ then
+      true
+    else
+      d₁.fvarId == d₂.fvarId && d₁.binderName == d₂.binderName &&
+      d₁.params == d₂.params && d₁.type == d₂.type &&
+      eqImp d₁.value d₂.value
+
+  private unsafe def eqCases (c₁ c₂ : Cases) : Bool :=
+    c₁.resultType == c₂.resultType && c₁.discr == c₂.discr &&
+    c₁.typeName == c₂.typeName && c₁.alts.isEqv c₂.alts eqAlt
+
+  private unsafe def eqAlt (a₁ a₂ : Alt) : Bool :=
+    match a₁, a₂ with
+    | .default k₁, .default k₂ => eqImp k₁ k₂
+    | .alt c₁ ps₁ k₁, .alt c₂ ps₂ k₂ => c₁ == c₂ && ps₁ == ps₂ && eqImp k₁ k₂
+    | _, _ => false
+end
+
+@[implemented_by eqImp] protected opaque Code.beq : Code → Code → Bool
+
+instance : BEq Code where
+  beq := Code.beq
+
+@[implemented_by eqFunDecl] protected opaque FunDecl.beq : FunDecl → FunDecl → Bool
+
+instance : BEq FunDecl where
+  beq := FunDecl.beq
+
+def Alt.getCode : Alt → Code
+  | .default k => k
+  | .alt _ _ k => k
+
+def Alt.getParams : Alt → Array Param
+  | .default _ => #[]
+  | .alt _ ps _ => ps
+
+def Alt.forCodeM [Monad m] (alt : Alt) (f : Code → m Unit) : m Unit := do
+  match alt with
+  | .default k => f k
+  | .alt _ _ k => f k
+
+private unsafe def updateAltCodeImp (alt : Alt) (k' : Code) : Alt :=
+  match alt with
+  | .default k => if ptrEq k k' then alt else .default k'
+  | .alt ctorName ps k => if ptrEq k k' then alt else .alt ctorName ps k'
+
+@[implemented_by updateAltCodeImp] opaque Alt.updateCode (alt : Alt) (c : Code) : Alt
+
+private unsafe def updateAltImp (alt : Alt) (ps' : Array Param) (k' : Code) : Alt :=
+  match alt with
+  | .alt ctorName ps k => if ptrEq k k' && ptrEq ps ps' then alt else .alt ctorName ps' k'
+  | _ => unreachable!
+
+@[implemented_by updateAltImp] opaque Alt.updateAlt! (alt : Alt) (ps' : Array Param) (k' : Code) : Alt
+
+@[inline] private unsafe def updateAltsImp (c : Code) (alts : Array Alt) : Code :=
+  match c with
+  | .cases cs => if ptrEq cs.alts alts then c else .cases { cs with alts }
+  | _ => unreachable!
+
+@[implemented_by updateAltsImp] opaque Code.updateAlts! (c : Code) (alts : Array Alt) : Code
+
+@[inline] private unsafe def updateCasesImp (c : Code) (resultType : Expr) (discr : FVarId) (alts : Array Alt) : Code :=
+  match c with
+  | .cases cs => if ptrEq cs.alts alts && ptrEq cs.resultType resultType && cs.discr == discr then c else .cases { cs with discr, resultType, alts }
+  | _ => unreachable!
+
+@[implemented_by updateCasesImp] opaque Code.updateCases! (c : Code) (resultType : Expr) (discr : FVarId) (alts : Array Alt) : Code
+
+@[inline] private unsafe def updateLetImp (c : Code) (decl' : LetDecl) (k' : Code) : Code :=
+  match c with
+  | .let decl k => if ptrEq k k' && ptrEq decl decl' then c else .let decl' k'
+  | _ => unreachable!
+
+@[implemented_by updateLetImp] opaque Code.updateLet! (c : Code) (decl' : LetDecl) (k' : Code) : Code
+
+@[inline] private unsafe def updateContImp (c : Code) (k' : Code) : Code :=
+  match c with
+  | .let decl k => if ptrEq k k' then c else .let decl k'
+  | .fun decl k => if ptrEq k k' then c else .fun decl k'
+  | .jp decl k => if ptrEq k k' then c else .jp decl k'
+  | _ => unreachable!
+
+@[implemented_by updateContImp] opaque Code.updateCont! (c : Code) (k' : Code) : Code
+
+@[inline] private unsafe def updateFunImp (c : Code) (decl' : FunDecl) (k' : Code) : Code :=
+  match c with
+  | .fun decl k => if ptrEq k k' && ptrEq decl decl' then c else .fun decl' k'
+  | .jp decl k => if ptrEq k k' && ptrEq decl decl' then c else .jp decl' k'
+  | _ => unreachable!
+
+@[implemented_by updateFunImp] opaque Code.updateFun! (c : Code) (decl' : FunDecl) (k' : Code) : Code
+
+@[inline] private unsafe def updateReturnImp (c : Code) (fvarId' : FVarId) : Code :=
+  match c with
+  | .return fvarId => if fvarId == fvarId' then c else .return fvarId'
+  | _ => unreachable!
+
+@[implemented_by updateReturnImp] opaque Code.updateReturn! (c : Code) (fvarId' : FVarId) : Code
+
+@[inline] private unsafe def updateJmpImp (c : Code) (fvarId' : FVarId) (args' : Array Arg) : Code :=
+  match c with
+  | .jmp fvarId args => if fvarId == fvarId' && ptrEq args args' then c else .jmp fvarId' args'
+  | _ => unreachable!
+
+@[implemented_by updateJmpImp] opaque Code.updateJmp! (c : Code) (fvarId' : FVarId) (args' : Array Arg) : Code
+
+@[inline] private unsafe def updateUnreachImp (c : Code) (type' : Expr) : Code :=
+  match c with
+  | .unreach type => if ptrEq type type' then c else .unreach type'
+  | _ => unreachable!
+
+@[implemented_by updateUnreachImp] opaque Code.updateUnreach! (c : Code) (type' : Expr) : Code
+
+private unsafe def updateParamCoreImp (p : Param) (type : Expr) : Param :=
+  if ptrEq type p.type then
+    p
+  else
+    { p with type }
+
+/--
+Low-level update `Param` function. It does not update the local context.
+Consider using `Param.update : Param → Expr → CompilerM Param` if you want the local context
+to be updated.
+-/
+@[implemented_by updateParamCoreImp] opaque Param.updateCore (p : Param) (type : Expr) : Param
+
+private unsafe def updateLetDeclCoreImp (decl : LetDecl) (type : Expr) (value : LetValue) : LetDecl :=
+  if ptrEq type decl.type && ptrEq value decl.value then
+    decl
+  else
+    { decl with type, value }
+
+/--
+Low-level update `LetDecl` function. It does not update the local context.
+Consider using `LetDecl.update : LetDecl → Expr → Expr → CompilerM LetDecl` if you want the local context
+to be updated.
+-/
+@[implemented_by updateLetDeclCoreImp] opaque LetDecl.updateCore (decl : LetDecl) (type : Expr) (value : LetValue) : LetDecl
+
+private unsafe def updateFunDeclCoreImp (decl: FunDecl) (type : Expr) (params : Array Param) (value : Code) : FunDecl :=
+  if ptrEq type decl.type && ptrEq params decl.params && ptrEq value decl.value then
+    decl
+  else
+    { decl with type, params, value }
+
+/--
+Low-level update `FunDecl` function. It does not update the local context.
+Consider using `FunDecl.update : LetDecl → Expr → Array Param → Code → CompilerM FunDecl` if you want the local context
+to be updated.
+-/
+@[implemented_by updateFunDeclCoreImp] opaque FunDecl.updateCore (decl : FunDecl) (type : Expr) (params : Array Param) (value : Code) : FunDecl
+
+def Cases.extractAlt! (cases : Cases) (ctorName : Name) : Alt × Cases :=
+  let found i := (cases.alts[i], { cases with alts := cases.alts.eraseIdx i })
+  if let some i := cases.alts.findFinIdx? fun | .alt ctorName' .. => ctorName == ctorName' | _ => false then
+    found i
+  else if let some i := cases.alts.findFinIdx? fun | .default _ => true | _ => false then
+    found i
+  else
+    unreachable!
+
+def Alt.mapCodeM [Monad m] (alt : Alt) (f : Code → m Code) : m Alt := do
+  return alt.updateCode (← f alt.getCode)
+
+def Code.isDecl : Code → Bool
+  | .let .. | .fun .. | .jp .. => true
+  | _ => false
+
+def Code.isFun : Code → Bool
+  | .fun .. => true
+  | _ => false
+
+def Code.isReturnOf : Code → FVarId → Bool
+  | .return fvarId, fvarId' => fvarId == fvarId'
+  | _, _ => false
+
+partial def Code.size (c : Code) : Nat :=
+  go c 0
+where
+  go (c : Code) (n : Nat) : Nat :=
+    match c with
+    | .let _ k => go k (n+1)
+    | .jp decl k | .fun decl k => go k <| go decl.value n
+    | .cases c => c.alts.foldl (init := n+1) fun n alt => go alt.getCode (n+1)
+    | .jmp .. => n+1
+    | .return .. | unreach .. => n -- `return` & `unreach` have weight zero
+
+/-- Return true iff `c.size ≤ n` -/
+partial def Code.sizeLe (c : Code) (n : Nat) : Bool :=
+  match go c |>.run 0 with
+  | .ok .. => true
+  | .error .. => false
+where
+  inc : EStateM Unit Nat Unit := do
+    modify (·+1)
+    unless (← get) <= n do throw ()
+
+  go (c : Code) : EStateM Unit Nat Unit := do
+    match c with
+    | .let _ k => inc; go k
+    | .jp decl k | .fun decl k => inc; go decl.value; go k
+    | .cases c => inc; c.alts.forM fun alt => go alt.getCode
+    | .jmp .. => inc
+    | .return .. | unreach .. => return ()
+
+partial def Code.forM [Monad m] (c : Code) (f : Code → m Unit) : m Unit :=
+  go c
+where
+  go (c : Code) : m Unit := do
+    f c
+    match c with
+    | .let _ k => go k
+    | .fun decl k | .jp decl k => go decl.value; go k
+    | .cases c => c.alts.forM fun alt => go alt.getCode
+    | .unreach .. | .return .. | .jmp .. => return ()
+
+partial def Code.instantiateValueLevelParams (code : Code) (levelParams : List Name) (us : List Level) : Code :=
+  instCode code
+where
+  instLevel (u : Level) :=
+    u.instantiateParams levelParams us
+
+  instExpr (e : Expr) :=
+    e.instantiateLevelParamsNoCache levelParams us
+
+  instParams (ps : Array Param) :=
+    ps.mapMono fun p => p.updateCore (instExpr p.type)
+
+  instAlt (alt : Alt) :=
+    match alt with
+    | .default k => alt.updateCode (instCode k)
+    | .alt _ ps k => alt.updateAlt! (instParams ps) (instCode k)
+
+  instArg (arg : Arg) : Arg :=
+    match arg with
+    | .type e => arg.updateType! (instExpr e)
+    | .fvar .. | .erased => arg
+
+  instLetValue (e : LetValue) : LetValue :=
+    match e with
+    | .const declName vs args => e.updateConst! declName (vs.mapMono instLevel) (args.mapMono instArg)
+    | .fvar fvarId args => e.updateFVar! fvarId (args.mapMono instArg)
+    | .proj .. | .lit .. | .erased => e
+
+  instLetDecl (decl : LetDecl) :=
+    decl.updateCore (instExpr decl.type) (instLetValue decl.value)
+
+  instFunDecl (decl : FunDecl) :=
+    decl.updateCore (instExpr decl.type) (instParams decl.params) (instCode decl.value)
+
+  instCode (code : Code) :=
+    match code with
+    | .let decl k => code.updateLet! (instLetDecl decl) (instCode k)
+    | .jp decl k | .fun decl k => code.updateFun! (instFunDecl decl) (instCode k)
+    | .cases c => code.updateCases! (instExpr c.resultType) c.discr (c.alts.mapMono instAlt)
+    | .jmp fvarId args => code.updateJmp! fvarId (args.mapMono instArg)
+    | .return .. => code
+    | .unreach type => code.updateUnreach! (instExpr type)
+
+inductive DeclValue where
+  | code (code : Code)
+  | extern (externAttrData : ExternAttrData)
+  deriving Inhabited, BEq
+
+partial def DeclValue.size : DeclValue → Nat
+  | .code c => c.size
+  | .extern .. => 0
+
+def DeclValue.mapCode (f : Code → Code) : DeclValue → DeclValue :=
+  fun
+    | .code c => .code (f c)
+    | .extern e => .extern e
+
+def DeclValue.mapCodeM [Monad m] (f : Code → m Code) : DeclValue → m DeclValue :=
+  fun v => do
+    match v with
+    | .code c => return .code (← f c)
+    | .extern .. => return v
+
+def DeclValue.forCodeM [Monad m] (f : Code → m Unit) : DeclValue → m Unit :=
+  fun v => do
+    match v with
+    | .code c => f c
+    | .extern .. => return ()
+
+def DeclValue.isCodeAndM [Monad m] (v : DeclValue) (f : Code → m Bool) : m Bool :=
+  match v with
+  | .code c => f c
+  | .extern .. => pure false
+
+/--
+Declaration being processed by the Lean to Lean compiler passes.
+-/
+structure Decl where
+  /--
+  The name of the declaration from the `Environment` it came from
+  -/
+  name  : Name
+  /--
+  Universe level parameter names.
+  -/
+  levelParams : List Name
+  /--
+  The type of the declaration. Note that this is an erased LCNF type
+  instead of the fully dependent one that might have been the original
+  type of the declaration in the `Environment`.
+  -/
+  type  : Expr
+  /--
+  Parameters.
+  -/
+  params : Array Param
+  /--
+  The body of the declaration, usually changes as it progresses
+  through compiler passes.
+  -/
+  value : DeclValue
+  /--
+  We set this flag to true during LCNF conversion. When we receive
+  a block of functions to be compiled, we set this flag to `true`
+  if there is an application to the function in the block containing
+  it. This is an approximation, but it should be good enough because
+  in the frontend, we invoke the compiler with blocks of strongly connected
+  components only.
+  We use this information to control inlining.
+  -/
+  recursive : Bool := false
+  /--
+  We set this flag to false during LCNF conversion if the Lean function
+  associated with this function was tagged as partial or unsafe. This
+  information affects how static analyzers treat function applications
+  of this kind. See `DefinitionSafety`.
+  `partial` and `unsafe` functions may not be terminating, but Lean
+  functions terminate, and some static analyzers exploit this
+  fact. So, we use the following semantics. Suppose we have a (large) natural
+  number `C`. We consider a nondeterministic model for computation of Lean expressions as
+  follows:
+  Each call to a partial/unsafe function uses up one "recursion token".
+  Prior to consuming `C` recursion tokens all partial functions must be called
+  as normal. Once the model has used up `C` recursion tokens, a subsequent call to
+  a partial function has the following nondeterministic options: it can either call
+  the function again, or return any value of the target type (even a noncomputable one).
+  Larger values of `C` yield less nondeterminism in the model, but even the intersection of
+  all choices of `C` yields nondeterminism where `def loop : A := loop` returns any value of type `A`.
+  The compiler fixes a choice for `C`. This is a fixed constant greater than 2^2^64,
+  which is allowed to be compiler and architecture dependent, and promises that it will
+  produce an execution consistent with every possible nondeterministic outcome of the `C`-model.
+  In the event that different nondeterministic executions disagree, the compiler is required to
+  exhaust resources or output a looping computation.
+  -/
+  safe : Bool := true
+  /--
+  We store the inline attribute at LCNF declarations to make sure we can set them for
+  auxiliary declarations created during compilation.
+  -/
+  inlineAttr? : Option InlineAttributeKind
+  deriving Inhabited, BEq
+
+def Decl.size (decl : Decl) : Nat :=
+  decl.value.size
+
+def Decl.getArity (decl : Decl) : Nat :=
+  decl.params.size
+
+def Decl.inlineAttr (decl : Decl) : Bool :=
+  decl.inlineAttr? matches some .inline
+
+def Decl.noinlineAttr (decl : Decl) : Bool :=
+  decl.inlineAttr? matches some .noinline
+
+def Decl.inlineIfReduceAttr (decl : Decl) : Bool :=
+  decl.inlineAttr? matches some .inlineIfReduce
+
+def Decl.alwaysInlineAttr (decl : Decl) : Bool :=
+  decl.inlineAttr? matches some .alwaysInline
+
+/-- Return `true` if the given declaration has been annotated with `[inline]`, `[inline_if_reduce]`, `[macro_inline]`, or `[always_inline]` -/
+def Decl.inlineable (decl : Decl) : Bool :=
+  match decl.inlineAttr? with
+  | some .noinline => false
+  | some _ => true
+  | none => false
+
+/--
+Return `some i` if `decl` is of the form
+```
+def f (a_0 ... a_i ...) :=
+  ...
+  cases a_i
+  | ...
+  | ...
+```
+That is, `f` is a sequence of declarations followed by a `cases` on the parameter `i`.
+We use this function to decide whether we should inline a declaration tagged with
+`[inline_if_reduce]` or not.
+-/
+def Decl.isCasesOnParam? (decl : Decl) : Option Nat :=
+  match decl.value with
+  | .code c => go c
+  | .extern .. => none
+where
+  go (code : Code) : Option Nat :=
+    match code with
+    | .let _ k | .jp _ k | .fun _ k => go k
+    | .cases c => decl.params.findIdx? fun param => param.fvarId == c.discr
+    | _ => none
+
+def Decl.instantiateTypeLevelParams (decl : Decl) (us : List Level) : Expr :=
+  decl.type.instantiateLevelParamsNoCache decl.levelParams us
+
+def Decl.instantiateParamsLevelParams (decl : Decl) (us : List Level) : Array Param :=
+  decl.params.mapMono fun param => param.updateCore (param.type.instantiateLevelParamsNoCache decl.levelParams us)
+
+/--
+Return `true` if the arrow type contains an instance implicit argument.
+-/
+def hasLocalInst (type : Expr) : Bool :=
+  match type with
+  | .forallE _ _ b bi => bi.isInstImplicit || hasLocalInst b
+  | _ => false
+
+/--
+Return `true` if `decl` is supposed to be inlined/specialized.
+-/
+def Decl.isTemplateLike (decl : Decl) : CoreM Bool := do
+  if hasLocalInst decl.type then
+    return true -- `decl` applications will be specialized
+  else if (← Meta.isInstance decl.name) then
+    return true -- `decl` is "fuel" for code specialization
+  else if decl.inlineable || hasSpecializeAttribute (← getEnv) decl.name then
+    return true -- `decl` is going to be inlined or specialized
+  else
+    return false
+
+private partial def collectType (e : Expr) : FVarIdHashSet → FVarIdHashSet :=
+  match e with
+  | .forallE _ d b _ => collectType b ∘ collectType d
+  | .lam _ d b _     => collectType b ∘ collectType d
+  | .app f a         => collectType f ∘ collectType a
+  | .fvar fvarId     => fun s => s.insert fvarId
+  | .mdata _ b       => collectType b
+  | .proj .. | .letE .. => unreachable!
+  | _                => id
+
+private def collectArg (arg : Arg) (s : FVarIdHashSet) : FVarIdHashSet :=
+  match arg with
+  | .erased => s
+  | .fvar fvarId => s.insert fvarId
+  | .type e => collectType e s
+
+private def collectArgs (args : Array Arg) (s : FVarIdHashSet) : FVarIdHashSet :=
+  args.foldl (init := s) fun s arg => collectArg arg s
+
+private def collectLetValue (e : LetValue) (s : FVarIdHashSet) : FVarIdHashSet :=
+  match e with
+  | .fvar fvarId args => collectArgs args <| s.insert fvarId
+  | .const _ _ args => collectArgs args s
+  | .proj _ _ fvarId => s.insert fvarId
+  | .lit .. | .erased => s
+
+private partial def collectParams (ps : Array Param) (s : FVarIdHashSet) : FVarIdHashSet :=
+  ps.foldl (init := s) fun s p => collectType p.type s
+
+mutual
+partial def FunDecl.collectUsed (decl : FunDecl) (s : FVarIdHashSet := {}) : FVarIdHashSet :=
+  decl.value.collectUsed <| collectParams decl.params <| collectType decl.type s
+
+partial def Code.collectUsed (code : Code) (s : FVarIdHashSet := {}) : FVarIdHashSet :=
+  match code with
+  | .let decl k => k.collectUsed <| collectLetValue decl.value <| collectType decl.type s
+  | .jp decl k | .fun decl k => k.collectUsed <| decl.collectUsed s
+  | .cases c =>
+    let s := s.insert c.discr
+    let s := collectType c.resultType s
+    c.alts.foldl (init := s) fun s alt =>
+      match alt with
+      | .default k => k.collectUsed s
+      | .alt _ ps k => k.collectUsed <| collectParams ps s
+  | .return fvarId => s.insert fvarId
+  | .unreach type => collectType type s
+  | .jmp fvarId args => collectArgs args <| s.insert fvarId
+end
+
+abbrev collectUsedAtExpr (s : FVarIdHashSet) (e : Expr) : FVarIdHashSet :=
+  collectType e s
+
+/--
+Traverse the given block of potentially mutually recursive functions
+and mark a declaration `f` as recursive if there is an application
+`f ...` in the block.
+This is an overapproximation, and relies on the fact that our frontend
+computes strongly connected components.
+See comment at `recursive` field.
+-/
+partial def markRecDecls (decls : Array Decl) : Array Decl :=
+  let (_, isRec) := go |>.run {}
+  decls.map fun decl =>
+    if isRec.contains decl.name then
+      { decl with recursive := true }
+    else
+      decl
+where
+  visit (code : Code) : StateM NameSet Unit := do
+    match code with
+    | .jp decl k | .fun decl k => visit decl.value; visit k
+    | .cases c => c.alts.forM fun alt => visit alt.getCode
+    | .unreach .. | .jmp .. | .return .. => return ()
+    | .let decl k =>
+      if let .const declName _ _ := decl.value then
+        if decls.any (·.name == declName) then
+          modify fun s => s.insert declName
+      visit k
+
+  go : StateM NameSet Unit :=
+    decls.forM (·.value.forCodeM visit)
+
+def instantiateRangeArgs (e : Expr) (beginIdx endIdx : Nat) (args : Array Arg) : Expr :=
+  if !e.hasLooseBVars then
+    e
+  else
+    e.instantiateRange beginIdx endIdx (args.map (·.toExpr))
+
+def instantiateRevRangeArgs (e : Expr) (beginIdx endIdx : Nat) (args : Array Arg) : Expr :=
+  if !e.hasLooseBVars then
+    e
+  else
+    e.instantiateRevRange beginIdx endIdx (args.map (·.toExpr))
+
+end Lean.Compiler.LCNF

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/Bind.lean

@@ -0,0 +1,132 @@
+/-
+Copyright (c) 2022 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Compiler.LCNF.InferType
+
+namespace Lean.Compiler.LCNF
+
+/-- Helper class for lifting `CompilerM.codeBind` -/
+class MonadCodeBind (m : Type → Type) where
+  codeBind : (c : Code) → (f : FVarId → m Code) → m Code
+
+/--
+Return code that is equivalent to `c >>= f`. That is, executes `c`, and then `f x`, where
+`x` is a variable that contains the result of `c`'s computation.
+
+If `c` contains a jump to a join point `jp_i` not declared in `c`, we throw an exception because
+an invalid block would be generated. It would be invalid because `f` would not
+be applied to `jp_i`. Note that, we could have decided to create a copy of `jp_i` where we apply `f` to it,
+by we decided to not do it to avoid code duplication.
+-/
+abbrev Code.bind [MonadCodeBind m] (c : Code) (f : FVarId → m Code) : m Code :=
+  MonadCodeBind.codeBind c f
+
+partial def CompilerM.codeBind (c : Code) (f : FVarId → CompilerM Code) : CompilerM Code := do
+  go c |>.run {}
+where
+  go (c : Code) : ReaderT FVarIdSet CompilerM Code := do
+    match c with
+    | .let decl k => return .let decl (← go k)
+    | .fun decl k => return .fun decl (← go k)
+    | .jp decl k =>
+      let value ← go decl.value
+      let type ← value.inferParamType decl.params
+      let decl ← decl.update' type value
+      withReader (fun s => s.insert decl.fvarId) do
+        return .jp decl (← go k)
+    | .cases c =>
+      let alts ← c.alts.mapM fun
+        | .alt ctorName params k => return .alt ctorName params (← go k)
+        | .default k => return .default (← go k)
+      if alts.isEmpty then
+        throwError "`Code.bind` failed, empty `cases` found"
+      let resultType ← mkCasesResultType alts
+      return .cases { c with alts, resultType }
+    | .return fvarId => f fvarId
+    | .jmp fvarId .. =>
+      unless (← read).contains fvarId do
+        throwError "`Code.bind` failed, it contains a out of scope join point"
+      return c
+    | .unreach type =>
+      /-
+      Create an auxiliary parameter `aux : type` to compute the resulting type of `f aux`.
+      This code is not very efficient, we could ask caller to provide the type of `c >>= f`,
+      but this is more convenient, and this case is seldom reached.
+      -/
+      let auxParam ← mkAuxParam type
+      let k ← f auxParam.fvarId
+      let typeNew ← k.inferType
+      eraseCode k
+      eraseParam auxParam
+      return .unreach typeNew
+
+instance : MonadCodeBind CompilerM where
+  codeBind := CompilerM.codeBind
+
+instance [MonadCodeBind m] : MonadCodeBind (ReaderT ρ m) where
+  codeBind c f ctx := c.bind fun fvarId => f fvarId ctx
+
+instance [STWorld ω m] [MonadCodeBind m] : MonadCodeBind (StateRefT' ω σ m) where
+  codeBind c f sref := c.bind fun fvarId => f fvarId sref
+
+/--
+Create new parameters for the given arrow type.
+Example: if `type` is `Nat → Bool → Int`, the result is
+an array containing two new parameters with types `Nat` and `Bool`.
+-/
+partial def mkNewParams (type : Expr) : CompilerM (Array Param) :=
+  go type #[] #[]
+where
+  go (type : Expr) (xs : Array Expr) (ps : Array Param) : CompilerM (Array Param) := do
+    match type with
+    | .forallE _ d b _ =>
+      let d := d.instantiateRev xs
+      let p ← mkAuxParam d
+      go b (xs.push (.fvar p.fvarId)) (ps.push p)
+    | _ =>
+      let type := type.instantiateRev xs
+      let type' := type.headBeta
+      if type' != type then
+        go type' #[] ps
+      else
+        return ps
+
+def isEtaExpandCandidateCore (type : Expr) (params : Array Param) : Bool :=
+  let typeArity := getArrowArity type
+  let valueArity := params.size
+  typeArity > valueArity
+
+abbrev FunDecl.isEtaExpandCandidate (decl : FunDecl) : Bool :=
+  isEtaExpandCandidateCore decl.type decl.params
+
+def etaExpandCore (type : Expr) (params : Array Param) (value : Code) : CompilerM (Array Param × Code) := do
+  let valueType ← instantiateForall type (params.map (mkFVar ·.fvarId))
+  let psNew ← mkNewParams valueType
+  let params := params ++ psNew
+  let xs := psNew.map fun p => .fvar p.fvarId
+  let value ← value.bind fun fvarId => do
+    let auxDecl ← mkAuxLetDecl (.fvar fvarId xs)
+    return .let auxDecl (.return auxDecl.fvarId)
+  return (params, value)
+
+def etaExpandCore? (type : Expr) (params : Array Param) (value : Code) : CompilerM (Option (Array Param × Code)) := do
+  if isEtaExpandCandidateCore type params then
+    etaExpandCore type params value
+  else
+    return none
+
+def FunDecl.etaExpand (decl : FunDecl) : CompilerM FunDecl := do
+  let some (params, value) ← etaExpandCore? decl.type decl.params decl.value | return decl
+  decl.update decl.type params value
+
+def Decl.etaExpand (decl : Decl) : CompilerM Decl := do
+  match decl.value with
+  | .code code =>
+    let some (params, newCode) ← etaExpandCore? decl.type decl.params code | return decl
+    return { decl with params, value := .code newCode}
+  | .extern .. => return decl
+
+end Lean.Compiler.LCNF

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/CSE.lean

@@ -0,0 +1,128 @@
+/-
+Copyright (c) 2022 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Compiler.LCNF.CompilerM
+import Lean.Compiler.LCNF.ToExpr
+import Lean.Compiler.LCNF.PassManager
+import Lean.Compiler.NeverExtractAttr
+
+namespace Lean.Compiler.LCNF
+
+/-! Common Sub-expression Elimination -/
+
+namespace CSE
+
+structure State where
+  map   : PHashMap Expr FVarId := {}
+  subst : FVarSubst := {}
+
+abbrev M := StateRefT State CompilerM
+
+instance : MonadFVarSubst M false where
+  getSubst := return (← get).subst
+
+instance : MonadFVarSubstState M where
+  modifySubst f := modify fun s => { s with subst := f s.subst }
+
+@[inline] def getSubst : M FVarSubst :=
+  return (← get).subst
+
+@[inline] def addEntry (value : Expr) (fvarId : FVarId) : M Unit :=
+  modify fun s => { s with map := s.map.insert value fvarId }
+
+@[inline] def withNewScope (x : M α) : M α := do
+  let map := (← get).map
+  try x finally modify fun s => { s with map }
+
+def replaceLet (decl : LetDecl) (fvarId : FVarId) : M Unit := do
+  eraseLetDecl decl
+  addFVarSubst decl.fvarId fvarId
+
+def replaceFun (decl : FunDecl) (fvarId : FVarId) : M Unit := do
+  eraseFunDecl decl
+  addFVarSubst decl.fvarId fvarId
+
+def hasNeverExtract (v : LetValue) : CompilerM Bool :=
+  match v with
+  | .const declName .. =>
+    return hasNeverExtractAttribute (← getEnv) declName
+  | .lit _ | .erased | .proj .. | .fvar .. =>
+    return false
+
+partial def _root_.Lean.Compiler.LCNF.Code.cse (shouldElimFunDecls : Bool) (code : Code) : CompilerM Code :=
+  go code |>.run' {}
+where
+  goFunDecl (decl : FunDecl) : M FunDecl := do
+    let type ← normExpr decl.type
+    let params ← normParams decl.params
+    let value ← withNewScope do go decl.value
+    decl.update type params value
+
+  go (code : Code) : M Code := do
+    match code with
+    | .let decl k =>
+      let decl ← normLetDecl decl
+      if (← hasNeverExtract decl.value) then
+        return code.updateLet! decl (← go k)
+      else
+        -- We only apply CSE to pure code
+        let key := decl.value.toExpr
+        match (← get).map.find? key with
+        | some fvarId =>
+          replaceLet decl fvarId
+          go k
+        | none =>
+          addEntry key decl.fvarId
+          return code.updateLet! decl (← go k)
+    | .fun decl k =>
+      let decl ← goFunDecl decl
+      if shouldElimFunDecls then
+        let value := decl.toExpr
+        match (← get).map.find? value with
+        | some fvarId' =>
+          replaceFun decl fvarId'
+          go k
+        | none =>
+          addEntry value decl.fvarId
+          return code.updateFun! decl (← go k)
+      else
+        return code.updateFun! decl (← go k)
+    | .jp decl k =>
+      let decl ← goFunDecl decl
+      /-
+       We currently don't eliminate common join points because we want to prevent
+       jumps to out-of-scope join points.
+      -/
+      return code.updateFun! decl (← go k)
+    | .cases c =>
+      withNormFVarResult (← normFVar c.discr) fun discr => do
+        let resultType ← normExpr c.resultType
+        let alts ← c.alts.mapMonoM fun alt => do
+          match alt with
+          | .alt _ ps k => withNewScope do
+            return alt.updateAlt! (← normParams ps) (← go k)
+          | .default k => withNewScope do return alt.updateCode (← go k)
+        return code.updateCases! resultType discr alts
+    | .return fvarId => withNormFVarResult (← normFVar fvarId) fun fvarId => return code.updateReturn! fvarId
+    | .jmp fvarId args => withNormFVarResult (← normFVar fvarId) fun fvarId => return code.updateJmp! fvarId (← normArgs args)
+    | .unreach .. => return code
+
+end CSE
+
+/--
+Common sub-expression elimination
+-/
+def Decl.cse (shouldElimFunDecls : Bool) (decl : Decl) : CompilerM Decl := do
+  let value ← decl.value.mapCodeM (·.cse shouldElimFunDecls)
+  return { decl with value }
+
+def cse (phase : Phase := .base) (shouldElimFunDecls := false) (occurrence := 0) : Pass :=
+  .mkPerDeclaration `cse (Decl.cse shouldElimFunDecls) phase occurrence
+
+builtin_initialize
+  registerTraceClass `Compiler.cse (inherited := true)
+
+end Lean.Compiler.LCNF

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/Check.lean

@@ -0,0 +1,307 @@
+/-
+Copyright (c) 2022 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Compiler.LCNF.InferType
+import Lean.Compiler.LCNF.PrettyPrinter
+import Lean.Compiler.LCNF.CompatibleTypes
+
+namespace Lean.Compiler.LCNF
+
+/-!
+# Note: Type compatibility checking for LCNF
+
+We used to have a type compatibility relation `≃` for LCNF types.
+It treated erased types/values as wildcards. Examples:
+- `List Nat ≃ List ◾`
+- `(List ◾ → List ◾) ≃ (List Nat → List Bool)`
+
+We used this relation to sanity check compiler passes, and detect
+buggy transformations that broke type compatibility. For example,
+given an application `f a`, we would check whether `a`s type as
+compatible with the type expected by `f`.
+
+However, the type compatibility relation is not transitive. Example:
+- `List Nat ≃ List ◾`, `List ◾ ≃ List String`, but `List Nat` and `List String` are **not** compatible.
+
+We tried address the issue above by adding casts, which required us
+to then add `cast` elimination simplifications, and generated a significant overhead in
+the code generator.
+
+Here is an example of transformation that would require the insertion of a cast operation.
+```
+def foo (g : List A → List A) (a : List B) :=
+  fun f (x : List ◾) :=
+    let _x.1 := g x
+    ...
+  let _x.2 := f a
+  ...
+```
+The code above would not trigger any type compatibility issue, but
+by inlining `f` without adding cast operations, we would get the
+following type incorrect code.
+```
+def foo (g : List A → List A) (a : List B) :=
+let _x.2 := g a -- Type error
+...
+```
+
+We have considered using a reflexive and transitive subtype relation `≺`.
+- `A ≺ A`
+- `(Nat × Nat) ≺ (Nat × ◾) ≺ (◾ × ◾) ≺ ◾`
+- `List Nat ≺ List ◾ ⊀ List String`
+- `(List ◾ → List Nat) ≺ (List Bool → List ◾)`
+Note that `A ≺ B` implies `A ≃ B`
+
+The subtype relation has better properties, but also has problems.
+First, when converting to LCNF we would have to add more casts. Example:
+the function takes a `List ◾`, but the value has type `◾`.
+Moreover, recall that `(List Nat → List Nat) ⊀ (◾ → ◾)` forcing us
+to add many casts operations when moving to the mono phase where
+we erase type parameters.
+
+Recall that type compatibility and subtype relationships do not help with memory layout.
+We have that `(UInt32 × UInt32) ≺ (◾ × ◾) ≺ ◾` but elements of these types have
+different runtime representation.
+
+Thus, we have decided to abandon the type compatibility checks and cast operations
+in LCNF. The only drawback is that we lose the capability of catching simple bugs
+at compiler passes.
+
+In the future, we can try to add a sanity check flag that instructs the compiler to use
+the subtype relation in sanity checks and add the necessary casts.
+
+-/
+
+namespace Check
+open InferType
+
+/-
+Type and structural properties checker for LCNF expressions.
+-/
+
+structure Context where
+  /-- Join points that are in scope. -/
+  jps : FVarIdSet := {}
+  /-- Variables and local functions in scope -/
+  vars : FVarIdSet := {}
+
+structure State where
+  /-- All free variables found -/
+  all : FVarIdHashSet := {}
+
+abbrev CheckM := ReaderT Context $ StateRefT State InferTypeM
+
+def checkTypes : CheckM Bool := do
+  return (← getConfig).checkTypes
+
+def checkFVar (fvarId : FVarId) : CheckM Unit :=
+  unless (← read).vars.contains fvarId do
+    throwError "invalid out of scope free variable {← getBinderName fvarId}"
+
+/-- Return true `f` is a constructor and `i` is less than its number of parameters. -/
+def isCtorParam (f : Expr) (i : Nat) : CoreM Bool := do
+  let .const declName _ := f | return false
+  let .ctorInfo info ← getConstInfo declName | return false
+  return i < info.numParams
+
+def checkAppArgs (f : Expr) (args : Array Arg) : CheckM Unit := do
+  let mut fType ← inferType f
+  let mut j := 0
+  for h : i in [:args.size] do
+    let arg := args[i]
+    if fType.isErased then
+      return ()
+    fType := fType.headBeta
+    let (d, b) ←
+      match fType with
+      | .forallE _ d b _ => pure (d, b)
+      | _ =>
+        fType := instantiateRevRangeArgs fType j i args |>.headBeta
+        match fType with
+        | .forallE _ d b _ => j := i; pure (d, b)
+        | _ => return ()
+    let expectedType := instantiateRevRangeArgs d j i args
+    if (← checkTypes) then
+      let argType ← arg.inferType
+      unless (← InferType.compatibleTypes argType expectedType) do
+        throwError "type mismatch at LCNF application{indentExpr (mkAppN f (args.map Arg.toExpr))}\nargument {arg.toExpr} has type{indentExpr argType}\nbut is expected to have type{indentExpr expectedType}"
+    unless (← pure (maybeTypeFormerType expectedType) <||> isErasedCompatible expectedType) do
+      match arg with
+      | .fvar fvarId => checkFVar fvarId
+      | .erased => pure ()
+      | .type _ =>
+        -- Constructor parameters that are not type formers are erased at phase .mono
+        unless (← getPhase) ≥ .mono && (← isCtorParam f i) do
+          throwError "invalid LCNF application{indentExpr (mkAppN f (args.map (·.toExpr)))}\nargument{indentExpr arg.toExpr}\nhas type{indentExpr expectedType}\nmust be a free variable"
+    fType := b
+
+def checkLetValue (e : LetValue) : CheckM Unit := do
+  match e with
+  | .lit .. | .erased => pure ()
+  | .const declName us args => checkAppArgs (mkConst declName us) args
+  | .fvar fvarId args => checkFVar fvarId; checkAppArgs (.fvar fvarId) args
+  | .proj _ _ fvarId => checkFVar fvarId
+
+def checkJpInScope (jp : FVarId) : CheckM Unit := do
+  unless (← read).jps.contains jp do
+    /-
+    We cannot jump to join points defined out of the scope of a local function declaration.
+    For example, the following is an invalid LCNF.
+    ```
+    jp_1 := fun x => ... -- Some join point
+    let f := fun y => -- Local function declaration.
+      ...
+      jp_1 _x.n -- jump to a join point that is not in the scope of `f`.
+    ```
+    -/
+    throwError "invalid jump to out of scope join point `{mkFVar jp}`"
+
+def checkParam (param : Param) : CheckM Unit := do
+  unless param == (← getParam param.fvarId) do
+    throwError "LCNF parameter mismatch at `{param.binderName}`, does not value in local context"
+
+def checkParams (params : Array Param) : CheckM Unit :=
+  params.forM checkParam
+
+def checkLetDecl (letDecl : LetDecl) : CheckM Unit := do
+  checkLetValue letDecl.value
+  if (← checkTypes) then
+    let valueType ← letDecl.value.inferType
+    unless (← InferType.compatibleTypes letDecl.type valueType) do
+      throwError "type mismatch at `{letDecl.binderName}`, value has type{indentExpr valueType}\nbut is expected to have type{indentExpr letDecl.type}"
+  unless letDecl == (← getLetDecl letDecl.fvarId) do
+    throwError "LCNF let declaration mismatch at `{letDecl.binderName}`, does not match value in local context"
+
+def addFVarId (fvarId : FVarId) : CheckM Unit := do
+  if (← get).all.contains fvarId then
+    throwError "invalid LCNF, free variables are not unique `{fvarId.name}`"
+  modify fun s => { s with all := s.all.insert fvarId }
+
+@[inline] def withFVarId (fvarId : FVarId) (x : CheckM α) : CheckM α := do
+  addFVarId fvarId
+  withReader (fun ctx => { ctx with vars := ctx.vars.insert fvarId }) x
+
+@[inline] def withJp (fvarId : FVarId) (x : CheckM α) : CheckM α := do
+  addFVarId fvarId
+  withReader (fun ctx => { ctx with jps := ctx.jps.insert fvarId }) x
+
+@[inline] def withParams (params : Array Param) (x : CheckM α) : CheckM α := do
+  params.forM (addFVarId ·.fvarId)
+  withReader (fun ctx => { ctx with vars := params.foldl (init := ctx.vars) fun vars p => vars.insert p.fvarId })
+    x
+
+mutual
+
+set_option linter.all false
+
+partial def checkFunDeclCore (declName : Name) (params : Array Param) (type : Expr) (value : Code) : CheckM Unit := do
+  checkParams params
+  withParams params do
+    discard <| check value
+    if (← checkTypes) then
+      let valueType ← mkForallParams params (← value.inferType)
+      unless (← InferType.compatibleTypes type valueType) do
+        throwError "type mismatch at `{declName}`, value has type{indentExpr valueType}\nbut is expected to have type{indentExpr type}"
+
+partial def checkFunDecl (funDecl : FunDecl) : CheckM Unit := do
+  checkFunDeclCore funDecl.binderName funDecl.params funDecl.type funDecl.value
+  let decl ← getFunDecl funDecl.fvarId
+  unless decl.binderName == funDecl.binderName do
+    throwError "LCNF local function declaration mismatch at `{funDecl.binderName}`, binder name in local context `{decl.binderName}`"
+  unless decl.type == funDecl.type do
+    throwError "LCNF local function declaration mismatch at `{funDecl.binderName}`, type in local context{indentExpr decl.type}\nexpected{indentExpr funDecl.type}"
+  unless (← getFunDecl funDecl.fvarId) == funDecl do
+    throwError "LCNF local function declaration mismatch at `{funDecl.binderName}`, declaration in local context does match"
+
+partial def checkCases (c : Cases) : CheckM Unit := do
+  let mut ctorNames : NameSet := {}
+  let mut hasDefault := false
+  checkFVar c.discr
+  for alt in c.alts do
+    match alt with
+    | .default k => hasDefault := true; check k
+    | .alt ctorName params k =>
+      checkParams params
+      if ctorNames.contains ctorName then
+        throwError "invalid LCNF `cases`, alternative `{ctorName}` occurs more than once"
+      ctorNames := ctorNames.insert ctorName
+      let .ctorInfo val ← getConstInfo ctorName | throwError "invalid LCNF `cases`, `{ctorName}` is not a constructor name"
+      unless val.induct == c.typeName do
+        throwError "invalid LCNF `cases`, `{ctorName}` is not a constructor of `{c.typeName}`"
+      unless params.size == val.numFields do
+        throwError "invalid LCNF `cases`, `{ctorName}` has # {val.numFields} fields, but alternative has # {params.size} alternatives"
+      withParams params do check k
+
+partial def check (code : Code) : CheckM Unit := do
+  match code with
+  | .let decl k => checkLetDecl decl; withFVarId decl.fvarId do check k
+  | .fun decl k =>
+    -- Remark: local function declarations should not jump to out of scope join points
+    withReader (fun ctx => { ctx with jps := {} }) do checkFunDecl decl
+    withFVarId decl.fvarId do check k
+  | .jp decl k => checkFunDecl decl; withJp decl.fvarId do check k
+  | .cases c => checkCases c
+  | .jmp fvarId args =>
+    checkJpInScope fvarId
+    let decl ← getFunDecl fvarId
+    unless decl.getArity == args.size do
+      throwError "invalid LCNF `goto`, join point {decl.binderName} has #{decl.getArity} parameters, but #{args.size} were provided"
+    checkAppArgs (.fvar fvarId) args
+  | .return fvarId => checkFVar fvarId
+  | .unreach .. => pure ()
+
+end
+
+def run (x : CheckM α) : CompilerM α :=
+  x |>.run {} |>.run' {} |>.run {}
+
+end Check
+
+def Decl.check (decl : Decl) : CompilerM Unit := do
+  Check.run do decl.value.forCodeM (Check.checkFunDeclCore decl.name decl.params decl.type)
+
+/--
+Check whether every local declaration in the local context is used in one of given `decls`.
+-/
+partial def checkDeadLocalDecls (decls : Array Decl) : CompilerM Unit := do
+  let (_, s) := visitDecls decls |>.run {}
+  let usesFVar (binderName : Name) (fvarId : FVarId) :=
+    unless s.contains fvarId do
+      throwError "LCNF local context contains unused local variable declaration `{binderName}`"
+  let lctx := (← get).lctx
+  lctx.params.forM fun fvarId decl => usesFVar decl.binderName fvarId
+  lctx.letDecls.forM fun fvarId decl => usesFVar decl.binderName fvarId
+  lctx.funDecls.forM fun fvarId decl => usesFVar decl.binderName fvarId
+where
+  visitFVar (fvarId : FVarId) : StateM FVarIdHashSet Unit :=
+    modify (·.insert fvarId)
+
+  visitParam (param : Param) : StateM FVarIdHashSet Unit := do
+    visitFVar param.fvarId
+
+  visitParams (params : Array Param) : StateM FVarIdHashSet Unit := do
+    params.forM visitParam
+
+  visitCode (code : Code) : StateM FVarIdHashSet Unit := do
+    match code with
+    | .jmp .. | .return .. | .unreach .. => return ()
+    | .let decl k => visitFVar decl.fvarId; visitCode k
+    | .fun decl k | .jp decl k =>
+      visitFVar decl.fvarId; visitParams decl.params; visitCode decl.value
+      visitCode k
+    | .cases c => c.alts.forM fun alt => do
+      match alt with
+      | .default k => visitCode k
+      | .alt _ ps k => visitParams ps; visitCode k
+
+  visitDecl (decl : Decl) : StateM FVarIdHashSet Unit := do
+    visitParams decl.params
+    decl.value.forCodeM visitCode
+
+  visitDecls (decls : Array Decl) : StateM FVarIdHashSet Unit :=
+    decls.forM visitDecl
+
+end Lean.Compiler.LCNF

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/Closure.lean

@@ -0,0 +1,172 @@
+/-
+Copyright (c) 2022 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Util.ForEachExprWhere
+import Lean.Compiler.LCNF.CompilerM
+
+namespace Lean.Compiler.LCNF
+namespace Closure
+
+/-!
+# Dependency collector for code specialization and lambda lifting.
+
+During code specialization and lambda lifting, we have code `C` containing free variables. These free variables
+are in a scope, and we say we are computing `C`'s closure.
+This module is used to compute the closure.
+-/
+
+structure Context where
+  /--
+  `inScope x` returns `true` if `x` is a variable that is not in `C`.
+  -/
+  inScope : FVarId → Bool
+  /--
+  If `abstract x` returns `true`, we convert `x` into a closure parameter. Otherwise,
+  we collect the dependencies in the `let`/`fun`-declaration too, and include the declaration in the closure.
+  Remark: the lambda lifting pass abstracts all `let`/`fun`-declarations.
+  -/
+  abstract : FVarId → Bool
+  /--
+  Indicates whether we are processing terms beneath a binder.
+  -/
+  isUnderBinder : Bool
+
+/--
+State for the `ClosureM` monad.
+-/
+structure State where
+  /--
+  Set of already visited free variables.
+  -/
+  visited : FVarIdHashSet := {}
+  /--
+  Free variables that must become new parameters of the code being specialized.
+  -/
+  params  : Array Param := #[]
+  /--
+  Let-declarations and local function declarations that are going to be "copied" to the code
+  being processed. For example, when this module is used in the code specializer, the let-declarations
+  often contain the instance values. In the current specialization heuristic all let-declarations are ground values
+  (i.e., they do not contain free-variables).
+  However, local function declarations may contain free variables.
+
+  All customers of this module try to avoid work duplication. If a let-declaration is a ground value,
+  it most likely will be computed during compilation time, and work duplication is not an issue.
+  -/
+  decls   : Array CodeDecl := #[]
+
+/--
+Monad for implementing the dependency collector.
+-/
+abbrev ClosureM := ReaderT Context $ StateRefT State CompilerM
+
+/--
+Mark a free variable as already visited.
+We perform a topological sort over the dependencies.
+-/
+def markVisited (fvarId : FVarId) : ClosureM Unit :=
+  modify fun s => { s with visited := s.visited.insert fvarId }
+
+mutual
+ /--
+  Collect dependencies in parameters. We need this because parameters may
+  contain other type parameters.
+  -/
+  partial def collectParams (params : Array Param) : ClosureM Unit :=
+    params.forM (collectType ·.type)
+
+  partial def collectArg (arg : Arg) : ClosureM Unit :=
+    match arg with
+    | .erased => return ()
+    | .type e => collectType e
+    | .fvar fvarId => collectFVar fvarId
+
+  partial def collectLetValue (e : LetValue) : ClosureM Unit := do
+    match e with
+    | .erased | .lit .. => return ()
+    | .proj _ _ fvarId => collectFVar fvarId
+    | .const _ _ args => args.forM collectArg
+    | .fvar fvarId args => collectFVar fvarId; args.forM collectArg
+
+  /--
+  Collect dependencies in the given code. We need this function to be able
+  to collect dependencies in a local function declaration.
+  -/
+  partial def collectCode (c : Code) : ClosureM Unit := do
+    match c with
+    | .let decl k =>
+      collectType decl.type
+      withReader (fun ctx => { ctx with isUnderBinder := ctx.isUnderBinder || decl.type.isForall })
+        do collectLetValue decl.value
+      collectCode k
+    | .fun decl k | .jp decl k => collectFunDecl decl; collectCode k
+    | .cases c =>
+      collectType c.resultType
+      collectFVar c.discr
+      c.alts.forM fun alt => do
+        match alt with
+        | .default k => collectCode k
+        | .alt _ ps k => collectParams ps; collectCode k
+    | .jmp _ args => args.forM collectArg
+    | .unreach type => collectType type
+    | .return fvarId => collectFVar fvarId
+
+  /-- Collect dependencies of a local function declaration. -/
+  partial def collectFunDecl (decl : FunDecl) : ClosureM Unit := do
+    collectType decl.type
+    collectParams decl.params
+    withReader (fun ctx => { ctx with isUnderBinder := true }) do
+      collectCode decl.value
+
+  /--
+  Process the given free variable.
+  If it has not already been visited and is in scope, we collect its dependencies.
+  -/
+  partial def collectFVar (fvarId : FVarId) : ClosureM Unit := do
+    unless (← get).visited.contains fvarId do
+      markVisited fvarId
+      let ctx ← read
+      if ctx.inScope fvarId then
+        /- We only collect the variables in the scope of the function application being specialized. -/
+        if let some funDecl ← findFunDecl? fvarId then
+          if ctx.isUnderBinder || ctx.abstract funDecl.fvarId then
+            modify fun s => { s with params := s.params.push <| { funDecl with borrow := false } }
+          else
+            collectFunDecl funDecl
+            modify fun s => { s with decls := s.decls.push <| .fun funDecl }
+        else if let some param ← findParam? fvarId then
+          collectType param.type
+          modify fun s => { s with params := s.params.push param }
+        else if let some letDecl ← findLetDecl? fvarId then
+          collectType letDecl.type
+          if ctx.isUnderBinder || ctx.abstract letDecl.fvarId then
+            modify fun s => { s with params := s.params.push <| { letDecl with borrow := false } }
+          else
+            collectLetValue letDecl.value
+            modify fun s => { s with decls := s.decls.push <| .let letDecl }
+        else
+          unreachable!
+
+  /-- Collect dependencies of the given expression. -/
+  partial def collectType (type : Expr) : ClosureM Unit := do
+    type.forEachWhere Expr.isFVar fun e => collectFVar e.fvarId!
+
+end
+
+def run (x : ClosureM α) (inScope : FVarId → Bool) (abstract : FVarId → Bool := fun _ => true) : CompilerM (α × Array Param × Array CodeDecl) := do
+  let (a, s) ← x { inScope, abstract, isUnderBinder := false } |>.run {}
+  -- If we've abstracted an fvar into a param, exclude its definition. Note that this still allows
+  -- for other decls the removed decl depends upon to be included, but they will be removed later
+  -- for having no users.
+  let mut paramFVars : FVarIdSet := {}
+  for param in s.params do
+    paramFVars := paramFVars.insert param.fvarId
+  let filteredDecls := s.decls.filter fun decl => !(paramFVars.contains decl.fvarId)
+  return (a, s.params, filteredDecls)
+
+end Closure
+
+end Lean.Compiler.LCNF

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/CompatibleTypes.lean

@@ -0,0 +1,146 @@
+/-
+Copyright (c) 2022 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Compiler.LCNF.InferType
+
+namespace Lean.Compiler.LCNF
+
+/-!
+# Compatible Types
+
+We used to type check LCNF after each compiler pass. However, we disable this capability because cast management was too costly.
+The casts may be needed to ensure the result of each pass is still typeable.
+However, these sanity checks are useful for catching silly mistakes.
+Thus, we have added an "LCNF type linter". When turned on, this "linter" option instructs the compiler to perform compatibility type checking
+in the LCNF code after some compiler passes.
+Recall most casts are only needed in functions that make heavy use of dependent types.
+We claim it is "defensible" to say this sanity checker is a linter. If the sanity checker fails, it means the user is "abusing" dependent types
+and performance may suffer at runtime.
+Here is an example of code that "abuses" dependent types:
+```
+def Tuple (α : Type u) : Nat → Type u
+  | 0   => PUnit
+  | 1   => α
+  | n+2 => α × Tuple α (n+1)
+
+def mkConstTuple (a : α) : (n : Nat) → Tuple α n
+  | 0 => ⟨⟩
+  | 1 => a
+  | n+2 => (a, mkConstTuple a (n+1))
+
+def Tuple.map (f : α → β) (xs : Tuple α n) : Tuple β n :=
+  match n with
+  | 0 => ⟨⟩
+  | 1 => f xs
+  | _+2 => match xs with
+    | (a, xs) => (f a, Tuple.map f xs)
+```
+-/
+
+
+/--
+Quick check for `compatibleTypes`. It is not monadic, but it is incomplete
+because it does not eta-expand type formers. See comment at `compatibleTypes`.
+Remark: if the result is `true`, then `a` and `b` are indeed compatible.
+If it is `false`, we must use the full-check.
+-/
+partial def compatibleTypesQuick (a b : Expr) : Bool :=
+  if a.isErased || b.isErased then
+    true
+  else
+    let a' := a.headBeta
+    let b' := b.headBeta
+    if a != a' || b != b' then
+      compatibleTypesQuick a' b'
+    else if a == b then
+      true
+    else
+      match a, b with
+      -- Note that even after reducing to head-beta, we can still have `.app` terms. For example,
+      -- an inductive constructor application such as `List Int`
+      | .app f a, .app g b => compatibleTypesQuick f g && compatibleTypesQuick a b
+      | .forallE _ d₁ b₁ _, .forallE _ d₂ b₂ _ => compatibleTypesQuick d₁ d₂ && compatibleTypesQuick b₁ b₂
+      | .lam _ d₁ b₁ _, .lam _ d₂ b₂ _ => compatibleTypesQuick d₁ d₂ && compatibleTypesQuick b₁ b₂
+      | .sort u, .sort v => Level.isEquiv u v
+      | .const n us, .const m vs => n == m && List.isEqv us vs Level.isEquiv
+      | _, _ => false
+
+/--
+Complete check for `compatibleTypes`. It eta-expands type formers. See comment at `compatibleTypes`.
+-/
+partial def InferType.compatibleTypesFull (a b : Expr) : InferTypeM Bool := do
+  if a.isErased || b.isErased then
+    return true
+  else
+    let a' := a.headBeta
+    let b' := b.headBeta
+    if a != a' || b != b' then
+      compatibleTypesFull a' b'
+    else if a == b then
+      return true
+    else
+      match a, b with
+      -- Note that even after reducing to head-beta, we can still have `.app` terms. For example,
+      -- an inductive constructor application such as `List Int`
+      | .app f a, .app g b => compatibleTypesFull f g <&&> compatibleTypesFull a b
+      | .forallE n d₁ b₁ bi, .forallE _ d₂ b₂ _ =>
+        unless (← compatibleTypesFull d₁ d₂) do return false
+        withLocalDecl n d₁ bi fun x =>
+          compatibleTypesFull (b₁.instantiate1 x) (b₂.instantiate1 x)
+      | .lam n d₁ b₁ bi, .lam _ d₂ b₂ _ =>
+        unless (← compatibleTypesFull d₁ d₂) do return false
+        withLocalDecl n d₁ bi fun x =>
+          compatibleTypesFull (b₁.instantiate1 x) (b₂.instantiate1 x)
+      | .sort u, .sort v => return Level.isEquiv u v
+      | .const n us, .const m vs => return n == m && List.isEqv us vs Level.isEquiv
+      | .mdata _ e, _ => compatibleTypesFull e b
+      | _, .mdata _ e => compatibleTypesFull a e
+      | _, _ =>
+        if a.isLambda then
+          let some b ← etaExpand? b | return false
+          compatibleTypesFull a b
+        else if b.isLambda then
+          let some a ← etaExpand? a | return false
+          compatibleTypesFull a b
+        else
+          return false
+where
+  etaExpand? (e : Expr) : InferTypeM (Option Expr) := do
+    match (← inferType e).headBeta with
+    | .forallE n d _ bi =>
+      /-
+      In principle, `.app e (.bvar 0)` may not be a valid LCNF type sub-expression
+      because `d` may not be a type former type, See remark `compatibleTypes` for
+      a justification why this is ok.
+      -/
+      return some (.lam n d (.app e (.bvar 0)) bi)
+    | _ => return none
+
+/--
+Return true if the LCNF types `a` and `b` are compatible.
+Remark: `a` and `b` can be type formers (e.g., `List`, or `fun (α : Type) => Nat → Nat × α`)
+Remark: We may need to eta-expand type formers to establish whether they are compatible or not.
+For example, suppose we have
+```
+fun (x : B) => Id B ◾ ◾
+Id B ◾
+```
+We must eta-expand `Id B ◾` to `fun (x : B) => Id B ◾ x`. Note that, we use `x` instead of `◾` to
+make the implementation simpler and skip the check whether `B` is a type former type. However,
+this simplification should not affect correctness since `◾` is compatible with everything.
+Remark: see comment at `isErasedCompatible`.
+Remark: because of "erasure confusion" see note above, we assume `◾` (aka `lcErasure`) is compatible with everything.
+This is a simplification. We used to use `isErasedCompatible`, but this only address item 1.
+For item 2, we would have to modify the `toLCNFType` function and make sure a type former is erased if the expected
+type is not always a type former (see `S.mk` type and example in the note above).
+-/
+def InferType.compatibleTypes (a b : Expr) : InferTypeM Bool := do
+  if compatibleTypesQuick a b then
+    return true
+  else
+    compatibleTypesFull a b
+
+end Lean.Compiler.LCNF

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/CompilerM.lean

@@ -0,0 +1,504 @@
+/-
+Copyright (c) 2022 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.CoreM
+import Lean.Compiler.LCNF.Basic
+import Lean.Compiler.LCNF.LCtx
+import Lean.Compiler.LCNF.ConfigOptions
+
+namespace Lean.Compiler.LCNF
+/--
+The pipeline phase a certain `Pass` is supposed to happen in.
+-/
+inductive Phase where
+  /-- Here we still carry most of the original type information, most
+  of the dependent portion is already (partially) erased though. -/
+  | base
+  /-- In this phase polymorphism has been eliminated. -/
+  | mono
+  deriving Inhabited
+
+/--
+The state managed by the `CompilerM` `Monad`.
+-/
+structure CompilerM.State where
+  /--
+  A `LocalContext` to store local declarations from let binders
+  and other constructs in as we move through `Expr`s.
+  -/
+  lctx     : LCtx := {}
+  /-- Next auxiliary variable suffix -/
+  nextIdx : Nat := 1
+  deriving Inhabited
+
+structure CompilerM.Context where
+  phase : Phase
+  config : ConfigOptions
+  deriving Inhabited
+
+abbrev CompilerM := ReaderT CompilerM.Context $ StateRefT CompilerM.State CoreM
+
+@[always_inline]
+instance : Monad CompilerM := let i := inferInstanceAs (Monad CompilerM); { pure := i.pure, bind := i.bind }
+
+@[inline] def withPhase (phase : Phase) (x : CompilerM α) : CompilerM α :=
+  withReader (fun ctx => { ctx with phase }) x
+
+def getPhase : CompilerM Phase :=
+  return (← read).phase
+
+def inBasePhase : CompilerM Bool :=
+  return (← getPhase) matches .base
+
+instance : AddMessageContext CompilerM where
+  addMessageContext msgData := do
+    let env ← getEnv
+    let lctx := (← get).lctx.toLocalContext
+    let opts ← getOptions
+    return MessageData.withContext { env, lctx, opts, mctx := {} } msgData
+
+def getType (fvarId : FVarId) : CompilerM Expr := do
+  let lctx := (← get).lctx
+  if let some decl := lctx.letDecls[fvarId]? then
+    return decl.type
+  else if let some decl := lctx.params[fvarId]? then
+    return decl.type
+  else if let some decl := lctx.funDecls[fvarId]? then
+    return decl.type
+  else
+    throwError "unknown free variable {fvarId.name}"
+
+def getBinderName (fvarId : FVarId) : CompilerM Name := do
+  let lctx := (← get).lctx
+  if let some decl := lctx.letDecls[fvarId]? then
+    return decl.binderName
+  else if let some decl := lctx.params[fvarId]? then
+    return decl.binderName
+  else if let some decl := lctx.funDecls[fvarId]? then
+    return decl.binderName
+  else
+    throwError "unknown free variable {fvarId.name}"
+
+def findParam? (fvarId : FVarId) : CompilerM (Option Param) :=
+  return (← get).lctx.params[fvarId]?
+
+def findLetDecl? (fvarId : FVarId) : CompilerM (Option LetDecl) :=
+  return (← get).lctx.letDecls[fvarId]?
+
+def findFunDecl? (fvarId : FVarId) : CompilerM (Option FunDecl) :=
+  return (← get).lctx.funDecls[fvarId]?
+
+def findLetValue? (fvarId : FVarId) : CompilerM (Option LetValue) := do
+  let some { value, .. } ← findLetDecl? fvarId | return none
+  return some value
+
+def isConstructorApp (fvarId : FVarId) : CompilerM Bool := do
+  let some (.const declName _ _) ← findLetValue? fvarId | return false
+  return (← getEnv).find? declName matches some (.ctorInfo ..)
+
+def Arg.isConstructorApp (arg : Arg) : CompilerM Bool := do
+  let .fvar fvarId := arg | return false
+  LCNF.isConstructorApp fvarId
+
+def getParam (fvarId : FVarId) : CompilerM Param := do
+  let some param ← findParam? fvarId | throwError "unknown parameter {fvarId.name}"
+  return param
+
+def getLetDecl (fvarId : FVarId) : CompilerM LetDecl := do
+  let some decl ← findLetDecl? fvarId | throwError "unknown let-declaration {fvarId.name}"
+  return decl
+
+def getFunDecl (fvarId : FVarId) : CompilerM FunDecl := do
+  let some decl ← findFunDecl? fvarId | throwError "unknown local function {fvarId.name}"
+  return decl
+
+@[inline] def modifyLCtx (f : LCtx → LCtx) : CompilerM Unit := do
+   modify fun s => { s with lctx := f s.lctx }
+
+def eraseLetDecl (decl : LetDecl) : CompilerM Unit := do
+  modifyLCtx fun lctx => lctx.eraseLetDecl decl
+
+def eraseFunDecl (decl : FunDecl) (recursive := true) : CompilerM Unit := do
+  modifyLCtx fun lctx => lctx.eraseFunDecl decl recursive
+
+def eraseCode (code : Code) : CompilerM Unit := do
+  modifyLCtx fun lctx => lctx.eraseCode code
+
+def eraseParam (param : Param) : CompilerM Unit :=
+  modifyLCtx fun lctx => lctx.eraseParam param
+
+def eraseParams (params : Array Param) : CompilerM Unit :=
+  modifyLCtx fun lctx => lctx.eraseParams params
+
+def eraseCodeDecl (decl : CodeDecl) : CompilerM Unit := do
+  match decl with
+  | .let decl => eraseLetDecl decl
+  | .jp decl | .fun decl => eraseFunDecl decl
+
+/--
+Erase all free variables occurring in `decls` from the local context.
+-/
+def eraseCodeDecls (decls : Array CodeDecl) : CompilerM Unit := do
+  decls.forM fun decl => eraseCodeDecl decl
+
+def eraseDecl (decl : Decl) : CompilerM Unit := do
+  eraseParams decl.params
+  decl.value.forCodeM eraseCode
+
+abbrev Decl.erase (decl : Decl) : CompilerM Unit :=
+  eraseDecl decl
+
+/--
+A free variable substitution.
+We use these substitutions when inlining definitions and "internalizing" LCNF code into `CompilerM`.
+During the internalization process, we ensure all free variables in the LCNF code do not collide with existing ones
+at the `CompilerM` local context.
+Remark: in LCNF, (computationally relevant) data is in A-normal form, but this is not the case for types and type formers.
+So, when inlining we often want to replace a free variable with a type or type former.
+
+The substitution contains entries `fvarId ↦ e` s.t., `e` is a valid LCNF argument. That is,
+it is a free variable, a type (or type former), or `lcErased`.
+
+`Check.lean` contains a substitution validator.
+-/
+abbrev FVarSubst := Std.HashMap FVarId Arg
+
+/--
+Replace the free variables in `e` using the given substitution.
+
+If `translator = true`, then we assume the free variables occurring in the range of the substitution are in another
+local context. For example, `translator = true` during internalization where we are making sure all free variables
+in a given expression are replaced with new ones that do not collide with the ones in the current local context.
+
+If `translator = false`, we assume the substitution contains free variable replacements in the same local context,
+and given entries such as `x₁ ↦ x₂`, `x₂ ↦ x₃`, ..., `xₙ₋₁ ↦ xₙ`, and the expression `f x₁ x₂`, we want the resulting
+expression to be `f xₙ xₙ`. We use this setting, for example, in the simplifier.
+-/
+private partial def normExprImp (s : FVarSubst) (e : Expr) (translator : Bool) : Expr :=
+  go e
+where
+  goApp (e : Expr) : Expr :=
+    match e with
+    | .app f a => e.updateApp! (goApp f) (go a)
+    | _ => go e
+
+  go (e : Expr) : Expr :=
+    if e.hasFVar then
+      match e with
+      | .fvar fvarId => match s[fvarId]? with
+        | some (.fvar fvarId') => if translator then .fvar fvarId' else go (.fvar fvarId')
+        | some (.type e) => if translator then e else go e
+        | some .erased => erasedExpr
+        | none => e
+      | .lit .. | .const .. | .sort .. | .mvar .. | .bvar .. => e
+      | .app f a => e.updateApp! (goApp f) (go a) |>.headBeta
+      | .mdata _ b => e.updateMData! (go b)
+      | .proj _ _ b => e.updateProj! (go b)
+      | .forallE _ d b _ => e.updateForallE! (go d) (go b)
+      | .lam _ d b _ => e.updateLambdaE! (go d) (go b)
+      | .letE .. => unreachable! -- Valid LCNF does not contain `let`-declarations
+    else
+      e
+
+/--
+Result type for `normFVar` and `normFVarImp`.
+-/
+inductive NormFVarResult where
+  | /-- New free variable. -/
+    fvar (fvarId : FVarId)
+  | /--
+    Free variable has been erased. This can happen when instantiating polymorphic code
+    with computationally irrelevant stuff. -/
+    erased
+  deriving Inhabited
+
+/--
+Normalize the given free variable.
+See `normExprImp` for documentation on the `translator` parameter.
+This function is meant to be used in contexts where the input free-variable is computationally relevant.
+This function panics if the substitution is mapping `fvarId` to an expression that is not another free variable.
+That is, it is not a type (or type former), nor `lcErased`. Recall that a valid `FVarSubst` contains only
+expressions that are free variables, `lcErased`, or type formers.
+-/
+private partial def normFVarImp (s : FVarSubst) (fvarId : FVarId) (translator : Bool) : NormFVarResult :=
+  match s[fvarId]? with
+  | some (.fvar fvarId') =>
+    if translator then
+      .fvar fvarId'
+    else
+      normFVarImp s fvarId' translator
+  -- Types and type formers are only preserved as hints and
+  -- are erased in computationally relevant contexts.
+  | some .erased | some (.type _) => .erased
+  | none => .fvar fvarId
+
+/--
+Replace the free variables in `arg` using the given substitution.
+
+See `normExprImp`
+-/
+private partial def normArgImp (s : FVarSubst) (arg : Arg) (translator : Bool) : Arg :=
+  match arg with
+  | .erased => arg
+  | .fvar fvarId =>
+    match s[fvarId]? with
+    | some (arg'@(.fvar _)) =>
+      if translator then arg' else normArgImp s arg' translator
+    | some (arg'@.erased) | some (arg'@(.type _)) => arg'
+    | none => arg
+  | .type e => arg.updateType! (normExprImp s e translator)
+
+private def normArgsImp (s : FVarSubst) (args : Array Arg) (translator : Bool) : Array Arg :=
+  args.mapMono (normArgImp s · translator)
+
+/--
+Replace the free variables in `e` using the given substitution.
+
+See `normExprImp`
+-/
+private partial def normLetValueImp (s : FVarSubst) (e : LetValue) (translator : Bool) : LetValue :=
+  match e with
+  | .erased | .lit .. => e
+  | .proj _ _ fvarId => match normFVarImp s fvarId translator with
+    | .fvar fvarId' => e.updateProj! fvarId'
+    | .erased => .erased
+  | .const _ _ args => e.updateArgs! (normArgsImp s args translator)
+  | .fvar fvarId args => match normFVarImp s fvarId translator with
+    | .fvar fvarId' => e.updateFVar! fvarId' (normArgsImp s args translator)
+    | .erased => .erased
+
+/--
+Interface for monads that have a free substitutions.
+-/
+class MonadFVarSubst (m : Type → Type) (translator : outParam Bool) where
+  getSubst : m FVarSubst
+
+export MonadFVarSubst (getSubst)
+
+instance (m n) [MonadLift m n] [MonadFVarSubst m t] : MonadFVarSubst n t where
+  getSubst := liftM (getSubst : m _)
+
+class MonadFVarSubstState (m : Type → Type) where
+  modifySubst : (FVarSubst → FVarSubst) → m Unit
+
+export MonadFVarSubstState (modifySubst)
+
+instance (m n) [MonadLift m n] [MonadFVarSubstState m] : MonadFVarSubstState n where
+  modifySubst f := liftM (modifySubst f : m _)
+
+/--
+Add the substitution `fvarId ↦ e`, `e` must be a valid LCNF `Arg`.
+
+See `Check.lean` for the free variable substitution checker.
+-/
+@[inline] def addSubst [MonadFVarSubstState m] (fvarId : FVarId) (arg : Arg) : m Unit :=
+  modifySubst fun s => s.insert fvarId arg
+
+/--
+Add the entry `fvarId ↦ fvarId'` to the free variable substitution.
+-/
+@[inline] def addFVarSubst [MonadFVarSubstState m] (fvarId : FVarId) (fvarId' : FVarId) : m Unit :=
+  modifySubst fun s => s.insert fvarId (.fvar fvarId')
+
+@[inline, inherit_doc normFVarImp] def normFVar [MonadFVarSubst m t] [Monad m] (fvarId : FVarId) : m NormFVarResult :=
+  return normFVarImp (← getSubst) fvarId t
+
+@[inline, inherit_doc normExprImp] def normExpr [MonadFVarSubst m t] [Monad m] (e : Expr) : m Expr :=
+  return normExprImp (← getSubst) e t
+
+@[inline, inherit_doc normArgImp] def normArg [MonadFVarSubst m t] [Monad m] (arg : Arg) : m Arg :=
+  return normArgImp (← getSubst) arg t
+
+@[inline, inherit_doc normLetValueImp] def normLetValue [MonadFVarSubst m t] [Monad m] (e : LetValue) : m LetValue :=
+  return normLetValueImp (← getSubst) e t
+
+@[inherit_doc normExprImp]
+abbrev normExprCore (s : FVarSubst) (e : Expr) (translator : Bool) : Expr :=
+  normExprImp s e translator
+
+/--
+Normalize the given arguments using the current substitution.
+-/
+def normArgs [MonadFVarSubst m t] [Monad m] (args : Array Arg) : m (Array Arg) :=
+  return normArgsImp (← getSubst) args t
+
+def mkFreshBinderName (binderName := `_x): CompilerM Name := do
+  let declName := .num binderName (← get).nextIdx
+  modify fun s => { s with nextIdx := s.nextIdx + 1 }
+  return declName
+
+def ensureNotAnonymous (binderName : Name) (baseName : Name) : CompilerM Name :=
+  if binderName.isAnonymous then
+    mkFreshBinderName baseName
+  else
+    return binderName
+
+/-!
+Helper functions for creating LCNF local declarations.
+-/
+
+def mkParam (binderName : Name) (type : Expr) (borrow : Bool) : CompilerM Param := do
+  let fvarId ← mkFreshFVarId
+  let binderName ← ensureNotAnonymous binderName `_y
+  let param := { fvarId, binderName, type, borrow }
+  modifyLCtx fun lctx => lctx.addParam param
+  return param
+
+def mkLetDecl (binderName : Name) (type : Expr) (value : LetValue) : CompilerM LetDecl := do
+  let fvarId ← mkFreshFVarId
+  let binderName ← ensureNotAnonymous binderName `_x
+  let decl := { fvarId, binderName, type, value }
+  modifyLCtx fun lctx => lctx.addLetDecl decl
+  return decl
+
+def mkFunDecl (binderName : Name) (type : Expr) (params : Array Param) (value : Code) : CompilerM FunDecl := do
+  let fvarId ← mkFreshFVarId
+  let binderName ← ensureNotAnonymous binderName `_f
+  let funDecl := { fvarId, binderName, type, params, value }
+  modifyLCtx fun lctx => lctx.addFunDecl funDecl
+  return funDecl
+
+def mkLetDeclErased : CompilerM LetDecl := do
+  mkLetDecl (← mkFreshBinderName `_x) erasedExpr .erased
+
+def mkReturnErased : CompilerM Code := do
+  let auxDecl ← mkLetDeclErased
+  return .let auxDecl (.return auxDecl.fvarId)
+
+private unsafe def updateParamImp (p : Param) (type : Expr) : CompilerM Param := do
+  if ptrEq type p.type then
+    return p
+  else
+    let p := { p with type }
+    modifyLCtx fun lctx => lctx.addParam p
+    return p
+
+@[implemented_by updateParamImp] opaque Param.update (p : Param) (type : Expr) : CompilerM Param
+
+private unsafe def updateLetDeclImp (decl : LetDecl) (type : Expr) (value : LetValue) : CompilerM LetDecl := do
+  if ptrEq type decl.type && ptrEq value decl.value then
+    return decl
+  else
+    let decl := { decl with type, value }
+    modifyLCtx fun lctx => lctx.addLetDecl decl
+    return decl
+
+@[implemented_by updateLetDeclImp] opaque LetDecl.update (decl : LetDecl) (type : Expr) (value : LetValue) : CompilerM LetDecl
+
+def LetDecl.updateValue (decl : LetDecl) (value : LetValue) : CompilerM LetDecl :=
+  decl.update decl.type value
+
+private unsafe def updateFunDeclImp (decl : FunDecl) (type : Expr) (params : Array Param) (value : Code) : CompilerM FunDecl := do
+  if ptrEq type decl.type && ptrEq params decl.params && ptrEq value decl.value then
+    return decl
+  else
+    let decl := { decl with type, params, value }
+    modifyLCtx fun lctx => lctx.addFunDecl decl
+    return decl
+
+@[implemented_by updateFunDeclImp] opaque FunDecl.update (decl : FunDecl) (type : Expr) (params : Array Param) (value : Code) : CompilerM FunDecl
+
+abbrev FunDecl.update' (decl : FunDecl) (type : Expr) (value : Code) : CompilerM FunDecl :=
+  decl.update type decl.params value
+
+abbrev FunDecl.updateValue (decl : FunDecl) (value : Code) : CompilerM FunDecl :=
+  decl.update decl.type decl.params value
+
+@[inline] def normParam [MonadLiftT CompilerM m] [Monad m] [MonadFVarSubst m t] (p : Param) : m Param := do
+  p.update (← normExpr p.type)
+
+def normParams [MonadLiftT CompilerM m] [Monad m] [MonadFVarSubst m t] (ps : Array Param) : m (Array Param) :=
+  ps.mapMonoM normParam
+
+def normLetDecl [MonadLiftT CompilerM m] [Monad m] [MonadFVarSubst m t] (decl : LetDecl) : m LetDecl := do
+  decl.update (← normExpr decl.type) (← normLetValue decl.value)
+
+abbrev NormalizerM (_translator : Bool) := ReaderT FVarSubst CompilerM
+
+instance : MonadFVarSubst (NormalizerM t) t where
+  getSubst := read
+
+/--
+If `result` is `.fvar fvarId`, then return `x fvarId`. Otherwise, it is `.erased`,
+and method returns `let _x.i := .erased; return _x.i`.
+-/
+@[inline] def withNormFVarResult [MonadLiftT CompilerM m] [Monad m] (result : NormFVarResult) (x : FVarId → m Code) : m Code := do
+  match result with
+  | .fvar fvarId => x fvarId
+  | .erased => mkReturnErased
+
+mutual
+  partial def normFunDeclImp (decl : FunDecl) : NormalizerM t FunDecl  := do
+    let type ← normExpr decl.type
+    let params ← normParams decl.params
+    let value ← normCodeImp decl.value
+    decl.update type params value
+
+  partial def normCodeImp (code : Code) : NormalizerM t Code := do
+    match code with
+    | .let decl k => return code.updateLet! (← normLetDecl decl) (← normCodeImp k)
+    | .fun decl k | .jp decl k => return code.updateFun! (← normFunDeclImp decl) (← normCodeImp k)
+    | .return fvarId => withNormFVarResult (← normFVar fvarId) fun fvarId => return code.updateReturn! fvarId
+    | .jmp fvarId args => withNormFVarResult (← normFVar fvarId) fun fvarId => return code.updateJmp! fvarId (← normArgs args)
+    | .unreach type => return code.updateUnreach! (← normExpr type)
+    | .cases c =>
+      let resultType ← normExpr c.resultType
+      withNormFVarResult (← normFVar c.discr) fun discr => do
+        let alts ← c.alts.mapMonoM fun alt =>
+          match alt with
+          | .alt _ params k => return alt.updateAlt! (← normParams params) (← normCodeImp k)
+          | .default k => return alt.updateCode (← normCodeImp k)
+        return code.updateCases! resultType discr alts
+end
+
+@[inline] def normFunDecl [MonadLiftT CompilerM m] [Monad m] [MonadFVarSubst m t] (decl : FunDecl) : m FunDecl := do
+  normFunDeclImp (t := t) decl (← getSubst)
+
+/-- Similar to `internalize`, but does not refresh `FVarId`s. -/
+@[inline] def normCode [MonadLiftT CompilerM m] [Monad m] [MonadFVarSubst m t] (code : Code) : m Code := do
+  normCodeImp (t := t) code (← getSubst)
+
+def replaceExprFVars (e : Expr) (s : FVarSubst) (translator : Bool) : CompilerM Expr :=
+  (normExpr e : NormalizerM translator Expr).run s
+
+def replaceFVars (code : Code) (s : FVarSubst) (translator : Bool) : CompilerM Code :=
+  (normCode code : NormalizerM translator Code).run s
+
+def mkFreshJpName : CompilerM Name := do
+  mkFreshBinderName `_jp
+
+def mkAuxParam (type : Expr) (borrow := false) : CompilerM Param := do
+  mkParam (← mkFreshBinderName `_y) type borrow
+
+def getConfig : CompilerM ConfigOptions :=
+  return (← read).config
+
+def CompilerM.run (x : CompilerM α) (s : State := {}) (phase : Phase := .base) : CoreM α := do
+  x { phase, config := toConfigOptions (← getOptions) } |>.run' s
+
+/-- Environment extension for local caching of key-value pairs, not persisted in .olean files. -/
+structure CacheExtension (α β : Type) [BEq α] [Hashable α] extends EnvExtension (List α × PHashMap α β)
+deriving Inhabited
+
+namespace CacheExtension
+
+def register [BEq α] [Hashable α] [Inhabited β] :
+    IO (CacheExtension α β) :=
+  CacheExtension.mk <$> registerEnvExtension (pure ([], {})) (asyncMode := .sync)  -- compilation is non-parallel anyway
+    (replay? := some fun oldState newState _ s =>
+      let newEntries := newState.1.take (newState.1.length - oldState.1.length)
+      newEntries.foldl (init := s) fun s e =>
+        (e :: s.1, s.2.insert e (newState.2.find! e)))
+
+def insert [BEq α] [Hashable α] [Inhabited β] (ext : CacheExtension α β) (a : α) (b : β) : CoreM Unit := do
+  modifyEnv (ext.modifyState · fun ⟨as, m⟩ => (a :: as, m.insert a b))
+
+def find? [BEq α] [Hashable α] [Inhabited β] (ext : CacheExtension α β) (a : α) : CoreM (Option β) := do
+  return ext.toEnvExtension.getState (← getEnv) |>.2.find? a
+
+end CacheExtension
+
+end Lean.Compiler.LCNF

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/ConfigOptions.lean

@@ -0,0 +1,67 @@
+/-
+Copyright (c) 2022 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Data.Options
+
+namespace Lean.Compiler.LCNF
+
+/--
+User controlled configuration options for the code generator.
+-/
+structure ConfigOptions where
+  /--
+  Any function declaration or join point with size `≤ smallThresold` is inlined
+  even if there are multiple occurrences.
+  -/
+  smallThreshold : Nat := 1
+  /--
+  Maximum number of times a recursive definition tagged with `[inline]` can be recursively inlined before generating an
+  error during compilation.
+  -/
+  maxRecInline : Nat := 1
+  /--
+  Maximum number of times a recursive definition tagged with `[inline_if_reduce]` can be recursively inlined
+  before generating an error during compilation.
+  -/
+  maxRecInlineIfReduce : Nat := 16
+  /--
+  Perform type compatibility checking after each compiler pass.
+  -/
+  checkTypes : Bool := false
+  deriving Inhabited
+
+register_builtin_option compiler.small : Nat := {
+  defValue := 1
+  group    := "compiler"
+  descr    := "(compiler) function declarations with size `≤ small` is inlined even if there are multiple occurrences."
+}
+
+register_builtin_option compiler.maxRecInline : Nat := {
+  defValue := 1
+  group    := "compiler"
+  descr    := "(compiler) maximum number of times a recursive definition tagged with `[inline]` can be recursively inlined before generating an error during compilation."
+}
+
+register_builtin_option compiler.maxRecInlineIfReduce : Nat := {
+  defValue := 16
+  group    := "compiler"
+  descr    := "(compiler) maximum number of times a recursive definition tagged with `[inline_if_reduce]` can be recursively inlined before generating an error during compilation."
+}
+
+register_builtin_option compiler.checkTypes : Bool := {
+  defValue := false
+  group    := "compiler"
+  descr    := "(compiler) perform type compatibility checking after each compiler pass. Note this is not a complete check, and it is used only for debugging purposes. It fails in code that makes heavy use of dependent types."
+}
+
+def toConfigOptions (opts : Options) : ConfigOptions := {
+  smallThreshold := compiler.small.get opts
+  maxRecInline   := compiler.maxRecInline.get opts
+  maxRecInlineIfReduce := compiler.maxRecInlineIfReduce.get opts
+  checkTypes := compiler.checkTypes.get opts
+}
+
+end Lean.Compiler.LCNF

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/DeclHash.lean

@@ -0,0 +1,44 @@
+/-
+Copyright (c) 2022 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Compiler.LCNF.Basic
+
+namespace Lean.Compiler.LCNF
+
+instance : Hashable Param where
+  hash p := mixHash (hash p.fvarId) (hash p.type)
+
+def hashParams (ps : Array Param) : UInt64 :=
+  hash ps
+
+mutual
+partial def hashAlt (alt : Alt) : UInt64 :=
+  match alt with
+  | .alt ctorName ps k => mixHash (mixHash (hash ctorName) (hash ps)) (hashCode k)
+  | .default k => hashCode k
+
+partial def hashAlts (alts : Array Alt) : UInt64 :=
+  alts.foldl (fun r a => mixHash r (hashAlt a)) 7
+
+partial def hashCode (code : Code) : UInt64 :=
+  match code with
+  | .let decl k => mixHash (mixHash (hash decl.fvarId) (hash decl.type)) (mixHash (hash decl.value) (hashCode k))
+  | .fun decl k | .jp decl k =>
+    mixHash (mixHash (mixHash (hash decl.fvarId) (hash decl.type)) (mixHash (hashCode decl.value) (hashCode k))) (hash decl.params)
+  | .return fvarId => hash fvarId
+  | .unreach type => hash type
+  | .jmp fvarId args => mixHash (hash fvarId) (hash args)
+  | .cases c => mixHash (mixHash (hash c.discr) (hash c.resultType)) (hashAlts c.alts)
+
+end
+
+instance : Hashable Code where
+  hash c := hashCode c
+
+deriving instance Hashable for DeclValue
+deriving instance Hashable for Decl
+
+end Lean.Compiler.LCNF

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/DependsOn.lean

@@ -0,0 +1,62 @@
+/-
+Copyright (c) 2022 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Compiler.LCNF.Basic
+
+namespace Lean.Compiler.LCNF
+
+private abbrev M := ReaderT FVarIdSet Id
+
+private def fvarDepOn (fvarId : FVarId) : M Bool :=
+  return (← read).contains fvarId
+
+private def typeDepOn (e : Expr) : M Bool := do
+  let s ← read
+  return e.hasAnyFVar fun fvarId => s.contains fvarId
+
+private def argDepOn (a : Arg) : M Bool := do
+  match a with
+  | .erased => return false
+  | .fvar fvarId => fvarDepOn fvarId
+  | .type e => typeDepOn e
+
+private def letValueDepOn (e : LetValue) : M Bool :=
+  match e with
+  | .erased | .lit .. => return false
+  | .proj _ _ fvarId => fvarDepOn fvarId
+  | .fvar fvarId args => fvarDepOn fvarId <||> args.anyM argDepOn
+  | .const _ _ args => args.anyM argDepOn
+
+private def LetDecl.depOn (decl : LetDecl) : M Bool :=
+  typeDepOn decl.type <||> letValueDepOn decl.value
+
+private partial def depOn (c : Code) : M Bool :=
+  match c with
+  | .let decl k => decl.depOn <||> depOn k
+  | .jp decl k | .fun decl k => typeDepOn decl.type <||> depOn decl.value <||> depOn k
+  | .cases c => typeDepOn c.resultType <||> fvarDepOn c.discr <||> c.alts.anyM fun alt => depOn alt.getCode
+  | .jmp fvarId args => fvarDepOn fvarId <||> args.anyM argDepOn
+  | .return fvarId => fvarDepOn fvarId
+  | .unreach _ => return false
+
+abbrev LetDecl.dependsOn (decl : LetDecl) (s : FVarIdSet) :  Bool :=
+  decl.depOn s
+
+abbrev FunDecl.dependsOn (decl : FunDecl) (s : FVarIdSet) :  Bool :=
+  typeDepOn decl.type s || depOn decl.value s
+
+def CodeDecl.dependsOn (decl : CodeDecl) (s : FVarIdSet) : Bool :=
+  match decl with
+  | .let decl => decl.dependsOn s
+  | .jp decl | .fun decl => decl.dependsOn s
+
+/--
+Return `true` is `c` depends on a free variable in `s`.
+-/
+def Code.dependsOn (c : Code) (s : FVarIdSet) : Bool :=
+  depOn c s
+
+end Lean.Compiler.LCNF

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/ElimDead.lean

@@ -0,0 +1,100 @@
+/-
+Copyright (c) 2022 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Compiler.LCNF.CompilerM
+
+namespace Lean.Compiler.LCNF
+
+abbrev UsedLocalDecls := FVarIdHashSet
+
+/--
+Collect set of (let) free variables in a LCNF value.
+This code exploits the LCNF property that local declarations do not occur in types.
+-/
+def collectLocalDeclsType (s : UsedLocalDecls) (type : Expr) : UsedLocalDecls :=
+  go s type
+where
+  go (s : UsedLocalDecls) (e : Expr) : UsedLocalDecls :=
+    match e with
+    | .forallE .. => s
+    | .lam _ _ b _ => go s b
+    | .app f a => go (go s a) f
+    | .fvar fvarId => s.insert fvarId
+    | .letE .. | .proj .. | .mdata .. => unreachable! -- Valid LCNF type does not contain this kind of expr
+    | _ => s
+
+def collectLocalDeclsArg (s : UsedLocalDecls) (arg : Arg) : UsedLocalDecls :=
+  match arg with
+  | .erased => s
+  | .type e => collectLocalDeclsType s e
+  | .fvar fvarId => s.insert fvarId
+
+def collectLocalDeclsArgs (s : UsedLocalDecls) (args : Array Arg) : UsedLocalDecls :=
+  args.foldl (init := s) collectLocalDeclsArg
+
+def collectLocalDeclsLetValue (s : UsedLocalDecls) (e : LetValue) : UsedLocalDecls :=
+  match e with
+  | .erased  | .lit .. => s
+  | .proj _ _ fvarId => s.insert fvarId
+  | .const _ _ args => collectLocalDeclsArgs s args
+  | .fvar fvarId args => collectLocalDeclsArgs (s.insert fvarId) args
+
+namespace ElimDead
+
+abbrev M := StateRefT UsedLocalDecls CompilerM
+
+private abbrev collectArgM (arg : Arg) : M Unit :=
+  modify (collectLocalDeclsArg · arg)
+
+private abbrev collectLetValueM (e : LetValue) : M Unit :=
+  modify (collectLocalDeclsLetValue · e)
+
+private abbrev collectFVarM (fvarId : FVarId) : M Unit :=
+  modify (·.insert fvarId)
+
+mutual
+partial def visitFunDecl (funDecl : FunDecl) : M FunDecl := do
+  let value ← elimDead funDecl.value
+  funDecl.updateValue value
+
+partial def elimDead (code : Code) : M Code := do
+  match code with
+  | .let decl k =>
+    let k ← elimDead k
+    if (← get).contains decl.fvarId then
+      /- Remark: we don't need to collect `decl.type` because LCNF local declarations do not occur in types. -/
+      collectLetValueM decl.value
+      return code.updateCont! k
+    else
+      eraseLetDecl decl
+      return k
+  | .fun decl k | .jp decl k =>
+    let k ← elimDead k
+    if (← get).contains decl.fvarId then
+      let decl ← visitFunDecl decl
+      return code.updateFun! decl k
+    else
+      eraseFunDecl decl
+      return k
+  | .cases c =>
+    let alts ← c.alts.mapMonoM fun alt => return alt.updateCode (← elimDead alt.getCode)
+    collectFVarM c.discr
+    return code.updateAlts! alts
+  | .return fvarId => collectFVarM fvarId; return code
+  | .jmp fvarId args => collectFVarM fvarId; args.forM collectArgM; return code
+  | .unreach .. => return code
+
+end
+
+end ElimDead
+
+def Code.elimDead (code : Code) : CompilerM Code :=
+  ElimDead.elimDead code |>.run' {}
+
+def Decl.elimDead (decl : Decl) : CompilerM Decl := do
+  return { decl with value := (← decl.value.mapCodeM Code.elimDead) }
+
+end Lean.Compiler.LCNF

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/ElimDeadBranches.lean

@@ -0,0 +1,630 @@
+/-
+Copyright (c) 2022 Henrik Böving. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Henrik Böving
+-/
+prelude
+import Lean.Compiler.LCNF.CompilerM
+import Lean.Compiler.LCNF.PassManager
+import Lean.Compiler.LCNF.PhaseExt
+import Lean.Compiler.LCNF.InferType
+
+namespace Lean.Compiler.LCNF
+
+namespace UnreachableBranches
+
+/--
+The abstract domain of the interpreter. Representing sets of values
+of a certain type.
+-/
+inductive Value where
+  /--
+  Undefined, could be anything we have no information.
+  -/
+  | bot
+  /--
+  All values are possible.
+  -/
+  | top
+  /--
+  A certain constructor with a certain sets of parameters is possible.
+  -/
+  | ctor (i : Name) (vs : Array Value)
+  /--
+  A set of values are possible.
+  -/
+  | choice (vs : List Value)
+  deriving Inhabited, Repr
+
+namespace Value
+
+-- TODO: parameterize
+def maxValueDepth := 8
+
+protected partial def beq : Value → Value → Bool
+| bot, bot => true
+| top, top => true
+| ctor i1 vs1 , ctor i2 vs2 =>
+  i1 == i2 && Array.isEqv vs1 vs2 Value.beq
+| choice vs1 , choice vs2 =>
+  let isSubset as bs := as.all (fun a => bs.any fun b => Value.beq a b)
+  isSubset vs1 vs2 && isSubset vs2 vs1
+| _, _ => false
+
+instance : BEq Value := ⟨Value.beq⟩
+
+mutual
+
+/--
+Fuse `v` into `vs`. That is do not only append but if we see that `v`
+is a constructor that is already contained within `vs` try to detect
+the difference between these values and merge them accordingly into a
+choice node further down the tree.
+-/
+partial def addChoice (vs : List Value) (v : Value) : List Value :=
+  match vs, v with
+  | [], v => [v]
+  | v1@(ctor i1 _ ) :: cs, ctor i2 _ =>
+    if i1 == i2 then
+      (merge v1 v) :: cs
+    else
+      v1 :: addChoice cs v
+  | _, _ => panic! "invalid addChoice"
+
+/--
+Merge two values into one. `bot` is the neutral element, `top` the annihilator.
+-/
+partial def merge (v1 v2 : Value) : Value :=
+  match v1, v2 with
+  | bot, v | v, bot => v
+  | top, _ | _, top => top
+  | ctor i1 vs1, ctor i2 vs2 =>
+    if i1 == i2 then
+      ctor i1 (Array.zipWith merge vs1 vs2)
+    else
+      choice [v1, v2]
+  | choice vs1, choice vs2 =>
+    choice (vs1.foldl addChoice vs2)
+  | choice vs, v | v, choice vs =>
+    choice (addChoice vs v)
+
+end
+
+/--
+Make sure constructors of recursive inductive datatypes can only occur once in each path.
+Values at depth > `maxValueDepth` are also approximated at `top`.
+We use this function to implement a simple widening operation for our abstract interpreter.
+Recall the widening functions is used to ensure termination in abstract interpreters.
+-/
+partial def truncate (env : Environment) (v : Value) : Value :=
+  go v {} maxValueDepth
+where
+  go (v : Value) (forbiddenTypes : NameSet) (remainingDepth : Nat) :=
+    match remainingDepth with
+    | 0 => top
+    | remainingDepth + 1 =>
+      match v with
+      | ctor i vs =>
+        let typeName := i.getPrefix
+        if forbiddenTypes.contains typeName then
+          top
+        else
+          let cont forbiddenTypes' :=
+            ctor i (vs.map (go · forbiddenTypes' remainingDepth))
+          match env.find? typeName with
+          | some (.inductInfo type) =>
+            if type.isRec then
+              cont <| forbiddenTypes.insert typeName
+            else
+              cont forbiddenTypes
+          | _ => cont forbiddenTypes
+      | choice vs =>
+        let vs := vs.map (go · forbiddenTypes remainingDepth)
+        if vs.elem top then
+          top
+        else
+          choice vs
+      | v => v
+
+/-- Widening operator that guarantees termination in our abstract interpreter. -/
+def widening (env : Environment) (v1 v2 : Value) : Value :=
+  truncate env (merge v1 v2)
+
+/--
+Check whether a certain constructor is part of a `Value` by name.
+Note that both `top` and `bot` will always true here. For bot this is
+because we have no information about the `Value` so just to be sure
+we don't claim the absence of a certain constructor.
+-/
+partial def containsCtor : Value → Name → Bool
+| .top .., _ => true
+| .bot .., _ => true -- we don't know so better be safe than sorry
+| .ctor i ..,  j => i == j
+| .choice vs .., j => vs.any fun v => containsCtor v j
+
+/--
+Obtain the arguments of a certain constructor within the `Value`.
+-/
+partial def getCtorArgs : Value → Name → Option (Array Value)
+| .ctor i args ..,  j => if i == j then some args else none
+| .choice vs .., j => do
+  for variant in vs do
+    if let .ctor i args .. := variant then
+      if i == j then
+        return args
+  none
+| _, _ => none
+
+partial def ofNat (n : Nat) : Value :=
+  if n > maxValueDepth then
+    goBig n n
+  else
+    goSmall n
+where
+  goBig (orig : Nat) (curr : Nat) : Value :=
+    if orig - curr == maxValueDepth then
+      .top
+    else
+      .ctor ``Nat.succ #[goBig orig (curr - 1)]
+  goSmall : Nat → Value
+  | 0 => .ctor ``Nat.zero #[]
+  | n + 1 => .ctor ``Nat.succ #[goSmall n]
+
+def ofLCNFLit : LCNF.LitValue → Value
+| .nat n => ofNat n
+-- TODO: Make this work for other numeric literal types.
+| .uint8 _ | .uint16 _ | .uint32 _ | .uint64 _ | .usize _ => .top
+-- TODO: We could make this much more precise but the payoff is questionable
+| .str .. => .top
+
+partial def proj : Value → Nat → Value
+| .ctor _ vs , i => vs.getD i bot
+| .choice vs, i => vs.foldl (fun r v => merge r (proj v i)) bot
+| v, _ => v
+
+/--
+We say that a `Value` is a literal iff it is only a tree of `Value.ctor`
+nodes.
+-/
+partial def isLiteral : Value → Bool
+| .ctor _ vs => vs.all isLiteral
+| _ => false
+
+/-
+TODO: Add support for "Higher Order Literals", that is literals with
+type parameters.
+-/
+/--
+Attempt to turn a `Value` that is representing a literal into a set of
+auxiliary declarations + the final `FVarId` of the declaration that
+contains the actual literal. If it is not a literal return none.
+-/
+partial def getLiteral (v : Value) : CompilerM (Option ((Array CodeDecl) × FVarId)) := do
+  if isLiteral v then
+    let literal ← go v
+    return some literal
+  else
+    return none
+where
+  go : Value → CompilerM ((Array CodeDecl) × FVarId)
+  | .ctor `Nat.zero #[] .. => do
+    let decl ← mkAuxLetDecl <| .lit <| .nat <| 0
+    return (#[.let decl], decl.fvarId)
+  | .ctor `Nat.succ #[val] .. => do
+    let val := getNatConstant val + 1
+    let decl ← mkAuxLetDecl <| .lit <| .nat <| val
+    return (#[.let decl], decl.fvarId)
+  | .ctor ctorName vs => do
+    let some (.ctorInfo ctorInfo) := (← getEnv).find? ctorName | unreachable!
+    let fields ← vs.mapM go
+    let flatten acc := fun (decls, var) => (acc.fst ++ decls, acc.snd.push <| .fvar var)
+    let (decls, args) :=
+      fields.foldl (init := (#[], Array.replicate ctorInfo.numParams .erased)) flatten
+    let letVal : LetValue := .const ctorName [] args
+    let letDecl ← mkAuxLetDecl letVal
+    return (decls.push <| .let letDecl, letDecl.fvarId)
+  | _ => unreachable!
+
+  getNatConstant : Value → Nat
+  | .ctor `Nat.zero #[] .. => 0
+  | .ctor `Nat.succ #[val] .. => getNatConstant val + 1
+  | _ => panic! "Not a well formed Nat constant Value"
+
+end Value
+
+/--
+A map from function names to the `Value` that the abstract interpreter
+produced for them.
+-/
+abbrev FunctionSummaries := PHashMap Name Value
+
+private abbrev decLt (a b : Name × Value) : Bool :=
+  Name.quickLt a.fst b.fst
+
+private abbrev findAtSorted? (entries : Array (Name × Value)) (fid : Name) : Option Value :=
+  entries.binSearch (fid, default) decLt |>.map Prod.snd
+
+/--
+Storing `FunctionSummaries` for all functions in a `.olean`.
+-/
+builtin_initialize functionSummariesExt : SimplePersistentEnvExtension (Name × Value) FunctionSummaries ←
+  registerSimplePersistentEnvExtension {
+    addImportedFn := fun _ => {}
+    addEntryFn := fun s ⟨e, n⟩ => s.insert e n
+    toArrayFn := fun s => s.toArray.qsort decLt
+    asyncMode := .sync  -- compilation is non-parallel anyway
+    replay? := some <| SimplePersistentEnvExtension.replayOfFilter (!·.contains ·.1) (fun s ⟨e, n⟩ => s.insert e n)
+  }
+
+/--
+Add a `Value` for a function name.
+-/
+def addFunctionSummary (env : Environment) (fid : Name) (v : Value) : Environment :=
+  functionSummariesExt.addEntry (env.addExtraName fid) (fid, v)
+
+/--
+Obtain the `Value` for a function name if possible.
+-/
+def getFunctionSummary? (env : Environment) (fid : Name) : Option Value :=
+  match env.getModuleIdxFor? fid with
+  | some modIdx => findAtSorted? (functionSummariesExt.getModuleEntries env modIdx) fid
+  | none        => functionSummariesExt.getState env |>.find? fid
+
+/--
+A map from variable identifiers to the `Value` produced by the abstract
+interpreter for them.
+-/
+abbrev Assignment := Std.HashMap FVarId Value
+
+/--
+The context of `InterpM`.
+-/
+structure InterpContext where
+  /--
+  The list of `Decl`s we are operating on in `InterpM`. This can be
+  a single declaration or a mutual block of declarations where their
+  analysis might influence each other as we approach the fixpoint.
+  -/
+  decls     : Array Decl
+  /--
+  The index of the function we are currently operating on in `decls.`
+  -/
+  currFnIdx : Nat := 0
+
+structure InterpState where
+  /--
+  `Assignment`s of functions in the `InterpContext`.
+  -/
+  assignments : Array Assignment
+  /--
+  `Value`s of functions in the `InterpContext` use during computation of
+  the fixpoint. Afterwards they are stored into the `Environment`.
+  -/
+  funVals     : PArray Value
+
+/--
+The monad which powers the abstract interpreter.
+-/
+abbrev InterpM := ReaderT InterpContext StateRefT InterpState CompilerM
+
+/--
+Get the variable `Assignment` of the current function.
+-/
+def getAssignment : InterpM Assignment := do
+  return (← get).assignments[(← read).currFnIdx]!
+
+/--
+Get the `Value` of a certain function in the current block by index.
+-/
+def getFunVal (funIdx : Nat) : InterpM Value := do
+  return (← get).funVals[funIdx]!
+
+def findFunVal? (declName : Name) : InterpM (Option Value) := do
+  match (← read).decls.findIdx? (·.name == declName) with
+  | some idx => return some (← getFunVal idx)
+  | none => return none
+
+/--
+Run `f` on the variable `Assignment` of the current function.
+-/
+def modifyAssignment (f : Assignment → Assignment) : InterpM Unit := do
+  let ctx ← read
+  let currFnIdx := ctx.currFnIdx
+  modify fun s => { s with assignments := s.assignments.modify currFnIdx f }
+
+/--
+Obtain the `Value` associated with `var` from the context of `InterpM`.
+If none is available return `Value.bot`.
+-/
+def findVarValue (var : FVarId) : InterpM Value := do
+  let assignment ← getAssignment
+  return assignment.getD var .bot
+
+/--
+Find the value of `arg` using the logic of `findVarValue`.
+-/
+def findArgValue (arg : Arg) : InterpM Value := do
+  match arg with
+  | .fvar fvarId => findVarValue fvarId
+  | _ => return .top
+
+/--
+Update the assignment of `var` by merging the current value with `newVal`.
+-/
+def updateVarAssignment (var : FVarId) (newVal : Value) : InterpM Unit := do
+  let val ← findVarValue var
+  let updatedVal := .merge val newVal
+  modifyAssignment (·.insert var updatedVal)
+
+/--
+Set the value of `var` to `bot`.
+-/
+def resetVarAssignment (var : FVarId) : InterpM Unit := do
+  modifyAssignment (·.insert var .bot)
+
+/--
+Widen the value of the current function by `v`.
+-/
+def updateCurrFnSummary (v : Value) : InterpM Unit := do
+  let ctx ← read
+  let env ← getEnv
+  let currFnIdx := ctx.currFnIdx
+  modify fun s => { s with funVals := s.funVals.modify currFnIdx (fun v' => .widening env v v') }
+
+/--
+Return true if the assignment of at least one parameter has been updated.
+Furthermore if we see that `params.size != args.size` we know that this is
+a partial application and set the values of the remaining parameters to
+`top` since it is impossible to track what will happen with them from here on.
+-/
+def updateFunDeclParamsAssignment (params : Array Param) (args : Array Arg) : InterpM Bool := do
+  let mut ret := false
+  for param in params, arg in args do
+    let paramVal ← findVarValue param.fvarId
+    let argVal ← findArgValue arg
+    let newVal := .merge paramVal argVal
+    if newVal != paramVal then
+      modifyAssignment (·.insert param.fvarId newVal)
+      ret := true
+  /-
+  This is a partial application, we can not know for sure what remaining
+  arguments the local function is getting passed without a much more
+  sophisticated analysis. Hence we will set all of the non applied ones
+  to top.
+  -/
+  if params.size != args.size then
+    for param in params[args.size...*] do
+      ret := (← findVarValue param.fvarId) == .bot
+      updateVarAssignment param.fvarId .top
+  return ret
+
+def updateFunDeclParamsTop (params : Array Param) : InterpM Bool := do
+  let mut ret := false
+  for param in params do
+    let paramVal ← findVarValue param.fvarId
+    let newVal := .top
+    if newVal != paramVal then
+      modifyAssignment (·.insert param.fvarId newVal)
+      ret := true
+  return ret
+
+private partial def resetNestedFunDeclParams : Code → InterpM Unit
+| .let _ k => resetNestedFunDeclParams k
+| .jp decl k | .fun decl k => do
+  decl.params.forM (resetVarAssignment ·.fvarId)
+  /- We don't need to reset the parameters of decls
+    nested in this one since they will be reset if this decl is used. -/
+  resetNestedFunDeclParams k
+| .cases cs =>
+  cs.alts.forM (resetNestedFunDeclParams ·.getCode)
+| .return .. | .unreach .. | .jmp .. => return ()
+
+/--
+The actual abstract interpreter on a block of `Code`.
+-/
+partial def interpCode : Code → InterpM Unit
+| .let decl k => do
+  let val ← interpLetValue decl.value
+  updateVarAssignment decl.fvarId val
+  if let .fvar fvarId args := decl.value then
+    if let some funDecl ← findFunDecl? fvarId then
+      -- TODO: unclear how much we should reset in the case of partial applications
+      interpFunCall funDecl args
+  interpCode k
+| .jp decl k | .fun decl k => do
+  interpCode decl.value
+  interpCode k
+| .jmp fn args => do
+  let jp ← getFunDecl fn
+  args.forM handleFunArg
+  interpFunCall jp args
+| .cases cs => do
+  let discrVal ← findVarValue cs.discr
+  for alt in cs.alts do
+    match alt with
+    | .alt ctor params body =>
+      if let some argValues := discrVal.getCtorArgs ctor then
+        params.zip argValues |>.forM (fun (param, val) => updateVarAssignment param.fvarId val)
+      else
+        params.forM (updateVarAssignment ·.fvarId .top)
+      interpCode body
+    | .default body => interpCode body
+| .return var => do
+  handleFunVar var
+  let val ← findVarValue var
+  updateCurrFnSummary val
+| .unreach .. => return ()
+where
+  /--
+  The abstract interpreter on a `LetValue`.
+  -/
+  interpLetValue (letVal : LetValue) : InterpM Value := do
+    match letVal with
+    | .lit val => return .ofLCNFLit val
+    | .proj _ idx struct => return (← findVarValue struct).proj idx
+    | .const declName _ args =>
+      let env ← getEnv
+      args.forM handleFunArg
+      match (← getDecl? declName) with
+      | some decl =>
+        if decl.getArity == args.size then
+          match getFunctionSummary? env declName with
+          | some v => return v
+          | none => return (← findFunVal? declName).getD .top
+        else
+          return .top
+      | none =>
+        let some (.ctorInfo info) := env.find? declName | return .top
+        let args := args[info.numParams...*].toArray
+        if info.numFields == args.size then
+          return .ctor declName (← args.mapM findArgValue)
+        else
+          return .top
+    | .fvar _ args =>
+      args.forM handleFunArg
+      /-
+      Since free variables in `LetValue`s cannot be of the form
+      `let x := y` after a simplifier pass we know they are in fact a
+      partially applied function, we cannot know anything about the result
+      of a partially applied function.
+      -/
+      return .top
+    | .erased => return .top
+
+  handleFunArg (arg : Arg) : InterpM Unit := do
+    if let .fvar fvarId := arg then
+      handleFunVar fvarId
+
+  /--
+  If we see a function being passed as an argument to a higher order
+  function we cannot know what arguments it will be passed further
+  down the line. Hence we set all of its arguments to `top` since anything
+  is possible.
+  -/
+  handleFunVar (var : FVarId) : InterpM Unit := do
+    if let some funDecl ← findFunDecl? var then
+      let updated ← updateFunDeclParamsTop funDecl.params
+      if updated then
+        /- We must reset the value of nested function declaration
+        parameters since they depend on `args` values. -/
+        resetNestedFunDeclParams funDecl.value
+        interpCode funDecl.value
+
+  interpFunCall (funDecl : FunDecl) (args : Array Arg) : InterpM Unit := do
+    let updated ← updateFunDeclParamsAssignment funDecl.params args
+    if updated then
+      /- We must reset the value of nested function declaration
+      parameters since they depend on `args` values. -/
+      resetNestedFunDeclParams funDecl.value
+      interpCode funDecl.value
+
+
+/--
+Rerun the abstract interpreter on all declarations except of the unsafe
+ones. Return whether any `Value` got updated in the process.
+-/
+def inferStep : InterpM Bool := do
+  let ctx ← read
+  for h : idx in [0:ctx.decls.size] do
+    let decl := ctx.decls[idx]
+    if !decl.safe then
+      continue
+
+    let currentVal ← getFunVal idx
+    withReader (fun ctx => { ctx with currFnIdx := idx }) do
+      decl.params.forM fun p => updateVarAssignment p.fvarId .top
+      match decl.value with
+      | .code code .. => interpCode code
+      | .extern .. => updateCurrFnSummary .top
+    let newVal ← getFunVal idx
+    if currentVal != newVal then
+      return true
+  return false
+
+/--
+Run `inferStep` until it reaches a fix point.
+-/
+partial def inferMain : InterpM Unit := do
+  let ctx ← read
+  modify fun s => { s with assignments := ctx.decls.map fun _ => {} }
+  let modified ← inferStep
+  if modified then
+    inferMain
+  else
+    return ()
+
+/--
+Use the information produced by the abstract interpreter to:
+- Eliminate branches that we know cannot be hit
+- Eliminate values that we know have to be constants.
+-/
+partial def elimDead (assignment : Assignment) (decl : Decl) : CompilerM Decl := do
+  trace[Compiler.elimDeadBranches] s!"Eliminating {decl.name} with {repr (← assignment.toArray |>.mapM (fun (name, val) => do return (toString (← getBinderName name), val)))}"
+  return { decl with value := (← decl.value.mapCodeM go) }
+where
+  go (code : Code) : CompilerM Code := do
+    match code with
+    | .let decl k =>
+      return code.updateLet! decl (← go k)
+    | .jp decl k | .fun decl k =>
+      return code.updateFun! (← decl.updateValue (← go decl.value)) (← go k)
+    | .cases cs =>
+      let discrVal := assignment.getD cs.discr .bot
+      let processAlt typ alt := do
+        match alt with
+        | .alt ctor args body =>
+          if discrVal.containsCtor ctor then
+            let filter param := do
+              if let some val := assignment[param.fvarId]? then
+                if let some literal ← val.getLiteral then
+                  return some (param, literal)
+              return none
+            let constantInfos ← args.filterMapM filter
+            if constantInfos.size != 0 then
+              let folder := fun (body, subst) (param, decls, var) => do
+                return (attachCodeDecls decls body, subst.insert param.fvarId (.fvar var))
+              let (body, subst) ← constantInfos.foldlM (init := (← go body, {})) folder
+              let body ← replaceFVars body subst false
+              return alt.updateCode body
+            else
+              return alt.updateCode (← go body)
+          else
+            trace[Compiler.elimDeadBranches] s!"Threw away cases {← getBinderName cs.discr} branch {ctor}"
+            eraseCode alt.getCode
+            return alt.updateCode <| .unreach typ
+        | .default body => return alt.updateCode (← go body)
+      return code.updateCases! cs.resultType cs.discr (← cs.alts.mapM <| processAlt cs.resultType)
+    | .jmp .. | .return .. | .unreach .. => return code
+
+end UnreachableBranches
+
+open UnreachableBranches in
+def Decl.elimDeadBranches (decls : Array Decl) : CompilerM (Array Decl) := do
+  let mut assignments := decls.map fun _ => {}
+  let initialVal i :=
+    /-
+    Non terminating functions are marked as unsafe, we don't want to run
+    any analysis on them since we cannot be sure they will ever return
+    the constructor that we inferred for them. For more information
+    refer to the docstring of `Decl.safe`.
+    -/
+    if decls[i]!.safe then .bot else .top
+  let mut funVals := decls.size.fold (init := .empty) fun i _ p => p.push (initialVal i)
+  let ctx := { decls }
+  let mut state := { assignments, funVals }
+  (_, state) ← inferMain |>.run ctx |>.run state
+  funVals := state.funVals
+  assignments := state.assignments
+  modifyEnv fun e =>
+    decls.size.fold (init := e) fun i _ env =>
+      addFunctionSummary env decls[i].name funVals[i]!
+
+  decls.mapIdxM fun i decl => if decl.safe then elimDead assignments[i]! decl else return decl
+
+def elimDeadBranches : Pass :=
+  { name := `elimDeadBranches, run := Decl.elimDeadBranches, phase := .mono }
+
+builtin_initialize
+  registerTraceClass `Compiler.elimDeadBranches (inherited := true)
+
+end Lean.Compiler.LCNF

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/ExtractClosed.lean

@@ -0,0 +1,161 @@
+/-
+Copyright (c) 2025 Lean FRO, LLC. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Cameron Zwarich
+-/
+prelude
+import Lean.Compiler.ClosedTermCache
+import Lean.Compiler.NeverExtractAttr
+import Lean.Compiler.LCNF.Basic
+import Lean.Compiler.LCNF.InferType
+import Lean.Compiler.LCNF.Internalize
+import Lean.Compiler.LCNF.MonoTypes
+import Lean.Compiler.LCNF.PassManager
+import Lean.Compiler.LCNF.ToExpr
+
+namespace Lean.Compiler.LCNF
+namespace ExtractClosed
+
+abbrev ExtractM := StateRefT (Array CodeDecl) CompilerM
+
+mutual
+
+partial def extractLetValue (v : LetValue) : ExtractM Unit := do
+  match v with
+  | .const _ _ args => args.forM extractArg
+  | .fvar fnVar args =>
+    extractFVar fnVar
+    args.forM extractArg
+  | .proj _ _ baseVar => extractFVar baseVar
+  | .lit _ | .erased => return ()
+
+partial def extractArg (arg : Arg) : ExtractM Unit := do
+  match arg with
+  | .fvar fvarId => extractFVar fvarId
+  | .type _ | .erased => return ()
+
+partial def extractFVar (fvarId : FVarId) : ExtractM Unit := do
+  if let some letDecl ← findLetDecl? fvarId then
+    modify fun decls => decls.push (.let letDecl)
+    extractLetValue letDecl.value
+
+end
+
+def isIrrelevantArg (arg : Arg) : Bool :=
+  match arg with
+  | .erased | .type _ => true
+  | .fvar _ => false
+
+structure Context where
+  baseName : Name
+  sccDecls : Array Decl
+
+structure State where
+  decls : Array Decl := {}
+
+abbrev M := ReaderT Context $ StateRefT State CompilerM
+
+mutual
+
+partial def shouldExtractLetValue (isRoot : Bool) (v : LetValue) : M Bool := do
+  match v with
+  | .lit (.str _) => return true
+  | .lit (.nat v) =>
+    -- The old compiler's implementation used the runtime's `is_scalar` function, which
+    -- introduces a dependency on the architecture used by the compiler.
+    return !isRoot || v >= Nat.pow 2 63
+  | .lit _ | .erased => return !isRoot
+  | .const name _ args =>
+    if (← read).sccDecls.any (·.name == name) then
+      return false
+    if hasNeverExtractAttribute (← getEnv) name then
+      return false
+    if isRoot then
+      if let some constInfo := (← getEnv).find? name then
+        let shouldExtract := match constInfo with
+        | .defnInfo val => val.type.isForall
+        | .ctorInfo _ => !(args.all isIrrelevantArg)
+        | _ => true
+        if !shouldExtract then
+          return false
+    args.allM shouldExtractArg
+  | .fvar fnVar args => return (← shouldExtractFVar fnVar) && (← args.allM shouldExtractArg)
+  | .proj _ _ baseVar => shouldExtractFVar baseVar
+
+partial def shouldExtractArg (arg : Arg) : M Bool := do
+  match arg with
+  | .fvar fvarId => shouldExtractFVar fvarId
+  | .type _ | .erased => return true
+
+partial def shouldExtractFVar (fvarId : FVarId) : M Bool := do
+  if let some letDecl ← findLetDecl? fvarId then
+    shouldExtractLetValue false letDecl.value
+  else
+    return false
+
+end
+
+mutual
+
+partial def visitCode (code : Code) : M Code := do
+  match code with
+  | .let decl k =>
+    if (← shouldExtractLetValue true decl.value) then
+      let ⟨_, decls⟩ ← extractLetValue decl.value |>.run {}
+      let decls := decls.reverse.push (.let decl)
+      let decls ← decls.mapM Internalize.internalizeCodeDecl |>.run' {}
+      let closedCode := attachCodeDecls decls (.return decls.back!.fvarId)
+      let closedExpr := closedCode.toExpr
+      let env ← getEnv
+      let name ← if let some closedTermName := getClosedTermName? env closedExpr then
+        eraseCode closedCode
+        pure closedTermName
+      else
+        let name := (← read).baseName ++ (`_closed).appendIndexAfter (← get).decls.size
+        cacheClosedTermName env closedExpr name |> setEnv
+        let decl := { name, levelParams := [], type := decl.type, params := #[],
+                      value := .code closedCode, inlineAttr? := some .noinline }
+        decl.saveMono
+        modify fun s => { s with decls := s.decls.push decl }
+        pure name
+      let decl ← decl.updateValue (.const name [] #[])
+      return code.updateLet! decl (← visitCode k)
+    else
+      return code.updateLet! decl (← visitCode k)
+  | .fun decl k =>
+    let decl ← decl.updateValue (← visitCode decl.value)
+    return code.updateFun! decl (← visitCode k)
+  | .jp decl k =>
+    let decl ← decl.updateValue (← visitCode decl.value)
+    return code.updateFun! decl (← visitCode k)
+  | .cases cases =>
+    let alts ← cases.alts.mapM (fun alt => do return alt.updateCode (← visitCode alt.getCode))
+    return code.updateAlts! alts
+  | .jmp .. | .return _ | .unreach .. => return code
+
+end
+
+def visitDecl (decl : Decl) : M Decl := do
+  let value ← decl.value.mapCodeM visitCode
+  return { decl with value }
+
+end ExtractClosed
+
+partial def Decl.extractClosed (decl : Decl) (sccDecls : Array Decl) : CompilerM (Array Decl) := do
+  let ⟨decl, s⟩ ← ExtractClosed.visitDecl decl |>.run { baseName := decl.name, sccDecls } |>.run {}
+  return s.decls.push decl
+
+def extractClosed : Pass where
+  phase := .mono
+  name := `extractClosed
+  run := fun decls => do
+    -- Reuse the option from the old compiler for now.
+    if (← getOptions).getBool `compiler.extract_closed true then
+      decls.foldlM (init := #[]) fun newDecls decl =>
+        return newDecls ++ (← decl.extractClosed decls)
+    else
+      return decls
+
+builtin_initialize registerTraceClass `Compiler.extractClosed (inherited := true)
+
+end Lean.Compiler.LCNF

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/FVarUtil.lean

@@ -0,0 +1,213 @@
+/-
+Copyright (c) 2022 Henrik Böving. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Henrik Böving
+-/
+prelude
+import Lean.Expr
+import Lean.Compiler.LCNF.Basic
+import Lean.Compiler.LCNF.CompilerM
+
+namespace Lean.Compiler.LCNF
+
+class TraverseFVar (α : Type) where
+  mapFVarM {m : Type → Type} [MonadLiftT CompilerM m] [Monad m] (f : FVarId → m FVarId) (val : α) : m α
+  forFVarM {m : Type → Type} [Monad m] (f : FVarId → m Unit) (val : α) : m Unit
+
+export TraverseFVar (mapFVarM forFVarM)
+
+partial def Expr.mapFVarM [MonadLiftT CompilerM m] [Monad m] (f : FVarId → m FVarId) (e : Expr) : m Expr := do
+  match e with
+  | .app fn arg => return e.updateApp! (← mapFVarM f fn) (← mapFVarM f arg)
+  | .fvar fvarId => return e.updateFVar! (← f fvarId)
+  | .lam _ ty body _ => return e.updateLambdaE! (← mapFVarM f ty) (← mapFVarM f body)
+  | .forallE _ ty body _ => return e.updateForallE! (← mapFVarM f ty) (← mapFVarM f body)
+  | .bvar .. | .sort .. => return e
+  | .mdata .. | .const .. | .lit .. => return e
+  | .letE ..  | .proj .. | .mvar .. => unreachable! -- LCNF types do not have this kind of expr
+
+partial def Expr.forFVarM [Monad m] (f : FVarId → m Unit) (e : Expr) : m Unit := do
+  match e with
+  | .app fn arg =>
+    forFVarM f fn
+    forFVarM f arg
+  | .fvar fvarId => f fvarId
+  | .lam _ ty body .. =>
+    forFVarM f ty
+    forFVarM f body
+  | .forallE _ ty body .. =>
+    forFVarM f ty
+    forFVarM f body
+  | .bvar .. | .sort .. => return
+  | .mdata .. | .const .. | .lit .. => return
+  | .mvar .. | .letE .. | .proj .. => unreachable! -- LCNF types do not have this kind of expr
+
+instance : TraverseFVar Expr where
+  mapFVarM := Expr.mapFVarM
+  forFVarM := Expr.forFVarM
+
+def Arg.mapFVarM [MonadLiftT CompilerM m] [Monad m] (f : FVarId → m FVarId) (arg : Arg) : m Arg := do
+  match arg with
+  | .erased => return .erased
+  | .type e => return arg.updateType! (← TraverseFVar.mapFVarM f e)
+  | .fvar fvarId => return arg.updateFVar! (← f fvarId)
+
+def Arg.forFVarM [Monad m] (f : FVarId → m Unit) (arg : Arg) : m Unit := do
+  match arg with
+  | .erased => return ()
+  | .type e => TraverseFVar.forFVarM f e
+  | .fvar fvarId => f fvarId
+
+instance : TraverseFVar Arg where
+  mapFVarM := Arg.mapFVarM
+  forFVarM := Arg.forFVarM
+
+def LetValue.mapFVarM [MonadLiftT CompilerM m] [Monad m] (f : FVarId → m FVarId) (e : LetValue) : m LetValue := do
+  match e with
+  | .lit .. | .erased => return e
+  | .proj _ _ fvarId => return e.updateProj! (← f fvarId)
+  | .const _ _ args => return e.updateArgs! (← args.mapM (TraverseFVar.mapFVarM f))
+  | .fvar fvarId args => return e.updateFVar! (← f fvarId) (← args.mapM (TraverseFVar.mapFVarM f))
+
+def LetValue.forFVarM [Monad m] (f : FVarId → m Unit) (e : LetValue) : m Unit := do
+  match e with
+  | .lit .. | .erased => return ()
+  | .proj _ _ fvarId => f fvarId
+  | .const _ _ args => args.forM (TraverseFVar.forFVarM f)
+  | .fvar fvarId args => f fvarId; args.forM (TraverseFVar.forFVarM f)
+
+instance : TraverseFVar LetValue where
+  mapFVarM := LetValue.mapFVarM
+  forFVarM := LetValue.forFVarM
+
+partial def LetDecl.mapFVarM [MonadLiftT CompilerM m] [Monad m] (f : FVarId → m FVarId) (decl : LetDecl) : m LetDecl := do
+  decl.update (← Expr.mapFVarM f decl.type) (← LetValue.mapFVarM f decl.value)
+
+partial def LetDecl.forFVarM [Monad m] (f : FVarId → m Unit) (decl : LetDecl) : m Unit := do
+  Expr.forFVarM f decl.type
+  LetValue.forFVarM f decl.value
+
+instance : TraverseFVar LetDecl where
+  mapFVarM := LetDecl.mapFVarM
+  forFVarM := LetDecl.forFVarM
+
+partial def Param.mapFVarM [MonadLiftT CompilerM m] [Monad m] (f : FVarId → m FVarId) (param : Param) : m Param := do
+  param.update (← Expr.mapFVarM f param.type)
+
+partial def Param.forFVarM [Monad m] (f : FVarId → m Unit) (param : Param) : m Unit := do
+  Expr.forFVarM f param.type
+
+instance : TraverseFVar Param where
+  mapFVarM := Param.mapFVarM
+  forFVarM := Param.forFVarM
+
+partial def Code.mapFVarM [MonadLiftT CompilerM m] [Monad m] (f : FVarId → m FVarId) (c : Code) : m Code := do
+  match c with
+  | .let decl k =>
+    let decl ← LetDecl.mapFVarM f decl
+    return Code.updateLet! c decl (← mapFVarM f k)
+  | .fun decl k =>
+    let params ← decl.params.mapM (Param.mapFVarM f)
+    let decl ← decl.update (← Expr.mapFVarM f decl.type) params (← mapFVarM f decl.value)
+    return Code.updateFun! c decl (← mapFVarM f k)
+  | .jp decl k =>
+    let params ← decl.params.mapM (Param.mapFVarM f)
+    let decl ← decl.update (← Expr.mapFVarM f decl.type) params (← mapFVarM f decl.value)
+    return Code.updateFun! c decl (← mapFVarM f k)
+  | .cases cs =>
+    return Code.updateCases! c (← Expr.mapFVarM f cs.resultType) (← f cs.discr) (← cs.alts.mapM (·.mapCodeM (mapFVarM f)))
+  | .jmp fn args =>
+    return Code.updateJmp! c (← f fn) (← args.mapM (Arg.mapFVarM f))
+  | .return var =>
+    return Code.updateReturn! c (← f var)
+  | .unreach typ =>
+    return Code.updateUnreach! c (← Expr.mapFVarM f typ)
+
+partial def Code.forFVarM [Monad m] (f : FVarId → m Unit) (c : Code) : m Unit := do
+  match c with
+  | .let decl k =>
+    LetDecl.forFVarM f decl
+    forFVarM f k
+  | .fun decl k =>
+    decl.params.forM (Param.forFVarM f)
+    Expr.forFVarM f decl.type
+    forFVarM f decl.value
+    forFVarM f k
+  | .jp decl k =>
+    decl.params.forM (Param.forFVarM f)
+    Expr.forFVarM f decl.type
+    forFVarM f decl.value
+    forFVarM f k
+  | .cases cs =>
+    Expr.forFVarM f cs.resultType
+    f cs.discr
+    cs.alts.forM (·.forCodeM (forFVarM f))
+  | .jmp fn args =>
+    f fn
+    args.forM (Arg.forFVarM f)
+  | .return var => f var
+  | .unreach typ =>
+    Expr.forFVarM f typ
+
+instance : TraverseFVar Code where
+  mapFVarM := Code.mapFVarM
+  forFVarM := Code.forFVarM
+
+def FunDecl.mapFVarM [MonadLiftT CompilerM m] [Monad m] (f : FVarId → m FVarId) (decl : FunDecl) : m FunDecl := do
+  let params ← decl.params.mapM (Param.mapFVarM f)
+  decl.update (← Expr.mapFVarM f decl.type) params (← Code.mapFVarM f decl.value)
+
+def FunDecl.forFVarM [Monad m] (f : FVarId → m Unit) (decl : FunDecl) : m Unit := do
+  decl.params.forM (Param.forFVarM f)
+  Expr.forFVarM f decl.type
+  Code.forFVarM f decl.value
+
+instance : TraverseFVar FunDecl where
+  mapFVarM := FunDecl.mapFVarM
+  forFVarM := FunDecl.forFVarM
+
+instance : TraverseFVar CodeDecl where
+  mapFVarM f decl := do
+    match decl with
+    | .fun decl => return .fun (← mapFVarM f decl)
+    | .jp decl => return .jp (← mapFVarM f decl)
+    | .let decl => return .let (← mapFVarM f decl)
+  forFVarM f decl :=
+    match decl with
+    | .fun decl => forFVarM f decl
+    | .jp decl => forFVarM f decl
+    | .let decl => forFVarM f decl
+
+instance : TraverseFVar Alt where
+  mapFVarM f alt := do
+    match alt with
+    | .alt ctor params c =>
+      let params ← params.mapM (Param.mapFVarM f)
+      return .alt ctor params (← Code.mapFVarM f c)
+    | .default c => return .default (← Code.mapFVarM f c)
+  forFVarM f alt := do
+    match alt with
+    | .alt _ params c =>
+      params.forM (Param.forFVarM f)
+      Code.forFVarM f c
+    | .default c => Code.forFVarM f c
+
+def anyFVarM [Monad m] [TraverseFVar α] (f : FVarId → m Bool) (x : α) : m Bool := do
+  return (← TraverseFVar.forFVarM go x |>.run) matches none
+where
+  go (fvar : FVarId) : OptionT m Unit := do
+    if (← f fvar) then failure
+
+def allFVarM [Monad m] [TraverseFVar α] (f : FVarId → m Bool) (x : α) : m Bool := do
+  return (← TraverseFVar.forFVarM go x |>.run) matches .some ..
+where
+  go (fvar : FVarId) : OptionT m Unit := do
+    if !(← f fvar) then failure
+
+def anyFVar [TraverseFVar α] (f : FVarId → Bool) (x : α) : Bool :=
+  Id.run <| anyFVarM (pure <| f ·) x
+
+def allFVar [TraverseFVar α] (f : FVarId → Bool) (x : α) : Bool :=
+  Id.run <| allFVarM (pure <| f ·) x
+
+end Lean.Compiler.LCNF

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/FixedParams.lean

@@ -0,0 +1,181 @@
+/-
+Copyright (c) 2022 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Compiler.LCNF.Basic
+import Lean.Compiler.LCNF.Types
+
+namespace Lean.Compiler.LCNF
+namespace FixedParams
+
+/-! # Fixed Parameter Static Analyzer -/
+
+/-
+If function is partially applied, we assume missing parameters are not fixed.
+Note that, since LCNF is in A-normal form, if function is used as an argument, none of its parameters
+will be considered fixed.
+
+We assume functions that are not in mutual block do not invoke the function being
+analyzed.
+
+We track fixed arguments using "abstract values". They are just a "token" or ⊤.
+We can view it as a form of constant propagation.
+
+When analyzing a function call to another function in the same mutual block,
+we visit its body after binding its parameters to "abstract values". We keep a cache
+of the already visited pairs ("declName", "abstract values").
+
+Whenever, we find a recursive call to the function being analyzed, we check whether
+the arguments match the initial "abstract values".
+
+We interrupt the analysis if all parameters of the function being analyzed have been
+marked as not fixed.
+-/
+
+/-- Abstract value for the "fixed parameter" analysis. -/
+inductive AbsValue where
+  | top
+  | erased
+  | val (i : Nat)
+  deriving Inhabited, BEq, Hashable
+
+structure Context where
+  /-- Declaration in the same mutual block. -/
+  decls : Array Decl
+  /--
+  Function being analyzed. We check every recursive call to this function.
+  Remark: `main` is in `decls`.
+  -/
+  main : Decl
+  /--
+  The assignment maps free variable ids in the current code being analyzed to abstract values.
+  We only track the abstract value assigned to parameters.
+  -/
+  assignment : FVarIdMap AbsValue
+
+structure State where
+  /--
+  Set of calls that have been already analyzed.
+  Recall that we assume that only functions in `decls` may have recursive calls to the function being analyzed (i.e., `main`).
+  Whenever there is function application `f a₁ ... aₙ`, where `f` is in `decls`, `f` is not `main`, and
+  we visit with the abstract values assigned to `aᵢ`, but first we record the visit here.
+  -/
+  visited : Std.HashSet (Name × Array AbsValue) := {}
+  /--
+  Bitmask containing the result, i.e., which parameters of `main` are fixed.
+  We initialize it with `true` everywhere.
+  -/
+  fixed : Array Bool
+
+/-- Monad for the fixed parameter static analyzer. We use the unit-exception to interrupt the analysis. -/
+abbrev FixParamM := ReaderT Context <| EStateM Unit State
+
+/-- Stop the analysis and mark all parameters as non-fixed. -/
+abbrev abort : FixParamM α := do
+  modify fun s => { s with fixed := s.fixed.map fun _ => false }
+  throw ()
+
+def evalFVar (fvarId : FVarId) : FixParamM AbsValue := do
+  let some val := (← read).assignment.find? fvarId | return .top
+  return val
+
+def evalArg (arg : Arg) : FixParamM AbsValue := do
+  match arg with
+  | .erased => return .erased
+  | .type (.fvar fvarId) => evalFVar fvarId
+  | .type _ => return .top
+  | .fvar fvarId => evalFVar fvarId
+
+def inMutualBlock (declName : Name) : FixParamM Bool :=
+  return (← read).decls.any (·.name == declName)
+
+def mkAssignment (decl : Decl) (values : Array AbsValue) : FVarIdMap AbsValue := Id.run do
+  let mut assignment := {}
+  for param in decl.params, value in values do
+    assignment := assignment.insert param.fvarId value
+  return assignment
+
+mutual
+
+partial def evalLetValue (e : LetValue) : FixParamM Unit := do
+  match e with
+  | .const declName _ args => evalApp declName args
+  | _ => return ()
+
+partial def evalCode (code : Code) : FixParamM Unit := do
+  match code with
+  | .let decl k => evalLetValue decl.value; evalCode k
+  | .fun decl k | .jp decl k => evalCode decl.value; evalCode k
+  | .cases c => c.alts.forM fun alt => evalCode alt.getCode
+  | .unreach .. | .jmp .. | .return .. => return ()
+
+partial def evalApp (declName : Name) (args : Array Arg) : FixParamM Unit := do
+  let main := (← read).main
+  if declName == main.name then
+    -- Recursive call to the function being analyzed
+    for h : i in [:main.params.size] do
+      if _h : i < args.size then
+        have : i < main.params.size := h.upper
+        let param := main.params[i]
+        let val ← evalArg args[i]
+        unless val == .val i || (val == .erased && param.type.isErased) do
+          -- Found non fixed argument
+          -- Remark: if the argument is erased and the type of the parameter is erased we assume it is a fixed "propositonal" parameter.
+          modify fun s => { s with fixed := s.fixed.set! i false }
+      else
+        -- Partial application mark argument as not fixed
+        modify fun s => { s with fixed := s.fixed.set! i false }
+    unless (← get).fixed.contains true do
+      throw () -- stop analysis, none of the arguments are fixed.
+  for decl in (← read).decls do
+    if declName == decl.name then
+      -- Call to another function in the same mutual block.
+      let mut values := #[]
+      for i in [:decl.params.size] do
+        if h : i < args.size then
+          values := values.push (← evalArg args[i])
+        else
+          values := values.push .top
+      let key := (declName, values)
+      unless (← get).visited.contains key do
+        modify fun s => { s with visited := s.visited.insert key }
+        decl.value.forCodeM fun c =>
+          let assignment := mkAssignment decl values
+          withReader (fun ctx => { ctx with assignment }) <| evalCode c
+
+end
+
+def mkInitialValues (numParams : Nat) : Array AbsValue := Id.run do
+  let mut values := #[]
+  for i in [:numParams] do
+    values := values.push <| .val i
+  return values
+
+end FixedParams
+open FixedParams
+
+/--
+Given the (potentially mutually) recursive declarations `decls`,
+return a map from declaration name `decl.name` to a bit-mask `m` where `m[i]` is true
+iff the `decl.params[i]` is a fixed argument. That is, it does not change in recursive
+applications.
+The function assumes that if a function `f` was declared in a mutual block, then `decls`
+contains all (computationally relevant) functions in the mutual block.
+-/
+def mkFixedParamsMap (decls : Array Decl) : NameMap (Array Bool) := Id.run do
+  let mut result := {}
+  for decl in decls do
+    let values := mkInitialValues decl.params.size
+    let assignment := mkAssignment decl values
+    let fixed := Array.replicate decl.params.size true
+    match decl.value with
+    | .code c =>
+      match evalCode c |>.run { main := decl, decls, assignment } |>.run { fixed } with
+      | .ok _ s | .error _ s => result := result.insert decl.name s.fixed
+    | .extern .. =>
+      result := result.insert decl.name fixed
+  return result
+
+end Lean.Compiler.LCNF

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/FloatLetIn.lean

@@ -0,0 +1,310 @@
+/-
+Copyright (c) 2022 Henrik Böving. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Henrik Böving
+-/
+prelude
+import Lean.Compiler.LCNF.CompilerM
+import Lean.Compiler.LCNF.FVarUtil
+import Lean.Compiler.LCNF.PassManager
+import Lean.Compiler.LCNF.Types
+
+namespace Lean.Compiler.LCNF
+
+namespace FloatLetIn
+
+/--
+The decision of the float mechanism.
+-/
+inductive Decision where
+|
+  /--
+  Push into the arm with name `name`.
+  -/
+  arm (name : Name)
+| /--
+  Push into the default arm.
+  -/
+  default
+|
+  /--
+  Dont move this declaration it is needed where it is right now.
+  -/
+  dont
+|
+  /--
+  No decision has been made yet.
+  -/
+  unknown
+deriving Hashable, BEq, Inhabited, Repr
+
+def Decision.ofAlt : Alt → Decision
+| .alt name _ _ => .arm name
+| .default _ => .default
+
+/--
+The context for `BaseFloatM`.
+-/
+structure BaseFloatContext where
+  /--
+  All the declarations that were collected in the current LCNF basic
+  block up to the current statement (in reverse order for efficiency).
+  -/
+  decls : List CodeDecl := []
+
+/--
+The state for `FloatM`
+-/
+structure FloatState where
+  /--
+  A map from identifiers of declarations to their current decision.
+  -/
+  decision : Std.HashMap FVarId Decision
+  /--
+  A map from decisions (excluding `unknown`) to the declarations with
+  these decisions (in correct order). Basically:
+  - Which declarations do we not move
+  - Which declarations do we move into a certain arm
+  - Which declarations do we move into the default arm
+  -/
+  newArms : Std.HashMap Decision (List CodeDecl)
+
+/--
+Use to collect relevant declarations for the floating mechanism.
+-/
+abbrev BaseFloatM :=  ReaderT BaseFloatContext CompilerM
+
+/--
+Use to compute the actual floating.
+-/
+abbrev FloatM := StateRefT FloatState BaseFloatM
+
+/--
+Add `decl` to the list of declarations and run `x` with that updated context.
+-/
+def withNewCandidate (decl : CodeDecl) (x : BaseFloatM α) : BaseFloatM α :=
+  withReader (fun r => { r with decls := decl :: r.decls }) do
+    x
+
+/--
+Run `x` with an empty list of declarations.
+-/
+def withNewScope (x : BaseFloatM α) : BaseFloatM α := do
+  withReader (fun _ => {}) do
+    x
+
+/--
+Whether to ignore `decl` for the floating mechanism. We want to do this if:
+- `decl`' is storing a typeclass instance
+- `decl` is a projection from a variable that is storing a typeclass instance
+-/
+def ignore? (decl : LetDecl) : BaseFloatM Bool :=  do
+   if (← isArrowClass? decl.type).isSome then
+     return true
+   else if let .proj _ _ fvarId := decl.value then
+     return (← isArrowClass? (← getType fvarId)).isSome
+   else
+     return false
+
+/--
+Compute the initial decision for all declarations that `BaseFloatM` collected
+up to this point, with respect to `cs`. The initial decisions are:
+- `dont` if the declaration is detected by `ignore?`
+- `dont` if the declaration is the discriminant of `cs` since we obviously need
+  the discriminant to be computed before the match.
+- `dont` if we see the declaration being used in more than one cases arm
+- `arm` or `default` if we see the declaration only being used in exactly one cases arm
+- `unknown` otherwise
+-/
+def initialDecisions (cs : Cases) : BaseFloatM (Std.HashMap FVarId Decision) := do
+  let mut map := Std.HashMap.emptyWithCapacity (← read).decls.length
+  map ← (← read).decls.foldrM (init := map) fun val acc => do
+    if let .let decl := val then
+      if (← ignore? decl) then
+        return acc.insert decl.fvarId .dont
+    return acc.insert val.fvarId .unknown
+
+  if map.contains cs.discr then
+    map := map.insert cs.discr .dont
+  (_, map) ← goCases cs |>.run map
+  return map
+where
+  goFVar (plannedDecision : Decision) (var : FVarId) : StateRefT (Std.HashMap FVarId Decision) BaseFloatM Unit := do
+    if let some decision := (← get)[var]? then
+      if decision == .unknown then
+        modify fun s => s.insert var plannedDecision
+      else if decision != plannedDecision then
+        modify fun s => s.insert var .dont
+      -- otherwise we already have the proper decision
+
+  goAlt (alt : Alt) : StateRefT (Std.HashMap FVarId Decision) BaseFloatM Unit :=
+    forFVarM (goFVar (.ofAlt alt)) alt
+  goCases (cs : Cases) : StateRefT (Std.HashMap FVarId Decision) BaseFloatM Unit :=
+    cs.alts.forM goAlt
+
+/--
+Compute the initial new arms. This will just set up a map from all arms of
+`cs` to empty `Array`s, plus one additional entry for `dont`.
+-/
+def initialNewArms (cs : Cases) : Std.HashMap Decision (List CodeDecl) := Id.run do
+  let mut map := Std.HashMap.emptyWithCapacity (cs.alts.size + 1)
+  map := map.insert .dont []
+  cs.alts.foldr (init := map) fun val acc => acc.insert (.ofAlt val) []
+
+/--
+Will:
+- put `decl` into the `dont` arm
+- decide that any free variable that occurs in `decl` and is a declaration
+  of interest as not getting moved either.
+```
+let x := ...
+let y := ...
+let z := x + y
+cases z with
+| n => z * x
+| m => z * y
+```
+Here `x` and `y` are originally marked as getting floated into `n` and `m`
+respectively but since `z` can't be moved we don't want that to move `x` and `y`.
+-/
+def dontFloat (decl : CodeDecl) : FloatM Unit := do
+  forFVarM goFVar decl
+  modify fun s => { s with newArms := s.newArms.insert .dont (decl :: s.newArms[Decision.dont]!) }
+where
+  goFVar (fvar : FVarId) : FloatM Unit := do
+    if (← get).decision.contains fvar then
+      modify fun s => { s with decision := s.decision.insert fvar .dont }
+
+/--
+Will:
+- put `decl` into the arm it is marked to be moved into
+- for any variables that might occur in `decl` and are of interest:
+  - if they are already meant to be floated into the same arm or not at all leave them untouched:
+    ```
+    let x := ...
+    let y := x + z
+    cases z with
+    | n => x * y
+    | m => z
+    ```
+    If we are at `y` `x` is already marked to be floated into `n` as well.
+  - if there hasn't be a decision yet, that is they are marked with `.unknown` we float
+    them into the same arm as the current value:
+    ```
+    let x := ..
+    let y := x + 2
+    cases z with
+    | n => y
+    | m => z
+    ```
+    Here `x` is initially marked as `.unknown` since it occurs in no branch, however
+    since we want to move `y` into the `n` branch we can also decide to move `x`
+    into the `n` branch. Note that this decision might be revoked later on in the case of:
+    ```
+    let x := ..
+    let a := x + 1
+    let y := x + 2
+    cases z with
+    | n => y
+    | m => a
+    ```
+    When we visit `a` `x` is now marked as getting moved into `n` but since it also occurs
+    in `a` which wants to be moved somewhere else we will instead decide to not move `x`
+    at all.
+  - if they are meant to be floated somewhere else decide that they won't get floated:
+    ```
+    let x := ...
+    let y := x + z
+    cases z with
+    | n => y
+    | m => x
+    ```
+    If we are at `y` `x` is still marked to be moved but we don't want that.
+-/
+def float (decl : CodeDecl) : FloatM Unit := do
+  let arm := (← get).decision[decl.fvarId]!
+  forFVarM (goFVar · arm) decl
+  modify fun s => { s with newArms := s.newArms.insert arm (decl :: s.newArms[arm]!) }
+where
+  goFVar (fvar : FVarId) (arm : Decision) : FloatM Unit := do
+    let some decision := (← get).decision[fvar]? | return ()
+    if decision == .unknown then
+      modify fun s => { s with decision := s.decision.insert fvar arm }
+    else if decision != arm then
+      modify fun s => { s with decision := s.decision.insert fvar .dont }
+
+/--
+Iterate through `decl`, pushing local declarations that are only used in one
+control flow arm into said arm in order to avoid useless computations.
+-/
+partial def floatLetIn (decl : Decl) : CompilerM Decl := do
+  let newValue ← decl.value.mapCodeM go |>.run {}
+  return { decl with value := newValue }
+where
+  /--
+  Iterate through the collected declarations,
+  determining from the bottom up whether they (and the declarations they refer to)
+  should get moved down into the arms of the cases statement or not.
+  -/
+  goCases : FloatM Unit := do
+    for decl in (← read).decls do
+      let currentDecision := (← get).decision[decl.fvarId]!
+      if currentDecision == .unknown then
+        /-
+        If the decision is still unknown by now this means `decl` is
+        unused in its continuation and can hence be removed.
+        -/
+        eraseCodeDecl decl
+      else if currentDecision == .dont then
+        dontFloat decl
+      else
+        float decl
+
+  go (code : Code) : BaseFloatM Code := do
+    match code with
+    | .let decl k =>
+      withNewCandidate (.let decl) do
+        go k
+    | .jp decl k =>
+      let value ← withNewScope do
+        go decl.value
+      let decl ← decl.updateValue value
+      withNewCandidate (.jp decl) do
+        go k
+    | .fun decl k =>
+      let value ← withNewScope do
+        go decl.value
+      let decl ← decl.updateValue value
+      withNewCandidate (.fun decl) do
+        go k
+    | .cases cs =>
+      let base := {
+        decision := (← initialDecisions cs)
+        newArms := initialNewArms cs
+      }
+      let (_, res) ← goCases |>.run base
+      let remainders := res.newArms[Decision.dont]!
+      let newAlts ← cs.alts.mapM fun alt => do
+        let decision := Decision.ofAlt alt
+        let newCode := res.newArms[decision]!
+        trace[Compiler.floatLetIn] "Size of code that was pushed into arm: {repr decision} {newCode.length}"
+        let fused ← withNewScope do
+          go (attachCodeDecls newCode.toArray alt.getCode)
+        return alt.updateCode fused
+      let mut newCases := Code.updateCases! code cs.resultType cs.discr newAlts
+      return attachCodeDecls remainders.toArray newCases
+    | .jmp .. | .return .. | .unreach .. =>
+      return attachCodeDecls (← read).decls.toArray.reverse code
+
+end FloatLetIn
+
+def Decl.floatLetIn (decl : Decl) : CompilerM Decl := do
+  FloatLetIn.floatLetIn decl
+
+def floatLetIn (phase := Phase.base) (occurrence := 0) : Pass :=
+  .mkPerDeclaration `floatLetIn Decl.floatLetIn phase occurrence
+
+builtin_initialize
+  registerTraceClass `Compiler.floatLetIn (inherited := true)
+
+end Lean.Compiler.LCNF

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/InferType.lean

@@ -0,0 +1,348 @@
+/-
+Copyright (c) 2022 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Compiler.LCNF.CompilerM
+import Lean.Compiler.LCNF.Types
+import Lean.Compiler.LCNF.PhaseExt
+import Lean.Compiler.LCNF.OtherDecl
+
+namespace Lean.Compiler.LCNF
+/-! # Type inference for LCNF -/
+
+/-
+Note about **erasure confusion**.
+
+1- After instantiating universe polymorphic code, we may have
+some types that become propositions, and all propositions are erased.
+
+For example, suppose we have
+```
+def f (α : Sort u) (x : α → α → Sort v) (a b : α) (h : x a b) ...
+```
+The LCNF type for this universe polymorphic declaration is
+```
+def f (α : Sort u) (x : α → α → Sort v) (a b : α) (h : x ◾ ◾) ...
+```
+Now, if we instantiate with `v` with the universe `0`, we have that `x ◾ ◾` is also a proposition
+and should be erased.
+
+2- We may also get "erasure confusion" when instantiating
+polymorphic code with types and type formers. For example, suppose we have
+```
+structure S (α : Type u) (β : Type v) (f : α → β) where
+  a : α
+  b : β := f a
+```
+The LCNF type for `S.mk` is
+```
+S.mk : {α : Type u} → {β : Type v} → {f : α → β} → α → β → S α β ◾
+```
+Note that `f` was erased from the resulting type `S α β ◾` because it is
+not a type former. Now, suppose we have the valid Lean declaration
+```
+def f : S Nat Type (fun _ => Nat) :=
+ S.mk 0 Nat
+```
+The LNCF type for the value `S.mk 0 Nat` is `S Nat Type ◾` (see `S.mk` type above),
+but the expected type is `S Nat Type (fun x => Nat)`. `fun x => Nat` is not erased
+here because it is a type former.
+-/
+
+namespace InferType
+
+/-
+Type inference algorithm for LCNF. Invoked by the LCNF type checker
+to check correctness of LCNF IR.
+-/
+
+/--
+We use a regular local context to store temporary local declarations
+created during type inference.
+-/
+abbrev InferTypeM := ReaderT LocalContext CompilerM
+
+def getBinderName (fvarId : FVarId) : InferTypeM Name := do
+  match (← read).find? fvarId with
+  | some localDecl => return localDecl.userName
+  | none => LCNF.getBinderName fvarId
+
+def getType (fvarId : FVarId) : InferTypeM Expr := do
+  match (← read).find? fvarId with
+  | some localDecl => return localDecl.type
+  | none => LCNF.getType fvarId
+
+def mkForallFVars (xs : Array Expr) (type : Expr) : InferTypeM Expr :=
+  let b := type.abstract xs
+  xs.size.foldRevM (init := b) fun i _ b => do
+    let x := xs[i]
+    let n ← InferType.getBinderName x.fvarId!
+    let ty ← InferType.getType x.fvarId!
+    let ty := ty.abstractRange i xs;
+    return .forallE n ty b .default
+
+def mkForallParams (params : Array Param) (type : Expr) : InferTypeM Expr :=
+  let xs := params.map fun p => .fvar p.fvarId
+  mkForallFVars xs type |>.run {}
+
+@[inline] def withLocalDecl (binderName : Name) (type : Expr) (binderInfo : BinderInfo) (k : Expr → InferTypeM α) : InferTypeM α := do
+  let fvarId ← mkFreshFVarId
+  withReader (fun lctx => lctx.mkLocalDecl fvarId binderName type binderInfo) do
+    k (.fvar fvarId)
+
+def inferConstType (declName : Name) (us : List Level) : CompilerM Expr := do
+  if declName == ``lcErased then
+    return erasedExpr
+  else if let some decl ← getDecl? declName then
+    return decl.instantiateTypeLevelParams us
+  else
+    /- Declaration does not have code associated with it: constructor, inductive type, foreign function -/
+    getOtherDeclType declName us
+
+def inferLitValueType (value : LitValue) : Expr :=
+  match value with
+  | .nat .. => mkConst ``Nat
+  | .str .. => mkConst ``String
+  | .uint8 .. => mkConst ``UInt8
+  | .uint16 .. => mkConst ``UInt16
+  | .uint32 .. => mkConst ``UInt32
+  | .uint64 .. => mkConst ``UInt64
+  | .usize .. => mkConst ``USize
+
+mutual
+  partial def inferArgType (arg : Arg) : InferTypeM Expr :=
+    match arg with
+    | .erased => return erasedExpr
+    | .type e => inferType e
+    | .fvar fvarId => LCNF.getType fvarId
+
+  partial def inferType (e : Expr) : InferTypeM Expr :=
+    match e with
+    | .const c us    => inferConstType c us
+    | .app ..        => inferAppType e
+    | .fvar fvarId   => InferType.getType fvarId
+    | .sort lvl      => return .sort (mkLevelSucc lvl)
+    | .forallE ..    => inferForallType e
+    | .lam ..        => inferLambdaType e
+    | .letE .. | .mvar .. | .mdata .. | .lit .. | .bvar .. | .proj .. => unreachable!
+
+  partial def inferLetValueType (e : LetValue) : InferTypeM Expr := do
+    match e with
+    | .erased => return erasedExpr
+    | .lit v => return inferLitValueType v
+    | .proj structName idx fvarId => inferProjType structName idx fvarId
+    | .const declName us args => inferAppTypeCore (← inferConstType declName us) args
+    | .fvar fvarId args => inferAppTypeCore (← getType fvarId) args
+
+  partial def inferAppTypeCore (fType : Expr) (args : Array Arg) : InferTypeM Expr := do
+    let mut j := 0
+    let mut fType := fType
+    for i in [:args.size] do
+      fType := fType.headBeta
+      match fType with
+      | .forallE _ _ b _ => fType := b
+      | _ =>
+        fType := instantiateRevRangeArgs fType j i args |>.headBeta
+        match fType with
+        | .forallE _ _ b _ => j := i; fType := b
+        | _ => return anyExpr
+    return instantiateRevRangeArgs fType j args.size args |>.headBeta
+
+  partial def inferAppType (e : Expr) : InferTypeM Expr := do
+    let mut j := 0
+    let mut fType ← inferType e.getAppFn
+    let args := e.getAppArgs
+    for i in [:args.size] do
+      fType := fType.headBeta
+      match fType with
+      | .forallE _ _ b _ => fType := b
+      | _ =>
+        fType := fType.instantiateRevRange j i args |>.headBeta
+        match fType with
+        | .forallE _ _ b _ => j := i; fType := b
+        | _ => return anyExpr
+    return fType.instantiateRevRange j args.size args |>.headBeta
+
+  partial def inferProjType (structName : Name) (idx : Nat) (s : FVarId) : InferTypeM Expr := do
+    let failed {α} : Unit → InferTypeM α := fun _ =>
+      throwError "invalid projection{indentExpr (mkProj structName idx (mkFVar s))}"
+    let structType := (← getType s).headBeta
+    if structType.isErased then
+      /- TODO: after we erase universe variables, we can just extract a better type using just `structName` and `idx`. -/
+      return erasedExpr
+    else if structType.isAny then
+      return anyExpr
+    else
+      matchConstStructure structType.getAppFn failed fun structVal structLvls ctorVal =>
+        let structTypeArgs := structType.getAppArgs
+        if structVal.numParams + structVal.numIndices != structTypeArgs.size then
+          failed ()
+        else do
+          let mut ctorType ← inferAppType (mkAppN (mkConst ctorVal.name structLvls) structTypeArgs[*...structVal.numParams])
+          for _ in [:idx] do
+            match ctorType with
+            | .forallE _ _ body _ =>
+              if body.hasLooseBVars then
+                -- This can happen when one of the fields is a type or type former.
+                ctorType := body.instantiate1 anyExpr
+              else
+                ctorType := body
+            | _ =>
+              if ctorType.isErased then return erasedExpr
+              failed ()
+          match ctorType with
+          | .forallE _ d _ _ => return d
+          | _ =>
+            if ctorType.isErased then return erasedExpr
+            failed ()
+
+  partial def getLevel? (type : Expr) : InferTypeM (Option Level) := do
+    match (← inferType type) with
+    | .sort u => return some u
+    | _ => return none
+
+  partial def inferForallType (e : Expr) : InferTypeM Expr :=
+    go e #[]
+  where
+    go (e : Expr) (fvars : Array Expr) : InferTypeM Expr := do
+      match e with
+      | .forallE n d b bi =>
+        withLocalDecl n (d.instantiateRev fvars) bi fun fvar =>
+          go b (fvars.push fvar)
+      | _ =>
+        let e := e.instantiateRev fvars
+        let some u ← getLevel? e | return erasedExpr
+        let mut u := u
+        for x in fvars.reverse do
+          let xType ← inferType x
+          let some v ← getLevel? xType | return erasedExpr
+          u := mkLevelIMax' v u
+        return .sort u.normalize
+
+  partial def inferLambdaType (e : Expr) : InferTypeM Expr :=
+    go e #[] #[]
+  where
+    go (e : Expr) (fvars : Array Expr) (all : Array Expr) : InferTypeM Expr := do
+      match e with
+      | .lam n d b bi =>
+        withLocalDecl n (d.instantiateRev all) bi fun fvar => go b (fvars.push fvar) (all.push fvar)
+      | .letE n t _ b _ =>
+        withLocalDecl n (t.instantiateRev all) .default fun fvar => go b fvars (all.push fvar)
+      | e =>
+        let type ← inferType (e.instantiateRev all)
+        mkForallFVars fvars type
+
+end
+end InferType
+
+def inferType (e : Expr) : CompilerM Expr :=
+  InferType.inferType e |>.run {}
+
+def inferAppType (fnType : Expr) (args : Array Arg) : CompilerM Expr :=
+  InferType.inferAppTypeCore fnType args |>.run {}
+
+def getLevel (type : Expr) : CompilerM Level := do
+  match (← inferType type) with
+  | .sort u => return u
+  | e => if e.isErased then return levelOne else throwError "type expected{indentExpr type}"
+
+def Arg.inferType (arg : Arg) : CompilerM Expr :=
+  InferType.inferArgType arg |>.run {}
+
+def LetValue.inferType (e : LetValue) : CompilerM Expr :=
+  InferType.inferLetValueType e |>.run {}
+
+def Code.inferType (code : Code) : CompilerM Expr := do
+  match code with
+  | .let _ k | .fun _ k | .jp _ k => k.inferType
+  | .return fvarId => getType fvarId
+  | .jmp fvarId args => InferType.inferAppTypeCore (← getType fvarId) args |>.run {}
+  | .unreach type => return type
+  | .cases c => return c.resultType
+
+def Code.inferParamType (params : Array Param) (code : Code) : CompilerM Expr := do
+  let type ← code.inferType
+  let xs := params.map fun p => .fvar p.fvarId
+  InferType.mkForallFVars xs type |>.run {}
+
+def Alt.inferType (alt : Alt) : CompilerM Expr :=
+  alt.getCode.inferType
+
+def mkAuxLetDecl (e : LetValue) (prefixName := `_x) : CompilerM LetDecl := do
+  mkLetDecl (← mkFreshBinderName prefixName) (← e.inferType) e
+
+def mkForallParams (params : Array Param) (type : Expr) : CompilerM Expr :=
+  InferType.mkForallParams params type |>.run {}
+
+def mkAuxFunDecl (params : Array Param) (code : Code) (prefixName := `_f) : CompilerM FunDecl := do
+  let type ← mkForallParams params (← code.inferType)
+  let binderName ← mkFreshBinderName prefixName
+  mkFunDecl binderName type params code
+
+def mkAuxJpDecl (params : Array Param) (code : Code) (prefixName := `_jp) : CompilerM FunDecl := do
+  mkAuxFunDecl params code prefixName
+
+def mkAuxJpDecl' (param : Param) (code : Code) (prefixName := `_jp) : CompilerM FunDecl := do
+  let params := #[param]
+  mkAuxFunDecl params code prefixName
+
+def mkCasesResultType (alts : Array Alt) : CompilerM Expr := do
+  if alts.isEmpty then
+    throwError "`Code.bind` failed, empty `cases` found"
+  let mut resultType ← alts[0]!.inferType
+  for alt in alts[1...*] do
+    resultType := joinTypes resultType (← alt.inferType)
+  return resultType
+
+/--
+Return `true` if `type` should be erased. See item 1 in the note above where `x ◾ ◾` is
+a proposition and should be erased when the universe level parameter is set to 0.
+
+Remark: `predVars` is a bitmask that indicates whether de-bruijn variables are predicates or not.
+That is, `#i` is a predicate if `predVars[predVars.size - i - 1] = true`
+-/
+partial def isErasedCompatible (type : Expr) (predVars : Array Bool := #[]): CompilerM Bool :=
+  go type predVars
+where
+  go (type : Expr) (predVars : Array Bool) : CompilerM Bool := do
+    let type := type.headBeta
+    match type with
+    | .const ..        => return type.isErased
+    | .sort ..         => return false
+    | .mdata _ e       => go e predVars
+    | .forallE _ t b _
+    | .lam _ t b _     => go b (predVars.push <| isPredicateType t)
+    | .app f _         => go f predVars
+    | .bvar idx        => return predVars[predVars.size - idx - 1]!
+    | .fvar fvarId     => return isPredicateType (← getType fvarId)
+    | .proj .. | .mvar .. | .letE .. | .lit .. => unreachable!
+
+/--
+Return `true` if the given LCNF are equivalent.
+`List Nat` and `(fun x => List x) Nat` are both equivalent.
+-/
+partial def eqvTypes (a b : Expr) : Bool :=
+  if a == b then
+    true
+  else if a.isErased && b.isErased then
+    -- `◾ α` is equivalent to `◾`
+    true
+  else
+    let a' := a.headBeta
+    let b' := b.headBeta
+    if a != a' || b != b' then
+      eqvTypes a' b'
+    else
+      match a, b with
+      | .mdata _ a, b => eqvTypes a b
+      | a, .mdata _ b => eqvTypes a b
+      | .app f a, .app g b => eqvTypes f g && eqvTypes a b
+      | .forallE _ d₁ b₁ _, .forallE _ d₂ b₂ _ => eqvTypes d₁ d₂ && eqvTypes b₁ b₂
+      | .lam _ d₁ b₁ _, .lam _ d₂ b₂ _ => eqvTypes d₁ d₂ && eqvTypes b₁ b₂
+      | .sort u, .sort v => Level.isEquiv u v
+      | .const n us, .const m vs => n == m && List.isEqv us vs Level.isEquiv
+      | _, _ => false
+
+end Lean.Compiler.LCNF

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/Internalize.lean

@@ -0,0 +1,131 @@
+/-
+Copyright (c) 2022 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Compiler.LCNF.Types
+import Lean.Compiler.LCNF.Bind
+import Lean.Compiler.LCNF.CompilerM
+
+namespace Lean.Compiler.LCNF
+
+private def refreshBinderName (binderName : Name) : CompilerM Name := do
+  match binderName with
+  | .num p _ =>
+    let r := .num p (← get).nextIdx
+    modify fun s => { s with nextIdx := s.nextIdx + 1 }
+    return r
+  | _ => return binderName
+
+namespace Internalize
+
+abbrev InternalizeM := StateRefT FVarSubst CompilerM
+
+/--
+The `InternalizeM` monad is a translator. It "translates" the free variables
+in the input expressions and `Code`, into new fresh free variables in the
+local context.
+-/
+instance : MonadFVarSubst InternalizeM true where
+  getSubst := get
+
+instance : MonadFVarSubstState InternalizeM where
+  modifySubst := modify
+
+private def mkNewFVarId (fvarId : FVarId) : InternalizeM FVarId := do
+  let fvarId' ← Lean.mkFreshFVarId
+  addFVarSubst fvarId fvarId'
+  return fvarId'
+
+def internalizeParam (p : Param) : InternalizeM Param := do
+  let binderName ← refreshBinderName p.binderName
+  let type ← normExpr p.type
+  let fvarId ← mkNewFVarId p.fvarId
+  let p := { p with binderName, fvarId, type }
+  modifyLCtx fun lctx => lctx.addParam p
+  return p
+
+def internalizeLetDecl (decl : LetDecl) : InternalizeM LetDecl := do
+  let binderName ← refreshBinderName decl.binderName
+  let type ← normExpr decl.type
+  let value ← normLetValue decl.value
+  let fvarId ← mkNewFVarId decl.fvarId
+  let decl := { decl with binderName, fvarId, type, value }
+  modifyLCtx fun lctx => lctx.addLetDecl decl
+  return decl
+
+mutual
+
+partial def internalizeFunDecl (decl : FunDecl) : InternalizeM FunDecl := do
+  let type ← normExpr decl.type
+  let binderName ← refreshBinderName decl.binderName
+  let params ← decl.params.mapM internalizeParam
+  let value ← internalizeCode decl.value
+  let fvarId ← mkNewFVarId decl.fvarId
+  let decl := { decl with binderName, fvarId, params, type, value }
+  modifyLCtx fun lctx => lctx.addFunDecl decl
+  return decl
+
+partial def internalizeCode (code : Code) : InternalizeM Code := do
+  match code with
+  | .let decl k => return .let (← internalizeLetDecl decl) (← internalizeCode k)
+  | .fun decl k => return .fun (← internalizeFunDecl decl) (← internalizeCode k)
+  | .jp decl k => return .jp (← internalizeFunDecl decl) (← internalizeCode k)
+  | .return fvarId => withNormFVarResult (← normFVar fvarId) fun fvarId => return .return fvarId
+  | .jmp fvarId args => withNormFVarResult (← normFVar fvarId) fun fvarId => return .jmp fvarId (← args.mapM normArg)
+  | .unreach type => return .unreach (← normExpr type)
+  | .cases c =>
+    withNormFVarResult (← normFVar c.discr) fun discr => do
+      let resultType ← normExpr c.resultType
+      let internalizeAltCode (k : Code) : InternalizeM Code :=
+        internalizeCode k
+      let alts ← c.alts.mapM fun
+        | .alt ctorName params k => return .alt ctorName (← params.mapM internalizeParam) (← internalizeAltCode k)
+        | .default k => return .default (← internalizeAltCode k)
+      return .cases { c with discr, alts, resultType }
+
+end
+
+partial def internalizeCodeDecl (decl : CodeDecl) : InternalizeM CodeDecl := do
+  match decl with
+  | .let decl => return .let (← internalizeLetDecl decl)
+  | .fun decl => return .fun (← internalizeFunDecl decl)
+  | .jp decl => return .jp (← internalizeFunDecl decl)
+
+end Internalize
+
+/--
+Refresh free variables ids in `code`, and store their declarations in the local context.
+-/
+partial def Code.internalize (code : Code) (s : FVarSubst := {}) : CompilerM Code :=
+  Internalize.internalizeCode code |>.run' s
+
+open Internalize in
+def Decl.internalize (decl : Decl) (s : FVarSubst := {}): CompilerM Decl :=
+  go decl |>.run' s
+where
+  go (decl : Decl) : InternalizeM Decl := do
+    let type ← normExpr decl.type
+    let params ← decl.params.mapM internalizeParam
+    let value ← decl.value.mapCodeM internalizeCode
+    return { decl with type, params, value }
+
+/--
+Create a fresh local context and internalize the given decls.
+-/
+def cleanup (decl : Array Decl) : CompilerM (Array Decl) := do
+  modify fun _ => {}
+  decl.mapM fun decl => do
+    modify fun s => { s with nextIdx := 1 }
+    decl.internalize
+
+def normalizeFVarIds (decl : Decl) : CoreM Decl := do
+  let ngenSaved ← getNGen
+  setNGen {}
+  try
+    CompilerM.run <| decl.internalize
+  finally
+    setNGen ngenSaved
+
+end Lean.Compiler.LCNF

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/JoinPoints.lean

@@ -0,0 +1,636 @@
+/-
+Copyright (c) 2022 Henrik Böving. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Henrik Böving
+-/
+prelude
+import Lean.Compiler.LCNF.CompilerM
+import Lean.Compiler.LCNF.PassManager
+import Lean.Compiler.LCNF.PullFunDecls
+import Lean.Compiler.LCNF.FVarUtil
+import Lean.Compiler.LCNF.ScopeM
+import Lean.Compiler.LCNF.InferType
+
+namespace Lean.Compiler.LCNF
+
+namespace JoinPointFinder
+
+open ScopeM
+
+/--
+Info about a join point candidate (a `fun` declaration) during the find phase.
+-/
+structure CandidateInfo where
+  /--
+  The arity of the candidate
+  -/
+  arity : Nat
+  /--
+  The set of candidates that rely on this candidate to be a join point.
+  For a more detailed explanation see the documentation of `find`
+  -/
+  associated : Std.HashSet FVarId
+  deriving Inhabited
+
+/--
+The state for the join point candidate finder.
+-/
+structure FindState where
+  /--
+  All current join point candidates accessible by their `FVarId`.
+  -/
+  candidates : Std.HashMap FVarId CandidateInfo := ∅
+  /--
+  The `FVarId`s of all `fun` declarations that were declared within the
+  current `fun`.
+  -/
+  scope : Std.HashSet FVarId := ∅
+
+abbrev ReplaceCtx := Std.HashMap FVarId Name
+
+abbrev FindM := ReaderT (Option FVarId) StateRefT FindState ScopeM
+abbrev ReplaceM := ReaderT ReplaceCtx CompilerM
+
+/--
+Attempt to find a join point candidate by its `FVarId`.
+-/
+private def findCandidate? (fvarId : FVarId) : FindM (Option CandidateInfo) := do
+  return (← get).candidates[fvarId]?
+
+/--
+Erase a join point candidate as well as all the ones that depend on it
+by its `FVarId`, no error is thrown is the candidate does not exist.
+-/
+private partial def eraseCandidate (fvarId : FVarId) : FindM Unit := do
+  if let some info ← findCandidate? fvarId then
+    modify (fun state => { state with candidates := state.candidates.erase fvarId })
+    info.associated.forM eraseCandidate
+
+/--
+Combinator for modifying the candidates in `FindM`.
+-/
+private def modifyCandidates (f : Std.HashMap FVarId CandidateInfo → Std.HashMap FVarId CandidateInfo) : FindM Unit :=
+  modify (fun state => {state with candidates := f state.candidates })
+
+/--
+Remove all join point candidates contained in `a`.
+-/
+private partial def removeCandidatesInArg (a : Arg) : FindM Unit := do
+  forFVarM eraseCandidate a
+
+/--
+Remove all join point candidates contained in `a`.
+-/
+private partial def removeCandidatesInLetValue (e : LetValue) : FindM Unit := do
+  forFVarM eraseCandidate e
+
+/--
+Add a new join point candidate to the state.
+-/
+private def addCandidate (fvarId : FVarId) (arity : Nat) : FindM Unit := do
+  let cinfo := { arity, associated := ∅ }
+  modifyCandidates (fun cs => cs.insert fvarId cinfo )
+
+/--
+Add a new join point dependency from `src` to `dst`.
+-/
+private def addDependency (src : FVarId) (target : FVarId) : FindM Unit := do
+  if let some targetInfo ← findCandidate? target then
+    modifyCandidates (fun cs => cs.insert target { targetInfo with associated := targetInfo.associated.insert src })
+  else
+    eraseCandidate src
+
+/--
+Find all `fun` declarations that qualify as a join point, that is:
+- are always fully applied
+- are always called in tail position
+
+Where a `fun` `f` is in tail position iff it is called as follows:
+```
+let res := f arg
+res
+```
+The majority (if not all) tail calls will be brought into this form
+by the simplifier pass.
+
+Furthermore a `fun` disqualifies as a join point if turning it into a join
+point would turn a call to it into an out of scope join point.
+This can happen if we have something like:
+```
+def test (b : Bool) (x y : Nat) : Nat :=
+  fun myjp x => Nat.add x (Nat.add x x)
+  fun f y =>
+    let x := Nat.add y y
+    myjp x
+  fun f y =>
+    let x := Nat.mul y y
+    myjp x
+  cases b (f x) (g y)
+```
+`f` and `g` can be detected as a join point right away, however
+`myjp` can only ever be detected as a join point after we have established
+this. This is because otherwise the calls to `myjp` in `f` and `g` would
+produce out of scope join point jumps.
+-/
+partial def find (decl : Decl) : CompilerM FindState := do
+  let (_, candidates) ← decl.value.forCodeM go |>.run none |>.run {} |>.run' {}
+  return candidates
+where
+  go : Code → FindM Unit
+  | .let decl k => do
+    match k, decl.value with
+    | .return valId, .fvar fvarId args =>
+      args.forM removeCandidatesInArg
+      if let some candidateInfo ← findCandidate? fvarId then
+        -- Erase candidate that are not fully applied or applied outside of tail position
+        if valId != decl.fvarId || args.size != candidateInfo.arity then
+          eraseCandidate fvarId
+        -- Out of scope join point candidate handling
+        else if let some upperCandidate ← read then
+          if !(← isInScope fvarId) then
+            addDependency fvarId upperCandidate
+      else
+        eraseCandidate fvarId
+    | _, _ =>
+      removeCandidatesInLetValue decl.value
+      go k
+  | .fun decl k => do
+    withReader (fun _ => some decl.fvarId) do
+      withNewScope do
+        go decl.value
+    addCandidate decl.fvarId decl.getArity
+    addToScope decl.fvarId
+    go k
+  | .jp decl k => do
+    go decl.value
+    go k
+  | .jmp _ args => args.forM removeCandidatesInArg
+  | .return val => eraseCandidate val
+  | .cases c => do
+    eraseCandidate c.discr
+    c.alts.forM (·.forCodeM go)
+  | .unreach .. => return ()
+
+/--
+Replace all join point candidate `fun` declarations with `jp` ones
+and all calls to them with `jmp`s.
+-/
+partial def replace (decl : Decl) (state : FindState) : CompilerM Decl := do
+  let mapper := fun acc cname _ => do return acc.insert cname (← mkFreshJpName)
+  let replaceCtx : ReplaceCtx ← state.candidates.foldM (init := ∅) mapper
+  let newValue ← decl.value.mapCodeM go |>.run replaceCtx
+  return { decl with value := newValue }
+where
+  go (code : Code) : ReplaceM Code := do
+    match code with
+    | .let decl k =>
+      match k, decl.value with
+      | .return valId, .fvar fvarId args =>
+        if valId == decl.fvarId then
+          if (← read).contains fvarId then
+            eraseLetDecl decl
+            return .jmp fvarId args
+          else
+            return code
+        else
+          return code
+      | _, _ => return Code.updateLet! code decl (← go k)
+    | .fun decl k =>
+      if let some replacement := (← read)[decl.fvarId]? then
+        let newDecl := { decl with
+          binderName := replacement,
+          value := (← go decl.value)
+        }
+        modifyLCtx fun lctx => lctx.addFunDecl newDecl
+        return .jp newDecl (← go k)
+      else
+        let newDecl ← decl.updateValue (← go decl.value)
+        return Code.updateFun! code newDecl (← go k)
+    | .jp decl k =>
+       let newDecl ← decl.updateValue (← go decl.value)
+       return Code.updateFun! code newDecl (← go k)
+    | .cases cs =>
+      return Code.updateCases! code cs.resultType cs.discr (← cs.alts.mapM (·.mapCodeM go))
+    | .jmp .. | .return .. | .unreach .. =>
+      return code
+
+end JoinPointFinder
+
+namespace JoinPointContextExtender
+
+open ScopeM
+
+/--
+The context managed by `ExtendM`.
+-/
+structure ExtendContext where
+  /--
+  The `FVarId` of the current join point if we are currently inside one.
+  -/
+  currentJp? : Option FVarId := none
+  /--
+  The list of valid candidates for extending the context. This will be
+  all `let` and `fun` declarations as well as all `jp` parameters up
+  until the last `fun` declaration in the tree.
+  -/
+  candidates : FVarIdSet := {}
+
+/--
+The state managed by `ExtendM`.
+-/
+structure ExtendState where
+  /--
+  A map from join point `FVarId`s to a respective map from free variables
+  to `Param`s. The free variables in this map are the once that the context
+  of said join point will be extended by passing in the respective parameter.
+  -/
+  fvarMap : Std.HashMap FVarId (Std.HashMap FVarId Param) := {}
+
+/--
+The monad for the `extendJoinPointContext` pass.
+-/
+abbrev ExtendM := ReaderT ExtendContext StateRefT ExtendState ScopeM
+
+/--
+Replace a free variable if necessary, that is:
+- It is in the list of candidates
+- We are currently within a join point (if we are within a function there
+  cannot be a need to replace them since we dont extend their context)
+- Said join point actually has a replacement parameter registered.
+otherwise just return `fvar`.
+-/
+def replaceFVar (fvar : FVarId) : ExtendM FVarId := do
+  if (← read).candidates.contains fvar then
+    if let some currentJp := (← read).currentJp? then
+      if let some replacement := (← get).fvarMap[currentJp]![fvar]? then
+        return replacement.fvarId
+  return fvar
+
+/--
+Add a new candidate to the current scope + to the list of candidates
+if we are currently within a join point. Then execute `x`.
+-/
+def withNewCandidate (fvar : FVarId) (x : ExtendM α) : ExtendM α := do
+  addToScope fvar
+  if (← read).currentJp?.isSome then
+    withReader (fun ctx => { ctx with candidates := ctx.candidates.insert fvar }) do
+      x
+  else
+    x
+
+/--
+Same as `withNewCandidate` but with multiple `FVarId`s.
+-/
+def withNewCandidates (fvars : Array FVarId) (x : ExtendM α) : ExtendM α := do
+  if (← read).currentJp?.isSome then
+    let candidates := (← read).candidates
+    let folder (acc : FVarIdSet) (val : FVarId) := do
+      addToScope val
+      return acc.insert val
+    let newCandidates ← fvars.foldlM (init := candidates) folder
+    withReader (fun ctx => { ctx with candidates := newCandidates }) do
+      x
+  else
+    x
+
+/--
+Extend the context of the current join point (if we are within one)
+by `fvar` if necessary.
+This is necessary if:
+- `fvar` is not in scope (that is, was declared outside of the current jp)
+- we have not already extended the context by `fvar`
+- the list of candidates contains `fvar`. This is because if we have something
+  like:
+  ```
+  let x := ..
+  fun f a =>
+    jp j b =>
+      let y := x
+      y
+  ```
+  There is no point in extending the context of `j` by `x` because we
+  cannot lift a join point outside of a local function declaration.
+-/
+def extendByIfNecessary (fvar : FVarId) : ExtendM Unit := do
+  if let some currentJp := (← read).currentJp? then
+    let mut translator := (← get).fvarMap[currentJp]!
+    let candidates := (← read).candidates
+    if !(← isInScope fvar) && !translator.contains fvar && candidates.contains fvar then
+      let typ ← getType fvar
+      let newParam ← mkAuxParam typ
+      translator := translator.insert fvar newParam
+      modify fun s => { s with fvarMap := s.fvarMap.insert currentJp translator }
+
+/--
+Merge the extended context of two join points if necessary. That is
+if we have a structure such as:
+```
+jp j.1 ... =>
+  jp j.2 .. =>
+    ...
+  ...
+```
+And we are just done visiting `j.2` we want to extend the context of
+`j.1` by all free variables that the context of `j.2` was extended by
+as well because we need to drag these variables through at the call sites
+of `j.2` in `j.1`.
+-/
+def mergeJpContextIfNecessary (jp : FVarId) : ExtendM Unit := do
+  if (← read).currentJp?.isSome then
+    let additionalArgs := (← get).fvarMap[jp]!.toArray
+    for (fvar, _) in additionalArgs do
+      extendByIfNecessary fvar
+
+/--
+We call this whenever we enter a new local function. It clears both the
+current join point and the list of candidates since we can't lift join
+points outside of functions as explained in `mergeJpContextIfNecessary`.
+-/
+def withNewFunScope (x : ExtendM α): ExtendM α := do
+  withReader (fun ctx => { ctx with currentJp? := none, candidates := {} }) do
+    withNewScope do
+      x
+
+/--
+We call this whenever we enter a new join point. It will set the current
+join point and extend the list of candidates by all of the parameters of
+the join point. This is so in the case of nested join points that refer
+to parameters of the current one we extend the context of the nested
+join points by said parameters.
+-/
+def withNewJpScope (decl : FunDecl) (x : ExtendM α): ExtendM α := do
+  withReader (fun ctx => { ctx with currentJp? := some decl.fvarId }) do
+    modify fun s => { s with fvarMap := s.fvarMap.insert decl.fvarId {} }
+    withNewScope do
+      withNewCandidates (decl.params.map (·.fvarId)) do
+        x
+
+/--
+We call this whenever we visit a new arm of a cases statement.
+It will back up the current scope (since we are doing a case split
+and want to continue with other arms afterwards) and add all of the
+parameters of the match arm to the list of candidates.
+-/
+def withNewAltScope (alt : Alt) (x : ExtendM α) : ExtendM α := do
+  withBackTrackingScope do
+    withNewCandidates (alt.getParams.map (·.fvarId)) do
+      x
+
+/--
+Use all of the above functions to find free variables declared outside
+of join points that said join points can be reasonaly extended by. Reasonable
+meaning that in case the current join point is nested within a function
+declaration we will not extend it by free variables declared before the
+function declaration because we cannot lift join points outside of function
+declarations.
+
+All of this is done to eliminate dependencies of join points onto their
+position within the code so we can pull them out as far as possible, hopefully
+enabling new inlining possibilities in the next simplifier run.
+-/
+partial def extend (decl : Decl) : CompilerM Decl := do
+  let newValue ← decl.value.mapCodeM go |>.run {} |>.run' {} |>.run' {}
+  let decl := { decl with value := newValue }
+  decl.pullFunDecls
+where
+  goFVar (fvar : FVarId) : ExtendM FVarId := do
+    extendByIfNecessary fvar
+    replaceFVar fvar
+  go (code : Code) : ExtendM Code := do
+    match code with
+    | .let decl k =>
+      let decl ← decl.updateValue (← mapFVarM goFVar decl.value)
+      withNewCandidate decl.fvarId do
+        return Code.updateLet! code decl (← go k)
+    | .jp decl k =>
+      let decl ← withNewJpScope decl do
+        let value ← go decl.value
+        let additionalParams := (← get).fvarMap[decl.fvarId]!.toArray |>.map Prod.snd
+        let newType := additionalParams.foldr (init := decl.type) (fun val acc => .forallE val.binderName val.type acc .default)
+        decl.update newType (additionalParams ++ decl.params) value
+      mergeJpContextIfNecessary decl.fvarId
+      withNewCandidate decl.fvarId do
+        return Code.updateFun! code decl (← go k)
+    | .fun decl k =>
+      let decl ← withNewFunScope do
+        decl.updateValue (← go decl.value)
+      withNewCandidate decl.fvarId do
+        return Code.updateFun! code decl (← go k)
+    | .cases cs =>
+      extendByIfNecessary cs.discr
+      let discr ← replaceFVar cs.discr
+      let visitor := fun alt => do
+        withNewAltScope alt do
+          alt.mapCodeM go
+      let alts ← cs.alts.mapM visitor
+      return Code.updateCases! code cs.resultType discr alts
+    | .jmp fn args =>
+      let mut newArgs ← args.mapM (mapFVarM goFVar)
+      let additionalArgs := (← get).fvarMap[fn]!.toArray |>.map Prod.fst
+      if let some _currentJp := (← read).currentJp? then
+        let f := fun arg => do
+          return .fvar (← goFVar arg)
+        newArgs := (←additionalArgs.mapM f) ++ newArgs
+      else
+        newArgs := (additionalArgs.map .fvar) ++ newArgs
+      return Code.updateJmp! code fn newArgs
+    | .return var =>
+      extendByIfNecessary var
+      return Code.updateReturn! code (← replaceFVar var)
+    | .unreach .. => return code
+
+end JoinPointContextExtender
+
+namespace JoinPointCommonArgs
+
+/--
+Context for `ReduceAnalysisM`.
+-/
+structure AnalysisCtx where
+  /--
+  The variables that are in scope at the time of the definition of
+  the join point.
+  -/
+  jpScopes : FVarIdMap FVarIdSet := {}
+
+/--
+State for `ReduceAnalysisM`.
+-/
+structure AnalysisState where
+  /--
+  A map, that for each join point id contains a map from all (so far)
+  duplicated argument ids to the respective duplicate value
+  -/
+  jpJmpArgs : FVarIdMap FVarSubst := {}
+
+abbrev ReduceAnalysisM := ReaderT AnalysisCtx StateRefT AnalysisState ScopeM
+abbrev ReduceActionM := ReaderT AnalysisState CompilerM
+
+def isInJpScope (jp : FVarId) (var : FVarId) : ReduceAnalysisM Bool := do
+  return (← read).jpScopes.find! jp |>.contains var
+
+open ScopeM
+
+/--
+Take a look at each join point and each of their call sites. If all
+call sites of a join point have one or more arguments in common, for example:
+```
+jp _jp.1 a b c => ...
+...
+cases foo
+| n1 => jmp _jp.1 d e f
+| n2 => jmp _jp.1 g e h
+```
+We can get rid of the common argument in favour of inlining it directly
+into the join point (in this case the `e`). This reduces the amount of
+arguments we have to pass around drastically for example in `ReaderT` based
+monad stacks.
+
+Note 1: This transformation can in certain niche cases obtain better results.
+For example:
+```
+jp foo a b => ..
+let x := ...
+cases discr
+| n1 => jmp foo x y
+| n2 => jmp foo x z
+```
+Here we will not collapse the `x` since it is defined after the join point `foo`
+and thus not accessible for substitution yet. We could however reorder the code in
+such a way that this is possible, this is currently not done since we observe
+than in praxis most of the applications of this transformation can occur naturally
+without reordering.
+
+Note 2: This transformation is kind of the opposite of `JoinPointContextExtender`.
+However we still benefit from the extender because in the `simp` run after it
+we might be able to pull join point declarations further up in the hierarchy
+of nested functions/join points which in turn might enable additional optimizations.
+After we have performed all of these optimizations we can take away the
+(remaining) common arguments and end up with nicely floated and optimized
+code that has as little arguments as possible in the join points.
+-/
+partial def reduce (decl : Decl) : CompilerM Decl := do
+  let (_, analysis) ← decl.value.forCodeM goAnalyze |>.run {} |>.run {} |>.run' {}
+  let newValue ← decl.value.mapCodeM goReduce |>.run analysis
+  return { decl with value := newValue }
+where
+  goAnalyzeFunDecl (fn : FunDecl) : ReduceAnalysisM Unit := do
+    withNewScope do
+      fn.params.forM (addToScope ·.fvarId)
+      goAnalyze fn.value
+
+  goAnalyze (code : Code) : ReduceAnalysisM Unit := do
+    match code with
+    | .let decl k =>
+      addToScope decl.fvarId
+      goAnalyze k
+    | .jp decl k =>
+      goAnalyzeFunDecl decl
+      let scope ← getScope
+      withReader (fun ctx => { ctx with jpScopes := ctx.jpScopes.insert decl.fvarId scope }) do
+        addToScope decl.fvarId
+        goAnalyze k
+    | .fun decl k =>
+      goAnalyzeFunDecl decl
+      addToScope decl.fvarId
+      goAnalyze k
+    | .cases cs =>
+      let visitor alt := do
+        withNewScope do
+          alt.getParams.forM (addToScope ·.fvarId)
+          goAnalyze alt.getCode
+      cs.alts.forM visitor
+    | .jmp fn args =>
+      let decl ← getFunDecl fn
+      if let some knownArgs := (← get).jpJmpArgs.find? fn then
+        let mut newArgs := knownArgs
+        for (param, arg) in decl.params.zip args do
+          if let some knownVal := newArgs[param.fvarId]? then
+            if arg != knownVal then
+              newArgs := newArgs.erase param.fvarId
+        modify fun s => { s with jpJmpArgs := s.jpJmpArgs.insert fn newArgs }
+      else
+        let folder := fun acc (param, arg) => do
+          if (← allFVarM (isInJpScope fn) arg) then
+            return acc.insert param.fvarId arg
+          else
+            return acc
+        let interestingArgs ← decl.params.zip args |>.foldlM (init := {}) folder
+        modify fun s => { s with jpJmpArgs := s.jpJmpArgs.insert fn interestingArgs }
+    | .return .. | .unreach .. => return ()
+
+  goReduce (code : Code) : ReduceActionM Code := do
+    match code with
+    | .jp decl k =>
+      if let some reducibleArgs := (← read).jpJmpArgs.find? decl.fvarId then
+        let filter param := do
+          let erasable := reducibleArgs.contains param.fvarId
+          if erasable then
+            eraseParam param
+          return !erasable
+        let newParams ← decl.params.filterM filter
+        let mut newValue ← goReduce decl.value
+        newValue ← replaceFVars newValue reducibleArgs false
+        let newType ←
+          if newParams.size != decl.params.size then
+            mkForallParams newParams (← newValue.inferType)
+          else
+            pure decl.type
+        let k ← goReduce k
+        let decl ← decl.update newType newParams newValue
+        return Code.updateFun! code decl k
+      else
+        return Code.updateFun! code decl (← goReduce k)
+    | .jmp fn args =>
+      let reducibleArgs := (← read).jpJmpArgs.find! fn
+      let decl ← getFunDecl fn
+      let newParams := decl.params.zip args
+        |>.filter (!reducibleArgs.contains ·.fst.fvarId)
+        |>.map Prod.snd
+      return Code.updateJmp! code fn newParams
+    | .let decl k =>
+      return Code.updateLet! code decl (← goReduce k)
+    | .fun decl k =>
+      let decl ← decl.updateValue (← goReduce decl.value)
+      return Code.updateFun! code decl (← goReduce k)
+    | .cases cs =>
+      let alts ← cs.alts.mapM (·.mapCodeM goReduce)
+      return Code.updateCases! code cs.resultType cs.discr alts
+    | .return .. | .unreach .. => return code
+
+end JoinPointCommonArgs
+
+/--
+Find all `fun` declarations in `decl` that qualify as join points then replace
+their definitions and call sites with `jp`/`jmp`.
+-/
+def Decl.findJoinPoints (decl : Decl) : CompilerM Decl := do
+  let findResult ← JoinPointFinder.find decl
+  trace[Compiler.findJoinPoints] "Found: {findResult.candidates.size} jp candidates"
+  JoinPointFinder.replace decl findResult
+
+def findJoinPoints : Pass :=
+  .mkPerDeclaration `findJoinPoints Decl.findJoinPoints .base
+
+builtin_initialize
+  registerTraceClass `Compiler.findJoinPoints (inherited := true)
+
+def Decl.extendJoinPointContext (decl : Decl) : CompilerM Decl := do
+  JoinPointContextExtender.extend decl
+
+def extendJoinPointContext (occurrence : Nat := 0) (phase := Phase.mono) (_h : phase ≠ .base := by simp): Pass :=
+  .mkPerDeclaration `extendJoinPointContext Decl.extendJoinPointContext phase (occurrence := occurrence)
+
+builtin_initialize
+  registerTraceClass `Compiler.extendJoinPointContext (inherited := true)
+
+def Decl.commonJoinPointArgs (decl : Decl) : CompilerM Decl := do
+  JoinPointCommonArgs.reduce decl
+
+def commonJoinPointArgs : Pass :=
+  .mkPerDeclaration `commonJoinPointArgs Decl.commonJoinPointArgs .mono
+
+builtin_initialize
+  registerTraceClass `Compiler.commonJoinPointArgs (inherited := true)
+
+end Lean.Compiler.LCNF

backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/LambdaLifting.lean

@@ -0,0 +1,190 @@
+/-
+Copyright (c) 2022 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Lean.Meta.Instances
+import Lean.Compiler.InlineAttrs
+import Lean.Compiler.LCNF.Closure
+import Lean.Compiler.LCNF.Types
+import Lean.Compiler.LCNF.MonadScope
+import Lean.Compiler.LCNF.Internalize
+import Lean.Compiler.LCNF.Level
+import Lean.Compiler.LCNF.AuxDeclCache
+
+namespace Lean.Compiler.LCNF
+namespace LambdaLifting
+
+/-- Context for the `LiftM` monad. -/
+structure Context where
+  /--
+  If `liftInstParamOnly` is `true`, then only local functions that take
+  local instances as parameters are lambda lifted.
+  -/
+  liftInstParamOnly : Bool := false
+  /-- Suffix for the new auxiliary declarations being created. -/
+  suffix : Name
+  /--
+  Declaration where lambda lifting is being applied.
+  We use it to provide the "base name" for auxiliary declarations and the flag `safe`.
+  -/
+  mainDecl : Decl
+  /--
+  If true, the lambda-lifted functions inherit the inline attribute from `mainDecl`.
+  We use this feature to implement `@[inline] instance ...` and `@[always_inline] instance ...`
+  -/
+  inheritInlineAttrs := false
+  /--
+  Only local functions with `size > minSize` are lambda lifted.
+  We use this feature to implement `@[inline] instance ...` and `@[always_inline] instance ...`
+  -/
+  minSize : Nat := 0
+
+
+/-- State for the `LiftM` monad. -/
+structure State where
+  /--
+  New auxiliary declarations
+  -/
+  decls  : Array Decl := #[]
+  /--
+  Next index for generating auxiliary declaration name.
+  -/
+  nextIdx := 0
+
+/-- Monad for applying lambda lifting. -/
+abbrev LiftM := ReaderT Context (StateRefT State (ScopeT CompilerM))
+
+/--
+Return `true` if the given declaration takes a local instance as a parameter.
+We lambda lift this kind of local function declaration before specialization.
+-/
+def hasInstParam (decl : FunDecl) : CompilerM Bool :=
+  decl.params.anyM fun param => return (← isArrowClass? param.type).isSome
+
+/--
+Return `true` if the given declaration should be lambda lifted.
+-/
+def shouldLift (decl : FunDecl) : LiftM Bool := do
+  let minSize := (← read).minSize
+  if decl.value.size < minSize then
+    return false
+  else if (← read).liftInstParamOnly then
+    hasInstParam decl
+  else
+    return true
+
+partial def mkAuxDeclName : LiftM Name := do
+  let nextIdx ← modifyGet fun s => (s.nextIdx, { s with nextIdx := s.nextIdx + 1})
+  let nameNew := (← read).mainDecl.name ++ (← read).suffix.appendIndexAfter nextIdx
+  if (← getDecl? nameNew).isNone then return nameNew
+  mkAuxDeclName
+
+open Internalize in
+/--
+Create a new auxiliary declaration. The array `closure` contains all free variables
+occurring in `decl`.
+-/
+def mkAuxDecl (closure : Array Param) (decl : FunDecl) : LiftM LetDecl := do
+  let nameNew ← mkAuxDeclName
+  let inlineAttr? ← if (← read).inheritInlineAttrs then pure (← read).mainDecl.inlineAttr? else pure none
+  let auxDecl ← go nameNew (← read).mainDecl.safe inlineAttr? |>.run' {}
+  let us := auxDecl.levelParams.map mkLevelParam
+  let auxDeclName ← match (← cacheAuxDecl auxDecl) with
+  | .new =>
+    auxDecl.save
+    modify fun { decls, .. } => { decls := decls.push auxDecl }
+    pure auxDecl.name
+  | .alreadyCached declName =>
+    auxDecl.erase
+    pure declName
+  let value := .const auxDeclName us (closure.map (.fvar ·.fvarId))
+  /- We reuse `decl`s `fvarId` to avoid substitution -/
+  let declNew := { fvarId := decl.fvarId, binderName := decl.binderName, type := decl.type, value }
+  modifyLCtx fun lctx => lctx.addLetDecl declNew
+  eraseFunDecl decl
+  return declNew
+where
+  go (nameNew : Name) (safe : Bool) (inlineAttr? : Option InlineAttributeKind) : InternalizeM Decl := do
+    let params := (← closure.mapM internalizeParam) ++ (← decl.params.mapM internalizeParam)
+    let code ← internalizeCode decl.value
+    let type ← code.inferType
+    let type ← mkForallParams params type
+    let value := .code code
+    let decl := { name := nameNew, levelParams := [], params, type, value, safe, inlineAttr?, recursive := false : Decl }
+    return decl.setLevelParams
+
+mutual
+  partial def visitFunDecl (funDecl : FunDecl) : LiftM FunDecl := do
+    let value ← withParams funDecl.params <| visitCode funDecl.value
+    funDecl.update' funDecl.type value
+
+  partial def visitCode (code : Code) : LiftM Code := do
+    match code with
+    | .let decl k =>
+      let k ← withFVar decl.fvarId <| visitCode k
+      return code.updateLet! decl k
+    | .fun decl k =>
+      let decl ← visitFunDecl decl
+      if (← shouldLift decl) then
+        let scope ← getScope
+        let (_, params, _) ← Closure.run (inScope := scope.contains) <| Closure.collectFunDecl decl
+        let declNew ← mkAuxDecl params decl
+        let k ← withFVar declNew.fvarId <| visitCode k
+        return .let declNew k
+      else
+        let k ← withFVar decl.fvarId <| visitCode k
+        return code.updateFun! decl k
+    | .jp decl k =>
+      let decl ← visitFunDecl decl
+      let k ← withFVar decl.fvarId <| visitCode k
+      return code.updateFun! decl k
+    | .cases c =>
+      let alts ← c.alts.mapMonoM fun alt =>
+        match alt with
+        | .default k => return alt.updateCode (← visitCode k)
+        | .alt _ ps k => withParams ps do return alt.updateCode (← visitCode k)
+      return code.updateAlts! alts
+    | .unreach .. | .jmp .. | .return .. => return code
+end
+
+def main (decl : Decl) : LiftM Decl := do
+  let value ← withParams decl.params <| decl.value.mapCodeM visitCode
+  return { decl with value }
+
+end LambdaLifting
+
+partial def Decl.lambdaLifting (decl : Decl) (liftInstParamOnly : Bool) (suffix : Name) (inheritInlineAttrs := false) (minSize := 0) : CompilerM (Array Decl) := do
+  let (decl, s) ← LambdaLifting.main decl |>.run { mainDecl := decl, liftInstParamOnly, suffix, inheritInlineAttrs, minSize } |>.run {} |>.run {}
+  return s.decls.push decl
+
+/--
+Eliminate all local function declarations.
+-/
+def lambdaLifting : Pass where
+  phase      := .mono
+  name       := `lambdaLifting
+  run        := fun decls => do
+    decls.foldlM (init := #[]) fun decls decl => return decls ++ (← decl.lambdaLifting false (suffix := `_lam))
+
+/--
+During eager lambda lifting, we lift
+- All local function declarations from instances (motivation: make sure it is cheap to inline them later)
+- Local function declarations that take local instances as parameters (motivation: ensure they are specialized)
+-/
+def eagerLambdaLifting : Pass where
+  phase      := .base
+  name       := `eagerLambdaLifting
+  run        := fun decls => do
+    decls.foldlM (init := #[]) fun decls decl => do
+      if decl.inlineAttr || (← Meta.isInstance decl.name) then
+        return decls.push decl
+      else
+        return decls ++ (← decl.lambdaLifting (liftInstParamOnly := true) (suffix := `_elam))
+
+builtin_initialize
+  registerTraceClass `Compiler.eagerLambdaLifting (inherited := true)
+  registerTraceClass `Compiler.lambdaLifting (inherited := true)
+
+end Lean.Compiler.LCNF

external/alphageometry/.venv-ag/Lib/site-packages/fontTools/subset/__main__.py

@@ -0,0 +1,6 @@
+import sys
+from fontTools.subset import main
+
+
+if __name__ == "__main__":
+    sys.exit(main())

external/alphageometry/.venv-ag/Lib/site-packages/fontTools/subset/cff.py

@@ -0,0 +1,184 @@
+from fontTools.misc import psCharStrings
+from fontTools import ttLib
+from fontTools.pens.basePen import NullPen
+from fontTools.misc.roundTools import otRound
+from fontTools.misc.loggingTools import deprecateFunction
+from fontTools.subset.util import _add_method, _uniq_sort
+
+
+class _ClosureGlyphsT2Decompiler(psCharStrings.SimpleT2Decompiler):
+    def __init__(self, components, localSubrs, globalSubrs):
+        psCharStrings.SimpleT2Decompiler.__init__(self, localSubrs, globalSubrs)
+        self.components = components
+
+    def op_endchar(self, index):
+        args = self.popall()
+        if len(args) >= 4:
+            from fontTools.encodings.StandardEncoding import StandardEncoding
+
+            # endchar can do seac accent bulding; The T2 spec says it's deprecated,
+            # but recent software that shall remain nameless does output it.
+            adx, ady, bchar, achar = args[-4:]
+            baseGlyph = StandardEncoding[bchar]
+            accentGlyph = StandardEncoding[achar]
+            self.components.add(baseGlyph)
+            self.components.add(accentGlyph)
+
+
+@_add_method(ttLib.getTableClass("CFF "))
+def closure_glyphs(self, s):
+    cff = self.cff
+    assert len(cff) == 1
+    font = cff[cff.keys()[0]]
+    glyphSet = font.CharStrings
+
+    decompose = s.glyphs
+    while decompose:
+        components = set()
+        for g in decompose:
+            if g not in glyphSet:
+                continue
+            gl = glyphSet[g]
+
+            subrs = getattr(gl.private, "Subrs", [])
+            decompiler = _ClosureGlyphsT2Decompiler(components, subrs, gl.globalSubrs)
+            decompiler.execute(gl)
+        components -= s.glyphs
+        s.glyphs.update(components)
+        decompose = components
+
+
+def _empty_charstring(font, glyphName, isCFF2, ignoreWidth=False):
+    c, fdSelectIndex = font.CharStrings.getItemAndSelector(glyphName)
+    if isCFF2 or ignoreWidth:
+        # CFF2 charstrings have no widths nor 'endchar' operators
+        c.setProgram([] if isCFF2 else ["endchar"])
+    else:
+        if hasattr(font, "FDArray") and font.FDArray is not None:
+            private = font.FDArray[fdSelectIndex].Private
+        else:
+            private = font.Private
+        dfltWdX = private.defaultWidthX
+        nmnlWdX = private.nominalWidthX
+        pen = NullPen()
+        c.draw(pen)  # this will set the charstring's width
+        if c.width != dfltWdX:
+            c.program = [c.width - nmnlWdX, "endchar"]
+        else:
+            c.program = ["endchar"]
+
+
+@_add_method(ttLib.getTableClass("CFF "))
+def prune_pre_subset(self, font, options):
+    cff = self.cff
+    # CFF table must have one font only
+    cff.fontNames = cff.fontNames[:1]
+
+    if options.notdef_glyph and not options.notdef_outline:
+        isCFF2 = cff.major > 1
+        for fontname in cff.keys():
+            font = cff[fontname]
+            _empty_charstring(font, ".notdef", isCFF2=isCFF2)
+
+    # Clear useless Encoding
+    for fontname in cff.keys():
+        font = cff[fontname]
+        # https://github.com/fonttools/fonttools/issues/620
+        font.Encoding = "StandardEncoding"
+
+    return True  # bool(cff.fontNames)
+
+
+@_add_method(ttLib.getTableClass("CFF "))
+def subset_glyphs(self, s):
+    cff = self.cff
+    for fontname in cff.keys():
+        font = cff[fontname]
+        cs = font.CharStrings
+
+        glyphs = s.glyphs.union(s.glyphs_emptied)
+
+        # Load all glyphs
+        for g in font.charset:
+            if g not in glyphs:
+                continue
+            c, _ = cs.getItemAndSelector(g)
+
+        if cs.charStringsAreIndexed:
+            indices = [i for i, g in enumerate(font.charset) if g in glyphs]
+            csi = cs.charStringsIndex
+            csi.items = [csi.items[i] for i in indices]
+            del csi.file, csi.offsets
+            if hasattr(font, "FDSelect"):
+                sel = font.FDSelect
+                sel.format = None
+                sel.gidArray = [sel.gidArray[i] for i in indices]
+            newCharStrings = {}
+            for indicesIdx, charsetIdx in enumerate(indices):
+                g = font.charset[charsetIdx]
+                if g in cs.charStrings:
+                    newCharStrings[g] = indicesIdx
+            cs.charStrings = newCharStrings
+        else:
+            cs.charStrings = {g: v for g, v in cs.charStrings.items() if g in glyphs}
+        font.charset = [g for g in font.charset if g in glyphs]
+        font.numGlyphs = len(font.charset)
+
+        if s.options.retain_gids:
+            isCFF2 = cff.major > 1
+            for g in s.glyphs_emptied:
+                _empty_charstring(font, g, isCFF2=isCFF2, ignoreWidth=True)
+
+    return True  # any(cff[fontname].numGlyphs for fontname in cff.keys())
+
+
+@_add_method(ttLib.getTableClass("CFF "))
+def prune_post_subset(self, ttfFont, options):
+    cff = self.cff
+    for fontname in cff.keys():
+        font = cff[fontname]
+        cs = font.CharStrings
+
+        # Drop unused FontDictionaries
+        if hasattr(font, "FDSelect"):
+            sel = font.FDSelect
+            indices = _uniq_sort(sel.gidArray)
+            sel.gidArray = [indices.index(ss) for ss in sel.gidArray]
+            arr = font.FDArray
+            arr.items = [arr[i] for i in indices]
+            del arr.file, arr.offsets
+
+    # Desubroutinize if asked for
+    if options.desubroutinize:
+        cff.desubroutinize()
+
+    # Drop hints if not needed
+    if not options.hinting:
+        self.remove_hints()
+    elif not options.desubroutinize:
+        self.remove_unused_subroutines()
+    return True
+
+
+@deprecateFunction(
+    "use 'CFFFontSet.desubroutinize()' instead", category=DeprecationWarning
+)
+@_add_method(ttLib.getTableClass("CFF "))
+def desubroutinize(self):
+    self.cff.desubroutinize()
+
+
+@deprecateFunction(
+    "use 'CFFFontSet.remove_hints()' instead", category=DeprecationWarning
+)
+@_add_method(ttLib.getTableClass("CFF "))
+def remove_hints(self):
+    self.cff.remove_hints()
+
+
+@deprecateFunction(
+    "use 'CFFFontSet.remove_unused_subroutines' instead", category=DeprecationWarning
+)
+@_add_method(ttLib.getTableClass("CFF "))
+def remove_unused_subroutines(self):
+    self.cff.remove_unused_subroutines()

external/alphageometry/.venv-ag/Lib/site-packages/fontTools/subset/svg.py

@@ -0,0 +1,253 @@
+from __future__ import annotations
+
+import re
+from functools import lru_cache
+from itertools import chain, count
+from typing import Dict, Iterable, Iterator, List, Optional, Set, Tuple
+
+try:
+    from lxml import etree
+except ImportError:
+    # lxml is required for subsetting SVG, but we prefer to delay the import error
+    # until subset_glyphs() is called (i.e. if font to subset has an 'SVG ' table)
+    etree = None
+
+from fontTools import ttLib
+from fontTools.subset.util import _add_method
+from fontTools.ttLib.tables.S_V_G_ import SVGDocument
+
+
+__all__ = ["subset_glyphs"]
+
+
+GID_RE = re.compile(r"^glyph(\d+)$")
+
+NAMESPACES = {
+    "svg": "http://www.w3.org/2000/svg",
+    "xlink": "http://www.w3.org/1999/xlink",
+}
+XLINK_HREF = f'{{{NAMESPACES["xlink"]}}}href'
+
+
+# TODO(antrotype): Replace with functools.cache once we are 3.9+
+@lru_cache(maxsize=None)
+def xpath(path):
+    # compile XPath upfront, caching result to reuse on multiple elements
+    return etree.XPath(path, namespaces=NAMESPACES)
+
+
+def group_elements_by_id(tree: etree.Element) -> Dict[str, etree.Element]:
+    # select all svg elements with 'id' attribute no matter where they are
+    # including the root element itself:
+    # https://github.com/fonttools/fonttools/issues/2548
+    return {el.attrib["id"]: el for el in xpath("//svg:*[@id]")(tree)}
+
+
+def parse_css_declarations(style_attr: str) -> Dict[str, str]:
+    # https://developer.mozilla.org/en-US/docs/Web/SVG/Attribute/style
+    # https://developer.mozilla.org/en-US/docs/Web/CSS/Syntax#css_declarations
+    result = {}
+    for declaration in style_attr.split(";"):
+        if declaration.count(":") == 1:
+            property_name, value = declaration.split(":")
+            property_name = property_name.strip()
+            result[property_name] = value.strip()
+        elif declaration.strip():
+            raise ValueError(f"Invalid CSS declaration syntax: {declaration}")
+    return result
+
+
+def iter_referenced_ids(tree: etree.Element) -> Iterator[str]:
+    # Yield all the ids that can be reached via references from this element tree.
+    # We currently support xlink:href (as used by <use> and gradient templates),
+    # and local url(#...) links found in fill or clip-path attributes
+    # TODO(anthrotype): Check we aren't missing other supported kinds of reference
+    find_svg_elements_with_references = xpath(
+        ".//svg:*[ "
+        "starts-with(@xlink:href, '#') "
+        "or starts-with(@fill, 'url(#') "
+        "or starts-with(@clip-path, 'url(#') "
+        "or contains(@style, ':url(#') "
+        "]",
+    )
+    for el in chain([tree], find_svg_elements_with_references(tree)):
+        ref_id = href_local_target(el)
+        if ref_id is not None:
+            yield ref_id
+
+        attrs = el.attrib
+        if "style" in attrs:
+            attrs = {**dict(attrs), **parse_css_declarations(el.attrib["style"])}
+        for attr in ("fill", "clip-path"):
+            if attr in attrs:
+                value = attrs[attr]
+                if value.startswith("url(#") and value.endswith(")"):
+                    ref_id = value[5:-1]
+                    assert ref_id
+                    yield ref_id
+
+
+def closure_element_ids(
+    elements: Dict[str, etree.Element], element_ids: Set[str]
+) -> None:
+    # Expand the initial subset of element ids to include ids that can be reached
+    # via references from the initial set.
+    unvisited = element_ids
+    while unvisited:
+        referenced: Set[str] = set()
+        for el_id in unvisited:
+            if el_id not in elements:
+                # ignore dangling reference; not our job to validate svg
+                continue
+            referenced.update(iter_referenced_ids(elements[el_id]))
+        referenced -= element_ids
+        element_ids.update(referenced)
+        unvisited = referenced
+
+
+def subset_elements(el: etree.Element, retained_ids: Set[str]) -> bool:
+    # Keep elements if their id is in the subset, or any of their children's id is.
+    # Drop elements whose id is not in the subset, and either have no children,
+    # or all their children are being dropped.
+    if el.attrib.get("id") in retained_ids:
+        # if id is in the set, don't recurse; keep whole subtree
+        return True
+    # recursively subset all the children; we use a list comprehension instead
+    # of a parentheses-less generator expression because we don't want any() to
+    # short-circuit, as our function has a side effect of dropping empty elements.
+    if any([subset_elements(e, retained_ids) for e in el]):
+        return True
+    assert len(el) == 0
+    parent = el.getparent()
+    if parent is not None:
+        parent.remove(el)
+    return False
+
+
+def remap_glyph_ids(
+    svg: etree.Element, glyph_index_map: Dict[int, int]
+) -> Dict[str, str]:
+    # Given {old_gid: new_gid} map, rename all elements containing id="glyph{gid}"
+    # special attributes
+    elements = group_elements_by_id(svg)
+    id_map = {}
+    for el_id, el in elements.items():
+        m = GID_RE.match(el_id)
+        if not m:
+            continue
+        old_index = int(m.group(1))
+        new_index = glyph_index_map.get(old_index)
+        if new_index is not None:
+            if old_index == new_index:
+                continue
+            new_id = f"glyph{new_index}"
+        else:
+            # If the old index is missing, the element correspond to a glyph that was
+            # excluded from the font's subset.
+            # We rename it to avoid clashes with the new GIDs or other element ids.
+            new_id = f".{el_id}"
+            n = count(1)
+            while new_id in elements:
+                new_id = f"{new_id}.{next(n)}"
+
+        id_map[el_id] = new_id
+        el.attrib["id"] = new_id
+
+    return id_map
+
+
+def href_local_target(el: etree.Element) -> Optional[str]:
+    if XLINK_HREF in el.attrib:
+        href = el.attrib[XLINK_HREF]
+        if href.startswith("#") and len(href) > 1:
+            return href[1:]  # drop the leading #
+    return None
+
+
+def update_glyph_href_links(svg: etree.Element, id_map: Dict[str, str]) -> None:
+    # update all xlink:href="#glyph..." attributes to point to the new glyph ids
+    for el in xpath(".//svg:*[starts-with(@xlink:href, '#glyph')]")(svg):
+        old_id = href_local_target(el)
+        assert old_id is not None
+        if old_id in id_map:
+            new_id = id_map[old_id]
+            el.attrib[XLINK_HREF] = f"#{new_id}"
+
+
+def ranges(ints: Iterable[int]) -> Iterator[Tuple[int, int]]:
+    # Yield sorted, non-overlapping (min, max) ranges of consecutive integers
+    sorted_ints = iter(sorted(set(ints)))
+    try:
+        start = end = next(sorted_ints)
+    except StopIteration:
+        return
+    for v in sorted_ints:
+        if v - 1 == end:
+            end = v
+        else:
+            yield (start, end)
+            start = end = v
+    yield (start, end)
+
+
+@_add_method(ttLib.getTableClass("SVG "))
+def subset_glyphs(self, s) -> bool:
+    if etree is None:
+        raise ImportError("No module named 'lxml', required to subset SVG")
+
+    # glyph names (before subsetting)
+    glyph_order: List[str] = s.orig_glyph_order
+    # map from glyph names to original glyph indices
+    rev_orig_glyph_map: Dict[str, int] = s.reverseOrigGlyphMap
+    # map from original to new glyph indices (after subsetting)
+    glyph_index_map: Dict[int, int] = s.glyph_index_map
+
+    new_docs: List[SVGDocument] = []
+    for doc in self.docList:
+        glyphs = {
+            glyph_order[i] for i in range(doc.startGlyphID, doc.endGlyphID + 1)
+        }.intersection(s.glyphs)
+        if not glyphs:
+            # no intersection: we can drop the whole record
+            continue
+
+        svg = etree.fromstring(
+            # encode because fromstring dislikes xml encoding decl if input is str.
+            # SVG xml encoding must be utf-8 as per OT spec.
+            doc.data.encode("utf-8"),
+            parser=etree.XMLParser(
+                # Disable libxml2 security restrictions to support very deep trees.
+                # Without this we would get an error like this:
+                # `lxml.etree.XMLSyntaxError: internal error: Huge input lookup`
+                # when parsing big fonts e.g. noto-emoji-picosvg.ttf.
+                huge_tree=True,
+                # ignore blank text as it's not meaningful in OT-SVG; it also prevents
+                # dangling tail text after removing an element when pretty_print=True
+                remove_blank_text=True,
+                # don't replace entities; we don't expect any in OT-SVG and they may
+                # be abused for XXE attacks
+                resolve_entities=False,
+            ),
+        )
+
+        elements = group_elements_by_id(svg)
+        gids = {rev_orig_glyph_map[g] for g in glyphs}
+        element_ids = {f"glyph{i}" for i in gids}
+        closure_element_ids(elements, element_ids)
+
+        if not subset_elements(svg, element_ids):
+            continue
+
+        if not s.options.retain_gids:
+            id_map = remap_glyph_ids(svg, glyph_index_map)
+            update_glyph_href_links(svg, id_map)
+
+        new_doc = etree.tostring(svg, pretty_print=s.options.pretty_svg).decode("utf-8")
+
+        new_gids = (glyph_index_map[i] for i in gids)
+        for start, end in ranges(new_gids):
+            new_docs.append(SVGDocument(new_doc, start, end, doc.compressed))
+
+    self.docList = new_docs
+
+    return bool(self.docList)