From Coq Require Import ssreflect ssrfun ssrbool.
From Coq Require Import Ensembles Logic.Classical_Prop.
From Coq Require Import Arith.Wf_nat Relations.Relation_Operators Wellfounded.Wellfounded.
From Coq Require Import Logic.FunctionalExtensionality.
From Coq.micromega Require Import Lia.

From Equations Require Import Equations.

From stdpp Require Import base option.

From MatchingLogic Require Import
     Syntax
     Semantics
     DerivedOperators_Syntax
     ProofSystem
     ProofMode.MLPM
     Utils.extralibrary
.

Import MatchingLogic.Syntax.Notations MatchingLogic.DerivedOperators_Syntax.Notations.

Global Set Transparent Obligations.
Derive NoConfusion for Pattern.
Derive Subterm for Pattern.

Open Scope ml_scope.

Equations match_not {Σ : Signature} (p : Pattern)
  : ({ p' : Pattern & p = patt_not p'}) + (forall p', p <> patt_not p')
  :=
  match_not (p' ---> ⊥) := inl _ ;
  match_not _ := inr _ .
Solve Obligations with Tactics.program_simplify; CoreTactics.equations_simpl.
Next Obligation.
  intros. eapply existT. reflexivity.
Defined.

Lemma match_not_patt_not  {Σ : Signature} p: is_inl (match_not (patt_not p)).
Proof.
  funelim (match_not _). simpl. reflexivity.
Qed.

Equations match_or {Σ : Signature} (p : Pattern)
  : ({ p1 : Pattern & {p2 : Pattern & p = patt_or p1 p2} } ) + (forall p1 p2, p <> patt_or p1 p2)
  :=
  match_or (p1 ---> p2) with match_not p1 => {
    | inl (existT p1' e) => inl _
    | inr _ => inr _
    } ;
  match_or _ := inr _.
Solve Obligations with Tactics.program_simplify; CoreTactics.equations_simpl.
Next Obligation.
  intros. inversion e. subst. eapply existT. eapply existT. reflexivity.
Defined.
Next Obligation.
  intros.
  unfold patt_or.
  assert (p1 <> patt_not p0). auto.
  congruence.
Defined.

Lemma match_or_patt_or  {Σ : Signature} p1 p2: is_inl (match_or (patt_or p1 p2)).
Proof. reflexivity. Qed.

Equations?  match_and {Σ : Signature} (p : Pattern)
  : ({ p1 : Pattern & {p2 : Pattern & p = patt_and p1 p2} } ) + (forall p1 p2, p <> patt_and p1 p2)
  :=
  match_and p with match_not p => {
    | inr _ := inr _ ;
    | inl (existT p' e') with match_or p' => {
      | inr _ := inr _ ;
      | inl (existT p1 (existT p2 e12)) with match_not p1 => {
        | inr _ := inr _ ;
        | inl (existT np1 enp1) with match_not p2 => {
          | inr _ := inr _ ;
          | inl (existT np2 enp2) := inl _
          }
        }
      }
    }.
Proof.
  - subst. eapply existT. eapply existT. reflexivity.
  - subst. intros. unfold not. intros Hcontra. inversion Hcontra.
    subst. specialize (n p0). contradiction.
  - subst. intros. unfold not. intros Hcontra. inversion Hcontra.
    subst. specialize (n p0). contradiction.
  - subst. intros. unfold not. intros Hcontra. inversion Hcontra.
    subst. specialize (n (patt_not p1) (patt_not p2)). contradiction.
  - intros. unfold not. intros Hcontra. subst.
    specialize (n ((patt_or (patt_not p1) (patt_not p2)))). contradiction.
Defined.

Lemma match_and_patt_and  {Σ : Signature} p1 p2: is_inl (match_and (patt_and p1 p2)).
Proof. reflexivity. Qed.

Lemma match_and_patt_or  {Σ : Signature} p1 p2: is_inl (match_and (patt_or p1 p2)) = false.
Proof.
  funelim (match_and _); rewrite -Heqcall; simpl; try reflexivity.
  subst. try inversion e'.
Qed.

Equations match_imp {Σ : Signature} (p : Pattern)
  : ({ p1 : Pattern & {p2 : Pattern & p = patt_imp p1 p2} } ) + (forall p1 p2, p <> patt_imp p1 p2)
  :=
  match_imp (p1 ---> p2) := inl _ ;
  match_imp _ := inr _.
Solve Obligations with Tactics.program_simplify; CoreTactics.equations_simpl.
Next Obligation.
  intros. eapply existT. eapply existT. reflexivity.
Defined.

Lemma match_imp_patt_imp {Σ : Signature} p1 p2: is_inl (match_imp (patt_imp p1 p2)).
Proof. reflexivity. Qed.

Equations match_bott {Σ : Signature} (p : Pattern)
  : (p = patt_bott) + (p <> patt_bott)
  :=
  match_bott patt_bott := inl _ ;
  match_bott _ := inr _.
Solve Obligations with Tactics.program_simplify; CoreTactics.equations_simpl.
Next Obligation. reflexivity. Defined.

Equations match_a_impl_b_impl_c {Σ : Signature} (p : Pattern) :
  ({a : Pattern & {b : Pattern & {c : Pattern & p = patt_imp a (patt_imp b c)} } })
  + (forall (a b c : Pattern), p <> patt_imp a (patt_imp b c)) :=
  match_a_impl_b_impl_c (p1 ---> (p2 ---> p3)) := inl _ ;
  match_a_impl_b_impl_c _ := inr _ .
Solve Obligations with Tactics.program_simplify; CoreTactics.equations_simpl.
Next Obligation.
  intros Σ p1 p2 p3.
  do 3 eapply existT.
  reflexivity.
Defined.


Require Import Io.All.
Require Choose.
Require Import Semantics.

Fixpoint to_choose {E A} (x : C.t E A) : Choose.t E A :=
  match x with
  | C.Ret _ v => Choose.Ret v
  | C.Call c => Choose.Call c Choose.Ret
  | C.Let _ _ x f => Choose.bind (to_choose x) (fun x => to_choose (f x))
  | C.Choose _ x1 x2 => Choose.Choose (to_choose x1) (to_choose x2)
  | C.Join _ _ x y => Choose.join (to_choose x) (to_choose y)
  end.

Module Path.
  Module Last.
    Fixpoint to_choose (p : C.Last.Path.t) : Choose.Path.t :=
      match p with
      | C.Last.Path.Ret => Choose.Path.Done
      | C.Last.Path.Let p_x p_f =>
        Choose.Path.bind (to_choose p_x) (to_choose p_f)
      | C.Last.Path.ChooseLeft p_x1 =>
        Choose.Path.ChooseLeft (to_choose p_x1)
      | C.Last.Path.ChooseRight p_x2 =>
        Choose.Path.ChooseRight (to_choose p_x2)
      | C.Last.Path.Join p_x p_y =>
        Choose.Path.ChooseLeft
          (Choose.Path.bind (to_choose p_x) (to_choose p_y))
      end.
  End Last.

  Fixpoint to_choose (p : C.Path.t) : Choose.Path.t :=
    match p with
    | C.Path.Call => Choose.Path.Done
    | C.Path.Let p_x => to_choose p_x
    | C.Path.LetDone p_x p_f =>
      Choose.Path.bind (Last.to_choose p_x) (to_choose p_f)
    | C.Path.ChooseLeft p_x1 => Choose.Path.ChooseLeft (to_choose p_x1)
    | C.Path.ChooseRight p_x2 => Choose.Path.ChooseRight (to_choose p_x2)
    | C.Path.JoinLeft p_x => Choose.Path.ChooseLeft (to_choose p_x)
    | C.Path.JoinLeftDone p_x p_y =>
      Choose.Path.ChooseLeft (Choose.Path.bind
        (Last.to_choose p_x) (to_choose p_y))
    | C.Path.JoinRight p_y => Choose.Path.ChooseRight (to_choose p_y)
    | C.Path.JoinRightDone p_x p_y =>
      Choose.Path.ChooseRight (Choose.Path.bind
        (to_choose p_x) (Last.to_choose p_y))
    end.

  Fixpoint to_c {E A} (x : C.t E A) (p : Choose.Path.t)
    : (C.Last.Path.t * A * Choose.Path.t) + C.Path.t :=
    match x with
    | C.Ret _ v => inl (C.Last.Path.Ret, v, p)
    | C.Call _ => inr C.Path.Call
    | C.Let _ _ x f =>
      match to_c x p with
      | inl (p_x, v_x, p) =>
        match to_c (f v_x) p with
        | inl (p_f, v_y, p) => inl (C.Last.Path.Let p_x p_f, v_y, p)
        | inr p_y => inr (C.Path.LetDone p_x p_y)
        end
      | inr p_x => inr (C.Path.Let p_x)
      end
    | C.Choose _ x1 x2 =>
      match p with
      | Choose.Path.Done => inr C.Path.Call
      | Choose.Path.ChooseLeft p =>
        match to_c x1 p with
        | inl (p_x1, v_x1, p) => inl (C.Last.Path.ChooseLeft p_x1, v_x1, p)
        | inr p_x1 => inr (C.Path.ChooseLeft p_x1)
        end
      | Choose.Path.ChooseRight p =>
        match to_c x2 p with
        | inl (p_x2, v_x2, p) => inl (C.Last.Path.ChooseRight p_x2, v_x2, p)
        | inr p_x2 => inr (C.Path.ChooseRight p_x2)
        end
      end
    | C.Join _ _ x y =>
      match p with
      | Choose.Path.Done => inr C.Path.Call
      | Choose.Path.ChooseLeft p =>
        match to_c x p with
        | inl (p_x, v_x, p) =>
          match to_c y p with
          | inl (p_y, v_y, p) => inl (C.Last.Path.Join p_x p_y, (v_x, v_y), p)
          | inr p_y => inr (C.Path.JoinLeftDone p_x p_y)
          end
        | inr p_x => inr (C.Path.JoinLeft p_x)
        end
      | Choose.Path.ChooseRight p =>
        match to_c y p with
        | inl (p_y, v_y, p) =>
          match to_c x p with
          | inl (p_x, v_x, p) => inl (C.Last.Path.Join p_x p_y, (v_x, v_y), p)
          | inr p_x => inr (C.Path.JoinRightDone p_x p_y)
          end
        | inr p_y => inr (C.Path.JoinRight p_y)
        end
      end
    end.
End Path.


(* Standard library imports *)
Require Import Coq.Strings.String.
Require Import Coq.Strings.Ascii.
Require Import Coq.Lists.List.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Bool.Bool.
Require Import Coq.omega.Omega.
Require Import Coq.Program.Equality.
Import ListNotations.
(* Project related imports *)
Require Import GenericLemmas.
Require Import OptionMonad.
Require Import Names.
Require Import AST.
Require Import UtilsProgram.
Require Import UtilsSkeleton.
Require Import Skeleton.
Require Import Typechecker.
Require Import Unique.

(**************************************************************************************************)
(** * Constructorization Part I:                                                                 *)
(**                                                                                *)
(** In the first part of the algorithm we compute a new program skeleton.                         *)
(**************************************************************************************************)

Definition DestrFunSignature : Type := list TypeName * TypeName.

Definition Constructor : Type := ScopedName * list TypeName.

Definition computeNewDatatype (p : program) (n : TypeName) : list Constructor :=
  (map (fun x => (global (fst x), snd x))
       (filter (fun x => eq_TypeName (fst (fst x)) n) (skeleton_gfun_sigs_g (program_skeleton p)))) ++
  (map (fun x => (local (fst x), snd x))
       (filter (fun x => eq_TypeName (fst (fst x)) n) (skeleton_gfun_sigs_l (program_skeleton p)))).

(**************************************************************************************************)
(** ** Proof of dts_ctors_in_dts (dt well-formedness #1)                                          *)
(**************************************************************************************************)

Lemma new_dts_ctors_in_dts_g : forall (p : program) (n : TypeName),
    dts_ctors_in_dts (n :: skeleton_dts (program_skeleton p))
      (map (fun x => (global (fst x), snd x))
       (filter (fun x => eq_TypeName (fst (fst x)) n) (skeleton_gfun_sigs_g (program_skeleton p)))).
Proof.
intros p n. unfold dts_ctors_in_dts.
assert (H : Forall (fun ctor => fst (unscope (fst ctor)) = n)
  (map (fun x => (global (fst x), snd x))
       (filter (fun x => eq_TypeName (fst (fst x)) n) (skeleton_gfun_sigs_g (program_skeleton p))))).
- induction (skeleton_gfun_sigs_g (program_skeleton p)).
  + simpl. apply Forall_nil.
  + simpl. destruct a as [[a0 a1] a2]; simpl in *. destruct (eq_TypeName a0 n) eqn:E.
    * simpl. apply Forall_cons. simpl. name_eq_tac. apply IHg.
    * apply IHg.
- induction (map (fun x => (global (fst x), snd x))
       (filter (fun x => eq_TypeName (fst (fst x)) n) (skeleton_gfun_sigs_g (program_skeleton p))));
    inversion H; subst.
  + apply Forall_nil.
  + apply Forall_cons.
    * simpl. left. reflexivity.
    * apply IHl. assumption.
Qed.

Lemma new_dts_ctors_in_dts_l : forall (p : program) (n : TypeName),
    dts_ctors_in_dts (n :: skeleton_dts (program_skeleton p))
      (map (fun x => (local (fst x), snd x))
       (filter (fun x => eq_TypeName (fst (fst x)) n) (skeleton_gfun_sigs_l (program_skeleton p)))).
intros p n. unfold dts_ctors_in_dts.
assert (H : Forall (fun ctor => fst (unscope (fst ctor)) = n)
  (map (fun x => (local (fst x), snd x))
       (filter (fun x => eq_TypeName (fst (fst x)) n) (skeleton_gfun_sigs_l (program_skeleton p))))).
- induction (skeleton_gfun_sigs_l (program_skeleton p)).
  + simpl. apply Forall_nil.
  + simpl. destruct a as [[a0 a1] a2]; simpl in *. destruct (eq_TypeName a0 n) eqn:E.
    * simpl. apply Forall_cons. simpl. name_eq_tac. apply IHg.
    * apply IHg.
- induction (map (fun x => (local (fst x), snd x))
       (filter (fun x => eq_TypeName (fst (fst x)) n) (skeleton_gfun_sigs_l (program_skeleton p))));
    inversion H; subst.
  + apply Forall_nil.
  + apply Forall_cons.
    * simpl. left. reflexivity.
    * apply IHl. assumption.
Qed.

Lemma new_dts_ctors_in_dts : forall (p : program) (n : TypeName),
    dts_ctors_in_dts (n :: skeleton_dts (program_skeleton p)) ((computeNewDatatype p n) ++ (skeleton_ctors (program_skeleton p))).
Proof.
intros p n. unfold dts_ctors_in_dts. unfold computeNewDatatype.
repeat apply Forall_app.
- apply new_dts_ctors_in_dts_g.
- apply new_dts_ctors_in_dts_l.
- destruct p. simpl. clear - program_skeleton. destruct program_skeleton. simpl.
  clear - skeleton_dts_ctors_in_dts. unfold dts_ctors_in_dts in skeleton_dts_ctors_in_dts.
  induction skeleton_ctors.
  + apply Forall_nil.
  + apply Forall_cons.
    * right. inversion skeleton_dts_ctors_in_dts; subst. assumption.
    * apply IHskeleton_ctors. inversion skeleton_dts_ctors_in_dts; subst. assumption.
Qed.

(**************************************************************************************************)
(** ** Proof of dts_ctor_names_unique (dt well-formedness #1)                                     *)
(**************************************************************************************************)

Lemma disjoint_app_unique : forall {A} (l1 l2 : list A),
  (forall a, ~(In a l1 /\ In a l2)) ->
  unique l1 ->
  unique l2 ->
  unique (l1 ++ l2).
Proof with try apply in_eq; try apply in_cons; auto.
intros. induction l1... rewrite <- app_comm_cons. apply Unique_cons.
- unfold not. intros. unfold not in H. inversion H0; subst. apply in_app_or in H2. destruct H2...
  apply H with (a0:=a). split...
- inversion H0; subst. apply IHl1... intros. unfold not. intros. unfold not in H. destruct H2. apply H with (a0:=a0). split...
Qed.

Lemma new_dts_ctor_names_unique : forall (p : program)(n : TypeName),
    dts_ctor_names_unique ((computeNewDatatype p n) ++ skeleton_ctors (program_skeleton p)).
Proof with auto.
intros p n. unfold dts_ctor_names_unique.
unfold computeNewDatatype. repeat (rewrite map_app). repeat (rewrite map_map). simpl.
pose proof (skeleton_dts_cdts_disjoint (program_skeleton p)) as Disj.
pose proof (skeleton_dts_ctors_in_dts (program_skeleton p)) as ctorInDts.
pose proof (skeleton_cdts_dtors_in_cdts (program_skeleton p)) as dtorInCdts.
pose proof (skeleton_gfun_sigs_in_cdts_g (program_skeleton p)) as InCdt_g.
pose proof (skeleton_gfun_sigs_in_cdts_l (program_skeleton p)) as InCdt_l.
apply disjoint_app_unique.
- intros. unfold not. intros. unfold dts_cdts_disjoint in Disj.
  unfold not in Disj. destruct H. apply in_app_or in H. destruct H.
  + unfold gfun_sigs_in_cdts in InCdt_g.
    rewrite Forall_forall in InCdt_g.
    rewrite in_map_iff in H. destruct H as [x [H xIn]].
    rewrite filter_In in xIn. destruct xIn.
    eapply Disj. rewrite and_comm. split.
    * apply InCdt_g. eauto.
    * unfold dts_ctors_in_dts in ctorInDts. rewrite Forall_forall in ctorInDts.
      apply (f_equal unscope) in H. simpl in H. unfold QName in *. rewrite H.
      rewrite in_map_iff in H0. destruct H0. destruct H0. destruct x0. simpl in *; subst.
      change a with (fst (a,l)). apply ctorInDts...
  + unfold gfun_sigs_in_cdts in InCdt_l.
    rewrite Forall_forall in InCdt_l.
    rewrite in_map_iff in H. destruct H as [x [H xIn]].
    rewrite filter_In in xIn. destruct xIn.
    eapply Disj. rewrite and_comm. split.
    * apply InCdt_l. eauto.
    * unfold dts_ctors_in_dts in ctorInDts. rewrite Forall_forall in ctorInDts.
      apply (f_equal unscope) in H. simpl in H. unfold QName in *. rewrite H.
      rewrite in_map_iff in H0. destruct H0. destruct H0. destruct x0. simpl in *; subst.
      change a with (fst (a,l)). apply ctorInDts...
- apply disjoint_app_unique.
  + intros. unfold not. intros. destruct H.
    rewrite in_map_iff in H. rewrite in_map_iff in H0.
    destruct H as [x [H xIn]]. destruct H0 as [x0 [H0 x0In]].
    rewrite <- H0 in H. discriminate.
  + pose proof (skeleton_gfun_sigs_names_unique_g (program_skeleton p)) as H.
    unfold gfun_sigs_names_unique in H. rewrite <- map_map.
    assert (forall l, unique l -> unique (map global l)) as H0.
    { intros. induction l; try apply Unique_nil. simpl. inversion H0; subst.
      apply Unique_cons... unfold not. intros. unfold not in H3. apply H3.
      rewrite in_map_iff in H1. do 2 (destruct H1). inversion H1; subst... }
    apply H0.
    rewrite filter_map with
      (g:=fun x : TypeName * Name => eq_TypeName (fst x) n) (f:=fst).
    apply filter_unique...
  + pose proof (skeleton_gfun_sigs_names_unique_l (program_skeleton p)) as H.
    unfold gfun_sigs_names_unique in H. rewrite <- map_map.
    assert (forall l, unique l -> unique (map local l)) as H0.
    { intros. induction l; try apply Unique_nil. simpl. inversion H0; subst.
      apply Unique_cons... unfold not. intros. unfold not in H3. apply H3.
      rewrite in_map_iff in H1. do 2 (destruct H1). inversion H1; subst... }
    apply H0.
    rewrite filter_map with
      (g:=fun x : TypeName * Name => eq_TypeName (fst x) n) (f:=fst).
    apply filter_unique...
- apply (skeleton_dts_ctor_names_unique (program_skeleton p)).
Qed.

(**************************************************************************************************)
(** ** Proof of cdts_dtors_in_cdts (cdt well-formedness #1)                                       *)
(**************************************************************************************************)

Definition new_cdts (p : program) (n : TypeName) : list TypeName :=
      (filter (fun n' : TypeName => negb (eq_TypeName n n')) (skeleton_cdts (program_skeleton p))).

Definition new_dtors (p : program) (n : TypeName) :=
  filter (fun x => match x with (n',_,_) => negb (eq_TypeName n (fst (unscope n'))) end) (skeleton_dtors (program_skeleton p)).

Lemma new_cdts_dtors_in_cdts : forall (p : program) (n : TypeName),
  cdts_dtors_in_cdts (new_cdts p n) (new_dtors p n).
Proof.
intros p n. unfold new_dtors. unfold new_cdts. destruct p. simpl. clear - program_skeleton.
destruct program_skeleton. simpl. clear - skeleton_cdts_dtors_in_cdts.
unfold cdts_dtors_in_cdts in *.
induction skeleton_dtors.
- simpl. apply Forall_nil.
- simpl. destruct a as [[a0 a1] a2]. simpl in *.
  destruct (eq_TypeName n (fst (unscope a0))) eqn:E.
  + simpl. apply IHskeleton_dtors. inversion skeleton_cdts_dtors_in_cdts; subst. apply H2.
  + simpl. apply Forall_cons.
    * simpl. inversion skeleton_cdts_dtors_in_cdts; subst. simpl in *. remember (fst (unscope a0)) as X.
      clear - H1 E. induction skeleton_cdts; try inversion H1.
      simpl. simpl in H1. destruct H1.
      -- subst. rewrite E. simpl. left. reflexivity.
      -- destruct (eq_TypeName n a) eqn:E'.
         ++ name_eq_tac. simpl. apply IHskeleton_cdts. assumption.
         ++ simpl. right. apply IHskeleton_cdts. assumption.
      -- simpl. destruct (eq_TypeName n a) eqn:E2.
         ++ simpl. apply IHskeleton_cdts. assumption.
         ++ simpl. right. apply IHskeleton_cdts. assumption.
    * apply IHskeleton_dtors. inversion skeleton_cdts_dtors_in_cdts; subst. assumption.
Qed.

(**************************************************************************************************)
(** ** Proof of cdts_dtor_names_unique (cdt well-formedness #2)                                   *)
(**************************************************************************************************)

Fact filter_ext : forall {A} (l : list A) f g,
  (forall a, f a = g a) ->
  filter f l = filter g l.
Proof with auto. intros. induction l... simpl. rewrite H. rewrite IHl... Qed.

Lemma new_cdts_dtor_names_unique : forall (p : program)(n : TypeName),
  cdts_dtor_names_unique (new_dtors p n).
Proof.
intros p n. unfold new_dtors. destruct p. simpl. clear - program_skeleton.
destruct program_skeleton. simpl. clear - skeleton_cdts_dtor_names_unique.
unfold cdts_dtor_names_unique in *.
rewrite filter_ext with (g:=fun x => negb (eq_TypeName n (fst (unscope (fst (fst x)))))).
2: { intros. destruct a. destruct p. auto. }
rewrite filter_map with
  (g:=fun x : ScopedName => negb (eq_TypeName n (fst (unscope x))))
  (f:=fun x => fst (fst x)). apply filter_unique. auto.
Qed.

(**************************************************************************************************)
(** ** Proof of dts_cdts_disjoint                                                                     *)
(**************************************************************************************************)

Lemma new_d_cd_disj : forall (p : program) (n : TypeName),
    dts_cdts_disjoint (n :: skeleton_dts (program_skeleton p)) (new_cdts p n).
Proof.
intros p n. unfold dts_cdts_disjoint. intros t H. unfold new_cdts in H.
destruct p; simpl in *. clear - H program_skeleton.
destruct program_skeleton; simpl in *. clear - H skeleton_dts_cdts_disjoint.
unfold dts_cdts_disjoint in skeleton_dts_cdts_disjoint.
destruct H. destruct H.
- subst. clear - H0. induction skeleton_cdts.
  + simpl in H0. assumption.
  + simpl in H0. destruct (eq_TypeName t a) eqn:E.
    * simpl in *. apply IHskeleton_cdts. assumption.
    * simpl in *. destruct H0.
      -- subst. name_refl_tac. inversion E.
      -- apply IHskeleton_cdts. assumption.
- specialize (skeleton_dts_cdts_disjoint t). apply skeleton_dts_cdts_disjoint. split.
   + assumption.
   + clear - H0. induction skeleton_cdts.
    * inversion H0.
    * simpl in *. destruct (eq_TypeName n a) eqn:E.
      -- simpl in *. name_eq_tac. right. apply IHskeleton_cdts. assumption.
      -- simpl in *. destruct H0.
         ++ left. assumption.
         ++ right. apply IHskeleton_cdts. assumption.
Qed.

(**************************************************************************************************)
(** ** Proof of cfun_sigs_in_dts (cfuns well-formedness #1)                                       *)
(**************************************************************************************************)

Definition cfunsigs_mapfun (x : ScopedName * list TypeName * TypeName) :=
  match x with (x1,x2,x3) => (unscope x1, x2, x3) end.

Definition cfunsigs_filterfun_g (n : TypeName) (x : ScopedName * list TypeName * TypeName) :=
  match x with
  |(global n',_,_) => eq_TypeName n (fst n')
  | _ => false
  end.

Definition new_cfunsigs_g p n :=
  List.map cfunsigs_mapfun (filter (cfunsigs_filterfun_g n) (skeleton_dtors (program_skeleton p)))
           ++ (skeleton_cfun_sigs_g (program_skeleton p)).

Lemma new_cfun_sigs_in_dts_g : forall (p : program) (n : TypeName),
    cfun_sigs_in_dts
      (n :: skeleton_dts (program_skeleton p))
      (new_cfunsigs_g p n).
Proof.
  intros p n. pose proof (skeleton_cfun_sigs_in_dts_g (program_skeleton p)).
  unfold cfun_sigs_in_dts in *. unfold new_cfunsigs_g. apply Forall_app.
  - (* Show the newly generated cfunsigs are in (n :: dts) *)
    clear H. induction (skeleton_dtors (program_skeleton p)).
    + simpl. apply Forall_nil.
    + simpl. destruct a as [[a0 a1] a2]. simpl in *. destruct a0.
      * apply IHd.
      * destruct (eq_TypeName n (fst q)) eqn:E.
        ** simpl. apply Forall_cons.
           *** left. simpl. name_eq_tac.
           *** apply IHd.
        ** apply IHd.
  - (* Show the old cfunsigs are in dts *)
    induction (skeleton_cfun_sigs_g (program_skeleton p)).
    + apply Forall_nil.
    + apply Forall_cons.
      * apply in_cons. inversion H; assumption.
      * apply IHc. inversion H; subst. assumption.
Qed.

Definition cfunsigs_filterfun_l (n : TypeName) (x : ScopedName * list TypeName * TypeName) :=
  match x with
  |(local n',_,_) => eq_TypeName n (fst n')
  | _ => false
  end.

Definition new_cfunsigs_l p n :=
  List.map cfunsigs_mapfun (filter (cfunsigs_filterfun_l n) (skeleton_dtors (program_skeleton p)))
           ++ (skeleton_cfun_sigs_l (program_skeleton p)).

Lemma new_cfun_sigs_in_dts_l : forall (p : program) (n : TypeName),
    cfun_sigs_in_dts
      (n :: skeleton_dts (program_skeleton p))
      (new_cfunsigs_l p n).
Proof.
  intros p n. pose proof (skeleton_cfun_sigs_in_dts_l (program_skeleton p)).
  unfold cfun_sigs_in_dts in *. unfold new_cfunsigs_l. apply Forall_app.
  - (* Show the newly generated cfunsigs are in (n :: dts) *)
    clear H. induction (skeleton_dtors (program_skeleton p)).
    + simpl. apply Forall_nil.
    + simpl. destruct a as [[a0 a1] a2]. simpl in *. destruct a0.
      * destruct (eq_TypeName n (fst q)) eqn:E.
        ** simpl. apply Forall_cons.
           *** left. simpl. name_eq_tac.
           *** apply IHd.
        ** apply IHd.
      * apply IHd.
  - (* Show the old cfunsigs are in dts *)
    induction (skeleton_cfun_sigs_l (program_skeleton p)).
    + apply Forall_nil.
    + apply Forall_cons.
      * apply in_cons. inversion H; assumption.
      * apply IHc. inversion H; subst. assumption.
Qed.

(**************************************************************************************************)
(** ** Proof of cfun_sigs_names_unique (cfuns well-formedness #2)                                 *)
(**************************************************************************************************)

Lemma new_cfun_sigs_names_unique_g : forall (p : program) (n : TypeName),
    cfun_sigs_names_unique (new_cfunsigs_g p n).
Proof.
intros p n. unfold cfun_sigs_names_unique. unfold new_cfunsigs_g.
pose proof (skeleton_cfun_sigs_names_unique_g (program_skeleton p)).
unfold cfun_sigs_names_unique in H. unfold cfunsigs_mapfun.
pose proof (skeleton_dts_cdts_disjoint (program_skeleton p)) as Disj.
pose proof (skeleton_cdts_dtors_in_cdts (program_skeleton p)) as dtorInCdts.
pose proof (skeleton_cfun_sigs_in_dts_g (program_skeleton p)) as InDt_g.
rewrite map_app.
apply disjoint_app_unique.
- intros. unfold not. intros. destruct H0.
  unfold cdts_dtors_in_cdts in dtorInCdts. rewrite Forall_forall in dtorInCdts.
  rewrite map_map in H0. rewrite in_map_iff in H0. do 2 (destruct H0).
  rewrite filter_In in H2. destruct H2. pose proof (dtorInCdts _ H2).

  unfold cfun_sigs_in_dts in InDt_g. rewrite Forall_forall in InDt_g.
  rewrite in_map_iff in H1. do 2 (destruct H1). pose proof (InDt_g _ H5).
  destruct x. destruct p0. subst. simpl in *. unfold QName in *. rewrite H1 in H6.

  unfold dts_cdts_disjoint in Disj. unfold not in Disj. eapply Disj. split; eauto.
- pose proof (skeleton_cdts_dtor_names_unique (program_skeleton p)).
  unfold cdts_dtor_names_unique in H0.
  unfold cfunsigs_filterfun_g. clear - H0.
  generalize dependent (skeleton_dtors (program_skeleton p)). induction d; intros.
  + simpl. apply Unique_nil.
  + simpl. destruct a. destruct p0. destruct s.
    * apply IHd. inversion H0; subst. auto.
    * case (eq_TypeName n (fst q)).
      -- simpl. apply Unique_cons.
         ++ inversion H0; subst. unfold not in *. intros. apply H2. clear - H.
            rewrite map_map in H. rewrite in_map_iff in H. do 2 (destruct H).
            rewrite filter_In in H0. destruct H0. destruct x. destruct p. rewrite <- H.
            simpl in *. rewrite in_map_iff. exists (s,l,t). simpl. split; auto.
            destruct s; try discriminate. auto.
         ++ inversion H0; subst. auto.
      -- inversion H0; subst. auto.
- apply (skeleton_cfun_sigs_names_unique_g (program_skeleton p)).
Qed.

Lemma new_cfun_sigs_names_unique_l : forall (p : program) (n : TypeName),
    cfun_sigs_names_unique (new_cfunsigs_l p n).
Proof.
intros p n. unfold cfun_sigs_names_unique. unfold new_cfunsigs_l.
pose proof (skeleton_cfun_sigs_names_unique_l (program_skeleton p)).
unfold cfun_sigs_names_unique in H. unfold cfunsigs_mapfun.
pose proof (skeleton_dts_cdts_disjoint (program_skeleton p)) as Disj.
pose proof (skeleton_cdts_dtors_in_cdts (program_skeleton p)) as dtorInCdts.
pose proof (skeleton_cfun_sigs_in_dts_l (program_skeleton p)) as InDt_l.
rewrite map_app.
apply disjoint_app_unique.
- intros. unfold not. intros. destruct H0.
  unfold cdts_dtors_in_cdts in dtorInCdts. rewrite Forall_forall in dtorInCdts.
  rewrite map_map in H0. rewrite in_map_iff in H0. do 2 (destruct H0).
  rewrite filter_In in H2. destruct H2. pose proof (dtorInCdts _ H2).

  unfold cfun_sigs_in_dts in InDt_l. rewrite Forall_forall in InDt_l.
  rewrite in_map_iff in H1. do 2 (destruct H1). pose proof (InDt_l _ H5).
  destruct x. destruct p0. subst. simpl in *. unfold QName in *. rewrite H1 in H6.

  unfold dts_cdts_disjoint in Disj. unfold not in Disj. eapply Disj. split; eauto.
- pose proof (skeleton_cdts_dtor_names_unique (program_skeleton p)).
  unfold cdts_dtor_names_unique in H0.
  unfold cfunsigs_filterfun_l. clear - H0.
  generalize dependent (skeleton_dtors (program_skeleton p)). induction d; intros.
  + simpl. apply Unique_nil.
  + simpl. destruct a. destruct p0. destruct s.
    * case (eq_TypeName n (fst q)).
      -- simpl. apply Unique_cons.
         ++ inversion H0; subst. unfold not in *. intros. apply H2. clear - H.
            rewrite map_map in H. rewrite in_map_iff in H. do 2 (destruct H).
            rewrite filter_In in H0. destruct H0. destruct x. destruct p. rewrite <- H.
            simpl in *. rewrite in_map_iff. exists (s,l,t). simpl. split; auto.
            destruct s; try discriminate. auto.
         ++ inversion H0; subst. auto.
      -- inversion H0; subst. auto.
    * apply IHd. inversion H0; subst. auto.
- apply (skeleton_cfun_sigs_names_unique_l (program_skeleton p)).
Qed.

(**************************************************************************************************)
(** ** Proof of gfun_sigs_in_dts (gfuns well-formedness #1)                                       *)
(**************************************************************************************************)

Definition new_gfunsigs_g p n :=
  filter (fun x => match x with (n',_) => negb (eq_TypeName n (fst n')) end) (skeleton_gfun_sigs_g (program_skeleton p)).

Lemma new_gfun_sigs_in_cdts_g : forall (p : program) (n : TypeName),
  gfun_sigs_in_cdts (new_cdts p n) (new_gfunsigs_g p n).
Proof.
  intros p n. unfold gfun_sigs_in_cdts. unfold new_cdts.
  unfold new_gfunsigs_g. destruct p; simpl. clear - program_skeleton.
  destruct program_skeleton; simpl. clear - skeleton_gfun_sigs_in_cdts_g.
  unfold gfun_sigs_in_cdts in skeleton_gfun_sigs_in_cdts_g.
  induction skeleton_gfun_sigs_g.
  -simpl. apply Forall_nil.
  -simpl. destruct a as [a0 a1]. simpl. destruct (eq_TypeName n (fst a0)) eqn:E.
   +simpl. apply IHskeleton_gfun_sigs_g. inversion skeleton_gfun_sigs_in_cdts_g; subst. assumption.
   +simpl. apply Forall_cons.
    *simpl. inversion skeleton_gfun_sigs_in_cdts_g; subst. clear - E H1. simpl in H1. induction skeleton_cdts.
     **inversion H1.
     **simpl. destruct (eq_TypeName n a) eqn:E'.
       ***simpl. apply IHskeleton_cdts. simpl in H1. destruct H1.
          ****subst. rewrite E in E'. inversion E'.
          ****assumption.
       ***simpl. simpl in H1. destruct H1.
          ****subst. left. reflexivity.
          ****right. apply IHskeleton_cdts. assumption.
    *apply IHskeleton_gfun_sigs_g. inversion skeleton_gfun_sigs_in_cdts_g; subst. assumption.
Qed.

Definition new_gfunsigs_l p n :=
  filter (fun x => match x with (n',_) => negb (eq_TypeName n (fst n')) end) (skeleton_gfun_sigs_l (program_skeleton p)).

Lemma new_gfun_sigs_in_cdts_l : forall (p : program) (n : TypeName),
  gfun_sigs_in_cdts (new_cdts p n) (new_gfunsigs_l p n).
Proof.
  intros p n. unfold gfun_sigs_in_cdts. unfold new_cdts.
  unfold new_gfunsigs_l. destruct p; simpl. clear - program_skeleton.
  destruct program_skeleton; simpl. clear - skeleton_gfun_sigs_in_cdts_l.
  unfold gfun_sigs_in_cdts in skeleton_gfun_sigs_in_cdts_l.
  induction skeleton_gfun_sigs_l.
  -simpl. apply Forall_nil.
  -simpl. destruct a as [a0 a1]. simpl. destruct (eq_TypeName n (fst a0)) eqn:E.
   +simpl. apply IHskeleton_gfun_sigs_l. inversion skeleton_gfun_sigs_in_cdts_l; subst. assumption.
   +simpl. apply Forall_cons.
    *simpl. inversion skeleton_gfun_sigs_in_cdts_l; subst. clear - E H1. simpl in H1. induction skeleton_cdts.
     **inversion H1.
     **simpl. destruct (eq_TypeName n a) eqn:E'.
       ***simpl. apply IHskeleton_cdts. simpl in H1. destruct H1.
          ****subst. rewrite E in E'. inversion E'.
          ****assumption.
       ***simpl. simpl in H1. destruct H1.
          ****subst. left. reflexivity.
          ****right. apply IHskeleton_cdts. assumption.
    *apply IHskeleton_gfun_sigs_l. inversion skeleton_gfun_sigs_in_cdts_l; subst. assumption.
Qed.

(**************************************************************************************************)
(** ** Proof of gfun_sigs_names_unique (gfuns well-formedness #2)                                 *)
(**************************************************************************************************)

Lemma new_gfun_sigs_names_unique_g : forall (p : program) (n : TypeName),
  gfun_sigs_names_unique (new_gfunsigs_g p n).
Proof.
intros p n. unfold gfun_sigs_names_unique. unfold new_gfunsigs_g.
pose proof (skeleton_gfun_sigs_names_unique_g (program_skeleton p)).
unfold gfun_sigs_names_unique in H.
assert (forall l, filter (fun x : TypeName * Name * list TypeName => let (n', _) := x in negb (eq_TypeName n (fst n'))) l
 = filter (fun x : TypeName * Name * list TypeName => negb (eq_TypeName n (fst (fst x)))) l).
{ clear. intros. induction l; auto. simpl. destruct a. simpl. rewrite IHl. auto. }
rewrite H0.
rewrite filter_map with
  (g:=fun x : TypeName * Name => negb (eq_TypeName n (fst x)))
  (f:=fst). apply filter_unique. auto.
Qed.

Lemma new_gfun_sigs_names_unique_l : forall (p : program) (n : TypeName),
  gfun_sigs_names_unique (new_gfunsigs_l p n).
Proof.
intros p n. unfold gfun_sigs_names_unique. unfold new_gfunsigs_l.
pose proof (skeleton_gfun_sigs_names_unique_l (program_skeleton p)).
unfold gfun_sigs_names_unique in H.
assert (forall l, filter (fun x : TypeName * Name * list TypeName => let (n', _) := x in negb (eq_TypeName n (fst n'))) l
 = filter (fun x : TypeName * Name * list TypeName => negb (eq_TypeName n (fst (fst x)))) l).
{ clear. intros. induction l; auto. simpl. destruct a. simpl. rewrite IHl. auto. }
rewrite H0.
rewrite filter_map with
  (g:=fun x : TypeName * Name => negb (eq_TypeName n (fst x)))
  (f:=fst). apply filter_unique. auto.
Qed.

(**************************************************************************************************)
(** * Constructorize to Skeleton.                                                                *)
(**************************************************************************************************)

Definition constructorize_to_skeleton (p : program) (n : TypeName) : skeleton :=
  let newDatatype := (computeNewDatatype p n) in
  {|
    skeleton_dts := n :: skeleton_dts (program_skeleton p);
    skeleton_ctors := newDatatype ++ (skeleton_ctors (program_skeleton p));
    skeleton_dts_ctors_in_dts := new_dts_ctors_in_dts p n;
    skeleton_dts_ctor_names_unique := new_dts_ctor_names_unique p n;
    skeleton_cdts := new_cdts p n;
    skeleton_dtors := new_dtors p n;
    skeleton_cdts_dtors_in_cdts := new_cdts_dtors_in_cdts p n;
    skeleton_cdts_dtor_names_unique := new_cdts_dtor_names_unique p n;
    skeleton_dts_cdts_disjoint := new_d_cd_disj p n;
    skeleton_fun_sigs := skeleton_fun_sigs (program_skeleton p);
    skeleton_fun_sigs_names_unique := skeleton_fun_sigs_names_unique (program_skeleton p);
    skeleton_cfun_sigs_g := new_cfunsigs_g p n;
    skeleton_cfun_sigs_in_dts_g := new_cfun_sigs_in_dts_g p n;
    skeleton_cfun_sigs_names_unique_g := new_cfun_sigs_names_unique_g p n;
    skeleton_cfun_sigs_l := new_cfunsigs_l p n;
    skeleton_cfun_sigs_in_dts_l := new_cfun_sigs_in_dts_l p n;
    skeleton_cfun_sigs_names_unique_l := new_cfun_sigs_names_unique_l p n;
    skeleton_gfun_sigs_g := new_gfunsigs_g p n;
    skeleton_gfun_sigs_in_cdts_g := new_gfun_sigs_in_cdts_g p n;
    skeleton_gfun_sigs_names_unique_g := new_gfun_sigs_names_unique_g p n;
    skeleton_gfun_sigs_l := new_gfunsigs_l p n;
    skeleton_gfun_sigs_in_cdts_l := new_gfun_sigs_in_cdts_l p n;
    skeleton_gfun_sigs_names_unique_l := new_gfun_sigs_names_unique_l p n
  |}.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Correctness of instruction selection for integer division *)

Require Import String.
Require Import Coqlib Maps.
Require Import AST Errors Integers Floats.
Require Import Values Memory Globalenvs Events Cminor Op CminorSel.
Require Import SelectOp SelectOpproof SplitLong.

Local Open Scope cminorsel_scope.
Local Open Scope string_scope.

(** * Axiomatization of the helper functions *)

Definition external_implements (name: string) (sg: signature) (vargs: list val) (vres: val) : Prop :=
  forall F V (ge: Genv.t F V) m,
  external_call (EF_runtime name sg) ge vargs m E0 vres m.

Definition builtin_implements (name: string) (sg: signature) (vargs: list val) (vres: val) : Prop :=
  forall F V (ge: Genv.t F V) m,
  external_call (EF_builtin name sg) ge vargs m E0 vres m.

Axiom i64_helpers_correct :
    (forall x z, Val.longoffloat x = Some z -> external_implements "__compcert_i64_dtos" sig_f_l (x::nil) z)
 /\ (forall x z, Val.longuoffloat x = Some z -> external_implements "__compcert_i64_dtou" sig_f_l (x::nil) z)
 /\ (forall x z, Val.floatoflong x = Some z -> external_implements "__compcert_i64_stod" sig_l_f (x::nil) z)
 /\ (forall x z, Val.floatoflongu x = Some z -> external_implements "__compcert_i64_utod" sig_l_f (x::nil) z)
 /\ (forall x z, Val.singleoflong x = Some z -> external_implements "__compcert_i64_stof" sig_l_s (x::nil) z)
 /\ (forall x z, Val.singleoflongu x = Some z -> external_implements "__compcert_i64_utof" sig_l_s (x::nil) z)
 /\ (forall x, builtin_implements "__builtin_negl" sig_l_l (x::nil) (Val.negl x))
 /\ (forall x y, builtin_implements "__builtin_addl" sig_ll_l (x::y::nil) (Val.addl x y))
 /\ (forall x y, builtin_implements "__builtin_subl" sig_ll_l (x::y::nil) (Val.subl x y))
 /\ (forall x y, builtin_implements "__builtin_mull" sig_ii_l (x::y::nil) (Val.mull' x y))
 /\ (forall x y z, Val.divls x y = Some z -> external_implements "__compcert_i64_sdiv" sig_ll_l (x::y::nil) z)
 /\ (forall x y z, Val.divlu x y = Some z -> external_implements "__compcert_i64_udiv" sig_ll_l (x::y::nil) z)
 /\ (forall x y z, Val.modls x y = Some z -> external_implements "__compcert_i64_smod" sig_ll_l (x::y::nil) z)
 /\ (forall x y z, Val.modlu x y = Some z -> external_implements "__compcert_i64_umod" sig_ll_l (x::y::nil) z)
 /\ (forall x y, external_implements "__compcert_i64_shl" sig_li_l (x::y::nil) (Val.shll x y))
 /\ (forall x y, external_implements "__compcert_i64_shr" sig_li_l (x::y::nil) (Val.shrlu x y))
 /\ (forall x y, external_implements "__compcert_i64_sar" sig_li_l (x::y::nil) (Val.shrl x y))
 /\ (forall x y, external_implements "__compcert_i64_umulh" sig_ll_l (x::y::nil) (Val.mullhu x y))
 /\ (forall x y, external_implements "__compcert_i64_smulh" sig_ll_l (x::y::nil) (Val.mullhs x y)).

Definition helper_declared {F V: Type} (p: AST.program (AST.fundef F) V) (id: ident) (name: string) (sg: signature) : Prop :=
  (prog_defmap p)!id = Some (Gfun (External (EF_runtime name sg))).

Definition helper_functions_declared {F V: Type} (p: AST.program (AST.fundef F) V) (hf: helper_functions) : Prop :=
     helper_declared p i64_dtos "__compcert_i64_dtos" sig_f_l
  /\ helper_declared p i64_dtou "__compcert_i64_dtou" sig_f_l
  /\ helper_declared p i64_stod "__compcert_i64_stod" sig_l_f
  /\ helper_declared p i64_utod "__compcert_i64_utod" sig_l_f
  /\ helper_declared p i64_stof "__compcert_i64_stof" sig_l_s
  /\ helper_declared p i64_utof "__compcert_i64_utof" sig_l_s
  /\ helper_declared p i64_sdiv "__compcert_i64_sdiv" sig_ll_l
  /\ helper_declared p i64_udiv "__compcert_i64_udiv" sig_ll_l
  /\ helper_declared p i64_smod "__compcert_i64_smod" sig_ll_l
  /\ helper_declared p i64_umod "__compcert_i64_umod" sig_ll_l
  /\ helper_declared p i64_shl "__compcert_i64_shl" sig_li_l
  /\ helper_declared p i64_shr "__compcert_i64_shr" sig_li_l
  /\ helper_declared p i64_sar "__compcert_i64_sar" sig_li_l
  /\ helper_declared p i64_umulh "__compcert_i64_umulh" sig_ll_l
  /\ helper_declared p i64_smulh "__compcert_i64_smulh" sig_ll_l.

(** * Correctness of the instruction selection functions for 64-bit operators *)

Section CMCONSTR.

Variable prog: program.
Variable hf: helper_functions.
Hypothesis HELPERS: helper_functions_declared prog hf.
Let ge := Genv.globalenv prog.
Variable sp: val.
Variable e: env.
Variable m: mem.

Ltac UseHelper := decompose [Logic.and] i64_helpers_correct; eauto.
Ltac DeclHelper := red in HELPERS; decompose [Logic.and] HELPERS; eauto.

Lemma eval_helper:
  forall le id name sg args vargs vres,
  eval_exprlist ge sp e m le args vargs ->
  helper_declared prog id name sg  ->
  external_implements name sg vargs vres ->
  eval_expr ge sp e m le (Eexternal id sg args) vres.
Proof.
  intros.
  red in H0. apply Genv.find_def_symbol in H0. destruct H0 as (b & P & Q).
  rewrite <- Genv.find_funct_ptr_iff in Q.
  econstructor; eauto.
Qed.

Corollary eval_helper_1:
  forall le id name sg arg1 varg1 vres,
  eval_expr ge sp e m le arg1 varg1 ->
  helper_declared prog id name sg  ->
  external_implements name sg (varg1::nil) vres ->
  eval_expr ge sp e m le (Eexternal id sg (arg1 ::: Enil)) vres.
Proof.
  intros. eapply eval_helper; eauto. constructor; auto. constructor.
Qed.

Corollary eval_helper_2:
  forall le id name sg arg1 arg2 varg1 varg2 vres,
  eval_expr ge sp e m le arg1 varg1 ->
  eval_expr ge sp e m le arg2 varg2 ->
  helper_declared prog id name sg  ->
  external_implements name sg (varg1::varg2::nil) vres ->
  eval_expr ge sp e m le (Eexternal id sg (arg1 ::: arg2 ::: Enil)) vres.
Proof.
  intros. eapply eval_helper; eauto. constructor; auto. constructor; auto. constructor.
Qed.

Remark eval_builtin_1:
  forall le id sg arg1 varg1 vres,
  eval_expr ge sp e m le arg1 varg1 ->
  builtin_implements id sg (varg1::nil) vres ->
  eval_expr ge sp e m le (Ebuiltin (EF_builtin id sg) (arg1 ::: Enil)) vres.
Proof.
  intros. econstructor. econstructor. eauto. constructor. apply H0.
Qed.

Remark eval_builtin_2:
  forall le id sg arg1 arg2 varg1 varg2 vres,
  eval_expr ge sp e m le arg1 varg1 ->
  eval_expr ge sp e m le arg2 varg2 ->
  builtin_implements id sg (varg1::varg2::nil) vres ->
  eval_expr ge sp e m le (Ebuiltin (EF_builtin id sg) (arg1 ::: arg2 ::: Enil)) vres.
Proof.
  intros. econstructor. constructor; eauto. constructor; eauto. constructor. apply H1.
Qed.

Definition unary_constructor_sound (cstr: expr -> expr) (sem: val -> val) : Prop :=
  forall le a x,
  eval_expr ge sp e m le a x ->
  exists v, eval_expr ge sp e m le (cstr a) v /\ Val.lessdef (sem x) v.

Definition binary_constructor_sound (cstr: expr -> expr -> expr) (sem: val -> val -> val) : Prop :=
  forall le a x b y,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  exists v, eval_expr ge sp e m le (cstr a b) v /\ Val.lessdef (sem x y) v.

Ltac EvalOp :=
  eauto;
  match goal with
  | [ |- eval_exprlist _ _ _ _ _ Enil _ ] => constructor
  | [ |- eval_exprlist _ _ _ _ _ (_:::_) _ ] => econstructor; EvalOp
  | [ |- eval_expr _ _ _ _ _ (Eletvar _) _ ] => constructor; simpl; eauto
  | [ |- eval_expr _ _ _ _ _ (Elet _ _) _ ] => econstructor; EvalOp
  | [ |- eval_expr _ _ _ _ _ (lift _) _ ] => apply eval_lift; EvalOp
  | [ |- eval_expr _ _ _ _ _ _ _ ] => eapply eval_Eop; [EvalOp | simpl; eauto]
  | _ => idtac
  end.

Lemma eval_splitlong:
  forall le a f v sem,
  (forall le a b x y,
   eval_expr ge sp e m le a x ->
   eval_expr ge sp e m le b y ->
   exists v, eval_expr ge sp e m le (f a b) v /\
             (forall p q, x = Vint p -> y = Vint q -> v = sem (Vlong (Int64.ofwords p q)))) ->
  match v with Vlong _ => True | _ => sem v = Vundef end ->
  eval_expr ge sp e m le a v ->
  exists v', eval_expr ge sp e m le (splitlong a f) v' /\ Val.lessdef (sem v) v'.
Proof.
  intros until sem; intros EXEC UNDEF.
  unfold splitlong. case (splitlong_match a); intros.
- InvEval; subst.
  exploit EXEC. eexact H2. eexact H3. intros [v' [A B]].
  exists v'; split. auto.
  destruct v1; simpl in *; try (rewrite UNDEF; auto).
  destruct v0; simpl in *; try (rewrite UNDEF; auto).
  erewrite B; eauto.
- exploit (EXEC (v :: le) (Eop Ohighlong (Eletvar 0 ::: Enil)) (Eop Olowlong (Eletvar 0 ::: Enil))).
  EvalOp. EvalOp.
  intros [v' [A B]].
  exists v'; split. econstructor; eauto.
  destruct v; try (rewrite UNDEF; auto). erewrite B; simpl; eauto. rewrite Int64.ofwords_recompose. auto.
Qed.

Lemma eval_splitlong_strict:
  forall le a f va v,
  eval_expr ge sp e m le a (Vlong va) ->
  (forall le a1 a2,
     eval_expr ge sp e m le a1 (Vint (Int64.hiword va)) ->
     eval_expr ge sp e m le a2 (Vint (Int64.loword va)) ->
     eval_expr ge sp e m le (f a1 a2) v) ->
  eval_expr ge sp e m le (splitlong a f) v.
Proof.
  intros until v.
  unfold splitlong. case (splitlong_match a); intros.
- InvEval. destruct v1; simpl in H; try discriminate. destruct v0; inv H.
  apply H0. rewrite Int64.hi_ofwords; auto. rewrite Int64.lo_ofwords; auto.
- EvalOp. apply H0; EvalOp.
Qed.

Lemma eval_splitlong2:
  forall le a b f va vb sem,
  (forall le a1 a2 b1 b2 x1 x2 y1 y2,
   eval_expr ge sp e m le a1 x1 ->
   eval_expr ge sp e m le a2 x2 ->
   eval_expr ge sp e m le b1 y1 ->
   eval_expr ge sp e m le b2 y2 ->
   exists v,
     eval_expr ge sp e m le (f a1 a2 b1 b2) v /\
     (forall p1 p2 q1 q2,
       x1 = Vint p1 -> x2 = Vint p2 -> y1 = Vint q1 -> y2 = Vint q2 ->
       v = sem (Vlong (Int64.ofwords p1 p2)) (Vlong (Int64.ofwords q1 q2)))) ->
  match va, vb with Vlong _, Vlong _ => True | _, _ => sem va vb = Vundef end ->
  eval_expr ge sp e m le a va ->
  eval_expr ge sp e m le b vb ->
  exists v, eval_expr ge sp e m le (splitlong2 a b f) v /\ Val.lessdef (sem va vb) v.
Proof.
  intros until sem; intros EXEC UNDEF.
  unfold splitlong2. case (splitlong2_match a b); intros.
- InvEval; subst.
  exploit (EXEC le h1 l1 h2 l2); eauto. intros [v [A B]].
  exists v; split; auto.
  destruct v1; simpl in *; try (rewrite UNDEF; auto).
  destruct v0; try (rewrite UNDEF; auto).
  destruct v2; simpl in *; try (rewrite UNDEF; auto).
  destruct v3; try (rewrite UNDEF; auto).
  erewrite B; eauto.
- InvEval; subst.
  exploit (EXEC (vb :: le) (lift h1) (lift l1)
                (Eop Ohighlong (Eletvar 0 ::: Enil)) (Eop Olowlong (Eletvar 0 ::: Enil))).
  EvalOp. EvalOp. EvalOp. EvalOp.
  intros [v [A B]].
  exists v; split.
  econstructor; eauto.
  destruct v1; simpl in *; try (rewrite UNDEF; auto).
  destruct v0; try (rewrite UNDEF; auto).
  destruct vb; try (rewrite UNDEF; auto).
  erewrite B; simpl; eauto. rewrite Int64.ofwords_recompose. auto.
- InvEval; subst.
  exploit (EXEC (va :: le)
                (Eop Ohighlong (Eletvar 0 ::: Enil)) (Eop Olowlong (Eletvar 0 ::: Enil))
                (lift h2) (lift l2)).
  EvalOp. EvalOp. EvalOp. EvalOp.
  intros [v [A B]].
  exists v; split.
  econstructor; eauto.
  destruct va; try (rewrite UNDEF; auto).
  destruct v1; simpl in *; try (rewrite UNDEF; auto).
  destruct v0; try (rewrite UNDEF; auto).
  erewrite B; simpl; eauto. rewrite Int64.ofwords_recompose. auto.
- exploit (EXEC (vb :: va :: le)
                (Eop Ohighlong (Eletvar 1 ::: Enil)) (Eop Olowlong (Eletvar 1 ::: Enil))
                (Eop Ohighlong (Eletvar 0 ::: Enil)) (Eop Olowlong (Eletvar 0 ::: Enil))).
  EvalOp. EvalOp. EvalOp. EvalOp.
  intros [v [A B]].
  exists v; split. EvalOp.
  destruct va; try (rewrite UNDEF; auto); destruct vb; try (rewrite UNDEF; auto).
  erewrite B; simpl; eauto. rewrite ! Int64.ofwords_recompose; auto.
Qed.

Lemma eval_splitlong2_strict:
  forall le a b f va vb v,
  eval_expr ge sp e m le a (Vlong va) ->
  eval_expr ge sp e m le b (Vlong vb) ->
  (forall le a1 a2 b1 b2,
     eval_expr ge sp e m le a1 (Vint (Int64.hiword va)) ->
     eval_expr ge sp e m le a2 (Vint (Int64.loword va)) ->
     eval_expr ge sp e m le b1 (Vint (Int64.hiword vb)) ->
     eval_expr ge sp e m le b2 (Vint (Int64.loword vb)) ->
     eval_expr ge sp e m le (f a1 a2 b1 b2) v) ->
  eval_expr ge sp e m le (splitlong2 a b f) v.
Proof.
  assert (INV: forall v1 v2 n,
    Val.longofwords v1 v2 = Vlong n -> v1 = Vint(Int64.hiword n) /\ v2 = Vint(Int64.loword n)).
  {
    intros. destruct v1; simpl in H; try discriminate. destruct v2; inv H.
    rewrite Int64.hi_ofwords; rewrite Int64.lo_ofwords; auto.
  }
  intros until v.
  unfold splitlong2. case (splitlong2_match a b); intros.
- InvEval. exploit INV. eexact H. intros [EQ1 EQ2]. exploit INV. eexact H0. intros [EQ3 EQ4].
  subst. auto.
- InvEval. exploit INV; eauto. intros [EQ1 EQ2]. subst.
  econstructor. eauto. apply H1; EvalOp.
- InvEval. exploit INV; eauto. intros [EQ1 EQ2]. subst.
  econstructor. eauto. apply H1; EvalOp.
- EvalOp. apply H1; EvalOp.
Qed.

Lemma is_longconst_sound:
  forall le a x n,
  is_longconst a = Some n ->
  eval_expr ge sp e m le a x ->
  x = Vlong n.
Proof.
  unfold is_longconst; intros until n; intros LC.
  destruct (is_longconst_match a); intros.
  inv LC. InvEval. simpl in H5. inv H5. auto.
  discriminate.
Qed.

Lemma is_longconst_zero_sound:
  forall le a x,
  is_longconst_zero a = true ->
  eval_expr ge sp e m le a x ->
  x = Vlong Int64.zero.
Proof.
  unfold is_longconst_zero; intros.
  destruct (is_longconst a) as [n|] eqn:E; try discriminate.
  revert H. predSpec Int64.eq Int64.eq_spec n Int64.zero.
  intros. subst. eapply is_longconst_sound; eauto.
  congruence.
Qed.

Lemma eval_lowlong: unary_constructor_sound lowlong Val.loword.
Proof.
  unfold lowlong; red. intros until x. destruct (lowlong_match a); intros.
  InvEval; subst. exists v0; split; auto.
  destruct v1; simpl; auto. destruct v0; simpl; auto.
  rewrite Int64.lo_ofwords. auto.
  exists (Val.loword x); split; auto. EvalOp.
Qed.

Lemma eval_highlong: unary_constructor_sound highlong Val.hiword.
Proof.
  unfold highlong; red. intros until x. destruct (highlong_match a); intros.
  InvEval; subst. exists v1; split; auto.
  destruct v1; simpl; auto. destruct v0; simpl; auto.
  rewrite Int64.hi_ofwords. auto.
  exists (Val.hiword x); split; auto. EvalOp.
Qed.

Lemma eval_longconst:
  forall le n, eval_expr ge sp e m le (longconst n) (Vlong n).
Proof.
  intros. EvalOp. rewrite Int64.ofwords_recompose; auto.
Qed.

Theorem eval_intoflong: unary_constructor_sound intoflong Val.loword.
Proof eval_lowlong.

Theorem eval_longofintu: unary_constructor_sound longofintu Val.longofintu.
Proof.
  red; intros. unfold longofintu. econstructor; split. EvalOp.
  unfold Val.longofintu. destruct x; auto.
  replace (Int64.repr (Int.unsigned i)) with (Int64.ofwords Int.zero i); auto.
  apply Int64.same_bits_eq; intros.
  rewrite Int64.testbit_repr by auto.
  rewrite Int64.bits_ofwords by auto.
  fold (Int.testbit i i0).
  destruct (zlt i0 Int.zwordsize).
  auto.
  rewrite Int.bits_zero. rewrite Int.bits_above by omega. auto.
Qed.

Theorem eval_longofint: unary_constructor_sound longofint Val.longofint.
Proof.
  red; intros. unfold longofint. destruct (longofint_match a).
- InvEval. econstructor; split. apply eval_longconst. auto.
- exploit (eval_shrimm ge sp e m (Int.repr 31) (x :: le) (Eletvar 0)). EvalOp.
  intros [v1 [A B]].
  econstructor; split. EvalOp.
  destruct x; simpl; auto.
  simpl in B. inv B. simpl.
  replace (Int64.repr (Int.signed i))
     with (Int64.ofwords (Int.shr i (Int.repr 31)) i); auto.
  apply Int64.same_bits_eq; intros.
  rewrite Int64.testbit_repr by auto.
  rewrite Int64.bits_ofwords by auto.
  rewrite Int.bits_signed by omega.
  destruct (zlt i0 Int.zwordsize).
  auto.
  assert (Int64.zwordsize = 2 * Int.zwordsize) by reflexivity.
  rewrite Int.bits_shr by omega.
  change (Int.unsigned (Int.repr 31)) with (Int.zwordsize - 1).
  f_equal. destruct (zlt (i0 - Int.zwordsize + (Int.zwordsize - 1)) Int.zwordsize); omega.
Qed.

Theorem eval_negl: unary_constructor_sound negl Val.negl.
Proof.
  unfold negl; red; intros. destruct (is_longconst a) eqn:E.
  econstructor; split. apply eval_longconst.
  exploit is_longconst_sound; eauto. intros EQ; subst x. simpl. auto.
  econstructor; split. eapply eval_builtin_1; eauto. UseHelper. auto.
Qed.

Theorem eval_notl: unary_constructor_sound notl Val.notl.
Proof.
  red; intros. unfold notl. apply eval_splitlong; auto.
  intros.
  exploit eval_notint. eexact H0. intros [va [A B]].
  exploit eval_notint. eexact H1. intros [vb [C D]].
  exists (Val.longofwords va vb); split. EvalOp.
  intros; subst. simpl in *. inv B; inv D.
  simpl. unfold Int.not. rewrite <- Int64.decompose_xor. auto.
  destruct x; auto.
Qed.

Theorem eval_longoffloat:
  forall le a x y,
  eval_expr ge sp e m le a x ->
  Val.longoffloat x = Some y ->
  exists v, eval_expr ge sp e m le (longoffloat a) v /\ Val.lessdef y v.
Proof.
  intros; unfold longoffloat. econstructor; split.
  eapply eval_helper_1; eauto. DeclHelper. UseHelper. auto.
Qed.

Theorem eval_longuoffloat:
  forall le a x y,
  eval_expr ge sp e m le a x ->
  Val.longuoffloat x = Some y ->
  exists v, eval_expr ge sp e m le (longuoffloat a) v /\ Val.lessdef y v.
Proof.
  intros; unfold longuoffloat. econstructor; split.
  eapply eval_helper_1; eauto. DeclHelper. UseHelper. auto.
Qed.

Theorem eval_floatoflong:
  forall le a x y,
  eval_expr ge sp e m le a x ->
  Val.floatoflong x = Some y ->
  exists v, eval_expr ge sp e m le (floatoflong a) v /\ Val.lessdef y v.
Proof.
  intros; unfold floatoflong. econstructor; split.
  eapply eval_helper_1; eauto. DeclHelper. UseHelper. auto.
Qed.

Theorem eval_floatoflongu:
  forall le a x y,
  eval_expr ge sp e m le a x ->
  Val.floatoflongu x = Some y ->
  exists v, eval_expr ge sp e m le (floatoflongu a) v /\ Val.lessdef y v.
Proof.
  intros; unfold floatoflongu. econstructor; split.
  eapply eval_helper_1; eauto. DeclHelper. UseHelper. auto.
Qed.

Theorem eval_longofsingle:
  forall le a x y,
  eval_expr ge sp e m le a x ->
  Val.longofsingle x = Some y ->
  exists v, eval_expr ge sp e m le (longofsingle a) v /\ Val.lessdef y v.
Proof.
  intros; unfold longofsingle.
  destruct x; simpl in H0; inv H0. destruct (Float32.to_long f) as [n|] eqn:EQ; simpl in H2; inv H2.
  exploit eval_floatofsingle; eauto. intros (v & A & B). simpl in B. inv B.
  apply Float32.to_long_double in EQ.
  eapply eval_longoffloat; eauto. simpl.
  change (Float.of_single f) with (Float32.to_double f); rewrite EQ; auto.
Qed.

Theorem eval_longuofsingle:
  forall le a x y,
  eval_expr ge sp e m le a x ->
  Val.longuofsingle x = Some y ->
  exists v, eval_expr ge sp e m le (longuofsingle a) v /\ Val.lessdef y v.
Proof.
  intros; unfold longuofsingle.
  destruct x; simpl in H0; inv H0. destruct (Float32.to_longu f) as [n|] eqn:EQ; simpl in H2; inv H2.
  exploit eval_floatofsingle; eauto. intros (v & A & B). simpl in B. inv B.
  apply Float32.to_longu_double in EQ.
  eapply eval_longuoffloat; eauto. simpl.
  change (Float.of_single f) with (Float32.to_double f); rewrite EQ; auto.
Qed.

Theorem eval_singleoflong:
  forall le a x y,
  eval_expr ge sp e m le a x ->
  Val.singleoflong x = Some y ->
  exists v, eval_expr ge sp e m le (singleoflong a) v /\ Val.lessdef y v.
Proof.
  intros; unfold singleoflong. econstructor; split.
  eapply eval_helper_1; eauto. DeclHelper. UseHelper. auto.
Qed.

Theorem eval_singleoflongu:
  forall le a x y,
  eval_expr ge sp e m le a x ->
  Val.singleoflongu x = Some y ->
  exists v, eval_expr ge sp e m le (singleoflongu a) v /\ Val.lessdef y v.
Proof.
  intros; unfold singleoflongu. econstructor; split.
  eapply eval_helper_1; eauto. DeclHelper. UseHelper. auto.
Qed.

Theorem eval_andl: binary_constructor_sound andl Val.andl.
Proof.
  red; intros. unfold andl. apply eval_splitlong2; auto.
  intros.
  exploit eval_and. eexact H1. eexact H3. intros [va [A B]].
  exploit eval_and. eexact H2. eexact H4. intros [vb [C D]].
  exists (Val.longofwords va vb); split. EvalOp.
  intros; subst. simpl in B; inv B. simpl in D; inv D.
  simpl. f_equal. rewrite Int64.decompose_and. auto.
  destruct x; auto. destruct y; auto.
Qed.

Theorem eval_orl: binary_constructor_sound orl Val.orl.
Proof.
  red; intros. unfold orl. apply eval_splitlong2; auto.
  intros.
  exploit eval_or. eexact H1. eexact H3. intros [va [A B]].
  exploit eval_or. eexact H2. eexact H4. intros [vb [C D]].
  exists (Val.longofwords va vb); split. EvalOp.
  intros; subst. simpl in B; inv B. simpl in D; inv D.
  simpl. f_equal. rewrite Int64.decompose_or. auto.
  destruct x; auto. destruct y; auto.
Qed.

Theorem eval_xorl: binary_constructor_sound xorl Val.xorl.
Proof.
  red; intros. unfold xorl. apply eval_splitlong2; auto.
  intros.
  exploit eval_xor. eexact H1. eexact H3. intros [va [A B]].
  exploit eval_xor. eexact H2. eexact H4. intros [vb [C D]].
  exists (Val.longofwords va vb); split. EvalOp.
  intros; subst. simpl in B; inv B. simpl in D; inv D.
  simpl. f_equal. rewrite Int64.decompose_xor. auto.
  destruct x; auto. destruct y; auto.
Qed.

Lemma is_intconst_sound:
  forall le a x n,
  is_intconst a = Some n ->
  eval_expr ge sp e m le a x ->
  x = Vint n.
Proof.
  unfold is_intconst; intros until n; intros LC.
  destruct a; try discriminate. destruct o; try discriminate. destruct e0; try discriminate.
  inv LC. intros. InvEval. auto.
Qed.

Remark eval_shift_imm:
  forall (P: expr -> Prop) n a0 a1 a2 a3,
  (n = Int.zero -> P a0) ->
  (0 <= Int.unsigned n < Int.zwordsize ->
   Int.ltu n Int.iwordsize = true ->
   Int.ltu (Int.sub Int.iwordsize n) Int.iwordsize = true ->
   Int.ltu n Int64.iwordsize' = true ->
   P a1) ->
  (Int.zwordsize <= Int.unsigned n < Int64.zwordsize ->
   Int.ltu (Int.sub n Int.iwordsize) Int.iwordsize = true ->
   P a2) ->
  P a3 ->
  P (if Int.eq n Int.zero then a0
     else if Int.ltu n Int.iwordsize then a1
     else if Int.ltu n Int64.iwordsize' then a2
     else a3).
Proof.
  intros until a3; intros A0 A1 A2 A3.
  predSpec Int.eq Int.eq_spec n Int.zero.
  apply A0; auto.
  assert (NZ: Int.unsigned n <> 0).
  { red; intros. elim H. rewrite <- (Int.repr_unsigned n). rewrite H0. auto. }
  destruct (Int.ltu n Int.iwordsize) eqn:LT.
  exploit Int.ltu_iwordsize_inv; eauto. intros RANGE.
  assert (0 <= Int.zwordsize - Int.unsigned n < Int.zwordsize) by omega.
  apply A1. auto. auto.
  unfold Int.ltu, Int.sub. rewrite Int.unsigned_repr_wordsize.
  rewrite Int.unsigned_repr. rewrite zlt_true; auto. omega.
  generalize Int.wordsize_max_unsigned; omega.
  unfold Int.ltu. rewrite zlt_true; auto.
  change (Int.unsigned Int64.iwordsize') with 64.
  change Int.zwordsize with 32 in RANGE. omega.
  destruct (Int.ltu n Int64.iwordsize') eqn:LT'.
  exploit Int.ltu_inv; eauto.
  change (Int.unsigned Int64.iwordsize') with (Int.zwordsize * 2).
  intros RANGE.
  assert (Int.zwordsize <= Int.unsigned n).
    unfold Int.ltu in LT. rewrite Int.unsigned_repr_wordsize in LT.
    destruct (zlt (Int.unsigned n) Int.zwordsize). discriminate. omega.
  apply A2. tauto. unfold Int.ltu, Int.sub. rewrite Int.unsigned_repr_wordsize.
  rewrite Int.unsigned_repr. rewrite zlt_true; auto. omega.
  generalize Int.wordsize_max_unsigned; omega.
  auto.
Qed.

Lemma eval_shllimm:
  forall n,
  unary_constructor_sound (fun e => shllimm e n) (fun v => Val.shll v (Vint n)).
Proof.
  unfold shllimm; red; intros.
  apply eval_shift_imm; intros.
  + (* n = 0 *)
    subst n. exists x; split; auto. destruct x; simpl; auto.
    change (Int64.shl' i Int.zero) with (Int64.shl i Int64.zero).
    rewrite Int64.shl_zero. auto.
  + (* 0 < n < 32 *)
    apply eval_splitlong with (sem := fun x => Val.shll x (Vint n)); auto.
    intros.
    exploit eval_shlimm. eexact H4. instantiate (1 := n). intros [v1 [A1 B1]].
    exploit eval_shlimm. eexact H5. instantiate (1 := n). intros [v2 [A2 B2]].
    exploit eval_shruimm. eexact H5. instantiate (1 := Int.sub Int.iwordsize n). intros [v3 [A3 B3]].
    exploit eval_or. eexact A1. eexact A3. intros [v4 [A4 B4]].
    econstructor; split. EvalOp.
    intros. subst. simpl in *. rewrite H1 in *. rewrite H2 in *. rewrite H3.
    inv B1; inv B2; inv B3. simpl in B4. inv B4.
    simpl. rewrite Int64.decompose_shl_1; auto.
    destruct x; auto.
  + (* 32 <= n < 64 *)
    exploit eval_lowlong. eexact H. intros [v1 [A1 B1]].
    exploit eval_shlimm. eexact A1. instantiate (1 := Int.sub n Int.iwordsize). intros [v2 [A2 B2]].
    econstructor; split. EvalOp.
    destruct x; simpl; auto.
    destruct (Int.ltu n Int64.iwordsize'); auto.
    simpl in B1; inv B1. simpl in B2. rewrite H1 in B2. inv B2.
    simpl. erewrite <- Int64.decompose_shl_2. instantiate (1 := Int64.hiword i).
    rewrite Int64.ofwords_recompose. auto. auto.
  + (* n >= 64 *)
    econstructor; split. eapply eval_helper_2; eauto. EvalOp. DeclHelper. UseHelper. auto.
Qed.

Theorem eval_shll: binary_constructor_sound shll Val.shll.
Proof.
  unfold shll; red; intros.
  destruct (is_intconst b) as [n|] eqn:IC.
- (* Immediate *)
  exploit is_intconst_sound; eauto. intros EQ; subst y; clear H0.
  eapply eval_shllimm; eauto.
- (* General case *)
  econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto.
Qed.

Lemma eval_shrluimm:
  forall n,
  unary_constructor_sound (fun e => shrluimm e n) (fun v => Val.shrlu v (Vint n)).
Proof.
  unfold shrluimm; red; intros. apply eval_shift_imm; intros.
  + (* n = 0 *)
    subst n. exists x; split; auto. destruct x; simpl; auto.
    change (Int64.shru' i Int.zero) with (Int64.shru i Int64.zero).
    rewrite Int64.shru_zero. auto.
  + (* 0 < n < 32 *)
    apply eval_splitlong with (sem := fun x => Val.shrlu x (Vint n)); auto.
    intros.
    exploit eval_shruimm. eexact H5. instantiate (1 := n). intros [v1 [A1 B1]].
    exploit eval_shruimm. eexact H4. instantiate (1 := n). intros [v2 [A2 B2]].
    exploit eval_shlimm. eexact H4. instantiate (1 := Int.sub Int.iwordsize n). intros [v3 [A3 B3]].
    exploit eval_or. eexact A1. eexact A3. intros [v4 [A4 B4]].
    econstructor; split. EvalOp.
    intros. subst. simpl in *. rewrite H1 in *. rewrite H2 in *. rewrite H3.
    inv B1; inv B2; inv B3. simpl in B4. inv B4.
    simpl. rewrite Int64.decompose_shru_1; auto.
    destruct x; auto.
  + (* 32 <= n < 64 *)
    exploit eval_highlong. eexact H. intros [v1 [A1 B1]].
    exploit eval_shruimm. eexact A1. instantiate (1 := Int.sub n Int.iwordsize). intros [v2 [A2 B2]].
    econstructor; split. EvalOp.
    destruct x; simpl; auto.
    destruct (Int.ltu n Int64.iwordsize'); auto.
    simpl in B1; inv B1. simpl in B2. rewrite H1 in B2. inv B2.
    simpl. erewrite <- Int64.decompose_shru_2. instantiate (1 := Int64.loword i).
    rewrite Int64.ofwords_recompose. auto. auto.
  + (* n >= 64 *)
    econstructor; split. eapply eval_helper_2; eauto. EvalOp. DeclHelper. UseHelper. auto.
Qed.

Theorem eval_shrlu: binary_constructor_sound shrlu Val.shrlu.
Proof.
  unfold shrlu; red; intros.
  destruct (is_intconst b) as [n|] eqn:IC.
- (* Immediate *)
  exploit is_intconst_sound; eauto. intros EQ; subst y; clear H0.
  eapply eval_shrluimm; eauto.
- (* General case *)
  econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto.
Qed.

Lemma eval_shrlimm:
  forall n,
  unary_constructor_sound (fun e => shrlimm e n) (fun v => Val.shrl v (Vint n)).
Proof.
  unfold shrlimm; red; intros. apply eval_shift_imm; intros.
  + (* n = 0 *)
    subst n. exists x; split; auto. destruct x; simpl; auto.
    change (Int64.shr' i Int.zero) with (Int64.shr i Int64.zero).
    rewrite Int64.shr_zero. auto.
  + (* 0 < n < 32 *)
    apply eval_splitlong with (sem := fun x => Val.shrl x (Vint n)); auto.
    intros.
    exploit eval_shruimm. eexact H5. instantiate (1 := n). intros [v1 [A1 B1]].
    exploit eval_shrimm. eexact H4. instantiate (1 := n). intros [v2 [A2 B2]].
    exploit eval_shlimm. eexact H4. instantiate (1 := Int.sub Int.iwordsize n). intros [v3 [A3 B3]].
    exploit eval_or. eexact A1. eexact A3. intros [v4 [A4 B4]].
    econstructor; split. EvalOp.
    intros. subst. simpl in *. rewrite H1 in *. rewrite H2 in *. rewrite H3.
    inv B1; inv B2; inv B3. simpl in B4. inv B4.
    simpl. rewrite Int64.decompose_shr_1; auto.
    destruct x; auto.
  + (* 32 <= n < 64 *)
    exploit eval_highlong. eexact H. intros [v1 [A1 B1]].
    assert (eval_expr ge sp e m (v1 :: le) (Eletvar 0) v1) by EvalOp.
    exploit eval_shrimm. eexact H2. instantiate (1 := Int.sub n Int.iwordsize). intros [v2 [A2 B2]].
    exploit eval_shrimm. eexact H2. instantiate (1 := Int.repr 31). intros [v3 [A3 B3]].
    econstructor; split. EvalOp.
    destruct x; simpl; auto.
    destruct (Int.ltu n Int64.iwordsize'); auto.
    simpl in B1; inv B1. simpl in B2. rewrite H1 in B2. inv B2.
    simpl in B3. inv B3.
    change (Int.ltu (Int.repr 31) Int.iwordsize) with true. simpl.
    erewrite <- Int64.decompose_shr_2. instantiate (1 := Int64.loword i).
    rewrite Int64.ofwords_recompose. auto. auto.
  + (* n >= 64 *)
    econstructor; split. eapply eval_helper_2; eauto. EvalOp. DeclHelper. UseHelper. auto.
Qed.

Theorem eval_shrl: binary_constructor_sound shrl Val.shrl.
Proof.
  unfold shrl; red; intros.
  destruct (is_intconst b) as [n|] eqn:IC.
- (* Immediate *)
  exploit is_intconst_sound; eauto. intros EQ; subst y; clear H0.
  eapply eval_shrlimm; eauto.
- (* General case *)
  econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto.
Qed.

Theorem eval_addl: Archi.ptr64 = false -> binary_constructor_sound addl Val.addl.
Proof.
  unfold addl; red; intros.
  set (default := Ebuiltin (EF_builtin "__builtin_addl" sig_ll_l) (a ::: b ::: Enil)).
  assert (DEFAULT:
    exists v, eval_expr ge sp e m le default v /\ Val.lessdef (Val.addl x y) v).
  {
    econstructor; split. eapply eval_builtin_2; eauto. UseHelper. auto.
  }
  destruct (is_longconst a) as [p|] eqn:LC1;
  destruct (is_longconst b) as [q|] eqn:LC2.
- exploit (is_longconst_sound le a); eauto. intros EQ; subst x.
  exploit (is_longconst_sound le b); eauto. intros EQ; subst y.
  econstructor; split. apply eval_longconst. simpl; auto.
- predSpec Int64.eq Int64.eq_spec p Int64.zero; auto.
  subst p. exploit (is_longconst_sound le a); eauto. intros EQ; subst x.
  exists y; split; auto. unfold Val.addl; rewrite H; destruct y; auto. rewrite Int64.add_zero_l; auto.
- predSpec Int64.eq Int64.eq_spec q Int64.zero; auto.
  subst q. exploit (is_longconst_sound le b); eauto. intros EQ; subst y.
  exists x; split; auto. unfold Val.addl; rewrite H; destruct x; simpl; auto. rewrite Int64.add_zero; auto.
- auto.
Qed.

Theorem eval_subl: Archi.ptr64 = false -> binary_constructor_sound subl Val.subl.
Proof.
  unfold subl; red; intros.
  set (default := Ebuiltin (EF_builtin "__builtin_subl" sig_ll_l) (a ::: b ::: Enil)).
  assert (DEFAULT:
    exists v, eval_expr ge sp e m le default v /\ Val.lessdef (Val.subl x y) v).
  {
    econstructor; split. eapply eval_builtin_2; eauto. UseHelper. auto.
  }
  destruct (is_longconst a) as [p|] eqn:LC1;
  destruct (is_longconst b) as [q|] eqn:LC2.
- exploit (is_longconst_sound le a); eauto. intros EQ; subst x.
  exploit (is_longconst_sound le b); eauto. intros EQ; subst y.
  econstructor; split. apply eval_longconst. simpl; auto.
- predSpec Int64.eq Int64.eq_spec p Int64.zero; auto.
  replace (Val.subl x y) with (Val.negl y). eapply eval_negl; eauto.
  subst p. exploit (is_longconst_sound le a); eauto. intros EQ; subst x.
  destruct y; simpl; auto.
- predSpec Int64.eq Int64.eq_spec q Int64.zero; auto.
  subst q. exploit (is_longconst_sound le b); eauto. intros EQ; subst y.
  exists x; split; auto. unfold Val.subl; rewrite H; destruct x; simpl; auto. rewrite Int64.sub_zero_l; auto.
- auto.
Qed.

Lemma eval_mull_base: binary_constructor_sound mull_base Val.mull.
Proof.
  unfold mull_base; red; intros. apply eval_splitlong2; auto.
- intros.
  set (p := Val.mull' x2 y2). set (le1 := p :: le0).
  assert (E1: eval_expr ge sp e m le1 (Eop Olowlong (Eletvar O ::: Enil)) (Val.loword p)) by EvalOp.
  assert (E2: eval_expr ge sp e m le1 (Eop Ohighlong (Eletvar O ::: Enil)) (Val.hiword p)) by EvalOp.
  exploit eval_mul. apply eval_lift. eexact H2. apply eval_lift. eexact H3.
  instantiate (1 := p). fold le1. intros [v3 [E3 L3]].
  exploit eval_mul. apply eval_lift. eexact H1. apply eval_lift. eexact H4.
  instantiate (1 := p). fold le1. intros [v4 [E4 L4]].
  exploit eval_add. eexact E2. eexact E3. intros [v5 [E5 L5]].
  exploit eval_add. eexact E5. eexact E4. intros [v6 [E6 L6]].
  exists (Val.longofwords v6 (Val.loword p)); split.
  EvalOp. eapply eval_builtin_2; eauto. UseHelper.
  intros. unfold le1, p in *; subst; simpl in *.
  inv L3. inv L4. inv L5. simpl in L6. inv L6.
  simpl. f_equal. symmetry. apply Int64.decompose_mul.
- destruct x; auto; destruct y; auto.
Qed.

Lemma eval_mullimm:
  forall n, unary_constructor_sound (mullimm n) (fun v => Val.mull v (Vlong n)).
Proof.
  unfold mullimm; red; intros.
  predSpec Int64.eq Int64.eq_spec n Int64.zero.
  subst n. econstructor; split. apply eval_longconst.
  destruct x; simpl; auto. rewrite Int64.mul_zero. auto.
  predSpec Int64.eq Int64.eq_spec n Int64.one.
  subst n. exists x; split; auto.
  destruct x; simpl; auto. rewrite Int64.mul_one. auto.
  destruct (Int64.is_power2' n) as [l|] eqn:P2.
  exploit eval_shllimm. eauto. instantiate (1 := l). intros [v [A B]].
  exists v; split; auto.
  destruct x; simpl; auto.
  erewrite Int64.mul_pow2' by eauto.
  simpl in B. erewrite Int64.is_power2'_range in B by eauto.
  exact B.
  apply eval_mull_base; auto. apply eval_longconst.
Qed.

Theorem eval_mull: binary_constructor_sound mull Val.mull.
Proof.
  unfold mull; red; intros.
  destruct (is_longconst a) as [p|] eqn:LC1;
  destruct (is_longconst b) as [q|] eqn:LC2.
- exploit (is_longconst_sound le a); eauto. intros EQ; subst x.
  exploit (is_longconst_sound le b); eauto. intros EQ; subst y.
  econstructor; split. apply eval_longconst. simpl; auto.
- exploit (is_longconst_sound le a); eauto. intros EQ; subst x.
  replace (Val.mull (Vlong p) y) with (Val.mull y (Vlong p)) in *.
  eapply eval_mullimm; eauto.
  destruct y; simpl; auto. rewrite Int64.mul_commut; auto.
- exploit (is_longconst_sound le b); eauto. intros EQ; subst y.
  eapply eval_mullimm; eauto.
- apply eval_mull_base; auto.
Qed.

Theorem eval_mullhu:
  forall n, unary_constructor_sound (fun a => mullhu a n) (fun v => Val.mullhu v (Vlong n)).
Proof.
  unfold mullhu; intros; red; intros. econstructor; split; eauto.
  eapply eval_helper_2; eauto. apply eval_longconst. DeclHelper; eauto. UseHelper.
Qed.

Theorem eval_mullhs:
  forall n, unary_constructor_sound (fun a => mullhs a n) (fun v => Val.mullhs v (Vlong n)).
Proof.
  unfold mullhs; intros; red; intros. econstructor; split; eauto.
  eapply eval_helper_2; eauto. apply eval_longconst. DeclHelper; eauto. UseHelper.
Qed.

Theorem eval_shrxlimm:
  forall le a n x z,
  Archi.ptr64 = false ->
  eval_expr ge sp e m le a x ->
  Val.shrxl x (Vint n) = Some z ->
  exists v, eval_expr ge sp e m le (shrxlimm a n) v /\ Val.lessdef z v.
Proof.
  intros.
  apply Val.shrxl_shrl_2 in H1. unfold shrxlimm.
  destruct (Int.eq n Int.zero).
- subst z; exists x; auto.
- set (le' := x :: le).
  edestruct (eval_shrlimm (Int.repr 63) le' (Eletvar O)) as (v1 & A1 & B1).
  constructor. reflexivity.
  edestruct (eval_shrluimm (Int.sub (Int.repr 64) n) le') as (v2 & A2 & B2).
  eexact A1.
  edestruct (eval_addl H le' (Eletvar 0)) as (v3 & A3 & B3).
  constructor. reflexivity. eexact A2.
  edestruct (eval_shrlimm n le') as (v4 & A4 & B4). eexact A3.
  exists v4; split.
  econstructor; eauto.
  assert (X: forall v1 v2 n, Val.lessdef v1 v2 -> Val.lessdef (Val.shrl v1 (Vint n)) (Val.shrl v2 (Vint n))).
  { intros. inv H2; auto. }
  assert (Y: forall v1 v2 n, Val.lessdef v1 v2 -> Val.lessdef (Val.shrlu v1 (Vint n)) (Val.shrlu v2 (Vint n))).
  { intros. inv H2; auto. }
  subst z. eapply Val.lessdef_trans; [|eexact B4]. apply X.
  eapply Val.lessdef_trans; [|eexact B3]. apply Val.addl_lessdef; auto.
  eapply Val.lessdef_trans; [|eexact B2]. apply Y.
  auto.
Qed.

Theorem eval_divlu_base:
  forall le a b x y z,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  Val.divlu x y = Some z ->
  exists v, eval_expr ge sp e m le (divlu_base a b) v /\ Val.lessdef z v.
Proof.
  intros; unfold divlu_base.
  econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto.
Qed.

Theorem eval_modlu_base:
  forall le a b x y z,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  Val.modlu x y = Some z ->
  exists v, eval_expr ge sp e m le (modlu_base a b) v /\ Val.lessdef z v.
Proof.
  intros; unfold modlu_base.
  econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto.
Qed.

Theorem eval_divls_base:
  forall le a b x y z,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  Val.divls x y = Some z ->
  exists v, eval_expr ge sp e m le (divls_base a b) v /\ Val.lessdef z v.
Proof.
  intros; unfold divls_base.
  econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto.
Qed.

Theorem eval_modls_base:
  forall le a b x y z,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  Val.modls x y = Some z ->
  exists v, eval_expr ge sp e m le (modls_base a b) v /\ Val.lessdef z v.
Proof.
  intros; unfold modls_base.
  econstructor; split. eapply eval_helper_2; eauto. DeclHelper. UseHelper. auto.
Qed.

Remark decompose_cmpl_eq_zero:
  forall h l,
  Int64.eq (Int64.ofwords h l) Int64.zero = Int.eq (Int.or h l) Int.zero.
Proof.
  intros.
  assert (Int64.zwordsize = Int.zwordsize * 2) by reflexivity.
  predSpec Int64.eq Int64.eq_spec (Int64.ofwords h l) Int64.zero.
  replace (Int.or h l) with Int.zero. rewrite Int.eq_true. auto.
  apply Int.same_bits_eq; intros.
  rewrite Int.bits_zero. rewrite Int.bits_or by auto.
  symmetry. apply orb_false_intro.
  transitivity (Int64.testbit (Int64.ofwords h l) (i + Int.zwordsize)).
  rewrite Int64.bits_ofwords by omega. rewrite zlt_false by omega. f_equal; omega.
  rewrite H0. apply Int64.bits_zero.
  transitivity (Int64.testbit (Int64.ofwords h l) i).
  rewrite Int64.bits_ofwords by omega. rewrite zlt_true by omega. auto.
  rewrite H0. apply Int64.bits_zero.
  symmetry. apply Int.eq_false. red; intros; elim H0.
  apply Int64.same_bits_eq; intros.
  rewrite Int64.bits_zero. rewrite Int64.bits_ofwords by auto.
  destruct (zlt i Int.zwordsize).
  assert (Int.testbit (Int.or h l) i = false) by (rewrite H1; apply Int.bits_zero).
  rewrite Int.bits_or in H3 by omega. exploit orb_false_elim; eauto. tauto.
  assert (Int.testbit (Int.or h l) (i - Int.zwordsize) = false) by (rewrite H1; apply Int.bits_zero).
  rewrite Int.bits_or in H3 by omega. exploit orb_false_elim; eauto. tauto.
Qed.

Lemma eval_cmpl_eq_zero:
  forall le a x,
  eval_expr ge sp e m le a (Vlong x) ->
  eval_expr ge sp e m le (cmpl_eq_zero a) (Val.of_bool (Int64.eq x Int64.zero)).
Proof.
  intros. unfold cmpl_eq_zero.
  eapply eval_splitlong_strict; eauto. intros.
  exploit eval_or. eexact H0. eexact H1. intros [v1 [A1 B1]]. simpl in B1; inv B1.
  exploit eval_comp. eexact A1. instantiate (2 := Eop (Ointconst Int.zero) Enil). EvalOp.
  instantiate (1 := Ceq). intros [v2 [A2 B2]].
  unfold Val.cmp in B2; simpl in B2.
  rewrite <- decompose_cmpl_eq_zero in B2.
  rewrite Int64.ofwords_recompose in B2.
  destruct (Int64.eq x Int64.zero); inv B2; auto.
Qed.

Lemma eval_cmpl_ne_zero:
  forall le a x,
  eval_expr ge sp e m le a (Vlong x) ->
  eval_expr ge sp e m le (cmpl_ne_zero a) (Val.of_bool (negb (Int64.eq x Int64.zero))).
Proof.
  intros. unfold cmpl_ne_zero.
  eapply eval_splitlong_strict; eauto. intros.
  exploit eval_or. eexact H0. eexact H1. intros [v1 [A1 B1]]. simpl in B1; inv B1.
  exploit eval_comp. eexact A1. instantiate (2 := Eop (Ointconst Int.zero) Enil). EvalOp.
  instantiate (1 := Cne). intros [v2 [A2 B2]].
  unfold Val.cmp in B2; simpl in B2.
  rewrite <- decompose_cmpl_eq_zero in B2.
  rewrite Int64.ofwords_recompose in B2.
  destruct (negb (Int64.eq x Int64.zero)); inv B2; auto.
Qed.

Lemma eval_cmplu_gen:
  forall ch cl a b le x y,
  eval_expr ge sp e m le a (Vlong x) ->
  eval_expr ge sp e m le b (Vlong y) ->
  eval_expr ge sp e m le (cmplu_gen ch cl a b)
    (Val.of_bool (if Int.eq (Int64.hiword x) (Int64.hiword y)
                  then Int.cmpu cl (Int64.loword x) (Int64.loword y)
                  else Int.cmpu ch (Int64.hiword x) (Int64.hiword y))).
Proof.
  intros. unfold cmplu_gen. eapply eval_splitlong2_strict; eauto. intros.
  econstructor. econstructor. EvalOp. simpl. eauto.
  destruct (Int.eq (Int64.hiword x) (Int64.hiword y)); EvalOp.
Qed.

Remark int64_eq_xor:
  forall p q, Int64.eq p q = Int64.eq (Int64.xor p q) Int64.zero.
Proof.
  intros.
  predSpec Int64.eq Int64.eq_spec p q.
  subst q. rewrite Int64.xor_idem. rewrite Int64.eq_true. auto.
  predSpec Int64.eq Int64.eq_spec (Int64.xor p q) Int64.zero.
  elim H. apply Int64.xor_zero_equal; auto.
  auto.
Qed.

Theorem eval_cmplu:
  forall c le a x b y v,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  Val.cmplu (Mem.valid_pointer m) c x y = Some v ->
  Archi.ptr64 = false ->
  eval_expr ge sp e m le (cmplu c a b) v.
Proof.
  intros. unfold Val.cmplu, Val.cmplu_bool in H1. rewrite H2 in H1. simpl in H1.
  destruct x; simpl in H1; try discriminate H1; destruct y; inv H1.
  rename i into x. rename i0 into y.
  destruct c; simpl.
- (* Ceq *)
  exploit eval_xorl. eexact H. eexact H0. intros [v1 [A B]]. simpl in B. inv B.
  rewrite int64_eq_xor. apply eval_cmpl_eq_zero; auto.
- (* Cne *)
  exploit eval_xorl. eexact H. eexact H0. intros [v1 [A B]]. simpl in B. inv B.
  rewrite int64_eq_xor. apply eval_cmpl_ne_zero; auto.
- (* Clt *)
  exploit (eval_cmplu_gen Clt Clt). eexact H. eexact H0. simpl.
  rewrite <- Int64.decompose_ltu. rewrite ! Int64.ofwords_recompose. auto.
- (* Cle *)
  exploit (eval_cmplu_gen Clt Cle). eexact H. eexact H0. intros.
  rewrite <- (Int64.ofwords_recompose x). rewrite <- (Int64.ofwords_recompose y).
  rewrite Int64.decompose_leu. auto.
- (* Cgt *)
  exploit (eval_cmplu_gen Cgt Cgt). eexact H. eexact H0. simpl.
  rewrite Int.eq_sym. rewrite <- Int64.decompose_ltu. rewrite ! Int64.ofwords_recompose. auto.
- (* Cge *)
  exploit (eval_cmplu_gen Cgt Cge). eexact H. eexact H0. intros.
  rewrite <- (Int64.ofwords_recompose x). rewrite <- (Int64.ofwords_recompose y).
  rewrite Int64.decompose_leu. rewrite Int.eq_sym. auto.
Qed.

Lemma eval_cmpl_gen:
  forall ch cl a b le x y,
  eval_expr ge sp e m le a (Vlong x) ->
  eval_expr ge sp e m le b (Vlong y) ->
  eval_expr ge sp e m le (cmpl_gen ch cl a b)
    (Val.of_bool (if Int.eq (Int64.hiword x) (Int64.hiword y)
                  then Int.cmpu cl (Int64.loword x) (Int64.loword y)
                  else Int.cmp ch (Int64.hiword x) (Int64.hiword y))).
Proof.
  intros. unfold cmpl_gen. eapply eval_splitlong2_strict; eauto. intros.
  econstructor. econstructor. EvalOp. simpl. eauto.
  destruct (Int.eq (Int64.hiword x) (Int64.hiword y)); EvalOp.
Qed.

Remark decompose_cmpl_lt_zero:
  forall h l,
  Int64.lt (Int64.ofwords h l) Int64.zero = Int.lt h Int.zero.
Proof.
  intros.
  generalize (Int64.shru_lt_zero (Int64.ofwords h l)).
  change (Int64.shru (Int64.ofwords h l) (Int64.repr (Int64.zwordsize - 1)))
    with (Int64.shru' (Int64.ofwords h l) (Int.repr 63)).
  rewrite Int64.decompose_shru_2.
  change (Int.sub (Int.repr 63) Int.iwordsize)
    with (Int.repr (Int.zwordsize - 1)).
  rewrite Int.shru_lt_zero.
  destruct (Int64.lt (Int64.ofwords h l) Int64.zero); destruct (Int.lt h Int.zero); auto; intros.
  elim Int64.one_not_zero. auto.
  elim Int64.one_not_zero. auto.
  vm_compute. intuition congruence.
Qed.

Theorem eval_cmpl:
  forall c le a x b y v,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  Val.cmpl c x y = Some v ->
  eval_expr ge sp e m le (cmpl c a b) v.
Proof.
  intros. unfold Val.cmpl in H1.
  destruct x; simpl in H1; try discriminate. destruct y; inv H1.
  rename i into x. rename i0 into y.
  destruct c; simpl.
- (* Ceq *)
  exploit eval_xorl. eexact H. eexact H0. intros [v1 [A B]]. simpl in B; inv B.
  rewrite int64_eq_xor. apply eval_cmpl_eq_zero; auto.
- (* Cne *)
  exploit eval_xorl. eexact H. eexact H0. intros [v1 [A B]]. simpl in B; inv B.
  rewrite int64_eq_xor. apply eval_cmpl_ne_zero; auto.
- (* Clt *)
  destruct (is_longconst_zero b) eqn:LC.
+ exploit is_longconst_zero_sound; eauto. intros EQ; inv EQ; clear H0.
  exploit eval_highlong. eexact H. intros [v1 [A1 B1]]. simpl in B1. inv B1.
  exploit eval_comp. eexact A1.
  instantiate (2 := Eop (Ointconst Int.zero) Enil). EvalOp.
  instantiate (1 := Clt). intros [v2 [A2 B2]].
  unfold Val.cmp in B2. simpl in B2.
  rewrite <- (Int64.ofwords_recompose x). rewrite decompose_cmpl_lt_zero.
  destruct (Int.lt (Int64.hiword x) Int.zero); inv B2; auto.
+ exploit (eval_cmpl_gen Clt Clt). eexact H. eexact H0. simpl.
  rewrite <- Int64.decompose_lt. rewrite ! Int64.ofwords_recompose. auto.
- (* Cle *)
  exploit (eval_cmpl_gen Clt Cle). eexact H. eexact H0. intros.
  rewrite <- (Int64.ofwords_recompose x). rewrite <- (Int64.ofwords_recompose y).
  rewrite Int64.decompose_le. auto.
- (* Cgt *)
  exploit (eval_cmpl_gen Cgt Cgt). eexact H. eexact H0. simpl.
  rewrite Int.eq_sym. rewrite <- Int64.decompose_lt. rewrite ! Int64.ofwords_recompose. auto.
- (* Cge *)
  destruct (is_longconst_zero b) eqn:LC.
+ exploit is_longconst_zero_sound; eauto. intros EQ; inv EQ; clear H0.
  exploit eval_highlong. eexact H. intros [v1 [A1 B1]]. simpl in B1; inv B1.
  exploit eval_comp. eexact A1.
  instantiate (2 := Eop (Ointconst Int.zero) Enil). EvalOp.
  instantiate (1 := Cge). intros [v2 [A2 B2]].
  unfold Val.cmp in B2; simpl in B2.
  rewrite <- (Int64.ofwords_recompose x). rewrite decompose_cmpl_lt_zero.
  destruct (negb (Int.lt (Int64.hiword x) Int.zero)); inv B2; auto.
+ exploit (eval_cmpl_gen Cgt Cge). eexact H. eexact H0. intros.
  rewrite <- (Int64.ofwords_recompose x). rewrite <- (Int64.ofwords_recompose y).
  rewrite Int64.decompose_le. rewrite Int.eq_sym. auto.
Qed.

End CMCONSTR.


(* heap_lang with deterministic allocation *)
From stdpp Require Import base gmap.
From iris.proofmode Require Import base proofmode classes.
From iris.heap_lang Require Import lang primitive_laws.
From iris_ni.program_logic Require Import dwp heap_lang_lifting.

(** A simple allocator only knows about the state.
    In the future we can also make it aware of the threadpool.
*)
Module Type Allocator.
Parameter oracle : state -> Z -> loc.
Axiom oracle_fresh : ∀ σ n (i : Z), (0 ≤ i)%Z → (i < n)%Z → (heap σ) !! (oracle σ n +ₗ i) = None.
End Allocator.

Module SimpleAllocator : Allocator.
  Definition oracle σ (n : Z) := fresh_locs (dom (gset loc) σ.(heap)).
  Lemma oracle_fresh : ∀ σ n (i : Z), (0 ≤ i)%Z → (i < n)%Z → (heap σ) !! (oracle σ n +ₗ i) = None.
  Proof.
    intros σ n i Hi Hn. eapply (not_elem_of_dom (D:=gset loc)).
    by apply fresh_locs_fresh.
  Qed.
End SimpleAllocator.

Module heap_lang_det (A : Allocator).

Inductive head_step : expr → state → list observation → expr → state → list expr → Prop :=
  | RecS f x e σ :
     head_step (Rec f x e) σ [] (Val $ RecV f x e) σ []
  | PairS v1 v2 σ :
     head_step (Pair (Val v1) (Val v2)) σ [] (Val $ PairV v1 v2) σ []
  | InjLS v σ :
     head_step (InjL $ Val v) σ [] (Val $ InjLV v) σ []
  | InjRS v σ :
     head_step (InjR $ Val v) σ [] (Val $ InjRV v) σ []
  | BetaS f x e1 v2 e' σ :
     e' = subst' x v2 (subst' f (RecV f x e1) e1) →
     head_step (App (Val $ RecV f x e1) (Val v2)) σ [] e' σ []
  | UnOpS op v v' σ :
     un_op_eval op v = Some v' →
     head_step (UnOp op (Val v)) σ [] (Val v') σ []
  | BinOpS op v1 v2 v' σ :
     bin_op_eval op v1 v2 = Some v' →
     head_step (BinOp op (Val v1) (Val v2)) σ [] (Val v') σ []
  | IfTrueS e1 e2 σ :
     head_step (If (Val $ LitV $ LitBool true) e1 e2) σ [] e1 σ []
  | IfFalseS e1 e2 σ :
     head_step (If (Val $ LitV $ LitBool false) e1 e2) σ [] e2 σ []
  | FstS v1 v2 σ :
     head_step (Fst (Val $ PairV v1 v2)) σ [] (Val v1) σ []
  | SndS v1 v2 σ :
     head_step (Snd (Val $ PairV v1 v2)) σ [] (Val v2) σ []
  | CaseLS v e1 e2 σ :
     head_step (Case (Val $ InjLV v) e1 e2) σ [] (App e1 (Val v)) σ []
  | CaseRS v e1 e2 σ :
     head_step (Case (Val $ InjRV v) e1 e2) σ [] (App e2 (Val v)) σ []
  | ForkS e σ:
     head_step (Fork e) σ [] (Val $ LitV LitUnit) σ [e]
  | AllocNS n v σ :
      let l := A.oracle σ n in
     (0 < n)%Z →
     (∀ i, (0 ≤ i)%Z → (i < n)%Z → σ.(heap) !! (l +ₗ i) = None) →
     head_step (AllocN (Val $ LitV $ LitInt n) (Val v)) σ
               []
               (Val $ LitV $ LitLoc l) (state_init_heap l n v σ)
               []
  | FreeS l v σ :
     σ.(heap) !! l = Some $ Some v →
     head_step (Free (Val $ LitV $ LitLoc l)) σ
               []
               (Val $ LitV LitUnit) (state_upd_heap <[l:=None]> σ)
               []
  | LoadS l v σ :
     σ.(heap) !! l = Some $ Some v →
     head_step (Load (Val $ LitV $ LitLoc l)) σ [] (of_val v) σ []
  | StoreS l v0 v σ :
     σ.(heap) !! l = Some $ Some v0 →
     head_step (Store (Val $ LitV $ LitLoc l) (Val v)) σ
               []
               (Val $ LitV LitUnit) (state_upd_heap <[l:=Some v]> σ)
               []
  | XchgS l v1 v2 σ :
     σ.(heap) !! l = Some $ Some v1 →
     head_step (Xchg (Val $ LitV $ LitLoc l) (Val v2)) σ
               []
               (Val v1) (state_upd_heap <[l:=Some v2]> σ)
               []
  | CmpXchgS l v1 v2 vl σ b :
     σ.(heap) !! l = Some $ Some vl →
     (* Crucially, this compares the same way as [EqOp]! *)
     vals_compare_safe vl v1 →
     b = bool_decide (vl = v1) →
     head_step (CmpXchg (Val $ LitV $ LitLoc l) (Val v1) (Val v2)) σ
               []
               (Val $ PairV vl (LitV $ LitBool b)) (if b then state_upd_heap <[l:=Some v2]> σ else σ)
               []
  | FaaS l i1 i2 σ :
     σ.(heap) !! l = Some $ Some (LitV (LitInt i1)) →
     head_step (FAA (Val $ LitV $ LitLoc l) (Val $ LitV $ LitInt i2)) σ
               []
               (Val $ LitV $ LitInt i1) (state_upd_heap <[l:=Some $ LitV (LitInt (i1 + i2))]>σ)
               []
  | NewProphS σ :
     let p := fresh σ.(used_proph_id) in
     head_step NewProph σ
               []
               (Val $ LitV $ LitProphecy p) (state_upd_used_proph_id ({[ p ]} ∪.) σ)
               []
  | ResolveS p v e σ w σ' κs ts :
     head_step e σ κs (Val v) σ' ts →
     head_step (Resolve e (Val $ LitV $ LitProphecy p) (Val w)) σ
               (κs ++ [(p, (v, w))]) (Val v) σ' ts.

Ltac inv_head_step :=
  repeat match goal with
  | _ => progress simplify_map_eq/= (* simplify memory stuff *)
  | H : to_val _ = Some _ |- _ => apply of_to_val in H
  | H : head_step ?e _ _ _ _ _ |- _ =>
     inversion H; subst; clear H
  end.

Local Hint Extern 0 (head_reducible _ _) => eexists _, _, _, _; simpl : core.
Local Hint Extern 0 (head_reducible_no_obs _ _) => eexists _, _, _; simpl : core.

(* [simpl apply] is too stupid, so we need extern hints here. *)
Local Hint Extern 1 (head_step _ _ _ _ _ _) => econstructor : core.
Local Hint Extern 0 (head_step (CmpXchg _ _ _) _ _ _ _ _) => eapply CmpXchgS : core.
Local Hint Extern 0 (head_step (AllocN _ _) _ _ _ _ _) => apply alloc_fresh : core.
Local Hint Extern 0 (head_step NewProph _ _ _ _ _) => apply new_proph_id_fresh : core.
Local Hint Resolve to_of_val : core.

(** The op sem is actually deterministic. *)
Theorem head_step_det e σ e'1 σ'1 obs1 efs1 e'2 σ'2 obs2 efs2 :
  head_step e σ obs1 e'1 σ'1 efs1 →
  head_step e σ obs2 e'2 σ'2 efs2 →
  obs1 = obs2 ∧ e'1 = e'2 ∧ σ'1 = σ'2 ∧ efs1 = efs2.
Proof.
  intros Hst1. revert obs2 e'2 σ'2 efs2.
  induction Hst1; intros obs2 e'2 σ'2 efs2;
    inversion 1; repeat simplify_map_eq/=; eauto.
  specialize (IHHst1 κs0 (Val v0) σ'2 efs2).
  assert (v = v0) as <-.
  { enough (Val v = Val v0); first by simplify_eq/=.
    by apply IHHst1. }
  repeat split; try f_equiv; eauto; by apply IHHst1.
Qed.

(** Basic properties *)
#[local] Instance fill_item_inj Ki : Inj (=) (=) (fill_item Ki).
Proof. induction Ki; intros ???; simplify_eq/=; auto with f_equal. Qed.

Lemma fill_item_val Ki e :
  is_Some (to_val (fill_item Ki e)) → is_Some (to_val e).
Proof. intros [v ?]. induction Ki; simplify_option_eq; eauto. Qed.

Lemma val_head_stuck e1 σ1 κ e2 σ2 efs : head_step e1 σ1 κ e2 σ2 efs → to_val e1 = None.
Proof. destruct 1; naive_solver. Qed.

Lemma head_ctx_step_val Ki e σ1 κ e2 σ2 efs :
  head_step (fill_item Ki e) σ1 κ e2 σ2 efs → is_Some (to_val e).
Proof. revert κ e2. induction Ki; inversion_clear 1; simplify_option_eq; eauto. Qed.

Lemma fill_item_no_val_inj Ki1 Ki2 e1 e2 :
  to_val e1 = None → to_val e2 = None →
  fill_item Ki1 e1 = fill_item Ki2 e2 → Ki1 = Ki2.
Proof. revert Ki1. induction Ki2, Ki1; naive_solver eauto with f_equal. Qed.

Lemma heap_lang_det_mixin : EctxiLanguageMixin of_val to_val fill_item head_step.
Proof.
  split; apply _ || eauto using to_of_val, of_to_val, val_head_stuck,
    fill_item_val, fill_item_no_val_inj, head_ctx_step_val.
Qed.

Canonical Structure heap_ectxi_lang_det := EctxiLanguage heap_lang_det_mixin.
Canonical Structure heap_ectx_lang_det := EctxLanguageOfEctxi heap_ectxi_lang_det.
Canonical Structure heap_lang_det := LanguageOfEctx heap_ectx_lang_det.

(** Different relations between the deterministic and non-deterministic semantics *)

Lemma head_step_det_nondet e σ e' σ' κs efs :
  head_step e σ κs e' σ' efs →
  heap_lang.head_step e σ κs e' σ' efs.
Proof.
  induction 1; try econstructor; eauto.
  - unfold p. apply is_fresh.
Qed.

Lemma prim_step_det_nondet e σ e' σ' κs efs :
  prim_step (Λ := heap_ectx_lang_det) e σ κs e' σ' efs →
  prim_step (Λ := heap_ectx_lang) e σ κs e' σ' efs.
Proof.
  inversion 1. subst. econstructor; try done. by apply head_step_det_nondet.
Qed.

Lemma head_step_nondet_det_val e v σ σ' κs efs e2 σ'2 κs2 efs2 :
  heap_lang.head_step e σ κs (Val v) σ' efs →
  head_step e σ κs2 e2 σ'2 efs2 →
  is_Some (to_val e2).
Proof.
  intros Hst_nondet Hst_det.
  inversion Hst_nondet; inversion Hst_det; simplify_eq/=; eauto.
  exists v. rewrite -H. eauto.
Qed.

Lemma head_reducible_nondet_det e σ :
  head_reducible (Λ := heap_ectx_lang) e σ →
  head_reducible (Λ := heap_ectx_lang_det) e σ.
Proof.
  destruct 1 as (κs&e2&σ2&efs&H).
  induction H; try by (do 4 eexists; econstructor; eauto).
  - repeat econstructor; eauto=> i Hi Hn.
    by apply A.oracle_fresh.
  - destruct IHhead_step as (κs2&e2&σ2&efs2&Hst_det). simpl in *.
    assert (is_Some (to_val e2)) as [v2 Hv2].
    { by eapply head_step_nondet_det_val. }
    repeat econstructor.
    rewrite -(of_to_val _ _ Hv2) in Hst_det. done.
Qed.

Lemma reducible_det_nondet e σ :
  reducible (Λ := heap_lang_det) e σ →
  reducible (Λ := heap_lang) e σ.
Proof.
  destruct 1 as (κs & e' & σ' & efs & H).
  inversion H. simpl in *. subst e e'.
  do 4 eexists. econstructor; try naive_solver.
  by apply head_step_det_nondet.
Qed.

Lemma reducible_nondet_det e σ :
  reducible (Λ := heap_lang) e σ →
  reducible (Λ := heap_lang_det) e σ.
Proof.
  destruct 1 as (κs & e' & σ' & efs & H).
  inversion H. simpl in *. subst e e'.
  apply (@head_prim_fill_reducible heap_ectxi_lang_det).
  apply head_reducible_nondet_det.
  by repeat eexists.
Qed.

Lemma head_step_nondet_det_obs e1 σ1 e2 σ2 efs e2' σ2' efs' κ :
  heap_lang.head_step e1 σ1 [] e2 σ2 efs →
  head_step e1 σ1 κ e2' σ2' efs' →
  κ = [].
Proof.
  intros Hst1 Hst2.
  inversion Hst2; try by eauto.
  simpl in * ; subst.
  inversion Hst1. exfalso.
  by eapply app_cons_not_nil.
Qed.

Lemma head_reducible_no_obs_nondet_det e σ :
  head_reducible_no_obs (Λ := heap_ectx_lang) e σ →
  head_reducible_no_obs (Λ := heap_ectx_lang_det) e σ.
Proof.
  destruct 1 as (e'&σ'&efs&Hst).
  assert (head_reducible (Λ := heap_ectx_lang_det) e σ) as Hred2.
  { apply head_reducible_nondet_det. eauto. }
  destruct Hred2 as (κ&e''&σ''&efs''&Hst2).
  assert (κ = []) as ->.
  { eapply head_step_nondet_det_obs; eauto. }
  eauto.
Qed.

Lemma reducible_no_obs_nondet_det e σ :
  reducible_no_obs (Λ := heap_lang) e σ →
  reducible_no_obs (Λ := heap_lang_det) e σ.
Proof.
  destruct 1 as (e' & σ' & efs & H).
  inversion H. simpl in *. subst e e'.
  apply (@head_prim_fill_reducible_no_obs heap_ectxi_lang_det).
  apply head_reducible_no_obs_nondet_det.
  by repeat eexists.
Qed.

Section lifting.

#[local] Instance heapG_irisG_det `{!heapGS Σ} : irisGS heap_lang_det Σ := {
  iris_invGS := heapGS_invGS;
  state_interp σ _ κs _ :=
    (gen_heap_interp σ.(heap) ∗ proph_map_interp κs σ.(used_proph_id))%I;
  fork_post _ := True%I;
  num_laters_per_step := λ _, 0;
  state_interp_mono _ _ _ _ := fupd_intro _ _;
}.

Context `{!heapGS Σ}.
Implicit Types Φ Ψ : val → iProp Σ.

Lemma wp_simul e E Φ :
  (wp (EXPR := language.expr heap_lang    ) (VAL := language.val heap_lang    ) NotStuck E e Φ) -∗
  (wp (EXPR := language.expr heap_lang_det) (VAL := language.val heap_lang_det) NotStuck E e Φ).
Proof.
  iLöb as "IH" forall (e E Φ).
  rewrite !wp_unfold /wp_pre /=.
  destruct (to_val e) as [v|]; first by eauto.
  iIntros "H". iIntros (σ1 m κ κs n) "[Hσ Hp]".
  iMod ("H" $! σ1 m κ κs n with "[$Hσ $Hp]") as "[% H]".
  iModIntro. iSplitR.
  { iPureIntro. by apply reducible_nondet_det. }
  iIntros (e2 σ2 efs Hst_det).
  iSpecialize ("H" $! e2 σ2 efs with "[%]").
  { by apply prim_step_det_nondet. }
  iMod "H" as "H". iModIntro. iNext.
  iMod "H" as "H". iModIntro.
  iMod "H" as "($&HWP&Hefs)". iModIntro.
  iSplitL "HWP".
  - by iApply "IH".
  - iApply (big_sepL_impl with "Hefs []").
    iModIntro. iIntros (???). iApply "IH".
Qed.
End lifting.

Section dwp_lifting.

#[local] Instance heapDG_irisDG_det `{heapDG Σ} : irisDG heap_lang_det Σ := {
  state_rel := (λ σ1 σ2 κs1 κs2,
      @gen_heap_interp _ _ _ _ _ heapDG_gen_heapG1 σ1.(heap)
    ∗ @proph_map_interp _ _ _ _ _ heapDG_proph_mapG1 κs1 σ1.(used_proph_id)
    ∗ @gen_heap_interp _ _ _ _ _ heapDG_gen_heapG2 σ2.(heap)
    ∗ @proph_map_interp _ _ _ _ _ heapDG_proph_mapG2 κs2 σ2.(used_proph_id))%I
}.

Context `{!heapDG Σ}.

Lemma dwp_simul e1 e2 E Φ :
  (dwp (Λ := heap_lang) E e1 e2 Φ) -∗
  (dwp (Λ := heap_lang_det) E e1 e2 Φ).
Proof.
  iLöb as "IH" forall (e1 e2 E Φ).
  rewrite !dwp_unfold /dwp_pre /=.
  repeat case_match; [by eauto with iFrame..|].
  iIntros "H". iIntros (σ1 σ2 κ1 κs1 κ2 κs2) "(Hσ1 & Hp1 & Hσ2 & Hp2)".
  iMod ("H" with "[$Hσ1 $Hp1 $Hσ2 $Hp2]") as "[% [% H]]".
  iModIntro. iSplitR.
  { iPureIntro. by apply reducible_no_obs_nondet_det. }
  iSplitR.
  { iPureIntro. by apply reducible_no_obs_nondet_det. }
  iIntros (e1' σ1' efs1 e2' σ2' efs2 Hst_det1 Hst_det2).
  iSpecialize ("H" $! e1' σ1' efs1 e2' σ2' efs2 with "[%] [%]").
  { by apply prim_step_det_nondet. }
  { by apply prim_step_det_nondet. }
  iMod "H" as "H". iModIntro.
  iNext. iMod "H" as "H". iModIntro.
  iDestruct "H" as "($&HWP&Hefs)".
  iSplitL "HWP".
  - by iApply "IH".
  - iApply (big_sepL2_impl with "Hefs []").
    iModIntro. iIntros (?????). iApply "IH".
Qed.

End dwp_lifting.

End heap_lang_det.