(*

  Copyright 2016 University of Luxembourg

  This file is part of our formalization of Platzer's
    "A Complete Uniform Substitution Calculus for Differential Dynamic Logic"
  available here: http://arxiv.org/pdf/1601.06183.pdf (July 27, 2016).
  We refer to this formalization as DdlCoq here.

  DdlCoq is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  DdlCoq is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with DdlCoq.  If not, see <http://www.gnu.org/licenses/>.

  authors:
    Vincent Rahli
    Marcus Völp
    Ivana Vukotic

 *)

Require Export fcset.

(* ========= About KAssignable ========= *)

(** is KAssignable in list *)
Definition in_KAssignable_dec (a : KAssignable) l :=
  in_dec KAssignable_dec a l.

(** lists of KAssignables are disjoint *)
Definition KAssignables_disj (l1 l2 : list KAssignable) : bool :=
  disj_dec KAssignable_dec l1 l2.

(** list l1 included in list l2 --- non-strict *)
Definition KAssignables_included (l1 l2 : list KAssignable) : bool :=
  included_dec KAssignable_dec l1 l2.

(* substraction (minus) for KAssagnables *)
Definition KAssignables_minus (l1 l2 : list KAssignable) :=
  minus_dec KAssignable_dec l1 l2.

(** intersection of 2 KAssignable lists *)
Definition KAssignables_inter (l1 l2 : list KAssignable) :=
  inter_dec KAssignable_dec l1 l2.

(* ========= About EAssignable ========= *)

(* To be able to remove assignables from eassignables, EA_all should hold
   a list of assignables as such: [EA_all l], corresponding to the collection
   of all variables except l.
 *)
