(*TODO: These imports should be pared down*)
Require Import FSets.
Require FSetAVL.
Require Import Coqlib.
Require Import Errors.
Require Import compcert.lib.Ordered.
Require Import AST.
Require Import Maps.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Memory.
Require Import Globalenvs.
Require Import Events.

Require Import Ctypes.
Require Import Cop.

Require Import sepcomp.mem_lemmas.
Require Import sepcomp.reach.

(** Properties of values obtained by casting to a given type. *)

Inductive val_casted: val -> type -> Prop :=
  | val_casted_int: forall sz si attr n,
      cast_int_int sz si n = n ->
      val_casted (Vint n) (Tint sz si attr)
  | val_casted_float: forall sz attr n,
      cast_float_float sz n = n ->
      val_casted (Vfloat n) (Tfloat sz attr)
  | val_casted_long: forall si attr n,
      val_casted (Vlong n) (Tlong si attr)
  | val_casted_ptr_ptr: forall b ofs ty attr,
      val_casted (Vptr b ofs) (Tpointer ty attr)
  | val_casted_int_ptr: forall n ty attr,
      val_casted (Vint n) (Tpointer ty attr)
  | val_casted_ptr_int: forall b ofs si attr,
      val_casted (Vptr b ofs) (Tint I32 si attr)
  | val_casted_ptr_cptr: forall b ofs id attr,
      val_casted (Vptr b ofs) (Tcomp_ptr id attr)
  | val_casted_int_cptr: forall n id attr,
      val_casted (Vint n) (Tcomp_ptr id attr)
  | val_casted_struct: forall id fld attr b ofs,
      val_casted (Vptr b ofs) (Tstruct id fld attr)
  | val_casted_union: forall id fld attr b ofs,
      val_casted (Vptr b ofs) (Tunion id fld attr)
  | val_casted_void: forall v,
      val_casted v Tvoid.

Definition val_casted_func (v : val) (t : type) : bool :=
  match v, t with
    | Vint n, Tint sz si attr =>
      if Int.eq_dec (cast_int_int sz si n) n then true
      else false
    | Vfloat n, Tfloat sz attr =>
      if Float.eq_dec (cast_float_float sz n) n then true
      else false
    | Vlong n, Tlong si attr => true
    | Vptr b ofs, Tpointer ty attr => true
    | Vint n, Tpointer ty attr => true
    | Vptr b ofs, Tint I32 si attr => true
    | Vptr b ofs, Tcomp_ptr id attr => true
    | Vint n, Tcomp_ptr id attr => true
    | Vptr b ofs, Tstruct id flt attr => true
    | Vptr b ofs, Tunion id flt attr => true
    | _, Tvoid => true
    | _, _ => false
  end.

Lemma val_casted_funcI v t :
  val_casted v t ->
  val_casted_func v t=true.
Proof.
destruct 1; simpl; auto.
rewrite H. case_eq (Int.eq_dec n n); auto.
rewrite H. case_eq (Float.eq_dec n n); auto.
destruct v; auto.
Qed.

Lemma val_casted_funcE v t :
  val_casted_func v t=true ->
  val_casted v t.
Proof.
destruct v; destruct t; simpl; try solve[inversion 1;econstructor; eauto].
case_eq (Int.eq_dec (cast_int_int i0 s i) i). intros e _ _.
constructor; auto. intros n _; inversion 1.
case_eq (Float.eq_dec (cast_float_float f0 f) f). intros e _ _.
constructor; auto. intros n _; inversion 1.
destruct i0; try inversion 1. constructor.
Qed.

Lemma val_casted_funcP v t :
  val_casted_func v t=true <-> val_casted v t.
Proof.
split; [apply val_casted_funcE|apply val_casted_funcI].
Qed.

Remark cast_int_int_idem:
  forall sz sg i, cast_int_int sz sg (cast_int_int sz sg i) = cast_int_int sz sg i.
Proof.
  intros. destruct sz; simpl; auto.
  destruct sg; [apply Int.sign_ext_idem|apply Int.zero_ext_idem]; compute; intuition congruence.
  destruct sg; [apply Int.sign_ext_idem|apply Int.zero_ext_idem]; compute; intuition congruence.
  destruct (Int.eq i Int.zero); auto.
Qed.

Remark cast_float_float_idem:
  forall sz f, cast_float_float sz (cast_float_float sz f) = cast_float_float sz f.
Proof.
  intros; destruct sz; simpl.
  apply Float.singleoffloat_idem; auto.
  auto.
Qed.

Lemma cast_val_is_casted:
  forall v ty ty' v', sem_cast v ty ty' = Some v' -> val_casted v' ty'.
Proof.
  unfold sem_cast; intros. destruct ty'; simpl in *.
(* void *)
  constructor.
(* int *)
  destruct i; destruct ty; simpl in H; try discriminate; destruct v; inv H.
  constructor. apply (cast_int_int_idem I8 s).
  constructor. apply (cast_int_int_idem I8 s).
  destruct (cast_float_int s f0); inv H1.   constructor. apply (cast_int_int_idem I8 s).
  constructor. apply (cast_int_int_idem I16 s).
  constructor. apply (cast_int_int_idem I16 s).
  destruct (cast_float_int s f0); inv H1.   constructor. apply (cast_int_int_idem I16 s).
  constructor. auto.
  constructor.
  constructor. auto.
  destruct (cast_float_int s f0); inv H1. constructor. auto.
  constructor. auto.
  constructor.
  constructor; auto.
  constructor.
  constructor; auto.
  constructor; auto.
  constructor; auto.
  constructor; auto.
  constructor. simpl. destruct (Int.eq i0 Int.zero); auto.
  constructor. simpl. destruct (Int64.eq i Int64.zero); auto.
  constructor. simpl. destruct (Float.cmp Ceq f0 Float.zero); auto.
  constructor. simpl. destruct (Int.eq i Int.zero); auto.
  constructor; auto.
  constructor. simpl. destruct (Int.eq i Int.zero); auto.
  constructor; auto.
  constructor. simpl. destruct (Int.eq i Int.zero); auto.
  constructor; auto.
  constructor. simpl. destruct (Int.eq i0 Int.zero); auto.
  constructor; auto.
(* long *)
  destruct ty; try discriminate.
  destruct v; inv H. constructor.
  destruct v; inv H. constructor.
  destruct v; try discriminate. destruct (cast_float_long s f0); inv H. constructor.
  destruct v; inv H. constructor.
  destruct v; inv H. constructor.
  destruct v; inv H. constructor.
  destruct v; inv H. constructor.
(* float *)
  destruct ty; simpl in H; try discriminate; destruct v; inv H.
  constructor. unfold cast_float_float, cast_int_float.
  destruct f; destruct s; auto.
  rewrite Float.singleofint_floatofint. apply Float.singleoffloat_idem.
  rewrite Float.singleofintu_floatofintu. apply Float.singleoffloat_idem.
  constructor. unfold cast_float_float, cast_long_float.
  destruct f; destruct s; auto. apply Float.singleoflong_idem. apply Float.singleoflongu_idem.
  constructor. apply cast_float_float_idem.
(* pointer *)
  destruct ty; simpl in H; try discriminate; destruct v; inv H; try constructor.
(* impossible cases *)
  discriminate.
  discriminate.
(* structs *)
  destruct ty; try discriminate; destruct v; try discriminate.
  destruct (ident_eq i0 i && fieldlist_eq f0 f); inv H; constructor.
(* unions *)
  destruct ty; try discriminate; destruct v; try discriminate.
  destruct (ident_eq i0 i && fieldlist_eq f0 f); inv H; constructor.
(* comp_ptr *)
  destruct ty; simpl in H; try discriminate; destruct v; inv H; constructor.
Qed.

Lemma val_casted_load_result:
  forall v ty chunk,
  val_casted v ty -> access_mode ty = By_value chunk ->
  Val.load_result chunk v = v.
Proof.
  intros. inversion H; clear H; subst v ty; simpl in H0.
  destruct sz.
  destruct si; inversion H0; clear H0; subst chunk; simpl in *; congruence.
  destruct si; inversion H0; clear H0; subst chunk; simpl in *; congruence.
  clear H1. inv H0. auto.
  inversion H0; clear H0; subst chunk. simpl in *.
  destruct (Int.eq n Int.zero); subst n; reflexivity.
  destruct sz; inversion H0; clear H0; subst chunk; simpl in *; congruence.
  inv H0; auto.
  inv H0; auto.
  inv H0; auto.
  inv H0; auto.
  discriminate.
  discriminate.
  discriminate.
  discriminate.
  discriminate.
Qed.

Lemma cast_val_casted:
  forall v ty, val_casted v ty -> sem_cast v ty ty = Some v.
Proof.
  intros. inversion H; clear H; subst v ty; unfold sem_cast; simpl; auto.
  destruct sz; congruence.
  congruence.
  unfold proj_sumbool; repeat rewrite dec_eq_true; auto.
  unfold proj_sumbool; repeat rewrite dec_eq_true; auto.
Qed.

Lemma val_casted_inject:
  forall f v v' ty,
  val_inject f v v' -> val_casted v ty -> val_casted v' ty.
Proof.
  intros. inv H; auto.
  inv H0; constructor.
  inv H0; constructor.
Qed.

Inductive val_casted_list: list val -> typelist -> Prop :=
  | vcl_nil:
      val_casted_list nil Tnil
  | vcl_cons: forall v1 vl ty1 tyl,
      val_casted v1 ty1 -> val_casted_list vl tyl ->
      val_casted_list (v1 :: vl) (Tcons  ty1 tyl).

Lemma val_casted_list_params:
  forall params vl,
  val_casted_list vl (type_of_params params) ->
  list_forall2 val_casted vl (map snd params).
Proof.
  induction params; simpl; intros.
  inv H. constructor.
  destruct a as [id ty]. inv H. constructor; auto.
Qed.

Fixpoint val_casted_list_func (vs : list val) (ts : typelist) : bool :=
  match vs, ts with
    | nil, Tnil => true
    | v1 :: vl, Tcons ty1 tyl =>
      val_casted_func v1 ty1 && val_casted_list_func vl tyl
    | _, _ => false
  end.

Lemma val_casted_list_funcP vs ts :
  val_casted_list_func vs ts=true <-> val_casted_list vs ts.
Proof.
revert ts; induction vs. destruct ts; simpl; auto.
split; auto. intros _. constructor.
split; auto. inversion 1. inversion 1.
split; auto. destruct ts; simpl; auto.
inversion 1. rewrite andb_true_iff. intros [H1 H2]. constructor.
apply val_casted_funcE in H1; auto. rewrite <-IHvs; auto.
inversion 1; subst. simpl. rewrite andb_true_iff; split.
apply val_casted_funcI; auto. rewrite IHvs; auto.
Qed.

Lemma val_casted_inj (j : meminj) v1 v2 tv :
  val_inject j v1 v2 ->
  val_casted v1 tv ->
  val_casted v2 tv.
Proof.
inversion 1; subst; auto.
inversion 1; subst; auto; try solve[constructor; auto].
inversion 1; constructor.
Qed.

Lemma val_casted_list_inj (j : meminj) vs1 vs2 ts :
  val_list_inject j vs1 vs2 ->
  val_casted_list vs1 ts ->
  val_casted_list vs2 ts.
