chore: update stage0

stage0/.gitattributes

@@ -1 +0,0 @@
-* -text -diff linguist-generated=true

stage0/library/CMakeLists.txt

@@ -1 +0,0 @@
-add_library (stage0 OBJECT ./Init/Coe.c ./Init/Control.c ./Init/Control/Alternative.c ./Init/Control/Applicative.c ./Init/Control/Conditional.c ./Init/Control/EState.c ./Init/Control/Except.c ./Init/Control/Functor.c ./Init/Control/Id.c ./Init/Control/Lift.c ./Init/Control/Monad.c ./Init/Control/MonadFail.c ./Init/Control/Option.c ./Init/Control/Reader.c ./Init/Control/State.c ./Init/Core.c ./Init/Data.c ./Init/Data/Array.c ./Init/Data/Array/Basic.c ./Init/Data/Array/BinSearch.c ./Init/Data/Array/QSort.c ./Init/Data/AssocList.c ./Init/Data/Basic.c ./Init/Data/BinomialHeap.c ./Init/Data/BinomialHeap/Basic.c ./Init/Data/ByteArray.c ./Init/Data/ByteArray/Basic.c ./Init/Data/Char.c ./Init/Data/Char/Basic.c ./Init/Data/DList.c ./Init/Data/Fin.c ./Init/Data/Fin/Basic.c ./Init/Data/HashMap.c ./Init/Data/HashMap/Basic.c ./Init/Data/HashSet.c ./Init/Data/Hashable.c ./Init/Data/Int.c ./Init/Data/Int/Basic.c ./Init/Data/List.c ./Init/Data/List/Basic.c ./Init/Data/List/BasicAux.c ./Init/Data/List/Control.c ./Init/Data/List/Instances.c ./Init/Data/Nat.c ./Init/Data/Nat/Basic.c ./Init/Data/Nat/Bitwise.c ./Init/Data/Nat/Control.c ./Init/Data/Nat/Div.c ./Init/Data/Option.c ./Init/Data/Option/Basic.c ./Init/Data/Option/BasicAux.c ./Init/Data/Option/Instances.c ./Init/Data/PersistentArray.c ./Init/Data/PersistentArray/Basic.c ./Init/Data/PersistentHashMap.c ./Init/Data/PersistentHashMap/Basic.c ./Init/Data/PersistentHashSet.c ./Init/Data/Queue.c ./Init/Data/Queue/Basic.c ./Init/Data/RBMap.c ./Init/Data/RBMap/Basic.c ./Init/Data/RBMap/BasicAux.c ./Init/Data/RBTree.c ./Init/Data/RBTree/Basic.c ./Init/Data/Random.c ./Init/Data/Repr.c ./Init/Data/Stack.c ./Init/Data/Stack/Basic.c ./Init/Data/String.c ./Init/Data/String/Basic.c ./Init/Data/ToString.c ./Init/Data/UInt.c ./Init/Default.c ./Init/Fix.c ./Init/Lean.c ./Init/Lean/Attributes.c ./Init/Lean/AuxRecursor.c ./Init/Lean/Class.c ./Init/Lean/Compiler.c ./Init/Lean/Compiler/ClosedTermCache.c ./Init/Lean/Compiler/ConstFolding.c ./Init/Lean/Compiler/ExportAttr.c ./Init/Lean/Compiler/ExternAttr.c ./Init/Lean/Compiler/IR.c ./Init/Lean/Compiler/IR/Basic.c ./Init/Lean/Compiler/IR/Borrow.c ./Init/Lean/Compiler/IR/Boxing.c ./Init/Lean/Compiler/IR/Checker.c ./Init/Lean/Compiler/IR/CompilerM.c ./Init/Lean/Compiler/IR/CtorLayout.c ./Init/Lean/Compiler/IR/ElimDeadBranches.c ./Init/Lean/Compiler/IR/ElimDeadVars.c ./Init/Lean/Compiler/IR/EmitC.c ./Init/Lean/Compiler/IR/EmitUtil.c ./Init/Lean/Compiler/IR/ExpandResetReuse.c ./Init/Lean/Compiler/IR/Format.c ./Init/Lean/Compiler/IR/FreeVars.c ./Init/Lean/Compiler/IR/LiveVars.c ./Init/Lean/Compiler/IR/NormIds.c ./Init/Lean/Compiler/IR/PushProj.c ./Init/Lean/Compiler/IR/RC.c ./Init/Lean/Compiler/IR/ResetReuse.c ./Init/Lean/Compiler/IR/SimpCase.c ./Init/Lean/Compiler/IR/UnboxResult.c ./Init/Lean/Compiler/ImplementedByAttr.c ./Init/Lean/Compiler/InitAttr.c ./Init/Lean/Compiler/InlineAttrs.c ./Init/Lean/Compiler/NameMangling.c ./Init/Lean/Compiler/NeverExtractAttr.c ./Init/Lean/Compiler/Specialize.c ./Init/Lean/Compiler/Util.c ./Init/Lean/Declaration.c ./Init/Lean/Elaborator.c ./Init/Lean/Elaborator/Alias.c ./Init/Lean/Elaborator/Basic.c ./Init/Lean/Elaborator/Command.c ./Init/Lean/Elaborator/ElabStrategyAttrs.c ./Init/Lean/Elaborator/PreTerm.c ./Init/Lean/Elaborator/ResolveName.c ./Init/Lean/Elaborator/Term.c ./Init/Lean/Environment.c ./Init/Lean/EqnCompiler.c ./Init/Lean/EqnCompiler/MatchPattern.c ./Init/Lean/Expr.c ./Init/Lean/Format.c ./Init/Lean/KVMap.c ./Init/Lean/LBool.c ./Init/Lean/LOption.c ./Init/Lean/Level.c ./Init/Lean/Linter.c ./Init/Lean/LocalContext.c ./Init/Lean/Message.c ./Init/Lean/Meta.c ./Init/Lean/Meta/Basic.c ./Init/Lean/Meta/Check.c ./Init/Lean/Meta/Exception.c ./Init/Lean/Meta/ExprDefEq.c ./Init/Lean/Meta/FunInfo.c ./Init/Lean/Meta/InferType.c ./Init/Lean/Meta/LevelDefEq.c ./Init/Lean/Meta/Offset.c ./Init/Lean/Meta/WHNF.c ./Init/Lean/MetavarContext.c ./Init/Lean/Modifiers.c ./Init/Lean/MonadCache.c ./Init/Lean/Name.c ./Init/Lean/NameGenerator.c ./Init/Lean/Options.c ./Init/Lean/Parser.c ./Init/Lean/Parser/Command.c ./Init/Lean/Parser/Identifier.c ./Init/Lean/Parser/Level.c ./Init/Lean/Parser/Module.c ./Init/Lean/Parser/Parser.c ./Init/Lean/Parser/Term.c ./Init/Lean/Parser/Transform.c ./Init/Lean/Parser/Trie.c ./Init/Lean/Path.c ./Init/Lean/Position.c ./Init/Lean/ProjFns.c ./Init/Lean/ReducibilityAttrs.c ./Init/Lean/Runtime.c ./Init/Lean/SMap.c ./Init/Lean/Scopes.c ./Init/Lean/Syntax.c ./Init/Lean/ToExpr.c ./Init/Lean/Trace.c ./Init/Lean/TypeClass.c ./Init/Lean/TypeClass/Basic.c ./Init/Lean/TypeClass/Context.c ./Init/Lean/TypeClass/Synth.c ./Init/Lean/Util.c ./Init/Lean/WHNF.c ./Init/System.c ./Init/System/FilePath.c ./Init/System/IO.c ./Init/System/Platform.c ./Init/Util.c ./Init/WF.c)

stage0/src/CMakeLists.txt

@@ -182,8 +182,7 @@ if("${CMAKE_C_COMPILER}" MATCHES "emcc")
     set(CFLAGS_EMSCRIPTEN "-Oz -O3")
     set(LEAN_EXTRA_CXX_FLAGS "${LEAN_EXTRA_CXX_FLAGS} ${CFLAGS_EMSCRIPTEN} -D LEAN_EMSCRIPTEN")
     set(LEAN_EXTRA_LINKER_FLAGS "${LEAN_EXTRA_LINKER_FLAGS} --memory-init-file 0 --llvm-lto 1 -s ALLOW_MEMORY_GROWTH=1 -s DISABLE_EXCEPTION_CATCHING=0 ${CFLAGS_EMSCRIPTEN}")
-    set(LEAN_JS_LIBRARY "${CMAKE_CURRENT_SOURCE_DIR}/../library" CACHE STRING
-            "location of olean files for lean.js")
+    set(LEAN_JS_LIBRARY "${CMAKE_CURRENT_SOURCE_DIR}" CACHE STRING "location of olean files for lean.js")
 endif()
 if (CMAKE_CROSSCOMPILING_EMULATOR)
   # emscripten likes to quote "node"
@@ -490,7 +489,7 @@ configure_file("${LEAN_SOURCE_DIR}/version.h.in" "${LEAN_BINARY_DIR}/version.h")
 configure_file("${LEAN_SOURCE_DIR}/config.h.in" "${LEAN_SOURCE_DIR}/config.h")
 install(FILES "${LEAN_SOURCE_DIR}/config.h" DESTINATION "${INCLUDE_DIR}")
 if(NOT STAGE0)
-  configure_file("${LEAN_SOURCE_DIR}/../library/Makefile.in" "${LEAN_SOURCE_DIR}/../library/Makefile")
+  configure_file("${LEAN_SOURCE_DIR}/Init/Makefile.in" "${LEAN_SOURCE_DIR}/Init/Makefile")
 endif()
 
 include_directories("${LEAN_BINARY_DIR}")
@@ -512,10 +511,10 @@ add_subdirectory(library/compiler)
 set(LEAN_OBJS ${LEAN_OBJS} $<TARGET_OBJECTS:compiler>)
 add_subdirectory(frontends/lean)
 set(LEAN_OBJS ${LEAN_OBJS} $<TARGET_OBJECTS:lean_frontend>)
-add_subdirectory(init)
-set(LEAN_OBJS ${LEAN_OBJS} $<TARGET_OBJECTS:init>)
+add_subdirectory(initialize)
+set(LEAN_OBJS ${LEAN_OBJS} $<TARGET_OBJECTS:initialize>)
 if(STAGE0)
-  add_subdirectory(../library stdlib)
+  add_subdirectory(../stdlib stdlib)
   set(LEAN_OBJS ${LEAN_OBJS} $<TARGET_OBJECTS:stage0>)
 endif()
 if(EMSCRIPTEN)
@@ -622,23 +621,11 @@ add_style_check_target(style "${LEAN_SOURCES}")
 add_test(NAME style_check COMMAND "${PYTHON_EXECUTABLE}" "${LEAN_SOURCE_DIR}/cmake/Modules/cpplint.py" ${LEAN_SOURCES})
 endif()
 
-# add_custom_target(
-#     leanpkg ALL
-#     COMMAND "${LEAN_SOURCE_DIR}/../bin/lean" --make ${LEAN_EXTRA_MAKE_OPTS}
-#     DEPENDS standard_lib
-#     WORKING_DIRECTORY "${LEAN_SOURCE_DIR}/../leanpkg"
-# )
-
 add_custom_target(clean-stdlib
-  WORKING_DIRECTORY "${LEAN_SOURCE_DIR}/../library"
-  COMMAND find . -name *.olean -delete
-	COMMAND find . -name *.depend -delete
-	COMMAND rm -r ../src/stage1 "${CMAKE_BINARY_DIR}/stage1" || true
-  )
-
-add_custom_target(clean-leanpkg
-  WORKING_DIRECTORY "${LEAN_SOURCE_DIR}/../leanpkg"
-  COMMAND "${CMAKE_COMMAND}" -P "${CMAKE_MODULE_PATH}/CleanOlean.cmake"
+  WORKING_DIRECTORY "${LEAN_SOURCE_DIR}/Init"
+  COMMAND find . -name '*.olean' -delete
+        COMMAND find . -name '*.depend' -delete
+        COMMAND rm -r ../stage1 "${CMAKE_BINARY_DIR}/stage1" || true
   )
 
 add_custom_target(clean-olean
@@ -654,18 +641,10 @@ install(FILES "${CMAKE_SOURCE_DIR}/../bin/leanpkg"
   DESTINATION bin
   PERMISSIONS OWNER_READ OWNER_WRITE OWNER_EXECUTE GROUP_READ GROUP_EXECUTE WORLD_READ WORLD_EXECUTE)
 
-install(DIRECTORY "${CMAKE_SOURCE_DIR}/../library" DESTINATION "${LIBRARY_DIR}"
+install(DIRECTORY "${CMAKE_SOURCE_DIR}/Init" DESTINATION "${LIBRARY_DIR}"
         FILES_MATCHING
         PATTERN "*.lean"
         PATTERN "*.olean"
-        PATTERN "leanpkg.toml"
-        PATTERN "*.md")
-
-install(DIRECTORY "${CMAKE_SOURCE_DIR}/../leanpkg" DESTINATION "${LIBRARY_DIR}"
-        FILES_MATCHING
-        PATTERN "*.lean"
-        PATTERN "*.olean"
-        PATTERN "leanpkg.toml"
         PATTERN "*.md")
 
 install(DIRECTORY "${CMAKE_SOURCE_DIR}/runtime" DESTINATION "${INCLUDE_DIR}"

stage0/src/Init/Coe.lean

@@ -0,0 +1,182 @@
+/-
+Copyright (c) 2016 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+
+/-
+The Elaborator tries to insert coercions automatically.
+Only instances of HasCoe type class are considered in the process.
+
+Lean also provides a "lifting" operator: ↑a.
+It uses all instances of HasLift type class.
+Every HasCoe instance is also a HasLift instance.
+
+We recommend users only use HasCoe for coercions that do not produce a lot
+of ambiguity.
+
+All coercions and lifts can be identified with the constant coe.
+
+We use the HasCoeToFun type class for encoding coercions from
+a Type to a Function space.
+
+We use the HasCoeToSort type class for encoding coercions from
+a Type to a sort.
+-/
+prelude
+import Init.Data.List.Basic
+universes u v
+
+class HasLift (a : Sort u) (b : Sort v) :=
+(lift : a → b)
+
+/-- Auxiliary class that contains the transitive closure of HasLift. -/
+class HasLiftT (a : Sort u) (b : Sort v) :=
+(lift : a → b)
+
+class HasCoe (a : Sort u) (b : Sort v) :=
+(coe : a → b)
+
+/-- Auxiliary class that contains the transitive closure of HasCoe. -/
+class HasCoeT (a : Sort u) (b : Sort v) :=
+(coe : a → b)
+
+class HasCoeToFun (a : Sort u) : Sort (max u (v+1)) :=
+(F : a → Sort v) (coe : ∀ x, F x)
+
+class HasCoeToSort (a : Sort u) : Type (max u (v+1)) :=
+(S : Sort v) (coe : a → S)
+
+@[inline] def lift {a : Sort u} {b : Sort v} [HasLift a b] : a → b :=
+@HasLift.lift a b _
+
+@[inline] def liftT {a : Sort u} {b : Sort v} [HasLiftT a b] : a → b :=
+@HasLiftT.lift a b _
+
+@[inline] def coeB {a : Sort u} {b : Sort v} [HasCoe a b] : a → b :=
+@HasCoe.coe a b _
+
+@[inline] def coeT {a : Sort u} {b : Sort v} [HasCoeT a b] : a → b :=
+@HasCoeT.coe a b _
+
+@[inline] def coeFnB {a : Sort u} [HasCoeToFun.{u, v} a] : ∀ (x : a), HasCoeToFun.F.{u, v} x :=
+HasCoeToFun.coe
+
+/- User Level coercion operators -/
+
+@[reducible, inline] def coe {a : Sort u} {b : Sort v} [HasLiftT a b] : a → b :=
+liftT
+
+@[reducible, inline] def coeFn {a : Sort u} [HasCoeToFun.{u, v} a] : ∀ (x : a), HasCoeToFun.F.{u, v} x :=
+HasCoeToFun.coe
+
+@[reducible, inline] def coeSort {a : Sort u} [HasCoeToSort.{u, v} a] : a → HasCoeToSort.S.{u, v} a :=
+HasCoeToSort.coe
+
+/- Notation -/
+
+universes u₁ u₂ u₃
+
+/- Transitive closure for HasLift, HasCoe, HasCoeToFun -/
+
+instance liftTrans {a : Sort u₁} {b : Sort u₂} {c : Sort u₃} [HasLiftT b c] [HasLift a b] : HasLiftT a c :=
+⟨fun x => liftT (lift x : b)⟩
+
+instance liftRefl {a : Sort u} : HasLiftT a a :=
+⟨id⟩
+
+instance coeTrans {a : Sort u₁} {b : Sort u₂} {c : Sort u₃} [HasCoeT b c] [HasCoe a b] : HasCoeT a c :=
+⟨fun x => coeT (coeB x : b)⟩
+
+instance coeBase {a : Sort u} {b : Sort v} [HasCoe a b] : HasCoeT a b :=
+⟨coeB⟩
+
+/- We add this instance directly into HasCoeT to avoid non-termination.
+
+   Suppose coeOption had Type (HasCoe a (Option a)).
+   Then, we can loop when searching a coercion from α to β (HasCoeT α β)
+   1- coeTrans at (HasCoeT α β)
+          (HasCoe α ?b₁) and (HasCoeT ?b₁ c)
+   2- coeOption at (HasCoe α ?b₁)
+          ?b₁ := Option α
+   3- coeTrans at (HasCoeT (Option α) β)
+          (HasCoe (Option α) ?b₂) and (HasCoeT ?b₂ β)
+   4- coeOption at (HasCoe (Option α) ?b₂)
+          ?b₂ := Option (Option α))
+   ...
+-/
+instance coeOption {a : Type u} : HasCoeT a (Option a) :=
+⟨fun x => some x⟩
+
+/- Auxiliary transitive closure for HasCoe which does not contain
+   instances such as coeOption.
+
+   They would produce non-termination when combined with coeFnTrans and coeSortTrans.
+-/
+class HasCoeTAux (a : Sort u) (b : Sort v) :=
+(coe : a → b)
+
+instance coeTransAux {a : Sort u₁} {b : Sort u₂} {c : Sort u₃} [HasCoeTAux b c] [HasCoe a b] : HasCoeTAux a c :=
+⟨fun x => @HasCoeTAux.coe b c _ (coeB x)⟩
+
+instance coeBaseAux {a : Sort u} {b : Sort v} [HasCoe a b] : HasCoeTAux a b :=
+⟨coeB⟩
+
+instance coeFnTrans {a : Sort u₁} {b : Sort u₂} [HasCoeToFun.{u₂, u₃} b] [HasCoeTAux a b] : HasCoeToFun.{u₁, u₃} a :=
+{ F   := fun x => @HasCoeToFun.F.{u₂, u₃} b _ (@HasCoeTAux.coe a b _ x),
+  coe := fun x => coeFn (@HasCoeTAux.coe a b _ x) }
+
+instance coeSortTrans {a : Sort u₁} {b : Sort u₂} [HasCoeToSort.{u₂, u₃} b] [HasCoeTAux a b] : HasCoeToSort.{u₁, u₃} a :=
+{ S   := HasCoeToSort.S.{u₂, u₃} b,
+  coe := fun x => coeSort (@HasCoeTAux.coe a b _ x) }
+
+/- Every coercion is also a lift -/
+
+instance coeToLift {a : Sort u} {b : Sort v} [HasCoeT a b] : HasLiftT a b :=
+⟨coeT⟩
+
+/- basic coercions -/
+
+instance coeBoolToProp : HasCoe Bool Prop :=
+⟨fun y => y = true⟩
+
+/- Tactics such as the simplifier only unfold reducible constants when checking whether two terms are definitionally
+   equal or a Term is a proposition. The motivation is performance.
+   In particular, when simplifying `p -> q`, the tactic `simp` only visits `p` if it can establish that it is a proposition.
+   Thus, we mark the following instance as @[reducible], otherwise `simp` will not visit `↑p` when simplifying `↑p -> q`.
+-/
+@[reducible] instance coeSortBool : HasCoeToSort Bool :=
+⟨Prop, fun y => y = true⟩
+
+instance coeDecidableEq (x : Bool) : Decidable (coe x) :=
+inferInstanceAs (Decidable (x = true))
+
+instance coeSubtype {a : Sort u} {p : a → Prop} : HasCoe {x // p x} a :=
+⟨Subtype.val⟩
+
+/- basic lifts -/
+
+universes ua ua₁ ua₂ ub ub₁ ub₂
+
+/- Remark: we can't use [HasLiftT a₂ a₁] since it will produce non-termination whenever a type class resolution
+   problem does not have a solution. -/
+instance liftFn {a₁ : Sort ua₁} {a₂ : Sort ua₂} {b₁ : Sort ub₁} {b₂ : Sort ub₂} [HasLiftT b₁ b₂] [HasLift a₂ a₁] : HasLift (a₁ → b₁) (a₂ → b₂) :=
+⟨fun f x => coe (f (coe x))⟩
+
+instance liftFnRange {a : Sort ua} {b₁ : Sort ub₁} {b₂ : Sort ub₂} [HasLiftT b₁ b₂] : HasLift (a → b₁) (a → b₂) :=
+⟨fun f x => coe (f x)⟩
+
+instance liftFnDom {a₁ : Sort ua₁} {a₂ : Sort ua₂} {b : Sort ub} [HasLift a₂ a₁] : HasLift (a₁ → b) (a₂ → b) :=
+⟨fun f x => f (coe x)⟩
+
+instance liftPair {a₁ : Type ua₁} {a₂ : Type ub₂} {b₁ : Type ub₁} {b₂ : Type ub₂} [HasLiftT a₁ a₂] [HasLiftT b₁ b₂] : HasLift (a₁ × b₁) (a₂ × b₂) :=
+⟨fun p => Prod.casesOn p (fun x y => (coe x,  coe y))⟩
+
+instance liftPair₁ {a₁ : Type ua₁} {a₂ : Type ua₂} {b : Type ub} [HasLiftT a₁ a₂] : HasLift (a₁ × b) (a₂ × b) :=
+⟨fun p => Prod.casesOn p (fun x y => (coe x, y))⟩
+
+instance liftPair₂ {a : Type ua} {b₁ : Type ub₁} {b₂ : Type ub₂} [HasLiftT b₁ b₂] : HasLift (a × b₁) (a × b₂) :=
+⟨fun p => Prod.casesOn p (fun x y => (x,  coe y))⟩
+
+instance liftList {a : Type u} {b : Type v} [HasLiftT a b] : HasLift (List a) (List b) :=
+⟨fun l => List.map (@coe a b _) l⟩

stage0/src/Init/Control.lean

@@ -0,0 +1,17 @@
+/-
+Copyright (c) 2016 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Init.Control.Applicative
+import Init.Control.Functor
+import Init.Control.Alternative
+import Init.Control.Monad
+import Init.Control.Lift
+import Init.Control.State
+import Init.Control.Id
+import Init.Control.Except
+import Init.Control.Reader
+import Init.Control.Option
+import Init.Control.Conditional

stage0/src/Init/Control/Alternative.lean

@@ -0,0 +1,39 @@
+/-
+Copyright (c) 2016 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Author: Leonardo de Moura
+-/
+prelude
+import Init.Core
+import Init.Control.Applicative
+universes u v
+
+class Alternative (f : Type u → Type v) extends Applicative f : Type (max (u+1) v) :=
+(failure : ∀ {α : Type u}, f α)
+(orelse  : ∀ {α : Type u}, f α → f α → f α)
+
+instance alternativeHasOrelse (f : Type u → Type v) (α : Type u) [Alternative f] : HasOrelse (f α) :=
+⟨Alternative.orelse⟩
+
+section
+variables {f : Type u → Type v} [Alternative f] {α : Type u}
+
+@[inline] def failure : f α :=
+Alternative.failure f
+
+@[inline] def guard {f : Type → Type v} [Alternative f] (p : Prop) [Decidable p] : f Unit :=
+if p then pure () else failure
+
+@[inline] def assert {f : Type → Type v} [Alternative f] (p : Prop) [Decidable p] : f (Inhabited p) :=
+if h : p then pure ⟨h⟩ else failure
+
+/- Later we define a coercion from Bool to Prop, but this version will still be useful.
+   Given (t : tactic Bool), we can write t >>= guardb -/
+@[inline] def guardb {f : Type → Type v} [Alternative f] : Bool → f Unit
+| true  => pure ()
+| false => failure
+
+@[inline] def optional (x : f α) : f (Option α) :=
+some <$> x <|> pure none
+
+end

stage0/src/Init/Control/Applicative.lean

@@ -0,0 +1,42 @@
+/-
+Copyright (c) 2016 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura, Sebastian Ullrich
+-/
+prelude
+import Init.Control.Functor
+open Function
+universes u v
+
+class HasPure (f : Type u → Type v) :=
+(pure {} {α : Type u} : α → f α)
+
+export HasPure (pure)
+
+class HasSeq (f : Type u → Type v) : Type (max (u+1) v) :=
+(seq  : ∀ {α β : Type u}, f (α → β) → f α → f β)
+
+infixl <*> := HasSeq.seq
+
+class HasSeqLeft (f : Type u → Type v) : Type (max (u+1) v) :=
+(seqLeft : ∀ {α β : Type u}, f α → f β → f α)
+
+infixl <* := HasSeqLeft.seqLeft
+
+class HasSeqRight (f : Type u → Type v) : Type (max (u+1) v) :=
+(seqRight : ∀ {α β : Type u}, f α → f β → f β)
+
+infixr *> := HasSeqRight.seqRight
+
+class Applicative (f : Type u → Type v) extends Functor f, HasPure f, HasSeq f, HasSeqLeft f, HasSeqRight f :=
+(map      := fun _ _ x y => pure x <*> y)
+(seqLeft  := fun α β a b => const β <$> a <*> b)
+(seqRight := fun α β a b => const α id <$> a <*> b)
+
+@[macroInline]
+def when {m : Type → Type u} [Applicative m] (c : Prop) [h : Decidable c] (t : m Unit) : m Unit :=
+if c then t else pure ()
+
+@[macroInline]
+def unless {m : Type → Type u} [Applicative m] (c : Prop) [h : Decidable c] (e : m Unit) : m Unit :=
+if c then pure () else e

stage0/src/Init/Control/Conditional.lean

@@ -0,0 +1,40 @@
+/-
+Copyright (c) 2016 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Author: Leonardo de Moura
+-/
+prelude
+import Init.Control.Monad
+import Init.Data.Option.Basic
+universes u v
+
+class HasToBool (α : Type u) :=
+(toBool : α → Bool)
+
+export HasToBool (toBool)
+
+instance : HasToBool Bool := ⟨id⟩
+instance {α} : HasToBool (Option α) := ⟨Option.toBool⟩
+
+@[macroInline] def bool {β : Type u} {α : Type v} [HasToBool β] (f t : α) (b : β) : α :=
+match toBool b with
+| true  => t
+| false => f
+
+@[macroInline] def orM {m : Type u → Type v} {β : Type u} [Monad m] [HasToBool β] (x y : m β) : m β :=
+do b ← x;
+   match toBool b with
+   | true  => pure b
+   | false => y
+
+@[macroInline] def andM {m : Type u → Type v} {β : Type u} [Monad m] [HasToBool β] (x y : m β) : m β :=
+do b ← x;
+   match toBool b with
+   | true  => y
+   | false => pure b
+
+infixl ` <||> `:30 := orM
+infixl ` <&&> `:35 := andM
+
+@[macroInline] def notM {m : Type → Type v} [Applicative m] (x : m Bool) : m Bool :=
+not <$> x

stage0/src/Init/Control/EState.lean

@@ -0,0 +1,155 @@
+/-
+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 Init.Control.State
+import Init.Control.Except
+universes u v
+
+namespace EStateM
+
+inductive Result (ε σ α : Type u)
+| ok    {} : α → σ → Result
+| error {} : ε → σ → Result
+
+variables {ε σ α : Type u}
+
+protected def Result.toString [HasToString ε] [HasToString α] : Result ε σ α → String
+| Result.ok a _    => "ok: " ++ toString a
+| Result.error e _ => "error: " ++ toString e
+
+protected def Result.repr [HasRepr ε] [HasRepr α] : Result ε σ α → String
+| Result.error e _ => "(error " ++ repr e ++ ")"
+| Result.ok a _    => "(ok " ++ repr a ++ ")"
+
+instance [HasToString ε] [HasToString α] : HasToString (Result ε σ α) := ⟨Result.toString⟩
+instance [HasRepr ε] [HasRepr α] : HasRepr (Result ε σ α) := ⟨Result.repr⟩
+
+end EStateM
+
+def EStateM (ε σ α : Type u) := σ → EStateM.Result ε σ α
+
+namespace EStateM
+
+variables {ε σ α β : Type u}
+
+instance [Inhabited ε] : Inhabited (EStateM ε σ α) :=
+⟨fun s => Result.error (arbitrary ε) s⟩
+
+@[inline] protected def pure (a : α) : EStateM ε σ α :=
+fun s => Result.ok a s
+
+@[inline] protected def set (s : σ) : EStateM ε σ PUnit :=
+fun _ => Result.ok ⟨⟩ s
+
+@[inline] protected def get : EStateM ε σ σ :=
+fun s => Result.ok s s
+
+@[inline] protected def modifyGet (f : σ → α × σ) : EStateM ε σ α :=
+fun s =>
+  match f s with
+  | (a, s) => Result.ok a s
+
+@[inline] protected def throw (e : ε) : EStateM ε σ α :=
+fun s => Result.error e s
+
+/-- Auxiliary instance for saving/restoring the "backtrackable" part of the state. -/
+class Backtrackable (δ : outParam $ Type u) (σ : Type u) :=
+(save    : σ → δ)
+(restore : σ → δ → σ)
+
+@[inline] protected def catch {δ} [Backtrackable δ σ] {α} (x : EStateM ε σ α) (handle : ε → EStateM ε σ α) : EStateM ε σ α :=
+fun s =>
+  let d := Backtrackable.save s;
+  match x s with
+  | Result.error e s => handle e (Backtrackable.restore s d)
+  | ok               => ok
+
+@[inline] protected def orelse {δ} [Backtrackable δ σ] (x₁ x₂ : EStateM ε σ α) : EStateM ε σ α :=
+fun s =>
+  let d := Backtrackable.save s;
+  match x₁ s with
+  | Result.error _ s => x₂ (Backtrackable.restore s d)
+  | ok               => ok
+
+/-- Alternative orelse operator that allows to select which exception should be used.
+    The default is to use the first exception since the standard `orelse` uses the second. -/
+@[inline] protected def orelse' {δ} [Backtrackable δ σ] (x₁ x₂ : EStateM ε σ α) (useFirstEx := true) : EStateM ε σ α :=
+fun s =>
+  let d := Backtrackable.save s;
+  match x₁ s with
+  | Result.error e₁ s₁ =>
+    match x₂ (Backtrackable.restore s₁ d) with
+    | Result.error e₂ s₂ => Result.error (if useFirstEx then e₁ else e₂) s₂
+    | ok                 => ok
+  | ok                 => ok
+
+@[inline] def adaptExcept {ε' : Type u} [HasLift ε ε'] (x : EStateM ε σ α) : EStateM ε' σ α :=
+fun s => match x s with
+  | Result.error e s => Result.error (lift e) s
+  | Result.ok a s    => Result.ok a s
+
+@[inline] protected def bind (x : EStateM ε σ α) (f : α → EStateM ε σ β) : EStateM ε σ β :=
+fun s => match x s with
+  | Result.ok a s    => f a s
+  | Result.error e s => Result.error e s
+
+@[inline] protected def map (f : α → β) (x : EStateM ε σ α) : EStateM ε σ β :=
+fun s => match x s with
+  | Result.ok a s    => Result.ok (f a) s
+  | Result.error e s => Result.error e s
+
+@[inline] protected def seqRight (x : EStateM ε σ α) (y : EStateM ε σ β) : EStateM ε σ β :=
+fun s => match x s with
+  | Result.ok _ s    => y s
+  | Result.error e s => Result.error e s
+
+instance : Monad (EStateM ε σ) :=
+{ bind := @EStateM.bind _ _, pure := @EStateM.pure _ _, map := @EStateM.map _ _, seqRight := @EStateM.seqRight _ _ }
+
+instance {δ} [Backtrackable δ σ] : HasOrelse (EStateM ε σ α) :=
+{ orelse := @EStateM.orelse _ _ _ _ _ }
+
+instance : MonadState σ (EStateM ε σ) :=
+{ set := @EStateM.set _ _, get := @EStateM.get _ _, modifyGet := @EStateM.modifyGet _ _ }
+
+instance {δ} [Backtrackable δ σ] : MonadExcept ε (EStateM ε σ) :=
+{ throw := @EStateM.throw _ _, catch := @EStateM.catch _ _ _ _ }
+
+@[inline] def adaptState {σ₁ σ₂} (split : σ → σ₁ × σ₂) (merge : σ₁ → σ₂ → σ) (x : EStateM ε σ₁ α) : EStateM ε σ α :=
+fun s =>
+  let (s₁, s₂) := split s;
+  match x s₁ with
+  | Result.ok a s₁    => Result.ok a (merge s₁ s₂)
+  | Result.error e s₁ => Result.error e (merge s₁ s₂)
+
+instance {ε σ σ'} : MonadStateAdapter σ σ' (EStateM ε σ) (EStateM ε σ') :=
+⟨fun σ'' α => EStateM.adaptState⟩
+
+@[inline] def fromStateM {ε σ α : Type} (x : StateM σ α) : EStateM ε σ α :=
+fun s =>
+  match x.run s with
+  | (a, s') => EStateM.Result.ok a s'
+
+@[inline] def run (x : EStateM ε σ α) (s : σ) : Result ε σ α :=
+x s
+
+@[inline] def run' (x : EStateM ε σ α) (s : σ) : Option α :=
+match run x s with
+| Result.ok v _    => some v
+| Result.error _ _ => none
+
+@[inline] def dummySave : σ → PUnit :=
+fun _ => ⟨⟩
+
+@[inline] def dummyRestore : σ → PUnit → σ :=
+fun s _ => s
+
+/- Dummy default instance -/
+instance nonBacktrackable : Backtrackable PUnit σ :=
+{ save    := dummySave,
+  restore := dummyRestore }
+
+end EStateM

stage0/src/Init/Control/Except.lean

@@ -0,0 +1,192 @@
+/-
+Copyright (c) 2017 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Jared Roesch, Sebastian Ullrich
+
+The Except monad transformer.
+-/
+prelude
+import Init.Control.Alternative
+import Init.Control.Lift
+import Init.Data.ToString
+import Init.Control.MonadFail
+universes u v w
+
+inductive Except (ε : Type u) (α : Type v)
+| error {} : ε → Except
+| ok {} : α → Except
+
+attribute [unbox] Except
+
+instance {ε α : Type} [Inhabited ε] : Inhabited (Except ε α) :=
+⟨Except.error (arbitrary ε)⟩
+
+section
+variables {ε : Type u} {α : Type v}
+
+protected def Except.toString [HasToString ε] [HasToString α] : Except ε α → String
+| Except.error e => "(error " ++ toString e ++ ")"
+| Except.ok a    => "(ok " ++ toString a ++ ")"
+
+protected def Except.repr [HasRepr ε] [HasRepr α] : Except ε α → String
+| Except.error e => "(error " ++ repr e ++ ")"
+| Except.ok a    => "(ok " ++ repr a ++ ")"
+
+instance [HasToString ε] [HasToString α] : HasToString (Except ε α) :=
+⟨Except.toString⟩
+
+instance [HasRepr ε] [HasRepr α] : HasRepr (Except ε α) :=
+⟨Except.repr⟩
+end
+
+namespace Except
+variables {ε : Type u}
+
+@[inline] protected def return {α : Type v} (a : α) : Except ε α :=
+Except.ok a
+
+@[inline] protected def map {α β : Type v} (f : α → β) : Except ε α → Except ε β
+| Except.error err => Except.error err
+| Except.ok v => Except.ok $ f v
+
+@[inline] protected def mapError {ε' : Type u} {α : Type v} (f : ε → ε') : Except ε α → Except ε' α
+| Except.error err => Except.error $ f err
+| Except.ok v => Except.ok v
+
+@[inline] protected def bind {α β : Type v} (ma : Except ε α) (f : α → Except ε β) : Except ε β :=
+match ma with
+| (Except.error err) => Except.error err
+| (Except.ok v)      => f v
+
+@[inline] protected def toBool {α : Type v} : Except ε α → Bool
+| Except.ok _    => true
+| Except.error _ => false
+
+@[inline] protected def toOption {α : Type v} : Except ε α → Option α
+| Except.ok a    => some a
+| Except.error _ => none
+
+@[inline] protected def catch {α : Type u} (ma : Except ε α) (handle : ε → Except ε α) : Except ε α :=
+match ma with
+| Except.ok a    => Except.ok a
+| Except.error e => handle e
+
+instance : Monad (Except ε) :=
+{ pure := @Except.return _, bind := @Except.bind _, map := @Except.map _ }
+end Except
+
+def ExceptT (ε : Type u) (m : Type u → Type v) (α : Type u) : Type v :=
+m (Except ε α)
+
+@[inline] def ExceptT.mk {ε : Type u} {m : Type u → Type v} {α : Type u} (x : m (Except ε α)) : ExceptT ε m α :=
+x
+
+@[inline] def ExceptT.run {ε : Type u} {m : Type u → Type v} {α : Type u} (x : ExceptT ε m α) : m (Except ε α) :=
+x
+
+namespace ExceptT
+variables {ε : Type u} {m : Type u → Type v} [Monad m]
+
+@[inline] protected def pure {α : Type u} (a : α) : ExceptT ε m α :=
+ExceptT.mk $ pure (Except.ok a)
+
+@[inline] protected def bindCont {α β : Type u} (f : α → ExceptT ε m β) : Except ε α → m (Except ε β)
+| Except.ok a    => f a
+| Except.error e => pure (Except.error e)
+
+@[inline] protected def bind {α β : Type u} (ma : ExceptT ε m α) (f : α → ExceptT ε m β) : ExceptT ε m β :=
+ExceptT.mk $ ma >>= ExceptT.bindCont f
+
+@[inline] protected def map {α β : Type u} (f : α → β) (x : ExceptT ε m α) : ExceptT ε m β :=
+ExceptT.mk $ x >>= fun a => match a with
+  | (Except.ok a)    => pure $ Except.ok (f a)
+  | (Except.error e) => pure $ Except.error e
+
+@[inline] protected def lift {α : Type u} (t : m α) : ExceptT ε m α :=
+ExceptT.mk $ Except.ok <$> t
+
+instance exceptTOfExcept : HasMonadLift (Except ε) (ExceptT ε m) :=
+⟨fun α e => ExceptT.mk $ pure e⟩
+
+instance : HasMonadLift m (ExceptT ε m) :=
+⟨@ExceptT.lift _ _ _⟩
+
+@[inline] protected def catch {α : Type u} (ma : ExceptT ε m α) (handle : ε → ExceptT ε m α) : ExceptT ε m α :=
+ExceptT.mk $ ma >>= fun res => match res with
+ | Except.ok a    => pure (Except.ok a)
+ | Except.error e => (handle e)
+
+instance (m') [Monad m'] : MonadFunctor m m' (ExceptT ε m) (ExceptT ε m') :=
+⟨fun _ f x => f x⟩
+
+instance : Monad (ExceptT ε m) :=
+{ pure := @ExceptT.pure _ _ _, bind := @ExceptT.bind _ _ _, map := @ExceptT.map _ _ _ }
+
+@[inline] protected def adapt {ε' α : Type u} (f : ε → ε') : ExceptT ε m α → ExceptT ε' m α :=
+fun x => ExceptT.mk $ Except.mapError f <$> x
+end ExceptT
+
+/-- An implementation of [MonadError](https://hackage.haskell.org/package/mtl-2.2.2/docs/Control-Monad-Except.html#t:MonadError) -/
+class MonadExcept (ε : outParam (Type u)) (m : Type v → Type w) :=
+(throw {} {α : Type v} : ε → m α)
+(catch {} {α : Type v} : m α → (ε → m α) → m α)
+
+namespace MonadExcept
+variables {ε : Type u} {m : Type v → Type w}
+
+@[inline] protected def orelse [MonadExcept ε m] {α : Type v} (t₁ t₂ : m α) : m α :=
+catch t₁ $ fun _ => t₂
+
+/-- Alternative orelse operator that allows to select which exception should be used.
+    The default is to use the first exception since the standard `orelse` uses the second. -/
+@[inline] def orelse' [MonadExcept ε m] {α : Type v} (t₁ t₂ : m α) (useFirstEx := true) : m α :=
+catch t₁ $ fun e₁ => catch t₂ $ fun e₂ => throw (if useFirstEx then e₁ else e₂)
+
+@[inline] def liftExcept {ε' : Type u} [MonadExcept ε m] [HasLiftT ε' ε] [Monad m] {α : Type v} : Except ε' α → m α
+| Except.error e => throw (coe e)
+| Except.ok a    => pure a
+end MonadExcept
+
+export MonadExcept (throw catch)
+
+instance (m : Type u → Type v) (ε : Type u) [Monad m] : MonadExcept ε (ExceptT ε m) :=
+{ throw := fun α e => ExceptT.mk $ pure (Except.error e),
+  catch := @ExceptT.catch ε _ _ }
+
+instance (ε) : MonadExcept ε (Except ε) :=
+{ throw := fun α => Except.error, catch := @Except.catch _ }
+
+/-- Adapt a Monad stack, changing its top-most error Type.
+
+    Note: This class can be seen as a simplification of the more "principled" definition
+    ```
+    class MonadExceptFunctor (ε ε' : outParam (Type u)) (n n' : Type u → Type u) :=
+    (map {} {α : Type u} : (∀ {m : Type u → Type u} [Monad m], ExceptT ε m α → ExceptT ε' m α) → n α → n' α)
+    ```
+-/
+class MonadExceptAdapter (ε ε' : outParam (Type u)) (m m' : Type u → Type v) :=
+(adaptExcept {} {α : Type u} : (ε → ε') → m α → m' α)
+export MonadExceptAdapter (adaptExcept)
+
+section
+variables {ε ε' : Type u} {m m' : Type u → Type v}
+
+instance monadExceptAdapterTrans {n n' : Type u → Type v} [MonadFunctor m m' n n'] [MonadExceptAdapter ε ε' m m'] : MonadExceptAdapter ε ε' n n' :=
+⟨fun α f => monadMap (fun α => (adaptExcept f : m α → m' α))⟩
+
+instance [Monad m] : MonadExceptAdapter ε ε' (ExceptT ε m) (ExceptT ε' m) :=
+⟨fun α => ExceptT.adapt⟩
+end
+
+instance (ε m out) [MonadRun out m] : MonadRun (fun α => out (Except ε α)) (ExceptT ε m) :=
+⟨fun α => run⟩
+
+-- useful for implicit failures in do-notation
+instance (m : Type → Type) [Monad m] : MonadFail (ExceptT String m) :=
+⟨fun _ => throw⟩
+
+/-- Execute `x` and then execute `finalizer` even if `x` threw an exception -/
+@[inline] def finally {ε α β : Type u} {m : Type u → Type v} [Monad m] [MonadExcept ε m] (x : m α) (finalizer : m β) : m α :=
+catch
+  (do a ← x; finalizer; pure a)
+  (fun e => do finalizer; throw e)

stage0/src/Init/Control/Functor.lean

@@ -0,0 +1,24 @@
+/-
+Copyright (c) Luke Nelson and Jared Roesch. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Luke Nelson, Jared Roesch, Sebastian Ullrich, Leonardo de Moura
+-/
+prelude
+import Init.Core
+open Function
+universes u v
+
+class Functor (f : Type u → Type v) : Type (max (u+1) v) :=
+(map : ∀ {α β : Type u}, (α → β) → f α → f β)
+(mapConst : ∀ {α β : Type u}, α → f β → f α := fun α β => map ∘ const β)
+
+infixr `<$>` := Functor.map
+infixr `<$`  := Functor.mapConst
+
+@[reducible] def Functor.mapConstRev {f : Type u → Type v} [Functor f] {α β : Type u} : f β → α → f α :=
+fun a b => b <$ a
+infixr `$>`  := Functor.mapConstRev
+
+@[reducible] def Functor.mapRev {f : Type u → Type v} [Functor f] {α β : Type u} : f α → (α → β) → f β :=
+fun a f => f <$> a
+infixl `<&>` := Functor.mapRev

stage0/src/Init/Control/Id.lean

@@ -0,0 +1,30 @@
+/-
+Copyright (c) 2017 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Sebastian Ullrich
+
+The identity Monad.
+-/
+prelude
+import Init.Control.Lift
+universe u
+
+def Id (type : Type u) : Type u := type
+
+@[inline] def Id.pure {α : Type u} (x : α) : Id α :=
+x
+
+@[inline] def Id.bind {α β : Type u} (x : Id α) (f : α → Id β) : Id β :=
+f x
+
+@[inline] def Id.map {α β : Type u} (f : α → β) (x : Id α) : Id β :=
+f x
+
+instance : Monad Id :=
+{ pure := @Id.pure, bind := @Id.bind, map := @Id.map }
+
+@[inline] def Id.run {α : Type u} (x : Id α) : α :=
+x
+
+instance : MonadRun id Id :=
+⟨@Id.run⟩

stage0/src/Init/Control/Lift.lean

@@ -0,0 +1,86 @@
+/-
+Copyright (c) 2016 Gabriel Ebner. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Gabriel Ebner, Sebastian Ullrich
+
+Classy functions for lifting monadic actions of different shapes.
+
+This theory is roughly modeled after the Haskell 'layers' package https://hackage.haskell.org/package/layers-0.1.
+Please see https://hackage.haskell.org/package/layers-0.1/docs/Documentation-Layers-Overview.html for an exhaustive discussion of the different approaches to lift functions.
+-/
+prelude
+import Init.Coe
+import Init.Control.Monad
+
+universes u v w
+
+/-- A Function for lifting a computation from an inner Monad to an outer Monad.
+    Like [MonadTrans](https://hackage.haskell.org/package/transformers-0.5.5.0/docs/Control-Monad-Trans-Class.html),
+    but `n` does not have to be a monad transformer.
+    Alternatively, an implementation of [MonadLayer](https://hackage.haskell.org/package/layers-0.1/docs/Control-Monad-Layer.html#t:MonadLayer) without `layerInvmap` (so far). -/
+class HasMonadLift (m : Type u → Type v) (n : Type u → Type w) :=
+(monadLift {} : ∀ {α}, m α → n α)
+
+/-- The reflexive-transitive closure of `HasMonadLift`.
+    `monadLift` is used to transitively lift monadic computations such as `StateT.get` or `StateT.put s`.
+    Corresponds to [MonadLift](https://hackage.haskell.org/package/layers-0.1/docs/Control-Monad-Layer.html#t:MonadLift). -/
+class HasMonadLiftT (m : Type u → Type v) (n : Type u → Type w) :=
+(monadLift {} : ∀ {α}, m α → n α)
+
+export HasMonadLiftT (monadLift)
+
+/-- A coercion that may reduce the need for explicit lifting.
+    Because of [limitations of the current coercion resolution](https://github.com/leanprover/Lean/issues/1402), this definition is not marked as a global instance and should be marked locally instead. -/
+@[reducible] def hasMonadLiftToHasCoe {m n} [HasMonadLiftT m n] {α} : HasCoe (m α) (n α) :=
+⟨monadLift⟩
+
+instance hasMonadLiftTTrans (m n o) [HasMonadLift n o] [HasMonadLiftT m n] : HasMonadLiftT m o :=
+⟨fun α ma => HasMonadLift.monadLift (monadLift ma : n α)⟩
+
+instance hasMonadLiftTRefl (m) : HasMonadLiftT m m :=
+⟨fun α => id⟩
+
+theorem monadLiftRefl {m : Type u → Type v} {α} : (monadLift : m α → m α) = id := rfl
+
+
+/-- A Functor in the control of monads. Can be used to lift Monad-transforming functions.
+    Based on pipes' [MFunctor](https://hackage.haskell.org/package/pipes-2.4.0/docs/Control-MFunctor.html),
+    but not restricted to monad transformers.
+    Alternatively, an implementation of [MonadTransFunctor](http://duairc.netsoc.ie/layers-docs/Control-Monad-Layer.html#t:MonadTransFunctor).
+
+
+    Remark: other libraries equate `m` and `m'`, and `n` and `n'`. We need to distinguish them to be able to implement
+    gadgets such as `MonadStateAdapter` and `MonadReaderAdapter`. -/
+class MonadFunctor (m m' : Type u → Type v) (n n' : Type u → Type w) :=
+(monadMap {} {α : Type u} : (∀ {β}, m β → m' β) → n α → n' α)
+
+/-- The reflexive-transitive closure of `MonadFunctor`.
+    `monadMap` is used to transitively lift Monad morphisms such as `StateT.zoom`.
+    A generalization of [MonadLiftFunctor](http://duairc.netsoc.ie/layers-docs/Control-Monad-Layer.html#t:MonadLiftFunctor), which can only lift endomorphisms (i.e. m = m', n = n'). -/
+class MonadFunctorT (m m' : Type u → Type v) (n n' : Type u → Type w) :=
+(monadMap {} {α : Type u} : (∀ {β}, m β → m' β) → n α → n' α)
+
+export MonadFunctorT (monadMap)
+
+instance monadFunctorTTrans (m m' n n' o o') [MonadFunctorT m m' n n'] [MonadFunctor n n' o o'] :
+  MonadFunctorT m m' o o' :=
+⟨fun α f => MonadFunctor.monadMap (fun β => (monadMap @f : n β → n' β))⟩
+
+instance monadFunctorTRefl (m m') : MonadFunctorT m m' m m' :=
+⟨fun α f => f⟩
+
+theorem monadMapRefl {m m' : Type u → Type v} (f : ∀ {β}, m β → m' β) {α} : (monadMap @f : m α → m' α) = f := rfl
+
+/-- Run a Monad stack to completion.
+    `run` should be the composition of the transformers' individual `run` functions.
+    This class mostly saves some typing when using highly nested Monad stacks:
+    ```
+    @[reducible] def MyMonad := ReaderT myCfg $ StateT myState $ ExceptT myErr id
+    -- def MyMonad.run {α : Type} (x : MyMonad α) (cfg : myCfg) (st : myState) := ((x.run cfg).run st).run
+    def MyMonad.run {α : Type} (x : MyMonad α) := MonadRun.run x
+    ```
+    -/
+class MonadRun (out : outParam $ Type u → Type v) (m : Type u → Type v) :=
+(run {} {α : Type u} : m α → out α)
+
+export MonadRun (run)

stage0/src/Init/Control/Monad.lean

@@ -0,0 +1,49 @@
+/-
+Copyright (c) Luke Nelson and Jared Roesch. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura, Luke Nelson, Jared Roesch, Sebastian Ullrich
+-/
+prelude
+import Init.Control.Applicative
+universes u v w
+
+open Function
+
+class HasBind (m : Type u → Type v) :=
+(bind : ∀ {α β : Type u}, m α → (α → m β) → m β)
+
+export HasBind (bind)
+
+infixr `>>=` := bind
+
+@[inline] def mcomp {α : Type u} {β δ : Type v} {m : Type v → Type w} [HasBind m] (f : α → m β) (g : β → m δ) : α → m δ :=
+fun a => f a >>= g
+
+infixr `>=>` := mcomp
+
+class Monad (m : Type u → Type v) extends Applicative m, HasBind m : Type (max (u+1) v) :=
+(map      := fun α β f x => x >>= pure ∘ f)
+(seq      := fun α β f x => f >>= (fun y => y <$> x))
+(seqLeft  := fun α β x y => x >>= fun a => y >>= fun _ => pure a)
+(seqRight := fun α β x y => x >>= fun _ => y)
+
+instance monadInhabited' {α : Type u} {m : Type u → Type v} [Monad m] : Inhabited (α → m α) :=
+⟨pure⟩
+
+instance monadInhabited {α : Type u} {m : Type u → Type v} [Monad m] [Inhabited α] : Inhabited (m α) :=
+⟨pure $ arbitrary _⟩
+
+def joinM {m : Type u → Type u} [Monad m] {α : Type u} (a : m (m α)) : m α :=
+bind a id
+
+@[macroInline]
+def condM {m : Type → Type u} [Monad m] {α : Type} (mbool : m Bool) (tm fm : m α) : m α :=
+do b ← mbool; cond b tm fm
+
+@[macroInline]
+def whenM {m : Type → Type u} [Monad m] (c : m Bool) (t : m Unit) : m Unit :=
+condM c t (pure ())
+
+@[macroInline]
+def unlessM {m : Type → Type u} [Monad m] (c : m Bool) (t : m Unit) : m Unit :=
+condM c (pure ()) t

stage0/src/Init/Control/MonadFail.lean

@@ -0,0 +1,19 @@
+/-
+Copyright (c) 2017 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Init.Control.Lift
+import Init.Data.String.Basic
+
+universes u v
+
+class MonadFail (m : Type u → Type v) :=
+(fail {} : ∀ {a}, String → m a)
+
+def matchFailed {α : Type u} {m : Type u → Type v} [MonadFail m] : m α :=
+MonadFail.fail "match failed"
+
+instance monadFailLift (m n : Type u → Type v) [HasMonadLift m n] [MonadFail m] [Monad n] : MonadFail n :=
+{ fail := fun α s => monadLift (MonadFail.fail s : m α) }

stage0/src/Init/Control/Option.lean

@@ -0,0 +1,68 @@
+/-
+Copyright (c) 2017 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura, Sebastian Ullrich
+-/
+prelude
+import Init.Control.Alternative
+import Init.Control.Lift
+import Init.Control.Except
+
+universes u v
+
+def OptionT (m : Type u → Type v) (α : Type u) : Type v :=
+m (Option α)
+
+@[inline] def OptionT.run {m : Type u → Type v} {α : Type u} (x : OptionT m α) : m (Option α) :=
+x
+
+namespace OptionT
+  variables {m : Type u → Type v} [Monad m] {α β : Type u}
+
+  @[inline] protected def bindCont {α β : Type u} (f : α → OptionT m β) : Option α → m (Option β)
+  | some a => f a
+  | none   => pure none
+
+  @[inline] protected def bind (ma : OptionT m α) (f : α → OptionT m β) : OptionT m β :=
+  (ma >>= OptionT.bindCont f : m (Option β))
+
+  @[inline] protected def pure (a : α) : OptionT m α :=
+  (pure (some a) : m (Option α))
+
+  instance : Monad (OptionT m) :=
+  { pure := @OptionT.pure _ _, bind := @OptionT.bind _ _ }
+
+  protected def orelse (ma : OptionT m α) (mb : OptionT m α) : OptionT m α :=
+  (do { some a ← ma | mb;
+        pure (some a) } : m (Option α))
+
+  @[inline] protected def fail : OptionT m α :=
+  (pure none : m (Option α))
+
+  instance : Alternative (OptionT m) :=
+  { failure := @OptionT.fail m _,
+    orelse  := @OptionT.orelse m _,
+    ..OptionT.Monad }
+
+  @[inline] protected def lift (ma : m α) : OptionT m α :=
+  (some <$> ma : m (Option α))
+
+  instance : HasMonadLift m (OptionT m) :=
+  ⟨@OptionT.lift _ _⟩
+
+  @[inline] protected def monadMap {m'} [Monad m'] {α} (f : ∀ {α}, m α → m' α) : OptionT m α → OptionT m' α :=
+  fun x => f x
+
+  instance (m') [Monad m'] : MonadFunctor m m' (OptionT m) (OptionT m') :=
+  ⟨fun α => OptionT.monadMap⟩
+
+  protected def catch (ma : OptionT m α) (handle : Unit → OptionT m α) : OptionT m α :=
+  (do { some a ← ma | (handle ());
+        pure a } : m (Option α))
+
+  instance : MonadExcept Unit (OptionT m) :=
+  { throw := fun _ _ => OptionT.fail, catch := @OptionT.catch _ _ }
+
+  instance (m out) [MonadRun out m] : MonadRun (fun α => out (Option α)) (OptionT m) :=
+  ⟨fun α => MonadRun.run⟩
+end OptionT

stage0/src/Init/Control/Reader.lean

@@ -0,0 +1,135 @@
+/-
+Copyright (c) 2017 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Sebastian Ullrich
+
+The Reader monad transformer for passing immutable State.
+-/
+
+prelude
+import Init.Control.Lift
+import Init.Control.Id
+import Init.Control.Alternative
+import Init.Control.Except
+universes u v w
+
+/-- An implementation of [ReaderT](https://hackage.haskell.org/package/transformers-0.5.5.0/docs/Control-Monad-Trans-Reader.html#t:ReaderT) -/
+def ReaderT (ρ : Type u) (m : Type u → Type v) (α : Type u) : Type (max u v) :=
+ρ → m α
+
+@[inline] def ReaderT.run {ρ : Type u} {m : Type u → Type v} {α : Type u} (x : ReaderT ρ m α) (r : ρ) : m α :=
+x r
+
+@[reducible] def Reader (ρ : Type u) := ReaderT ρ id
+
+namespace ReaderT
+section
+variables {ρ : Type u} {m : Type u → Type v} [Monad m] {α β : Type u}
+
+@[inline] protected def read : ReaderT ρ m ρ :=
+pure
+
+@[inline] protected def pure (a : α) : ReaderT ρ m α :=
+fun r => pure a
+
+@[inline] protected def bind (x : ReaderT ρ m α) (f : α → ReaderT ρ m β) : ReaderT ρ m β :=
+fun r => do a ← x r; f a r
+
+@[inline] protected def map (f : α → β) (x : ReaderT ρ m α) : ReaderT ρ m β :=
+fun r => f <$> x r
+
+instance : Monad (ReaderT ρ m) :=
+{ pure := @ReaderT.pure _ _ _, bind := @ReaderT.bind _ _ _, map := @ReaderT.map _ _ _ }
+
+@[inline] protected def lift (a : m α) : ReaderT ρ m α :=
+fun r => a
+
+instance (m) [Monad m] : HasMonadLift m (ReaderT ρ m) :=
+⟨@ReaderT.lift ρ m _⟩
+
+instance (ρ m m') [Monad m] [Monad m'] : MonadFunctor m m' (ReaderT ρ m) (ReaderT ρ m') :=
+⟨fun _ f x r => f (x r)⟩
+
+@[inline] protected def adapt {ρ' : Type u} [Monad m] {α : Type u} (f : ρ' → ρ) : ReaderT ρ m α → ReaderT ρ' m α :=
+fun x r => x (f r)
+
+@[inline] protected def orelse [Alternative m] {α : Type u} (x₁ x₂ : ReaderT ρ m α) : ReaderT ρ m α :=
+fun s => x₁ s <|> x₂ s
+
+@[inline] protected def failure [Alternative m] {α : Type u} : ReaderT ρ m α :=
+fun s => failure
+
+instance [Alternative m] : Alternative (ReaderT ρ m) :=
+{ failure := @ReaderT.failure _ _ _ _,
+  orelse  := @ReaderT.orelse _ _ _ _,
+  ..ReaderT.Monad }
+
+instance (ε) [Monad m] [MonadExcept ε m] : MonadExcept ε (ReaderT ρ m) :=
+{ throw := fun α => ReaderT.lift ∘ throw,
+  catch := fun α x c r => catch (x r) (fun e => (c e) r) }
+end
+end ReaderT
+
+/-- An implementation of [MonadReader](https://hackage.haskell.org/package/mtl-2.2.2/docs/Control-Monad-Reader-Class.html#t:MonadReader).
+    It does not contain `local` because this Function cannot be lifted using `monadLift`.
+    Instead, the `MonadReaderAdapter` class provides the more general `adaptReader` Function.
+
+    Note: This class can be seen as a simplification of the more "principled" definition
+    ```
+    class MonadReader (ρ : outParam (Type u)) (n : Type u → Type u) :=
+    (lift {} {α : Type u} : (∀ {m : Type u → Type u} [Monad m], ReaderT ρ m α) → n α)
+    ```
+    -/
+class MonadReader (ρ : outParam (Type u)) (m : Type u → Type v) :=
+(read {} : m ρ)
+
+export MonadReader (read)
+
+instance monadReaderTrans {ρ : Type u} {m : Type u → Type v} {n : Type u → Type w}
+  [HasMonadLift m n] [MonadReader ρ m] : MonadReader ρ n :=
+⟨monadLift (MonadReader.read : m ρ)⟩
+
+instance {ρ : Type u} {m : Type u → Type v} [Monad m] : MonadReader ρ (ReaderT ρ m) :=
+⟨ReaderT.read⟩
+
+
+/-- Adapt a Monad stack, changing the Type of its top-most environment.
+
+    This class is comparable to [Control.Lens.Magnify](https://hackage.haskell.org/package/lens-4.15.4/docs/Control-Lens-Zoom.html#t:Magnify), but does not use lenses (why would it), and is derived automatically for any transformer implementing `MonadFunctor`.
+
+    Note: This class can be seen as a simplification of the more "principled" definition
+    ```
+    class MonadReaderFunctor (ρ ρ' : outParam (Type u)) (n n' : Type u → Type u) :=
+    (map {} {α : Type u} : (∀ {m : Type u → Type u} [Monad m], ReaderT ρ m α → ReaderT ρ' m α) → n α → n' α)
+    ```
+    -/
+class MonadReaderAdapter (ρ ρ' : outParam (Type u)) (m m' : Type u → Type v) :=
+(adaptReader {} {α : Type u} : (ρ' → ρ) → m α → m' α)
+export MonadReaderAdapter (adaptReader)
+
+section
+variables {ρ ρ' : Type u} {m m' : Type u → Type v}
+
+instance monadReaderAdapterTrans {n n' : Type u → Type v} [MonadFunctor m m' n n'] [MonadReaderAdapter ρ ρ' m m'] : MonadReaderAdapter ρ ρ' n n' :=
+⟨fun α f => monadMap (fun α => (adaptReader f : m α → m' α))⟩
+
+instance [Monad m] : MonadReaderAdapter ρ ρ' (ReaderT ρ m) (ReaderT ρ' m) :=
+⟨fun α => ReaderT.adapt⟩
+end
+
+instance (ρ : Type u) (m out) [MonadRun out m] : MonadRun (fun α => ρ → out α) (ReaderT ρ m) :=
+⟨fun α x => run ∘ x⟩
+
+class MonadReaderRunner (ρ : Type u) (m m' : Type u → Type u) :=
+(runReader {} {α : Type u} : m α → ρ → m' α)
+export MonadReaderRunner (runReader)
+
+section
+variables {ρ ρ' : Type u} {m m' : Type u → Type u}
+
+instance monadReaderRunnerTrans {n n' : Type u → Type u} [MonadFunctor m m' n n'] [MonadReaderRunner ρ m m'] : MonadReaderRunner ρ n n' :=
+⟨fun α x r => monadMap (fun (α) (y : m α) => (runReader y r : m' α)) x⟩
+
+instance ReaderT.MonadStateRunner [Monad m] : MonadReaderRunner ρ (ReaderT ρ m) m :=
+⟨fun α x r => x r⟩
+end

stage0/src/Init/Control/State.lean

@@ -0,0 +1,190 @@
+/-
+Copyright (c) 2016 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura, Sebastian Ullrich
+
+The State monad transformer.
+-/
+prelude
+import Init.Control.Alternative
+import Init.Control.Lift
+import Init.Control.Id
+import Init.Control.Except
+universes u v w
+
+def StateT (σ : Type u) (m : Type u → Type v) (α : Type u) : Type (max u v) :=
+σ → m (α × σ)
+
+@[inline] def StateT.run {σ : Type u} {m : Type u → Type v} {α : Type u} (x : StateT σ m α) (s : σ) : m (α × σ) :=
+x s
+
+@[inline] def StateT.run' {σ : Type u} {m : Type u → Type v} [Functor m] {α : Type u} (x : StateT σ m α) (s : σ) : m α :=
+Prod.fst <$> x s
+
+@[reducible] def StateM (σ α : Type u) : Type u := StateT σ Id α
+
+namespace StateT
+section
+variables {σ : Type u} {m : Type u → Type v}
+variables [Monad m] {α β : Type u}
+
+@[inline] protected def pure (a : α) : StateT σ m α :=
+fun s => pure (a, s)
+
+@[inline] protected def bind (x : StateT σ m α) (f : α → StateT σ m β) : StateT σ m β :=
+fun s => do (a, s) ← x s; f a s
+
+@[inline] protected def map (f : α → β) (x : StateT σ m α) : StateT σ m β :=
+fun s => do (a, s) ← x s; pure (f a, s)
+
+instance : Monad (StateT σ m) :=
+{ pure := @StateT.pure _ _ _, bind := @StateT.bind _ _ _, map := @StateT.map _ _ _ }
+
+@[inline] protected def orelse [Alternative m] {α : Type u} (x₁ x₂ : StateT σ m α) : StateT σ m α :=
+fun s => x₁ s <|> x₂ s
+
+@[inline] protected def failure [Alternative m] {α : Type u} : StateT σ m α :=
+fun s => failure
+
+instance [Alternative m] : Alternative (StateT σ m) :=
+{ failure := @StateT.failure _ _ _ _,
+  orelse  := @StateT.orelse _ _ _ _,
+  .. StateT.Monad }
+
+@[inline] protected def get : StateT σ m σ :=
+fun s => pure (s, s)
+
+@[inline] protected def set : σ → StateT σ m PUnit :=
+fun s' s => pure (⟨⟩, s')
+
+@[inline] protected def modifyGet (f : σ → α × σ) : StateT σ m α :=
+fun s => pure (f s)
+
+@[inline] protected def lift {α : Type u} (t : m α) : StateT σ m α :=
+fun s => do a ← t; pure (a, s)
+
+instance : HasMonadLift m (StateT σ m) :=
+⟨@StateT.lift σ m _⟩
+
+instance (σ m m') [Monad m] [Monad m'] : MonadFunctor m m' (StateT σ m) (StateT σ m') :=
+⟨fun _ f x s => f (x s)⟩
+
+@[inline] protected def adapt {σ σ' σ'' α : Type u} {m : Type u → Type v} [Monad m] (split : σ → σ' × σ'')
+        (join : σ' → σ'' → σ) (x : StateT σ' m α) : StateT σ m α :=
+fun st => do
+  let (st, ctx) := split st;
+  (a, st') ← x st;
+  pure (a, join st' ctx)
+
+instance (ε) [MonadExcept ε m] : MonadExcept ε (StateT σ m) :=
+{ throw := fun α => StateT.lift ∘ throw,
+  catch := fun α x c s => catch (x s) (fun e => c e s) }
+end
+end StateT
+
+/-- An implementation of [MonadState](https://hackage.haskell.org/package/mtl-2.2.2/docs/Control-Monad-State-Class.html).
+    In contrast to the Haskell implementation, we use overlapping instances to derive instances
+    automatically from `monadLift`. -/
+class MonadState (σ : outParam (Type u)) (m : Type u → Type v) :=
+/- Obtain the top-most State of a Monad stack. -/
+(get {} : m σ)
+/- Set the top-most State of a Monad stack. -/
+(set {} : σ → m PUnit)
+/- Map the top-most State of a Monad stack.
+
+   Note: `modifyGet f` may be preferable to `do s <- get; let (a, s) := f s; put s; pure a`
+   because the latter does not use the State linearly (without sufficient inlining). -/
+(modifyGet {} {α : Type u} : (σ → α × σ) → m α)
+
+export MonadState (get set modifyGet)
+
+section
+variables {σ : Type u} {m : Type u → Type v}
+
+@[inline] def modify [MonadState σ m] (f : σ → σ) : m PUnit :=
+modifyGet (fun s => (PUnit.unit, f s))
+
+@[inline] def getModify [MonadState σ m] [Monad m] (f : σ → σ) : m σ :=
+do s ← get; modify f; pure s
+
+-- NOTE: The Ordering of the following two instances determines that the top-most `StateT` Monad layer
+-- will be picked first
+instance monadStateTrans {n : Type u → Type w} [MonadState σ m] [HasMonadLift m n] : MonadState σ n :=
+{ get := monadLift (MonadState.get : m _),
+  set := fun st => monadLift (MonadState.set st : m _),
+  modifyGet := fun α f => monadLift (MonadState.modifyGet f : m _) }
+
+instance [Monad m] : MonadState σ (StateT σ m) :=
+{ get := StateT.get,
+  set := StateT.set,
+  modifyGet := @StateT.modifyGet _ _ _ }
+
+end
+
+/-- Adapt a Monad stack, changing the Type of its top-most State.
+
+    This class is comparable to [Control.Lens.Zoom](https://hackage.haskell.org/package/lens-4.15.4/docs/Control-Lens-Zoom.html#t:Zoom), but does not use lenses (yet?), and is derived automatically for any transformer implementing `MonadFunctor`.
+
+    For zooming into a part of the State, the `split` Function should split σ into the part σ' and the "context" σ'' so that the potentially modified σ' and the context can be rejoined by `join` in the end.
+    In the simplest case, the context can be chosen as the full outer State (ie. `σ'' = σ`), which makes `split` and `join` simpler to define. However, note that the State will not be used linearly in this case.
+
+    Example:
+    ```
+    def zoomFst {α σ σ' : Type} : State σ α → State (σ × σ') α :=
+    adaptState id Prod.mk
+    ```
+
+    The Function can also zoom out into a "larger" State, where the new parts are supplied by `split` and discarded by `join` in the end. The State is therefore not used linearly anymore but merely affinely, which is not a practically relevant distinction in Lean.
+
+    Example:
+    ```
+    def withSnd {α σ σ' : Type} (snd : σ') : State (σ × σ') α → State σ α :=
+    adaptState (fun st => ((st, snd), ())) (fun ⟨st,snd⟩ _ => st)
+    ```
+
+    Note: This class can be seen as a simplification of the more "principled" definition
+    ```
+    class MonadStateFunctor (σ σ' : outParam (Type u)) (n n' : Type u → Type u) :=
+    (map {} {α : Type u} : (∀ {m : Type u → Type u} [Monad m], StateT σ m α → StateT σ' m α) → n α → n' α)
+    ```
+    which better describes the intent of "we can map a `StateT` anywhere in the Monad stack".
+    If we look at the unfolded Type of the first argument `∀ m [Monad m], (σ → m (α × σ)) → σ' → m (α × σ')`, we see that it has the lens Type `∀ f [Functor f], (α → f α) → β → f β` with `f` specialized to `fun σ => m (α × σ)` (exercise: show that this is a lawful Functor). We can build all lenses we are insterested in from the functions `split` and `join` as
+    ```
+    fun f _ st => let (st, ctx) := split st in
+              (fun st' => join st' ctx) <$> f st
+    ```
+    -/
+class MonadStateAdapter (σ σ' : outParam (Type u)) (m m' : Type u → Type v) :=
+(adaptState {} {σ'' α : Type u} (split : σ' → σ × σ'') (join : σ → σ'' → σ') : m α → m' α)
+export MonadStateAdapter (adaptState)
+
+section
+variables {σ σ' : Type u} {m m' : Type u → Type v}
+
+@[inline] def MonadStateAdapter.adaptState' [MonadStateAdapter σ σ' m m'] {α : Type u} (toSigma : σ' → σ) (fromSigma : σ → σ') : m α → m' α :=
+adaptState (fun st => (toSigma st, PUnit.unit)) (fun st _ => fromSigma st)
+export MonadStateAdapter (adaptState')
+
+instance monadStateAdapterTrans {n n' : Type u → Type v} [MonadStateAdapter σ σ' m m'] [MonadFunctor m m' n n'] : MonadStateAdapter σ σ' n n' :=
+⟨fun σ'' α split join => monadMap (fun α => (adaptState split join : m α → m' α))⟩
+
+instance [Monad m] : MonadStateAdapter σ σ' (StateT σ m) (StateT σ' m) :=
+⟨fun σ'' α => StateT.adapt⟩
+end
+
+instance (σ : Type u) (m out : Type u → Type v) [MonadRun out m] [Functor m] : MonadRun (fun α => σ → out α) (StateT σ m) :=
+⟨fun α x => run ∘ StateT.run' x⟩
+
+class MonadStateRunner (σ : Type u) (m m' : Type u → Type u) :=
+(runState {} {α : Type u} : m α → σ → m' α)
+export MonadStateRunner (runState)
+
+section
+variables {σ σ' : Type u} {m m' : Type u → Type u}
+
+instance monadStateRunnerTrans {n n' : Type u → Type u} [MonadStateRunner σ m m'] [MonadFunctor m m' n n'] : MonadStateRunner σ n n' :=
+⟨fun α x s => monadMap (fun (α) (y : m α) => (runState y s : m' α)) x⟩
+
+instance StateT.MonadStateRunner [Monad m] : MonadStateRunner σ (StateT σ m) m :=
+⟨fun α x s => Prod.fst <$> x s⟩
+end

stage0/src/Init/Data.lean

@@ -0,0 +1,23 @@
+/-
+Copyright (c) 2016 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.Basic
+import Init.Data.Nat
+import Init.Data.Char
+import Init.Data.String
+import Init.Data.List
+import Init.Data.Int
+import Init.Data.Array
+import Init.Data.ByteArray
+import Init.Data.Fin
+import Init.Data.UInt
+import Init.Data.RBTree
+import Init.Data.RBMap
+import Init.Data.Option
+import Init.Data.HashMap
+import Init.Data.Random
+import Init.Data.Queue
+import Init.Data.Stack

stage0/src/Init/Data/Array.lean

@@ -0,0 +1,9 @@
+/-
+Copyright (c) 2017 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Gabriel Ebner
+-/
+prelude
+import Init.Data.Array.Basic
+import Init.Data.Array.QSort
+import Init.Data.Array.BinSearch

stage0/src/Init/Data/Array/Basic.lean

@@ -0,0 +1,561 @@
+/-
+Copyright (c) 2018 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.Nat.Basic
+import Init.Data.Fin.Basic
+import Init.Data.UInt
+import Init.Data.Repr
+import Init.Data.ToString
+import Init.Control.Id
+import Init.Util
+universes u v w
+
+/-
+The Compiler has special support for arrays.
+They are implemented using dynamic arrays: https://en.wikipedia.org/wiki/Dynamic_array
+-/
+structure Array (α : Type u) :=
+(sz   : Nat)
+(data : Fin sz → α)
+
+attribute [extern "lean_array_mk"] Array.mk
+attribute [extern "lean_array_data"] Array.data
+attribute [extern "lean_array_sz"] Array.sz
+
+@[reducible, extern "lean_array_get_size"]
+def Array.size {α : Type u} (a : @& Array α) : Nat :=
+a.sz
+
+namespace Array
+variables {α : Type u}
+
+/- The parameter `c` is the initial capacity -/
+@[extern "lean_mk_empty_array_with_capacity"]
+def mkEmpty (c : @& Nat) : Array α :=
+{ sz := 0,
+  data := fun ⟨x, h⟩ => absurd h (Nat.notLtZero x) }
+
+@[extern "lean_array_push"]
+def push (a : Array α) (v : α) : Array α :=
+{ sz   := Nat.succ a.sz,
+  data := fun ⟨j, h₁⟩ =>
+    if h₂ : j = a.sz then v
+    else a.data ⟨j, Nat.ltOfLeOfNe (Nat.leOfLtSucc h₁) h₂⟩ }
+
+@[extern "lean_mk_array"]
+def mkArray {α : Type u} (n : Nat) (v : α) : Array α :=
+{ sz   := n,
+  data := fun _ => v}
+
+theorem szMkArrayEq {α : Type u} (n : Nat) (v : α) : (mkArray n v).sz = n :=
+rfl
+
+def empty : Array α :=
+mkEmpty 0
+
+instance : HasEmptyc (Array α) :=
+⟨Array.empty⟩
+
+instance : Inhabited (Array α) :=
+⟨Array.empty⟩
+
+def isEmpty (a : Array α) : Bool :=
+a.size = 0
+
+def singleton (v : α) : Array α :=
+mkArray 1 v
+
+@[extern "lean_array_fget"]
+def get (a : @& Array α) (i : @& Fin a.size) : α :=
+a.data i
+
+/- Low-level version of `fget` which is as fast as a C array read.
+   `Fin` values are represented as tag pointers in the Lean runtime. Thus,
+   `fget` may be slightly slower than `uget`. -/
+@[extern "lean_array_uget"]
+def uget (a : @& Array α) (i : USize) (h : i.toNat < a.size) : α :=
+a.get ⟨i.toNat, h⟩
+
+/- "Comfortable" version of `fget`. It performs a bound check at runtime. -/
+@[extern "lean_array_get"]
+def get! [Inhabited α] (a : @& Array α) (i : @& Nat) : α :=
+if h : i < a.size then a.get ⟨i, h⟩ else arbitrary α
+
+def back [Inhabited α] (a : Array α) : α :=
+a.get! (a.size - 1)
+
+def get? (a : Array α) (i : Nat) : Option α :=
+if h : i < a.size then some (a.get ⟨i, h⟩) else none
+
+def getD (a : Array α) (i : Nat) (v₀ : α) : α :=
+if h : i < a.size then a.get ⟨i, h⟩ else v₀
+
+@[extern "lean_array_fset"]
+def set (a : Array α) (i : @& Fin a.size) (v : α) : Array α :=
+{ sz   := a.sz,
+  data := fun j => if h : i = j then v else a.data j }
+
+theorem szFSetEq (a : Array α) (i : Fin a.size) (v : α) : (set a i v).size = a.size :=
+rfl
+
+theorem szPushEq (a : Array α) (v : α) : (push a v).size = a.size + 1 :=
+rfl
+
+/- Low-level version of `fset` which is as fast as a C array fset.
+   `Fin` values are represented as tag pointers in the Lean runtime. Thus,
+   `fset` may be slightly slower than `uset`. -/
+@[extern "lean_array_uset"]
+def uset (a : Array α) (i : USize) (v : α) (h : i.toNat < a.size) : Array α :=
+a.set ⟨i.toNat, h⟩ v
+
+/- "Comfortable" version of `fset`. It performs a bound check at runtime. -/
+@[extern "lean_array_set"]
+def set! (a : Array α) (i : @& Nat) (v : α) : Array α :=
+if h : i < a.size then a.set ⟨i, h⟩ v else panic! "index out of bounds"
+
+@[extern "lean_array_fswap"]
+def swap (a : Array α) (i j : @& Fin a.size) : Array α :=
+let v₁ := a.get i;
+let v₂ := a.get j;
+let a  := a.set i v₂;
+a.set j v₁
+
+@[extern "lean_array_swap"]
+def swap! (a : Array α) (i j : @& Nat) : Array α :=
+if h₁ : i < a.size then
+if h₂ : j < a.size then swap a ⟨i, h₁⟩ ⟨j, h₂⟩
+else panic! "index out of bounds"
+else panic! "index out of bounds"
+
+@[inline] def swapAt {α : Type} (a : Array α) (i : Fin a.size) (v : α) : α × Array α :=
+let e := a.get i;
+let a := a.set i v;
+(e, a)
+
+-- TODO: delete as soon as we can define local instances
+@[neverExtract] private def swapAtPanic! [Inhabited α] (i : Nat) : α × Array α :=
+panic! ("index " ++ toString i ++ " out of bounds")
+
+@[inline] def swapAt! {α : Type} (a : Array α) (i : Nat) (v : α) : α × Array α :=
+if h : i < a.size then swapAt a ⟨i, h⟩ v else @swapAtPanic! _ ⟨v⟩ i
+
+@[extern "lean_array_pop"]
+def pop (a : Array α) : Array α :=
+{ sz   := Nat.pred a.size,
+  data := fun ⟨j, h⟩ => a.get ⟨j, Nat.ltOfLtOfLe h (Nat.predLe _)⟩ }
+
+-- TODO(Leo): justify termination using wf-rec
+partial def shrink : Array α → Nat → Array α
+| a, n => if n ≥ a.size then a else shrink a.pop n
+
+section
+variables {m : Type v → Type w} [Monad m]
+variables {β : Type v} {σ : Type u}
+
+-- TODO(Leo): justify termination using wf-rec
+@[specialize] partial def iterateMAux (a : Array α) (f : ∀ (i : Fin a.size), α → β → m β) : Nat → β → m β
+| i, b =>
+  if h : i < a.size then
+     let idx : Fin a.size := ⟨i, h⟩;
+     f idx (a.get idx) b >>= iterateMAux (i+1)
+  else pure b
+
+@[inline] def iterateM (a : Array α) (b : β) (f : ∀ (i : Fin a.size), α → β → m β) : m β :=
+iterateMAux a f 0 b
+
+@[inline] def foldlM (f : β → α → m β) (b : β) (a : Array α) : m β :=
+iterateM a b (fun _ b a => f a b)
+
+@[inline] def foldlFromM (f : β → α → m β) (b : β) (a : Array α) (ini : Nat := 0) : m β :=
+iterateMAux a (fun _ b a => f a b) ini b
+
+-- TODO(Leo): justify termination using wf-rec
+@[specialize] partial def iterateM₂Aux (a₁ : Array α) (a₂ : Array σ) (f : ∀ (i : Fin a₁.size), α → σ → β → m β) : Nat → β → m β
+| i, b =>
+  if h₁ : i < a₁.size then
+     let idx₁ : Fin a₁.size := ⟨i, h₁⟩;
+     if h₂ : i < a₂.size then
+       let idx₂ : Fin a₂.size := ⟨i, h₂⟩;
+       f idx₁ (a₁.get idx₁) (a₂.get idx₂) b >>= iterateM₂Aux (i+1)
+     else pure b
+  else pure b
+
+@[inline] def iterateM₂ (a₁ : Array α) (a₂ : Array σ) (b : β) (f : ∀ (i : Fin a₁.size), α → σ → β → m β) : m β :=
+iterateM₂Aux a₁ a₂ f 0 b
+
+@[inline] def foldlM₂ (f : β → α → σ → m β) (b : β) (a₁ : Array α) (a₂ : Array σ): m β :=
+iterateM₂ a₁ a₂ b (fun _ a₁ a₂ b => f b a₁ a₂)
+
+-- TODO(Leo): justify termination using wf-rec
+@[specialize] partial def findMAux (a : Array α) (f : α → m (Option β)) : Nat → m (Option β)
+| i =>
+  if h : i < a.size then
+     let idx : Fin a.size := ⟨i, h⟩;
+     do r ← f (a.get idx);
+        match r with
+        | some v => pure r
+        | none   => findMAux (i+1)
+  else pure none
+
+@[inline] def findM (a : Array α) (f : α → m (Option β)) : m (Option β) :=
+findMAux a f 0
+
+@[specialize] partial def findRevMAux (a : Array α) (f : α → m (Option β)) : ∀ (idx : Nat), idx ≤ a.size → m (Option β)
+| i, h =>
+  if hLt : 0 < i then
+    have i - 1 < i from Nat.subLt hLt (Nat.zeroLtSucc 0);
+    have i - 1 < a.size from Nat.ltOfLtOfLe this h;
+    let idx : Fin a.size := ⟨i - 1, this⟩;
+    do
+      r ← f (a.get idx);
+      match r with
+      | some v => pure r
+      | none   =>
+        have i - 1 ≤ a.size from Nat.leOfLt this;
+        findRevMAux (i-1) this
+  else pure none
+
+@[inline] def findRevM (a : Array α) (f : α → m (Option β)) : m (Option β) :=
+findRevMAux a f a.size (Nat.leRefl _)
+
+end
+
+section
+variables {β : Type w} {σ : Type u}
+
+@[inline] def iterate (a : Array α) (b : β) (f : ∀ (i : Fin a.size), α → β → β) : β :=
+Id.run $ iterateMAux a f 0 b
+
+@[inline] def iterateFrom (a : Array α) (b : β) (i : Nat) (f : ∀ (i : Fin a.size), α → β → β) : β :=
+Id.run $ iterateMAux a f i b
+
+@[inline] def foldl (f : β → α → β) (b : β) (a : Array α) : β :=
+iterate a b (fun _ a b => f b a)
+
+@[inline] def foldlFrom (f : β → α → β) (b : β) (a : Array α) (ini : Nat := 0) : β :=
+Id.run $ foldlFromM f b a ini
+
+@[inline] def iterate₂ (a₁ : Array α) (a₂ : Array σ) (b : β) (f : ∀ (i : Fin a₁.size), α → σ → β → β) : β :=
+Id.run $ iterateM₂Aux a₁ a₂ f 0 b
+
+@[inline] def foldl₂ (f : β → α → σ → β) (b : β) (a₁ : Array α) (a₂ : Array σ) : β :=
+iterate₂ a₁ a₂ b (fun _ a₁ a₂ b => f b a₁ a₂)
+
+@[inline] def find? (a : Array α) (f : α → Option β) : Option β :=
+Id.run $ findMAux a f 0
+
+@[inline] def find! [Inhabited β] (a : Array α) (f : α → Option β) : β :=
+match find? a f with
+| some b => b
+| none   => panic! "failed to find element"
+
+@[inline] def findRev? (a : Array α) (f : α → Option β) : Option β :=
+Id.run $ findRevMAux a f a.size (Nat.leRefl _)
+
+@[inline] def findRev! [Inhabited β] (a : Array α) (f : α → Option β) : β :=
+match findRev? a f with
+| some b => b
+| none   => panic! "failed to find element"
+
+@[specialize] partial def findIdxAux (a : Array α) (p : α → Bool) : Nat → Option Nat
+| i =>
+  if h : i < a.size then
+     let idx : Fin a.size := ⟨i, h⟩;
+     if p (a.get idx) then some i
+     else findIdxAux (i+1)
+  else none
+
+@[inline] def findIdx? (a : Array α) (p : α → Bool) : Option Nat :=
+findIdxAux a p 0
+
+@[inline] def findIdx! (a : Array α) (p : α → Bool) : Nat :=
+match findIdxAux a p 0 with
+| some i => i
+| none   => panic! "failed to find element"
+
+end
+
+section
+variables {m : Type → Type w} [Monad m]
+
+@[specialize] partial def anyRangeMAux (a : Array α) (endIdx : Nat) (hlt : endIdx ≤ a.size) (p : α → m Bool) : Nat → m Bool
+| i =>
+  if h : i < endIdx then
+     let idx : Fin a.size := ⟨i, Nat.ltOfLtOfLe h hlt⟩;
+     do b ← p (a.get idx);
+     match b with
+     | true  => pure true
+     | false => anyRangeMAux (i+1)
+  else pure false
+
+@[inline] def anyM (a : Array α) (p : α → m Bool) : m Bool :=
+anyRangeMAux a a.size (Nat.leRefl _) p 0
+
+@[inline] def allM (a : Array α) (p : α → m Bool) : m Bool :=
+do b ← anyM a (fun v => do b ← p v; pure (!b)); pure (!b)
+
+@[inline] def anyRangeM (a : Array α) (beginIdx endIdx : Nat) (p : α → m Bool) : m Bool :=
+if h : endIdx ≤ a.size then
+  anyRangeMAux a endIdx h p beginIdx
+else
+  anyRangeMAux a a.size (Nat.leRefl _) p beginIdx
+
+@[inline] def allRangeM (a : Array α) (beginIdx endIdx : Nat) (p : α → m Bool) : m Bool :=
+do b ← anyRangeM a beginIdx endIdx (fun v => do b ← p v; pure b); pure (!b)
+
+end
+
+@[inline] def any (a : Array α) (p : α → Bool) : Bool :=
+Id.run $ anyM a p
+
+@[inline] def anyRange (a : Array α) (beginIdx endIdx : Nat) (p : α → Bool) : Bool :=
+Id.run $ anyRangeM a beginIdx endIdx p
+
+@[inline] def anyFrom (a : Array α) (beginIdx : Nat) (p : α → Bool) : Bool :=
+Id.run $ anyRangeM a beginIdx a.size p
+
+@[inline] def all (a : Array α) (p : α → Bool) : Bool :=
+!any a (fun v => !p v)
+
+@[inline] def allRange (a : Array α) (beginIdx endIdx : Nat) (p : α → Bool) : Bool :=
+!anyRange a beginIdx endIdx (fun v => !p v)
+
+section
+variables {m : Type v → Type w} [Monad m]
+variable {β : Type v}
+
+@[specialize] private def iterateRevMAux (a : Array α) (f : ∀ (i : Fin a.size), α → β → m β) : ∀ (i : Nat), i ≤ a.size → β → m β
+| 0,   h, b => pure b
+| j+1, h, b => do
+  let i : Fin a.size := ⟨j, h⟩;
+  b ← f i (a.get i) b;
+  iterateRevMAux j (Nat.leOfLt h) b
+
+@[inline] def iterateRevM (a : Array α) (b : β) (f : ∀ (i : Fin a.size), α → β → m β) : m β :=
+iterateRevMAux a f a.size (Nat.leRefl _) b
+
+@[inline] def foldrM (f : α → β → m β) (b : β) (a : Array α) : m β :=
+iterateRevM a b (fun _ => f)
+
+end
+
+@[inline] def iterateRev {β} (a : Array α) (b : β) (f : ∀ (i : Fin a.size), α → β → β) : β :=
+Id.run $ iterateRevM a b f
+
+@[inline] def foldr {β} (f : α → β → β) (b : β) (a : Array α) : β :=
+Id.run $ foldrM f b a
+
+def toList (a : Array α) : List α :=
+a.foldr List.cons []
+
+instance [HasRepr α] : HasRepr (Array α) :=
+⟨fun a => "#" ++ repr a.toList⟩
+
+instance [HasToString α] : HasToString (Array α) :=
+⟨fun a => "#" ++ toString a.toList⟩
+
+section
+variables {m : Type u → Type w} [Monad m]
+variable {β : Type u}
+
+@[specialize] unsafe partial def umapMAux (f : Nat → α → m β) : Nat → Array α → m (Array β)
+| i, a =>
+  if h : i < a.size then
+     let idx : Fin a.size := ⟨i, h⟩;
+     let v   : α          := a.get idx;
+     let a                := a.set idx (@unsafeCast _ _ ⟨v⟩ ());
+     do newV ← f i v; umapMAux (i+1) (a.set idx (@unsafeCast _ _ ⟨v⟩ newV))
+  else
+     pure (unsafeCast a)
+
+@[inline] unsafe partial def umapM (f : α → m β) (as : Array α) : m (Array β) :=
+umapMAux (fun i a => f a) 0 as
+
+@[inline] unsafe partial def umapIdxM (f : Nat → α → m β) (as : Array α) : m (Array β) :=
+umapMAux f 0 as
+
+@[implementedBy Array.umapM] def mapM (f : α → m β) (as : Array α) : m (Array β) :=
+as.foldlM (fun bs a => do b ← f a; pure (bs.push b)) (mkEmpty as.size)
+
+@[implementedBy Array.umapIdxM] def mapIdxM (f : Nat → α → m β) (as : Array α) : m (Array β) :=
+as.iterateM (mkEmpty as.size) (fun i a bs => do b ← f i.val a; pure (bs.push b))
+end
+
+section
+variable {β : Type u}
+
+@[inline] def modify [Inhabited α] (a : Array α) (i : Nat) (f : α → α) : Array α :=
+if h : i < a.size then
+  let idx : Fin a.size := ⟨i, h⟩;
+  let v                := a.get idx;
+  let a                := a.set idx (arbitrary α);
+  let v                := f v;
+  a.set idx v
+else
+  a
+
+@[inline] def mapIdx (f : Nat → α → β) (a : Array α) : Array β :=
+Id.run $ mapIdxM f a
+
+@[inline] def map (f : α → β) (as : Array α) : Array β :=
+Id.run $ mapM f as
+end
+
+section
+variables {m : Type u → Type v} [Monad m]
+variable {β : Type u}
+
+@[specialize]
+partial def forMAux {α : Type w} {β : Type u} (f : α → m β) (a : Array α) : Nat → m PUnit
+| i =>
+  if h : i < a.size then
+     let idx : Fin a.size := ⟨i, h⟩;
+     let v   : α          := a.get idx;
+     f v *> forMAux (i+1)
+  else
+     pure ⟨⟩
+
+def forM {α : Type w} {β : Type u} (f : α → m β) (a : Array α) : m PUnit :=
+a.forMAux f 0
+
+end
+
+-- TODO(Leo): justify termination using wf-rec
+partial def extractAux (a : Array α) : Nat → ∀ (e : Nat), e ≤ a.size → Array α → Array α
+| i, e, hle, r =>
+  if hlt : i < e then
+    let idx : Fin a.size := ⟨i, Nat.ltOfLtOfLe hlt hle⟩;
+    extractAux (i+1) e hle (r.push (a.get idx))
+ else r
+
+def extract (a : Array α) (b e : Nat) : Array α :=
+let r : Array α := mkEmpty (e - b);
+if h : e ≤ a.size then extractAux a b e h r
+else r
+
+protected def append (a : Array α) (b : Array α) : Array α :=
+b.foldl (fun a v => a.push v) a
+
+instance : HasAppend (Array α) := ⟨Array.append⟩
+
+-- TODO(Leo): justify termination using wf-rec
+partial def isEqvAux (a b : Array α) (hsz : a.size = b.size) (p : α → α → Bool) : Nat → Bool
+| i =>
+  if h : i < a.size then
+     let aidx : Fin a.size := ⟨i, h⟩;
+     let bidx : Fin b.size := ⟨i, hsz ▸ h⟩;
+     match p (a.get aidx) (b.get bidx) with
+     | true  => isEqvAux (i+1)
+     | false => false
+  else
+    true
+
+@[specialize] def isEqv (a b : Array α) (p : α → α → Bool) : Bool :=
+if h : a.size = b.size then
+  isEqvAux a b h p 0
+else
+  false
+
+instance [HasBeq α] : HasBeq (Array α) :=
+⟨fun a b => isEqv a b HasBeq.beq⟩
+
+-- TODO(Leo): justify termination using wf-rec, and use `swap`
+partial def reverseAux : Array α → Nat → Array α
+| a, i =>
+  let n := a.size;
+  if i < n / 2 then
+    reverseAux (a.swap! i (n - i - 1)) (i+1)
+  else
+    a
+
+def reverse (a : Array α) : Array α :=
+reverseAux a 0
+
+-- TODO(Leo): justify termination using wf-rec
+@[specialize] partial def filterAux (p : α → Bool) : Array α → Nat → Nat → Array α
+| a, i, j =>
+  if h₁ : i < a.size then
+    if p (a.get ⟨i, h₁⟩) then
+       if h₂ : j < i then
+         filterAux (a.swap ⟨i, h₁⟩ ⟨j, Nat.ltTrans h₂ h₁⟩) (i+1) (j+1)
+       else
+         filterAux a (i+1) (j+1)
+    else
+       filterAux a (i+1) j
+  else
+    a.shrink j
+
+@[inline] def filter (p : α → Bool) (as : Array α) : Array α :=
+filterAux p as 0 0
+
+partial def indexOfAux {α} [HasBeq α] (a : Array α) (v : α) : Nat → Option (Fin a.size)
+| i =>
+  if h : i < a.size then
+    let idx : Fin a.size := ⟨i, h⟩;
+    if a.get idx == v then some idx
+    else indexOfAux (i+1)
+  else none
+
+def indexOf {α} [HasBeq α] (a : Array α) (v : α) : Option (Fin a.size) :=
+indexOfAux a v 0
+
+partial def eraseIdxAux {α} : Nat → Array α → Array α
+| i, a =>
+  if h : i < a.size then
+    let idx  : Fin a.size := ⟨i, h⟩;
+    let idx1 : Fin a.size := ⟨i - 1, Nat.ltOfLeOfLt (Nat.predLe i) h⟩;
+    eraseIdxAux (i+1) (a.swap idx idx1)
+  else
+    a.pop
+
+def feraseIdx {α} (a : Array α) (i : Fin a.size) : Array α :=
+eraseIdxAux (i.val + 1) a
+
+def eraseIdx {α} (a : Array α) (i : Nat) : Array α :=
+if i < a.size then eraseIdxAux (i+1) a else a
+
+theorem szFSwapEq (a : Array α) (i j : Fin a.size) : (a.swap i j).size = a.size :=
+rfl
+
+theorem szPopEq (a : Array α) : a.pop.size = a.size - 1 :=
+rfl
+
+section
+/- Instance for justifying `partial` declaration.
+   We should be able to delete it as soon as we restore support for well-founded recursion. -/
+instance eraseIdxSzAuxInstance (a : Array α) : Inhabited { r : Array α // r.size = a.size - 1 } :=
+⟨⟨a.pop, szPopEq a⟩⟩
+
+partial def eraseIdxSzAux {α} (a : Array α) : ∀ (i : Nat) (r : Array α), r.size = a.size → { r : Array α // r.size = a.size - 1 }
+| i, r, heq =>
+  if h : i < r.size then
+    let idx  : Fin r.size := ⟨i, h⟩;
+    let idx1 : Fin r.size := ⟨i - 1, Nat.ltOfLeOfLt (Nat.predLe i) h⟩;
+    eraseIdxSzAux (i+1) (r.swap idx idx1) ((szFSwapEq r idx idx1).trans heq)
+  else
+    ⟨r.pop, (szPopEq r).trans (heq ▸ rfl)⟩
+end
+
+def eraseIdx' {α} (a : Array α) (i : Fin a.size) : { r : Array α // r.size = a.size - 1 } :=
+eraseIdxSzAux a (i.val + 1) a rfl
+
+def contains [HasBeq α] (as : Array α) (a : α) : Bool :=
+as.any $ fun b => a == b
+
+end Array
+
+export Array (mkArray)
+
+@[inlineIfReduce] def List.toArrayAux {α : Type u} : List α → Array α → Array α
+| [],    r => r
+| a::as, r => List.toArrayAux as (r.push a)
+
+@[inlineIfReduce] def List.redLength {α : Type u} : List α → Nat
+| []    => 0
+| _::as => as.redLength + 1
+
+@[inline] def List.toArray {α : Type u} (as : List α) : Array α :=
+as.toArrayAux (Array.mkEmpty as.redLength)

stage0/src/Init/Data/Array/BinSearch.lean

@@ -0,0 +1,32 @@
+/-
+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 Init.Data.Array.Basic
+universes u v
+
+namespace Array
+-- TODO: remove the [Inhabited α] parameters as soon as we have the tactic framework for automating proof generation and using Array.fget
+-- TODO: remove `partial` using well-founded recursion
+
+@[specialize] partial def binSearchAux {α : Type u} {β : Type v} [Inhabited α] [Inhabited β] (lt : α → α → Bool) (found : Option α → β) (as : Array α) (k : α) : Nat → Nat → β
+| lo, hi =>
+  if lo <= hi then
+    let m := (lo + hi)/2;
+    let a := as.get! m;
+    if lt a k then binSearchAux (m+1) hi
+    else if lt k a then
+      if m == 0 then found none
+      else binSearchAux lo (m-1)
+    else found (some a)
+  else found none
+
+@[inline] def binSearch {α : Type} [Inhabited α] (as : Array α) (k : α) (lt : α → α → Bool) (lo := 0) (hi := as.size - 1) : Option α :=
+binSearchAux lt id as k lo hi
+
+@[inline] def binSearchContains {α : Type} [Inhabited α] (as : Array α) (k : α) (lt : α → α → Bool) (lo := 0) (hi := as.size - 1) : Bool :=
+binSearchAux lt Option.isSome as k lo hi
+
+end Array

stage0/src/Init/Data/Array/QSort.lean

@@ -0,0 +1,49 @@
+/-
+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 Init.Data.Array.Basic
+
+namespace Array
+-- TODO: remove the [Inhabited α] parameters as soon as we have the tactic framework for automating proof generation and using Array.fget
+-- TODO: remove `partial` using well-founded recursion
+
+@[specialize] private partial def partitionAux {α : Type} [Inhabited α] (lt : α → α → Bool) (hi : Nat) (pivot : α) : Array α → Nat → Nat → Nat × Array α
+| as, i, j =>
+  if j < hi then
+    if lt (as.get! j) pivot then
+      let as := as.swap! i j;
+      partitionAux as (i+1) (j+1)
+    else
+      partitionAux as i (j+1)
+  else
+    let as := as.swap! i hi;
+    (i, as)
+
+@[inline] def partition {α : Type} [Inhabited α] (as : Array α) (lt : α → α → Bool) (lo hi : Nat) : Nat × Array α :=
+let mid := (lo + hi) / 2;
+let as  := if lt (as.get! mid) (as.get! lo) then as.swap! lo mid else as;
+let as  := if lt (as.get! hi)  (as.get! lo) then as.swap! lo hi  else as;
+let as  := if lt (as.get! mid) (as.get! hi) then as.swap! mid hi else as;
+let pivot := as.get! hi;
+partitionAux lt hi pivot as lo lo
+
+@[specialize] partial def qsortAux {α : Type} [Inhabited α] (lt : α → α → Bool) : Array α → Nat → Nat → Array α
+| as, low, high =>
+  if low < high then
+    let p   := partition as lt low high;
+    -- TODO: fix `partial` support in the equation compiler, it breaks if we use `let (mid, as) := partition as lt low high`
+    let mid := p.1;
+    let as  := p.2;
+    if mid >= high then as
+    else
+      let as  := qsortAux as low mid;
+      qsortAux as (mid+1) high
+  else as
+
+@[inline] def qsort {α : Type} [Inhabited α] (as : Array α) (lt : α → α → Bool) (low := 0) (high := as.size - 1) : Array α :=
+qsortAux lt as low high
+
+end Array

stage0/src/Init/Data/AssocList.lean

@@ -0,0 +1,50 @@
+/-
+Copyright (c) 2019 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Author: Leonardo de Moura
+-/
+prelude
+import Init.Control.Id
+universes u v w
+
+/- List-like type to avoid extra level of indirection -/
+inductive AssocList (α : Type u) (β : Type v)
+| nil {} : AssocList
+| cons (key : α) (value : β) (tail : AssocList) : AssocList
+
+namespace AssocList
+variables {α : Type u} {β : Type v} {δ : Type w} {m : Type w → Type w} [Monad m]
+
+def empty : AssocList α β :=
+nil
+
+@[specialize] def foldlM (f : δ → α → β → m δ) : δ → AssocList α β → m δ
+| d, nil         => pure d
+| d, cons a b es => do d ← f d a b; foldlM d es
+
+@[inline] def foldl (f : δ → α → β → δ) (d : δ) (as : AssocList α β) : δ :=
+Id.run (foldlM f d as)
+
+def find [HasBeq α] (a : α) : AssocList α β → Option β
+| nil         => none
+| cons k v es => match k == a with
+  | true  => some v
+  | false => find es
+
+def contains [HasBeq α] (a : α) : AssocList α β → Bool
+| nil         => false
+| cons k v es => k == a || contains es
+
+def replace [HasBeq α] (a : α) (b : β) : AssocList α β → AssocList α β
+| nil         => nil
+| cons k v es => match k == a with
+  | true  => cons a b es
+  | false => cons k v (replace es)
+
+def erase [HasBeq α] (a : α) : AssocList α β → AssocList α β
+| nil         => nil
+| cons k v es => match k == a with
+  | true  => es
+  | false => cons k v (erase es)
+
+end AssocList

stage0/src/Init/Data/Basic.lean

@@ -0,0 +1,15 @@
+/-
+Copyright (c) 2016 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.Nat.Basic
+import Init.Data.Fin.Basic
+import Init.Data.List.Basic
+import Init.Data.Char.Basic
+import Init.Data.String.Basic
+import Init.Data.Option.Basic
+import Init.Data.UInt
+import Init.Data.Repr
+import Init.Data.ToString

stage0/src/Init/Data/BinomialHeap.lean

@@ -0,0 +1,7 @@
+/-
+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 Init.Data.BinomialHeap.Basic

stage0/src/Init/Data/BinomialHeap/Basic.lean

@@ -0,0 +1,149 @@
+/-
+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 Init.Data.List
+import Init.Coe
+universes u
+
+namespace BinomialHeapImp
+
+structure HeapNodeAux (α : Type u) (h : Type u) :=
+(val : α) (rank : Nat) (children : List h)
+
+inductive Heap (α : Type u) : Type u
+| empty {} : Heap
+| heap  (ns : List (HeapNodeAux α Heap)) : Heap
+
+abbrev HeapNode (α) := HeapNodeAux α (Heap α)
+
+variables {α : Type u}
+
+instance : Inhabited (Heap α) := ⟨Heap.empty⟩
+
+def hRank : List (HeapNode α) → Nat
+| []   => 0
+| h::_ => h.rank
+
+def isEmpty : Heap α → Bool
+| Heap.empty => true
+| _          => false
+
+def singleton (a : α) : Heap α :=
+Heap.heap [{ val := a, rank := 1, children := [] }]
+
+@[specialize] def combine (lt : α → α → Bool) (n₁ n₂ : HeapNode α) : HeapNode α :=
+if lt n₂.val n₁.val then
+   { rank := n₂.rank + 1, children := n₂.children ++ [Heap.heap [n₁]], .. n₂ }
+else
+   { rank := n₁.rank + 1, children := n₁.children ++ [Heap.heap [n₂]], .. n₁ }
+
+@[specialize] partial def mergeNodes (lt : α → α → Bool) : List (HeapNode α) → List (HeapNode α) → List (HeapNode α)
+| [], h  => h
+| h,  [] => h
+| f@(h₁ :: t₁), s@(h₂ :: t₂) =>
+  if h₁.rank < h₂.rank then h₁ :: mergeNodes t₁ s
+  else if h₂.rank < h₁.rank then h₂ :: mergeNodes t₂ f
+  else
+    let merged := combine lt h₁ h₂;
+    let r      := merged.rank;
+    if r != hRank t₁ then
+      if r != hRank t₂ then merged :: mergeNodes t₁ t₂ else mergeNodes (merged :: t₁) t₂
+    else
+      if r != hRank t₂ then mergeNodes t₁ (merged :: t₂) else merged :: mergeNodes t₁ t₂
+
+@[specialize] def merge (lt : α → α → Bool) : Heap α → Heap α → Heap α
+| Heap.empty,    h           => h
+| h,             Heap.empty  => h
+| Heap.heap h₁, Heap.heap h₂ => Heap.heap (mergeNodes lt h₁ h₂)
+
+@[specialize] def head? (lt : α → α → Bool) : Heap α → Option α
+| Heap.empty  => none
+| Heap.heap h => h.foldl
+  (fun r n => match r with
+   | none   => n.val
+   | some v => if lt v n.val then v else n.val) none
+
+/- O(log n) -/
+@[specialize] def head [Inhabited α] (lt : α → α → Bool) : Heap α → α
+| Heap.empty        => arbitrary α
+| Heap.heap []      => arbitrary α
+| Heap.heap (h::hs) => hs.foldl (fun r n => if lt r n.val then r else n.val) h.val
+
+@[specialize] def findMin (lt : α → α → Bool) : List (HeapNode α) → Nat → HeapNode α × Nat → HeapNode α × Nat
+| [],    _,   r          => r
+| h::hs, idx, (h', idx') => if lt h.val h'.val then findMin hs (idx+1) (h, idx) else findMin hs (idx+1) (h', idx')
+
+def tail (lt : α → α → Bool) : Heap α → Heap α
+| Heap.empty        => Heap.empty
+| Heap.heap []      => Heap.empty
+| Heap.heap [h]     =>
+  match h.children with
+  | []      => Heap.empty
+  | (h::hs) => hs.foldl (merge lt) h
+| Heap.heap hhs@(h::hs) =>
+  let (min, minIdx) := findMin lt hs 1 (h, 0);
+  let rest          := hhs.eraseIdx minIdx;
+  min.children.foldl (merge lt) (Heap.heap rest)
+
+partial def toList (lt : α → α → Bool) : Heap α → List α
+| Heap.empty => []
+| h          => match head? lt h with
+  | none   => []
+  | some a => a :: toList (tail lt h)
+
+inductive WellFormed (lt : α → α → Bool) : Heap α → Prop
+| emptyWff                  : WellFormed Heap.empty
+| singletonWff (a : α)      : WellFormed (singleton a)
+| mergeWff (h₁ h₂ : Heap α) : WellFormed h₁ → WellFormed h₂ → WellFormed (merge lt h₁ h₂)
+| tailWff (h : Heap α)      : WellFormed h → WellFormed (tail lt h)
+
+end BinomialHeapImp
+
+open BinomialHeapImp
+
+def BinomialHeap (α : Type u) (lt : α → α → Bool) := { h : Heap α // WellFormed lt h }
+
+@[inline] def mkBinomialHeap (α : Type u) (lt : α → α → Bool) : BinomialHeap α lt :=
+⟨Heap.empty, WellFormed.emptyWff lt⟩
+
+namespace BinomialHeap
+variables {α : Type u} {lt : α → α → Bool}
+
+@[inline] def empty : BinomialHeap α lt :=
+mkBinomialHeap α lt
+
+@[inline] def isEmpty : BinomialHeap α lt → Bool
+| ⟨b, _⟩ => BinomialHeapImp.isEmpty b
+
+/- O(1) -/
+@[inline] def singleton (a : α) : BinomialHeap α lt :=
+⟨BinomialHeapImp.singleton a, WellFormed.singletonWff lt a⟩
+
+/- O(log n) -/
+@[inline] def merge : BinomialHeap α lt → BinomialHeap α lt → BinomialHeap α lt
+| ⟨b₁, h₁⟩, ⟨b₂, h₂⟩ => ⟨BinomialHeapImp.merge lt b₁ b₂, WellFormed.mergeWff b₁ b₂ h₁ h₂⟩
+
+/- O(log n) -/
+@[inline] def head [Inhabited α] : BinomialHeap α lt → α
+| ⟨b, _⟩ => BinomialHeapImp.head lt b
+
+/- O(log n) -/
+@[inline] def head? : BinomialHeap α lt → Option α
+| ⟨b, _⟩ => BinomialHeapImp.head? lt b
+
+/- O(log n) -/
+@[inline] def tail : BinomialHeap α lt → BinomialHeap α lt
+| ⟨b, h⟩ => ⟨BinomialHeapImp.tail lt b, WellFormed.tailWff b h⟩
+
+/- O(log n) -/
+@[inline] def insert (a : α) (h : BinomialHeap α lt) : BinomialHeap α lt :=
+merge (singleton a) h
+
+/- O(n log n) -/
+@[inline] def toList : BinomialHeap α lt → List α
+| ⟨b, _⟩ => BinomialHeapImp.toList lt b
+
+end BinomialHeap

stage0/src/Init/Data/ByteArray.lean

@@ -0,0 +1,7 @@
+/-
+Copyright (c) 2019 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Author: Leonardo de Moura
+-/
+prelude
+import Init.Data.ByteArray.Basic

stage0/src/Init/Data/ByteArray/Basic.lean

@@ -0,0 +1,68 @@
+/-
+Copyright (c) 2019 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Author: Leonardo de Moura
+-/
+prelude
+import Init.Data.Array.Basic
+import Init.Data.UInt
+import Init.Data.Option.Basic
+universes u
+
+structure ByteArray :=
+(data : Array UInt8)
+
+attribute [extern "lean_byte_array_mk"] ByteArray.mk
+attribute [extern "lean_byte_array_data"] ByteArray.data
+
+namespace ByteArray
+@[extern "lean_mk_empty_byte_array"]
+def mkEmpty (c : @& Nat) : ByteArray :=
+{ data := #[] }
+
+def empty : ByteArray :=
+mkEmpty 0
+
+instance : Inhabited ByteArray :=
+⟨empty⟩
+
+@[extern "lean_byte_array_push"]
+def push : ByteArray → UInt8 → ByteArray
+| ⟨bs⟩, b => ⟨bs.push b⟩
+
+@[extern "lean_byte_array_size"]
+def size : (@& ByteArray) → Nat
+| ⟨bs⟩ => bs.size
+
+@[extern "lean_byte_array_get"]
+def get! : (@& ByteArray) → (@& Nat) → UInt8
+| ⟨bs⟩, i => bs.get! i
+
+@[extern "lean_byte_array_set"]
+def set! : ByteArray → (@& Nat) → UInt8 → ByteArray
+| ⟨bs⟩, i, b => ⟨bs.set! i b⟩
+
+def isEmpty (s : ByteArray) : Bool :=
+s.size == 0
+
+partial def toListAux (bs : ByteArray) : Nat → List UInt8 → List UInt8
+| i, r =>
+  if i < bs.size then
+    toListAux (i+1) (bs.get! i :: r)
+  else
+    r.reverse
+
+def toList (bs : ByteArray) : List UInt8 :=
+toListAux bs 0 []
+
+end ByteArray
+
+def List.toByteArrayAux : List UInt8 → ByteArray → ByteArray
+| [],    r => r
+| b::bs, r => List.toByteArrayAux bs (r.push b)
+
+def List.toByteArray (bs : List UInt8) : ByteArray :=
+bs.toByteArrayAux ByteArray.empty
+
+instance : HasToString ByteArray :=
+⟨fun bs => bs.toList.toString⟩

stage0/src/Init/Data/Char.lean

@@ -0,0 +1,7 @@
+/-
+Copyright (c) 2016 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.Char.Basic

stage0/src/Init/Data/Char/Basic.lean

@@ -0,0 +1,94 @@
+/-
+Copyright (c) 2016 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Author: Leonardo de Moura
+-/
+prelude
+import Init.Data.UInt
+@[inline, reducible] def isValidChar (n : UInt32) : Prop :=
+n < 0xd800 ∨ (0xdfff < n ∧ n < 0x110000)
+
+/-- The `Char` Type represents an unicode scalar value.
+    See http://www.unicode.org/glossary/#unicode_scalar_value). -/
+structure Char :=
+(val : UInt32) (valid : isValidChar val)
+
+instance : HasSizeof Char :=
+⟨fun c => c.val.toNat⟩
+
+namespace Char
+def utf8Size (c : Char) : UInt32 :=
+let v := c.val;
+     if UInt32.land v 0x80 = 0    then 1
+else if UInt32.land v 0xE0 = 0xC0 then 2
+else if UInt32.land v 0xF0 = 0xE0 then 3
+else if UInt32.land v 0xF8 = 0xF0 then 4
+else if UInt32.land v 0xFC = 0xF8 then 5
+else if UInt32.land v 0xFE = 0xFC then 6
+else if v = 0xFF                  then 1
+else 0
+
+protected def Less (a b : Char) : Prop := a.val < b.val
+protected def LessEq (a b : Char) : Prop := a.val ≤ b.val
+
+instance : HasLess Char   := ⟨Char.Less⟩
+instance : HasLessEq Char := ⟨Char.LessEq⟩
+
+protected def lt (a b : Char) : Bool := a.val < b.val
+
+instance decLt (a b : Char) :  Decidable (a < b) :=
+UInt32.decLt _ _
+
+instance decLe (a b : Char) : Decidable (a ≤ b) :=
+UInt32.decLe _ _
+
+axiom isValidChar0 : isValidChar 0
+
+@[noinline, matchPattern] def ofNat (n : Nat) : Char :=
+if h : isValidChar n.toUInt32 then {val := n.toUInt32, valid := h} else {val := 0, valid := isValidChar0}
+
+@[inline] def toNat (c : Char) : Nat :=
+c.val.toNat
+
+theorem eqOfVeq : ∀ {c d : Char}, c.val = d.val → c = d
+| ⟨v, h⟩, ⟨_, _⟩, rfl => rfl
+
+theorem veqOfEq : ∀ {c d : Char}, c = d → c.val = d.val
+| _, _, rfl => rfl
+
+theorem neOfVne {c d : Char} (h : c.val ≠ d.val) : c ≠ d :=
+fun h' => absurd (veqOfEq h') h
+
+theorem vneOfNe {c d : Char} (h : c ≠ d) : c.val ≠ d.val :=
+fun h' => absurd (eqOfVeq h') h
+
+instance : DecidableEq Char :=
+{decEq := fun i j => decidableOfDecidableOfIff
+  (decEq i.val j.val) ⟨Char.eqOfVeq, Char.veqOfEq⟩}
+
+instance : Inhabited Char :=
+⟨'A'⟩
+
+def isWhitespace (c : Char) : Bool :=
+c = ' ' || c = '\t' || c = '\n'
+
+def isUpper (c : Char) : Bool :=
+c.val ≥ 65 && c.val ≤ 90
+
+def isLower (c : Char) : Bool :=
+c.val ≥ 97 && c.val ≤ 122
+
+def isAlpha (c : Char) : Bool :=
+c.isUpper || c.isLower
+
+def isDigit (c : Char) : Bool :=
+c.val ≥ 48 && c.val ≤ 57
+
+def isAlphanum (c : Char) : Bool :=
+c.isAlpha || c.isDigit
+
+def toLower (c : Char) : Char :=
+let n := toNat c;
+if n >= 65 ∧ n <= 90 then ofNat (n + 32) else c
+
+end Char

stage0/src/Init/Data/DList.lean

@@ -0,0 +1,62 @@
+/-
+Copyright (c) 2018 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Author: Leonardo de Moura
+-/
+prelude
+import Init.Data.List.Basic
+universes u
+/--
+A difference List is a Function that, given a List, returns the original
+contents of the difference List prepended to the given List.
+This structure supports `O(1)` `append` and `concat` operations on lists, making it
+useful for append-heavy uses such as logging and pretty printing.
+-/
+structure DList (α : Type u) :=
+(apply     : List α → List α)
+(invariant : ∀ l, apply l = apply [] ++ l)
+
+namespace DList
+variables {α : Type u}
+open List
+
+def ofList (l : List α) : DList α :=
+⟨append l, fun t => (appendNil l).symm ▸ rfl⟩
+
+def empty : DList α :=
+⟨id, fun t => rfl⟩
+
+instance : HasEmptyc (DList α) :=
+⟨DList.empty⟩
+
+def toList : DList α → List α
+| ⟨f, h⟩ => f []
+
+def singleton (a : α) : DList α :=
+⟨fun t => a :: t,
+ fun t => rfl⟩
+
+def cons : α → DList α → DList α
+| a, ⟨f, h⟩ =>
+  ⟨fun t => a :: f t,
+   fun t =>
+    show a :: f t = a :: f [] ++ t from
+    have h₁ : a :: f t = a :: (f nil ++ t) := h t ▸ rfl;
+    have h₂ : a :: (f nil ++ t) = a :: f nil ++ t := (consAppend _ _ _).symm;
+    Eq.trans h₁ h₂⟩
+
+def append : DList α → DList α → DList α
+| ⟨f, h₁⟩, ⟨g, h₂⟩ =>
+  ⟨f ∘ g, fun t =>
+    show f (g t) = (f (g [])) ++ t from
+   (h₁ (g [])).symm ▸ (appendAssoc (f []) (g []) t).symm ▸ h₂ t ▸ h₁ (g t) ▸ rfl⟩
+
+def push : DList α → α → DList α
+| ⟨f, h⟩, a =>
+  ⟨fun t => f (a :: t),
+   fun t => (h (a::t)).symm ▸ (h [a]).symm ▸ (appendAssoc (f []) [a] t).symm ▸ rfl⟩
+
+instance : HasAppend (DList α) :=
+⟨DList.append⟩
+
+end DList

stage0/src/Init/Data/Fin.lean

@@ -0,0 +1,7 @@
+/-
+Copyright (c) 2017 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Author: Leonardo de Moura
+-/
+prelude
+import Init.Data.Fin.Basic

stage0/src/Init/Data/Fin/Basic.lean

@@ -0,0 +1,107 @@
+/-
+Copyright (c) 2016 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Author: Leonardo de Moura
+-/
+prelude
+import Init.Data.Nat.Div
+import Init.Data.Nat.Bitwise
+
+open Nat
+structure Fin (n : Nat) := (val : Nat) (isLt : val < n)
+
+namespace Fin
+
+protected def lt {n} (a b : Fin n) : Prop :=
+a.val < b.val
+
+protected def le {n} (a b : Fin n) : Prop :=
+a.val ≤ b.val
+
+instance {n} : HasLess (Fin n)    := ⟨Fin.lt⟩
+instance {n} : HasLessEq (Fin n)  := ⟨Fin.le⟩
+
+instance decLt {n} (a b : Fin n) :  Decidable (a < b) :=
+Nat.decLt _ _
+
+instance decLe {n} (a b : Fin n) : Decidable (a ≤ b) :=
+Nat.decLe _ _
+
+def elim0.{u} {α : Sort u} : Fin 0 → α
+| ⟨_, h⟩ => absurd h (notLtZero _)
+
+variable {n : Nat}
+
+def ofNat {n : Nat} (a : Nat) : Fin (succ n) :=
+⟨a % succ n, Nat.modLt _ (Nat.zeroLtSucc _)⟩
+
+def ofNat' {n : Nat} (a : Nat) (h : n > 0) : Fin n :=
+⟨a % n, Nat.modLt _ h⟩
+
+private theorem mlt {n b : Nat} : ∀ {a}, n > a → b % n < n
+| 0,   h => Nat.modLt _ h
+| a+1, h =>
+  have n > 0 from Nat.ltTrans (Nat.zeroLtSucc _) h;
+  Nat.modLt _ this
+
+protected def add : Fin n → Fin n → Fin n
+| ⟨a, h⟩, ⟨b, _⟩ => ⟨(a + b) % n, mlt h⟩
+
+protected def mul : Fin n → Fin n → Fin n
+| ⟨a, h⟩, ⟨b, _⟩ => ⟨(a * b) % n, mlt h⟩
+
+protected def sub : Fin n → Fin n → Fin n
+| ⟨a, h⟩, ⟨b, _⟩ => ⟨(a + (n - b)) % n, mlt h⟩
+
+/-
+Remark: mod/div/modn/land/lor can be defined without using (% n), but
+we are trying to minimize the number of Nat theorems
+needed to boostrap Lean.
+-/
+
+protected def mod : Fin n → Fin n → Fin n
+| ⟨a, h⟩, ⟨b, _⟩ => ⟨(a % b) % n, mlt h⟩
+
+protected def div : Fin n → Fin n → Fin n
+| ⟨a, h⟩, ⟨b, _⟩ => ⟨(a / b) % n, mlt h⟩
+
+protected def modn : Fin n → Nat → Fin n
+| ⟨a, h⟩, m => ⟨(a % m) % n, mlt h⟩
+
+def land : Fin n → Fin n → Fin n
+| ⟨a, h⟩, ⟨b, _⟩ => ⟨(Nat.land a b) % n, mlt h⟩
+
+def lor : Fin n → Fin n → Fin n
+| ⟨a, h⟩, ⟨b, _⟩ => ⟨(Nat.lor a b) % n, mlt h⟩
+
+instance : HasZero (Fin (succ n)) := ⟨⟨0, succPos n⟩⟩
+instance : HasOne (Fin (succ n))  := ⟨ofNat 1⟩
+instance : HasAdd (Fin n)         := ⟨Fin.add⟩
+instance : HasSub (Fin n)         := ⟨Fin.sub⟩
+instance : HasMul (Fin n)         := ⟨Fin.mul⟩
+instance : HasMod (Fin n)         := ⟨Fin.mod⟩
+instance : HasDiv (Fin n)         := ⟨Fin.div⟩
+instance : HasModn (Fin n)        := ⟨Fin.modn⟩
+
+theorem eqOfVeq : ∀ {i j : Fin n}, (val i) = (val j) → i = j
+| ⟨iv, ilt₁⟩, ⟨.(iv), ilt₂⟩, rfl => rfl
+
+theorem veqOfEq : ∀ {i j : Fin n}, i = j → (val i) = (val j)
+| ⟨iv, ilt⟩, .(_), rfl => rfl
+
+theorem neOfVne {i j : Fin n} (h : val i ≠ val j) : i ≠ j :=
+fun h' => absurd (veqOfEq h') h
+
+theorem vneOfNe {i j : Fin n} (h : i ≠ j) : val i ≠ val j :=
+fun h' => absurd (eqOfVeq h') h
+
+theorem modnLt : ∀ {m : Nat} (i : Fin n), m > 0 → (i %ₙ m).val < m
+| m, ⟨a, h⟩, hp =>  Nat.ltOfLeOfLt (modLe _ _) (modLt _ hp)
+
+end Fin
+
+open Fin
+
+instance (n : Nat) : DecidableEq (Fin n) :=
+{decEq := fun i j => decidableOfDecidableOfIff
+  (decEq i.val j.val) ⟨eqOfVeq, veqOfEq⟩}

stage0/src/Init/Data/HashMap.lean

@@ -0,0 +1,7 @@
+/-
+Copyright (c) 2019 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Author: Leonardo de Moura
+-/
+prelude
+import Init.Data.HashMap.Basic

stage0/src/Init/Data/HashMap/Basic.lean

@@ -0,0 +1,182 @@
+/-
+Copyright (c) 2018 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Author: Leonardo de Moura
+-/
+prelude
+import Init.Data.Array.Basic
+import Init.Data.AssocList
+import Init.Data.Option.Basic
+import Init.Data.Hashable
+universes u v w
+
+def HashMapBucket (α : Type u) (β : Type v) :=
+{ b : Array (AssocList α β) // b.size > 0 }
+
+def HashMapBucket.update {α : Type u} {β : Type v} (data : HashMapBucket α β) (i : USize) (d : AssocList α β) (h : i.toNat < data.val.size) : HashMapBucket α β :=
+⟨ data.val.uset i d h,
+  transRelRight Greater (Array.szFSetEq (data.val) ⟨USize.toNat i, h⟩ d) data.property ⟩
+
+structure HashMapImp (α : Type u) (β : Type v) :=
+(size       : Nat)
+(buckets    : HashMapBucket α β)
+
+def mkHashMapImp {α : Type u} {β : Type v} (nbuckets := 8) : HashMapImp α β :=
+let n := if nbuckets = 0 then 8 else nbuckets;
+{ size       := 0,
+  buckets    :=
+  ⟨ mkArray n AssocList.nil,
+    have p₁ : (mkArray n (@AssocList.nil α β)).size = n from Array.szMkArrayEq _ _;
+    have p₂ : n = (if nbuckets = 0 then 8 else nbuckets) from rfl;
+    have p₃ : (if nbuckets = 0 then 8 else nbuckets) > 0 from
+      match nbuckets with
+      | 0            => Nat.zeroLtSucc _
+      | (Nat.succ x) => Nat.zeroLtSucc _;
+    transRelRight Greater (Eq.trans p₁ p₂) p₃ ⟩ }
+
+namespace HashMapImp
+variables {α : Type u} {β : Type v}
+
+def mkIdx {n : Nat} (h : n > 0) (u : USize) : { u : USize // u.toNat < n } :=
+⟨u %ₙ n, USize.modnLt _ h⟩
+
+@[inline] def reinsertAux (hashFn : α → USize) (data : HashMapBucket α β) (a : α) (b : β) : HashMapBucket α β :=
+let ⟨i, h⟩ := mkIdx data.property (hashFn a);
+data.update i (AssocList.cons a b (data.val.uget i h)) h
+
+@[inline] def foldBucketsM {δ : Type w} {m : Type w → Type w} [Monad m] (data : HashMapBucket α β) (d : δ) (f : δ → α → β → m δ) : m δ :=
+data.val.foldlM (fun d b => b.foldlM f d) d
+
+@[inline] def foldBuckets {δ : Type w} (data : HashMapBucket α β) (d : δ) (f : δ → α → β → δ) : δ :=
+Id.run $ foldBucketsM data d f
+
+@[inline] def foldM {δ : Type w} {m : Type w → Type w} [Monad m] (f : δ → α → β → m δ) (d : δ) (h : HashMapImp α β) : m δ :=
+foldBucketsM h.buckets d f
+
+@[inline] def fold {δ : Type w} (f : δ → α → β → δ) (d : δ) (m : HashMapImp α β) : δ :=
+foldBuckets m.buckets d f
+
+def find [HasBeq α] [Hashable α] (m : HashMapImp α β) (a : α) : Option β :=
+match m with
+| ⟨_, buckets⟩ =>
+  let ⟨i, h⟩ := mkIdx buckets.property (hash a);
+  (buckets.val.uget i h).find a
+
+def contains [HasBeq α] [Hashable α] (m : HashMapImp α β) (a : α) : Bool :=
+match m with
+| ⟨_, buckets⟩ =>
+  let ⟨i, h⟩ := mkIdx buckets.property (hash a);
+  (buckets.val.uget i h).contains a
+
+-- TODO: remove `partial` by using well-founded recursion
+partial def moveEntries [Hashable α] : Nat → Array (AssocList α β) → HashMapBucket α β → HashMapBucket α β
+| i, source, target =>
+  if h : i < source.size then
+     let idx : Fin source.size := ⟨i, h⟩;
+     let es  : AssocList α β   := source.get idx;
+     -- We remove `es` from `source` to make sure we can reuse its memory cells when performing es.foldl
+     let source                := source.set idx AssocList.nil;
+     let target                := es.foldl (reinsertAux hash) target;
+     moveEntries (i+1) source target
+  else target
+
+def expand [Hashable α] (size : Nat) (buckets : HashMapBucket α β) : HashMapImp α β :=
+let nbuckets := buckets.val.size * 2;
+have aux₁  : nbuckets > 0 from Nat.mulPos buckets.property (Nat.zeroLtBit0 Nat.oneNeZero);
+have aux₂  : (mkArray nbuckets (@AssocList.nil α β)).size = nbuckets from Array.szMkArrayEq _ _;
+let new_buckets : HashMapBucket α β := ⟨mkArray nbuckets AssocList.nil, aux₂.symm ▸ aux₁⟩;
+{ size    := size,
+  buckets := moveEntries 0 buckets.val new_buckets }
+
+def insert [HasBeq α] [Hashable α] (m : HashMapImp α β) (a : α) (b : β) : HashMapImp α β :=
+match m with
+| ⟨size, buckets⟩ =>
+  let ⟨i, h⟩ := mkIdx buckets.property (hash a);
+  let bkt    := buckets.val.uget i h;
+  if bkt.contains a
+  then ⟨size, buckets.update i (bkt.replace a b) h⟩
+  else
+    let size'    := size + 1;
+    let buckets' := buckets.update i (AssocList.cons a b bkt) h;
+    if size' ≤ buckets.val.size
+    then { size := size', buckets := buckets' }
+    else expand size' buckets'
+
+def erase [HasBeq α] [Hashable α] (m : HashMapImp α β) (a : α) : HashMapImp α β :=
+match m with
+| ⟨ size, buckets ⟩ =>
+  let ⟨i, h⟩ := mkIdx buckets.property (hash a);
+  let bkt    := buckets.val.uget i h;
+  if bkt.contains a then ⟨size - 1, buckets.update i (bkt.erase a) h⟩
+  else m
+
+inductive WellFormed [HasBeq α] [Hashable α] : HashMapImp α β → Prop
+| mkWff     : ∀ n,                    WellFormed (mkHashMapImp n)
+| insertWff : ∀ m a b, WellFormed m → WellFormed (insert m a b)
+| eraseWff  : ∀ m a,   WellFormed m → WellFormed (erase m a)
+
+end HashMapImp
+
+def HashMap (α : Type u) (β : Type v) [HasBeq α] [Hashable α] :=
+{ m : HashMapImp α β // m.WellFormed }
+
+open HashMapImp
+
+def mkHashMap {α : Type u} {β : Type v} [HasBeq α] [Hashable α] (nbuckets := 8) : HashMap α β :=
+⟨ mkHashMapImp nbuckets, WellFormed.mkWff nbuckets ⟩
+
+namespace HashMap
+variables {α : Type u} {β : Type v} [HasBeq α] [Hashable α]
+
+instance : Inhabited (HashMap α β) :=
+⟨mkHashMap⟩
+
+instance : HasEmptyc (HashMap α β) :=
+⟨mkHashMap⟩
+
+@[inline] def insert (m : HashMap α β) (a : α) (b : β) : HashMap α β :=
+match m with
+| ⟨ m, hw ⟩ => ⟨ m.insert a b, WellFormed.insertWff m a b hw ⟩
+
+@[inline] def erase (m : HashMap α β) (a : α) : HashMap α β :=
+match m with
+| ⟨ m, hw ⟩ => ⟨ m.erase a, WellFormed.eraseWff m a hw ⟩
+
+@[inline] def find (m : HashMap α β) (a : α) : Option β :=
+match m with
+| ⟨ m, _ ⟩ => m.find a
+
+@[inline] def findD (m : HashMap α β) (a : α) (b₀ : β) : β :=
+(m.find a).getD b₀
+
+@[inline] def find! [Inhabited β] (m : HashMap α β) (a : α) : β :=
+match m.find a with
+| some b => b
+| none   => panic! "key is not in the map"
+
+@[inline] def contains (m : HashMap α β) (a : α) : Bool :=
+match m with
+| ⟨ m, _ ⟩ => m.contains a
+
+@[inline] def foldM {δ : Type w} {m : Type w → Type w} [Monad m] (f : δ → α → β → m δ) (d : δ) (h : HashMap α β) : m δ :=
+match h with
+| ⟨ h, _ ⟩ => h.foldM f d
+
+@[inline] def fold {δ : Type w} (f : δ → α → β → δ) (d : δ) (m : HashMap α β) : δ :=
+match m with
+| ⟨ m, _ ⟩ => m.fold f d
+
+@[inline] def size (m : HashMap α β) : Nat :=
+match m with
+| ⟨ {size := sz, ..}, _ ⟩ => sz
+
+@[inline] def isEmpty (m : HashMap α β) : Bool :=
+m.size = 0
+
+@[inline] def empty : HashMap α β :=
+mkHashMap
+
+def numBuckets (m : HashMap α β) : Nat :=
+m.val.buckets.val.size
+
+end HashMap

stage0/src/Init/Data/HashSet.lean

@@ -0,0 +1,51 @@
+/-
+Copyright (c) 2019 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Author: Leonardo de Moura
+-/
+prelude
+import Init.Data.HashMap
+
+universes u v
+
+structure HashSet (α : Type u) [HasBeq α] [Hashable α] :=
+(set : HashMap α Unit)
+
+def mkHashSet {α : Type u} [HasBeq α] [Hashable α] (nbuckets := 8) : HashSet α :=
+{ set := mkHashMap nbuckets }
+
+namespace HashSet
+
+variables {α : Type u} [HasBeq α] [Hashable α]
+
+instance : Inhabited (HashSet α) :=
+⟨mkHashSet⟩
+
+instance : HasEmptyc (HashSet α) :=
+⟨mkHashSet⟩
+
+@[inline] def insert (s : HashSet α) (a : α) : HashSet α :=
+{ set := s.set.insert a () }
+
+@[inline] def erase (s : HashSet α) (a : α) : HashSet α :=
+{ set := s.set.erase a }
+
+@[inline] def contains (s : HashSet α) (a : α) : Bool :=
+s.set.contains a
+
+@[inline] def size (s : HashSet α) : Nat :=
+s.set.size
+
+@[inline] def isEmpty (s : HashSet α) : Bool :=
+s.set.isEmpty
+
+@[inline] def empty : HashSet α :=
+mkHashSet
+
+@[inline] def foldM {β : Type v} {m : Type v → Type v} [Monad m] (f : β → α → m β) (d : β) (s : HashSet α) : m β :=
+s.set.foldM (fun d a _ => f d a) d
+
+@[inline] def fold {β : Type v} (f : β → α → β) (d : β) (s : HashSet α) : β :=
+Id.run $ s.foldM f d
+
+end HashSet

stage0/src/Init/Data/Hashable.lean

@@ -0,0 +1,40 @@
+/-
+Copyright (c) 2016 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.UInt
+import Init.Data.String
+universes u
+
+class Hashable (α : Type u) :=
+(hash : α → USize)
+
+export Hashable (hash)
+
+@[extern "lean_usize_mix_hash"]
+constant mixHash (u₁ u₂ : USize) : USize := arbitrary _
+
+@[extern "lean_string_hash"]
+protected constant String.hash (s : String) : USize := arbitrary _
+instance : Hashable String := ⟨String.hash⟩
+
+protected def Nat.hash (n : Nat) : USize :=
+USize.ofNat n
+
+instance : Hashable Nat := ⟨Nat.hash⟩
+
+instance {α β} [Hashable α] [Hashable β] : Hashable (α × β) :=
+⟨fun ⟨a, b⟩ => mixHash (hash a) (hash b)⟩
+
+def Option.hash {α} [Hashable α] : Option α → USize
+| none   => 11
+| some a => mixHash (hash a) 13
+
+instance {α} [Hashable α] : Hashable (Option α) := ⟨Option.hash⟩
+
+def List.hash {α} [Hashable α] (as : List α) : USize :=
+as.foldl (fun r a => mixHash r (hash a)) 7
+
+instance {α} [Hashable α] : Hashable (List α) := ⟨List.hash⟩

stage0/src/Init/Data/Int.lean

@@ -0,0 +1,7 @@
+/-
+Copyright (c) 2016 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.Int.Basic

stage0/src/Init/Data/Int/Basic.lean

@@ -0,0 +1,170 @@
+/-
+Copyright (c) 2016 Jeremy Avigad. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Jeremy Avigad, Leonardo de Moura
+
+The integers, with addition, multiplication, and subtraction.
+-/
+prelude
+import Init.Data.Nat.Basic
+import Init.Data.List
+import Init.Coe
+import Init.Data.Repr
+import Init.Data.ToString
+open Nat
+
+/- the Type, coercions, and notation -/
+
+inductive Int : Type
+| ofNat   : Nat → Int
+| negSucc : Nat → Int
+
+attribute [extern "lean_nat_to_int"] Int.ofNat
+attribute [extern "lean_int_neg_succ_of_nat"] Int.negSucc
+
+instance : HasCoe Nat Int := ⟨Int.ofNat⟩
+
+namespace Int
+protected def zero : Int := ofNat 0
+protected def one  : Int := ofNat 1
+
+instance : HasZero Int := ⟨Int.zero⟩
+instance : HasOne Int  := ⟨Int.one⟩
+
+def negOfNat : Nat → Int
+| 0      => 0
+| succ m => negSucc m
+
+@[extern "lean_int_neg"]
+protected def neg (n : @& Int) : Int :=
+match n with
+| ofNat n   => negOfNat n
+| negSucc n => succ n
+
+def subNatNat (m n : Nat) : Int :=
+match (n - m : Nat) with
+| 0        => ofNat (m - n)  -- m ≥ n
+| (succ k) => negSucc k
+
+@[extern "lean_int_add"]
+protected def add (m n : @& Int) : Int :=
+match m, n with
+| ofNat m,   ofNat n   => ofNat (m + n)
+| ofNat m,   negSucc n => subNatNat m (succ n)
+| negSucc m, ofNat n   => subNatNat n (succ m)
+| negSucc m, negSucc n => negSucc (m + n)
+
+@[extern "lean_int_mul"]
+protected def mul (m n : @& Int) : Int :=
+match m, n with
+| ofNat m,   ofNat n   => ofNat (m * n)
+| ofNat m,   negSucc n => negOfNat (m * succ n)
+| negSucc m, ofNat n   => negOfNat (succ m * n)
+| negSucc m, negSucc n => ofNat (succ m * succ n)
+
+instance : HasNeg Int := ⟨Int.neg⟩
+instance : HasAdd Int := ⟨Int.add⟩
+instance : HasMul Int := ⟨Int.mul⟩
+
+@[extern "lean_int_sub"]
+protected def sub (m n : @& Int) : Int :=
+m + -n
+
+instance : HasSub Int := ⟨Int.sub⟩
+
+inductive NonNeg : Int → Prop
+| mk (n : Nat) : NonNeg (ofNat n)
+
+protected def LessEq (a b : Int) : Prop := NonNeg (b - a)
+
+instance : HasLessEq Int := ⟨Int.LessEq⟩
+
+protected def Less (a b : Int) : Prop := (a + 1) ≤ b
+
+instance : HasLess Int := ⟨Int.Less⟩
+
+@[extern "lean_int_dec_eq"]
+protected def decEq (a b : @& Int) : Decidable (a = b) :=
+match a, b with
+ | ofNat a, ofNat b => match decEq a b with
+   | isTrue h  => isTrue  $ h ▸ rfl
+   | isFalse h => isFalse $ fun h' => Int.noConfusion h' (fun h' => absurd h' h)
+ | negSucc a, negSucc b => match decEq a b with
+   | isTrue h  => isTrue  $ h ▸ rfl
+   | isFalse h => isFalse $ fun h' => Int.noConfusion h' (fun h' => absurd h' h)
+ | ofNat a, negSucc b => isFalse $ fun h => Int.noConfusion h
+ | negSucc a, ofNat b => isFalse $ fun h => Int.noConfusion h
+
+instance Int.DecidableEq : DecidableEq Int :=
+{decEq := Int.decEq}
+
+@[extern "lean_int_dec_nonneg"]
+private def decNonneg (m : @& Int) : Decidable (NonNeg m) :=
+match m with
+| ofNat m   => isTrue $ NonNeg.mk m
+| negSucc m => isFalse $ fun h => nomatch h
+
+@[extern "lean_int_dec_le"]
+instance decLe (a b : @& Int) : Decidable (a ≤ b) :=
+decNonneg _
+
+@[extern "lean_int_dec_lt"]
+instance decLt (a b : @& Int) : Decidable (a < b) :=
+decNonneg _
+
+@[extern "lean_nat_abs"]
+def natAbs (m : @& Int) : Nat :=
+match m with
+| ofNat m   => m
+| negSucc m => m.succ
+
+protected def repr : Int → String
+| ofNat m   => Nat.repr m
+| negSucc m => "-" ++ Nat.repr (succ m)
+
+instance : HasRepr Int :=
+⟨Int.repr⟩
+
+instance : HasToString Int :=
+⟨Int.repr⟩
+
+@[extern "lean_int_div"]
+def div : (@& Int) → (@& Int) → Int
+| ofNat m,   ofNat n   => ofNat (m / n)
+| ofNat m,   negSucc n => -ofNat (m / succ n)
+| negSucc m, ofNat n   => -ofNat (succ m / n)
+| negSucc m, negSucc n => ofNat (succ m / succ n)
+
+@[extern "lean_int_mod"]
+def mod : (@& Int) → (@& Int) → Int
+| ofNat m,   ofNat n   => ofNat (m % n)
+| ofNat m,   negSucc n => ofNat (m % succ n)
+| negSucc m, ofNat n   => -ofNat (succ m % n)
+| negSucc m, negSucc n => -ofNat (succ m % succ n)
+
+instance : HasDiv Int := ⟨Int.div⟩
+instance : HasMod Int := ⟨Int.mod⟩
+
+def toNat : Int → Nat
+| ofNat n   => n
+| negSucc n => 0
+
+def natMod (m n : Int) : Nat := (m % n).toNat
+
+end Int
+
+namespace String
+
+def toInt (s : String) : Int :=
+if s.get 0 = '-' then
+ - Int.ofNat (s.toSubstring.drop 1).toNat
+else
+ Int.ofNat s.toNat
+
+def isInt (s : String) : Bool :=
+if s.get 0 = '-' then
+  (s.toSubstring.drop 1).isNat
+else
+  s.isNat
+
+end String

stage0/src/Init/Data/List.lean

@@ -0,0 +1,10 @@
+/-
+Copyright (c) 2016 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.Basic
+import Init.Data.List.BasicAux
+import Init.Data.List.Instances
+import Init.Data.List.Control

stage0/src/Init/Data/List/Basic.lean

@@ -0,0 +1,346 @@
+/-
+Copyright (c) 2016 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Author: Leonardo de Moura
+-/
+prelude
+import Init.Core
+import Init.Data.Nat.Basic
+open Decidable List
+
+universes u v w
+
+instance (α : Type u) : Inhabited (List α) :=
+⟨List.nil⟩
+
+variables {α : Type u} {β : Type v} {γ : Type w}
+
+namespace List
+
+protected def hasDecEq [DecidableEq α] : ∀ (a b : List α), Decidable (a = b)
+| [],    []    => isTrue rfl
+| a::as, []    => isFalse (fun h => List.noConfusion h)
+| [],    b::bs => isFalse (fun h => List.noConfusion h)
+| a::as, b::bs =>
+  match decEq a b with
+  | isTrue hab  =>
+    match hasDecEq as bs with
+    | isTrue habs  => isTrue (Eq.subst hab (Eq.subst habs rfl))
+    | isFalse nabs => isFalse (fun h => List.noConfusion h (fun _ habs => absurd habs nabs))
+  | isFalse nab => isFalse (fun h => List.noConfusion h (fun hab _ => absurd hab nab))
+
+instance [DecidableEq α] : DecidableEq (List α) :=
+{decEq := List.hasDecEq}
+
+def reverseAux : List α → List α → List α
+| [],   r => r
+| a::l, r => reverseAux l (a::r)
+
+def reverse : List α → List α :=
+fun l => reverseAux l []
+
+protected def append (as bs : List α) : List α :=
+reverseAux as.reverse bs
+
+instance : HasAppend (List α) :=
+⟨List.append⟩
+
+theorem reverseAuxReverseAuxNil : ∀ (as bs : List α), reverseAux (reverseAux as bs) [] = reverseAux bs as
+| [], bs     => rfl
+| a::as,  bs =>
+  show reverseAux (reverseAux as (a::bs)) [] = reverseAux bs (a::as) from
+  reverseAuxReverseAuxNil as (a::bs)
+
+theorem nilAppend (as : List α) : [] ++ as = as :=
+rfl
+
+theorem appendNil (as : List α) : as ++ [] = as :=
+show reverseAux (reverseAux as []) [] = as from
+reverseAuxReverseAuxNil as []
+
+theorem reverseAuxReverseAux : ∀ (as bs cs : List α), reverseAux (reverseAux as bs) cs = reverseAux bs (reverseAux (reverseAux as []) cs)
+| [],    bs, cs => rfl
+| a::as, bs, cs =>
+  Eq.trans
+    (reverseAuxReverseAux as (a::bs) cs)
+    (congrArg (fun b => reverseAux bs b) (reverseAuxReverseAux as [a] cs).symm)
+
+theorem consAppend (a : α) (as bs : List α) : (a::as) ++ bs = a::(as ++ bs) :=
+reverseAuxReverseAux as [a] bs
+
+theorem appendAssoc : ∀ (as bs cs : List α), (as ++ bs) ++ cs = as ++ (bs ++ cs)
+| [],    bs, cs => rfl
+| a::as, bs, cs =>
+  show ((a::as) ++ bs) ++ cs = (a::as) ++ (bs ++ cs)      from
+  have h₁ : ((a::as) ++ bs) ++ cs = a::(as++bs) ++ cs     from congrArg (fun ds => ds ++ cs) (consAppend a as bs);
+  have h₂ : a::(as++bs) ++ cs     = a::((as++bs) ++ cs)   from consAppend a (as++bs) cs;
+  have h₃ : a::((as++bs) ++ cs)   = a::(as ++ (bs ++ cs)) from congrArg (fun as => a::as) (appendAssoc as bs cs);
+  have h₄ : a::(as ++ (bs ++ cs)) = (a::as ++ (bs ++ cs)) from (consAppend a as (bs++cs)).symm;
+  Eq.trans (Eq.trans (Eq.trans h₁ h₂) h₃) h₄
+
+instance : HasEmptyc (List α) :=
+⟨List.nil⟩
+
+protected def erase {α} [HasBeq α] : List α → α → List α
+| [],    b => []
+| a::as, b => match a == b with
+  | true  => as
+  | false => a :: erase as b
+
+def eraseIdx : List α → Nat → List α
+| [],    _   => []
+| a::as, 0   => as
+| a::as, n+1 => a :: eraseIdx as n
+
+def lengthAux : List α → Nat → Nat
+| [],    n => n
+| a::as, n => lengthAux as (n+1)
+
+def length (as : List α) : Nat :=
+lengthAux as 0
+
+def isEmpty : List α → Bool
+| []     => true
+| _ :: _ => false
+
+def set : List α → Nat → α → List α
+| a::as, 0,   b => b::as
+| a::as, n+1, b => a::(set as n b)
+| [],    _,   _ => []
+
+@[specialize] def map (f : α → β) : List α → List β
+| []    => []
+| a::as => f a :: map as
+
+@[specialize] def map₂ (f : α → β → γ) : List α → List β → List γ
+| [],    _     => []
+| _,     []    => []
+| a::as, b::bs => f a b :: map₂ as bs
+
+def join : List (List α) → List α
+| []      => []
+| a :: as => a ++ join as
+
+@[specialize] def filterMap (f : α → Option β) : List α → List β
+| []   => []
+| a::as =>
+  match f a with
+  | none   => filterMap as
+  | some b => b :: filterMap as
+
+@[specialize] def filterAux (p : α → Bool) : List α → List α → List α
+| [],    rs => rs.reverse
+| a::as, rs => match p a with
+   | true  => filterAux as (a::rs)
+   | false => filterAux as rs
+
+@[inline] def filter (p : α → Bool) (as : List α) : List α :=
+filterAux p as []
+
+@[specialize] def partitionAux (p : α → Bool) : List α → List α × List α → List α × List α
+| [],    (bs, cs) => (bs.reverse, cs.reverse)
+| a::as, (bs, cs) =>
+  match p a with
+  | true  => partitionAux as (a::bs, cs)
+  | false => partitionAux as (bs, a::cs)
+
+@[inline] def partition (p : α → Bool) (as : List α) : List α × List α :=
+partitionAux p as ([], [])
+
+def dropWhile (p : α → Bool) : List α → List α
+| []   => []
+| a::l => match p a with
+  | true  => dropWhile l
+  | false =>  a::l
+
+def find (p : α → Bool) : List α → Option α
+| []    => none
+| a::as => match p a with
+  | true  => some a
+  | false => find as
+
+def elem [HasBeq α] (a : α) : List α → Bool
+| []    => false
+| b::bs => match a == b with
+  | true  => true
+  | false => elem bs
+
+def notElem [HasBeq α] (a : α) (as : List α) : Bool :=
+!(as.elem a)
+
+abbrev contains [HasBeq α] (as : List α) (a : α) : Bool :=
+elem a as
+
+def eraseDupsAux {α} [HasBeq α] : List α → List α → List α
+| [],    bs => bs.reverse
+| a::as, bs => match bs.elem a with
+  | true  => eraseDupsAux as bs
+  | false => eraseDupsAux as (a::bs)
+
+def eraseDups {α} [HasBeq α] (as : List α) : List α :=
+eraseDupsAux as []
+
+@[specialize] def spanAux (p : α → Bool) : List α → List α → List α × List α
+| [],    rs => (rs.reverse, [])
+| a::as, rs => match p a with
+  | true  => spanAux as (a::rs)
+  | false => (rs.reverse, a::as)
+
+@[inline] def span (p : α → Bool) (as : List α) : List α × List α :=
+spanAux p as []
+
+def lookup [HasBeq α] : α → List (α × β) → Option β
+| _, []        => none
+| a, (k,b)::es => match a == k with
+  | true  => some b
+  | false => lookup a es
+
+def removeAll [HasBeq α] (xs ys : List α) : List α :=
+xs.filter (fun x => ys.notElem x)
+
+def drop : Nat → List α → List α
+| 0,   a     => a
+| n+1, []    => []
+| n+1, a::as => drop n as
+
+def take : Nat → List α → List α
+| 0,   a     => []
+| n+1, []    => []
+| n+1, a::as => a :: take n as
+
+@[specialize] def foldl (f : α → β → α) : α → List β → α
+| a, []     => a
+| a, b :: l => foldl (f a b) l
+
+@[specialize] def foldr (f : α → β → β) (b : β) : List α → β
+| []     => b
+| a :: l => f a (foldr l)
+
+@[specialize] def foldr1 (f : α → α → α) : ∀ (xs : List α), xs ≠ [] → α
+| [],             h => absurd rfl h
+| [a],            _ => a
+| a :: as@(_::_), _ => f a (foldr1 as (fun h => List.noConfusion h))
+
+@[specialize] def foldr1Opt (f : α → α → α) : List α → Option α
+| []      => none
+| a :: as => some $ foldr1 f (a :: as) (fun h => List.noConfusion h)
+
+@[inline] def any (l : List α) (p : α → Bool) : Bool :=
+foldr (fun a r => p a || r) false l
+
+@[inline] def all (l : List α) (p : α → Bool) : Bool :=
+foldr (fun a r => p a && r) true l
+
+def or  (bs : List Bool) : Bool := bs.any id
+
+def and (bs : List Bool) : Bool := bs.all id
+
+def zipWith (f : α → β → γ) : List α → List β → List γ
+| x::xs, y::ys => f x y :: zipWith xs ys
+| _,     _     => []
+
+def zip : List α → List β → List (Prod α β) :=
+zipWith Prod.mk
+
+def unzip : List (α × β) → List α × List β
+| []          => ([], [])
+| (a, b) :: t => match unzip t with | (al, bl) => (a::al, b::bl)
+
+def replicate (n : Nat) (a : α) : List α :=
+n.repeat (fun xs => a :: xs) []
+
+def rangeAux : Nat → List Nat → List Nat
+| 0,   ns => ns
+| n+1, ns => rangeAux n (n::ns)
+
+def range (n : Nat) : List Nat :=
+rangeAux n []
+
+def iota : Nat → List Nat
+| 0       => []
+| m@(n+1) => m :: iota n
+
+def enumFrom : Nat → List α → List (Nat × α)
+| n, [] => nil
+| n, x :: xs   => (n, x) :: enumFrom (n + 1) xs
+
+def enum : List α → List (Nat × α) := enumFrom 0
+
+def init : List α → List α
+| []   => []
+| [a]  => []
+| a::l => a::init l
+
+def intersperse (sep : α) : List α → List α
+| []    => []
+| [x]   => [x]
+| x::xs => x::sep::intersperse xs
+
+def intercalate (sep : List α) (xs : List (List α)) : List α :=
+join (intersperse sep xs)
+
+@[inline] protected def bind {α : Type u} {β : Type v} (a : List α) (b : α → List β) : List β :=
+join (map b a)
+
+@[inline] protected def pure {α : Type u} (a : α) : List α :=
+[a]
+
+inductive Less [HasLess α] : List α → List α → Prop
+| nil  (b : α) (bs : List α) : Less [] (b::bs)
+| head {a : α} (as : List α) {b : α} (bs : List α) : a < b → Less (a::as) (b::bs)
+| tail {a : α} {as : List α} {b : α} {bs : List α} : ¬ a < b → ¬ b < a → Less as bs → Less (a::as) (b::bs)
+
+instance [HasLess α] : HasLess (List α) :=
+⟨List.Less⟩
+
+instance hasDecidableLt [HasLess α] [h : DecidableRel HasLess.Less] : ∀ (l₁ l₂ : List α), Decidable (l₁ < l₂)
+| [],    []    => isFalse (fun h => nomatch h)
+| [],    b::bs => isTrue (Less.nil _ _)
+| a::as, []    => isFalse (fun h => nomatch h)
+| a::as, b::bs =>
+  match h a b with
+  | isTrue h₁  => isTrue (Less.head _ _ h₁)
+  | isFalse h₁ =>
+    match h b a with
+    | isTrue h₂  => isFalse (fun h => match h with
+       | Less.head _ _ h₁' => absurd h₁' h₁
+       | Less.tail _ h₂' _ => absurd h₂ h₂')
+    | isFalse h₂ =>
+      match hasDecidableLt as bs with
+      | isTrue h₃  => isTrue (Less.tail h₁ h₂ h₃)
+      | isFalse h₃ => isFalse (fun h => match h with
+         | Less.head _ _ h₁' => absurd h₁' h₁
+         | Less.tail _ _ h₃' => absurd h₃' h₃)
+
+@[reducible] protected def LessEq [HasLess α] (a b : List α) : Prop :=
+¬ b < a
+
+instance [HasLess α] : HasLessEq (List α) :=
+⟨List.LessEq⟩
+
+instance hasDecidableLe [HasLess α] [h : DecidableRel (HasLess.Less : α → α → Prop)] : ∀ (l₁ l₂ : List α), Decidable (l₁ ≤ l₂) :=
+fun a b => Not.Decidable
+
+/--  `isPrefixOf l₁ l₂` returns `true` Iff `l₁` is a prefix of `l₂`. -/
+def isPrefixOf [HasBeq α] : List α → List α → Bool
+| [],    _     => true
+| _,     []    => false
+| a::as, b::bs => a == b && isPrefixOf as bs
+
+/--  `isSuffixOf l₁ l₂` returns `true` Iff `l₁` is a suffix of `l₂`. -/
+def isSuffixOf [HasBeq α] (l₁ l₂ : List α) : Bool :=
+isPrefixOf l₁.reverse l₂.reverse
+
+@[specialize] def isEqv : List α → List α → (α → α → Bool) → Bool
+| [],    [],    _   => true
+| a::as, b::bs, eqv => eqv a b && isEqv as bs eqv
+| _,     _,     eqv => false
+
+protected def beq [HasBeq α] : List α → List α → Bool
+| [],    []    => true
+| a::as, b::bs => a == b && beq as bs
+| _,     _     => false
+
+instance [HasBeq α] : HasBeq (List α) := ⟨List.beq⟩
+
+end List

stage0/src/Init/Data/List/BasicAux.lean

@@ -0,0 +1,72 @@
+/-
+Copyright (c) 2019 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Author: Leonardo de Moura
+-/
+prelude
+import Init.Data.List.Basic
+import Init.Util
+
+universes u
+
+namespace List
+/- The following functions can't be defined at `init.data.list.basic`, because they depend on `init.util`,
+   and `init.util` depends on `init.data.list.basic`. -/
+
+variables {α : Type u}
+
+def get! [Inhabited α] : Nat → List α → α
+| 0,   a::as => a
+| n+1, a::as => get! n as
+| _,   _     => panic! "invalid index"
+
+def get? : Nat → List α → Option α
+| 0,   a::as => some a
+| n+1, a::as => get? n as
+| _,   _     => none
+
+def getD (idx : Nat) (as : List α) (a₀ : α) : α :=
+(as.get? idx).getD a₀
+
+def head! [Inhabited α] : List α → α
+| []   => panic! "empty list"
+| a::_ => a
+
+def head? : List α → Option α
+| []   => none
+| a::_ => some a
+
+def headD : List α → α → α
+| [],   a₀ => a₀
+| a::_, _  => a
+
+def tail! : List α → List α
+| []    => panic! "empty list"
+| a::as => as
+
+def tail? : List α → Option (List α)
+| []    => none
+| a::as => some as
+
+def tailD : List α → List α → List α
+| [],   as₀ => as₀
+| a::as, _  => as
+
+def getLast : ∀ (as : List α), as ≠ [] → α
+| [],       h => absurd rfl h
+| [a],      h => a
+| a::b::as, h => getLast (b::as) (fun h => List.noConfusion h)
+
+def getLast! [Inhabited α] : List α → α
+| []    => panic! "empty list"
+| a::as => getLast (a::as) (fun h => List.noConfusion h)
+
+def getLast? : List α → Option α
+| []    => none
+| a::as => some (getLast (a::as) (fun h => List.noConfusion h))
+
+def getLastD : List α → α → α
+| [],   a₀ => a₀
+| a::as, _ => getLast (a::as) (fun h => List.noConfusion h)
+
+end List

stage0/src/Init/Data/List/Control.lean

@@ -0,0 +1,121 @@
+/-
+Copyright (c) 2019 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Author: Leonardo de Moura
+-/
+prelude
+import Init.Control.Monad
+import Init.Control.Alternative
+
+namespace List
+universes u v w u₁ u₂
+
+/-
+Remark: we can define `mapM`, `mapM₂` and `forM` using `Applicative` instead of `Monad`.
+Example:
+```
+def mapM {m : Type u → Type v} [Applicative m] {α : Type w} {β : Type u} (f : α → m β) : List α → m (List β)
+| []    => pure []
+| a::as => List.cons <$> (f a) <*> mapM as
+```
+
+However, we consider `f <$> a <*> b` an anti-idiom because the generated code
+may produce unnecessary closure allocations.
+Suppose `m` is a `Monad`, and it uses the default implementation for `Applicative.seq`.
+Then, the compiler expands `f <$> a <*> b <*> c` into something equivalent to
+```
+(Functor.map f a >>= fun g_1 => Functor.map g_1 b) >>= fun g_2 => Functor.map g_2 c
+```
+In an ideal world, the compiler may eliminate the temporary closures `g_1` and `g_2` after it inlines
+`Functor.map` and `Monad.bind`. However, this can easily fail. For example, suppose
+`Functor.map f a >>= fun g_1 => Functor.map g_1 b` expanded into a match-expression.
+This is not unreasonable and can happen in many different ways, e.g., we are using a monad that
+may throw exceptions. Then, the compiler has to decide whether it will create a join-point for
+the continuation of the match or float it. If the compiler decides to float, then it will
+be able to eliminate the closures, but it may not be feasible since floating match expressions
+may produce exponential blowup in the code size.
+
+Finally, we rarely use `mapM` with something that is not a `Monad`.
+
+Users that want to use `mapM` with `Applicative` should use `mapA` instead.
+-/
+
+@[specialize]
+def mapM {m : Type u → Type v} [Monad m] {α : Type w} {β : Type u} (f : α → m β) : List α → m (List β)
+| []    => pure []
+| a::as => do b ← f a; bs ← mapM as; pure (b :: bs)
+
+@[specialize]
+def mapM₂ {m : Type u → Type v} [Monad m] {α : Type u₁} {β : Type u₂} {γ : Type u} (f : α → β → m γ) : List α → List β → m (List γ)
+| a::as, b::bs => do c ← f a b; cs ← mapM₂ as bs; pure (c :: cs)
+| _,     _     => pure []
+
+@[specialize]
+def mapA {m : Type u → Type v} [Applicative m] {α : Type w} {β : Type u} (f : α → m β) : List α → m (List β)
+| []    => pure []
+| a::as => List.cons <$> f a <*> mapA as
+
+@[specialize]
+def mapA₂ {m : Type u → Type v} [Applicative m] {α : Type u₁} {β : Type u₂} {γ : Type u} (f : α → β → m γ) : List α → List β → m (List γ)
+| a::as, b::bs => List.cons <$> f a b <*> mapA₂ as bs
+| _,     _     => pure []
+
+@[specialize]
+def forM {m : Type u → Type v} [Monad m] {α : Type w} {β : Type u} (f : α → m β) : List α → m PUnit
+| []     => pure ⟨⟩
+| h :: t => do f h; forM t
+
+@[specialize]
+def forM₂ {m : Type u → Type v} [Monad m] {α : Type u₁} {β : Type u₂} {γ : Type u} (f : α → β → m γ) : List α → List β → m PUnit
+| a::as, b::bs => do f a b; forM₂ as bs
+| _,     _     => pure ⟨⟩
+
+@[specialize]
+def forA {m : Type u → Type v} [Applicative m] {α : Type w} {β : Type u} (f : α → m β) : List α → m PUnit
+| []     => pure ⟨⟩
+| h :: t => f h *> forA t
+
+@[specialize]
+def forA₂ {m : Type u → Type v} [Applicative m] {α : Type u₁} {β : Type u₂} {γ : Type u} (f : α → β → m γ) : List α → List β → m PUnit
+| a::as, b::bs => f a b *> forA₂ as bs
+| _,     _     => pure ⟨⟩
+
+@[specialize]
+def filterM {m : Type → Type v} [Monad m] {α : Type} (f : α → m Bool) : List α → m (List α)
+| []     => pure []
+| h :: t => do b ← f h; t' ← filterM t; cond b (pure (h :: t')) (pure t')
+
+@[specialize]
+def foldlM {m : Type u → Type v} [Monad m] {s : Type u} {α : Type w} : (s → α → m s) → s → List α → m s
+| f, s, [] => pure s
+| f, s, h :: r   => do
+  s' ← f s h;
+  foldlM f s' r
+
+@[specialize]
+def foldrM {m : Type u → Type v} [Monad m] {s : Type u} {α : Type w} : (α → s → m s) → s → List α → m s
+| f, s, [] => pure s
+| f, s, h :: r   => do
+  s' ← foldrM f s r;
+  f h s'
+
+@[specialize]
+def firstM {m : Type u → Type v} [Monad m] [Alternative m] {α : Type w} {β : Type u} (f : α → m β) : List α → m β
+| []    => failure
+| a::as => f a <|> firstM as
+
+@[specialize]
+def anyM {m : Type → Type u} [Monad m] {α : Type v} (f : α → m Bool) : List α → m Bool
+| []    => pure false
+| a::as => do b ← f a; match b with
+  | true  => pure true
+  | false =>  anyM as
+
+@[specialize]
+def allM {m : Type → Type u} [Monad m] {α : Type v} (f : α → m Bool) : List α → m Bool
+| []    => pure true
+| a::as => do b ← f a; match b with
+  | true  => allM as
+  | false => pure false
+
+end List

stage0/src/Init/Data/List/Instances.lean

@@ -0,0 +1,20 @@
+/-
+Copyright (c) 2016 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Author: Leonardo de Moura
+-/
+prelude
+import Init.Data.List.Basic
+import Init.Control.Alternative
+import Init.Control.Monad
+open List
+
+universes u v
+
+instance : Monad List :=
+{ pure := @List.pure, map := @List.map, bind := @List.bind }
+
+instance : Alternative List :=
+{ failure := @List.nil,
+  orelse  := @List.append,
+  ..List.Monad }

stage0/src/Init/Data/Nat.lean

@@ -0,0 +1,10 @@
+/-
+Copyright (c) 2016 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.Nat.Basic
+import Init.Data.Nat.Div
+import Init.Data.Nat.Bitwise
+import Init.Data.Nat.Control

stage0/src/Init/Data/Nat/Basic.lean

@@ -0,0 +1,717 @@
+/-
+Copyright (c) 2014 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Floris van Doorn, Leonardo de Moura
+-/
+prelude
+import Init.Core
+universes u
+
+namespace Nat
+
+@[extern "lean_nat_dec_eq"]
+def beq : Nat → Nat → Bool
+| zero,   zero   => true
+| zero,   succ m => false
+| succ n, zero   => false
+| succ n, succ m => beq n m
+
+theorem eqOfBeqEqTt : ∀ {n m : Nat}, beq n m = true → n = m
+| zero,   zero,   h => rfl
+| zero,   succ m, h => Bool.noConfusion h
+| succ n, zero,   h => Bool.noConfusion h
+| succ n, succ m, h =>
+  have beq n m = true from h;
+  have n = m from eqOfBeqEqTt this;
+  congrArg succ this
+
+theorem neOfBeqEqFf : ∀ {n m : Nat}, beq n m = false → n ≠ m
+| zero,   zero,   h₁, h₂ => Bool.noConfusion h₁
+| zero,   succ m, h₁, h₂ => Nat.noConfusion h₂
+| succ n, zero,   h₁, h₂ => Nat.noConfusion h₂
+| succ n, succ m, h₁, h₂ =>
+  have beq n m = false from h₁;
+  have n ≠ m from neOfBeqEqFf this;
+  Nat.noConfusion h₂ (fun h₂ => absurd h₂ this)
+
+@[extern "lean_nat_dec_eq"]
+protected def decEq (n m : @& Nat) : Decidable (n = m) :=
+if h : beq n m = true then isTrue (eqOfBeqEqTt h)
+else isFalse (neOfBeqEqFf (eqFalseOfNeTrue h))
+
+@[inline] instance : DecidableEq Nat :=
+{decEq := Nat.decEq}
+
+@[extern "lean_nat_dec_le"]
+def ble : Nat → Nat → Bool
+| zero,   zero   => true
+| zero,   succ m => true
+| succ n, zero   => false
+| succ n, succ m => ble n m
+
+protected def le (n m : Nat) : Prop :=
+ble n m = true
+
+instance : HasLessEq Nat :=
+⟨Nat.le⟩
+
+protected def lt (n m : Nat) : Prop :=
+Nat.le (succ n) m
+
+instance : HasLess Nat :=
+⟨Nat.lt⟩
+
+@[extern c inline "lean_nat_sub(#1, lean_box(1))"]
+def pred : Nat → Nat
+| 0   => 0
+| a+1 => a
+
+@[extern "lean_nat_sub"]
+protected def sub : (@& Nat) → (@& Nat) → Nat
+| a, 0   => a
+| a, b+1 => pred (sub a b)
+
+@[extern "lean_nat_mul"]
+protected def mul : (@& Nat) → (@& Nat) → Nat
+| a, 0   => 0
+| a, b+1 => (mul a b) + a
+
+instance : HasSub Nat :=
+⟨Nat.sub⟩
+
+instance : HasMul Nat :=
+⟨Nat.mul⟩
+
+@[specialize] def foldAux {α : Type u} (f : Nat → α → α) (s : Nat) : Nat → α → α
+| 0,      a => a
+| succ n, a => foldAux n (f (s - (succ n)) a)
+
+@[inline] def fold {α : Type u} (f : Nat → α → α) (n : Nat) (a : α) : α :=
+foldAux f n n a
+
+@[specialize] def foldRevAux {α : Type u} (f : Nat → α → α) : Nat → α → α
+| 0,      a => a
+| succ n, a => foldRevAux n (f n a)
+
+@[inline] def foldRev {α : Type u} (f : Nat → α → α) (n : Nat) (a : α) : α :=
+foldRevAux f n a
+
+@[specialize] def anyAux (f : Nat → Bool) (s : Nat) : Nat → Bool
+| 0      => false
+| succ n => f (s - (succ n)) || anyAux n
+
+/- `any f n = true` iff there is `i in [0, n-1]` s.t. `f i = true` -/
+@[inline] def any (f : Nat → Bool) (n : Nat) : Bool :=
+anyAux f n n
+
+@[inline] def all (f : Nat → Bool) (n : Nat) : Bool :=
+!any (fun i => !f i) n
+
+@[specialize] def repeatAux {α : Type u} (f : α → α) : Nat → α → α
+| 0,      a => a
+| succ n, a => repeatAux n (f a)
+
+@[inline] def repeat {α : Type u} (f : α → α) (n : Nat) (a : α) : α :=
+repeatAux f n a
+
+protected def pow (m : Nat) : Nat → Nat
+| 0      => 1
+| succ n => pow n * m
+
+instance : HasPow Nat Nat :=
+⟨Nat.pow⟩
+
+/- Nat.add theorems -/
+
+protected theorem zeroAdd : ∀ (n : Nat), 0 + n = n
+| 0   => rfl
+| n+1 => congrArg succ (zeroAdd n)
+
+theorem succAdd : ∀ (n m : Nat), (succ n) + m = succ (n + m)
+| n, 0   => rfl
+| n, m+1 => congrArg succ (succAdd n m)
+
+theorem addSucc (n m : Nat) : n + succ m = succ (n + m) :=
+rfl
+
+protected theorem addZero (n : Nat) : n + 0 = n :=
+rfl
+
+theorem addOne (n : Nat) : n + 1 = succ n :=
+rfl
+
+theorem succEqAddOne (n : Nat) : succ n = n + 1 :=
+rfl
+
+protected theorem addComm : ∀ (n m : Nat), n + m = m + n
+| n, 0   => Eq.symm (Nat.zeroAdd n)
+| n, m+1 =>
+  suffices succ (n + m) = succ (m + n) from Eq.symm (succAdd m n) ▸ this;
+  congrArg succ (addComm n m)
+
+protected theorem addAssoc : ∀ (n m k : Nat), (n + m) + k = n + (m + k)
+| n, m, 0      => rfl
+| n, m, succ k => congrArg succ (addAssoc n m k)
+
+protected theorem addLeftComm : ∀ (n m k : Nat), n + (m + k) = m + (n + k) :=
+leftComm Nat.add Nat.addComm Nat.addAssoc
+
+protected theorem addRightComm : ∀ (n m k : Nat), (n + m) + k = (n + k) + m :=
+rightComm Nat.add Nat.addComm Nat.addAssoc
+
+protected theorem addLeftCancel : ∀ {n m k : Nat}, n + m = n + k → m = k
+| 0,      m, k, h => Nat.zeroAdd m ▸ Nat.zeroAdd k ▸ h
+| succ n, m, k, h =>
+  have n+m = n+k from
+    have succ (n + m) = succ (n + k) from succAdd n m ▸ succAdd n k ▸ h;
+    Nat.noConfusion this id;
+  addLeftCancel this
+
+protected theorem addRightCancel {n m k : Nat} (h : n + m = k + m) : n = k :=
+have m + n = m + k from Nat.addComm n m ▸ Nat.addComm k m ▸ h;
+Nat.addLeftCancel this
+
+/- Nat.mul theorems -/
+
+protected theorem mulZero (n : Nat) : n * 0 = 0 :=
+rfl
+
+theorem mulSucc (n m : Nat) : n * succ m = n * m + n :=
+rfl
+
+protected theorem zeroMul : ∀ (n : Nat), 0 * n = 0
+| 0      => rfl
+| succ n => (mulSucc 0 n).symm ▸ (zeroMul n).symm ▸ rfl
+
+theorem succMul : ∀ (n m : Nat), (succ n) * m = (n * m) + m
+| n, 0      => rfl
+| n, succ m =>
+  have succ (n * m + m + n) = succ (n * m + n + m) from
+    congrArg succ (Nat.addRightComm _ _ _);
+  (mulSucc n m).symm ▸ (mulSucc (succ n) m).symm ▸ (succMul n m).symm ▸ this
+
+protected theorem mulComm : ∀ (n m : Nat), n * m = m * n
+| n, 0      => (Nat.zeroMul n).symm ▸ (Nat.mulZero n).symm ▸ rfl
+| n, succ m => (mulSucc n m).symm ▸ (succMul m n).symm ▸ (mulComm n m).symm ▸ rfl
+
+protected theorem mulOne : ∀ (n : Nat), n * 1 = n :=
+Nat.zeroAdd
+
+protected theorem oneMul (n : Nat) : 1 * n = n :=
+Nat.mulComm n 1 ▸ Nat.mulOne n
+
+protected theorem leftDistrib : ∀ (n m k : Nat), n * (m + k) = n * m + n * k
+| 0,      m, k => (Nat.zeroMul (m + k)).symm ▸ (Nat.zeroMul m).symm ▸ (Nat.zeroMul k).symm ▸ rfl
+| succ n, m, k =>
+  have h₁ : succ n * (m + k) = n * (m + k) + (m + k)              from succMul _ _;
+  have h₂ : n * (m + k) + (m + k) = (n * m + n * k) + (m + k)     from leftDistrib n m k ▸ rfl;
+  have h₃ : (n * m + n * k) + (m + k) = n * m + (n * k + (m + k)) from Nat.addAssoc _ _ _;
+  have h₄ : n * m + (n * k + (m + k)) = n * m + (m + (n * k + k)) from congrArg (fun x => n*m + x) (Nat.addLeftComm _ _ _);
+  have h₅ : n * m + (m + (n * k + k)) = (n * m + m) + (n * k + k) from (Nat.addAssoc _ _ _).symm;
+  have h₆ : (n * m + m) + (n * k + k) = (n * m + m) + succ n * k  from succMul n k ▸ rfl;
+  have h₇ : (n * m + m) + succ n * k = succ n * m + succ n * k    from succMul n m ▸ rfl;
+  (((((h₁.trans h₂).trans h₃).trans h₄).trans h₅).trans h₆).trans h₇
+
+protected theorem rightDistrib (n m k : Nat) : (n + m) * k = n * k + m * k :=
+have h₁ : (n + m) * k = k * (n + m)     from Nat.mulComm _ _;
+have h₂ : k * (n + m) = k * n + k * m   from Nat.leftDistrib _ _ _;
+have h₃ : k * n + k * m = n * k + k * m from Nat.mulComm n k ▸ rfl;
+have h₄ : n * k + k * m = n * k + m * k from Nat.mulComm m k ▸ rfl;
+((h₁.trans h₂).trans h₃).trans h₄
+
+protected theorem mulAssoc : ∀ (n m k : Nat), (n * m) * k = n * (m * k)
+| n, m, 0      => rfl
+| n, m, succ k =>
+  have h₁ : n * m * succ k = n * m * (k + 1)              from rfl;
+  have h₂ : n * m * (k + 1) = (n * m * k) + n * m * 1     from Nat.leftDistrib _ _ _;
+  have h₃ : (n * m * k) + n * m * 1 = (n * m * k) + n * m from (Nat.mulOne (n*m)).symm ▸ rfl;
+  have h₄ : (n * m * k) + n * m = (n * (m * k)) + n * m   from (mulAssoc n m k).symm ▸ rfl;
+  have h₅ : (n * (m * k)) + n * m = n * (m * k + m)       from (Nat.leftDistrib n (m*k) m).symm;
+  have h₆ : n * (m * k + m) = n * (m * succ k)            from Nat.mulSucc m k ▸ rfl;
+((((h₁.trans h₂).trans h₃).trans h₄).trans h₅).trans h₆
+
+/- Inequalities -/
+
+protected def leRefl : ∀ (n : Nat), n ≤ n
+| zero   => rfl
+| succ n => leRefl n
+
+theorem leSucc : ∀ (n : Nat), n ≤ succ n
+| zero   => rfl
+| succ n => leSucc n
+
+theorem succLeSucc {n m : Nat} (h : n ≤ m) : succ n ≤ succ m :=
+h
+
+theorem succLtSucc {n m : Nat} : n < m → succ n < succ m :=
+succLeSucc
+
+theorem leStep : ∀ {n m : Nat}, n ≤ m → n ≤ succ m
+| zero,   zero,   h => rfl
+| zero,   succ n, h => rfl
+| succ n, zero,   h => Bool.noConfusion h
+| succ n, succ m, h =>
+  have n ≤ m from h;
+  have n ≤ succ m from leStep this;
+  succLeSucc this
+
+theorem zeroLe : ∀ (n : Nat), 0 ≤ n
+| zero   => rfl
+| succ n => rfl
+
+theorem zeroLtSucc (n : Nat) : 0 < succ n :=
+succLeSucc (zeroLe n)
+
+def succPos := zeroLtSucc
+
+theorem notSuccLeZero : ∀ (n : Nat), succ n ≤ 0 → False
+| 0,   h => nomatch h
+| n+1, h => nomatch h
+
+theorem notLtZero (n : Nat) : ¬ n < 0 :=
+notSuccLeZero n
+
+theorem predLePred : ∀ {n m : Nat}, n ≤ m → pred n ≤ pred m
+| zero,   zero,   h => rfl
+| zero,   succ n, h => zeroLe n
+| succ n, zero,   h => Bool.noConfusion h
+| succ n, succ m, h => h
+
+theorem leOfSuccLeSucc {n m : Nat} : succ n ≤ succ m → n ≤ m :=
+predLePred
+
+@[extern "lean_nat_dec_le"]
+instance decLe (n m : @& Nat) : Decidable (n ≤ m) :=
+decEq (ble n m) true
+
+@[extern "lean_nat_dec_lt"]
+instance decLt (n m : @& Nat) : Decidable (n < m) :=
+Nat.decLe (succ n) m
+
+protected theorem eqOrLtOfLe : ∀ {n m: Nat}, n ≤ m → n = m ∨ n < m
+| zero,   zero,   h => Or.inl rfl
+| zero,   succ n, h => Or.inr $ zeroLe n
+| succ n, zero,   h => Bool.noConfusion h
+| succ n, succ m, h =>
+  have n ≤ m from h;
+  have n = m ∨ n < m from eqOrLtOfLe this;
+  Or.elim this
+   (fun h => Or.inl $ congrArg succ h)
+   (fun h => Or.inr $ succLtSucc h)
+
+theorem ltSuccOfLe {n m : Nat} : n ≤ m → n < succ m :=
+succLeSucc
+
+protected theorem subZero (n : Nat) : n - 0 = n :=
+rfl
+
+theorem succSubSuccEqSub (n m : Nat) : succ n - succ m = n - m :=
+Nat.recOn m
+  (show succ n - succ zero = n - zero from (Eq.refl (succ n - succ zero)))
+  (fun m => congrArg pred)
+
+theorem notSuccLeSelf : ∀ (n : Nat), ¬succ n ≤ n :=
+fun n => Nat.rec (notSuccLeZero 0) (fun a b c => b (leOfSuccLeSucc c)) n
+
+protected theorem ltIrrefl (n : Nat) : ¬n < n :=
+notSuccLeSelf n
+
+protected theorem leTrans : ∀ {n m k : Nat}, n ≤ m → m ≤ k → n ≤ k
+| zero,   m,      k,      h₁, h₂ => zeroLe _
+| succ n, zero,   k,      h₁, h₂ => Bool.noConfusion h₁
+| succ n, succ m, zero,   h₁, h₂ => Bool.noConfusion h₂
+| succ n, succ m, succ k, h₁, h₂ =>
+  have h₁' : n ≤ m from h₁;
+  have h₂' : m ≤ k from h₂;
+  have n ≤ k from leTrans h₁' h₂';
+  succLeSucc this
+
+theorem predLe : ∀ (n : Nat), pred n ≤ n
+| zero   => rfl
+| succ n => leSucc _
+
+theorem predLt : ∀ {n : Nat}, n ≠ 0 → pred n < n
+| zero,   h => absurd rfl h
+| succ n, h => ltSuccOfLe (Nat.leRefl _)
+
+theorem subLe (n m : Nat) : n - m ≤ n :=
+Nat.recOn m (Nat.leRefl (n - 0)) (fun m => Nat.leTrans (predLe (n - m)))
+
+theorem subLt : ∀ {n m : Nat}, 0 < n → 0 < m → n - m < n
+| 0,   m,   h1, h2 => absurd h1 (Nat.ltIrrefl 0)
+| n+1, 0,   h1, h2 => absurd h2 (Nat.ltIrrefl 0)
+| n+1, m+1, h1, h2 =>
+  Eq.symm (succSubSuccEqSub n m) ▸
+    show n - m < succ n from
+    ltSuccOfLe (subLe n m)
+
+protected theorem ltOfLtOfLe {n m k : Nat} : n < m → m ≤ k → n < k :=
+Nat.leTrans
+
+protected theorem leOfEq {n m : Nat} (p : n = m) : n ≤ m :=
+p ▸ Nat.leRefl n
+
+theorem leSuccOfLe {n m : Nat} (h : n ≤ m) : n ≤ succ m :=
+Nat.leTrans h (leSucc m)
+
+theorem leOfSuccLe {n m : Nat} (h : succ n ≤ m) : n ≤ m :=
+Nat.leTrans (leSucc n) h
+
+protected theorem leOfLt {n m : Nat} (h : n < m) : n ≤ m :=
+leOfSuccLe h
+
+def lt.step {n m : Nat} : n < m → n < succ m := leStep
+
+theorem eqZeroOrPos : ∀ (n : Nat), n = 0 ∨ n > 0
+| 0   => Or.inl rfl
+| n+1 => Or.inr (succPos _)
+
+protected theorem ltTrans {n m k : Nat} (h₁ : n < m) : m < k → n < k :=
+Nat.leTrans (leStep h₁)
+
+protected theorem ltOfLeOfLt {n m k : Nat} (h₁ : n ≤ m) : m < k → n < k :=
+Nat.leTrans (succLeSucc h₁)
+
+def lt.base (n : Nat) : n < succ n := Nat.leRefl (succ n)
+
+theorem ltSuccSelf (n : Nat) : n < succ n := lt.base n
+
+protected theorem leAntisymm : ∀ {n m : Nat}, n ≤ m → m ≤ n → n = m
+| zero,   zero,   h₁, h₂ => rfl
+| succ n, zero,   h₁, h₂ => Bool.noConfusion h₁
+| zero,   succ m, h₁, h₂ => Bool.noConfusion h₂
+| succ n, succ m, h₁, h₂ =>
+  have h₁' : n ≤ m from h₁;
+  have h₂' : m ≤ n from h₂;
+  have n = m from leAntisymm h₁' h₂';
+  congrArg succ this
+
+protected theorem ltOrGe : ∀ (n m : Nat), n < m ∨ n ≥ m
+| n, 0   => Or.inr (zeroLe n)
+| n, m+1 =>
+  match ltOrGe n m with
+  | Or.inl h => Or.inl (leSuccOfLe h)
+  | Or.inr h =>
+    match Nat.eqOrLtOfLe h with
+    | Or.inl h1 => Or.inl (h1 ▸ ltSuccSelf m)
+    | Or.inr h1 => Or.inr h1
+
+protected theorem leTotal (m n : Nat) : m ≤ n ∨ n ≤ m :=
+Or.elim (Nat.ltOrGe m n)
+  (fun h => Or.inl (Nat.leOfLt h))
+  Or.inr
+
+protected theorem ltOfLeAndNe {m n : Nat} (h1 : m ≤ n) : m ≠ n → m < n :=
+resolveRight (Or.swap (Nat.eqOrLtOfLe h1))
+
+theorem eqZeroOfLeZero {n : Nat} (h : n ≤ 0) : n = 0 :=
+Nat.leAntisymm h (zeroLe _)
+
+theorem ltOfSuccLt {n m : Nat} : succ n < m → n < m :=
+leOfSuccLe
+
+theorem ltOfSuccLtSucc {n m : Nat} : succ n < succ m → n < m :=
+leOfSuccLeSucc
+
+theorem ltOfSuccLe {n m : Nat} (h : succ n ≤ m) : n < m :=
+h
+
+theorem succLeOfLt {n m : Nat} (h : n < m) : succ n ≤ m :=
+h
+
+theorem ltOrEqOrLeSucc {m n : Nat} (h : m ≤ succ n) : m ≤ n ∨ m = succ n :=
+Decidable.byCases
+  (fun (h' : m = succ n) => Or.inr h')
+  (fun (h' : m ≠ succ n) =>
+     have m < succ n from Nat.ltOfLeAndNe h h';
+     have succ m ≤ succ n from succLeOfLt this;
+     Or.inl (leOfSuccLeSucc this))
+
+theorem leAddRight : ∀ (n k : Nat), n ≤ n + k
+| n, 0   => Nat.leRefl n
+| n, k+1 => leSuccOfLe (leAddRight n k)
+
+theorem leAddLeft (n m : Nat): n ≤ m + n :=
+Nat.addComm n m ▸ leAddRight n m
+
+theorem le.dest : ∀ {n m : Nat}, n ≤ m → Exists (fun k => n + k = m)
+| zero,   zero,   h => ⟨0, rfl⟩
+| zero,   succ n, h => ⟨succ n, show 0 + succ n = succ n from (Nat.addComm 0 (succ n)).symm ▸ rfl⟩
+| succ n, zero,   h => Bool.noConfusion h
+| succ n, succ m, h =>
+  have n ≤ m from h;
+  have Exists (fun k => n + k = m) from le.dest this;
+  match this with
+  | ⟨k, h⟩ => ⟨k, show succ n + k = succ m from ((succAdd n k).symm ▸ h ▸ rfl)⟩
+
+theorem le.intro {n m k : Nat} (h : n + k = m) : n ≤ m :=
+h ▸ leAddRight n k
+
+protected theorem notLeOfGt {n m : Nat} (h : n > m) : ¬ n ≤ m :=
+fun h₁ => Or.elim (Nat.ltOrGe n m)
+  (fun h₂ => absurd (Nat.ltTrans h h₂) (Nat.ltIrrefl _))
+  (fun h₂ =>
+    have Heq : n = m from Nat.leAntisymm h₁ h₂;
+    absurd (@Eq.subst _ _ _ _ Heq h) (Nat.ltIrrefl m))
+
+theorem gtOfNotLe {n m : Nat} (h : ¬ n ≤ m) : n > m :=
+Or.elim (Nat.ltOrGe m n)
+  (fun h₁ => h₁)
+  (fun h₁ => absurd h₁ h)
+
+protected theorem ltOfLeOfNe {n m : Nat} (h₁ : n ≤ m) (h₂ : n ≠ m) : n < m :=
+Or.elim (Nat.ltOrGe n m)
+  (fun h₃ => h₃)
+  (fun h₃ => absurd (Nat.leAntisymm h₁ h₃) h₂)
+
+protected theorem addLeAddLeft {n m : Nat} (h : n ≤ m) (k : Nat) : k + n ≤ k + m :=
+match le.dest h with
+| ⟨w, hw⟩ =>
+  have h₁ : k + n + w = k + (n + w) from Nat.addAssoc _ _ _;
+  have h₂ : k + (n + w) = k + m     from congrArg _ hw;
+  le.intro $ h₁.trans h₂
+
+protected theorem addLeAddRight {n m : Nat} (h : n ≤ m) (k : Nat) : n + k ≤ m + k :=
+have h₁ : n + k = k + n from Nat.addComm _ _;
+have h₂ : k + n ≤ k + m from Nat.addLeAddLeft h k;
+have h₃ : k + m = m + k from Nat.addComm _ _;
+transRelLeft (fun a b => a ≤ b) (transRelRight (fun a b => a ≤ b) h₁ h₂) h₃
+
+protected theorem addLtAddLeft {n m : Nat} (h : n < m) (k : Nat) : k + n < k + m :=
+ltOfSuccLe (addSucc k n ▸ Nat.addLeAddLeft (succLeOfLt h) k)
+
+protected theorem addLtAddRight {n m : Nat} (h : n < m) (k : Nat) : n + k < m + k :=
+Nat.addComm k m ▸ Nat.addComm k n ▸ Nat.addLtAddLeft h k
+
+protected theorem zeroLtOne : 0 < (1:Nat) :=
+zeroLtSucc 0
+
+theorem leOfLtSucc {m n : Nat} : m < succ n → m ≤ n :=
+leOfSuccLeSucc
+
+theorem addLeAdd {a b c d : Nat} (h₁ : a ≤ b) (h₂ : c ≤ d) : a + c ≤ b + d :=
+Nat.leTrans (Nat.addLeAddRight h₁ c) (Nat.addLeAddLeft h₂ b)
+
+theorem addLtAdd {a b c d : Nat} (h₁ : a < b) (h₂ : c < d) : a + c < b + d :=
+Nat.ltTrans (Nat.addLtAddRight h₁ c) (Nat.addLtAddLeft h₂ b)
+
+/- Basic theorems for comparing numerals -/
+
+theorem natZeroEqZero : Nat.zero = 0 :=
+rfl
+
+protected theorem oneNeZero : 1 ≠ (0 : Nat) :=
+fun h => Nat.noConfusion h
+
+protected theorem zeroNeOne : 0 ≠ (1 : Nat) :=
+fun h => Nat.noConfusion h
+
+theorem succNeZero (n : Nat) : succ n ≠ 0 :=
+fun h => Nat.noConfusion h
+
+protected theorem bit0SuccEq (n : Nat) : bit0 (succ n) = succ (succ (bit0 n)) :=
+show succ (succ n + n) = succ (succ (n + n)) from
+congrArg succ (succAdd n n)
+
+protected theorem zeroLtBit0 : ∀ {n : Nat}, n ≠ 0 → 0 < bit0 n
+| 0,      h => absurd rfl h
+| succ n, h =>
+  have h₁ : 0 < succ (succ (bit0 n))             from zeroLtSucc _;
+  have h₂ : succ (succ (bit0 n)) = bit0 (succ n) from (Nat.bit0SuccEq n).symm;
+  transRelLeft (fun a b => a < b) h₁ h₂
+
+protected theorem zeroLtBit1 (n : Nat) : 0 < bit1 n :=
+zeroLtSucc _
+
+protected theorem bit0NeZero : ∀ {n : Nat}, n ≠ 0 → bit0 n ≠ 0
+| 0,   h => absurd rfl h
+| n+1, h =>
+  suffices (n+1) + (n+1) ≠ 0 from this;
+  suffices succ ((n+1) + n) ≠ 0 from this;
+  fun h => Nat.noConfusion h
+
+protected theorem bit1NeZero (n : Nat) : bit1 n ≠ 0 :=
+show succ (n + n) ≠ 0 from
+fun h => Nat.noConfusion h
+
+protected theorem bit1EqSuccBit0 (n : Nat) : bit1 n = succ (bit0 n) :=
+rfl
+
+protected theorem bit1SuccEq (n : Nat) : bit1 (succ n) = succ (succ (bit1 n)) :=
+Eq.trans (Nat.bit1EqSuccBit0 (succ n)) (congrArg succ (Nat.bit0SuccEq n))
+
+protected theorem bit1NeOne : ∀ {n : Nat}, n ≠ 0 → bit1 n ≠ 1
+| 0,   h, h1 => absurd rfl h
+| n+1, h, h1 => Nat.noConfusion h1 (fun h2 => absurd h2 (succNeZero _))
+
+protected theorem bit0NeOne : ∀ (n : Nat), bit0 n ≠ 1
+| 0,   h => absurd h (Ne.symm Nat.oneNeZero)
+| n+1, h =>
+  have h1 : succ (succ (n + n)) = 1 from succAdd n n ▸ h;
+  Nat.noConfusion h1
+    (fun h2 => absurd h2 (succNeZero (n + n)))
+
+protected theorem addSelfNeOne : ∀ (n : Nat), n + n ≠ 1
+| 0,   h => Nat.noConfusion h
+| n+1, h =>
+  have h1 : succ (succ (n + n)) = 1 from succAdd n n ▸ h;
+  Nat.noConfusion h1 (fun h2 => absurd h2 (Nat.succNeZero (n + n)))
+
+protected theorem bit1NeBit0 : ∀ (n m : Nat), bit1 n ≠ bit0 m
+| 0,   m,   h => absurd h (Ne.symm (Nat.addSelfNeOne m))
+| n+1, 0,   h =>
+  have h1 : succ (bit0 (succ n)) = 0 from h;
+  absurd h1 (Nat.succNeZero _)
+| n+1, m+1, h =>
+  have h1 : succ (succ (bit1 n)) = succ (succ (bit0 m)) from
+    Nat.bit0SuccEq m ▸ Nat.bit1SuccEq n ▸ h;
+  have h2 : bit1 n = bit0 m from
+    Nat.noConfusion h1 (fun h2' => Nat.noConfusion h2' (fun h2'' => h2''));
+  absurd h2 (bit1NeBit0 n m)
+
+protected theorem bit0NeBit1 : ∀ (n m : Nat), bit0 n ≠ bit1 m :=
+fun n m => Ne.symm (Nat.bit1NeBit0 m n)
+
+protected theorem bit0Inj : ∀ {n m : Nat}, bit0 n = bit0 m → n = m
+| 0,   0,   h => rfl
+| 0,   m+1, h => absurd h.symm (succNeZero _)
+| n+1, 0,   h => absurd h (succNeZero _)
+| n+1, m+1, h =>
+  have (n+1) + n = (m+1) + m from Nat.noConfusion h id;
+  have n + (n+1) = m + (m+1) from Nat.addComm (m+1) m ▸ Nat.addComm (n+1) n ▸ this;
+  have succ (n + n) = succ (m + m) from this;
+  have n + n = m + m from Nat.noConfusion this id;
+  have n = m from bit0Inj this;
+  congrArg (fun a => a + 1) this
+
+protected theorem bit1Inj : ∀ {n m : Nat}, bit1 n = bit1 m → n = m :=
+fun n m h =>
+have succ (bit0 n) = succ (bit0 m) from Nat.bit1EqSuccBit0 n ▸ Nat.bit1EqSuccBit0 m ▸ h;
+have bit0 n = bit0 m from Nat.noConfusion this id;
+Nat.bit0Inj this
+
+protected theorem bit0Ne {n m : Nat} : n ≠ m → bit0 n ≠ bit0 m :=
+fun h₁ h₂ => absurd (Nat.bit0Inj h₂) h₁
+
+protected theorem bit1Ne {n m : Nat} : n ≠ m → bit1 n ≠ bit1 m :=
+fun h₁ h₂ => absurd (Nat.bit1Inj h₂) h₁
+
+protected theorem zeroNeBit0 {n : Nat} : n ≠ 0 → 0 ≠ bit0 n :=
+fun h => Ne.symm (Nat.bit0NeZero h)
+
+protected theorem zeroNeBit1 (n : Nat) : 0 ≠ bit1 n :=
+Ne.symm (Nat.bit1NeZero n)
+
+protected theorem oneNeBit0 (n : Nat) : 1 ≠ bit0 n :=
+Ne.symm (Nat.bit0NeOne n)
+
+protected theorem oneNeBit1 {n : Nat} : n ≠ 0 → 1 ≠ bit1 n :=
+fun h => Ne.symm (Nat.bit1NeOne h)
+
+protected theorem oneLtBit1 : ∀ {n : Nat}, n ≠ 0 → 1 < bit1 n
+| 0,      h => absurd rfl h
+| succ n, h =>
+  suffices succ 0 < succ (succ (bit1 n)) from (Nat.bit1SuccEq n).symm ▸ this;
+  succLtSucc (zeroLtSucc _)
+
+protected theorem oneLtBit0 : ∀ {n : Nat}, n ≠ 0 → 1 < bit0 n
+| 0,      h => absurd rfl h
+| succ n, h =>
+  suffices succ 0 < succ (succ (bit0 n)) from (Nat.bit0SuccEq n).symm ▸ this;
+  succLtSucc (zeroLtSucc _)
+
+protected theorem bit0Lt {n m : Nat} (h : n < m) : bit0 n < bit0 m :=
+Nat.addLtAdd h h
+
+protected theorem bit1Lt {n m : Nat} (h : n < m) : bit1 n < bit1 m :=
+succLtSucc (Nat.addLtAdd h h)
+
+protected theorem bit0LtBit1 {n m : Nat} (h : n ≤ m) : bit0 n < bit1 m :=
+ltSuccOfLe (Nat.addLeAdd h h)
+
+protected theorem bit1LtBit0 : ∀ {n m : Nat}, n < m → bit1 n < bit0 m
+| n, 0,      h => absurd h (notLtZero _)
+| n, succ m, h =>
+  have n ≤ m from leOfLtSucc h;
+  have succ (n + n) ≤ succ (m + m)      from succLeSucc (addLeAdd this this);
+  have succ (n + n) ≤ succ m + m        from (succAdd m m).symm ▸ this;
+  show succ (n + n) < succ (succ m + m) from ltSuccOfLe this
+
+protected theorem oneLeBit1 (n : Nat) : 1 ≤ bit1 n :=
+show 1 ≤ succ (bit0 n) from
+succLeSucc (zeroLe (bit0 n))
+
+protected theorem oneLeBit0 : ∀ (n : Nat), n ≠ 0 → 1 ≤ bit0 n
+| 0,   h => absurd rfl h
+| n+1, h =>
+  suffices 1 ≤ succ (succ (bit0 n)) from Eq.symm (Nat.bit0SuccEq n) ▸ this;
+  succLeSucc (zeroLe (succ (bit0 n)))
+
+/- mul + order -/
+
+theorem mulLeMulLeft {n m : Nat} (k : Nat) (h : n ≤ m) : k * n ≤ k * m :=
+match le.dest h with
+| ⟨l, hl⟩ =>
+  have k * n + k * l = k * m from Nat.leftDistrib k n l ▸ hl.symm ▸ rfl;
+  le.intro this
+
+theorem mulLeMulRight {n m : Nat} (k : Nat) (h : n ≤ m) : n * k ≤ m * k :=
+Nat.mulComm k m ▸ Nat.mulComm k n ▸ mulLeMulLeft k h
+
+protected theorem mulLeMul {n₁ m₁ n₂ m₂ : Nat} (h₁ : n₁ ≤ n₂) (h₂ : m₁ ≤ m₂) : n₁ * m₁ ≤ n₂ * m₂ :=
+Nat.leTrans (mulLeMulRight _ h₁) (mulLeMulLeft _ h₂)
+
+protected theorem mulLtMulOfPosLeft {n m k : Nat} (h : n < m) (hk : k > 0) : k * n < k * m :=
+Nat.ltOfLtOfLe (Nat.addLtAddLeft hk _) (Nat.mulSucc k n ▸ Nat.mulLeMulLeft k (succLeOfLt h))
+
+protected theorem mulLtMulOfPosRight {n m k : Nat} (h : n < m) (hk : k > 0) : n * k < m * k :=
+Nat.mulComm k m ▸ Nat.mulComm k n ▸ Nat.mulLtMulOfPosLeft h hk
+
+protected theorem mulPos {n m : Nat} (ha : n > 0) (hb : m > 0) : n * m > 0 :=
+have h : 0 * m < n * m from Nat.mulLtMulOfPosRight ha hb;
+Nat.zeroMul m ▸ h
+
+/- power -/
+
+theorem powSucc (n m : Nat) : n^(succ m) = n^m * n :=
+rfl
+
+theorem powZero (n : Nat) : n^0 = 1 := rfl
+
+theorem powLePowOfLeLeft {n m : Nat} (h : n ≤ m) : ∀ (i : Nat), n^i ≤ m^i
+| 0      => Nat.leRefl _
+| succ i => Nat.mulLeMul (powLePowOfLeLeft i) h
+
+theorem powLePowOfLeRight {n : Nat} (hx : n > 0) {i : Nat} : ∀ {j}, i ≤ j → n^i ≤ n^j
+| 0,      h =>
+  have i = 0 from eqZeroOfLeZero h;
+  this.symm ▸ Nat.leRefl _
+| succ j, h =>
+  Or.elim (ltOrEqOrLeSucc h)
+    (fun h => show n^i ≤ n^j * n from
+      suffices n^i * 1 ≤ n^j * n from Nat.mulOne (n^i) ▸ this;
+      Nat.mulLeMul (powLePowOfLeRight h) hx)
+    (fun h => h.symm ▸ Nat.leRefl _)
+
+theorem posPowOfPos {n : Nat} (m : Nat) (h : 0 < n) : 0 < n^m :=
+powLePowOfLeRight h (Nat.zeroLe _)
+
+/- Max -/
+
+protected def max (n m : Nat) : Nat :=
+if n ≤ m then m else n
+
+end Nat
+
+namespace Prod
+
+@[inline] def foldI {α : Type u} (f : Nat → α → α) (i : Nat × Nat) (a : α) : α :=
+Nat.foldAux f i.2 (i.2 - i.1) a
+
+@[inline] def anyI (f : Nat → Bool) (i : Nat × Nat) : Bool :=
+Nat.anyAux f i.2 (i.2 - i.1)
+
+@[inline] def allI (f : Nat → Bool) (i : Nat × Nat) : Bool :=
+!Nat.anyAux (fun a => !f a) i.2 (i.2 - i.1)
+
+end Prod

stage0/src/Init/Data/Nat/Bitwise.lean

@@ -0,0 +1,29 @@
+/-
+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 Init.Data.Nat.Basic
+import Init.Data.Nat.Div
+import Init.Coe
+
+namespace Nat
+
+partial def bitwise (f : Bool → Bool → Bool) : Nat → Nat → Nat | n, m =>
+if n = 0 then      (if f false true then m else 0)
+else if m = 0 then (if f true false then n else 0)
+else
+  let n' := n / 2;
+  let m' := m / 2;
+  let b₁ := n % 2 = 1;
+  let b₂ := m % 2 = 1;
+  let r  := bitwise n' m';
+  if f b₁ b₂ then bit1 r else bit0 r
+
+@[extern "lean_nat_land"]
+def land : Nat → Nat → Nat := bitwise and
+@[extern "lean_nat_lor"]
+def lor  : Nat → Nat → Nat := bitwise or
+
+end Nat

stage0/src/Init/Data/Nat/Control.lean

@@ -0,0 +1,56 @@
+/-
+Copyright (c) 2019 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Author: Leonardo de Moura
+-/
+prelude
+import Init.Control.Monad
+import Init.Control.Alternative
+import Init.Data.Nat.Basic
+
+namespace Nat
+universes u v
+
+@[specialize] def forMAux {m} [Monad m] (f : Nat → m Unit) (n : Nat) : Nat → m Unit
+| 0   => pure ()
+| i+1 => do f (n-i-1); forMAux i
+
+@[inline] def forM {m} [Monad m] (n : Nat) (f : Nat → m Unit) : m Unit :=
+forMAux f n n
+
+@[specialize] def forRevMAux {m} [Monad m] (f : Nat → m Unit) : Nat → m Unit
+| 0   => pure ()
+| i+1 => do f i; forRevMAux i
+
+@[inline] def forRevM {m} [Monad m] (n : Nat) (f : Nat → m Unit) : m Unit :=
+forRevMAux f n
+
+@[specialize] def foldMAux {α : Type u} {m : Type u → Type v} [Monad m] (f : Nat → α → m α) (n : Nat) : Nat → α → m α
+| 0,   a => pure a
+| i+1, a => f (n-i-1) a >>= foldMAux i
+
+@[inline] def foldM {α : Type u} {m : Type u → Type v} [Monad m] (f : Nat → α → m α) (a : α) (n : Nat) : m α :=
+foldMAux f n n a
+
+@[specialize] def foldRevMAux {α : Type u} {m : Type u → Type v} [Monad m] (f : Nat → α → m α) : Nat → α → m α
+| 0,   a => pure a
+| i+1, a => f i a >>= foldRevMAux i
+
+@[inline] def foldRevM {α : Type u} {m : Type u → Type v} [Monad m] (f : Nat → α → m α) (a : α) (n : Nat) : m α :=
+foldRevMAux f n a
+
+@[specialize] def allMAux {m} [Monad m] (p : Nat → m Bool) (n : Nat) : Nat → m Bool
+| 0   => pure true
+| i+1 => condM (p (n-i-1)) (allMAux i) (pure false)
+
+@[inline] def allM {m} [Monad m] (n : Nat) (p : Nat → m Bool) : m Bool :=
+allMAux p n n
+
+@[specialize] def anyMAux {m} [Monad m] (p : Nat → m Bool) (n : Nat) : Nat → m Bool
+| 0   => pure false
+| i+1 => condM (p (n-i-1)) (pure true) (anyMAux i)
+
+@[inline] def anyM {m} [Monad m] (n : Nat) (p : Nat → m Bool) : m Bool :=
+anyMAux p n n
+
+end Nat

stage0/src/Init/Data/Nat/Div.lean

@@ -0,0 +1,108 @@
+/-
+Copyright (c) 2016 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Init.WF
+import Init.Data.Nat.Basic
+namespace Nat
+
+private def divRecLemma {x y : Nat} : 0 < y ∧ y ≤ x → x - y < x :=
+fun h => And.rec (fun ypos ylex => subLt (Nat.ltOfLtOfLe ypos ylex) ypos) h
+
+private def div.F (x : Nat) (f : ∀ x₁, x₁ < x → Nat → Nat) (y : Nat) : Nat :=
+if h : 0 < y ∧ y ≤ x then f (x - y) (divRecLemma h) y + 1 else zero
+
+@[extern "lean_nat_div"]
+protected def div (a b : @& Nat) : Nat :=
+WellFounded.fix ltWf div.F a b
+
+instance : HasDiv Nat :=
+⟨Nat.div⟩
+
+private theorem divDefAux (x y : Nat) : x / y = if h : 0 < y ∧ y ≤ x then (x - y) / y + 1 else 0 :=
+congrFun (WellFounded.fixEq ltWf div.F x) y
+
+theorem divDef (x y : Nat) : x / y = if 0 < y ∧ y ≤ x then (x - y) / y + 1 else 0 :=
+difEqIf (0 < y ∧ y ≤ x) ((x - y) / y + 1) 0 ▸ divDefAux x y
+
+private theorem div.induction.F.{u}
+        (C : Nat → Nat → Sort u)
+        (h₁ : ∀ x y, 0 < y ∧ y ≤ x → C (x - y) y → C x y)
+        (h₂ : ∀ x y, ¬(0 < y ∧ y ≤ x) → C x y)
+        (x : Nat) (f : ∀ (x₁ : Nat), x₁ < x → ∀ (y : Nat), C x₁ y) (y : Nat) : C x y :=
+if h : 0 < y ∧ y ≤ x then h₁ x y h (f (x - y) (divRecLemma h) y) else h₂ x y h
+
+@[elabAsEliminator]
+theorem div.inductionOn.{u}
+      {C : Nat → Nat → Sort u}
+      (x y : Nat)
+      (h₁ : ∀ x y, 0 < y ∧ y ≤ x → C (x - y) y → C x y)
+      (h₂ : ∀ x y, ¬(0 < y ∧ y ≤ x) → C x y)
+      : C x y :=
+WellFounded.fix Nat.ltWf (div.induction.F C h₁ h₂) x y
+
+private def mod.F (x : Nat) (f : ∀ x₁, x₁ < x → Nat → Nat) (y : Nat) : Nat :=
+if h : 0 < y ∧ y ≤ x then f (x - y) (divRecLemma h) y else x
+
+@[extern "lean_nat_mod"]
+protected def mod (a b : @& Nat) : Nat :=
+WellFounded.fix ltWf mod.F a b
+
+instance : HasMod Nat :=
+⟨Nat.mod⟩
+
+private theorem modDefAux (x y : Nat) : x % y = if h : 0 < y ∧ y ≤ x then (x - y) % y else x :=
+congrFun (WellFounded.fixEq ltWf mod.F x) y
+
+theorem modDef (x y : Nat) : x % y = if 0 < y ∧ y ≤ x then (x - y) % y else x :=
+difEqIf (0 < y ∧ y ≤ x) ((x - y) % y) x ▸ modDefAux x y
+
+@[elabAsEliminator]
+theorem mod.inductionOn.{u}
+      {C : Nat → Nat → Sort u}
+      (x y : Nat)
+      (h₁ : ∀ x y, 0 < y ∧ y ≤ x → C (x - y) y → C x y)
+      (h₂ : ∀ x y, ¬(0 < y ∧ y ≤ x) → C x y)
+      : C x y :=
+div.inductionOn x y h₁ h₂
+
+theorem modZero (a : Nat) : a % 0 = a :=
+suffices (if 0 < 0 ∧ 0 ≤ a then (a - 0) % 0 else a) = a from (modDef a 0).symm ▸ this;
+have h : ¬ (0 < 0 ∧ 0 ≤ a) from fun ⟨h₁, _⟩ => absurd h₁ (Nat.ltIrrefl _);
+ifNeg h
+
+theorem modEqOfLt {a b : Nat} (h : a < b) : a % b = a :=
+suffices (if 0 < b ∧ b ≤ a then (a - b) % b else a) = a from (modDef a b).symm ▸ this;
+have h' : ¬(0 < b ∧ b ≤ a) from fun ⟨_, h₁⟩ => absurd h₁ (Nat.notLeOfGt h);
+ifNeg h'
+
+theorem modEqSubMod {a b : Nat} (h : a ≥ b) : a % b = (a - b) % b :=
+Or.elim (eqZeroOrPos b)
+  (fun h₁ => h₁.symm ▸ (Nat.subZero a).symm ▸ rfl)
+  (fun h₁ => (modDef a b).symm ▸ ifPos ⟨h₁, h⟩)
+
+theorem modLt (x : Nat) {y : Nat} : y > 0 → x % y < y :=
+mod.inductionOn x y
+  (fun (x y) ⟨_, h₁⟩ (h₂ h₃) =>
+   have ih  : (x - y) % y < y from h₂ h₃;
+   have Heq : x % y = (x - y) % y from modEqSubMod h₁;
+   Heq.symm ▸ ih)
+  (fun x y h₁ h₂ =>
+    have h₁ : ¬ 0 < y ∨ ¬ y ≤ x from Iff.mp (Decidable.notAndIffOrNot _ _) h₁;
+    Or.elim h₁
+     (fun h₁ => absurd h₂ h₁)
+     (fun h₁ =>
+       have hgt : y > x from gtOfNotLe h₁;
+       have Heq : x % y = x from modEqOfLt hgt;
+       Heq.symm ▸ hgt))
+
+theorem modLe (x y : Nat) : x % y ≤ x :=
+Or.elim (Nat.ltOrGe x y)
+  (fun (h₁ : x < y) => (modEqOfLt h₁).symm ▸ Nat.leRefl _)
+  (fun (h₁ : x ≥ y) => Or.elim (eqZeroOrPos y)
+    (fun (h₂ : y = 0) => h₂.symm ▸ (Nat.modZero x).symm ▸ Nat.leRefl _)
+    (fun (h₂ : y > 0) => Nat.leTrans (Nat.leOfLt (Nat.modLt _ h₂)) h₁))
+
+end Nat

stage0/src/Init/Data/Option.lean

@@ -0,0 +1,9 @@
+/-
+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 Init.Data.Option.Basic
+import Init.Data.Option.BasicAux
+import Init.Data.Option.Instances

stage0/src/Init/Data/Option/Basic.lean

@@ -0,0 +1,94 @@
+/-
+Copyright (c) 2014 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Init.Core
+import Init.Control.Monad
+import Init.Control.Alternative
+import Init.Coe
+open Decidable
+
+universes u v
+
+namespace Option
+
+def toMonad {m : Type → Type} [Monad m] [Alternative m] {A} : Option A → m A
+| none => failure
+| some a   => pure a
+
+@[macroInline] def getD {α : Type u} : Option α → α → α
+| some x, _ => x
+| none,   e => e
+
+@[inline] def toBool {α : Type u} : Option α → Bool
+| some _ => true
+| none   => false
+
+@[inline] def isSome {α : Type u} : Option α → Bool
+| some _ => true
+| none   => false
+
+@[inline] def isNone {α : Type u} : Option α → Bool
+| some _ => false
+| none   => true
+
+@[inline] protected def bind {α : Type u} {β : Type v} : Option α → (α → Option β) → Option β
+| none,   b => none
+| some a, b => b a
+
+@[inline] protected def map {α β} (f : α → β) (o : Option α) : Option β :=
+Option.bind o (some ∘ f)
+
+theorem mapId {α} : (Option.map id : Option α → Option α) = id :=
+funext (fun o => match o with | none => rfl | some x => rfl)
+
+instance : Monad Option :=
+{pure := @some, bind := @Option.bind, map := @Option.map}
+
+@[macroInline] protected def orelse {α : Type u} : Option α → Option α → Option α
+| some a, _ => some a
+| none,   b => b
+
+/- Remark: when using the polymorphic notation `a <|> b` is not a `[macroInline]`.
+   Thus, `a <|> b` will make `Option.orelse` to behave like it was marked as `[inline]`. -/
+instance : Alternative Option :=
+{ failure := @none,
+  orelse  := @Option.orelse,
+  ..Option.Monad }
+
+@[inline] protected def lt {α : Type u} (r : α → α → Prop) : Option α → Option α → Prop
+| none, some x     => True
+| some x,   some y => r x y
+| _, _             => False
+
+instance decidableRelLt {α : Type u} (r : α → α → Prop) [s : DecidableRel r] : DecidableRel (Option.lt r)
+| none,   some y => isTrue  trivial
+| some x, some y => s x y
+| some x, none   => isFalse notFalse
+| none,   none   => isFalse notFalse
+
+end Option
+
+instance (α : Type u) : Inhabited (Option α) :=
+⟨none⟩
+
+instance {α : Type u} [DecidableEq α] : DecidableEq (Option α) :=
+{decEq := fun a b => match a, b with
+ | none,      none      => isTrue rfl
+ | none,      (some v₂) => isFalse (fun h => Option.noConfusion h)
+ | (some v₁), none      => isFalse (fun h => Option.noConfusion h)
+ | (some v₁), (some v₂) =>
+   match decEq v₁ v₂ with
+   | (isTrue e)  => isTrue (congrArg (@some α) e)
+   | (isFalse n) => isFalse (fun h => Option.noConfusion h (fun e => absurd e n))}
+
+instance {α : Type u} [HasBeq α] : HasBeq (Option α) :=
+⟨fun a b => match a, b with
+ | none,      none      => true
+ | none,      (some v₂) => false
+ | (some v₁), none      => false
+ | (some v₁), (some v₂) => v₁ == v₂⟩
+
+instance {α : Type u} [HasLess α] : HasLess (Option α) := ⟨Option.lt HasLess.Less⟩

stage0/src/Init/Data/Option/BasicAux.lean

@@ -0,0 +1,18 @@
+/-
+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 Init.Data.Option.Basic
+import Init.Util
+
+universes u
+
+namespace Option
+
+@[inline] def get! {α : Type u} [Inhabited α] : Option α → α
+| some x => x
+| none   => panic! "value is none"
+
+end Option

stage0/src/Init/Data/Option/Instances.lean

@@ -0,0 +1,18 @@
+/-
+Copyright (c) 2017 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.Option.Basic
+
+universes u v
+
+theorem Option.eqOfEqSome {α : Type u} : ∀ {x y : Option α}, (∀z, x = some z ↔ y = some z) → x = y
+| none,   none,   h => rfl
+| none,   some z, h => Option.noConfusion ((h z).2 rfl)
+| some z, none,   h => Option.noConfusion ((h z).1 rfl)
+| some z, some w, h => Option.noConfusion ((h w).2 rfl) (congrArg some)
+
+theorem Option.eqNoneOfIsNone {α : Type u} : ∀ {o : Option α}, o.isNone → o = none
+| none, h => rfl

stage0/src/Init/Data/PersistentArray.lean

@@ -0,0 +1,7 @@
+/-
+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 Init.Data.PersistentArray.Basic

stage0/src/Init/Data/PersistentArray/Basic.lean

@@ -0,0 +1,330 @@
+/-
+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 Init.Control.Conditional
+import Init.Data.Array
+universes u v w
+
+inductive PersistentArrayNode (α : Type u)
+| node (cs : Array PersistentArrayNode) : PersistentArrayNode
+| leaf (vs : Array α)                   : PersistentArrayNode
+
+namespace PersistentArrayNode
+
+instance {α : Type u} : Inhabited (PersistentArrayNode α) := ⟨leaf #[]⟩
+
+def isNode {α} : PersistentArrayNode α → Bool
+| node _ => true
+| leaf _ => false
+
+end PersistentArrayNode
+
+abbrev PersistentArray.initShift : USize := 5
+abbrev PersistentArray.branching : USize := USize.ofNat (2 ^ PersistentArray.initShift.toNat)
+
+structure PersistentArray (α : Type u) :=
+/- Recall that we run out of memory if we have more than `usizeSz/8` elements.
+   So, we can stop adding elements at `root` after `size > usizeSz`, and
+   keep growing the `tail`. This modification allow us to use `USize` instead
+   of `Nat` when traversing `root`. -/
+(root    : PersistentArrayNode α := PersistentArrayNode.node (Array.mkEmpty PersistentArray.branching.toNat))
+(tail    : Array α               := Array.mkEmpty PersistentArray.branching.toNat)
+(size    : Nat                   := 0)
+(shift   : USize                 := PersistentArray.initShift)
+(tailOff : Nat                   := 0)
+
+abbrev PArray (α : Type u) := PersistentArray α
+
+namespace PersistentArray
+/- TODO: use proofs for showing that array accesses are not out of bounds.
+   We can do it after we reimplement the tactic framework. -/
+variables {α : Type u}
+open PersistentArrayNode
+
+def empty : PersistentArray α :=
+{}
+
+def isEmpty (a : PersistentArray α) : Bool :=
+a.size == 0
+
+instance : Inhabited (PersistentArray α) := ⟨{}⟩
+
+def mkEmptyArray : Array α := Array.mkEmpty branching.toNat
+
+abbrev mul2Shift (i : USize) (shift : USize) : USize := i.shiftLeft shift
+abbrev div2Shift (i : USize) (shift : USize) : USize := i.shiftRight shift
+abbrev mod2Shift (i : USize) (shift : USize) : USize := USize.land i ((USize.shiftLeft 1 shift) - 1)
+
+partial def getAux [Inhabited α] : PersistentArrayNode α → USize → USize → α
+| node cs, i, shift => getAux (cs.get! (div2Shift i shift).toNat) (mod2Shift i shift) (shift - initShift)
+| leaf cs, i, _     => cs.get! i.toNat
+
+def get! [Inhabited α] (t : PersistentArray α) (i : Nat) : α :=
+if i >= t.tailOff then
+  t.tail.get! (i - t.tailOff)
+else
+  getAux t.root (USize.ofNat i) t.shift
+
+partial def setAux : PersistentArrayNode α → USize → USize → α → PersistentArrayNode α
+| node cs, i, shift, a =>
+  let j     := div2Shift i shift;
+  let i     := mod2Shift i shift;
+  let shift := shift - initShift;
+  node $ cs.modify j.toNat $ fun c => setAux c i shift a
+| leaf cs, i, _,     a => leaf (cs.set! i.toNat a)
+
+def set (t : PersistentArray α) (i : Nat) (a : α) : PersistentArray α :=
+if i >= t.tailOff then
+  { tail := t.tail.set! (i - t.tailOff) a, .. t }
+else
+  { root := setAux t.root (USize.ofNat i) t.shift a, .. t }
+
+@[specialize] partial def modifyAux [Inhabited α] (f : α → α) : PersistentArrayNode α → USize → USize → PersistentArrayNode α
+| node cs, i, shift =>
+  let j     := div2Shift i shift;
+  let i     := mod2Shift i shift;
+  let shift := shift - initShift;
+  node $ cs.modify j.toNat $ fun c => modifyAux c i shift
+| leaf cs, i, _     => leaf (cs.modify i.toNat f)
+
+@[specialize] def modify [Inhabited α] (t : PersistentArray α) (i : Nat) (f : α → α) : PersistentArray α :=
+if i >= t.tailOff then
+  { tail := t.tail.modify (i - t.tailOff) f, .. t }
+else
+  { root := modifyAux f t.root (USize.ofNat i) t.shift, .. t }
+
+partial def mkNewPath : USize → Array α → PersistentArrayNode α
+| shift, a =>
+  if shift == 0 then
+    leaf a
+  else
+    node (mkEmptyArray.push (mkNewPath (shift - initShift) a))
+
+partial def insertNewLeaf : PersistentArrayNode α → USize → USize → Array α → PersistentArrayNode α
+| node cs,   i, shift, a =>
+  if i < branching then
+    node (cs.push (leaf a))
+  else
+    let j     := div2Shift i shift;
+    let i     := mod2Shift i shift;
+    let shift := shift - initShift;
+    if j.toNat < cs.size then
+       node $ cs.modify j.toNat $ fun c => insertNewLeaf c i shift a
+    else
+       node $ cs.push $ mkNewPath shift a
+| n, _, _, _ => n -- unreachable
+
+def mkNewTail (t : PersistentArray α) : PersistentArray α :=
+if t.size <= (mul2Shift 1 (t.shift + initShift)).toNat then
+  { tail    := mkEmptyArray, root := insertNewLeaf t.root (USize.ofNat (t.size - 1)) t.shift t.tail,
+    tailOff := t.size,
+    .. t }
+else
+  { tail := #[],
+    root := let n := mkEmptyArray.push t.root;
+            node (n.push (mkNewPath t.shift t.tail)),
+    shift   := t.shift + initShift,
+    tailOff := t.size,
+    .. t }
+
+def tooBig : Nat := usizeSz / 8
+
+def push (t : PersistentArray α) (a : α) : PersistentArray α :=
+let r := { tail := t.tail.push a, size := t.size + 1, .. t };
+if r.tail.size < branching.toNat || t.size >= tooBig then
+  r
+else
+  mkNewTail r
+
+private def emptyArray {α : Type u} : Array (PersistentArrayNode α) :=
+Array.mkEmpty PersistentArray.branching.toNat
+
+partial def popLeaf : PersistentArrayNode α → Option (Array α) × Array (PersistentArrayNode α)
+| n@(node cs) =>
+  if h : cs.size ≠ 0 then
+    let idx : Fin cs.size := ⟨cs.size - 1, Nat.predLt h⟩;
+    let last := cs.get idx;
+    let cs   := cs.set idx (arbitrary _);
+    match popLeaf last with
+    | (none,   _)       => (none, emptyArray)
+    | (some l, newLast) =>
+      if newLast.size == 0 then
+        let cs := cs.pop;
+        if cs.isEmpty then (some l, emptyArray) else (some l, cs)
+      else
+        (some l, cs.set idx (node newLast))
+  else
+    (none, emptyArray)
+| leaf vs   => (some vs, emptyArray)
+
+def pop (t : PersistentArray α) : PersistentArray α :=
+if t.tail.size > 0 then
+  { tail := t.tail.pop, size := t.size - 1, .. t }
+else
+  match popLeaf t.root with
+  | (none, _) => t
+  | (some last, newRoots) =>
+    let last       := last.pop;
+    let newSize    := t.size - 1;
+    let newTailOff := newSize - last.size;
+    if newRoots.size == 1 && (newRoots.get! 0).isNode then
+      { root    := newRoots.get! 0,
+        shift   := t.shift - initShift,
+        size    := newSize,
+        tail    := last,
+        tailOff := newTailOff }
+    else
+      { root    := node newRoots,
+        size    := newSize,
+        tail    := last,
+        tailOff := newTailOff,
+        .. t }
+
+section
+variables {m : Type v → Type w} [Monad m]
+variable {β : Type v}
+
+@[specialize] partial def foldlMAux (f : β → α → m β) : PersistentArrayNode α → β → m β
+| node cs, b => cs.foldlM (fun b c => foldlMAux c b) b
+| leaf vs, b => vs.foldlM f b
+
+@[specialize] def foldlM (t : PersistentArray α) (f : β → α → m β) (b : β) : m β :=
+do b ← foldlMAux f t.root b; t.tail.foldlM f b
+
+@[specialize] partial def findMAux (f : α → m (Option β)) : PersistentArrayNode α → m (Option β)
+| node cs => cs.findM (fun c => findMAux c)
+| leaf vs => vs.findM f
+
+@[specialize] def findM (t : PersistentArray α) (f : α → m (Option β)) : m (Option β) :=
+do b ← findMAux f t.root;
+   match b with
+   | none   => t.tail.findM f
+   | some b => pure (some b)
+
+@[specialize] partial def findRevMAux (f : α → m (Option β)) : PersistentArrayNode α → m (Option β)
+| node cs => cs.findRevM (fun c => findRevMAux c)
+| leaf vs => vs.findRevM f
+
+@[specialize] def findRevM (t : PersistentArray α) (f : α → m (Option β)) : m (Option β) :=
+do b ← t.tail.findRevM f;
+   match b with
+   | none   => findRevMAux f t.root
+   | some b => pure (some b)
+
+partial def foldlFromMAux (f : β → α → m β) : PersistentArrayNode α → USize → USize → β → m β
+| node cs, i, shift, b => do
+  let j    := (div2Shift i shift).toNat;
+  b ← foldlFromMAux (cs.get! j) (mod2Shift i shift) (shift - initShift) b;
+  cs.foldlFromM (fun b c => foldlMAux f c b) b (j+1)
+| leaf vs, i, _, b => vs.foldlFromM f b i.toNat
+
+def foldlFromM (t : PersistentArray α) (f : β → α → m β) (b : β) (ini : Nat) : m β :=
+if ini >= t.tailOff then
+  t.tail.foldlFromM f b (ini - t.tailOff)
+else do
+  b ← foldlFromMAux f t.root (USize.ofNat ini) t.shift b;
+  t.tail.foldlM f b
+
+@[specialize] partial def forMAux (f : α → m β) : PersistentArrayNode α → m PUnit
+| node cs => cs.forM (fun c => forMAux c)
+| leaf vs => vs.forM f
+
+@[specialize] def forM (t : PersistentArray α) (f : α → m β) : m PUnit :=
+forMAux f t.root *> t.tail.forM f
+
+end
+
+@[inline] def foldl {β} (t : PersistentArray α) (f : β → α → β) (b : β) : β :=
+Id.run (t.foldlM f b)
+
+@[inline] def find {β} (t : PersistentArray α) (f : α → (Option β)) : Option β :=
+Id.run (t.findM f)
+
+@[inline] def findRev {β} (t : PersistentArray α) (f : α → (Option β)) : Option β :=
+Id.run (t.findRevM f)
+
+@[inline] def foldlFrom {β} (t : PersistentArray α) (f : β → α → β) (b : β) (ini : Nat) : β :=
+Id.run (t.foldlFromM f b ini)
+
+def toList (t : PersistentArray α) : List α :=
+(t.foldl (fun xs x => x :: xs) []).reverse
+
+section
+variables {m : Type → Type w} [Monad m]
+@[specialize] partial def anyMAux (p : α → m Bool) : PersistentArrayNode α → m Bool
+| node cs => cs.anyM (fun c => anyMAux c)
+| leaf vs => vs.anyM p
+
+@[specialize] def anyM (t : PersistentArray α) (p : α → m Bool) : m Bool :=
+anyMAux p t.root <||> t.tail.anyM p
+
+@[inline] def allM (a : PersistentArray α) (p : α → m Bool) : m Bool :=
+do b ← anyM a (fun v => do b ← p v; pure (not b)); pure (not b)
+
+end
+
+@[inline] def any (a : PersistentArray α) (p : α → Bool) : Bool :=
+Id.run $ anyM a p
+
+@[inline] def all (a : PersistentArray α) (p : α → Bool) : Bool :=
+!any a (fun v => !p v)
+
+section
+variables {m : Type u → Type v} [Monad m]
+variable {β : Type u}
+
+@[specialize] partial def mapMAux (f : α → m β) : PersistentArrayNode α → m (PersistentArrayNode β)
+| node cs => node <$> cs.mapM (fun c => mapMAux c)
+| leaf vs => leaf <$> vs.mapM f
+
+@[specialize] def mapM (f : α → m β) (t : PersistentArray α) : m (PersistentArray β) :=
+do root ← mapMAux f t.root;
+   tail ← t.tail.mapM f;
+   pure { tail := tail, root := root, .. t }
+
+end
+
+@[inline] def map {β} (f : α → β) (t : PersistentArray α) : PersistentArray β :=
+Id.run (t.mapM f)
+
+structure Stats :=
+(numNodes : Nat) (depth : Nat) (tailSize : Nat)
+
+partial def collectStats : PersistentArrayNode α → Stats → Nat → Stats
+| node cs, s, d =>
+  cs.foldl (fun s c => collectStats c s (d+1))
+    { numNodes := s.numNodes + 1,
+      depth    := Nat.max d s.depth, .. s }
+| leaf vs, s, d => { numNodes := s.numNodes + 1, depth := Nat.max d s.depth, .. s }
+
+def stats (r : PersistentArray α) : Stats :=
+collectStats r.root { numNodes := 0, depth := 0, tailSize := r.tail.size } 0
+
+def Stats.toString (s : Stats) : String :=
+"{nodes := " ++ toString s.numNodes ++ ", depth := " ++ toString s.depth  ++ ", tail size := " ++ toString s.tailSize ++ "}"
+
+instance : HasToString Stats := ⟨Stats.toString⟩
+
+end PersistentArray
+
+def List.toPersistentArrayAux {α : Type u} : List α → PersistentArray α → PersistentArray α
+| [],    t => t
+| x::xs, t => List.toPersistentArrayAux xs (t.push x)
+
+def List.toPersistentArray {α : Type u} (xs : List α) : PersistentArray α :=
+xs.toPersistentArrayAux {}
+
+def Array.toPersistentArray {α : Type u} (xs : Array α) : PersistentArray α :=
+xs.foldl (fun p x => p.push x) PersistentArray.empty
+
+@[inline] def Array.toPArray {α : Type u} (xs : Array α) : PersistentArray α :=
+xs.toPersistentArray
+
+def mkPersistentArray {α : Type u} (n : Nat) (v : α) : PArray α :=
+n.fold (fun i p => p.push v) PersistentArray.empty
+
+@[inline] def mkPArray {α : Type u} (n : Nat) (v : α) : PArray α :=
+mkPersistentArray n v

stage0/src/Init/Data/PersistentHashMap.lean

@@ -0,0 +1,7 @@
+/-
+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 Init.Data.PersistentHashMap.Basic

stage0/src/Init/Data/PersistentHashMap/Basic.lean

@@ -0,0 +1,293 @@
+/-
+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 Init.Data.Array
+import Init.Data.Hashable
+universes u v w w'
+
+namespace PersistentHashMap
+
+inductive Entry (α : Type u) (β : Type v) (σ : Type w)
+| entry {} (key : α) (val : β) : Entry
+| ref   {} (node : σ) : Entry
+| null  {} : Entry
+
+instance Entry.inhabited {α β σ} : Inhabited (Entry α β σ) := ⟨Entry.null⟩
+
+inductive Node (α : Type u) (β : Type v) : Type (max u v)
+| entries   (es : Array (Entry α β Node)) : Node
+| collision (ks : Array α) (vs : Array β) (h : ks.size = vs.size) : Node
+
+instance Node.inhabited {α β} : Inhabited (Node α β) := ⟨Node.entries #[]⟩
+
+abbrev shift         : USize  := 5
+abbrev branching     : USize  := USize.ofNat (2 ^ shift.toNat)
+abbrev maxDepth      : USize  := 7
+abbrev maxCollisions : Nat    := 4
+
+def mkEmptyEntriesArray {α β} : Array (Entry α β (Node α β)) :=
+(Array.mkArray PersistentHashMap.branching.toNat PersistentHashMap.Entry.null)
+
+end PersistentHashMap
+
+structure PersistentHashMap (α : Type u) (β : Type v) [Hashable α] [HasBeq α] :=
+(root    : PersistentHashMap.Node α β := PersistentHashMap.Node.entries PersistentHashMap.mkEmptyEntriesArray)
+(size    : Nat                        := 0)
+
+abbrev PHashMap (α : Type u) (β : Type v) [Hashable α] [HasBeq α] := PersistentHashMap α β
+
+namespace PersistentHashMap
+variables {α : Type u} {β : Type v}
+
+def empty [Hashable α] [HasBeq α] : PersistentHashMap α β := {}
+
+instance [Hashable α] [HasBeq α] : HasEmptyc (PersistentHashMap α β) := ⟨empty⟩
+
+def isEmpty [Hashable α] [HasBeq α] (m : PersistentHashMap α β) : Bool :=
+m.size == 0
+
+instance [Hashable α] [HasBeq α] : Inhabited (PersistentHashMap α β) := ⟨{}⟩
+
+def mkEmptyEntries {α β} : Node α β :=
+Node.entries mkEmptyEntriesArray
+
+abbrev mul2Shift (i : USize) (shift : USize) : USize := i.shiftLeft shift
+abbrev div2Shift (i : USize) (shift : USize) : USize := i.shiftRight shift
+abbrev mod2Shift (i : USize) (shift : USize) : USize := USize.land i ((USize.shiftLeft 1 shift) - 1)
+
+inductive IsCollisionNode : Node α β → Prop
+| mk (keys : Array α) (vals : Array β) (h : keys.size = vals.size) : IsCollisionNode (Node.collision keys vals h)
+
+abbrev CollisionNode (α β) := { n : Node α β // IsCollisionNode n }
+
+inductive IsEntriesNode : Node α β → Prop
+| mk (entries : Array (Entry α β (Node α β))) : IsEntriesNode (Node.entries entries)
+
+abbrev EntriesNode (α β) := { n : Node α β // IsEntriesNode n }
+
+private theorem setSizeEq {ks : Array α} {vs : Array β} (h : ks.size = vs.size) (i : Fin ks.size) (j : Fin vs.size) (k : α) (v : β)
+                           : (ks.set i k).size = (vs.set j v).size :=
+have h₁ : (ks.set i k).size = ks.size from Array.szFSetEq _ _ _;
+have h₂ : (vs.set j v).size = vs.size from Array.szFSetEq _ _ _;
+(h₁.trans h).trans h₂.symm
+
+private theorem pushSizeEq {ks : Array α} {vs : Array β} (h : ks.size = vs.size) (k : α) (v : β) : (ks.push k).size = (vs.push v).size :=
+have h₁ : (ks.push k).size = ks.size + 1 from Array.szPushEq _ _;
+have h₂ : (vs.push v).size = vs.size + 1 from Array.szPushEq _ _;
+have h₃ : ks.size + 1 = vs.size + 1      from h ▸ rfl;
+(h₁.trans h₃).trans h₂.symm
+
+partial def insertAtCollisionNodeAux [HasBeq α] : CollisionNode α β → Nat → α → β → CollisionNode α β
+| n@⟨Node.collision keys vals heq, _⟩, i, k, v =>
+  if h : i < keys.size then
+    let idx : Fin keys.size := ⟨i, h⟩;
+    let k' := keys.get idx;
+    if k == k' then
+       let j : Fin vals.size := ⟨i, heq ▸ h⟩;
+       ⟨Node.collision (keys.set idx k) (vals.set j v) (setSizeEq heq idx j k v), IsCollisionNode.mk _ _ _⟩
+    else insertAtCollisionNodeAux n (i+1) k v
+  else
+    ⟨Node.collision (keys.push k) (vals.push v) (pushSizeEq heq k v), IsCollisionNode.mk _ _ _⟩
+| ⟨Node.entries _, h⟩, _, _, _ => False.elim (nomatch h)
+
+def insertAtCollisionNode [HasBeq α] : CollisionNode α β → α → β → CollisionNode α β :=
+fun n k v => insertAtCollisionNodeAux n 0 k v
+
+def getCollisionNodeSize : CollisionNode α β → Nat
+| ⟨Node.collision keys _ _, _⟩ => keys.size
+| ⟨Node.entries _, h⟩          => False.elim (nomatch h)
+
+def mkCollisionNode (k₁ : α) (v₁ : β) (k₂ : α) (v₂ : β) : Node α β :=
+let ks : Array α := Array.mkEmpty maxCollisions;
+let ks := (ks.push k₁).push k₂;
+let vs : Array β := Array.mkEmpty maxCollisions;
+let vs := (vs.push v₁).push v₂;
+Node.collision ks vs rfl
+
+partial def insertAux [HasBeq α] [Hashable α] : Node α β → USize → USize → α → β → Node α β
+| Node.collision keys vals heq, _, depth, k, v =>
+  let newNode := insertAtCollisionNode ⟨Node.collision keys vals heq, IsCollisionNode.mk _ _ _⟩ k v;
+  if depth >= maxDepth || getCollisionNodeSize newNode < maxCollisions then newNode.val
+  else match newNode with
+    | ⟨Node.entries _, h⟩ => False.elim (nomatch h)
+    | ⟨Node.collision keys vals heq, _⟩ =>
+      let entries : Node α β := mkEmptyEntries;
+      keys.iterate entries $ fun i k entries =>
+        let v := vals.get ⟨i.val, heq ▸ i.isLt⟩;
+        let h := hash k;
+        -- dbgTrace ("toCollision " ++ toString i ++ ", h: " ++ toString h ++ ", depth: " ++ toString depth ++ ", h': " ++
+        --          toString (div2Shift h (shift * (depth - 1)))) $ fun _ =>
+        let h := div2Shift h (shift * (depth - 1));
+        insertAux entries h depth k v
+| Node.entries entries, h, depth, k, v =>
+  let j     := (mod2Shift h shift).toNat;
+  Node.entries $ entries.modify j $ fun entry =>
+    match entry with
+    | Entry.null        => Entry.entry k v
+    | Entry.ref node    => Entry.ref $ insertAux node (div2Shift h shift) (depth+1) k v
+    | Entry.entry k' v' =>
+      if k == k' then Entry.entry k v
+      else Entry.ref $ mkCollisionNode k' v' k v
+
+def insert [HasBeq α] [Hashable α] : PersistentHashMap α β → α → β → PersistentHashMap α β
+| { root := n, size := sz }, k, v => { root := insertAux n (hash k) 1 k v, size := sz + 1 }
+
+partial def findAtAux [HasBeq α] (keys : Array α) (vals : Array β) (heq : keys.size = vals.size) : Nat → α → Option β
+| i, k =>
+  if h : i < keys.size then
+    let k' := keys.get ⟨i, h⟩;
+    if k == k' then some (vals.get ⟨i, heq ▸ h⟩)
+    else findAtAux (i+1) k
+  else none
+
+partial def findAux [HasBeq α] : Node α β → USize → α → Option β
+| Node.entries entries, h, k =>
+  let j     := (mod2Shift h shift).toNat;
+  match entries.get! j with
+  | Entry.null       => none
+  | Entry.ref node   => findAux node (div2Shift h shift) k
+  | Entry.entry k' v => if k == k' then some v else none
+| Node.collision keys vals heq, _, k => findAtAux keys vals heq 0 k
+
+def find [HasBeq α] [Hashable α] : PersistentHashMap α β → α → Option β
+| { root := n, .. }, k => findAux n (hash k) k
+
+@[inline] def findD [HasBeq α] [Hashable α] (m : PersistentHashMap α β) (a : α) (b₀ : β) : β :=
+(m.find a).getD b₀
+
+@[inline] def find! [HasBeq α] [Hashable α] [Inhabited β] (m : PersistentHashMap α β) (a : α) : β :=
+match m.find a with
+| some b => b
+| none   => panic! "key is not in the map"
+
+partial def containsAtAux [HasBeq α] (keys : Array α) (vals : Array β) (heq : keys.size = vals.size) : Nat → α → Bool
+| i, k =>
+  if h : i < keys.size then
+    let k' := keys.get ⟨i, h⟩;
+    if k == k' then true
+    else containsAtAux (i+1) k
+  else false
+
+partial def containsAux [HasBeq α] : Node α β → USize → α → Bool
+| Node.entries entries, h, k =>
+  let j     := (mod2Shift h shift).toNat;
+  match entries.get! j with
+  | Entry.null       => false
+  | Entry.ref node   => containsAux node (div2Shift h shift) k
+  | Entry.entry k' v => k == k'
+| Node.collision keys vals heq, _, k => containsAtAux keys vals heq 0 k
+
+def contains [HasBeq α] [Hashable α] : PersistentHashMap α β → α → Bool
+| { root := n, .. }, k => containsAux n (hash k) k
+
+partial def isUnaryEntries (a : Array (Entry α β (Node α β))) : Nat → Option (α × β) → Option (α × β)
+| i, acc =>
+  if h : i < a.size then
+    match a.get ⟨i, h⟩ with
+    | Entry.null      => isUnaryEntries (i+1) acc
+    | Entry.ref _     => none
+    | Entry.entry k v =>
+      match acc with
+      | none   => isUnaryEntries (i+1) (some (k, v))
+      | some _ => none
+  else acc
+
+def isUnaryNode : Node α β → Option (α × β)
+| Node.entries entries         => isUnaryEntries entries 0 none
+| Node.collision keys vals heq =>
+  if h : 1 = keys.size then
+    have 0 < keys.size from h ▸ (Nat.zeroLtSucc _);
+    some (keys.get ⟨0, this⟩, vals.get ⟨0, heq ▸ this⟩)
+  else
+    none
+
+partial def eraseAux [HasBeq α] : Node α β → USize → α → Node α β × Bool
+| n@(Node.collision keys vals heq), _, k =>
+  match keys.indexOf k with
+  | some idx =>
+    let ⟨keys', keq⟩ := keys.eraseIdx' idx;
+    let ⟨vals', veq⟩ := vals.eraseIdx' (Eq.rec idx heq);
+    have keys.size - 1 = vals.size - 1 from heq ▸ rfl;
+    (Node.collision keys' vals' (keq.trans (this.trans veq.symm)), true)
+  | none     => (n, false)
+| n@(Node.entries entries), h, k =>
+  let j       := (mod2Shift h shift).toNat;
+  let entry   := entries.get! j;
+  match entry with
+  | Entry.null       => (n, false)
+  | Entry.entry k' v =>
+    if k == k' then (Node.entries (entries.set! j Entry.null), true) else (n, false)
+  | Entry.ref node   =>
+    let entries := entries.set! j Entry.null;
+    let (newNode, deleted) := eraseAux node (div2Shift h shift) k;
+    if !deleted then (n, false)
+    else match isUnaryNode newNode with
+      | none        => (Node.entries (entries.set! j (Entry.ref newNode)), true)
+      | some (k, v) => (Node.entries (entries.set! j (Entry.entry k v)), true)
+
+def erase [HasBeq α] [Hashable α] : PersistentHashMap α β → α → PersistentHashMap α β
+| { root := n, size := sz }, k =>
+  let h := hash k;
+  let (n, del) := eraseAux n h k;
+  { root := n, size := if del then sz - 1 else sz }
+
+section
+variables {m : Type w → Type w'} [Monad m]
+variables {σ : Type w}
+
+@[specialize] partial def foldlMAux (f : σ → α → β → m σ) : Node α β → σ → m σ
+| Node.collision keys vals heq, acc => keys.iterateM acc $ fun i k acc => f acc k (vals.get ⟨i.val, heq ▸ i.isLt⟩)
+| Node.entries entries, acc => entries.foldlM (fun acc entry =>
+  match entry with
+  | Entry.null      => pure acc
+  | Entry.entry k v => f acc k v
+  | Entry.ref node  => foldlMAux node acc)
+  acc
+
+@[specialize] def foldlM [Hashable α] [HasBeq α] (map : PersistentHashMap α β) (f : σ → α → β → m σ) (acc : σ) : m σ :=
+foldlMAux f map.root acc
+
+@[specialize] def foldl [Hashable α] [HasBeq α] (map : PersistentHashMap α β) (f : σ → α → β → σ) (acc : σ) : σ :=
+Id.run $ map.foldlM f acc
+end
+
+def toList [Hashable α] [HasBeq α] (m : PersistentHashMap α β) : List (α × β) :=
+m.foldl (fun ps k v => (k, v) :: ps) []
+
+structure Stats :=
+(numNodes      : Nat := 0)
+(numNull       : Nat := 0)
+(numCollisions : Nat := 0)
+(maxDepth      : Nat := 0)
+
+partial def collectStats : Node α β → Stats → Nat → Stats
+| Node.collision keys _ _, stats, depth =>
+  { numNodes      := stats.numNodes + 1,
+    numCollisions := stats.numCollisions + keys.size - 1,
+    maxDepth      := Nat.max stats.maxDepth depth,
+    .. stats }
+| Node.entries entries, stats, depth =>
+  let stats :=
+    { numNodes      := stats.numNodes + 1,
+      maxDepth      := Nat.max stats.maxDepth depth,
+      .. stats };
+  entries.foldl (fun stats entry =>
+    match entry with
+    | Entry.null      => { numNull := stats.numNull + 1, .. stats }
+    | Entry.ref node  => collectStats node stats (depth + 1)
+    | Entry.entry _ _ => stats)
+    stats
+
+def stats [Hashable α] [HasBeq α] (m : PersistentHashMap α β) : Stats :=
+collectStats m.root {} 1
+
+def Stats.toString (s : Stats) : String :=
+"{ nodes := " ++  toString  s.numNodes ++ ", null := " ++ toString s.numNull ++
+", collisions := " ++ toString s.numCollisions ++ ", depth := " ++ toString s.maxDepth ++ "}"
+
+instance : HasToString Stats := ⟨Stats.toString⟩
+
+end PersistentHashMap

stage0/src/Init/Data/PersistentHashSet.lean

@@ -0,0 +1,50 @@
+/-
+Copyright (c) 2019 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Author: Leonardo de Moura
+-/
+prelude
+import Init.Data.PersistentHashMap
+
+universes u v
+
+structure PersistentHashSet (α : Type u) [HasBeq α] [Hashable α] :=
+(set : PersistentHashMap α Unit)
+
+abbrev PHashSet (α : Type u) [HasBeq α] [Hashable α] := PersistentHashSet α
+
+namespace PersistentHashSet
+
+variables {α : Type u} [HasBeq α] [Hashable α]
+
+@[inline] def isEmpty (s : PersistentHashSet α) : Bool :=
+s.set.isEmpty
+
+@[inline] def empty : PersistentHashSet α :=
+{ set := PersistentHashMap.empty }
+
+instance : Inhabited (PersistentHashSet α) :=
+⟨empty⟩
+
+instance : HasEmptyc (PersistentHashSet α) :=
+⟨empty⟩
+
+@[inline] def insert (s : PersistentHashSet α) (a : α) : PersistentHashSet α :=
+{ set := s.set.insert a () }
+
+@[inline] def erase (s : PersistentHashSet α) (a : α) : PersistentHashSet α :=
+{ set := s.set.erase a }
+
+@[inline] def contains (s : PersistentHashSet α) (a : α) : Bool :=
+s.set.contains a
+
+@[inline] def size (s : PersistentHashSet α) : Nat :=
+s.set.size
+
+@[inline] def foldM {β : Type v} {m : Type v → Type v} [Monad m] (f : β → α → m β) (d : β) (s : PersistentHashSet α) : m β :=
+s.set.foldlM (fun d a _ => f d a) d
+
+@[inline] def fold {β : Type v} (f : β → α → β) (d : β) (s : PersistentHashSet α) : β :=
+Id.run $ s.foldM f d
+
+end PersistentHashSet

stage0/src/Init/Data/Queue.lean

@@ -0,0 +1,7 @@
+/-
+Copyright (c) 2019 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Daniel Selsam
+-/
+prelude
+import Init.Data.Queue.Basic

stage0/src/Init/Data/Queue/Basic.lean

@@ -0,0 +1,41 @@
+/-
+Copyright (c) 2019 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Daniel Selsam
+
+Simple queue implemented using two lists.
+Note: this is only a temporary placeholder.
+-/
+prelude
+import Init.Data.Array
+import Init.Data.Int
+universes u v w
+
+structure Queue (α : Type u) :=
+(eList dList : List α := [])
+
+namespace Queue
+
+variable {α : Type u}
+
+def empty : Queue α :=
+{ eList := [], dList := [] }
+
+def isEmpty (q : Queue α) : Bool :=
+q.dList.isEmpty && q.eList.isEmpty
+
+def enqueue (v : α) (q : Queue α) : Queue α :=
+{ eList := v::q.eList .. q }
+
+def enqueueAll (vs : List α) (q : Queue α) : Queue α :=
+{ eList := vs ++ q.eList .. q }
+
+def dequeue? (q : Queue α) : Option (α × Queue α) :=
+match q.dList with
+| d::ds => some (d, { dList := ds, .. q })
+| []    =>
+  match q.eList.reverse with
+  | []    => none
+  | d::ds => some (d, { eList := [], dList := ds })
+
+end Queue

stage0/src/Init/Data/RBMap.lean

@@ -0,0 +1,8 @@
+/-
+Copyright (c) 2017 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.RBMap.Basic
+import Init.Data.RBMap.BasicAux

stage0/src/Init/Data/RBMap/Basic.lean

@@ -0,0 +1,309 @@
+/-
+Copyright (c) 2017 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.Repr
+import Init.Data.Option.Basic
+
+universes u v w w'
+
+inductive Rbcolor
+| red | black
+
+inductive RBNode (α : Type u) (β : α → Type v)
+| leaf  {}                                                                            : RBNode
+| node  (color : Rbcolor) (lchild : RBNode) (key : α) (val : β key) (rchild : RBNode) : RBNode
+
+namespace RBNode
+variables {α : Type u} {β : α → Type v} {σ : Type w}
+
+open Rbcolor Nat
+
+def depth (f : Nat → Nat → Nat) : RBNode α β → Nat
+| leaf           => 0
+| node _ l _ _ r => succ (f (depth l) (depth r))
+
+protected def min : RBNode α β → Option (Sigma (fun k => β k))
+| leaf              => none
+| node _ leaf k v _ => some ⟨k, v⟩
+| node _ l k v _    => min l
+
+protected def max : RBNode α β → Option (Sigma (fun k => β k))
+| leaf              => none
+| node _ _ k v leaf => some ⟨k, v⟩
+| node _ _ k v r    => max r
+
+@[specialize] def fold (f : σ → ∀ (k : α), β k → σ) : σ → RBNode α β → σ
+| b, leaf           => b
+| b, node _ l k v r => fold (f (fold b l) k v) r
+
+@[specialize] def mfold {m : Type w → Type w'} [Monad m] (f : σ → ∀ (k : α), β k → m σ) : σ → RBNode α β → m σ
+| b, leaf           => pure b
+| b, node _ l k v r => do
+  b ← mfold b l;
+  b ← f b k v;
+  mfold b r
+
+@[specialize] def revFold (f : σ → ∀ (k : α), β k → σ) : σ → RBNode α β → σ
+| b, leaf           => b
+| b, node _ l k v r => revFold (f (revFold b r) k v) l
+
+@[specialize] def all (p : ∀ k, β k → Bool) : RBNode α β → Bool
+| leaf           => true
+| node _ l k v r => p k v && all l && all r
+
+@[specialize] def any (p : ∀ k, β k → Bool) : RBNode α β → Bool
+| leaf             => false
+| node _ l k v r => p k v || any l || any r
+
+def singleton (k : α) (v : β k) : RBNode α β :=
+node red leaf k v leaf
+
+@[inline] def balance1 : ∀ a, β a → RBNode α β → RBNode α β → RBNode α β
+| kv, vv, t, node _ (node red l kx vx r₁) ky vy r₂   => node red (node black l kx vx r₁) ky vy (node black r₂ kv vv t)
+| kv, vv, t, node _ l₁ ky vy (node red l₂ kx vx r)   => node red (node black l₁ ky vy l₂) kx vx (node black r kv vv t)
+| kv, vv, t, node _ l  ky vy r                       => node black (node red l ky vy r) kv vv t
+| _,  _,  _,                                       _ => leaf -- unreachable
+
+@[inline] def balance2 : RBNode α β → ∀ a, β a → RBNode α β → RBNode α β
+| t, kv, vv, node _ (node red l kx₁ vx₁ r₁) ky vy r₂  => node red (node black t kv vv l) kx₁ vx₁ (node black r₁ ky vy r₂)
+| t, kv, vv, node _ l₁ ky vy (node red l₂ kx₂ vx₂ r₂) => node red (node black t kv vv l₁) ky vy (node black l₂ kx₂ vx₂ r₂)
+| t, kv, vv, node _ l ky vy r                         => node black t kv vv (node red l ky vy r)
+| _, _,  _,                                        _  => leaf -- unreachable
+
+def isRed : RBNode α β → Bool
+| node red _ _ _ _ => true
+| _                => false
+
+def isBlack : RBNode α β → Bool
+| node black _ _ _ _ => true
+| _                  => false
+
+section Insert
+
+variables (lt : α → α → Bool)
+
+@[specialize] def ins : RBNode α β → ∀ k, β k → RBNode α β
+| leaf,               kx, vx => node red leaf kx vx leaf
+| node red a ky vy b, kx, vx =>
+   if lt kx ky then node red (ins a kx vx) ky vy b
+   else if lt ky kx then node red a ky vy (ins b kx vx)
+   else node red a kx vx b
+| node black a ky vy b, kx, vx =>
+    if lt kx ky then
+      if isRed a then balance1 ky vy b (ins a kx vx)
+      else node black (ins a kx vx) ky vy b
+    else if lt ky kx then
+      if isRed b then balance2 a ky vy (ins b kx vx)
+      else node black a ky vy (ins b kx vx)
+    else
+       node black a kx vx b
+
+def setBlack : RBNode α β → RBNode α β
+| node _ l k v r => node black l k v r
+| e              => e
+
+@[specialize] def insert (t : RBNode α β) (k : α) (v : β k) : RBNode α β :=
+if isRed t then setBlack (ins lt t k v)
+else ins lt t k v
+
+end Insert
+
+def balance₃ : RBNode α β → ∀ k, β k → RBNode α β → RBNode α β
+| node red (node red a kx vx b) ky vy c,   k, v, d => node red (node black a kx vx b) ky vy (node black c k v d)
+| node red a kx vx (node red b ky vy c),   k, v, d => node red (node black a kx vx b) ky vy (node black c k v d)
+| a, k, v, node red b ky vy (node red c kz vz d)   => node red (node black a k v b) ky vy (node black c kz vz d)
+| a, k, v, node red (node red b ky vy c) kz vz d   => node red (node black a k v b) ky vy (node black c kz vz d)
+| l, k, v, r                                       => node black l k v r
+
+def setRed : RBNode α β → RBNode α β
+| node _ a k v b => node red a k v b
+| e              => e
+
+def balLeft : RBNode α β → ∀ k, β k → RBNode α β → RBNode α β
+| node red a kx vx b,   k, v, r                    => node red (node black a kx vx b) k v r
+| l, k, v, node black a ky vy b                    => balance₃ l k v (node red a ky vy b)
+| l, k, v, node red (node black a ky vy b) kz vz c => node red (node black l k v a) ky vy (balance₃ b kz vz (setRed c))
+| l, k, v, r                                       => node red l k v r -- unreachable
+
+def balRight (l : RBNode α β) (k : α) (v : β k) (r : RBNode α β) : RBNode α β :=
+match r with
+| (node red b ky vy c) => node red l k v (node black b ky vy c)
+| _ => match l with
+  | node black a kx vx b                    => balance₃ (node red a kx vx b) k v r
+  | node red a kx vx (node black b ky vy c) => node red (balance₃ (setRed a) kx vx b) ky vy (node black c k v r)
+  | _                                       => node red l k v r -- unreachable
+
+-- TODO: use wellfounded recursion
+partial def appendTrees :  RBNode α β → RBNode α β → RBNode α β
+| leaf, x => x
+| x, leaf => x
+| node red a kx vx b,   node red c ky vy d   =>
+  match appendTrees b c with
+  | node red b' kz vz c' => node red (node red a kx vx b') kz vz (node red c' ky vy d)
+  | bc                   => node red a kx vx (node red bc ky vy d)
+| node black a kx vx b,   node black c ky vy d   =>
+   match appendTrees b c with
+   | node red b' kz vz c' => node red (node black a kx vx b') kz vz (node black c' ky vy d)
+   | bc                   => balLeft a kx vx (node black bc ky vy d)
+ | a, node red b kx vx c   => node red (appendTrees a b) kx vx c
+ | node red a kx vx b,   c => node red a kx vx (appendTrees b c)
+
+section Erase
+
+variables (lt : α → α → Bool)
+
+@[specialize] def del (x : α) : RBNode α β → RBNode α β
+| leaf           => leaf
+| node _ a y v b =>
+  if lt x y then
+    if a.isBlack then balLeft (del a) y v b
+    else node red (del a) y v b
+  else if lt y x then
+    if b.isBlack then balRight a y v (del b)
+    else node red a y v (del b)
+  else appendTrees a b
+
+@[specialize] def erase (x : α) (t : RBNode α β) : RBNode α β :=
+let t := del lt x t;
+t.setBlack
+
+end Erase
+
+section Membership
+variable (lt : α → α → Bool)
+
+@[specialize] def findCore : RBNode α β → ∀ (k : α), Option (Sigma (fun k => β k))
+| leaf,             x => none
+| node _ a ky vy b, x =>
+   if lt x ky then findCore a x
+   else if lt ky x then findCore b x
+   else some ⟨ky, vy⟩
+
+@[specialize] def find {β : Type v} : RBNode α (fun _ => β) → α → Option β
+| leaf,             x => none
+| node _ a ky vy b, x =>
+  if lt x ky then find a x
+  else if lt ky x then find b x
+  else some vy
+
+@[specialize] def lowerBound : RBNode α β → α → Option (Sigma β) → Option (Sigma β)
+| leaf,             x, lb => lb
+| node _ a ky vy b, x, lb =>
+  if lt x ky then lowerBound a x lb
+  else if lt ky x then lowerBound b x (some ⟨ky, vy⟩)
+  else some ⟨ky, vy⟩
+
+end Membership
+
+inductive WellFormed (lt : α → α → Bool) : RBNode α β → Prop
+| leafWff : WellFormed leaf
+| insertWff {n n' : RBNode α β} {k : α} {v : β k} : WellFormed n → n' = insert lt n k v → WellFormed n'
+| eraseWff {n n' : RBNode α β} {k : α} : WellFormed n → n' = erase lt k n → WellFormed n'
+
+end RBNode
+
+open RBNode
+
+/- TODO(Leo): define dRBMap -/
+
+def RBMap (α : Type u) (β : Type v) (lt : α → α → Bool) : Type (max u v) :=
+{t : RBNode α (fun _ => β) // t.WellFormed lt }
+
+@[inline] def mkRBMap (α : Type u) (β : Type v) (lt : α → α → Bool) : RBMap α β lt :=
+⟨leaf, WellFormed.leafWff lt⟩
+
+@[inline] def RBMap.empty {α : Type u} {β : Type v} {lt : α → α → Bool} : RBMap α β lt :=
+mkRBMap _ _ _
+
+instance (α : Type u) (β : Type v) (lt : α → α → Bool) : HasEmptyc (RBMap α β lt) :=
+⟨RBMap.empty⟩
+
+namespace RBMap
+variables {α : Type u} {β : Type v} {σ : Type w} {lt : α → α → Bool}
+
+def depth (f : Nat → Nat → Nat) (t : RBMap α β lt) : Nat :=
+t.val.depth f
+
+@[inline] def fold (f : σ → α → β → σ) : σ → RBMap α β lt → σ
+| b, ⟨t, _⟩ => t.fold f b
+
+@[inline] def revFold (f : σ → α → β → σ) : σ → RBMap α β lt → σ
+| b, ⟨t, _⟩ => t.revFold f b
+
+@[inline] def mfold {m : Type w → Type w'} [Monad m] (f : σ → α → β → m σ) : σ → RBMap α β lt → m σ
+| b, ⟨t, _⟩ => t.mfold f b
+
+@[inline] def mfor {m : Type w → Type w'} [Monad m] (f : α → β → m σ) (t : RBMap α β lt) : m PUnit :=
+t.mfold (fun _ k v =>  f k v *> pure ⟨⟩) ⟨⟩
+
+@[inline] def isEmpty : RBMap α β lt → Bool
+| ⟨leaf, _⟩ => true
+| _         => false
+
+@[specialize] def toList : RBMap α β lt → List (α × β)
+| ⟨t, _⟩ => t.revFold (fun ps k v => (k, v)::ps) []
+
+@[inline] protected def min : RBMap α β lt → Option (α × β)
+| ⟨t, _⟩ =>
+  match t.min with
+  | some ⟨k, v⟩ => some (k, v)
+  | none        => none
+
+@[inline] protected def max : RBMap α β lt → Option (α × β)
+| ⟨t, _⟩ =>
+  match t.max with
+  | some ⟨k, v⟩ => some (k, v)
+  | none        => none
+
+instance [HasRepr α] [HasRepr β] : HasRepr (RBMap α β lt) :=
+⟨fun t => "rbmapOf " ++ repr t.toList⟩
+
+@[inline] def insert : RBMap α β lt → α → β → RBMap α β lt
+| ⟨t, w⟩, k, v => ⟨t.insert lt k v, WellFormed.insertWff w rfl⟩
+
+@[inline] def erase : RBMap α β lt → α → RBMap α β lt
+| ⟨t, w⟩, k => ⟨t.erase lt k, WellFormed.eraseWff w rfl⟩
+
+@[specialize] def ofList : List (α × β) → RBMap α β lt
+| []        => mkRBMap _ _ _
+| ⟨k,v⟩::xs => (ofList xs).insert k v
+
+@[inline] def findCore : RBMap α β lt → α → Option (Sigma (fun (k : α) => β))
+| ⟨t, _⟩, x => t.findCore lt x
+
+@[inline] def find : RBMap α β lt → α → Option β
+| ⟨t, _⟩, x => t.find lt x
+
+@[inline] def findD (t : RBMap α β lt) (k : α) (v₀ : β) : β :=
+(t.find k).getD v₀
+
+/-- (lowerBound k) retrieves the kv pair of the largest key smaller than or equal to `k`,
+    if it exists. -/
+@[inline] def lowerBound : RBMap α β lt → α → Option (Sigma (fun (k : α) => β))
+| ⟨t, _⟩, x => t.lowerBound lt x none
+
+@[inline] def contains (t : RBMap α β lt) (a : α) : Bool :=
+(t.find a).isSome
+
+@[inline] def fromList (l : List (α × β)) (lt : α → α → Bool) : RBMap α β lt :=
+l.foldl (fun r p => r.insert p.1 p.2) (mkRBMap α β lt)
+
+@[inline] def all : RBMap α β lt → (α → β → Bool) → Bool
+| ⟨t, _⟩, p => t.all p
+
+@[inline] def any : RBMap α β lt → (α → β → Bool) → Bool
+| ⟨t, _⟩, p => t.any p
+
+def size (m : RBMap α β lt) : Nat :=
+m.fold (fun sz _ _ => sz+1) 0
+
+def maxDepth (t : RBMap α β lt) : Nat :=
+t.val.depth Nat.max
+
+end RBMap
+
+def rbmapOf {α : Type u} {β : Type v} (l : List (α × β)) (lt : α → α → Bool) : RBMap α β lt :=
+RBMap.fromList l lt

stage0/src/Init/Data/RBMap/BasicAux.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 Init.Data.RBMap.Basic
+import Init.Util
+
+universes u v w w'
+
+namespace RBMap
+variables {α : Type u} {β : Type v} {lt : α → α → Bool}
+
+@[inline] def min! [Inhabited α] [Inhabited β] (t : RBMap α β lt) : α × β :=
+match t.min with
+| some p => p
+| none   => panic! "map is empty"
+
+@[inline] def max! [Inhabited α] [Inhabited β] (t : RBMap α β lt) : α × β :=
+match t.max with
+| some p => p
+| none   => panic! "map is empty"
+
+@[inline] def find! [Inhabited β] (t : RBMap α β lt) (k : α) : β :=
+match t.find k with
+| some b => b
+| none   => panic! "key is not in the map"
+
+end RBMap

stage0/src/Init/Data/RBTree.lean

@@ -0,0 +1,7 @@
+/-
+Copyright (c) 2017 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.RBTree.Basic

stage0/src/Init/Data/RBTree/Basic.lean

@@ -0,0 +1,95 @@
+/-
+Copyright (c) 2017 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.RBMap.Basic
+universes u v w
+
+def RBTree (α : Type u) (lt : α → α → Bool) : Type u :=
+RBMap α Unit lt
+
+@[inline] def mkRBTree (α : Type u) (lt : α → α → Bool) : RBTree α lt :=
+mkRBMap α Unit lt
+
+instance (α : Type u) (lt : α → α → Bool) : HasEmptyc (RBTree α lt) :=
+⟨mkRBTree α lt⟩
+
+namespace RBTree
+variables {α : Type u} {β : Type v} {lt : α → α → Bool}
+
+@[inline] def empty : RBTree α lt :=
+RBMap.empty
+
+@[inline] def depth (f : Nat → Nat → Nat) (t : RBTree α lt) : Nat :=
+RBMap.depth f t
+
+@[inline] def fold (f : β → α → β) (b : β) (t : RBTree α lt) : β :=
+RBMap.fold (fun r a _ => f r a) b t
+
+@[inline] def revFold (f : β → α → β) (b : β) (t : RBTree α lt) : β :=
+RBMap.revFold (fun r a _ => f r a) b t
+
+@[inline] def mfold {m : Type v → Type w} [Monad m] (f : β → α → m β) (b : β) (t : RBTree α lt) : m β :=
+RBMap.mfold (fun r a _ => f r a) b t
+
+@[inline] def mfor {m : Type v → Type w} [Monad m] (f : α → m β) (t : RBTree α lt) : m PUnit :=
+t.mfold (fun _ a => f a *> pure ⟨⟩) ⟨⟩
+
+@[inline] def isEmpty (t : RBTree α lt) : Bool :=
+RBMap.isEmpty t
+
+@[specialize] def toList (t : RBTree α lt) : List α :=
+t.revFold (fun as a => a::as) []
+
+@[inline] protected def min (t : RBTree α lt) : Option α :=
+match RBMap.min t with
+| some ⟨a, _⟩ => some a
+| none        => none
+
+@[inline] protected def max (t : RBTree α lt) : Option α :=
+match RBMap.max t with
+| some ⟨a, _⟩ => some a
+| none        => none
+
+instance [HasRepr α] : HasRepr (RBTree α lt) :=
+⟨fun t => "rbtreeOf " ++ repr t.toList⟩
+
+@[inline] def insert (t : RBTree α lt) (a : α) : RBTree α lt :=
+RBMap.insert t a ()
+
+@[inline] def erase (t : RBTree α lt) (a : α) : RBTree α lt :=
+RBMap.erase t a
+
+@[specialize] def ofList : List α → RBTree α lt
+| []    => mkRBTree _ _
+| x::xs => (ofList xs).insert x
+
+@[inline] def find (t : RBTree α lt) (a : α) : Option α :=
+match RBMap.findCore t a with
+| some ⟨a, _⟩ => some a
+| none        => none
+
+@[inline] def contains (t : RBTree α lt) (a : α) : Bool :=
+(t.find a).isSome
+
+def fromList (l : List α) (lt : α → α → Bool) : RBTree α lt :=
+l.foldl insert (mkRBTree α lt)
+
+@[inline] def all (t : RBTree α lt) (p : α → Bool) : Bool :=
+RBMap.all t (fun a _ => p a)
+
+@[inline] def any (t : RBTree α lt) (p : α → Bool) : Bool :=
+RBMap.any t (fun a _ => p a)
+
+def subset (t₁ t₂ : RBTree α lt) : Bool :=
+t₁.all $ fun a => (t₂.find a).toBool
+
+def seteq (t₁ t₂ : RBTree α lt) : Bool :=
+subset t₁ t₂ && subset t₂ t₁
+
+end RBTree
+
+def rbtreeOf {α : Type u} (l : List α) (lt : α → α → Bool) : RBTree α lt :=
+RBTree.fromList l lt

stage0/src/Init/Data/Random.lean

@@ -0,0 +1,122 @@
+/-
+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 Init.System.IO
+import Init.Data.Int
+universes u
+
+/-
+Basic random number generator support based on the one
+available on the Haskell library
+-/
+
+/- Interface for random number generators. -/
+class RandomGen (g : Type u) :=
+/- `range` returns the range of values returned by
+    the generator. -/
+(range : g → Nat × Nat)
+/- `next` operation returns a natural number that is uniformly distributed
+    the range returned by `range` (including both end points),
+   and a new generator. -/
+(next  : g → Nat × g)
+/-
+  The 'split' operation allows one to obtain two distinct random number
+  generators. This is very useful in functional programs (for example, when
+  passing a random number generator down to recursive calls). -/
+(split : g → g × g)
+
+/- "Standard" random number generator. -/
+structure StdGen :=
+(s1 : Nat) (s2 : Nat)
+
+def stdRange := (1, 2147483562)
+
+instance : HasRepr StdGen :=
+{ repr := fun ⟨s1, s2⟩ => "⟨" ++ toString s1 ++ ", " ++ toString s2 ++ "⟩" }
+
+def stdNext : StdGen → Nat × StdGen
+| ⟨s1, s2⟩ =>
+  let k    : Int := s1 / 53668;
+  let s1'  : Int := 40014 * ((s1 : Int) - k * 53668) - k * 12211;
+  let s1'' : Int := if s1' < 0 then s1' + 2147483563 else s1';
+  let k'   : Int := s2 / 52774;
+  let s2'  : Int := 40692 * ((s2 : Int) - k' * 52774) - k' * 3791;
+  let s2'' : Int := if s2' < 0 then s2' + 2147483399 else s2';
+  let z    : Int := s1'' - s2'';
+  let z'   : Int := if z < 1 then z + 2147483562 else z % 2147483562;
+  (z'.toNat, ⟨s1''.toNat, s2''.toNat⟩)
+
+def stdSplit : StdGen → StdGen × StdGen
+| g@⟨s1, s2⟩ =>
+  let newS1  := if s1 = 2147483562 then 1 else s1 + 1;
+  let newS2  := if s2 = 1          then 2147483398 else s2 - 1;
+  let newG   := (stdNext g).2;
+  let leftG  := StdGen.mk newS1 newG.2;
+  let rightG := StdGen.mk newG.1 newS2;
+  (leftG, rightG)
+
+instance : RandomGen StdGen :=
+{range  := fun _ => stdRange,
+ next   := stdNext,
+ split  := stdSplit}
+
+/-- Return a standard number generator. -/
+def mkStdGen (s : Nat := 0) : StdGen :=
+let q  := s / 2147483562;
+let s1 := s % 2147483562;
+let s2 := q % 2147483398;
+⟨s1 + 1, s2 + 1⟩
+
+/-
+Auxiliary function for randomNatVal.
+Generate random values until we exceed the target magnitude.
+`genLo` and `genMag` are the generator lower bound and magnitude.
+The parameter `r` is the "remaining" magnitude.
+-/
+private partial def randNatAux {gen : Type u} [RandomGen gen] (genLo genMag : Nat) : Nat → (Nat × gen) → Nat × gen
+| 0,        (v, g) => (v, g)
+| r'@(r+1), (v, g) =>
+  let (x, g') := RandomGen.next g;
+  let v'      := v*genMag + (x - genLo);
+  randNatAux (r' / genMag - 1) (v', g')
+
+/-- Generate a random natural number in the interval [lo, hi]. -/
+def randNat {gen : Type u} [RandomGen gen] (g : gen) (lo hi : Nat) : Nat × gen :=
+let lo'            := if lo > hi then hi else lo;
+let hi'            := if lo > hi then lo else hi;
+let (genLo, genHi) := RandomGen.range g;
+let genMag         := genHi - genLo + 1;
+    /-
+      Probabilities of the most likely and least likely result
+      will differ at most by a factor of (1 +- 1/q).  Assuming the RandomGen
+      is uniform, of course
+    -/
+let q       := 1000;
+let k       := hi' - lo' + 1;
+let tgtMag  := k * q;
+let (v, g') := randNatAux genLo genMag tgtMag (0, g);
+let v'      := lo' + (v % k);
+(v', g')
+
+/-- Generate a random Boolean. -/
+def randBool {gen : Type u} [RandomGen gen] (g : gen) : Bool × gen :=
+let (v, g') := randNat g 0 1;
+(v = 1, g')
+
+def IO.mkStdGenRef : IO (IO.Ref StdGen) :=
+IO.mkRef mkStdGen
+
+@[init IO.mkStdGenRef]
+constant IO.stdGenRef : IO.Ref StdGen := arbitrary _
+
+def IO.setRandSeed (n : Nat) : IO Unit :=
+IO.stdGenRef.set (mkStdGen n)
+
+def IO.rand (lo hi : Nat) : IO Nat :=
+do gen ← IO.stdGenRef.get;
+   let (r, gen) := randNat gen lo hi;
+   IO.stdGenRef.set gen;
+   pure r

stage0/src/Init/Data/Repr.lean

@@ -0,0 +1,145 @@
+/-
+Copyright (c) 2016 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Author: Leonardo de Moura
+-/
+prelude
+import Init.Data.String.Basic
+import Init.Data.UInt
+import Init.Data.Nat.Div
+open Sum Subtype Nat
+
+universes u v
+
+class HasRepr (α : Type u) :=
+(repr : α → String)
+
+export HasRepr (repr)
+
+-- This instance is needed because `id` is not reducible
+instance {α : Type u} [HasRepr α] : HasRepr (id α) :=
+inferInstanceAs (HasRepr α)
+
+instance : HasRepr Bool :=
+⟨fun b => cond b "true" "false"⟩
+
+instance {p : Prop} : HasRepr (Decidable p) :=
+⟨fun b => @ite p b _ "true" "false"⟩
+
+protected def List.reprAux {α : Type u} [HasRepr α] : Bool → List α → String
+| b,     []    => ""
+| true,  x::xs => repr x ++ List.reprAux false xs
+| false, x::xs => ", " ++ repr x ++ List.reprAux false xs
+
+protected def List.repr {α : Type u} [HasRepr α] : List α → String
+| []    => "[]"
+| x::xs => "[" ++ List.reprAux true (x::xs) ++ "]"
+
+instance {α : Type u} [HasRepr α] : HasRepr (List α) :=
+⟨List.repr⟩
+
+instance : HasRepr Unit :=
+⟨fun u => "()"⟩
+
+instance {α : Type u} [HasRepr α] : HasRepr (Option α) :=
+⟨fun o => match o with | none => "none" | (some a) => "(some " ++ repr a ++ ")"⟩
+
+instance {α : Type u} {β : Type v} [HasRepr α] [HasRepr β] : HasRepr (Sum α β) :=
+⟨fun s => match s with | (inl a) => "(inl " ++ repr a ++ ")" | (inr b) => "(inr " ++ repr b ++ ")"⟩
+
+instance {α : Type u} {β : Type v} [HasRepr α] [HasRepr β] : HasRepr (α × β) :=
+⟨fun ⟨a, b⟩ => "(" ++ repr a ++ ", " ++ repr b ++ ")"⟩
+
+instance {α : Type u} {β : α → Type v} [HasRepr α] [s : ∀ x, HasRepr (β x)] : HasRepr (Sigma β) :=
+⟨fun ⟨a, b⟩ => "⟨"  ++ repr a ++ ", " ++ repr b ++ "⟩"⟩
+
+instance {α : Type u} {p : α → Prop} [HasRepr α] : HasRepr (Subtype p) :=
+⟨fun s => repr (val s)⟩
+
+namespace Nat
+
+def digitChar (n : Nat) : Char :=
+if n = 0 then '0' else
+if n = 1 then '1' else
+if n = 2 then '2' else
+if n = 3 then '3' else
+if n = 4 then '4' else
+if n = 5 then '5' else
+if n = 6 then '6' else
+if n = 7 then '7' else
+if n = 8 then '8' else
+if n = 9 then '9' else
+if n = 0xa then 'a' else
+if n = 0xb then 'b' else
+if n = 0xc then 'c' else
+if n = 0xd then 'd' else
+if n = 0xe then 'e' else
+if n = 0xf then 'f' else
+'*'
+
+def toDigitsCore (base : Nat) : Nat → Nat → List Char → List Char
+| 0,      n, ds => ds
+| fuel+1, n, ds =>
+  let d  := digitChar $ n % base;
+  let n' := n / base;
+  if n' = 0 then d::ds
+  else toDigitsCore fuel n' (d::ds)
+
+def toDigits (base : Nat) (n : Nat) : List Char :=
+toDigitsCore base (n+1) n []
+
+protected def repr (n : Nat) : String :=
+(toDigits 10 n).asString
+
+end Nat
+
+instance : HasRepr Nat :=
+⟨Nat.repr⟩
+
+def hexDigitRepr (n : Nat) : String :=
+String.singleton $ Nat.digitChar n
+
+def charToHex (c : Char) : String :=
+let n  := Char.toNat c;
+let d2 := n / 16;
+let d1 := n % 16;
+hexDigitRepr d2 ++ hexDigitRepr d1
+
+def Char.quoteCore (c : Char) : String :=
+if       c = '\n' then "\\n"
+else if  c = '\t' then "\\t"
+else if  c = '\\' then "\\\\"
+else if  c = '\"' then "\\\""
+else if  c.toNat <= 31 ∨ c = '\x7f' then "\\x" ++ charToHex c
+else String.singleton c
+
+instance : HasRepr Char :=
+⟨fun c => "'" ++ Char.quoteCore c ++ "'"⟩
+
+def String.quoteAux : List Char → String
+| []    => ""
+| x::xs => Char.quoteCore x ++ String.quoteAux xs
+
+def String.quote (s : String) : String :=
+if s.isEmpty = true then "\"\""
+else "\"" ++ String.quoteAux s.toList ++ "\""
+
+instance : HasRepr String :=
+⟨String.quote⟩
+
+instance : HasRepr Substring :=
+⟨fun s => String.quote s.toString ++ ".toSubstring"⟩
+
+instance : HasRepr String.Iterator :=
+⟨fun ⟨s, pos⟩ => "(String.Iterator.mk " ++ repr s ++ " " ++ repr pos ++ ")"⟩
+
+instance (n : Nat) : HasRepr (Fin n) :=
+⟨fun f => repr (Fin.val f)⟩
+
+instance : HasRepr UInt16 := ⟨fun n => repr n.toNat⟩
+instance : HasRepr UInt32 := ⟨fun n => repr n.toNat⟩
+instance : HasRepr UInt64 := ⟨fun n => repr n.toNat⟩
+instance : HasRepr USize  := ⟨fun n => repr n.toNat⟩
+
+def Char.repr (c : Char) : String :=
+repr c

stage0/src/Init/Data/Stack.lean

@@ -0,0 +1,7 @@
+/-
+Copyright (c) 2019 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Daniel Selsam
+-/
+prelude
+import Init.Data.Stack.Basic

stage0/src/Init/Data/Stack/Basic.lean

@@ -0,0 +1,41 @@
+/-
+Copyright (c) 2019 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Daniel Selsam
+
+Simple stack API implemented using an array.
+-/
+prelude
+import Init.Data.Array
+import Init.Data.Int
+universes u v w
+
+structure Stack (α : Type u) :=
+(vals : Array α := #[])
+
+namespace Stack
+
+variable {α : Type u}
+
+def empty : Stack α :=
+{}
+
+def isEmpty (s : Stack α) : Bool :=
+s.vals.isEmpty
+
+def push (v : α) (s : Stack α) : Stack α :=
+{ vals := s.vals.push v .. s }
+
+def peek? (s : Stack α) : Option α :=
+if s.vals.isEmpty then none else s.vals.get? (s.vals.size-1)
+
+def peek! [Inhabited α] (s : Stack α) : α :=
+s.vals.back
+
+def pop [Inhabited α] (s : Stack α) : Stack α :=
+{ vals := s.vals.pop .. s }
+
+def modify [Inhabited α] (s : Stack α) (f : α → α) : Stack α :=
+{ vals := s.vals.modify (s.vals.size-1) f .. s }
+
+end Stack

stage0/src/Init/Data/String.lean

@@ -0,0 +1,7 @@
+/-
+Copyright (c) 2016 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.String.Basic

stage0/src/Init/Data/String/Basic.lean

@@ -0,0 +1,518 @@
+/-
+Copyright (c) 2016 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Author: Leonardo de Moura
+-/
+prelude
+import Init.Data.List.Basic
+import Init.Data.Char.Basic
+import Init.Data.Option.Basic
+universes u
+
+structure String :=
+(data : List Char)
+
+abbrev String.Pos := Nat
+
+structure Substring :=
+(str : String) (startPos : String.Pos) (stopPos : String.Pos)
+
+attribute [extern "lean_string_mk"] String.mk
+attribute [extern "lean_string_data"] String.data
+
+@[extern "lean_string_dec_eq"]
+def String.decEq (s₁ s₂ : @& String) : Decidable (s₁ = s₂) :=
+match s₁, s₂ with
+| ⟨s₁⟩, ⟨s₂⟩ =>
+ if h : s₁ = s₂ then isTrue (congrArg _ h)
+ else isFalse (fun h' => String.noConfusion h' (fun h' => absurd h' h))
+
+instance : DecidableEq String :=
+{decEq := String.decEq}
+
+def List.asString (s : List Char) : String :=
+⟨s⟩
+
+namespace String
+instance : HasLess String :=
+⟨fun s₁ s₂ => s₁.data < s₂.data⟩
+
+@[extern "lean_string_dec_lt"]
+instance decLt (s₁ s₂ : @& String) : Decidable (s₁ < s₂) :=
+List.hasDecidableLt s₁.data s₂.data
+
+@[extern "lean_string_length"]
+def length : (@& String) → Nat
+| ⟨s⟩ => s.length
+
+/- The internal implementation uses dynamic arrays and will perform destructive updates
+   if the String is not shared. -/
+@[extern "lean_string_push"]
+def push : String → Char → String
+| ⟨s⟩, c => ⟨s ++ [c]⟩
+
+/- The internal implementation uses dynamic arrays and will perform destructive updates
+   if the String is not shared. -/
+@[extern "lean_string_append"]
+def append : String → (@& String) → String
+| ⟨a⟩, ⟨b⟩ => ⟨a ++ b⟩
+
+/- O(n) in the runtime, where n is the length of the String -/
+def toList (s : String) : List Char :=
+s.data
+
+private def csize (c : Char) : Nat :=
+c.utf8Size.toNat
+
+private def utf8ByteSizeAux : List Char → Nat → Nat
+| [],    r => r
+| c::cs, r => utf8ByteSizeAux cs (r + csize c)
+
+@[extern "lean_string_utf8_byte_size"]
+def utf8ByteSize : (@& String) → Nat
+| ⟨s⟩ => utf8ByteSizeAux s 0
+
+@[inline] def bsize (s : String) : Nat :=
+utf8ByteSize s
+
+@[inline] def toSubstring (s : String) : Substring :=
+{str := s, startPos := 0, stopPos := s.bsize}
+
+private def utf8GetAux : List Char → Pos → Pos → Char
+| [],    i, p => arbitrary Char
+| c::cs, i, p => if i = p then c else utf8GetAux cs (i + csize c) p
+
+@[extern "lean_string_utf8_get"]
+def get : (@& String) → (@& Pos) → Char
+| ⟨s⟩, p => utf8GetAux s 0 p
+
+private def utf8SetAux (c' : Char) : List Char → Pos → Pos → List Char
+| [],    i, p => []
+| c::cs, i, p =>
+  if i = p then (c'::cs) else c::(utf8SetAux cs (i + csize c) p)
+
+@[extern "lean_string_utf8_set"]
+def set : String → (@& Pos) → Char → String
+| ⟨s⟩, i, c => ⟨utf8SetAux c s 0 i⟩
+
+@[extern "lean_string_utf8_next"]
+def next (s : @& String) (p : @& Pos) : Pos :=
+let c := get s p;
+p + csize c
+
+private def utf8PrevAux : List Char → Pos → Pos → Pos
+| [],    i, p => 0
+| c::cs, i, p =>
+  let cz := csize c;
+  let i' := i + cz;
+  if i' = p then i else utf8PrevAux cs i' p
+
+@[extern "lean_string_utf8_prev"]
+def prev : (@& String) → (@& Pos) → Pos
+| ⟨s⟩, p => if p = 0 then 0 else utf8PrevAux s 0 p
+
+def front (s : String) : Char :=
+get s 0
+
+def back (s : String) : Char :=
+get s (prev s (bsize s))
+
+@[extern "lean_string_utf8_at_end"]
+def atEnd : (@& String) → (@& Pos) → Bool
+| s, p => p ≥ utf8ByteSize s
+
+/- TODO: remove `partial` keywords after we restore the tactic
+  framework and wellfounded recursion support -/
+
+partial def posOfAux (s : String) (c : Char) (stopPos : Pos) : Pos → Pos
+| pos =>
+  if pos == stopPos then pos
+  else if s.get pos == c then pos
+       else posOfAux (s.next pos)
+
+@[inline] def posOf (s : String) (c : Char) : Pos :=
+posOfAux s c s.bsize 0
+
+partial def revPosOfAux (s : String) (c : Char) : Pos → Option Pos
+| pos =>
+ if s.get pos == c then some pos
+ else if pos == 0 then none
+ else revPosOfAux (s.prev pos)
+
+def revPosOf (s : String) (c : Char) : Option Pos :=
+if s.bsize == 0 then none
+else revPosOfAux s c (s.prev s.bsize)
+
+private def utf8ExtractAux₂ : List Char → Pos → Pos → List Char
+| [],    _, _ => []
+| c::cs, i, e => if i = e then [] else c :: utf8ExtractAux₂ cs (i + csize c) e
+
+private def utf8ExtractAux₁ : List Char → Pos → Pos → Pos → List Char
+| [],        _, _, _ => []
+| s@(c::cs), i, b, e => if i = b then utf8ExtractAux₂ s i e else utf8ExtractAux₁ cs (i + csize c) b e
+
+@[extern "lean_string_utf8_extract"]
+def extract : (@& String) → (@& Pos) → (@& Pos) → String
+| ⟨s⟩, b, e => if b ≥ e then ⟨[]⟩ else ⟨utf8ExtractAux₁ s 0 b e⟩
+
+@[specialize] partial def splitAux (s : String) (p : Char → Bool) : Pos → Pos → List String → List String
+| b, i, r =>
+  if s.atEnd i then
+    let r := if p (s.get i) then ""::(s.extract b (i-1))::r else (s.extract b i)::r;
+    r.reverse
+  else if p (s.get i) then
+    let i := s.next i;
+    splitAux i i (s.extract b (i-1)::r)
+  else splitAux b (s.next i) r
+
+@[specialize] def split (s : String) (p : Char → Bool) : List String :=
+splitAux s p 0 0 []
+
+partial def splitOnAux (s sep : String) : Pos → Pos → Pos → List String → List String
+| b, i, j, r =>
+  if s.atEnd i then
+    let r := if sep.atEnd j then ""::(s.extract b (i-j))::r else (s.extract b i)::r;
+    r.reverse
+  else if s.get i == sep.get j then
+    let i := s.next i;
+    let j := sep.next j;
+    if sep.atEnd j then splitOnAux i i 0 (s.extract b (i-j)::r)
+    else splitOnAux b i j r
+  else splitOnAux b (s.next i) 0 r
+
+def splitOn (s : String) (sep : String := " ") : List String :=
+if sep == "" then [s] else splitOnAux s sep 0 0 0 []
+
+instance : Inhabited String :=
+⟨""⟩
+
+instance : HasSizeof String :=
+⟨String.length⟩
+
+instance : HasAppend String :=
+⟨String.append⟩
+
+def str : String → Char → String := push
+
+def pushn (s : String) (c : Char) (n : Nat) : String :=
+n.repeat (fun s => s.push c) s
+
+def isEmpty (s : String) : Bool :=
+s.bsize == 0
+
+def join (l : List String) : String :=
+l.foldl (fun r s => r ++ s) ""
+
+def singleton (c : Char) : String :=
+"".push c
+
+def intercalate (s : String) (ss : List String) : String :=
+(List.intercalate s.toList (ss.map toList)).asString
+
+structure Iterator :=
+(s : String) (i : Pos)
+
+def mkIterator (s : String) : Iterator :=
+⟨s, 0⟩
+
+namespace Iterator
+def toString : Iterator → String
+| ⟨s, _⟩ => s
+
+def remainingBytes : Iterator → Nat
+| ⟨s, i⟩ => s.bsize - i
+
+def pos : Iterator → Pos
+| ⟨s, i⟩ => i
+
+def curr : Iterator → Char
+| ⟨s, i⟩ => get s i
+
+def next : Iterator → Iterator
+| ⟨s, i⟩ => ⟨s, s.next i⟩
+
+def prev : Iterator → Iterator
+| ⟨s, i⟩ => ⟨s, s.prev i⟩
+
+def hasNext : Iterator → Bool
+| ⟨s, i⟩ => i < utf8ByteSize s
+
+def hasPrev : Iterator → Bool
+| ⟨s, i⟩ => i > 0
+
+def setCurr : Iterator → Char → Iterator
+| ⟨s, i⟩, c => ⟨s.set i c, i⟩
+
+def toEnd : Iterator → Iterator
+| ⟨s, _⟩ => ⟨s, s.bsize⟩
+
+def extract : Iterator → Iterator → String
+| ⟨s₁, b⟩, ⟨s₂, e⟩ =>
+  if s₁ ≠ s₂ || b > e then ""
+  else s₁.extract b e
+
+def forward : Iterator → Nat → Iterator
+| it, 0   => it
+| it, n+1 => forward it.next n
+
+def remainingToString : Iterator → String
+| ⟨s, i⟩ => s.extract i s.bsize
+
+/- (isPrefixOfRemaining it₁ it₂) is `true` Iff `it₁.remainingToString` is a prefix
+   of `it₂.remainingToString`. -/
+def isPrefixOfRemaining : Iterator → Iterator → Bool
+| ⟨s₁, i₁⟩, ⟨s₂, i₂⟩ => s₁.extract i₁ s₁.bsize = s₂.extract i₂ (i₂ + (s₁.bsize - i₁))
+
+def nextn : Iterator → Nat → Iterator
+| it, 0   => it
+| it, i+1 => nextn it.next i
+
+def prevn : Iterator → Nat → Iterator
+| it, 0   => it
+| it, i+1 => prevn it.prev i
+end Iterator
+
+partial def offsetOfPosAux (s : String) (pos : Pos) : Pos → Nat → Nat
+| i, offset =>
+  if i == pos || s.atEnd i then offset
+  else offsetOfPosAux (s.next i) (offset+1)
+
+def offsetOfPos (s : String) (pos : Pos) : Nat :=
+offsetOfPosAux s pos 0 0
+
+@[specialize] partial def foldlAux {α : Type u} (f : α → Char → α) (s : String) (stopPos : Pos) : Pos → α → α
+| i, a =>
+  if i == stopPos then a
+  else foldlAux (s.next i) (f a (s.get i))
+
+@[inline] def foldl {α : Type u} (f : α → Char → α) (a : α) (s : String) : α :=
+foldlAux f s s.bsize 0 a
+
+@[specialize] partial def foldrAux {α : Type u} (f : Char → α → α) (a : α) (s : String) (stopPos : Pos) : Pos → α
+| i =>
+  if i == stopPos then a
+  else f (s.get i) (foldrAux (s.next i))
+
+@[inline] def foldr {α : Type u} (f : Char → α → α) (a : α) (s : String) : α :=
+foldrAux f a s s.bsize 0
+
+@[specialize] partial def anyAux (s : String) (stopPos : Pos) (p : Char → Bool) : Pos → Bool
+| i =>
+  if i == stopPos then false
+  else if p (s.get i) then true
+  else anyAux (s.next i)
+
+@[inline] def any (s : String) (p : Char → Bool) : Bool :=
+anyAux s s.bsize p 0
+
+@[inline] def all (s : String) (p : Char → Bool) : Bool :=
+!s.any (fun c => !p c)
+
+def contains (s : String) (c : Char) : Bool :=
+s.any (fun a => a == c)
+
+@[specialize] partial def mapAux (f : Char → Char) : Pos → String → String
+| i, s =>
+  if s.atEnd i then s
+  else
+    let c := f (s.get i);
+    let s := s.set i c;
+    mapAux (s.next i) s
+
+@[inline] def map (f : Char → Char) (s : String) : String :=
+mapAux f 0 s
+
+def toNat (s : String) : Nat :=
+s.foldl (fun n c => n*10 + (c.toNat - '0'.toNat)) 0
+
+def isNat (s : String) : Bool :=
+s.all $ fun c => c.isDigit
+
+partial def isPrefixOfAux (p s : String) : Pos → Bool
+| i =>
+  if p.atEnd i then true
+  else
+    let c₁ := p.get i;
+    let c₂ := s.get i;
+    c₁ == c₂ && isPrefixOfAux (s.next i)
+
+/- Return true iff `p` is a prefix of `s` -/
+def isPrefixOf (p : String) (s : String) : Bool :=
+p.length ≤ s.length && isPrefixOfAux p s 0
+
+end String
+
+namespace Substring
+
+@[inline] def toString : Substring → String
+| ⟨s, b, e⟩ => s.extract b e
+
+@[inline] def toIterator : Substring → String.Iterator
+| ⟨s, b, _⟩ => ⟨s, b⟩
+
+@[inline] def get : Substring → String.Pos → Char
+| ⟨s, b, _⟩, p => s.get (b+p)
+
+@[inline] def next : Substring → String.Pos → String.Pos
+| ⟨s, b, e⟩, p =>
+  let p := s.next (b+p);
+  if p > e then e - b else p - b
+
+@[inline] def prev : Substring → String.Pos → String.Pos
+| ⟨s, b, _⟩, p =>
+  if p = b then p else s.prev (b+p) - b
+
+@[inline] def front (s : Substring) : Char :=
+s.get 0
+
+@[inline] def posOf (s : Substring) (c : Char) : String.Pos :=
+match s with
+| ⟨s, b, e⟩ => (String.posOfAux s c e b) - b
+
+@[inline] def drop : Substring → Nat → Substring
+| ⟨s, b, e⟩, n =>
+  if b + n ≥ e then "".toSubstring
+  else ⟨s, b+n, e⟩
+
+@[inline] def dropRight : Substring → Nat → Substring
+| ⟨s, b, e⟩, n =>
+  if e - n ≤ e then "".toSubstring
+  else ⟨s, b, e - n⟩
+
+@[inline] def take : Substring → Nat → Substring
+| ⟨s, b, e⟩, n =>
+  let e := if b + n ≥ e then e else b + n;
+  ⟨s, b, e⟩
+
+@[inline] def takeRight : Substring → Nat → Substring
+| ⟨s, b, e⟩, n =>
+  let b := if e - n ≤ b then b else e - n;
+  ⟨s, b, e⟩
+
+@[inline] def atEnd : Substring → String.Pos → Bool
+| ⟨s, b, e⟩, p => b + p == e
+
+@[inline] def extract : Substring → String.Pos → String.Pos → Substring
+| ⟨s, b, _⟩, b', e' => if b' ≥ e' then ⟨"", 0, 1⟩ else ⟨s, b+b', b+e'⟩
+
+partial def splitOnAux (s sep : String) (stopPos : String.Pos) : String.Pos → String.Pos → String.Pos → List Substring → List Substring
+| b, i, j, r =>
+  if i == stopPos then
+    let r := if sep.atEnd j then "".toSubstring::{str := s, startPos := b, stopPos := i-j}::r else {str := s, startPos := b, stopPos := i}::r;
+    r.reverse
+  else if s.get i == sep.get j then
+    let i := s.next i;
+    let j := sep.next j;
+    if sep.atEnd j then splitOnAux i i 0 ({str := s, startPos := b, stopPos := i-j}::r)
+    else splitOnAux b i j r
+  else splitOnAux b (s.next i) 0 r
+
+def splitOn (s : Substring) (sep : String := " ") : List Substring :=
+if sep == "" then [s] else splitOnAux s.str sep s.stopPos s.startPos s.startPos 0 []
+
+@[inline] def foldl {α : Type u} (f : α → Char → α) (a : α) (s : Substring) : α :=
+match s with
+| ⟨s, b, e⟩ => String.foldlAux f s e b a
+
+@[inline] def foldr {α : Type u} (f : Char → α → α) (a : α) (s : Substring) : α :=
+match s with
+| ⟨s, b, e⟩ => String.foldrAux f a s e b
+
+@[inline] def any (s : Substring) (p : Char → Bool) : Bool :=
+match s with
+| ⟨s, b, e⟩ => String.anyAux s e p b
+
+@[inline] def all (s : Substring) (p : Char → Bool) : Bool :=
+!s.any (fun c => !p c)
+
+def contains (s : Substring) (c : Char) : Bool :=
+s.any (fun a => a == c)
+
+@[specialize] partial def takeWhileAux (s : String) (stopPos : String.Pos) (p : Char → Bool) : String.Pos → String.Pos
+| i =>
+  if i == stopPos then i
+  else if p (s.get i) then takeWhileAux (s.next i)
+  else i
+
+@[inline] def takeWhile : Substring → (Char → Bool) → Substring
+| ⟨s, b, e⟩, p =>
+  let e := takeWhileAux s e p b;
+  ⟨s, b, e⟩
+
+@[inline] def dropWhile : Substring → (Char → Bool) → Substring
+| ⟨s, b, e⟩, p =>
+  let b := takeWhileAux s e p b;
+  ⟨s, b, e⟩
+
+@[specialize] partial def takeRightWhileAux (s : String) (begPos : String.Pos) (p : Char → Bool) : String.Pos → String.Pos
+| i =>
+  if i == begPos then i
+  else
+    let i' := s.prev i;
+    let c  := s.get i';
+    if !p c then i
+    else takeRightWhileAux i'
+
+@[inline] def takeRightWhile : Substring → (Char → Bool) → Substring
+| ⟨s, b, e⟩, p =>
+  let b := takeRightWhileAux s b p e;
+  ⟨s, b, e⟩
+
+@[inline] def dropRightWhile : Substring → (Char → Bool) → Substring
+| ⟨s, b, e⟩, p =>
+  let e := takeRightWhileAux s b p e;
+  ⟨s, b, e⟩
+
+@[inline] def trimLeft (s : Substring) : Substring :=
+s.dropWhile Char.isWhitespace
+
+@[inline] def trimRight (s : Substring) : Substring :=
+s.dropRightWhile Char.isWhitespace
+
+@[inline] def trim : Substring → Substring
+| ⟨s, b, e⟩ =>
+  let b := takeWhileAux s e Char.isWhitespace b;
+  let e := takeRightWhileAux s b Char.isWhitespace e;
+  ⟨s, b, e⟩
+
+def toNat (s : Substring) : Nat :=
+s.foldl (fun n c => n*10 + (c.toNat - '0'.toNat)) 0
+
+def isNat (s : Substring) : Bool :=
+s.all $ fun c => c.isDigit
+
+end Substring
+
+namespace String
+
+def drop (s : String) (n : Nat) : String :=
+(s.toSubstring.drop n).toString
+
+def dropRight (s : String) (n : Nat) : String :=
+(s.toSubstring.dropRight n).toString
+
+def take (s : String) (n : Nat) : String :=
+(s.toSubstring.take n).toString
+
+def takeRight (s : String) (n : Nat) : String :=
+(s.toSubstring.takeRight n).toString
+
+def takeWhile (s : String) (p : Char → Bool) : String :=
+(s.toSubstring.takeWhile p).toString
+
+def dropWhile (s : String) (p : Char → Bool) : String :=
+(s.toSubstring.dropWhile p).toString
+
+def trimRight (s : String) : String :=
+s.toSubstring.trimRight.toString
+
+def trimLeft (s : String) : String :=
+s.toSubstring.trimLeft.toString
+
+def trim (s : String) : String :=
+s.toSubstring.trim.toString
+
+end String
+
+protected def Char.toString (c : Char) : String :=
+String.singleton c

stage0/src/Init/Data/ToString.lean

@@ -0,0 +1,97 @@
+/-
+Copyright (c) 2016 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Author: Leonardo de Moura
+-/
+prelude
+import Init.Data.String.Basic
+import Init.Data.UInt
+import Init.Data.Nat.Div
+import Init.Data.Repr
+open Sum Subtype Nat
+
+universes u v
+
+class HasToString (α : Type u) :=
+(toString : α → String)
+
+export HasToString (toString)
+
+-- This instance is needed because `id` is not reducible
+instance {α : Type u} [HasToString α] : HasToString (id α) :=
+inferInstanceAs (HasToString α)
+
+instance : HasToString String :=
+⟨fun s => s⟩
+
+instance : HasToString Substring :=
+⟨fun s => s.toString⟩
+
+instance : HasToString String.Iterator :=
+⟨fun it => it.remainingToString⟩
+
+instance : HasToString Bool :=
+⟨fun b => cond b "true" "false"⟩
+
+instance {p : Prop} : HasToString (Decidable p) :=
+-- Remark: type class inference will not consider local instance `b` in the new Elaborator
+⟨fun b => @ite p b _ "true" "false"⟩
+
+protected def List.toStringAux {α : Type u} [HasToString α] : Bool → List α → String
+| b,     []    => ""
+| true,  x::xs => toString x ++ List.toStringAux false xs
+| false, x::xs => ", " ++ toString x ++ List.toStringAux false xs
+
+protected def List.toString {α : Type u} [HasToString α] : List α → String
+| []    => "[]"
+| x::xs => "[" ++ List.toStringAux true (x::xs) ++ "]"
+
+instance {α : Type u} [HasToString α] : HasToString (List α) :=
+⟨List.toString⟩
+
+instance : HasToString Unit :=
+⟨fun u => "()"⟩
+
+instance : HasToString Nat :=
+⟨fun n => repr n⟩
+
+instance : HasToString Char :=
+⟨fun c => c.toString⟩
+
+instance (n : Nat) : HasToString (Fin n) :=
+⟨fun f => toString (Fin.val f)⟩
+
+instance : HasToString UInt8 :=
+⟨fun n => toString n.toNat⟩
+
+instance : HasToString UInt16 :=
+⟨fun n => toString n.toNat⟩
+
+instance : HasToString UInt32 :=
+⟨fun n => toString n.toNat⟩
+
+instance : HasToString UInt64 :=
+⟨fun n => toString n.toNat⟩
+
+instance : HasToString USize :=
+⟨fun n => toString n.toNat⟩
+
+def addParenHeuristic (s : String) : String :=
+if "(".isPrefixOf s || "[".isPrefixOf s || "{".isPrefixOf s || "#[".isPrefixOf s then s
+else if !s.any Char.isWhitespace then s
+else "(" ++ s ++ ")"
+
+instance {α : Type u} [HasToString α] : HasToString (Option α) :=
+⟨fun o => match o with | none => "none" | (some a) => "(some " ++ addParenHeuristic (toString a) ++ ")"⟩
+
+instance {α : Type u} {β : Type v} [HasToString α] [HasToString β] : HasToString (Sum α β) :=
+⟨fun s => match s with | (inl a) => "(inl " ++ addParenHeuristic (toString a) ++ ")" | (inr b) => "(inr " ++ addParenHeuristic (toString b) ++ ")"⟩
+
+instance {α : Type u} {β : Type v} [HasToString α] [HasToString β] : HasToString (α × β) :=
+⟨fun ⟨a, b⟩ => "(" ++ toString a ++ ", " ++ toString b ++ ")"⟩
+
+instance {α : Type u} {β : α → Type v} [HasToString α] [s : ∀ x, HasToString (β x)] : HasToString (Sigma β) :=
+⟨fun ⟨a, b⟩ => "⟨"  ++ toString a ++ ", " ++ toString b ++ "⟩"⟩
+
+instance {α : Type u} {p : α → Prop} [HasToString α] : HasToString (Subtype p) :=
+⟨fun s => toString (val s)⟩

stage0/src/Init/Data/UInt.lean

@@ -0,0 +1,340 @@
+/-
+Copyright (c) 2018 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.Fin.Basic
+import Init.System.Platform
+
+open Nat
+
+def uint8Sz : Nat := 256
+structure UInt8 :=
+(val : Fin uint8Sz)
+
+@[extern "lean_uint8_of_nat"]
+def UInt8.ofNat (n : @& Nat) : UInt8 := ⟨Fin.ofNat n⟩
+abbrev Nat.toUInt8 := UInt8.ofNat
+@[extern "lean_uint8_to_nat"]
+def UInt8.toNat (n : UInt8) : Nat := n.val.val
+@[extern c inline "#1 + #2"]
+def UInt8.add (a b : UInt8) : UInt8 := ⟨a.val + b.val⟩
+@[extern c inline "#1 - #2"]
+def UInt8.sub (a b : UInt8) : UInt8 := ⟨a.val - b.val⟩
+@[extern c inline "#1 * #2"]
+def UInt8.mul (a b : UInt8) : UInt8 := ⟨a.val * b.val⟩
+@[extern c inline "#2 == 0 ? 0 : #1 / #2"]
+def UInt8.div (a b : UInt8) : UInt8 := ⟨a.val / b.val⟩
+@[extern c inline "#2 == 0 ? 0 : #1 % #2"]
+def UInt8.mod (a b : UInt8) : UInt8 := ⟨a.val % b.val⟩
+@[extern "lean_uint8_modn"]
+def UInt8.modn (a : UInt8) (n : @& Nat) : UInt8 := ⟨a.val %ₙ n⟩
+@[extern c inline "#1 & #2"]
+def UInt8.land (a b : UInt8) : UInt8 := ⟨Fin.land a.val b.val⟩
+@[extern c inline "#1 | #2"]
+def UInt8.lor (a b : UInt8) : UInt8 := ⟨Fin.lor a.val b.val⟩
+def UInt8.lt (a b : UInt8) : Prop := a.val < b.val
+def UInt8.le (a b : UInt8) : Prop := a.val ≤ b.val
+
+instance : HasZero UInt8     := ⟨UInt8.ofNat 0⟩
+instance : HasOne UInt8      := ⟨UInt8.ofNat 1⟩
+instance : HasAdd UInt8      := ⟨UInt8.add⟩
+instance : HasSub UInt8      := ⟨UInt8.sub⟩
+instance : HasMul UInt8      := ⟨UInt8.mul⟩
+instance : HasMod UInt8      := ⟨UInt8.mod⟩
+instance : HasModn UInt8     := ⟨UInt8.modn⟩
+instance : HasDiv UInt8      := ⟨UInt8.div⟩
+instance : HasLess UInt8     := ⟨UInt8.lt⟩
+instance : HasLessEq UInt8   := ⟨UInt8.le⟩
+instance : Inhabited UInt8   := ⟨0⟩
+
+@[extern c inline "#1 == #2"]
+def UInt8.decEq (a b : UInt8) : Decidable (a = b) :=
+UInt8.casesOn a $ fun n => UInt8.casesOn b $ fun m =>
+  if h : n = m then isTrue (h ▸ rfl) else isFalse (fun h' => UInt8.noConfusion h' (fun h' => absurd h' h))
+
+@[extern c inline "#1 < #2"]
+def UInt8.decLt (a b : UInt8) : Decidable (a < b) :=
+UInt8.casesOn a $ fun n => UInt8.casesOn b $ fun m =>
+  inferInstanceAs (Decidable (n < m))
+
+@[extern c inline "#1 <= #2"]
+def UInt8.decLe (a b : UInt8) : Decidable (a ≤ b) :=
+UInt8.casesOn a $ fun n => UInt8.casesOn b $ fun m =>
+  inferInstanceAs (Decidable (n <= m))
+
+instance : DecidableEq UInt8 := {decEq := UInt8.decEq}
+instance UInt8.hasDecidableLt (a b : UInt8) : Decidable (a < b) := UInt8.decLt a b
+instance UInt8.hasDecidableLe (a b : UInt8) : Decidable (a ≤ b) := UInt8.decLe a b
+
+def uint16Sz : Nat := 65536
+structure UInt16 :=
+(val : Fin uint16Sz)
+
+@[extern "lean_uint16_of_nat"]
+def UInt16.ofNat (n : @& Nat) : UInt16 := ⟨Fin.ofNat n⟩
+abbrev Nat.toUInt16 := UInt16.ofNat
+@[extern "lean_uint16_to_nat"]
+def UInt16.toNat (n : UInt16) : Nat := n.val.val
+@[extern c inline "#1 + #2"]
+def UInt16.add (a b : UInt16) : UInt16 := ⟨a.val + b.val⟩
+@[extern c inline "#1 - #2"]
+def UInt16.sub (a b : UInt16) : UInt16 := ⟨a.val - b.val⟩
+@[extern c inline "#1 * #2"]
+def UInt16.mul (a b : UInt16) : UInt16 := ⟨a.val * b.val⟩
+@[extern c inline "#2 == 0 ? 0 : #1 / #2"]
+def UInt16.div (a b : UInt16) : UInt16 := ⟨a.val / b.val⟩
+@[extern c inline "#2 == 0 ? 0 : #1 % #2"]
+def UInt16.mod (a b : UInt16) : UInt16 := ⟨a.val % b.val⟩
+@[extern "lean_uint16_modn"]
+def UInt16.modn (a : UInt16) (n : @& Nat) : UInt16 := ⟨a.val %ₙ n⟩
+@[extern c inline "#1 & #2"]
+def UInt16.land (a b : UInt16) : UInt16 := ⟨Fin.land a.val b.val⟩
+@[extern c inline "#1 | #2"]
+def UInt16.lor (a b : UInt16) : UInt16 := ⟨Fin.lor a.val b.val⟩
+def UInt16.lt (a b : UInt16) : Prop := a.val < b.val
+def UInt16.le (a b : UInt16) : Prop := a.val ≤ b.val
+
+instance : HasZero UInt16     := ⟨UInt16.ofNat 0⟩
+instance : HasOne UInt16      := ⟨UInt16.ofNat 1⟩
+instance : HasAdd UInt16      := ⟨UInt16.add⟩
+instance : HasSub UInt16      := ⟨UInt16.sub⟩
+instance : HasMul UInt16      := ⟨UInt16.mul⟩
+instance : HasMod UInt16      := ⟨UInt16.mod⟩
+instance : HasModn UInt16     := ⟨UInt16.modn⟩
+instance : HasDiv UInt16      := ⟨UInt16.div⟩
+instance : HasLess UInt16     := ⟨UInt16.lt⟩
+instance : HasLessEq UInt16   := ⟨UInt16.le⟩
+instance : Inhabited UInt16   := ⟨0⟩
+
+@[extern c inline "#1 == #2"]
+def UInt16.decEq (a b : UInt16) : Decidable (a = b) :=
+UInt16.casesOn a $ fun n => UInt16.casesOn b $ fun m =>
+  if h : n = m then isTrue (h ▸ rfl) else isFalse (fun h' => UInt16.noConfusion h' (fun h' => absurd h' h))
+
+@[extern c inline "#1 < #2"]
+def UInt16.decLt (a b : UInt16) : Decidable (a < b) :=
+UInt16.casesOn a $ fun n => UInt16.casesOn b $ fun m =>
+  inferInstanceAs (Decidable (n < m))
+
+@[extern c inline "#1 <= #2"]
+def UInt16.decLe (a b : UInt16) : Decidable (a ≤ b) :=
+UInt16.casesOn a $ fun n => UInt16.casesOn b $ fun m =>
+  inferInstanceAs (Decidable (n <= m))
+
+instance : DecidableEq UInt16 := {decEq := UInt16.decEq}
+instance UInt16.hasDecidableLt (a b : UInt16) : Decidable (a < b) := UInt16.decLt a b
+instance UInt16.hasDecidableLe (a b : UInt16) : Decidable (a ≤ b) := UInt16.decLe a b
+
+def uint32Sz : Nat := 4294967296
+structure UInt32 :=
+(val : Fin uint32Sz)
+
+@[extern "lean_uint32_of_nat"]
+def UInt32.ofNat (n : @& Nat) : UInt32 := ⟨Fin.ofNat n⟩
+abbrev Nat.toUInt32 := UInt32.ofNat
+@[extern "lean_uint32_to_nat"]
+def UInt32.toNat (n : UInt32) : Nat := n.val.val
+@[extern c inline "#1 + #2"]
+def UInt32.add (a b : UInt32) : UInt32 := ⟨a.val + b.val⟩
+@[extern c inline "#1 - #2"]
+def UInt32.sub (a b : UInt32) : UInt32 := ⟨a.val - b.val⟩
+@[extern c inline "#1 * #2"]
+def UInt32.mul (a b : UInt32) : UInt32 := ⟨a.val * b.val⟩
+@[extern c inline "#2 == 0 ? 0 : #1 / #2"]
+def UInt32.div (a b : UInt32) : UInt32 := ⟨a.val / b.val⟩
+@[extern c inline "#2 == 0 ? 0 : #1 % #2"]
+def UInt32.mod (a b : UInt32) : UInt32 := ⟨a.val % b.val⟩
+@[extern "lean_uint32_modn"]
+def UInt32.modn (a : UInt32) (n : @& Nat) : UInt32 := ⟨a.val %ₙ n⟩
+@[extern c inline "#1 & #2"]
+def UInt32.land (a b : UInt32) : UInt32 := ⟨Fin.land a.val b.val⟩
+@[extern c inline "#1 | #2"]
+def UInt32.lor (a b : UInt32) : UInt32 := ⟨Fin.lor a.val b.val⟩
+def UInt32.lt (a b : UInt32) : Prop := a.val < b.val
+def UInt32.le (a b : UInt32) : Prop := a.val ≤ b.val
+
+instance : HasZero UInt32     := ⟨UInt32.ofNat 0⟩
+instance : HasOne UInt32      := ⟨UInt32.ofNat 1⟩
+instance : HasAdd UInt32      := ⟨UInt32.add⟩
+instance : HasSub UInt32      := ⟨UInt32.sub⟩
+instance : HasMul UInt32      := ⟨UInt32.mul⟩
+instance : HasMod UInt32      := ⟨UInt32.mod⟩
+instance : HasModn UInt32     := ⟨UInt32.modn⟩
+instance : HasDiv UInt32      := ⟨UInt32.div⟩
+instance : HasLess UInt32     := ⟨UInt32.lt⟩
+instance : HasLessEq UInt32   := ⟨UInt32.le⟩
+instance : Inhabited UInt32   := ⟨0⟩
+
+@[extern c inline "#1 == #2"]
+def UInt32.decEq (a b : UInt32) : Decidable (a = b) :=
+UInt32.casesOn a $ fun n => UInt32.casesOn b $ fun m =>
+  if h : n = m then isTrue (h ▸ rfl) else isFalse (fun h' => UInt32.noConfusion h' (fun h' => absurd h' h))
+
+@[extern c inline "#1 < #2"]
+def UInt32.decLt (a b : UInt32) : Decidable (a < b) :=
+UInt32.casesOn a $ fun n => UInt32.casesOn b $ fun m =>
+  inferInstanceAs (Decidable (n < m))
+
+@[extern c inline "#1 <= #2"]
+def UInt32.decLe (a b : UInt32) : Decidable (a ≤ b) :=
+UInt32.casesOn a $ fun n => UInt32.casesOn b $ fun m =>
+  inferInstanceAs (Decidable (n <= m))
+
+instance : DecidableEq UInt32 := {decEq := UInt32.decEq}
+instance UInt32.hasDecidableLt (a b : UInt32) : Decidable (a < b) := UInt32.decLt a b
+instance UInt32.hasDecidableLe (a b : UInt32) : Decidable (a ≤ b) := UInt32.decLe a b
+
+def uint64Sz : Nat := 18446744073709551616
+structure UInt64 :=
+(val : Fin uint64Sz)
+
+@[extern "lean_uint64_of_nat"]
+def UInt64.ofNat (n : @& Nat) : UInt64 := ⟨Fin.ofNat n⟩
+abbrev Nat.toUInt64 := UInt64.ofNat
+@[extern "lean_uint64_to_nat"]
+def UInt64.toNat (n : UInt64) : Nat := n.val.val
+@[extern c inline "#1 + #2"]
+def UInt64.add (a b : UInt64) : UInt64 := ⟨a.val + b.val⟩
+@[extern c inline "#1 - #2"]
+def UInt64.sub (a b : UInt64) : UInt64 := ⟨a.val - b.val⟩
+@[extern c inline "#1 * #2"]
+def UInt64.mul (a b : UInt64) : UInt64 := ⟨a.val * b.val⟩
+@[extern c inline "#2 == 0 ? 0 : #1 / #2"]
+def UInt64.div (a b : UInt64) : UInt64 := ⟨a.val / b.val⟩
+@[extern c inline "#2 == 0 ? 0 : #1 % #2"]
+def UInt64.mod (a b : UInt64) : UInt64 := ⟨a.val % b.val⟩
+@[extern "lean_uint64_modn"]
+def UInt64.modn (a : UInt64) (n : @& Nat) : UInt64 := ⟨a.val %ₙ n⟩
+@[extern c inline "#1 & #2"]
+def UInt64.land (a b : UInt64) : UInt64 := ⟨Fin.land a.val b.val⟩
+@[extern c inline "#1 | #2"]
+def UInt64.lor (a b : UInt64) : UInt64 := ⟨Fin.lor a.val b.val⟩
+def UInt64.lt (a b : UInt64) : Prop := a.val < b.val
+def UInt64.le (a b : UInt64) : Prop := a.val ≤ b.val
+@[extern c inline "((uint8_t)#1)"]
+def UInt64.toUInt8 (a : UInt64) : UInt8 := a.toNat.toUInt8
+@[extern c inline "((uint16_t)#1)"]
+def UInt64.toUInt16 (a : UInt64) : UInt16 := a.toNat.toUInt16
+@[extern c inline "((uint32_t)#1)"]
+def UInt64.toUInt32 (a : UInt64) : UInt32 := a.toNat.toUInt32
+@[extern c inline "((uint64_t)#1)"]
+def UInt32.toUInt64 (a : UInt32) : UInt64 := a.toNat.toUInt64
+
+-- TODO(Leo): give reference implementation for shiftLeft and shiftRight, and define them for other UInt types
+@[extern c inline "#1 << #2"]
+constant UInt64.shiftLeft (a b : UInt64) : UInt64 := (arbitrary Nat).toUInt64
+@[extern c inline "#1 >> #2"]
+constant UInt64.shiftRight (a b : UInt64) : UInt64 := (arbitrary Nat).toUInt64
+
+instance : HasZero UInt64     := ⟨UInt64.ofNat 0⟩
+instance : HasOne UInt64      := ⟨UInt64.ofNat 1⟩
+instance : HasAdd UInt64      := ⟨UInt64.add⟩
+instance : HasSub UInt64      := ⟨UInt64.sub⟩
+instance : HasMul UInt64      := ⟨UInt64.mul⟩
+instance : HasMod UInt64      := ⟨UInt64.mod⟩
+instance : HasModn UInt64     := ⟨UInt64.modn⟩
+instance : HasDiv UInt64      := ⟨UInt64.div⟩
+instance : HasLess UInt64     := ⟨UInt64.lt⟩
+instance : HasLessEq UInt64   := ⟨UInt64.le⟩
+instance : Inhabited UInt64   := ⟨0⟩
+
+@[extern c inline "(uint64_t)#1"]
+def Bool.toUInt64 (b : Bool) : UInt64 := if b then 1 else 0
+
+@[extern c inline "#1 == #2"]
+def UInt64.decEq (a b : UInt64) : Decidable (a = b) :=
+UInt64.casesOn a $ fun n => UInt64.casesOn b $ fun m =>
+  if h : n = m then isTrue (h ▸ rfl) else isFalse (fun h' => UInt64.noConfusion h' (fun h' => absurd h' h))
+
+@[extern c inline "#1 < #2"]
+def UInt64.decLt (a b : UInt64) : Decidable (a < b) :=
+UInt64.casesOn a $ fun n => UInt64.casesOn b $ fun m =>
+  inferInstanceAs (Decidable (n < m))
+
+@[extern c inline "#1 <= #2"]
+def UInt64.decLe (a b : UInt64) : Decidable (a ≤ b) :=
+UInt64.casesOn a $ fun n => UInt64.casesOn b $ fun m =>
+  inferInstanceAs (Decidable (n <= m))
+
+instance : DecidableEq UInt64 := {decEq := UInt64.decEq}
+instance UInt64.hasDecidableLt (a b : UInt64) : Decidable (a < b) := UInt64.decLt a b
+instance UInt64.hasDecidableLe (a b : UInt64) : Decidable (a ≤ b) := UInt64.decLe a b
+
+def usizeSz : Nat := (2:Nat) ^ System.Platform.numBits
+structure USize :=
+(val : Fin usizeSz)
+
+theorem usizeSzGt0 : usizeSz > 0 :=
+Nat.posPowOfPos System.Platform.numBits (Nat.zeroLtSucc _)
+
+@[extern "lean_usize_of_nat"]
+def USize.ofNat (n : @& Nat) : USize := ⟨Fin.ofNat' n usizeSzGt0⟩
+abbrev Nat.toUSize := USize.ofNat
+@[extern "lean_usize_to_nat"]
+def USize.toNat (n : USize) : Nat := n.val.val
+@[extern c inline "#1 + #2"]
+def USize.add (a b : USize) : USize := ⟨a.val + b.val⟩
+@[extern c inline "#1 - #2"]
+def USize.sub (a b : USize) : USize := ⟨a.val - b.val⟩
+@[extern c inline "#1 * #2"]
+def USize.mul (a b : USize) : USize := ⟨a.val * b.val⟩
+@[extern c inline "#2 == 0 ? 0 : #1 / #2"]
+def USize.div (a b : USize) : USize := ⟨a.val / b.val⟩
+@[extern c inline "#2 == 0 ? 0 : #1 % #2"]
+def USize.mod (a b : USize) : USize := ⟨a.val % b.val⟩
+@[extern "lean_usize_modn"]
+def USize.modn (a : USize) (n : @& Nat) : USize := ⟨a.val %ₙ n⟩
+@[extern c inline "#1 & #2"]
+def USize.land (a b : USize) : USize := ⟨Fin.land a.val b.val⟩
+@[extern c inline "#1 | #2"]
+def USize.lor (a b : USize) : USize := ⟨Fin.lor a.val b.val⟩
+@[extern c inline "#1"]
+def UInt32.toUSize (a : UInt32) : USize := a.toNat.toUSize
+@[extern c inline "((size_t)#1)"]
+def UInt64.toUSize (a : UInt64) : USize := a.toNat.toUSize
+@[extern c inline "(uint32_t)#1"]
+def USize.toUInt32 (a : USize) : UInt32 := a.toNat.toUInt32
+
+-- TODO(Leo): give reference implementation for shiftLeft and shiftRight, and define them for other UInt types
+@[extern c inline "#1 << #2"]
+constant USize.shiftLeft (a b : USize) : USize := (arbitrary Nat).toUSize
+@[extern c inline "#1 >> #2"]
+constant USize.shiftRight (a b : USize) : USize := (arbitrary Nat).toUSize
+def USize.lt (a b : USize) : Prop := a.val < b.val
+def USize.le (a b : USize) : Prop := a.val ≤ b.val
+
+instance : HasZero USize     := ⟨USize.ofNat 0⟩
+instance : HasOne USize      := ⟨USize.ofNat 1⟩
+instance : HasAdd USize      := ⟨USize.add⟩
+instance : HasSub USize      := ⟨USize.sub⟩
+instance : HasMul USize      := ⟨USize.mul⟩
+instance : HasMod USize      := ⟨USize.mod⟩
+instance : HasModn USize     := ⟨USize.modn⟩
+instance : HasDiv USize      := ⟨USize.div⟩
+instance : HasLess USize     := ⟨USize.lt⟩
+instance : HasLessEq USize   := ⟨USize.le⟩
+instance : Inhabited USize   := ⟨0⟩
+
+@[extern c inline "#1 == #2"]
+def USize.decEq (a b : USize) : Decidable (a = b) :=
+USize.casesOn a $ fun n => USize.casesOn b $ fun m =>
+  if h : n = m then isTrue (h ▸ rfl) else isFalse (fun h' => USize.noConfusion h' (fun h' => absurd h' h))
+
+@[extern c inline "#1 < #2"]
+def USize.decLt (a b : USize) : Decidable (a < b) :=
+USize.casesOn a $ fun n => USize.casesOn b $ fun m =>
+  inferInstanceAs (Decidable (n < m))
+
+@[extern c inline "#1 <= #2"]
+def USize.decLe (a b : USize) : Decidable (a ≤ b) :=
+USize.casesOn a $ fun n => USize.casesOn b $ fun m =>
+  inferInstanceAs (Decidable (n <= m))
+
+instance : DecidableEq USize := {decEq := USize.decEq}
+instance USize.hasDecidableLt (a b : USize) : Decidable (a < b) := USize.decLt a b
+instance USize.hasDecidableLe (a b : USize) : Decidable (a ≤ b) := USize.decLe a b
+
+theorem USize.modnLt {m : Nat} : ∀ (u : USize), m > 0 → USize.toNat (u %ₙ m) < m
+| ⟨u⟩, h => Fin.modnLt u h

stage0/src/Init/Default.lean

@@ -0,0 +1,15 @@
+/-
+Copyright (c) 2014 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Init.Core
+import Init.Control
+import Init.Data.Basic
+import Init.Coe
+import Init.WF
+import Init.Data
+import Init.System
+import Init.Util
+import Init.Fix

stage0/src/Init/Fix.lean

@@ -0,0 +1,80 @@
+/-
+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 Init.Data.UInt
+universe u
+
+def bfix1 {α β : Type u} (base : α → β) (rec : (α → β) → α → β) : Nat → α → β
+| 0,   a => base a
+| n+1, a => rec (bfix1 n) a
+
+@[extern c inline "lean_fixpoint(#4, #5)"]
+def fixCore1 {α β : Type u} (base : @& (α → β)) (rec : (α → β) → α → β) : α → β :=
+bfix1 base rec usizeSz
+
+@[inline] def fixCore {α β : Type u} (base : @& (α → β)) (rec : (α → β) → α → β) : α → β :=
+fixCore1 base rec
+
+@[inline] def fix1 {α β : Type u} [Inhabited β] (rec : (α → β) → α → β) : α → β :=
+fixCore1 (fun _ => arbitrary β) rec
+
+@[inline] def fix {α β : Type u} [Inhabited β] (rec : (α → β) → α → β) : α → β :=
+fixCore1 (fun _ => arbitrary β) rec
+
+def bfix2 {α₁ α₂ β : Type u} (base : α₁ → α₂ → β) (rec : (α₁ → α₂ → β) → α₁ → α₂ → β) : Nat → α₁ → α₂ → β
+| 0,   a₁, a₂ => base a₁ a₂
+| n+1, a₁, a₂ => rec (bfix2 n) a₁ a₂
+
+@[extern c inline "lean_fixpoint2(#5, #6, #7)"]
+def fixCore2 {α₁ α₂ β : Type u} (base : α₁ → α₂ → β) (rec : (α₁ → α₂ → β) → α₁ → α₂ → β) : α₁ → α₂ → β :=
+bfix2 base rec usizeSz
+
+@[inline] def fix2 {α₁ α₂ β : Type u} [Inhabited β] (rec : (α₁ → α₂ → β) → α₁ → α₂ → β) : α₁ → α₂ → β :=
+fixCore2 (fun _ _ => arbitrary β) rec
+
+def bfix3 {α₁ α₂ α₃ β : Type u} (base : α₁ → α₂ → α₃ → β) (rec : (α₁ → α₂ → α₃ → β) → α₁ → α₂ → α₃ → β) : Nat → α₁ → α₂ → α₃ → β
+| 0,   a₁, a₂, a₃ => base a₁ a₂ a₃
+| n+1, a₁, a₂, a₃ => rec (bfix3 n) a₁ a₂ a₃
+
+@[extern c inline "lean_fixpoint3(#6, #7, #8, #9)"]
+def fixCore3 {α₁ α₂ α₃ β : Type u} (base : α₁ → α₂ → α₃ → β) (rec : (α₁ → α₂ → α₃ → β) → α₁ → α₂ → α₃ → β) : α₁ → α₂ → α₃ → β :=
+bfix3 base rec usizeSz
+
+@[inline] def fix3 {α₁ α₂ α₃ β : Type u} [Inhabited β] (rec : (α₁ → α₂ → α₃ → β) → α₁ → α₂ → α₃ → β) : α₁ → α₂ → α₃ → β :=
+fixCore3 (fun _ _ _ => arbitrary β) rec
+
+def bfix4 {α₁ α₂ α₃ α₄ β : Type u} (base : α₁ → α₂ → α₃ → α₄ → β) (rec : (α₁ → α₂ → α₃ → α₄ → β) → α₁ → α₂ → α₃ → α₄ → β) : Nat → α₁ → α₂ → α₃ → α₄ → β
+| 0,   a₁, a₂, a₃, a₄ => base a₁ a₂ a₃ a₄
+| n+1, a₁, a₂, a₃, a₄ => rec (bfix4 n) a₁ a₂ a₃ a₄
+
+@[extern c inline "lean_fixpoint4(#7, #8, #9, #10, #11)"]
+def fixCore4 {α₁ α₂ α₃ α₄ β : Type u} (base : α₁ → α₂ → α₃ → α₄ → β) (rec : (α₁ → α₂ → α₃ → α₄ → β) → α₁ → α₂ → α₃ → α₄ → β) : α₁ → α₂ → α₃ → α₄ → β :=
+bfix4 base rec usizeSz
+
+@[inline] def fix4 {α₁ α₂ α₃ α₄ β : Type u} [Inhabited β] (rec : (α₁ → α₂ → α₃ → α₄ → β) → α₁ → α₂ → α₃ → α₄ → β) : α₁ → α₂ → α₃ → α₄ → β :=
+fixCore4 (fun _ _ _ _ => arbitrary β) rec
+
+def bfix5 {α₁ α₂ α₃ α₄ α₅ β : Type u} (base : α₁ → α₂ → α₃ → α₄ → α₅ → β) (rec : (α₁ → α₂ → α₃ → α₄ → α₅ → β) → α₁ → α₂ → α₃ → α₄ → α₅ → β) : Nat → α₁ → α₂ → α₃ → α₄ → α₅ → β
+| 0,   a₁, a₂, a₃, a₄, a₅ => base a₁ a₂ a₃ a₄ a₅
+| n+1, a₁, a₂, a₃, a₄, a₅ => rec (bfix5 n) a₁ a₂ a₃ a₄ a₅
+
+@[extern c inline "lean_fixpoint5(#8, #9, #10, #11, #12, #13)"]
+def fixCore5 {α₁ α₂ α₃ α₄ α₅ β : Type u} (base : α₁ → α₂ → α₃ → α₄ → α₅ → β) (rec : (α₁ → α₂ → α₃ → α₄ → α₅ → β) → α₁ → α₂ → α₃ → α₄ → α₅ → β) : α₁ → α₂ → α₃ → α₄ → α₅ → β :=
+bfix5 base rec usizeSz
+
+@[inline] def fix5 {α₁ α₂ α₃ α₄ α₅ β : Type u} [Inhabited β] (rec : (α₁ → α₂ → α₃ → α₄ → α₅ → β) → α₁ → α₂ → α₃ → α₄ → α₅ → β) : α₁ → α₂ → α₃ → α₄ → α₅ → β :=
+fixCore5 (fun _ _ _ _ _ => arbitrary β) rec
+
+def bfix6 {α₁ α₂ α₃ α₄ α₅ α₆ β : Type u} (base : α₁ → α₂ → α₃ → α₄ → α₅ → α₆ → β) (rec : (α₁ → α₂ → α₃ → α₄ → α₅ → α₆ → β) → α₁ → α₂ → α₃ → α₄ → α₅ → α₆ → β) : Nat → α₁ → α₂ → α₃ → α₄ → α₅ → α₆ → β
+| 0,   a₁, a₂, a₃, a₄, a₅, a₆ => base a₁ a₂ a₃ a₄ a₅ a₆
+| n+1, a₁, a₂, a₃, a₄, a₅, a₆ => rec (bfix6 n) a₁ a₂ a₃ a₄ a₅ a₆
+
+@[extern c inline "lean_fixpoint6(#9, #10, #11, #12, #13, #14, #15)"]
+def fixCore6 {α₁ α₂ α₃ α₄ α₅ α₆ β : Type u} (base : α₁ → α₂ → α₃ → α₄ → α₅ → α₆ → β) (rec : (α₁ → α₂ → α₃ → α₄ → α₅ → α₆ → β) → α₁ → α₂ → α₃ → α₄ → α₅ → α₆ → β) : α₁ → α₂ → α₃ → α₄ → α₅ → α₆ → β :=
+bfix6 base rec usizeSz
+
+@[inline] def fix6 {α₁ α₂ α₃ α₄ α₅ α₆ β : Type u} [Inhabited β] (rec : (α₁ → α₂ → α₃ → α₄ → α₅ → α₆ → β) → α₁ → α₂ → α₃ → α₄ → α₅ → α₆ → β) : α₁ → α₂ → α₃ → α₄ → α₅ → α₆ → β :=
+fixCore6 (fun _ _ _ _ _ _ => arbitrary β) rec

stage0/src/Init/Lean.lean

@@ -0,0 +1,25 @@
+/-
+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 Init.Lean.Path
+import Init.Lean.Compiler
+import Init.Lean.Environment
+import Init.Lean.Modifiers
+import Init.Lean.ProjFns
+import Init.Lean.Runtime
+import Init.Lean.Attributes
+import Init.Lean.Parser
+import Init.Lean.ReducibilityAttrs
+import Init.Lean.Elaborator
+import Init.Lean.EqnCompiler
+import Init.Lean.Class
+import Init.Lean.LocalContext
+import Init.Lean.MetavarContext
+import Init.Lean.TypeClass
+import Init.Lean.Trace
+import Init.Lean.AuxRecursor
+import Init.Lean.Linter
+import Init.Lean.Meta

stage0/src/Init/Lean/Attributes.lean

@@ -0,0 +1,318 @@
+/-
+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 Init.Lean.Scopes
+import Init.Lean.Syntax
+
+namespace Lean
+
+inductive AttributeApplicationTime
+| afterTypeChecking | afterCompilation | beforeElaboration
+
+structure AttributeImpl :=
+(name : Name)
+(descr : String)
+(add (env : Environment) (decl : Name) (args : Syntax) (persistent : Bool) : IO Environment)
+(addScoped (env : Environment) (decl : Name) (args : Syntax) : IO Environment
+           := throw (IO.userError ("attribute '" ++ toString name ++ "' does not support scopes")))
+(erase (env : Environment) (decl : Name) (persistent : Bool) : IO Environment
+       := throw (IO.userError ("attribute '" ++ toString name ++ "' does not support removal")))
+(activateScoped (env : Environment) (scope : Name) : IO Environment := pure env)
+(pushScope (env : Environment) : IO Environment := pure env)
+(popScope (env : Environment) : IO Environment := pure env)
+(applicationTime := AttributeApplicationTime.afterTypeChecking)
+
+instance AttributeImpl.inhabited : Inhabited AttributeImpl :=
+⟨{ name := arbitrary _, descr := arbitrary _, add := fun env _ _ _ => pure env }⟩
+
+def mkAttributeMapRef : IO (IO.Ref (HashMap Name AttributeImpl)) :=
+IO.mkRef {}
+
+@[init mkAttributeMapRef]
+constant attributeMapRef : IO.Ref (HashMap Name AttributeImpl) := arbitrary _
+
+def mkAttributeArrayRef : IO (IO.Ref (Array AttributeImpl)) :=
+IO.mkRef #[]
+
+@[init mkAttributeArrayRef]
+constant attributeArrayRef : IO.Ref (Array AttributeImpl) := arbitrary _
+
+/- Low level attribute registration function. -/
+def registerAttribute (attr : AttributeImpl) : IO Unit :=
+do m ← attributeMapRef.get;
+   when (m.contains attr.name) $ throw (IO.userError ("invalid attribute declaration, '" ++ toString attr.name ++ "' has already been used"));
+   initializing ← IO.initializing;
+   unless initializing $ throw (IO.userError ("failed to register attribute, attributes can only be registered during initialization"));
+   attributeMapRef.modify (fun m => m.insert attr.name attr);
+   attributeArrayRef.modify (fun attrs => attrs.push attr)
+
+/- Return true iff `n` is the name of a registered attribute. -/
+@[export lean_is_attribute]
+def isAttribute (n : Name) : IO Bool :=
+do m ← attributeMapRef.get; pure (m.contains n)
+
+/- Return the name of all registered attributes. -/
+def getAttributeNames : IO (List Name) :=
+do m ← attributeMapRef.get; pure $ m.fold (fun r n _ => n::r) []
+
+def getAttributeImpl (attrName : Name) : IO AttributeImpl :=
+do m ← attributeMapRef.get;
+   match m.find attrName with
+   | some attr => pure attr
+   | none      => throw (IO.userError ("unknown attribute '" ++ toString attrName ++ "'"))
+
+@[export lean_attribute_application_time]
+def attributeApplicationTime (n : Name) : IO AttributeApplicationTime :=
+do attr ← getAttributeImpl n;
+   pure attr.applicationTime
+
+namespace Environment
+
+/- Add attribute `attr` to declaration `decl` with arguments `args`. If `persistent == true`, then attribute is saved on .olean file.
+   It throws an error when
+   - `attr` is not the name of an attribute registered in the system.
+   - `attr` does not support `persistent == false`.
+   - `args` is not valid for `attr`. -/
+@[export lean_add_attribute]
+def addAttribute (env : Environment) (decl : Name) (attrName : Name) (args : Syntax := Syntax.missing) (persistent := true) : IO Environment :=
+do attr ← getAttributeImpl attrName;
+   attr.add env decl args persistent
+
+/- Add a scoped attribute `attr` to declaration `decl` with arguments `args` and scope `decl.getPrefix`.
+   Scoped attributes are always persistent.
+   It returns `Except.error` when
+   - `attr` is not the name of an attribute registered in the system.
+   - `attr` does not support scoped attributes.
+   - `args` is not valid for `attr`.
+
+   Remark: the attribute will not be activated if `decl` is not inside the current namespace `env.getNamespace`. -/
+@[export lean_add_scoped_attribute]
+def addScopedAttribute (env : Environment) (decl : Name) (attrName : Name) (args : Syntax := Syntax.missing) : IO Environment :=
+do attr ← getAttributeImpl attrName;
+   attr.addScoped env decl args
+
+/- Remove attribute `attr` from declaration `decl`. The effect is the current scope.
+   It returns `Except.error` when
+   - `attr` is not the name of an attribute registered in the system.
+   - `attr` does not support erasure.
+   - `args` is not valid for `attr`. -/
+@[export lean_erase_attribute]
+def eraseAttribute (env : Environment) (decl : Name) (attrName : Name) (persistent := true) : IO Environment :=
+do attr ← getAttributeImpl attrName;
+   attr.erase env decl persistent
+
+/- Activate the scoped attribute `attr` for all declarations in scope `scope`.
+   We use this function to implement the command `open foo`. -/
+@[export lean_activate_scoped_attribute]
+def activateScopedAttribute (env : Environment) (attrName : Name) (scope : Name) : IO Environment :=
+do attr ← getAttributeImpl attrName;
+   attr.activateScoped env scope
+
+/- Activate all scoped attributes at `scope` -/
+@[export lean_activate_scoped_attributes]
+def activateScopedAttributes (env : Environment) (scope : Name) : IO Environment :=
+do attrs ← attributeArrayRef.get;
+   attrs.foldlM (fun env attr => attr.activateScoped env scope) env
+
+/- We use this function to implement commands `namespace foo` and `section foo`.
+   It activates scoped attributes in the new resulting namespace. -/
+@[export lean_push_scope]
+def pushScope (env : Environment) (header : Name) (isNamespace : Bool) : IO Environment :=
+do let env := env.pushScopeCore header isNamespace;
+   let ns  := env.getNamespace;
+   attrs ← attributeArrayRef.get;
+   attrs.foldlM (fun env attr => do env ← attr.pushScope env; if isNamespace then attr.activateScoped env ns else pure env) env
+
+/- We use this function to implement commands `end foo` for closing namespaces and sections. -/
+@[export lean_pop_scope]
+def popScope (env : Environment) : IO Environment :=
+do let env := env.popScopeCore;
+   attrs ← attributeArrayRef.get;
+   attrs.foldlM (fun env attr => attr.popScope env) env
+
+end Environment
+
+/--
+   Tag attributes are simple and efficient. They are useful for marking declarations in the modules where
+   they were defined.
+
+   The startup cost for this kind of attribute is very small since `addImportedFn` is a constant function.
+
+   They provide the predicate `tagAttr.hasTag env decl` which returns true iff declaration `decl`
+   is tagged in the environment `env`. -/
+structure TagAttribute :=
+(attr : AttributeImpl)
+(ext  : PersistentEnvExtension Name NameSet)
+
+def registerTagAttribute (name : Name) (descr : String) (validate : Environment → Name → Except String Unit := fun _ _ => Except.ok ()) : IO TagAttribute :=
+do ext : PersistentEnvExtension Name NameSet ← registerPersistentEnvExtension {
+     name            := name,
+     addImportedFn   := fun _ => pure {},
+     addEntryFn      := fun (s : NameSet) n => s.insert n,
+     exportEntriesFn := fun es =>
+       let r : Array Name := es.fold (fun a e => a.push e) #[];
+       r.qsort Name.quickLt,
+     statsFn         := fun s => "tag attribute" ++ Format.line ++ "number of local entries: " ++ format s.size
+   };
+   let attrImpl : AttributeImpl := {
+     name  := name,
+     descr := descr,
+     add   := fun env decl args persistent => do
+       unless args.isMissing $ throw (IO.userError ("invalid attribute '" ++ toString name ++ "', unexpected argument"));
+       unless persistent $ throw (IO.userError ("invalid attribute '" ++ toString name ++ "', must be persistent"));
+       unless (env.getModuleIdxFor decl).isNone $
+         throw (IO.userError ("invalid attribute '" ++ toString name ++ "', declaration is in an imported module"));
+       match validate env decl with
+       | Except.error msg => throw (IO.userError ("invalid attribute '" ++ toString name ++ "', " ++ msg))
+       | _                => pure $ ext.addEntry env decl
+   };
+   registerAttribute attrImpl;
+   pure { attr := attrImpl, ext := ext }
+
+namespace TagAttribute
+
+instance : Inhabited TagAttribute := ⟨{attr := arbitrary _, ext := arbitrary _}⟩
+
+def hasTag (attr : TagAttribute) (env : Environment) (decl : Name) : Bool :=
+match env.getModuleIdxFor decl with
+| some modIdx => (attr.ext.getModuleEntries env modIdx).binSearchContains decl Name.quickLt
+| none        => (attr.ext.getState env).contains decl
+
+end TagAttribute
+
+/--
+   A `TagAttribute` variant where we can attach parameters to attributes.
+   It is slightly more expensive and consumes a little bit more memory than `TagAttribute`.
+
+   They provide the function `pAttr.getParam env decl` which returns `some p` iff declaration `decl`
+   contains the attribute `pAttr` with parameter `p`. -/
+structure ParametricAttribute (α : Type) :=
+(attr : AttributeImpl)
+(ext  : PersistentEnvExtension (Name × α) (NameMap α))
+
+def registerParametricAttribute {α : Type} [Inhabited α] (name : Name) (descr : String)
+       (getParam : Environment → Name → Syntax → Except String α)
+       (afterSet : Environment → Name → α → Except String Environment := fun env _ _ => Except.ok env) : IO (ParametricAttribute α) :=
+do ext : PersistentEnvExtension (Name × α) (NameMap α) ← registerPersistentEnvExtension {
+     name            := name,
+     addImportedFn   := fun _ => pure {},
+     addEntryFn      := fun (s : NameMap α) (p : Name × α) => s.insert p.1 p.2,
+     exportEntriesFn := fun m =>
+       let r : Array (Name × α) := m.fold (fun a n p => a.push (n, p)) #[];
+       r.qsort (fun a b => Name.quickLt a.1 b.1),
+     statsFn         := fun s => "parametric attribute" ++ Format.line ++ "number of local entries: " ++ format s.size
+   };
+   let attrImpl : AttributeImpl := {
+     name  := name,
+     descr := descr,
+     add   := fun env decl args persistent => do
+       unless persistent $ throw (IO.userError ("invalid attribute '" ++ toString name ++ "', must be persistent"));
+       unless (env.getModuleIdxFor decl).isNone $
+         throw (IO.userError ("invalid attribute '" ++ toString name ++ "', declaration is in an imported module"));
+       match getParam env decl args with
+       | Except.error msg => throw (IO.userError ("invalid attribute '" ++ toString name ++ "', " ++ msg))
+       | Except.ok val    => do
+         let env := ext.addEntry env (decl, val);
+         match afterSet env decl val with
+         | Except.error msg => throw (IO.userError ("invalid attribute '" ++ toString name ++ "', " ++ msg))
+         | Except.ok env    => pure env
+   };
+   registerAttribute attrImpl;
+   pure { attr := attrImpl, ext := ext }
+
+namespace ParametricAttribute
+
+instance {α : Type} : Inhabited (ParametricAttribute α) := ⟨{attr := arbitrary _, ext := arbitrary _}⟩
+
+def getParam {α : Type} [Inhabited α] (attr : ParametricAttribute α) (env : Environment) (decl : Name) : Option α :=
+match env.getModuleIdxFor decl with
+| some modIdx =>
+  match (attr.ext.getModuleEntries env modIdx).binSearch (decl, arbitrary _) (fun a b => Name.quickLt a.1 b.1) with
+  | some (_, val) => some val
+  | none          => none
+| none        => (attr.ext.getState env).find decl
+
+def setParam {α : Type} (attr : ParametricAttribute α) (env : Environment) (decl : Name) (param : α) : Except String Environment :=
+if (env.getModuleIdxFor decl).isSome then
+  Except.error ("invalid '" ++ toString attr.attr.name ++ "'.setParam, declaration is in an imported module")
+else if ((attr.ext.getState env).find decl).isSome then
+  Except.error ("invalid '" ++ toString attr.attr.name ++ "'.setParam, attribute has already been set")
+else
+  Except.ok (attr.ext.addEntry env (decl, param))
+
+end ParametricAttribute
+
+/-
+  Given a list `[a₁, ..., a_n]` of elements of type `α`, `EnumAttributes` provides an attribute `Attr_i` for
+  associating a value `a_i` with an declaration. `α` is usually an enumeration type.
+  Note that whenever we register an `EnumAttributes`, we create `n` attributes, but only one environment extension. -/
+structure EnumAttributes (α : Type) :=
+(attrs : List AttributeImpl)
+(ext   : PersistentEnvExtension (Name × α) (NameMap α))
+
+def registerEnumAttributes {α : Type} [Inhabited α] (extName : Name) (attrDescrs : List (Name × String × α)) (validate : Environment → Name → α → Except String Unit := fun _ _ _ => Except.ok ()) (applicationTime := AttributeApplicationTime.afterTypeChecking) : IO (EnumAttributes α) :=
+do ext : PersistentEnvExtension (Name × α) (NameMap α) ← registerPersistentEnvExtension {
+     name            := extName,
+     addImportedFn   := fun _ => pure {},
+     addEntryFn      := fun (s : NameMap α) (p : Name × α) => s.insert p.1 p.2,
+     exportEntriesFn := fun m =>
+       let r : Array (Name × α) := m.fold (fun a n p => a.push (n, p)) #[];
+       r.qsort (fun a b => Name.quickLt a.1 b.1),
+     statsFn         := fun s => "enumeration attribute extension" ++ Format.line ++ "number of local entries: " ++ format s.size
+   };
+   let attrs := attrDescrs.map $ fun ⟨name, descr, val⟩ => { AttributeImpl .
+     name            := name,
+     descr           := descr,
+     applicationTime := applicationTime,
+     add             := fun env decl args persistent => do
+       unless persistent $ throw (IO.userError ("invalid attribute '" ++ toString name ++ "', must be persistent"));
+       unless (env.getModuleIdxFor decl).isNone $
+         throw (IO.userError ("invalid attribute '" ++ toString name ++ "', declaration is in an imported module"));
+       match validate env decl val with
+       | Except.error msg => throw (IO.userError ("invalid attribute '" ++ toString name ++ "', " ++ msg))
+       | _                => pure $ ext.addEntry env (decl, val)
+   };
+   attrs.forM registerAttribute;
+   pure { ext := ext, attrs := attrs }
+
+namespace EnumAttributes
+
+instance {α : Type} : Inhabited (EnumAttributes α) := ⟨{attrs := [], ext := arbitrary _}⟩
+
+def getValue {α : Type} [Inhabited α] (attr : EnumAttributes α) (env : Environment) (decl : Name) : Option α :=
+match env.getModuleIdxFor decl with
+| some modIdx =>
+  match (attr.ext.getModuleEntries env modIdx).binSearch (decl, arbitrary _) (fun a b => Name.quickLt a.1 b.1) with
+  | some (_, val) => some val
+  | none          => none
+| none        => (attr.ext.getState env).find decl
+
+def setValue {α : Type} (attrs : EnumAttributes α) (env : Environment) (decl : Name) (val : α) : Except String Environment :=
+if (env.getModuleIdxFor decl).isSome then
+  Except.error ("invalid '" ++ toString attrs.ext.name ++ "'.setValue, declaration is in an imported module")
+else if ((attrs.ext.getState env).find decl).isSome then
+  Except.error ("invalid '" ++ toString attrs.ext.name ++ "'.setValue, attribute has already been set")
+else
+  Except.ok (attrs.ext.addEntry env (decl, val))
+
+end EnumAttributes
+
+/- Helper function for converting a Syntax object representing attribute parameters into an identifier.
+   It returns `none` if the parameter is not a simple identifier.
+
+   Remark: in the future, attributes should define their own parsers, and we should use `match_syntax` to
+   decode the Syntax object. -/
+def attrParamSyntaxToIdentifier (s : Syntax) : Option Name :=
+match s with
+| Syntax.node k args =>
+  if k == nullKind && args.size == 1 then match args.get! 0 with
+    | Syntax.ident _ _ id _ => some id
+    | _ => none
+  else
+    none
+| _ => none
+
+end Lean

stage0/src/Init/Lean/AuxRecursor.lean

@@ -0,0 +1,39 @@
+/-
+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 Init.Lean.Environment
+
+namespace Lean
+
+def mkAuxRecursorExtension : IO TagDeclarationExtension :=
+mkTagDeclarationExtension `auxRec
+
+@[init mkAuxRecursorExtension]
+constant auxRecExt : TagDeclarationExtension := arbitrary _
+
+@[export lean_mark_aux_recursor]
+def markAuxRecursor (env : Environment) (n : Name) : Environment :=
+auxRecExt.tag env n
+
+@[export lean_is_aux_recursor]
+def isAuxRecursor (env : Environment) (n : Name) : Bool :=
+auxRecExt.isTagged env n
+
+def mkNoConfusionExtension : IO TagDeclarationExtension :=
+mkTagDeclarationExtension `noConf
+
+@[init mkNoConfusionExtension]
+constant noConfusionExt : TagDeclarationExtension := arbitrary _
+
+@[export lean_mark_no_confusion]
+def markNoConfusion (env : Environment) (n : Name) : Environment :=
+noConfusionExt.tag env n
+
+@[export lean_is_no_confusion]
+def isNoConfusion (env : Environment) (n : Name) : Bool :=
+noConfusionExt.isTagged env n
+
+end Lean

stage0/src/Init/Lean/Class.lean

@@ -0,0 +1,144 @@
+/-
+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 Init.Lean.Attributes
+
+namespace Lean
+
+inductive ClassEntry
+| «class»    (name : Name) (hasOutParam : Bool)
+| «instance» (name : Name) (ofClass : Name)
+
+namespace ClassEntry
+
+@[inline] def getName : ClassEntry → Name
+| «class» n _ => n
+| «instance» n _ => n
+
+def lt (a b : ClassEntry) : Bool :=
+Name.quickLt a.getName b.getName
+
+end ClassEntry
+
+structure ClassState :=
+(classToInstances : SMap Name (List Name) := SMap.empty)
+(hasOutParam      : SMap Name Bool := SMap.empty)
+(instances        : SMap Name Unit := SMap.empty)
+
+namespace ClassState
+
+instance : Inhabited ClassState := ⟨{}⟩
+
+def addEntry (s : ClassState) (entry : ClassEntry) : ClassState :=
+match entry with
+| ClassEntry.«class» clsName hasOutParam =>
+  { hasOutParam := s.hasOutParam.insert clsName hasOutParam, .. s }
+| ClassEntry.«instance» instName clsName =>
+  { instances        := s.instances.insert instName (),
+    classToInstances := match s.classToInstances.find clsName with
+      | some insts => s.classToInstances.insert clsName (instName :: insts)
+      | none       => s.classToInstances.insert clsName [instName],
+    .. s }
+
+def switch : ClassState → ClassState
+| ⟨m₁, m₂, m₃⟩ => ⟨m₁.switch, m₂.switch, m₃.switch⟩
+
+end ClassState
+
+/- TODO: add support for scoped instances -/
+def mkClassExtension : IO (SimplePersistentEnvExtension ClassEntry ClassState) :=
+registerSimplePersistentEnvExtension {
+  name          := `classExt,
+  addEntryFn    := ClassState.addEntry,
+  addImportedFn := fun es => (mkStateFromImportedEntries ClassState.addEntry {} es).switch
+}
+
+@[init mkClassExtension]
+constant classExtension : SimplePersistentEnvExtension ClassEntry ClassState := arbitrary _
+
+@[export lean_is_class]
+def isClass (env : Environment) (n : Name) : Bool :=
+(classExtension.getState env).hasOutParam.contains n
+
+@[export lean_is_instance]
+def isInstance (env : Environment) (n : Name) : Bool :=
+(classExtension.getState env).instances.contains n
+
+@[export lean_get_class_instances]
+def getClassInstances (env : Environment) (n : Name) : List Name :=
+match (classExtension.getState env).classToInstances.find n with
+| some insts => insts
+| none       => []
+
+@[export lean_has_out_params]
+def hasOutParams (env : Environment) (n : Name) : Bool :=
+match (classExtension.getState env).hasOutParam.find n with
+| some b => b
+| none   => false
+
+@[export lean_is_out_param]
+def isOutParam (e : Expr) : Bool :=
+e.isAppOfArity `outParam 1
+
+def Expr.hasOutParam : Expr → Bool
+| Expr.forallE _ d b _ => isOutParam d || Expr.hasOutParam b
+| _                    => false
+
+def addClass (env : Environment) (clsName : Name) : Except String Environment :=
+if isClass env clsName then Except.error ("class has already been declared '" ++ toString clsName ++ "'")
+else match env.find clsName with
+  | none      => Except.error ("unknown declaration '" ++ toString clsName ++ "'")
+  | some decl@(ConstantInfo.inductInfo _) => Except.ok (classExtension.addEntry env (ClassEntry.«class» clsName decl.type.hasOutParam))
+  | some _    => Except.error ("invalid 'class', declaration '" ++ toString clsName ++ "' must be inductive datatype or structure")
+
+private def consumeNLambdas : Nat → Expr → Option Expr
+| 0,   e                => some e
+| i+1, Expr.lam _ _ b _ => consumeNLambdas i b
+| _,   _                => none
+
+partial def getClassName (env : Environment) : Expr → Option Name
+| Expr.forallE _ _ b _ => getClassName b
+| e                    => do
+  Expr.const c _ _ ← pure e.getAppFn | none;
+  info ← env.find c;
+  match info.value? with
+  | some val => do
+    body ← consumeNLambdas e.getAppNumArgs val;
+    getClassName body
+  | none =>
+    if isClass env c then some c
+    else none
+
+@[export lean_add_instance]
+def addInstance (env : Environment) (instName : Name) : Except String Environment :=
+match env.find instName with
+| none      => Except.error ("unknown declaration '" ++ toString instName ++ "'")
+| some decl =>
+  match getClassName env decl.type with
+  | none => Except.error ("invalid instance '" ++ toString instName ++ "', failed to retrieve class")
+  | some clsName => Except.ok (classExtension.addEntry env (ClassEntry.«instance» instName clsName))
+
+@[init] def registerClassAttr : IO Unit :=
+registerAttribute {
+  name  := `class,
+  descr := "type class",
+  add   := fun env decl args persistent => do
+    unless args.isMissing $ throw (IO.userError ("invalid attribute 'class', unexpected argument"));
+    unless persistent $ throw (IO.userError ("invalid attribute 'class', must be persistent"));
+    IO.ofExcept (addClass env decl)
+}
+
+@[init] def registerInstanceAttr : IO Unit :=
+registerAttribute {
+  name  := `instance,
+  descr := "type class instance",
+  add   := fun env decl args persistent => do
+    unless args.isMissing $ throw (IO.userError ("invalid attribute 'instance', unexpected argument"));
+    unless persistent $ throw (IO.userError ("invalid attribute 'instance', must be persistent"));
+    IO.ofExcept (addInstance env decl)
+}
+
+end Lean

stage0/src/Init/Lean/Compiler.lean

@@ -0,0 +1,14 @@
+/-
+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 Init.Lean.Compiler.InlineAttrs
+import Init.Lean.Compiler.Specialize
+import Init.Lean.Compiler.ConstFolding
+import Init.Lean.Compiler.ClosedTermCache
+import Init.Lean.Compiler.ExternAttr
+import Init.Lean.Compiler.ImplementedByAttr
+import Init.Lean.Compiler.NeverExtractAttr
+import Init.Lean.Compiler.IR

stage0/src/Init/Lean/Compiler/ClosedTermCache.lean

@@ -0,0 +1,33 @@
+/-
+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 Init.Lean.Environment
+
+namespace Lean
+
+abbrev ClosedTermCache := SMap Expr Name
+
+def mkClosedTermCacheExtension : IO (SimplePersistentEnvExtension (Expr × Name) ClosedTermCache) :=
+registerSimplePersistentEnvExtension {
+  name       := `closedTermCache,
+  addImportedFn := fun as =>
+    let cache : ClosedTermCache := mkStateFromImportedEntries (fun s (p : Expr × Name) => s.insert p.1 p.2) {} as;
+    cache.switch,
+  addEntryFn := fun s ⟨e, n⟩ => s.insert e n
+}
+
+@[init mkClosedTermCacheExtension]
+constant closedTermCacheExt : SimplePersistentEnvExtension (Expr × Name) ClosedTermCache := arbitrary _
+
+@[export lean_cache_closed_term_name]
+def cacheClosedTermName (env : Environment) (e : Expr) (n : Name) : Environment :=
+closedTermCacheExt.addEntry env (e, n)
+
+@[export lean_get_closed_term_name]
+def getClosedTermName (env : Environment) (e : Expr) : Option Name :=
+(closedTermCacheExt.getState env).find e
+
+end Lean

stage0/src/Init/Lean/Compiler/ConstFolding.lean

@@ -0,0 +1,205 @@
+/-
+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 Init.System.Platform
+import Init.Lean.Expr
+import Init.Lean.Compiler.Util
+
+/- Constant folding for primitives that have special runtime support. -/
+
+namespace Lean
+namespace Compiler
+
+def BinFoldFn := Bool → Expr → Expr → Option Expr
+def UnFoldFn  := Bool → Expr → Option Expr
+
+def mkUIntTypeName (nbytes : Nat) : Name :=
+mkNameSimple ("UInt" ++ toString nbytes)
+
+structure NumScalarTypeInfo :=
+(nbits : Nat)
+(id : Name      := mkUIntTypeName nbits)
+(ofNatFn : Name := mkNameStr id "ofNat")
+(toNatFn : Name := mkNameStr id "toNat")
+(size : Nat     := 2^nbits)
+
+def numScalarTypes : List NumScalarTypeInfo :=
+[{nbits := 8}, {nbits := 16}, {nbits := 32}, {nbits := 64},
+ {id := `USize, nbits := System.Platform.numBits}]
+
+def isOfNat (fn : Name) : Bool :=
+numScalarTypes.any (fun info => info.ofNatFn == fn)
+
+def isToNat (fn : Name) : Bool :=
+numScalarTypes.any (fun info => info.toNatFn == fn)
+
+def getInfoFromFn (fn : Name) : List NumScalarTypeInfo → Option NumScalarTypeInfo
+| []          => none
+| info::infos =>
+  if info.ofNatFn == fn then some info
+  else getInfoFromFn infos
+
+def getInfoFromVal : Expr → Option NumScalarTypeInfo
+| Expr.app (Expr.const fn _ _) _ _ => getInfoFromFn fn numScalarTypes
+| _                                => none
+
+@[export lean_get_num_lit]
+def getNumLit : Expr → Option Nat
+| Expr.lit (Literal.natVal n) _    => some n
+| Expr.app (Expr.const fn _ _) a _ => if isOfNat fn then getNumLit a else none
+| _                                => none
+
+def mkUIntLit (info : NumScalarTypeInfo) (n : Nat) : Expr :=
+mkApp (mkConst info.ofNatFn) (mkNatLit (n%info.size))
+
+def mkUInt32Lit (n : Nat) : Expr :=
+mkUIntLit {nbits := 32} n
+
+def foldBinUInt (fn : NumScalarTypeInfo → Bool → Nat → Nat → Nat) (beforeErasure : Bool) (a₁ a₂ : Expr) : Option Expr :=
+do n₁   ← getNumLit a₁;
+   n₂   ← getNumLit a₂;
+   info ← getInfoFromVal a₁;
+   pure $ mkUIntLit info (fn info beforeErasure n₁ n₂)
+
+def foldUIntAdd := foldBinUInt $ fun _ _ => HasAdd.add
+def foldUIntMul := foldBinUInt $ fun _ _ => HasMul.mul
+def foldUIntDiv := foldBinUInt $ fun _ _ => HasDiv.div
+def foldUIntMod := foldBinUInt $ fun _ _ => HasMod.mod
+def foldUIntSub := foldBinUInt $ fun info _ a b => (a + (info.size - b))
+
+def preUIntBinFoldFns : List (Name × BinFoldFn) :=
+[(`add, foldUIntAdd), (`mul, foldUIntMul), (`div, foldUIntDiv),
+ (`mod, foldUIntMod), (`sub, foldUIntSub)]
+
+def uintBinFoldFns : List (Name × BinFoldFn) :=
+numScalarTypes.foldl (fun r info => r ++ (preUIntBinFoldFns.map (fun ⟨suffix, fn⟩ => (info.id ++ suffix, fn)))) []
+
+def foldNatBinOp (fn : Nat → Nat → Nat) (a₁ a₂ : Expr) : Option Expr :=
+do n₁   ← getNumLit a₁;
+   n₂   ← getNumLit a₂;
+   pure $ mkNatLit (fn n₁ n₂)
+
+def foldNatAdd (_ : Bool) := foldNatBinOp HasAdd.add
+def foldNatMul (_ : Bool) := foldNatBinOp HasMul.mul
+def foldNatDiv (_ : Bool) := foldNatBinOp HasDiv.div
+def foldNatMod (_ : Bool) := foldNatBinOp HasMod.mod
+def foldNatPow (_ : Bool) := foldNatBinOp HasPow.pow
+
+def mkNatEq (a b : Expr) : Expr :=
+mkAppN (mkConst `Eq [levelOne]) #[(mkConst `Nat), a, b]
+
+def mkNatLt (a b : Expr) : Expr :=
+mkAppN (mkConst `HasLt.lt [levelZero]) #[mkConst `Nat, mkConst `Nat.HasLt, a, b]
+
+def mkNatLe (a b : Expr) : Expr :=
+mkAppN (mkConst `HasLt.le [levelZero]) #[mkConst `Nat, mkConst `Nat.HasLe, a, b]
+
+def toDecidableExpr (beforeErasure : Bool) (pred : Expr) (r : Bool) : Expr :=
+match beforeErasure, r with
+| false, true  => mkDecIsTrue  neutralExpr neutralExpr
+| false, false => mkDecIsFalse neutralExpr neutralExpr
+| true,  true  => mkDecIsTrue pred (mkLcProof pred)
+| true,  false => mkDecIsFalse pred (mkLcProof pred)
+
+def foldNatBinPred (mkPred : Expr → Expr → Expr) (fn : Nat → Nat → Bool)
+                      (beforeErasure : Bool) (a₁ a₂ : Expr) : Option Expr :=
+do n₁   ← getNumLit a₁;
+   n₂   ← getNumLit a₂;
+   pure $ toDecidableExpr beforeErasure (mkPred a₁ a₂) (fn n₁ n₂)
+
+def foldNatDecEq := foldNatBinPred mkNatEq (fun a b => a = b)
+def foldNatDecLt := foldNatBinPred mkNatLt (fun a b => a < b)
+def foldNatDecLe := foldNatBinPred mkNatLe (fun a b => a ≤ b)
+
+def natFoldFns : List (Name × BinFoldFn) :=
+[(`Nat.add, foldNatAdd),
+ (`Nat.mul, foldNatMul),
+ (`Nat.div, foldNatDiv),
+ (`Nat.mod, foldNatMod),
+ (`Nat.pow, foldNatPow),
+ (`Nat.pow._main, foldNatPow),
+ (`Nat.decEq, foldNatDecEq),
+ (`Nat.decLt, foldNatDecLt),
+ (`Nat.decLe, foldNatDecLe)]
+
+def getBoolLit : Expr → Option Bool
+| Expr.const `Bool.true _ _  => some true
+| Expr.const `Bool.false _ _ => some false
+| _                          => none
+
+def foldStrictAnd (_ : Bool) (a₁ a₂ : Expr) : Option Expr :=
+let v₁ := getBoolLit a₁;
+let v₂ := getBoolLit a₂;
+match v₁, v₂ with
+| some true,  _ => a₂
+| some false, _ => a₁
+| _, some true  => a₁
+| _, some false => a₂
+| _, _          => none
+
+def foldStrictOr (_ : Bool) (a₁ a₂ : Expr) : Option Expr :=
+let v₁ := getBoolLit a₁;
+let v₂ := getBoolLit a₂;
+match v₁, v₂ with
+| some true,  _ => a₁
+| some false, _ => a₂
+| _, some true  => a₂
+| _, some false => a₁
+| _, _          => none
+
+def boolFoldFns : List (Name × BinFoldFn) :=
+[(`strictOr, foldStrictOr), (`strictAnd, foldStrictAnd)]
+
+def binFoldFns : List (Name × BinFoldFn) :=
+boolFoldFns ++ uintBinFoldFns ++ natFoldFns
+
+def foldNatSucc (_ : Bool) (a : Expr) : Option Expr :=
+do n   ← getNumLit a;
+   pure $ mkNatLit (n+1)
+
+def foldCharOfNat (beforeErasure : Bool) (a : Expr) : Option Expr :=
+do guard (!beforeErasure);
+   n ← getNumLit a;
+   pure $
+     if isValidChar n.toUInt32 then mkUInt32Lit n
+     else mkUInt32Lit 0
+
+def foldToNat (_ : Bool) (a : Expr) : Option Expr :=
+do n ← getNumLit a;
+   pure $ mkNatLit n
+
+def uintFoldToNatFns : List (Name × UnFoldFn) :=
+numScalarTypes.foldl (fun r info => (info.toNatFn, foldToNat) :: r) []
+
+def unFoldFns : List (Name × UnFoldFn) :=
+[(`Nat.succ, foldNatSucc),
+ (`Char.ofNat, foldCharOfNat)]
+++ uintFoldToNatFns
+
+def findBinFoldFn (fn : Name) : Option BinFoldFn :=
+binFoldFns.lookup fn
+
+def findUnFoldFn (fn : Name) : Option UnFoldFn :=
+unFoldFns.lookup fn
+
+@[export lean_fold_bin_op]
+def foldBinOp (beforeErasure : Bool) (f : Expr) (a : Expr) (b : Expr) : Option Expr :=
+match f with
+| Expr.const fn _ _ => do
+   foldFn ← findBinFoldFn fn;
+   foldFn beforeErasure a b
+| _ => none
+
+@[export lean_fold_un_op]
+def foldUnOp (beforeErasure : Bool) (f : Expr) (a : Expr) : Option Expr :=
+match f with
+| Expr.const fn _ _ => do
+   foldFn ← findUnFoldFn fn;
+   foldFn beforeErasure a
+| _ => none
+
+end Compiler
+end Lean

stage0/src/Init/Lean/Compiler/ExportAttr.lean

@@ -0,0 +1,38 @@
+/-
+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 Init.Lean.Attributes
+
+namespace Lean
+
+private def isValidCppId (id : String) : Bool :=
+let first := id.get 0;
+first.isAlpha  && (id.toSubstring.drop 1).all (fun c => c.isAlpha || c.isDigit || c == '_')
+
+private def isValidCppName : Name → Bool
+| Name.str Name.anonymous s _ => isValidCppId s
+| Name.str p s _              => isValidCppId s && isValidCppName p
+| _                           => false
+
+def mkExportAttr : IO (ParametricAttribute Name) :=
+registerParametricAttribute `export "name to be used by code generators" $ fun _ _ stx =>
+  match attrParamSyntaxToIdentifier stx with
+  | some exportName =>
+    if isValidCppName exportName then Except.ok exportName
+    else Except.error "invalid 'export' function name, is not a valid C++ identifier"
+  | _ => Except.error "unexpected kind of argument"
+
+@[init mkExportAttr]
+constant exportAttr : ParametricAttribute Name := arbitrary _
+
+@[export lean_get_export_name_for]
+def getExportNameFor (env : Environment) (n : Name) : Option Name :=
+exportAttr.getParam env n
+
+def isExport (env : Environment) (n : Name) : Bool :=
+(getExportNameFor env n).isSome
+
+end Lean

stage0/src/Init/Lean/Compiler/ExternAttr.lean

@@ -0,0 +1,161 @@
+/-
+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 Init.Data.Option.Basic
+import Init.Lean.Expr
+import Init.Lean.Environment
+import Init.Lean.Attributes
+import Init.Lean.ProjFns
+
+namespace Lean
+
+inductive ExternEntry
+| adhoc    (backend : Name)
+| inline   (backend : Name) (pattern : String)
+| standard (backend : Name) (fn : String)
+| foreign  (backend : Name) (fn : String)
+
+/-
+- `@[extern]`
+   encoding: ```.entries = [adhoc `all]```
+- `@[extern "level_hash"]`
+   encoding: ```.entries = [standard `all "levelHash"]```
+- `@[extern cpp "lean::string_size" llvm "lean_str_size"]`
+   encoding: ```.entries = [standard `cpp "lean::string_size", standard `llvm "leanStrSize"]```
+- `@[extern cpp inline "#1 + #2"]`
+   encoding: ```.entries = [inline `cpp "#1 + #2"]```
+- `@[extern cpp "foo" llvm adhoc]`
+   encoding: ```.entries = [standard `cpp "foo", adhoc `llvm]```
+- `@[extern 2 cpp "io_prim_println"]`
+   encoding: ```.arity = 2, .entries = [standard `cpp "ioPrimPrintln"]```
+-/
+structure ExternAttrData :=
+(arity    : Option Nat := none)
+(entries  : List ExternEntry)
+
+instance ExternAttrData.inhabited : Inhabited ExternAttrData := ⟨{ entries := [] }⟩
+
+private partial def syntaxToExternEntries (a : Array Syntax) : Nat → List ExternEntry → Except String (List ExternEntry)
+| i, entries =>
+  if i == a.size then Except.ok entries
+  else match a.get! i with
+    | Syntax.ident _ _ backend _ =>
+      let i := i + 1;
+      if i == a.size then Except.error "string or identifier expected"
+      else match (a.get! i).isIdOrAtom with
+        | some "adhoc"  => syntaxToExternEntries (i+1) (ExternEntry.adhoc backend :: entries)
+        | some "inline" =>
+          let i := i + 1;
+          match (a.get! i).isStrLit with
+          | some pattern => syntaxToExternEntries (i+1) (ExternEntry.inline backend pattern :: entries)
+          | none => Except.error "string literal expected"
+        | _ => match (a.get! i).isStrLit with
+          | some fn => syntaxToExternEntries (i+1) (ExternEntry.standard backend fn :: entries)
+          | none => Except.error "string literal expected"
+    | _ => Except.error "identifier expected"
+
+private def syntaxToExternAttrData (s : Syntax) : ExceptT String Id ExternAttrData :=
+match s with
+| Syntax.missing => Except.ok { entries := [ ExternEntry.adhoc `all ] }
+| Syntax.node _ args =>
+  if args.size == 0 then Except.error "unexpected kind of argument"
+  else
+    let (arity, i) : Option Nat × Nat := match (args.get! 0).isNatLit with
+      | some arity => (some arity, 1)
+      | none       => (none, 0);
+    match (args.get! i).isStrLit with
+    | some str =>
+      if args.size == i+1 then
+        Except.ok { arity := arity, entries := [ ExternEntry.standard `all str ] }
+      else
+        Except.error "invalid extern attribute"
+    | none => match syntaxToExternEntries args i [] with
+      | Except.ok entries => Except.ok { arity := arity, entries := entries }
+      | Except.error msg  => Except.error msg
+| _ => Except.error "unexpected kind of argument"
+
+@[extern "lean_add_extern"]
+constant addExtern (env : Environment) (n : Name) : ExceptT String Id Environment := arbitrary _
+
+def mkExternAttr : IO (ParametricAttribute ExternAttrData) :=
+registerParametricAttribute `extern "builtin and foreign functions"
+  (fun _ _ => syntaxToExternAttrData)
+  (fun env declName _ =>
+    if env.isProjectionFn declName || env.isConstructor declName then
+      addExtern env declName
+    else
+      pure env)
+
+@[init mkExternAttr]
+constant externAttr : ParametricAttribute ExternAttrData := arbitrary _
+
+@[export lean_get_extern_attr_data]
+def getExternAttrData (env : Environment) (n : Name) : Option ExternAttrData :=
+externAttr.getParam env n
+
+private def parseOptNum : Nat → String.Iterator → Nat → String.Iterator × Nat
+| 0,   it, r => (it, r)
+| n+1, it, r =>
+  if !it.hasNext then (it, r)
+  else
+    let c := it.curr;
+    if '0' <= c && c <= '9'
+    then parseOptNum n it.next (r*10 + (c.toNat - '0'.toNat))
+    else (it, r)
+
+def expandExternPatternAux (args : List String) : Nat → String.Iterator → String → String
+| 0,   it, r => r
+| i+1, it, r =>
+  if ¬ it.hasNext then r
+  else let c := it.curr;
+    if c ≠ '#' then expandExternPatternAux i it.next (r.push c)
+    else
+      let it      := it.next;
+      let (it, j) := parseOptNum it.remainingBytes it 0;
+      let j       := j-1;
+      expandExternPatternAux i it (r ++ args.getD j "")
+
+def expandExternPattern (pattern : String) (args : List String) : String :=
+expandExternPatternAux args pattern.length pattern.mkIterator ""
+
+def mkSimpleFnCall (fn : String) (args : List String) : String :=
+fn ++ "(" ++ ((args.intersperse ", ").foldl HasAppend.append "") ++ ")"
+
+def ExternEntry.backend : ExternEntry → Name
+| ExternEntry.adhoc n      => n
+| ExternEntry.inline n _   => n
+| ExternEntry.standard n _ => n
+| ExternEntry.foreign n _  => n
+
+def getExternEntryForAux (backend : Name) : List ExternEntry → Option ExternEntry
+| []    => none
+| e::es =>
+  if e.backend == `all then some e
+  else if e.backend == backend then some e
+  else getExternEntryForAux es
+
+def getExternEntryFor (d : ExternAttrData) (backend : Name) : Option ExternEntry :=
+getExternEntryForAux backend d.entries
+
+def isExtern (env : Environment) (fn : Name) : Bool :=
+(getExternAttrData env fn).isSome
+
+/- We say a Lean function marked as `[extern "<c_fn_nane>"]` is for all backends, and it is implemented using `extern "C"`.
+   Thus, there is no name mangling. -/
+def isExternC (env : Environment) (fn : Name) : Bool :=
+match getExternAttrData env fn with
+| some { entries := [ ExternEntry.standard `all _ ], .. } => true
+| _ => false
+
+def getExternNameFor (env : Environment) (backend : Name) (fn : Name) : Option String :=
+do data ← getExternAttrData env fn;
+   entry ← getExternEntryFor data backend;
+   match entry with
+   | ExternEntry.standard _ n => pure n
+   | ExternEntry.foreign _ n  => pure n
+   | _ => failure
+
+end Lean

stage0/src/Init/Lean/Compiler/IR.lean

@@ -0,0 +1,80 @@
+/-
+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 Init.Lean.Compiler.IR.Basic
+import Init.Lean.Compiler.IR.Format
+import Init.Lean.Compiler.IR.CompilerM
+import Init.Lean.Compiler.IR.PushProj
+import Init.Lean.Compiler.IR.ElimDeadVars
+import Init.Lean.Compiler.IR.SimpCase
+import Init.Lean.Compiler.IR.ResetReuse
+import Init.Lean.Compiler.IR.NormIds
+import Init.Lean.Compiler.IR.Checker
+import Init.Lean.Compiler.IR.Borrow
+import Init.Lean.Compiler.IR.Boxing
+import Init.Lean.Compiler.IR.RC
+import Init.Lean.Compiler.IR.ExpandResetReuse
+import Init.Lean.Compiler.IR.UnboxResult
+import Init.Lean.Compiler.IR.ElimDeadBranches
+import Init.Lean.Compiler.IR.EmitC
+
+namespace Lean
+namespace IR
+
+private def compileAux (decls : Array Decl) : CompilerM Unit :=
+do logDecls `init decls;
+   checkDecls decls;
+   decls ← elimDeadBranches decls;
+   logDecls `elim_dead_branches decls;
+   let decls := decls.map Decl.pushProj;
+   logDecls `push_proj decls;
+   let decls := decls.map Decl.insertResetReuse;
+   logDecls `reset_reuse decls;
+   let decls := decls.map Decl.elimDead;
+   logDecls `elim_dead decls;
+   let decls := decls.map Decl.simpCase;
+   logDecls `simp_case decls;
+   let decls := decls.map Decl.normalizeIds;
+   decls ← inferBorrow decls;
+   logDecls `borrow decls;
+   decls ← explicitBoxing decls;
+   logDecls `boxing decls;
+   decls ← explicitRC decls;
+   logDecls `rc decls;
+   let decls := decls.map Decl.expandResetReuse;
+   logDecls `expand_reset_reuse decls;
+   let decls := decls.map Decl.pushProj;
+   logDecls `push_proj decls;
+   logDecls `result decls;
+   checkDecls decls;
+   addDecls decls;
+   pure ()
+
+@[export lean_ir_compile]
+def compile (env : Environment) (opts : Options) (decls : Array Decl) : Log × (Except String Environment) :=
+match (compileAux decls opts).run { env := env } with
+| EStateM.Result.ok     _  s => (s.log, Except.ok s.env)
+| EStateM.Result.error msg s => (s.log, Except.error msg)
+
+def addBoxedVersionAux (decl : Decl) : CompilerM Unit :=
+do env ← getEnv;
+   if !ExplicitBoxing.requiresBoxedVersion env decl then pure ()
+   else do
+     let decl := ExplicitBoxing.mkBoxedVersion decl;
+     let decls : Array Decl := #[decl];
+     decls ← explicitRC decls;
+     decls.forM $ fun decl => modifyEnv $ fun env => addDeclAux env decl;
+     pure ()
+
+-- Remark: we are ignoring the `Log` here. This should be fine.
+@[export lean_ir_add_boxed_version]
+def addBoxedVersion (env : Environment) (decl : Decl) : Except String Environment :=
+match (addBoxedVersionAux decl Options.empty).run { env := env } with
+| EStateM.Result.ok     _  s => Except.ok s.env
+| EStateM.Result.error msg s => Except.error msg
+
+end IR
+end Lean

stage0/src/Init/Lean/Compiler/IR/Basic.lean

@@ -0,0 +1,595 @@
+/-
+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 Init.Data.Array
+import Init.Lean.Name
+import Init.Lean.KVMap
+import Init.Lean.Format
+import Init.Lean.Compiler.ExternAttr
+/-
+Implements (extended) λPure and λRc proposed in the article
+"Counting Immutable Beans", Sebastian Ullrich and Leonardo de Moura.
+
+The Lean to IR transformation produces λPure code, and
+this part is implemented in C++. The procedures described in the paper
+above are implemented in Lean.
+-/
+namespace Lean
+namespace IR
+
+/- Function identifier -/
+abbrev FunId := Name
+abbrev Index := Nat
+/- Variable identifier -/
+structure VarId :=
+(idx : Index)
+/- Join point identifier -/
+structure JoinPointId :=
+(idx : Index)
+
+abbrev Index.lt (a b : Index) : Bool := a < b
+
+namespace VarId
+instance : HasBeq VarId := ⟨fun a b => a.idx == b.idx⟩
+instance : HasToString VarId := ⟨fun a => "x_" ++ toString a.idx⟩
+instance : HasFormat VarId := ⟨fun a => toString a⟩
+instance : Hashable VarId := ⟨fun a => hash a.idx⟩
+end VarId
+
+namespace JoinPointId
+instance : HasBeq JoinPointId := ⟨fun a b => a.idx == b.idx⟩
+instance : HasToString JoinPointId := ⟨fun a => "block_" ++ toString a.idx⟩
+instance : HasFormat JoinPointId := ⟨fun a => toString a⟩
+instance : Hashable JoinPointId := ⟨fun a => hash a.idx⟩
+end JoinPointId
+
+abbrev MData := KVMap
+namespace MData
+abbrev empty : MData := {KVMap .}
+instance : HasEmptyc MData := ⟨empty⟩
+end MData
+
+/- Low Level IR types. Most are self explanatory.
+
+   - `usize` represents the C++ `size_t` Type. We have it here
+      because it is 32-bit in 32-bit machines, and 64-bit in 64-bit machines,
+      and we want the C++ backend for our Compiler to generate platform independent code.
+
+   - `irrelevant` for Lean types, propositions and proofs.
+
+   - `object` a pointer to a value in the heap.
+
+   - `tobject` a pointer to a value in the heap or tagged pointer
+      (i.e., the least significant bit is 1) storing a scalar value.
+
+   - `struct` and `union` are used to return small values (e.g., `Option`, `Prod`, `Except`)
+      on the stack.
+
+Remark: the RC operations for `tobject` are slightly more expensive because we
+first need to test whether the `tobject` is really a pointer or not.
+
+Remark: the Lean runtime assumes that sizeof(void*) == sizeof(sizeT).
+Lean cannot be compiled on old platforms where this is not True.
+
+Since values of type `struct` and `union` are only used to return values,
+We assume they must be used/consumed "linearly". We use the term "linear" here
+to mean "exactly once" in each execution. That is, given `x : S`, where `S` is a struct,
+then one of the following must hold in each (execution) branch.
+1- `x` occurs only at a single `ret x` instruction. That is, it is being consumed by being returned.
+2- `x` occurs only at a single `ctor`. That is, it is being "consumed" by being stored into another `struct/union`.
+3- We extract (aka project) every single field of `x` exactly once. That is, we are consuming `x` by consuming each
+   of one of its components. Minor refinement: we don't need to consume scalar fields or struct/union
+   fields that do not contain object fields.
+-/
+inductive IRType
+| float | uint8 | uint16 | uint32 | uint64 | usize
+| irrelevant | object | tobject
+| struct (leanTypeName : Option Name) (types : Array IRType) : IRType
+| union (leanTypeName : Name) (types : Array IRType) : IRType
+
+namespace IRType
+
+partial def beq : IRType → IRType → Bool
+| float,          float          => true
+| uint8,          uint8          => true
+| uint16,         uint16         => true
+| uint32,         uint32         => true
+| uint64,         uint64         => true
+| usize,          usize          => true
+| irrelevant,     irrelevant     => true
+| object,         object         => true
+| tobject,        tobject        => true
+| struct n₁ tys₁, struct n₂ tys₂ => n₁ == n₂ && Array.isEqv tys₁ tys₂ beq
+| union n₁ tys₁,  union n₂ tys₂  => n₁ == n₂ && Array.isEqv tys₁ tys₂ beq
+| _,              _              => false
+
+instance HasBeq : HasBeq IRType := ⟨beq⟩
+
+def isScalar : IRType → Bool
+| float  => true
+| uint8  => true
+| uint16 => true
+| uint32 => true
+| uint64 => true
+| usize  => true
+| _      => false
+
+def isObj : IRType → Bool
+| object  => true
+| tobject => true
+| _       => false
+
+def isIrrelevant : IRType → Bool
+| irrelevant => true
+| _ => false
+
+def isStruct : IRType → Bool
+| struct _ _ => true
+| _ => false
+
+def isUnion : IRType → Bool
+| union _ _ => true
+| _ => false
+
+end IRType
+
+/- Arguments to applications, constructors, etc.
+   We use `irrelevant` for Lean types, propositions and proofs that have been erased.
+   Recall that for a Function `f`, we also generate `f._rarg` which does not take
+   `irrelevant` arguments. However, `f._rarg` is only safe to be used in full applications. -/
+inductive Arg
+| var (id : VarId)
+| irrelevant
+
+namespace Arg
+protected def beq : Arg → Arg → Bool
+| var x,      var y      => x == y
+| irrelevant, irrelevant => true
+| _,          _          => false
+
+instance : HasBeq Arg := ⟨Arg.beq⟩
+instance : Inhabited Arg := ⟨irrelevant⟩
+end Arg
+
+@[export lean_ir_mk_var_arg] def mkVarArg (id : VarId) : Arg := Arg.var id
+
+inductive LitVal
+| num (v : Nat)
+| str (v : String)
+
+def LitVal.beq : LitVal → LitVal → Bool
+| LitVal.num v₁, LitVal.num v₂ => v₁ == v₂
+| LitVal.str v₁, LitVal.str v₂ => v₁ == v₂
+| _,             _             => false
+
+instance LitVal.HasBeq : HasBeq LitVal := ⟨LitVal.beq⟩
+
+/- Constructor information.
+
+   - `name` is the Name of the Constructor in Lean.
+   - `cidx` is the Constructor index (aka tag).
+   - `size` is the number of arguments of type `object/tobject`.
+   - `usize` is the number of arguments of type `usize`.
+   - `ssize` is the number of bytes used to store scalar values.
+
+Recall that a Constructor object contains a header, then a sequence of
+pointers to other Lean objects, a sequence of `USize` (i.e., `size_t`)
+scalar values, and a sequence of other scalar values. -/
+structure CtorInfo :=
+(name : Name) (cidx : Nat) (size : Nat) (usize : Nat) (ssize : Nat)
+
+def CtorInfo.beq : CtorInfo → CtorInfo → Bool
+| ⟨n₁, cidx₁, size₁, usize₁, ssize₁⟩, ⟨n₂, cidx₂, size₂, usize₂, ssize₂⟩ =>
+  n₁ == n₂ && cidx₁ == cidx₂ && size₁ == size₂ && usize₁ == usize₂ && ssize₁ == ssize₂
+
+instance CtorInfo.HasBeq : HasBeq CtorInfo := ⟨CtorInfo.beq⟩
+
+def CtorInfo.isRef (info : CtorInfo) : Bool :=
+info.size > 0 || info.usize > 0 || info.ssize > 0
+
+def CtorInfo.isScalar (info : CtorInfo) : Bool :=
+!info.isRef
+
+inductive Expr
+/- We use `ctor` mainly for constructing Lean object/tobject values `lean_ctor_object` in the runtime.
+   This instruction is also used to creat `struct` and `union` return values.
+   For `union`, only `i.cidx` is relevant. For `struct`, `i` is irrelevant. -/
+| ctor (i : CtorInfo) (ys : Array Arg)
+| reset (n : Nat) (x : VarId)
+/- `reuse x in ctor_i ys` instruction in the paper. -/
+| reuse (x : VarId) (i : CtorInfo) (updtHeader : Bool) (ys : Array Arg)
+/- Extract the `tobject` value at Position `sizeof(void*)*i` from `x`.
+   We also use `proj` for extracting fields from `struct` return values, and casting `union` return values. -/
+| proj (i : Nat) (x : VarId)
+/- Extract the `Usize` value at Position `sizeof(void*)*i` from `x`. -/
+| uproj (i : Nat) (x : VarId)
+/- Extract the scalar value at Position `sizeof(void*)*n + offset` from `x`. -/
+| sproj (n : Nat) (offset : Nat) (x : VarId)
+/- Full application. -/
+| fap (c : FunId) (ys : Array Arg)
+/- Partial application that creates a `pap` value (aka closure in our nonstandard terminology). -/
+| pap (c : FunId) (ys : Array Arg)
+/- Application. `x` must be a `pap` value. -/
+| ap  (x : VarId) (ys : Array Arg)
+/- Given `x : ty` where `ty` is a scalar type, this operation returns a value of Type `tobject`.
+   For small scalar values, the Result is a tagged pointer, and no memory allocation is performed. -/
+| box (ty : IRType) (x : VarId)
+/- Given `x : [t]object`, obtain the scalar value. -/
+| unbox (x : VarId)
+| lit (v : LitVal)
+/- Return `1 : uint8` Iff `RC(x) > 1` -/
+| isShared (x : VarId)
+/- Return `1 : uint8` Iff `x : tobject` is a tagged pointer (storing a scalar value). -/
+| isTaggedPtr (x : VarId)
+
+@[export lean_ir_mk_ctor_expr]  def mkCtorExpr (n : Name) (cidx : Nat) (size : Nat) (usize : Nat) (ssize : Nat) (ys : Array Arg) : Expr := Expr.ctor ⟨n, cidx, size, usize, ssize⟩ ys
+@[export lean_ir_mk_proj_expr]  def mkProjExpr (i : Nat) (x : VarId) : Expr := Expr.proj i x
+@[export lean_ir_mk_uproj_expr] def mkUProjExpr (i : Nat) (x : VarId) : Expr := Expr.uproj i x
+@[export lean_ir_mk_sproj_expr] def mkSProjExpr (n : Nat) (offset : Nat) (x : VarId) : Expr := Expr.sproj n offset x
+@[export lean_ir_mk_fapp_expr]  def mkFAppExpr (c : FunId) (ys : Array Arg) : Expr := Expr.fap c ys
+@[export lean_ir_mk_papp_expr]  def mkPAppExpr (c : FunId) (ys : Array Arg) : Expr := Expr.pap c ys
+@[export lean_ir_mk_app_expr]   def mkAppExpr (x : VarId) (ys : Array Arg) : Expr := Expr.ap x ys
+@[export lean_ir_mk_num_expr]   def mkNumExpr (v : Nat) : Expr := Expr.lit (LitVal.num v)
+@[export lean_ir_mk_str_expr]   def mkStrExpr (v : String) : Expr := Expr.lit (LitVal.str v)
+
+structure Param :=
+(x : VarId) (borrow : Bool) (ty : IRType)
+
+instance paramInh : Inhabited Param := ⟨{ x := { idx := 0 }, borrow := false, ty := IRType.object }⟩
+
+@[export lean_ir_mk_param] def mkParam (x : VarId) (borrow : Bool) (ty : IRType) : Param := ⟨x, borrow, ty⟩
+
+inductive AltCore (FnBody : Type) : Type
+| ctor (info : CtorInfo) (b : FnBody) : AltCore
+| default (b : FnBody) : AltCore
+
+inductive FnBody
+/- `let x : ty := e; b` -/
+| vdecl (x : VarId) (ty : IRType) (e : Expr) (b : FnBody)
+/- Join point Declaration `block_j (xs) := e; b` -/
+| jdecl (j : JoinPointId) (xs : Array Param) (v : FnBody) (b : FnBody)
+/- Store `y` at Position `sizeof(void*)*i` in `x`. `x` must be a Constructor object and `RC(x)` must be 1.
+   This operation is not part of λPure is only used during optimization. -/
+| set (x : VarId) (i : Nat) (y : Arg) (b : FnBody)
+| setTag (x : VarId) (cidx : Nat) (b : FnBody)
+/- Store `y : Usize` at Position `sizeof(void*)*i` in `x`. `x` must be a Constructor object and `RC(x)` must be 1. -/
+| uset (x : VarId) (i : Nat) (y : VarId) (b : FnBody)
+/- Store `y : ty` at Position `sizeof(void*)*i + offset` in `x`. `x` must be a Constructor object and `RC(x)` must be 1.
+   `ty` must not be `object`, `tobject`, `irrelevant` nor `Usize`. -/
+| sset (x : VarId) (i : Nat) (offset : Nat) (y : VarId) (ty : IRType) (b : FnBody)
+/- RC increment for `object`. If c == `true`, then `inc` must check whether `x` is a tagged pointer or not.
+   If `persistent == true` then `x` is statically known to be a persistent object. -/
+| inc (x : VarId) (n : Nat) (c : Bool) (persistent : Bool) (b : FnBody)
+/- RC decrement for `object`. If c == `true`, then `inc` must check whether `x` is a tagged pointer or not.
+   If `persistent == true` then `x` is statically known to be a persistent object. -/
+| dec (x : VarId) (n : Nat) (c : Bool) (persistent : Bool) (b : FnBody)
+| del (x : VarId) (b : FnBody)
+| mdata (d : MData) (b : FnBody)
+| case (tid : Name) (x : VarId) (xType : IRType) (cs : Array (AltCore FnBody))
+| ret (x : Arg)
+/- Jump to join point `j` -/
+| jmp (j : JoinPointId) (ys : Array Arg)
+| unreachable
+
+instance : Inhabited FnBody := ⟨FnBody.unreachable⟩
+
+abbrev FnBody.nil := FnBody.unreachable
+
+@[export lean_ir_mk_vdecl] def mkVDecl (x : VarId) (ty : IRType) (e : Expr) (b : FnBody) : FnBody := FnBody.vdecl x ty e b
+@[export lean_ir_mk_jdecl] def mkJDecl (j : JoinPointId) (xs : Array Param) (v : FnBody) (b : FnBody) : FnBody := FnBody.jdecl j xs v b
+@[export lean_ir_mk_uset] def mkUSet (x : VarId) (i : Nat) (y : VarId) (b : FnBody) : FnBody := FnBody.uset x i y b
+@[export lean_ir_mk_sset] def mkSSet (x : VarId) (i : Nat) (offset : Nat) (y : VarId) (ty : IRType) (b : FnBody) : FnBody := FnBody.sset x i offset y ty b
+@[export lean_ir_mk_case] def mkCase (tid : Name) (x : VarId) (cs : Array (AltCore FnBody)) : FnBody :=
+-- Tyhe field `xType` is set by `explicitBoxing` compiler pass.
+FnBody.case tid x IRType.object cs
+@[export lean_ir_mk_ret] def mkRet (x : Arg) : FnBody := FnBody.ret x
+@[export lean_ir_mk_jmp] def mkJmp (j : JoinPointId) (ys : Array Arg) : FnBody := FnBody.jmp j ys
+@[export lean_ir_mk_unreachable] def mkUnreachable : Unit → FnBody := fun _ => FnBody.unreachable
+
+abbrev Alt := AltCore FnBody
+@[matchPattern] abbrev Alt.ctor    := @AltCore.ctor FnBody
+@[matchPattern] abbrev Alt.default := @AltCore.default FnBody
+
+instance altInh : Inhabited Alt :=
+⟨Alt.default (arbitrary _)⟩
+
+def FnBody.isTerminal : FnBody → Bool
+| FnBody.case _ _ _ _  => true
+| FnBody.ret _         => true
+| FnBody.jmp _ _       => true
+| FnBody.unreachable   => true
+| _                    => false
+
+def FnBody.body : FnBody → FnBody
+| FnBody.vdecl _ _ _ b    => b
+| FnBody.jdecl _ _ _ b    => b
+| FnBody.set _ _ _ b      => b
+| FnBody.uset _ _ _ b     => b
+| FnBody.sset _ _ _ _ _ b => b
+| FnBody.setTag _ _ b     => b
+| FnBody.inc _ _ _ _ b    => b
+| FnBody.dec _ _ _ _ b    => b
+| FnBody.del _ b          => b
+| FnBody.mdata _ b        => b
+| other                   => other
+
+def FnBody.setBody : FnBody → FnBody → FnBody
+| FnBody.vdecl x t v _,    b => FnBody.vdecl x t v b
+| FnBody.jdecl j xs v _,   b => FnBody.jdecl j xs v b
+| FnBody.set x i y _,      b => FnBody.set x i y b
+| FnBody.uset x i y _,     b => FnBody.uset x i y b
+| FnBody.sset x i o y t _, b => FnBody.sset x i o y t b
+| FnBody.setTag x i _,     b => FnBody.setTag x i b
+| FnBody.inc x n c p _,    b => FnBody.inc x n c p b
+| FnBody.dec x n c p _,    b => FnBody.dec x n c p b
+| FnBody.del x _,          b => FnBody.del x b
+| FnBody.mdata d _,        b => FnBody.mdata d b
+| other,                   b => other
+
+@[inline] def FnBody.resetBody (b : FnBody) : FnBody :=
+b.setBody FnBody.nil
+
+/- If b is a non terminal, then return a pair `(c, b')` s.t. `b == c <;> b'`,
+   and c.body == FnBody.nil -/
+@[inline] def FnBody.split (b : FnBody) : FnBody × FnBody :=
+let b' := b.body;
+let c  := b.resetBody;
+(c, b')
+
+def AltCore.body : Alt → FnBody
+| Alt.ctor _ b  => b
+| Alt.default b => b
+
+def AltCore.setBody : Alt → FnBody → Alt
+| Alt.ctor c _, b  => Alt.ctor c b
+| Alt.default _, b => Alt.default b
+
+@[inline] def AltCore.modifyBody (f : FnBody → FnBody) : AltCore FnBody → Alt
+| Alt.ctor c b  => Alt.ctor c (f b)
+| Alt.default b => Alt.default (f b)
+
+@[inline] def AltCore.mmodifyBody {m : Type → Type} [Monad m] (f : FnBody → m FnBody) : AltCore FnBody → m Alt
+| Alt.ctor c b  => Alt.ctor c <$> f b
+| Alt.default b => Alt.default <$> f b
+
+def Alt.isDefault : Alt → Bool
+| Alt.ctor _ _  => false
+| Alt.default _ => true
+
+def push (bs : Array FnBody) (b : FnBody) : Array FnBody :=
+let b := b.resetBody;
+bs.push b
+
+partial def flattenAux : FnBody → Array FnBody → (Array FnBody) × FnBody
+| b, r =>
+  if b.isTerminal then (r, b)
+  else flattenAux b.body (push r b)
+
+def FnBody.flatten (b : FnBody) : (Array FnBody) × FnBody :=
+flattenAux b #[]
+
+partial def reshapeAux : Array FnBody → Nat → FnBody → FnBody
+| a, i, b =>
+  if i == 0 then b
+  else
+    let i         := i - 1;
+    let (curr, a) := a.swapAt! i (arbitrary _);
+    let b         := curr.setBody b;
+    reshapeAux a i b
+
+def reshape (bs : Array FnBody) (term : FnBody) : FnBody :=
+reshapeAux bs bs.size term
+
+@[inline] def modifyJPs (bs : Array FnBody) (f : FnBody → FnBody) : Array FnBody :=
+bs.map $ fun b => match b with
+  | FnBody.jdecl j xs v k => FnBody.jdecl j xs (f v) k
+  | other                 => other
+
+@[inline] def mmodifyJPs {m : Type → Type} [Monad m] (bs : Array FnBody) (f : FnBody → m FnBody) : m (Array FnBody) :=
+bs.mapM $ fun b => match b with
+  | FnBody.jdecl j xs v k => do v ← f v; pure $ FnBody.jdecl j xs v k
+  | other                 => pure other
+
+@[export lean_ir_mk_alt] def mkAlt (n : Name) (cidx : Nat) (size : Nat) (usize : Nat) (ssize : Nat) (b : FnBody) : Alt := Alt.ctor ⟨n, cidx, size, usize, ssize⟩ b
+
+inductive Decl
+| fdecl  (f : FunId) (xs : Array Param) (ty : IRType) (b : FnBody)
+| extern (f : FunId) (xs : Array Param) (ty : IRType) (ext : ExternAttrData)
+
+namespace Decl
+
+instance : Inhabited Decl :=
+⟨fdecl (arbitrary _) (arbitrary _) IRType.irrelevant (arbitrary _)⟩
+
+def name : Decl → FunId
+| Decl.fdecl f _ _ _  => f
+| Decl.extern f _ _ _ => f
+
+def params : Decl → Array Param
+| Decl.fdecl _ xs _ _  => xs
+| Decl.extern _ xs _ _ => xs
+
+def resultType : Decl → IRType
+| Decl.fdecl _ _ t _  => t
+| Decl.extern _ _ t _ => t
+
+def isExtern : Decl → Bool
+| Decl.extern _ _ _ _ => true
+| _ => false
+
+end Decl
+
+@[export lean_ir_mk_decl] def mkDecl (f : FunId) (xs : Array Param) (ty : IRType) (b : FnBody) : Decl := Decl.fdecl f xs ty b
+
+@[export lean_ir_mk_extern_decl] def mkExternDecl (f : FunId) (xs : Array Param) (ty : IRType) (e : ExternAttrData) : Decl :=
+Decl.extern f xs ty e
+
+/-- Set of variable and join point names -/
+abbrev IndexSet := RBTree Index Index.lt
+instance vsetInh : Inhabited IndexSet := ⟨{}⟩
+
+def mkIndexSet (idx : Index) : IndexSet :=
+RBTree.empty.insert idx
+
+inductive LocalContextEntry
+| param     : IRType → LocalContextEntry
+| localVar  : IRType → Expr → LocalContextEntry
+| joinPoint : Array Param → FnBody → LocalContextEntry
+
+abbrev LocalContext := RBMap Index LocalContextEntry Index.lt
+
+def LocalContext.addLocal (ctx : LocalContext) (x : VarId) (t : IRType) (v : Expr) : LocalContext :=
+ctx.insert x.idx (LocalContextEntry.localVar t v)
+
+def LocalContext.addJP (ctx : LocalContext) (j : JoinPointId) (xs : Array Param) (b : FnBody) : LocalContext :=
+ctx.insert j.idx (LocalContextEntry.joinPoint xs b)
+
+def LocalContext.addParam (ctx : LocalContext) (p : Param) : LocalContext :=
+ctx.insert p.x.idx (LocalContextEntry.param p.ty)
+
+def LocalContext.addParams (ctx : LocalContext) (ps : Array Param) : LocalContext :=
+ps.foldl LocalContext.addParam ctx
+
+def LocalContext.isJP (ctx : LocalContext) (idx : Index) : Bool :=
+match ctx.find idx with
+| some (LocalContextEntry.joinPoint _ _) => true
+| other => false
+
+def LocalContext.getJPBody (ctx : LocalContext) (j : JoinPointId) : Option FnBody :=
+match ctx.find j.idx with
+| some (LocalContextEntry.joinPoint _ b) => some b
+| other => none
+
+def LocalContext.getJPParams (ctx : LocalContext) (j : JoinPointId) : Option (Array Param) :=
+match ctx.find j.idx with
+| some (LocalContextEntry.joinPoint ys _) => some ys
+| other => none
+
+def LocalContext.isParam (ctx : LocalContext) (idx : Index) : Bool :=
+match ctx.find idx with
+| some (LocalContextEntry.param _) => true
+| other => false
+
+def LocalContext.isLocalVar (ctx : LocalContext) (idx : Index) : Bool :=
+match ctx.find idx with
+| some (LocalContextEntry.localVar _ _) => true
+| other => false
+
+def LocalContext.contains (ctx : LocalContext) (idx : Index) : Bool :=
+ctx.contains idx
+
+def LocalContext.eraseJoinPointDecl (ctx : LocalContext) (j : JoinPointId) : LocalContext :=
+ctx.erase j.idx
+
+def LocalContext.getType (ctx : LocalContext) (x : VarId) : Option IRType :=
+match ctx.find x.idx with
+| some (LocalContextEntry.param t) => some t
+| some (LocalContextEntry.localVar t _) => some t
+| other => none
+
+def LocalContext.getValue (ctx : LocalContext) (x : VarId) : Option Expr :=
+match ctx.find x.idx with
+| some (LocalContextEntry.localVar _ v) => some v
+| other => none
+
+abbrev IndexRenaming := RBMap Index Index Index.lt
+
+class HasAlphaEqv (α : Type) :=
+(aeqv : IndexRenaming → α → α → Bool)
+
+export HasAlphaEqv (aeqv)
+
+def VarId.alphaEqv (ρ : IndexRenaming) (v₁ v₂ : VarId) : Bool :=
+match ρ.find v₁.idx with
+| some v => v == v₂.idx
+| none   => v₁ == v₂
+
+instance VarId.hasAeqv : HasAlphaEqv VarId := ⟨VarId.alphaEqv⟩
+
+def Arg.alphaEqv (ρ : IndexRenaming) : Arg → Arg → Bool
+| Arg.var v₁,     Arg.var v₂     => aeqv ρ v₁ v₂
+| Arg.irrelevant, Arg.irrelevant => true
+| _,              _              => false
+
+instance Arg.hasAeqv : HasAlphaEqv Arg := ⟨Arg.alphaEqv⟩
+
+def args.alphaEqv (ρ : IndexRenaming) (args₁ args₂ : Array Arg) : Bool :=
+Array.isEqv args₁ args₂ (fun a b => aeqv ρ a b)
+
+instance args.hasAeqv : HasAlphaEqv (Array Arg) := ⟨args.alphaEqv⟩
+
+def Expr.alphaEqv (ρ : IndexRenaming) : Expr → Expr → Bool
+| Expr.ctor i₁ ys₁,        Expr.ctor i₂ ys₂        => i₁ == i₂ && aeqv ρ ys₁ ys₂
+| Expr.reset n₁ x₁,        Expr.reset n₂ x₂        => n₁ == n₂ && aeqv ρ x₁ x₂
+| Expr.reuse x₁ i₁ u₁ ys₁, Expr.reuse x₂ i₂ u₂ ys₂ => aeqv ρ x₁ x₂ && i₁ == i₂ && u₁ == u₂ && aeqv ρ ys₁ ys₂
+| Expr.proj i₁ x₁,         Expr.proj i₂ x₂         => i₁ == i₂ && aeqv ρ x₁ x₂
+| Expr.uproj i₁ x₁,        Expr.uproj i₂ x₂        => i₁ == i₂ && aeqv ρ x₁ x₂
+| Expr.sproj n₁ o₁ x₁,     Expr.sproj n₂ o₂ x₂     => n₁ == n₂ && o₁ == o₂ && aeqv ρ x₁ x₂
+| Expr.fap c₁ ys₁,         Expr.fap c₂ ys₂         => c₁ == c₂ && aeqv ρ ys₁ ys₂
+| Expr.pap c₁ ys₁,         Expr.pap c₂ ys₂         => c₁ == c₂ && aeqv ρ ys₂ ys₂
+| Expr.ap x₁ ys₁,          Expr.ap x₂ ys₂          => aeqv ρ x₁ x₂ && aeqv ρ ys₁ ys₂
+| Expr.box ty₁ x₁,         Expr.box ty₂ x₂         => ty₁ == ty₂ && aeqv ρ x₁ x₂
+| Expr.unbox x₁,           Expr.unbox x₂           => aeqv ρ x₁ x₂
+| Expr.lit v₁,             Expr.lit v₂             => v₁ == v₂
+| Expr.isShared x₁,        Expr.isShared x₂        => aeqv ρ x₁ x₂
+| Expr.isTaggedPtr x₁,     Expr.isTaggedPtr x₂     => aeqv ρ x₁ x₂
+| _,                        _                      => false
+
+instance Expr.hasAeqv : HasAlphaEqv Expr:= ⟨Expr.alphaEqv⟩
+
+def addVarRename (ρ : IndexRenaming) (x₁ x₂ : Nat) :=
+if x₁ == x₂ then ρ else ρ.insert x₁ x₂
+
+def addParamRename (ρ : IndexRenaming) (p₁ p₂ : Param) : Option IndexRenaming :=
+if p₁.ty == p₂.ty && p₁.borrow = p₂.borrow then some (addVarRename ρ p₁.x.idx p₂.x.idx)
+else none
+
+def addParamsRename (ρ : IndexRenaming) (ps₁ ps₂ : Array Param) : Option IndexRenaming :=
+if ps₁.size != ps₂.size then none
+else Array.foldl₂ (fun ρ p₁ p₂ => do ρ ← ρ; addParamRename ρ p₁ p₂) (some ρ) ps₁ ps₂
+
+partial def FnBody.alphaEqv : IndexRenaming → FnBody → FnBody → Bool
+| ρ, FnBody.vdecl x₁ t₁ v₁ b₁,      FnBody.vdecl x₂ t₂ v₂ b₂      => t₁ == t₂ && aeqv ρ v₁ v₂ && FnBody.alphaEqv (addVarRename ρ x₁.idx x₂.idx) b₁ b₂
+| ρ, FnBody.jdecl j₁ ys₁ v₁ b₁,  FnBody.jdecl j₂ ys₂ v₂ b₂        => match addParamsRename ρ ys₁ ys₂ with
+  | some ρ' => FnBody.alphaEqv ρ' v₁ v₂ && FnBody.alphaEqv (addVarRename ρ j₁.idx j₂.idx) b₁ b₂
+  | none    => false
+| ρ, FnBody.set x₁ i₁ y₁ b₁,        FnBody.set x₂ i₂ y₂ b₂        => aeqv ρ x₁ x₂ && i₁ == i₂ && aeqv ρ y₁ y₂ && FnBody.alphaEqv ρ b₁ b₂
+| ρ, FnBody.uset x₁ i₁ y₁ b₁,       FnBody.uset x₂ i₂ y₂ b₂       => aeqv ρ x₁ x₂ && i₁ == i₂ && aeqv ρ y₁ y₂ && FnBody.alphaEqv ρ b₁ b₂
+| ρ, FnBody.sset x₁ i₁ o₁ y₁ t₁ b₁, FnBody.sset x₂ i₂ o₂ y₂ t₂ b₂ =>
+  aeqv ρ x₁ x₂ && i₁ = i₂ && o₁ = o₂ && aeqv ρ y₁ y₂ && t₁ == t₂ && FnBody.alphaEqv ρ b₁ b₂
+| ρ, FnBody.setTag x₁ i₁ b₁,        FnBody.setTag x₂ i₂ b₂        => aeqv ρ x₁ x₂ && i₁ == i₂ && FnBody.alphaEqv ρ b₁ b₂
+| ρ, FnBody.inc x₁ n₁ c₁ p₁ b₁,     FnBody.inc x₂ n₂ c₂ p₂ b₂     => aeqv ρ x₁ x₂ && n₁ == n₂ && c₁ == c₂ && p₁ == p₂ && FnBody.alphaEqv ρ b₁ b₂
+| ρ, FnBody.dec x₁ n₁ c₁ p₁ b₁,     FnBody.dec x₂ n₂ c₂ p₂ b₂     => aeqv ρ x₁ x₂ && n₁ == n₂ && c₁ == c₂ && p₁ == p₂ && FnBody.alphaEqv ρ b₁ b₂
+| ρ, FnBody.del x₁ b₁,              FnBody.del x₂ b₂              => aeqv ρ x₁ x₂ && FnBody.alphaEqv ρ b₁ b₂
+| ρ, FnBody.mdata m₁ b₁,            FnBody.mdata m₂ b₂            => m₁ == m₂ && FnBody.alphaEqv ρ b₁ b₂
+| ρ, FnBody.case n₁ x₁ _ alts₁,     FnBody.case n₂ x₂ _ alts₂     => n₁ == n₂ && aeqv ρ x₁ x₂ && Array.isEqv alts₁ alts₂ (fun alt₁ alt₂ =>
+   match alt₁, alt₂ with
+   | Alt.ctor i₁ b₁, Alt.ctor i₂ b₂ => i₁ == i₂ && FnBody.alphaEqv ρ b₁ b₂
+   | Alt.default b₁, Alt.default b₂ => FnBody.alphaEqv ρ b₁ b₂
+   | _,              _              => false)
+| ρ, FnBody.jmp j₁ ys₁,             FnBody.jmp j₂ ys₂             => j₁ == j₂ && aeqv ρ ys₁ ys₂
+| ρ, FnBody.ret x₁,                 FnBody.ret x₂                 => aeqv ρ x₁ x₂
+| _, FnBody.unreachable,            FnBody.unreachable            => true
+| _, _,                             _                             => false
+
+def FnBody.beq (b₁ b₂ : FnBody) : Bool :=
+FnBody.alphaEqv ∅  b₁ b₂
+
+instance FnBody.HasBeq : HasBeq FnBody := ⟨FnBody.beq⟩
+
+abbrev VarIdSet := RBTree VarId (fun x y => x.idx < y.idx)
+namespace VarIdSet
+instance : Inhabited VarIdSet := ⟨{}⟩
+end VarIdSet
+
+def mkIf (x : VarId) (t e : FnBody) : FnBody :=
+FnBody.case `Bool x IRType.uint8 #[
+  Alt.ctor {name := `Bool.false, cidx := 0, size := 0, usize := 0, ssize := 0} e,
+  Alt.ctor {name := `Bool.true, cidx := 1, size := 0, usize := 0, ssize := 0} t
+]
+
+end IR
+end Lean

stage0/src/Init/Lean/Compiler/IR/Borrow.lean

@@ -0,0 +1,316 @@
+/-
+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 Init.Data.Nat
+import Init.Lean.Compiler.ExportAttr
+import Init.Lean.Compiler.IR.CompilerM
+import Init.Lean.Compiler.IR.NormIds
+
+namespace Lean
+namespace IR
+namespace Borrow
+/- We perform borrow inference in a block of mutually recursive functions.
+   Join points are viewed as local functions, and are identified using
+   their local id + the name of the surrounding function.
+
+   We keep a mapping from function and joint points to parameters (`Array Param`).
+   Recall that `Param` contains the field `borrow`.
+   The type `Key` is the the key of this map. -/
+inductive Key
+| decl (name : FunId)
+| jp   (name : FunId) (jpid : JoinPointId)
+
+namespace Key
+def beq : Key → Key → Bool
+| decl n₁,   decl n₂   => n₁ == n₂
+| jp n₁ id₁, jp n₂ id₂ => n₁ == n₂ && id₁ == id₂
+| _,         _         => false
+
+instance : HasBeq Key := ⟨beq⟩
+
+def getHash : Key → USize
+| decl n  => hash n
+| jp n id => mixHash (hash n) (hash id)
+
+instance : Hashable Key := ⟨getHash⟩
+end Key
+
+abbrev ParamMap := HashMap Key (Array Param)
+
+def ParamMap.fmt (map : ParamMap) : Format :=
+let fmts := map.fold (fun fmt k ps =>
+  let k := match k with
+    | Key.decl n  => format n
+    | Key.jp n id => format n ++ ":" ++ format id;
+  fmt ++ Format.line ++ k ++ " -> " ++ formatParams ps)
+ Format.nil;
+"{" ++ (Format.nest 1 fmts) ++ "}"
+
+instance : HasFormat ParamMap := ⟨ParamMap.fmt⟩
+instance : HasToString ParamMap := ⟨fun m => Format.pretty (format m)⟩
+
+namespace InitParamMap
+
+/- Mark parameters that take a reference as borrow -/
+def initBorrow (ps : Array Param) : Array Param :=
+ps.map $ fun p => { borrow := p.ty.isObj, .. p }
+
+/- We do perform borrow inference for constants marked as `export`.
+   Reason: we current write wrappers in C++ for using exported functions.
+   These wrappers use smart pointers such as `object_ref`.
+   When writing a new wrapper we need to know whether an argument is a borrow
+   inference or not.
+
+   We can revise this decision when we implement code for generating
+   the wrappers automatically. -/
+def initBorrowIfNotExported (exported : Bool) (ps : Array Param) : Array Param :=
+if exported then ps else initBorrow ps
+
+partial def visitFnBody (fnid : FunId) : FnBody → StateM ParamMap Unit
+| FnBody.jdecl j xs v b   => do
+  modify $ fun m => m.insert (Key.jp fnid j) (initBorrow xs);
+  visitFnBody v;
+  visitFnBody b
+| e =>
+  unless (e.isTerminal) $ do
+    let (instr, b) := e.split;
+    visitFnBody b
+
+def visitDecls (env : Environment) (decls : Array Decl) : StateM ParamMap Unit :=
+decls.forM $ fun decl => match decl with
+  | Decl.fdecl f xs _ b => do
+    let exported := isExport env f;
+    modify $ fun m => m.insert (Key.decl f) (initBorrowIfNotExported exported xs);
+    visitFnBody f b
+  | _ => pure ()
+end InitParamMap
+
+def mkInitParamMap (env : Environment) (decls : Array Decl) : ParamMap :=
+(InitParamMap.visitDecls env decls *> get).run' {}
+
+/- Apply the inferred borrow annotations stored at `ParamMap` to a block of mutually
+   recursive functions. -/
+namespace ApplyParamMap
+
+partial def visitFnBody : FnBody → FunId → ParamMap → FnBody
+| FnBody.jdecl j xs v b,   fnid, map =>
+  let v := visitFnBody v fnid map;
+  let b := visitFnBody b fnid map;
+  match map.find (Key.jp fnid j) with
+  | some ys => FnBody.jdecl j ys v b
+  | none    => FnBody.jdecl j xs v b
+| e, fnid, map =>
+  if e.isTerminal then e
+  else
+    let (instr, b) := e.split;
+    let b := visitFnBody b fnid map;
+    instr.setBody b
+
+def visitDecls (decls : Array Decl) (map : ParamMap) : Array Decl :=
+decls.map $ fun decl => match decl with
+  | Decl.fdecl f xs ty b =>
+    let b := visitFnBody b f map;
+    match map.find (Key.decl f) with
+    | some xs => Decl.fdecl f xs ty b
+    | none    => Decl.fdecl f xs ty b
+  | other => other
+
+end ApplyParamMap
+
+def applyParamMap (decls : Array Decl) (map : ParamMap) : Array Decl :=
+-- dbgTrace ("applyParamMap " ++ toString map) $ fun _ =>
+ApplyParamMap.visitDecls decls map
+
+structure BorrowInfCtx :=
+(env : Environment)
+(currFn : FunId := arbitrary _) -- Function being analyzed.
+(paramSet : IndexSet := {}) -- Set of all function parameters in scope. This is used to implement the heuristic at `ownArgsUsingParams`
+
+structure BorrowInfState :=
+/- `map` is a mapping storing the inferred borrow annotations for all functions (and joint points) in a mutually recursive declaration. -/
+(map : ParamMap)
+/- Set of variables that must be `owned`. -/
+(owned : IndexSet := {})
+(modifiedOwned : Bool := false)
+(modifiedParamMap : Bool := false)
+
+abbrev M := ReaderT BorrowInfCtx (StateM BorrowInfState)
+
+def markModifiedParamMap : M Unit :=
+modify $ fun s => { modifiedParamMap := true, .. s }
+
+def ownVar (x : VarId) : M Unit :=
+-- dbgTrace ("ownVar " ++ toString x) $ fun _ =>
+modify $ fun s =>
+  if s.owned.contains x.idx then s
+  else { owned := s.owned.insert x.idx, modifiedOwned := true, .. s }
+
+def ownArg (x : Arg) : M Unit :=
+match x with
+| (Arg.var x) => ownVar x
+| _           => pure ()
+
+def ownArgs (xs : Array Arg) : M Unit :=
+xs.forM ownArg
+
+def isOwned (x : VarId) : M Bool :=
+do s ← get;
+   pure $ s.owned.contains x.idx
+
+/- Updates `map[k]` using the current set of `owned` variables. -/
+def updateParamMap (k : Key) : M Unit :=
+do s ← get;
+   match s.map.find k with
+   | some ps => do
+     ps ← ps.mapM $ fun (p : Param) =>
+      if p.borrow && s.owned.contains p.x.idx then do
+        markModifiedParamMap; pure { borrow := false, .. p }
+      else
+        pure p;
+     modify $ fun s => { map := s.map.insert k ps, .. s }
+   | none    => pure ()
+
+def getParamInfo (k : Key) : M (Array Param) :=
+do s ← get;
+   match s.map.find k with
+   | some ps => pure ps
+   | none    =>
+     match k with
+     | (Key.decl fn) => do
+       ctx ← read;
+       match findEnvDecl ctx.env fn with
+       | some decl => pure decl.params
+       | none      => pure #[]   -- unreachable if well-formed input
+     | _ => pure #[] -- unreachable if well-formed input
+
+/- For each ps[i], if ps[i] is owned, then mark xs[i] as owned. -/
+def ownArgsUsingParams (xs : Array Arg) (ps : Array Param) : M Unit :=
+xs.size.forM $ fun i => do
+  let x := xs.get! i;
+  let p := ps.get! i;
+  unless p.borrow $ ownArg x
+
+/- For each xs[i], if xs[i] is owned, then mark ps[i] as owned.
+   We use this action to preserve tail calls. That is, if we have
+   a tail call `f xs`, if the i-th parameter is borrowed, but `xs[i]` is owned
+   we would have to insert a `dec xs[i]` after `f xs` and consequently
+   "break" the tail call. -/
+def ownParamsUsingArgs (xs : Array Arg) (ps : Array Param) : M Unit :=
+xs.size.forM $ fun i => do
+  let x := xs.get! i;
+  let p := ps.get! i;
+  match x with
+  | Arg.var x => whenM (isOwned x) $ ownVar p.x
+  | _         => pure ()
+
+/- Mark `xs[i]` as owned if it is one of the parameters `ps`.
+   We use this action to mark function parameters that are being "packed" inside constructors.
+   This is a heuristic, and is not related with the effectiveness of the reset/reuse optimization.
+   It is useful for code such as
+   ```
+   def f (x y : obj) :=
+   let z := ctor_1 x y;
+   ret z
+   ```
+-/
+def ownArgsIfParam (xs : Array Arg) : M Unit :=
+do ctx ← read;
+   xs.forM $ fun x =>
+     match x with
+     | Arg.var x => when (ctx.paramSet.contains x.idx) $ ownVar x
+     | _ => pure ()
+
+def collectExpr (z : VarId) : Expr → M Unit
+| Expr.reset _ x      => ownVar z *> ownVar x
+| Expr.reuse x _ _ ys => ownVar z *> ownVar x *> ownArgsIfParam ys
+| Expr.ctor _ xs      => ownVar z *> ownArgsIfParam xs
+| Expr.proj _ x       => whenM (isOwned z) $ ownVar x
+| Expr.fap g xs       => do ps ← getParamInfo (Key.decl g);
+  -- dbgTrace ("collectExpr: " ++ toString g ++ " " ++ toString (formatParams ps)) $ fun _ =>
+  ownVar z *> ownArgsUsingParams xs ps
+| Expr.ap x ys        => ownVar z *> ownVar x *> ownArgs ys
+| Expr.pap _ xs       => ownVar z *> ownArgs xs
+| other               => pure ()
+
+def preserveTailCall (x : VarId) (v : Expr) (b : FnBody) : M Unit :=
+do ctx ← read;
+match v, b with
+| (Expr.fap g ys), (FnBody.ret (Arg.var z)) =>
+  when (ctx.currFn == g && x == z) $ do
+    -- dbgTrace ("preserveTailCall " ++ toString b) $ fun _ => do
+    ps ← getParamInfo (Key.decl g);
+    ownParamsUsingArgs ys ps
+| _, _ => pure ()
+
+def updateParamSet (ctx : BorrowInfCtx) (ps : Array Param) : BorrowInfCtx :=
+{ paramSet := ps.foldl (fun s p => s.insert p.x.idx) ctx.paramSet, .. ctx }
+
+partial def collectFnBody : FnBody → M Unit
+| FnBody.jdecl j ys v b => do
+  adaptReader (fun ctx => updateParamSet ctx ys) (collectFnBody v);
+  ctx ← read;
+  updateParamMap (Key.jp ctx.currFn j);
+  collectFnBody b
+| FnBody.vdecl x _ v b => collectFnBody b *> collectExpr x v *> preserveTailCall x v b
+| FnBody.jmp j ys      => do
+  ctx ← read;
+  ps ← getParamInfo (Key.jp ctx.currFn j);
+  ownArgsUsingParams ys ps; -- for making sure the join point can reuse
+  ownParamsUsingArgs ys ps  -- for making sure the tail call is preserved
+| FnBody.case _ _ _ alts => alts.forM $ fun alt => collectFnBody alt.body
+| e                      => unless (e.isTerminal) $ collectFnBody e.body
+
+@[specialize] partial def whileModifingOwnedAux (x : M Unit) : Unit → M Unit
+| _ => do
+  modify $ fun s => { modifiedOwned := false, .. s };
+  x;
+  s ← get;
+  if s.modifiedOwned then whileModifingOwnedAux ()
+  else pure ()
+
+/- Keep executing `x` while it modifies ownedSet -/
+@[inline] def whileModifingOwned (x : M Unit) : M Unit :=
+whileModifingOwnedAux x ()
+
+partial def collectDecl : Decl → M Unit
+| Decl.fdecl f ys _ b   =>
+  adaptReader (fun ctx => let ctx := updateParamSet ctx ys; { currFn := f, .. ctx }) $ do
+   modify $ fun (s : BorrowInfState) => { owned := {}, .. s };
+   whileModifingOwned (collectFnBody b);
+   updateParamMap (Key.decl f)
+| _ => pure ()
+
+@[specialize] partial def whileModifingParamMapAux (x : M Unit) : Unit → M Unit
+| _ => do
+  modify $ fun s => { modifiedParamMap := false, .. s };
+  s ← get;
+  -- dbgTrace (toString s.map) $ fun _ => do
+  x;
+  s ← get;
+  if s.modifiedParamMap then whileModifingParamMapAux ()
+  else pure ()
+
+/- Keep executing `x` while it modifies paramMap -/
+@[inline] def whileModifingParamMap (x : M Unit) : M Unit :=
+whileModifingParamMapAux x ()
+
+def collectDecls (decls : Array Decl) : M ParamMap :=
+do whileModifingParamMap (decls.forM collectDecl);
+   s ← get;
+   pure s.map
+
+def infer (env : Environment) (decls : Array Decl) : ParamMap :=
+(collectDecls decls { env := env }).run' { map := mkInitParamMap env decls }
+
+end Borrow
+
+def inferBorrow (decls : Array Decl) : CompilerM (Array Decl) :=
+do env ← getEnv;
+   let paramMap := Borrow.infer env decls;
+   pure (Borrow.applyParamMap decls paramMap)
+
+end IR
+end Lean

stage0/src/Init/Lean/Compiler/IR/Boxing.lean

@@ -0,0 +1,345 @@
+/-
+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 Init.Control.EState
+import Init.Control.Reader
+import Init.Data.AssocList
+import Init.Data.Nat
+import Init.Lean.Runtime
+import Init.Lean.Compiler.ClosedTermCache
+import Init.Lean.Compiler.ExternAttr
+import Init.Lean.Compiler.IR.Basic
+import Init.Lean.Compiler.IR.CompilerM
+import Init.Lean.Compiler.IR.FreeVars
+import Init.Lean.Compiler.IR.ElimDeadVars
+
+namespace Lean
+namespace IR
+namespace 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 :=
+mkNameStr n "_boxed"
+
+def isBoxedName : Name → Bool
+| Name.str _ "_boxed" _ => true
+| _                     => false
+
+abbrev N := StateM Nat
+
+private def 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;
+   qs ← ps.mapM (fun _ => do x ← mkFresh; pure { Param . x := x, ty := IRType.object, borrow := false });
+   (newVDecls, xs) ← qs.size.foldM
+     (fun i (r : Array FnBody × Array Arg) =>
+        let (newVDecls, xs) := r;
+        let p := ps.get! i;
+        let q := qs.get! i;
+        if !p.ty.isScalar then pure (newVDecls, xs.push (Arg.var q.x))
+        else do
+          x ← mkFresh;
+          pure (newVDecls.push (FnBody.vdecl x p.ty (Expr.unbox q.x) (arbitrary _)), xs.push (Arg.var x)))
+     (#[], #[]);
+   r ← mkFresh;
+   let newVDecls := newVDecls.push (FnBody.vdecl r decl.resultType (Expr.fap decl.name xs) (arbitrary _));
+   body ←
+     if !decl.resultType.isScalar then do {
+       pure $ reshape newVDecls (FnBody.ret (Arg.var r))
+     } else do {
+       newR ← mkFresh;
+       let newVDecls := newVDecls.push (FnBody.vdecl newR IRType.object (Expr.box decl.resultType r) (arbitrary _));
+       pure $ reshape newVDecls (FnBody.ret (Arg.var newR))
+     };
+   pure $ Decl.fdecl (mkBoxedName decl.name) qs IRType.object body
+
+def mkBoxedVersion (decl : Decl) : Decl :=
+(mkBoxedVersionAux decl).run' 1
+
+def addBoxedVersions (env : Environment) (decls : Array Decl) : Array Decl :=
+let boxedDecls := decls.foldl
+  (fun (newDecls : Array Decl) 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 => match alt with
+    | 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 :=
+(f : FunId := arbitrary _) (localCtx : LocalContext := {}) (resultType : IRType := IRType.irrelevant) (decls : Array Decl) (env : Environment)
+
+structure BoxingState :=
+(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)
+
+def mkFresh : M VarId :=
+do oldS ← getModify (fun s => { nextIdx := s.nextIdx + 1, .. s });
+   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 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 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 ctx ← read;
+   match findEnvDecl' ctx.env fid ctx.decls with
+   | some decl => pure decl
+   | none      => pure (arbitrary _) -- unreachable if well-formed
+
+@[inline] def withParams {α : Type} (xs : Array Param) (k : M α) : M α :=
+adaptReader (fun (ctx : BoxingContext) => { localCtx := ctx.localCtx.addParams xs, .. ctx }) k
+
+@[inline] def withVDecl {α : Type} (x : VarId) (ty : IRType) (v : Expr) (k : M α) : M α :=
+adaptReader (fun (ctx : BoxingContext) => { localCtx := ctx.localCtx.addLocal x ty v, .. ctx }) k
+
+@[inline] def withJDecl {α : Type} (j : JoinPointId) (xs : Array Param) (v : FnBody) (k : M α) : M α :=
+adaptReader (fun (ctx : BoxingContext) => { localCtx := ctx.localCtx.addJP j xs v, .. ctx }) 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 pure none -- We assume unboxing is always cheap
+else match xType with
+| IRType.uint8  => pure none
+| IRType.uint16 => pure none
+| _ => do
+  localCtx ← getLocalContext;
+  match localCtx.getValue x with
+  | some val =>
+    match val with
+    | Expr.lit _ => pure $ some val
+    | Expr.fap _ args => pure $ if args.size == 0 then some val else none
+    | _ => pure none
+  | _ => pure 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 opt? ← isExpensiveConstantValueBoxing x xType;
+   match opt? with
+   | some v => do
+     ctx ← read;
+     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 => {
+        auxDecls     := s.auxDecls.push auxDecl,
+        auxDeclCache := s.auxDeclCache.cons body auxConst,
+        nextAuxId    := s.nextAuxId + 1,
+        .. s
+       };
+       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 xType ← getVarType x;
+   if eqvTypes xType expected then k x
+   else do
+     y ← mkFresh;
+     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
+
+@[specialize] def castArgsIfNeededAux (xs : Array Arg) (typeFromIdx : Nat → IRType) : M (Array Arg × Array FnBody) :=
+xs.iterateM (#[], #[]) $ fun i (x : Arg) (r : Array Arg × Array FnBody) =>
+  let expected := typeFromIdx i.val;
+  let (xs, bs) := r;
+  match x with
+  | Arg.irrelevant => pure (xs.push x, bs)
+  | Arg.var x => do
+    xType ← getVarType x;
+    if eqvTypes xType expected then pure (xs.push (Arg.var x), bs)
+    else do
+      y ← mkFresh;
+      v ← mkCast x xType expected;
+      let b := FnBody.vdecl y expected v FnBody.nil;
+      pure (xs.push (Arg.var y), bs.push b)
+
+@[inline] def castArgsIfNeeded (xs : Array Arg) (ps : Array Param) (k : Array Arg → M FnBody) : M FnBody :=
+do (ys, bs) ← castArgsIfNeededAux xs (fun i => (ps.get! i).ty);
+   b ← k ys;
+   pure (reshape bs b)
+
+@[inline] def boxArgsIfNeeded (xs : Array Arg) (k : Array Arg → M FnBody) : M FnBody :=
+do (ys, bs) ← castArgsIfNeededAux xs (fun _ => IRType.object);
+   b ← k ys;
+   pure (reshape bs b)
+
+def unboxResultIfNeeded (x : VarId) (ty : IRType) (e : Expr) (b : FnBody) : M FnBody :=
+if ty.isScalar then do
+  y ← mkFresh;
+  pure $ FnBody.vdecl y IRType.object e (FnBody.vdecl x ty (Expr.unbox y) b)
+else
+  pure $ FnBody.vdecl x ty e b
+
+def castResultIfNeeded (x : VarId) (ty : IRType) (e : Expr) (eType : IRType) (b : FnBody) : M FnBody :=
+if eqvTypes ty eType then pure $ FnBody.vdecl x ty e b
+else do
+  y ← mkFresh;
+  v ← mkCast y eType ty;
+  pure $ 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
+    pure $ FnBody.vdecl x ty (Expr.lit (LitVal.num c.cidx)) b
+  else
+    boxArgsIfNeeded ys $ fun ys => pure $ FnBody.vdecl x ty (Expr.ctor c ys) b
+| Expr.reuse w c u ys =>
+  boxArgsIfNeeded ys $ fun ys => pure $ FnBody.vdecl x ty (Expr.reuse w c u ys) b
+| Expr.fap f ys => do
+  decl ← getDecl f;
+  castArgsIfNeeded ys decl.params $ fun ys =>
+  castResultIfNeeded x ty (Expr.fap f ys) decl.resultType b
+| Expr.pap f ys => do
+  env ← getEnv;
+  decl ← getDecl f;
+  let f := if requiresBoxedVersion env decl then mkBoxedName f else f;
+  boxArgsIfNeeded ys $ fun ys => pure $ 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
+| other =>
+  pure $ FnBody.vdecl x ty e b
+
+partial def visitFnBody : FnBody → M FnBody
+| FnBody.vdecl x t v b     => do
+  b ← withVDecl x t v (visitFnBody b);
+  visitVDeclExpr x t v b
+| FnBody.jdecl j xs v b    => do
+  v ← withParams xs (visitFnBody v);
+  b ← withJDecl j xs v (visitFnBody b);
+  pure $ FnBody.jdecl j xs v b
+| FnBody.uset x i y b      => do
+  b ← visitFnBody b;
+  castVarIfNeeded y IRType.usize $ fun y =>
+    pure $ FnBody.uset x i y b
+| FnBody.sset x i o y ty b => do
+  b ← visitFnBody b;
+  castVarIfNeeded y ty $ fun y =>
+    pure $ 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;
+  alts ← alts.mapM $ fun alt => alt.mmodifyBody visitFnBody;
+  castVarIfNeeded x expected $ fun x => do
+    pure $ FnBody.case tid x expected alts
+| FnBody.ret x             => do
+  expected ← getResultType;
+  castArgIfNeeded x expected (fun x => pure $ FnBody.ret x)
+| FnBody.jmp j ys          => do
+  ps ← getJPParams j;
+  castArgsIfNeeded ys ps (fun ys => pure $ 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 (fun (newDecls : Array Decl) (decl : Decl) =>
+  match decl with
+  | Decl.fdecl f xs t b =>
+    let nextIdx  := decl.maxIndex + 1;
+    let (b, s)   := (withParams xs (visitFnBody b) { f := f, resultType := t, .. ctx }).run { nextIdx := nextIdx };
+    let newDecls := newDecls ++ s.auxDecls;
+    let newDecl  := Decl.fdecl f xs t 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 env ← getEnv;
+   pure $ ExplicitBoxing.run env decls
+
+end IR
+end Lean

stage0/src/Init/Lean/Compiler/IR/Checker.lean

@@ -0,0 +1,160 @@
+/-
+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 Init.Lean.Compiler.IR.CompilerM
+
+namespace Lean
+namespace IR
+
+namespace Checker
+
+structure CheckerContext :=
+(env : Environment) (localCtx : LocalContext := {}) (decls : Array Decl)
+
+structure CheckerState :=
+(foundVars : IndexSet := {})
+
+abbrev M := ReaderT CheckerContext (ExceptT String (StateT CheckerState Id))
+
+def markIndex (i : Index) : M Unit :=
+do s ← get;
+   when (s.foundVars.contains i) $ throw ("variable / joinpoint index " ++ toString i ++ " has already been used");
+   modify $ fun s => { foundVars := s.foundVars.insert i, .. s }
+
+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 ctx ← read;
+   match findEnvDecl' ctx.env c ctx.decls with
+   | none   => throw ("unknown declaration '" ++ toString c ++ "'")
+   | some d => pure d
+
+def checkVar (x : VarId) : M Unit :=
+do ctx ← read;
+   unless (ctx.localCtx.isLocalVar x.idx || ctx.localCtx.isParam x.idx) $ throw ("unknown variable '" ++ toString x ++ "'")
+
+def checkJP (j : JoinPointId) : M Unit :=
+do ctx ← read;
+   unless (ctx.localCtx.isJP j.idx) $ throw ("unknown join point '" ++ toString j ++ "'")
+
+def checkArg (a : Arg) : M Unit :=
+match a with
+| Arg.var x => checkVar x
+| other     => pure ()
+
+def checkArgs (as : Array Arg) : M Unit :=
+as.forM checkArg
+
+@[inline] def checkEqTypes (ty₁ ty₂ : IRType) : M Unit :=
+unless (ty₁ == ty₂) $ throw ("unexpected type")
+
+@[inline] def checkType (ty : IRType) (p : IRType → Bool) : M Unit :=
+unless (p ty) $ throw ("unexpected type")
+
+def checkObjType (ty : IRType) : M Unit := checkType ty IRType.isObj
+
+def checkScalarType (ty : IRType) : M Unit := checkType ty IRType.isScalar
+
+def getType (x : VarId) : M IRType :=
+do ctx ← read;
+   match ctx.localCtx.getType x with
+   | some ty => pure ty
+   | none    => throw ("unknown variable '" ++ toString x ++ "'")
+
+@[inline] def checkVarType (x : VarId) (p : IRType → Bool) : M Unit :=
+do ty ← getType x; checkType ty p
+
+def checkObjVar (x : VarId) : M Unit :=
+checkVarType x IRType.isObj
+
+def checkScalarVar (x : VarId) : M Unit :=
+checkVarType x IRType.isScalar
+
+def checkFullApp (c : FunId) (ys : Array Arg) : M Unit :=
+do decl ← getDecl c;
+   unless (ys.size == decl.params.size) (throw ("incorrect number of arguments to '" ++ toString c ++ "', " ++ toString ys.size ++ " provided, " ++ toString decl.params.size ++ " expected"));
+   checkArgs ys
+
+def checkPartialApp (c : FunId) (ys : Array Arg) : M Unit :=
+do decl ← getDecl c;
+   unless (ys.size < decl.params.size) (throw ("too many arguments too partial application '" ++ toString c ++ "', num. args: " ++ toString ys.size ++ ", arity: " ++ toString 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          => when (!ty.isStruct && !ty.isUnion && c.isRef) (checkObjType ty) *> checkArgs ys
+| Expr.reset _ x          => checkObjVar x *> checkObjType ty
+| Expr.reuse x i u 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 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.get ⟨i,h⟩) ty else throw "invalid proj index"
+  | IRType.union _ tys  => if h : i < tys.size then checkEqTypes (tys.get ⟨i,h⟩) ty else throw "invalid proj index"
+  | other               => throw "unexpected type"
+| 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.isTaggedPtr 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 ctx ← read;
+   localCtx ← ps.foldlM (fun (ctx : LocalContext) p => do
+      markVar p.x;
+      pure $ ctx.addParam p) ctx.localCtx;
+   adaptReader (fun _ => { localCtx := localCtx, .. ctx }) k
+
+partial def checkFnBody : FnBody → M Unit
+| FnBody.vdecl x t v b    => do
+  checkExpr t v;
+  markVar x;
+  ctx ← read;
+  adaptReader (fun (ctx : CheckerContext) => { localCtx := ctx.localCtx.addLocal x t v, .. ctx }) (checkFnBody b)
+| FnBody.jdecl j ys v b => do
+  markJP j;
+  withParams ys (checkFnBody v);
+  ctx ← read;
+  adaptReader (fun (ctx : CheckerContext) => { localCtx := ctx.localCtx.addJP j ys v, .. ctx }) (checkFnBody b)
+| FnBody.set x _ y b      => checkVar x *> checkArg y *> checkFnBody b
+| FnBody.uset x _ y b     => checkVar x *> checkVar y *> checkFnBody b
+| FnBody.sset x _ _ y _ b => checkVar x *> checkVar y *> checkFnBody b
+| FnBody.setTag x _ b     => checkVar x *> checkFnBody b
+| FnBody.inc x _ _ _ b    => checkVar x *> checkFnBody b
+| FnBody.dec x _ _ _ b    => checkVar x *> checkFnBody b
+| FnBody.del x b          => checkVar x *> checkFnBody b
+| FnBody.mdata _ b        => checkFnBody b
+| FnBody.jmp j ys         => checkJP j *> checkArgs ys
+| FnBody.ret x            => checkArg x
+| FnBody.case _ x _ alts  => checkVar x *> alts.forM (fun alt => checkFnBody alt.body)
+| FnBody.unreachable      => pure ()
+
+def checkDecl : Decl → M Unit
+| Decl.fdecl f xs t b  => withParams xs (checkFnBody b)
+| Decl.extern f xs t _ => withParams xs (pure ())
+
+end Checker
+
+def checkDecl (decls : Array Decl) (decl : Decl) : CompilerM Unit :=
+do env ← getEnv;
+   match (Checker.checkDecl decl { env := env, decls := decls }).run' {} with
+   | Except.error msg => throw ("IR check failed at '" ++ toString decl.name ++ "', error: " ++ msg)
+   | other            => pure ()
+
+def checkDecls (decls : Array Decl) : CompilerM Unit :=
+decls.forM (checkDecl decls)
+
+end IR
+end Lean

stage0/src/Init/Lean/Compiler/IR/CompilerM.lean

@@ -0,0 +1,145 @@
+/-
+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 Init.Control.Reader
+import Init.Lean.Environment
+import Init.Lean.Compiler.IR.Basic
+import Init.Lean.Compiler.IR.Format
+
+namespace Lean
+namespace IR
+
+inductive LogEntry
+| 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 : HasFormat LogEntry := ⟨LogEntry.fmt⟩
+end LogEntry
+
+abbrev Log := Array LogEntry
+
+def Log.format (log : Log) : Format :=
+log.foldl (fun fmt entry => fmt ++ Format.line ++ format entry) Format.nil
+
+@[export lean_ir_log_to_string]
+def Log.toString (log : Log) : String :=
+log.format.pretty
+
+structure CompilerState :=
+(env : Environment) (log : Log := #[])
+
+abbrev CompilerM := ReaderT Options (EStateM String CompilerState)
+
+def log (entry : LogEntry) : CompilerM Unit :=
+modify $ fun s => { log := s.log.push entry, .. s }
+
+def tracePrefixOptionName := `trace.compiler.ir
+
+private def isLogEnabledFor (opts : Options) (optName : Name) : Bool :=
+match opts.find optName with
+| some (DataValue.ofBool v) => v
+| other => opts.getBool tracePrefixOptionName
+
+private def logDeclsAux (optName : Name) (cls : Name) (decls : Array Decl) : CompilerM Unit :=
+do opts ← read;
+   when (isLogEnabledFor opts optName) $ log (LogEntry.step cls decls)
+
+@[inline] def logDecls (cls : Name) (decl : Array Decl) : CompilerM Unit :=
+logDeclsAux (tracePrefixOptionName ++ cls) cls decl
+
+private def logMessageIfAux {α : Type} [HasFormat α] (optName : Name) (a : α) : CompilerM Unit :=
+do opts ← read;
+   when (isLogEnabledFor opts optName) $ log (LogEntry.message (format a))
+
+@[inline] def logMessageIf {α : Type} [HasFormat α] (cls : Name) (a : α) : CompilerM Unit :=
+logMessageIfAux (tracePrefixOptionName ++ cls) a
+
+@[inline] def logMessage {α : Type} [HasFormat α] (cls : Name) (a : α) : CompilerM Unit :=
+logMessageIfAux tracePrefixOptionName a
+
+@[inline] def modifyEnv (f : Environment → Environment) : CompilerM Unit :=
+modify $ fun s => { env := f s.env, .. s }
+
+abbrev DeclMap := SMap Name Decl
+
+/- Create an array of decls to be saved on .olean file.
+   `decls` may contain duplicate entries, but we assume the one that occurs last is the most recent one. -/
+private def mkEntryArray (decls : List Decl) : Array Decl :=
+/- Remove duplicates by adding decls into a map -/
+let map : HashMap Name Decl := {};
+let map := decls.foldl (fun (map : HashMap Name Decl) decl => map.insert decl.name decl) map;
+map.fold (fun a k v => a.push v) #[]
+
+def mkDeclMapExtension : IO (SimplePersistentEnvExtension Decl DeclMap) :=
+registerSimplePersistentEnvExtension {
+  name       := `IRDecls,
+  addImportedFn := fun as =>
+     let m : DeclMap := mkStateFromImportedEntries (fun s (d : Decl) => s.insert d.name d) {} as;
+     m.switch,
+  addEntryFn := fun s d => s.insert d.name d,
+  toArrayFn  := mkEntryArray
+}
+
+@[init mkDeclMapExtension]
+constant declMapExt : SimplePersistentEnvExtension Decl DeclMap := arbitrary _
+
+@[export lean_ir_find_env_decl]
+def findEnvDecl (env : Environment) (n : Name) : Option Decl :=
+(declMapExt.getState env).find n
+
+def findDecl (n : Name) : CompilerM (Option Decl) :=
+do s ← get;
+   pure $ findEnvDecl s.env n
+
+def containsDecl (n : Name) : CompilerM Bool :=
+do s ← get;
+   pure $ (declMapExt.getState s.env).contains n
+
+def getDecl (n : Name) : CompilerM Decl :=
+do (some decl) ← findDecl n | throw ("unknown declaration '" ++ toString n ++ "'");
+   pure decl
+
+@[export lean_ir_add_decl]
+def addDeclAux (env : Environment) (decl : Decl) : Environment :=
+declMapExt.addEntry env decl
+
+def getDecls (env : Environment) : List Decl :=
+declMapExt.getEntries env
+
+def getEnv : CompilerM Environment :=
+do s ← get; pure s.env
+
+def addDecl (decl : Decl) : CompilerM Unit :=
+modifyEnv (fun env => declMapExt.addEntry env 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 => if decl.name == n then some decl else none) with
+| some decl => some decl
+| none      => (declMapExt.getState env).find n
+
+def findDecl' (n : Name) (decls : Array Decl) : CompilerM (Option Decl) :=
+do s ← get; pure $ findEnvDecl' s.env n decls
+
+def containsDecl' (n : Name) (decls : Array Decl) : CompilerM Bool :=
+if decls.any (fun decl => decl.name == n) then pure true
+else do
+  s ← get;
+  pure $ (declMapExt.getState s.env).contains n
+
+def getDecl' (n : Name) (decls : Array Decl) : CompilerM Decl :=
+do (some decl) ← findDecl' n decls | throw ("unknown declaration '" ++ toString n ++ "'");
+   pure decl
+
+end IR
+end Lean

stage0/src/Init/Lean/Compiler/IR/CtorLayout.lean

@@ -0,0 +1,42 @@
+/-
+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 Init.Lean.Environment
+import Init.Lean.Compiler.IR.Format
+
+namespace Lean
+namespace IR
+
+inductive CtorFieldInfo
+| irrelevant
+| object (i : Nat)
+| usize  (i : Nat)
+| scalar (sz : Nat) (offset : Nat) (type : IRType)
+
+namespace CtorFieldInfo
+
+def format : CtorFieldInfo → Format
+| irrelevant => "◾"
+| object i   => "obj@" ++ fmt i
+| usize i    => "usize@" ++ fmt i
+| scalar sz offset type => "scalar#" ++ fmt sz ++ "@" ++ fmt offset ++ ":" ++ fmt type
+
+instance : HasFormat CtorFieldInfo := ⟨format⟩
+
+end CtorFieldInfo
+
+structure CtorLayout :=
+(cidx       : Nat)
+(fieldInfo  : List CtorFieldInfo)
+(numObjs    : Nat)
+(numUSize   : Nat)
+(scalarSize : Nat)
+
+@[extern "lean_ir_get_ctor_layout"]
+constant getCtorLayout (env : Environment) (ctorName : Name) : Except String CtorLayout := arbitrary _
+
+end IR
+end Lean

stage0/src/Init/Lean/Compiler/IR/ElimDeadBranches.lean

@@ -0,0 +1,288 @@
+/-
+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 Init.Control.Reader
+import Init.Data.Option
+import Init.Data.Nat
+import Init.Lean.Compiler.IR.Format
+import Init.Lean.Compiler.IR.Basic
+import Init.Lean.Compiler.IR.CompilerM
+
+namespace Lean
+namespace IR
+namespace UnreachableBranches
+
+/-- Value used in the abstract interpreter -/
+inductive Value
+| bot -- undefined
+| top -- any value
+| ctor (i : CtorInfo) (vs : Array Value)
+| choice (vs : List Value)
+
+namespace Value
+
+instance : Inhabited Value := ⟨top⟩
+
+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₂ beq
+| choice vs₁, choice vs₂ =>
+  vs₁.all (fun v₁ => vs₂.any $ fun v₂ => beq v₁ v₂)
+  &&
+  vs₂.all (fun v₂ => vs₁.any $ fun v₁ => beq v₁ v₂)
+| _, _ => false
+
+instance : HasBeq Value := ⟨Value.beq⟩
+
+partial def addChoice (merge : Value → Value → Value) : List Value → Value → List Value
+| [], v => [v]
+| v₁@(ctor i₁ vs₁) :: cs, v₂@(ctor i₂ vs₂) =>
+  if i₁ == i₂ then merge v₁ v₂ :: cs
+  else v₁ :: addChoice cs v₂
+| _, _ => panic! "invalid addChoice"
+
+partial def merge : Value → Value → Value
+| 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 (fun i r => r.push (merge (vs₁.get! i) (vs₂.get! 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
+
+protected partial def format : Value → Format
+| top => "top"
+| bot => "bot"
+| choice vs => fmt "@" ++ @List.format _ ⟨format⟩ vs
+| ctor i vs => fmt "#" ++ if vs.isEmpty then fmt i.name else Format.paren (fmt i.name ++ @formatArray _ ⟨format⟩ vs)
+
+instance : HasFormat Value := ⟨Value.format⟩
+instance : HasToString Value := ⟨Format.pretty ∘ Value.format⟩
+
+/- Make sure constructors of recursive inductive datatypes can only occur once in each path.
+   We use this function this function to implement a simple widening operation for our abstract
+   interpreter. -/
+partial def truncate (env : Environment) : Value → NameSet → Value
+| 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 => truncate v found');
+    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 => truncate v found;
+  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 := SMap FunId Value
+
+def mkFunctionSummariesExtension : IO (SimplePersistentEnvExtension (FunId × Value) FunctionSummaries) :=
+registerSimplePersistentEnvExtension {
+  name       := `unreachBranchesFunSummary,
+  addImportedFn := fun as =>
+    let cache : FunctionSummaries := mkStateFromImportedEntries (fun s (p : FunId × Value) => s.insert p.1 p.2) {} as;
+    cache.switch,
+  addEntryFn := fun s ⟨e, n⟩ => s.insert e n
+}
+
+@[init mkFunctionSummariesExtension]
+constant functionSummariesExt : SimplePersistentEnvExtension (FunId × Value) FunctionSummaries := arbitrary _
+
+def addFunctionSummary (env : Environment) (fid : FunId) (v : Value) : Environment :=
+functionSummariesExt.addEntry env (fid, v)
+
+def getFunctionSummary (env : Environment) (fid : FunId) : Option Value :=
+(functionSummariesExt.getState env).find fid
+
+abbrev Assignment := HashMap VarId Value
+
+structure InterpContext :=
+(currFnIdx : Nat := 0)
+(decls     : Array Decl)
+(env       : Environment)
+(lctx      : LocalContext := {})
+
+structure InterpState :=
+(assignments : Array Assignment)
+(funVals     : PArray Value) -- we take snapshots during fixpoint computations
+
+abbrev M := ReaderT InterpContext (StateM InterpState)
+
+open Value
+
+def findVarValue (x : VarId) : M Value :=
+do ctx ← read;
+   s ← get;
+   let assignment := s.assignments.get! ctx.currFnIdx;
+   pure $ assignment.findD 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 v' ← findVarValue x;
+   ctx ← read;
+   modify $ fun s => { assignments := s.assignments.modify ctx.currFnIdx $ fun a => a.insert x (merge v v'), .. s }
+
+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 => ctor i <$> ys.mapM (fun y => findArgValue y)
+| Expr.proj i x  => do v ← findVarValue x; pure $ projValue v i
+| Expr.fap fid ys => do
+  ctx ← read;
+  match getFunctionSummary ctx.env fid with
+  | some v => pure v
+  | none   => do
+    s ← get;
+    match ctx.decls.findIdx? (fun decl => decl.name == fid) with
+    | some idx => pure $ s.funVals.get! 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 ctx ← read;
+   let currFnIdx := ctx.currFnIdx;
+   modify $ fun s => { funVals := s.funVals.modify currFnIdx (fun v' => widening ctx.env v v'), .. s }
+
+/-- Return true if the assignment of at least one parameter has been updated. -/
+def updateJPParamsAssignment (ys : Array Param) (xs : Array Arg) : M Bool :=
+do ctx ← read;
+   let currFnIdx := ctx.currFnIdx;
+   ys.size.foldM (fun i r => do
+     let y := ys.get! i;
+     let x := xs.get! i;
+     yVal ← findVarValue y.x;
+     xVal ← findArgValue x;
+     let newVal := merge yVal xVal;
+     if newVal == yVal then pure r
+     else do
+       modify $ fun s => { assignments := s.assignments.modify currFnIdx $ fun a => a.insert y.x newVal, .. s };
+       pure true)
+     false
+
+partial def interpFnBody : FnBody → M Unit
+| FnBody.vdecl x _ e b => do
+  v ← interpExpr e;
+  updateVarAssignment x v;
+  interpFnBody b
+| FnBody.jdecl j ys v b =>
+  adaptReader (fun (ctx : InterpContext) => { lctx := ctx.lctx.addJP j ys v, .. ctx }) $
+    interpFnBody b
+| FnBody.case _ x _ alts => do
+  v ← findVarValue x;
+  alts.forM $ fun alt =>
+    match alt with
+    | Alt.ctor i b  => when (containsCtor v i) $ interpFnBody b
+    | Alt.default b => interpFnBody b
+| FnBody.ret x => do
+  v ← findArgValue x;
+  -- dbgTrace ("ret " ++ toString v) $ fun _ =>
+  updateCurrFnSummary v
+| FnBody.jmp j xs => do
+  ctx ← read;
+  let ys := (ctx.lctx.getJPParams j).get!;
+  updated ← updateJPParamsAssignment ys xs;
+  when updated $
+    interpFnBody $ (ctx.lctx.getJPBody j).get!
+| e => unless (e.isTerminal) $ interpFnBody e.body
+
+def inferStep : M Bool :=
+do ctx ← read;
+   modify $ fun s => { assignments := ctx.decls.map $ fun _ => {}, .. s };
+   ctx.decls.size.foldM (fun idx modified => do
+     match ctx.decls.get! idx with
+     | Decl.fdecl fid ys _ b => do
+       s ← get;
+       -- dbgTrace (">> " ++ toString fid) $ fun _ =>
+       let currVals := s.funVals.get! idx;
+       adaptReader (fun (ctx : InterpContext) => { currFnIdx := idx, .. ctx }) $ do
+         ys.forM $ fun y => updateVarAssignment y.x top;
+         interpFnBody b;
+       s ← get;
+       let newVals := s.funVals.get! idx;
+       pure (modified || currVals != newVals)
+     | Decl.extern _ _ _ _ => pure modified)
+     false
+
+partial def inferMain : Unit → M Unit
+| _ => do
+  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 b)
+| FnBody.jdecl j ys v b => FnBody.jdecl j ys (elimDeadAux v) (elimDeadAux b)
+| FnBody.case tid x xType alts =>
+  let v := assignment.findD x bot;
+  let alts := alts.map $ fun alt =>
+    match alt with
+    | Alt.ctor i b  => Alt.ctor i $ if containsCtor v i then elimDeadAux b else FnBody.unreachable
+    | Alt.default b => Alt.default (elimDeadAux b);
+  FnBody.case tid x xType alts
+| e =>
+  if e.isTerminal then e
+  else
+    let (instr, b) := e.split;
+    let b := elimDeadAux b;
+    instr.setBody b
+
+partial def elimDead (assignment : Assignment) : Decl → Decl
+| Decl.fdecl fid ys t b => Decl.fdecl fid ys t $ elimDeadAux assignment b
+| other => other
+
+end UnreachableBranches
+
+open UnreachableBranches
+
+def elimDeadBranches (decls : Array Decl) : CompilerM (Array Decl) :=
+do  s ← get;
+    let env := s.env;
+    let assignments : Array Assignment := decls.map $ fun _ => {};
+    let funVals := mkPArray decls.size Value.bot;
+    let ctx : InterpContext := { decls := decls, env := env };
+    let s : InterpState := { assignments := assignments, funVals := funVals };
+    let (_, s) := (inferMain () ctx).run s;
+    let funVals := s.funVals;
+    let assignments := s.assignments;
+    modify $ fun s =>
+      let env := decls.size.fold (fun i env =>
+        -- dbgTrace (">> " ++ toString (decls.get! i).name ++ " " ++ toString (funVals.get! i)) $ fun _ =>
+        addFunctionSummary env (decls.get! i).name (funVals.get! i))
+        s.env;
+      { env := env, .. s };
+    pure $ decls.mapIdx $ fun i decl => elimDead (assignments.get! i) decl
+
+end IR
+end Lean

stage0/src/Init/Lean/Compiler/IR/ElimDeadVars.lean

@@ -0,0 +1,52 @@
+/-
+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 Init.Lean.Compiler.IR.Basic
+import Init.Lean.Compiler.IR.FreeVars
+
+namespace Lean
+namespace IR
+
+partial def reshapeWithoutDeadAux : Array FnBody → FnBody → IndexSet → FnBody
+| bs, b, used =>
+  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;
+      reshapeWithoutDeadAux bs b used;
+    let keepIfUsed (vidx : Index) :=
+      if used.contains vidx then keep ()
+      else reshapeWithoutDeadAux 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 ()
+
+def reshapeWithoutDead (bs : Array FnBody) (term : FnBody) : FnBody :=
+reshapeWithoutDeadAux bs term term.freeIndices
+
+partial def FnBody.elimDead : FnBody → FnBody
+| b =>
+  let (bs, term) := b.flatten;
+  let bs         := modifyJPs bs FnBody.elimDead;
+  let term       := match term with
+    | FnBody.case tid x xType alts =>
+      let alts := alts.map $ fun alt => alt.modifyBody FnBody.elimDead;
+      FnBody.case tid x xType alts
+    | other => other;
+  reshapeWithoutDead bs term
+
+/-- Eliminate dead let-declarations and join points -/
+def Decl.elimDead : Decl → Decl
+| Decl.fdecl f xs t b => Decl.fdecl f xs t b.elimDead
+| other               => other
+
+end IR
+end Lean

stage0/src/Init/Lean/Compiler/IR/EmitC.lean

@@ -0,0 +1,720 @@
+/-
+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 Init.Control.Conditional
+import Init.Lean.Runtime
+import Init.Lean.Compiler.NameMangling
+import Init.Lean.Compiler.ExportAttr
+import Init.Lean.Compiler.InitAttr
+import Init.Lean.Compiler.IR.CompilerM
+import Init.Lean.Compiler.IR.EmitUtil
+import Init.Lean.Compiler.IR.NormIds
+import Init.Lean.Compiler.IR.SimpCase
+import Init.Lean.Compiler.IR.Boxing
+
+namespace Lean
+namespace IR
+open ExplicitBoxing (requiresBoxedVersion mkBoxedName isBoxedName)
+namespace EmitC
+
+def leanMainFn := "_lean_main"
+
+structure Context :=
+(env        : Environment)
+(modName    : Name)
+(jpMap      : JPParamsMap := {})
+(mainFn     : FunId := arbitrary _)
+(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 env ← getEnv;
+   match findEnvDecl env n with
+   | some d => pure d
+   | none   => throw ("unknown declaration '" ++ toString n ++ "'")
+
+@[inline] def emit {α : Type} [HasToString α] (a : α) : M Unit :=
+modify (fun out => out ++ toString a)
+
+@[inline] def emitLn {α : Type} [HasToString α] (a : α) : M Unit :=
+emit a *> emit "\n"
+
+def emitLns {α : Type} [HasToString α] (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.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 ("invalid export name '" ++ toString n ++ "'")
+
+def toCName (n : Name) : M String :=
+do env ← getEnv;
+   -- TODO: we should support simple export names only
+   match getExportNameFor env n with
+   | some (Name.str Name.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 env ← getEnv;
+   -- TODO: we should support simple export names only
+   match getExportNameFor env n with
+   | some (Name.str Name.anonymous s _) => pure $ "_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) (addExternForConsts : Bool) : M Unit :=
+do let ps := decl.params;
+   env ← getEnv;
+   when (ps.isEmpty && addExternForConsts) (emit "extern ");
+   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 {
+         when (i > 0) (emit ", ");
+         emit (toCType (ps.get! i).ty)
+       };
+     emit ")"
+   };
+   emitLn ";"
+
+def emitFnDecl (decl : Decl) (addExternForConsts : Bool) : M Unit :=
+do cppBaseName ← toCName decl.name;
+   emitFnDeclAux decl cppBaseName addExternForConsts
+
+def emitExternDeclAux (decl : Decl) (cNameStr : String) : M Unit :=
+do let cName := mkNameSimple cNameStr;
+   env ← getEnv;
+   let extC := isExternC env decl.name;
+   emitFnDeclAux decl cNameStr (!extC)
+
+def emitFnDecls : M Unit :=
+do 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
+     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 d ← getDecl `main;
+   match d with
+   | Decl.fdecl f xs t b => do
+     unless (xs.size == 2 || xs.size == 1) (throw "invalid main function, incorrect arity when generating code");
+     env ← getEnv;
+     let usesLeanAPI := usesLeanNamespace env d;
+     if usesLeanAPI then
+       emitLn "void lean_initialize();"
+     else
+       emitLn "void lean_initialize_runtime_module();";
+     emitLn "int main(int argc, char ** argv) {\nlean_object* in; lean_object* res;";
+     if usesLeanAPI then
+       emitLn "lean_initialize();"
+     else
+       emitLn "lean_initialize_runtime_module();";
+     modName ← getModName;
+     emitLn ("res = initialize_" ++ (modName.mangle "") ++ "(lean_io_mk_world());");
+     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 do {
+       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 do {
+       emitLn ("res = " ++ leanMainFn ++ "(lean_io_mk_world());")
+     };
+     emitLn "}";
+     emitLns ["if (lean_io_result_is_ok(res)) {",
+              "  int ret = lean_unbox(lean_io_result_get_value(res));",
+              "  lean_dec_ref(res);",
+              "  return ret;",
+              "} else {",
+              "  lean_io_result_show_error(res);",
+              "  lean_dec_ref(res);",
+              "  return 1;",
+              "}"];
+     emitLn "}"
+   | other => throw "function declaration expected"
+
+def hasMainFn : M Bool :=
+do env ← getEnv;
+   let decls := getDecls env;
+   pure $ decls.any (fun d => d.name == `main)
+
+def emitMainFnIfNeeded : M Unit :=
+whenM hasMainFn emitMainFn
+
+def emitFileHeader : M Unit :=
+do env ← getEnv;
+   modName ← getModName;
+   emitLn "// Lean compiler output";
+   emitLn ("// Module: " ++ toString modName);
+   emit "// Imports:";
+   env.imports.forM $ fun m => emit (" " ++ toString m);
+   emitLn "";
+   emitLn "#include \"runtime/lean.h\"";
+   emitLns [
+    "#if defined(__clang__)",
+    "#pragma clang diagnostic ignored \"-Wunused-parameter\"",
+    "#pragma clang diagnostic ignored \"-Wunused-label\"",
+    "#elif defined(__GNUC__) && !defined(__CLANG__)",
+    "#pragma GCC diagnostic ignored \"-Wunused-parameter\"",
+    "#pragma GCC diagnostic ignored \"-Wunused-label\"",
+    "#pragma GCC diagnostic ignored \"-Wunused-but-set-variable\"",
+    "#endif",
+    "#ifdef __cplusplus",
+    "extern \"C\" {",
+    "#endif"
+  ]
+
+def emitFileFooter : M Unit :=
+emitLns [
+ "#ifdef __cplusplus",
+ "}",
+ "#endif"
+]
+
+def throwUnknownVar {α : Type} (x : VarId) : M α :=
+throw ("unknown variable '" ++ toString x ++ "'")
+
+def getJPParams (j : JoinPointId) : M (Array Param) :=
+do ctx ← read;
+   match ctx.jpMap.find 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
+  ctx ← read;
+  if isTailCallTo ctx.mainFn e then
+    pure d
+  else
+    declareVar x t *> declareVars b true
+| FnBody.jdecl j xs _ b,    d => 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 alts.size != 2 then none
+else match alts.get! 0 with
+  | Alt.ctor c b => some (c.cidx, b, (alts.get! 1).body)
+  | _            => none
+
+def emitIf (emitBody : FnBody → M Unit) (x : VarId) (xType : IRType) (tag : Nat) (t : FnBody) (e : FnBody) : M Unit :=
+do emit "if ("; emitTag x xType; emit " == "; emit tag; emitLn ")";
+   emitBody t;
+   emitLn "else";
+   emitBody e
+
+def emitCase (emitBody : FnBody → M Unit) (x : VarId) (xType : IRType) (alts : Array Alt) : M Unit :=
+match isIf alts with
+| some (tag, t, e) => emitIf emitBody x xType tag t e
+| _ => do
+  emit "switch ("; emitTag x xType; emitLn ") {";
+  let alts := ensureHasDefault alts;
+  alts.forM $ fun alt => match alt with
+    | Alt.ctor c b  => emit "case " *> emit c.cidx *> emitLn ":" *> emitBody b
+    | Alt.default b => emitLn "default: " *> emitBody b;
+  emitLn "}"
+
+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;
+   when (n != 1) (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;
+   when (n != 1) (do 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 :=
+if n > 0 then do
+  emit "sizeof(void*)*"; emit n;
+  when (offset > 0) (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  => throw "floats are not supported yet"
+   | 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 ps ← getJPParams j;
+   unless (xs.size == ps.size) (throw "invalid goto");
+    xs.size.forM $ fun i => do {
+      let p := ps.get! i;
+      let x := xs.get! i;
+      emit p.x; emit " = "; emitArg x; emitLn ";"
+    };
+    emit "goto "; emit j; emitLn ";"
+
+def emitLhs (z : VarId) : M Unit :=
+do emit z; emit " = "
+
+def emitArgs (ys : Array Arg) : M Unit :=
+ys.size.forM $ fun i => do
+  when (i > 0) (emit ", ");
+  emitArg (ys.get! i)
+
+def emitCtorScalarSize (usize : Nat) (ssize : Nat) : M Unit :=
+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.get! 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 ";";
+   when updtHeader (do 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  => throw "floats are not supported yet"
+   | 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.
+   ys.size.foldM
+     (fun i (first : Bool) =>
+       if (ps.get! i).ty.isIrrelevant then
+         pure first
+       else do
+         unless first (emit ", ");
+         emitArg (ys.get! 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 ";"
+| some (ExternEntry.foreign _ extFn)  => emitSimpleExternalCall extFn ps ys
+| _ => throw ("failed to emit extern application '" ++ toString f ++ "'")
+
+def emitFullApp (z : VarId) (f : FunId) (ys : Array Arg) : M Unit :=
+do emitLhs z;
+   decl ← getDecl f;
+   match decl with
+   | Decl.extern _ ps _ extData => emitExternCall f ps extData ys
+   | _ => do emitCName f; when (ys.size > 0) (do emit "("; emitArgs ys; emit ")"); emitLn ";"
+
+def emitPartialApp (z : VarId) (f : FunId) (ys : Array Arg) : M Unit :=
+do 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.get! 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  => throw "floats are not supported yet"
+| other         => 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;
+   match t with
+   | IRType.usize  => emit "lean_unbox_usize"
+   | IRType.uint32 => emit "lean_unbox_uint32"
+   | IRType.uint64 => emit "lean_unbox_uint64"
+   | IRType.float  => throw "floats are not supported yet"
+   | other         => emit "lean_unbox";
+   emit "("; emit x; emitLn ");"
+
+def emitIsShared (z : VarId) (x : VarId) : M Unit :=
+do emitLhs z; emit "!lean_is_exclusive("; emit x; emitLn ");"
+
+def emitIsTaggedPtr (z : VarId) (x : VarId) : M Unit :=
+do emitLhs z; emit "!lean_is_scalar("; 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 == '\n' 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 emitNumLit (t : IRType) (v : Nat) : M Unit :=
+if t.isObj then do
+  if v < uint32Sz then
+    emit "lean_unsigned_to_nat(" *> emit v *> emit "u)"
+  else
+    emit "lean_cstr_to_nat(\"" *> emit v *> emit "\")"
+else
+  emit v
+
+def emitLit (z : VarId) (t : IRType) (v : LitVal) : M Unit :=
+emitLhs z *>
+match v with
+| LitVal.num v => emitNumLit t v *> emitLn ";"
+| LitVal.str v => do emit "lean_mk_string("; emit (quoteString v); 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.isTaggedPtr x  => emitIsTaggedPtr z x
+| Expr.lit v          => emitLit z t v
+
+def isTailCall (x : VarId) (v : Expr) (b : FnBody) : M Bool :=
+do ctx ← read;
+   match v, b with
+   | Expr.fap f _, FnBody.ret (Arg.var y) => pure $ 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.get! i;
+  (i+1, n).anyI $ fun j => paramEqArg p (ys.get! j)
+
+def emitTailCall (v : Expr) : M Unit :=
+match v with
+| Expr.fap _ ys => do
+  ctx ← read;
+  let ps := ctx.mainParams;
+  unless (ps.size == ys.size) (throw "invalid tail call");
+  if overwriteParam ps ys then do {
+    emitLn "{";
+    ps.size.forM $ fun i => do {
+      let p := ps.get! i;
+      let y := ys.get! 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.get! i;
+      let y := ys.get! i;
+      unless (paramEqArg p y) (do emit p.x; emit " = _tmp_"; emit i; emitLn ";")
+    };
+    emitLn "}"
+  } else do {
+    ys.size.forM $ fun i => do {
+      let p := ps.get! i;
+      let y := ys.get! i;
+      unless (paramEqArg p y) (do emit p.x; emit " = "; emitArg y; emitLn ";")
+    }
+  };
+  emitLn "goto _start;"
+| _ => throw "bug at emitTailCall"
+
+partial def emitBlock (emitBody : FnBody → M Unit) : FnBody → M Unit
+| FnBody.jdecl j xs v b      => emitBlock b
+| d@(FnBody.vdecl x t v b)   =>
+  do 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 (emitInc x n c) *> emitBlock b
+| FnBody.dec x n c p b       => unless p (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 emitBody x xType alts
+| FnBody.jmp j xs            => emitJmp j xs
+| FnBody.unreachable         => emitLn "lean_panic_unreachable();"
+
+partial def emitJPs (emitBody : FnBody → M Unit) : FnBody → M Unit
+| FnBody.jdecl j xs v b => do emit j; emitLn ":"; emitBody v; emitJPs b
+| e                     => unless e.isTerminal (emitJPs e.body)
+
+partial def emitFnBody : FnBody → M Unit
+| b => do
+emitLn "{";
+declared ← declareVars b false;
+when declared (emitLn "");
+emitBlock emitFnBody b;
+emitJPs emitFnBody b;
+emitLn "}"
+
+def emitDeclAux (d : Decl) : M Unit :=
+do env ← getEnv;
+   let (vMap, jpMap) := mkVarJPMaps d;
+   adaptReader (fun (ctx : Context) => { jpMap := jpMap, .. ctx }) $ do
+   unless (hasInitAttr env d.name) $
+     match d with
+     | Decl.fdecl f xs t b => do
+       baseName ← toCName f;
+       emit (toCType t); emit " ";
+       if xs.size > 0 then do {
+         emit baseName;
+         emit "(";
+         if xs.size > closureMaxArgs && isBoxedName d.name then
+           emit "lean_object** _args"
+         else
+           xs.size.forM $ fun i => do {
+             when (i > 0) (emit ", ");
+             let x := xs.get! i;
+             emit (toCType x.ty); emit " "; emit x.x
+           };
+         emit ")"
+       } else do {
+         emit ("_init_" ++ baseName ++ "()")
+       };
+       emitLn " {";
+       when (xs.size > closureMaxArgs && isBoxedName d.name) $
+         xs.size.forM $ fun i => do {
+           let x := xs.get! i;
+           emit "lean_object* "; emit x.x; emit " = _args["; emit i; emitLn "];"
+         };
+       emitLn "_start:";
+       adaptReader (fun (ctx : Context) => { mainFn := f, mainParams := xs, .. ctx }) (emitFnBody b);
+       emitLn "}"
+     | _ => pure ()
+
+def emitDecl (d : Decl) : M Unit :=
+let d := d.normalizeIds; -- ensure we don't have gaps in the variable indices
+catch
+  (emitDeclAux d)
+  (fun err => throw (err ++ "\ncompiling:\n" ++ toString d))
+
+def emitFns : M Unit :=
+do env ← getEnv;
+   let decls := getDecls env;
+   decls.reverse.forM emitDecl
+
+def emitMarkPersistent (d : Decl) (n : Name) : M Unit :=
+when d.resultType.isObj $ do {
+  emit "lean_mark_persistent("; emitCName n; emitLn ");"
+}
+
+def emitDeclInit (d : Decl) : M Unit :=
+do env ← getEnv;
+   let n := d.name;
+   if isIOUnitInitFn env n then do {
+     emit "res = "; emitCName n; emitLn "(lean_io_mk_world());";
+     emitLn "if (lean_io_result_is_error(res)) return res;";
+     emitLn "lean_dec_ref(res);"
+   } else when (d.params.size == 0) $
+     match getInitFnNameFor env d.name with
+     | some initFn => do {
+       emit "res = "; emitCName initFn; emitLn "(lean_io_mk_world());";
+       emitLn "if (lean_io_result_is_error(res)) return res;";
+       emitCName n; emitLn " = lean_io_result_get_value(res);";
+       emitMarkPersistent d n;
+       emitLn "lean_dec_ref(res);"
+       }
+     | _ => do { emitCName n; emit " = "; emitCInitName n; emitLn "();"; emitMarkPersistent d n }
+
+def emitInitFn : M Unit :=
+do env ← getEnv;
+   modName ← getModName;
+   env.imports.forM $ fun imp => emitLn ("lean_object* initialize_" ++ imp.module.mangle "" ++ "(lean_object*);");
+   emitLns [
+     "static bool _G_initialized = false;",
+     "lean_object* initialize_" ++ modName.mangle "" ++ "(lean_object* w) {",
+     "lean_object * res;",
+     "if (_G_initialized) return lean_mk_io_result(lean_box(0));",
+     "_G_initialized = true;"
+   ];
+   env.imports.forM $ fun imp => emitLns [
+     "res = initialize_" ++ imp.module.mangle "" ++ "(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_mk_io_result(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 IR
+end Lean

stage0/src/Init/Lean/Compiler/IR/EmitUtil.lean

@@ -0,0 +1,122 @@
+/-
+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 Init.Control.Conditional
+import Init.Lean.Compiler.InitAttr
+import Init.Lean.Compiler.IR.CompilerM
+
+/- Helper functions for backend code generators -/
+
+namespace Lean
+namespace 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
+
+namespace UsesLeanNamespace
+
+abbrev M := ReaderT Environment (StateM NameSet)
+
+def leanNameSpacePrefix := `Lean
+
+partial def visitFnBody : FnBody → M Bool
+| FnBody.vdecl _ _ v b   =>
+  let checkFn (f : FunId) : M Bool :=
+     if leanNameSpacePrefix.isPrefixOf f then pure true
+     else do {
+       s ← get;
+       if s.contains f then
+         visitFnBody b
+       else do
+         modify (fun s => s.insert f);
+         env ← read;
+         match findEnvDecl env f with
+         | some (Decl.fdecl _ _ _ fbody) => visitFnBody fbody <||> visitFnBody b
+         | other                         => visitFnBody b
+    };
+  match v with
+  | Expr.fap f _ => checkFn f
+  | Expr.pap f _ => checkFn f
+  | other        => visitFnBody b
+| FnBody.jdecl _ _ v b   => visitFnBody v <||> visitFnBody b
+| FnBody.case _ _ _ alts => alts.anyM $ fun alt => visitFnBody alt.body
+| e =>
+  if e.isTerminal then pure false
+  else visitFnBody e.body
+
+end UsesLeanNamespace
+
+def usesLeanNamespace (env : Environment) : Decl → Bool
+| Decl.fdecl _ _ _ b => (UsesLeanNamespace.visitFnBody b env).run' {}
+| _                  => false
+
+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
+| FnBody.vdecl _ _ v b   =>
+  match v with
+  | Expr.fap f _ => collect f *> collectFnBody b
+  | Expr.pap f _ => collect f *> collectFnBody b
+  | other        => collectFnBody b
+| FnBody.jdecl _ _ v b   => collectFnBody v *> collectFnBody b
+| FnBody.case _ _ _ alts => alts.forM $ fun alt => collectFnBody alt.body
+| e => unless e.isTerminal $ collectFnBody e.body
+
+def collectInitDecl (fn : Name) : M Unit :=
+do env ← read;
+   match getInitFnNameFor env fn with
+   | some initFn => collect initFn
+   | _           => pure ()
+
+def collectDecl : Decl → M NameSet
+| Decl.fdecl fn _ _ b  => collectInitDecl fn *> CollectUsedDecls.collectFnBody b *> get
+| Decl.extern fn _ _ _ => collectInitDecl fn *> get
+
+end CollectUsedDecls
+
+def collectUsedDecls (env : Environment) (decl : Decl) (used : NameSet := {}) : NameSet :=
+(CollectUsedDecls.collectDecl decl env).run' used
+
+abbrev VarTypeMap  := HashMap VarId IRType
+abbrev JPParamsMap := 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
+| FnBody.vdecl x t _ b    => collectVar x t ∘ collectFnBody b
+| FnBody.jdecl j xs v b   => collectJP j xs ∘ collectParams xs ∘ collectFnBody v ∘ collectFnBody b
+| FnBody.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
+| Decl.fdecl _ xs _ 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

stage0/src/Init/Lean/Compiler/IR/ExpandResetReuse.lean

@@ -0,0 +1,294 @@
+/-
+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 Init.Control.State
+import Init.Control.Reader
+import Init.Data.Nat
+import Init.Lean.Compiler.IR.CompilerM
+import Init.Lean.Compiler.IR.NormIds
+import Init.Lean.Compiler.IR.FreeVars
+
+namespace Lean
+namespace IR
+namespace ExpandResetReuse
+/- Mapping from variable to projections -/
+abbrev ProjMap  := HashMap VarId Expr
+namespace CollectProjMap
+abbrev Collector := ProjMap → ProjMap
+@[inline] def collectVDecl (x : VarId) (v : Expr) : Collector :=
+fun m => match v with
+ | Expr.proj _ _    => m.insert x v
+ | Expr.sproj _ _ _ => m.insert x v
+ | Expr.uproj _ _   => m.insert x v
+ | _                => m
+
+partial def collectFnBody : FnBody → Collector
+| FnBody.vdecl x _ v b   => collectVDecl x v ∘ collectFnBody b
+| FnBody.jdecl _ _ v b   => collectFnBody v ∘ collectFnBody b
+| FnBody.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
+| Decl.fdecl _ _ _ b => CollectProjMap.collectFnBody b {}
+| _ => {}
+
+structure Context :=
+(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
+| FnBody.vdecl _ _ v b   =>
+  match v with
+  | Expr.reuse y _ _ _ => x == y || consumed b
+  | _                  => consumed b
+| FnBody.dec y _ _ _ b   => x == y || consumed b
+| FnBody.case _ _ _ alts => alts.all $ fun alt => consumed alt.body
+| e => !e.isTerminal && consumed e.body
+
+abbrev Mask := Array (Option VarId)
+
+/- Auxiliary function for eraseProjIncFor -/
+partial def eraseProjIncForAux (y : VarId) : Array FnBody → Mask → Array FnBody → Array FnBody × Mask
+| bs, mask, keep =>
+  let done (_ : Unit)        := (bs ++ keep.reverse, mask);
+  let keepInstr (b : FnBody) := eraseProjIncForAux bs.pop mask (keep.push b);
+  if bs.size < 2 then done ()
+  else
+    let b := bs.back;
+    match b with
+    | (FnBody.vdecl _ _ (Expr.sproj _ _ _) _) => keepInstr b
+    | (FnBody.vdecl _ _ (Expr.uproj _ _) _)   => keepInstr b
+    | (FnBody.inc z n c p _) =>
+      if n == 0 then done () else
+      let b' := bs.get! (bs.size - 2);
+      match b' with
+      | (FnBody.vdecl w _ (Expr.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 bs mask keep
+        else done ()
+      | other => done ()
+    | other => 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 (mkArray n none) #[]
+
+/- Replace `reuse x ctor ...` with `ctor ...`, and remoce `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 b)
+| FnBody.vdecl z t v b   =>
+  match v with
+  | Expr.reuse y c u xs =>
+    if x == y then FnBody.vdecl z t (Expr.ctor c xs) b
+    else FnBody.vdecl z t v (reuseToCtor b)
+  | _ =>
+    FnBody.vdecl z t v (reuseToCtor b)
+| FnBody.case tid y yType alts   =>
+  let alts := alts.map $ fun alt => alt.modifyBody reuseToCtor;
+  FnBody.case tid y yType alts
+| e =>
+  if e.isTerminal then e
+  else
+    let (instr, b) := e.split;
+    let b := reuseToCtor 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
+  (fun b m => match m with
+    | some z => FnBody.inc z 1 true false b
+    | none   => b)
+  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
+  (fun i b =>
+    match mask.get! i with
+    | some _ => pure b -- code took ownership of this field
+    | none   => do
+      fld ← mkFresh;
+      pure (FnBody.vdecl fld IRType.object (Expr.proj i y) (FnBody.dec fld 1 true false b)))
+  b
+
+def setFields (y : VarId) (zs : Array Arg) (b : FnBody) : FnBody :=
+zs.size.fold
+  (fun i b => FnBody.set y i (zs.get! i) b)
+  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.find 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.find 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.find 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 b
+  else FnBody.set x i y (removeSelfSet b)
+| FnBody.uset x i y b   =>
+  if isSelfUSet ctx x i y then removeSelfSet b
+  else FnBody.uset x i y (removeSelfSet b)
+| FnBody.sset x n i y t b   =>
+  if isSelfSSet ctx x n i y then removeSelfSet b
+  else FnBody.sset x n i y t (removeSelfSet b)
+| FnBody.case tid y yType alts   =>
+  let alts := alts.map $ fun alt => alt.modifyBody removeSelfSet;
+  FnBody.case tid y yType alts
+| e =>
+  if e.isTerminal then e
+  else
+    let (instr, b) := e.split;
+    let b := removeSelfSet 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 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 b)
+  | _ => FnBody.vdecl z t v (reuseToSet b)
+| FnBody.case tid y yType alts   =>
+  let alts := alts.map $ fun alt => alt.modifyBody reuseToSet;
+  FnBody.case tid y yType alts
+| e =>
+  if e.isTerminal then e
+  else
+    let (instr, b) := e.split;
+    let b := reuseToSet 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 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 bOld := FnBody.vdecl x IRType.object (Expr.reset n y) b;
+   let (bs, mask) := eraseProjIncFor n y bs;
+   /- Remark: we may be duplicting 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;
+   bFast ← mkFastPath x y mask b;
+   /- We only optimize recursively the fast. -/
+   bFast ← mainFn bFast #[];
+   c ← mkFresh;
+   let b := FnBody.vdecl c IRType.uint8 (Expr.isShared y) (mkIf c bSlow bFast);
+   pure $ reshape bs b
+
+partial def searchAndExpand : FnBody → Array FnBody → M FnBody
+| d@(FnBody.vdecl x t (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
+  v ← searchAndExpand v #[];
+  searchAndExpand b (push bs (FnBody.jdecl j xs v FnBody.nil))
+| FnBody.case tid x xType alts,   bs => do
+  alts ← alts.mapM $ fun alt => alt.mmodifyBody $ fun b => searchAndExpand b #[];
+  pure $ reshape bs (FnBody.case tid x xType alts)
+| b, bs =>
+  if b.isTerminal then pure $ reshape bs b
+  else searchAndExpand b.body (push bs b)
+
+def main (d : Decl) : Decl :=
+match d with
+| (Decl.fdecl f xs t b) =>
+  let m := mkProjMap d;
+  let nextIdx := d.maxIndex + 1;
+  let b := (searchAndExpand b #[] { projMap := m }).run' nextIdx;
+  Decl.fdecl f xs t b
+| d => d
+
+end ExpandResetReuse
+
+/-- (Try to) expand `reset` and `reuse` instructions. -/
+def Decl.expandResetReuse (d : Decl) : Decl :=
+(ExpandResetReuse.main d).normalizeIds
+
+end IR
+end Lean

stage0/src/Init/Lean/Compiler/IR/Format.lean

@@ -0,0 +1,132 @@
+/-
+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 Init.Lean.Compiler.IR.Basic
+import Init.Lean.Format
+
+namespace Lean
+namespace IR
+
+private def formatArg : Arg → Format
+| Arg.var id     => format id
+| Arg.irrelevant => "◾"
+
+instance argHasFormat : HasFormat Arg := ⟨formatArg⟩
+
+def formatArray {α : Type} [HasFormat α] (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 litValHasFormat : HasFormat LitVal := ⟨formatLitVal⟩
+
+private def formatCtorInfo : CtorInfo → Format
+| { name := name, cidx := cidx, usize := usize, ssize := ssize, .. } =>
+  let r := format "ctor_" ++ format cidx;
+  let r := if usize > 0 || ssize > 0 then r ++ "." ++ format usize ++ "." ++ format ssize else r;
+  let r := if name != Name.anonymous then r ++ "[" ++ format name ++ "]" else r;
+  r
+
+instance ctorInfoHasFormat : HasFormat 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
+| Expr.isTaggedPtr x  => "isTaggedPtr " ++ format x
+
+instance exprHasFormat   : HasFormat Expr := ⟨formatExpr⟩
+instance exprHasToString : HasToString Expr := ⟨fun e => Format.pretty (format e)⟩
+
+private partial def formatIRType : IRType → Format
+| IRType.float        => "float"
+| 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 => "struct " ++ Format.bracket "{" (@Format.joinSep _ ⟨formatIRType⟩ tys.toList ", ") "}"
+| IRType.union _ tys  => "union " ++ Format.bracket "{" (@Format.joinSep _ ⟨formatIRType⟩ tys.toList ", ") "}"
+
+instance typeHasFormat : HasFormat IRType := ⟨formatIRType⟩
+
+private def formatParam : Param → Format
+| { x := name, borrow := b, ty := ty } => "(" ++ format name ++ " : " ++ (if b then "@& " else "") ++ format ty ++ ")"
+
+instance paramHasFormat : HasFormat 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
+
+@[export lean_ir_format_fn_body_head]
+def formatFnBodyHead : FnBody → Format
+| FnBody.vdecl x ty e b      => "let " ++ format x ++ " : " ++ format ty ++ " := " ++ format e
+| FnBody.jdecl j xs v b      => format j ++ formatParams xs ++ " := ..."
+| FnBody.set x i y b         => "set " ++ format x ++ "[" ++ format i ++ "] := " ++ format y
+| FnBody.uset x i y b        => "uset " ++ format x ++ "[" ++ format i ++ "] := " ++ format y
+| FnBody.sset x i o y ty b   => "sset " ++ format x ++ "[" ++ format i ++ ", " ++ format o ++ "] : " ++ format ty ++ " := " ++ format y
+| FnBody.setTag x cidx b     => "setTag " ++ format x ++ " := " ++ format cidx
+| FnBody.inc x n c _ b       => "inc" ++ (if n != 1 then Format.sbracket (format n) else "") ++ " " ++ format x
+| FnBody.dec x n c _ b       => "dec" ++ (if n != 1 then Format.sbracket (format n) else "") ++ " " ++ format x
+| FnBody.del x b             => "del " ++ format x
+| FnBody.mdata d b           => "mdata " ++ format d
+| FnBody.case tid x xType cs => "case " ++ format x ++ " of ..."
+| FnBody.jmp j ys            => "jmp " ++ format j ++ formatArray ys
+| FnBody.ret x               => "ret " ++ format x
+| FnBody.unreachable         => "⊥"
+
+partial def formatFnBody (indent : Nat := 2) : FnBody → Format
+| FnBody.vdecl x ty e b      => "let " ++ format x ++ " : " ++ format ty ++ " := " ++ format e ++ ";" ++ Format.line ++ formatFnBody b
+| FnBody.jdecl j xs v b      => format j ++ formatParams xs ++ " :=" ++ Format.nest indent (Format.line ++ formatFnBody v) ++ ";" ++ Format.line ++ formatFnBody b
+| FnBody.set x i y b         => "set " ++ format x ++ "[" ++ format i ++ "] := " ++ format y ++ ";" ++ Format.line ++ formatFnBody b
+| FnBody.uset x i y b        => "uset " ++ format x ++ "[" ++ format i ++ "] := " ++ format y ++ ";" ++ Format.line ++ formatFnBody b
+| FnBody.sset x i o y ty b   => "sset " ++ format x ++ "[" ++ format i ++ ", " ++ format o ++ "] : " ++ format ty ++ " := " ++ format y ++ ";" ++ Format.line ++ formatFnBody b
+| FnBody.setTag x cidx b     => "setTag " ++ format x ++ " := " ++ format cidx ++ ";" ++ Format.line ++ formatFnBody b
+| FnBody.inc x n c _ b       => "inc" ++ (if n != 1 then Format.sbracket (format n) else "") ++ " " ++ format x ++ ";" ++ Format.line ++ formatFnBody b
+| FnBody.dec x n c _ b       => "dec" ++ (if n != 1 then Format.sbracket (format n) else "") ++ " " ++ format x ++ ";" ++ Format.line ++ formatFnBody b
+| FnBody.del x b             => "del " ++ format x ++ ";" ++ Format.line ++ formatFnBody b
+| FnBody.mdata d b           => "mdata " ++ format d ++ ";" ++ Format.line ++ formatFnBody b
+| FnBody.case tid x xType cs => "case " ++ format x ++ " : " ++ format xType ++ " of" ++ cs.foldl (fun r c => r ++ Format.line ++ formatAlt formatFnBody indent c) Format.nil
+| FnBody.jmp j ys            => "jmp " ++ format j ++ formatArray ys
+| FnBody.ret x               => "ret " ++ format x
+| FnBody.unreachable         => "⊥"
+
+instance fnBodyHasFormat : HasFormat FnBody := ⟨formatFnBody⟩
+instance fnBodyHasToString : HasToString FnBody := ⟨fun b => (format b).pretty⟩
+
+def formatDecl (indent : Nat := 2) : Decl → Format
+| Decl.fdecl f xs ty b  => "def " ++ format f ++ formatParams xs ++ format " : " ++ format ty ++ " :=" ++ Format.nest indent (Format.line ++ formatFnBody indent b)
+| Decl.extern f xs ty _ => "extern " ++ format f ++ formatParams xs ++ format " : " ++ format ty
+
+instance declHasFormat : HasFormat Decl := ⟨formatDecl⟩
+
+@[export lean_ir_decl_to_string]
+def declToString (d : Decl) : String :=
+(format d).pretty
+
+instance declHasToString : HasToString Decl := ⟨declToString⟩
+
+end IR
+end Lean

stage0/src/Init/Lean/Compiler/IR/FreeVars.lean

@@ -0,0 +1,236 @@
+/-
+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 Init.Lean.Compiler.IR.Basic
+
+namespace Lean
+namespace 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 : HasAndthen Collector := ⟨seq⟩
+
+private def collectArg : Arg → Collector
+| Arg.var x  => collectVar x
+| irrelevant => skip
+
+@[specialize] 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 v          => skip
+| Expr.isShared x     => collectVar x
+| Expr.isTaggedPtr 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
+| Decl.fdecl _ xs _ b  => collectParams xs >> collectFnBody b
+| Decl.extern _ 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 bv 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 (fun s p => s.insert p.x.idx) s
+
+@[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 : HasAndthen Collector := ⟨seq⟩
+
+private def collectArg : Arg → Collector
+| Arg.var x  => collectVar x
+| irrelevant => skip
+
+@[specialize] 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 v          => skip
+| Expr.isShared x     => collectVar x
+| Expr.isTaggedPtr 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 v          => false
+| Expr.isShared x     => visitVar w x
+| Expr.isTaggedPtr x  => visitVar w x
+
+partial def visitFnBody (w : Index) : FnBody → Bool
+| FnBody.vdecl x _ v b    => visitExpr w v || visitFnBody b
+| FnBody.jdecl j ys v b   => visitFnBody v || visitFnBody b
+| FnBody.set x _ y b      => visitVar w x || visitArg w y || visitFnBody b
+| FnBody.uset x _ y b     => visitVar w x || visitVar w y || visitFnBody b
+| FnBody.sset x _ _ y _ b => visitVar w x || visitVar w y || visitFnBody b
+| FnBody.setTag x _ b     => visitVar w x || visitFnBody b
+| FnBody.inc x _ _ _ b    => visitVar w x || visitFnBody b
+| FnBody.dec x _ _ _ b    => visitVar w x || visitFnBody b
+| FnBody.del x b          => visitVar w x || visitFnBody b
+| FnBody.mdata _ b        => visitFnBody 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 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 IR
+end Lean