diff --git a/.gitattributes b/.gitattributes index 09751f913bb5f401014f186f616c3fd0bc38582e..30b8fe08358ceb7d15b4a60a83918f121b51f868 100644 --- a/.gitattributes +++ b/.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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/Boxing.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/Boxing.lean new file mode 100644 index 0000000000000000000000000000000000000000..9e06d2ca6f9d9bd0947ae3bb725cf5bf941bf064 --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/Checker.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/Checker.lean new file mode 100644 index 0000000000000000000000000000000000000000..269dee33555c7a2c76f15c16da58038f7be007cb --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/CompilerM.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/CompilerM.lean new file mode 100644 index 0000000000000000000000000000000000000000..17e30c9fc424ef9a7f2b31a5912c7d5b76b4e97b --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/ElimDeadBranches.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/ElimDeadBranches.lean new file mode 100644 index 0000000000000000000000000000000000000000..43514a4b8fbd6da87b3b2728ed552fa7700dd8cb --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/ElimDeadVars.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/ElimDeadVars.lean new file mode 100644 index 0000000000000000000000000000000000000000..e462e69192fc8fc0b5140fe25d20038ce0a44942 --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/EmitC.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/EmitC.lean new file mode 100644 index 0000000000000000000000000000000000000000..b45ea2eaee8e1d888c7335e28e65d613930f662b --- /dev/null +++ b/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 + #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 " + 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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/EmitLLVM.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/EmitLLVM.lean new file mode 100644 index 0000000000000000000000000000000000000000..4ae99e930a20e80a03d231857de906dcddeb6ffc --- /dev/null +++ b/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 ) + 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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/EmitUtil.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/EmitUtil.lean new file mode 100644 index 0000000000000000000000000000000000000000..0c78fda3f2c6524a3bedf624bdca274bea72e88a --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/ExpandResetReuse.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/ExpandResetReuse.lean new file mode 100644 index 0000000000000000000000000000000000000000..dbfdbdf72f4c7aa95601c1b6b75e8e60ad55d37a --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/Format.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/Format.lean new file mode 100644 index 0000000000000000000000000000000000000000..12720d830c757da481bbd84744cbd789ed26e7eb --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/FreeVars.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/FreeVars.lean new file mode 100644 index 0000000000000000000000000000000000000000..c969f68481fd99619f52d51250f08422c275566a --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/LLVMBindings.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/LLVMBindings.lean new file mode 100644 index 0000000000000000000000000000000000000000..0d5e63a81f37f92ad6032bf019e01f488df8fa23 --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/LiveVars.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/LiveVars.lean new file mode 100644 index 0000000000000000000000000000000000000000..fbb6cfc80d6504897991a1ca41a5b16d2ce7c4a2 --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/NormIds.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/NormIds.lean new file mode 100644 index 0000000000000000000000000000000000000000..32997d302ba270100712d6c2a44344a2bd6cb6a2 --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/PushProj.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/PushProj.lean new file mode 100644 index 0000000000000000000000000000000000000000..2985b313027c7a1f438caa09ba1cf7fff4091b18 --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/RC.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/RC.lean new file mode 100644 index 0000000000000000000000000000000000000000..79d9b09e4d27fc78d10a8c898d6dacb93e48357d --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/ResetReuse.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/ResetReuse.lean new file mode 100644 index 0000000000000000000000000000000000000000..e187700717a95d29ae1927a799a5896452233f79 --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/SimpCase.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/SimpCase.lean new file mode 100644 index 0000000000000000000000000000000000000000..e1519f84126e274bdb306aa447cbae28edbfe36b --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/Sorry.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/Sorry.lean new file mode 100644 index 0000000000000000000000000000000000000000..87ad1214bc5cb0eef8308cadab0719a14209c566 --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/ToIR.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/ToIR.lean new file mode 100644 index 0000000000000000000000000000000000000000..00c3cd8a6f73c40e21d6d156831648185e1e8ce5 --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/ToIRType.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/ToIRType.lean new file mode 100644 index 0000000000000000000000000000000000000000..8f67ee7fd6b061c3afaa13ddba176bde83f92d15 --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/UnboxResult.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/IR/UnboxResult.lean new file mode 100644 index 0000000000000000000000000000000000000000..eb3e6359f9aaa0658ae0de3101f0ae33fa8c23a8 --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/AlphaEqv.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/AlphaEqv.lean new file mode 100644 index 0000000000000000000000000000000000000000..c8d8a7c9e26f539527e54b54550dddda7454e407 --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/AuxDeclCache.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/AuxDeclCache.lean new file mode 100644 index 0000000000000000000000000000000000000000..1e1347138bc9626efdb53beef6b514d4ef044a46 --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/BaseTypes.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/BaseTypes.lean new file mode 100644 index 0000000000000000000000000000000000000000..a6d96e2aef5f54b7a980b2f762d5f251442efd11 --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/Basic.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/Basic.lean new file mode 100644 index 0000000000000000000000000000000000000000..5bb80a6797fd2e2fb4f7e353960eaa0798099fe3 --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/Bind.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/Bind.lean new file mode 100644 index 0000000000000000000000000000000000000000..5844bcfca19514fd029456498b70d2a8d2519597 --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/CSE.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/CSE.lean new file mode 100644 index 0000000000000000000000000000000000000000..bf0cae5557eae29fc409e185e7c85f32a8d16f74 --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/Check.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/Check.lean new file mode 100644 index 0000000000000000000000000000000000000000..419d4236baa849dc6082f47cce48aeb0824b42a3 --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/Closure.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/Closure.lean new file mode 100644 index 0000000000000000000000000000000000000000..321d7d84ef8db80db8472396d0fce387ca3706ab --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/CompatibleTypes.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/CompatibleTypes.lean new file mode 100644 index 0000000000000000000000000000000000000000..270d890af50c6115ba81700e72ddc8b1ce0ed415 --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/CompilerM.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/CompilerM.lean new file mode 100644 index 0000000000000000000000000000000000000000..6a396ed7f89c296bed93c8ee6219ece87eda4330 --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/ConfigOptions.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/ConfigOptions.lean new file mode 100644 index 0000000000000000000000000000000000000000..52229170644bfc7d338383f2fd3b17ed20882ff8 --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/DeclHash.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/DeclHash.lean new file mode 100644 index 0000000000000000000000000000000000000000..d5d164e9a29927aa88a84eea41462ac588249de6 --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/DependsOn.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/DependsOn.lean new file mode 100644 index 0000000000000000000000000000000000000000..4e664bc7678b1c7f589c757212122c31ac66e118 --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/ElimDead.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/ElimDead.lean new file mode 100644 index 0000000000000000000000000000000000000000..8a845860cd6f73da4adb705bde956fffc6e73114 --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/ElimDeadBranches.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/ElimDeadBranches.lean new file mode 100644 index 0000000000000000000000000000000000000000..282622dcf7559e2485af7f1109558cfa77b68417 --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/ExtractClosed.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/ExtractClosed.lean new file mode 100644 index 0000000000000000000000000000000000000000..1ef4044c95a2a1be97fe325ffe827993d67a7a13 --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/FVarUtil.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/FVarUtil.lean new file mode 100644 index 0000000000000000000000000000000000000000..8e8380df1bffa545494b9d619baf56fd008ddd93 --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/FixedParams.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/FixedParams.lean new file mode 100644 index 0000000000000000000000000000000000000000..490e1dcbc01ee2f95da18292c23d4e0203cc0267 --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/FloatLetIn.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/FloatLetIn.lean new file mode 100644 index 0000000000000000000000000000000000000000..964119556af1d2f94efe999c66abdb889dd3010b --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/InferType.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/InferType.lean new file mode 100644 index 0000000000000000000000000000000000000000..4d51ee69110c235b19ee73629b1248c786843f42 --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/Internalize.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/Internalize.lean new file mode 100644 index 0000000000000000000000000000000000000000..946d75a2c9a13699532889239aa542598bf6091a --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/JoinPoints.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/JoinPoints.lean new file mode 100644 index 0000000000000000000000000000000000000000..8ecd79f24e133774bf090440b7fceedaacfb7a26 --- /dev/null +++ b/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 diff --git a/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/LambdaLifting.lean b/backend/core/leanprover--lean4---v4.22.0/src/lean/Lean/Compiler/LCNF/LambdaLifting.lean new file mode 100644 index 0000000000000000000000000000000000000000..2a9a465a1d1ccee476e6fb756a511b783677ad3d --- /dev/null +++ b/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 diff --git a/external/alphageometry/.venv-ag/Lib/site-packages/fontTools/subset/__init__.py b/external/alphageometry/.venv-ag/Lib/site-packages/fontTools/subset/__init__.py new file mode 100644 index 0000000000000000000000000000000000000000..c43d02ce4a63c3a24f683ad418d93b2705c3b70c --- /dev/null +++ b/external/alphageometry/.venv-ag/Lib/site-packages/fontTools/subset/__init__.py @@ -0,0 +1,3930 @@ +# Copyright 2013 Google, Inc. All Rights Reserved. +# +# Google Author(s): Behdad Esfahbod + +from __future__ import annotations + +from fontTools import config +from fontTools.misc.roundTools import otRound +from fontTools import ttLib +from fontTools.ttLib.tables import otTables +from fontTools.ttLib.tables.otBase import USE_HARFBUZZ_REPACKER +from fontTools.otlLib.maxContextCalc import maxCtxFont +from fontTools.pens.basePen import NullPen +from fontTools.misc.loggingTools import Timer +from fontTools.misc.cliTools import makeOutputFileName +from fontTools.subset.util import _add_method, _uniq_sort +from fontTools.subset.cff import * +from fontTools.subset.svg import * +from fontTools.varLib import varStore, multiVarStore # For monkey-patching +from fontTools.ttLib.tables._n_a_m_e import NameRecordVisitor, makeName +from fontTools.unicodedata import mirrored +import sys +import struct +import array +import logging +from collections import Counter, defaultdict +from functools import reduce +from types import MethodType + +__usage__ = "fonttools subset font-file [glyph...] [--option=value]..." + +__doc__ = ( + """\ +fonttools subset -- OpenType font subsetter and optimizer + +fonttools subset is an OpenType font subsetter and optimizer, based on +fontTools. It accepts any TT- or CFF-flavored OpenType (.otf or .ttf) +or WOFF (.woff) font file. The subsetted glyph set is based on the +specified glyphs or characters, and specified OpenType layout features. + +The tool also performs some size-reducing optimizations, aimed for using +subset fonts as webfonts. Individual optimizations can be enabled or +disabled, and are enabled by default when they are safe. + +Usage: """ + + __usage__ + + """ + +At least one glyph or one of --gids, --gids-file, --glyphs, --glyphs-file, +--text, --text-file, --unicodes, or --unicodes-file, must be specified. + +Args: + +font-file + The input font file. +glyph + Specify one or more glyph identifiers to include in the subset. Must be + PS glyph names, or the special string '*' to keep the entire glyph set. + +Initial glyph set specification +^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + +These options populate the initial glyph set. Same option can appear +multiple times, and the results are accummulated. + +--gids=[,...] + Specify comma/whitespace-separated list of glyph IDs or ranges as decimal + numbers. For example, --gids=10-12,14 adds glyphs with numbers 10, 11, + 12, and 14. + +--gids-file= + Like --gids but reads from a file. Anything after a '#' on any line is + ignored as comments. + +--glyphs=[,...] + Specify comma/whitespace-separated PS glyph names to add to the subset. + Note that only PS glyph names are accepted, not gidNNN, U+XXXX, etc + that are accepted on the command line. The special string '*' will keep + the entire glyph set. + +--glyphs-file= + Like --glyphs but reads from a file. Anything after a '#' on any line + is ignored as comments. + +--text= + Specify characters to include in the subset, as UTF-8 string. + +--text-file= + Like --text but reads from a file. Newline character are not added to + the subset. + +--unicodes=[,...] + Specify comma/whitespace-separated list of Unicode codepoints or + ranges as hex numbers, optionally prefixed with 'U+', 'u', etc. + For example, --unicodes=41-5a,61-7a adds ASCII letters, so does + the more verbose --unicodes=U+0041-005A,U+0061-007A. + The special strings '*' will choose all Unicode characters mapped + by the font. + +--unicodes-file= + Like --unicodes, but reads from a file. Anything after a '#' on any + line in the file is ignored as comments. + +--ignore-missing-glyphs + Do not fail if some requested glyphs or gids are not available in + the font. + +--no-ignore-missing-glyphs + Stop and fail if some requested glyphs or gids are not available + in the font. [default] + +--ignore-missing-unicodes [default] + Do not fail if some requested Unicode characters (including those + indirectly specified using --text or --text-file) are not available + in the font. + +--no-ignore-missing-unicodes + Stop and fail if some requested Unicode characters are not available + in the font. + Note the default discrepancy between ignoring missing glyphs versus + unicodes. This is for historical reasons and in the future + --no-ignore-missing-unicodes might become default. + +Other options +^^^^^^^^^^^^^ + +For the other options listed below, to see the current value of the option, +pass a value of '?' to it, with or without a '='. In some environments, +you might need to escape the question mark, like this: '--glyph-names\\?'. + +Examples:: + + $ fonttools subset --glyph-names? + Current setting for 'glyph-names' is: False + $ fonttools subset --name-IDs=? + Current setting for 'name-IDs' is: [0, 1, 2, 3, 4, 5, 6] + $ fonttools subset --hinting? --no-hinting --hinting? + Current setting for 'hinting' is: True + Current setting for 'hinting' is: False + +Output options +^^^^^^^^^^^^^^ + +--output-file= + The output font file. If not specified, the subsetted font + will be saved in as font-file.subset. + +--flavor= + Specify flavor of output font file. May be 'woff' or 'woff2'. + Note that WOFF2 requires the Brotli Python extension, available + at https://github.com/google/brotli + +--with-zopfli + Use the Google Zopfli algorithm to compress WOFF. The output is 3-8 % + smaller than pure zlib, but the compression speed is much slower. + The Zopfli Python bindings are available at: + https://pypi.python.org/pypi/zopfli + +--harfbuzz-repacker + By default, we serialize GPOS/GSUB using the HarfBuzz Repacker when + uharfbuzz can be imported and is successful, otherwise fall back to + the pure-python serializer. Set the option to force using the HarfBuzz + Repacker (raises an error if uharfbuzz can't be found or fails). + +--no-harfbuzz-repacker + Always use the pure-python serializer even if uharfbuzz is available. + +Glyph set expansion +^^^^^^^^^^^^^^^^^^^ + +These options control how additional glyphs are added to the subset. + +--retain-gids + Retain glyph indices; just empty glyphs not needed in-place. + +--notdef-glyph + Add the '.notdef' glyph to the subset (ie, keep it). [default] + +--no-notdef-glyph + Drop the '.notdef' glyph unless specified in the glyph set. This + saves a few bytes, but is not possible for Postscript-flavored + fonts, as those require '.notdef'. For TrueType-flavored fonts, + this works fine as long as no unsupported glyphs are requested + from the font. + +--notdef-outline + Keep the outline of '.notdef' glyph. The '.notdef' glyph outline is + used when glyphs not supported by the font are to be shown. It is not + needed otherwise. + +--no-notdef-outline + When including a '.notdef' glyph, remove its outline. This saves + a few bytes. [default] + +--recommended-glyphs + Add glyphs 0, 1, 2, and 3 to the subset, as recommended for + TrueType-flavored fonts: '.notdef', 'NULL' or '.null', 'CR', 'space'. + Some legacy software might require this, but no modern system does. + +--no-recommended-glyphs + Do not add glyphs 0, 1, 2, and 3 to the subset, unless specified in + glyph set. [default] + +--no-layout-closure + Do not expand glyph set to add glyphs produced by OpenType layout + features. Instead, OpenType layout features will be subset to only + rules that are relevant to the otherwise-specified glyph set. + +--layout-features[+|-]=[,...] + Specify (=), add to (+=) or exclude from (-=) the comma-separated + set of OpenType layout feature tags that will be preserved. + Glyph variants used by the preserved features are added to the + specified subset glyph set. By default, 'calt', 'ccmp', 'clig', 'curs', + 'dnom', 'frac', 'kern', 'liga', 'locl', 'mark', 'mkmk', 'numr', 'rclt', + 'rlig', 'rvrn', and all features required for script shaping are + preserved. To see the full list, try '--layout-features=?'. + Use '*' to keep all features. + Multiple --layout-features options can be provided if necessary. + Examples: + + --layout-features+=onum,pnum,ss01 + * Keep the default set of features and 'onum', 'pnum', 'ss01'. + --layout-features-='mark','mkmk' + * Keep the default set of features but drop 'mark' and 'mkmk'. + --layout-features='kern' + * Only keep the 'kern' feature, drop all others. + --layout-features='' + * Drop all features. + --layout-features='*' + * Keep all features. + --layout-features+=aalt --layout-features-=vrt2 + * Keep default set of features plus 'aalt', but drop 'vrt2'. + +--layout-scripts[+|-]=