Proof.
intros H1; revert vs1 vs2 H1; induction ts; simpl; intros vs1 vs2 H1 H2.
revert H2 H1; inversion 1; subst. inversion 1; subst. constructor.
revert H2 H1; inversion 1; subst. inversion 1; subst. constructor.
eapply val_casted_inj; eauto.
eapply IHts; eauto.
Qed.

Definition val_has_type_func (v : val) (t : typ) : bool :=
  match v with
    | Vundef => true
    | Vint _ => match t with
                  | AST.Tint => true
                  | _ => false
                end
    | Vlong _ => match t with
                 | AST.Tlong => true
                 | _ => false
               end
    | Vfloat f => match t with
                    | AST.Tfloat => true
                    | Tsingle => if Float.is_single_dec f then true else false
                    | _ => false
                  end
    | Vptr _ _ => match t with
                    | AST.Tint => true
                    | _ => false
                  end
  end.

Lemma val_has_type_funcP v t :
  Val.has_type v t <-> (val_has_type_func v t=true).
Proof.
split.
induction v; auto.
simpl. destruct t; auto.
simpl. destruct t; auto.
simpl. destruct t; auto. destruct (Float.is_single_dec f); auto.
simpl. destruct t; auto.
induction v; simpl; auto.
destruct t; auto; try inversion 1.
destruct t; auto; try inversion 1.
destruct t; auto; try solve[inversion 1].
destruct (Float.is_single_dec f); try solve[inversion 1|auto].
destruct t; auto. inversion 1. inversion 1. inversion 1.
Qed.

Fixpoint val_has_type_list_func (vl : list val) (tyl : list typ) : bool :=
  match vl, tyl with
    | nil, nil => true
    | v :: vl', ty :: tyl' => val_has_type_func v ty
                              && val_has_type_list_func vl' tyl'
    | nil, _ :: _ => false
    | _ :: _, nil => false
  end.

Lemma val_has_type_list_func_charact vl tyl :
  Val.has_type_list vl tyl <-> (val_has_type_list_func vl tyl=true).
Proof.
revert tyl; induction vl.
destruct tyl. simpl. split; auto. simpl. split; auto. inversion 1.
intros. destruct tyl. simpl. split; auto. inversion 1.
simpl. split. intros [H H2].
+ rewrite andb_true_iff. split.
  rewrite <-val_has_type_funcP; auto.
  rewrite <-IHvl; auto.
+ rewrite andb_true_iff. intros [H H2]. split.
  rewrite val_has_type_funcP; auto.
  rewrite IHvl; auto.
Qed.

Fixpoint tys_nonvoid (tyl : typelist) :=
  match tyl with
    | Tnil => true
    | Tcons Tvoid tyl' => false
    | Tcons _ tyl' => tys_nonvoid tyl'
  end.

Fixpoint vals_defined (vl : list val) :=
  match vl with
    | nil => true
    | Vundef :: _ => false
    | _ :: vl' => vals_defined vl'
  end.

Lemma vals_inject_defined (vl1 vl2 : list val) (j : meminj) :
  val_list_inject j vl1 vl2 ->
  vals_defined vl1=true ->
  vals_defined vl2=true.
