/-
Copyright (c) 2022 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Siddharth Bhat
-/

import Lean.Data.HashMap
import Lean.Runtime
import Lean.Compiler.NameMangling
import Lean.Compiler.ExportAttr
import Lean.Compiler.InitAttr
import Lean.Compiler.IR.CompilerM
import Lean.Compiler.IR.EmitUtil
import Lean.Compiler.IR.NormIds
import Lean.Compiler.IR.SimpCase
import Lean.Compiler.IR.Boxing
import Lean.Compiler.IR.ResetReuse
import Lean.Compiler.IR.LLVMBindings

open Lean.IR.ExplicitBoxing (isBoxedName)

namespace Lean.IR

def leanMainFn := "_lean_main"

namespace LLVM
-- TODO(bollu): instantiate target triple and find out what size_t is.
def size_tType (llvmctx : LLVM.Context) : IO (LLVM.LLVMType llvmctx) :=
  LLVM.i64Type llvmctx
end LLVM

namespace EmitLLVM

structure Context (llvmctx : LLVM.Context) where
  env        : Environment
  modName    : Name
  jpMap      : JPParamsMap := {}
  mainFn     : FunId := default
  mainParams : Array Param := #[]
  llvmmodule : LLVM.Module llvmctx

structure State (llvmctx : LLVM.Context) where
  var2val : HashMap VarId (LLVM.LLVMType llvmctx × LLVM.Value llvmctx)
  jp2bb   : HashMap JoinPointId (LLVM.BasicBlock llvmctx)

abbrev Error := String

abbrev M (llvmctx : LLVM.Context) :=
  StateRefT (State llvmctx) (ReaderT (Context llvmctx) (ExceptT Error IO))

instance : Inhabited (M llvmctx α) where
  default := throw "Error: inhabitant"

def addVartoState (x : VarId) (v : LLVM.Value llvmctx) (ty : LLVM.LLVMType llvmctx) : M llvmctx Unit := do
  modify (fun s => { s with var2val := s.var2val.insert x (ty, v) }) -- add new variable

def addJpTostate (jp : JoinPointId) (bb : LLVM.BasicBlock llvmctx) : M llvmctx Unit :=
  modify (fun s => { s with jp2bb := s.jp2bb.insert jp bb })

def emitJp (jp : JoinPointId) : M llvmctx (LLVM.BasicBlock llvmctx) := do
  let state ← get
  match state.jp2bb.find? jp with
  | .some bb => return bb
  | .none => throw s!"unable to find join point {jp}"

def getLLVMModule : M llvmctx (LLVM.Module llvmctx) := Context.llvmmodule <$> read

def getEnv : M llvmctx Environment := Context.env <$> read

def getModName : M llvmctx  Name := Context.modName <$> read

def getDecl (n : Name) : M llvmctx Decl := do
  let env ← getEnv
  match findEnvDecl env n with
  | some d => pure d
  | none   => throw s!"unknown declaration {n}"

def constIntUnsigned (n : Nat) : M llvmctx (LLVM.Value llvmctx) :=  do
    LLVM.constIntUnsigned llvmctx (UInt64.ofNat n)

def getOrCreateFunctionPrototype (mod : LLVM.Module llvmctx)
    (retty : LLVM.LLVMType llvmctx) (name : String) (args : Array (LLVM.LLVMType llvmctx)) : M llvmctx  (LLVM.Value llvmctx) := do
  LLVM.getOrAddFunction mod name $ ← LLVM.functionType retty args (isVarArg := false)

def callLeanBox (builder : LLVM.Builder llvmctx)
    (arg : LLVM.Value llvmctx) (name : String := "") : M llvmctx (LLVM.Value llvmctx) := do
  let fnName :=  "lean_box"
  let retty ← LLVM.voidPtrType llvmctx
  let argtys := #[ ← LLVM.size_tType llvmctx ]
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
  let fnty ← LLVM.functionType retty argtys
  LLVM.buildCall2 builder fnty fn  #[arg] name

def callLeanMarkPersistentFn (builder : LLVM.Builder llvmctx) (arg : LLVM.Value llvmctx) : M llvmctx  Unit := do
  let fnName :=  "lean_mark_persistent"
  let retty ← LLVM.voidType llvmctx
  let argtys := #[ ← LLVM.voidPtrType llvmctx ]
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
  let fnty ← LLVM.functionType retty argtys
  let _ ←   LLVM.buildCall2 builder fnty fn  #[arg]

-- `lean_{inc, dec}_{ref?}_{1,n}`
inductive RefcountKind where
  | inc | dec

instance : ToString RefcountKind where
  toString
    | .inc => "inc"
    | .dec => "dec"

def callLeanRefcountFn (builder : LLVM.Builder llvmctx)
    (kind : RefcountKind) (checkRef? : Bool) (arg : LLVM.Value llvmctx)
    (delta : Option (LLVM.Value llvmctx) := Option.none) : M llvmctx Unit := do
  let fnName :=  s!"lean_{kind}{if checkRef? then "" else "_ref"}{if delta.isNone then "" else "_n"}"
  let retty ← LLVM.voidType llvmctx
  let argtys := if delta.isNone then #[← LLVM.voidPtrType llvmctx] else #[← LLVM.voidPtrType llvmctx, ← LLVM.size_tType llvmctx]
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
  let fnty ← LLVM.functionType retty argtys
  match delta with
  | .none => do
    -- since refcount δ is 1, we only supply the pointer.
    let _ ← LLVM.buildCall2 builder fnty fn #[arg]
  | .some n => do
    let _ ← LLVM.buildCall2 builder fnty fn #[arg, n]

-- `decRef1`
-- Do NOT attempt to merge this code with callLeanRefcountFn, because of the uber confusing
-- semantics of 'ref?'. If 'ref?' is true, it calls the version that is lean_dec
def callLeanDecRef (builder : LLVM.Builder llvmctx) (res : LLVM.Value llvmctx) : M llvmctx Unit := do
  let fnName :=  "lean_dec_ref"
  let retty ← LLVM.voidType llvmctx
  let argtys := #[ ← LLVM.i8PtrType llvmctx ]
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
  let fnty ← LLVM.functionType retty argtys
  let _ ← LLVM.buildCall2 builder fnty fn  #[res]

def callLeanUnsignedToNatFn (builder : LLVM.Builder llvmctx)
    (n : Nat) (name : String := "") : M llvmctx (LLVM.Value llvmctx) := do
  let mod ← getLLVMModule
  let argtys := #[← LLVM.i32Type llvmctx]
  let retty ← LLVM.voidPtrType llvmctx
  let f ←   getOrCreateFunctionPrototype mod retty "lean_unsigned_to_nat"  argtys
  let fnty ← LLVM.functionType retty argtys
  let nv ← LLVM.constInt32 llvmctx (UInt64.ofNat n)
  LLVM.buildCall2 builder fnty f #[nv] name

def callLeanMkStringFromBytesFn (builder : LLVM.Builder llvmctx)
    (strPtr nBytes : LLVM.Value llvmctx) (name : String) : M llvmctx (LLVM.Value llvmctx) := do
  let fnName :=  "lean_mk_string_from_bytes"
  let retty ← LLVM.voidPtrType llvmctx
  let argtys :=  #[← LLVM.voidPtrType llvmctx, ← LLVM.i64Type llvmctx]
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
  let fnty ← LLVM.functionType retty argtys
  LLVM.buildCall2 builder fnty fn #[strPtr, nBytes] name

def callLeanMkString (builder : LLVM.Builder llvmctx)
    (strPtr : LLVM.Value llvmctx) (name : String) : M llvmctx (LLVM.Value llvmctx) := do
  let retty ← LLVM.voidPtrType llvmctx
  let argtys :=  #[← LLVM.voidPtrType llvmctx]
  let fn ←  getOrCreateFunctionPrototype (← getLLVMModule) retty "lean_mk_string" argtys
  let fnty ← LLVM.functionType retty argtys
  LLVM.buildCall2 builder fnty fn #[strPtr] name

def callLeanCStrToNatFn (builder : LLVM.Builder llvmctx)
    (n : Nat) (name : String := "") : M llvmctx (LLVM.Value llvmctx) := do
  let fnName :=  "lean_cstr_to_nat"
  let retty ← LLVM.voidPtrType llvmctx
  let argtys :=  #[← LLVM.voidPtrType llvmctx]
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
  let fnty ← LLVM.functionType retty argtys
  let s ← LLVM.buildGlobalString builder (value := toString n)
  LLVM.buildCall2 builder fnty fn #[s] name

def callLeanIOMkWorld (builder : LLVM.Builder llvmctx) : M llvmctx (LLVM.Value llvmctx) := do
  let fnName :=  "lean_io_mk_world"
  let retty ← LLVM.voidPtrType llvmctx
  let argtys :=  #[]
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
  let fnty ← LLVM.functionType retty argtys
  LLVM.buildCall2 builder fnty fn #[] "mk_io_out"

def callLeanIOResultIsError (builder : LLVM.Builder llvmctx)
    (arg : LLVM.Value llvmctx) (name : String := "") : M llvmctx (LLVM.Value llvmctx) := do
  let fnName :=  "lean_io_result_is_error"
  let retty ← LLVM.i1Type llvmctx
  let argtys :=  #[← LLVM.voidPtrType llvmctx]
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
  let fnty ← LLVM.functionType retty argtys
  LLVM.buildCall2 builder fnty fn #[arg] name

def callLeanAllocCtor (builder : LLVM.Builder llvmctx)
    (tag num_objs scalar_sz : Nat) (name : String := "") : M llvmctx (LLVM.Value llvmctx) := do
  let fnName :=  "lean_alloc_ctor"
  let retty ← LLVM.voidPtrType llvmctx
  let i32 ← LLVM.i32Type llvmctx
  let argtys :=  #[i32, i32, i32]
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
  let fnty ← LLVM.functionType retty argtys

  let tag ← LLVM.constInt32 llvmctx (UInt64.ofNat tag)
  let num_objs ← LLVM.constInt32 llvmctx (UInt64.ofNat num_objs)
  let scalar_sz ← LLVM.constInt32 llvmctx (UInt64.ofNat scalar_sz)
  LLVM.buildCall2 builder fnty fn #[tag, num_objs, scalar_sz] name

def callLeanCtorSet (builder : LLVM.Builder llvmctx)
    (o i v : LLVM.Value llvmctx) : M llvmctx Unit := do
  let fnName := "lean_ctor_set"
  let retty ← LLVM.voidType llvmctx
  let voidptr ← LLVM.voidPtrType llvmctx
  let unsigned ← LLVM.size_tType llvmctx
  let argtys :=  #[voidptr, unsigned, voidptr]
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
  let fnty ← LLVM.functionType retty argtys
  _ <- LLVM.buildCall2 builder fnty fn  #[o, i, v]

def callLeanIOResultMKOk (builder : LLVM.Builder llvmctx)
    (v : LLVM.Value llvmctx) (name : String := "") : M llvmctx (LLVM.Value llvmctx) := do
  let fnName :=  "lean_io_result_mk_ok"
  let voidptr ← LLVM.voidPtrType llvmctx
  let retty := voidptr
  let argtys :=  #[voidptr]
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
  let fnty ← LLVM.functionType retty argtys
  LLVM.buildCall2 builder fnty fn #[v] name

def callLeanAllocClosureFn (builder : LLVM.Builder llvmctx)
    (f arity nys : LLVM.Value llvmctx) (retName : String := "") : M llvmctx (LLVM.Value llvmctx) := do
  let fnName :=  "lean_alloc_closure"
  let retty ← LLVM.voidPtrType llvmctx
  let argtys := #[ ← LLVM.voidPtrType llvmctx, ← LLVM.size_tType llvmctx, ← LLVM.size_tType llvmctx]
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
  let fnty ← LLVM.functionType retty argtys
  LLVM.buildCall2 builder fnty fn  #[f, arity, nys] retName

def callLeanClosureSetFn (builder : LLVM.Builder llvmctx)
    (closure ix arg : LLVM.Value llvmctx) (retName : String := "") : M llvmctx Unit := do
  let fnName :=  "lean_closure_set"
  let retty ← LLVM.voidType llvmctx
  let argtys := #[ ← LLVM.voidPtrType llvmctx, ← LLVM.size_tType llvmctx, ← LLVM.voidPtrType llvmctx]
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
  let fnty ← LLVM.functionType retty argtys
  let _ ← LLVM.buildCall2 builder fnty fn  #[closure, ix, arg] retName

def callLeanObjTag (builder : LLVM.Builder llvmctx)
    (closure : LLVM.Value llvmctx) (retName : String := "") : M llvmctx (LLVM.Value llvmctx) := do
  let fnName :=  "lean_obj_tag"
  let retty ← LLVM.i32Type llvmctx
  let argtys := #[ ← LLVM.voidPtrType llvmctx]
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
  let fnty ← LLVM.functionType retty argtys
  let out ← LLVM.buildCall2 builder fnty fn  #[closure] retName
  LLVM.buildSextOrTrunc builder out (← LLVM.i64Type llvmctx)

def callLeanIOResultGetValue (builder : LLVM.Builder llvmctx)
    (v : LLVM.Value llvmctx) (name : String := "") : M llvmctx (LLVM.Value llvmctx) := do
  let fnName :=  "lean_io_result_get_value"
  let retty ← LLVM.voidPtrType llvmctx
  let argtys := #[ ← LLVM.voidPtrType llvmctx]
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
  let fnty ← LLVM.functionType retty argtys
  LLVM.buildCall2 builder fnty fn #[v] name

def callLeanCtorRelease (builder : LLVM.Builder llvmctx)
    (closure i : LLVM.Value llvmctx) (retName : String := "") : M llvmctx Unit := do
  let fnName :=  "lean_ctor_release"
  let retty ← LLVM.voidType llvmctx
  let argtys := #[ ← LLVM.voidPtrType llvmctx, ← LLVM.size_tType llvmctx]
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
  let fnty ← LLVM.functionType retty argtys
  let _ ← LLVM.buildCall2 builder fnty fn  #[closure, i] retName

def callLeanCtorSetTag (builder : LLVM.Builder llvmctx)
    (closure i : LLVM.Value llvmctx) (retName : String := "") : M llvmctx Unit := do
  let fnName :=  "lean_ctor_set_tag"
  let retty ← LLVM.voidType llvmctx
  let argtys := #[ ← LLVM.voidPtrType llvmctx, ← LLVM.size_tType llvmctx]
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
  let fnty ← LLVM.functionType retty argtys
  let _ ← LLVM.buildCall2 builder fnty fn  #[closure, i] retName