(* EA_all [] represents V U V' *)
Definition EAssignables := @FCset KAssignable.

(** is KAssignable in EAssignables *)
Definition in_eassignables (a : KAssignable) (e : EAssignables) : bool :=
  in_fcset KAssignable_dec a e.

(** EAssignables e1 and e2 are disjoint *)
Definition eassignables_disj (e1 e2 : EAssignables) : bool :=
  fcset_disj KAssignable_dec e1 e2.

(** returns true if one EAssignable is subset of another *)
Definition eassignables_subset (e1 e2 : EAssignables) : bool :=
  fcset_subset KAssignable_dec e1 e2.

Definition EA_assignables (l : list KAssignable) := FCS_finite l.
Definition EA_all (l : list KAssignable) := FCS_infinite l.

(** append for EAssignables *)
Definition EAssignables_app (e1 e2 : EAssignables) : EAssignables :=
  fcset_app KAssignable_dec e1 e2.

(** intersection of EAssignables *)
Definition EAssignables_inter (e1 e2 : EAssignables) : EAssignables :=
  fcset_inter KAssignable_dec e1 e2.

Definition remove_assignables
           (e : EAssignables)
           (vs : list KAssignable) : EAssignables :=
  fcset_remove_list KAssignable_dec e vs.

Definition remove_eassignables (l1 l2 : EAssignables) : EAssignables :=
  fcset_remove KAssignable_dec l1 l2.

(*========= some KAssignables/EAssignables lemmas =========*)

(** a is in subtraction (minus) of two KAssignable lists,
than a is element of first list and it's not in second list *)
Lemma in_KAssignables_minus :
  forall a l1 l2,
    List.In a (KAssignables_minus l1 l2)
    <-> (List.In a l1 /\ ~ List.In a l2).
Proof.
  apply in_minus_dec.
Qed.

(** a is in intersection of two KAssignable lists,
then a is in both lists *)
Lemma in_KAssignables_inter :
  forall a l1 l2,
    List.In a (KAssignables_inter l1 l2)
    <-> (List.In a l1 /\ List.In a l2).
Proof.
  apply in_inter_dec.
Qed.

(**

  if a is not in intersection of two KAssignable lists,
  then a is not element of either of them

 *)
Lemma in_eassignables_app_false_implies :
  forall a e1 e2,
    in_eassignables a (EAssignables_app e1 e2) = false
    ->
    (
      in_eassignables a e1 = false
      /\
      in_eassignables a e2 = false
    ).
Proof.
  apply in_fcset_app_false_implies.
Qed.

(**

  a is in intersectopn of two EAssignables,
  iff a is element of one of them

 *)
Lemma in_eassignables_app_true_iff :
  forall a e1 e2,
    in_eassignables a (EAssignables_app e1 e2) = true
    <->
    (
      in_eassignables a e1 = true
      \/
      in_eassignables a e2 = true
    ).
Proof.
  apply in_fcset_app_true_iff.
Qed.

(** iff v is in EA_assignables l, then v is in list l *)
Lemma in_eassignables_assignables :
  forall v l,
    in_eassignables v (EA_assignables l) = true
    <-> List.In v l.
Proof.
  apply in_fcset_finite.
Qed.

(** if KAssignables form l1 are included in l2 than l1 is subset of l2 *)
Lemma KAssignables_included_prop :
  forall l1 l2,
    KAssignables_included l1 l2 = true
    <-> subset l1 l2.
Proof.
  apply included_dec_prop.
Qed.
Hint Rewrite KAssignables_included_prop : core.

(** returns true if EAssignables are subset of list of KAssignables *)
Definition eassignables_subset_assignables
           (e : EAssignables)
           (l : list KAssignable) : bool :=
  fcset_subset_list KAssignable_dec e l.

(** if EAssignables e is subset of list of KAssignables l,
as well as a is in e, then a is in lilst l *)
Lemma eassignables_subset_assignables_prop :
  forall e l a,
    eassignables_subset_assignables e l = true
    -> in_eassignables a e = true
    -> List.In a l.
Proof.
  apply fset_subset_list_prop.
Qed.

(** if two list of KAssignables l1 and l2 are disjoint, then l1 and l2 are disjoint *)
Lemma KAssignables_disj_prop :
  forall l1 l2,
    KAssignables_disj l1 l2 = true
    <-> disjoint l1 l2.
Proof.
  apply disj_dec_prop.
Qed.
Hint Rewrite KAssignables_disj_prop : core.

(** if EAssignables e1 is subset of EAssignables subset e2,
and a is in e1 then a is in e2 *)
Lemma eassignables_subset_prop :
  forall e1 e2 a,
    eassignables_subset e1 e2 = true
    -> in_eassignables a e1 = true
    -> in_eassignables a e2 = true.
Proof.
  apply fcset_subset_prop.
Qed.

(** conversion form variable to KAssigable *)
Definition KAssignable_x : KAssignable :=
  KAssignVar (variable "x").

(** we need this in order to prove eassignables_subset_iff lemma *)
Fixpoint KAssignable2str (a : KAssignable) : String.string :=
  match a with
  | KAssignVar (variable x) => x
  | KAssignDiff x => KAssignable2str x
  end.

Lemma fresh_kvariable : FreshFun KVariable.
Proof.
  unfold FreshFun.
  introv.

  exists (variable (String.append "x" (append_string_list (map KVariable2string l)))).
  remember ("x") as extra.
  assert (0 < String.length extra)%nat as len by (subst; simpl; auto).
  clear Heqextra.
  revert dependent extra.
  induction l; introv s; allsimpl; tcsp.
  rw string_append_assoc.
  introv k; repndors;[|apply IHl in k;auto;rw string_length_append; omega].

  match goal with
  | [ H : ?a = ?b |- _ ] =>
    assert (KVariable2string a = KVariable2string b) as xx by (rewrite <- H; auto)
  end.
  simpl in xx.
  unfold KAssignable2string in xx.

  assert (String.length a
          = String.length
              (String.append
                 (String.append extra a)
                 (append_string_list (map KVariable2string l)))) as e.
  { rewrite <- xx; auto. }
  allrw string_length_append.
  omega.
Defined.

(** we need this in order to prove eassignables_subset_iff lemma *)
Lemma fresh_string : FreshFun String.string.
Proof.
  unfold FreshFun.
  introv.

  exists (String.append "x" (append_string_list l)).
  remember ("x") as extra.
  assert (0 < String.length extra)%nat as len by (subst; simpl; auto).
  clear Heqextra.
  revert dependent extra.
  induction l; introv s; allsimpl; tcsp.
  rw string_append_assoc.
  introv k; repndors;[|apply IHl in k;auto;rw string_length_append; omega].

  assert (String.length a
          = String.length
              (String.append
                 (String.append extra a)
                 (append_string_list l))) as e by (rw <- k; auto).
  allrw string_length_append.
  omega.
Defined.

(** we need this in order to prove eassignables_subset_iff lemma *)
Lemma fresh_kassignable : FreshFun KAssignable.
Proof.
  unfold FreshFun.
  introv.

  exists (KAssignVar (variable (String.append "x" (append_string_list (map KAssignable2string l))))).
  remember ("x") as extra.
  assert (0 < String.length extra)%nat as len by (subst; simpl; auto).
  clear Heqextra.
  revert dependent extra.
  induction l; introv s; allsimpl; tcsp.
  rw string_append_assoc.
  introv k; repndors;[|apply IHl in k;auto;rw string_length_append; omega].

  match goal with
  | [ H : ?a = ?b |- _ ] =>
    assert (KAssignable2str a = KAssignable2str b) as xx by (rewrite <- H; auto)
  end.
  simpl in xx.
  unfold KAssignable2string in xx.

  assert (String.length a
          = String.length
              (String.append
                 (String.append extra a)
                 (append_string_list (map KAssignable2string l)))) as e.
  { unfold KAssignable2string.
    rewrite <- xx.
    clear xx k s extra IHl l.
    induction a; simpl; auto. }
  allrw string_length_append.
  omega.
Defined.

(** iff a is in EAssignables e1 from which EAssignables e2 are removed,
ihant a is in e1, and it's not in e2 *)
Lemma in_eassignables_remove_eassignables :
  forall a e1 e2,
    in_eassignables a (remove_eassignables e1 e2) = true
    <-> (in_eassignables a e1 = true /\ not (in_eassignables a e2 = true)).
Proof.
  apply in_fcset_remove.
Qed.

(** if list of KAssignables is in nil, then l is nil *)
Lemma KAssignables_included_nil_implies :
  forall l, KAssignables_included l [] = true -> l = [].
Proof.
  apply included_dec_nil_implies.
Qed.

(** if e is subset of append of two EAssignables,
then e is subset of both EAssignables *)
Lemma eassignables_subset_app_l_true_iff :
  forall e1 e2 e,
    eassignables_subset (EAssignables_app e1 e2) e = true
    <-> (eassignables_subset e1 e = true /\ eassignables_subset e2 e = true).
Proof.
  apply fcset_subset_app_l_true_iff.
  apply fresh_kassignable.
Qed.

(** if e is susbset of e1 and e is subset of e2, the e is subset of append of e1 and e2 *)
Lemma implies_eassignables_subset_app_r_true :
  forall e1 e2 e,
    (eassignables_subset e e1 = true \/ eassignables_subset e e2 = true)
    -> eassignables_subset e (EAssignables_app e1 e2) = true.
Proof.
  apply implies_fcset_subset_app_r_true.
  apply fresh_kassignable.
Qed.

(** if a is susbset of v then append of a and b is subset of append of v and b *)
Lemma eassignables_subset_app_right :
  forall a b v,
    eassignables_subset a v = true
    -> eassignables_subset (EAssignables_app a b) (EAssignables_app v b) = true.
Proof.
  apply fcset_subset_app_right.
Qed.

(** if a is in intersection of EAssignables e1 and e2, then a is e1 and a is in e2 *)
Lemma in_eassignables_inter_iff :
  forall a e1 e2,
    in_eassignables a (EAssignables_inter e1 e2) = true
    <-> (in_eassignables a e1 = true /\ in_eassignables a e2 = true).
Proof.
  apply in_fcset_inter_iff.
Qed.

(** if e is subset of EAssignables e1 and e is subset of EAssignables e2,
then e is subset of intersection of e1 and e2 *)
Lemma implies_eassignables_subset_inter_l_true :
  forall e1 e2 e,
    (eassignables_subset e1 e = true \/ eassignables_subset e2 e = true)
    -> eassignables_subset (EAssignables_inter e1 e2) e = true.
Proof.
  apply implies_fcset_subset_inter_l_true.
  apply fresh_kassignable.
Qed.

(** if EAssignables e1 is subset of EAssignables e2,
every a which is in e1, is in e2 *)
Lemma eassignables_subset_iff :
  forall e1 e2,
    eassignables_subset e1 e2 = true
    <-> (forall a, in_eassignables a e1 = true -> in_eassignables a e2 = true).
Proof.
  apply fcset_subset_iff.
  apply fresh_kassignable.
Qed.

(** reflexivity for subsets of EAssignables *)
Lemma eassignables_subset_refl :
  forall e, eassignables_subset e e = true.
Proof.
  apply fcset_subset_refl.
Qed.
Hint Resolve eassignables_subset_refl : core.

(** transitivity of subsets of EAssignables *)
Lemma eassignables_subset_trans :
  forall e1 e2 e3,
    eassignables_subset e1 e2 = true
    -> eassignables_subset e2 e3 = true
    -> eassignables_subset e1 e3 = true.
Proof.
  apply fcset_subset_trans.
Qed.

(** if x is removed from e, and then appended to it,
e is subset of that set  *)
Lemma eassignables_subset_app_remove :
  forall e x,
    eassignables_subset e (EAssignables_app (remove_eassignables e x) x) = true.
Proof.
  apply fcset_subset_app_remove.
Qed.

(** subtraction (minus) of l2 on append of l1 and l3
is same as subtraction of l3 from subtraction of l2 from l1 *)
Lemma KAssignables_minus_app_r :
  forall l1 l2 l3,
    KAssignables_minus l1 (l2 ++ l3)
    = KAssignables_minus (KAssignables_minus l1 l2) l3.
Proof.
  apply minus_dec_app_r.
Qed.

(** swap for subtraction (minus) of three lists *)
Lemma KAssignables_minus_swap :
  forall l1 l2 l3,
    KAssignables_minus (KAssignables_minus l1 l2) l3
    = KAssignables_minus (KAssignables_minus l1 l3) l2.
Proof.
  apply minus_dec_swap.
Qed.

(** if l1 is subset of l3, then subtraction (minus) of list l3
from intersection of lists l1 and l2 returns nil *)
Lemma KAssignables_minus_inter_cancel_ss :
  forall l1 l2 l3,
    subset l1 l3
    -> KAssignables_minus (KAssignables_inter l1 l2) l3 = [].
Proof.
  apply minus_inter_dec_cancel_ss.
Qed.

(** subtraction (minus) of list l1 of KAssignables from intersection of
that list with list l2 returns nil *)
Lemma KAssignables_minus_inter_cancel :
  forall l1 l2,
    KAssignables_minus (KAssignables_inter l1 l2) l1 = [].
Proof.
  apply minus_inter_dec_cancel.
Qed.

(** subtraction (minus) and intersection on list of KAssignables can be swapped *)
Lemma KAssignables_inter_minus_swap :
  forall l1 l2 l3,
    KAssignables_inter (KAssignables_minus l1 l2) l3
    = KAssignables_minus (KAssignables_inter l1 l3) l2.
Proof.
  apply inter_minus_dec_swap.
Qed.

(** intersection of list l of KAssignables with nil, returns nil *)
Lemma KAssignables_inter_nil_r :
  forall l, KAssignables_inter l [] = [].
Proof.
  apply inter_dec_nil_r.
Qed.
Hint Rewrite KAssignables_inter_nil_r : core.

(** symmentry of intersection of two lists of KAssignables *)
Lemma KAssignables_inter_sym :
  forall l1 l2,
    eqset
      (KAssignables_inter l1 l2)
      (KAssignables_inter l2 l1).
Proof.
  apply inter_dec_sym.
Qed.

(** equality for EAssignables *)
Definition eassignables_eq (e1 e2 : EAssignables) : Prop :=
  fcset_eq KAssignable_dec e1 e2.

(** reflexivity for equality of EAssignables *)
Lemma eassignables_eq_refl :
  forall e, eassignables_eq e e.
Proof.
  apply fcset_eq_refl.
Qed.
Hint Resolve eassignables_eq_refl : core.

(** iff EAssinables in FCS_infinite l1 (complement of list l1)
are equal to EAssignables in EA_lll l2 (complement of list l2)
list l1 and l2 are equal*)
Lemma eassignables_eq_FCS_infinite :
  forall l1 l2,
    eassignables_eq (FCS_infinite l1) (FCS_infinite l2)
    <-> eqset l1 l2.
Proof.
  apply fcset_eq_FCS_infinite.
Qed.

(** if list l1 is equal to l3, and l2 is equal to l4
list of KAssignables gained by subtraction (minus) of l2 form l2
is same as list of KAssignables gained by subtraction (minus) of l4 form l3 *)
Lemma implies_eqset_KAssignables_minus :
  forall l1 l2 l3 l4,
    eqset l1 l3
    -> eqset l2 l4
    -> eqset (KAssignables_minus l1 l2) (KAssignables_minus l3 l4).
Proof.
  apply implies_eqset_minus_dec.
Qed.

(** associativity of intersection of KAssignables *)
Lemma KAssignables_inter_assoc :
  forall l1 l2 l3,
    KAssignables_inter (KAssignables_inter l1 l2) l3
    = KAssignables_inter l1 (KAssignables_inter l2 l3).
Proof.
  apply inter_dec_assoc.
Qed.

(** associativity for EAassignables *)
Lemma EAssignables_app_assoc :
  forall e1 e2 e3,
    eassignables_eq
      (EAssignables_app (EAssignables_app e1 e2) e3)
      (EAssignables_app e1 (EAssignables_app e2 e3)).
Proof.
  apply fcset_app_assoc.
Qed.

(** list of KAssignables l minus nil returns list l *)
Lemma KAssignables_minus_nil_r :
  forall l, KAssignables_minus l [] = l.
Proof.
  apply minus_dec_nil_r.
Qed.
Hint Rewrite KAssignables_minus_nil_r : core.

(** nil appended to EAssigbales returns EAssignables *)
Lemma EAssignables_app_EA_assignables_nil_r :
  forall e, EAssignables_app e (EA_assignables []) = e.
Proof.
  apply fcset_app_nil_r.
Qed.
Hint Rewrite EAssignables_app_EA_assignables_nil_r : core.

Lemma EAssignables_app_all_left :
  forall e,
    EAssignables_app (EA_all []) e = EA_all [].
Proof.
  apply fcset_app_all_left.
Qed.
Hint Rewrite EAssignables_app_all_left : core.

Lemma EAssignables_app_all_right :
  forall e,
    EAssignables_app e (EA_all []) = EA_all [].
Proof.
  apply fcset_app_all_right.
Qed.
Hint Rewrite EAssignables_app_all_right : core.

Lemma eassignables_subset_all_implies :
  forall V,
    eassignables_subset (EA_all []) V = true
    -> V = EA_all [].
Proof.
  apply fcset_subset_all_implies.
Qed.

Lemma eassignables_disj_prop :
  forall e1 e2 x,
    eassignables_disj e1 e2 = true
    -> in_eassignables x e1 = true
    -> in_eassignables x e2 = false.
Proof.
  apply fcset_disj_prop.
Qed.

Lemma eassignables_subset_nil_implies :
  forall e,
    eassignables_subset e (EA_assignables []) = true
    -> e = EA_assignables [].
Proof.
  apply fcset_subset_nil_implies.
Qed.

Lemma EAssignables_app_eq_nil_implies :
  forall a b,
    EAssignables_app a b = EA_assignables []
    -> (a = EA_assignables [] /\ b = EA_assignables []).
Proof.
  apply fcset_app_eq_nil_implies.
Qed.

Lemma eassignables_disj_sym :
  forall e1 e2 : EAssignables,
    eassignables_disj e1 e2 = true
    -> eassignables_disj e2 e1 = true.
Proof.
  apply fcset_disj_sym.
Qed.

Lemma eassignables_disj_EAssignables_app_l :
  forall e1 e2 e,
    eassignables_disj (EAssignables_app e1 e2) e = true
    <-> (eassignables_disj e1 e = true /\ eassignables_disj e2 e = true).
Proof.
  apply fcset_disj_app_l.
Qed.


(* Liveness Analysis *)

(** Liveness analysis on SpecIR *)
(* Inspired by CompCert analysis over RTL *)

Require Import Coqlib.
Require Import Maps.
Require Import Kildall.
Require Import Lattice.
Require Import IR.
Require Import IRinterpreter.
Require Import Ordered.
Require Import Coq.MSets.MSetPositive.
Require Import common.
Require Import Errors.
Require Import RTL.

(** A register [r] is live at a point [p] if there exists a path
  from [p] to some instruction that uses [r] as argument,
  and [r] is not redefined along this path.
  Liveness can be computed by a backward dataflow analysis.
  The analysis operates over sets of (live) pseudo-registers. *)

(* Basic definitions over register sets *)
Definition regset: Type := PositiveSet.t.
Lemma regset_eq_refl: forall x, PositiveSet.eq x x.
Proof. apply PositiveSet.eq_equiv. Qed.
Lemma regset_eq_sym: forall x y, PositiveSet.eq x y -> PositiveSet.eq y x.
Proof. apply PositiveSet.eq_equiv. Qed.
Lemma regset_eq_trans: forall x y z, PositiveSet.eq x y -> PositiveSet.eq y z -> PositiveSet.eq x z.
Proof. apply PositiveSet.eq_equiv. Qed.

(* Definition of the lattice used to compute liveness *)
Module LiveFlatRegset <: SEMILATTICE.

Definition t : Type := regset.

Definition eq (x y: t) : Prop :=
  PositiveSet.Equal x y.

Lemma eq_refl: forall x, eq x x.
Proof. apply regset_eq_refl. Qed.

Lemma eq_sym: forall x y, eq x y -> eq y x.
Proof. apply regset_eq_sym. Qed.

Lemma eq_trans: forall x y z, eq x y -> eq y z -> eq x z.
Proof. apply regset_eq_trans. Qed.

Definition beq (x y: t) : bool := PositiveSet.equal x y.

Lemma beq_correct: forall x y, beq x y = true -> eq x y.
Proof.
  unfold eq. intros. apply PositiveSet.equal_spec. auto.
Qed.

Definition ge (x y: t) : Prop :=
  PositiveSet.Subset y x.

Lemma ge_refl: forall x y, eq x y -> ge x y.
Proof.
  unfold eq, ge. intros x y EQ r IN. apply EQ. auto.
Qed.

Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
Proof.
  unfold ge. intros x y z Hxy Hyz r IN. auto.
Qed.

Definition bot: t := PositiveSet.empty.

Lemma ge_bot: forall x, ge x bot.
Proof.
  unfold ge. intros x r IN. inv IN.
Qed.

Definition lub (x y: t) : t :=
  PositiveSet.union x y.

Lemma ge_lub_left: forall x y, ge (lub x y) x.
Proof.
  intros x y r IN. apply PositiveSet.union_spec. left. auto.
Qed.

Lemma ge_lub_right: forall x y, ge (lub x y) y.
Proof.
  intros x y r IN. apply PositiveSet.union_spec. right. auto.
Qed.

End LiveFlatRegset.

Definition live_abs_dr: Type := regset.

(* Starting the analysis, no registers are live *)
Definition live_entry_abs_dr: live_abs_dr :=
  PositiveSet.empty.

(* Associating a live_abs_dr to each label *)
Definition live_abs_state : Type := PMap.t live_abs_dr.
Definition live_absstate_get (pc:label) (abs:live_abs_state) : live_abs_dr :=
  PMap.get pc abs.

(* Inserting a new live register into an abstract set *)
Definition reg_live (r:reg) (adr:live_abs_dr) : live_abs_dr :=
  PositiveSet.add r adr.

(* Removing a new live register from an abstract set *)
Definition reg_dead (r:reg) (adr:live_abs_dr) : live_abs_dr :=
  PositiveSet.remove r adr.

(* Inserting a list of live registers *)
Fixpoint reg_list_live
             (rl: list reg) (lv: live_abs_dr) : live_abs_dr :=
  match rl with
  | nil => lv
  | r1 :: rs => reg_live r1 (reg_list_live rs lv)
  end.

(* Removing a list of live registers *)
Fixpoint reg_list_dead
             (rl: list reg) (lv: live_abs_dr) : live_abs_dr :=
  match rl with
  | nil => lv
  | r1 :: rs => reg_list_dead rs (reg_dead r1 lv)
  end.

(* Various operations on regsets, used in transfer function *)
Definition expr_live (expr: expr) (after: live_abs_dr): live_abs_dr :=
  match expr with
  | ZAR _ => after
  | UNA _ r => reg_live r after
  | BIN _ r1 r2 => reg_live r1 (reg_live r2 after)
  end.

Fixpoint expr_list_live (exl: list expr) (after: live_abs_dr): live_abs_dr :=
  match exl with
  | nil => after
  | e::t => expr_live e (expr_list_live t after)
  end.

Fixpoint varmap_live (vm: varmap) (after: live_abs_dr): live_abs_dr :=
  match vm with
  | nil => after
  | (r,e)::t => expr_live e (varmap_live t after)
  end.

(** Here is the transfer function for the dataflow analysis.
  Since this is a backward dataflow analysis, it takes as argument
  the abstract register set ``after'' the given instruction,
  i.e. the registers that are live after; and it returns as result
  the abstract register set ``before'' the given instruction,
  i.e. the registers that must be live before.
  The general relation between ``live before'' and ``live after''
  an instruction is that a register is live before if either
  it is one of the arguments of the instruction, or it is not the result
  of the instruction and it is live after. *)
(* The transf function that updates live_abs_dr *)
Definition live_dr_transf
            (c: IR.code) (pc: positive) (after: live_abs_dr) : live_abs_dr :=
  match c!pc with
  | None =>
    PositiveSet.empty
  | Some i =>
    match i with
    | Nop next => after
    | IPrint e next => expr_live e after
    | MemSet adreg valreg next =>
      reg_live adreg (reg_live valreg after)
    | MemGet dstreg adreg next =>
      reg_live adreg (reg_dead dstreg after)
    | Call f args retreg next =>
      reg_list_live args (reg_dead retreg after)
    | Cond r tr fl => reg_live r after
    | Return e =>
      expr_live e after
    | Op r ex next =>
      expr_live ex (reg_dead r after)
    | Assume guard tgt vm next =>
        expr_live guard (varmap_live vm after)
    | Anchor tgt vm next =>
        varmap_live vm after
    end
  end.

(** The liveness analysis is then obtained by instantiating the
  general framework for backward dataflow analysis provided by
  module [Kildall].  *)
Module DS := Backward_Dataflow_Solver (LiveFlatRegset) (NodeSetBackward).

Definition list_entries (f: version) : list (label * live_abs_dr) :=
  ((ver_entry f), PositiveSet.empty)::nil.

Definition liveness_analyze (f: version): option live_abs_state :=
  DS.fixpoint (ver_code f) (IR.successors) (live_dr_transf (ver_code f)).

(** Basic property of the liveness information computed by [analyze]. *)
Lemma liveness_successor:
  forall f live n i s,
  liveness_analyze f = Some live ->
  (ver_code f)!n = Some i ->
  In s (successors i) ->
  PositiveSet.Subset (live_dr_transf (ver_code f) s (live_absstate_get s live)) (live_absstate_get n live).
Proof.
  unfold liveness_analyze. intros. eapply DS.fixpoint_solution; eauto.
  intros n0 a H2. unfold live_dr_transf. rewrite H2. unfold DS.L.bot.
  apply DS.L.eq_refl.
Qed.

(* Basic inclusions of regsets *)
Lemma reg_live_subset:
  forall r live, PositiveSet.Subset live (reg_live r live).
Proof.
  unfold PositiveSet.Subset. unfold reg_live. intros.
  apply PositiveSet.add_spec. right. auto.
Qed.

Lemma expr_live_subset:
  forall e rs, PositiveSet.Subset rs (expr_live e rs).
Proof.
  unfold PositiveSet.Subset. unfold expr_live. intros.
  destruct e;
    repeat (apply PositiveSet.add_spec; right); auto.
Qed.

Lemma reg_list_live_subset:
  forall rl rs, PositiveSet.Subset rs (reg_list_live rl rs).
Proof.
  unfold PositiveSet.Subset. induction rl; intros; auto.
  simpl. apply reg_live_subset. apply IHrl. auto.
Qed.

Lemma expr_list_live_subset:
  forall exl rs, PositiveSet.Subset rs (expr_list_live exl rs).
Proof.
  unfold PositiveSet.Subset. induction exl; intros; auto.
  simpl. apply expr_live_subset. auto.
Qed.

Lemma varmap_subset:
  forall v rs, PositiveSet.Subset rs (varmap_live v rs).
Proof.
  unfold PositiveSet.Subset. intros v rs. induction v; intros; auto. destruct a.
  simpl. apply expr_live_subset. apply IHv. auto.
Qed.

Lemma in_or_not:
  forall (l:label) l_fs,
    In l l_fs \/ ~ In l l_fs.
Proof.
  intros l l_fs. induction l_fs.
  - right. unfold not; intros. inv H.
  - poseq_destr a l.
    + left. simpl. left. auto.
    + destruct IHl_fs; [left | right]; simpl; try (right; auto).
      unfold not. intros [EQ | IN]; auto.
Qed.

(** * AGREEEMENT  *)
(* This to relate regmaps with regsets *)
(* But IR_to_RTLBlock uses its own version of agreement *)

(* Two regmaps agree on a regset iff they have the same values
   on the registers of the regset (may be None) *)
Definition agree (rm1 rm2:reg_map) (adr:live_abs_dr) :=
  forall r:reg, PositiveSet.In r adr -> rm1 # r = rm2 # r.

Lemma agree_refl:
  forall rs rm,
    agree rm rm rs.
Proof.
  unfold agree. intros. auto.
Qed.

Lemma agree_sym:
  forall rs rm1 rm2,
    agree rm1 rm2 rs ->
    agree rm2 rm1 rs.
Proof.
  unfold agree. intros. symmetry. auto.
Qed.

Lemma agree_trans:
  forall rs rm1 rm2 rm3,
    agree rm1 rm2 rs ->
    agree rm2 rm3 rs ->
    agree rm1 rm3 rs.
Proof.
  unfold agree. intros. rewrite H; auto.
Qed.

Lemma agree_subset:
  forall rs1 rs2 rms rmo,
    PositiveSet.Subset rs1 rs2 ->
    agree rms rmo rs2 ->
    agree rms rmo rs1.
Proof.
  unfold agree. intros. auto.
Qed.

(* Liveness transfer preserves agree *)
Lemma agree_transfer:
  forall live rms rmo f pc pc' i,
    liveness_analyze f = Some live ->
    (ver_code f)!pc = Some i ->
    In pc' (successors i) ->
    agree rms rmo (live!!pc) ->
    agree rms rmo (live_dr_transf (ver_code f) pc' (live!!pc')).
Proof.
  intros. apply agree_subset with (live!!pc); auto.
  eapply liveness_successor; eauto.
Qed.

(* The following lemmas express the fact that agreeing on the regset obtained
   after adding registers implies agreeing on the original regset
   (which contains less registers) *)
Lemma reg_live_agree:
  forall e rs rms rmo,
    agree rms rmo (reg_live e rs) ->
    agree rms rmo rs.
Proof.
  intros. eapply agree_subset; eauto. apply reg_live_subset.
Qed.

Lemma expr_live_agree:
  forall e rs rms rmo,
    agree rms rmo (expr_live e rs) ->
    agree rms rmo rs.
Proof.
  intros. eapply agree_subset; eauto. apply expr_live_subset.
Qed.

Lemma expr_list_live_agree:
  forall exl rs rms rmo,
    agree rms rmo (expr_list_live exl rs) ->
    agree rms rmo rs.
Proof.
  intros. eapply agree_subset; eauto. apply expr_list_live_subset.
Qed.

Lemma reg_list_live_agree:
  forall exl rs rms rmo,
    agree rms rmo (reg_list_live exl rs) ->
    agree rms rmo rs.
Proof.
  intros. eapply agree_subset; eauto. apply reg_list_live_subset.
Qed.

(* Lemma movelist_live_agree: *)
(*   forall ml rs rms rmo, *)
(*     agree rms rmo (movelist_live ml rs) -> *)
(*     agree rms rmo rs. *)
(* Proof. *)
(*   intros. eapply agree_subset; eauto. apply movelist_subset. *)
(* Qed. *)

Lemma varmap_live_agree:
  forall vm rs rms rmo,
    agree rms rmo (varmap_live vm rs) ->
    agree rms rmo rs.
Proof.
  intros. eapply agree_subset; eauto. apply varmap_subset.
Qed.

(* Lemma synth_live_agree: *)
(*   forall sl rs rms rmo, *)
(*     agree rms rmo (synth_live sl rs) -> *)
(*     agree rms rmo rs. *)
(* Proof. *)
(*   intros. eapply agree_subset; eauto. apply synth_subset. *)
(* Qed. *)

Lemma agree_eval_reg:
  forall r v rs rms rmo ,
    agree rms rmo (reg_live r rs) ->
    eval_reg r rms = OK v ->
    eval_reg r rmo = OK v.
Proof.
  intros. unfold agree in H. unfold eval_reg in H0. rewrite H in H0.
    2: { simpl. apply PositiveSet.add_spec. left. auto. }
    unfold eval_reg. rewrite H0. simpl. auto.
Qed.

(* If two regmaps agree on the registers used for the evaluation of e,
   then e evaluates to the same value in both regmaps *)
Lemma agree_eval_expr:
  forall e v rs rms rmo ,
    agree rms rmo (expr_live e rs) ->
    eval_expr e rms = OK v ->
    eval_expr e rmo = OK v.
Proof.
  intros. destruct e; simpl in H0.
  - destruct (eval_reg r rms) eqn:EVALL; inv H0.
    destruct (eval_reg r0 rms) eqn:EVALR; inv H2.
    unfold agree in H. unfold eval_reg in EVALL. rewrite H in EVALL.
    2: { simpl. apply PositiveSet.add_spec. left. auto. }
    unfold eval_reg in EVALR. rewrite H in EVALR.
    2: { simpl. apply PositiveSet.add_spec. right. apply PositiveSet.add_spec. auto. }
    simpl. unfold eval_reg. rewrite EVALL. rewrite EVALR. simpl. auto.
  - destruct (eval_reg r rms) eqn:EVAL; inv H0.
    unfold agree in H. unfold eval_reg in EVAL. rewrite H in EVAL.
    2: { simpl. apply PositiveSet.add_spec. left. auto. }
    simpl. unfold eval_reg. rewrite EVAL. simpl. auto.
  - destruct z. inv H0. simpl. auto.
Qed.

(* If two regmaps agree on the registers used for the evaluation of
   the list of expressions [le], then [le] evaluates to the same boolean value
   in both regmaps *)
(* Lemma agree_eval_list_expr: *)
(*   forall rs rm1 rm2 le b, *)
(*     agree rm1 rm2 (expr_list_live le rs) -> *)
(*     eval_list_expr le rm1 b -> *)
(*     eval_list_expr le rm2 b. *)
(* Proof. *)
(*   intros. generalize dependent b. induction le; intros; inv H0; try constructor. *)
(*   - eapply agree_eval_expr in EVAL; eauto. *)
(*   - eapply agree_eval_expr in EVALH; eauto. *)
(*     econstructor; eauto. apply IHle; auto. *)
(*     unfold agree in *. intros. apply H. simpl. *)
(*     eapply expr_live_subset; eauto. *)
(* Qed. *)

(* If two regmaps agree on the registers used for the evaluation of
   the list of expressions [le], then each expression of [le] evaluates to the same value
   in both regmaps *)
Lemma agree_eval_list:
  forall rs rm1 rm2 le lv,
    agree rm1 rm2 (expr_list_live le rs) ->
    eval_list le rm1 = OK lv ->
    eval_list le rm2 = OK lv.
Proof.
  intros. generalize dependent lv.
  induction le; intros.
  - inv H0. simpl. auto.
  - simpl in H0. destruct (eval_expr a rm1) eqn:EVAL1; inv H0.
    eapply agree_eval_expr in EVAL1; eauto.
    destruct (eval_list le rm1) eqn:EVAL2; inv H2.
    simpl. rewrite EVAL1. simpl.
    assert (OK l = OK l) by auto. apply IHle in H0.
    2: { eapply agree_subset; eauto. apply expr_live_subset. }
    rewrite H0. simpl. auto.
Qed.

Lemma agree_eval_list_reg:
  forall rs rm1 rm2 le lv,
    agree rm1 rm2 (reg_list_live le rs) ->
    eval_list_reg le rm1 = OK lv ->
    eval_list_reg le rm2 = OK lv.
Proof.
  intros. generalize dependent lv.
  induction le; intros.
  - inv H0. simpl. auto.
  - simpl in H0. destruct (eval_reg a rm1) eqn:EVAL1; inv H0.
    eapply agree_eval_reg in EVAL1; eauto.
    destruct (eval_list_reg le rm1) eqn:EVAL2; inv H2.
    simpl. rewrite EVAL1. simpl.
    assert (OK l = OK l) by auto. apply IHle in H0.
    2: { eapply agree_subset; eauto. simpl.
         apply reg_live_subset. }
    rewrite H0. simpl. auto.
Qed.

(* Auxiliary lemmas on movelists *)
(* If a register is not assigned by a movelist, it contains the same value
   before and after the update *)
(* Lemma not_use_movelist: *)
(*   forall ml r rm rmu, *)
(*     ~(In r (map fst ml)) -> *)
(*     update_movelist ml rm rmu -> *)
(*     rm ! r = rmu ! r. *)
(* Proof. *)
(*   induction ml; intros. *)
(*   - inv H0. auto. *)
(*   - inv H0. poseq_destr r r0. *)
(*     + simpl in H. unfold not in H. *)
(*       exfalso. apply H. left. auto.  *)
(*     + rewrite PTree.gso; auto. simpl in H. *)
(*       eapply Classical_Prop.not_or_and in H as [NEQ NIN]. apply IHml; auto. *)
(* Qed. *)

(* If a register is assigned by a movelist and two regmaps agree on all the
   registers whose value is needed to evaluate all the expressions of
   the movelist, then we can decompose the movelist appropriately *)
(* Lemma reg_in_movelist: *)
(*   forall ml r rs rm1 rm2, *)
(*     agree rm1 rm2 (movelist_live ml rs) -> *)
(*     In r (map fst ml) -> *)
(*     exists ml1 ml2 e rs', *)
(*       ml = ml1 ++ (r,e)::ml2 /\ ~(In r (map fst ml1)) /\ *)
(*       agree rm1 rm2 (expr_live e rs'). *)
(* Proof. *)
(*   induction ml; intros; inv H0. *)
(*   - simpl in H. destruct a. exists nil, ml, e, (movelist_live ml rs). *)
(*     split; auto. *)
(*   - simpl in H. destruct a. *)
(*     apply IHml with r rs rm1 rm2 in H1 as [ml1 [ml2 [e' [rs' [EQ [NIN AGREE]]]]]]. *)
(*     2: { eapply expr_live_agree. eauto. } *)
(*     poseq_destr r r0. *)
(*     + exists nil, (ml1 ++ (r0,e')::ml2), e, (movelist_live (ml1 ++ (r0, e') :: ml2) rs). *)
(*       split; auto. *)
(*     + exists ((r0,e)::ml1), ml2, e', rs'. subst. *)
(*       split; auto; try split; auto. *)
(*       simpl. intros [EQ' | IN]; subst; auto. *)
(* Qed. *)

(* If we assign a register [r] with a movelist, and two regmaps agree on the
   registers used by the expression assigned to [r], then they agree on [r]
   after the update no matter what was the value before *)
(* Lemma use_movelist: *)
(*   forall ml1 ml2 ml r e rs rm1 rm1u rm2 rm2u, *)
(*     ml = ml1 ++ (r,e)::ml2 -> *)
(*     ~(In r (map fst ml1)) -> *)
(*     agree rm1 rm2 (expr_live e rs) -> *)
(*     update_movelist ml rm1 rm1u -> *)
(*     update_movelist ml rm2 rm2u -> *)
(*     rm1u ! r = rm2u ! r. *)
(* Proof. *)
(*   induction ml1. *)
(*   - intros. inv H2; inv H4. *)
(*     inv H3. rewrite PTree.gss. rewrite PTree.gss. f_equal. *)
(*     eapply agree_eval_expr in EVAL; eauto. *)
(*     eapply eval_expr_determ; eauto. *)
(*   - intros. inv H2; inv H4. *)
(*     inv H3. assert (r <> r0). *)
(*     { intros contra. apply H0. simpl. left. auto. } *)
(*     rewrite PTree.gso; auto. rewrite PTree.gso; auto. *)
(*     eapply IHml1; eauto. intros contra. simpl in H0. *)
(*     apply H0. right. auto. *)
(* Qed. *)

(* Two agreeing regmaps still agree after having the same update *)
(* Lemma agree_update_movelist_aux: *)
(*   forall ml rs rm1 rm2 rm1u rm2u, *)
(*     agree rm1 rm2 (movelist_live ml rs) -> *)
(*     update_movelist ml rm1 rm1u -> *)
(*     update_movelist ml rm2 rm2u -> *)
(*     agree rm1u rm2u (movelist_live ml rs). *)
(* Proof. *)
(*   induction ml; intros; inv H0; inv H1; auto. *)
(*   unfold agree. intros. *)
(*   simpl in H0. simpl in H. poseq_destr r r0. *)
(*   - repeat rewrite PTree.gss. f_equal. *)
(*     eapply agree_eval_expr in EVAL; eauto. *)
(*     eapply eval_expr_determ; eauto. *)
(*   - repeat (rewrite PTree.gso; auto). *)
(*     assert (In r0 (map fst ml) \/ ~(In r0 (map fst ml))) as [IN' | NIN'] by (apply in_or_not). *)
(*     + eapply reg_in_movelist in IN' as [ml1 [ml2 [e' [rs' [EQ [NIN'' AGREE]]]]]]; eauto. *)
(*       * eapply use_movelist; eauto. *)
(*       * eapply expr_live_agree; eauto. *)
(*     + assert (rm1 ! r0 = rm' ! r0). *)
(*       { eapply not_use_movelist; eauto. } *)
(*       assert (rm2 ! r0 = rm'0 ! r0). *)
(*       { eapply not_use_movelist; eauto. } *)
(*       rewrite <- H1. rewrite <- H2. apply H. apply H0. *)
(* Qed. *)

(* Lemma agree_update_movelist: *)
(*   forall rs rm1 rm2 rm2u ml, *)
(*     agree rm1 rm2 (movelist_live ml rs) -> *)
(*     update_movelist ml rm2 rm2u -> *)
(*     exists rm1u, *)
(*       update_movelist ml rm1 rm1u /\ *)
(*       agree rm1u rm2u (movelist_live ml rs). *)
(* Proof. *)
(*   intros. generalize dependent rm2u. induction ml; intros; inv H0. *)
(*   - exists rm1. split; auto. constructor. *)
(*   - assert (UPDATE':= UPDATE). apply IHml in UPDATE as [rm1u [UPDATE EQ]]. *)
(*     2: { unfold agree in *. intros. apply H. simpl. *)
(*          apply expr_live_subset. auto. } *)
(*     apply agree_sym in H. *)
(*     assert (EVAL':=EVAL). *)
(*     eapply agree_eval_expr in EVAL; eauto. *)
(*     exists (rm1u#r<-v). split; try constructor; eauto. *)
(*     apply agree_sym. eapply agree_update_movelist_aux; eauto; econstructor; eauto. *)
(* Qed. *)

Lemma agree_update_regmap:
  forall rs rm1 rm2 newrm vm,
    agree rm1 rm2 (varmap_live vm rs) ->
    update_regmap vm rm2 = OK newrm ->
    update_regmap vm rm1 = OK newrm.
Proof.
  intros. generalize dependent newrm.
  induction vm; intros; inv H0; auto.
  destruct a. destruct (eval_expr e rm2) eqn:EVAL1; inv H2.
  apply agree_sym in H. eapply agree_eval_expr in EVAL1; eauto.
  simpl. rewrite EVAL1. simpl.
  destruct (update_regmap vm rm2) eqn:EVAL2; inv H1.
  assert (OK r0 = OK r0) by auto. apply IHvm in H0.
  rewrite H0. auto.
  eapply expr_live_agree. apply agree_sym in H. simpl in H. eauto.
Qed.

(* Lemma agree_synthesize_frame: *)
(*   forall rs rm1 rm2 p sl stack, *)
(*     agree rm1 rm2 (synth_live sl rs) -> *)
(*     synthesize_frame p rm2 sl stack -> *)
(*     synthesize_frame p rm1 sl stack. *)
(* Proof. *)
(*   intros. generalize dependent stack. *)
(*   induction sl; intros; inv H0; try constructor; auto. *)
(*   - eapply agree_update_regmap in UPDATE; eauto. *)
(*   - apply IHsl; auto. simpl in H. *)
(*     eapply varmap_live_agree. eauto. *)
(* Qed. *)

(* It is sufficient to agree on all the registers of [rs] excepted [reg]
   before an assignation provided we assign the same value to [reg]
   on both sides *)
Lemma agree_insert_dead:
  forall rs rm rm_opt reg v,
    agree rm rm_opt (reg_dead reg rs) ->
    agree (rm # reg <- v) (rm_opt # reg <- v) rs.
Proof.
  intros. unfold agree in *.
  intros r IN. poseq_destr r reg.
  - rewrite PTree.gss. rewrite PTree.gss. auto.
  - rewrite PTree.gso; auto. rewrite PTree.gso; auto. apply H.
    apply PositiveSet.remove_spec; split; auto.
Qed.

(* updating the rm on both sides *)
Lemma agree_insert:
  forall rs rm rm_opt reg v,
    agree rm rm_opt rs ->
    agree (rm # reg <- v) (rm_opt # reg <- v) rs.
Proof.
  intros. apply agree_subset with (reg_dead reg rs) rs rm rm_opt in H.
  - apply agree_insert_dead. auto.
  - intros r IN. apply PositiveSet.remove_spec in IN as [IN _]. auto.
Qed.

(* Lemma agree_movelist_live: *)
(*   forall ml rs rs' rms rmo, *)
(*     agree rms rmo (movelist_live ml rs) -> *)
(*     agree rms rmo rs -> *)
(*     agree rms rmo rs' -> *)
(*     agree rms rmo (movelist_live ml rs'). *)
(* Proof. *)
(*   induction ml; intros; auto. *)
(*   simpl. destruct a. simpl in H. intros r' IN. *)
(*   destruct e; destruct o; try destruct o0; simpl in *; *)
(*     try (apply (IHml rs rs' rms rmo); assumption); poseq_destr r' r0; *)
(*       try (apply H; apply PositiveSet.add_spec; left; reflexivity). *)
(*   - poseq_destr r' r1. *)
(*     + apply H. apply PositiveSet.add_spec. right. *)
(*       apply PositiveSet.add_spec. left. auto. *)
(*     + apply (IHml rs rs' rms rmo); auto. *)
(*       * eapply agree_subset; try apply H. *)
(*         intros reg IN'. repeat (apply PositiveSet.add_spec; right; auto). *)
(*       * repeat (apply PositiveSet.add_spec in IN as [contra | IN]; auto; *)
(*                 try contradiction). *)
(*   - apply (IHml rs rs' rms rmo); auto. *)
(*     + eapply agree_subset; try apply H. *)
(*       intros reg IN'. apply PositiveSet.add_spec. right. auto. *)
(*     + apply PositiveSet.add_spec in IN as [contra | IN]; auto. contradiction. *)
(*   - apply (IHml rs rs' rms rmo); auto. *)
(*     + eapply agree_subset; try apply H. *)
(*       intros reg IN'. apply PositiveSet.add_spec. right. auto. *)
(*     + apply PositiveSet.add_spec in IN as [contra | IN]; auto. contradiction. *)
(*   - apply (IHml rs rs' rms rmo); auto. *)
(*     + eapply agree_subset; try apply H. *)
(*       intros reg IN'. apply PositiveSet.add_spec. right. auto. *)
(*     + apply PositiveSet.add_spec in IN as [contra | IN]; auto. contradiction. *)
(* Qed. *)

(* Lemma movelist_reg_dead_subset: *)
(*   forall ml r rs, *)
(*     PositiveSet.Subset (movelist_dead ml (reg_dead r rs)) (reg_dead r (movelist_dead ml rs)). *)
(* Proof. *)
(*   induction ml; intros. *)
(*   - simpl. intros r' IN. auto. *)
(*   - simpl. destruct a. intros r' IN. poseq_destr r' r0. *)
(*     + apply PositiveSet.remove_spec in IN as [_ contra]. destruct contra. auto. *)
(*     + poseq_destr r' r. *)
(*       * apply PositiveSet.remove_spec in IN as [IN _]. apply IHml in IN. *)
(*         apply PositiveSet.remove_spec in IN as [_ contra]. destruct contra. auto. *)
(*       * repeat (apply PositiveSet.remove_spec; split; auto). *)
(*         apply PositiveSet.remove_spec in IN as [IN _]. apply IHml in IN. *)
(*         apply PositiveSet.remove_spec in IN as [IN _]. auto. *)
(* Qed. *)

(* (* Before an update_movelist, it is sufficient to agree on all the registers *)
(*    of [rs] excepted the registers assigned by the movelist *) *)
(* Lemma agree_movelist_dead: *)
(*   forall ml rs rms rmsu rmo rmou, *)
(*     agree rms rmo (movelist_live ml (movelist_dead ml rs)) -> *)
(*     update_movelist ml rms rmsu -> *)
(*     update_movelist ml rmo rmou -> *)
(*     agree rmsu rmou rs. *)
(* Proof. *)
(*   induction ml; intros; inv H0; inv H1; simpl in H; auto. *)
(*   simpl in H. eapply agree_eval_expr in EVAL; eauto. *)
(*   eapply eval_expr_determ in EVAL0; eauto. *)
(*   inv EVAL0. apply agree_insert_dead. *)
(*   eapply IHml; eauto. *)
(*   apply agree_subset with *)
(*       (movelist_live ml (reg_dead r (movelist_dead ml rs))) *)
(*       (expr_live e (movelist_live ml (reg_dead r (movelist_dead ml rs)))) *)
(*       rms rmo in H; try apply expr_live_subset. *)
(*   eapply agree_movelist_live; eauto. *)
(*   + eapply movelist_live_agree. eauto. *)
(*   + eapply agree_subset. apply movelist_reg_dead_subset. *)
(*     eapply movelist_live_agree. eauto. *)
(* Qed. *)


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^468 - 17
Base: 32
***)

Definition curve : CurveParameters :=
  {|
    sz := 15%nat;
    base := 32;
    bitwidth := 32;
    s := 2^468;
    c := [(1, 17)];
    carry_chains := None;

    a24 := None;
    coef_div_modulus := None;

    goldilocks := None;
    karatsuba := None;
    montgomery := true;
    freeze := Some false;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas64_2e256m2e32m977_6limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


From Undecidability Require Import bestaxioms EA equiv_on DecidabilityFacts SemiDecidabilityFacts Definitions reductions EnumerabilityFacts ReducibilityTransport.

Import EmbedNatNotations.

Set Default Goal Selector "!".

Lemma Rice {p : nat -> Prop} c_bot c :
  (forall x, ~ W c_bot x) ->
  (forall c1 c2, W c1 ≡{_} W c2 -> p c1 -> p c2) ->
  ~ p c ->
  p c_bot -> compl K0 ⪯ₘ p.
Proof.
  intros Hbot Hequiv Hc Hpbot.
  edestruct EAP with (p := fun x y => K0 x /\ W c y) as [f Hf]. {
    exists (fun x => fun! ⟨n,m⟩ => if φ x n is Some x' then if Nat.eqb x x' then φ c m else None else None).
    intros x y. split.
    + intros [[n H1] [m H2]]. exists ⟨n,m⟩. now rewrite embedP, H1, PeanoNat.Nat.eqb_refl, H2.
    + intros [nm H]. destruct (unembed nm) as [n m].
      destruct φ as [x' | ] eqn:E; try congruence.
      destruct (PeanoNat.Nat.eqb_spec x x') as [-> | ]; try congruence.
      firstorder.
  }
  exists f. intros x. unfold K0, compl.
  split.
  - intros H. eapply Hequiv. 2:exact Hpbot.
    cbn. intros. rewrite <- (Hf x x0). firstorder.
  - intros H. intros Hx.
    apply Hc. eapply Hequiv. 2: exact H.
    intros y. rewrite <- (Hf x y). firstorder.
Qed.

Lemma Rice_Theorem {p : nat -> Prop} :
  (forall c1 c2, W c1 ≡{_} W c2 -> p c1 -> p c2) ->
  (exists c1, p c1) ->
  (exists c2, ~ p c2) -> ~ (enumerable p /\ enumerable (compl p)).
Proof.
  intros Hequiv [c1 Hc1] [c2 Hc2] [Hp1 Hp2].
  destruct (do_EA (fun _ => False)) as [c_bot Hbot].
  - exists (fun _ => None). firstorder congruence.
  - assert (~~ (p c_bot \/ ~ p c_bot)) as Hc by tauto.
    apply Hc; clear Hc. intros [? | ?].
    + clear Hp2. eapply K0_not_enumerable; eauto.
      eapply enumerable_red; eauto.
      1: eapply Rice with (c_bot0 := c_bot); eauto.
      firstorder.
    + clear Hp1. eapply K0_not_enumerable; eauto.
      eapply enumerable_red; eauto.
      1: eapply Rice with (c_bot0 := c_bot) (c := c1); eauto.
      1: firstorder.
      intros ? ? ? H1 ?. eapply H1, Hequiv; eauto; firstorder.
Qed.

Lemma Rice_TheoremCorr {p : nat -> Prop} :
  (forall c1 c2, W c1 ≡{_} W c2 -> p c1 -> p c2) ->
  (exists c1, p c1) ->
  (exists c2, ~ p c2) -> ~ decidable p.
Proof.
  intros Hequiv Hc1 Hc2 Hp.
  eapply Rice_Theorem; eauto.
  split.
  - eapply decidable_enumerable; eauto.
  - eapply decidable_enumerable; eauto.
    now eapply decidable_complement.
Qed.

Lemma Rice_HO {p : (nat -> Prop) -> Prop} :
  (forall (q q' : nat -> Prop), (forall x, q x <-> q' x) -> p q <-> p q') ->
  forall q1 q2,
    enumerable q1 -> enumerable q2 ->
    p q1 -> ~ p q2 -> ~ decidable p.
Proof.
  intros Hequiv q1 q2 H1 H2 Hq1 Hq2 H.
  eapply (@Rice_TheoremCorr (fun c => p (W c))).
  - firstorder.
  - eapply do_EA in H1 as [c Hc]. exists c. firstorder.
  - eapply do_EA in H2 as [c Hc]. exists c. firstorder.
  - destruct H as [f Hf]. exists (fun c => f (W c)). firstorder.
Qed.

Section EPF.

Variable Part : partiality.

Variable Θ : nat -> (nat ↛ nat).

Instance equiv_part `{partiality} {A} : equiv_on (part A) := {| equiv_rel := @partial.equiv _ A |}.

Variable EPF : forall f : nat -> nat ↛ nat, exists γ, forall x, Θ (γ x) ≡{nat ↛ nat} f x.

Lemma FP : forall f, exists e, Θ e ≡{_} Θ (f e).
Proof.
  intros f.
  pose (h := fun x y => bind (Θ x x) (fun e => Θ e y)).
  destruct (EPF h)  as [γ Hγ].
  destruct (EPF (fun _ x => ret (f (γ x))))  as [γ' Hc].
  pose (c := γ' 0).
  exists (γ c).
  rewrite Hγ. unfold h.
  intros x v. rewrite bind_hasvalue. split.
  - now intros (y & <- % Hc % ret_hasvalue_inv & H2).
  - intros Hv. eexists. split; eauto.
    eapply Hc. now eapply ret_hasvalue.
Qed.

Lemma Rice_Theorem' {p : nat -> Prop} :
  (forall c1 c2, Θ c1 ≡{_} Θ c2 -> p c1 -> p c2) ->
  (exists c1, p c1) ->
  (exists c2, ~ p c2) -> ~ decidable p.
Proof.
  intros Hequiv [c1 Hc1] [c2 Hc2] [f Hf].
  pose (h x := if f x then Θ c2 else Θ c1).
  destruct (EPF h) as [γ H].
  destruct (FP γ) as [c Hc].
  rewrite H in Hc. unfold h in Hc.
  destruct (f c) eqn:E.
  - assert (Hx : p c) by firstorder.
    eapply Hc2. eapply Hequiv. 2: eapply Hx. eapply Hc.
  - assert (Hx : ~ p c) by firstorder congruence.
    eapply Hx. eapply Hequiv. 1:symmetry; eapply Hc. exact Hc1.
Qed.

End EPF.

Corollary Rice_HO' {Part : partiality} {p : (nat ↛ nat) -> Prop} :
  EPF -> (forall f f', f ≡{_} f' -> p f <-> p f') ->
  forall f1 f2, p f1 -> ~ p f2 -> ~ decidable p.
Proof.
  intros [θ EPF] Hequiv f1 f2 H1 H2 H.
  eapply (@Rice_Theorem' Part θ EPF (fun c => p (θ c))).
  - firstorder.
  - destruct (EPF (fun _ => f1)) as [c Hc]. exists (c 0).
    firstorder.
  - destruct (EPF (fun _ => f2)) as [c Hc]. exists (c 0).
    firstorder.
  - destruct H as [f Hf]. exists (fun c => f (θ c)). firstorder.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj19eqsynthconj4 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (mult lv0 lv1) (mult lv1 (plus Zero lv0))).
Admitted.
QuickChick conj19eqsynthconj4.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*         Xavier Leroy, Collège de France and INRIA Paris             *)
(*                                                                     *)
(*  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.     *)
(*                                                                     *)
(* *********************************************************************)

(** Translation from Mach to AArch64. *)

Require Import Recdef Coqlib Zwf Zbits.
Require Import Errors AST Integers Floats Op.
Require Import Locations Mach Asm.
Require SelectOp.

Local Open Scope string_scope.
Local Open Scope list_scope.
Local Open Scope error_monad_scope.

(** Alignment check for symbols *)

Parameter symbol_is_aligned : ident -> Z -> bool.
(** [symbol_is_aligned id sz] checks whether the symbol [id] is [sz] aligned *)

(** Extracting integer or float registers. *)

Definition ireg_of (r: mreg) : res ireg :=
  match preg_of r with IR mr => OK mr | _ => Error(msg "Asmgen.ireg_of") end.

Definition freg_of (r: mreg) : res freg :=
  match preg_of r with FR mr => OK mr | _ => Error(msg "Asmgen.freg_of") end.

(** Recognition of immediate arguments for logical integer operations.*)

(** Valid immediate arguments are repetitions of a bit pattern [B]
  of length [e] = 2, 4, 8, 16, 32 or 64.
  The bit pattern [B] must be of the form [0*1*0*] or [1*0*1*]
  but must not be all zeros or all ones. *)

(** The following automaton recognizes [0*1*0*|1*0*1*].
<<
               0          1          0
              / \        / \        / \
              \ /        \ /        \ /
        -0--> [B] --1--> [D] --0--> [F]
       /
     [A]
       \
        -1--> [C] --0--> [E] --1--> [G]
              / \        / \        / \
              \ /        \ /        \ /
               1          0          1
>>
*)

Module Automaton.

Inductive state : Type := SA | SB | SC | SD | SE | SF | SG | Sbad.

Definition start := SA.

Definition next (s: state) (b: bool) :=
  match s, b with
    | SA,false => SB      | SA,true => SC
    | SB,false => SB      | SB,true => SD
    | SC,false => SE      | SC,true => SC
    | SD,false => SF      | SD,true => SD
    | SE,false => SE      | SE,true => SG
    | SF,false => SF      | SF,true => Sbad
    | SG,false => Sbad    | SG,true => SG
    | Sbad,_ => Sbad
  end.

Definition accepting (s: state) :=
  match s with
  | SA | SB | SC | SD | SE | SF | SG => true
  | Sbad => false
  end.

Fixpoint run (len: nat) (s: state) (x: Z) : bool :=
  match len with
  | Datatypes.O => accepting s
  | Datatypes.S len => run len (next s (Z.odd x)) (Z.div2 x)
  end.

End Automaton.

(** The following function determines the candidate length [e],
    ensuring that [x] is a repetition [BB...B]
    of a bit pattern [B] of length [e]. *)

Definition logical_imm_length (x: Z) (sixtyfour: bool) : nat :=
  (** [test n] checks that the low [2n] bits of [x] are of the
      form [BB], that is, two occurrences of the same [n] bits *)
  let test (n: Z) : bool :=
    Z.eqb (Zzero_ext n x) (Zzero_ext n (Z.shiftr x n)) in
  (** If [test n] fails, we know that the candidate length [e] is
      at least [2n].  Hence we test with decreasing values of [n]:
      32, 16, 8, 4, 2. *)
  if sixtyfour && negb (test 32) then 64%nat
  else if negb (test 16) then 32%nat
  else if negb (test 8) then 16%nat
  else if negb (test 4) then 8%nat
  else if negb (test 2) then 4%nat
  else 2%nat.

(** A valid logical immediate is
- neither [0] nor [-1];
- composed of a repetition [BBBBB] of a bit-pattern [B] of length [e]
- the low [e] bits of the number, that is, [B], match [0*1*0*] or [1*0*1*].
*)

Definition is_logical_imm32 (x: int) : bool :=
  negb (Int.eq x Int.zero) && negb (Int.eq x Int.mone) &&
  Automaton.run (logical_imm_length (Int.unsigned x) false)
                Automaton.start (Int.unsigned x).

Definition is_logical_imm64 (x: int64) : bool :=
  negb (Int64.eq x Int64.zero) && negb (Int64.eq x Int64.mone) &&
  Automaton.run (logical_imm_length (Int64.unsigned x) true)
                Automaton.start (Int64.unsigned x).

(** Arithmetic immediates are 12-bit unsigned numbers, possibly shifted left 12 bits *)

Definition is_arith_imm32 (x: int) : bool :=
  Int.eq x (Int.zero_ext 12 x)
  || Int.eq x (Int.shl (Int.zero_ext 12 (Int.shru x (Int.repr 12))) (Int.repr 12)).

Definition is_arith_imm64 (x: int64) : bool :=
  Int64.eq x (Int64.zero_ext 12 x)
  || Int64.eq x (Int64.shl (Int64.zero_ext 12 (Int64.shru x (Int64.repr 12))) (Int64.repr 12)).

(** Decompose integer literals into 16-bit fragments *)

Fixpoint decompose_int (N: nat) (n p: Z) {struct N} : list (Z * Z) :=
  match N with
  | Datatypes.O => nil
  | Datatypes.S N =>
    let frag := Zzero_ext 16 (Z.shiftr n p) in
    if Z.eqb frag 0 then
      decompose_int N n (p + 16)
    else
      (frag, p) :: decompose_int N (Z.ldiff n (Z.shiftl 65535 p)) (p + 16)
  end.

Definition negate_decomposition (l: list (Z * Z)) :=
  List.map (fun np => (Z.lxor (fst np) 65535, snd np)) l.

Definition loadimm_k (sz: isize) (rd: ireg) (l: list (Z * Z)) (k: code) : code :=
  List.fold_right (fun np k => Pmovk sz rd (fst np) (snd np) :: k) k l.

Definition loadimm_z (sz: isize) (rd: ireg) (l: list (Z * Z)) (k: code) : code :=
  match l with
  | nil => Pmovz sz rd 0 0 :: k
  | (n1, p1) :: l => Pmovz sz rd n1 p1 :: loadimm_k sz rd l k
  end.

Definition loadimm_n (sz: isize) (rd: ireg) (l: list (Z * Z)) (k: code) : code :=
  match l with
  | nil => Pmovn sz rd 0 0 :: k
  | (n1, p1) :: l => Pmovn sz rd n1 p1 :: loadimm_k sz rd (negate_decomposition l) k
  end.

Definition loadimm (sz: isize) (rd: ireg) (n: Z) (k: code) : code :=
  let N := match sz with W => 2%nat | X => 4%nat end in
  let dz := decompose_int N n 0 in
  let dn := decompose_int N (Z.lnot n) 0 in
  if Nat.leb (List.length dz) (List.length dn)
  then loadimm_z sz rd dz k
  else loadimm_n sz rd dn k.

Definition loadimm32 (rd: ireg) (n: int) (k: code) : code :=
  if is_logical_imm32 n
  then Porrimm W rd XZR (Int.unsigned n) :: k
  else loadimm W rd (Int.unsigned n) k.

Definition loadimm64 (rd: ireg) (n: int64) (k: code) : code :=
  if is_logical_imm64 n
  then Porrimm X rd XZR (Int64.unsigned n) :: k
  else loadimm X rd (Int64.unsigned n) k.

(** Add immediate *)

Definition addimm_aux (insn: iregsp -> iregsp -> Z -> instruction)
                        (rd r1: iregsp) (n: Z) (k: code) :=
  let nlo := Zzero_ext 12 n in
  let nhi := n - nlo in
  if Z.eqb nhi 0 then
    insn rd r1 nlo :: k
  else if Z.eqb nlo 0 then
    insn rd r1 nhi :: k
  else
    insn rd r1 nhi :: insn rd rd nlo :: k.

Definition addimm32 (rd r1: ireg) (n: int) (k: code) : code :=
  let m := Int.neg n in
  if Int.eq n (Int.zero_ext 24 n) then
    addimm_aux (Paddimm W) rd r1 (Int.unsigned n) k
  else if Int.eq m (Int.zero_ext 24 m) then
    addimm_aux (Psubimm W) rd r1 (Int.unsigned m) k
  else if Int.lt n Int.zero then
    loadimm32 X16 m (Psub W rd r1 X16 SOnone :: k)
  else
    loadimm32 X16 n (Padd W rd r1 X16 SOnone :: k).

Definition addimm64 (rd r1: iregsp) (n: int64) (k: code) : code :=
  let m := Int64.neg n in
  if Int64.eq n (Int64.zero_ext 24 n) then
    addimm_aux (Paddimm X) rd r1 (Int64.unsigned n) k
  else if Int64.eq m (Int64.zero_ext 24 m) then
    addimm_aux (Psubimm X) rd r1 (Int64.unsigned m) k
  else if Int64.lt n Int64.zero then
    loadimm64 X16 m (Psubext rd r1 X16 (EOuxtx Int.zero) :: k)
  else
    loadimm64 X16 n (Paddext rd r1 X16 (EOuxtx Int.zero) :: k).

(** Logical immediate *)

Definition logicalimm32
              (insn1: ireg -> ireg0 -> Z -> instruction)
              (insn2: ireg -> ireg0 -> ireg -> shift_op -> instruction)
              (rd r1: ireg) (n: int) (k: code) : code :=
  if is_logical_imm32 n
  then insn1 rd r1 (Int.unsigned n) :: k
  else loadimm32 X16 n (insn2 rd r1 X16 SOnone :: k).

Definition logicalimm64
              (insn1: ireg -> ireg0 -> Z -> instruction)
              (insn2: ireg -> ireg0 -> ireg -> shift_op -> instruction)
              (rd r1: ireg) (n: int64) (k: code) : code :=
  if is_logical_imm64 n
  then insn1 rd r1 (Int64.unsigned n) :: k
  else loadimm64 X16 n (insn2 rd r1 X16 SOnone :: k).

(** Sign- or zero-extended arithmetic *)

Definition transl_extension (ex: extension) (a: int) : extend_op :=
  match ex with Xsgn32 => EOsxtw a | Xuns32 => EOuxtw a end.

Definition move_extended_base
              (rd: ireg) (r1: ireg) (ex: extension) (k: code) : code :=
  match ex with
  | Xsgn32 => Pcvtsw2x rd r1 :: k
  | Xuns32 => Pcvtuw2x rd r1 :: k
  end.

Definition move_extended
              (rd: ireg) (r1: ireg) (ex: extension) (a: int) (k: code) : code :=
  if Int.eq a Int.zero then
    move_extended_base rd r1 ex k
  else
    move_extended_base rd r1 ex (Padd X rd XZR rd (SOlsl a) :: k).

Definition arith_extended
              (insnX: iregsp -> iregsp -> ireg -> extend_op -> instruction)
              (insnS: ireg -> ireg0 -> ireg -> shift_op -> instruction)
              (rd r1 r2: ireg) (ex: extension) (a: int) (k: code) : code :=
  if Int.ltu a (Int.repr 5) then
    insnX rd r1 r2 (transl_extension ex a) :: k
  else
    move_extended_base X16 r2 ex (insnS rd r1 X16 (SOlsl a) :: k).

(** Extended right shift *)

Definition shrx32 (rd r1: ireg) (n: int) (k: code) : code :=
  if Int.eq n Int.zero then
    Pmov rd r1 :: k
  else
    Porr W X16 XZR r1 (SOasr (Int.repr 31)) ::
    Padd W X16 r1 X16 (SOlsr (Int.sub Int.iwordsize n)) ::
    Porr W rd XZR X16 (SOasr n) :: k.

Definition shrx64 (rd r1: ireg) (n: int) (k: code) : code :=
  if Int.eq n Int.zero then
    Pmov rd r1 :: k
  else
    Porr X X16 XZR r1 (SOasr (Int.repr 63)) ::
    Padd X X16 r1 X16 (SOlsr (Int.sub Int64.iwordsize' n)) ::
    Porr X rd XZR X16 (SOasr n) :: k.

(** Load the address [id + ofs] in [rd] *)

Definition loadsymbol (rd: ireg) (id: ident) (ofs: ptrofs) (k: code) : code :=
  if SelectOp.symbol_is_relocatable id then
    if Ptrofs.eq ofs Ptrofs.zero then
      Ploadsymbol rd id :: k
    else
      Ploadsymbol rd id :: addimm64 rd rd (Ptrofs.to_int64 ofs) k
  else
    Padrp rd id ofs :: Paddadr rd rd id ofs :: k.

(** Translate a shifted operand *)

Definition transl_shift (s: Op.shift) (a: int): Asm.shift_op :=
  match s with
  | Slsl => SOlsl a
  | Slsr => SOlsr a
  | Sasr => SOasr a
  | Sror => SOror a
  end.

(** Translation of a condition.  Prepends to [k] the instructions
  that evaluate the condition and leave its boolean result in one of
  the bits of the condition register.  The bit in question is
  determined by the [crbit_for_cond] function. *)

Definition transl_cond
              (cond: condition) (args: list mreg) (k: code) :=
  match cond, args with
  | (Ccomp c | Ccompu c), a1 :: a2 :: nil =>
      do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pcmp W r1 r2 SOnone :: k)
  | (Ccompshift c s a | Ccompushift c s a), a1 :: a2 :: nil =>
      do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pcmp W r1 r2 (transl_shift s a) :: k)
  | (Ccompimm c n | Ccompuimm c n), a1 :: nil =>
      do r1 <- ireg_of a1;
      OK (if is_arith_imm32 n then
            Pcmpimm W r1 (Int.unsigned n) :: k
          else if is_arith_imm32 (Int.neg n) then
            Pcmnimm W r1 (Int.unsigned (Int.neg n)) :: k
          else
            loadimm32 X16 n (Pcmp W r1 X16 SOnone :: k))
  | (Cmaskzero n | Cmasknotzero n), a1 :: nil =>
      do r1 <- ireg_of a1;
      OK (if is_logical_imm32 n then
            Ptstimm W r1 (Int.unsigned n) :: k
          else
            loadimm32 X16 n (Ptst W r1 X16 SOnone :: k))
  | (Ccompl c | Ccomplu c), a1 :: a2 :: nil =>
      do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pcmp X r1 r2 SOnone :: k)
  | (Ccomplshift c s a | Ccomplushift c s a), a1 :: a2 :: nil =>
      do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pcmp X r1 r2 (transl_shift s a) :: k)
  | (Ccomplimm c n | Ccompluimm c n), a1 :: nil =>
      do r1 <- ireg_of a1;
      OK (if is_arith_imm64 n then
            Pcmpimm X r1 (Int64.unsigned n) :: k
          else if is_arith_imm64 (Int64.neg n) then
            Pcmnimm X r1 (Int64.unsigned (Int64.neg n)) :: k
          else
            loadimm64 X16 n (Pcmp X r1 X16 SOnone :: k))
  | (Cmasklzero n | Cmasklnotzero n), a1 :: nil =>
      do r1 <- ireg_of a1;
      OK (if is_logical_imm64 n then
            Ptstimm X r1 (Int64.unsigned n) :: k
          else
            loadimm64 X16 n (Ptst X r1 X16 SOnone :: k))
  | Ccompf cmp, a1 :: a2 :: nil =>
      do r1 <- freg_of a1; do r2 <- freg_of a2;
      OK (Pfcmp D r1 r2 :: k)
  | Cnotcompf cmp, a1 :: a2 :: nil =>
      do r1 <- freg_of a1; do r2 <- freg_of a2;
      OK (Pfcmp D r1 r2 :: k)
  | Ccompfzero cmp, a1 :: nil =>
      do r1 <- freg_of a1;
      OK (Pfcmp0 D r1 :: k)
  | Cnotcompfzero cmp, a1 :: nil =>
      do r1 <- freg_of a1;
      OK (Pfcmp0 D r1 :: k)
  | Ccompfs cmp, a1 :: a2 :: nil =>
      do r1 <- freg_of a1; do r2 <- freg_of a2;
      OK (Pfcmp S r1 r2 :: k)
  | Cnotcompfs cmp, a1 :: a2 :: nil =>
      do r1 <- freg_of a1; do r2 <- freg_of a2;
      OK (Pfcmp S r1 r2 :: k)
  | Ccompfszero cmp, a1 :: nil =>
      do r1 <- freg_of a1;
      OK (Pfcmp0 S r1 :: k)
  | Cnotcompfszero cmp, a1 :: nil =>
      do r1 <- freg_of a1;
      OK (Pfcmp0 S r1 :: k)
  | _, _ =>
      Error(msg "Asmgen.transl_cond")
  end.

Definition cond_for_signed_cmp (cmp: comparison) :=
  match cmp with
  | Ceq => TCeq
  | Cne => TCne
  | Clt => TClt
  | Cle => TCle
  | Cgt => TCgt
  | Cge => TCge
  end.

Definition cond_for_unsigned_cmp (cmp: comparison) :=
  match cmp with
  | Ceq => TCeq
  | Cne => TCne
  | Clt => TClo
  | Cle => TCls
  | Cgt => TChi
  | Cge => TChs
  end.

Definition cond_for_float_cmp (cmp: comparison) :=
  match cmp with
  | Ceq => TCeq
  | Cne => TCne
  | Clt => TCmi
  | Cle => TCls
  | Cgt => TCgt
  | Cge => TCge
  end.

Definition cond_for_float_not_cmp (cmp: comparison) :=
  match cmp with
  | Ceq => TCne
  | Cne => TCeq
  | Clt => TCpl
  | Cle => TChi
  | Cgt => TCle
  | Cge => TClt
  end.

Definition cond_for_cond (cond: condition) :=
  match cond with
  | Ccomp cmp => cond_for_signed_cmp cmp
  | Ccompu cmp => cond_for_unsigned_cmp cmp
  | Ccompshift cmp s a => cond_for_signed_cmp cmp
  | Ccompushift cmp s a => cond_for_unsigned_cmp cmp
  | Ccompimm cmp n => cond_for_signed_cmp cmp
  | Ccompuimm cmp n => cond_for_unsigned_cmp cmp
  | Cmaskzero n => TCeq
  | Cmasknotzero n => TCne
  | Ccompl cmp => cond_for_signed_cmp cmp
  | Ccomplu cmp => cond_for_unsigned_cmp cmp
  | Ccomplshift cmp s a => cond_for_signed_cmp cmp
  | Ccomplushift cmp s a => cond_for_unsigned_cmp cmp
  | Ccomplimm cmp n => cond_for_signed_cmp cmp
  | Ccompluimm cmp n => cond_for_unsigned_cmp cmp
  | Cmasklzero n => TCeq
  | Cmasklnotzero n => TCne
  | Ccompf cmp => cond_for_float_cmp cmp
  | Cnotcompf cmp => cond_for_float_not_cmp cmp
  | Ccompfzero cmp => cond_for_float_cmp cmp
  | Cnotcompfzero cmp => cond_for_float_not_cmp cmp
  | Ccompfs cmp => cond_for_float_cmp cmp
  | Cnotcompfs cmp => cond_for_float_not_cmp cmp
  | Ccompfszero cmp => cond_for_float_cmp cmp
  | Cnotcompfszero cmp => cond_for_float_not_cmp cmp
  end.

(** Translation of a conditional branch.  Prepends to [k] the instructions
  that evaluate the condition and ranch to [lbl] if it holds.
  We recognize some conditional branches that can be implemented
  without setting then testing condition flags.  *)

Definition transl_cond_branch_default
              (c: condition) (args: list mreg) (lbl: label) (k: code) :=
  transl_cond c args (Pbc (cond_for_cond c) lbl :: k).

Definition transl_cond_branch
              (c: condition) (args: list mreg) (lbl: label) (k: code) :=
  match args, c with
  | a1 :: nil, (Ccompimm Cne n | Ccompuimm Cne n) =>
      if Int.eq n Int.zero
      then (do r1 <- ireg_of a1; OK (Pcbnz W r1 lbl :: k))
      else transl_cond_branch_default c args lbl k
  | a1 :: nil, (Ccompimm Ceq n | Ccompuimm Ceq n) =>
      if Int.eq n Int.zero
      then (do r1 <- ireg_of a1; OK (Pcbz W r1 lbl :: k))
      else transl_cond_branch_default c args lbl k
  | a1 :: nil, (Ccomplimm Cne n | Ccompluimm Cne n) =>
      if Int64.eq n Int64.zero
      then (do r1 <- ireg_of a1; OK (Pcbnz X r1 lbl :: k))
      else transl_cond_branch_default c args lbl k
  | a1 :: nil, (Ccomplimm Ceq n | Ccompluimm Ceq n) =>
      if Int64.eq n Int64.zero
      then (do r1 <- ireg_of a1; OK (Pcbz X r1 lbl :: k))
      else transl_cond_branch_default c args lbl k
  | a1 :: nil, Cmaskzero n =>
      match Int.is_power2 n with
      | Some bit => do r1 <- ireg_of a1; OK (Ptbz W r1 bit lbl :: k)
      | None => transl_cond_branch_default c args lbl k
      end
  | a1 :: nil, Cmasknotzero n =>
      match Int.is_power2 n with
      | Some bit => do r1 <- ireg_of a1; OK (Ptbnz W r1 bit lbl :: k)
      | None => transl_cond_branch_default c args lbl k
      end
  | a1 :: nil, Cmasklzero n =>
      match Int64.is_power2' n with
      | Some bit => do r1 <- ireg_of a1; OK (Ptbz X r1 bit lbl :: k)
      | None => transl_cond_branch_default c args lbl k
      end
  | a1 :: nil, Cmasklnotzero n =>
      match Int64.is_power2' n with
      | Some bit => do r1 <- ireg_of a1; OK (Ptbnz X r1 bit lbl :: k)
      | None => transl_cond_branch_default c args lbl k
      end
  | _, _ =>
      transl_cond_branch_default c args lbl k
  end.

(** Translation of the arithmetic operation [res <- op(args)].
    The corresponding instructions are prepended to [k]. *)

Definition transl_op
              (op: operation) (args: list mreg) (res: mreg) (k: code) :=
  match op, args with
  | Omove, a1 :: nil =>
      match preg_of res, preg_of a1 with
      | IR r, IR a => OK (Pmov r a :: k)
      | FR r, FR a => OK (Pfmov r a :: k)
      |  _  ,  _   => Error(msg "Asmgen.Omove")
      end
  | Ointconst n, nil =>
      do rd <- ireg_of res;
      OK (loadimm32 rd n k)
  | Olongconst n, nil =>
      do rd <- ireg_of res;
      OK (loadimm64 rd n k)
  | Ofloatconst f, nil =>
      do rd <- freg_of res;
      OK (if Float.eq_dec f Float.zero
          then Pfmovi D rd XZR :: k
          else Pfmovimmd rd f :: k)
  | Osingleconst f, nil =>
      do rd <- freg_of res;
      OK (if Float32.eq_dec f Float32.zero
          then Pfmovi S rd XZR :: k
          else Pfmovimms rd f :: k)
  | Oaddrsymbol id ofs, nil =>
      do rd <- ireg_of res;
      OK (loadsymbol rd id ofs k)
  | Oaddrstack ofs, nil =>
      do rd <- ireg_of res;
      OK (addimm64 rd XSP (Ptrofs.to_int64 ofs) k)
(** 32-bit integer arithmetic *)
  | Oshift s a, a1 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1;
      OK (Porr W rd XZR r1 (transl_shift s a) :: k)
  | Oadd, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Padd W rd r1 r2 SOnone :: k)
  | Oaddshift s a, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Padd W rd r1 r2 (transl_shift s a) :: k)
  | Oaddimm n, a1 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1;
      OK (addimm32 rd r1 n k)
  | Oneg, a1 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1;
      OK (Psub W rd XZR r1 SOnone :: k)
  | Onegshift s a, a1 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1;
      OK (Psub W rd XZR r1 (transl_shift s a) :: k)
  | Osub, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Psub W rd r1 r2 SOnone :: k)
  | Osubshift s a, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Psub W rd r1 r2 (transl_shift s a) :: k)
  | Omul, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pmadd W rd r1 r2 XZR :: k)
  | Omuladd, a1 :: a2 :: a3 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r3 <- ireg_of a3;
      OK (Pmadd W rd r2 r3 r1 :: k)
  | Omulsub, a1 :: a2 :: a3 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r3 <- ireg_of a3;
      OK (Pmsub W rd r2 r3 r1 :: k)
  | Odiv, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Psdiv W rd r1 r2 :: k)
  | Odivu, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pudiv W rd r1 r2 :: k)
  | Oand, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pand W rd r1 r2 SOnone :: k)
  | Oandshift s a, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pand W rd r1 r2 (transl_shift s a) :: k)
  | Oandimm n, a1 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1;
      OK (logicalimm32 (Pandimm W) (Pand W) rd r1 n k)
  | Oor, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Porr W rd r1 r2 SOnone :: k)
  | Oorshift s a, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Porr W rd r1 r2 (transl_shift s a) :: k)
  | Oorimm n, a1 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1;
      OK (logicalimm32 (Porrimm W) (Porr W) rd r1 n k)
  | Oxor, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Peor W rd r1 r2 SOnone :: k)
  | Oxorshift s a, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Peor W rd r1 r2 (transl_shift s a) :: k)
  | Oxorimm n, a1 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1;
      OK (logicalimm32 (Peorimm W) (Peor W) rd r1 n k)
  | Onot, a1 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1;
      OK (Porn W rd XZR r1 SOnone :: k)
  | Onotshift s a, a1 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1;
      OK (Porn W rd XZR r1 (transl_shift s a) :: k)
  | Obic, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pbic W rd r1 r2 SOnone :: k)
  | Obicshift s a, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pbic W rd r1 r2 (transl_shift s a) :: k)
  | Oorn, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Porn W rd r1 r2 SOnone :: k)
  | Oornshift s a, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Porn W rd r1 r2 (transl_shift s a) :: k)
  | Oeqv, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Peon W rd r1 r2 SOnone :: k)
  | Oeqvshift s a, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Peon W rd r1 r2 (transl_shift s a) :: k)
  | Oshl, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Plslv W rd r1 r2 :: k)
  | Oshr, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pasrv W rd r1 r2 :: k)
  | Oshru, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Plsrv W rd r1 r2 :: k)
  | Oshrximm n, a1 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1;
      OK (shrx32 rd r1 n k)
  | Ozext s, a1 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1;
      OK (Pubfiz W rd r1 Int.zero s :: k)
  | Osext s, a1 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1;
      OK (Psbfiz W rd r1 Int.zero s :: k)
  | Oshlzext s a, a1 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1;
      OK (Pubfiz W rd r1 a (Z.min s (Int.zwordsize - Int.unsigned a)) :: k)
  | Oshlsext s a, a1 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1;
      OK (Psbfiz W rd r1 a (Z.min s (Int.zwordsize - Int.unsigned a)) :: k)
  | Ozextshr a s, a1 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1;
      OK (Pubfx W rd r1 a (Z.min s (Int.zwordsize - Int.unsigned a)) :: k)
  | Osextshr a s, a1 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1;
      OK (Psbfx W rd r1 a (Z.min s (Int.zwordsize - Int.unsigned a)) :: k)
(** 64-bit integer arithmetic *)
  | Oshiftl s a, a1 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1;
      OK (Porr X rd XZR r1 (transl_shift s a) :: k)
  | Oextend x a, a1 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1;
      OK (move_extended rd r1 x a k)
  (* [Omakelong] and [Ohighlong] should not occur *)
  | Olowlong, a1 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1;
      assertion (ireg_eq rd r1);
      OK (Pcvtx2w rd :: k)
  | Oaddl, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Padd X rd r1 r2 SOnone :: k)
  | Oaddlshift s a, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Padd X rd r1 r2 (transl_shift s a) :: k)
  | Oaddlext x a, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (arith_extended Paddext (Padd X) rd r1 r2 x a k)
  | Oaddlimm n, a1 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1;
      OK (addimm64 rd r1 n k)
  | Onegl, a1 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1;
      OK (Psub X rd XZR r1 SOnone :: k)
  | Oneglshift s a, a1 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1;
      OK (Psub X rd XZR r1 (transl_shift s a) :: k)
  | Osubl, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Psub X rd r1 r2 SOnone :: k)
  | Osublshift s a, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Psub X rd r1 r2 (transl_shift s a) :: k)
  | Osublext x a, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (arith_extended Psubext (Psub X) rd r1 r2 x a k)
  | Omull, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pmadd X rd r1 r2 XZR :: k)
  | Omulladd, a1 :: a2 :: a3 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r3 <- ireg_of a3;
      OK (Pmadd X rd r2 r3 r1 :: k)
  | Omullsub, a1 :: a2 :: a3 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2; do r3 <- ireg_of a3;
      OK (Pmsub X rd r2 r3 r1 :: k)
  | Omullhs, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Psmulh rd r1 r2 :: k)
  | Omullhu, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pumulh rd r1 r2 :: k)
  | Odivl, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Psdiv X rd r1 r2 :: k)
  | Odivlu, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pudiv X rd r1 r2 :: k)
  | Oandl, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pand X rd r1 r2 SOnone :: k)
  | Oandlshift s a, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pand X rd r1 r2 (transl_shift s a) :: k)
  | Oandlimm n, a1 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1;
      OK (logicalimm64 (Pandimm X) (Pand X) rd r1 n k)
  | Oorl, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Porr X rd r1 r2 SOnone :: k)
  | Oorlshift s a, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Porr X rd r1 r2 (transl_shift s a) :: k)
  | Oorlimm n, a1 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1;
      OK (logicalimm64 (Porrimm X) (Porr X) rd r1 n k)
  | Oxorl, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Peor X rd r1 r2 SOnone :: k)
  | Oxorlshift s a, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Peor X rd r1 r2 (transl_shift s a) :: k)
  | Oxorlimm n, a1 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1;
      OK (logicalimm64 (Peorimm X) (Peor X) rd r1 n k)
  | Onotl, a1 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1;
      OK (Porn X rd XZR r1 SOnone :: k)
  | Onotlshift s a, a1 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1;
      OK (Porn X rd XZR r1 (transl_shift s a) :: k)
  | Obicl, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pbic X rd r1 r2 SOnone :: k)
  | Obiclshift s a, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pbic X rd r1 r2 (transl_shift s a) :: k)
  | Oornl, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Porn X rd r1 r2 SOnone :: k)
  | Oornlshift s a, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Porn X rd r1 r2 (transl_shift s a) :: k)
  | Oeqvl, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Peon X rd r1 r2 SOnone :: k)
  | Oeqvlshift s a, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Peon X rd r1 r2 (transl_shift s a) :: k)
  | Oshll, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Plslv X rd r1 r2 :: k)
  | Oshrl, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Pasrv X rd r1 r2 :: k)
  | Oshrlu, a1 :: a2 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (Plsrv X rd r1 r2 :: k)
  | Oshrlximm n, a1 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1;
      OK (shrx64 rd r1 n k)
  | Ozextl s, a1 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1;
      OK (Pubfiz X rd r1 Int.zero s :: k)
  | Osextl s, a1 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1;
      OK (Psbfiz X rd r1 Int.zero s :: k)
  | Oshllzext s a, a1 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1;
      OK (Pubfiz X rd r1 a (Z.min s (Int64.zwordsize - Int.unsigned a)) :: k)
  | Oshllsext s a, a1 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1;
      OK (Psbfiz X rd r1 a (Z.min s (Int64.zwordsize - Int.unsigned a)) :: k)
  | Ozextshrl a s, a1 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1;
      OK (Pubfx X rd r1 a (Z.min s (Int64.zwordsize - Int.unsigned a)) :: k)
  | Osextshrl a s, a1 :: nil =>
      do rd <- ireg_of res; do r1 <- ireg_of a1;
      OK (Psbfx X rd r1 a (Z.min s (Int64.zwordsize - Int.unsigned a)) :: k)
(** 64-bit floating-point arithmetic *)
  | Onegf, a1 :: nil =>
      do rd <- freg_of res; do rs <- freg_of a1;
      OK (Pfneg D rd rs :: k)
  | Oabsf, a1 :: nil =>
      do rd <- freg_of res; do rs <- freg_of a1;
      OK (Pfabs D rd rs :: k)
  | Oaddf, a1 :: a2 :: nil =>
      do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2;
      OK (Pfadd D rd rs1 rs2 :: k)
  | Osubf, a1 :: a2 :: nil =>
      do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2;
      OK (Pfsub D rd rs1 rs2 :: k)
  | Omulf, a1 :: a2 :: nil =>
      do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2;
      OK (Pfmul D rd rs1 rs2 :: k)
  | Odivf, a1 :: a2 :: nil =>
      do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2;
      OK (Pfdiv D rd rs1 rs2 :: k)
(** 32-bit floating-point arithmetic *)
  | Onegfs, a1 :: nil =>
      do rd <- freg_of res; do rs <- freg_of a1;
      OK (Pfneg S rd rs :: k)
  | Oabsfs, a1 :: nil =>
      do rd <- freg_of res; do rs <- freg_of a1;
      OK (Pfabs S rd rs :: k)
  | Oaddfs, a1 :: a2 :: nil =>
      do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2;
      OK (Pfadd S rd rs1 rs2 :: k)
  | Osubfs, a1 :: a2 :: nil =>
      do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2;
      OK (Pfsub S rd rs1 rs2 :: k)
  | Omulfs, a1 :: a2 :: nil =>
      do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2;
      OK (Pfmul S rd rs1 rs2 :: k)
  | Odivfs, a1 :: a2 :: nil =>
      do rd <- freg_of res; do rs1 <- freg_of a1; do rs2 <- freg_of a2;
      OK (Pfdiv S rd rs1 rs2 :: k)
  | Osingleoffloat, a1 :: nil =>
      do rd <- freg_of res; do rs <- freg_of a1;
      OK (Pfcvtsd rd rs :: k)
  | Ofloatofsingle, a1 :: nil =>
      do rd <- freg_of res; do rs <- freg_of a1;
      OK (Pfcvtds rd rs :: k)
(** Conversions between int and float *)
  | Ointoffloat, a1 :: nil =>
      do rd <- ireg_of res; do rs <- freg_of a1;
      OK (Pfcvtzs W D rd rs :: k)
  | Ointuoffloat, a1 :: nil =>
      do rd <- ireg_of res; do rs <- freg_of a1;
      OK (Pfcvtzu W D rd rs :: k)
  | Ofloatofint, a1 :: nil =>
      do rd <- freg_of res; do rs <- ireg_of a1;
      OK (Pscvtf D W rd rs :: k)
  | Ofloatofintu, a1 :: nil =>
      do rd <- freg_of res; do rs <- ireg_of a1;
      OK (Pucvtf D W rd rs :: k)
  | Ointofsingle, a1 :: nil =>
      do rd <- ireg_of res; do rs <- freg_of a1;
      OK (Pfcvtzs W S rd rs :: k)
  | Ointuofsingle, a1 :: nil =>
      do rd <- ireg_of res; do rs <- freg_of a1;
      OK (Pfcvtzu W S rd rs :: k)
  | Osingleofint, a1 :: nil =>
      do rd <- freg_of res; do rs <- ireg_of a1;
      OK (Pscvtf S W rd rs :: k)
  | Osingleofintu, a1 :: nil =>
      do rd <- freg_of res; do rs <- ireg_of a1;
      OK (Pucvtf S W rd rs :: k)
  | Olongoffloat, a1 :: nil =>
      do rd <- ireg_of res; do rs <- freg_of a1;
      OK (Pfcvtzs X D rd rs :: k)
  | Olonguoffloat, a1 :: nil =>
      do rd <- ireg_of res; do rs <- freg_of a1;
      OK (Pfcvtzu X D rd rs :: k)
  | Ofloatoflong, a1 :: nil =>
      do rd <- freg_of res; do rs <- ireg_of a1;
      OK (Pscvtf D X rd rs :: k)
  | Ofloatoflongu, a1 :: nil =>
      do rd <- freg_of res; do rs <- ireg_of a1;
      OK (Pucvtf D X rd rs :: k)
  | Olongofsingle, a1 :: nil =>
      do rd <- ireg_of res; do rs <- freg_of a1;
      OK (Pfcvtzs X S rd rs :: k)
  | Olonguofsingle, a1 :: nil =>
      do rd <- ireg_of res; do rs <- freg_of a1;
      OK (Pfcvtzu X S rd rs :: k)
  | Osingleoflong, a1 :: nil =>
      do rd <- freg_of res; do rs <- ireg_of a1;
      OK (Pscvtf S X rd rs :: k)
  | Osingleoflongu, a1 :: nil =>
      do rd <- freg_of res; do rs <- ireg_of a1;
      OK (Pucvtf S X rd rs :: k)
(** Boolean tests *)
  | Ocmp c, _ =>
      do rd <- ireg_of res;
      transl_cond c args (Pcset rd (cond_for_cond c) :: k)
(** Conditional move *)
  | Osel cmp ty, a1 :: a2 :: args =>
      match preg_of res with
      | IR r =>
          do r1 <- ireg_of a1; do r2 <- ireg_of a2;
          transl_cond cmp args (Pcsel r r1 r2 (cond_for_cond cmp) :: k)
      | FR r =>
          do r1 <- freg_of a1; do r2 <- freg_of a2;
          transl_cond cmp args (Pfsel r r1 r2 (cond_for_cond cmp) :: k)
      | _ =>
          Error(msg "Asmgen.Osel")
      end
  | _, _ =>
      Error(msg "Asmgen.transl_op")
  end.

(** Translation of addressing modes *)

Definition offset_representable (sz: Z) (ofs: int64) : bool :=
  let isz := Int64.repr sz in
  (** either unscaled 9-bit signed *)
  Int64.eq ofs (Int64.sign_ext 9 ofs) ||
  (** or scaled 12-bit unsigned *)
  (Int64.eq (Int64.modu ofs isz) Int64.zero
   && Int64.ltu ofs (Int64.shl isz (Int64.repr 12))).

Definition transl_addressing (sz: Z) (addr: Op.addressing) (args: list mreg)
                             (insn: Asm.addressing -> instruction) (k: code) : res code :=
  match addr, args with
  | Aindexed ofs, a1 :: nil =>
      do r1 <- ireg_of a1;
       if offset_representable sz ofs then
        OK (insn (ADimm r1 ofs) :: k)
      else
        OK (loadimm64 X16 ofs (insn (ADreg r1 X16) :: k))
  | Aindexed2, a1 :: a2 :: nil =>
      do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      OK (insn (ADreg r1 r2) :: k)
  | Aindexed2shift a, a1 :: a2 :: nil =>
      do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      if Int.eq a Int.zero then
        OK (insn (ADreg r1 r2) :: k)
      else if Int.eq (Int.shl Int.one a) (Int.repr sz) then
        OK (insn (ADlsl r1 r2 a) :: k)
      else
        OK (Padd X X16 r1 r2 (SOlsl a) :: insn (ADimm X16 Int64.zero) :: k)
  | Aindexed2ext x a, a1 :: a2 :: nil =>
      do r1 <- ireg_of a1; do r2 <- ireg_of a2;
      if Int.eq a Int.zero || Int.eq (Int.shl Int.one a) (Int.repr sz) then
        OK (insn (match x with Xsgn32 => ADsxt r1 r2 a
                             | Xuns32 => ADuxt r1 r2 a end) :: k)
      else
        OK (arith_extended Paddext (Padd X) X16 r1 r2 x a
                           (insn (ADimm X16 Int64.zero) :: k))
  | Aglobal id ofs, nil =>
      assertion (negb (SelectOp.symbol_is_relocatable id));
      if Ptrofs.eq (Ptrofs.modu ofs (Ptrofs.repr sz)) Ptrofs.zero && symbol_is_aligned id sz
      then OK (Padrp X16 id ofs :: insn (ADadr X16 id ofs) :: k)
      else OK (loadsymbol X16 id ofs (insn (ADimm X16 Int64.zero) :: k))
  | Ainstack ofs, nil =>
      let ofs := Ptrofs.to_int64 ofs in
      if offset_representable sz ofs then
        OK (insn (ADimm XSP ofs) :: k)
      else
        OK (loadimm64 X16 ofs (insn (ADreg XSP X16) :: k))
  | _, _ =>
      Error(msg "Asmgen.transl_addressing")
  end.

(** Translation of loads and stores *)

Definition transl_load (chunk: memory_chunk) (addr: Op.addressing)
                       (args: list mreg) (dst: mreg) (k: code) : res code :=
  match chunk with
  | Mint8unsigned =>
      do rd <- ireg_of dst; transl_addressing 1 addr args (Pldrb W rd) k
  | Mint8signed =>
      do rd <- ireg_of dst; transl_addressing 1 addr args (Pldrsb W rd) k
  | Mint16unsigned =>
      do rd <- ireg_of dst; transl_addressing 2 addr args (Pldrh W rd) k
  | Mint16signed =>
      do rd <- ireg_of dst; transl_addressing 2 addr args (Pldrsh W rd) k
  | Mint32 =>
      do rd <- ireg_of dst; transl_addressing 4 addr args (Pldrw rd) k
  | Mint64 =>
      do rd <- ireg_of dst; transl_addressing 8 addr args (Pldrx rd) k
  | Mfloat32 =>
      do rd <- freg_of dst; transl_addressing 4 addr args (Pldrs rd) k
  | Mfloat64 =>
      do rd <- freg_of dst; transl_addressing 8 addr args (Pldrd rd) k
  | Many32 =>
      do rd <- ireg_of dst; transl_addressing 4 addr args (Pldrw_a rd) k
  | Many64 =>
      do rd <- ireg_of dst; transl_addressing 8 addr args (Pldrx_a rd) k
  end.

Definition transl_store (chunk: memory_chunk) (addr: Op.addressing)
                        (args: list mreg) (src: mreg) (k: code) : res code :=
  match chunk with
  | Mint8unsigned | Mint8signed =>
      do r1 <- ireg_of src; transl_addressing 1 addr args (Pstrb r1) k
  | Mint16unsigned | Mint16signed =>
      do r1 <- ireg_of src; transl_addressing 2 addr args (Pstrh r1) k
  | Mint32 =>
      do r1 <- ireg_of src; transl_addressing 4 addr args (Pstrw r1) k
  | Mint64 =>
      do r1 <- ireg_of src; transl_addressing 8 addr args (Pstrx r1) k
  | Mfloat32 =>
      do r1 <- freg_of src; transl_addressing 4 addr args (Pstrs r1) k
  | Mfloat64 =>
      do r1 <- freg_of src; transl_addressing 8 addr args (Pstrd r1) k
  | Many32 =>
      do r1 <- ireg_of src; transl_addressing 4 addr args (Pstrw_a r1) k
  | Many64 =>
      do r1 <- ireg_of src; transl_addressing 8 addr args (Pstrx_a r1) k
  end.

(** Register-indexed loads and stores *)

Definition indexed_memory_access (insn: Asm.addressing -> instruction)
                                 (sz: Z) (base: iregsp) (ofs: ptrofs) (k: code) :=
  let ofs := Ptrofs.to_int64 ofs in
  if offset_representable sz ofs
  then insn (ADimm base ofs) :: k
  else loadimm64 X16 ofs (insn (ADreg base X16) :: k).

Definition loadind (base: iregsp) (ofs: ptrofs) (ty: typ) (dst: mreg) (k: code) :=
  match ty, preg_of dst with
  | Tint,    IR rd => OK (indexed_memory_access (Pldrw rd) 4 base ofs k)
  | Tlong,   IR rd => OK (indexed_memory_access (Pldrx rd) 8 base ofs k)
  | Tsingle, FR rd => OK (indexed_memory_access (Pldrs rd) 4 base ofs k)
  | Tfloat,  FR rd => OK (indexed_memory_access (Pldrd rd) 8 base ofs k)
  | Tany32,  IR rd => OK (indexed_memory_access (Pldrw_a rd) 4 base ofs k)
  | Tany64,  IR rd => OK (indexed_memory_access (Pldrx_a rd) 8 base ofs k)
  | Tany64,  FR rd => OK (indexed_memory_access (Pldrd_a rd) 8 base ofs k)
  | _, _           => Error (msg "Asmgen.loadind")
  end.

Definition storeind (src: mreg) (base: iregsp) (ofs: ptrofs) (ty: typ) (k: code) :=
  match ty, preg_of src with
  | Tint,    IR rd => OK (indexed_memory_access (Pstrw rd) 4 base ofs k)
  | Tlong,   IR rd => OK (indexed_memory_access (Pstrx rd) 8 base ofs k)
  | Tsingle, FR rd => OK (indexed_memory_access (Pstrs rd) 4 base ofs k)
  | Tfloat,  FR rd => OK (indexed_memory_access (Pstrd rd) 8 base ofs k)
  | Tany32,  IR rd => OK (indexed_memory_access (Pstrw_a rd) 4 base ofs k)
  | Tany64,  IR rd => OK (indexed_memory_access (Pstrx_a rd) 8 base ofs k)
  | Tany64,  FR rd => OK (indexed_memory_access (Pstrd_a rd) 8 base ofs k)
  | _, _           => Error (msg "Asmgen.storeind")
  end.

Definition loadptr (base: iregsp) (ofs: ptrofs) (dst: ireg) (k: code) :=
  indexed_memory_access (Pldrx dst) 8 base ofs k.

Definition storeptr (src: ireg) (base: iregsp) (ofs: ptrofs) (k: code) :=
  indexed_memory_access (Pstrx src) 8 base ofs k.

(** Function epilogue *)

Definition make_epilogue (f: Mach.function) (k: code) :=
  loadptr XSP f.(fn_retaddr_ofs) RA
    (Pfreeframe f.(fn_stacksize) f.(fn_link_ofs) :: k).

(** Translation of a Mach instruction. *)

Definition transl_instr (f: Mach.function) (i: Mach.instruction)
                        (r15_is_parent: bool) (k: code) : res code :=
  match i with
  | Mgetstack ofs ty dst =>
      loadind XSP ofs ty dst k
  | Msetstack src ofs ty =>
      storeind src XSP ofs ty k
  | Mgetparam ofs ty dst =>
      (* load via the frame pointer if it is valid *)
      do c <- loadind X15 ofs ty dst k;
      OK (if r15_is_parent then c else loadptr XSP f.(fn_link_ofs) X15 c)
  | Mop op args res =>
      transl_op op args res k
  | Mload chunk addr args dst =>
      transl_load chunk addr args dst k
  | Mstore chunk addr args src =>
      transl_store chunk addr args src k
  | Mcall sig (inl r) =>
      do r1 <- ireg_of r; OK (Pblr r1 sig :: k)
  | Mcall sig (inr symb) =>
      OK (Pbl symb sig :: k)
  | Mtailcall sig (inl r) =>
      do r1 <- ireg_of r;
      OK (make_epilogue f (Pbr r1 sig :: k))
  | Mtailcall sig (inr symb) =>
      OK (make_epilogue f (Pbs symb sig :: k))
  | Mbuiltin ef args res =>
      OK (Pbuiltin ef (List.map (map_builtin_arg preg_of) args) (map_builtin_res preg_of res) :: k)
  | Mlabel lbl =>
      OK (Plabel lbl :: k)
  | Mgoto lbl =>
      OK (Pb lbl :: k)
  | Mcond cond args lbl =>
      transl_cond_branch cond args lbl k
  | Mjumptable arg tbl =>
      do r <- ireg_of arg;
      OK (Pbtbl r tbl :: k)
  | Mreturn =>
      OK (make_epilogue f (Pret RA :: k))
  end.

(** Translation of a code sequence *)

Definition it1_is_parent (before: bool) (i: Mach.instruction) : bool :=
  match i with
  | Msetstack src ofs ty => before
  | Mgetparam ofs ty dst => negb (mreg_eq dst R15)
  | Mop op args res => before && negb (mreg_eq res R15)
  | _ => false
  end.

(** This is the naive definition that we no longer use because it
  is not tail-recursive.  It is kept as specification. *)

Fixpoint transl_code (f: Mach.function) (il: list Mach.instruction) (it1p: bool) :=
  match il with
  | nil => OK nil
  | i1 :: il' =>
      do k <- transl_code f il' (it1_is_parent it1p i1);
      transl_instr f i1 it1p k
  end.

(** This is an equivalent definition in continuation-passing style
  that runs in constant stack space. *)

Fixpoint transl_code_rec (f: Mach.function) (il: list Mach.instruction)
                         (it1p: bool) (k: code -> res code) :=
  match il with
  | nil => k nil
  | i1 :: il' =>
      transl_code_rec f il' (it1_is_parent it1p i1)
        (fun c1 => do c2 <- transl_instr f i1 it1p c1; k c2)
  end.

Definition transl_code' (f: Mach.function) (il: list Mach.instruction) (it1p: bool) :=
  transl_code_rec f il it1p (fun c => OK c).

(** Translation of a whole function.  Note that we must check
  that the generated code contains less than [2^32] instructions,
  otherwise the offset part of the [PC] code pointer could wrap
  around, leading to incorrect executions. *)

Definition transl_function (f: Mach.function) :=
  do c <- transl_code' f f.(Mach.fn_code) true;
  OK (mkfunction f.(Mach.fn_sig)
        (Pallocframe f.(fn_stacksize) f.(fn_link_ofs) ::
         storeptr RA XSP f.(fn_retaddr_ofs) c)).

Definition transf_function (f: Mach.function) : res Asm.function :=
  do tf <- transl_function f;
  if zlt Ptrofs.max_unsigned (list_length_z tf.(fn_code))
  then Error (msg "code size exceeded")
  else OK tf.

Definition transf_fundef (f: Mach.fundef) : res Asm.fundef :=
  transf_partial_fundef transf_function f.

Definition transf_program (p: Mach.program) : res Asm.program :=
  transform_partial_program transf_fundef p.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C P Q I : Universe, ((wd_ P Q /\ (wd_ A B /\ (wd_ A C /\ (wd_ B C /\ (wd_ A P /\ (wd_ A Q /\ (wd_ B P /\ (wd_ B Q /\ (wd_ C P /\ (wd_ C Q /\ (wd_ B I /\ (wd_ I C /\ (wd_ B C /\ (wd_ P I /\ (wd_ Q I /\ (col_ B I C /\ (col_ P Q I /\ col_ B C P))))))))))))))))) -> col_ B P Q)).
Proof.
  time tac.
Qed.

End FOFProblem.