Proof.
revert vl2; induction vl1; simpl. destruct vl2; try solve[inversion 1|auto].
intros vl2; inversion 1; subst. destruct a; try solve[inversion 1].
inv H. inv H5. simpl. intros X. rewrite (IHvl1 vl'); auto.
inv H. inv H5. simpl. intros X. rewrite (IHvl1 vl'); auto.
inv H. inv H5. simpl. intros X. rewrite (IHvl1 vl'); auto.
inv H. inv H5. simpl. intros X. rewrite (IHvl1 vl'); auto.
Qed.

Lemma valinject_hastype':
  forall (j : meminj) (v v' : val),
    val_inject j v v' ->
    v <> Vundef ->
    forall T : typ, Val.has_type v T -> Val.has_type v' T.
Proof.
  intros.
  induction H; auto.
  elim H0; auto.
Qed.

Lemma val_list_inject_hastype j vl1 vl2 tys :
  val_list_inject j vl1 vl2 ->
  vals_defined vl1=true ->
  val_has_type_list_func vl1 tys=true ->
  val_has_type_list_func vl2 tys=true.
Proof.
revert vl2 tys. induction vl1. inversion 1. solve[destruct tys; simpl; auto].
intros H tys H1 H2 H3. inv H1.
assert (def: vals_defined vl1=true).
{ inv H2. revert H0. destruct a; auto. congruence. }
simpl. destruct tys. simpl in H3; congruence.
rewrite andb_true_iff. split.
rewrite <-val_has_type_funcP. eapply valinject_hastype'; eauto.
simpl in H2. intros contra. rewrite contra in H2. congruence.
inv H3. rewrite andb_true_iff in H0.
  destruct H0 as [H0 _]. solve[rewrite val_has_type_funcP; auto].
eapply (IHvl1 vl'); eauto.
inv H3. rewrite H0. rewrite andb_true_iff in H0.
  solve[destruct H0 as [_ ->]; auto].
Qed.

Lemma val_list_inject_defined j vl1 vl2 :
  val_list_inject j vl1 vl2 ->
  vals_defined vl1=true ->
  vals_defined vl2=true.
Proof.
revert vl2. induction vl1; simpl.
+ intros vl2; inversion 1; auto.
+ intros vl2; inversion 1; subst. inv H.
simpl. intros H8.
assert (def1: vals_defined vl1=true).
{ destruct a; try solve[congruence]. }
revert H2 H8. inversion 1; auto. subst. congruence.
Qed.

(*TODO: put these in Events.v*)
Fixpoint encode_longs (tyl : list typ) (vl : list val) :=
  match tyl with
    | nil => nil
    | AST.Tlong :: tyl' =>
      match vl with
        | nil => nil
        | Vlong n :: vl' => Vint (Int64.hiword n) :: Vint (Int64.loword n)
                            :: encode_longs tyl' vl'
        | Vundef :: vl' => Vundef :: Vundef :: encode_longs tyl' vl'
        | _ :: vl' => Vundef :: Vundef :: encode_longs tyl' vl'
      end
    | t :: tyl' =>
      match vl with
        | nil => nil
        | v :: vl' => v :: encode_longs tyl' vl'
      end
  end.

Fixpoint encode_typs (tyl : list typ) : list typ :=
  match tyl with
    | nil => nil
    | AST.Tlong :: tyl' => AST.Tint :: AST.Tint :: encode_typs tyl'
    | t :: tyl' => t :: encode_typs tyl'
  end.

Lemma encode_longs_has_type tyl vl :
  Val.has_type_list vl tyl ->
  Val.has_type_list (encode_longs tyl vl) (encode_typs tyl).
Proof.
revert vl; induction tyl. simpl; auto.
destruct vl. intros; contradiction. intros [H H2]. simpl.
destruct a; try solve[split; auto].
destruct v; simpl; auto.
Qed.

Lemma decode_encode_longs tyl vl :
  Val.has_type_list vl tyl ->
  decode_longs tyl (encode_longs tyl vl) = vl.
Proof.
revert tyl; induction vl.
destruct tyl. simpl; auto.
destruct t; simpl; auto.
destruct tyl. simpl. inversion 1. inversion 1; subst. clear H.
simpl. destruct t; auto; try rewrite IHvl; auto.
destruct a; simpl; try solve[inv H0].
rewrite IHvl; auto.
rewrite IHvl; auto. f_equal.
rewrite Int64.ofwords_recompose; auto.
Qed.

Lemma encode_longs_inject:
  forall (f : meminj) (tyl : list typ) (vl1 vl2 : list val),
  val_list_inject f vl1 vl2 ->
  val_list_inject f (encode_longs tyl vl1) (encode_longs tyl vl2).
Proof.
intros until vl2; intros H; revert tyl; induction H; simpl.
destruct tyl; simpl; [solve[constructor]|]. solve[destruct t; auto].
destruct tyl; simpl; [solve[constructor]|]. destruct t.
solve[constructor; auto].
solve[constructor; auto].
inv H. solve[auto]. constructor; auto. solve[auto]. solve[auto].
destruct v'; solve[auto|constructor; auto].
solve[constructor; auto].
Qed.

Fixpoint getBlocks' (vl : list val) (b0 : block) :=
  match vl with
    | nil => false
    | Vptr b _ :: vl' => eq_block b b0 || getBlocks' vl' b0
    | _ :: vl' => getBlocks' vl' b0
  end.

Lemma getBlocks_getBlocks' vl b0 : getBlocks vl b0 = getBlocks' vl b0.
Proof.
induction vl; simpl; auto.
destruct a; auto. unfold getBlocks. simpl.
destruct (eq_block b b0); simpl; auto.
rewrite <-IHvl. unfold getBlocks.
destruct (
     in_dec eq_block b0
       (fold_right
          (fun (v : val) (L : list block) =>
           match v with
           | Vundef => L
           | Vint _ => L
           | Vlong _ => L
           | Vfloat _ => L
           | Vptr b' _ => b' :: L
           end) nil vl)
); auto.
Qed.

Lemma getBlocks_encode_longs tys vals b :
  getBlocks (encode_longs tys vals) b=true ->
  getBlocks vals b=true.
Proof.
  rewrite !getBlocks_getBlocks'.
  revert tys; induction vals; simpl; auto. destruct tys. simpl; auto.
  solve[destruct t; simpl; auto].
  destruct tys. simpl; congruence.
  simpl. destruct t; destruct a; simpl; intros; try solve[eapply IHvals; eauto].
  rewrite orb_true_iff in H. destruct H. rewrite H; auto.
    rewrite orb_true_iff. right. solve[eapply IHvals; eauto].
  rewrite orb_true_iff in H. destruct H. rewrite H; auto.
    rewrite orb_true_iff. right. solve[eapply IHvals; eauto].
  rewrite orb_true_iff. right. solve[eapply IHvals; eauto].
  rewrite orb_true_iff in H. destruct H. rewrite H; auto.
    rewrite orb_true_iff. right. solve[eapply IHvals; eauto].
Qed.

Lemma val_casted_has_type a t :
  tys_nonvoid (Tcons t Tnil) = true ->
  val_casted_func a t = true ->
  val_has_type_func a (typ_of_type t) = true.
Proof.
intros H0 H.
apply val_casted_funcE in H.
induction H; try solve[auto].
destruct H. destruct sz. simpl.
generalize (Float.singleoffloat_is_single n0).
destruct (Float.is_single_dec (Float.singleoffloat n0)); auto. auto.
simpl in H0. congruence.
Qed.

Lemma val_casted_has_type_list vals tys :
  tys_nonvoid tys = true ->
  val_casted_list_func vals tys = true ->
  val_has_type_list_func vals (typlist_of_typelist tys) = true.
Proof.
revert vals; induction tys. simpl. intros vals.
destruct vals. simpl; auto. simpl. solve[inversion 2].
simpl; intros vals; revert tys IHtys; induction vals. simpl.
  intros; congruence.
simpl; intros. rewrite andb_true_iff in H0; destruct H0 as [H0 H2].
assert (H3: tys_nonvoid tys = true).
{ destruct t; solve[congruence|auto]. }
rewrite andb_true_iff. split; auto.
apply val_casted_has_type; auto. destruct t; auto.
Qed.


Require Import ZArith.
Require Import List.
Require Import Bool.
Require        BoolExt.
Require        OptionExt.
Require        ListExt.
Require Import Twosig.
Require Import BasicMachineTypes.
Require Import ClassDatatypesIface.
Require Import ClasspoolIface.
Require Import AssignabilityIface.
Require Import ResolutionIface.
Require Import VirtualMethodLookupIface.
Require Import CertRuntimeTypesIface.
Require Import ResourceAlgebra.
Require Import JVMState.
Require Import NativeMethods.
Require Import AnnotationIface.
Require        FSetInterface.

(* TODO: remove *)
Set Asymmetric Patterns.

Module Execution (B    : BASICS)
                 (RA   : RESOURCE_ALGEBRA B)
                 (ANN  : ANNOTATION B)
                 (C    : CLASSDATATYPES B ANN)
                 (CP   : CLASSPOOL B ANN C)
                 (A    : ASSIGNABILITY B ANN C CP)
                 (R    : RESOLUTION B ANN C CP A)
                 (VM   : VIRTUALMETHODLOOKUP B ANN C CP A)
                 (RDT  : CERTRUNTIMETYPES B ANN C CP A)
                 (JVM  : JVMSTATE B RA ANN C CP A R VM RDT)
                 (NATIVE : NATIVE_METHODS B RA ANN C CP A R VM RDT JVM)
                 (ClassnameSet :FSetInterface.S with Definition E.t := B.Classname.t with Definition E.eq := B.Classname.eq).

Import RDT.
Import JVM.

Section WithPreclasses.

Hypothesis preclasses : CP.Preclasspool.t.
Hypothesis privilegedclasses : ClassnameSet.t.

(* Exception handling *)
Section ExceptionHandling.

Hypothesis classes : CP.cert_classpool.

Inductive find_handler_result : Set :=
| handler_found : nat -> find_handler_result
| handler_notfound : find_handler_result
| handler_wrong : find_handler_result.

Definition search_handlers (handlers:list C.exception_handler)
                           (pc:nat)
                           (class:C.class)
                           (exc_cls:B.Classname.t)
                         : find_handler_result
  :=
  let fix search_handlers_aux (handlers:list C.exception_handler) : find_handler_result :=
        match handlers with
        | nil =>
           handler_notfound
        | C.mkExcHandler start_pc end_pc handler_pc opt_type_idx::handlers =>
           if C.is_within start_pc end_pc pc then
              match opt_type_idx with
              | None =>
                 handler_found handler_pc
              | Some type_idx =>
                 match C.ConstantPool.lookup (C.class_constantpool class) type_idx with
                 | Some (C.cpe_classref cls_nm) =>
                    if A.is_assignable classes (C.ty_obj exc_cls) (C.ty_obj cls_nm) then
                       handler_found handler_pc
                    else
                       search_handlers_aux handlers
                 | _ => handler_wrong
                 end
              end
           else
              search_handlers_aux handlers
        end in
    search_handlers_aux handlers.

Fixpoint unwind_stack (frames:list frame)
                      (ref:Heap.addr_t)
                      (exc_cls:B.Classname.t)
                      {struct frames}
                    : option (list frame)
  :=
  match frames with
  | nil => Some nil
  | mkFrame _ lvars pc code mth class::frames =>
     match search_handlers (C.code_exception_table code) pc class exc_cls with
     | handler_found pc =>
        Some (mkFrame (rt_addr (Some ref)::nil) lvars pc code mth class::frames)
     | handler_notfound =>
        unwind_stack frames ref exc_cls
     | handler_wrong =>
        None
     end
  end.

(* need to make this abstract by hiding the implementation and just specifying what happens:
 * - gets the least
 *)

End ExceptionHandling.

Definition throw_exception : state -> Heap.addr_t -> exec_result :=
  fun state ref => match state with
  | mkState fs classes heap statics res reslimit =>
     match heap_lookup_class heap ref with
     | inleft (exist cls_nm _) =>
        match unwind_stack classes fs ref cls_nm with
        | Some nil =>
           stop_exn (mkState nil classes heap statics res reslimit) ref
        | Some fs =>
           cont (mkState fs classes heap statics res reslimit)
        | None => wrong
        end
     | inright _ => wrong
     end
  end.

Definition add_res_new : B.Classname.t -> state -> state :=
  fun clsnm state => match state with
  | mkState fs classes heap statics used reslimit =>
     let new_used := match RA.r_new clsnm with
                       | None => used
                       | Some r => RA.combine used r
                     end in
       mkState fs classes heap statics new_used reslimit
  end.

(* FIXME: this doesn't really create the objects properly: it never runs their initialiser, nor does it resolve the classes.
          we should add an invariant that states that the builtin exception classes have already been loaded *)
Definition throw_builtin_exception : state -> CP.exn -> exec_result :=
  fun state e => match state with
  | mkState fs classes heap statics res reslimit =>
     let cls_nm := CP.builtin_exception_to_class_name e in
     match CP.gather_class_exists_evidence classes cls_nm with (* FIXME: need an invariant that states that builtin exception classes always exist *)
     | inright evidence =>
        match heap_new heap cls_nm evidence with
        | pack2 heap' addr (conj _ (conj _ (conj _ (conj preserve _)))) =>
           let statics' := preserve_cert_fieldstore_over_heap statics preserve in
           let state' := add_res_new cls_nm (mkState fs classes heap' statics' res reslimit) in
            throw_exception state' addr
        end
     | inleft _ => wrong
     end
  end.

(* Instruction implementations *)

Definition exec_iconst : B.Int32.t -> state -> exec_result :=
  fun i state => match state with
  | mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit =>
     cont (mkState (mkFrame (rt_int i::op_stack) lvars (S pc) code mth class::fs) classes heap statics res reslimit)
  | _ => wrong
  end.

Definition exec_iarithb : C.integer_bop -> state -> exec_result :=
  fun op state => match state with
  | mkState (mkFrame (rt_int z2::rt_int z1::op_stack) lvars pc code mth class::fs) classes heap statics res reslimit =>
     let result := match op with
                   | C.iadd => Some (B.Int32.add z1 z2)
                   | C.isub => Some (B.Int32.sub z1 z2)
                   | C.imul => Some (B.Int32.mul z1 z2)
                   | C.iand => Some (B.Int32.logand z1 z2)
                   | C.ior  => Some (B.Int32.logor z1 z2)
                   | C.ixor => Some (B.Int32.logxor z1 z2)
                   | _    => None
                   end in
     match result with
     | None => undefined
     | Some z =>
        cont (mkState (mkFrame (rt_int z::op_stack) lvars (S pc) code mth class::fs) classes heap statics res reslimit)
     end
  | _ => wrong
  end.

Definition exec_iarithu : C.integer_uop -> state -> exec_result :=
  fun op state => match state with
  | mkState (mkFrame (rt_int i::op_stack) lvars pc code mth class::fs) classes heap statics res reslimit =>
     let r := match op with C.ineg => B.Int32.neg i end in
     cont (mkState (mkFrame (rt_int r::op_stack) lvars (S pc) code mth class::fs) classes heap statics res reslimit)
  | _ => wrong
  end.

Definition exec_load : nat -> state -> exec_result :=
  fun n state => match state with
  | mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit =>
     match OptionExt.option_mult (nth_error lvars n) with
     | None => wrong
     | Some v =>
        cont (mkState (mkFrame (v::op_stack) lvars (S pc) code mth class::fs) classes heap statics res reslimit)
     end
  | _ => wrong
  end.

Definition update_lvars : nat -> rt_val -> list (option rt_val) -> option (list (option rt_val)) :=
  fun n v lvars0 =>
  let olvars1 := match n with
                | O => Some lvars0
                | S n' =>
                   (* obliterate the preceding value if it is a category 2 one *)
                   match nth_error lvars0 n' with
                   | None => None
                   | Some None => Some lvars0
                   | Some (Some v) =>
                      match val_category v with
                      | C.category1 => Some lvars0
                      | C.category2 => ListExt.list_update lvars0 n' None
                      end
                   end
                end in
  match olvars1 with
  | None => None
  | Some lvars1 =>
     match ListExt.list_update lvars1 n (Some v) with
     | None => None
     | Some lvars2 =>
        match val_category v with
        | C.category1 => Some lvars2
        | C.category2 => ListExt.list_update lvars2 (S n) None
        end
     end
  end.

Definition exec_store : nat -> state -> exec_result :=
  fun n state => match state with
  | mkState (mkFrame (v::op_stack) lvars pc code mth class::fs) classes heap statics res reslimit =>
     match update_lvars n v lvars with
     | None => wrong
     | Some new_lvars =>
        cont (mkState (mkFrame op_stack new_lvars (S pc) code mth class::fs) classes heap statics res reslimit)
     end
  | _ => wrong
  end.

Definition update_reslimit (cls:C.class) (mth:C.method) (limit:RA.res) :=
  match ANN.grants (C.method_annot mth) with
    | None => limit
    | Some grant =>
      if ClassnameSet.mem (C.class_name cls) privilegedclasses then RA.combine limit (RA.res_parse grant) else limit
  end.

Definition exec_valreturn : state -> exec_result :=
  fun state => match state with
  | mkState (mkFrame (v::_) _ _ _ omth oclass::nil) classes heap statics res reslimit =>
     stop (mkState nil classes heap statics res (update_reslimit oclass omth reslimit)) (Some v)
  | mkState (mkFrame (v::_) _ _ _ omth oclass::mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit =>
     cont (mkState (mkFrame (v::op_stack) lvars (S pc) code mth class::fs) classes heap statics res (update_reslimit oclass omth reslimit))
  | _ =>
     wrong
  end.

Definition exec_return : state -> exec_result :=
  fun state => match state with
  | mkState (mkFrame _ _ _ _ omth oclass::nil) classes heap statics res reslimit =>
     stop (mkState nil classes heap statics res (update_reslimit oclass omth reslimit)) None
  | mkState (mkFrame _ _ _ _ omth oclass::mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit =>
     cont (mkState (mkFrame op_stack lvars (S pc) code mth class::fs) classes heap statics res (update_reslimit oclass omth reslimit))
  | _ => wrong
  end.

Definition exec_goto : Z -> state -> exec_result :=
  fun offset state => match state with
  | mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit =>
     match C.pc_plus_offset pc offset with
     | None => wrong
     | Some new_pc =>
        cont (mkState (mkFrame op_stack lvars new_pc code mth class::fs) classes heap statics res reslimit)
     end
  | _ => wrong
  end.

Definition exec_dup : state -> exec_result :=
  fun state => match state with
  | mkState (mkFrame (v::op_stack) lvars pc code mth class::fs) classes heap statics res reslimit =>
     match val_category v with
     | C.category1 =>
        cont (mkState (mkFrame (v::v::op_stack) lvars (S pc) code mth class::fs) classes heap statics res reslimit)
     | C.category2 =>
        wrong
     end
  | _ => wrong
  end.

Definition exec_dup_x1 : state -> exec_result :=
  fun state => match state with
  | mkState (mkFrame (v1::v2::op_stack) lvars pc code mth class::fs) classes heap statics res reslimit =>
     match val_category v1, val_category v2 with
     | C.category1, C.category1 =>
        cont (mkState (mkFrame (v1::v2::v1::op_stack) lvars (S pc) code mth class::fs) classes heap statics res reslimit)
     | _,_ => wrong
     end
  | _ => wrong
  end.

Definition exec_dup_x2 : state -> exec_result :=
  fun state => match state with
  | mkState (mkFrame (v1::v2::op_stack) lvars pc code mth class::fs) classes heap statics res reslimit =>
     match val_category v1, val_category v2 with
     | C.category1, C.category1 =>
        match op_stack with
        | nil => wrong
        | v3::op_stack =>
           match val_category v3 with
           | C.category1 =>
              cont (mkState (mkFrame (v1::v2::v3::v1::op_stack) lvars (S pc) code mth class::fs) classes heap statics res reslimit)
           | C.category2 =>
              wrong
           end
        end
     | C.category1, C.category2 =>
       cont (mkState (mkFrame (v1::v2::v1::op_stack) lvars (S pc) code mth class::fs) classes heap statics res reslimit)
     | _,_ => wrong
     end
  | _ => wrong
  end.

Definition exec_dup2 : state -> exec_result :=
  fun state => match state with
  | mkState (mkFrame (v1::op_stack) lvars pc code mth class::fs) classes heap statics res reslimit =>
     match val_category v1 with
     | C.category1 =>
        match op_stack with
        | nil => wrong
        | v2::op_stack =>
           cont (mkState (mkFrame (v1::v2::v1::v2::op_stack) lvars (S pc) code mth class::fs) classes heap statics res reslimit)
        end
     | C.category2 =>
        cont (mkState (mkFrame (v1::v1::op_stack) lvars (S pc) code mth class::fs) classes heap statics res reslimit)
     end
  | _ => wrong
  end.

Definition exec_dup2_x1 : state -> exec_result :=
  fun state => match state with
  | mkState (mkFrame (v1::v2::op_stack) lvars pc code mth class::fs) classes heap statics res reslimit =>
     match val_category v1 with
     | C.category1 =>
        match op_stack with
        | nil => wrong
        | v3::op_stack =>
           cont (mkState (mkFrame (v1::v2::v3::v1::v2::op_stack) lvars (S pc) code mth class::fs) classes heap statics res reslimit)
        end
     | C.category2 =>
        cont (mkState (mkFrame (v1::v2::v1::op_stack) lvars (S pc) code mth class::fs) classes heap statics res reslimit)
     end
  | _ => wrong
  end.

Definition exec_dup2_x2 : state -> exec_result :=
  fun state => match state with
  | mkState (mkFrame (v1::v2::op_stack) lvars pc code mth class::fs) classes heap statics res reslimit =>
     match val_category v2 with
     | C.category1 =>
        match op_stack with
        | nil => wrong
        | v3::op_stack =>
           match val_category v1, val_category v3 with
           | C.category1, C.category1 =>
              match op_stack with
              | nil => wrong
              | v4::op_stack =>
                 match val_category v4 with
                 | C.category1 =>
                    cont (mkState (mkFrame (v1::v2::v3::v4::v1::v2::op_stack) lvars (S pc) code mth class::fs) classes heap statics res reslimit)
                 | C.category2 =>
                    wrong
                 end
              end
           | C.category1, C.category2 =>
              cont (mkState (mkFrame (v1::v2::v3::v1::v2::op_stack) lvars (S pc) code mth class::fs) classes heap statics res reslimit)
           | C.category2, C.category1 =>
              cont (mkState (mkFrame (v1::v2::v3::v1::op_stack) lvars (S pc) code mth class::fs) classes heap statics res reslimit)
           | C.category2, C.category2 =>
              wrong
           end
        end
     | C.category2 =>
        match val_category v1 with
        | C.category1 => wrong
        | C.category2 =>
           cont (mkState (mkFrame (v1::v2::v1::op_stack) lvars (S pc) code mth class::fs) classes heap statics res reslimit)
        end
     end
  | _ => wrong
  end.

Definition exec_nop : state -> exec_result :=
  fun state => match state with
  | mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit =>
     cont (mkState (mkFrame op_stack lvars (S pc) code mth class::fs) classes heap statics res reslimit)
  | _ => wrong
  end.

Definition exec_pop : state -> exec_result :=
  fun state => match state with
  | mkState (mkFrame (v::op_stack) lvars pc code mth class::fs) classes heap statics res reslimit =>
     match val_category v with
     | C.category1 =>
        cont (mkState (mkFrame op_stack lvars (S pc) code mth class::fs) classes heap statics res reslimit)
     | C.category2 =>
        wrong
     end
  | _ => wrong
  end.

Definition exec_pop2 : state -> exec_result :=
  fun state => match state with
  | mkState (mkFrame (v::op_stack) lvars pc code mth class::fs) classes heap statics res reslimit =>
     match val_category v with
     | C.category1 =>
        match op_stack with
        | nil => wrong
        | _::op_stack =>
           cont (mkState (mkFrame op_stack lvars (S pc) code mth class::fs) classes heap statics res reslimit)
        end
     | C.category2 =>
        cont (mkState (mkFrame op_stack lvars (S pc) code mth class::fs) classes heap statics res reslimit)
     end
  | _ => wrong
  end.

Fixpoint make_padding_lvars (n:nat) : list (option rt_val) :=
  match n with 0 => nil | S n => None::make_padding_lvars n end.

Definition default_value : C.java_type -> rt_val :=
  fun ty => match ty with
  | C.ty_byte    => rt_int B.Int32.zero
  | C.ty_int     => rt_int B.Int32.zero
  | C.ty_short   => rt_int B.Int32.zero
  | C.ty_char    => rt_int B.Int32.zero
  | C.ty_boolean => rt_int B.Int32.zero
  | C.ty_double  => rt_double
  | C.ty_float   => rt_float
  | C.ty_long    => rt_long
  | C.ty_ref _   => rt_addr None
  end.

Definition exec_putstatic : B.ConstantPoolRef.t -> state -> exec_result :=
  fun idx state => match state with
  | mkState (mkFrame (v::op_stack) lvars pc code mth class::fs) classes heap statics res reslimit =>
     match C.ConstantPool.lookup (C.class_constantpool class) idx with
     | Some (C.cpe_fieldref cls_nm field_nm ty) =>
        match R.resolve_field (C.class_name class) cls_nm field_nm ty classes preclasses with
        | CP.load_ok classes preserved _ (c,f) (conj c_exists f_exists) =>
           let heap := preserve_cert_heap heap preserved in
           let statics := preserve_cert_fieldstore_over_classes statics preserved in
           match BoolExt.bool_informative (C.field_static f) with
           | left is_static =>
              match type_check_rt_val classes heap v ty with
              | left well_typed =>
                 let f_ok := (ex_intro _ c (ex_intro _ f (conj c_exists (conj f_exists is_static)))) in
                 match fieldstore_update statics (C.class_name c) field_nm ty v well_typed f_ok with
                 | exist statics' _ =>
                    cont (mkState (mkFrame op_stack lvars (S pc) code mth class::fs) classes heap statics res reslimit)
                 end
              | right _ =>
                 wrong
              end
            | right not_static =>
              throw_builtin_exception (mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit) CP.errIncompatibleClassChange
            end
        | CP.load_err classes preserved _ e =>
           let heap := preserve_cert_heap heap preserved in
           let statics := preserve_cert_fieldstore_over_classes statics preserved in
           throw_builtin_exception (mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit) e
        end
     | _ => wrong
     end
  | _ => wrong
  end.

Definition exec_getstatic : B.ConstantPoolRef.t -> state -> exec_result :=
  fun idx state => match state with
  | mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit =>
     match C.ConstantPool.lookup (C.class_constantpool class) idx with
     | Some (C.cpe_fieldref cls_nm field_nm ty) =>
        match R.resolve_field (C.class_name class) cls_nm field_nm ty classes preclasses with
        | CP.load_err classes preserved _ e =>
           let heap := preserve_cert_heap heap preserved in
           let statics := preserve_cert_fieldstore_over_classes statics preserved in
           throw_builtin_exception (mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit) e
        | CP.load_ok classes preserved _ (c,f) (conj c_exists f_exists) =>
           let heap := preserve_cert_heap heap preserved in
           let statics := preserve_cert_fieldstore_over_classes statics preserved in
           match BoolExt.bool_informative (C.field_static f) with
           | left f_static =>
              let f_ok := ex_intro _ c (ex_intro _ f (conj c_exists (conj f_exists f_static))) in
              match fieldstore_lookup statics (C.class_name c) field_nm ty f_ok with
              | exist v _ =>
                 cont (mkState (mkFrame (v::op_stack) lvars (S pc) code mth class::fs) classes heap statics res reslimit)
              end
           | right not_static =>
              throw_builtin_exception (mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit) CP.errIncompatibleClassChange
           end
        end
     | _ => wrong
     end
  | _ => wrong
  end.

Definition exec_new : B.ConstantPoolRef.t -> state -> exec_result :=
  fun idx state => match state with
  | mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit =>
     match C.ConstantPool.lookup (C.class_constantpool class) idx with
     | Some (C.cpe_classref cls_nm) =>
        match R.resolve_class (C.class_name class) cls_nm classes preclasses with
        | CP.load_err classes preserved _ e =>
           let heap := preserve_cert_heap heap preserved in
           let statics := preserve_cert_fieldstore_over_classes statics preserved in
           throw_builtin_exception (mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit) e
        | CP.load_ok classes preserved _ c c_exists =>
           let heap := preserve_cert_heap heap preserved in
           let statics := preserve_cert_fieldstore_over_classes statics preserved in
           if C.class_abstract c then
              throw_builtin_exception (mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit) CP.errInstantiation
           else match BoolExt.bool_informative (C.class_interface c) with
                | left is_interface =>
                  throw_builtin_exception (mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit) CP.errInstantiation
                | right not_interface =>
                   match heap_new heap cls_nm (ex_intro _ c (conj c_exists not_interface)) with
                   | pack2 heap addr (conj _ (conj _ (conj _ (conj preserved _)))) =>
                      let statics := preserve_cert_fieldstore_over_heap statics preserved in
                      let state' := mkState (mkFrame (rt_addr (Some addr)::op_stack) lvars (S pc) code mth class::fs) classes heap statics res reslimit in
                       cont (add_res_new cls_nm state')
                   end
                end
        end
     | _ => wrong
     end
  | _ => wrong
  end.

Definition exec_getfield : B.ConstantPoolRef.t -> state -> exec_result :=
  fun idx state => match state with
  | mkState (mkFrame (rt_addr a::op_stack) lvars pc code mth class::fs) classes heap statics res reslimit =>
     match C.ConstantPool.lookup (C.class_constantpool class) idx with
     | Some (C.cpe_fieldref cls_nm field_nm ty) =>
        match R.resolve_field (C.class_name class) cls_nm field_nm ty classes preclasses with
        | CP.load_err classes preserved _ e =>
           let heap := preserve_cert_heap heap preserved in
           let statics := preserve_cert_fieldstore_over_classes statics preserved in
           throw_builtin_exception (mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit) e
        | CP.load_ok classes preserved _ (c,f) (conj H1 H2) =>
           let heap := preserve_cert_heap heap preserved in
           let statics := preserve_cert_fieldstore_over_classes statics preserved in
           if C.field_static f then
              throw_builtin_exception (mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit) CP.errIncompatibleClassChange
           else
              match a with
              | None =>
                 throw_builtin_exception (mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit) CP.errNullPointer
              | Some a =>
                 match heap_lookup_field heap a (C.class_name c) (C.field_name f) ty with
                 | inleft (exist v _) =>
                    cont (mkState (mkFrame (v::op_stack) lvars (S pc) code mth class::fs) classes heap statics res reslimit)
                 | inright _ =>
                    wrong
                 end
              end
        end
     | _ => wrong
     end
  | _ => wrong
  end.

Definition exec_putfield : B.ConstantPoolRef.t -> state -> exec_result :=
  fun idx state => match state with
  | mkState (mkFrame (v::rt_addr a::op_stack) lvars pc code mth class::fs) classes heap statics res reslimit =>
     match C.ConstantPool.lookup (C.class_constantpool class) idx with
     | Some (C.cpe_fieldref cls_nm field_nm ty) =>
        match R.resolve_field (C.class_name class) cls_nm field_nm ty classes preclasses with
        | CP.load_err classes preserved _ e =>
           let heap := preserve_cert_heap heap preserved in
           let statics := preserve_cert_fieldstore_over_classes statics preserved in
           throw_builtin_exception (mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit) e
        | CP.load_ok classes preserved _ (c,f) (conj H1 H2) =>
           let heap := preserve_cert_heap heap preserved in
           let statics := preserve_cert_fieldstore_over_classes statics preserved in
           if C.field_static f then
              throw_builtin_exception (mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit) CP.errIncompatibleClassChange
           else if C.field_final f &&
                   (if B.Classname.eq_dec (C.class_name class) (C.class_name c) then false else true) then
              throw_builtin_exception (mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit) CP.errIllegalAccess
           else
              match a with
              | None =>
                 throw_builtin_exception (mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit) CP.errNullPointer
              | Some a =>
                 match type_check_rt_val classes heap v ty with
                 | left welltyped =>
                    match heap_update_field heap a (C.class_name c) (C.field_name f) ty v welltyped with
                    | inleft (exist heap (conj _ (conj preserved _))) =>
                       let statics := preserve_cert_fieldstore_over_heap statics preserved in
                       cont (mkState (mkFrame op_stack lvars (S pc) code mth class::fs) classes heap statics res reslimit)
                    | inright _ =>
                       wrong
                    end
                 | right _ =>
                    wrong
                 end
              end
        end
     | _ => wrong
     end
  | _ => wrong
  end.

Fixpoint pop_n (n:nat) (l:list rt_val) {struct n} : option (list rt_val * list rt_val) :=
  match n, l with
  | 0,   l     => Some (nil,l)
  | S n, nil   => None
  | S n, v::vs => match pop_n n vs with None => None | Some (l',rest) => Some (v::l', rest) end
  end.

Fixpoint stack_to_lvars (stack:list rt_val) (required_lvars:nat) {struct stack} : option (list (option rt_val)) :=
  match stack with
  | nil      => Some (make_padding_lvars required_lvars)
  | v::stack =>
     match val_category v, required_lvars with
     | C.category1, S n     =>
        match stack_to_lvars stack n with
        | None => None
        | Some stack' => Some (Some v::stack')
        end
     | C.category2, S (S n) =>
        match stack_to_lvars stack n with
        | None => None
        | Some stack' => Some (Some v::None::stack')
        end
     | _, _ => None
     end
  end.

Definition basic_invoke : C.class -> C.method -> list rt_val -> state -> exec_result :=
  fun class method args state => match state with
  | mkState fs classes heap statics res reslimit =>
     match C.method_code method with
       (* Callers rule out abstract methods *)
     | None =>
       match NATIVE.native_invoke class method args state with
         | None => wrong
         | Some (NATIVE.Build_result (NATIVE.exn exn) classes' heap' statics' res' reslimit') =>
           throw_exception (mkState fs classes' heap' statics' res' reslimit') exn
         | Some (NATIVE.Build_result NATIVE.void classes' heap' statics' res' reslimit') =>
           match fs with
             | (mkFrame op_stack lvars pc code mth class::fs') =>
               cont (mkState (mkFrame op_stack lvars (S pc) code mth class::fs') classes' heap' statics' res' reslimit')
             | _ => wrong
           end
         | Some (NATIVE.Build_result (NATIVE.val val) classes' heap' statics' res' reslimit') =>
           match fs with
             | (mkFrame op_stack lvars pc code mth class::fs') =>
               cont (mkState (mkFrame (val::op_stack) lvars (S pc) code mth class::fs') classes' heap' statics' res' reslimit')
             | _ => wrong
           end
       end
     | Some code =>
        match stack_to_lvars args (C.code_max_lvars code) with
        | None => wrong
        | Some lvars =>
           cont (mkState (mkFrame nil lvars 0 code method class::fs) classes heap statics res reslimit)
        end
     end
  end.

Definition basic_invokestatic : B.Classname.t -> B.Classname.t -> B.Methodname.t -> C.descriptor -> list rt_val -> state -> exec_result :=
  fun caller clsname meth_name meth_desc args state => match state with
  | mkState fs classes heap statics res reslimit =>
     match R.resolve_method caller clsname meth_name meth_desc classes preclasses with
     | CP.load_err classes preserved _ e =>
        let heap := preserve_cert_heap heap preserved in
        let statics := preserve_cert_fieldstore_over_classes statics preserved in
        throw_builtin_exception (mkState fs classes heap statics res reslimit) e
     | CP.load_ok classes preserved _ (class,method) (conj H1 H2) =>
        let heap := preserve_cert_heap heap preserved in
        let statics := preserve_cert_fieldstore_over_classes statics preserved in
        if C.method_static method then
           basic_invoke class method args (mkState fs classes heap statics res reslimit)
        else
           throw_builtin_exception (mkState fs classes heap statics res reslimit) CP.errIncompatibleClassChange
     end
  end.

Definition exec_invokestatic : B.ConstantPoolRef.t -> state -> exec_result :=
  fun idx state => match state with
  | mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit =>
     match C.ConstantPool.lookup (C.class_constantpool class) idx with
     | Some (C.cpe_methodref clsname methname methdescrip) =>
        match pop_n (length (C.descriptor_arg_types methdescrip)) op_stack with
        | None => wrong
        | Some (args, op_stack) =>
           let state' := mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit in
           basic_invokestatic (C.class_name class) clsname methname methdescrip (rev args) state'
        end
     | _ => wrong
     end
  | _ => wrong
  end.

(* FIXME: need to properly understand the ACC_SUPER flag on page 284 *)
Definition exec_invokespecial : B.ConstantPoolRef.t -> state -> exec_result :=
  fun idx state => match state with
  | mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit =>
     match C.ConstantPool.lookup (C.class_constantpool class) idx with
     | Some (C.cpe_methodref clsname methname methdescrip) =>
        match R.resolve_method (C.class_name class) clsname methname methdescrip classes preclasses with
        | CP.load_err classes preserved _ e =>
           let heap := preserve_cert_heap heap preserved in
           let statics := preserve_cert_fieldstore_over_classes statics preserved in
           throw_builtin_exception (mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit) e
        | CP.load_ok classes preserved _ (c,m) (conj H1 H2) =>
           let heap := preserve_cert_heap heap preserved in
           let statics := preserve_cert_fieldstore_over_classes statics preserved in
           match pop_n (length (C.descriptor_arg_types methdescrip)) op_stack with
           | Some (preargs, rt_addr (Some addr)::op_stack) =>
              let args := rt_addr (Some addr)::rev preargs in
              if C.method_static m then
                 throw_builtin_exception (mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit) CP.errIncompatibleClassChange
              else if C.method_abstract m then
                 throw_builtin_exception (mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit) CP.errAbstractMethod
              else (* FIXME: need a special check for instance initialization methods *)
                 let state' := mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit in
                 basic_invoke c m args state'
           | Some (args, rt_addr None::op_stack) =>
              throw_builtin_exception (mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit) CP.errNullPointer
           | _ => wrong
           end
        end
     | _ => wrong
     end
  | _ => wrong
  end.

Definition exec_invokevirtual : B.ConstantPoolRef.t -> state -> exec_result :=
  fun idx state =>
    match state with
      | mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit =>
        match C.ConstantPool.lookup (C.class_constantpool class) idx with
          | Some (C.cpe_methodref clsname methname methdescrip) =>
            match B.Methodname.eq_dec methname B.init with
              | left _ => wrong (* cannot call methods called '<init>' via invokevirtual *)
              | right _ =>
                match R.resolve_method (C.class_name class) clsname methname methdescrip classes preclasses with
                  | CP.load_err classes preserved _ e =>
                    let heap := preserve_cert_heap heap preserved in
                      let statics := preserve_cert_fieldstore_over_classes statics preserved in
                        throw_builtin_exception (mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit) e
                  | CP.load_ok classes preserved _ (c,m) (conj H1 H2) =>
                    let heap := preserve_cert_heap heap preserved in
                      let statics := preserve_cert_fieldstore_over_classes statics preserved in
                        if C.method_static m then
                          throw_builtin_exception (mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit) CP.errIncompatibleClassChange
                          else
                            match pop_n (length (C.descriptor_arg_types methdescrip)) op_stack with
                              | Some (preargs, rt_addr (Some addr)::op_stack) =>
                                let args := rt_addr (Some addr)::rev preargs in
                                  match heap_lookup_class heap addr with
                                    | inleft (exist cls_nm addr_is_cls_nm) =>
                                      if A.is_assignable classes (C.ty_obj cls_nm) (C.ty_obj clsname) then
                                        let evidence := object_class_implies_class_exists addr_is_cls_nm in
                                          match VM.lookup_virtual_method classes cls_nm (methname, methdescrip) evidence with
                                            | Some (pack2 c' m' _) =>
                                              if C.method_abstract m' then
                                                throw_builtin_exception (mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit) CP.errAbstractMethod
                                                else
                                                  let state' := mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit in
                                                    basic_invoke c' m' args state'
                                            | None =>
                                              throw_builtin_exception (mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit) CP.errAbstractMethod
                                          end
                                        else
                                          wrong
                                    | inright _ => wrong
                                  end
                              | Some (_, rt_addr None::op_stack) =>
                                throw_builtin_exception (mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit) CP.errNullPointer
                              | _ => wrong
                            end
                end
            end
          | _ => wrong
        end
      | _ => wrong
    end.

Definition exec_invokeinterface : B.ConstantPoolRef.t -> state -> exec_result :=
  fun idx state => match state with
  | mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit =>
     match C.ConstantPool.lookup (C.class_constantpool class) idx with
     | Some (C.cpe_interfacemethodref clsname methname methdescrip) =>
       match B.Methodname.eq_dec methname B.init with
       | left _ => wrong (* cannot call methods called '<init>' via invokeinterface *)
       | right _ =>
         match R.resolve_interface_method (C.class_name class) clsname methname methdescrip classes preclasses with
         | CP.load_err classes preserved _ e =>
            let heap := preserve_cert_heap heap preserved in
            let statics := preserve_cert_fieldstore_over_classes statics preserved in
            throw_builtin_exception (mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit) e
         | CP.load_ok classes preserved _ (c,m) (conj H1 H2) =>
            let heap := preserve_cert_heap heap preserved in
            let statics := preserve_cert_fieldstore_over_classes statics preserved in
            if C.method_static m then (* FIXME: this should be automatic from the fact that this is an interface *)
               throw_builtin_exception (mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit) CP.errIncompatibleClassChange
            else
               match pop_n (length (C.descriptor_arg_types methdescrip)) op_stack with
               | Some (preargs, rt_addr (Some addr)::op_stack) =>
                  let args := rt_addr (Some addr)::rev preargs in
                  match heap_lookup_class heap addr with
                  | inleft (exist cls_nm addr_is_cls_nm) =>
                     if A.is_assignable classes (C.ty_obj cls_nm) (C.ty_obj clsname) then
                       let evidence := object_class_implies_class_exists addr_is_cls_nm in
                       match VM.lookup_virtual_method classes cls_nm (methname, methdescrip) evidence with
                       | Some (pack2 c' m' _) =>
                          if C.method_abstract m' then
                             throw_builtin_exception (mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit) CP.errAbstractMethod
                          else
                             let state' := mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit in
                             basic_invoke c' m' args state'
                       | None =>
                          throw_builtin_exception (mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit) CP.errAbstractMethod
                       end
                     else
                       throw_builtin_exception (mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit) CP.errIncompatibleClassChange
                  | _ => wrong
                  end
               | Some (_, rt_addr None::op_stack) =>
                  throw_builtin_exception (mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit) CP.errNullPointer
               | _ => wrong
               end
         end
       end
     | _ => wrong
     end
  | _ => wrong
  end.

Definition exec_if : C.cmp -> Z -> state -> exec_result :=
  fun test offset state => match state with
  | mkState (mkFrame (rt_int z::op_stack) lvars pc code mth class::fs) classes heap statics res reslimit =>
     let test_succeeded :=
          match test with
          | C.cmp_eq => B.Int32.eq z B.Int32.zero
          | C.cmp_ne => B.Int32.neq z B.Int32.zero
          | C.cmp_lt => B.Int32.lt z B.Int32.zero
          | C.cmp_le => B.Int32.le z B.Int32.zero
          | C.cmp_gt => B.Int32.gt z B.Int32.zero
          | C.cmp_ge => B.Int32.ge z B.Int32.zero
          end in
     match (if test_succeeded then (C.pc_plus_offset pc offset) else (Some (S pc))) with
     | None => wrong
     | Some new_pc =>
        cont (mkState (mkFrame op_stack lvars new_pc code mth class::fs) classes heap statics res reslimit)
     end
  | _ => wrong
  end.

Definition exec_if_icmp : C.cmp -> Z -> state -> exec_result :=
  fun test offset state => match state with
  | mkState (mkFrame (rt_int z2::rt_int z1::op_stack) lvars pc code mth class::fs) classes heap statics res reslimit =>
     let test_succeeded :=
          match test with
          | C.cmp_eq => B.Int32.eq z1 z2
          | C.cmp_ne => B.Int32.neq z1 z2
          | C.cmp_lt => B.Int32.lt z1 z2
          | C.cmp_le => B.Int32.le z1 z2
          | C.cmp_gt => B.Int32.gt z1 z2
          | C.cmp_ge => B.Int32.ge z1 z2
          end in
     match (if test_succeeded then (C.pc_plus_offset pc offset) else (Some (S pc))) with
     | None => wrong
     | Some new_pc =>
        cont (mkState (mkFrame op_stack lvars new_pc code mth class::fs) classes heap statics res reslimit)
     end
  | _ => wrong
  end.

Definition exec_swap : state -> exec_result :=
  fun state => match state with
  | mkState (mkFrame (v1::v2::op_stack) lvars pc code mth class::fs) classes heap statics res reslimit =>
     match val_category v1, val_category v2 with
     | C.category1, C.category1 =>
        cont (mkState (mkFrame (v2::v1::op_stack) lvars (S pc) code mth class::fs) classes heap statics res reslimit)
     | _,_ =>
        wrong
     end
  | _ => wrong
  end.

Definition exec_iinc : nat -> B.Int32.t -> state -> exec_result :=
  fun n c state => match state with
  | mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit =>
     match OptionExt.option_mult (nth_error lvars n) with
     | Some (rt_int z) =>
        match update_lvars n (rt_int (B.Int32.add z c)) lvars with
        | None => wrong
        | Some new_lvars =>
           cont (mkState (mkFrame op_stack new_lvars (S pc) code mth class::fs) classes heap statics res reslimit)
        end
     | _ => wrong
     end
  | _ => wrong
  end.

Definition exec_aconst_null : state -> exec_result :=
  fun state => match state with
  | mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit =>
     cont (mkState (mkFrame (rt_addr None::op_stack) lvars (S pc) code mth class::fs) classes heap statics res reslimit)
  | _ => wrong
  end.

Definition option_addr_eq_dec : forall (a b:option Heap.addr_t), {a=b}+{a<>b}.
decide equality.
generalize a a0. decide equality.
Defined.

Definition exec_if_acmp : C.acmp -> Z -> state -> exec_result :=
  fun test offset state => match state with
  | mkState (mkFrame (rt_addr a1::rt_addr a2::op_stack) lvars pc code mth class::fs) classes heap statics res reslimit =>
     let test_succeeded :=
          match test with
          | C.acmp_eq => if option_addr_eq_dec a1 a2 then true else false
          | C.acmp_ne => if option_addr_eq_dec a1 a2 then false else true
          end in
     match (if test_succeeded then (C.pc_plus_offset pc offset) else (Some (S pc))) with
     | None => wrong
     | Some new_pc =>
        cont (mkState (mkFrame op_stack lvars new_pc code mth class::fs) classes heap statics res reslimit)
     end
  | _ => wrong
  end.

Definition exec_if_nonnull : Z -> state -> exec_result :=
  fun offset state => match state with
  | mkState (mkFrame (rt_addr a::op_stack) lvars pc code mth class::fs) classes heap statics res reslimit =>
     match a with
     | None =>
        cont (mkState (mkFrame op_stack lvars (S pc) code mth class::fs) classes heap statics res reslimit)
     | Some _ =>
        match C.pc_plus_offset pc offset with
        | None => wrong
        | Some new_pc =>
           cont (mkState (mkFrame op_stack lvars new_pc code mth class::fs) classes heap statics res reslimit)
        end
     end
  | _ => wrong
  end.

Definition exec_if_null : Z -> state -> exec_result :=
  fun offset state => match state with
  | mkState (mkFrame (rt_addr a::op_stack) lvars pc code mth class::fs) classes heap statics res reslimit =>
     match a with
     | Some _ =>
        cont (mkState (mkFrame op_stack lvars (S pc) code mth class::fs) classes heap statics res reslimit)
     | None =>
        match C.pc_plus_offset pc offset with
        | None => wrong
        | Some new_pc =>
           cont (mkState (mkFrame op_stack lvars new_pc code mth class::fs) classes heap statics res reslimit)
        end
     end
  | _ => wrong
  end.

Definition exec_ldc : B.ConstantPoolRef.t -> state -> exec_result :=
  fun idx state => match state with
  | mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit =>
     match C.ConstantPool.lookup (C.class_constantpool class) idx with
     | Some (C.cpe_int i) =>
        cont (mkState (mkFrame (rt_int i::op_stack) lvars (S pc) code mth class::fs) classes heap statics res reslimit)
     | _ => undefined (* FIXME: do floats and strings *)
     end
  | _ => wrong
  end.

Definition exec_ldc2 : B.ConstantPoolRef.t -> state -> exec_result :=
  fun idx state => match state with
  | mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit =>
     match C.ConstantPool.lookup (C.class_constantpool class) idx with
     | _ => undefined (* FIXME: do longs and doubles *)
     end
  | _ => wrong
  end.

Definition exec_instanceof : B.ConstantPoolRef.t -> state -> exec_result :=
  fun idx state => match state with
  | mkState (mkFrame (rt_addr a::op_stack) lvars pc code mth class::fs) classes heap statics res reslimit =>
     match C.ConstantPool.lookup (C.class_constantpool class) idx with
     | Some (C.cpe_classref cls_nm) =>
        match R.resolve_class (C.class_name class) cls_nm classes preclasses with
        | CP.load_err classes preserved _ e =>
           let heap := preserve_cert_heap heap preserved in
           let statics := preserve_cert_fieldstore_over_classes statics preserved in
           throw_builtin_exception (mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit) e
        | CP.load_ok classes preserved _ T H =>
           let heap := preserve_cert_heap heap preserved in
           let statics := preserve_cert_fieldstore_over_classes statics preserved in
           match a with
           | None => (* It was a null pointer *)
              cont (mkState (mkFrame (rt_int B.Int32.zero::op_stack) lvars (S pc) code mth class::fs) classes heap statics res reslimit)
           | Some a =>
              match heap_lookup_class heap a with
              | inleft (exist obj_cls_nm _) =>
                 if A.is_assignable classes (C.ty_obj obj_cls_nm) (C.ty_obj cls_nm) then
                    cont (mkState (mkFrame (rt_int B.Int32.one::op_stack) lvars (S pc) code mth class::fs) classes heap statics res reslimit)
                 else
                    cont (mkState (mkFrame (rt_int B.Int32.zero::op_stack) lvars (S pc) code mth class::fs) classes heap statics res reslimit)
              | inright _ => wrong
              end
           end
        end
     | _ => wrong
     end
  | _ => wrong
  end.

Definition exec_checkcast : B.ConstantPoolRef.t -> state -> exec_result :=
  fun idx state => match state with
  | mkState (mkFrame (rt_addr a::op_stack) lvars pc code mth class::fs) classes heap statics res reslimit =>
     match C.ConstantPool.lookup (C.class_constantpool class) idx with
     | Some (C.cpe_classref cls_nm) =>
        match R.resolve_class (C.class_name class) cls_nm classes preclasses with
        | CP.load_err classes preserved _ e =>
           let heap := preserve_cert_heap heap preserved in
           let statics := preserve_cert_fieldstore_over_classes statics preserved in
           throw_builtin_exception (mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit) e
        | CP.load_ok classes preserved _ T H =>
           let heap := preserve_cert_heap heap preserved in
           let statics := preserve_cert_fieldstore_over_classes statics preserved in
           match a with
           | None => (* null pointer *)
              cont (mkState (mkFrame (rt_addr None::op_stack) lvars (S pc) code mth class::fs) classes heap statics res reslimit)
           | Some a =>
              match heap_lookup_class heap a with
              | inleft (exist obj_cls_nm _) =>
                 if A.is_assignable classes (C.ty_obj obj_cls_nm) (C.ty_obj cls_nm) then
                    cont (mkState (mkFrame (rt_addr (Some a)::op_stack) lvars (S pc) code mth class::fs) classes heap statics res reslimit)
                 else
                    throw_builtin_exception (mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit) CP.errClassCast
              | inright _ => wrong
              end
           end
        end
     | _ => wrong
     end
  | _ => wrong
  end.

Definition exec_athrow : state -> exec_result :=
  fun state => match state with
  | mkState (mkFrame (rt_addr a::op_stack) lvars pc code mth class::fs) classes heap statics res reslimit =>
     let state := (mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit) in
     match a with
     | None =>
        throw_builtin_exception state CP.errNullPointer
     | Some r =>
        match heap_lookup_class heap r with
        | inleft (exist cls_nm _) =>
           if A.is_assignable classes (C.ty_obj cls_nm) (C.ty_obj B.java_lang_Throwable) then
              throw_exception state r
           else
              wrong
        | inright _ => wrong
        end
     end
  | _ => wrong
  end.

Definition exec : state -> exec_result :=
  fun state => match state with
  | mkState (mkFrame op_stack lvars pc code mth class::fs) classes heap statics res reslimit =>
     match nth_error (C.code_code code) pc with
     | None => wrong
     | Some op =>
  match op with
  (* Constants *)
  | C.op_iconst i         => exec_iconst i
  | C.op_ldc idx          => exec_ldc idx
  | C.op_ldc2 idx         => exec_ldc2 idx

  (* Arithmetic *)
  | C.op_iinc n c         => exec_iinc n c
  | C.op_iarithb op       => exec_iarithb op
  | C.op_iarithu op       => exec_iarithu op

  (* Local variables *)
  | C.op_load ty n        => exec_load n
  | C.op_store ty n       => exec_store n

  (* Stack operations *)
  | C.op_dup              => exec_dup
  | C.op_dup_x1           => exec_dup_x1
  | C.op_dup_x2           => exec_dup_x2
  | C.op_dup2             => exec_dup2
  | C.op_dup2_x1          => exec_dup2_x1
  | C.op_dup2_x2          => exec_dup2_x2
  | C.op_nop              => exec_nop
  | C.op_pop              => exec_pop
  | C.op_pop2             => exec_pop2
  | C.op_swap             => exec_swap

  (* OO *)
  | C.op_aconst_null      => exec_aconst_null
  | C.op_invokestatic idx => exec_invokestatic idx
  | C.op_putstatic idx    => exec_putstatic idx
  | C.op_getstatic idx    => exec_getstatic idx
  | C.op_putfield idx     => exec_putfield idx
  | C.op_getfield idx     => exec_getfield idx
  | C.op_new idx          => exec_new idx
  | C.op_invokeinterface idx => exec_invokeinterface idx
  | C.op_invokespecial idx=> exec_invokespecial idx
  | C.op_invokevirtual idx=> exec_invokevirtual idx
  | C.op_instanceof idx   => exec_instanceof idx
  | C.op_checkcast idx    => exec_checkcast idx

  (* Flow control *)
  | C.op_if test offset   => exec_if test offset
  | C.op_if_acmp test offset => exec_if_acmp test offset
  | C.op_if_icmp test offset => exec_if_icmp test offset
  | C.op_ifnonnull offset => exec_if_nonnull offset
  | C.op_ifnull offset    => exec_if_null offset
  | C.op_valreturn ty     => exec_valreturn
  | C.op_return           => exec_return
  | C.op_goto offset      => exec_goto offset
  | C.op_athrow           => exec_athrow

  | _ => fun s => undefined
  end state
  end
  | _ => wrong
  end.

Definition init : B.Classname.t -> B.Methodname.t -> C.descriptor -> list rt_val -> state -> exec_result :=
  fun clsname methname methdescrip args state => match state with
  | mkState nil classes heap statics res reslimit =>
     basic_invokestatic clsname clsname methname methdescrip args state
  | _ => wrong
  end.

End WithPreclasses.

End Execution.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.

Local Open Scope Z_scope.

Section Spec.

  Definition data_create_unknown1_spec (g_rd: Pointer) (data_addr: Z64) (map_addr: Z64) (g_data': Pointer) (adt: RData) : option (RData * Z64) :=
    match map_addr, data_addr with
    | VZ64 map_addr, VZ64 data_addr =>
      rely is_int64 map_addr; rely is_int64 data_addr;
      let idx0 := __addr_to_idx map_addr 0 in
      let idx1 := __addr_to_idx map_addr 1 in
      let idx2 := __addr_to_idx map_addr 2 in
      let idx3 := __addr_to_idx map_addr 3 in
      let ret_idx := idx3 in
      rely (peq (base g_rd) ginfo_loc);
      rely (peq (base g_data') ginfo_loc);
      rely prop_dec ((buffer (priv adt)) @ SLOT_RD = None);
      rely prop_dec ((buffer (priv adt)) @ SLOT_TABLE = None);
      rely prop_dec ((buffer (priv adt)) @ SLOT_DELEGATED = None);
      let rd_gidx := (offset g_rd) in
      let data_gidx := offset g_data' in
      let grd := (gs (share adt)) @ rd_gidx in
      rely prop_dec (__addr_to_gidx data_addr = data_gidx);
      rely (g_tag (ginfo grd) =? GRANULE_STATE_RD);
      rely prop_dec (glock grd = Some CPU_ID);
      let root_gidx := (g_rtt (gnorm grd)) in
      rely is_gidx rd_gidx; rely is_gidx root_gidx; rely is_gidx data_gidx;
      when adt == query_oracle adt;
      let adt := adt {log: EVT CPU_ID (RTT_WALK root_gidx map_addr 1) :: log adt} in
      (* hold root lock *)
      let groot := (gs (share adt)) @ root_gidx in
      rely (tbl_level (gaux groot) =? 0);
      rely prop_dec (glock groot = None);
      rely (g_tag (ginfo groot) =? GRANULE_STATE_TABLE);
      rely (gtype groot =? GRANULE_STATE_TABLE);
      (* walk deeper root *)
      let entry0 := (g_data (gnorm groot)) @ idx0 in
      rely is_int64 entry0;
      let phys0 := __entry_to_phys entry0 3 in
      let lv1_gidx := __addr_to_gidx phys0 in
      if (__entry_is_table entry0) && (GRANULE_ALIGNED phys0) && (is_gidx lv1_gidx) then
        (* level 1 valid, hold level 1 lock *)
        let glv1 := (gs (share adt)) @ lv1_gidx in
        rely prop_dec (glock glv1 = None);
        rely (tbl_level (gaux glv1) =? 1);
        (* walk deeper level 1 *)
        rely (g_tag (ginfo glv1) =? GRANULE_STATE_TABLE);
        rely (gtype glv1 =? GRANULE_STATE_TABLE);
        let entry1 := (g_data (gnorm glv1)) @ idx1 in
        rely is_int64 entry1;
        let phys1 := __entry_to_phys entry1 3 in
        let lv2_gidx := __addr_to_gidx phys1 in
        if (__entry_is_table entry1) && (GRANULE_ALIGNED phys1) && (is_gidx lv2_gidx) then
          (* level 2 valid, hold level 2 lock *)
          let adt := adt {log: EVT CPU_ID (REL lv1_gidx glv1 {glock: Some CPU_ID}) :: EVT CPU_ID (ACQ lv2_gidx) :: log adt} in
          let glv2 := (gs (share adt)) @ lv2_gidx in
          rely (tbl_level (gaux glv2) =? 2);
          rely prop_dec (glock glv2 = None);
          (* walk deeper level 2 *)
          rely (g_tag (ginfo glv2) =? GRANULE_STATE_TABLE);
          rely (gtype glv2 =? GRANULE_STATE_TABLE);
          let entry2 := (g_data (gnorm glv2)) @ idx2 in
          rely is_int64 entry2;
          let phys2 := __entry_to_phys entry2 3 in
          let lv3_gidx := __addr_to_gidx phys2 in
          if (__entry_is_table entry2) && (GRANULE_ALIGNED phys2) && (is_gidx lv3_gidx) then
            (* level 2 valid, hold level 2 lock *)
            when adt == query_oracle adt;
            let adt := adt {log: EVT CPU_ID (REL lv2_gidx glv2 {glock: Some CPU_ID}) :: EVT CPU_ID (ACQ lv3_gidx) :: log adt} in
            let glv3 := (gs (share adt)) @ lv3_gidx in
            rely prop_dec (glock glv3 = None);
            rely (tbl_level (gaux glv3) =? 3);
            let adt :=  adt {priv: (priv adt) {wi_llt: lv3_gidx} {wi_index: idx3}} in
            (* create data *)
            let llt_gidx := lv3_gidx in
            let idx := idx3 in
            let gn_llt := (gs (share adt)) @ llt_gidx in
            let gn_data := (gs (share adt)) @ data_gidx in
            rely (g_tag (ginfo gn_llt) =? GRANULE_STATE_TABLE);
            rely (gtype gn_llt =? GRANULE_STATE_TABLE);
            rely (gtype gn_data =? GRANULE_STATE_DELEGATED);
            rely prop_dec (glock gn_data = Some CPU_ID);
            rely (tbl_level (gaux gn_data) =? 0);
            let llt_pte := (g_data (gnorm gn_llt)) @ idx in
            rely is_int64 llt_pte;
            if PTE_TO_IPA_STATE llt_pte =? IPA_STATE_VACANT then
              let gdata' := gn_data {gaux: mkAuxillaryVars 0 0 map_addr} in
              let pte_val := Z.lor (IPA_STATE_TO_PTE IPA_STATE_ABSENT) data_addr in
              let llt' := (g_data (gnorm gn_llt)) # idx == pte_val in
              let gllt' := gn_llt {ginfo : (ginfo gn_llt) {g_refcount : g_refcount (ginfo gn_llt) + 1}}
                                  {gnorm: (gnorm gn_llt) {g_data: llt'}} in
              Some (adt {log: EVT CPU_ID (REL llt_gidx gllt' {glock: Some CPU_ID}) :: log adt}
                        {share : (share adt) {gs : ((gs (share adt)) # data_gidx == gdata') # llt_gidx == gllt'}},
                    VZ64 0)
            else Some (adt {log: EVT CPU_ID (REL llt_gidx gn_llt {glock: Some CPU_ID}) :: log adt}, VZ64 1)
          else
            (* level 3 invalid *)
            Some (adt {log: EVT CPU_ID (REL lv2_gidx glv2 {glock: Some CPU_ID}) :: log adt}
                      {priv: (priv adt) {wi_llt: 0} {wi_index: ret_idx}}, VZ64 1)
        else
          (* level 2 invalid *)
          Some (adt {log: EVT CPU_ID (REL lv1_gidx glv1 {glock: Some CPU_ID}) :: log adt}
                    {priv: (priv adt) {wi_llt: 0} {wi_index: ret_idx}}, VZ64 1)
      else
        (* level 1 invalid *)
        Some (adt {priv: (priv adt) {wi_llt: 0} {wi_index: ret_idx}}, VZ64 1)
    end.

End Spec.


Require Import VST.floyd.proofauto.
Require Import malloc.
Require Import malloc_lemmas.
Require Import malloc_sep.
Require Import VSU_malloc_definitions.
Local Open Scope logic.
(*
Definition Gprog : funspecs := external_specs ++ private_specs.
*)
Lemma body_malloc_large: semax_body MF_Vprog MF_Gprog f_malloc_large malloc_large_spec.
Proof.
start_function.
forward_call (n+WA+WORD). (*! t'1 = mmap0(nbytes+WASTE+WORD ...) !*)
{ entailer!. }
(*{ rep_lia. }*)
Intros p.
(* NOTE could split cases here; then two symbolic executions but simpler ones *)
forward_if. (*! if (p==NULL) !*)
- (* typecheck guard *)
  if_tac; entailer!.
- (* case p == NULL *)
  forward. (*! return NULL  !*)
  Exists (Vint (Int.repr 0)).
  if_tac; entailer!. (* cases in post of mmap *)
- (* case p <> NULL *)
  if_tac. (* cases in post of mmap *)
  + (* impossible case *)
    exfalso. destruct p; try contradiction; simpl in *.
  + assert_PROP (
        (force_val
           (sem_add_ptr_int tuint Signed
                            (force_val
                               (sem_cast_pointer
                                  (force_val
                                     (sem_add_ptr_int tschar Unsigned p
                                                      (Vint
                                                         (Int.sub
                                                            (Int.mul (Ptrofs.to_int (Ptrofs.repr 4)) (Int.repr 2))
                                                            (Ptrofs.to_int (Ptrofs.repr 4))))))))
                            (Vint (Int.repr 0))) = field_address tuint [] (offset_val WA p)) ).
    (* painful pointer reasoning to enable forward (p+WASTE)[0] = nbytes *)
    { entailer!.
      destruct p; try contradiction; simpl.
      normalize.
      unfold field_address.
      rewrite if_true.
      { simpl.  normalize. }
      hnf. (* drill down *)
      repeat split; auto.
      - (* size compat *)
        red.
        match goal with | H:size_compatible' _ _ |- _ => red in H end.
        unfold Ptrofs.add.
        rewrite (Ptrofs.unsigned_repr WA) by rep_lia.
        rewrite Ptrofs.unsigned_repr by rep_lia.
        simpl sizeof. rep_lia.
      - (* align compat *)
        red.
        eapply align_compatible_rec_by_value; try reflexivity.
        simpl in *. unfold natural_alignment in *. unfold Z.divide in *.
        match goal with | HA: (exists z:Z, _) /\ _ |- _ => destruct HA as [Hz Hlim] end.
        inv Hz.
        rewrite <- (Ptrofs.repr_unsigned i).
        match goal with | HA: Ptrofs.unsigned _ = _ |- _ => rewrite HA end.
        exists (2*x+1). change WA with 4.
        rewrite ptrofs_add_repr. rewrite Ptrofs.unsigned_repr.
        lia. rep_lia.
    }
    rewrite malloc_large_chunk; try rep_lia; try assumption.
    Intros. (* flatten sep *)
    forward. (*! (p+WASTE)[0] = nbytes;  !*)
    forward. (*! return (p+WASTE+WORD);  !*)
    (* postcond *)
    Exists (offset_val (WA+WORD) p).
    entailer!.
    simpl.
    if_tac.
    { exfalso. destruct p; try contradiction; simpl in *.
      match goal with | HA: Vptr _ _  = nullval |- _ => inv HA end. }
    unfold malloc_token'.
    Exists n.
    unfold malloc_tok.
    if_tac. rep_lia. entailer!.
    { apply malloc_compatible_offset; try rep_lia; try apply WORD_ALIGN_aligned.
      replace (n+(WA+WORD)) with (n + WA + WORD) by lia. assumption. }
    cancel.
    (* split off the token's share of chunk *)
    rewrite <- memory_block_Ews_join.
    (* data_at_ from memory_block *)
    replace (n - n) with 0 by lia.
    rewrite memory_block_zero.  entailer!.
Qed.
(*
Definition module := [mk_body body_malloc_large].
*)


Set Implicit Arguments.
Require Export Shared.
Require Export Ascii String.
Require Export LibTactics LibLogic LibReflect LibList
  LibOperation LibStruct LibNat LibEpsilon LibFunc LibHeap.
Require Fappli_IEEE Fappli_IEEE_bits.

(************************************************************)
(************************************************************)
(************************************************************)
(************************************************************)
(** * Javascript *)

(**************************************************************)
(** ** Numerical values *)

Definition number :=
  Fappli_IEEE_bits.binary64.

Definition number_of_int : int -> number :=
  Fappli_IEEE_bits.b64_of_bits.

Definition number_add : number -> number -> number :=
  Fappli_IEEE_bits.b64_plus Fappli_IEEE.mode_NE.

Definition number_mult : number -> number -> number :=
  Fappli_IEEE_bits.b64_mult Fappli_IEEE.mode_NE.

Definition number_div : number -> number -> number :=
  Fappli_IEEE_bits.b64_div Fappli_IEEE.mode_NE.

(**************************************************************)
(** ** Datatypes *)

(** Binary operators *)

Inductive binary_op :=
  | binary_op_add
  | binary_op_mult
  | binary_op_div
  | binary_op_equal
  | binary_op_instanceof
  | binary_op_in.

(* Unary operator *)

Inductive unary_op :=
  | unary_op_not
  | unary_op_delete
  | unary_op_typeof
  | unary_op_pre_incr
  | unary_op_post_incr
  | unary_op_pre_decr
  | unary_op_post_decr
  | unary_op_void.

(** Grammar of literals *)

Inductive literal :=
  | literal_null : literal
  | literal_bool : bool -> literal
  | literal_number : number -> literal
  | literal_string : string -> literal.

(** Grammar of expressions *)

Inductive expr :=
  | expr_this : expr
  | expr_variable : string -> expr
  | expr_literal : literal -> expr
  | expr_object : list (string * expr) -> expr
  | expr_function : option string -> list string -> expr -> expr
  | expr_access : expr -> expr -> expr
  | expr_member : expr -> string -> expr
  | expr_new : expr -> list expr -> expr
  | expr_call : expr -> list expr -> expr
  | expr_unary_op : unary_op -> expr -> expr
  | expr_binary_op : expr -> binary_op -> expr -> expr
  | expr_and : expr -> expr -> expr
  | expr_or : expr -> expr -> expr
  | expr_assign : expr -> option binary_op -> expr -> expr
  | expr_seq : expr -> expr -> expr
  | expr_var_decl : string -> option expr -> expr
  | expr_if : expr -> expr -> option expr -> expr
  | expr_while : expr -> expr -> expr
  | expr_with : expr -> expr -> expr
  | expr_skip.

(**************************************************************)
(** ** Data types for the semantics *)

(** Locations (address of objects) *)

Inductive loc :=
  | loc_normal : nat -> loc
  | loc_null : loc
  | loc_scope : loc
  | loc_global : loc
  | loc_eval : loc
  | loc_obj_proto : loc
  | loc_func_proto : loc
  | loc_eval_proto : loc.

(** Field names *)

Inductive field :=
  | field_normal : string -> field
  | field_proto : field
  | field_body : field
  | field_scope: field
  | field_this : field.

(** The particular "prototype" field name *)

Definition field_normal_prototype :=
  field_normal "prototype".

(** Reference: pair of a location and a field *)

Inductive ref :=
  | Ref : loc -> field -> ref.

(** Scope chain *)

Definition scope := list loc.

(** Grammar of values *)

Inductive value :=
  | value_undef : value
  | value_bool : bool -> value
  | value_number : number -> value
  | value_string : string -> value
  | value_loc : loc -> value
  | value_scope : scope -> value
  | value_body : list string -> expr -> value.

(** Result of an evaluation: a value or a reference *)

Inductive result :=
  | result_value : value -> result
  | result_ref : ref -> result.

(** Heaps are finite maps from references to values.
    Heaps are based on the "heap" typed defined in [Shared.v].
    The values [heap_write], [heap_read] and [heap_binds]
    and [indom] are also defined in [Shared.v]. *)

Module Heap := LibHeap.HeapList.

Definition heap := Heap.heap ref value.

(** Coercions *)

Coercion field_normal : string >-> field.
Coercion value_number : number >-> value.
Coercion value_string : string >-> value.
Coercion value_loc : loc >-> value.
Coercion result_value : value >-> result.
Coercion result_ref : ref >-> result.


From mathcomp
Require Import ssreflect ssrbool ssrnat eqtype seq ssrfun.
From fcsl
Require Import prelude pred pcm unionmap heap.
From HTT
Require Import stmod stsep stlog stlogR.
From SSL
Require Import core.
From Hammer Require Import Hammer.
(* Configure Hammer *)
Set Hammer ATPLimit 60.
Unset Hammer Eprover.
Unset Hammer Vampire.
Add Search Blacklist "fcsl.".
Add Search Blacklist "HTT.".
Add Search Blacklist "Coq.ssr.ssrfun".
Add Search Blacklist "mathcomp.ssreflect.ssrfun".
Add Search Blacklist "mathcomp.ssreflect.bigop".
Add Search Blacklist "mathcomp.ssreflect.choice".
Add Search Blacklist "mathcomp.ssreflect.div".
Add Search Blacklist "mathcomp.ssreflect.finfun".
Add Search Blacklist "mathcomp.ssreflect.fintype".
Add Search Blacklist "mathcomp.ssreflect.path".
Add Search Blacklist "mathcomp.ssreflect.tuple".

Require Import common.

Definition sll_free_type :=
  forall (vprogs : ptr),
  {(vghosts : seq nat)},
  STsep (
    fun h =>
      let: (x) := vprogs in
      let: (s) := vghosts in
      exists h_sll_xs_1,
      h = h_sll_xs_1 /\ sll x s h_sll_xs_1,
    [vfun (_: unit) h =>
      let: (x) := vprogs in
      let: (s) := vghosts in
      h = empty
    ]).

Program Definition sll_free : sll_free_type :=
  Fix (fun (sll_free : sll_free_type) vprogs =>
    let: (x) := vprogs in
    Do (
      if (x) == (null)
      then
        ret tt
      else
        vx1 <-- @read nat x;
        nxtx1 <-- @read ptr (x .+ 1);
        sll_free (nxtx1);;
        dealloc x;;
        dealloc (x .+ 1);;
        ret tt
    )).
Obligation Tactic := intro; move=>x; ssl_program_simpl.
Next Obligation.
ssl_ghostelim_pre.
move=>s.
ex_elim h_sll_xs_1.
move=>[sigma_self].
subst h_self.
move=>H_sll_xs_1.
ssl_ghostelim_post.
ssl_open ((x) == (null)) H_sll_xs_1.
move=>[phi_sll_xs_10].
move=>[sigma_sll_xs_1].
subst h_sll_xs_1.
try rename h_sll_xs_1 into h_sll_x_1.
try rename H_sll_xs_1 into H_sll_x_1.
ssl_emp;
sslauto.
ex_elim vx s1x nxtx.
ex_elim h_sll_nxtxs1x_0x.
move=>[phi_sll_xs_10].
move=>[sigma_sll_xs_1].
subst h_sll_xs_1.
move=>H_sll_nxtxs1x_0x.
try rename h_sll_xs_1 into h_sll_xvxs1x_1.
try rename H_sll_xs_1 into H_sll_xvxs1x_1.
ssl_read x.
try rename vx into vx1.
try rename h_sll_xvxs1x_1 into h_sll_xvx1s1x_1.
try rename H_sll_xvxs1x_1 into H_sll_xvx1s1x_1.
ssl_read (x .+ 1).
try rename nxtx into nxtx1.
try rename h_sll_nxtxs1x_0x into h_sll_nxtx1s1x_0x.
try rename H_sll_nxtxs1x_0x into H_sll_nxtx1s1x_0x.
try rename h_sll_x1s1_11 into h_sll_nxtx1s1x_0x.
try rename H_sll_x1s1_11 into H_sll_nxtx1s1x_0x.
ssl_call_pre (h_sll_nxtx1s1x_0x).
ssl_call (s1x).
exists (h_sll_nxtx1s1x_0x);
sslauto.
ssl_frame_unfold.
move=>h_call0.
move=>[sigma_call0].
subst h_call0.
store_valid.
ssl_dealloc x.
ssl_dealloc (x .+ 1).
ssl_emp;
sslauto.
Qed.