def toLLVMType (t : IRType) : M llvmctx (LLVM.LLVMType llvmctx) := do
  match t with
  | IRType.float      => LLVM.doubleTypeInContext llvmctx
  | IRType.uint8      => LLVM.intTypeInContext llvmctx 8
  | IRType.uint16     => LLVM.intTypeInContext llvmctx 16
  | IRType.uint32     => LLVM.intTypeInContext llvmctx 32
  | IRType.uint64     => LLVM.intTypeInContext llvmctx 64
  -- TODO: how to cleanly size_t in LLVM? We can do eg. instantiate the current target and query for size.
  | IRType.usize      => LLVM.size_tType llvmctx
  | IRType.object     => do LLVM.pointerType (← LLVM.i8Type llvmctx)
  | IRType.tobject    => do LLVM.pointerType (← LLVM.i8Type llvmctx)
  | IRType.irrelevant => do LLVM.pointerType (← LLVM.i8Type llvmctx)
  | IRType.struct _ _ => panic! "not implemented yet"
  | IRType.union _ _  => panic! "not implemented yet"

def throwInvalidExportName {α : Type} (n : Name) : M llvmctx α := do
  throw s!"invalid export name {n.toString}"

def toCName (n : Name) : M llvmctx String := do
  match getExportNameFor? (← getEnv) n with
  | some (.str .anonymous s) => pure s
  | some _                   => throwInvalidExportName n
  | none                     => if n == `main then pure leanMainFn else pure n.mangle

def toCInitName (n : Name) : M llvmctx String := do
  match getExportNameFor? (← getEnv) n with
  | some (.str .anonymous s) => return "_init_" ++ s
  | some _                   => throwInvalidExportName n
  | none                     => pure ("_init_" ++ n.mangle)

/--
## LLVM Control flow Utilities
-/

-- Indicates whether the API for building the blocks for then/else should
-- forward the control flow to the merge block.
inductive ShouldForwardControlFlow where
| yes | no

-- Get the function we are currently inserting into.
def builderGetInsertionFn (builder : LLVM.Builder llvmctx) : M llvmctx (LLVM.Value llvmctx) := do
  let builderBB ← LLVM.getInsertBlock builder
  LLVM.getBasicBlockParent builderBB

def builderAppendBasicBlock (builder : LLVM.Builder llvmctx) (name : String) : M llvmctx (LLVM.BasicBlock llvmctx) := do
  let fn ← builderGetInsertionFn builder
  LLVM.appendBasicBlockInContext llvmctx fn name

def buildWhile_ (builder : LLVM.Builder llvmctx) (name : String)
    (condcodegen : LLVM.Builder llvmctx → M llvmctx (LLVM.Value llvmctx))
    (bodycodegen : LLVM.Builder llvmctx → M llvmctx Unit) : M llvmctx Unit := do
  let fn ← builderGetInsertionFn builder

  let nameHeader := name ++ "header"
  let nameBody := name ++ "body"
  let nameMerge := name ++ "merge"

  -- cur → header
  let headerbb ← LLVM.appendBasicBlockInContext llvmctx fn nameHeader
  let _ ← LLVM.buildBr builder headerbb

  let bodybb ← LLVM.appendBasicBlockInContext llvmctx fn nameBody
  let mergebb ← LLVM.appendBasicBlockInContext llvmctx fn nameMerge

  -- header → {body, merge}
  LLVM.positionBuilderAtEnd builder headerbb
  let cond ← condcodegen builder
  let _ ← LLVM.buildCondBr builder cond bodybb mergebb

  -- body → header
  LLVM.positionBuilderAtEnd builder bodybb
  bodycodegen builder
  let _ ← LLVM.buildBr builder headerbb

  -- merge
  LLVM.positionBuilderAtEnd builder mergebb

-- build an if, and position the builder at the merge basic block after execution.
-- The '_' denotes that we return Unit on each branch.
def buildIfThen_ (builder : LLVM.Builder llvmctx) (name : String) (brval : LLVM.Value llvmctx)
    (thencodegen : LLVM.Builder llvmctx → M llvmctx ShouldForwardControlFlow) : M llvmctx Unit := do
  let fn ← builderGetInsertionFn builder

  let nameThen := name ++ "Then"
  let nameElse := name ++ "Else"
  let nameMerge := name ++ "Merge"

  let thenbb ← LLVM.appendBasicBlockInContext llvmctx fn nameThen
  let elsebb ← LLVM.appendBasicBlockInContext llvmctx fn nameElse
  let mergebb ← LLVM.appendBasicBlockInContext llvmctx fn nameMerge
  let _ ← LLVM.buildCondBr builder brval thenbb elsebb
  -- then
  LLVM.positionBuilderAtEnd builder thenbb
  let fwd? ← thencodegen builder
  match fwd? with
  | .yes => let _ ← LLVM.buildBr builder mergebb
  | .no => pure ()
  -- else
  LLVM.positionBuilderAtEnd builder elsebb
  let _ ← LLVM.buildBr builder mergebb
  -- merge
  LLVM.positionBuilderAtEnd builder mergebb

def buildIfThenElse_ (builder : LLVM.Builder llvmctx)  (name : String) (brval : LLVM.Value llvmctx)
    (thencodegen : LLVM.Builder llvmctx → M llvmctx ShouldForwardControlFlow)
    (elsecodegen : LLVM.Builder llvmctx → M llvmctx ShouldForwardControlFlow) : M llvmctx Unit := do
  let fn ← LLVM.getBasicBlockParent (← LLVM.getInsertBlock builder)
  let thenbb ← LLVM.appendBasicBlockInContext llvmctx fn (name ++ "Then")
  let elsebb ← LLVM.appendBasicBlockInContext llvmctx fn (name ++ "Else")
  let mergebb ← LLVM.appendBasicBlockInContext llvmctx fn (name ++ "Merge")
  let _ ← LLVM.buildCondBr builder brval thenbb elsebb
  -- then
  LLVM.positionBuilderAtEnd builder thenbb
  let fwd? ← thencodegen builder
  match fwd? with
  | .yes => let _ ← LLVM.buildBr builder mergebb
  | .no => pure ()
  -- else
  LLVM.positionBuilderAtEnd builder elsebb
  let fwd? ← elsecodegen builder
  match fwd? with
  | .yes => let _ ← LLVM.buildBr builder mergebb
  | .no => pure ()
  -- merge
  LLVM.positionBuilderAtEnd builder mergebb

-- Recall that lean uses `i8` for booleans, not `i1`, so we need to compare with `true`.
def buildLeanBoolTrue? (builder : LLVM.Builder llvmctx)
    (b : LLVM.Value llvmctx) (name : String := "") : M llvmctx (LLVM.Value llvmctx) := do
  LLVM.buildICmp builder LLVM.IntPredicate.NE b (← LLVM.constInt8 llvmctx 0) name

def emitFnDeclAux (mod : LLVM.Module llvmctx)
    (decl : Decl) (cppBaseName : String) (isExternal : Bool) : M llvmctx (LLVM.Value llvmctx) := do
  let ps := decl.params
  let env ← getEnv
  -- bollu: if we have a declaration with no parameters, then we emit it as a global pointer.
  -- bollu: Otherwise, we emit it as a function
  if ps.isEmpty then
      let retty ← (toLLVMType decl.resultType)
      let global ← LLVM.getOrAddGlobal mod cppBaseName retty
      if !isExternal then
        LLVM.setInitializer global (← LLVM.getUndef retty)
      return global
  else
      let retty ← (toLLVMType decl.resultType)
      let mut argtys := #[]
      for p in ps do
        -- if it is extern, then we must not add irrelevant args
        if !(isExternC env decl.name) || !p.ty.isIrrelevant then
          argtys := argtys.push (← toLLVMType p.ty)
      -- TODO (bollu): simplify this API, this code of `closureMaxArgs` is duplicated in multiple places.
      if argtys.size > closureMaxArgs && isBoxedName decl.name then
        argtys := #[← LLVM.pointerType (← LLVM.voidPtrType llvmctx)]
      let fnty ← LLVM.functionType retty argtys (isVarArg := false)
      LLVM.getOrAddFunction mod cppBaseName fnty

def emitFnDecl (decl : Decl) (isExternal : Bool) : M llvmctx Unit := do
  let cppBaseName ← toCName decl.name
  let _ ← emitFnDeclAux (← getLLVMModule) decl cppBaseName isExternal

def emitExternDeclAux (decl : Decl) (cNameStr : String) : M llvmctx Unit := do
  let env ← getEnv
  let extC := isExternC env decl.name
  let _ ← emitFnDeclAux (← getLLVMModule) decl cNameStr extC

def emitFnDecls : M llvmctx Unit := do
  let env ← getEnv
  let decls := getDecls env
  let modDecls  : NameSet := decls.foldl (fun s d => s.insert d.name) {}
  let usedDecls : NameSet := decls.foldl (fun s d => collectUsedDecls env d (s.insert d.name)) {}
  let usedDecls := usedDecls.toList
  for n in usedDecls do
    let decl ← getDecl n
    match getExternNameFor env `c decl.name with
    | some cName => emitExternDeclAux decl cName
    | none       => emitFnDecl decl (!modDecls.contains n)
  return ()

def emitLhsSlot_ (x : VarId) : M llvmctx (LLVM.LLVMType llvmctx × LLVM.Value llvmctx) := do
  let state ← get
  match state.var2val.find? x with
  | .some v => return v
  | .none => throw s!"unable to find variable {x}"

def emitLhsVal (builder : LLVM.Builder llvmctx)
    (x : VarId) (name : String := "") : M llvmctx (LLVM.Value llvmctx) := do
  let (xty, xslot) ← emitLhsSlot_ x
  LLVM.buildLoad2 builder xty xslot name

def emitLhsSlotStore (builder : LLVM.Builder llvmctx)
    (x : VarId) (v : LLVM.Value llvmctx) : M llvmctx Unit := do
  let (_, slot) ← emitLhsSlot_ x
  LLVM.buildStore builder v slot

def emitArgSlot_ (builder : LLVM.Builder llvmctx)
    (x : Arg) : M llvmctx (LLVM.LLVMType llvmctx × LLVM.Value llvmctx) := do
  match x with
  | Arg.var x => emitLhsSlot_ x
  | _ => do
    let slotty ← LLVM.voidPtrType llvmctx
    let slot ← LLVM.buildAlloca builder slotty "irrelevant_slot"
    let v ← callLeanBox builder (← LLVM.constIntUnsigned llvmctx 0) "irrelevant_val"
    let _ ← LLVM.buildStore builder v slot
    return (slotty, slot)

def emitArgVal (builder : LLVM.Builder llvmctx)
    (x : Arg) (name : String := "") : M llvmctx (LLVM.LLVMType llvmctx × LLVM.Value llvmctx) := do
  let (xty, xslot) ← emitArgSlot_ builder x
  let xval ← LLVM.buildLoad2 builder xty xslot name
  return (xty, xval)

def emitAllocCtor (builder : LLVM.Builder llvmctx)
    (c : CtorInfo) : M llvmctx (LLVM.Value llvmctx) := do
  -- TODO(bollu) : find the correct size, don't assume 'void*' size is 8
  let hackSizeofVoidPtr := 8
  let scalarSize := hackSizeofVoidPtr * c.usize + c.ssize
  callLeanAllocCtor builder c.cidx c.size scalarSize "lean_alloc_ctor_out"

def emitCtorSetArgs (builder : LLVM.Builder llvmctx)
    (z : VarId) (ys : Array Arg) : M llvmctx Unit := do
  ys.size.forM fun i => do
    let zv ← emitLhsVal builder z
    let (_yty, yv) ← emitArgVal builder ys[i]!
    let iv ← LLVM.constIntUnsigned llvmctx (UInt64.ofNat i)
    callLeanCtorSet builder zv iv yv
    emitLhsSlotStore builder z zv
    pure ()

def emitCtor (builder : LLVM.Builder llvmctx)
    (z : VarId) (c : CtorInfo) (ys : Array Arg) : M llvmctx Unit := do
  let (_llvmty, slot) ← emitLhsSlot_ z
  if c.size == 0 && c.usize == 0 && c.ssize == 0 then do
    let v ← callLeanBox builder (← constIntUnsigned c.cidx) "lean_box_outv"
    let _ ← LLVM.buildStore builder v slot
  else do
    let v ← emitAllocCtor builder c
    let _ ← LLVM.buildStore builder v slot
    emitCtorSetArgs builder z ys

def emitInc (builder : LLVM.Builder llvmctx)
    (x : VarId) (n : Nat) (checkRef? : Bool) : M llvmctx Unit := do
  let xv ← emitLhsVal builder x
  if n != 1
  then do
     let nv ← LLVM.constIntUnsigned llvmctx (UInt64.ofNat n)
     callLeanRefcountFn builder (kind := RefcountKind.inc) (checkRef? := checkRef?) (delta := nv) xv
  else callLeanRefcountFn builder (kind := RefcountKind.inc) (checkRef? := checkRef?) xv

def emitDec (builder : LLVM.Builder llvmctx)
    (x : VarId) (n : Nat) (checkRef? : Bool) : M llvmctx Unit := do
  let xv ← emitLhsVal builder x
  if n != 1
  then throw "expected n = 1 for emitDec"
  else callLeanRefcountFn builder (kind := RefcountKind.dec) (checkRef? := checkRef?) xv

def emitNumLit (builder : LLVM.Builder llvmctx)
    (t : IRType) (v : Nat) : M llvmctx (LLVM.Value llvmctx) := do
  if t.isObj then
    if v < UInt32.size then
      callLeanUnsignedToNatFn builder v
    else
      callLeanCStrToNatFn builder v
  else
    LLVM.constInt (← toLLVMType t) (UInt64.ofNat v)

def toHexDigit (c : Nat) : String :=
  String.singleton c.digitChar

-- TODO(bollu) : Setup code sharing between 'EmitC' and 'EmitLLVM'
def quoteString (s : String) : String :=
  let q := "\"";
  let q := s.foldl
    (fun q c => q ++
      if c == '\n' then "\\n"
      else if c == '\r' then "\\r"
      else if c == '\t' then "\\t"
      else if c == '\\' then "\\\\"
      else if c == '\"' then "\\\""
      else if c.toNat <= 31 then
        "\\x" ++ toHexDigit (c.toNat / 16) ++ toHexDigit (c.toNat % 16)
      -- TODO(Leo) : we should use `\unnnn` for escaping unicode characters.
      else String.singleton c)
    q;
  q ++ "\""

def emitSimpleExternalCall (builder : LLVM.Builder llvmctx)
    (f : String)
    (ps : Array Param)
    (ys : Array Arg)
    (retty : IRType)
    (name : String) : M llvmctx (LLVM.Value llvmctx) := do
  let mut args := #[]
  let mut argTys := #[]
  for (p, y) in ps.zip ys do
    if !p.ty.isIrrelevant then
      let (_yty, yv) ← emitArgVal builder y ""
      argTys := argTys.push (← toLLVMType p.ty)
      args := args.push yv
  let fnty ← LLVM.functionType (← toLLVMType retty) argTys
  let fn ← LLVM.getOrAddFunction (← getLLVMModule) f fnty
  LLVM.buildCall2 builder fnty fn args name

