(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
(* *********************************************************************)
(*                                                                     *)
(*              Object Primitives                                      *)
(*                                                                     *)
(*          Ronghui Gu <ronghui.gu@yale.edu>                           *)
(*                                                                     *)
(*          Yale Flint Group                                           *)
(*                                                                     *)
(* *********************************************************************)

Require Import Coqlib.
Require Import Maps.
Require Import AuxStateDataType.
Require Import FlatMemory.
Require Import AbstractDataType.
Require Import Integers.
Require Import Values.
Require Import Constant.
Require Import RealParams.
Require Import CalRealIDPDE.
Require Import CalRealInitPTE.
Require Import CalRealPTPool.
Require Import CalRealPT.
Require Import CalRealSMSPool.
Require Import CalRealProcModule.
Require Import CalRealIntelModule.
Require Import liblayers.compat.CompatGenSem.
Require Import ObjEPT.

Section OBJ_VMX.

  Context `{real_params: RealParams}.

  Function vmx_readz_spec (i: Z) (adt: RData): option Z :=
    match (ikern adt, pg adt, ihost adt) with
      | (true, true, true) =>
        if zle_lt 0 i VMX_Size' then
          match ZMap.get i (vmx adt) with
            | Vint v => Some (Int.unsigned v)
            | _ => None
          end
        else None
      | _ => None
    end.

  Function vmx_writez_spec (i value: Z) (adt: RData): option RData :=
    match (ikern adt, pg adt, ihost adt) with
      | (true, true, true) =>
        if zle_lt 0 i VMX_Size' then
          Some adt {vmx: ZMap.set i (Vint (Int.repr value)) (vmx adt)}
        else None
      | _ => None
    end.

  (*Function vmx_readz64_spec (i: Z) (adt: RData): option Z64 :=
    match (ikern adt, pg adt, ihost adt) with
      | (true, true, true) =>
        if zle_lt 0 i VMX_Size' then
          match ZMap.get i (vmx adt), ZMap.get (i + 1) (vmx adt)  with
            | Vint v1, Vint v2 =>
              Some (VZ64 (Int.unsigned v1 + Z.shiftl (Int.unsigned v2) 32))
            | _, _ => None
          end
        else None
      | _ => None
    end.

  Function vmx_writez64_spec (i : Z) (value: Z64) (adt: RData): option RData :=
    match (ikern adt, pg adt, ihost adt) with
      | (true, true, true) =>
        if zle_lt 0 i VMX_Size' then
          let d := ZMap.set i (Vint (Int.repr (Z642Z value))) (vmx adt) in
          let d1 := ZMap.set (i + 1) (Vint (Int.repr (Z.shiftr (Z642Z value) 32))) d in
          Some adt {vmx: d1}
        else None
      | _ => None
    end.

  (* Asm Prim *)
  Function vmx_read_spec (i: Z) (adt: RData): (option val) :=
    match (ikern adt, pg adt, ihost adt) with
      | (true, true, true) =>
        if zle_le 0 i VMX_Size' then
          Some (ZMap.get i (vmx adt))
        else None
      | _ => None
    end.

  (* Asm Prim *)
  Function vmx_write_spec (i: Z) (value: val) (adt: RData): option RData :=
    match (ikern adt, pg adt, ihost adt) with
      | (true, true, true) =>
        if zle_le 0 i VMX_Size' then
          Some adt {vmx: ZMap.set i value (vmx adt)}
        else None
      | _ => None
    end.    *)

(*
unsigned int
vmx_get_reg(unsigned int reg)
{
    unsigned int val;

	switch (reg) {
	case GUEST_EAX:
		val = (uint32_t) vmx.g_rax;
		break;
	case GUEST_EBX:
		val = (uint32_t) vmx.g_rbx;
		break;
	case GUEST_ECX:
		val = (uint32_t) vmx.g_rcx;
		break;
	case GUEST_EDX:
		val = (uint32_t) vmx.g_rdx;
		break;
	case GUEST_ESI:
		val = (uint32_t) vmx.g_rsi;
		break;
	case GUEST_EDI:
		val = (uint32_t) vmx.g_rdi;
		break;
	case GUEST_EBP:
		val = (uint32_t) vmx.g_rbp;
		break;
	case GUEST_ESP:
		val = vmcs_read32(VMCS_GUEST_RSP);
		break;
	case GUEST_EIP:
		val = (uint32_t) vmx.g_rip;
		break;
	case GUEST_EFLAGS:
		val = vmcs_read32(VMCS_GUEST_RFLAGS);
		break;
	case GUEST_CR0:
		val = vmcs_read32(VMCS_GUEST_CR0);
		break;
	case GUEST_CR2:
		val = (uint32_t) vmx.g_cr2;
		break;
	case GUEST_CR3:
		val = vmcs_read32(VMCS_GUEST_CR3);
		break;
	case GUEST_CR4:
		val = vmcs_read32(VMCS_GUEST_CR4);
		break;
	default:
        break;
	}

	return val;
}
*)

  Inductive reg_type:=
    | TVMCS (z: Z)
    | TVMX (z: Z).

  Function Z2reg_type (reg: Z) :=
    match reg with
      | C_GUEST_EAX => Some (TVMX VMX_G_RAX')
      | C_GUEST_EBX => Some (TVMX VMX_G_RBX')
      | C_GUEST_ECX => Some (TVMX VMX_G_RCX')
      | C_GUEST_EDX => Some (TVMX VMX_G_RDX')
      | C_GUEST_ESI => Some (TVMX VMX_G_RSI')
      | C_GUEST_EDI => Some (TVMX VMX_G_RDI')
      | C_GUEST_CR2 => Some (TVMX VMX_G_CR2')
      | C_GUEST_EBP => Some (TVMX VMX_G_RBP')
      | C_GUEST_EIP => Some (TVMX VMX_G_RIP')
      (* get from vmcs *)
      | C_GUEST_ESP => Some (TVMCS C_VMCS_GUEST_RSP)
      | C_GUEST_EFLAGS => Some (TVMCS C_VMCS_GUEST_RFLAGS)
      | C_GUEST_CR0 => Some (TVMCS C_VMCS_GUEST_CR0)
      | C_GUEST_CR3 => Some (TVMCS C_VMCS_GUEST_CR3)
      | C_GUEST_CR4 => Some (TVMCS C_VMCS_GUEST_CR4)
      | _ => None
    end.

  Function vmx_get_reg_spec (reg: Z) (adt: RData) : option Z :=
    match (ikern adt, pg adt, ihost adt) with
    | (true, true, true) =>
      match Z2reg_type reg with
        | Some (TVMX z) =>
          match ZMap.get z (vmx adt) with
            | Vint v => Some (Int.unsigned v)
            | _ => None
          end
        | Some (TVMCS z) =>
          match vmcs adt with
            | VMCSValid revid abrtid d =>
             match ZMap.get z d with
               | Vint v => Some (Int.unsigned v)
               | _ => None
             end
          end
        | _ => None
      end
    | _ => None
    end.

(*
void
vmx_set_reg(unsigned int reg, unsigned val)
{
	switch (reg) {
	case GUEST_EAX:
		vmx.g_rax = val;
		break;
	case GUEST_EBX:
		vmx.g_rbx = val;
		break;
	case GUEST_ECX:
		vmx.g_rcx = val;
		break;
	case GUEST_EDX:
		vmx.g_rdx = val;
		break;
	case GUEST_ESI:
		vmx.g_rsi = val;
		break;
	case GUEST_EDI:
		vmx.g_rdi = val;
		break;
	case GUEST_EBP:
		vmx.g_rbp = val;
		break;
	case GUEST_ESP:
		vmcs_write32(VMCS_GUEST_RSP, val);
		break;
	case GUEST_EIP:
		vmx.g_rip = val;
		break;
	case GUEST_EFLAGS:
		vmcs_write32(VMCS_GUEST_RFLAGS, val);
		break;
	case GUEST_CR0:
		vmcs_write32(VMCS_GUEST_CR0, val);
		break;
	case GUEST_CR2:
		vmx.g_cr2 = val;
		break;
	case GUEST_CR3:
		vmcs_write32(VMCS_GUEST_CR3, val);
		break;
	case GUEST_CR4:
		vmcs_write32(VMCS_GUEST_CR4, val);
		break;
	default:
        break;
	}
}
 *)

  Function vmx_set_reg_spec (reg v: Z) (adt: RData): option RData :=
    match (ikern adt, pg adt, ihost adt) with
      | (true, true, true) =>
        match Z2reg_type reg with
          | Some (TVMX z) => Some adt {vmx: ZMap.set z (Vint (Int.repr v)) (vmx adt)}
          | Some (TVMCS z) =>
            match vmcs adt with
              | VMCSValid revid abrtid d =>
                Some adt {vmcs: VMCSValid revid abrtid (ZMap.set z (Vint (Int.repr v)) d)}
            end
          | _ => None
        end
      | _ => None
    end.

(*
unsigned int
vmx_get_next_eip()
{
	return vmx.g_rip + vmcs_read32(VMCS_EXIT_ITRUCTION_LENGTH);
}
 *)

  Function vmx_get_next_eip_spec (adt: RData) : option Z :=
    match (ikern adt, pg adt, ihost adt) with
      | (true, true, true) =>
        match vmcs adt with
          | VMCSValid revid abrtid d =>
            match ZMap.get VMX_G_RIP' (vmx adt) with
              | Vint v1 =>
                match ZMap.get C_VMCS_EXIT_INSTRUCTION_LENGTH d with
                  | Vint v2 => Some (Int.unsigned v1 + Int.unsigned v2)
                  | _ => None
                end
              | _ => None
            end
        end
      | _ => None
    end.

(*
#define EXIT_QUAL_IO_SIZE(q)	((q) & 7)
# define EXIT_QUAL_IO_ONE_BYTE	0
# define EXIT_QUAL_IO_TWO_BYTE	1
# define EXIT_QUAL_IO_FOUR_BYTE	3

unsigned int
vmx_get_exit_io_width(void)
{
    unsigned int width;

    if (EXIT_QUAL_IO_SIZE(vmx.exit_qualification) == EXIT_QUAL_IO_ONE_BYTE)
        width = SZ8;
    else if (EXIT_QUAL_IO_SIZE(vmx.exit_qualification) == EXIT_QUAL_IO_TWO_BYTE)
        width = SZ16;
    else
        width = SZ32;

    return width;
}
 *)

  Function vmx_get_io_width_spec (adt: RData): option Z :=
    match (ikern adt, pg adt, ihost adt) with
    | (true, true, true) =>
      match ZMap.get VMX_EXIT_QUALIFICATION' (vmx adt) with
        | Vint v =>
          let qsize := Z.land (Int.unsigned v) EXIT_QUAL_IO_SIZE in
          if zeq qsize EXIT_QUAL_IO_ONE_BYTE then Some SZ8
          else if zeq qsize EXIT_QUAL_IO_TWO_BYTE then Some SZ16
               else Some SZ32
        |_ => None
      end
    | _ => None
    end.

(*
#define EXIT_QUAL_IO_DIR(q)	(((q) >> 3) & 1)
# define EXIT_QUAL_IO_OUT	0
# define EXIT_QUAL_IO_IN	1

unsigned int
vmx_get_exit_io_write(void)
{
    unsigned int write;

    if (EXIT_QUAL_IO_DIR(vmx.exit_qualification) == EXIT_QUAL_IO_IN)
        write = 0;
    else
        write = 1;

    return write;
}
 *)

  Function vmx_get_io_write_spec (adt: RData): option Z :=
    match (ikern adt, pg adt, ihost adt) with
      | (true, true, true) =>
        match ZMap.get VMX_EXIT_QUALIFICATION' (vmx adt) with
          | Vint v =>
            let qdir :=  (Z.land (Z.shiftr (Int.unsigned v) EXIT_QUAL_IO_DIR) 1) in
            if zeq qdir EXIT_QUAL_IO_IN then Some 0
            else Some 1
          |_ => None
        end
      | _ => None
    end.

(*
#define EXIT_QUAL_IO_REP(q)	(((q) >> 5) & 1)

unsigned int
vmx_get_exit_io_rep(void)
{
    return EXIT_QUAL_IO_REP(vmx.exit_qualification) ? 1 : 0;
}
 *)

  Function vmx_get_exit_io_rep_spec (adt: RData): option Z :=
    match (ikern adt, pg adt, ihost adt) with
      | (true, true, true) =>
        match ZMap.get VMX_EXIT_QUALIFICATION' (vmx adt) with
          | Vint v =>
            let qrep := Z.land (Z.shiftr (Int.unsigned v) EXIT_QUAL_IO_REP) 1 in
            Some qrep
          |_ => None
        end
      | _ => None
    end.

  (*
#define EXIT_QUAL_IO_STR(q)	(((q) >> 4) & 1)

unsigned int
vmx_get_exit_io_str(void)
{
    return EXIT_QUAL_IO_STR(vmx.exit_qualification) ? 1 : 0;
}
   *)

  Function vmx_get_exit_io_str_spec (adt: RData): option Z :=
    match (ikern adt, pg adt, ihost adt) with
      | (true, true, true) =>
        match ZMap.get VMX_EXIT_QUALIFICATION' (vmx adt) with
          | Vint v =>
            let qrep := Z.land (Z.shiftr (Int.unsigned v) EXIT_QUAL_IO_STR) 1 in
            Some qrep
          |_ => None
        end
      | _ => None
    end.

(*
unsigned int
vmx_get_exit_io_port(void)
{
    return EXIT_QUAL_IO_PORT(vmx.exit_qualification);
}

#define EXIT_QUAL_IO_PORT(q)	((uint16_t) (((q) >> 16) & 0xffff))
 *)

  Function vmx_get_exit_io_port_spec (adt: RData) :=
    match (ikern adt, pg adt, ihost adt) with
      | (true, true, true) =>
        match ZMap.get VMX_EXIT_QUALIFICATION' (vmx adt) with
          | Vint v =>
            Some ((Int.unsigned v) / C_EXIT_QUAL_IO_PORT)
          | _ => None
        end
      | _ => None
    end.

(*
void
vmx_set_mmap(unsigned int gpa, unsigned int hpa, unsigned int mem_type)
{
	int rc = 0;

	rc = ept_add_mapping(gpa, hpa, mem_type);

	if (rc) {
		KERN_DEBUG("EPT_add mapping error : ept@0x%x, gpa:0x%x, "
			   "hpa:0x%llx\n", vmx.pml4ept, gpa, hpa);
                return rc;
	} else {
		return ept_invalidate_mappings((uint64_t)(uintptr_t) vmx.pml4ept);
	}
}

IMPORTANT: this function has to call ept_invalidate_mappings(),
But the semantics is empty!!!!!!!!!!!!!!!!!!!!!!
 *)
  Function vmx_set_mmap_spec (gpa : Z)  (hpa : Z) (mem_type: Z) (adt: RData) :=
    match ept_add_mapping_spec gpa hpa mem_type adt with
      | Some (adt', res) =>
        if zle_le 0 res Int.max_unsigned then
          if zle_lt 0 mem_type 4096 then
            if zeq res 0 then
              match ept_invalidate_mappings_spec adt' with
                | Some z => Some (adt', z)
                | _ => None
              end
            else Some (adt', res)
          else None
        else None
      | _ => None
    end.

  (*
FIXME: ECX
vmx_enter:

             "pushl %%ebp;"
             "pushl %%edi;"

/*should be able to remove

             /* save the address of vmx on the stack */
             "pushl %%ecx;"         /* placeholder */
             "pushl %%ecx;"         /* address of vmx */
             "movl %1, %%edi;"
             "vmwrite %%esp, %%edi;"
             /* save entry TSC */
             "pushl %%ecx;"
             "rdtscp;"
             "popl %%ecx;"
             "movl %%eax, %c[enter_tsc_lo](%0);"
             "movl %%edx, %c[enter_tsc_hi](%0);"
*/

             /* load guest registers */
             "movl %c[g_cr2](%0), %%edi;"   /* guest %cr2 */
             "movl %%edi, %%cr2;"
             "movl %c[g_dr0](%0), %%edi;"   /* guest %dr0 */
             "movl %%edi, %%dr0;"
             "movl %c[g_dr1](%0), %%edi;"   /* guest %dr1 */
             "movl %%edi, %%dr1;"
             "movl %c[g_dr2](%0), %%edi;"   /* guest %dr2 */
             "movl %%edi, %%dr2;"
             "movl %c[g_dr3](%0), %%edi;"   /* guest %dr3 */
             "movl %%edi, %%dr3;"
             "movl %c[g_dr6](%0), %%edi;"   /* guest %dr6 */
             /* "movl %%edi, %%dr6;" */
             "movl %c[g_rax](%0), %%eax;"   /* guest %eax */
             "movl %c[g_rbx](%0), %%ebx;"   /* guest %ebx */
             "movl %c[g_rdx](%0), %%edx;"   /* guest %edx */
             "movl %c[g_rsi](%0), %%esi;"   /* guest %esi */
             "movl %c[g_rdi](%0), %%edi;"   /* guest %edi */
             "movl %c[g_rbp](%0), %%ebp;"   /* guest %ebp */

*)

  Definition vmx_enter_spec (rs: regset) (adt: RData) : option (RData * regset) :=
    match (ikern adt, ihost adt, pg adt, init adt) with
      | (true, true, true, true) =>
        let vvmx := vmx adt in
        let rs' := (Pregmap.init Vundef)
                     # EAX <- (ZMap.get VMX_G_RAX' vvmx) # EBX <- (ZMap.get VMX_G_RBX' vvmx)
                     # EDX <- (ZMap.get VMX_G_RDX' vvmx) # ESI <- (ZMap.get VMX_G_RSI' vvmx)
                     # EDI <- (ZMap.get VMX_G_RDI' vvmx) # EBP <- (ZMap.get VMX_G_RBP' vvmx)
                     # RA <- (ZMap.get VMX_G_RIP' vvmx) in
        let vvmx1 := ZMap.set VMX_HOST_EBP' (rs EBP) vvmx in
        let vvmx2 := ZMap.set VMX_HOST_EDI' (rs EDI) vvmx1 in
        Some (adt {vmx: vvmx2}{ihost: false}, rs')
      | _ => None
    end.

(*
void vmx_enter_pre () {
    vmcs_write32(VMCS_GUEST_RIP, vmx.g_rip);
}
*)

  Function vmx_enter_pre_spec (adt: RData) : option RData :=
    match (ikern adt, pg adt, ihost adt, init adt) with
      | (true, true, true, true) =>
        match vmcs adt with
          | VMCSValid revid abrtid d =>
            match ZMap.get VMX_G_RIP' (vmx adt) with
              | Vint v =>
                let d' := ZMap.set C_VMCS_GUEST_RIP (Vint v) d in
                Some (adt {vmcs: VMCSValid revid abrtid d'})
              | _ => None
            end
        end
      | _ => None
    end.

(* vm_run:
    vmptrld(vmx.vmcs);
    jump vmx_enter_pre;
    jump vmx_enter;
    jump hostout;
*)

  Definition vm_run_spec (rs: regset) (adt: RData) : option (RData * regset) :=
    match (ikern adt, pg adt, ihost adt, init adt) with
      | (true, true, true, true) =>
        match vmcs adt with
          | VMCSValid revid abrtid d =>
            match ZMap.get VMX_G_RIP' (vmx adt) with
              | Vint v =>
                let d' := ZMap.set C_VMCS_GUEST_RIP (Vint v) d in
                let vvmx := vmx adt in
                let rs' := (Pregmap.init Vundef)
                             # EAX <- (ZMap.get VMX_G_RAX' vvmx) # EBX <- (ZMap.get VMX_G_RBX' vvmx)
                             # EDX <- (ZMap.get VMX_G_RDX' vvmx) # ESI <- (ZMap.get VMX_G_RSI' vvmx)
                             # EDI <- (ZMap.get VMX_G_RDI' vvmx) # EBP <- (ZMap.get VMX_G_RBP' vvmx)
                             # RA <- (ZMap.get VMX_G_RIP' vvmx) in
                let vvmx1 := ZMap.set VMX_HOST_EBP' (rs EBP) vvmx in
                let vvmx2 := ZMap.set VMX_HOST_EDI' (rs EDI) vvmx1 in
                Some (adt {vmx: vvmx2} {vmcs: VMCSValid revid abrtid d'} {ihost: false}, rs')
              | _ => None
            end
        end
      | _ => None
    end.

(*
FIXME: ecx

vmx_exit:

             "movl %%edi, %c[g_rdi](%0);"   /* guest %edi */
             "movl %%cr2, %%edi;"       /* guest %cr2 */
             "movl %%edi, %c[g_cr2](%0);"
             "movl %%dr0, %%edi;"       /* guest %dr0 */
             "movl %%edi, %c[g_dr0](%0);"
             "movl %%dr1, %%edi;"       /* guest %dr1 */
             "movl %%edi, %c[g_dr1](%0);"
             "movl %%dr2, %%edi;"       /* guest %dr2 */
             "movl %%edi, %c[g_dr1](%0);"
             "movl %%dr3, %%edi;"       /* guest %dr3 */
             "movl %%edi, %c[g_dr3](%0);"
             "movl %%dr6, %%edi;"       /* guest %dr6 */
             "movl %%edi, %c[g_dr6](%0);"
             "movl %%eax, %c[g_rax](%0);"   /* guest %eax */
             "movl %%ebx, %c[g_rbx](%0);"   /* guest %ebx */
             "popl %%edi;"          /* guest %ecx */
             "movl %%edi, %c[g_rcx](%0);"
             "movl %%edx, %c[g_rdx](%0);"   /* guest %edx */
             "movl %%esi, %c[g_rsi](%0);"   /* guest %esi */
             "movl %%ebp, %c[g_rbp](%0);"   /* guest %ebp */

/* should be removed

             /* save exit TSC */
             "pushl %%ecx;"
             "rdtscp;"
             "popl %%ecx;"
             "movl %%eax, %c[exit_tsc_lo](%0);"
             "movl %%edx, %c[exit_tsc_hi](%0);"
*/

             /* load host registers */
             "popl %%edi;"
             "popl %%ebp;"
*)

  Definition vmx_exit_spec (rs: regset) (adt: RData) : option (RData * regset) :=
    match (ikern adt, ihost adt, pg adt, init adt) with
      | (true, true, true, true) =>
        let vvmx := vmx adt in
        let vvmx1 := ZMap.set VMX_G_RDI' (rs EDI) vvmx in
        let vvmx2 := ZMap.set VMX_G_RAX' (rs EAX) vvmx1 in
        let vvmx3 := ZMap.set VMX_G_RBX' (rs EBX) vvmx2 in
        (*let vvmx4 := ZMap.set VMX_G_RCX' (rs ECX) vvmx3 in*)
        let vvmx5 := ZMap.set VMX_G_RDX' (rs EDX) vvmx3 in
        let vvmx6 := ZMap.set VMX_G_RSI' (rs ESI) vvmx5 in
        let vvmx7 := ZMap.set VMX_G_RBP' (rs EBP) vvmx6 in

        let rs' := (Pregmap.init Vundef)
                     # EDI <- (ZMap.get VMX_HOST_EDI' vvmx) # EBP <- (ZMap.get VMX_HOST_EBP' vvmx) in
        Some (adt {vmx: vvmx7}, rs')
      | _ => None
    end.

(*

void vmx_exit_post (){
   vmx.g_rip = vmcs_read32(VMCS_GUEST_RIP);
   vmx.exit_reason = vmcs_read32(VMCS_EXIT_REASON);
   vmx.exit_qualification = vmcs_read32(VMCS_EXIT_QUALIFICATION);
   vmx.launched = 1;
}
*)

  Function vmx_exit_post_spec (adt: RData) : option RData :=
    match (ikern adt, pg adt, ihost adt) with
      | (true, true, true) =>
        match vmcs adt with
          | VMCSValid revid abrtid d =>
            let vvmx := vmx adt in
            match ZMap.get C_VMCS_GUEST_RIP d, ZMap.get C_VMCS_EXIT_REASON d,
                  ZMap.get C_VMCS_EXIT_QUALIFICATION d with
              | Vint v1, Vint v2, Vint v3 =>
                let vvmx1 := ZMap.set VMX_G_RIP' (Vint v1) vvmx in
                let vvmx2 := ZMap.set VMX_EXIT_REASON' (Vint v2) vvmx1 in
                let vvmx3 := ZMap.set VMX_EXIT_QUALIFICATION' (Vint v3) vvmx2 in
                let vvmx4 := ZMap.set VMX_LAUNCHED' Vone vvmx3 in
                Some (adt {vmx: vvmx4})
              | _,_,_ => None
            end
        end
      | _ => None
    end.

(*

vmx_return_from_guest:
   hostin;
   call vmx_exit;
   call vmx_exit_post_spec;
*)

  Definition vmx_return_from_guest_spec (rs: regset) (adt: RData) : option (RData * regset) :=
    match (ikern adt, pg adt, ihost adt, init adt) with
      | (true, true, false, true) =>
        match vmcs adt with
          | VMCSValid revid abrtid d =>
            let vvmx := vmx adt in
            let vvmx1 := ZMap.set VMX_G_RDI' (rs EDI) vvmx in
            let vvmx2 := ZMap.set VMX_G_RAX' (rs EAX) vvmx1 in
            let vvmx3 := ZMap.set VMX_G_RBX' (rs EBX) vvmx2 in
            (*let vvmx4 := ZMap.set VMX_G_RCX' (rs ECX) vvmx3 in*)
            let vvmx5 := ZMap.set VMX_G_RDX' (rs EDX) vvmx3 in
            let vvmx6 := ZMap.set VMX_G_RSI' (rs ESI) vvmx5 in
            let vvmx7 := ZMap.set VMX_G_RBP' (rs EBP) vvmx6 in
            match ZMap.get C_VMCS_GUEST_RIP d, ZMap.get C_VMCS_EXIT_REASON d,
                  ZMap.get C_VMCS_EXIT_QUALIFICATION d with
              | Vint v1, Vint v2, Vint v3 =>
                let vvmx8 := ZMap.set VMX_G_RIP' (Vint v1) vvmx7 in
                let vvmx9 := ZMap.set VMX_EXIT_REASON' (Vint v2) vvmx8 in
                let vvmx10 := ZMap.set VMX_EXIT_QUALIFICATION' (Vint v3) vvmx9 in
                let vvmx11 := ZMap.set VMX_LAUNCHED' Vone vvmx10 in
                let rs' := (Pregmap.init Vundef)
                             # EDI <- (ZMap.get VMX_HOST_EDI' vvmx) # EBP <- (ZMap.get VMX_HOST_EBP' vvmx) in
                Some (adt {vmx: vvmx11} {ihost: true}, rs')
              | _,_,_ => None
            end
        end
      | _ => None
    end.

(*
FIXME: identifier

void
vmx_init(unsigned int mbi_addr)
{
    int rw;
    vmcs_set_defaults (mbi_addr);
    // What is this???? Why not using vmcs_write()?????
    vmx.vmcs->identifier = rdmsr(MSR_VMX_BASIC) & 0xffffffff;

    vmx.g_rip = 0xfff0;
    vmx.vpid = 1;
    vmx.g_cr2 = 0;
    vmx.g_dr0 = vmx.g_dr1 = vmx.g_dr2 = vmx.g_dr3 = 0;
    vmx.g_dr6 = 0xffff0ff0;

}
 *)

  Function vmx_init_spec (mbi_adr:Z)
           (pml4ept_b tss_b gdt_b idt_b msr_bitmap_b io_bitmap_b host_rip_b: block)
           (adt: RData) : option RData :=
    match (init adt, pg adt, ikern adt, ihost adt, ipt adt) with
      | (false, false, true, true, true) =>
        Some adt {vmxinfo: real_vmxinfo} {pg: true} {LAT: real_LAT (LAT adt)} {nps: real_nps}
             {AC: real_AC} {init: true} {PT: 0} {ptpool: real_pt (ptpool adt)}
             {idpde: real_idpde (idpde adt)}
             {smspool: real_smspool (smspool adt)}
             {abtcb: ZMap.set 0 (AbTCBValid RUN (-1)) (real_abtcb (abtcb adt))}
             {abq: real_abq (abq adt)} {cid: 0} {syncchpool: real_syncchpool (syncchpool adt)}
             {ept: real_ept (ept adt)}
             {vmcs: real_vmcs (vmcs adt) real_vmxinfo
                              pml4ept_b tss_b gdt_b idt_b msr_bitmap_b io_bitmap_b host_rip_b}
             {vmx: real_vmx (vmx adt)}
      | _ => None
    end.

End OBJ_VMX.

Require Import liblayers.compat.CompatGenSem.
Require Import liblayers.compat.CompatLayers.
Require Import CommonTactic.
Require Import RefinementTactic.
Require Import PrimSemantics.
Require Import IntelPrimSemantics.
Require Import AuxLemma.

Section OBJ_SIM.

  Context `{data : CompatData RData}.
  Context `{data0 : CompatData RData}.

  Context `{Hstencil: Stencil}.
  Context `{Hmem: Mem.MemoryModel}.
  Context `{Hmwd: UseMemWithData mem}.

  Notation HDATAOps := (cdata (cdata_prf := data) RData).
  Notation LDATAOps := (cdata (cdata_prf := data0) RData).

  Context `{rel_prf: CompatRel _ (memory_model_ops:= memory_model_ops) _
                               (stencil_ops:= stencil_ops) HDATAOps LDATAOps}.

  Lemma val_inject_vint_eq:
    forall f n v v' i,
      val_inject f (ZMap.get n v) (ZMap.get n v')
      -> ZMap.get n v = Vint i
      -> ZMap.get n v' = Vint i.
  Proof.
    intros.
    rewrite H0 in H; inversion H; reflexivity.
  Qed.

  Section VMX_GET_REG_SIM.

    Context {re1: relate_impl_iflags}.
    Context {re2: relate_impl_vmx}.
    Context {re3: relate_impl_vmcs}.

    Lemma vmx_get_reg_exist:
      forall s habd labd reg v f,
        vmx_get_reg_spec reg habd = Some v
        -> relate_AbData s f habd labd
        -> vmx_get_reg_spec reg labd = Some v.
    Proof.
      unfold vmx_get_reg_spec in *. intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_vmx_eq; eauto. inversion 1; subst.
      exploit relate_impl_vmcs_eq; eauto. intros.
      revert H. inversion H4. subrewrite.
      subdestruct; erewrite val_inject_vint_eq; eauto.
    Qed.

    Lemma vmx_get_reg_sim:
      forall id,
        sim (crel RData RData) (id ↦ gensem vmx_get_reg_spec)
            (id ↦ gensem vmx_get_reg_spec).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl (@match_AbData). intros.
      match_external_states_simpl.
      eapply vmx_get_reg_exist in H2; eauto.
      rewrite H2; reflexivity.
    Qed.

  End VMX_GET_REG_SIM.

  Section VMX_SET_REG_SIM.

    Context {re1: relate_impl_iflags}.
    Context {re2: relate_impl_vmx}.
    Context {re3: relate_impl_vmcs}.

    Lemma vmx_set_reg_exist:
      forall s habd habd' labd reg v f,
        vmx_set_reg_spec reg v habd = Some habd'
        -> relate_AbData s f habd labd
        -> exists labd', vmx_set_reg_spec reg v labd = Some labd'
                         /\ relate_AbData s f habd' labd'.
    Proof.
      unfold vmx_set_reg_spec; intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_vmx_eq; eauto. inversion 1; subst.
      exploit relate_impl_vmcs_eq; eauto. intros.
      revert H. inversion H4. subrewrite.
      subdestruct; inv HQ; refine_split'; trivial.

      - apply relate_impl_vmcs_update; try assumption.
        apply VMCS_inj_set_int.
        rewrite H, H6; assumption.
      - apply relate_impl_vmx_update; try assumption.
        apply VMX_inj_set_int; auto.
    Qed.

    Context {mt1: match_impl_iflags}.
    Context {mt2: match_impl_vmx}.
    Context {mt3: match_impl_vmcs}.

    Lemma vmx_set_reg_match:
      forall s d d' m reg v f,
        vmx_set_reg_spec reg v d = Some d'
        -> match_AbData s d m f
        -> match_AbData s d' m f.
    Proof.
      unfold vmx_set_reg_spec; intros. subdestruct; inv H; trivial;
        [ eapply match_impl_vmcs_update
        | eapply match_impl_vmx_update ];
        assumption.
    Qed.

    Context {inv: PreservesInvariants (HD:= data) vmx_set_reg_spec}.
    Context {inv0: PreservesInvariants (HD:= data0) vmx_set_reg_spec}.

    Lemma vmx_set_reg_sim :
      forall id,
        sim (crel RData RData) (id ↦ gensem vmx_set_reg_spec)
            (id ↦ gensem vmx_set_reg_spec).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl (@match_AbData). intros.
      exploit vmx_set_reg_exist; eauto 1; intros [labd' [HP HM]].
      match_external_states_simpl.
      eapply vmx_set_reg_match; eauto.
    Qed.

  End VMX_SET_REG_SIM.

  Section VMX_GET_NEXT_EIP_SIM.

    Context {re1: relate_impl_iflags}.
    Context {re2: relate_impl_vmx}.
    Context {re3: relate_impl_vmcs}.

    Lemma vmx_get_next_eip_exist:
      forall s habd labd v f,
        vmx_get_next_eip_spec habd = Some v
        -> relate_AbData s f habd labd
        -> vmx_get_next_eip_spec labd = Some v.
    Proof.
      unfold vmx_get_next_eip_spec in *. intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_vmx_eq; eauto. inversion 1; subst.
      exploit relate_impl_vmcs_eq; eauto. intros.
      revert H. inversion H4. subrewrite. subdestruct.
      erewrite 2 val_inject_vint_eq; eauto.
    Qed.

    Lemma vmx_get_next_eip_sim:
      forall id,
        sim (crel RData RData) (id ↦ gensem vmx_get_next_eip_spec)
            (id ↦ gensem vmx_get_next_eip_spec).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl (@match_AbData). intros.
      match_external_states_simpl.
      eapply vmx_get_next_eip_exist in H2; eauto.
      rewrite H2; reflexivity.
    Qed.

  End VMX_GET_NEXT_EIP_SIM.

  Section VMX_GET_IO_WIDTH_SIM.

    Context {re1: relate_impl_iflags}.
    Context {re2: relate_impl_vmx}.

    Lemma vmx_get_io_width_exist:
      forall s habd labd v f,
        vmx_get_io_width_spec habd = Some v
        -> relate_AbData s f habd labd
        -> vmx_get_io_width_spec labd = Some v.
    Proof.
      Local Opaque Z.land.

      unfold vmx_get_io_width_spec in *. intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_vmx_eq; eauto. inversion 1; subst.
      revert H. subrewrite.

      (* Manually unfold to delimit subdestruct until the [ZMap.get], whose
         argument [vmx habd] couldn't be changed to [vmx labd] mismatching
         that in the goal. *)
      destruct (ikern labd) eqn:Hdestruct; contra_inv;
      destruct (pg labd) eqn:Hdestruct1; contra_inv;
      destruct (ihost labd) eqn:Hdestruct2; contra_inv;
      destruct (ZMap.get 28%Z (vmx habd)) eqn:Hdestruct3; contra_inv.
      erewrite val_inject_vint_eq; eauto.
    Qed.

    Lemma vmx_get_io_width_sim:
      forall id,
        sim (crel RData RData) (id ↦ gensem vmx_get_io_width_spec)
            (id ↦ gensem vmx_get_io_width_spec).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl (@match_AbData). intros.
      match_external_states_simpl.
      eapply vmx_get_io_width_exist in H2; eauto.
      rewrite H2; reflexivity.
    Qed.

  End VMX_GET_IO_WIDTH_SIM.

  Section VMX_GET_IO_WRITE_SIM.

    Context {re1: relate_impl_iflags}.
    Context {re2: relate_impl_vmx}.

    Lemma vmx_get_io_write_exist:
      forall s habd labd v f,
        vmx_get_io_write_spec habd = Some v
        -> relate_AbData s f habd labd
        -> vmx_get_io_write_spec labd = Some v.
    Proof.
      Local Opaque Z.shiftr.

      unfold vmx_get_io_write_spec in *. intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_vmx_eq; eauto. inversion 1; subst.
      revert H. subrewrite.

      (* Manually unfold to delimit subdestruct until the [ZMap.get], whose
         argument [vmx habd] couldn't be changed to [vmx labd] mismatching
         that in the goal. *)
      destruct (ikern labd) eqn:Hdestruct; contra_inv;
      destruct (pg labd) eqn:Hdestruct1; contra_inv;
      destruct (ihost labd) eqn:Hdestruct2; contra_inv;
      destruct (ZMap.get 28%Z (vmx habd)) eqn:Hdestruct3; contra_inv.
      erewrite val_inject_vint_eq; eauto.
    Qed.

    Lemma vmx_get_io_write_sim:
      forall id,
        sim (crel RData RData) (id ↦ gensem vmx_get_io_write_spec)
            (id ↦ gensem vmx_get_io_write_spec).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl (@match_AbData). intros.
      match_external_states_simpl.
      eapply vmx_get_io_write_exist in H2; eauto.
      rewrite H2; reflexivity.
    Qed.

  End VMX_GET_IO_WRITE_SIM.

  Section VMX_GET_EXIT_IO_REP_SIM.

    Context {re1: relate_impl_iflags}.
    Context {re2: relate_impl_vmx}.

    Lemma vmx_get_exit_io_rep_exist:
      forall s habd labd v f,
        vmx_get_exit_io_rep_spec habd = Some v
        -> relate_AbData s f habd labd
        -> vmx_get_exit_io_rep_spec labd = Some v.
    Proof.
      Local Opaque Z.land Z.shiftr.

      unfold vmx_get_exit_io_rep_spec in *. intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_vmx_eq; eauto. inversion 1; subst.
      revert H. subrewrite. subdestruct.
      erewrite val_inject_vint_eq; eauto.
    Qed.

    Lemma vmx_get_exit_io_rep_sim:
      forall id,
        sim (crel RData RData) (id ↦ gensem vmx_get_exit_io_rep_spec)
            (id ↦ gensem vmx_get_exit_io_rep_spec).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl (@match_AbData). intros.
      match_external_states_simpl.
      eapply vmx_get_exit_io_rep_exist in H2; eauto.
      rewrite H2; reflexivity.
    Qed.

  End VMX_GET_EXIT_IO_REP_SIM.

  Section VMX_GET_EXIT_IO_STR_SIM.

    Context {re1: relate_impl_iflags}.
    Context {re2: relate_impl_vmx}.

    Lemma vmx_get_exit_io_str_exist:
      forall s habd labd v f,
        vmx_get_exit_io_str_spec habd = Some v
        -> relate_AbData s f habd labd
        -> vmx_get_exit_io_str_spec labd = Some v.
    Proof.
      Local Opaque Z.land Z.shiftr.

      unfold vmx_get_exit_io_str_spec in *. intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_vmx_eq; eauto. inversion 1; subst.
      revert H. subrewrite. subdestruct.
      erewrite val_inject_vint_eq; eauto.
    Qed.

    Lemma vmx_get_exit_io_str_sim:
      forall id,
        sim (crel RData RData) (id ↦ gensem vmx_get_exit_io_str_spec)
            (id ↦ gensem vmx_get_exit_io_str_spec).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl (@match_AbData). intros.
      match_external_states_simpl.
      eapply vmx_get_exit_io_str_exist in H2; eauto.
      rewrite H2; reflexivity.
    Qed.

  End VMX_GET_EXIT_IO_STR_SIM.

  Section VMX_GET_EXIT_IO_PORT_SIM.

    Context {re1: relate_impl_iflags}.
    Context {re2: relate_impl_vmx}.

    Lemma vmx_get_exit_io_port_exist:
      forall s habd labd v f,
        vmx_get_exit_io_port_spec habd = Some v
        -> relate_AbData s f habd labd
        -> vmx_get_exit_io_port_spec labd = Some v.
    Proof.
      unfold vmx_get_exit_io_port_spec in *. intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_vmx_eq; eauto. inversion 1; subst.
      revert H. subrewrite. subdestruct.
      erewrite val_inject_vint_eq; eauto.
    Qed.

    Lemma vmx_get_exit_io_port_sim:
      forall id,
        sim (crel RData RData) (id ↦ gensem vmx_get_exit_io_port_spec)
            (id ↦ gensem vmx_get_exit_io_port_spec).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl (@match_AbData). intros.
      match_external_states_simpl.
      eapply vmx_get_exit_io_port_exist in H2; eauto.
      rewrite H2; reflexivity.
    Qed.

  End VMX_GET_EXIT_IO_PORT_SIM.

  Section VMX_SET_MMAP_SIM.

    Context {re1: relate_impl_iflags}.
    Context {re2: relate_impl_ept}.

    Lemma vmx_set_mmap_exist:
      forall s habd habd' labd gpa hpa mem_type i f,
        vmx_set_mmap_spec gpa hpa mem_type habd = Some (habd', i)
        -> relate_AbData s f habd labd
        -> exists labd', vmx_set_mmap_spec gpa hpa mem_type labd = Some (labd', i)
                         /\ relate_AbData s f habd' labd'.
    Proof.
      unfold vmx_set_mmap_spec; intros.
      destruct (ept_add_mapping_spec gpa hpa mem_type habd) as [ [] |] eqn:Hdestruct; contra_inv.
      exploit ept_add_mapping_exist; eauto; intros [labd' [HP HM]].
      revert H. subrewrite.
      subdestruct; inv HQ.
      erewrite ept_invalidate_mappings_exists; eauto.
      refine_split'; trivial.
    Qed.

    Context {mt1: match_impl_iflags}.
    Context {mt2: match_impl_ept}.

    Lemma vmx_set_mmap_match:
      forall s d d' m gpa hpa mem_type i f,
        vmx_set_mmap_spec gpa hpa mem_type d = Some (d', i)
        -> match_AbData s d m f
        -> match_AbData s d' m f.
    Proof.
      unfold vmx_set_mmap_spec; intros.
      subdestruct; inv H;
      eapply ept_add_mapping_match; eauto.
    Qed.

    Context {inv: PreservesInvariants (HD:= data) vmx_set_mmap_spec}.
    Context {inv0: PreservesInvariants (HD:= data0) vmx_set_mmap_spec}.

    Lemma vmx_set_mmap_sim :
      forall id,
        sim (crel RData RData) (id ↦ gensem vmx_set_mmap_spec)
            (id ↦ gensem vmx_set_mmap_spec).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl (@match_AbData). intros.
      exploit vmx_set_mmap_exist; eauto 1; intros [labd' [HP HM]].
      match_external_states_simpl.
      eapply vmx_set_mmap_match; eauto.
    Qed.

  End VMX_SET_MMAP_SIM.

  Section VM_RUN_SIM.

    Context {re1: relate_impl_iflags}.
    Context {re2: relate_impl_vmx}.
    Context {re3: relate_impl_vmcs}.
    Context {re4: relate_impl_init}.

    Lemma vm_run_exist:
      forall s n habd habd' labd rs0 rs1 r'0 f,
        vm_run_spec rs0 habd = Some (habd', rs1)
        -> relate_AbData s f habd labd
        -> (forall r, val_inject f (Pregmap.get r rs0) (Pregmap.get r r'0))
        -> (forall r, Val.has_type (r'0#r) AST.Tint)
        -> (forall r, val_inject (Mem.flat_inj n) (r'0 r) (r'0 r))
        -> VMX_inject_neutral (vmx labd) n
        -> exists labd' r'1, vm_run_spec r'0 labd = Some (labd', r'1)
                         /\ relate_AbData s f habd' labd'
                         /\ (forall r, val_inject f (Pregmap.get r rs1) (Pregmap.get r r'1))
                         /\ (forall r, Val.has_type (r'1#r) AST.Tint)
                         /\ (forall r, val_inject (Mem.flat_inj n) (r'1 r) (r'1 r)).
    Proof.
      unfold vm_run_spec; intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_vmx_eq; eauto. inversion 1; subst.
      exploit relate_impl_vmcs_eq; eauto. intros.
      exploit relate_impl_init_eq; eauto. intros.
      revert H. inversion H8. subrewrite.
      pose proof (H7 14%Z) as HINJ.
      subdestruct. inv HINJ.
      inv HQ. refine_split'; trivial.
      - apply relate_impl_ihost_update, relate_impl_vmcs_update.
        + apply relate_impl_vmx_update; try assumption.
          apply VMX_inj_set, H1.
          apply VMX_inj_set, H1; assumption.
        + apply VMCS_inj_set.
          rewrite H, H11; assumption.
          constructor.
      - intros.
        repeat apply AsmX.set_reg_inject; auto.
      - inv H4. intros.
        destruct r0 as [| [] | [] | | [] |]; try apply H10; try constructor.
      - inv H4.
        destruct r0 as [| [] | [] | | [] |];
        try apply H3; try apply H10;
        constructor.
    Qed.

    Context {mt1: match_impl_iflags}.
    Context {mt2: match_impl_vmx}.
    Context {mt3: match_impl_vmcs}.

    Lemma vm_run_match:
      forall s d d' m rs0 rs1 f,
        vm_run_spec rs0 d = Some (d', rs1)
        -> match_AbData s d m f
        -> match_AbData s d' m f.
    Proof.
      unfold vm_run_spec; intros.
      subdestruct; inv H; trivial.
      apply match_impl_ihost_update.
      apply match_impl_vmcs_update.
      apply match_impl_vmx_update. assumption.
    Qed.

    Context {inv: VMXEnterInvariants (data_ops := data_ops) vm_run_spec}.
    Context {inv0: VMXEnterInvariants (data_ops:= data_ops0) vm_run_spec}.

    Lemma vm_run_sim :
      forall id,
        (forall n d, low_level_invariant n d -> VMX_inject_neutral (vmx d) n) ->
        sim (crel RData RData) (id ↦ primcall_vmx_enter_compatsem vm_run_spec id)
            (id ↦ primcall_vmx_enter_compatsem vm_run_spec id).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl'. intros.
      inv H1. inv H0. inv match_extcall_states.
      set (rs02 := (Pregmap.init Vundef) # EDI <- (rs2 EDI) # EBP <- (rs2 EBP)).
      assert (HR: forall reg,
                    val_inject f (Pregmap.get reg rs01) (Pregmap.get reg rs02)).
      {
        intros. subst rs01 rs02.
        val_inject_simpl.
      }
      exploit vm_run_exist; eauto 2.

      intros r; destruct r as [| [] | [] | | [] |]; try constructor;
      try apply ASM_INV.

      intros r; destruct r as [| [] | [] | | [] |]; try constructor;
      try apply ASM_INV.

      intros (labd' & r'1 & HP & HM & Hrinj' & Hrwt' & Hrinj_flat').
      refine_split; eauto 1.
      econstructor; eauto 1.
      - eapply reg_symbol_inject; eassumption.
      - eapply reg_val_inject_defined; eauto 1.
      - intros.
        specialize (match_reg ESP); unfold Pregmap.get in match_reg.
        inv match_reg; try congruence.
        specialize (HESP_STACK _ _ (eq_sym H1)).
        replace b1 with b2 by congruence.
        split.
        * apply Ple_trans with b0;
          [ apply HESP_STACK | apply (match_inject_forward _ _ _ H3) ].
        * apply (Mem.valid_block_inject_2 _ _ _ _ _ _ H3 match_inject).
      - econstructor; eauto. econstructor; eauto.
        eapply vm_run_match; eassumption.
        subst rs0.
        val_inject_simpl.
    Qed.

  End VM_RUN_SIM.

  Section VMX_RETURN_FROM_GUEST_SIM.

    Context {re1: relate_impl_iflags}.
    Context {re2: relate_impl_vmx}.
    Context {re3: relate_impl_vmcs}.
    Context {re4: relate_impl_init}.

    Lemma vmx_return_from_guest_exist:
      forall s n habd habd' labd rs0 rs1 r'0 f,
        vmx_return_from_guest_spec rs0 habd = Some (habd', rs1)
        -> relate_AbData s f habd labd
        -> (forall r, val_inject f (Pregmap.get r rs0) (Pregmap.get r r'0))
        -> (forall r, Val.has_type (r'0#r) AST.Tint)
        -> (forall r, val_inject (Mem.flat_inj n) (r'0 r) (r'0 r))
        -> VMX_inject_neutral (vmx labd) n
        -> exists labd' r'1, vmx_return_from_guest_spec r'0 labd = Some (labd', r'1)
                         /\ relate_AbData s f habd' labd'
                         /\ (forall r, val_inject f (Pregmap.get r rs1) (Pregmap.get r r'1))
                         /\ (forall r, Val.has_type (r'1#r) AST.Tint)
                         /\ (forall r, val_inject (Mem.flat_inj n) (r'1 r) (r'1 r)).
    Proof.
      unfold vmx_return_from_guest_spec; intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_vmx_eq; eauto. inversion 1; subst.
      exploit relate_impl_vmcs_eq; eauto. intros.
      exploit relate_impl_init_eq; eauto. intros.
      revert H. inversion H8. subrewrite.
      pose proof (H12 26654%Z) as Hi1.
      pose proof (H12 17410%Z) as Hi2.
      pose proof (H12 25600%Z) as Hi3.
      subdestruct.
      inv HQ. inv Hi1. inv Hi2. inv Hi3.
      refine_split'; trivial.
      - apply relate_impl_ihost_update, relate_impl_vmx_update; try assumption.
        repeat (apply VMX_inj_set_int || apply VMX_inj_set);
         solve  [ assumption | apply H1 | apply H12 ].
      - intros.
        repeat apply AsmX.set_reg_inject; auto.
      - inv H4. intros.
        destruct r0 as [| [] | [] | | [] |]; try apply H10; try constructor.
      - inv H4.
        destruct r0 as [| [] | [] | | [] |]; try apply H3; try apply H10; constructor.
    Qed.

    Context {mt1: match_impl_iflags}.
    Context {mt2: match_impl_vmx}.

    Lemma vmx_return_from_guest_match:
      forall s d d' m rs0 rs1 f,
        vmx_return_from_guest_spec rs0 d = Some (d', rs1)
        -> match_AbData s d m f
        -> match_AbData s d' m f.
    Proof.
      unfold vmx_return_from_guest_spec; intros.
      subdestruct; inv H; trivial.
      apply match_impl_ihost_update.
      apply match_impl_vmx_update. assumption.
    Qed.

    Context {inv: VMXExitInvariants (data_ops := data_ops) vmx_return_from_guest_spec}.
    Context {inv0: VMXExitInvariants (data_ops:= data_ops0) vmx_return_from_guest_spec}.

    Lemma vmx_return_from_guest_sim :
      forall id,
        (forall n d, low_level_invariant n d -> VMX_inject_neutral (vmx d) n) ->
        sim (crel RData RData) (id ↦ primcall_vmx_return_compatsem vmx_return_from_guest_spec id)
            (id ↦ primcall_vmx_return_compatsem vmx_return_from_guest_spec id).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl'. intros.
      inv H1. inv H0. inv match_extcall_states.
      set (rs02 := (Pregmap.init Vundef)
                     #EAX <- (rs2 EAX) #EBX <- (rs2 EBX)
                     #EDX <- (rs2 EDX) #EDI <- (rs2 EDI)
                     #ESI <- (rs2 ESI) #EBP <- (rs2 EBP)).
      assert (HR: forall reg,
                    val_inject f (Pregmap.get reg rs01) (Pregmap.get reg rs02)).
      {
        intros. subst rs01 rs02.
        val_inject_simpl.
      }

      exploit vmx_return_from_guest_exist; eauto 2.

      intros r; destruct r as [| [] | [] | | [] |]; try constructor;
      try apply ASM_INV.

      intros r; destruct r as [| [] | [] | | [] |]; try constructor;
      try apply ASM_INV.

      intros (labd' & r'1 & HP & HM & Hrinj' & Hrwt' & Hrinj_flat').
      refine_split; eauto 1.
      econstructor; eauto 1.
      - eapply reg_symbol_inject; eassumption.
      - eapply reg_val_inject_defined; eauto 1.
      - intros.
        specialize (match_reg ESP); unfold Pregmap.get in match_reg.
        inv match_reg; try congruence.
        specialize (HESP_STACK _ _ (eq_sym H1)).
        replace b1 with b2 by congruence.
        split.
        * apply Ple_trans with b0;
          [ apply HESP_STACK | apply (match_inject_forward _ _ _ H3) ].
        * apply (Mem.valid_block_inject_2 _ _ _ _ _ _ H3 match_inject).
      - econstructor; eauto. econstructor; eauto.
        eapply vmx_return_from_guest_match; eassumption.
        subst rs0.
        val_inject_simpl.
    Qed.

  End VMX_RETURN_FROM_GUEST_SIM.

  Section VMX_INIT_SIM.

    Context `{real_params: RealParams}.

    Context {re1: relate_impl_iflags}.
    Context {re2: relate_impl_vmx}.
    Context {re3: relate_impl_vmcs}.
    Context {re4: relate_impl_ipt}.
    Context {re5: relate_impl_LAT}.
    Context {re6: relate_impl_nps}.
    Context {re7: relate_impl_init}.
    Context {re8: relate_impl_PT}.
    Context {re9: relate_impl_ptpool}.
    Context {re10: relate_impl_idpde}.
    Context {re11: relate_impl_smspool}.
    Context {re12: relate_impl_abtcb}.
    Context {re13: relate_impl_abq}.
    Context {re14: relate_impl_cid}.
    Context {re15: relate_impl_syncchpool}.
    Context {re16: relate_impl_vmxinfo}.
    Context {re17: relate_impl_ept}.
    Context {re18: relate_impl_AC}.

    Let block_inject_neutral f b :=
      forall ofs, val_inject f (Vptr b ofs) (Vptr b ofs).

    Lemma vmx_init_exist:
      forall s habd habd' labd mbi_adr pm4ept_b tss_b gdt_b idt_b msr_bitmap_b io_bitmap_b host_rip_b f,
        vmx_init_spec mbi_adr pm4ept_b tss_b gdt_b idt_b msr_bitmap_b io_bitmap_b host_rip_b habd = Some habd'
        -> relate_AbData s f habd labd
        -> block_inject_neutral f pm4ept_b
        -> block_inject_neutral f tss_b
        -> block_inject_neutral f gdt_b
        -> block_inject_neutral f idt_b
        -> block_inject_neutral f msr_bitmap_b
        -> block_inject_neutral f io_bitmap_b
        -> block_inject_neutral f host_rip_b
        -> exists labd', vmx_init_spec mbi_adr pm4ept_b tss_b gdt_b idt_b msr_bitmap_b io_bitmap_b host_rip_b labd = Some labd'
                         /\ relate_AbData s f habd' labd'.
    Proof.
      unfold vmx_init_spec; intros.
      exploit relate_impl_iflags_eq; eauto. inversion 1.
      exploit relate_impl_ipt_eq; eauto.
      exploit relate_impl_init_eq; eauto.
      exploit relate_impl_LAT_eq; eauto.
      exploit relate_impl_ptpool_eq; eauto.
      exploit relate_impl_idpde_eq; eauto.
      exploit relate_impl_cid_eq; eauto.
      exploit relate_impl_abq_eq; eauto.
      exploit relate_impl_abtcb_eq; eauto.
      exploit relate_impl_syncchpool_eq; eauto.
      exploit relate_impl_vmxinfo_eq; eauto.
      exploit relate_impl_smspool_eq; eauto.
      exploit relate_impl_ept_eq; eauto.
      exploit relate_impl_vmx_eq; eauto.
      exploit relate_impl_vmcs_eq; eauto. intros.
      revert H. subrewrite. subdestruct.
      inv HQ. refine_split'; trivial.

      apply relate_impl_vmx_update; [| repeat apply VMX_inj_set_int; auto ].
      apply relate_impl_vmcs_update.
      - apply relate_impl_ept_update.
        apply relate_impl_syncchpool_update.
        apply relate_impl_cid_update.
        apply relate_impl_abq_update.
        apply relate_impl_abtcb_update.
        apply relate_impl_smspool_update.
        apply relate_impl_idpde_update.
        apply relate_impl_ptpool_update.
        apply relate_impl_PT_update.
        apply relate_impl_init_update.
        apply relate_impl_AC_update.
        apply relate_impl_nps_update.
        apply relate_impl_LAT_update.
        apply relate_impl_pg_update.
        apply relate_impl_vmxinfo_update. assumption.
      - inversion H9.
        repeat (apply VMCS_inj_set_int || apply VMCS_inj_set);
          try rewrite H; auto.
        econstructor.
        assumption.
    Qed.

    Context {mt1: match_impl_iflags}.
    Context {mt2: match_impl_vmx}.
    Context {mt3: match_impl_vmcs}.
    Context {mt4: match_impl_ipt}.
    Context {mt5: match_impl_LAT}.
    Context {mt6: match_impl_nps}.
    Context {mt7: match_impl_init}.
    Context {mt8: match_impl_PT}.
    Context {mt9: match_impl_ptpool}.
    Context {mt10: match_impl_idpde}.
    Context {mt11: match_impl_smspool}.
    Context {mt12: match_impl_abtcb}.
    Context {mt13: match_impl_abq}.
    Context {mt14: match_impl_cid}.
    Context {mt15: match_impl_syncchpool}.
    Context {mt16: match_impl_vmxinfo}.
    Context {mt17: match_impl_ept}.
    Context {mt18: match_impl_AC}.

    Lemma vmx_init_match:
      forall s d d' m mbi_adr pm4ept_b tss_b gdt_b idt_b msr_bitmap_b io_bitmap_b host_rip_b f,
        vmx_init_spec mbi_adr pm4ept_b tss_b gdt_b idt_b msr_bitmap_b io_bitmap_b host_rip_b d = Some d'
        -> match_AbData s d m f
        -> match_AbData s d' m f.
    Proof.
      unfold vmx_init_spec; intros.
      subdestruct; inv H; trivial.
      apply match_impl_vmx_update.
      apply match_impl_vmcs_update.
      apply match_impl_ept_update.
      apply match_impl_syncchpool_update.
      apply match_impl_cid_update.
      apply match_impl_abq_update.
      apply match_impl_abtcb_update.
      apply match_impl_smspool_update.
      apply match_impl_idpde_update.
      apply match_impl_ptpool_update.
      apply match_impl_PT_update.
      apply match_impl_init_update.
      apply match_impl_AC_update.
      apply match_impl_nps_update.
      apply match_impl_LAT_update.
      apply match_impl_pg_update.
      apply match_impl_vmxinfo_update. assumption.
    Qed.

    Context {inv: VMCSSetDefaultsInvariants (data_ops := data_ops) vmx_init_spec}.
    Context {inv0: VMCSSetDefaultsInvariants (data_ops := data_ops0) vmx_init_spec}.

    Lemma inject_incr_block_inject_neutral s f i b :
        find_symbol s i = Some b
        -> inject_incr (Mem.flat_inj (genv_next s)) f
        -> block_inject_neutral f b.
    Proof.
      unfold block_inject_neutral; intros symbol_exists incr ?.
      apply val_inject_ptr with 0%Z.
      - apply incr.
        unfold Mem.flat_inj.
        destruct (plt b (genv_next s)); try reflexivity.
        contradict n.
        eapply genv_symb_range; eassumption.
      - symmetry; apply Int.add_zero.
    Qed.

    Lemma vmx_init_sim :
      forall id,
        sim (crel RData RData) (id ↦ vmcs_set_defaults_compatsem vmx_init_spec)
            (id ↦ vmcs_set_defaults_compatsem vmx_init_spec).
    Proof.
      intros. layer_sim_simpl. compatsim_simpl (@match_AbData). intros.
      exploit vmx_init_exist; eauto 2 using inject_incr_block_inject_neutral.

      intros [labd' [HP HM]].
      match_external_states_simpl.
      eapply vmx_init_match; eauto.
    Qed.

  End VMX_INIT_SIM.

End OBJ_SIM.


(** * Functoriality of the construction of adjunctions *)
Require Import Category.Core Functor.Core NaturalTransformation.Core.
Require Import Functor.Identity Functor.Composition.Core.
Require Import NaturalTransformation.Composition.Core NaturalTransformation.Composition.Laws.
Require Import NaturalTransformation.Identity.
Require Import NaturalTransformation.Paths.
Require Import Functor.Dual NaturalTransformation.Dual.
Require Import Adjoint.Core Adjoint.UnitCounit Adjoint.Dual.
Require Import Adjoint.Functorial.Parts.
Require Import HoTT.Tactics.
Require Import Basics.Tactics.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope natural_transformation_scope.
Local Open Scope morphism_scope.

Section laws.
  (** Some tactics to handle all the proofs.  The tactics deal with
      the "obvious" commutativity requirements by writing back and
      forth with associativity and respectfulness of composition,
      trying to find applications of the adjunction laws. *)
  Local Ltac try_various_ways tac :=
    progress repeat first [ progress tac
                          | rewrite <- ?Functor.Core.composition_of;
                            progress try_associativity_quick tac
                          | rewrite -> ?Functor.Core.composition_of;
                            progress try_associativity_quick tac ].

  (** This is suboptimal, because we keep rewriting back and forth
      with associativity and [composition_of].  But it only takes 0.74
      seconds total, so it's probably not worth optimizing. *)
  Local Ltac handle_laws' :=
    idtac;
    match goal with
      | _ => reflexivity
      | _ => progress rewrite ?identity_of, ?Category.Core.left_identity, ?Category.Core.right_identity
      | _ => try_various_ways ltac:(f_ap)
      | [ |- context[components_of ?T ?x] ]
        => try_various_ways ltac:(simpl rewrite <- (commutes T))
      | [ |- context[unit ?A] ]
        => try_various_ways ltac:(rewrite (unit_counit_equation_1 A))
      | [ |- context[unit ?A] ]
        => try_various_ways ltac:(rewrite (unit_counit_equation_2 A))
    end.

  Local Ltac t :=
    apply path_natural_transformation; intro;
    cbn;
    repeat handle_laws'.

  Section left.
    Local Arguments unit : simpl never.
    Local Arguments counit : simpl never.

    Section identity_of.
      Context `{Funext}.
      Variables C D : PreCategory.

      Variable G : Functor D C.
      Variable F : Functor C D.
      Variable A : F -| G.

      Definition left_identity_of
      : @left_morphism_of C C 1 D D 1 G F A G F A 1
        = ((left_identity_natural_transformation_2 _)
             o (right_identity_natural_transformation_1 _))%natural_transformation.
      Proof. t. Qed.

      Definition left_identity_of_nondep
      : @left_morphism_of_nondep C D G F A G F A 1 = 1%natural_transformation.
      Proof. t. Qed.
    End identity_of.

    Section composition_of_dep.
      Context `{Funext}.
      Variables C C' C'' : PreCategory.
      Variable CF : Functor C C'.
      Variable CF' : Functor C' C''.
      Variables D D' D'' : PreCategory.
      Variable DF : Functor D D'.
      Variable DF' : Functor D' D''.

      Variable G : Functor D C.
      Variable F : Functor C D.
      Variable A : F -| G.
      Variable G' : Functor D' C'.
      Variable F' : Functor C' D'.
      Variable A' : F' -| G'.
      Variable G'' : Functor D'' C''.
      Variable F'' : Functor C'' D''.
      Variable A'' : F'' -| G''.
      Variable T : NaturalTransformation (CF o G) (G' o DF).
      Variable T' : NaturalTransformation (CF' o G') (G'' o DF').

      Local Open Scope natural_transformation_scope.

      Definition left_composition_of
      : (@left_morphism_of
           _ _ _ _ _ _ _ _
           A _ _ A''
           ((associator_1 _ _ _)
              o (T' oR DF)
              o (associator_2 _ _ _)
              o (CF' oL T)
              o (associator_1 _ _ _)))
        = (associator_2 _ _ _)
            o (DF' oL left_morphism_of A A' T)
            o (associator_1 _ _ _)
            o (left_morphism_of A' A'' T' oR CF)
            o (associator_2 _ _ _).
      Proof. t. Qed.
    End composition_of_dep.

    Section composition_of.
      Context `{Funext}.
      Variables C D : PreCategory.

      Variable G : Functor D C.
      Variable F : Functor C D.
      Variable A : F -| G.
      Variable G' : Functor D C.
      Variable F' : Functor C D.
      Variable A' : F' -| G'.
      Variable G'' : Functor D C.
      Variable F'' : Functor C D.
      Variable A'' : F'' -| G''.
      Variable T : NaturalTransformation G G'.
      Variable T' : NaturalTransformation G' G''.

      Local Open Scope natural_transformation_scope.

      Definition left_composition_of_nondep
      : (@left_morphism_of_nondep _ _ _ _ A _ _ A'' (T' o T))
        = ((left_morphism_of_nondep A A' T)
             o (left_morphism_of_nondep A' A'' T')).
      Proof. t. Qed.
    End composition_of.
  End left.

  Section right.
    Section identity_of.
      Context `{Funext}.
      Variables C D : PreCategory.

      Variable F : Functor C D.
      Variable G : Functor D C.
      Variable A : F -| G.

      Definition right_identity_of
      : @right_morphism_of C C 1 D D 1 F G A F G A 1
        = ((right_identity_natural_transformation_2 _)
             o (left_identity_natural_transformation_1 _))%natural_transformation
        := ap (@NaturalTransformation.Dual.opposite _ _ _ _)
              (@left_identity_of _ _ _ F^op G^op A^op).

      Definition right_identity_of_nondep
      : @right_morphism_of_nondep C D F G A F G A 1 = 1%natural_transformation
        := ap (@NaturalTransformation.Dual.opposite _ _ _ _)
              (@left_identity_of_nondep _ _ _ F^op G^op A^op).
    End identity_of.

    Section composition_of_dep.
      Context `{Funext}.
      Variables C C' C'' : PreCategory.
      Variable CF : Functor C C'.
      Variable CF' : Functor C' C''.
      Variables D D' D'' : PreCategory.
      Variable DF : Functor D D'.
      Variable DF' : Functor D' D''.

      Variable F : Functor C D.
      Variable G : Functor D C.
      Variable A : F -| G.
      Variable F' : Functor C' D'.
      Variable G' : Functor D' C'.
      Variable A' : F' -| G'.
      Variable F'' : Functor C'' D''.
      Variable G'' : Functor D'' C''.
      Variable A'' : F'' -| G''.
      Variable T : NaturalTransformation (F' o CF) (DF o F).
      Variable T' : NaturalTransformation (F'' o CF') (DF' o F').

      Local Open Scope natural_transformation_scope.

      (** This is slow, at about 3.8 s.  It also requires the opposite
          association to unify. *)
      Definition right_composition_of
      : right_morphism_of
          A A''
          ((associator_2 DF' DF F)
             o ((DF' oL T)
                  o ((associator_1 DF' F' CF)
                       o ((T' oR CF)
                            o (associator_2 F'' CF' CF)))))
        = (associator_1 G'' DF' DF)
            o ((right_morphism_of A' A'' T' oR DF)
                 o ((associator_2 CF' G' DF)
                      o ((CF' oL right_morphism_of A A' T)
                           o (associator_1 CF' CF G))))
        := ap (@NaturalTransformation.Dual.opposite _ _ _ _)
              (@left_composition_of
                 _ _ _ _ (DF^op) (DF'^op) _ _ _ (CF^op) (CF'^op)
                 _ _ A^op _ _ A'^op _ _ A''^op T^op T'^op).
    End composition_of_dep.

    Section composition_of.
      Context `{Funext}.
      Variables C D : PreCategory.

      Variable F : Functor C D.
      Variable G : Functor D C.
      Variable A : F -| G.
      Variable F' : Functor C D.
      Variable G' : Functor D C.
      Variable A' : F' -| G'.
      Variable F'' : Functor C D.
      Variable G'' : Functor D C.
      Variable A'' : F'' -| G''.
      Variable T : NaturalTransformation F F'.
      Variable T' : NaturalTransformation F' F''.

      Local Open Scope natural_transformation_scope.

      Definition right_composition_of_nondep
      : (@right_morphism_of_nondep _ _ _ _ A'' _ _ A (T' o T))
        = ((right_morphism_of_nondep A' A T)
             o (right_morphism_of_nondep A'' A' T'))
        := ap (@NaturalTransformation.Dual.opposite _ _ _ _)
              (@left_composition_of_nondep _ _ _ _ _ A''^op _ _ A'^op _ _ A^op T'^op T^op).
    End composition_of.
  End right.
End laws.


Require Import VST.floyd.proofauto.
Require Import VST.floyd.VSU.
Require Import pile.
Require Import spec_stdlib.
Require Import spec_pile.
Require Import spec_pile_private.
Require Import PileModel.

Section Pile_VSU.
Variable M: MallocFreeAPD.

Lemma listrep_local_facts:
  forall sigma p,
   listrep M sigma p |--
   !! (is_pointer_or_null p /\ (p=nullval <-> sigma=nil) /\ Forall (Z.le 0) sigma).
Proof.
intros.
revert p; induction sigma;
  unfold listrep; fold listrep; intros.
  entailer!; intuition.
Intros y. entailer!.
split.
split; intro. subst p. destruct H0; contradiction. discriminate.
constructor; auto. lia.
Qed.

Local Hint Resolve listrep_local_facts : saturate_local.

Lemma listrep_valid_pointer:
  forall sigma p,
   listrep M sigma p |-- valid_pointer p.
Proof.
 destruct sigma; unfold listrep; fold listrep;
 intros; entailer!; auto with valid_pointer.
Qed.

Local Hint Resolve listrep_valid_pointer : valid_pointer.

Lemma prep_local_facts:
  forall sigma p,
   prep M sigma p |-- !! (isptr p /\ Forall (Z.le 0) sigma).
Proof.
intros.
unfold prep.
Intros q.
entailer!.
Qed.
Local Hint Resolve prep_local_facts : saturate_local.

Lemma prep_valid_pointer:
  forall sigma p,
   prep M sigma p |-- valid_pointer p.
Proof.
 intros.
 unfold prep. Intros x.
 entailer!; auto with valid_pointer.
Qed.
Local Hint Resolve prep_valid_pointer : valid_pointer.

Definition pilefreeable (p: val) : mpred :=
            malloc_token M Ews tpile p.

Definition PILE: PileAPD := Build_PileAPD (prep M) prep_local_facts prep_valid_pointer pilefreeable.

Definition PILEPRIV: PilePrivateAPD M := Build_PilePrivateAPD M PILE (eq_refl _).

Definition surely_malloc_spec :=
  DECLARE _surely_malloc
   WITH t:type, gv: globals
   PRE [ size_t ]
       PROP (0 <= sizeof t <= Ptrofs.max_unsigned;
                complete_legal_cosu_type t = true;
                natural_aligned natural_alignment t = true)
       PARAMS (Vptrofs (Ptrofs.repr (sizeof t))) GLOBALS (gv)
       SEP (mem_mgr M gv)
    POST [ tptr tvoid ] EX p:_,
       PROP ()
       LOCAL (temp ret_temp p)
       SEP (mem_mgr M gv; malloc_token M Ews t p * data_at_ Ews t p).

  Definition Pile_ASI: funspecs := PileASI M PILE.

  Definition pile_imported_specs:funspecs := MallocFreeASI M.

  Definition pile_internal_specs: funspecs := surely_malloc_spec::Pile_ASI.

  Definition PileVprog: varspecs. mk_varspecs prog. Defined.
  Definition PileGprog: funspecs := pile_imported_specs ++ pile_internal_specs.

Lemma body_surely_malloc: semax_body PileVprog PileGprog f_surely_malloc surely_malloc_spec.
Proof.
start_function.
forward_call (malloc_spec_sub M t) gv.
Intros p.
if_tac.
{ subst.
  forward_if False.
  - forward_call 1. contradiction.
  - congruence. }
forward_if True.
+ contradiction.
+ forward. entailer!.
+ forward. Exists p. entailer!.
Qed.

Lemma body_Pile_new: semax_body PileVprog PileGprog f_Pile_new (Pile_new_spec M PILE).
Proof.
start_function.
forward_call (tpile, gv).
split3; simpl; auto; computable.
Intros p.
repeat step!.
simpl spec_pile.pilerep.
unfold prep, listrep, pile_freeable.
repeat step!.
Qed.

Lemma body_Pile_add: semax_body PileVprog PileGprog f_Pile_add (Pile_add_spec M PILE).
Proof.
start_function.
forward_call (tlist, gv).
split3; simpl; auto; computable.
Intros q.
simpl spec_pile.pilerep; unfold prep.
Intros head.
forward.
forward.
forward.
forward.
simpl pilerep; unfold prep.
Exists q.
unfold listrep at 2; fold listrep.
Exists head.
entailer!; try apply derives_refl.
Qed.

Lemma body_Pile_count: semax_body PileVprog PileGprog f_Pile_count (Pile_count_spec PILE).
Proof.
start_function.
simpl pilerep; unfold prep. Intros head.
forward.
unfold Sfor.
forward.
forward_loop (EX r:val, EX s2: list Z,
   PROP(0 <= sumlist s2 <= sumlist sigma)
   LOCAL(temp _c (Vint (Int.repr (sumlist sigma - sumlist s2)));
              temp _p p; temp _q r)
   SEP (data_at Ews tpile head p;
          listrep M s2 r -* listrep M sigma head;
          listrep M s2 r))%assert
   break:
  (PROP()
   LOCAL(temp _c (Vint (Int.repr (sumlist sigma))); temp _p p)
   SEP (data_at Ews tpile head p;
          listrep M sigma head))%assert.
-
Exists head sigma.
entailer!. rewrite Z.sub_diag. auto.
apply wand_sepcon_adjoint. cancel.
-
Intros r s2.
forward_if (r<>nullval).
forward.
entailer!.
subst r.
forward.
entailer!.
assert (s2=nil) by intuition; subst s2.
simpl. rewrite Z.sub_0_r; auto.
sep_apply (modus_ponens_wand (listrep M s2 nullval)).
cancel.
Intros.
destruct s2.
assert_PROP False; [ | contradiction]. {
 entailer!. assert (r=nullval) by intuition; subst r. congruence.
}
unfold listrep at 3; fold (listrep M).
Intros r'.
forward.
forward. {
 entailer!.
 simpl in H0.
 clear - H0 H H2 H9.
 rewrite (Int.signed_repr z) by rep_lia.
 rewrite (Int.signed_repr) by rep_lia.
 assert (0 <= sumlist s2). {
 clear - H9. induction s2; simpl; auto. lia.
 inv H9. apply IHs2 in H2. lia.
 }
 rep_lia.
}
forward.
Exists r' s2.
entailer!.
simpl. split.
simpl in H0.
 assert (0 <= sumlist s2). {
 clear - H9. induction s2; simpl; auto. lia.
 inv H9. apply IHs2 in H2. lia.
 }
 rep_lia.
 f_equal; f_equal; lia.
apply -> wand_sepcon_adjoint.
match goal with |- (_ * ?A * ?B * ?C)%logic |-- _ =>
 assert ((A * B * C)%logic |-- listrep M (z::s2) r) end.
unfold listrep at 2; fold (listrep M). Exists r'. entailer!.
sep_apply H10.
sep_apply modus_ponens_wand.
auto.
 -
forward.
simpl pilerep; unfold prep.
Exists head.
cancel.
Qed.

Lemma body_Pile_free: semax_body PileVprog PileGprog f_Pile_free (Pile_free_spec M PILE).
Proof.
start_function.
simpl pilerep; unfold prep.
simpl pile_freeable. unfold pilefreeable. Intros head.
forward.
forward_while (EX q:val, EX s2: list Z,
   PROP ( )
   LOCAL (temp _q q; temp _p p; gvars gv)
   SEP (data_at Ews tpile head p;
       listrep M s2 q; malloc_token M Ews tpile p;
   mem_mgr M gv))%assert.
{ Exists head sigma; entailer!. }
{ entailer!. }
{ destruct s2.
   assert_PROP False; [|contradiction]. unfold listrep. entailer!.
  unfold listrep; fold (listrep M).
  Intros y.
  forward.
  forward_call (free_spec_sub M (Tstruct _list noattr)) (q, gv).
  rewrite if_false by (intro; subst; contradiction).
  cancel.
  forward.
  Exists (y, s2).
  entailer!. cancel. }
subst.
assert_PROP (p<>nullval). entailer!.
forward_call (free_spec_sub M (Tstruct _pile noattr))  (p, gv).
rewrite if_false by auto.
cancel.
forward.
rewrite (proj1 H0) by auto.
unfold listrep.
entailer!.
Qed.

Definition PileVSU: @VSU NullExtension.Espec
           nil pile_imported_specs ltac:(QPprog prog) Pile_ASI emp.
 Proof.
    mkVSU prog pile_internal_specs.
    + solve_SF_internal body_surely_malloc.
    + solve_SF_internal body_Pile_new.
    + solve_SF_internal body_Pile_add.
    + solve_SF_internal body_Pile_count.
    + solve_SF_internal body_Pile_free.
  Qed.

Definition PilePrivateVSU: @VSU NullExtension.Espec
      nil pile_imported_specs ltac:(QPprog prog) (PilePrivateASI M PILEPRIV) emp.
 Proof.
    mkVSU prog pile_internal_specs.
    + solve_SF_internal body_surely_malloc.
    + solve_SF_internal body_Pile_new.
    + solve_SF_internal body_Pile_add.
    + solve_SF_internal body_Pile_count.
    + solve_SF_internal body_Pile_free.
  Qed.

End Pile_VSU.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect.
Require Import ssrnat.
Require Import seq.
Require Import cfmap.
Require Import cfreducible.
Require Import configurations.

Lemma red294to298 : reducible_in_range 294 298 the_configs.
Proof. CheckReducible. Qed.


Add LoadPath "../from_compcert".
Require Import Libs.
(*Require Import Floats.*)
Require Import AST.
Require Import Setoid.
Require Import ArithClasses.

(* we define the type of memories for Loops *)

(* memory is splitted in arrays. Each array is recognised through it's
   ident.

   each cell of the array is then accessed through a list of indexes
   of type int *)

Record Array_Id := mk_Array_Id {
  open_Array_Id : ident}.

Global Instance singletonInd_Array_Id : singletonInd Array_Id ident :=
{ open := open_Array_Id;
  mk := mk_Array_Id}.
Proof.
  destruct i; auto.
  auto.
Qed.

Record Cell_Id `(Numerical Num) := mkCellIdent
  { array : Array_Id;
    cell : list Num}.

Implicit Arguments Cell_Id [[H]].
Implicit Arguments array [[Num] [H]].
Implicit Arguments cell [[Num] [H]].

Definition z2icell (ci: Cell_Id Z) : option (Cell_Id int) :=
  do c <- z2ilist (ci.(cell));
  Some {| array := ci.(array);
     cell := c|}.

Definition i2zcell (ci: Cell_Id int) : Cell_Id Z :=
  {| array := ci.(array);
     cell := i2zlist ci.(cell)|}.

Lemma z2i2zcell zci ici: z2icell zci = Some ici -> i2zcell ici = zci.
Proof.
  unfold z2icell, i2zcell.
  destruct zci, ici. simpl. intro SOME.
  monadInv SOME.
  inv SOME.
  f_equal.
  apply z2i2zlist. auto.
Qed.

Global Instance EqDec_t `{Numerical Num}: EqDec (Cell_Id Num).
Proof.
  constructor. intros.
  dec_eq.
Qed.

Module Type BASEMEM(N:NUMERICAL).
  Import N.
  Existing Instance Numerical_Num.

  (* values of the language *)
  Parameter Value: Type.

  (* memories *)
  Parameter Memory: Type.

  (* memories can be of "same layout", and it's an equivalence
     relation. One can see two memories with the same layout as memories
     with the same arrays, containing the same layout of values. *)

  Parameter same_memory_layout: relation Memory.

  Declare Instance Equiv_smt: Equivalence same_memory_layout.

  Parameter read: Memory -> Cell_Id Num -> option Value.

  (* two memories with same layout are readable at the same locations *)

  Parameter read_same_layout:
    forall mem1 mem2 ci, same_memory_layout mem1 mem2 ->
    is_some (read mem1 ci) -> is_some (read mem2 ci).

  Parameter write: Memory -> Cell_Id Num -> Value -> option Memory.

  (* you don't change the layout of a memory by writing in it *)

  Parameter write_keep_layout:
    forall mem1 mem2 ci v, write mem1 ci v = Some mem2 -> same_memory_layout mem1 mem2.

  (* two memories with the same layout are accessible at the same locations *)
  Parameter write_same_layout:
    forall mem1 mem2 ci v, same_memory_layout mem1 mem2 ->
    (is_some (write mem1 ci v) -> is_some (write mem2 ci v)).

  (* write followed by a read *)
  Definition read_write mem ci v : option Value :=
    do mem' <- write mem ci v;
    read mem' ci.

  (* at the same location for two memories with the same layout, we read
     the new value *)
  (* one might have espect something like:

     read_write mem1 ci v = Some mem2 ->
     read mem2 ci = Some v

     This would not take into account the fact that writing at some
     location can lead to lose information. Say you have a char[] and
     you write a large value in it. The compiler will automatically
     downgrade the large value to a char before writing it. So reading
     it will lead to a value in the range of char, not the initial one.

     For the correctness of the reordering of write, it is in fact
     useless to know exactly what would be read, but just that it is
     the same, whatever the order of the writes are*)

  Parameter rws: forall mem1 mem2 ci v,
    same_memory_layout mem1 mem2 ->
    read_write mem1 ci v = read_write mem2 ci v.

  (* at an other location, we read the old value *)
  Parameter rwo: forall mem1 mem2 ci1 ci2 v,
    write mem1 ci1 v = Some mem2 -> ci1 <> ci2 ->
    read mem2 ci2 = read mem1 ci2.

End BASEMEM.

(* This is a very simplist instance of the module type. A more
   credible one can be found in OtherMemory. It is to show it is
   instanciable and to "explain" better some prerequisites*)

Module BMem(N:NUMERICAL) <: BASEMEM(N).
  Import N.
  Existing Instance Numerical_Num.

  Definition Value := Z.

  (*
  Inductive has_type: value -> typ -> Prop :=
  | HT_int: forall i, has_type (Vint i) Tint
  | HT_float: forall f, has_type (Vfloat f) Tfloat.

  Definition typ_of (v:val) :=
    match v with
      | Vint _ => Tint
      | Vfloat _ => Tfloat
    end.
  *)
  Module ValEqDec <: EQUALITY_TYPE.
    Definition t := Value.
    Global Instance EqDec_t: EqDec Value.
    Proof.
      constructor. unfold Value.
      apply ZEqDec.EqDec_t.
    Qed.
  End ValEqDec.

  Definition valid_cell:= Cell_Id Num -> bool.

  Definition eqA_valid_cell (mt1 mt2: valid_cell) := forall ci, mt1 ci = mt2 ci.

  Lemma valid_cell_equiv: Equivalence eqA_valid_cell.
  Proof.
    prove_equiv; dintuition congruence.
  Qed.

  Instance EqA_mt : EqA valid_cell:=
  { eqA := eqA_valid_cell;
    eqAequiv := valid_cell_equiv}.

  (* a memory is a mapping between Cell_Ids and Values *)
  Definition Memory := Cell_Id Num -> option Value.

  Implicit Type m: Memory.

  Definition valid_cell_of (mem: Memory) ci :=
    match mem ci with
      | None => false
      | Some _ => true
    end.

  Definition same_memory_layout mem1 mem2 := valid_cell_of mem1 ≡ valid_cell_of mem2.

  Global Instance Equiv_smt: Equivalence same_memory_layout.
  Proof.
    prove_equiv; unfold same_memory_layout.
    reflexivity. symmetry; auto.
    intros * H H0. eapply transitivity; eauto.
  Defined.

  Definition read m ci:= m ci.

  (* two memories with same layout are readable at the same locations *)

(*  Lemma same_typ_of: forall mem1 mem2 ci, same_memory_layout mem1 mem2 ->
    typ_of <$> mem1 ci = typ_of <$> mem2 ci.
  Proof.
    intros * H.
    unfold same_memory_layout, mem_type_of in H.
    simpl in *. auto.
  Qed.*)

  Lemma read_same_layout:
    forall mem1 mem2 ci, same_memory_layout mem1 mem2 -> is_some (read mem1 ci) ->
      is_some (read mem2 ci).
  Proof.
    unfold same_memory_layout, read, valid_cell_of.
    intros * H. compute in H. specialize (H ci).
    destruct (mem1 ci), (mem2 ci); intro; simpl in *;  auto.
  Qed.

  Definition write m ci v :=
    if valid_cell_of m ci then
      Some (fun ci' => if ci' == ci then Some v else m ci')
    else
      None.

  (* you don't change the layout of a memory by writing in it *)

  Lemma write_keep_layout:
    forall mem1 mem2 ci v, write mem1 ci v = Some mem2 -> same_memory_layout mem1 mem2.
  Proof.
    unfold write, same_memory_layout.
    intros mem1 mem2 ci v H.
    simpl. intro ci'.
    dest_if; simpl; clean.
    unfold valid_cell_of in *; simpl in *.
    dest==; subst; auto.
  Qed.

  Lemma write_same_layout:
    forall mem1 mem2 ci v, same_memory_layout mem1 mem2 -> (is_some (write mem1 ci v) -> is_some (write mem2 ci v)).
  Proof.
    unfold same_memory_layout, write, valid_cell_of. compute.
    intros mem1 mem2 ci v H.
    specialize (H ci).
    destruct (mem1 ci); destruct (mem2 ci); clean.
  Qed.

  Definition read_write m ci v : option Value :=
    do m' <- write m ci v;
    read m' ci.

  Lemma rws: forall mem1 mem2 ci v,
    same_memory_layout mem1 mem2 ->
    read_write mem1 ci v = read_write mem2 ci v.
  Proof.
    unfold same_memory_layout, write, read, valid_cell_of. compute.
    intros mem1 mem2 ci v H.
    specialize (H ci).
    destruct (mem1 ci); destruct (mem2 ci); clean.
  Qed.

  Lemma rwo: forall mem1 mem2 ci1 ci2 v, write mem1 ci1 v = Some mem2 -> ci1 <> ci2 ->
    read mem2 ci2 = read mem1 ci2.
  Proof.
    unfold same_memory_layout, write, read, valid_cell_of. compute.
    intros mem1 mem2 ci1 ci2 v H H0.
    destruct (mem1 ci1); clean.
  Qed.

End BMem.

(* build a complete memory from a base memory *)
Module MEMORY (N:NUMERICAL) (BM: BASEMEM(N)).
  Export BM.

  (* two memories are equivalent if the map the same cells to the same values
     and they have the same layout *)
  Definition eqA_memory mem1 mem2 :=
    same_memory_layout mem1 mem2 /\
    forall ci, read mem1 ci = read mem2 ci.

  Lemma eqA_mem_equiv : Equivalence eqA_memory.
  Proof.
    prove_equiv; unfold eqA_memory; intros; split'.
    Case "Reflexivity"; SCase "left".
      reflexivity.
    Case "Reflexivity"; SCase "right".
      reflexivity.
    Case "Symmetry"; SCase "left".
      inv H. symmetry; auto.
    Case "Symmetry"; SCase "right".
      inv H; symmetry; auto.
    Case "Transitivity"; SCase "left".
      inv H; inv H0; etransitivity; eauto.
      inv H; inv H0; etransitivity; eauto.
  Qed.

  (* this gives us the notation ≡ *)
  Global Instance EqA_memory : EqA Memory :=
  { eqA := eqA_memory;
    eqAequiv := eqA_mem_equiv}.

  Lemma EqA_memory_unfold: forall mem1 mem2,
    mem1 ≡ mem2 = (same_memory_layout mem1 mem2 /\
    forall ci, read mem1 ci = read mem2 ci).
  Proof.
    reflexivity.
  Qed.

  Lemma use_EqA_memory_1: forall mem1 mem2,
    mem1 ≡ mem2 -> forall ci, read mem1 ci = read mem2 ci.
  Proof.
    intros * [? ?]; auto.
  Qed.

  Lemma use_EqA_memory_2: forall mem1 mem2,
    mem1 ≡ mem2 -> same_memory_layout mem1 mem2.
  Proof.
    intros * [? ?]; auto.
  Qed.

  (* we don't want EqA_memory to be unfold in general *)
  Global Opaque EqA_memory.

  Global Hint Resolve use_EqA_memory_1 use_EqA_memory_2 read_same_layout
    write_keep_layout write_same_layout rws rwo: memory.

  Lemma smt_refl: forall m, same_memory_layout m m.
  Proof. reflexivity. Qed.

  Lemma smt_sym: forall mem1 mem2, same_memory_layout mem1 mem2 -> same_memory_layout mem2 mem1.
  Proof. symmetry. auto. Qed.

  Lemma smt_trans: forall mem1 mem2 m3, same_memory_layout mem1 mem2 -> same_memory_layout mem2 m3 -> same_memory_layout mem1 m3.
  Proof. etransitivity; eauto. Qed.

  Global Hint Immediate smt_sym: memory.
  Global Hint Resolve 5 smt_trans: memory.
  Hint Extern 1 (same_memory_layout ?X ?X) => reflexivity: memory.

  Ltac get_all_mem_layouts :=
  option_on_right;
  repeat
  match goal with
    | H: ?mem1 ≡ ?mem2 |- _ =>
      match goal with
        | H' : same_memory_layout mem1 mem2 |- _ => fail 1
        | H' : same_memory_layout mem2 mem1 |- _ => fail 1
        | |- _ =>
          pose proof (use_EqA_memory_2 _ _ H)
      end
  end;
  repeat
  match goal with
    | H: write ?mem1 _ _ = Some ?mem2 |- _ =>
      match goal with
        | H' : same_memory_layout mem1 mem2 |- _ => fail 1
        | H' : same_memory_layout mem2 mem1 |- _ => fail 1
        | |- _ =>
          pose proof (write_keep_layout _ _ _ _ H)
      end
  end.

  Definition owrite omem ci v: option Memory :=
    do mem <- omem;
    write mem ci v.

  Lemma rws': forall mem1 mem2 mem1' mem2' ci v, same_memory_layout mem1 mem2 ->
    write mem1 ci v = Some mem1' -> write mem2 ci v = Some mem2' ->
    read mem1' ci = read mem2' ci.
  Proof.
    intros mem1 mem2 mem1' mem2' ci v H H0 H1.
    pose proof (rws mem1 mem2 ci v H). compute in H2.
    rewrite H0, H1 in H2. auto.
  Qed.
  Hint Resolve rws': memory.

  Ltac check_diff x y :=
    match goal with
      | H : x <> y |- _ => idtac
      | H : y <> x |- _  => idtac
    end.

  Ltac push_read_up :=
  repeat
  match goal with
    | H: write ?mem1 ?ci1 ?v = Some ?mem2 |- context[read ?mem2 ?ci2] =>
      check_diff ci1 ci2;
      replace (read mem2 ci2) with (read mem1 ci2) by (symmetry; eapply rwo; eauto)
  end.

  Ltac solve_same_memory :=
    repeat match goal with
             | H : _ ≡ _ |- _ => apply use_EqA_memory_2 in H
           end;
    repeat match goal with
             | H: write _ _ _ = Some _ |- _ =>
               apply write_keep_layout in H; revert H
             | H : same_memory_layout _ _ |- _ => revert H
           end;
    clear'; intros;
    let rec aux := (* aux is used to backtrack *)
    match goal with
    | H: same_memory_layout ?m1 ?m2 |- same_memory_layout ?m1 ?m2
      => apply H
    | H: same_memory_layout ?m1 ?m2 |- same_memory_layout ?m1 ?m2
      => symmetry; apply H
    | H: same_memory_layout ?m1 _ |- same_memory_layout ?m1 _ =>
      etransitivity; [eapply H| clear H; solve [aux]]
    | H: same_memory_layout _ ?m1 |- same_memory_layout ?m1 _ =>
      etransitivity; [symmetry; eapply H| clear H; solve [aux]]
    end in solve [aux].

  (* if two cells are differents, we can permut the write *)
  Lemma permut_write: forall mem1 mem2 ci1 ci2 v1 v2, ci1 <> ci2 ->
    mem1 ≡ mem2 ->
    owrite (write mem1 ci1 v1) ci2 v2 ≡ owrite (write mem2 ci2 v2) ci1 v1.
  Proof.
    intros * DIFF EQUIV.
    remember (write mem1 ci1 v1) as omem1.
    remember (write mem2 ci2 v2) as omem2.
    destruct' omem1 as [mem1'|]; destruct' omem2 as [mem2'|];
    unfold owrite; prog_dos; prog_dos; clean; try reflexivity.

    Case "Some mem1'"; SCase "Some mem2'".

    repeat match goal with
        | H: write ?M1 ?CI ?V = Some _|- context[write ?M2 ?CI ?V] =>
          let HSOME := fresh in
          let HSAME := fresh in
            assert (is_some (write M2 CI V)) as HSOME by
            (assert (same_memory_layout M1 M2) as HSAME by solve_same_memory;
             eapply write_same_layout;[ eapply HSAME| instantiate; eauto]);
            inv HSOME
      end.
    simpl; rewrite EqA_memory_unfold.
    get_all_mem_layouts.

    split'.
    SSCase "left".
      eauto with memory.
    SSCase "right".
      intro ci.
      dest ci == ci1; dest ci == ci2; repeat (progress subst); auto;
        push_read_up; eauto with memory.

    Case "Some mem1'"; SCase "None".
    simpl.
    get_all_mem_layouts.
    prog_match_option; auto.

    assert (is_some (write mem ci2 v2)) by auto. symmetry in H0.
    eapply (write_same_layout mem mem2) in H1.
    rewrite Heqomem2 in H1. auto. etransitivity; eauto.

    Case "None"; SCase "Some mem2'".
    simpl.
    get_all_mem_layouts.
    case_eq (write mem2' ci1 v1); intros; auto.

    assert (is_some (write mem2' ci1 v1)) by auto.
    symmetry in H0. eapply (write_same_layout mem2' mem1) in H2.
    rewrite Heqomem1 in H2. auto.
    symmetry in H0. symmetry. etransitivity; eauto.
  Qed.

End MEMORY.

Module ZBMem := BMem(ZNum).
Module IntBMem := BMem(IntNum).

Module Zmem := MEMORY(ZNum)(ZBMem).
Module Intmem := MEMORY(IntNum)(IntBMem).

Module BmemI2Z(BMI: BASEMEM(IntNum)) <: BASEMEM(ZNum).

  (* values of the language *)
  Definition Value:= BMI.Value.

  (* memories *)
  Definition Memory := BMI.Memory.
  Implicit Type m: Memory.
  Implicit Type ci: Cell_Id Z.

  (* memories can be of "same layout", and it's an equivalence relation *)

  Definition same_memory_layout : relation Memory := BMI.same_memory_layout.

  Global Instance Equiv_smt: Equivalence same_memory_layout.
  Proof.
    unfold same_memory_layout.
    apply BMI.Equiv_smt.
  Qed.

  Definition read m ci : option Value :=
    do ci' <- z2icell ci;
    BMI.read m ci'.

  (* two memories with same layout are readable at the same locations *)

  Lemma read_same_layout:
    forall mem1 mem2 ci, same_memory_layout mem1 mem2 ->
      is_some (read mem1 ci) -> is_some (read mem2 ci).
  Proof.
    intros * SMT SOME.
    unfold read in *.
    monadInv SOME. simpl_do.
    eapply BMI.read_same_layout; eauto.
  Qed.

  Definition write m ci v: option Memory :=
    do ci' <- z2icell ci;
    BMI.write m ci' v.

  (* you don't change the layout of a memory by writing in it *)

  Lemma write_keep_layout:
    forall mem1 mem2 ci v, write mem1 ci v = Some mem2 -> same_memory_layout mem1 mem2.
  Proof.
    unfold write. intros * SOME.
    monadInv SOME. eapply BMI.write_keep_layout; eauto.
  Qed.

  Lemma write_same_layout:
    forall mem1 mem2 ci v, same_memory_layout mem1 mem2 -> (is_some (write mem1 ci v)
      -> is_some (write mem2 ci v)).
  Proof.
    unfold write. intros * SMT SOME.
    monadInv SOME. simpl_do. eapply BMI.write_same_layout; eauto.
  Qed.

  Definition read_write m ci v : option Value :=
    do m' <- write m ci v;
    read m' ci.

  Lemma rws: forall mem1 mem2 ci v,
    same_memory_layout mem1 mem2 ->
    read_write mem1 ci v = read_write mem2 ci v.
  Proof.
    intros * SMT.
    destruct (z2icell ci) as [ci'|] _eqn.
    pose proof (BMI.rws mem1 mem2 ci' v SMT).
    unfold BMI.read_write in H.
    unfold read_write, read, write.
    rewrite Heqo.
    compute in H. compute. auto.

    unfold read_write, read, write.
    rewrite Heqo. simpl_do. reflexivity.
  Qed.
  Lemma inv_cons: forall A (a1 a2 :A) l1 l2,
    tag_to_inv (a1 :: l1 = a2 :: l2).
  Proof. auto. Qed.
  Hint Rewrite inv_cons: opt_inv.

  Lemma rwo: forall mem1 mem2 ci1 ci2 v, write mem1 ci1 v = Some mem2 -> ci1 <> ci2 ->
    read mem2 ci2 = read mem1 ci2.
  Proof.
    unfold write, read.

    intros * SOME DIFF.
    monadInv SOME.
    prog_dos.
    eapply BMI.rwo; eauto.
    intro. apply DIFF. subst.
    erewrite <- z2i2zcell; eauto.
    erewrite <- (z2i2zcell ci1); eauto.
  Qed.

End BmemI2Z.


(* begin hide *)
From ITree Require Import
     ITree
     Basics.Monad
     Events.StateFacts
     Eq.Eqit.

From Vellvm Require Import
     Utilities
     Syntax
     Semantics.LLVMEvents
     Semantics.Denotation
     Handlers.Handlers.
(* end hide *)

Section InterpreterMCFG.

  (**
   Partial interpretations of the trees produced by the denotation of _VIR_ programs.
   The intent is to allow us to only interpret as many layers as needed
   to perform the required semantic reasoning, and lift for free the
   equivalence down the pipe.
   This gives us a _vertical_ notion of compositionality.
   *)

  Definition interp_mcfg1 {R} (t: itree L0 R) g :=
    let uvalue_trace       := interp_intrinsics t in
    let L1_trace           := interp_global uvalue_trace g in
    L1_trace.

  Definition interp_mcfg2 {R} (t: itree L0 R) g l :=
    let uvalue_trace   := interp_intrinsics t in
    let L1_trace       := interp_global uvalue_trace g in
    let L2_trace       := interp_local_stack L1_trace l in
    L2_trace.

  Definition interp_mcfg3 {R} (t: itree L0 R) g l m :=
    let uvalue_trace   := interp_intrinsics t in
    let L1_trace       := interp_global uvalue_trace g in
    let L2_trace       := interp_local_stack L1_trace l in
    let L3_trace       := interp_memory L2_trace m in
    L3_trace.

  Definition interp_mcfg4 {R} RR (t: itree L0 R) g l m :=
    let uvalue_trace   := interp_intrinsics t in
    let L1_trace       := interp_global uvalue_trace g in
    let L2_trace       := interp_local_stack L1_trace l in
    let L3_trace       := interp_memory L2_trace m in
    let L4_trace       := model_undef RR L3_trace in
    L4_trace.

  (* The interpreter stray away from the model starting from the fourth layer: we pick an arbitrary valid path of execution *)
  Definition interp_mcfg4_exec {R} (t: itree L0 R) g l m :=
    let uvalue_trace   := interp_intrinsics t in
    let L1_trace       := interp_global uvalue_trace g in
    let L2_trace       := interp_local_stack L1_trace l in
    let L3_trace       := interp_memory L2_trace m in
    let L4_trace       := exec_undef L3_trace in
    L4_trace.

End InterpreterMCFG.

Section InterpreterCFG.

  (**
   Partial interpretations of the trees produced by the
   denotation of cfg. They differ from the ones of Vellvm programs by
   their event signature, as well as by the lack of a stack of local event.
   The intent is to allow us to only interpret as many layers as needed
   to perform the required semantic reasoning, and lift for free the
   equivalence down the pipe.
   This gives us a _vertical_ notion of compositionality.
   *)

  (**
   NOTE: Can we avoid this duplication w.r.t. [interpi]?
   *)

  Definition interp_cfg1 {R} (t: itree instr_E R) (g: global_env) :=
    let L0_trace       := interp_intrinsics t in
    let L1_trace       := interp_global L0_trace g in
    L1_trace.

  Definition interp_cfg2 {R} (t: itree instr_E R) (g: global_env) (l: local_env) :=
    let L0_trace       := interp_intrinsics t in
    let L1_trace       := interp_global L0_trace g in
    let L2_trace       := interp_local L1_trace l in
    L2_trace.

  Definition interp_cfg3 {R} (t: itree instr_E R) (g: global_env) (l: local_env) (m: memory_stack) :=
    let L0_trace       := interp_intrinsics t in
    let L1_trace       := interp_global L0_trace g in
    let L2_trace       := interp_local L1_trace l in
    let L3_trace       := interp_memory L2_trace m in
    L3_trace.

  Definition interp_cfg4 {R} RR (t: itree instr_E R) (g: global_env) (l: local_env) (m: memory_stack) :=
    let L0_trace       := interp_intrinsics t in
    let L1_trace       := interp_global L0_trace g in
    let L2_trace       := interp_local L1_trace l in
    let L3_trace       := interp_memory L2_trace m in
    let L4_trace       := model_undef RR L3_trace in
    L4_trace.

End InterpreterCFG.

Module D := Denotation Addr LLVMEvents.
Export D.

Module SemNotations.

  Notation ℑ1 := interp_cfg1.
  Notation ℑ2 := interp_cfg2.
  Notation ℑ3 := interp_cfg3.
  Notation ℑ4 := interp_cfg4.
  Notation ℑ  := interp_cfg4.

  Notation ℑs1 := interp_mcfg1.
  Notation ℑs2 := interp_mcfg2.
  Notation ℑs3 := interp_mcfg3.
  Notation ℑs4 := interp_mcfg4.
  Notation ℑs  := interp_mcfg4.

  Notation Ret1 g x     := (Ret (g,x)).
  Notation Ret2 g l x   := (Ret (l,(g,x))).
  Notation Ret3 g l m x := (Ret (m,(l,(g,x)))).

  Notation "⟦ e 'at?' t '⟧e'" :=  (denote_exp t e).
  Notation "⟦ e 'at' t '⟧e'" :=   (denote_exp (Some t) e).
  Notation "⟦ e '⟧e'" :=          (denote_exp None e).
  Notation "⟦ e 'at?' t '⟧e3'" := (ℑ3 (translate exp_to_instr ⟦ e at? t ⟧e)).
  Notation "⟦ e 'at' t '⟧e3'" :=  (ℑ3 (translate exp_to_instr ⟦ e at t ⟧e)).
  Notation "⟦ e '⟧e3'" :=         (ℑ3 (translate exp_to_instr ⟦ e ⟧e )).

  Notation "⟦ i '⟧i'" :=        (denote_instr i).
  Notation "⟦ i '⟧i3'" :=       (ℑ3 ⟦ i ⟧i).

  Notation "⟦ c '⟧c'" :=          (denote_code c).
  Notation "⟦ c '⟧c3'" :=         (ℑ3 ⟦ c ⟧c).

  Notation "⟦ t '⟧t'" :=        (denote_terminator t).
  Notation "⟦ t '⟧t3'" :=       (ℑ3 (translate exp_to_instr ⟦ t ⟧t)).

  Notation "⟦ phi '⟧Φ' from"  := (denote_phi from phi) (at level 0, from at next level).
  Notation "⟦ phi '⟧Φ3' from" := (ℑ3 (denote_phi from phi)) (at level 0, from at next level).

  Notation "⟦ phis '⟧Φs' from"  := (denote_phis from phis) (at level 0, from at next level).
  Notation "⟦ phis '⟧Φs3' from" := (ℑ3 (denote_phis from phis)) (at level 0, from at next level).

  Notation "⟦ bk '⟧b'" :=  (denote_block bk).
  Notation "⟦ bk '⟧b3' id" := (ℑ3 (⟦ bk ⟧b id)) (at level 0, id at next level).

  Notation "⟦ bks '⟧bs'"  := (denote_ocfg bks).
  Notation "⟦ bks '⟧bs3' ids" := (ℑ3 (denote_ocfg bks ids)) (at level 0, ids at next level).

  Notation "⟦ f '⟧cfg'"  := (denote_cfg f).
  Notation "⟦ f '⟧cfg3'" := (ℑ3 (denote_cfg f)).

  Notation "⟦ f '⟧f'"  := (denote_function f).

  Ltac intros3 := intros (? & ? & ? & ?).

End SemNotations.


Add Search Blacklist "Private_" "_subproof".
Set Printing Depth 50.
Remove Search Blacklist "Private_" "_subproof".
Add Search Blacklist "Private_" "_subproof".
Add LoadPath "../..".
Require Import BetaJulia.BasicPLDefs.Identifier.
Require Import BetaJulia.Sub0280a.BaseDefs.
Require Import BetaJulia.Sub0280a.BaseMatchProps.
Require Import Coq.Lists.List.
Import ListNotations.
Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Open Scope btjm.
Lemma cname_eq__decidable : forall n1 n2 : cname, Decidable.decidable (n1 = n2).
Proof.
(intros n1 n2; destruct n1; destruct n2; (left; reflexivity) || (right; intros H; inversion H)).
Qed.
Definition sem_sub (t1 t2 : ty) := forall k : nat, ||-[ k][t1]<= [t2].
Notation "'||-' '[' t1 ']' '<=' '[' t2 ']'" := (sem_sub t1 t2) (at level 50) : btjm_scope.
Lemma sem_sub__refint_eXrefX : ||- [TRef tint]<= [TExist vX (TRef tX)].
Proof.
(intros k).
(destruct k; intros w1; exists 1; intros v Hm).
-
(apply match_ty_ref__weak_inv in Hm).
(destruct Hm as [t' Heq]; subst).
(simpl).
exists tint.
constructor.
-
(apply match_ty_ref__inv in Hm).
(destruct Hm as [t' [Heq Href]]; subst).
(simpl).
exists t'.
(split; intros w; exists w; tauto).
Qed.
Lemma sem_sub__eXrefX_eYrefY : ||- [TExist vX (TRef tX)]<= [TExist vY (TRef tY)].
Proof.
(intros k; intros w1; exists w1; intros v Hm).
(destruct w1).
-
(apply match_ty_exist__0_inv in Hm; contradiction).
-
(apply match_ty_exist__inv in Hm).
(destruct Hm as [tx Hmx]).
(apply match_ty_exist).
exists tx.
assumption.
Qed.
Lemma sem_sub_refeXrefX_eYrefY : ||- [TRef (TExist vX (TRef tX))]<= [TExist vY (TRef tY)].
Proof.
(intros k w1).
exists (S w1).
(intros v Hm).
(apply match_ty_exist).
exists (TExist vX (TRef tX)).
assumption.
Qed.
Lemma not_sem_sub__refint_refflt : ~ ||- [TRef tint]<= [TRef tflt].
Proof.
(intros Hcontra).
specialize (Hcontra 1 0).
(destruct Hcontra as [w2 Hcontra]).
(assert (Hm : |-[ 1, 0] TRef tint <$ TRef tint) by (apply match_ty_value_type__reflexive; constructor)).
specialize (Hcontra _ Hm).
clear Hm.
(apply match_ty_ref__inv in Hcontra).
(destruct Hcontra as [t' [Heq Hcontra]]).
(inversion Heq; subst).
clear Heq.
(destruct Hcontra as [Hcontra _]).
(assert (Hm : |-[ 0, 0] tint <$ tint) by (apply match_ty_value_type__reflexive; constructor)).
specialize (Hcontra 0).
(destruct Hcontra as [w2' Hcontra]).
specialize (Hcontra _ Hm).
(apply match_ty_cname__inv in Hcontra).
(inversion Hcontra).
Qed.
Lemma sem_sub__eunion__unione : forall (X : id) (t1 t2 : ty), ||- [TExist X (TUnion t1 t2)]<= [TUnion (TExist X t1) (TExist X t2)].
Proof.
(intros X t1 t2 k).
(intros w1).
exists w1.
(intros v Hm).
(destruct w1).
-
(apply match_ty_exist__0_inv in Hm).
contradiction.
-
(apply match_ty_exist__inv in Hm).
(destruct Hm as [tx Hmx]).
(simpl in Hmx).
(apply match_ty_union__inv in Hmx).
(destruct Hmx as [Hmx| Hmx]; [ apply match_ty_union_1 | apply match_ty_union_2 ]; apply match_ty_exist; exists tx; assumption).
Qed.
Lemma sem_sub__unione__eunion : forall (X : id) (t1 t2 : ty), ||- [TUnion (TExist X t1) (TExist X t2)]<= [TExist X (TUnion t1 t2)].
Proof.
(intros X t1 t2 k).
(intros w1).
exists w1.
(intros v Hm).
(apply match_ty_union__inv in Hm).
(destruct Hm as [Hm| Hm]).
-
(destruct w1).
+
(apply match_ty_exist__0_inv in Hm).
contradiction.
+
(apply match_ty_exist__inv in Hm).
(destruct Hm as [tx Hmx]).
(simpl in Hmx).
(apply match_ty_exist).
exists tx.
(apply match_ty_union_1).
assumption.
-
(destruct w1).
+
(apply match_ty_exist__0_inv in Hm).
contradiction.
+
(apply match_ty_exist__inv in Hm).
(destruct Hm as [tx Hmx]).
(simpl in Hmx).
(apply match_ty_exist).
exists tx.
(apply match_ty_union_2).
assumption.
Qed.
Lemma sem_sub__pair_exist_distr_1 : forall (X : id) (t1 t2 : ty), ||- [TPair (TExist X t1) t2]<= [TExist X (TPair t1 t2)].
Proof.
(intros X t1 t2 k w1).
(* Auto-generated comment: Succeeded. *)


Class inhabited(A: Type): Type := mk_inhabited { default: A }.
Global Arguments mk_inhabited {_} _.
Global Hint Mode inhabited + : typeclass_instances.

Global Hint Extern 1 (inhabited _) =>
  simple refine (mk_inhabited _); constructor
  : typeclass_instances.

Module InhabitedTests.
  Goal inhabited nat. typeclasses eauto. Abort.
  Goal inhabited (list nat). typeclasses eauto. Abort.
  Goal forall A, inhabited (option A). typeclasses eauto. Abort.

  Inductive test_foo: Type :=
  | C1(x: False)
  | C2
  | C3(x: False).

  Goal inhabited test_foo. typeclasses eauto. Abort.
End InhabitedTests.

(* TODO move code below to specific files *)

Require Import coqutil.Word.Interface.
Global Instance word_inhabited{width: BinInt.Z}{word: word.word width}: inhabited word :=
  mk_inhabited (word.of_Z BinInt.Z0).

Require Import coqutil.Map.Interface.
Global Instance map_inhabited{key value: Type}{map: map.map key value}: inhabited map :=
  mk_inhabited map.empty.

Module Option.
  Definition force{A: Type}{i: inhabited A}(o: option A): A :=
    match o with
    | Some a => a
    | None => default
    end.
End Option.