Require Import ZArith String List Bool.
Require Import ExtLib.Core.ZDecidables.
Require Import ExtLib.Structures.Monads.
Require Import ExtLib.Data.Monads.OptionMonad.
Require Import ExtLib.Data.Monads.StateMonad.
Require Import ExtLib.Structures.Folds.
Require Import ExtLib.Data.Strings.
Require Import ExtLib.Data.Char.
Require Import ExtLib.Data.Lists.
Require Import ExtLib.Data.Option.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Tactics.Consider.

Set Implicit Arguments.
Set Strict Implicit.

(** Provides abstract syntax and "ugly" printer for LLVM assembly code.
    I've tried to be relatively complete but there are a few missing
    instructions, attributes, etc. that we are very unlikely to use
    (e.g., things dealing with concurrency or intrinsics.)

    The ugly printer has not been tested at all.

    We probably want to provide some some convenience on top of this
    for building abstract syntax that provides convenient defaults.
*)
Module LLVM.
  Import MonadNotation String.
  Local Open Scope string_scope.
  Local Open Scope monad_scope.
  Definition var := string.
  Definition label := string.

  Inductive cconv : Type :=
  | X86_fastcallcc | C_cc | Fast_cc | Cold_cc | CC10_cc | Num_cc : nat -> cconv.

  Inductive linkage : Type :=
  | Private | Linker_private | Linker_private_weak | Linker_private_weak_def_auto
  | Internal | Available_externally | Linkonce | Weak | Common | Appending | Extern_weak
  | Linkonce_odr | Weak_odr | External | Dllimport | Dllexport.

  Inductive visibility : Type := | Default_v | Hidden_v | Protected_v.

  Inductive param_attr : Type :=
  | Zeroext_pattr | Signext_pattr | Inreg_pattr | Byval_pattr | Sret_pattr | Noalias_pattr
  | Nocapture_pattr | Nest_pattr.

  Inductive fn_attr : Type :=
  | Address_safety | Align_stack : nat -> fn_attr | Alwaysinline | Nonlazybind | Inlinehint
  | Naked | Noimplicitfloat | Noinline | Noredzone | Noreturn | Nounwind
  | Optsize | Readnone | Readonly | Returns_twice | Ssp | Sspreq | Uwtable.

  Inductive type : Type :=
  | I_t : nat -> type
  | Half_t | Float_t | Double_t | X86_fp80_t | Fp128_t | Ppc_fp128_t
  | Void_t | Label_t | X86mmx_t | Metadata_t
  | Array_t : list nat -> type -> type
  | Fn_t : forall (returntype: type) (arg_types : list type) (vararg : bool), type
  | Struct_t : forall (packed:bool) (elts : list type), type
  | Named_t : string -> type
  | Opaque_t : type
  | Pointer_t : forall (addrspace:nat), type -> type
  | Vector_t : nat -> type -> type.

  Inductive constant : Type :=
  | True_c
  | False_c
  | Int_c : Z -> constant
  | Float_c : string -> constant
  | Null_c : constant
  | Global_c : var -> constant
  | Undef_c : constant
  | Zero_c : constant
  | Struct_c : list constant -> constant
  | Array_c : list constant -> constant
  | Vector_c : list constant -> constant
  | Metadata_c : list constant -> constant
  | Metastring_c : string -> constant
  | Ptrtoint_c : type -> constant -> type -> constant
  | Inttoptr_c : type -> constant -> type -> constant
  | Bitcast_c : type ->constant -> type -> constant.

  Inductive value : Type :=
  | Local : var -> value
  | Global : var -> value
  | AnonLocal : nat -> value
  | AnonGlobal : nat -> value
  | Constant : constant -> value.

  Inductive cond : Type :=
  | Eq | Ne | Ugt | Uge | Ult | Ule | Sgt | Sge | Slt | Sle.

  Inductive fcond : Type :=
  | False_fc | Oeq_fc | Ogt_fc | Oge_fc | Olt_fc | Ole_fc | One_fc | Ord_fc | Ueq_fc
  | Ugt_fc | Uge_fc | Ult_fc | Ule_fc | Une_fc | Uno_fc | True_fc.

  Inductive exp : Type :=
  | Add_e : forall (nuw:bool) (nsw:bool) (ty:type) (op1:value) (op2:value), exp
  | Fadd_e : forall (ty:type) (op1:value) (op2:value), exp
  | Sub_e : forall (nuw:bool) (nsw:bool) (ty:type) (op1:value) (op2:value), exp
  | Fsub_e : forall (ty:type) (op1:value) (op2:value), exp
  | Mul_e : forall (nuw:bool) (nsw:bool) (ty:type) (op1:value) (op2:value), exp
  | Fmul_e : forall (ty:type) (op1:value) (op2:value), exp
  | Udiv_e : forall (exact:bool) (ty:type) (op1 op2:value), exp
  | Sdiv_e : forall (exact:bool) (ty:type) (op1 op2:value), exp
  | Fdiv_e : forall (ty:type) (op1:value) (op2:value), exp
  | Urem_e : forall (ty:type) (op1:value) (op2:value), exp
  | Srem_e : forall (ty:type) (op1:value) (op2:value), exp
  | Frem_e : forall (ty:type) (op1:value) (op2:value), exp
  | Shl_e : forall (nuw:bool) (nsw:bool) (ty:type) (op1:value) (op2:value), exp
  | Lshr_e : forall (exact:bool) (ty:type) (op1 op2:value), exp
  | Ashr_e : forall (exact:bool) (ty:type) (op1 op2:value), exp
  | And_e : forall (ty:type) (op1 op2:value), exp
  | Or_e : forall (ty:type) (op1 op2:value), exp
  | Xor_e : forall (ty:type) (op1 op2:value), exp
  | Extractvalue_e : type -> value -> nat -> list nat -> exp
  | Insertvalue_e : type -> value -> type -> value -> nat -> list nat -> exp
  | Alloca_e : type -> option (type * nat) -> option nat -> exp
  | Load_e : forall (atomic:bool) (volatile:bool) (ty:type) (pointer:value) (align:option nat)
                    (nontemporal:option nat) (invariant:option nat) (singlethread:bool), exp
  | Getelementptr_e : forall (inbounds:bool)(pointer_ty:type) (pointerval: value), list (type * value) -> exp
  | Trunc_e : type -> value -> type -> exp
  | Zext_e : type -> value -> type -> exp
  | Sext_e : type -> value -> type -> exp
  | Fptrunc_e : type -> value -> type -> exp
  | Fpext_e : type -> value -> type -> exp
  | Fptoui_e : type -> value -> type -> exp
  | Fptosi_e : type -> value -> type -> exp
  | Uitofp_e : type -> value -> type -> exp
  | Sitofp_e : type -> value -> type -> exp
  | Ptrtoint_e : type -> value -> type -> exp
  | Inttoptr_e : type -> value -> type -> exp
  | Bitcast_e : type -> value -> type -> exp
  | Icmp_e : cond -> type -> value -> value -> exp
  | Fcmp_e : fcond -> type -> value -> value -> exp
  | Phi_e : type -> list (value * label) -> exp
  | Select_e : type -> value -> type -> value -> type -> value -> exp
  | Call_e : forall (tail:bool) (convention: option cconv) (ret_attrs:list param_attr) (ty:type)
                    (fnptrty: option type) (fnptr:value)
                    (args : list (type * value * (list param_attr)))
                    (fn_attrs: list fn_attr), exp.

  Definition flag(b:bool)(s:string) : string := if b then s else "".

  Inductive instr : Type :=
  | Comment_i : string -> instr
  | Ret_i : option (type * value) -> instr
  | Br_cond_i : value -> label -> label -> instr
  | Br_uncond_i : label -> instr
  | Switch_i : type -> value -> label -> list (type * Z * label) -> instr
  | Resume_i : type -> value -> instr
  | Unreachable_i : instr
  | Assign_i : (option value) -> exp -> instr
  | Store_i : forall (atomic:bool) (volatile:bool) (ty:type) (v:value) (ptrty:type) (pointer:value)
                     (align:option nat) (nontemporal:option nat) (singlethread:bool), instr.

  Record fn_header : Type := {
    linkage_fh : option linkage ;
    visibility_fh : option visibility ;
    cconv_fh : option cconv ;
    unnamed_addr_fh : bool ;
    return_type_fh : type ;
    return_type_attrs_fh : list param_attr ;
    name_fh : var ;
    args_fh : list (type * var * list (param_attr)) ;
    attrs_fh : list fn_attr ;
    section_fh : option string ;
    align_fh : option nat ;
    gc_fh : option string
  }.

  Definition block := ((option label) * (list instr))%type.

  Inductive topdecl : Type :=
  | Global_d : forall (x:var) (addrspace:option nat) (l:option linkage) (unnamed_addr:bool) (const:bool)
                      (t:type) (c:constant) (section:option string) (align:option nat), topdecl
  | Define_d : fn_header -> list block -> topdecl
  | Declare_d : fn_header -> topdecl
  | Alias_d : forall (x:var) (l:option linkage) (v:option visibility) (t:type) (e:exp), topdecl
  | Metadata_d : forall (x:var), list constant -> topdecl.

  Definition module := list topdecl.

  Fixpoint eq_type x y : bool :=
    match x , y with
      | I_t n , I_t n' => eq_dec n n'
      | Half_t , Half_t => true
      | Float_t , Float_t => true
      | Double_t , Double_t => true
      | X86_fp80_t , X86_fp80_t => true
      | Fp128_t , Fp128_t => true
      | Ppc_fp128_t , Ppc_fp128_t => true
      | Void_t , Void_t => true
      | Label_t , Label_t => true
      | X86mmx_t , X86mmx_t => true
      | Metadata_t , Metadata_t => true
      | Array_t ns t , Array_t ns' t' =>
        eq_dec ns ns' && eq_type t t'
      | Fn_t r a b , Fn_t r' a' b' =>
        eq_type r r' && eq_dec b b' &&
        (fix recur l r :=
          match l , r with
            | nil , nil => true
            | cons l ls , cons r rs =>
              if eq_type l r then recur ls rs else false
            | _ , _ => false
          end) a a'
      | Struct_t b e , Struct_t b' e' =>
        eq_dec b b' &&
        (fix recur l r :=
          match l , r with
            | nil , nil => true
            | cons l ls , cons r rs =>
              if eq_type l r then recur ls rs else false
            | _ , _ => false
          end) e e'
      | Named_t n , Named_t n' =>
        eq_dec n n'
      | Pointer_t a t , Pointer_t a' t' =>
        eq_dec a a' && eq_type t t'
      | Vector_t n t , Vector_t n' t' =>
        eq_dec n n' && eq_type t t'
      | _ , _ => false
  end.

  Global Instance RelDec_eq_LLVMtype : RelDec (@eq LLVM.type) :=
  { rel_dec := eq_type }.

  Fixpoint eq_constant x y : bool :=
    match x , y with
      | True_c , True_c
      | False_c , False_c
      | Null_c , Null_c
      | Undef_c , Undef_c
      | Zero_c , Zero_c => true
      | Int_c i1, Int_c i2 => eq_dec i1 i2
      | Float_c c1, Float_c c2 => eq_dec c1 c2
      | Global_c v , Global_c v' => eq_dec v v'
      | Struct_c v , Struct_c v'
      | Array_c v, Array_c v'
      | Vector_c v , Vector_c v'
      | Metadata_c v , Metadata_c v' =>
        (fix rec xs ys : bool :=
          match xs , ys with
            | nil , nil => true
            | x :: xs , y :: ys =>
              eq_constant x y && rec xs ys
            | _ , _ => false
          end) v v'
      | Metastring_c v , Metastring_c v' => eq_dec v v'
      | Ptrtoint_c t1 c t2 , Ptrtoint_c t1' c' t2' =>
        eq_constant c c' && eq_dec t1 t1' && eq_dec t2 t2'
      | Inttoptr_c t1 c t2 , Inttoptr_c t1' c' t2' =>
        eq_constant c c' && eq_dec t1 t1' && eq_dec t2 t2'
      | Bitcast_c t1 c t2 , Bitcast_c t1' c' t2' =>
        eq_constant c c' && eq_dec t1 t1' && eq_dec t2 t2'
      | _ , _ => false
    end.

  Global Instance RelDec_eq_constant : RelDec (@eq LLVM.constant) :=
  { rel_dec := eq_constant }.

  Global Instance RelDec_eq_value : RelDec (@eq value) :=
  { rel_dec := fun x y =>
    match x , y with
      | Local v, Local v' => eq_dec v v'
      | Global v , Global v' => eq_dec v v'
      | AnonLocal v, AnonLocal v' => eq_dec v v'
      | AnonGlobal v, AnonGlobal v' => eq_dec v v'
      | Constant c, Constant c' => eq_dec c c'
      | _ , _ => false
    end }.

  Section Printing.
    Require Import ExtLib.Programming.Show.
    Import ShowNotation.
    Local Open Scope show_scope.

    Global Instance Show_cconv : Show cconv :=
      fun c =>
        match c with
          | X86_fastcallcc => "x86_fastcallcc"
          | C_cc => "ccc" | Fast_cc => "fastcc" | Cold_cc => "coldcc" | CC10_cc => "cc 10"
          | Num_cc n => "cc " << show n
        end.

    Global Instance Show_linkage : Show linkage :=
      fun l =>
        match l with
          | Private => "private"
          | Linker_private => "linker_private"
          | Linker_private_weak => "linker_private_weak"
          | Linker_private_weak_def_auto => "linker_private_weak_def_auto"
          | Internal => "internal"
          | Available_externally => "available_externally"
          | Linkonce => "linkonce"
          | Weak => "weak"
          | Common => "common"
          | Appending => "appending"
          | Extern_weak => "extern_weak"
          | Linkonce_odr => "linkonce_odr"
          | Weak_odr => "weak_odr"
          | External => "external"
          | Dllimport => "dllimport"
          | Dllexport => "dllexport"
        end.

    Global Instance Show_param_attr : Show param_attr :=
      fun p =>
        match p with
          | Zeroext_pattr => "zeroext" | Signext_pattr => "signext" | Inreg_pattr => "inreg"
          | Byval_pattr => "byval" | Sret_pattr => "sret" | Noalias_pattr => "noalias"
          | Nocapture_pattr => "nocapture" | Nest_pattr => "nest"
        end.

    Definition double_quote := Ascii.ascii_of_nat 34.
    Definition quoted := wrap double_quote double_quote.

    Global Instance Show_visibility : Show visibility :=
      fun v => quoted
        match v with
          | Default_v => "default" | Hidden_v => "hidden" | Protected_v => "protected"
        end.

    Global Instance Show_fn_attr : Show fn_attr :=
      fun f =>
        match f with
          | Address_safety => "address_safety"
          | Align_stack n => "alignstack(" << show n << ")"
          | Alwaysinline => "alwaysinline"
          | Nonlazybind => "nonlazybind"
          | Inlinehint => "inlinehint"
          | Naked => "naked"
          | Noimplicitfloat => "noimplicitfloat"
          | Noinline => "noinline"
          | Noredzone => "noredzone"
          | Noreturn => "noreturn"
          | Nounwind => "nounwind"
          | Optsize => "optsize"
          | Readnone => "readnone"
          | Readonly => "readonly"
          | Returns_twice => "returns_twice"
          | Ssp => "ssp"
          | Sspreq => "sspreq"
          | Uwtable => "uwtable"
        end.

    Global Instance Show_type : Show type :=
      fix show_type (t : type) : showM :=
        match t with
          | I_t n => "i" << show n
          | Half_t => "half"
          | Float_t => "float"
          | Double_t => "double"
          | X86_fp80_t => "x86_fp80"
          | Fp128_t => "fp128"
          | Ppc_fp128_t => "ppc_fp128"
          | Void_t => "void"
          | Label_t => "label"
          | X86mmx_t => "x86mmx"
          | Metadata_t => "metadata"
          | Array_t ns t =>
            List.fold_right (fun (i:nat) (t:showM) =>
                         "[" << show i << " x " << t << "]") (show_type t) ns
          | Fn_t t ts vararg =>
            show_type t << "(" << sepBy ", " (List.map show_type ts) <<
            (if vararg then ",...)" else ")")
          | Struct_t packed elts =>
            let s := "{" << (sepBy ", " (List.map show_type elts)) << "}" in
            if packed then "<" << s << ">" else s
          | Named_t x => x
          | Opaque_t => "opaque"
          | Pointer_t 0 t => show_type t << " *"
          | Pointer_t n t => show_type t << "addrspace(" << show n << ") *"
          | Vector_t n t => "<" << show n << " x " << show_type t << ">"
        end.

    Global Instance Show_constant : Show constant :=
      fix show_constant c :=
        match c return showM with
          | True_c => "true"
          | False_c => "false"
          | Int_c i => show i
          | Float_c s => s
          | Null_c =>  "null"
          | Global_c v => v
          | Undef_c => "undef"
          | Zero_c => "zeroinitializer"
          | Struct_c cs => "{" << sepBy ", " (List.map show_constant cs) << "}"
          | Array_c cs => "[" << sepBy ", " (List.map show_constant cs) << "]"
          | Vector_c cs => "<" << sepBy ", " (List.map show_constant cs) << ">"
          | Metastring_c s => "!" << quoted s
          | Metadata_c cs => "!{" << sepBy ", " (List.map show_constant cs) << "}"
          | Ptrtoint_c t1 c t2 => "ptrtoint (" << (show t1) << " " << (show_constant c) << " to " << (show t2) << ")"
          | Inttoptr_c t1 c t2 => "inttoptr (" << (show t1) << " " << (show_constant c) << " to " << (show t2) << ")"
          | Bitcast_c t1 c t2 => "bitcast (" << (show t1) << " " << (show_constant c) << " to " << (show t2) << ")"
        end.

    Global Instance Show_value : Show value :=
      fun v =>
        match v with
          | Local x => "%" << x
          | Global x => "@" << x
          | AnonLocal n => "%" << show n
          | AnonGlobal n => "@" << show n
          | Constant c => show c
        end.

    Global Instance Show_cond : Show cond :=
      fun c =>
        match c with
          | Eq => "eq" | Ne => "ne" | Ugt => "ugt" | Uge => "uge" | Ult => "ult" | Ule => "ule"
          | Sgt => "sgt" | Sge => "sge" | Slt => "slt" | Sle => "sle"
        end.

    Global Instance Show_fcond : Show fcond :=
      fun f =>
        match f with
          | False_fc => "false" | Oeq_fc => "oeq" | Ogt_fc => "ogt" | Oge_fc => "oge" | Olt_fc => "olt"
          | Ole_fc => "ole" | One_fc => "one" | Ord_fc => "ord" | Ueq_fc => "ueq" | Ugt_fc => "ugt"
          | Uge_fc => "uge" | Ult_fc => "ult" | Ule_fc => "ule" | Une_fc => "une" | Uno_fc => "uno"
          | True_fc => "true"
        end.

    Definition option_show (T : Type) (f : T -> showM) (o : option T) : showM :=
      match o with
        | None => empty
        | Some x => f x
      end.

    Global Instance Show_option (T : Type) {S : Show T} : Show (option T) :=
      fun x => option_show show x.

    Definition show_fn_header (drop_vars:bool) (fh:fn_header) : showM :=
      show (linkage_fh fh) << " " <<
      show (visibility_fh fh) << " " <<
      show (cconv_fh fh) << " " <<
      (if (unnamed_addr_fh fh) then "unnamed_addr " else empty) <<
      show (return_type_fh fh) << " " <<
      iter_show (map (fun x => show x << " ") (return_type_attrs_fh fh)) <<
      "@" << name_fh fh << "(" <<
      sepBy ", "
            (map (fun (p : type * var * list param_attr) =>
              let '(t, x, attrs) := p in
              show t <<
              (if drop_vars then empty else " %"%string << x) <<
              iter_show (map (fun x => show x << " ") attrs))
              (args_fh fh)) <<
      ") " <<
      iter_show (map (fun x => show x << " ") (attrs_fh fh)) <<
      option_show (fun s : string => ", section " << quoted s << " ") (section_fh fh) <<
      option_show (fun n => ", align " << show n << " ") (align_fh fh) <<
      option_show (fun s : string => "gc " << quoted s << " ") (gc_fh fh).

    Definition show_arith(opcode:string)(nuw nsw:bool)(ty:type)(op1 op2:value) : showM :=
      opcode << " " << flag nuw "nuw " << flag nsw "nsw " << show ty << " " <<
      show op1 << ", " << show op2.

    Definition show_binop(opcode:string)(ty:type)(op1 op2:value) : showM :=
      show_arith opcode false false ty op1 op2.

    Definition show_logical(opcode:string)(ex:bool)(ty:type)(op1 op2:value) : showM :=
      opcode << " " << flag ex "exact " << show ty << " " << show op1 << ", " << show op2.

    Definition show_conv(opcode:string)(ty1:type)(op:value)(ty2:type) : showM :=
      opcode << " " << show ty1 << " " << show op << " to " << show ty2.

    Definition show_alloca (ty : type) (opttynum : option (type * nat)) (optalign : option nat) : showM :=
      "alloca " << show ty <<
      match opttynum return showM with
        | None => ""
        | Some (ty,n) => ", " << show ty << " " << show n
      end <<
      match optalign return showM with
        | None => ""
        | Some n => ", align " << show n
      end.

    Definition show_call (tail : bool) (conv : option cconv) (ret_attrs : list param_attr)
      (ty : type) (fnptrty : option type) (fnptr : value) (args : list (type * value * list param_attr)) (fnattrs : list fn_attr) : showM :=
      flag tail "tail " << "call " << option_show show conv << " " <<
      sepBy " " (List.map show ret_attrs) << " " <<
      show ty << " " << option_show show fnptrty <<
      show fnptr << "(" <<
      (sepBy ", " (List.map (fun x => match x with | (t,v,a) =>
                                        (show t) << " " << (show v) <<
                                        (sepBy " " (List.map show a))
                                      end) args))
      << ") " << sepBy " " (List.map show fnattrs).

    Global Instance Show_exp : Show exp :=
    { show := fun e =>
        match e with
          | Add_e nuw nsw ty op1 op2 => show_arith "add" nuw nsw ty op1 op2
          | Fadd_e ty op1 op2 => show_binop "fadd" ty op1 op2
          | Sub_e nuw nsw ty op1 op2 => show_arith "sub" nuw nsw ty op1 op2
          | Fsub_e ty op1 op2 => show_binop "fsub" ty op1 op2
          | Mul_e nuw nsw ty op1 op2 => show_arith "mul" nuw nsw ty op1 op2
          | Fmul_e ty op1 op2 => show_binop "fmul" ty op1 op2
          | Udiv_e ex ty op1 op2 => show_logical "udiv" ex ty op1 op2
          | Sdiv_e ex ty op1 op2 => show_logical "sdiv" ex ty op1 op2
          | Fdiv_e ty op1 op2 => show_binop "fdiv" ty op1 op2
          | Urem_e ty op1 op2 => show_binop "urem" ty op1 op2
          | Srem_e ty op1 op2 => show_binop "srem" ty op1 op2
          | Frem_e ty op1 op2 => show_binop "frem" ty op1 op2
          | Shl_e nuw nsw ty op1 op2 => show_arith "shl" nuw nsw ty op1 op2
          | Lshr_e ex ty op1 op2 => show_logical "lshr" ex ty op1 op2
          | Ashr_e ex ty op1 op2 => show_logical "ashr" ex ty op1 op2
          | And_e ty op1 op2 => show_binop "and" ty op1 op2
          | Or_e ty op1 op2 => show_binop "or" ty op1 op2
          | Xor_e ty op1 op2 => show_binop "xor" ty op1 op2
          | Extractvalue_e ty op n ns =>
            "extractvalue " << show ty << " " << show op << ", " <<
            sepBy ", " (List.map show (n::ns))
          | Insertvalue_e ty1 op1 ty2 op2 n ns =>
            "insertvalue " << show ty1 << " " << show op1 << ", " <<
            show ty2 << " " << show op2 << ", " <<
            sepBy ", " (List.map show (n::ns))
          | Alloca_e ty opttynum optalign => show_alloca ty opttynum optalign
          | Load_e atomic volatile ty pointer align nontemporal invariant singlethread =>
            (* fixme: just doing the simple stuff here *)
           "load " << flag atomic "atomic " << flag volatile "volatile " <<
            show ty << " " << show pointer << " " << flag singlethread "singlethread " <<
            match align return showM with
              | None => ""
              | Some n => ", align " << show n
            end
          | Getelementptr_e inbounds ty v indexes =>
            "getelementptr " << (flag inbounds "inbounds ") << (show ty) << " " <<
            (sepBy ", " ((show v)::
              (List.map (fun p => (show (fst p)) << " " << (show (snd p))) indexes)))
          | Trunc_e ty1 v ty2 => show_conv "trunc" ty1 v ty2
          | Zext_e ty1 v ty2 => show_conv "zext" ty1 v ty2
          | Sext_e ty1 v ty2 => show_conv "sext" ty1 v ty2
          | Fptrunc_e ty1 v ty2 => show_conv "fptrunc" ty1 v ty2
          | Fpext_e ty1 v ty2 => show_conv "fpext" ty1 v ty2
          | Fptoui_e ty1 v ty2 => show_conv "fptoui" ty1 v ty2
          | Fptosi_e ty1 v ty2 => show_conv "fptosi" ty1 v ty2
          | Uitofp_e ty1 v ty2 => show_conv "uitofp" ty1 v ty2
          | Sitofp_e ty1 v ty2 => show_conv "sitofp" ty1 v ty2
          | Ptrtoint_e ty1 v ty2 => show_conv "ptrtoint" ty1 v ty2
          | Inttoptr_e ty1 v ty2 => show_conv "inttoptr" ty1 v ty2
          | Bitcast_e ty1 v ty2 => show_conv "bitcast" ty1 v ty2
          | Icmp_e cond ty v1 v2 => "icmp " << (show cond) << " " << (show ty) <<
            (show v1) << ", " << (show v2)
          | Fcmp_e cond ty v1 v2 => "fcmp " << (show cond) << " " << (show ty) <<
            (show v1) << ", " << (show v2)
          | Phi_e ty vls =>
            "phi " << show ty << " " <<
            sepBy ", " (List.map (fun p : (value * label) => "[ " << show (fst p) << ", %" << (snd p) << " ]") vls)
          | Select_e ty1 v1 ty2 v2 ty3 v3 =>
            "select " << (show ty1) << " " << (show v1) << ", " <<
            (show ty2) << " " << (show v2) << ", " <<
            (show ty3) << " " << (show v3)
          | Call_e tail conv ret_attrs ty fnptrty fnptr args fnattrs =>
            show_call tail conv ret_attrs ty fnptrty fnptr args fnattrs
        end }.

    Global Instance Show_instr : Show instr :=
      fun i =>
        match i with
          | Comment_i s => "; " << s
          | Ret_i vopt =>
            "ret " <<
            option_show (fun p => show (fst p) << " " << show (snd p)) vopt
          | Br_cond_i v l1 l2 =>
            "br i1 " << show v << ", label %" << l1 << ", label %" << l2
          | Br_uncond_i l =>
            "br label %"<< l
          | Switch_i t v def arms =>
            "switch " << show t << " " << show v << ", label %" << def << " [" <<
            sepBy " " (List.map (fun p : type * Z * label =>
              let '(t,i,l) := p in
              show t << " " << show i << ", label %" << l) arms) << " ]"
          | Resume_i t v =>
            "resume " << show t << " " << show v
          | Unreachable_i => "unreachable"
          | Assign_i (Some x) e => show x << " = " << show e
          | Assign_i None e => show e
          | Store_i atomic volatile ty v ptrty pointer align nontemporal singlethread =>
            (* fix -- doesn't do nontemporal or ordering *)
            "store " << flag atomic "atomic " << flag volatile "volatile " << show ty << " " <<
            show v << ", " << show ptrty << " " << show pointer << " " <<
            flag singlethread "singlethread " <<
            option_show (fun n => ", align " << show n << " ") align
        end.

    Global Instance Show_block : Show block :=
      fun b =>
        match fst b with
          | None => "  "
          | Some l =>
            l << ":" << chr_newline << "  "
        end
        << indent "  " (sepBy Char.chr_newline (map show (snd b))).

    Global Instance Show_topdecl : Show topdecl :=
      fun t =>
        match t return showM with
          | Global_d x a l u c t v s al =>
            x << " = " <<
            option_show (fun n => "addrspace(" << show n << ")") a <<
            option_show show l <<
            (if u then "unnamed_addr " else empty) <<
            (if c then "constant " else empty) <<
            show t << " " <<
            show v << " " <<
            option_show (fun s : string => ", section " << quoted s << " ") s <<
            option_show (fun n => ", align " << show n << " ") al <<
            chr_newline
          | Define_d fh bs => "define " <<
            show_fn_header false fh << " {" << indent "  " (chr_newline << sepBy Char.chr_newline (map show bs)) << chr_newline << "}" << chr_newline
          | Declare_d fh => "declare " << show_fn_header true fh << chr_newline
          | Alias_d x l v t e =>
            x << " = alias " <<
            show l <<
            show v <<
            show t << " " <<
            show e << chr_newline
          | Metadata_d x cs =>
            x << " = metadata !{" << sepBy ", " (List.map show cs) <<
            "}" << chr_newline
        end.

    Global Instance Show_module : Show module :=
      fun m => sepBy Char.chr_newline (map show m).

    Definition string_of_module (m : module) : string := runShow (show m) "".
    Definition string_of_topdecl (t : topdecl) : string := runShow (show t) "".
    Definition string_of_fn_header (b : bool) (h : fn_header) : string := runShow (show_fn_header b h) "".

  End Printing.
End LLVM.


Require Import VST.floyd.proofauto.
Require Import common_predicates.
Require Import sll_append.
From SSL_VST Require Import core.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition sll_append_spec :=
  DECLARE _sll_append
   WITH x1: val, r: val, x2: val, s2: (list Z), _alpha_526: sll_card, _alpha_525: sll_card, s1: (list Z)
   PRE [ (tptr (Tunion _sslval noattr)), (tptr (Tunion _sslval noattr)) ]
   PROP( is_pointer_or_null((x1 : val)); is_pointer_or_null((r : val)); is_pointer_or_null((x2 : val)) )
   PARAMS(x1; r)
   SEP ((data_at Tsh (tarray (Tunion _sslval noattr) 1) [(inr (x2 : val))] (r : val)); (sll (x1 : val) (s1 : list Z) (_alpha_525 : sll_card)); (sll (x2 : val) (s2 : list Z) (_alpha_526 : sll_card)))
   POST[ tvoid ]
   EX _alpha_527: sll_card,
   EX y: val,
   EX s: (list Z),
   PROP( ((s : list Z) = ((s1 : list Z) ++ (s2 : list Z))); is_pointer_or_null((y : val)) )
   LOCAL()
   SEP ((data_at Tsh (tarray (Tunion _sslval noattr) 1) [(inr (y : val))] (r : val)); (sll (y : val) (s : list Z) (_alpha_527 : sll_card))).

Definition Gprog : funspecs :=
  ltac:(with_library prog [sll_append_spec]).

Lemma body_sll_append : semax_body Vprog Gprog f_sll_append sll_append_spec.
Proof.

start_function.
ssl_open_context.
assert_PROP (isptr r). { entailer!. }
try rename x2 into x22.
forward.
forward_if.

 - {
assert_PROP (_alpha_525 = sll_card_0) as ssl_card_assert. { entailer!; ssl_dispatch_card. }
ssl_card sll ssl_card_assert .
assert_PROP (((x1 : val) = nullval)). { entailer!. }
let ssl_var := fresh in assert_PROP(s1 = ([] : list Z)) as ssl_var; try rewrite ssl_var in *. { entailer!. }
forward; entailer!.
Exists (_alpha_526 : sll_card).
Exists (x22 : val).
Exists (([] : list Z) ++ (s2 : list Z)).
ssl_entailer.

}
 - {
assert_PROP (exists _alpha_524, _alpha_525 = sll_card_1 _alpha_524) as ssl_card_assert. { entailer!; ssl_dispatch_card. }
ssl_card sll ssl_card_assert _alpha_524x1.
assert_PROP ((~ ((x1 : val) = nullval))). { entailer!. }
Intros vx1 s1x1 nxtx1.
let ssl_var := fresh in assert_PROP(s1 = (([(vx1 : Z)] : list Z) ++ (s1x1 : list Z))) as ssl_var; try rewrite ssl_var in *. { entailer!. }
try rename vx1 into vx12.
forward.
try rename nxtx1 into nxtx12.
forward.
assert_PROP(is_pointer_or_null((nxtx12 : val))). { entailer!. }
assert_PROP(is_pointer_or_null((r : val))). { entailer!. }
assert_PROP(is_pointer_or_null((x22 : val))). { entailer!. }
forward_call ((nxtx12 : val), (r : val), (x22 : val), (s2 : list Z), (_alpha_526 : sll_card), (_alpha_524x1 : sll_card), (s1x1 : list Z)).
let ret := fresh vret in Intros ret; destruct ret as [[_alpha_5271 y1] s3].
assert_PROP(is_pointer_or_null((y1 : val))). { entailer!. }
let ssl_var := fresh in assert_PROP(s3 = ((s1x1 : list Z) ++ (s2 : list Z))) as ssl_var; try rewrite ssl_var in *. { entailer!. }
try rename y1 into y12.
forward.
forward.
forward.
forward; entailer!.
Exists (sll_card_1 (_alpha_5271 : sll_card) : sll_card).
Exists (x1 : val).
Exists ((([(vx12 : Z)] : list Z) ++ (s1x1 : list Z)) ++ (s2 : list Z)).
ssl_entailer.
rewrite (unfold_sll_card_1 (_alpha_5271 : sll_card)) at 1.
Exists (vx12 : Z).
Exists ((s1x1 : list Z) ++ (s2 : list Z)).
Exists (y12 : val).
ssl_entailer.

}

Qed.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
Require Import ZArith Lia.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require Import seq_ext.
Require Import machine_int.
Require Import mips_seplog mips_frame mips_tactics.
Import MachineInt.

Local Open Scope heap_scope.
Import mips_bipl.expr_m.
Local Open Scope mips_expr_scope.
Import mips_bipl.assert_m.
Local Open Scope mips_assert_scope.
Local Open Scope mips_cmd_scope.
Local Open Scope mips_hoare_scope.

Lemma dom_heap_invariant0 s c s' : s -- c ----> s' ->
  forall st h st' h', s = Some (st, h) -> s' = Some (st', h') ->
    heap.dom h = heap.dom h'.
Proof.
case=> //; clear s c s'.
- (* nop *) move=> s st h st' h' -> [] _ <- //.
- (* add *) move=> st h rd rs rt Hcond st_ h_ st' h' [] _ <- [] _ <- //.
- (* addi *) move=> st h rd rs rt Hcond st_ h_ st' h' [] _ <- [] _ <- //.
- (* addiu *) move=> st h rt rs imm st_ h_ st' h' [] _ <- [] _ <- //.
- (* addu *) move=> st h rd rs rt st_ h_ st' h' [] _ <- [] _ <- //.
- (* cmd_and *) move=> st h rd rs rt st_ h_ st' h' [] _ <- [] _ <- //.
- (* andi *) move=> st h rt rs imm st_ h_ st' h' [] _ <- [] _ <- //.
- (* lw *) move=> st h rt off base p z Hp Hz st_ h_ st' h' [] _ <- [] _ <- //.
- (* lwxs *) move=> st h rt idx base p z Hp Hz st_ h_ st' h' [] _ <- [] _ <- //.
- (* maddu *) move=> st h rs rt st_ h_ st' h' [] _ <- [] _ <- //.
- (* mfhi *) move=> st h rd st_ h_ st' h' [] _ <- [] _ <- //.
- (* mflhxu *) move=> st h rd st_ h_ st' h' [] _ <- [] _ <- //.
- (* mflo *) move=> st h rd st_ h_ st' h' [] _ <- [] _ <- //.
- (* movn *) move=> st h rd rs rt Hcond st_ h_ st' h' [] _ <- [] _ <- //.
- move=> st h _ _ rt Hcond st_ h_ st' h' [] _ <- [] _ <- //.
- (* movz *) move=> st h rd rs rt Hcond st_ h_ st' h' [] _ <- [] _ <- //.
- move=> st h _ _ rt Hcond st_ h_ st' h' [] _ <- [] _ <- //.
- (* msubu *) move=> st h rs rt st_ h_ st' h' [] _ <- [] _ <- //.
- (* mthi *) move=> st h rs st_ h_ st' h' [] _ <- [] _ <- //.
- (* mtlo *) move=> st h rs st_ h_ st' h' [] _ <- [] _ <- //.
- (* multu *) move=> st h rs rt st_ h_ st' h' [] _ <- [] _ <- //.
- (* nor *) move=> st h rd rs rt st_ h_ st' h' [] _ <- [] _ <- //.
- (* cmd_or *) move=> st h rd rs rt st_ h_ st' h' [] _ <- [] _ <- //.
- (* sll *) move=> st h rx ry sa st_ h_ st' h' [] _ <- [] _ <- //.
- (* sllv *) move=> st h rd rt rs st_ h_ st' h' [] _ <- [] _ <- //.
- (* sltu *) move=> st h rd rt rs st_ h_ st' h' st'_ h'_ [] _ <- [] _ <- //.
- (* sra *) by move=> st h rd rt sa st_ h_ st' h' [] _ <- [] _ <-.
- (* srl *) by move=> st h rd rt sa st_ h_ st' h' [] _ <- [] _ <-.
- (* srlv *) by move=> st h rd rt rs st_ h_ st' h' [] _ <- [] _ <-.
- (* subu *) by move=> st h rd rs rt st_ h_ st' h' [] _ <- [] _ <-.
- (* sw *) move=> st h rt off base p Hp [z Hz] st_ h_ st'_ h'_ [] _ <- [] _ <-.
  by rewrite heap.dom_upd_invariant.
- (* xor *) by move=> st h rd rs rt st_ h_ st' h' [] _ <- [] _ <-.
- (* xori *) by move=> st h rt rs imm st_ h_ st' h' [] _ <- [] _ <-.
Qed.

Lemma dom_heap_invariant' s c s' : s -- c ---> s' ->
  forall st h st' h', s = Some (st, h) -> s' = Some (st', h') ->
    heap.dom h = heap.dom h'.
Proof.
elim=> //; clear s c s'.
- (* cmd0 *) move=> s c s' H st he st' he' Hs Hs'.
  by eapply dom_heap_invariant0; eauto.
- (* seq *) move=> s s' s'' c d Hc IHc Hd IHd /= st he st'' he'' Hs Hs''.
  destruct s' as [[st' he']|]; last first.
    move/semop_prop_m.from_none : Hd => Hd.
    by subst.
  eapply trans_eq.
  by eapply IHc; eauto.
  by eapply IHd; eauto.
- (* while true *) move=> [st h] s' s'' t c Ht Hc IH1 Hwhile IH2 st_ h_ st'' h'' [] _ <- Hs''.
  destruct s' as [[st' h']|].
  apply trans_eq with (heap.dom h').
  by apply (IH1 _ _ _ _ (refl_equal _) (refl_equal _)).
  eapply IH2; eauto.
  destruct s'' => //.
  by move/semop_prop_m.from_none : Hwhile.
- (* while false *)  by move=> [st h] t _ Ht st_ h_ st' h' [] _ <- [] _ <-.
Qed.

Lemma dom_heap_invariant s h c s' h' : Some (s, h) -- c ---> Some (s', h') ->
  heap.dom h = heap.dom h'.
Proof. intros. eapply dom_heap_invariant'; eauto. Qed.

Lemma reg_unchanged0 : forall (c : cmd0) st h st' h',
  Some (st, h) -- c ----> Some (st', h') ->
  forall x, x \notin (mips_frame.modified_regs c) ->
    [x]_st = [x]_st'.
Proof.
elim.
- move=> st h st' h'.
  case/exec0_nop_inv=> X Y; by subst.
- move=> rt rs imm st h st' h'.
  case/exec0_add_inv.
  + case=> H1 [] Hst' Hh'; subst => x /=.
    rewrite negb_and orbC /=.
    move/eqP => X.
    by rewrite store.get_upd.
  + by case.
- move=> rt rs imm st h st' h'.
  case/exec0_addi_inv.
  + case=> H1 [] Hst' Hh'; subst => x /=.
    rewrite negb_and orbC /=.
    move/eqP => X.
    by rewrite store.get_upd.
  + by case.
- move=> rt rs imm st h st' h'.
  case/exec0_addiu_inv=> Hst' Hh'; subst => x /=.
  rewrite negb_and orbC /=.
  move/eqP => X.
  by rewrite store.get_upd.
- move=> rd rs rt st h st' h'.
  case/exec0_addu_inv => Hst' Hh'; subst => x /=.
  rewrite negb_and orbC /=.
  move/eqP => X.
  by rewrite store.get_upd.
- move=> rd rs rt st h st' h'.
  case/exec0_and_inv => Hst' Hh'; subst => x /=.
  rewrite negb_and orbC /=.
  move/eqP => X.
  by rewrite store.get_upd.
- move=> rt rs imm st h st' h'.
  case/exec0_andi_inv=> Hst' Hh'; subst => x /=.
  rewrite negb_and orbC /=.
  move/eqP => X.
  by rewrite store.get_upd.
- move=> rt off base st h st' h'.
  case/exec0_lw_inv.
  move=> [p [Hp [z [Hz]]]] [] Hst' Hh'; subst => x /=.
  rewrite negb_and orbC /=.
  move/eqP => X.
  by rewrite store.get_upd.
  by case.
- (* lwxs *) move=> rt idx base st h st' h'.
  case/exec0_lwxs_inv.
  move=> [p [Hp [z [Hz]]]] [] Hst' Hh'; subst => x /=.
  rewrite negb_and orbC /=.
  move/eqP => X.
  by rewrite store.get_upd.
  by case.
- move=> rs rt st h st' h'.
  case/exec0_maddu_inv=> Hst' Hh'; subst => x /= _.
  by rewrite store.get_maddu_op.
- move=> rd st h st' h'.
  case/exec0_mfhi_inv=> Hst' Hh'; subst => x /=.
  rewrite negb_and orbC /=.
  move/eqP => X.
  by rewrite store.get_upd.
- move=> rd st h st' h'.
  case/exec0_mflhxu_inv=> Hst' Hh'; subst => x /=.
  rewrite negb_and orbC /=.
  move/eqP => X.
  rewrite store.get_mflhxu_op.
  by rewrite store.get_upd.
- (* mflo *) move=> rd st h st' h'.
  case/exec0_mflo_inv=> Hst' Hh'; subst => x /=.
  rewrite negb_and orbC /=.
  move/eqP => X.
  by rewrite store.get_upd.
- (* movn *) move=> rd rs rt st h st' h'.
  case/exec0_movn_inv.
  move=> [Hrt []] Hst' Hh'; subst => x /=.
  rewrite negb_and orbC /=.
  move/eqP => X.
  by rewrite store.get_upd.
  move=> [Hrt []] Hst' Hh'; by subst.
- move=> rd rs rt st h st' h'.
  case/exec0_movz_inv.
  move=> [Hrt []] Hst' Hh'; subst => x /=.
  rewrite negb_and orbC /=.
  move/eqP => X.
  by rewrite store.get_upd.
  move=> [Hrt []] Hst' Hh'; by subst.
- move=> rs rt st h st' h'.
  case/exec0_msubu_inv=> Hst' Hh'; subst => x _.
  by rewrite store.get_msubu_op.
- move=> rs st h st' h'.
  case/exec0_mthi_inv=> Hst' Hh'; subst => x _.
  by rewrite store.get_mthi_op.
- (* mtlo *) move=> rs st h st' h'.
  case/exec0_mtlo_inv=> Hst' Hh'; subst => x _.
  by rewrite store.get_mtlo_op.
- move=> rs rt st h st' h'.
  case/exec0_multu_inv=> Hst' Hh'; subst => x _.
  by rewrite store.get_multu_op.
- move=> rd rs rt st h st' h'.
  case/exec0_nor_inv=> Hst' Hh'; subst => x /=.
  rewrite negb_and orbC /=.
  move/eqP => X.
  by rewrite store.get_upd.
- move=> rd rs rt st h st' h'.
  case/exec0_or_inv=> Hst' Hh'; subst => x /=.
  rewrite negb_and orbC /=.
  move/eqP => X.
  by rewrite store.get_upd.
- (* sll *) move=> rx ry sa st h st' h'.
  case/exec0_sll_inv=> Hst' Hh'; subst => x /=.
  rewrite negb_and orbC /=.
  move/eqP => X.
  by rewrite store.get_upd.
- move=> rd rt rs st h st' h'.
  case/exec0_sllv_inv=> Hst' Hh'; subst => x /=.
  rewrite negb_and orbC /=.
  move/eqP => X.
  by rewrite store.get_upd.
- move=> rd rt rs st h st' h'.
  case/exec0_sltu_inv=> Hst' Hh'; subst => x /=.
  rewrite negb_and orbC /=.
  move/eqP => X.
  by rewrite store.get_upd.
- (* sra *) move=> rd rt sa st h st' h'.
  case/exec0_sra_inv=> Hst' Hh'; subst => x /=.
  rewrite negb_and orbC /=.
  move/eqP => X.
  by rewrite store.get_upd.
- (* srl *) move=> rd rt sa st h st' h'.
  case/exec0_srl_inv=> Hst' Hh'; subst => x /=.
  rewrite negb_and orbC /=.
  move/eqP => X.
  by rewrite store.get_upd.
- move=> rd rt rs st h st' h'.
  case/exec0_srlv_inv=> Hst' Hh'; subst => x /=.
  rewrite negb_and orbC /=.
  move/eqP => X.
  by rewrite store.get_upd.
- move=> rd rt rs st h st' h'.
  case/exec0_subu_inv=> Hst' Hh'; subst => x /=.
  rewrite negb_and orbC /=.
  move/eqP => X.
  by rewrite store.get_upd.
- move=> rt off base st h st' h'.
  case/exec0_sw_inv.
  move=> [p [Hp [z [Hz]]]] [] Hst' Hh'; by subst.
  by case.
- (* xor *) move=> rd rs rt st h st' h'.
  case/exec0_xor_inv=> Hst' Hh'; subst => x /=.
  rewrite negb_and orbC /=.
  move/eqP => X.
  by rewrite store.get_upd.
- move=> rt rs imm st h st' h'.
  case/exec0_xori_inv=> Hst' Hh'; subst => x /=.
  rewrite negb_and orbC /=.
  move/eqP => X.
  by rewrite store.get_upd.
Qed.

Lemma reg_unchanged' s c s' : (s -- c ---> s') ->
  forall x st h st' h', ~ List.In x (modified_regs c) ->
    s = Some (st, h) -> s' = Some (st', h') ->
    store.get x st = store.get x st'.
Proof.
elim => //; clear s c s'.
- (* cmd0 *) move=> s c s' H x st h st' h' Hx Hs Hs'.
  subst.
  eapply reg_unchanged0.
  apply H.
  apply/negP.
  by move/inP.
- (* seq *) move=> s s' s'' c d Hc IHc Hd IHd x st h st'' h'' Hx Hs Hs''.
  destruct s' as [[st' h']|]; last first.
    move/semop_prop_m.from_none : Hd => Hd; by subst.
  eapply trans_eq.
  eapply IHc.
  contradict Hx.
  rewrite /=.
  apply List.in_or_app; by left.
  apply Hs.
  reflexivity.
  eapply IHd.
  contradict Hx.
  rewrite /=.
  apply List.in_or_app; by right.
  reflexivity.
  by apply Hs''.
- (* if true *) move=> [s h] s' t c d Ht Hc IH x st he st' he' Hx [] X Y Hs'; subst.
  eapply IH.
  contradict Hx.
  rewrite /=.
  apply List.in_or_app; by left.
  reflexivity.
  reflexivity.
- (* if false *) move=> [s h] s' t c d Ht Hc IH x st he st' he' Hx [] X Y Hs'; subst.
  eapply IH.
  contradict Hx.
  rewrite /=.
  apply List.in_or_app; by right.
  reflexivity.
  reflexivity.
- (* while true *) move=> [s h] s' s'' t c Ht Hc IHc Hwhile IHwhile x st he st'' he'' Hx [] X Y Hs''; subst.
  destruct s' as [[st' he']|]; last first.
    move/semop_prop_m.from_none : Hwhile => Hwhile; by subst.
  eapply trans_eq.
  eapply IHc.
  done.
  reflexivity.
  reflexivity.
  eapply IHwhile.
  done.
  reflexivity.
  reflexivity.
- (* while false *) move=> [s h] t c Ht x st he st' he' Hx [] X Y [] U V; subst.
  by subst.
Qed.

Lemma reg_unchanged : forall st h c st' h',
  Some (st, h) -- c ---> Some (st', h') ->
  forall x, ~ List.In x (modified_regs c) ->
    store.get x st = store.get x st'.
Proof. intros. eapply reg_unchanged'; eauto. Qed.

Ltac Reg_unchanged :=
  match goal with
    | Hid : (Some (?st1, ?h1) -- ?c ---> Some (?st2, ?h2))%mips_cmd
     |- ( [ ?r1 ]_ ?st1 = [ ?r2 ]_ ?st2 )%mips_expr =>
        apply reg_unchanged with h1 c h2; [exact Hid | idtac]
    | Hid : WMIPS_Semop.exec (Some (?st1, ?h1)) ?c (Some (?st2, ?h2))
      |- ( [ ?r1 ]_ ?st1 = [ ?r2 ]_ ?st2 )%mips_expr =>
        apply reg_unchanged with h1 c h2; [exact Hid | idtac]
  end.

Lemma triple_exec_proj0 (P : assert) c (Q : assert) :
  (mips_seplog.hoare0 P c Q) ->
    forall st h st' h' d,
      P st (heap.proj h d) ->
      (Some (st, h) -- c ----> Some (st', h')) ->
      (Some (st, heap.proj h d) -- c ----> Some (st', heap.proj h' d)).
Proof.
elim=> //; clear P c Q.
- move=> P st h st' h' d _.
  case/exec0_nop_inv => -> ->; by constructor.
- move=> Q rs rt rd st h st' h' d _.
  case/exec0_add_inv.
  + case=> Hcond [] -> ->; by constructor.
  + by case.
- move=> Q rt rs imm st h st' h' d _.
  case/exec0_addi_inv.
  + case=> Hcond [] -> ->; by constructor.
  + by case.
- move=> Q rt rs imm st h st' h' d _.
  case/exec0_addiu_inv=> -> ->; by constructor.
- move=> Q rs rt rd st h st' h' d _.
  case/exec0_addu_inv=> -> ->; by constructor.
- move=> Q rd rs rt st h st' h' d _.
  case/exec0_and_inv => -> ->; by constructor.
- move=> Q rt rs imm st h st' h' d _.
  case/exec0_andi_inv => -> ->; by constructor.
- move=> Q rt off base st h st' h' d Hpre.
  case/exec0_lw_inv.
  + case=> p [] Hp [] z [] Hz [] -> ->.
    apply exec0_lw with p => //.
    rewrite heap.get_proj //.
    rewrite /mips_seplog.wp_lw in Hpre.
    case: Hpre => p' [] Hp' [] z' [] Hz' HQ.
    have ? : p = p' by rewrite [u2Z _]/= in Hp'; lia.
    subst p'.
    apply/seq_ext.inP.
    move/heap.get_Some_in_dom : Hz'; move/seq_ext.inP.
    move: (heap.inc_dom_proj d h).
    move/seq_ext.incP.
    by apply.
  + by case.
- move=> rt idx base Q st h st' h' d Hpre.
  case/exec0_lwxs_inv.
  + case=> p [] Hp [] z [] Hz [] -> ->.
    apply exec0_lwxs with p => //.
    rewrite heap.get_proj //.
    rewrite /mips_seplog.wp_lwxs in Hpre.
    case: Hpre => p' [] Hp' [] z' [] Hz' HQ.
    have ? : p = p' by rewrite [u2Z _]/= in Hp'; lia.
    subst p'.
    apply/seq_ext.inP.
    move/heap.get_Some_in_dom : Hz'; move/seq_ext.inP.
    move: (heap.inc_dom_proj d h).
    move/seq_ext.incP.
    by apply.
  + by case.
- move=> Q rs rt st h st' h' d _.
  case/exec0_maddu_inv=> -> ->; by constructor.
- move=> Q rd st h st' h' d _.
  case/exec0_mfhi_inv=> -> ->; by constructor.
- move=> rd Q st h st' h' d _.
  case/exec0_mflhxu_inv=> -> ->; by constructor.
- move=> Q rd st h st' h' d _.
  case/exec0_mflo_inv=> -> ->; by constructor.
- move=> Q rd rs rt st h st' h' d _.
  case/exec0_movn_inv.
  + case=> Htest [] -> ->; by apply exec0_movn_true.
  + case=> Htest [] -> ->; by apply exec0_movn_false.
- move=> Q rd rs rt st h st' h' d _.
  case/exec0_movz_inv.
  + case=> Htest [] -> ->; by apply exec0_movz_true.
  + case=> Htest [] -> ->; by apply exec0_movz_false.
- move=> Q rs rt st h st' h' d _.
  case/exec0_msubu_inv=> -> ->; by constructor.
- move=> Q rs st h st' h' d _.
  case/exec0_mthi_inv=> -> ->; by constructor.
- move=> Q rs st h st' h' d _.
  case/exec0_mtlo_inv => -> ->; by constructor.
- move=> Q rs rt st h st' h' d _.
  case/exec0_multu_inv=> -> ->; by constructor.
- move=> Q rd rs rt st h st' h' d _.
  case/exec0_nor_inv=> -> ->; by constructor.
- move=> Q rd rs rt st h st' h' d _.
  case/exec0_or_inv=> -> ->; by constructor.
- move=> Q rx ry sa st h st' h' d _.
  case/exec0_sll_inv=> -> ->; by constructor.
- move=> Q rd rs rt st h st' h' d _.
  case/exec0_sllv_inv=> -> ->; by constructor.
- move=> Q rd rs rt st h st' h' d _.
  case/exec0_sltu_inv=> -> ->; by constructor.
- (* sra *) move=> Q rd rt sa st h st' h' d _.
  case/exec0_sra_inv=> -> ->; by constructor.
- move=> Q rd rt sa st h st' h' d _.
  case/exec0_srl_inv=> -> ->; by constructor.
- move=> Q rd rt rs st h st' h' d _.
  case/exec0_srlv_inv=> -> ->; by constructor.
- move=> Q rs rt rd st h st' h' d _.
  case/exec0_subu_inv=> -> ->; by constructor.
- move=> rt off base Q st h st' h' d Hpre.
  case/exec0_sw_inv.
  + case=> p [] Hp [] z [] Hz [] -> ->.
    rewrite heap.proj_upd.
    apply exec0_sw => //.
    exists z.
    rewrite heap.get_proj //.
    rewrite /mips_seplog.wp_sw in Hpre.
    case: Hpre => p' [] Hp' [] [] z' Hz' HQ.
    have ? : p = p' by rewrite [u2Z _]/= in Hp'; lia.
    subst p'.
    apply/seq_ext.inP.
    move/heap.get_Some_in_dom : Hz'; move/seq_ext.inP.
    move: (heap.inc_dom_proj d h).
    move/seq_ext.incP.
    by apply.
  + by case.
- move=> Q rd rs rt st h st' h' d Hpre.
  case/exec0_xor_inv=> -> ->; by constructor.
- move=> Q rt rs imm st h st' h' d Hpre.
  case/exec0_xori_inv=> -> ->; by constructor.
Qed.

Lemma triple_exec_proj P c Q :
  mips_seplog.WMIPS_Hoare.hoare P c Q ->
  forall d st h st' h',
    P st (heap.proj h d) ->
    Some (st, h) -- c ---> Some (st', h') ->
    Some (st, heap.proj h d) -- c ---> Some (st', heap.proj h' d).
Proof.
elim=> //; clear P c Q.
- move=> P Q c Htriple d st h st' h' HP Hc.
  apply while.exec_cmd0.
  eapply triple_exec_proj0; eauto.
  by inversion Hc.
- move=> P Q R c1 c2 Hc1 IHc1 Hc2 IHc2 d st h st' h' HP.
  case/semop_prop_m.exec_seq_inv.
  case.
  + case=> st'' h'' [] Hc1' Hc2'.
    apply while.exec_seq with (Some (st'', heap.proj h'' d)).
    apply IHc1 => //.
    apply IHc2 => //.
    move/hoare_prop_m.soundness : Hc1 => Hc1.
    rewrite /hoare_semantics in Hc1.
    move/Hc1 : (HP) => HP'.
    case: HP' => _ HP'.
    apply HP' => //.
    by apply IHc1.
  + case=> _.
    by move/semop_prop_m.from_none.
- move=> P P' Q Q' c HQ'Q HPP' Hc IHc s st h st' h' HP Hexec_c.
  apply IHc; last by [].
  by apply HPP'.
- move=> P t c Htriple_c IHc d st h st' h' HP.
  move Hs : (Some (st, h)) => s.
  move Hs' : (Some (st', h')) => s'.
  move Hwhile : (while.while t c) => C.
  move=> Hexec_C.
  move: Hexec_C P t c Htriple_c IHc d st h st' h' HP Hs' Hs Hwhile.
  elim=> //; clear s s' C.
  + move=> [s h] s' s'' t c Ht H_exec_c IH_exec_c H_exec_while IH_exec_while P t_ c_ Hhoare_c_ IH d s_ h_ st'' h'' HP.
    destruct s' as [[s' h']|].
    * move=> Hs'' [] X Y.
      subst s_ h_.
      case=> X Y; subst t_ c_.
      case/boolP : (eval_b t s) => X.
      - apply while.exec_while_true with (Some (s', heap.proj h' d)) => //.
        by apply IH.
        apply: (IH_exec_while _ _ _ Hhoare_c_) => //.
        move/hoare_prop_m.soundness in Hhoare_c_.
        rewrite /hoare_semantics in Hhoare_c_.
        apply: (proj2 (Hhoare_c_ _ _ (conj HP X))).
        by apply IH.
      - by rewrite Ht in X.
    * move/semop_prop_m.from_none : H_exec_while.
      by move=> ->.
  + move=> [s h] t c Ht P t_ c_ Hhoare_c IH d st_ h_ st' h' HP.
    case=> X Y; subst.
    case=> X Y; subst.
    case=> X Y; subst.
    by apply while.exec_while_false.
- move=> P Q t c1 c2.
  move=> Hhoare_c1 IHc1 Hhoare_c2 IHc2 d st h st' h' HP.
  case/boolP : (eval_b t st) => X.
  + move/(semop_prop_m.exec_ifte_true_inv _ _ _ _ _ _ X) => Hc1.
    apply while.exec_ifte_true => //; by apply IHc1.
  + move/(semop_prop_m.exec_ifte_false_inv _ _ _ _ _ _ X) => Hc2.
    apply while.exec_ifte_false => //; by apply IHc2.
Qed.

Lemma exec_deter_proj0 s (c : cmd0) s' : s -- c ----> s'  ->
  forall st h st' h' d st'_proj h'_proj,
    s = Some (st, h) -> s' = Some (st',h') ->
    Some (st, heap.proj h d) -- c ----> Some (st'_proj, h'_proj) ->
    st'_proj = st' /\ h'_proj = heap.proj h' d /\ h \D\ d = h' \D\ d.
Proof.
case=> //; clear s c s'.
- move=> s st h st' h' d st'_proj h'_proj [] -> [] X Y.
  subst st' h'; by case/exec0_nop_inv.
- move=> st h rd rs rt Hcond st_ h_ st' h' d st'_proj h'_proj [] X Y; subst st_ h_.
  case=> X Y; subst st' h'.
  case/exec0_add_inv.
  + by case=> _ [].
  + tauto.
- move=> st h rt rs imm Hcond st_ h_ st' h' d st'_proj h'_proj [] X Y; subst st_ h_.
  case=> X Y; subst st' h'.
  case/exec0_addi_inv.
  + by case=> _ [].
  + tauto.
- move=> st h rt rs imm st_ h_ st' h' d st'_proj h'_proj [] X Y; subst st_ h_.
  case=> X Y; subst st' h'; by case/exec0_addiu_inv.
- move=> st h rt rs imm st_ h_ st' h' d st'_proj h'_proj [] X Y; subst st_ h_.
  case=> X Y; subst st' h'; by case/exec0_addu_inv.
- move=> st h rd rs rt st_ h_ st' h' d st'_proj h'_proj [] X Y; subst st_ h_.
  case=> X Y; subst st' h'; by case/exec0_and_inv.
- move=> st h rt rs imm st_ h_ st' h' d st'_proj h'_proj [] X Y; subst st_ h_.
  case=> X Y; subst st' h'; by case/exec0_andi_inv.
- move=> st h rt off base p z Hp Hz st_ h_ st' h' d st'_proj h'_proj [] X Y; subst st_ h_.
  case=> X Y; subst st' h'.
  case/exec0_lw_inv.
  + case=> p_ [Hp_ [z_ [Hz_ []] ]] Heq.
    split=> //.
    have {Hp_}X : p = p_ by lia. subst p_.
    move/heap.get_Some_in_dom : (Hz_); move/seq_ext.inP.
    move/seq_ext.incP : (heap.inc_dom_proj d h) => X; move/X => p_d.
    rewrite heap.get_proj // in Hz_; last by apply/seq_ext.inP.
    rewrite Heq.
    f_equal.
    rewrite Hz in Hz_.
    by case: Hz_.
  + by case.
- move=> st h rt ids base p z Hp Hz st_ h_ st' h' d st'_proj h'_proj [] X Y; subst st_ h_.
  case=> X Y; subst st' h'.
  case/exec0_lwxs_inv.
  + case=> p_ [] Hp_ [] z_ [] Hz_ [] -> ->.
    split=> //.
    have Hpp_ : p = p_ by lia.
    subst p_.
    move/heap.get_Some_in_dom : (Hz_); move/seq_ext.inP.
    move/seq_ext.incP : (heap.inc_dom_proj d h) => X; move/X => Hp_in_d.
    rewrite heap.get_proj // in Hz_; last by apply/seq_ext.inP.
    rewrite Hz in Hz_; by case : Hz_ => ->.
  + by case.
- move=> st h rs rt st_ h_ st' h' d st'_proj h'_proj [] <- <- [] <- <-.
  by case/exec0_maddu_inv=> -> ->.
- move=> st h rd st_ h_ st' h' d st'_proj h'_proj [] <- <- [] <- <-.
  by case/exec0_mfhi_inv=> -> ->.
- move=> st h rd st_ h_ st' h' d st'_proj h'_proj [] <- <- [] <- <-.
  by case/exec0_mflhxu_inv=> -> ->.
- move=> st h rd st_ h_ st' h' d st'_proj h'_proj [] <- <- [] <- <-.
  by case/exec0_mflo_inv=> -> ->.
- move=> st h rd rs rt Hcond st_ h_ st' h' d st'_proj h'_proj [] <- <- [] <- <-.
  case/exec0_movn_inv.
  + by case=> Hcond' [] -> ->.
  + case; tauto.
- move=> st h rd rs rt Hcond st_ h_ st' h' d st'_proj h'_proj [] <- <- [] <- <-.
  case/exec0_movn_inv.
  + case; tauto.
  + by case=> Hcond' [] -> ->.
- move=> st h rd rs rt Hcond st_ h_ st' h' d st'_proj h'_proj [] <- <- [] <- <-.
  case/exec0_movz_inv.
  + by case=> Hcond' [] -> ->.
  + case; tauto.
- move=> st h rd rs rt Hcond st_ h_ st' h' d st'_proj h'_proj [] <- <- [] <- <-.
  case/exec0_movz_inv.
  + case; tauto.
  + by case=> Hcond' [] -> ->.
- move=> st h rs rt st_ h_ st' h' d st'_proj h'_proj [] <- <- [] <- <-.
  by case/exec0_msubu_inv=> -> ->.
- move=> st h rs st_ h_ st' h' d st'_proj h'_proj [] <- <- [] <- <-.
  by case/exec0_mthi_inv=> -> ->.
- move=> st h rs st_ h_ st' h' d st'_proj h'_proj [] <- <- [] <- <-.
  by case/exec0_mtlo_inv=> -> ->.
- move=> st h rs rt st_ h_ st' h' d st'_proj h'_proj [] <- <- [] <- <-.
  by case/exec0_multu_inv=> -> ->.
- move=> st h rd rs rt st_ h_ st' h' d st'_proj h'_proj [] <- <- [] <- <-.
  by case/exec0_nor_inv=> -> ->.
- move=> st h rd rs rt st_ h_ st' h' d st'_proj h'_proj [] <- <- [] <- <-.
  by case/exec0_or_inv=> -> ->.
- move=> st h rx ry sa st_ h_ st' h' d st'_proj h'_proj [] <- <- [] <- <-.
  by case/exec0_sll_inv=> -> ->.
- move=> st h rd rt rs st_ h_ st' h' d st'_proj h'_proj [] <- <- [] <- <-.
  by case/exec0_sllv_inv=> -> ->.
- move=> st h rd rs rt st_ h_ st' h' st'_ h'_ d st'_proj h'_proj [] <- <- [] <- <-.
  case/exec0_sltu_inv=> -> ->.
  by rewrite -h_.
- (* sra *) move=> st h rd rt sa st_ h_ st' h' d st'_proj h'_proj [] <- <- [] <- <-.
  by case/exec0_sra_inv=> -> ->.
- (* srl *) move=> st h rd rt sa st_ h_ st' h' d st'_proj h'_proj [] <- <- [] <- <-.
  by case/exec0_srl_inv=> -> ->.
- move=> st h rd rt rs st_ h_ st' h' d st'_proj h'_proj [] <- <- [] <- <-.
  by case/exec0_srlv_inv=> -> ->.
- move=> st h rt rs imm st_ h_ st' h' d st'_proj h'_proj [] X Y; subst st_ h_.
  case=> X Y; subst st' h'.
  by case/exec0_subu_inv.
- (* sw *) move=> st h rt off base p HP [z Hz] st_ h_ st' h' d st'_proj h'_proj [] X Y; subst st_ h_.
  case=> X Y; subst st' h'.
  case/exec0_sw_inv.
  (* no error *)
  + case=> p_ [Hp_ [z_ [Hz_ []]]] Heq.
    have {Hp_}X : p = p_ by lia. subst p_.
    move/heap.get_Some_in_dom : (Hz_); move/seq_ext.inP.
    move/seq_ext.incP : (heap.inc_dom_proj d h) => X; move/X => Hp_in_d.
    rewrite heap.get_proj // in Hz_; last by apply/seq_ext.inP.
    rewrite Hz in Hz_. case: Hz_ => ?; subst z_.
    split; first by [].
    split.
    * by rewrite heap.proj_upd.
    * rewrite heap.difs_upd //; by apply/seq_ext.inP.
  + by case.
- (* xor *) move=> st h rd rs rt st_ h_ st' h' d st'_proj h'_proj [] X Y; subst st_ h_.
  case=> X Y; subst st' h'; by case/exec0_xor_inv.
- (* xori *) move=> st h rt rs imm st_ h_ st' h' d st'_proj h'_proj [] X Y; subst st_ h_.
  case=> X Y; subst st' h'; by case/exec0_xori_inv.
Qed.

Lemma exec_deter_proj' s c s' : s -- c ---> s' ->
  forall st h st' h' d st'_proj h'_proj,
    s = Some (st, h) -> s' = Some (st', h') ->
    Some (st, heap.proj h d) -- c ---> Some (st'_proj, h'_proj) ->
    st' = st'_proj /\ h'_proj = heap.proj h' d /\ h \D\ d = h' \D\ d.
Proof.
elim=> //; clear s c s'.
- (* cmd0 *) move=> s c s' H st h st' h' d st'_proj h'_proj Hs Hs' Hc.
  inversion Hc; subst.
  move: (exec_deter_proj0 _ _ _ H st h st' h' d _ _ (refl_equal _) (refl_equal _) H2).
  by case => H1 [h2 H3].
- (* seq *) move=> s s'' s' c1 c2 Hc1 IHc1 Hc2 IHc2 st h st' h' d st'_proj h'_proj Hs Hs'.
  subst s s'.
  case/semop_prop_m.exec_seq_inv.
  case.
  + case=> st''_proj h''_proj [Hc1' Hc2'].
    destruct s'' as [[st''_ h'']|].
    - case : {IHc1}(IHc1 st h st''_ h'' d st''_proj h''_proj (refl_equal _) (refl_equal _) Hc1') => IHc1 [IHc1' IHc1''].
      subst st''_ h''_proj.
      case : {IHc2}(IHc2 st''_proj h'' st' h' d _ _ (refl_equal _) (refl_equal _) Hc2') => IHc2 [IHc2' IHc2''].
      subst st'_proj h'_proj.
      by rewrite IHc1'' IHc2''.
    - by move/semop_prop_m.from_none : Hc2.
  + case=> H1; by move/semop_prop_m.from_none.
- (* if true *) move=> [st h] s' t c1 c2 Ht Hc IHc st_ h_ st' h' d st'_proj h'_proj [] X Y; subst st_ h_.
  move=> Hs'.
  move=> H.
  apply semop_prop_m.exec_ifte_true_inv in H; last by [].
  by apply (IHc st h st' h' d _ _ (refl_equal _) Hs' H).
- (* if false *) move=> [st h] s' t c1 c2 Ht Hc IHc st_ h_ st' h' d st'_proj h'_proj [] X Y; subst st_ h_.
  move=> Hs'.
  move=> H.
  apply semop_prop_m.exec_ifte_false_inv in H; last by [].
  by apply (IHc st h st' h' d _ _ (refl_equal _) Hs' H).
- (* while true *) move=> [st h] s'' s' t c Ht Hc IHc Hwhile IHwhile st_ h_ st' h' d st'_proj h'_proj [] X Y.
  subst st_ h_ => Hs' H.
  apply semop_prop_m.exec_while_inv_true in H; last by [].
  case : H => st''_proj [h''_proj [Hc' Hwhile']].
  destruct s'' as [[st''_ h''_]|].
  + move: {IHc}(IHc st h st''_ h''_ d st''_proj h''_proj (refl_equal _) (refl_equal _) Hc') => [IHc1 [IHc2 IHc3]].
    subst st''_ h''_proj.
    move: {IHwhile}(IHwhile st''_proj h''_ st' h' d _ _ (refl_equal _) Hs' Hwhile') => IHwhile.
    split; first by tauto.
    split; first by tauto.
    rewrite IHc3; tauto.
  + move/semop_prop_m.from_none in Hwhile; by subst.
- (* while false *) move=> [st h] t c Ht st_ h_ st__ h__ d st'_proj h'_proj [] X Y.
  subst st_ h_. move=> [] X Y.
  subst st__ h__.
  by case/semop_prop_m.exec_while_inv_false.
Qed.

Lemma exec_deter_proj : forall st h c st' h', Some (st, h) -- c ---> Some (st', h') ->
  forall d st'_proj h'_proj,
    Some (st, heap.proj h d) -- c ---> Some (st'_proj, h'_proj) ->
    st' = st'_proj /\ h'_proj = heap.proj h' d /\ h \D\ d = h' \D\ d.
Proof.
intros.
eapply exec_deter_proj'.
by apply H.
reflexivity.
reflexivity.
by apply H0.
Qed.

Definition is_sw (c : cmd0) : bool :=
  match c with | sw _ _ _ => true | _ => false end.

(* TODO: inelegant *)
Fixpoint contains_sw (c : @while.cmd cmd0 expr_b) : bool :=
  match c with
    | while.cmd_cmd0 c0 => is_sw c0
    | c ; d => contains_sw c || contains_sw d
    | while.ifte _ c d => contains_sw c || contains_sw d
    | while.while _ c => contains_sw c
  end.

Lemma no_sw_heap_invariant_cmd0 s (c : cmd0) s' :
  (s -- c ----> s') ->
  ~~ contains_sw c ->
  forall st h st' h',
    s = Some (st, h) -> s' = Some (st', h') ->
    h = h'.
Proof.
elim=> //; clear s c s'.
- (* nop *) move=> s _ st he st' he' -> [] //.
- (* add *) move=> s ha rd rs rt H _ st he st' he' [] X Y [] U V; by subst.
- (* addi *) move=> s h rt rs imm H _ st he st' he' [] X Y [] U V; by subst.
- (* addiu *) move=> s h rt rs imm _ st he st' he' [] X Y [] U V; by subst.
- (* addu *) move=> s h rd rs rt _ st he st' he' [] X Y [] U V; by subst.
- (* cmd_and *) move=> s h rd rs rt _ st he st' he' [] X Y [] U V; by subst.
- (* andi *) move=> s h rd rs rt _ st he st' he' [] X Y [] U V; by subst.
- (* lw *) move=> s h rt off base p z Hp Hz _ st he st' he' [] X Y [] U V; by subst.
- (* lwxs *) move=> s h rt idx base p z Hp Hz _ st he st' he' [] X Y [] U V; by subst.
- (* maddu *) move=> s h rs rt _ s_ h_ st' h' [] _ <- [] _ <- //.
- (* mfhi *) move=> s h rd _ s_ h_ st' h' [] _ <- [] _ <- //.
- (* mflhxu *) move=> s h rd _ s_ h_ st' h' [] _ <- [] _ <- //.
- (* mflo *) move=> s h rd _ s_ h_ st' h' [] _ <- [] _ <- //.
- (* movn *) move=> s h rd rs rt H _ s_ h_ st' h' [] _ <- [] _ <- //.
- (* movn *) move=> s h rd rs rt H _ s_ h_ st' h' [] _ <- [] _ <- //.
- (* movz *) move=> s h rd rs rt H _ s_ h_ st' h' [] _ <- [] _ <- //.
- (* movz *) move=> s h rd rs rt H _ s_ h_ st' h' [] _ <- [] _ <- //.
- (* msubu *) move=> s h rs rt _ s_ h_ st' h' [] _ <- [] _ <- //.
- (* mthi *) move=> s h rs _ s_ h_ st' h' [] _ <- [] _ <- //.
- (* mtlo *) move=> s h rs _ s_ h_ st' h' [] _ <- [] _ <- //.
- (* multu *) move=> s h rs rt _ s_ h_ st' h' [] _ <- [] _ <- //.
- (* nor *) move=> s h rd rs rt _ s_ h_ st' h' [] _ <- [] _ <- //.
- (* or *) move=> s h rd rs rt _ s_ h_ st' h' [] _ <- [] _ <- //.
- (* sll *) move=> s h rx ry sa _ s_ h_ st' h' [] _ <- [] _ <- //.
- (* sllv *) move=> s h rd rt rs _ s_ h_ st' h' [] _ <- [] _ <- //.
- (* sltu *) move=> s h rd rs rt flag H _ s_ h_ st' h' [] _ <- [] _ <- //.
- (* sra *) by move=> s h rd rt sa _ s_ h_ st' h' [] _ <- [] _ <-.
- (* srl *) by move=> s h rd rt sa _ s_ h_ st' h' [] _ <- [] _ <-.
- (* srlv *) move=> s h rd rt rs _ s_ h_ st' h' [] _ <- [] _ <- //.
- (* subu *) move=> s h rd rs rt _ s_ h_ st' h' [] _ <- [] _ <- //.
- (* xor *) move=> s h rd rs rt _ s_ h_ st' h' [] _ <- [] _ <- //.
- (* xori *) move=> s h rt rs imm _ s_ h_ st' h' [] _ <- [] _ <- //.
Qed.

Lemma no_sw_heap_invariant s c s' :
  s -- c ---> s' -> ~~ contains_sw c ->
  forall st h st' h', s = Some (st, h) -> s' = Some (st', h') ->
    h = h'.
Proof.
elim=> //; clear s c s'.
- (* cmd0 *) move=> s c s' H Hcontains st he st' he' Hs Hs'.
  eapply no_sw_heap_invariant_cmd0.
  apply H.
  done.
  apply Hs.
  apply Hs'.
- (* seq *) move=> s s' s'' c d Hc IHc Hd IHd /= Hcontains st he st'' he'' Hs Hs''.
  destruct s' as [[st' he']|]; last first.
    move/semop_prop_m.from_none : Hd => Hd.
    by subst.
  eapply trans_eq.
  eapply IHc.
  apply/negP. move/orP : Hcontains. tauto.
  apply Hs.
  reflexivity.
  eapply IHd.
  apply/negP. move/orP : Hcontains. tauto.
  reflexivity.
  apply Hs''.
- (* ifte true *) move=> [st h] s' t c1 c2 Ht Hc1 IHc1 Hcontains st_ h_ st' h' [] X Y.
  subst st_ h_ => Hs'.
  apply IHc1 with st st' => //.
  move: Hcontains.
  rewrite /= negb_or.
  by case/andP.
- (* ifte false *) move=> [st h] s' t c1 c2 Ht Hc2 IHc2 Hcontains st_ h_ st' h' [] X Y.
  subst st_ h_ => Hs'.
  apply IHc2 with st st' => //.
  move: Hcontains.
  rewrite /= negb_or.
  by case/andP.
- (* while true *) move=> [s h] s' s'' b c Hb Hc IHc Hwhile IHwhile Hcontains s_ h_ st'' h'' [] _ <- Hs''.
  destruct s' as [[st' h']|].
  eapply trans_eq.
  eapply IHc => //.
  eapply IHwhile => //.
  apply Hs''.
  subst s''.
  by move/semop_prop_m.from_none : Hwhile.
- (* while false *) move=> [s h] b c Hb Hcontains s_ h_ s__ h__.
  case=> _ <-.
  by case=> _ <-.
Qed.

Lemma safety_monotonicity0 (s : option state) (c : cmd0) (s' : option state) :
   (s -- c ----> s') ->
   forall (st : store.t) (h0 : heap.t) (st' : store.t)
     (h' : heap.t),
   Some (st, h0) = s ->
   Some (st', h') = s' ->
   forall h'' : heap.t,
   heap.disj h0 h'' ->
   (Some (st, heap.union h0 h'') -- c ----> Some (st', heap.union h' h'')) /\
   heap.disj h' h''.
Proof.
elim=> //; clear s c s'.
- (* skip *) move=> st st0 h st' h' [] X [] Y h'' Hdisj.
  subst st.
  case: Y => Y Z; subst.
  split; [by constructor | assumption].
- (* add *) move=> st h rd rs rt Hcond st_ h_ st' h' [] -> -> [] -> -> h'' Hdisj.
  split; [by constructor | assumption].
- (* addi *) move=> st h rt rs imm Hcond st_ h_ st' h' [] -> -> [] -> -> h'' Hdisj.
  split; [by constructor | assumption].
- (* addiu *) move=> st h rt rs imm st_ h_ st' h' [] -> -> [] -> -> h'' Hdisj.
  split; [by constructor | assumption].
- (* addu *) move=> st h rd rs rt st_ h_ st' h' [] -> -> [] -> -> h'' Hdisj.
  split; [by constructor | assumption].
- (* cmd_and *) move=> st h rd rs rt st_ h_ st' h' [] -> -> [] -> -> h'' Hdisj.
  split; [by constructor | assumption].
- (* andi *) move=> st h rt rs imm st_ h_ st' h' [] -> -> [] -> -> h'' Hdisj.
  split; [by constructor | assumption].
- (* lw *) move=> s h rt off base p z Hp Hz st he st' he' [] X Y [] Z U; subst.
  move=> h'' Hdisj.
  split=> //.
  econstructor; eauto.
  by apply heap.get_union_L.
- (* lwxs *) move=> s h rt idx base p z Hp Hz st he st' he' [] X Y [] Z U; subst.
  move=> h'' Hdisj.
  split=> //.
  econstructor; eauto.
  by apply heap.get_union_L.
- (* maddu *) move=> st h rs rt st_ h_ st' h' [] -> -> [] -> -> h'' Hdisj.
  split; [by constructor | assumption].
- (* mfhi *) move=> st h rd st_ h_ st' h' [] -> -> [] -> -> h'' Hdisj.
  split; [by constructor | assumption].
- (* mflhxu *) move=> st h rd st_ h_ st' h' [] -> -> [] -> -> h'' Hdisj.
  split; [by constructor | assumption].
- (* mflo *) move=> st h rd st_ h_ st' h' [] -> -> [] -> -> h'' Hdisj.
  split; [by constructor | assumption].
- (* movn true *) move=> st h rd rs rt Hcond st_ h_ st' h' [] -> -> [] -> -> h'' Hdisj.
  split; [by constructor | assumption].
- (* movn false *) move=> st h rd rs rt Hcond st_ h_ st' h' [] -> -> [] -> -> h'' Hdisj.
  split; [by constructor | assumption].
- (* movz true *) move=> st h rd rs rt Hcond st_ h_ st' h' [] -> -> [] -> -> h'' Hdisj.
  split; [by constructor | assumption].
- (* movz false *) move=> st h rd rs rt Hcond st_ h_ st' h' [] -> -> [] -> -> h'' Hdisj.
  split; [by constructor | assumption].
- (* msubu *) move=> st h rs rt st_ h_ st' h' [] -> -> [] -> -> h'' Hdisj.
  split; [by constructor | assumption].
- (* mthi *) move=> st h rd st_ h_ st' h' [] -> -> [] -> -> h'' Hdisj.
  split; [by constructor | assumption].
- (* mtlo *) move=> st h rd st_ h_ st' h' [] -> -> [] -> -> h'' Hdisj.
  split; [by constructor | assumption].
- (* multu *) move=> st h rs rt st_ h_ st' h' [] -> -> [] -> -> h'' Hdisj.
  split; [by constructor | assumption].
- (* nor *) move=> st h rd rs rt st_ h_ st' h' [] -> -> [] -> -> h'' Hdisj.
  split; [by constructor | assumption].
- (* cmd_or *) move=> st h rd rs rt st_ h_ st' h' [] -> -> [] -> -> h'' Hdisj.
  split; [by constructor | assumption].
- (* sll *) move=> st h rx ry sa st_ h_ st' h' [] -> -> [] -> -> h'' Hdisj.
  split; [by constructor | assumption].
- (* sllv *) move=> st h rd rs rt st_ h_ st' h' [] -> -> [] -> -> h'' Hdisj.
  split; [by constructor | assumption].
- (* sltu *) move=> st h rd rs rt flag Hflas st_ h_ st' h' [] -> -> [] -> -> h'' Hdisj.
  split; [by constructor | assumption].
- (* sra *) move=> st h rd rt sa st_ h_ st' h' [] -> -> [] -> -> h'' Hdisj.
  split; [by constructor | assumption].
- (* srl *) move=> st h rd rt sa st_ h_ st' h' [] -> -> [] -> -> h'' Hdisj.
  split; [by constructor | assumption].
- (* srlv *) move=> st h rd rt sa st_ h_ st' h' [] -> -> [] -> -> h'' Hdisj.
  split; [by constructor | assumption].
- (* subu *) move=> st h rd rs rt st_ h_ st' h' [] -> -> [] -> -> h'' Hdisj.
  split; [by constructor | assumption].
- (* sw *) move=> s h rt off base p Hp [z Hz] st he st' he' [] X Y [] Z U; subst.
  move=> h'' Hdisj.
  rewrite -(heap.upd_union_L _ _ _ _ _ z) //.
  split.
  + econstructor; eauto.
    exists z.
    by apply heap.get_union_L.
  + by apply heap.disj_upd.
- (* xor *) move=> st h rd rs rt st_ h_ st' h' [] -> -> [] -> -> h'' Hdisj.
  split; [by constructor | assumption].
- (* xori *) move=> st h rt rs imm st_ h_ st' h' [] -> -> [] -> -> h'' Hdisj.
  split; [by constructor | assumption].
Qed.

Lemma safety_monotonicity c st h st' h' :
    (Some (st, h) -- c ---> Some (st', h')) ->
    forall h'',
      heap.disj h h'' ->
      (Some (st, heap.union h h'') -- c ---> Some (st', heap.union h' h'')) /\
      heap.disj h' h''.
Proof.
move Hs : (Some (st, h)) => s.
move Hs' : (Some (st', h')) => s'.
move=> Hexec.
move: Hexec st h st' h' Hs Hs'.
elim=> //; clear c s s'.
- move=> s c s' H st h0 st' h' X Y h'' Hdisj.
  case: (safety_monotonicity0 _ _ _ H _ _ _ _ X Y h'' Hdisj) => H1 H2.
  split => //.
  by constructor.
- move=> s s' s'' c1 c2 Hc1 IHc1 Hc2 IHc2 st h st'' h'' Hs Hs' h_disj Hdisj.
  destruct s' as [[st' h']|].
  - case: (IHc1 _ _ _ _ Hs (refl_equal _) _ Hdisj) => H1 H2.
    case: (IHc2 _ _ _ _ (refl_equal _) Hs' _ H2) => H3 H4.
    split => //.
    apply while.exec_seq with (Some (st', heap.union h' h_disj)) => //.
  - destruct s'' as [[st''_ h''_]|] => //.
    by move/semop_prop_m.from_none : Hc2.
- move=> [st h] s' b c1 c2 Hb Hc1 IHc1 st_ h_ st' h' [] -> -> Hs' h'' Hh''.
  case: {IHc1}(IHc1 _ _ _ _ (refl_equal _) Hs' _ Hh'').
  split=> //.
  by apply while.exec_ifte_true.
- move=> [st h] s' b c1 c2 Hb Hc1 IHc1 st_ h_ st' h' [] -> -> Hs' h'' Hh''.
  case: {IHc1}(IHc1 _ _ _ _ (refl_equal _) Hs' _ Hh'').
  split=> //.
  by apply while.exec_ifte_false.
- move=> [st h] s' s'' b c Hb Hc IHc Hwhile IHwhile st_ h_ st'' h'' [] -> -> Hs'' h2 Hh2.
  destruct s' as [[st' h']|].
  + case: (IHc _ _ _ _ (refl_equal _) (refl_equal _) _ Hh2) => Htmp Htmp'.
    subst s''.
     case: (IHwhile _ _ _ _ (refl_equal _) (refl_equal _) _ Htmp') => Htmp'' Htmp'''.
     split=> //.
     by apply while.exec_while_true with (Some (st', heap.union h' h2)).
  + subst s''.
    by move/semop_prop_m.from_none : Hwhile.
- move=> [st h] b c Hb st_ h_ st' h' [] -> -> [] -> -> h2 Hh2.
  split=> //.
  by apply while.exec_while_false.
Qed.

From mathcomp Require Import seq.

Lemma exec_termi_proj0 (s : option state) (c : cmd0) (s' : option state) :
   s -- c ----> s' ->
   forall (st : store.t) (h0 : heap.t) d,
   Some (st, h0) = s ->
   exists s'_ : option state, Some (st, heap.proj h0 d) -- c ---> s'_.
Proof.
case=> //; clear s c s'.
- move=> s st h d [] Hs.
  eapply ex_intro.
  constructor.
  by apply exec0_nop.
- move=> st h rd rs rt Hcond st_ h_ d [] -> ->.
  eapply ex_intro.
  constructor.
  by apply exec0_add.
- move=> st h rd rs rt Hcond st_ h_ d [] -> ->.
  eapply ex_intro.
  constructor.
  by apply exec0_add_error.
- move=> st h rt rs imm Hcond st_ h_ d [] -> ->.
  eapply ex_intro.
  constructor.
  by apply exec0_addi.
- move=> st h rt rs imm Hcond st_ h_ d [] -> ->.
  eapply ex_intro.
  constructor.
  by apply exec0_addi_error.
- move=> st h rt rs imm st_ h_ d [] -> ->.
  eapply ex_intro.
  constructor.
  by apply exec0_addiu.
- move=> st h rd rs rt st_ h_ d [] -> ->.
  eapply ex_intro.
  constructor.
  by apply exec0_addu.
- move=> st h rd rs rt st_ h_ d [] -> ->.
  eapply ex_intro.
  constructor.
  by apply exec0_and.
- move=> st h rt rs imm st_ h_ d [] -> ->.
  eapply ex_intro.
  constructor.
  by apply exec0_andi.
- move=> st h rt off base p z Hp Hz st_ h_ d [] -> ->.
  case/boolP : (p \in d) => X.
  + eapply ex_intro.
    constructor.
    apply exec0_lw with p => //.
    rewrite heap.get_proj //.
    by apply Hz.
  + eapply ex_intro.
    constructor.
    apply exec0_lw_error.
    move=> [l [Hl [p_ Hp_]]].
    rewrite Hp in Hl.
    have {Hl}Y : p = l by lia.
    subst l.
    by rewrite heap.get_proj_None in Hp_.
- move=> st h rt off base Hcond st_ h_ d [] -> ->.
  eapply ex_intro.
  constructor.
  apply exec0_lw_error.
  contradict Hcond.
  case: Hcond => l [Hl [z Hz]]; exists l; split=> //.
  exists z.
  case/boolP : (l \in d) => X.
  + by rewrite heap.get_proj in Hz.
  + by rewrite heap.get_proj_None in Hz.
- move=> st h rt idx base p z Hp Hz st_ h_ d [] -> ->.
  case/boolP : (p \in d) => X.
  + eapply ex_intro.
    constructor.
    apply exec0_lwxs with p => //.
    rewrite heap.get_proj //.
    by apply Hz.
  + eapply ex_intro.
    constructor.
    apply exec0_lwxs_error.
    move=> [l [Hl [p_ Hp_]]].
    rewrite Hp in Hl.
    have {Hl}Y : p = l by lia.
    subst l.
    by rewrite heap.get_proj_None in Hp_.
- move=> st h rt off base Hcond st_ h_ d [] -> ->.
  eapply ex_intro.
  constructor.
  apply exec0_lwxs_error.
  contradict Hcond.
  case: Hcond => l [Hl [z Hz]]; exists l; split=> //.
  exists z.
  case/boolP : (l \in d) => X.
  + by rewrite heap.get_proj in Hz.
  + by rewrite heap.get_proj_None in Hz.
- move=> st h rs rt st_ h_ d [] -> ->.
  eapply ex_intro.
  constructor.
  by apply exec0_maddu.
- move=> st h rd st_ h_ d [] -> ->.
  eapply ex_intro.
  constructor.
  by apply exec0_mfhi.
- move=> st h rd st_ h_ d [] -> ->.
  eapply ex_intro.
  constructor.
  by apply exec0_mflhxu.
- move=> st h rd st_ h_ d [] -> ->.
  eapply ex_intro.
  constructor.
  by apply exec0_mflo.
- move=> st h rd rs rt Hcond st_ h_ d [] -> ->.
  eapply ex_intro.
  constructor.
  by apply exec0_movn_true.
- move=> st h rd rs rt Hcond st_ h_ d [] -> ->.
  eapply ex_intro.
  constructor.
  by apply exec0_movn_false.
- move=> st h rd rs rt Hcond st_ h_ d [] -> ->.
  eapply ex_intro.
  constructor.
  by apply exec0_movz_true.
- move=> st h rd rs rt Hcond st_ h_ d [] -> ->.
  eapply ex_intro.
  constructor.
  by apply exec0_movz_false.
- move=> st h rs rt st_ h_ d [] -> ->.
  eapply ex_intro.
  constructor.
  by apply exec0_msubu.
- move=> st h rd st_ h_ d [] -> ->.
  eapply ex_intro.
  constructor.
  by apply exec0_mthi.
- move=> st h rd st_ h_ d [] -> ->.
  eapply ex_intro.
  constructor.
  by apply exec0_mtlo.
- move=> st h rs rt st_ h_ d [] -> ->.
  eapply ex_intro.
  constructor.
  by apply exec0_multu.
- move=> st h rd rs rt st_ h_ d [] -> ->.
  eapply ex_intro.
  constructor.
  by apply exec0_nor.
- move=> st h rd rs rt st_ h_ d [] -> ->.
  eapply ex_intro.
  constructor.
  by apply exec0_or.
- move=> st h rx ry sa st_ h_ d [] -> ->.
  eapply ex_intro.
  constructor.
  by apply exec0_sll.
- move=> st h rd rs rt st_ h_ d [] -> ->.
  eapply ex_intro.
  constructor.
  by apply exec0_sllv.
- move=> st h rd rs rt flag Hflag st_ h_ d [] -> ->.
  eapply ex_intro.
  constructor.
  by apply exec0_sltu.
- move=> st h rd rt sa st_ h_ d [] -> ->.
  eapply ex_intro.
  by apply while.exec_cmd0, exec0_sra.
- move=> st h rd rt sa st_ h_ d [] -> ->.
  eapply ex_intro.
  by apply while.exec_cmd0, exec0_srl.
- move=> st h rd rs rt st_ h_ d [] -> ->.
  eapply ex_intro.
  constructor.
  by apply exec0_srlv.
- move=> st h rd rs rt st_ h_ d [] -> ->.
  eapply ex_intro.
  constructor.
  by apply exec0_subu.
- move=> st h rt off base p Hp [z Hz] st_ h_ d [] -> ->.
  case/boolP : (p \in d) => X.
  + eapply ex_intro.
    constructor.
    apply exec0_sw.
    apply Hp.
    exists z.
    by rewrite heap.get_proj.
  + eapply ex_intro.
    constructor.
    apply exec0_sw_err.
    move=> [l [Hl [z' Hz']]].
    have X' : p = l by lia.
    subst p.
    by rewrite heap.get_proj_None in Hz'.
- move=> st h rt off base H st_ h_ d [] -> ->.
  eapply ex_intro.
  constructor.
  apply exec0_sw_err.
  contradict H.
  case: H => [l [Hl [p Hp]]].
  exists l; split => //.
  exists p.
  case/boolP : (l \in d) => X.
  rewrite heap.get_proj // in Hp.
  by rewrite heap.get_proj_None in Hp.
- move=> st h rd rs rt st_ h_ d [] -> ->.
  eapply ex_intro.
  constructor.
  by apply exec0_xor.
- move=> st h rt rs imm st_ h_ d [] -> ->.
  eapply ex_intro.
  constructor.
  by apply exec0_xori.
Qed.

Module semop_deter_prop_m := while.While_Semop_Deter_Prop WMIPS_Semop_Deter.

Lemma exec_termi_proj st h s' c d : Some (st, h) -- c ---> s' ->
  exists s'_, Some (st, heap.proj h d) -- c ---> s'_.
Proof.
move Hs : (Some (st, h)) => s.
move=> Hexec.
move: Hexec st h d Hs.
elim=> //; clear c s s'.
- exact exec_termi_proj0.
- move=> s s' s'' c1 c2 Hc1 IHc1 Hc2 IHc2 st h d Hs.
  case: (IHc1 _ _ d Hs) => s1 Hs1.
  destruct s' as [[st' h']|].
  + subst s.
    destruct s1 as [[st1 h1]|].
    * move: (exec_deter_proj _ _ _ _ _ Hc1 _ _ _ Hs1) => Htmp.
      case: Htmp => Hst1 [Hh1 Hd'].
      subst st' h1.
      case: {IHc2}(IHc2 _ _ d (refl_equal _)) => s''_ IHc2.
      exists s''_.
      by eapply while.exec_seq; eauto.
    * exists None.
      eapply while.exec_seq; eauto.
      apply while.exec_none.
  + destruct s''.
    * by move/semop_prop_m.from_none : Hc2.
    * destruct s1 as [[st1 h1]|].
      - move: (safety_monotonicity _ _ _ _ _ Hs1 (heap.difs h d) (map_prop_m.proj_difs_disj_spec _ _)).
        rewrite -heap.proj_difs.
        case=> Hexec _.
        subst s.
        by move: (semop_deter_prop_m.exec_deter _ _ _ Hexec _ Hc1).
      - exists None.
        by eapply while.exec_seq; eauto.
- move=> [st h] s' b c1 c2 Hb Hc1 IHc1 st_ h_ d.
  case=> X Y; subst st_ h_.
  case: (IHc1 _ _ d (refl_equal _)) => s1 Hs1.
  exists s1.
  by apply while.exec_ifte_true.
- move=> [st h] s' b c1 c2 Hb Hc1 IHc1 st_ h_ d.
  case=> X Y; subst st_ h_.
  case: (IHc1 _ _ d (refl_equal _)) => s1 Hs1.
  exists s1.
  by apply while.exec_ifte_false.
- (* while true *) move=> [st h] s' s'' b c Hb Hc IHc Hwhile IHwhile st_ h_ d [] X Y; subst st_ h_.
  case: {IHc}(IHc _ _ d (refl_equal _)) => s1 IHc.
  destruct s1 as [[st1 h1]|].
  + destruct s' as [[st' h']|].
    * move: (exec_deter_proj _ _ _ _ _ Hc _ _ _ IHc) => Htmp.
      case: Htmp => Hst1 [Hh1 Hh'].
      subst st1 h1.
      case: {IHwhile}(IHwhile _ _ d (refl_equal _)) => s' IHwhile.
      exists s'.
      eapply while.exec_while_true => //.
      apply IHc.
      done.
    * move: (safety_monotonicity _ _ _ _ _ IHc (heap.difs h d) (map_prop_m.proj_difs_disj_spec _ _)).
      rewrite -heap.proj_difs.
      case=> Hexec _.
      by move: (semop_deter_prop_m.exec_deter _ _ _ Hexec _ Hc).
  + exists None.
    apply while.exec_while_true with None => //.
    by apply while.exec_none.
- move=> [st h] b c Hb st_ h_ d [] -> ->.
  eapply ex_intro.
  by apply while.exec_while_false.
Qed.

Require Import Epsilon.

Lemma triple_exec_precond c P Q : mips_seplog.WMIPS_Hoare.hoare P c Q ->
  forall st h s', Some (st, h) -- c ---> s' ->
    forall d, P st (heap.proj h d) ->
      {s' | Some (st,h) -- c ---> Some s' }.
Proof.
move=> Hhoare st h s' Hexec d HP.
apply constructive_indefinite_description.
move/hoare_prop_m.soundness : Hhoare.
rewrite /hoare_semantics.
move/(_ _ _ HP) => [Hno_err Hsome].
destruct s' as [p|].
by exists p.
move: (exec_termi_proj _ _ _ _ d Hexec).
case => x Hx.
destruct x as [[st' h']|] => //.
move: (safety_monotonicity _ _ _ _ _ Hx (heap.difs h d) (map_prop_m.proj_difs_disj_spec _ _)).
rewrite -heap.proj_difs.
case=> H1 H2.
by move: (semop_deter_prop_m.exec_deter _ _ _ Hexec _ H1).
Qed.

(* NB: inelegant *)
Definition is_while (c : @while.cmd cmd0 expr_b) : bool :=
  match c with | while.while _ _ => true | _ => false end.

(* NB: inelegant *)
Fixpoint contains_while (c : @while.cmd cmd0 expr_b) : bool :=
  match c with
    | while.cmd_cmd0 c0 => false
    | c ; d => contains_while c || contains_while d
    | while.ifte _ c d => contains_while c || contains_while d
    | while.while _ c => true
  end.

Lemma no_while_terminate : forall c, ~~ contains_while c ->
  forall s, exists s', (s -- c ---> s').
Proof.
elim=> //.
- move=> c _ [s|].
  + case: (mips_cmd.cmd0_terminate c s) => x Hx.
    exists x. by apply while.exec_cmd0.
  + exists None; by apply while.exec_none.
- move=> c1 IHc1 c2 IHc2.
  rewrite /= negb_or.
  case/andP=> H1 H2 s.
  case: {IHc1 H1}(IHc1 H1 s) => s1 H1.
  case: {IHc2 H2}(IHc2 H2 s1) => s2 H2.
  exists s2; by apply while.exec_seq with s1.
- move=> b c1 IH1 c2 IH2.
  rewrite /= negb_or.
  case/andP=> H1 H2 s.
  destruct s as [[s h]|].
  + case/boolP : (eval_b b s) => Hb.
    * case: {IH1 H1}(IH1 H1 (Some (s, h))) => s1 H1.
      exists s1; by apply while.exec_ifte_true.
    * case: {IH2 H2}(IH2 H2 (Some (s, h))) => s2 H2.
      by exists s2; apply while.exec_ifte_false.
  + exists None; by apply while.exec_none.
Qed.