-- TODO: if the external call is one that we cannot code generate, give up and
-- generate fallback code.
def emitExternCall (builder : LLVM.Builder llvmctx)
    (f : FunId)
    (ps : Array Param)
    (extData : ExternAttrData)
    (ys : Array Arg) (retty : IRType)
    (name : String := "") : M llvmctx (LLVM.Value llvmctx) :=
  match getExternEntryFor extData `c with
  | some (ExternEntry.standard _ extFn) => emitSimpleExternalCall builder extFn ps ys retty name
  | some (ExternEntry.inline "llvm" _pat) => throw "Unimplemented codegen of inline LLVM"
  | some (ExternEntry.inline _ pat) => throw s!"Cannot codegen non-LLVM inline code '{pat}'."
  | some (ExternEntry.foreign _ extFn)  => emitSimpleExternalCall builder extFn ps ys retty name
  | _ => throw s!"Failed to emit extern application '{f}'."

def getFunIdTy (f : FunId) : M llvmctx (LLVM.LLVMType llvmctx) := do
  let decl ← getDecl f
  let retty ← toLLVMType decl.resultType
  let argtys ← decl.params.mapM (fun p => do toLLVMType p.ty)
  LLVM.functionType retty argtys

/--
Create a function declaration and return a pointer to the function.
If the function actually takes arguments, then we must have a function pointer in scope.
If the function takes no arguments, then it is a top-level closed term, and its value will
be stored in a global pointer. So, we load from the global pointer. The type of the global is function pointer pointer.
This returns a *function pointer.*
-/
def getOrAddFunIdValue (builder : LLVM.Builder llvmctx) (f : FunId) : M llvmctx (LLVM.Value llvmctx) := do
  let decl ← getDecl f
  let fcname ← toCName f
  let retty ← toLLVMType decl.resultType
  if decl.params.isEmpty then
     let gslot ← LLVM.getOrAddGlobal (← getLLVMModule) fcname retty
     LLVM.buildLoad2 builder retty gslot
  else
    let argtys ← decl.params.mapM (fun p => do toLLVMType p.ty)
    let fnty ← LLVM.functionType retty argtys
    LLVM.getOrAddFunction (← getLLVMModule) fcname fnty

def emitPartialApp (builder : LLVM.Builder llvmctx) (z : VarId) (f : FunId) (ys : Array Arg) : M llvmctx Unit := do
  let decl ← getDecl f
  let fv ← getOrAddFunIdValue builder f
  let arity := decl.params.size
  let (_zty, zslot) ← emitLhsSlot_ z
  let zval ← callLeanAllocClosureFn builder fv
                                    (← constIntUnsigned arity)
                                    (← constIntUnsigned ys.size)
  LLVM.buildStore builder zval zslot
  ys.size.forM fun i => do
    let (yty, yslot) ← emitArgSlot_ builder ys[i]!
    let yval ← LLVM.buildLoad2 builder yty yslot
    callLeanClosureSetFn builder zval (← constIntUnsigned i) yval

def emitApp (builder : LLVM.Builder llvmctx) (z : VarId) (f : VarId) (ys : Array Arg) : M llvmctx Unit := do
  if ys.size > closureMaxArgs then do
    let aargs ← LLVM.buildAlloca builder (← LLVM.arrayType (← LLVM.voidPtrType llvmctx) (UInt64.ofNat ys.size)) "aargs"
    for i in List.range ys.size do
      let (yty, yv) ← emitArgVal builder ys[i]!
      let aslot ← LLVM.buildInBoundsGEP2 builder yty aargs #[← constIntUnsigned 0, ← constIntUnsigned i] s!"param_{i}_slot"
      LLVM.buildStore builder yv aslot
    let fnName :=  s!"lean_apply_m"
    let retty ← LLVM.voidPtrType llvmctx
    let args := #[← emitLhsVal builder f, ← constIntUnsigned ys.size, aargs]
    -- '1 + ...'. '1' for the fn and 'args' for the arguments
    let argtys := #[← LLVM.voidPtrType llvmctx]
    let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
    let fnty ← LLVM.functionType retty argtys
    let zv ← LLVM.buildCall2 builder fnty fn args
    emitLhsSlotStore builder z zv
  else do

    let fnName :=  s!"lean_apply_{ys.size}"
    let retty ← LLVM.voidPtrType llvmctx
    let args : Array (LLVM.Value llvmctx) := #[← emitLhsVal builder f] ++ (← ys.mapM (fun y => Prod.snd <$> (emitArgVal builder y)))
    -- '1 + ...'. '1' for the fn and 'args' for the arguments
    let argtys := (List.replicate (1 + ys.size) (← LLVM.voidPtrType llvmctx)).toArray
    let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
    let fnty ← LLVM.functionType retty argtys
    let zv ← LLVM.buildCall2 builder fnty fn args
    emitLhsSlotStore builder z zv

def emitFullApp (builder : LLVM.Builder llvmctx)
    (z : VarId) (f : FunId) (ys : Array Arg) : M llvmctx Unit := do
  let (__zty, zslot) ← emitLhsSlot_ z
  let decl ← getDecl f
  match decl with
  | Decl.extern _ ps retty extData =>
     let zv ← emitExternCall builder f ps extData ys retty
     LLVM.buildStore builder zv zslot
  | Decl.fdecl .. =>
    if ys.size > 0 then
        let fv ← getOrAddFunIdValue builder f
        let ys ←  ys.mapM (fun y => do
            let (yty, yslot) ← emitArgSlot_ builder y
            let yv ← LLVM.buildLoad2 builder yty yslot
            return yv)
        let zv ← LLVM.buildCall2 builder (← getFunIdTy f) fv ys
        LLVM.buildStore builder zv zslot
    else
       let zv ← getOrAddFunIdValue builder f
       LLVM.buildStore builder zv zslot

-- Note that this returns a *slot*, just like `emitLhsSlot_`.
def emitLit (builder : LLVM.Builder llvmctx)
    (z : VarId) (t : IRType) (v : LitVal) : M llvmctx (LLVM.Value llvmctx) := do
  let llvmty ← toLLVMType t
  let zslot ← LLVM.buildAlloca builder llvmty
  addVartoState z zslot llvmty
  let zv ← match v with
            | LitVal.num v => emitNumLit builder t v
            | LitVal.str v =>
                 let zero ← LLVM.constIntUnsigned llvmctx 0
                 let str_global ← LLVM.buildGlobalString builder v
                 -- access through the global, into the 0th index of the array
                 let strPtr ← LLVM.buildInBoundsGEP2 builder
                                (← LLVM.opaquePointerTypeInContext llvmctx)
                                str_global #[zero] ""
                 let nbytes ← LLVM.constIntUnsigned llvmctx (UInt64.ofNat (v.utf8ByteSize))
                 callLeanMkStringFromBytesFn builder strPtr nbytes ""
  LLVM.buildStore builder zv zslot
  return zslot

def callLeanCtorGet (builder : LLVM.Builder llvmctx)
    (x i : LLVM.Value llvmctx) (retName : String) : M llvmctx (LLVM.Value llvmctx) := do
  let fnName :=  "lean_ctor_get"
  let retty ← LLVM.voidPtrType llvmctx
  let argtys := #[ ← LLVM.voidPtrType llvmctx, ← LLVM.i32Type llvmctx]
  let fnty ← LLVM.functionType retty argtys
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
  let i ← LLVM.buildSextOrTrunc builder i (← LLVM.i32Type llvmctx)
  LLVM.buildCall2 builder fnty fn  #[x, i] retName

def emitProj (builder : LLVM.Builder llvmctx) (z : VarId) (i : Nat) (x : VarId) : M llvmctx Unit := do
  let xval ← emitLhsVal builder x
  let zval ← callLeanCtorGet builder xval (← constIntUnsigned i) ""
  emitLhsSlotStore builder z zval

def callLeanCtorGetUsize (builder : LLVM.Builder llvmctx)
    (x i : LLVM.Value llvmctx) (retName : String) : M llvmctx (LLVM.Value llvmctx) := do
  let fnName :=  "lean_ctor_get_usize"
  let retty ← LLVM.size_tType llvmctx
  let argtys := #[ ← LLVM.voidPtrType llvmctx, ← LLVM.size_tType llvmctx]
  let fnty ← LLVM.functionType retty argtys
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
  LLVM.buildCall2 builder fnty fn  #[x, i] retName

def emitUProj (builder : LLVM.Builder llvmctx) (z : VarId) (i : Nat) (x : VarId) : M llvmctx Unit := do
  let xval ← emitLhsVal builder x
  let zval ← callLeanCtorGetUsize builder xval (← constIntUnsigned i) ""
  emitLhsSlotStore builder z zval

def emitOffset (builder : LLVM.Builder llvmctx)
    (n : Nat) (offset : Nat) : M llvmctx (LLVM.Value llvmctx) := do
   -- TODO(bollu) : replace 8 with sizeof(void*)
   let out ← constIntUnsigned 8
   let out ← LLVM.buildMul builder out (← constIntUnsigned n) "" -- sizeof(void*)*n
   LLVM.buildAdd builder out (← constIntUnsigned offset) "" -- sizeof(void*)*n+offset

def emitSProj (builder : LLVM.Builder llvmctx)
    (z : VarId) (t : IRType) (n offset : Nat) (x : VarId) : M llvmctx Unit := do
  let (fnName, retty) ←
    match t with
    | IRType.float  => pure ("lean_ctor_get_float", ← LLVM.doubleTypeInContext llvmctx)
    | IRType.uint8  => pure ("lean_ctor_get_uint8", ← LLVM.i8Type llvmctx)
    | IRType.uint16 => pure ("lean_ctor_get_uint16", ←  LLVM.i16Type llvmctx)
    | IRType.uint32 => pure ("lean_ctor_get_uint32", ← LLVM.i32Type llvmctx)
    | IRType.uint64 => pure ("lean_ctor_get_uint64", ← LLVM.i64Type llvmctx)
    | _             => throw s!"Invalid type for lean_ctor_get: '{t}'"
  let argtys := #[ ← LLVM.voidPtrType llvmctx, ← LLVM.size_tType llvmctx]
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
  let xval ← emitLhsVal builder x
  let offset ← emitOffset builder n offset
  let fnty ← LLVM.functionType retty argtys
  let zval ← LLVM.buildCall2 builder fnty fn  #[xval, offset]
  emitLhsSlotStore builder z zval

def callLeanIsExclusive (builder : LLVM.Builder llvmctx)
    (closure : LLVM.Value llvmctx) (retName : String := "") : M llvmctx (LLVM.Value llvmctx) := do
  let fnName :=  "lean_is_exclusive"
  let retty ← LLVM.i1Type llvmctx
  let argtys := #[ ← LLVM.voidPtrType llvmctx]
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
  let fnty ← LLVM.functionType retty argtys
  let out ← LLVM.buildCall2 builder fnty fn  #[closure] retName
  LLVM.buildSextOrTrunc builder out (← LLVM.i8Type llvmctx)

def callLeanIsScalar (builder : LLVM.Builder llvmctx)
    (closure : LLVM.Value llvmctx) (retName : String := "") : M llvmctx (LLVM.Value llvmctx) := do
  let fnName :=  "lean_is_scalar"
  let retty ← LLVM.i8Type llvmctx
  let argtys := #[ ← LLVM.voidPtrType llvmctx]
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
  let fnty ← LLVM.functionType retty argtys
  LLVM.buildCall2 builder fnty fn  #[closure] retName

def emitIsShared (builder : LLVM.Builder llvmctx) (z : VarId) (x : VarId) : M llvmctx Unit := do
    let xv ← emitLhsVal builder x
    let exclusive? ← callLeanIsExclusive builder xv
    let exclusive? ← LLVM.buildSextOrTrunc builder exclusive? (← LLVM.i1Type llvmctx)
    let shared? ← LLVM.buildNot builder exclusive?
    let shared? ← LLVM.buildSext builder shared? (← LLVM.i8Type llvmctx)
    emitLhsSlotStore builder z shared?

def emitBox (builder : LLVM.Builder llvmctx) (z : VarId) (x : VarId) (xType : IRType) : M llvmctx Unit := do
  let xv ← emitLhsVal builder x
  let (fnName, argTy, xv) ←
    match xType with
    | IRType.usize  => pure ("lean_box_usize", ← LLVM.size_tType llvmctx, xv)
    | IRType.uint32 => pure ("lean_box_uint32", ← LLVM.i32Type llvmctx, xv)
    | IRType.uint64 => pure ("lean_box_uint64", ← LLVM.size_tType llvmctx, xv)
    | IRType.float  => pure ("lean_box_float", ← LLVM.doubleTypeInContext llvmctx, xv)
    | _             => do
         -- sign extend smaller values into i64
         let xv ← LLVM.buildSext builder xv (← LLVM.size_tType llvmctx)
         pure ("lean_box", ← LLVM.size_tType llvmctx, xv)
  let retty ← LLVM.voidPtrType llvmctx
  let argtys := #[argTy]
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
  let fnty ← LLVM.functionType retty argtys
  let zv ← LLVM.buildCall2 builder fnty fn  #[xv]
  emitLhsSlotStore builder z zv

def IRType.isIntegerType (t : IRType) : Bool :=
  match t with
  | .uint8 => true
  | .uint16 => true
  | .uint32 => true
  | .uint64 => true
  | .usize => true
  | _ => false

def callUnboxForType (builder : LLVM.Builder llvmctx)
    (t : IRType)
    (v : LLVM.Value llvmctx)
    (retName : String := "") : M llvmctx (LLVM.Value llvmctx) := do
  let (fnName, retty) ←
     match t with
     | IRType.usize  => pure ("lean_unbox_usize", ← toLLVMType t)
     | IRType.uint32 => pure ("lean_unbox_uint32", ← toLLVMType t)
     | IRType.uint64 => pure ("lean_unbox_uint64", ← toLLVMType t)
     | IRType.float  => pure ("lean_unbox_float", ← toLLVMType t)
     | _             => pure ("lean_unbox", ← LLVM.size_tType llvmctx)
  let argtys := #[← LLVM.voidPtrType llvmctx ]
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
  let fnty ← LLVM.functionType retty argtys
  LLVM.buildCall2 builder fnty fn #[v] retName

def emitUnbox (builder : LLVM.Builder llvmctx)
    (z : VarId) (t : IRType) (x : VarId) (retName : String := "") : M llvmctx Unit := do
  let zval ← callUnboxForType builder t (← emitLhsVal builder x) retName
  -- NOTE(bollu) : note that lean_unbox only returns an i64, but we may need to truncate to
  -- smaller widths. see `phashmap` for an example of this occurring at calls to `lean_unbox`
  let zval ←
    if IRType.isIntegerType t
    then LLVM.buildSextOrTrunc builder zval (← toLLVMType t)
    else pure zval
  emitLhsSlotStore builder z zval

def emitReset (builder : LLVM.Builder llvmctx) (z : VarId) (n : Nat) (x : VarId) : M llvmctx Unit := do
  let xv ← emitLhsVal builder x
  let isExclusive ← callLeanIsExclusive builder xv
  let isExclusive ← buildLeanBoolTrue? builder isExclusive
  buildIfThenElse_ builder "isExclusive" isExclusive
   (fun builder => do
     let xv ← emitLhsVal builder x
     n.forM fun i => do
         callLeanCtorRelease builder xv (← constIntUnsigned i)
     emitLhsSlotStore builder z xv
     return ShouldForwardControlFlow.yes
   )
   (fun builder => do
      let xv ← emitLhsVal builder x
      callLeanDecRef builder xv
      let box0 ← callLeanBox builder (← constIntUnsigned 0) "box0"
      emitLhsSlotStore builder z box0
      return ShouldForwardControlFlow.yes
   )

def emitReuse (builder : LLVM.Builder llvmctx)
    (z : VarId) (x : VarId) (c : CtorInfo) (updtHeader : Bool) (ys : Array Arg) : M llvmctx Unit := do
  let xv ← emitLhsVal builder x
  let isScalar ← callLeanIsScalar builder xv
  let isScalar ← buildLeanBoolTrue? builder isScalar
  buildIfThenElse_ builder  "isScalar" isScalar
    (fun builder => do
      let cv ← emitAllocCtor builder c
      emitLhsSlotStore builder z cv
      return ShouldForwardControlFlow.yes
   )
   (fun builder => do
       let xv ← emitLhsVal builder x
       emitLhsSlotStore builder z xv
       if updtHeader then
          let zv ← emitLhsVal builder z
          callLeanCtorSetTag builder zv (← constIntUnsigned c.cidx)
       return ShouldForwardControlFlow.yes
   )
  emitCtorSetArgs builder z ys

def emitVDecl (builder : LLVM.Builder llvmctx) (z : VarId) (t : IRType) (v : Expr) : M llvmctx Unit := do
  match v with
  | Expr.ctor c ys      => emitCtor builder z c ys
  | Expr.reset n x      => emitReset builder z n x
  | Expr.reuse x c u ys => emitReuse builder z x c u ys
  | Expr.proj i x       => emitProj builder z i x
  | Expr.uproj i x      => emitUProj builder z i x
  | Expr.sproj n o x    => emitSProj builder z t n o x
  | Expr.fap c ys       => emitFullApp builder z c ys
  | Expr.pap c ys       => emitPartialApp builder z c ys
  | Expr.ap x ys        => emitApp builder z x ys
  | Expr.box t x        => emitBox builder z x t
  | Expr.unbox x        => emitUnbox builder z t x
  | Expr.isShared x     => emitIsShared builder z x
  | Expr.lit v          => let _ ← emitLit builder z t v

def declareVar (builder : LLVM.Builder llvmctx) (x : VarId) (t : IRType) : M llvmctx Unit := do
  let llvmty ← toLLVMType t
  let alloca ← LLVM.buildAlloca builder llvmty "varx"
  addVartoState x alloca llvmty

partial def declareVars (builder : LLVM.Builder llvmctx) (f : FnBody) : M llvmctx Unit := do
  match f with
  | FnBody.vdecl x t _ b => do
      declareVar builder x t
      declareVars builder b
  | FnBody.jdecl _ xs _ b => do
      for param in xs do declareVar builder param.x param.ty
      declareVars builder b
  | e => do
      if e.isTerminal then pure () else declareVars builder e.body

def emitTag (builder : LLVM.Builder llvmctx) (x : VarId) (xType : IRType) : M llvmctx (LLVM.Value llvmctx) := do
  if xType.isObj then do
    let xval ← emitLhsVal builder x
    callLeanObjTag builder xval
  else if xType.isScalar then do
    emitLhsVal builder x
  else
    throw "Do not know how to `emitTag` in general."

def emitSet (builder : LLVM.Builder llvmctx) (x : VarId) (i : Nat) (y : Arg) : M llvmctx Unit := do
  let fnName :=  "lean_ctor_set"
  let retty ← LLVM.voidType llvmctx
  let argtys := #[ ← LLVM.voidPtrType llvmctx, ← LLVM.size_tType llvmctx, ← LLVM.voidPtrType llvmctx]
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
  let fnty ← LLVM.functionType retty argtys
  let _ ← LLVM.buildCall2 builder fnty fn  #[← emitLhsVal builder x, ← constIntUnsigned i, (← emitArgVal builder y).2]

def emitUSet (builder : LLVM.Builder llvmctx) (x : VarId) (i : Nat) (y : VarId) : M llvmctx Unit := do
  let fnName :=  "lean_ctor_set_usize"
  let retty ← LLVM.voidType llvmctx
  let argtys := #[ ← LLVM.voidPtrType llvmctx, ← LLVM.size_tType llvmctx, ← LLVM.size_tType llvmctx]
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
  let fnty ← LLVM.functionType retty argtys
  let _ ← LLVM.buildCall2 builder fnty fn  #[← emitLhsVal builder x, ← constIntUnsigned i, (← emitLhsVal builder y)]

def emitTailCall (builder : LLVM.Builder llvmctx) (f : FunId) (v : Expr) : M llvmctx Unit := do
   match v with
  | Expr.fap _ ys => do
    let llvmctx ← read
    let ps := llvmctx.mainParams
    unless ps.size == ys.size do throw s!"Invalid tail call. f:'{f}' v:'{v}'"
    let args ← ys.mapM (fun y => Prod.snd <$> emitArgVal builder y)
    let fn ← builderGetInsertionFn builder
    let call ← LLVM.buildCall2 builder (← getFunIdTy f) fn args
    -- TODO (bollu) : add 'musttail' attribute using the C API.
    LLVM.setTailCall call true -- mark as tail call
    let _ ← LLVM.buildRet builder call
  | _ => throw s!"EmitTailCall expects function application, found '{v}'"

def emitJmp (builder : LLVM.Builder llvmctx) (jp : JoinPointId) (xs : Array Arg) : M llvmctx Unit := do
 let llvmctx ← read
  let ps ← match llvmctx.jpMap.find? jp with
  | some ps => pure ps
  | none    => throw s!"Unknown join point {jp}"
  unless xs.size == ps.size do throw s!"Invalid goto, mismatched sizes between arguments, formal parameters."
  for (p, x)  in ps.zip xs do
    let (_xty, xv) ← emitArgVal builder x
    emitLhsSlotStore builder p.x xv
  let _ ← LLVM.buildBr builder (← emitJp jp)

def emitSSet (builder : LLVM.Builder llvmctx) (x : VarId) (n : Nat) (offset : Nat) (y : VarId) (t : IRType) : M llvmctx Unit := do
  let (fnName, setty) ←
  match t with
  | IRType.float  => pure ("lean_ctor_set_float", ← LLVM.doubleTypeInContext llvmctx)
  | IRType.uint8  => pure ("lean_ctor_set_uint8", ← LLVM.i8Type llvmctx)
  | IRType.uint16 => pure ("lean_ctor_set_uint16", ← LLVM.i16Type llvmctx)
  | IRType.uint32 => pure ("lean_ctor_set_uint32", ← LLVM.i32Type llvmctx)
  | IRType.uint64 => pure ("lean_ctor_set_uint64", ← LLVM.i64Type llvmctx)
  | _             => throw s!"invalid type for 'lean_ctor_set': '{t}'"
  let argtys := #[ ← LLVM.voidPtrType llvmctx, ← LLVM.size_tType llvmctx, setty]
  let retty  ← LLVM.voidType llvmctx
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
  let xv ← emitLhsVal builder x
  let offset ← emitOffset builder n offset
  let yv ← emitLhsVal builder y
  let fnty ← LLVM.functionType retty argtys
  let _ ← LLVM.buildCall2 builder fnty fn  #[xv, offset, yv]

def emitDel (builder : LLVM.Builder llvmctx) (x : VarId) : M llvmctx Unit := do
  let argtys := #[ ← LLVM.voidPtrType llvmctx]
  let retty  ← LLVM.voidType llvmctx
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty "lean_free_object" argtys
  let xv ← emitLhsVal builder x
  let fnty ← LLVM.functionType retty argtys
  let _ ← LLVM.buildCall2 builder fnty fn  #[xv]

def emitSetTag (builder : LLVM.Builder llvmctx) (x : VarId) (i : Nat) : M llvmctx Unit := do
  let argtys := #[← LLVM.voidPtrType llvmctx, ← LLVM.size_tType llvmctx]
  let retty  ← LLVM.voidType llvmctx
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty "lean_ctor_set_tag" argtys
  let xv ← emitLhsVal builder x
  let fnty ← LLVM.functionType retty argtys
  let _ ← LLVM.buildCall2 builder fnty fn  #[xv, ← constIntUnsigned i]

def ensureHasDefault' (alts : Array Alt) : Array Alt :=
  if alts.any Alt.isDefault then alts
  else
    let last := alts.back
    let alts := alts.pop
    alts.push (Alt.default last.body)

mutual
partial def emitCase (builder : LLVM.Builder llvmctx)
    (x : VarId) (xType : IRType) (alts : Array Alt) : M llvmctx Unit := do
  let oldBB ← LLVM.getInsertBlock builder
  -- NOTE: In this context, 'Zext' versus 'Sext' have a meaninful semantic difference.
  --       We perform a zero extend so that one-bit tags of `0/-1` actually extend to `0/1`
  --       in 64-bit space.
  let tag ← emitTag builder x xType
  let tag ← LLVM.buildZext builder tag (← LLVM.i64Type llvmctx)
  let alts := ensureHasDefault' alts
  let defaultBB ← builderAppendBasicBlock builder s!"case_{xType}_default"
  let numCasesHint := alts.size
  let switch ← LLVM.buildSwitch builder tag defaultBB (UInt64.ofNat numCasesHint)
  alts.forM fun alt => do
    match alt with
    | Alt.ctor c b  =>
       let destbb ← builderAppendBasicBlock builder s!"case_{xType}_{c.name}_{c.cidx}"
       LLVM.addCase switch (← constIntUnsigned c.cidx) destbb
       LLVM.positionBuilderAtEnd builder destbb
       emitFnBody builder b
    | Alt.default b =>
       LLVM.positionBuilderAtEnd builder defaultBB
       emitFnBody builder b
  LLVM.clearInsertionPosition builder
  LLVM.positionBuilderAtEnd builder oldBB -- reset state to previous insertion point.

-- NOTE:  emitJP promises to keep the builder context untouched.
partial def emitJDecl (builder : LLVM.Builder llvmctx)
    (jp : JoinPointId) (_ps : Array Param) (b : FnBody) : M llvmctx Unit := do
  let oldBB ← LLVM.getInsertBlock builder
  let jpbb ← builderAppendBasicBlock builder s!"jp_{jp.idx}"
  addJpTostate jp jpbb
  LLVM.positionBuilderAtEnd builder jpbb
  -- NOTE(bollu) : Note that we declare the slots for the variables that are inside
  --              the join point body before emitting the join point body.
  --              This ensures reachability via dominance.
  -- TODO(bollu) : Eliminate the need entirely for 'alloca'/slots by generating SSA phi nodes
  --              directly as discussed with digamma(Mario Carneiro <di.gama@gmail.com>)
  declareVars builder b
  emitBlock builder b
  LLVM.positionBuilderAtEnd builder oldBB -- reset state

partial def emitUnreachable (builder : LLVM.Builder llvmctx) : M llvmctx Unit := do
  let retty ← LLVM.voidType llvmctx
  let argtys := #[]
  let fn ← getOrCreateFunctionPrototype  (← getLLVMModule) retty "lean_internal_panic_unreachable" argtys
  let fnty ← LLVM.functionType retty argtys
  let _ ← LLVM.buildCall2 builder fnty fn #[]
  let _ ← LLVM.buildUnreachable builder

partial def emitBlock (builder : LLVM.Builder llvmctx) (b : FnBody) : M llvmctx Unit := do
  match b with
  | FnBody.jdecl j xs  v b      =>
       emitJDecl builder j xs v
       emitBlock builder b
  | d@(FnBody.vdecl x t v b)   => do
    let llvmctx ← read
    if isTailCallTo llvmctx.mainFn d then
      emitTailCall builder llvmctx.mainFn v
    else
      emitVDecl builder x t v
      emitBlock builder b
  | FnBody.inc x n c p b       =>
    unless p do emitInc builder x n c
    emitBlock builder b
  | FnBody.dec x n c p b       =>
    unless p do emitDec builder x n c
    emitBlock builder b
  | FnBody.del x b             =>  emitDel builder x; emitBlock builder b
  | FnBody.setTag x i b        =>  emitSetTag builder x i; emitBlock builder b
  | FnBody.set x i y b         => emitSet builder x i y; emitBlock builder b
  | FnBody.uset x i y b        => emitUSet builder x i y; emitBlock builder b
  | FnBody.sset x i o y t b    => emitSSet builder x i o y t; emitBlock builder b
  | FnBody.mdata _ b           => emitBlock builder b
  | FnBody.ret x               => do
      let (_xty, xv) ← emitArgVal builder x "ret_val"
      let _ ← LLVM.buildRet builder xv
  | FnBody.case _ x xType alts =>
     emitCase builder x xType alts
  | FnBody.jmp j xs            =>
     emitJmp builder j xs
  | FnBody.unreachable         => emitUnreachable builder

partial def emitFnBody  (builder : LLVM.Builder llvmctx)  (b : FnBody) : M llvmctx Unit := do
  declareVars builder b
  emitBlock builder b

end

def emitFnArgs (builder : LLVM.Builder llvmctx)
    (needsPackedArgs? : Bool)  (llvmfn : LLVM.Value llvmctx) (params : Array Param) : M llvmctx Unit := do
  if needsPackedArgs? then do
      let argsp ← LLVM.getParam llvmfn 0 -- lean_object **args
      for i in List.range params.size do
          let param := params[i]!
          -- argsi := (args + i)
          let argsi ← LLVM.buildGEP2 builder (← LLVM.voidPtrType llvmctx) argsp #[← constIntUnsigned i] s!"packed_arg_{i}_slot"
          let llvmty ← toLLVMType param.ty
          -- pv := *(argsi) = *(args + i)
          let pv ← LLVM.buildLoad2 builder llvmty argsi
          -- slot for arg[i] which is always void* ?
          let alloca ← LLVM.buildAlloca builder llvmty s!"arg_{i}"
          LLVM.buildStore builder pv alloca
          addVartoState params[i]!.x alloca llvmty
  else
      let n := LLVM.countParams llvmfn
      for i in (List.range n.toNat) do
        let llvmty ← toLLVMType params[i]!.ty
        let alloca ← LLVM.buildAlloca builder  llvmty s!"arg_{i}"
        let arg ← LLVM.getParam llvmfn (UInt64.ofNat i)
        let _ ← LLVM.buildStore builder arg alloca
        addVartoState params[i]!.x alloca llvmty

def emitDeclAux (mod : LLVM.Module llvmctx) (builder : LLVM.Builder llvmctx) (d : Decl) : M llvmctx Unit := do
  let env ← getEnv
  let (_, jpMap) := mkVarJPMaps d
  withReader (fun llvmctx => { llvmctx with jpMap := jpMap }) do
  unless hasInitAttr env d.name do
    match d with
    | .fdecl (f := f) (xs := xs) (type := t) (body := b) .. =>
      let baseName ← toCName f
      let name := if xs.size > 0 then baseName else "_init_" ++ baseName
      let retty ← toLLVMType t
      let mut argtys := #[]
      let needsPackedArgs? := xs.size > closureMaxArgs && isBoxedName d.name
      if needsPackedArgs? then
          argtys := #[← LLVM.pointerType (← LLVM.voidPtrType llvmctx)]
      else
        for x in xs do
          argtys := argtys.push (← toLLVMType x.ty)
      let fnty ← LLVM.functionType retty argtys (isVarArg := false)
      let llvmfn ← LLVM.getOrAddFunction mod name fnty
      withReader (fun llvmctx => { llvmctx with mainFn := f, mainParams := xs }) do
        set { var2val := default, jp2bb := default : EmitLLVM.State llvmctx } -- flush variable map
        let bb ← LLVM.appendBasicBlockInContext llvmctx llvmfn "entry"
        LLVM.positionBuilderAtEnd builder bb
        emitFnArgs builder needsPackedArgs? llvmfn xs
        emitFnBody builder b
      pure ()
    | _ => pure ()

def emitDecl (mod : LLVM.Module llvmctx) (builder : LLVM.Builder llvmctx) (d : Decl) : M llvmctx Unit := do
  let d := d.normalizeIds -- ensure we don't have gaps in the variable indices
  try
    emitDeclAux mod builder d
    return ()
  catch err =>
    throw (s!"emitDecl:\ncompiling:\n{d}\nerr:\n{err}\n")

def emitFns (mod : LLVM.Module llvmctx) (builder : LLVM.Builder llvmctx) : M llvmctx Unit := do
  let env ← getEnv
  let decls := getDecls env
  decls.reverse.forM (emitDecl mod builder)

def callIODeclInitFn (builder : LLVM.Builder llvmctx)
    (initFnName : String)
    (world : LLVM.Value llvmctx): M llvmctx (LLVM.Value llvmctx) := do
  let retty ← LLVM.voidPtrType llvmctx
  let argtys := #[← LLVM.voidPtrType llvmctx]
  let fn ← getOrCreateFunctionPrototype  (← getLLVMModule) retty initFnName argtys
  let fnty ← LLVM.functionType retty argtys
  LLVM.buildCall2 builder fnty fn #[world]

def callPureDeclInitFn (builder : LLVM.Builder llvmctx)
    (initFnName : String)
    (retty : LLVM.LLVMType llvmctx): M llvmctx (LLVM.Value llvmctx) := do
  let argtys := #[]
  let fn ← getOrCreateFunctionPrototype  (← getLLVMModule) retty initFnName argtys
  let fnty ← LLVM.functionType retty argtys
  LLVM.buildCall2 builder fnty fn #[]

def emitDeclInit (builder : LLVM.Builder llvmctx)
    (parentFn : LLVM.Value llvmctx) (d : Decl) : M llvmctx Unit := do
  let env ← getEnv
  if isIOUnitInitFn env d.name then do
    let world ← callLeanIOMkWorld builder
    let resv ← callIODeclInitFn builder (← toCName d.name) world
    let err? ← callLeanIOResultIsError builder resv "is_error"
    buildIfThen_ builder s!"init_{d.name}_isError" err?
      (fun builder => do
        let _ ← LLVM.buildRet builder resv
        pure ShouldForwardControlFlow.no)
    -- TODO (bollu) : emit lean_dec_ref. For now, it does not matter.
  else if d.params.size == 0 then
    match getInitFnNameFor? env d.name with
    | some initFn =>
      let llvmty ← toLLVMType d.resultType
      let dslot ←  LLVM.getOrAddGlobal (← getLLVMModule) (← toCName d.name) llvmty
      LLVM.setInitializer dslot (← LLVM.getUndef llvmty)
      let initBB ← builderAppendBasicBlock builder s!"do_{d.name}_init"
      let restBB ← builderAppendBasicBlock builder s!"post_{d.name}_init"
      let checkBuiltin? := getBuiltinInitFnNameFor? env d.name |>.isSome
      if checkBuiltin? then
        -- `builtin` is set to true if the initializer is part of the executable,
        -- and not loaded dynamically.
        let builtinParam ← LLVM.getParam parentFn 0
        let cond ← buildLeanBoolTrue? builder builtinParam "is_builtin_true"
        let _ ← LLVM.buildCondBr builder cond initBB restBB
       else
        let _ ← LLVM.buildBr builder initBB
      LLVM.positionBuilderAtEnd builder initBB
      let world ← callLeanIOMkWorld builder
      let resv ← callIODeclInitFn builder (← toCName initFn) world
      let err? ← callLeanIOResultIsError builder resv s!"{d.name}_is_error"
      buildIfThen_ builder s!"init_{d.name}_isError" err?
        (fun builder => do
          let _ ← LLVM.buildRet builder resv
          pure ShouldForwardControlFlow.no)
      if d.resultType.isScalar then
        let dval ← callLeanIOResultGetValue builder resv s!"{d.name}_res"
        let dval ← callUnboxForType builder d.resultType dval
        LLVM.buildStore builder dval dslot
      else
         let dval ← callLeanIOResultGetValue builder resv s!"{d.name}_res"
         LLVM.buildStore builder dval dslot
         callLeanMarkPersistentFn builder dval
      let _ ← LLVM.buildBr builder restBB
      LLVM.positionBuilderAtEnd builder restBB
    | none => do
      let llvmty ← toLLVMType d.resultType
      let dslot ←  LLVM.getOrAddGlobal (← getLLVMModule) (← toCName d.name) llvmty
      LLVM.setInitializer dslot (← LLVM.getUndef llvmty)
      let dval ← callPureDeclInitFn builder (← toCInitName d.name) (← toLLVMType d.resultType)
      LLVM.buildStore builder dval dslot
      if d.resultType.isObj then
         callLeanMarkPersistentFn builder dval

def callModInitFn (builder : LLVM.Builder llvmctx)
    (modName : Name) (input world : LLVM.Value llvmctx) (retName : String): M llvmctx (LLVM.Value llvmctx) := do
  let fnName := mkModuleInitializationFunctionName modName
  let retty ← LLVM.voidPtrType llvmctx
  let argtys := #[ (← LLVM.i8Type llvmctx), (← LLVM.voidPtrType llvmctx)]
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
  let fnty ← LLVM.functionType retty argtys
  LLVM.buildCall2 builder fnty fn #[input, world] retName

def emitInitFn (mod : LLVM.Module llvmctx) (builder : LLVM.Builder llvmctx) : M llvmctx Unit := do
  let env ← getEnv
  let modName ← getModName

  let initFnTy ← LLVM.functionType (← LLVM.voidPtrType llvmctx) #[ (← LLVM.i8Type llvmctx), (← LLVM.voidPtrType llvmctx)] (isVarArg := false)
  let initFn ← LLVM.getOrAddFunction mod (mkModuleInitializationFunctionName modName) initFnTy
  let entryBB ← LLVM.appendBasicBlockInContext llvmctx initFn "entry"
  LLVM.positionBuilderAtEnd builder entryBB
  let ginit?ty := ← LLVM.i1Type llvmctx
  let ginit?slot ← LLVM.getOrAddGlobal mod (modName.mangle ++ "_G_initialized") ginit?ty
  LLVM.setInitializer ginit?slot (← LLVM.constFalse llvmctx)
  let ginit?v ← LLVM.buildLoad2 builder ginit?ty ginit?slot "init_v"
  buildIfThen_ builder "isGInitialized" ginit?v
    (fun builder => do
      let box0 ← callLeanBox builder (← LLVM.constIntUnsigned llvmctx 0) "box0"
      let out ← callLeanIOResultMKOk builder box0 "retval"
      let _ ← LLVM.buildRet builder out
      pure ShouldForwardControlFlow.no)
  LLVM.buildStore builder (← LLVM.constTrue llvmctx) ginit?slot

  env.imports.forM fun import_ => do
    let builtin ← LLVM.getParam initFn 0
    let world ← callLeanIOMkWorld builder
    let res ← callModInitFn builder import_.module builtin world ("res_" ++ import_.module.mangle)
    let err? ← callLeanIOResultIsError builder res ("res_is_error_"  ++ import_.module.mangle)
    buildIfThen_ builder ("IsError" ++ import_.module.mangle) err?
      (fun builder => do
        let _ ← LLVM.buildRet builder res
        pure ShouldForwardControlFlow.no)
    callLeanDecRef builder res
  let decls := getDecls env
  decls.reverse.forM (emitDeclInit builder initFn)
  let box0 ← callLeanBox builder (← LLVM.constIntUnsigned llvmctx 0) "box0"
  let out ← callLeanIOResultMKOk builder box0 "retval"
  let _ ← LLVM.buildRet builder out

def callLeanInitialize (builder : LLVM.Builder llvmctx) : M llvmctx Unit := do
  let fnName :=  "lean_initialize"
  let retty ← LLVM.voidType llvmctx
  let argtys := #[]
  let fnty ← LLVM.functionType retty argtys
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
  let _ ← LLVM.buildCall2 builder fnty fn #[]

def callLeanInitializeRuntimeModule (builder : LLVM.Builder llvmctx) : M llvmctx Unit := do
  let fnName :=  "lean_initialize_runtime_module"
  let retty ← LLVM.voidType llvmctx
  let argtys := #[]
  let fnty ← LLVM.functionType retty argtys
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
  let _ ← LLVM.buildCall2 builder fnty fn #[]

def callLeanSetPanicMessages (builder : LLVM.Builder llvmctx)
    (enable? : LLVM.Value llvmctx) : M llvmctx Unit := do
  let fnName :=  "lean_set_panic_messages"
  let retty ← LLVM.voidType llvmctx
  let argtys := #[ ← LLVM.i1Type llvmctx ]
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
  let fnty ← LLVM.functionType retty argtys
  let _ ← LLVM.buildCall2 builder fnty fn #[enable?]

def callLeanIOMarkEndInitialization (builder : LLVM.Builder llvmctx) : M llvmctx Unit := do
  let fnName :=  "lean_io_mark_end_initialization"
  let retty ← LLVM.voidType llvmctx
  let argtys := #[]
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
  let fnty ← LLVM.functionType retty argtys
  let _ ← LLVM.buildCall2 builder fnty fn #[]

def callLeanIOResultIsOk (builder : LLVM.Builder llvmctx)
    (arg : LLVM.Value llvmctx) (name : String := "") : M llvmctx (LLVM.Value llvmctx) := do
  let fnName :=  "lean_io_result_is_ok"
  let retty ← LLVM.i1Type llvmctx
  let argtys := #[ ← LLVM.voidPtrType llvmctx ]
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
  let fnty ← LLVM.functionType retty argtys
  LLVM.buildCall2 builder fnty fn #[arg] name

def callLeanInitTaskManager (builder : LLVM.Builder llvmctx) : M llvmctx Unit := do
  let fnName :=  "lean_init_task_manager"
  let retty ← LLVM.voidType llvmctx
  let argtys := #[]
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
  let fnty ← LLVM.functionType retty argtys
   let _ ← LLVM.buildCall2 builder fnty fn #[]

def callLeanFinalizeTaskManager (builder : LLVM.Builder llvmctx) : M llvmctx Unit := do
  let fnName :=  "lean_finalize_task_manager"
  let retty ← LLVM.voidPtrType llvmctx
  let argtys := #[]
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
  let fnty ← LLVM.functionType retty argtys
   let _ ← LLVM.buildCall2 builder fnty fn #[]

def callLeanUnboxUint32 (builder : LLVM.Builder llvmctx)
    (v : LLVM.Value llvmctx) (name : String := "") : M llvmctx (LLVM.Value llvmctx) := do
  let fnName :=  "lean_unbox_uint32"
  let retty ← LLVM.i32Type llvmctx
  let argtys := #[ ← LLVM.voidPtrType llvmctx ]
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
  let fnty ← LLVM.functionType retty argtys
  LLVM.buildCall2 builder fnty fn  #[v] name

def callLeanIOResultShowError (builder : LLVM.Builder llvmctx)
    (v : LLVM.Value llvmctx) (name : String := "") : M llvmctx Unit := do
  let fnName :=  "lean_io_result_show_error"
  let retty ← LLVM.voidType llvmctx
  let argtys := #[ ← LLVM.voidPtrType llvmctx ]
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty fnName argtys
  let fnty ← LLVM.functionType retty argtys
  let _ ← LLVM.buildCall2 builder fnty fn #[v] name

def callLeanMainFn (builder : LLVM.Builder llvmctx)
    (argv? : Option (LLVM.Value llvmctx))
    (world : LLVM.Value llvmctx)
    (name : String) : M llvmctx (LLVM.Value llvmctx) := do
  let retty ← LLVM.voidPtrType llvmctx
  let voidptr ← LLVM.voidPtrType llvmctx
  let argtys := if argv?.isSome then #[ voidptr, voidptr ] else #[ voidptr ]
  let fn ← getOrCreateFunctionPrototype (← getLLVMModule) retty leanMainFn argtys
  let fnty ← LLVM.functionType retty argtys
  let args := match argv? with
              | .some argv => #[argv, world]
              | .none => #[world]
  LLVM.buildCall2 builder fnty fn args name

def emitMainFn (mod : LLVM.Module llvmctx) (builder : LLVM.Builder llvmctx) : M llvmctx Unit := do
  let d ← getDecl `main
  let xs ← match d with
   | .fdecl (xs := xs) .. => pure xs
   | _ =>  throw "Function declaration expected for 'main'"

  unless xs.size == 2 || xs.size == 1 do throw s!"Invalid main function, main expected to have '2' or '1' arguments, found '{xs.size}' arguments"
  let env ← getEnv
  let usesLeanAPI := usesModuleFrom env `Lean
  let mainTy ← LLVM.functionType (← LLVM.i64Type llvmctx)
      #[(← LLVM.i64Type llvmctx), (← LLVM.pointerType (← LLVM.voidPtrType llvmctx))]
  let main ← LLVM.getOrAddFunction mod "main" mainTy
  let entry ← LLVM.appendBasicBlockInContext llvmctx main "entry"
  LLVM.positionBuilderAtEnd builder entry
  /-
  #if defined(WIN32) || defined(_WIN32)
  SetErrorMode(SEM_FAILCRITICALERRORS);
  #endif
  -/
  let inty ← LLVM.voidPtrType llvmctx
  let inslot ← LLVM.buildAlloca builder (← LLVM.pointerType inty) "in"
  let resty ← LLVM.voidPtrType llvmctx
  let res ← LLVM.buildAlloca builder (← LLVM.pointerType resty) "res"
  if usesLeanAPI then callLeanInitialize builder else callLeanInitializeRuntimeModule builder
    /- We disable panic messages because they do not mesh well with extracted closed terms.
        See issue #534. We can remove this workaround after we implement issue #467. -/
  callLeanSetPanicMessages builder (← LLVM.constFalse llvmctx)
  let world ← callLeanIOMkWorld builder
  let resv ← callModInitFn builder (← getModName) (← LLVM.constInt8 llvmctx 1) world ((← getModName).toString ++ "_init_out")
  let _ ← LLVM.buildStore builder resv res

  callLeanSetPanicMessages builder (← LLVM.constTrue llvmctx)
  callLeanIOMarkEndInitialization builder

  let resv ← LLVM.buildLoad2 builder resty res "resv"
  let res_is_ok ← callLeanIOResultIsOk builder resv "res_is_ok"
  buildIfThen_ builder "resIsOkBranches"  res_is_ok
    (fun builder => do -- then clause of the builder)
      callLeanDecRef builder resv
      callLeanInitTaskManager builder
      if xs.size == 2 then
        let inv ← callLeanBox builder (← LLVM.constInt (← LLVM.size_tType llvmctx) 0) "inv"
        let _ ← LLVM.buildStore builder inv inslot
        let ity ← LLVM.size_tType llvmctx
        let islot ← LLVM.buildAlloca builder ity "islot"
        let argcval ← LLVM.getParam main 0
        let argvval ← LLVM.getParam main 1
        LLVM.buildStore builder argcval islot
        buildWhile_ builder "argv"
          (condcodegen := fun builder => do
            let iv ← LLVM.buildLoad2 builder ity islot "iv"
            let i_gt_1 ← LLVM.buildICmp builder LLVM.IntPredicate.UGT iv (← constIntUnsigned 1) "i_gt_1"
            return i_gt_1)
          (bodycodegen := fun builder => do
            let iv ← LLVM.buildLoad2 builder ity islot "iv"
            let iv_next ← LLVM.buildSub builder iv (← constIntUnsigned 1) "iv.next"
            LLVM.buildStore builder iv_next islot
            let nv ← callLeanAllocCtor builder 1 2 0 "nv"
            let argv_i_next_slot ← LLVM.buildGEP2 builder (← LLVM.voidPtrType llvmctx) argvval #[iv_next] "argv.i.next.slot"
            let argv_i_next_val ← LLVM.buildLoad2 builder (← LLVM.voidPtrType llvmctx) argv_i_next_slot "argv.i.next.val"
            let argv_i_next_val_str ← callLeanMkString builder argv_i_next_val "arg.i.next.val.str"
            callLeanCtorSet builder nv (← constIntUnsigned 0) argv_i_next_val_str
            let inv ← LLVM.buildLoad2 builder inty inslot "inv"
            callLeanCtorSet builder nv (← constIntUnsigned 1) inv
            LLVM.buildStore builder nv inslot)
        let world ← callLeanIOMkWorld builder
        let inv ← LLVM.buildLoad2 builder inty inslot "inv"
        let resv ← callLeanMainFn builder (argv? := .some inv) (world := world) "resv"
        let _ ← LLVM.buildStore builder resv res
        pure ShouldForwardControlFlow.yes
      else
          let world ← callLeanIOMkWorld builder
          let resv ← callLeanMainFn builder (argv? := .none) (world := world) "resv"
          let _ ← LLVM.buildStore builder resv res
          pure ShouldForwardControlFlow.yes
  )

  -- `IO _`
  let retTy := env.find? `main |>.get! |>.type |>.getForallBody
  -- either `UInt32` or `(P)Unit`
  let retTy := retTy.appArg!
  -- finalize at least the task manager to avoid leak sanitizer false positives
  -- from tasks outliving the main thread
  callLeanFinalizeTaskManager builder
  let resv ← LLVM.buildLoad2 builder resty res "resv"
  let res_is_ok ← callLeanIOResultIsOk builder resv "res_is_ok"
  buildIfThenElse_ builder "res.is.ok" res_is_ok
    (fun builder => -- then builder
      if retTy.constName? == some ``UInt32 then do
        let resv ← LLVM.buildLoad2 builder resty res "resv"
        let retv ← callLeanUnboxUint32 builder (← callLeanIOResultGetValue builder resv "io_val") "retv"
        let retv ← LLVM.buildSext builder retv (← LLVM.i64Type llvmctx) "retv_sext"
        callLeanDecRef builder resv
        let _ ← LLVM.buildRet builder retv
        pure ShouldForwardControlFlow.no
      else do
        callLeanDecRef builder resv
        let _ ← LLVM.buildRet builder (← LLVM.constInt64 llvmctx 0)
        pure ShouldForwardControlFlow.no

    )
    (fun builder => do -- else builder
        let resv ← LLVM.buildLoad2 builder resty res "resv"
        callLeanIOResultShowError builder resv
        callLeanDecRef builder resv
        let _ ← LLVM.buildRet builder (← LLVM.constInt64 llvmctx 1)
        pure ShouldForwardControlFlow.no)
  -- at the merge
  let _ ← LLVM.buildUnreachable builder

def hasMainFn : M llvmctx Bool := do
  let env ← getEnv
  let decls := getDecls env
  return decls.any (fun d => d.name == `main)

def emitMainFnIfNeeded (mod : LLVM.Module llvmctx) (builder : LLVM.Builder llvmctx) : M llvmctx Unit := do
  if (← hasMainFn) then emitMainFn mod builder

def main : M llvmctx Unit := do
  emitFnDecls
  let builder ← LLVM.createBuilderInContext llvmctx
  emitFns (← getLLVMModule) builder
  emitInitFn (← getLLVMModule) builder
  emitMainFnIfNeeded (← getLLVMModule) builder
end EmitLLVM

def getLeanHBcPath : IO System.FilePath := do
  return (← getLibDir (← getBuildDir)) / "lean.h.bc"

def optimizeLLVMModule (mod : LLVM.Module ctx) : IO Unit := do
  let pm  ← LLVM.createPassManager
  let pmb ← LLVM.createPassManagerBuilder
  pmb.setOptLevel 3
  pmb.populateModulePassManager pm
  LLVM.runPassManager pm mod
  LLVM.disposePassManager pm
  LLVM.disposePassManagerBuilder pmb

/--
`emitLLVM` is the entrypoint for the lean shell to code generate LLVM.
-/
@[export lean_ir_emit_llvm]
def emitLLVM (env : Environment) (modName : Name) (filepath : String) (tripleStr? : Option String) : IO Unit := do
  LLVM.llvmInitializeTargetInfo
  let llvmctx ← LLVM.createContext
  let module ← LLVM.createModule llvmctx modName.toString
  let emitLLVMCtx : EmitLLVM.Context llvmctx := {env := env, modName := modName, llvmmodule := module}
  let initState := { var2val := default, jp2bb := default : EmitLLVM.State llvmctx}
  let out? ← ((EmitLLVM.main (llvmctx := llvmctx)).run initState).run emitLLVMCtx
  match out? with
  | .ok _ => do
         let membuf ← LLVM.createMemoryBufferWithContentsOfFile (← getLeanHBcPath).toString
         let modruntime ← LLVM.parseBitcode llvmctx membuf
         LLVM.linkModules (dest := emitLLVMCtx.llvmmodule) (src := modruntime)
         optimizeLLVMModule emitLLVMCtx.llvmmodule
         LLVM.writeBitcodeToFile emitLLVMCtx.llvmmodule filepath
         let tripleStr := tripleStr?.getD (← LLVM.getDefaultTargetTriple)
         let target ← LLVM.getTargetFromTriple tripleStr
         let cpu := "generic"
         let features := ""
         let targetMachine ← LLVM.createTargetMachine target tripleStr cpu features
         let codegenType := LLVM.CodegenFileType.ObjectFile
         LLVM.targetMachineEmitToFile targetMachine emitLLVMCtx.llvmmodule (filepath ++ ".o") codegenType
         LLVM.disposeModule emitLLVMCtx.llvmmodule
         LLVM.disposeTargetMachine targetMachine
  | .error err => throw (IO.Error.userError err)
end Lean.IR


import Architectural.proofObligations
import lacu
import Architectural.lang
import tactic
import system.io

open LANG PORTS tactic

local infix ` OR `:50 := LANG.disj
local infix ` & `:50 := LANG.conj

meta def preprocess_rpo_fst : tactic (name × name) := do
  x ← tactic.get_unused_name `x,
  H ← tactic.get_unused_name `H,
  tactic.intro x,
  `[simp],
  `[rw AssertionLang.impl_def],
  tactic.intro H,
  `[rw [list_conj_iff, get_nfs] at H, simp at H, rw toMap at H],
  return ⟨x, H⟩

def theList := [armPosition,LAAP,armController].pw_filter (ne)

meta def foo : tactic unit :=
do
  v ← mk_meta_var `(ne armPosition LAAP),
  set_goals [v]

-- example : true :=
-- begin
-- foo, dec_trivial,
-- end

meta def solve_rpo_fst : tactic unit := do
  ⟨x, H⟩ ← preprocess_rpo_fst,
  `[rcases H with ⟨H1,H2,H3⟩],
  tactic.repeat `[rw Map.find_val at H1 H2 H3],
  `[have  distinct1 : armPosition ≠ LAAP, by {dec_trivial,},
  have  distinct2 : armPosition ≠ armController, by {dec_trivial},
  have  distinct3 : armController ≠ LAAP, by {dec_trivial},
  repeat {simp [distinct1, distinct2, distinct3] at *,},
  rw nf_def at *, intro A, simp at *,
  apply (@synchronize (atom fault_PWMFlow_LACU).neg.always x fault_PWMFlow_LACU fault_armFlow_armController).mpr,
  simp,
  apply H3, clear H3,
  rw @forall_conj_distrib_mem x _ _,split,
  rw @forall_conj_distrib_mem' x _ _,split,
  rw @forall_conj_distrib_mem' x _ _,split,
  apply (@synchronize (atom fault_angleSensor_armController).neg.always x fault_angleSensor_armController fault_output_armPosition ).mpr,
  simp,
  apply H1, clear H1,
  rw @forall_conj_distrib_mem x _ _ at A,
  cases A with A1 A2, clear A2,
  rw @forall_conj_distrib_mem' x _ _ at A1,
  cases A1 with A1 A3, clear A3,
  rw @forall_conj_distrib_mem' x _ _ at A1,
  cases A1 with A1 A2, clear A2,
  apply (@synchronize (((atom fault_input2_armPosition).neg OR (atom fault_input1_armPosition).neg).always) x fault_input1_armPosition fault_armPositionAngle1_LACU).mpr,
  apply (@synchronize (((atom fault_input2_armPosition).neg OR (atom fault_armPositionAngle1_LACU).neg).always) x fault_input2_armPosition fault_armPositionAngle2_LACU).mpr,
  simp,
  intros i,
  replace A1 := A1 i, rwa LANG.disj_comm at A1,
  unfold LACU_ARCH_MODEL, simp, unfold LACU_ARCH_MODEL, dsimp, dec_trivial,
  unfold LACU_ARCH_MODEL, dsimp, dec_trivial,
  apply ((@synchronize (atom fault_LAAPActive_armController).neg.always) x fault_LAAPActive_armController fault_LAAPActive_LAAP).mpr,
  simp,
  have : x ∈ AssertionLang.sem ((atom fault_LAAPFlow_LAAP).neg & (atom fault_LAAPActive_LAAP).neg).always → x ∈ ((atom fault_LAAPActive_LAAP).neg).always.sem,
   by {intro h, intro i,
    rw forall_conj_distrib_mem at h,
    cases h with h1 h2,
    apply h2 i,
        },
  apply this, clear this,
  apply H2, clear H2, clear H1,
  apply ((@synchronize ((atom fault_LAAPRequest_LAAP).neg & (atom fault_operatorControlLever_LAAP).neg).always) x fault_operatorControlLever_LAAP fault_operatorControlLever_LACU).mpr,
  simp,
  apply ((@synchronize ((atom fault_LAAPRequest_LAAP).neg & (atom fault_operatorControlLever_LACU).neg).always) x fault_LAAPRequest_LAAP fault_LAAPRequest_LACU).mpr,
  simp,

  rw @forall_conj_distrib_mem x _ _,
  rw @forall_conj_distrib_mem x _ _  at A,
  cases A with A1 A2,
  rw @forall_conj_distrib_mem' x _ _  at A1,
  cases A1 with A1 A3,
  rw @forall_conj_distrib_mem' x _ _  at A1,
  cases A1 with A1 A4,
  split,
  exact A4,
  exact A3,
    unfold LACU_ARCH_MODEL, dsimp, dec_trivial,
    unfold LACU_ARCH_MODEL, dsimp, dec_trivial,
    unfold LACU_ARCH_MODEL, dsimp, dec_trivial,
  apply ((@synchronize (atom fault_LAAPFlow_armController).neg.always) x fault_LAAPFlow_armController fault_LAAPFlow_LAAP).mpr,
  simp,intro i,
  rw @forall_conj_distrib_mem x _ _  at H2,
 have : (x ∈ AssertionLang.sem ((atom fault_LAAPFlow_LAAP).neg & (atom fault_LAAPActive_LAAP).neg).always) → stream.drop i x ∈ (atom fault_LAAPFlow_LAAP).neg.sem,
 by { intros H', rw @forall_conj_distrib_mem x _ _  at H',
 cases H' with H' H'',
 apply H' i,}, apply this, clear this, apply H2,
  rw @forall_conj_distrib_mem x _ _  at A,
  cases A with A1 A2,
  rw @forall_conj_distrib_mem' x _ _  at A1,
  cases A1 with A1 A3,
  rw @forall_conj_distrib_mem' x _ _  at A1,
  cases A1 with A1 A4,
  split,
  apply (@synchronize (atom fault_LAAPRequest_LAAP).neg.always x fault_LAAPRequest_LAAP fault_LAAPRequest_LACU).mpr,
  simp, apply A4,
    unfold LACU_ARCH_MODEL, dsimp, dec_trivial,
apply (@synchronize (atom fault_operatorControlLever_LAAP).neg.always x fault_operatorControlLever_LAAP fault_operatorControlLever_LACU).mpr,
  simp, apply A3,
    unfold LACU_ARCH_MODEL, dsimp, dec_trivial,
    unfold LACU_ARCH_MODEL, dsimp, dec_trivial,
  rw @forall_conj_distrib_mem x _ _  at A,
  cases A with A1 A2,
  rw @forall_conj_distrib_mem' x _ _  at A1,
  cases A1 with A1 A3,
  rw @forall_conj_distrib_mem' x _ _  at A1,
  cases A1 with A1 A4,
  apply (@synchronize (atom fault_operatorControlLever_armController).neg.always x fault_operatorControlLever_armController fault_operatorControlLever_LACU).mpr,
  simp,
  intro i,
  apply A3 i,  unfold LACU_ARCH_MODEL, dsimp, dec_trivial,
   unfold LACU_ARCH_MODEL, dsimp, dec_trivial],
  return ()

-- meta def get_comp_names : tactic (list (expr × expr)) :=
-- do

-- meta def get_comp_names : tactic (list (expr × expr)) :=
-- do

meta def tac1 : tactic unit :=
`[rw AssertionLang.impl_def,
intro Ha,
rw AssertionLang.conj_def at Ha,
cases Ha with Ha Hb,
rw list_conj_iff at Hb,
simp at Hb,
have Hb1 := Hb LAAP (by {rw H, simp,}),
have Hb2 := Hb armController (by {rw H, simp,}),
clear Hb,
simp at *,
rw Map.find_val at *,
rw Map.find_val at *,
rw Map.find_val at *,
simp at *,
rw H,
have  distinct1 : armPosition ≠ LAAP, by {dec_trivial,},
  have  distinct2 : armPosition ≠ armController, by {dec_trivial},
  have  distinct3 : armController ≠ LAAP, by {dec_trivial},
  repeat {simp [distinct1, distinct2, distinct3] at *,}]

meta def tac2 : tactic unit :=
`[rw AssertionLang.impl_def,
intro Ha,
rw AssertionLang.conj_def at Ha,
cases Ha with Ha Hb,
rw list_conj_iff at Hb,
simp at Hb,
have Hb1 := Hb armController (by {rw H, dec_trivial,}),
have Hb2 := Hb armPosition (by {rw H, dec_trivial,}),
clear Hb,
simp at *,
rw Map.find_val at *,
rw Map.find_val at *,
rw Map.find_val at *,
have  distinct1 : armPosition ≠ LAAP, by {dec_trivial,},
  have  distinct2 : armPosition ≠ armController, by {dec_trivial},
  have  distinct3 : armController ≠ LAAP, by {dec_trivial},
  repeat {simp [distinct1, distinct2, distinct3] at *,}]

meta def tac3 : tactic unit :=
`[rw AssertionLang.impl_def,
intro Ha,
rw AssertionLang.conj_def at Ha,
cases Ha with Ha Hb,
rw list_conj_iff at Hb,
simp at Hb,
have Hb1 := Hb LAAP (by {rw H, dec_trivial,}),
have Hb2 := Hb armPosition (by {rw H, dec_trivial,}),
clear Hb,
simp at *,
rw Map.find_val at *,
rw Map.find_val at *,
rw Map.find_val at *,
have  distinct1 : armPosition ≠ LAAP, by {dec_trivial,},
  have  distinct2 : armPosition ≠ armController, by {dec_trivial},
  have  distinct3 : armController ≠ LAAP, by {dec_trivial},
  repeat {simp [distinct1, distinct2, distinct3] at *,}]

meta def solve_rpo_snd : tactic unit := do
`[rw RPO_snd,
intros S H s,
simp at *,
cases H,
work_on_goal 0 { tac1,
  rw @forall_conj_distrib_mem s _ _  at Ha,
  cases Ha with Ha Ha2,
  rw @forall_conj_distrib_mem' s _ _  at Ha,
  cases Ha with Ha Ha3,
   rw @forall_conj_distrib_mem' s _ _  at Ha,
  cases Ha with Ha Ha4,
  intro i,
  apply (@synchronize (((atom fault_input2_armPosition).neg OR (atom fault_input1_armPosition).neg).always) s fault_input1_armPosition fault_armPositionAngle1_LACU).mpr,
  apply (@synchronize (((atom fault_input2_armPosition).neg OR (atom fault_armPositionAngle1_LACU).neg).always) s fault_input2_armPosition fault_armPositionAngle2_LACU).mpr,
  simp,
  intro i,
  replace Ha := Ha i, rwa LANG.disj_comm at Ha,
      unfold LACU_ARCH_MODEL, dsimp, dec_trivial,
      unfold LACU_ARCH_MODEL, dsimp, dec_trivial,

  },

cases H, tac2, rw H,
  have  distinct1 : armPosition ≠ LAAP, by {dec_trivial,},
  have  distinct2 : armPosition ≠ armController, by {dec_trivial},
  have  distinct3 : armController ≠ LAAP, by {dec_trivial},
  repeat {simp [distinct1, distinct2, distinct3] at *,},
  rw @forall_conj_distrib_mem s _ _  at Ha,
  cases Ha with Ha Ha2,
  rw @forall_conj_distrib_mem' s _ _  at Ha,
  cases Ha with Ha Ha3,
   rw @forall_conj_distrib_mem' s _ _  at Ha,
  cases Ha with Ha Ha4,
  rw @forall_conj_distrib_mem s _ _ ,
  split,
  apply (@synchronize (atom fault_LAAPRequest_LAAP).neg.always s fault_LAAPRequest_LAAP fault_LAAPRequest_LACU).mpr,
  simp, exact Ha4,
  unfold LACU_ARCH_MODEL, dsimp, dec_trivial,
apply (@synchronize (atom fault_operatorControlLever_LAAP).neg.always s fault_operatorControlLever_LAAP fault_operatorControlLever_LACU).mpr,
simp, assumption,   unfold LACU_ARCH_MODEL, dsimp, dec_trivial,

tac3,
rw H,
  have  distinct1 : armPosition ≠ LAAP, by {dec_trivial,},
  have  distinct2 : armPosition ≠ armController, by {dec_trivial},
  have  distinct3 : armController ≠ LAAP, by {dec_trivial},
  repeat {simp [distinct1, distinct2, distinct3] at *,},
  rw @forall_conj_distrib_mem s _ _ ,
  split,
  rw @forall_conj_distrib_mem' s _ _ ,
  split,
  rw @forall_conj_distrib_mem' s _ _ ,
  split,
  apply (@synchronize (atom fault_angleSensor_armController).neg.always s fault_angleSensor_armController fault_output_armPosition ).mpr,
  simp,
  rw nf_def at Hb2,
  simp at Hb2, apply Hb2,
 rw @forall_conj_distrib_mem s _ _  at Ha,
  cases Ha with Ha Ha2,
  rw @forall_conj_distrib_mem' s _ _  at Ha,
  cases Ha with Ha Ha3,
   rw @forall_conj_distrib_mem' s _ _  at Ha,
  cases Ha with Ha Ha4,
  intro i,
  apply (@synchronize (((atom fault_input2_armPosition).neg OR (atom fault_input1_armPosition).neg).always) s fault_input1_armPosition fault_armPositionAngle1_LACU).mpr,
  apply (@synchronize (((atom fault_input2_armPosition).neg OR (atom fault_armPositionAngle1_LACU).neg).always) s fault_input2_armPosition fault_armPositionAngle2_LACU).mpr,
  simp,
  intro i,
  replace Ha := Ha i, rwa LANG.disj_comm at Ha,
      unfold LACU_ARCH_MODEL, dsimp, dec_trivial,
      unfold LACU_ARCH_MODEL, dsimp, dec_trivial,
      unfold LACU_ARCH_MODEL, dsimp, dec_trivial,
  apply ((@synchronize (atom fault_LAAPActive_armController).neg.always) s fault_LAAPActive_armController fault_LAAPActive_LAAP).mpr,
  simp, rw nf_def at Hb1,
  simp at Hb1,
  intro i,
   have : (s ∈ AssertionLang.sem ((atom  fault_LAAPFlow_LAAP).neg & (atom fault_LAAPActive_LAAP).neg ).always) → stream.drop i s ∈ (atom fault_LAAPActive_LAAP).neg.sem,
  by { intros H', rw @forall_conj_distrib_mem s _ _  at H',
 cases H' with H' H'',
 apply H'' i,}, apply this,clear this,
 apply Hb1,
 rw @forall_conj_distrib_mem s _ _  at Ha,
  cases Ha with Ha Ha2,
  rw @forall_conj_distrib_mem' s _ _  at Ha,
  cases Ha with Ha Ha3,
   rw @forall_conj_distrib_mem' s _ _  at Ha,
  cases Ha with Ha Ha4,
  apply ((@synchronize ((atom fault_LAAPRequest_LAAP).neg & (atom fault_operatorControlLever_LAAP).neg).always) s fault_operatorControlLever_LAAP fault_operatorControlLever_LACU).mpr,
  simp,
  apply ((@synchronize ((atom fault_LAAPRequest_LAAP).neg & (atom fault_operatorControlLever_LACU).neg).always) s fault_LAAPRequest_LAAP fault_LAAPRequest_LACU).mpr,
  simp,
  intro i, split, apply Ha4 i,
  apply Ha3 i,
      unfold LACU_ARCH_MODEL, dsimp, dec_trivial,
      unfold LACU_ARCH_MODEL, dsimp, dec_trivial,
      unfold LACU_ARCH_MODEL, dsimp, dec_trivial,

rw nf_def at Hb1,
  simp at Hb1,

apply ((@synchronize (atom fault_LAAPFlow_armController).neg.always) s fault_LAAPFlow_armController fault_LAAPFlow_LAAP).mpr,
simp,
intro i,
have : (s ∈ AssertionLang.sem ((atom  fault_LAAPFlow_LAAP).neg & (atom fault_LAAPActive_LAAP).neg ).always) → stream.drop i s ∈ (atom fault_LAAPFlow_LAAP).neg.sem,
  by { intros H', rw @forall_conj_distrib_mem s _ _  at H', cases H' with H' H'', apply H' i,},
apply this,
apply Hb1,
 rw @forall_conj_distrib_mem s _ _  at Ha,
  cases Ha with Ha Ha2,
  rw @forall_conj_distrib_mem' s _ _  at Ha,
  cases Ha with Ha Ha3,
   rw @forall_conj_distrib_mem' s _ _  at Ha,
  cases Ha with Ha Ha4,
  apply ((@synchronize ((atom fault_LAAPRequest_LAAP).neg & (atom fault_operatorControlLever_LAAP).neg).always) s fault_operatorControlLever_LAAP fault_operatorControlLever_LACU).mpr,
  simp,
  apply ((@synchronize ((atom fault_LAAPRequest_LAAP).neg & (atom fault_operatorControlLever_LACU).neg).always) s fault_LAAPRequest_LAAP fault_LAAPRequest_LACU).mpr,
  simp,
  intro i,
  split, apply Ha4 i, apply Ha3 i,
      unfold LACU_ARCH_MODEL, dsimp, dec_trivial,
      unfold LACU_ARCH_MODEL, dsimp, dec_trivial,
      unfold LACU_ARCH_MODEL, dsimp, dec_trivial,

 rw @forall_conj_distrib_mem s _ _  at Ha,
  cases Ha with Ha Ha2,
  rw @forall_conj_distrib_mem' s _ _  at Ha,
  cases Ha with Ha Ha3,
   rw @forall_conj_distrib_mem' s _ _  at Ha,
  cases Ha with Ha Ha4,
  apply (@synchronize (atom fault_operatorControlLever_armController).neg.always s fault_operatorControlLever_armController fault_operatorControlLever_LACU).mpr,
 simp,
      apply Ha3,
      unfold LACU_ARCH_MODEL, dsimp, dec_trivial]

meta def solve_rpo : tactic unit := do
`[split], solve_rpo_fst

-- example : RPO_snd
--     {ArchitectureWithContracts .
--      to_Architecture := LACU_ARCH_MODEL,
--      parent := {Contract .
--                 A := ((atom fault_armPositionAngle1_LACU).neg OR(atom fault_armPositionAngle2_LACU).neg&(atom
--                                fault_LAAPRequest_LACU).neg&(atom fault_operatorControlLever_LACU).neg&(atom
--                            fault_groundSpeed_LACU).neg).always,
--                 G := (atom fault_PWMFlow_LACU).neg.always},
--      contracts := toMap
--                     [(armPosition,
--                        {Contract .
--                         A := ((atom fault_input2_armPosition).neg OR(atom fault_input1_armPosition).neg).always,
--                         G := (atom fault_output_armPosition).neg.always}), (armController,
--                        {Contract .
--                         A := ((atom fault_angleSensor_armController).neg&(atom fault_LAAPActive_armController).neg&(atom
--                                      fault_LAAPFlow_armController).neg&(atom
--                                    fault_operatorControlLever_armController).neg).always,
--                         G := (atom fault_armFlow_armController).neg.always}), (LAAP,
--                        {Contract .
--                         A := ((atom fault_LAAPRequest_LAAP).neg&(atom fault_operatorControlLever_LAAP).neg).always,
--                         G := ((atom fault_LAAPFlow_LAAP).neg&(atom fault_LAAPActive_LAAP).neg).always})],
--      all_components := by {unfold LACU_ARCH_MODEL, auto_all_comps,}}:=
-- begin
-- solve_rpo_snd,
-- end


import data.finset.basic
import data.fintype.basic

/-
High-level model of Soong build system (very incomplete)

 Concrete examples of libraries:

 /system/bin/cameraserver
 - soong world: no options specified (meaning, 'local to system')

 /vendor/bin/vndservicemanager
 - soong world: "vendor: true" (meaning, 'local to vendor')

 libgui
 - soong world: "vendor_available: false, vndk: { enabled: true, },"
 - "vndk-private"

 libcamerahelper
 - soong world: "vendor_available: true, vndk: { enabled: true, },"
 - soong world: "libcamerahelper loads libgui" -- not important to model, this
                actually the relationship between vndk and vndk-private
 - "vndk"

 libbinder_ndk
 - soong world: "vendor_available: true, isLlNdk() true"
 - ll-ndk
 -/

--------------------------------------------------------------------------------
/-
 - Core data structures of Soong model
 -/

/-
 - Different kinds of libraries which have regular behavior in some sense
 - This does not correspond to any particular abstraction in the codebase but
 - is very useful for clarifying a mental model of how things work (lots of
 - behavior can be defined purely in virtue of what library classes a library
 - inhabits, without having to look at details of the library itself).
 -/
@[derive decidable_eq]
inductive Library_class
 | system_local: Library_class
 | system_ext: Library_class
 | vendor_local: Library_class
 | llndk: Library_class
 | vndk: Library_class
 | vndk_sp: Library_class
 | vndk_ext: Library_class
 | vndk_private: Library_class
 | product: Library_class
 | recovery: Library_class

open Library_class

/-
 - Being assigned some subset of these variants is a property of a given library
 - Which are assigned ends up dictating the build environment to a large degree.
 -/
@[derive decidable_eq]
inductive Variant
 | core: Variant
 | vendor_platform : Variant
 | product_platform : Variant
 | product_product : Variant
 | ramdisk : Variant
 | recovery : Variant

/-
 - Specified by a user in a Soong input file.
 -/
@[derive decidable_eq]
structure Library :=
 (name: string)

 (vendor_available: option bool)

 (vendor: option bool)
 -- declared as a VNDK or VNDK-SP module. The vendor variant
    -- will be installed in /system instead of /vendor partition.
    -- if true, then vendor_available must be explicitly set to either ⊤ or ⊥
 (vndk_enabled: option bool)
 -- declared as a VNDK-SP module, which is a subset of VNDK (need vndk_enabled).
    -- All these modules are allowed to link to VNDK-SP or LL-NDK
    -- modules only. Other dependency will cause link-type errors.
    -- none/false means lib is VNDK-core
    -- can link to other VNDK-core ,VNDK-SP or LL-NDK modules only.
    -- Warning: sometimes erroneously referred to as support_same_process
 (vndk_support_system_process: option bool)
 -- Whether m.linker(*llndkStubDecorator) returns true or not
 -- Assume that llndkHeadersDecorator has same value
 -- Modeled as a boolean field for simplicity
 (llndk_stub: bool)

 (device_specific: bool)
 (product_specific: bool)
 (is_vndk: bool)
 (is_vndkext: bool)
 -- Dependencies on other libraries by name
 (deps: finset string)

/-
 - Based on Jiyong's summary
 - The "none" corresponds to the very first check of ImageMutatorBegin, where
 - it fails because having both of these options set doesn't make sense
 - TODO consider all four booleans together,
 -   vndk-private is when vendor_available is false but vndk_enabled is true
 -   vndk_sp_private is the same as above but also has
 -     vndk_support_system_process true
 -/
def assign_library_classes (lib: Library): option (finset Library_class) :=
 (option.lift_or_get finset.has_union.1)

 (match lib.vendor, lib.vendor_available  with
  | (some _),      (some _)  := none
  | (some vendor), _         := some [vendor_local].to_finset
  | _,             (some tt) := some [vendor_local, system_local].to_finset
  | _,             (some ff) := some [system_local].to_finset -- TODO CHECK THIS
  | none,          none      := some [system_local].to_finset
  end)
  $  (option.lift_or_get finset.has_union.1)

  (match lib.vndk_enabled, lib.vndk_support_system_process with
    | (some tt), (some tt) := some [vndk_sp].to_finset
    | (some tt), _         := some [vndk].to_finset
    | _,         (some _)  := none
    | _,          _        := some ∅
   end)

  (some $ if lib.llndk_stub then [llndk].to_finset else ∅)

/-
 - Based on the implemenation at ~3122 of cc.go
 - Relies on assign_library_classes
 -/
 open Variant
 def libaryclass_to_variants: Library_class → finset Variant
 | system_local:= [core].to_finset
 | system_ext:= [core].to_finset
 | vendor_local:= [].to_finset -- aka vendorSpecific (ignore kernelHeadersDecorator) and ignore vendor board (it's experimental) only look at line 255
 | llndk:= [].to_finset -- variants from lines 187-197
 | vndk:= [core].to_finset -- AND whatever is in vendor_local
 | vndk_sp:= [].to_finset -- SAME as vndk
 | vndk_ext:= [].to_finset -- same as vendor_local
 | vndk_private:= [].to_finset -- same as vendor_local
 | product:= [core].to_finset
 | recovery:= [Variant.recovery].to_finset

/-
 - Map over and union
 - That we can do this is the justification of library_class' existance.
 - All members of a library class share variants.
 -/
def libary_to_variant (libc: Library): option (finset Variant):=
  assign_library_classes libc >>= λ lcs, some $
    (libclasses.1.map library_class_to_variants).fold (∪) ∅

--------------------------------------------------------------------------------
/-
 - Transitive relationship of reachability in a graph
 -/
inductive depends: finset Library → Library → Library → Prop
 | edge: ∀ (ctx: finset Library) (src tar: Library),
    src ∈ ctx → tar ∈ ctx
        → tar.name ∈ src.deps
            → depends ctx src tar
 | trans: ∀ (ctx: finset Library) (src mid tar: Library),
    src ∈ ctx → tar ∈ ctx
        → depends ctx src mid
            → depends ctx mid tar
                → depends ctx src tar

--------------------------------------------------------------------------------
/-
 - Concrete library examples
 -/
-- def cameraserver: Library := ⟨"cameraserver", none, none, none, ∅⟩
-- def libcamerahelper: Library := ⟨"libcamerahelper", some tt, none, none, ∅⟩
-- def vndservicemanager: Library := ⟨"vndservicemanager", ff, none, none, ∅⟩
-- def libgui: Library := ⟨"libgui", some ff, none, none, ∅⟩
-- def libutils: Library := ⟨"libutils", some tt, none, none, ∅⟩
--------------------------------------------------------------------------------
/-
 - Proofs about the model
 -/

theorem assign_library_classes_nonempty:
  forall lib: Library, ¬ (assign_library_classes lib) = some ∅
 := sorry

-- theorem double_loadable:
--   forall llndklib vndklib: LibraryWithClass, llndklib <= vndklib
--     → vndklib.double_loadable
--  := sorry


import Yatima.Datatypes.Const
import Lurk.LDON

open Lurk

instance : Coe Nat LDON where
  coe := .num ∘ .ofNat

instance : OfNat LDON n where
  ofNat := .num (.ofNat n)

instance : Coe Bool LDON where coe
  | false => 0
  | true  => 1

instance : Coe String LDON where
  coe := .str

instance : Coe F LDON where
  coe := .num

instance : Coe (List LDON) LDON where
  coe xs := xs.foldr (init := .nil) .cons

instance : Coe Lean.Literal LDON where coe
  | .natVal n => ([0, n] : List LDON)
  | .strVal s => ([1, s] : List LDON)

namespace Yatima.IR

def Univ.toLDON : Univ → LDON
  | .zero     => ([0] : List LDON)
  | .succ u   => ([1, u.toLDON] : List LDON)
  | .max u v  => ([2, u.toLDON, v.toLDON] : List LDON)
  | .imax u v => ([3, u.toLDON, v.toLDON] : List LDON)
  | .var n    => ([4, n] : List LDON)

instance : Coe Univ LDON where
  coe := Univ.toLDON

def Expr.toLDON : Expr → LDON
  | .var n lvls     => ([0, n, lvls.map IR.Univ.toLDON] : List LDON)
  | .sort u         => ([1, u] : List LDON)
  | .const ptr lvls => ([2, ptr, lvls.map IR.Univ.toLDON] : List LDON)
  | .app fn arg     => ([3, fn.toLDON, arg.toLDON] : List LDON)
  | .lam name body  => ([4, name.toLDON, body.toLDON] : List LDON)
  | .pi x y         => ([5, x.toLDON, y.toLDON] : List LDON)
  | .letE x y z     => ([6, x.toLDON, y.toLDON, z.toLDON] : List LDON)
  | .lit l          => ([7, l] : List LDON)
  | .proj n e       => ([8, n, e.toLDON] : List LDON)

instance : Coe Expr LDON where
  coe := Expr.toLDON

def Axiom.toLDON : Axiom → LDON
  | ⟨lvls, type⟩ => ([0, lvls, type] : List LDON)

instance : Coe Axiom LDON where
  coe := Axiom.toLDON

def Theorem.toLDON : Theorem → LDON
  | ⟨lvls, type, value⟩ => ([0, lvls, type, value] : List LDON)

instance : Coe Theorem LDON where
  coe := Theorem.toLDON

def Opaque.toLDON : Opaque → LDON
  | ⟨lvls, type, value⟩ => ([0, lvls, type, value] : List LDON)

instance : Coe Opaque LDON where
  coe := Opaque.toLDON

instance : Coe Lean.QuotKind LDON where coe
  | .type => ([0] : List LDON)
  | .ctor => ([1] : List LDON)
  | .lift => ([2] : List LDON)
  | .ind  => ([3] : List LDON)

def Quotient.toLDON : Quotient → LDON
  | ⟨lvls, type, kind⟩ => ([0, lvls, type, kind] : List LDON)

instance : Coe Quotient LDON where
  coe := Quotient.toLDON

instance : Coe Lean.DefinitionSafety LDON where coe
  | .unsafe  => ([0] : List LDON)
  | .safe    => ([1] : List LDON)
  | .partial => ([2] : List LDON)

def Definition.toLDON : Definition → LDON
  | ⟨lvls, type, value, part⟩ =>
    ([0, lvls, type, value, part] : List LDON)

instance : Coe Definition LDON where
  coe := Definition.toLDON

def Constructor.toLDON : Constructor → LDON
  | ⟨lvls, type, idx, params, fields⟩ => ([0, lvls, type, idx, params, fields] : List LDON)

instance : Coe Constructor LDON where
  coe := Constructor.toLDON

def RecursorRule.toLDON : RecursorRule → LDON
  | ⟨fields, rhs⟩ => ([0, fields, rhs] : List LDON)

instance : Coe RecursorRule LDON where
  coe := RecursorRule.toLDON

def Recursor.toLDON : Recursor → LDON
  | ⟨lvls, type, params, indices, motives, minors, rules, isK, internal⟩ =>
    ([0, lvls, type, params, indices, motives, minors, rules.map RecursorRule.toLDON, isK, internal] : List LDON)

instance : Coe Recursor LDON where
  coe := Recursor.toLDON

def Inductive.toLDON : Inductive → LDON
  | ⟨lvls, type, params, indices, ctors, recrs, recr, refl, struct, unit⟩ =>
    ([0, lvls, type, params, indices, ctors.map Constructor.toLDON, recrs.map Recursor.toLDON, recr, refl, struct, unit] : List LDON)

instance : Coe Inductive LDON where
  coe := Inductive.toLDON

def InductiveProj.toLDON : InductiveProj → LDON
  | ⟨block, idx⟩ => ([0, block, idx] : List LDON)

instance : Coe InductiveProj LDON where
  coe := InductiveProj.toLDON

def ConstructorProj.toLDON : ConstructorProj → LDON
  | ⟨block, idx, cidx⟩ => ([0, block, idx, cidx] : List LDON)

instance : Coe ConstructorProj LDON where
  coe := ConstructorProj.toLDON

def RecursorProj.toLDON : RecursorProj → LDON
  | ⟨block, idx, ridx⟩ => ([0, block, idx, ridx] : List LDON)

instance : Coe RecursorProj LDON where
  coe := RecursorProj.toLDON

def DefinitionProj.toLDON : DefinitionProj → LDON
  | ⟨block, idx⟩ => ([0, block, idx] : List LDON)

instance : Coe DefinitionProj LDON where
  coe := DefinitionProj.toLDON

def Const.toLDON : Const → LDON
  | .axiom x           => ([0, x] : List LDON)
  | .theorem x         => ([1, x] : List LDON)
  | .opaque x          => ([2, x] : List LDON)
  | .definition x      => ([3, x] : List LDON)
  | .quotient x        => ([4, x] : List LDON)
  | .inductiveProj x   => ([5, x] : List LDON)
  | .constructorProj x => ([6, x] : List LDON)
  | .recursorProj x    => ([7, x] : List LDON)
  | .definitionProj x  => ([8, x] : List LDON)
  | .mutDefBlock x     => ([9, x.map Definition.toLDON] : List LDON)
  | .mutIndBlock x     => ([10, x.map Inductive.toLDON] : List LDON)

end Yatima.IR


import group_theory.group_action.basic

variables (R M S : Type*)

/-- Some arbitrary type depending on `has_scalar R M` -/
@[irreducible, nolint has_inhabited_instance unused_arguments]
def foo [has_scalar R M] : Type* := ℕ

variables [has_scalar R M] [has_scalar S R] [has_scalar S M]

/-- This instance is incompatible with `has_scalar.comp.is_scalar_tower`.
However, all its parameters are (instance) implicits or irreducible defs, so it
should not be dangerous. -/
@[nolint unused_arguments]
instance foo.has_scalar [is_scalar_tower S R M] : has_scalar S (foo R M) :=
⟨λ _ _, by { unfold foo, exact 37 }⟩

-- If there is no `is_scalar_tower S R M` parameter, this should fail quickly,
-- not loop forever.
example : has_scalar S (foo R M) :=
begin
  tactic.success_if_fail_with_msg tactic.interactive.apply_instance
    "tactic.mk_instance failed to generate instance for
  has_scalar S (foo R M)",
  unfold foo,
  exact ⟨λ _ _, 37⟩
end

/-
local attribute [instance] has_scalar.comp.is_scalar_tower
-- When `has_scalar.comp.is_scalar_tower` is an instance, this recurses indefinitely.
example : has_scalar S (foo R M) :=
begin
  tactic.success_if_fail_with_msg tactic.interactive.apply_instance
    "maximum class-instance resolution depth has been reached (the limit can be increased by setting option 'class.instance_max_depth') (the class-instance resolution trace can be visualized by setting option 'trace.class_instances')",
  unfold foo,
  exact ⟨λ _ _, 37⟩
end
-/


import ..flocq

/- Indeterminate architecture -/

namespace archi
open flocq

def ptr64 : bool := sorry

def big_endian : bool := sorry

def align_int64 : ℕ := sorry
def align_float64 : ℕ := sorry

def splitlong : bool := sorry

lemma splitlong_ptr32 : splitlong = tt → ptr64 = ff := sorry

def default_pl_64 : bool × nan_pl 53 := sorry

def choose_binop_pl_64 (s1 : bool) (pl1 : nan_pl 53) (s2 : bool) (pl2 : nan_pl 53) : bool := sorry

def default_pl_32 : bool × nan_pl 24 := sorry

def choose_binop_pl_32 (s1 : bool) (pl1 : nan_pl 24) (s2 : bool) (pl2 : nan_pl 24) : bool := sorry

def float_of_single_preserves_sNaN : bool := sorry

end archi