Module Op


Operators and addressing modes. The abstract syntax and dynamic semantics for the CminorSel, RTL, LTL and Mach languages depend on the following types, defined in this library: These types are processor-specific and correspond roughly to what the processor can compute in one instruction. In other terms, these types reflect the state of the program after instruction selection. For a processor-independent set of operations, see the abstract syntax and dynamic semantics of the Cminor language.

Require Import Axioms.
Require Import Coqlib.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Memory.
Require Import Globalenvs.
Require Import Events.
Require Import ExtValues.
Require Import Errors.
Require Import Unityping.
Require Import Compopts.

Inductive immed_kind := OTHER | ADDSUB | CONST.

Fixpoint is_immed_arith_arm (n: nat) (x: int) {struct n}: bool :=
  match n with
  | Datatypes.O => false
  | Datatypes.S n =>
      Int.eq x (Int.and x (Int.repr 255)) ||
      is_immed_arith_arm n (Int.rol x (Int.repr 2))
  end.

Fixpoint is_immed_arith_thumb (n: nat) (x: int) {struct n}: bool :=
  match n with
  | Datatypes.O => true
  | Datatypes.S n =>
      Int.eq x (Int.and x (Int.repr 255)) ||
      (Int.eq (Int.and x Int.one) Int.zero
       && is_immed_arith_thumb n (Int.shru x Int.one))
  end.

Definition is_immed_arith_thumb_special (imkind: immed_kind) (x: int): bool :=
  (match imkind with
   | ADDSUB => Int.lt x (Int.repr 4096) && (negb (Int.lt x Int.zero))
   | CONST => Int.lt x (Int.repr 65536) && (negb (Int.lt x Int.zero))
   | OTHER => false
   end) ||
  let l1 := Int.and x (Int.repr 255) in
  let l2 := Int.shl l1 (Int.repr 8) in
  let l3 := Int.shl l2 (Int.repr 8) in
  let l4 := Int.shl l3 (Int.repr 8) in
  let l13 := Int.or l1 l3 in
  let l24 := Int.or l2 l4 in
  Int.eq x l13 || Int.eq x l24 || Int.eq x (Int.or l13 l24).

Definition is_immed_arith (imkind: immed_kind) (x: int): bool :=
  if thumb tt
  then is_immed_arith_thumb 24%nat x || is_immed_arith_thumb_special (imkind: immed_kind) x
  else is_immed_arith_arm 16%nat x.

Decomposition of a 32-bit integer into a list of immediate arguments, whose sum or "or" or "xor" equals the integer.

Fixpoint decompose_int_arm (N: nat) (n p: int) : list int :=
  match N with
  | Datatypes.O =>
      if Int.eq n Int.zero then nil else n :: nil
  | Datatypes.S M =>
      if Int.eq (Int.and n (Int.shl (Int.repr 3) p)) Int.zero then
        decompose_int_arm M n (Int.add p (Int.repr 2))
      else
        let m := Int.shl (Int.repr 255) p in
        Int.and n m ::
        decompose_int_arm M (Int.and n (Int.not m)) (Int.add p (Int.repr 2))
  end.

Fixpoint decompose_int_thumb (N: nat) (n p: int) : list int :=
  match N with
  | Datatypes.O =>
      if Int.eq n Int.zero then nil else n :: nil
  | Datatypes.S M =>
      if Int.eq (Int.and n (Int.shl Int.one p)) Int.zero then
        decompose_int_thumb M n (Int.add p Int.one)
      else
        let m := Int.shl (Int.repr 255) p in
        Int.and n m ::
        decompose_int_thumb M (Int.and n (Int.not m)) (Int.add p Int.one)
  end.

Definition decompose_int_base (imkind: immed_kind) (n: int): list int :=
  if thumb tt
  then if is_immed_arith_thumb_special imkind n
       then n :: nil
       else decompose_int_thumb 24%nat n Int.zero
  else decompose_int_arm 12%nat n Int.zero.

Definition decompose_int (imkind: immed_kind) (n: int) : list int :=
  match decompose_int_base imkind n with
  | nil => Int.zero :: nil
  | l => l
  end.

Predicates classifying integer constants by how many ARM/Thumb-2 instructions loadimm / addimm need to materialize them. is_immed_loadimm and is_immed_addimm are the n for which the fast path of those smart constructors emits exactly one instruction.

Definition is_immed_loadimm (n: int) : bool :=
  Nat.leb (List.length (decompose_int CONST n)) 1 ||
  Nat.leb (List.length (decompose_int OTHER (Int.not n))) 1.

Definition is_immed_addimm (n: int) : bool :=
  Nat.leb (List.length (decompose_int ADDSUB n)) 1 ||
  Nat.leb (List.length (decompose_int ADDSUB (Int.neg n))) 1.

Predicates classifying VFP floating-point constants by their vmov.f32 / vmov.f64 immediate-encodability under VFPv3. The encoding accepts a normalized binary float with 1 sign bit, 4 bits of fraction, and a 3-bit biased exponent in -3, 4; only the top 4 mantissa bits may be set. Mirrors Constantexpand.is_immediate_float64.

Definition is_immediate_float64 (f : float) : bool :=
  let bits := Int64.unsigned (Float.to_bits f) in
  let exp := Z.land (Z.shiftr bits 52) 2047 - 1023 in
  let mant := Z.land bits 4503599627370495 in
  let mant_top4 := Z.land mant 4222124650659840 in
  andb (andb (Z.leb (-3) exp) (Z.leb exp 4))
       (Z.eqb mant mant_top4).

Definition is_immediate_float32 (f : float32) : bool :=
  let bits := Int.unsigned (Float32.to_bits f) in
  let exp := Z.land (Z.shiftr bits 23) 255 - 127 in
  let mant := Z.land bits 8388607 in
  let mant_top4 := Z.land mant 7864320 in
  andb (andb (Z.leb (-3) exp) (Z.leb exp 4))
       (Z.eqb mant mant_top4).

Decomposition of an integer constant

Lemma decompose_int_arm_or:
  forall N n p x, List.fold_left Int.or (decompose_int_arm N n p) x = Int.or x n.
Proof.
  induction N; intros; simpl.
  predSpec Int.eq Int.eq_spec n Int.zero; simpl.
  subst n. rewrite Int.or_zero. auto.
  auto.
  predSpec Int.eq Int.eq_spec (Int.and n (Int.shl (Int.repr 3) p)) Int.zero.
  auto.
  simpl. rewrite IHN. rewrite Int.or_assoc. decEq. rewrite <- Int.and_or_distrib.
  rewrite Int.or_not_self. apply Int.and_mone.
Qed.

Lemma decompose_int_arm_xor:
  forall N n p x, List.fold_left Int.xor (decompose_int_arm N n p) x = Int.xor x n.
Proof.
  induction N; intros; simpl.
  predSpec Int.eq Int.eq_spec n Int.zero; simpl.
  subst n. rewrite Int.xor_zero. auto.
  auto.
  predSpec Int.eq Int.eq_spec (Int.and n (Int.shl (Int.repr 3) p)) Int.zero.
  auto.
  simpl. rewrite IHN. rewrite Int.xor_assoc. decEq. rewrite <- Int.and_xor_distrib.
  rewrite Int.xor_not_self. apply Int.and_mone.
Qed.

Lemma decompose_int_arm_add:
  forall N n p x, List.fold_left Int.add (decompose_int_arm N n p) x = Int.add x n.
Proof.
  induction N; intros; simpl.
  predSpec Int.eq Int.eq_spec n Int.zero; simpl.
  subst n. rewrite Int.add_zero. auto.
  auto.
  predSpec Int.eq Int.eq_spec (Int.and n (Int.shl (Int.repr 3) p)) Int.zero.
  auto.
  simpl. rewrite IHN. rewrite Int.add_assoc. decEq. rewrite Int.add_and.
  rewrite Int.or_not_self. apply Int.and_mone. apply Int.and_not_self.
Qed.

Remark decompose_int_arm_nil:
  forall N n p, decompose_int_arm N n p = nil -> n = Int.zero.
Proof.
  intros. generalize (decompose_int_arm_or N n p Int.zero). rewrite H. simpl.
  rewrite Int.or_commut; rewrite Int.or_zero; auto.
Qed.

Lemma decompose_int_thumb_or:
  forall N n p x, List.fold_left Int.or (decompose_int_thumb N n p) x = Int.or x n.
Proof.
  induction N; intros; simpl.
  predSpec Int.eq Int.eq_spec n Int.zero; simpl.
  subst n. rewrite Int.or_zero. auto.
  auto.
  predSpec Int.eq Int.eq_spec (Int.and n (Int.shl Int.one p)) Int.zero.
  auto.
  simpl. rewrite IHN. rewrite Int.or_assoc. decEq. rewrite <- Int.and_or_distrib.
  rewrite Int.or_not_self. apply Int.and_mone.
Qed.

Lemma decompose_int_thumb_xor:
  forall N n p x, List.fold_left Int.xor (decompose_int_thumb N n p) x = Int.xor x n.
Proof.
  induction N; intros; simpl.
  predSpec Int.eq Int.eq_spec n Int.zero; simpl.
  subst n. rewrite Int.xor_zero. auto.
  auto.
  predSpec Int.eq Int.eq_spec (Int.and n (Int.shl Int.one p)) Int.zero.
  auto.
  simpl. rewrite IHN. rewrite Int.xor_assoc. decEq. rewrite <- Int.and_xor_distrib.
  rewrite Int.xor_not_self. apply Int.and_mone.
Qed.

Lemma decompose_int_thumb_add:
  forall N n p x, List.fold_left Int.add (decompose_int_thumb N n p) x = Int.add x n.
Proof.
  induction N; intros; simpl.
  predSpec Int.eq Int.eq_spec n Int.zero; simpl.
  subst n. rewrite Int.add_zero. auto.
  auto.
  predSpec Int.eq Int.eq_spec (Int.and n (Int.shl Int.one p)) Int.zero.
  auto.
  simpl. rewrite IHN. rewrite Int.add_assoc. decEq. rewrite Int.add_and.
  rewrite Int.or_not_self. apply Int.and_mone. apply Int.and_not_self.
Qed.

Remark decompose_int_thumb_nil:
  forall N n p, decompose_int_thumb N n p = nil -> n = Int.zero.
Proof.
  intros. generalize (decompose_int_thumb_or N n p Int.zero). rewrite H. simpl.
  rewrite Int.or_commut; rewrite Int.or_zero; auto.
Qed.

Lemma decompose_int_general:
  forall (f: val -> int -> val) (g: int -> int -> int),
  (forall v1 n2 n3, f (f v1 n2) n3 = f v1 (g n2 n3)) ->
  (forall n1 n2 n3, g (g n1 n2) n3 = g n1 (g n2 n3)) ->
  (forall n, g Int.zero n = n) ->
  (forall N n p x, List.fold_left g (decompose_int_arm N n p) x = g x n) ->
  (forall N n p x, List.fold_left g (decompose_int_thumb N n p) x = g x n) ->
  forall imkind n v,
  List.fold_left f (decompose_int imkind n) v = f v n.
Proof.
  intros f g DISTR ASSOC ZERO DECOMP1 DECOMP2.
  assert (A: forall l x y, g x (fold_left g l y) = fold_left g l (g x y)).
    induction l; intros; simpl. auto. rewrite IHl. decEq. rewrite ASSOC; auto.
  assert (B: forall l v n, fold_left f l (f v n) = f v (fold_left g l n)).
    induction l; intros; simpl.
    auto.
    rewrite IHl. rewrite DISTR. decEq. decEq. auto.
  intros. unfold decompose_int, decompose_int_base.
  destruct (thumb tt); [destruct (is_immed_arith_thumb_special imkind n)|].
- reflexivity.
- destruct (decompose_int_thumb 24%nat n Int.zero) eqn:DB.
  + simpl. exploit decompose_int_thumb_nil; eauto. congruence.
  + simpl. rewrite B. decEq.
    generalize (DECOMP2 24%nat n Int.zero Int.zero).
    rewrite DB; simpl. rewrite ! ZERO. auto.
- destruct (decompose_int_arm 12%nat n Int.zero) eqn:DB.
  + simpl. exploit decompose_int_arm_nil; eauto. congruence.
  + simpl. rewrite B. decEq.
    generalize (DECOMP1 12%nat n Int.zero Int.zero).
    rewrite DB; simpl. rewrite ! ZERO. auto.
Qed.

Lemma decompose_int_or:
  forall imkind n v,
  List.fold_left (fun v i => Val.or v (Vint i)) (decompose_int imkind n) v = Val.or v (Vint n).
Proof.
  intros. apply decompose_int_general with (f := fun v n => Val.or v (Vint n)) (g := Int.or).
  intros. rewrite Val.or_assoc. auto.
  apply Int.or_assoc.
  intros. rewrite Int.or_commut. apply Int.or_zero.
  apply decompose_int_arm_or. apply decompose_int_thumb_or.
Qed.

Lemma decompose_int_bic:
  forall imkind n v,
  List.fold_left (fun v i => Val.and v (Vint (Int.not i))) (decompose_int imkind n) v = Val.and v (Vint (Int.not n)).
Proof.
  intros. apply decompose_int_general with (f := fun v n => Val.and v (Vint (Int.not n))) (g := Int.or).
  intros. rewrite Val.and_assoc. simpl. decEq. decEq. rewrite Int.not_or_and_not. auto.
  apply Int.or_assoc.
  intros. rewrite Int.or_commut. apply Int.or_zero.
  apply decompose_int_arm_or. apply decompose_int_thumb_or.
Qed.

Lemma decompose_int_xor:
  forall imkind n v,
  List.fold_left (fun v i => Val.xor v (Vint i)) (decompose_int imkind n) v = Val.xor v (Vint n).
Proof.
  intros. apply decompose_int_general with (f := fun v n => Val.xor v (Vint n)) (g := Int.xor).
  intros. rewrite Val.xor_assoc. auto.
  apply Int.xor_assoc.
  intros. rewrite Int.xor_commut. apply Int.xor_zero.
  apply decompose_int_arm_xor. apply decompose_int_thumb_xor.
Qed.

Lemma decompose_int_add:
  forall imkind n v,
  List.fold_left (fun v i => Val.add v (Vint i)) (decompose_int imkind n) v = Val.add v (Vint n).
Proof.
  intros. apply decompose_int_general with (f := fun v n => Val.add v (Vint n)) (g := Int.add).
  intros. rewrite Val.add_assoc. auto.
  apply Int.add_assoc.
  intros. rewrite Int.add_commut. apply Int.add_zero.
  apply decompose_int_arm_add. apply decompose_int_thumb_add.
Qed.

Lemma decompose_int_sub:
  forall imkind n v,
  List.fold_left (fun v i => Val.sub v (Vint i)) (decompose_int imkind n) v = Val.sub v (Vint n).
Proof.
  intros. apply decompose_int_general with (f := fun v n => Val.sub v (Vint n)) (g := Int.add).
  intros. repeat rewrite Val.sub_add_opp. rewrite Val.add_assoc. decEq. simpl. decEq.
  rewrite Int.neg_add_distr; auto.
  apply Int.add_assoc.
  intros. rewrite Int.add_commut. apply Int.add_zero.
  apply decompose_int_arm_add. apply decompose_int_thumb_add.
Qed.


Open Scope error_monad_scope.

Set Implicit Arguments.
Local Transparent Archi.ptr64.

Record shift_amount: Type :=
  { s_amount: int;
    s_range: Int.ltu s_amount Int.iwordsize = true }.

Coercion s_amount: shift_amount >-> int.

Inductive shift : Type :=
  | Slsl: shift_amount -> shift
  | Slsr: shift_amount -> shift
  | Sasr: shift_amount -> shift
  | Sror: shift_amount -> shift.

Conditions (boolean-valued operators).

Inductive condition : Type :=
  | Ccomp: comparison -> condition (* signed integer comparison *)
  | Ccompu: comparison -> condition (* unsigned integer comparison *)
  | Ccompshift: comparison -> shift -> condition (* signed integer comparison *)
  | Ccompushift: comparison -> shift -> condition (* unsigned integer comparison *)
  | Ccompimm: comparison -> int -> condition (* signed integer comparison with a constant *)
  | Ccompuimm: comparison -> int -> condition (* unsigned integer comparison with a constant *)
  | Ccompf: comparison -> condition (* 64-bit floating-point comparison *)
  | Cnotcompf: comparison -> condition (* negation of a floating-point comparison *)
  | Ccompfzero: comparison -> condition (* floating-point comparison with 0.0 *)
  | Cnotcompfzero: comparison -> condition (* negation of a floating-point comparison with 0.0 *)
  | Ccompfs: comparison -> condition (* 32-bit floating-point comparison *)
  | Cnotcompfs: comparison -> condition (* negation of a floating-point comparison *)
  | Ccompfszero: comparison -> condition (* floating-point comparison with 0.0 *)
  | Cnotcompfszero: comparison -> condition (* negation of a floating-point comparison with 0.0 *)
  | Cmaskzero: int -> condition (* test (arg & n) == 0 *)
  | Cmasknotzero: int -> condition (* test (arg & n) != 0 *)
ARM-local: 64-bit ordered compare-as-condition, lowered to cmp+sbcs followed by a conditional branch (no Pmovite). Inputs are the four split halves: hi1 :: lo1 :: hi2 :: lo2 :: nil. Equality cases are not lowered by these; SelectLong routes Ceq/Cne through the SplitLong xor;xor;or;clz path.
  | Ccompcarryu: comparison -> condition (* unsigned 64-bit compare *)
  | Ccompcarry: comparison -> condition. (* signed 64-bit compare *)

Arithmetic and logical operations. In the descriptions, rd is the result of the operation and r1, r2, etc, are the arguments.

Inductive operation : Type :=
  | Omove: operation (* rd = r1 *)
  | Ocopy
  | Ocopyimm (uid : int)
  | Ointconst: int -> operation (* rd is set to the given integer constant *)
  | Ofloatconst: float -> operation (* rd is set to the given 64-bit float constant *)
  | Osingleconst: float32 -> operation (* rd is set to the given 32-bit float constant *)
  | Oaddrsymbol: qualident -> ptrofs -> operation (* rd is set to the the address of the symbol plus the offset *)
  | Oaddrstack: ptrofs -> operation (* rd is set to the stack pointer plus the given offset *)
  | Ocast8signed: operation (* rd is 8-bit sign extension of r1 *)
  | Ocast16signed: operation (* rd is 16-bit sign extension of r1 *)
  | Oadd: operation (* rd = r1 + r2 *)
  | Oaddshift: shift -> operation (* rd = r1 + shifted r2 *)
  | Oaddimm: int -> operation (* rd = r1 + n *)
  | Osub: operation (* rd = r1 - r2 *)
  | Osubshift: shift -> operation (* rd = r1 - shifted r2 *)
  | Orsubshift: shift -> operation (* rd = shifted r2 - r1 *)
  | Orsubimm: int -> operation (* rd = n - r1 *)
  | Omul: operation (* rd = r1 * r2 *)
  | Omla: operation (* rd = r1 * r2 + r3 *)
  | Omls: operation (* rd = -r1 * r2 + r3 *)
  | Omulhs: operation (* rd = high part of r1 * r2, signed *)
  | Omulhu: operation (* rd = high part of r1 * r2, unsigned *)
  | Odiv: operation (* rd = r1 / r2 (signed) *)
  | Odivu: operation (* rd = r1 / r2 (unsigned) *)
  | Oand: operation (* rd = r1 & r2 *)
  | Oandshift: shift -> operation (* rd = r1 & shifted r2 *)
  | Oandimm: int -> operation (* rd = r1 & n *)
  | Oor: operation (* rd = r1 | r2 *)
  | Oorshift: shift -> operation (* rd = r1 | shifted r2 *)
  | Oorimm: int -> operation (* rd = r1 | n *)
  | Oxor: operation (* rd = r1 ^ r2 *)
  | Oxorshift: shift -> operation (* rd = r1 ^ shifted r2 *)
  | Oxorimm: int -> operation (* rd = r1 ^ n *)
  | Obic: operation (* rd = r1 & ~r2 *)
  | Obicshift: shift -> operation (* rd = r1 & ~(shifted r2) *)
  | Onot: operation (* rd = ~r1 *)
  | Onotshift: shift -> operation (* rd = ~(shifted r1) *)
  | Oshl: operation (* rd = r1 << r2 *)
  | Oshr: operation (* rd = r1 >> r2 (signed) *)
  | Oshru: operation (* rd = r1 >> r2 (unsigned) *)
  | Oror: operation (* rd = ror(r1, r2) (variable rotate right) *)
  | Oshift: shift -> operation (* rd = shifted r1 *)
  | Oshrximm: int -> operation (* rd = r1 / 2^n (signed) *)
  | Onegf: operation (* rd = - r1 *)
  | Oabsf: operation (* rd = abs(r1) *)
  | Oaddf: operation (* rd = r1 + r2 *)
  | Osubf: operation (* rd = r1 - r2 *)
  | Omulf: operation (* rd = r1 * r2 *)
  | Odivf: operation (* rd = r1 / r2 *)
  | Osqrtf: operation (* rd = sqrt(r1) *)
  | Omlaf : operation
  | Omlsf : operation
  | Onegfs: operation (* rd = - r1 *)
  | Oabsfs: operation (* rd = abs(r1) *)
  | Oaddfs: operation (* rd = r1 + r2 *)
  | Osubfs: operation (* rd = r1 - r2 *)
  | Omulfs: operation (* rd = r1 * r2 *)
  | Odivfs: operation (* rd = r1 / r2 *)
  | Osqrtfs: operation (* rd = sqrt(r1) *)
  | Omlafs : operation
  | Omlsfs : operation
  | Osingleoffloat: operation (* rd is r1 truncated to single-precision float *)
  | Ofloatofsingle: operation (* rd is r1 expanded to double-precision float *)
  | Ointoffloat: operation (* rd = signed_int_of_float(r1) *)
  | Ointuoffloat: operation (* rd = unsigned_int_of_float(r1) *)
  | Ofloatofint: operation (* rd = float_of_signed_int(r1) *)
  | Ofloatofintu: operation (* rd = float_of_unsigned_int(r1) *)
  | Ointofsingle: operation (* rd = signed_int_of_single(r1) *)
  | Ointuofsingle: operation (* rd = unsigned_int_of_single(r1) *)
  | Osingleofint: operation (* rd = single_of_signed_int(r1) *)
  | Osingleofintu: operation (* rd = single_of_unsigned_int(r1) *)
  | Omakelong: operation (* rd = r1 << 32 | r2 *)
  | Olowlong: operation (* rd = low-word(r1) *)
  | Ohighlong: operation (* rd = high-word(r1) *)
  | Ocmp: condition -> operation (* rd = 1 if condition holds, rd = 0 otherwise. *)
  | Osel: condition -> operation (* rd = rs1 if condition holds, rd = rs2 otherwise. *)
  | Oselimm: condition -> int -> operation (* rd = rs1 if condition holds, rd = imm otherwise. *)
  | Oselimm2: condition -> int -> int -> operation (* rd = imm1 if condition holds, rd = imm2 otherwise. *)
  | Oubfx: forall (lsb sz : int), operation
  | Osbfx: forall (lsb sze : int), operation
  | Obfc: forall (lsb sz : int), operation
  | Obfi: forall (lsb sz : int), operation
  | Oclz
  | Oreverse_bits
  | Obswap32 (* rd = byte-reverse(r1) *)
  | Obits_of_single
  | Osingle_of_bits
  | Ohibits_of_float
  | Ogetcanary
  | Oaddimm_reg: int -> operation (* rd = rd + n *)
  | OEaddimm: int -> operation (* rd = r1 + n *)
  | OEsubimm: int -> operation (* rd = r1 - n *)
  | OErsbimm: int -> operation (* rd = n - r1 *)
  | OEandimm: int -> operation (* rd = r1 & n *)
  | OEbicimm: int -> operation (* rd = r1 & ~n *)
  | OEorrimm: int -> operation (* rd = r1 | n *)
  | OEeorimm: int -> operation (* rd = r1 ^ n *)
  | OEmovimm: int -> operation (* rd = r1 *)
  | OEmvnimm: int -> operation (* rd = ~r1 *)
ARM-local: 64-bit compare-as-int, lowered as cmp+sbcs+movite. Inputs are split halves: hi1 :: lo1 :: hi2 :: lo2 :: nil. Eval returns Vint 1 if the comparison holds, Vint 0 otherwise, or Vundef if any operand is not Vint.
  | Ocmpcarryu: comparison -> operation (* unsigned 64-bit compare to int *)
  | Ocmpcarry: comparison -> operation (* signed 64-bit compare to int *)
  .

Addressing modes. r1, r2, etc, are the arguments to the addressing.

Inductive addressing: Type :=
  | Aindexed: int -> addressing (* Address is r1 + offset *)
  | Aindexed2: addressing (* Address is r1 + r2 *)
  | Aindexed2shift: shift -> addressing (* Address is r1 + shifted r2 *)
  | Ainstack: ptrofs -> addressing. (* Address is stack_pointer + offset *)
Definition Aindexed' := Aindexed.

Comparison functions (used in module CSE).

Definition eq_shift (x y: shift): {x=y} + {x<>y}.
Proof.
  revert x y.
  generalize Int.eq_dec; intro.
  assert (forall (x y: shift_amount), {x=y}+{x<>y}).
  destruct x as [x Px]. destruct y as [y Py]. destruct (H x y).
  subst x. rewrite (proof_irr Px Py). left; auto.
  right. red; intro. elim n. inversion H0. auto.
  decide equality.
Defined.

Definition eq_condition (x y: condition) : {x=y} + {x<>y}.
Proof.
  generalize Int.eq_dec; intro.
  assert (forall (x y: comparison), {x=y}+{x<>y}). decide equality.
  generalize eq_shift; intro.
  decide equality.
Defined.

Definition eq_operation (x y: operation): {x=y} + {x<>y}.
Proof.
  generalize Int.eq_dec Ptrofs.eq_dec QualIdent.eq ident_eq typ_eq; intros.
  generalize Float.eq_dec Float32.eq_dec; intros.
  generalize eq_shift; intro.
  generalize eq_condition; intro.
  assert (forall (x y: comparison), {x=y}+{x<>y}) by decide equality.
  decide equality.
Defined.

Definition eq_addressing (x y: addressing) : {x=y} + {x<>y}.
Proof.
  generalize Int.eq_dec Ptrofs.eq_dec; intro.
  generalize eq_shift; intro.
  decide equality.
Defined.

Global Opaque eq_shift eq_condition eq_operation eq_addressing.

Evaluation functions


Evaluation of conditions, operators and addressing modes applied to lists of values. Return None when the computation can trigger an error, e.g. integer division by zero. eval_condition returns a boolean, eval_operation and eval_addressing return a value.

Definition eval_shift (s: shift) (v: val) : val :=
  match s with
  | Slsl x => Val.shl v (Vint x)
  | Slsr x => Val.shru v (Vint x)
  | Sasr x => Val.shr v (Vint x)
  | Sror x => Val.ror v (Vint x)
  end.

Definition eval_condition (cond: condition) (vl: list val) (m: mem):
               option bool :=
  match cond, vl with
  | Ccomp c, v1 :: v2 :: nil => Val.cmp_bool c v1 v2
  | Ccompu c, v1 :: v2 :: nil => Val.cmpu_bool (Mem.valid_pointer m) c v1 v2
  | Ccompshift c s, v1 :: v2 :: nil => Val.cmp_bool c v1 (eval_shift s v2)
  | Ccompushift c s, v1 :: v2 :: nil => Val.cmpu_bool (Mem.valid_pointer m) c v1 (eval_shift s v2)
  | Ccompimm c n, v1 :: nil => Val.cmp_bool c v1 (Vint n)
  | Ccompuimm c n, v1 :: nil => Val.cmpu_bool (Mem.valid_pointer m) c v1 (Vint n)
  | Ccompf c, v1 :: v2 :: nil => Val.cmpf_bool c v1 v2
  | Cnotcompf c, v1 :: v2 :: nil => option_map negb (Val.cmpf_bool c v1 v2)
  | Ccompfzero c, v1 :: nil => Val.cmpf_bool c v1 (Vfloat Float.zero)
  | Cnotcompfzero c, v1 :: nil => option_map negb (Val.cmpf_bool c v1 (Vfloat Float.zero))
  | Ccompfs c, v1 :: v2 :: nil => Val.cmpfs_bool c v1 v2
  | Cnotcompfs c, v1 :: v2 :: nil => option_map negb (Val.cmpfs_bool c v1 v2)
  | Ccompfszero c, v1 :: nil => Val.cmpfs_bool c v1 (Vsingle Float32.zero)
  | Cnotcompfszero c, v1 :: nil => option_map negb (Val.cmpfs_bool c v1 (Vsingle Float32.zero))
  | Cmaskzero n, v1 :: nil => Val.cmp_bool Ceq (Val.and v1 (Vint n)) (Vint Int.zero)
  | Cmasknotzero n, v1 :: nil => Val.cmp_bool Cne (Val.and v1 (Vint n)) (Vint Int.zero)
  | Ccompcarryu c, hi1 :: lo1 :: hi2 :: lo2 :: nil =>
      Val.cmplu_bool (fun _ _ => true) c
                     (Val.longofwords hi1 lo1)
                     (Val.longofwords hi2 lo2)
  | Ccompcarry c, hi1 :: lo1 :: hi2 :: lo2 :: nil =>
      Val.cmpl_bool c
                    (Val.longofwords hi1 lo1)
                    (Val.longofwords hi2 lo2)
  | _, _ => None
  end.

Definition eval_operation
    (F V: Type) (genv: Genv.t F V) (sp: val)
    (op: operation) (vl: list val) (m: mem): option val :=
  match op, vl with
  | Omove, v1::nil => Some v1
  | Ocopy, v1::v2::nil => Some v1
  | Ocopyimm _, v1::nil => Some v1
  | Ointconst n, nil => Some (Vint n)
  | Ofloatconst n, nil => Some (Vfloat n)
  | Osingleconst n, nil => Some (Vsingle n)
  | Oaddrsymbol s ofs, nil => Some (Genv.symbol_address genv s ofs)
  | Oaddrstack ofs, nil => Some (Val.offset_ptr sp ofs)
  | Ocast8signed, v1::nil => Some (Val.sign_ext 8 v1)
  | Ocast16signed, v1::nil => Some (Val.sign_ext 16 v1)
  | Oadd, v1 :: v2 :: nil => Some (Val.add v1 v2)
  | Oaddshift s, v1 :: v2 :: nil => Some (Val.add v1 (eval_shift s v2))
  | Oaddimm n, v1 :: nil => Some (Val.add v1 (Vint n))
  | Osub, v1 :: v2 :: nil => Some (Val.sub v1 v2)
  | Osubshift s, v1 :: v2 :: nil => Some (Val.sub v1 (eval_shift s v2))
  | Orsubshift s, v1 :: v2 :: nil => Some (Val.sub (eval_shift s v2) v1)
  | Orsubimm n, v1 :: nil => Some (Val.sub (Vint n) v1)
  | Omul, v1 :: v2 :: nil => Some (Val.mul v1 v2)
  | Omla, v1 :: v2 :: v3 :: nil => Some (Val.add (Val.mul v1 v2) v3)
  | Omls, v1 :: v2 :: v3 :: nil => Some (Val.sub v3 (Val.mul v1 v2))
  | Omulhs, v1::v2::nil => Some (Val.mulhs v1 v2)
  | Omulhu, v1::v2::nil => Some (Val.mulhu v1 v2)
  | Odiv, v1 :: v2 :: nil => Val.divs v1 v2
  | Odivu, v1 :: v2 :: nil => Val.divu v1 v2
  | Oand, v1 :: v2 :: nil => Some (Val.and v1 v2)
  | Oandshift s, v1 :: v2 :: nil => Some (Val.and v1 (eval_shift s v2))
  | Oandimm n, v1 :: nil => Some (Val.and v1 (Vint n))
  | Oor, v1 :: v2 :: nil => Some (Val.or v1 v2)
  | Oorshift s, v1 :: v2 :: nil => Some (Val.or v1 (eval_shift s v2))
  | Oorimm n, v1 :: nil => Some (Val.or v1 (Vint n))
  | Oxor, v1 :: v2 :: nil => Some (Val.xor v1 v2)
  | Oxorshift s, v1 :: v2 :: nil => Some (Val.xor v1 (eval_shift s v2))
  | Oxorimm n, v1 :: nil => Some (Val.xor v1 (Vint n))
  | Obic, v1 :: v2 :: nil => Some (Val.and v1 (Val.notint v2))
  | Obicshift s, v1 :: v2 :: nil => Some (Val.and v1 (Val.notint (eval_shift s v2)))
  | Onot, v1 :: nil => Some (Val.notint v1)
  | Onotshift s, v1 :: nil => Some (Val.notint (eval_shift s v1))
  | Oshl, v1 :: v2 :: nil => Some (Val.shl v1 v2)
  | Oshr, v1 :: v2 :: nil => Some (Val.shr v1 v2)
  | Oshru, v1 :: v2 :: nil => Some (Val.shru v1 v2)
  | Oror, v1 :: v2 :: nil => Some (Val.ror v1 v2)
  | Oshift s, v1 :: nil => Some (eval_shift s v1)
  | Oshrximm n, v1 :: nil => Val.shrx v1 (Vint n)
  | Onegf, v1::nil => Some(Val.negf v1)
  | Oabsf, v1::nil => Some(Val.absf v1)
  | Oaddf, v1::v2::nil => Some(Val.addf v1 v2)
  | Osubf, v1::v2::nil => Some(Val.subf v1 v2)
  | Omulf, v1::v2::nil => Some(Val.mulf v1 v2)
  | Odivf, v1::v2::nil => Some(Val.divf v1 v2)
  | Osqrtf, v1::nil => Some(Val.sqrtf v1)
  | Omlaf, v1::v2::v3::nil => Some(Val.addf v1 (Val.mulf v2 v3))
  | Omlsf, v1::v2::v3::nil => Some(Val.subf v1 (Val.mulf v2 v3))
  | Onegfs, v1::nil => Some(Val.negfs v1)
  | Oabsfs, v1::nil => Some(Val.absfs v1)
  | Oaddfs, v1::v2::nil => Some(Val.addfs v1 v2)
  | Osubfs, v1::v2::nil => Some(Val.subfs v1 v2)
  | Omulfs, v1::v2::nil => Some(Val.mulfs v1 v2)
  | Odivfs, v1::v2::nil => Some(Val.divfs v1 v2)
  | Osqrtfs, v1::nil => Some(Val.sqrtfs v1)
  | Omlafs, v1::v2::v3::nil => Some(Val.addfs v1 (Val.mulfs v2 v3))
  | Omlsfs, v1::v2::v3::nil => Some(Val.subfs v1 (Val.mulfs v2 v3))
  | Osingleoffloat, v1::nil => Some(Val.singleoffloat v1)
  | Ofloatofsingle, v1::nil => Some(Val.floatofsingle v1)
  | Ointoffloat, v1::nil => Val.intoffloat v1
  | Ointuoffloat, v1::nil => Val.intuoffloat v1
  | Ofloatofint, v1::nil => Val.floatofint v1
  | Ofloatofintu, v1::nil => Val.floatofintu v1
  | Ointofsingle, v1::nil => Val.intofsingle v1
  | Ointuofsingle, v1::nil => Val.intuofsingle v1
  | Osingleofint, v1::nil => Val.singleofint v1
  | Osingleofintu, v1::nil => Val.singleofintu v1
  | Omakelong, v1::v2::nil => Some(Val.longofwords v1 v2)
  | Olowlong, v1::nil => Some(Val.loword v1)
  | Ohighlong, v1::nil => Some(Val.hiword v1)
  | Ocmp c, _ => Some(Val.of_optbool (eval_condition c vl m))
  | Osel c, v1::v2::vl => Some(Val.select (eval_condition c vl m) v1 v2)
  | Oselimm c imm, v1::vl => Some(Val.select (eval_condition c vl m) v1 (Vint imm))
  | Oselimm2 c imm1 imm2, vl => Some(Val.select (eval_condition c vl m) (Vint imm1) (Vint imm2))
  | Oclz, v1::nil => Some (match v1 with Vint n => Vint (Int.clz n) | _ => Vundef end)
  | Oreverse_bits, v1::nil => Some (match v1 with Vint n => Vint (Int.reverse_bits n) | _ => Vundef end)
  | Obswap32, v1::nil => Some (ExtValues.val_bswap32 v1)
  | Obits_of_single, v1::nil => Some (Val.bits_of_single v1)
  | Osingle_of_bits, v1::nil => Some (Val.single_of_bits v1)
  | Ohibits_of_float, v1::nil => Some (Val.hiword (Val.bits_of_float v1))
  | (Osbfx lsb sz), v1::nil =>
       Some(Val.sign_ext (Int.unsigned sz) (Val.shru v1 (Vint lsb)))
  | (Oubfx lsb sz), v1::nil =>
      Some(Val.zero_ext (Int.unsigned sz) (Val.shru v1 (Vint lsb)))
  | (Obfc lsb sz), v1::nil => Some (clearf lsb sz v1)
  | (Obfi lsb sz), v1::v2::nil => Some (insf lsb sz v1 v2)
  | Ogetcanary, nil => Some (canary_val tt)
  | Oaddimm_reg n, v1 :: nil => Some (Val.add v1 (Vint n))
  | OEaddimm n, v1 :: nil => Some (Val.add v1 (Vint n))
  | OEsubimm n, v1 :: nil => Some (Val.sub v1 (Vint n))
  | OErsbimm n, v1 :: nil => Some (Val.sub (Vint n) v1)
  | OEandimm n, v1 :: nil => Some (Val.and v1 (Vint n))
  | OEbicimm n, v1 :: nil => Some (Val.and v1 (Val.notint (Vint n)))
  | OEorrimm n, v1 :: nil => Some (Val.or v1 (Vint n))
  | OEeorimm n, v1 :: nil => Some (Val.xor v1 (Vint n))
  | OEmovimm n, nil => Some (Vint n)
  | OEmvnimm n, nil => Some (Val.notint (Vint n))
  | Ocmpcarryu c, hi1::lo1::hi2::lo2::nil =>
      Some (Val.of_optbool (Val.cmplu_bool (fun _ _ => true) c
                              (Val.longofwords hi1 lo1)
                              (Val.longofwords hi2 lo2)))
  | Ocmpcarry c, hi1::lo1::hi2::lo2::nil =>
      Some (Val.of_optbool (Val.cmpl_bool c
                              (Val.longofwords hi1 lo1)
                              (Val.longofwords hi2 lo2)))
  | _, _ => None
  end.

Definition eval_addressing
    (F V: Type) (genv: Genv.t F V) (sp: val)
    (addr: addressing) (vl: list val) : option val :=
  match addr, vl with
  | Aindexed n, v1 :: nil => Some (Val.add v1 (Vint n))
  | Aindexed2, v1 :: v2 :: nil => Some (Val.add v1 v2)
  | Aindexed2shift s, v1 :: v2 :: nil => Some (Val.add v1 (eval_shift s v2))
  | Ainstack ofs, nil => Some (Val.offset_ptr sp ofs)
  | _, _ => None
  end.

Remark eval_addressing_Ainstack:
  forall (F V: Type) (genv: Genv.t F V) sp ofs,
  eval_addressing genv sp (Ainstack ofs) nil = Some (Val.offset_ptr sp ofs).
Proof.
  intros. reflexivity.
Qed.

Remark eval_addressing_Ainstack_inv:
  forall (F V: Type) (genv: Genv.t F V) sp ofs vl v,
  eval_addressing genv sp (Ainstack ofs) vl = Some v -> vl = nil /\ v = Val.offset_ptr sp ofs.
Proof.
  unfold eval_addressing; intros; destruct vl; inv H; auto.
Qed.

Ltac FuncInv :=
  match goal with
  | H: (match ?x with nil => _ | _ :: _ => _ end = Some _) |- _ =>
      destruct x; simpl in H; try discriminate; FuncInv
  | H: (Some _ = Some _) |- _ =>
      injection H; intros; clear H; FuncInv
  | _ =>
      idtac
  end.

Static typing of conditions, operators and addressing modes.


Definition type_of_condition (c: condition) : list typ :=
  match c with
  | Ccomp _ => Tint :: Tint :: nil
  | Ccompu _ => Tint :: Tint :: nil
  | Ccompshift _ _ => Tint :: Tint :: nil
  | Ccompushift _ _ => Tint :: Tint :: nil
  | Ccompimm _ _ => Tint :: nil
  | Ccompuimm _ _ => Tint :: nil
  | Ccompf _ => Tfloat :: Tfloat :: nil
  | Cnotcompf _ => Tfloat :: Tfloat :: nil
  | Ccompfzero _ => Tfloat :: nil
  | Cnotcompfzero _ => Tfloat :: nil
  | Ccompfs _ => Tsingle :: Tsingle :: nil
  | Cnotcompfs _ => Tsingle :: Tsingle :: nil
  | Ccompfszero _ => Tsingle :: nil
  | Cnotcompfszero _ => Tsingle :: nil
  | Cmaskzero _ => Tint :: nil
  | Cmasknotzero _ => Tint :: nil
  | Ccompcarryu _ => Tint :: Tint :: Tint :: Tint :: nil
  | Ccompcarry _ => Tint :: Tint :: Tint :: Tint :: nil
  end.

Definition type_of_operation (op: operation) : list typ * typ :=
  match op with
  | Omove | Ocopyimm _ => (Tint :: nil, Tint)
  | Ocopy => (Tint :: Tint :: nil, Tint)
  | Osel c => (Tint :: Tint :: type_of_condition c, Tint)
  | Ointconst _ => (nil, Tint)
  | Ofloatconst f => (nil, Tfloat)
  | Osingleconst f => (nil, Tsingle)
  | Oaddrsymbol _ _ => (nil, Tint)
  | Oaddrstack _ => (nil, Tint)
  | Ocast8signed => (Tint :: nil, Tint)
  | Ocast16signed => (Tint :: nil, Tint)
  | Oadd => (Tint :: Tint :: nil, Tint)
  | Oaddshift _ => (Tint :: Tint :: nil, Tint)
  | Oaddimm _ => (Tint :: nil, Tint)
  | Osub => (Tint :: Tint :: nil, Tint)
  | Osubshift _ => (Tint :: Tint :: nil, Tint)
  | Orsubshift _ => (Tint :: Tint :: nil, Tint)
  | Orsubimm _ => (Tint :: nil, Tint)
  | Omul => (Tint :: Tint :: nil, Tint)
  | Omla => (Tint :: Tint :: Tint :: nil, Tint)
  | Omls => (Tint :: Tint :: Tint :: nil, Tint)
  | Omulhs => (Tint :: Tint :: nil, Tint)
  | Omulhu => (Tint :: Tint :: nil, Tint)
  | Odiv => (Tint :: Tint :: nil, Tint)
  | Odivu => (Tint :: Tint :: nil, Tint)
  | Oand => (Tint :: Tint :: nil, Tint)
  | Oandshift _ => (Tint :: Tint :: nil, Tint)
  | Oandimm _ => (Tint :: nil, Tint)
  | Oor => (Tint :: Tint :: nil, Tint)
  | Oorshift _ => (Tint :: Tint :: nil, Tint)
  | Oorimm _ => (Tint :: nil, Tint)
  | Oxor => (Tint :: Tint :: nil, Tint)
  | Oxorshift _ => (Tint :: Tint :: nil, Tint)
  | Oxorimm _ => (Tint :: nil, Tint)
  | Obic => (Tint :: Tint :: nil, Tint)
  | Obicshift _ => (Tint :: Tint :: nil, Tint)
  | Onot => (Tint :: nil, Tint)
  | Onotshift _ => (Tint :: nil, Tint)
  | Oshl => (Tint :: Tint :: nil, Tint)
  | Oshr => (Tint :: Tint :: nil, Tint)
  | Oshru => (Tint :: Tint :: nil, Tint)
  | Oror => (Tint :: Tint :: nil, Tint)
  | Oshift _ => (Tint :: nil, Tint)
  | Oshrximm _ => (Tint :: nil, Tint)
  | Onegf => (Tfloat :: nil, Tfloat)
  | Oabsf => (Tfloat :: nil, Tfloat)
  | Oaddf => (Tfloat :: Tfloat :: nil, Tfloat)
  | Osubf => (Tfloat :: Tfloat :: nil, Tfloat)
  | Omulf => (Tfloat :: Tfloat :: nil, Tfloat)
  | Odivf => (Tfloat :: Tfloat :: nil, Tfloat)
  | Osqrtf => (Tfloat :: nil, Tfloat)
  | Omlaf => (Tfloat :: Tfloat :: Tfloat :: nil, Tfloat)
  | Omlsf => (Tfloat :: Tfloat :: Tfloat :: nil, Tfloat)
  | Onegfs => (Tsingle :: nil, Tsingle)
  | Oabsfs => (Tsingle :: nil, Tsingle)
  | Oaddfs => (Tsingle :: Tsingle :: nil, Tsingle)
  | Osubfs => (Tsingle :: Tsingle :: nil, Tsingle)
  | Omulfs => (Tsingle :: Tsingle :: nil, Tsingle)
  | Odivfs => (Tsingle :: Tsingle :: nil, Tsingle)
  | Osqrtfs => (Tsingle :: nil, Tsingle)
  | Omlafs => (Tsingle :: Tsingle :: Tsingle :: nil, Tsingle)
  | Omlsfs => (Tsingle :: Tsingle :: Tsingle :: nil, Tsingle)
  | Osingleoffloat => (Tfloat :: nil, Tsingle)
  | Ofloatofsingle => (Tsingle :: nil, Tfloat)
  | Ointoffloat => (Tfloat :: nil, Tint)
  | Ointuoffloat => (Tfloat :: nil, Tint)
  | Ofloatofint => (Tint :: nil, Tfloat)
  | Ofloatofintu => (Tint :: nil, Tfloat)
  | Ointofsingle => (Tsingle :: nil, Tint)
  | Ointuofsingle => (Tsingle :: nil, Tint)
  | Osingleofint => (Tint :: nil, Tsingle)
  | Osingleofintu => (Tint :: nil, Tsingle)
  | Omakelong => (Tint :: Tint :: nil, Tlong)
  | Olowlong => (Tlong :: nil, Tint)
  | Ohighlong => (Tlong :: nil, Tint)
  | Ocmp c => (type_of_condition c, Tint)
  | Oselimm c _ => (Tint :: type_of_condition c, Tint)
  | Oselimm2 c _ _ => (type_of_condition c, Tint)

  | Oclz => (Tint :: nil, Tint)
  | Oreverse_bits => (Tint :: nil, Tint)
  | Obswap32 => (Tint :: nil, Tint)
  | Obits_of_single => (Tsingle :: nil, Tint)
  | Osingle_of_bits => (Tint :: nil, Tsingle)
  | Ohibits_of_float => (Tfloat :: nil, Tint)
  | (Oubfx _ _) | (Osbfx _ _) | (Obfc _ _ ) => (Tint :: nil, Tint)
  | (Obfi _ _ ) => (Tint :: Tint :: nil, Tint)
  | Ogetcanary => (nil, canary_type)

  | Oaddimm_reg _ => (Tint :: nil, Tint)

  | OEaddimm _ => (Tint :: nil, Tint)
  | OEsubimm _ => (Tint :: nil, Tint)
  | OErsbimm _ => (Tint :: nil, Tint)
  | OEandimm _ => (Tint :: nil, Tint)
  | OEbicimm _ => (Tint :: nil, Tint)
  | OEorrimm _ => (Tint :: nil, Tint)
  | OEeorimm _ => (Tint :: nil, Tint)
  | OEmovimm _ => (nil, Tint)
  | OEmvnimm _ => (nil, Tint)
  | Ocmpcarryu _ => (Tint :: Tint :: Tint :: Tint :: nil, Tint)
  | Ocmpcarry _ => (Tint :: Tint :: Tint :: Tint :: nil, Tint)
  end.

Definition type_of_addressing (addr: addressing) : list typ :=
  match addr with
  | Aindexed _ => Tint :: nil
  | Aindexed2 => Tint :: Tint :: nil
  | Aindexed2shift _ => Tint :: Tint :: nil
  | Ainstack _ => nil
  end.

Inductive wt_special_op : operation -> list typ -> typ -> Prop :=
| wt_Omove : forall ty,
    wt_special_op Omove (ty :: nil) ty
| wt_Ocopy : forall ty,
    wt_special_op Ocopy (ty :: Tint :: nil) ty
| wt_Ocopyimm : forall uid ty,
    wt_special_op (Ocopyimm uid) (ty :: nil) ty
| wt_Osel : forall c ty,
    wt_special_op (Osel c) (ty :: ty :: type_of_condition c) ty
| wt_Oselimm : forall c imm,
    wt_special_op (Oselimm c imm) (Tint :: type_of_condition c) Tint.

Module RTLtypes <: TYPE_ALGEBRA.

Definition t := typ.
Definition eq := typ_eq.
Definition default := Tint.

End RTLtypes.

Module S := UniSolver(RTLtypes).

Definition type_special_op (e: S.typenv) (op: operation) args res : Errors.res S.typenv :=
  match op with
  | Omove | Ocopyimm _ =>
      match args with
      | arg :: nil => do (changed, e') <- S.move e res arg; OK e'
      | _ => Error (msg "ill-formed move")
      end
  | Ocopy =>
      match args with
      | arg :: uid :: nil =>
          do e' <- S.set e uid Tint;
          do (changed, e') <- S.move e' res arg;
          OK e'
      | _ => Error (msg "ill-formed copy")
      end
  | Osel c =>
      match args with
      | arg1 :: arg2 :: args =>
          do e' <- S.set_list e args (type_of_condition c);
          do (changed, e') <- S.move e' res arg1;
          do (changed, e') <- S.move e' res arg2;
          OK e'
      | _ => Error (msg "ill-formed select")
      end
  | Oselimm c _ =>
      match args with
      | arg1 :: args =>
          do e' <- S.set_list e args (type_of_condition c);
          do (changed, e') <- S.move e' res arg1;
          do e' <- S.set e' res Tint;
          OK e'
      | _ => Error (msg "ill-formed selimm")
      end
  | _ => Error (msg "non-special instruction")
  end.

Lemma type_special_op_incr:
  forall e op args res e' te,
    type_special_op e op args res = OK e' -> S.satisf te e' -> S.satisf te e.
Proof.
  intros ? [] * TYP SAT; simpl in TYP; try congruence.
  all:repeat (destruct args as [|? args]; try congruence; []).
  all:monadInv TYP.
  all:eauto using S.move_incr, S.set_incr, S.set_list_incr.
Qed.

Lemma type_special_op_sound:
  forall e op args res e' te,
  type_special_op e op args res = OK e' ->
  S.satisf te e' ->
  wt_special_op op (map te args) (te res).
Proof.
  intros ? [] * TYP SATISF; simpl in TYP; try congruence.
  all:repeat (destruct args as [|? args]; try congruence; []).
  all:monadInv TYP; simpl.
  - (* move *)
    eapply S.move_sound in EQ as <-; eauto. constructor.
  - (* copy *)
    eapply S.set_sound with (te:=te) in EQ as ->; eauto using S.move_incr.
    eapply S.move_sound in EQ1 as <-; eauto. constructor.
  - (* copyimm *)
    eapply S.move_sound in EQ as <-; eauto. constructor.
  - (* sel *)
    eapply S.set_list_sound with (te:=te) in EQ as ->; eauto using S.move_incr.
    eapply S.move_sound in EQ1 as <-; eauto using S.move_incr.
    eapply S.move_sound in EQ0 as ->; eauto. constructor.
  - (* selimm *)
    eapply S.set_sound with (te:=te) in EQ0 as Hres; eauto.
    rewrite Hres.
    eapply S.move_sound in EQ1 as Hp; eauto using S.set_incr.
    rewrite <- Hp, Hres.
    eapply S.set_list_sound with (te:=te) in EQ as ->; eauto using S.move_incr, S.set_incr. constructor.
Qed.

Lemma type_special_op_complete:
  forall te e op args res,
    S.satisf te e ->
    wt_special_op op (map te args) (te res) ->
    exists e', type_special_op e op args res = OK e' /\ S.satisf te e'.
Proof.
  intros * SAT WT; inv WT; simpl.
  all:repeat (destruct args as [|? args]; simpl in *; try congruence; []).
  all:repeat (match goal with H:_::_ = _::_ |- _ => inv H end).
  - (* move *)
    edestruct S.move_complete as (?&?&->&?SAT); eauto; simpl.
    do 2 esplit; eauto.
  - (* copy *)
    edestruct S.set_complete as (?&->&?SAT); eauto; simpl.
    edestruct S.move_complete as (?&?&->&?SAT); eauto; simpl.
    do 2 esplit; eauto.
  - (* copyimm *)
    edestruct S.move_complete as (?&?&->&?SAT); eauto; simpl.
    do 2 esplit; eauto.
  - (* sel *)
    rewrite H3.
    edestruct S.set_list_complete as (?&->&?SAT); eauto; simpl.
    do 2 (edestruct S.move_complete as (?&?&->&?SAT); eauto; simpl).
    do 2 esplit; eauto.
  - (* selimm *)
    rewrite H3.
    edestruct S.set_list_complete as (?&->&?SAT); eauto; simpl.
    edestruct S.move_complete as (?&?&->&?SAT); eauto; simpl.
    congruence.
    edestruct S.set_complete as (?&->&?SAT); eauto; simpl.
    do 2 esplit; eauto.
Qed.

Weak type soundness results for eval_operation: the result values, when defined, are always of the type predicted by type_of_operation.

Section SOUNDNESS.

Variable A V: Type.
Variable genv: Genv.t A V.

Definition is_special_op op :=
  match op with
  | Omove | Ocopy | Ocopyimm _ | Osel _ | Oselimm _ _ => true
  | _ => false
  end.

Lemma type_of_operation_sound:
  forall op vl sp v m,
  is_special_op op = false ->
  eval_operation genv sp op vl m = Some v ->
  Val.has_type v (snd (type_of_operation op)).
Proof with
(try exact I; try reflexivity).
  assert (S: forall s v, Val.has_type (eval_shift s v) Tint).
    intros. unfold eval_shift. destruct s; destruct v; simpl; auto; rewrite s_range; exact I.
  intros.
  destruct op; simpl; simpl in H0; FuncInv; try subst v...
  - unfold Genv.symbol_address.
    destruct (Genv.find_symbol genv q)...
  - destruct sp...
  - destruct v0...
  - destruct v0...
  - destruct v0; destruct v1...
  - generalize (S s v1). destruct v0; destruct (eval_shift s v1); simpl; tauto.
  - destruct v0...
  - destruct v0; destruct v1... simpl. destruct (eq_block b b0)...
  - generalize (S s v1). destruct v0; destruct (eval_shift s v1); simpl; intuition. destruct (eq_block b b0)...
  - generalize (S s v1). destruct v0; destruct (eval_shift s v1); simpl; intuition. destruct (eq_block b0 b)...
  - destruct v0...
  - destruct v0; destruct v1...
  - destruct v0... destruct v1... destruct v2...
  - (* Omls *)
    destruct v0, v1, v2; cbn; constructor.
  - destruct v0; destruct v1...
  - destruct v0; destruct v1...
  - destruct v0; destruct v1; simpl in H0; inv H0.
    destruct (Int.eq i0 Int.zero || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2...
  - destruct v0; destruct v1; simpl in H0; inv H0. destruct (Int.eq i0 Int.zero); inv H2...
  - destruct v0; destruct v1...
  - generalize (S s v1). destruct v0; destruct (eval_shift s v1); simpl; tauto.
  - destruct v0...
  - destruct v0; destruct v1...
  - generalize (S s v1). destruct v0; destruct (eval_shift s v1); simpl; tauto.
  - destruct v0...
  - destruct v0; destruct v1...
  - generalize (S s v1). destruct v0; destruct (eval_shift s v1); simpl; tauto.
  - destruct v0...
  - destruct v0; destruct v1...
  - generalize (S s v1). destruct v0; destruct (eval_shift s v1); simpl; tauto.
  - destruct v0...
  - generalize (S s v0). destruct (eval_shift s v0); simpl; tauto.
  - destruct v0; destruct v1... simpl. destruct (Int.ltu i0 Int.iwordsize)...
  - destruct v0; destruct v1... simpl. destruct (Int.ltu i0 Int.iwordsize)...
  - destruct v0; destruct v1... simpl. destruct (Int.ltu i0 Int.iwordsize)...
  - destruct v0; destruct v1...
  - apply S.
  - destruct v0; simpl in H0; inv H0. destruct (Int.ltu i (Int.repr 31)); inv H2...
  - destruct v0...
  - destruct v0...
  - destruct v0; destruct v1...
  - destruct v0; destruct v1...
  - destruct v0; destruct v1...
  - destruct v0; destruct v1...
  - destruct v0... (* Osqrtf *)
  - (* Omlaf *)
    destruct v0, v1, v2...
  - (* Omlsf *)
    destruct v0, v1, v2...
  - destruct v0...
  - destruct v0...
  - destruct v0; destruct v1...
  - destruct v0; destruct v1...
  - destruct v0; destruct v1...
  - destruct v0; destruct v1...
  - destruct v0... (* Osqrtfs *)
  - (* Omlafs *)
    destruct v0, v1, v2...
  - (* Omlsfs *)
    destruct v0, v1, v2...
  - destruct v0...
  - destruct v0...
  - destruct v0; simpl in H0; inv H0. destruct (Float.to_int f); simpl in H2; inv H2...
  - destruct v0; simpl in H0; inv H0. destruct (Float.to_intu f); simpl in H2; inv H2...
  - destruct v0; simpl in H0; inv H0...
  - destruct v0; simpl in H0; inv H0...
  - destruct v0; simpl in H0; inv H0. destruct (Float32.to_int f); simpl in H2; inv H2...
  - destruct v0; simpl in H0; inv H0. destruct (Float32.to_intu f); simpl in H2; inv H2...
  - destruct v0; simpl in H0; inv H0...
  - destruct v0; simpl in H0; inv H0...
  - destruct v0; destruct v1...
  - destruct v0...
  - destruct v0...
  - destruct (eval_condition c vl m)... destruct b...
  - destruct (eval_condition c vl m)... destruct b...
  - destruct v0; simpl; trivial.
    destruct Int.ltu; simpl; trivial.
  - destruct v0; simpl; trivial.
    destruct Int.ltu; simpl; trivial.
  - unfold clearf. destruct is_bitfield; cycle 1. constructor.
    destruct v0; cbn; constructor.
  - unfold insf. destruct is_bitfield; cycle 1. constructor.
    destruct v0; cbn; trivial.
    destruct v1; cbn; trivial.
    destruct Int.ltu; cbn; trivial.
  - destruct v0; cbn; trivial. (* Oclz *)
  - destruct v0; cbn; trivial. (* Oreverse_bits *)
  - destruct v0; cbn; trivial.
  - destruct v0; cbn; trivial.
  - destruct v0; cbn; trivial.
  - destruct v0; cbn; trivial.
  - destruct v0; cbn; trivial.
  (* expansed instructions *)
  - destruct v0; cbn; trivial.
  - destruct v0; cbn; trivial.
  - destruct v0; cbn; trivial.
  - destruct v0; cbn; trivial.
  - destruct v0; cbn; trivial.
  - destruct v0; cbn; trivial.
  - destruct v0; cbn; trivial.
  - (* Ocmpcarryu *) destruct (Val.cmplu_bool _ _ _ _) as [[]|]; cbn; trivial.
  - (* Ocmpcarry  *) destruct (Val.cmpl_bool _ _ _) as [[]|]; cbn; trivial.
Qed.

Definition is_trapping_op (op : operation) :=
  match op with
  | Odiv | Odivu
  | Oshrximm _
  | Ointoffloat | Ointuoffloat
  | Ointofsingle | Ointuofsingle
  | Ofloatofint | Ofloatofintu
  | Osingleofint | Osingleofintu => true
  | _ => false
  end.
                

Definition args_of_operation op :=
  if eq_operation op Omove
  then 1%nat
  else List.length (fst (type_of_operation op)).

Lemma is_trapping_op_sound:
  forall op vl sp m,
    is_trapping_op op = false ->
    (List.length vl) = args_of_operation op ->
    eval_operation genv sp op vl m <> None.
Proof.
  unfold args_of_operation.
  destruct op; destruct eq_operation; intros; simpl in *; try congruence.
  all: try (destruct vl as [ | vh1 vl1]; try discriminate).
  all: try (destruct vl1 as [ | vh2 vl2]; try discriminate).
  all: try (destruct vl2 as [ | vh3 vl3]; try discriminate).
  all: try (destruct vl3 as [ | vh4 vl4]; try discriminate).
  all: try (destruct vl4 as [ | vh5 vl5]; try discriminate).
  all: try discriminate; try congruence.
Qed.

Lemma wt_exec_special_op:
  forall sp op targs tres args m v,
  wt_special_op op targs tres ->
  eval_operation genv sp op args m = Some v ->
  list_forall2 Val.has_type args targs ->
  Val.has_type v tres.
Proof.
  inversion 1; subst; intros * EVAL WTREGS; simpl in *.
  all:repeat (destruct args as [|? args]; simpl in *; try congruence; []).
  all:repeat (match goal with
              | H:list_forall2 _ (_::_) _ |- _ => inv H
              | H: Some _ = Some _ |- _ => inv H
              end); auto.
  - (* select *)
    unfold Val.select. destruct eval_condition as [[]|]; auto.
    constructor.
  - (* selimm *)
    unfold Val.select. destruct eval_condition as [[]|]; auto. exact I.
    constructor.
Qed.
End SOUNDNESS.

Manipulating and transforming operations


Constructing shift amounts.

Program Definition mk_shift_amount (n: int) : shift_amount :=
  {| s_amount := Int.modu n Int.iwordsize; s_range := _ |}.
Next Obligation.
  assert (0 <= Z.modulo (Int.unsigned n) 32 < 32). apply Z_mod_lt. lia.
  unfold Int.ltu, Int.modu. change (Int.unsigned Int.iwordsize) with 32.
  rewrite Int.unsigned_repr. apply zlt_true. lia.
  assert (32 < Int.max_unsigned). compute; auto. lia.
Qed.

Lemma mk_shift_amount_eq:
  forall n, Int.ltu n Int.iwordsize = true -> s_amount (mk_shift_amount n) = n.
Proof.
  intros; simpl. unfold Int.modu. transitivity (Int.repr (Int.unsigned n)).
  decEq. apply Z.mod_small. apply Int.ltu_inv; auto.
  apply Int.repr_unsigned.
Qed.

Recognition of move operations.

Definition is_move_operation
    (A: Type) (op: operation) (args: list A) : option A :=
  match op, args with
  | Omove, arg :: nil => Some arg
  | _, _ => None
  end.

Lemma is_move_operation_correct:
  forall (A: Type) (op: operation) (args: list A) (a: A),
  is_move_operation op args = Some a ->
  op = Omove /\ args = a :: nil.
Proof.
  intros until a. unfold is_move_operation; destruct op;
  try (intros; discriminate).
  destruct args. intros; discriminate.
  destruct args. intros. intuition congruence.
  intros; discriminate.
Qed.

negate_condition cond returns a condition that is logically equivalent to the negation of cond.

Definition negate_condition (cond: condition): condition :=
  match cond with
  | Ccomp c => Ccomp(negate_comparison c)
  | Ccompu c => Ccompu(negate_comparison c)
  | Ccompshift c s => Ccompshift (negate_comparison c) s
  | Ccompushift c s => Ccompushift (negate_comparison c) s
  | Ccompimm c n => Ccompimm (negate_comparison c) n
  | Ccompuimm c n => Ccompuimm (negate_comparison c) n
  | Ccompf c => Cnotcompf c
  | Cnotcompf c => Ccompf c
  | Ccompfzero c => Cnotcompfzero c
  | Cnotcompfzero c => Ccompfzero c
  | Ccompfs c => Cnotcompfs c
  | Cnotcompfs c => Ccompfs c
  | Ccompfszero c => Cnotcompfszero c
  | Cnotcompfszero c => Ccompfszero c
  | Cmaskzero n => Cmasknotzero n
  | Cmasknotzero n => Cmaskzero n
  | Ccompcarryu c => Ccompcarryu (negate_comparison c)
  | Ccompcarry c => Ccompcarry (negate_comparison c)
  end.

Lemma eval_negate_condition:
  forall cond vl m,
  eval_condition (negate_condition cond) vl m = option_map negb (eval_condition cond vl m).
Proof.
  intros. destruct cond; simpl.
  repeat (destruct vl; auto). apply Val.negate_cmp_bool.
  repeat (destruct vl; auto). apply Val.negate_cmpu_bool.
  repeat (destruct vl; auto). apply Val.negate_cmp_bool.
  repeat (destruct vl; auto). apply Val.negate_cmpu_bool.
  repeat (destruct vl; auto). apply Val.negate_cmp_bool.
  repeat (destruct vl; auto). apply Val.negate_cmpu_bool.
  repeat (destruct vl; auto).
  repeat (destruct vl; auto). destruct (Val.cmpf_bool c v v0); auto. destruct b; auto.
  repeat (destruct vl; auto).
  repeat (destruct vl; auto). destruct (Val.cmpf_bool c v (Vfloat Float.zero)); auto. destruct b; auto.
  repeat (destruct vl; auto).
  repeat (destruct vl; auto). destruct (Val.cmpfs_bool c v v0); auto. destruct b; auto.
  repeat (destruct vl; auto).
  repeat (destruct vl; auto). destruct (Val.cmpfs_bool c v (Vsingle Float32.zero)); auto. destruct b; auto.
  repeat (destruct vl; auto). change Cne with (negate_comparison Ceq); apply Val.negate_cmp_bool.
  repeat (destruct vl; auto). change Ceq with (negate_comparison Cne); apply Val.negate_cmp_bool.
  repeat (destruct vl; auto). apply Val.negate_cmplu_bool.
  repeat (destruct vl; auto). apply Val.negate_cmpl_bool.
Qed.

Shifting stack-relative references. This is used in Stacking.

Definition shift_stack_addressing (delta: Z) (addr: addressing) :=
  match addr with
  | Ainstack ofs => Ainstack (Ptrofs.add (Ptrofs.repr delta) ofs)
  | _ => addr
  end.

Definition shift_stack_operation (delta: Z) (op: operation) :=
  match op with
  | Oaddrstack ofs => Oaddrstack (Ptrofs.add (Ptrofs.repr delta) ofs)
  | _ => op
  end.

Lemma type_shift_stack_addressing:
  forall delta addr, type_of_addressing (shift_stack_addressing delta addr) = type_of_addressing addr.
Proof.
  intros. destruct addr; auto.
Qed.

Lemma type_shift_stack_operation:
  forall delta op, type_of_operation (shift_stack_operation delta op) = type_of_operation op.
Proof.
  intros. destruct op; auto.
Qed.

Lemma eval_shift_stack_addressing:
  forall F V (ge: Genv.t F V) sp addr vl delta,
  eval_addressing ge (Vptr sp Ptrofs.zero) (shift_stack_addressing delta addr) vl =
  eval_addressing ge (Vptr sp (Ptrofs.repr delta)) addr vl.
Proof.
  intros. destruct addr; simpl; auto.
  rewrite Ptrofs.add_zero_l; auto.
Qed.

Lemma eval_shift_stack_operation:
  forall F V (ge: Genv.t F V) sp op vl m delta,
  eval_operation ge (Vptr sp Ptrofs.zero) (shift_stack_operation delta op) vl m =
  eval_operation ge (Vptr sp (Ptrofs.repr delta)) op vl m.
Proof.
  intros. destruct op; simpl; auto.
  rewrite Ptrofs.add_zero_l; auto.
Qed.

Offset an addressing mode addr by a quantity delta, so that it designates the pointer delta bytes past the pointer designated by addr. May be undefined, in which case None is returned.

Definition offset_addressing (addr: addressing) (delta: Z) : option addressing :=
  match addr with
  | Aindexed n => Some(Aindexed (Int.add n (Int.repr delta)))
  | Aindexed2 => None
  | Aindexed2shift s => None
  | Ainstack n => Some(Ainstack (Ptrofs.add n (Ptrofs.repr delta)))
  end.

Lemma eval_offset_addressing:
  forall (F V: Type) (ge: Genv.t F V) sp addr args delta addr' v,
  offset_addressing addr delta = Some addr' ->
  eval_addressing ge sp addr args = Some v ->
  eval_addressing ge sp addr' args = Some(Val.add v (Vint (Int.repr delta))).
Proof.
  intros. destruct addr; simpl in H; inv H; simpl in *; FuncInv; subst.
  rewrite Val.add_assoc; auto.
  destruct sp; simpl; auto. rewrite Ptrofs.add_assoc. do 4 f_equal. symmetry; auto with ptrofs.
Qed.

Operations that are so cheap to recompute that CSE should not factor them out.

Operations so cheap to compute that CSE shouldn't bother deduplicating them: the alternative — replacing a recompute with an Omove from a CSE-tracked register — costs the same instruction, plus a longer live range that may force a spill. So the threshold is strict: 1 ARM/Thumb-2 instruction, no register inputs. For Ointconst n, Oaddrstack n this means loadimm / addimm must emit a single instruction (predicates is_immed_loadimm / is_immed_addimm). Larger constants lower to movw + movt in Thumb-2 or longer iterate-op chains; CSE can profitably reuse them.

Definition is_trivial_op (op: operation) : bool :=
  match op with
  | Omove => true
  | Ointconst n => is_immed_loadimm n
  | Oaddrstack n => is_immed_addimm (Ptrofs.to_int n)
  | _ => false
  end.

Operations cheap enough to recompute (rematerialize) at use sites instead of spilling. Used by the AG2001 register allocator (-fregalloc= AG2001). The predicate must select operations that take no register inputs — otherwise the rematerialization would itself need to materialize those inputs. The alternative when false is a stack spill+reload str + ldr — 2 instructions plus L1 latency — so the threshold is more permissive than is_trivial_op: anything materializable in at most 2 register-only instructions qualifies. - Ointconst n in Thumb-2 always lowers to at most movw + movt (2 instr); in non-Thumb only the modified-immediate forms qualify. - Ofloatconst f / Osingleconst f: VFPv3 vmov.f64/f32 #imm is a single VFP instruction. Pool-loaded constants are 1 ARM instruction but pay the same L1 latency as a stack reload, so we exclude them. - Oaddrstack n: addimm always fits in at most 2 ARM/Thumb-2 instructions when ADDSUB encodings are exhausted (we accept length-1 OR length-2 decompositions).

Definition is_cheap_to_rematerialize (op: operation) : bool :=
  match op with
  | Ointconst n =>
      is_immed_loadimm n || Archi.thumb2_support
  | Ofloatconst f => andb Archi.vfpv3 (is_immediate_float64 f)
  | Osingleconst f => andb Archi.vfpv3 (is_immediate_float32 f)
  | Oaddrstack n =>
      let i := Ptrofs.to_int n in
      Nat.leb (List.length (decompose_int ADDSUB i)) 2 ||
      Nat.leb (List.length (decompose_int ADDSUB (Int.neg i))) 2
  | _ => false
  end.

Definition is_cheaper_than (op1 op2: operation) : bool :=
  match op1, op2 with
  | (Oaddrsymbol _ _), (Oaddimm _ | Omove) => false
  | _, _ => true
  end.
Opaque is_cheaper_than.

Operations that depend on the memory state.

Definition cond_depends_on_memory (c: condition) : bool :=
  match c with
  | Ccompu _ | Ccompushift _ _| Ccompuimm _ _ => true
  | _ => false
  end.

Definition op_depends_on_memory (op: operation) : bool :=
  match op with
  | Ocmp c => cond_depends_on_memory c
  | Osel c => cond_depends_on_memory c
  | Oselimm c _ => cond_depends_on_memory c
  | Oselimm2 c _ _ => cond_depends_on_memory c
  | _ => false
  end.

Lemma cond_depends_on_memory_correct:
  forall c args m1 m2,
  cond_depends_on_memory c = false ->
  eval_condition c args m1 = eval_condition c args m2.
Proof.
  intros. destruct c; simpl; auto; discriminate.
Qed.

Lemma op_depends_on_memory_correct:
  forall (F V: Type) (ge: Genv.t F V) sp op args m1 m2,
  op_depends_on_memory op = false ->
  eval_operation ge sp op args m1 = eval_operation ge sp op args m2.
Proof.
  intros until m2. destruct op; simpl; try congruence; intros C.
- f_equal; f_equal; apply cond_depends_on_memory_correct; auto.
- destruct args; auto. destruct args; auto.
  rewrite (cond_depends_on_memory_correct c args m1 m2 C). auto.
- destruct args; auto.
  rewrite (cond_depends_on_memory_correct c args m1 m2 C). auto.
- rewrite (cond_depends_on_memory_correct c args m1 m2 C). auto.
Qed.

Lemma cond_valid_pointer_eq:
  forall cond args m1 m2,
  (forall b z, Mem.valid_pointer m1 b z = Mem.valid_pointer m2 b z) ->
  eval_condition cond args m1 = eval_condition cond args m2.
Proof.
  intros until m2. intro MEM. destruct cond eqn:COND; simpl; try congruence.
  all: repeat (destruct args; simpl; try congruence);
    erewrite cmpu_bool_valid_pointer_eq || erewrite cmplu_bool_valid_pointer_eq; eauto.
Qed.

Lemma op_valid_pointer_eq:
  forall (F V: Type) (ge: Genv.t F V) sp op args m1 m2,
  (forall b z, Mem.valid_pointer m1 b z = Mem.valid_pointer m2 b z) ->
  eval_operation ge sp op args m1 = eval_operation ge sp op args m2.
Proof.
  intros until m2. destruct op eqn:OP; simpl; try congruence.
  - intros MEM; destruct c; simpl; try congruence;
    repeat (destruct args; simpl; try congruence);
    erewrite cmpu_bool_valid_pointer_eq || erewrite cmplu_bool_valid_pointer_eq; eauto.
  - intro MEM; destruct c; simpl; try congruence;
      repeat (destruct args; simpl; try congruence);
      erewrite cmpu_bool_valid_pointer_eq || erewrite cmplu_bool_valid_pointer_eq; eauto.
  - intro MEM; destruct c; simpl; try congruence;
      repeat (destruct args; simpl; try congruence);
      erewrite cmpu_bool_valid_pointer_eq || erewrite cmplu_bool_valid_pointer_eq; eauto.
  - intro MEM; destruct c; simpl; try congruence;
      repeat (destruct args; simpl; try congruence);
      erewrite cmpu_bool_valid_pointer_eq || erewrite cmplu_bool_valid_pointer_eq; eauto.
Qed.

Global variables mentioned in an operation or addressing mode

Definition globals_operation (op: operation) : list qualident :=
  match op with
  | Oaddrsymbol s ofs => s :: nil
  | _ => nil
  end.

Definition globals_addressing (addr: addressing) : list qualident := nil.

Invariance and compatibility properties.


eval_operation and eval_addressing depend on a global environment for resolving references to global symbols. We show that they give the same results if a global environment is replaced by another that assigns the same addresses to the same symbols.

Section GENV_TRANSF.

Variable F1 F2 V1 V2: Type.
Variable ge1: Genv.t F1 V1.
Variable ge2: Genv.t F2 V2.
Hypothesis agree_on_symbols:
  forall s, Genv.find_symbol ge2 s = Genv.find_symbol ge1 s.

Lemma eval_operation_preserved:
  forall sp op vl m,
  eval_operation ge2 sp op vl m = eval_operation ge1 sp op vl m.
Proof.
  intros.
  unfold eval_operation; destruct op; auto.
  unfold Genv.symbol_address. rewrite agree_on_symbols; auto.
Qed.

Lemma eval_addressing_preserved:
  forall sp addr vl,
  eval_addressing ge2 sp addr vl = eval_addressing ge1 sp addr vl.
Proof.
  intros.
  assert (UNUSED: forall s, Genv.find_symbol ge2 s = Genv.find_symbol ge1 s).
  exact agree_on_symbols.
  unfold eval_addressing; destruct addr; auto.
Qed.

End GENV_TRANSF.

Compatibility of the evaluation functions with value injections.

Section EVAL_COMPAT.

Variable F1 F2 V1 V2: Type.
Variable ge1: Genv.t F1 V1.
Variable ge2: Genv.t F2 V2.
Variable f: meminj.

Variable m1: mem.
Variable m2: mem.

Hypothesis valid_pointer_inj:
  forall b1 ofs b2 delta,
  f b1 = Some(b2, delta) ->
  Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true ->
  Mem.valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true.

Hypothesis weak_valid_pointer_inj:
  forall b1 ofs b2 delta,
  f b1 = Some(b2, delta) ->
  Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true ->
  Mem.weak_valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true.

Hypothesis weak_valid_pointer_no_overflow:
  forall b1 ofs b2 delta,
  f b1 = Some(b2, delta) ->
  Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true ->
  0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned.

Hypothesis valid_different_pointers_inj:
  forall b1 ofs1 b2 ofs2 b1' delta1 b2' delta2,
  b1 <> b2 ->
  Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs1) = true ->
  Mem.valid_pointer m1 b2 (Ptrofs.unsigned ofs2) = true ->
  f b1 = Some (b1', delta1) ->
  f b2 = Some (b2', delta2) ->
  b1' <> b2' \/
  Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta1)) <> Ptrofs.unsigned (Ptrofs.add ofs2 (Ptrofs.repr delta2)).

Ltac InvInject :=
  match goal with
  | [ H: Val.inject _ (Vint _) _ |- _ ] =>
      inv H; InvInject
  | [ H: Val.inject _ (Vfloat _) _ |- _ ] =>
      inv H; InvInject
  | [ H: Val.inject _ (Vsingle _) _ |- _ ] =>
      inv H; InvInject
  | [ H: Val.inject _ (Vptr _ _) _ |- _ ] =>
      inv H; InvInject
  | [ H: Val.inject_list _ nil _ |- _ ] =>
      inv H; InvInject
  | [ H: Val.inject_list _ (_ :: _) _ |- _ ] =>
      inv H; InvInject
  | _ => idtac
  end.

Remark eval_shift_inj:
  forall s v v', Val.inject f v v' -> Val.inject f (eval_shift s v) (eval_shift s v').
Proof.
  intros. inv H; destruct s; simpl; auto; rewrite s_range; auto.
Qed.

Lemma eval_condition_inj:
  forall cond vl1 vl2 b,
  Val.inject_list f vl1 vl2 ->
  eval_condition cond vl1 m1 = Some b ->
  eval_condition cond vl2 m2 = Some b.
Proof.
  intros. destruct cond; simpl in H0; FuncInv; InvInject; simpl.
  eauto 4 using Val.cmp_bool_inject.
  eauto 4 using Val.cmpu_bool_inject, Mem.valid_pointer_implies.
  eauto using Val.cmp_bool_inject, eval_shift_inj.
  eauto 4 using Val.cmpu_bool_inject, Mem.valid_pointer_implies, eval_shift_inj.
  eauto 4 using Val.cmp_bool_inject.
  eauto 4 using Val.cmpu_bool_inject, Mem.valid_pointer_implies.
  inv H3; inv H2; simpl in H0; inv H0; auto.
  inv H3; inv H2; simpl in H0; inv H0; auto.
  inv H3; simpl in H0; inv H0; auto.
  inv H3; simpl in H0; inv H0; auto.
  inv H3; inv H2; simpl in H0; inv H0; auto.
  inv H3; inv H2; simpl in H0; inv H0; auto.
  inv H3; simpl in H0; inv H0; auto.
  inv H3; simpl in H0; inv H0; auto.
  inv H3; simpl in H0; inv H0; auto.
  inv H3; simpl in H0; inv H0; auto.
  (* Ccompcarryu *)
  repeat match goal with H : Val.inject _ _ _ |- _ => inv H end;
    simpl in H0; inv H0; auto.
  (* Ccompcarry *)
  repeat match goal with H : Val.inject _ _ _ |- _ => inv H end;
    simpl in H0; inv H0; auto.
Qed.

Ltac TrivialExists :=
  match goal with
  | [ |- exists v2, Some ?v1 = Some v2 /\ Val.inject _ _ v2 ] =>
      exists v1; split; auto
  | _ => idtac
  end.

Lemma eval_operation_inj:
  forall op sp1 vl1 sp2 vl2 v1,
  (forall id ofs,
      In id (globals_operation op) ->
      Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) ->
  Val.inject f sp1 sp2 ->
  Val.inject_list f vl1 vl2 ->
  eval_operation ge1 sp1 op vl1 m1 = Some v1 ->
  exists v2, eval_operation ge2 sp2 op vl2 m2 = Some v2 /\ Val.inject f v1 v2.
Proof.
  intros until v1; intros GL; intros. destruct op; simpl in H1; simpl; FuncInv; InvInject; TrivialExists.
  - apply GL; simpl; auto.
  - apply Val.offset_ptr_inject; auto.
  - inv H4; simpl; auto.
  - inv H4; simpl; auto.
  - apply Val.add_inject; auto.
  - apply Val.add_inject; auto. apply eval_shift_inj; auto.
  - apply Val.add_inject; auto.

  - apply Val.sub_inject; auto.
  - apply Val.sub_inject; auto. apply eval_shift_inj; auto.
  - apply Val.sub_inject; auto. apply eval_shift_inj; auto.
  - apply (@Val.sub_inject f (Vint i) (Vint i) v v'); auto.

  - inv H4; inv H2; simpl; auto.
  - apply Val.add_inject; auto. inv H4; inv H2; simpl; auto.
  - apply Val.sub_inject; auto. inv H4; inv H2; simpl; auto.
  - inv H4; inv H2; simpl; auto.
  - inv H4; inv H2; simpl; auto.
  - inv H4; inv H3; simpl in H1; inv H1. simpl.
    destruct (Int.eq i0 Int.zero || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H2. TrivialExists.
  - inv H4; inv H3; simpl in H1; inv H1. simpl.
    destruct (Int.eq i0 Int.zero); inv H2. TrivialExists.

  - inv H4; inv H2; simpl; auto.
  - exploit (eval_shift_inj s). eexact H2. intros IS. inv H4; inv IS; simpl; auto.
  - inv H4; simpl; auto.
  - inv H4; inv H2; simpl; auto.
  - exploit (eval_shift_inj s). eexact H2. intros IS. inv H4; inv IS; simpl; auto.
  - inv H4; simpl; auto.
  - inv H4; inv H2; simpl; auto.
  - exploit (eval_shift_inj s). eexact H2. intros IS. inv H4; inv IS; simpl; auto.
  - inv H4; simpl; auto.
  - inv H4; inv H2; simpl; auto.
  - exploit (eval_shift_inj s). eexact H2. intros IS. inv H4; inv IS; simpl; auto.

  - inv H4; simpl; auto.
  - exploit (eval_shift_inj s). eexact H4. intros IS. inv IS; simpl; auto.

  - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto.
  - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto.
  - inv H4; inv H2; simpl; auto. destruct (Int.ltu i0 Int.iwordsize); auto.
  - inv H4; inv H2; simpl; auto.
  - apply eval_shift_inj; auto.
  - inv H4; simpl in H1; inv H1. simpl. destruct (Int.ltu i (Int.repr 31)); inv H2. TrivialExists.

  - inv H4; simpl; auto.
  - inv H4; simpl; auto.
  - inv H4; inv H2; simpl; auto.
  - inv H4; inv H2; simpl; auto.
  - inv H4; inv H2; simpl; auto.
  - inv H4; inv H2; simpl; auto.
  - inv H4; simpl; auto. (* Osqrtf *)
  - inv H4; inv H2; inv H3; simpl; auto.
  - inv H4; inv H2; inv H3; simpl; auto.

  - inv H4; simpl; auto.
  - inv H4; simpl; auto.
  - inv H4; inv H2; simpl; auto.
  - inv H4; inv H2; simpl; auto.
  - inv H4; inv H2; simpl; auto.
  - inv H4; inv H2; simpl; auto.
  - inv H4; simpl; auto. (* Osqrtfs *)
  - inv H4; inv H2; inv H3; simpl; auto.
  - inv H4; inv H2; inv H3; simpl; auto.

  - inv H4; simpl; auto.
  - inv H4; simpl; auto.

  - inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_int f0); simpl in H2; inv H2.
  exists (Vint i); auto.
  - inv H4; simpl in H1; inv H1. simpl. destruct (Float.to_intu f0); simpl in H2; inv H2.
  exists (Vint i); auto.
  - inv H4; simpl in *; inv H1. TrivialExists.
  - inv H4; simpl in *; inv H1. TrivialExists.

  - inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_int f0); simpl in H2; inv H2.
  exists (Vint i); auto.
  - inv H4; simpl in H1; inv H1. simpl. destruct (Float32.to_intu f0); simpl in H2; inv H2.
  exists (Vint i); auto.
  - inv H4; simpl in *; inv H1. TrivialExists.
  - inv H4; simpl in *; inv H1. TrivialExists.

  - inv H4; inv H2; simpl; auto.
  - inv H4; simpl; auto.
  - inv H4; simpl; auto.

  - subst v1. destruct (eval_condition c vl1 m1) eqn:?.
  exploit eval_condition_inj; eauto. intros EQ; rewrite EQ.
  destruct b; simpl; constructor.
  simpl; constructor.

  - apply Val.select_inject; auto.
  destruct (eval_condition c vl1 m1) eqn:?; auto.
  right; symmetry; eapply eval_condition_inj; eauto.
  - apply Val.select_inject; auto.
    destruct (eval_condition c vl1 m1) eqn:?; auto.
    right; symmetry; eapply eval_condition_inj; eauto.
  - subst v1. apply Val.select_inject; auto.
    destruct (eval_condition c vl1 m1) eqn:?; auto.
    right; symmetry; eapply eval_condition_inj; eauto.
  - inv H4; simpl; try constructor.
    destruct Int.ltu; simpl; constructor.
  - inv H4; simpl; try constructor.
    destruct Int.ltu; simpl; constructor.
  - inv H4; unfold clearf; destruct is_bitfield; cbn; constructor.
  - inv H4; inv H2; unfold insf; destruct is_bitfield; cbn; try constructor.
    destruct Int.ltu; cbn; constructor.
  - inv H4; simpl; auto. (* Oclz *)
  - inv H4; simpl; auto. (* Oreverse_bits *)
  - inv H4; simpl; auto.
  - inv H4; simpl; auto.
  - inv H4; simpl; auto.
  - inv H4; simpl; auto.
  - constructor.
  - apply Val.add_inject; auto.

  - apply Val.add_inject; auto.
  - apply Val.sub_inject; auto.
  - inv H4; auto.
  - inv H4; simpl; auto.
  - inv H4; simpl; auto.
  - inv H4; simpl; auto.
  - inv H4; simpl; auto.
  (* Ocmpcarryu *)
  - assert (LO12: Val.inject f (Val.longofwords v v0) (Val.longofwords v' v'0))
      by (apply Val.longofwords_inject; auto).
    assert (LO34: Val.inject f (Val.longofwords v2 v3) (Val.longofwords v'1 v'2))
      by (apply Val.longofwords_inject; auto).
    destruct v, v0; cbn in LO12; cbn;
      try (constructor; fail);
      inv LO12;
      destruct v2, v3; cbn in LO34; cbn;
        try (constructor; fail);
        inv LO34;
        destruct (Int64.cmpu c _ _); cbn; constructor.
  (* Ocmpcarry *)
  - assert (LO12: Val.inject f (Val.longofwords v v0) (Val.longofwords v' v'0))
      by (apply Val.longofwords_inject; auto).
    assert (LO34: Val.inject f (Val.longofwords v2 v3) (Val.longofwords v'1 v'2))
      by (apply Val.longofwords_inject; auto).
    destruct v, v0; cbn in LO12; cbn;
      try (constructor; fail);
      inv LO12;
      destruct v2, v3; cbn in LO34; cbn;
        try (constructor; fail);
        inv LO34;
        destruct (Int64.cmp c _ _); cbn; constructor.
Qed.

Lemma eval_addressing_inj:
  forall addr sp1 vl1 sp2 vl2 v1,
  (forall id ofs,
      In id (globals_addressing addr) ->
      Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) ->
  Val.inject f sp1 sp2 ->
  Val.inject_list f vl1 vl2 ->
  eval_addressing ge1 sp1 addr vl1 = Some v1 ->
  exists v2, eval_addressing ge2 sp2 addr vl2 = Some v2 /\ Val.inject f v1 v2.
Proof.
  intros. destruct addr; simpl in H2; simpl; FuncInv; InvInject; TrivialExists.
  apply Val.add_inject; auto.
  apply Val.add_inject; auto.
  apply Val.add_inject; auto. apply eval_shift_inj; auto.
  apply Val.offset_ptr_inject; auto.
Qed.

Lemma eval_addressing_inj_none:
  forall addr sp1 vl1 sp2 vl2,
  (forall id ofs,
      In id (globals_addressing addr) ->
      Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id ofs)) ->
  Val.inject f sp1 sp2 ->
  Val.inject_list f vl1 vl2 ->
  eval_addressing ge1 sp1 addr vl1 = None ->
  eval_addressing ge2 sp2 addr vl2 = None.
Proof.
  intros until vl2. intros Hglobal Hinjsp Hinjvl.
  destruct addr; simpl in *;
  inv Hinjvl; trivial; try discriminate; inv H0; trivial; try discriminate; inv H2; trivial; try discriminate.
Qed.
End EVAL_COMPAT.

Compatibility of the evaluation functions with the ``is less defined'' relation over values.

Section EVAL_LESSDEF.

Variable F V: Type.
Variable genv: Genv.t F V.

Remark valid_pointer_extends:
  forall m1 m2, Mem.extends m1 m2 ->
  forall b1 ofs b2 delta,
  Some(b1, 0) = Some(b2, delta) ->
  Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true ->
  Mem.valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true.
Proof.
  intros. inv H0. rewrite Ptrofs.add_zero. eapply Mem.valid_pointer_extends; eauto.
Qed.

Remark weak_valid_pointer_extends:
  forall m1 m2, Mem.extends m1 m2 ->
  forall b1 ofs b2 delta,
  Some(b1, 0) = Some(b2, delta) ->
  Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true ->
  Mem.weak_valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true.
Proof.
  intros. inv H0. rewrite Ptrofs.add_zero. eapply Mem.weak_valid_pointer_extends; eauto.
Qed.

Remark weak_valid_pointer_no_overflow_extends:
  forall m1 b1 ofs b2 delta,
  Some(b1, 0) = Some(b2, delta) ->
  Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true ->
  0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned.
Proof.
  intros. inv H. rewrite Z.add_0_r. apply Ptrofs.unsigned_range_2.
Qed.

Remark valid_different_pointers_extends:
  forall m1 b1 ofs1 b2 ofs2 b1' delta1 b2' delta2,
  b1 <> b2 ->
  Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs1) = true ->
  Mem.valid_pointer m1 b2 (Ptrofs.unsigned ofs2) = true ->
  Some(b1, 0) = Some (b1', delta1) ->
  Some(b2, 0) = Some (b2', delta2) ->
  b1' <> b2' \/
  Ptrofs.unsigned(Ptrofs.add ofs1 (Ptrofs.repr delta1)) <> Ptrofs.unsigned(Ptrofs.add ofs2 (Ptrofs.repr delta2)).
Proof.
  intros. inv H2; inv H3. auto.
Qed.

Lemma eval_condition_lessdef:
  forall cond vl1 vl2 b m1 m2,
  Val.lessdef_list vl1 vl2 ->
  Mem.extends m1 m2 ->
  eval_condition cond vl1 m1 = Some b ->
  eval_condition cond vl2 m2 = Some b.
Proof.
  intros. eapply eval_condition_inj with (f := fun b => Some(b, 0)) (m1 := m1).
  apply valid_pointer_extends; auto.
  apply weak_valid_pointer_extends; auto.
  apply weak_valid_pointer_no_overflow_extends.
  apply valid_different_pointers_extends; auto.
  rewrite <- val_inject_list_lessdef. eauto. auto.
Qed.

Lemma eval_operation_lessdef:
  forall sp op vl1 vl2 v1 m1 m2,
  Val.lessdef_list vl1 vl2 ->
  Mem.extends m1 m2 ->
  eval_operation genv sp op vl1 m1 = Some v1 ->
  exists v2, eval_operation genv sp op vl2 m2 = Some v2 /\ Val.lessdef v1 v2.
Proof.
  intros. rewrite val_inject_list_lessdef in H.
  assert (exists v2 : val,
          eval_operation genv sp op vl2 m2 = Some v2
          /\ Val.inject (fun b => Some(b, 0)) v1 v2).
  eapply eval_operation_inj with (m1 := m1) (sp1 := sp).
  apply valid_pointer_extends; auto.
  apply weak_valid_pointer_extends; auto.
  apply weak_valid_pointer_no_overflow_extends.
  apply valid_different_pointers_extends; auto.
  intros. rewrite <- val_inject_lessdef; auto.
  rewrite <- val_inject_lessdef; auto.
  eauto. auto.
  destruct H2 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto.
Qed.

Lemma eval_addressing_lessdef:
  forall sp addr vl1 vl2 v1,
  Val.lessdef_list vl1 vl2 ->
  eval_addressing genv sp addr vl1 = Some v1 ->
  exists v2, eval_addressing genv sp addr vl2 = Some v2 /\ Val.lessdef v1 v2.
Proof.
  intros. rewrite val_inject_list_lessdef in H.
  assert (exists v2 : val,
          eval_addressing genv sp addr vl2 = Some v2
          /\ Val.inject (fun b => Some(b, 0)) v1 v2).
  eapply eval_addressing_inj with (sp1 := sp).
  intros. rewrite <- val_inject_lessdef; auto.
  rewrite <- val_inject_lessdef; auto.
  eauto. auto.
  destruct H1 as [v2 [A B]]. exists v2; split; auto. rewrite val_inject_lessdef; auto.
Qed.

Lemma eval_addressing_lessdef_none:
  forall sp addr vl1 vl2,
  Val.lessdef_list vl1 vl2 ->
  eval_addressing genv sp addr vl1 = None ->
  eval_addressing genv sp addr vl2 = None.
Proof.
  intros. rewrite val_inject_list_lessdef in H.
  eapply eval_addressing_inj_none with (sp1 := sp).
  intros. rewrite <- val_inject_lessdef; auto.
  rewrite <- val_inject_lessdef; auto.
  eauto. auto.
Qed.

End EVAL_LESSDEF.

Compatibility of the evaluation functions with memory injections.

Section EVAL_INJECT.

Variable F V: Type.
Variable genv: Genv.t F V.
Variable f: meminj.
Hypothesis globals: meminj_preserves_globals genv f.
Variable sp1: block.
Variable sp2: block.
Variable delta: Z.
Hypothesis sp_inj: f sp1 = Some(sp2, delta).

Remark symbol_address_inject:
  forall id ofs, Val.inject f (Genv.symbol_address genv id ofs) (Genv.symbol_address genv id ofs).
Proof.
  intros. unfold Genv.symbol_address. destruct (Genv.find_symbol genv id) eqn:?; auto.
  exploit (proj1 globals); eauto. intros.
  econstructor; eauto. rewrite Ptrofs.add_zero; auto.
Qed.

Lemma eval_condition_inject:
  forall cond vl1 vl2 b m1 m2,
  Val.inject_list f vl1 vl2 ->
  Mem.inject f m1 m2 ->
  eval_condition cond vl1 m1 = Some b ->
  eval_condition cond vl2 m2 = Some b.
Proof.
  intros. eapply eval_condition_inj with (f := f) (m1 := m1); eauto.
  intros; eapply Mem.valid_pointer_inject_val; eauto.
  intros; eapply Mem.weak_valid_pointer_inject_val; eauto.
  intros; eapply Mem.weak_valid_pointer_inject_no_overflow; eauto.
  intros; eapply Mem.different_pointers_inject; eauto.
Qed.

Lemma eval_addressing_inject:
  forall addr vl1 vl2 v1,
  Val.inject_list f vl1 vl2 ->
  eval_addressing genv (Vptr sp1 Ptrofs.zero) addr vl1 = Some v1 ->
  exists v2,
     eval_addressing genv (Vptr sp2 Ptrofs.zero) (shift_stack_addressing delta addr) vl2 = Some v2
  /\ Val.inject f v1 v2.
Proof.
  intros.
  rewrite eval_shift_stack_addressing.
  eapply eval_addressing_inj with (sp1 := Vptr sp1 Ptrofs.zero); eauto.
  intros. apply symbol_address_inject.
  econstructor; eauto. rewrite Ptrofs.add_zero_l; auto.
Qed.

Lemma eval_addressing_inject_none:
  forall addr vl1 vl2,
  Val.inject_list f vl1 vl2 ->
  eval_addressing genv (Vptr sp1 Ptrofs.zero) addr vl1 = None ->
  eval_addressing genv (Vptr sp2 Ptrofs.zero) (shift_stack_addressing delta addr) vl2 = None.
Proof.
  intros.
  rewrite eval_shift_stack_addressing.
  eapply eval_addressing_inj_none with (sp1 := Vptr sp1 Ptrofs.zero); eauto.
  intros. apply symbol_address_inject.
  econstructor; eauto. rewrite Ptrofs.add_zero_l; auto.
Qed.

Lemma eval_operation_inject:
  forall op vl1 vl2 v1 m1 m2,
  Val.inject_list f vl1 vl2 ->
  Mem.inject f m1 m2 ->
  eval_operation genv (Vptr sp1 Ptrofs.zero) op vl1 m1 = Some v1 ->
  exists v2,
     eval_operation genv (Vptr sp2 Ptrofs.zero) (shift_stack_operation delta op) vl2 m2 = Some v2
  /\ Val.inject f v1 v2.
Proof.
  intros.
  rewrite eval_shift_stack_operation. simpl.
  eapply eval_operation_inj with (sp1 := Vptr sp1 Ptrofs.zero) (m1 := m1); eauto.
  intros; eapply Mem.valid_pointer_inject_val; eauto.
  intros; eapply Mem.weak_valid_pointer_inject_val; eauto.
  intros; eapply Mem.weak_valid_pointer_inject_no_overflow; eauto.
  intros; eapply Mem.different_pointers_inject; eauto.
  intros; apply symbol_address_inject.
  econstructor; eauto. rewrite Ptrofs.add_zero_l; auto.
Qed.

End EVAL_INJECT.

Symbol remapping for operations and addressing modes


These definitions and lemmas support passes that remap global symbols (e.g., symbol injection / static merging). They are architecture-specific because the set of symbol-referencing operations and addressing modes differs across targets. On ARM, only Oaddrsymbol references a symbol in operations, and no addressing modes reference symbols.

Section MAP_INJECT.

Variable F1 F2 V1 V2: Type.
Variable ge1: Genv.t F1 V1.
Variable ge2: Genv.t F2 V2.
Variable f: meminj.
Variable map_sym: qualident -> ptrofs -> qualident * ptrofs.

Remap operations that reference global symbols.

Definition map_operation (op: operation) : operation :=
  match op with
  | Oaddrsymbol id ofs => let '(id', ofs') := map_sym id ofs in Oaddrsymbol id' ofs'
  | _ => op
  end.

Remap addressing modes that reference global symbols. On ARM, no addressing modes reference symbols.

Definition map_addressing (addr: addressing) : addressing :=
  let _ := map_sym in addr.

Variable m1: mem.
Variable m2: mem.

Hypothesis valid_pointer_inj:
  forall b1 ofs b2 delta,
  f b1 = Some(b2, delta) ->
  Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true ->
  Mem.valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true.

Hypothesis weak_valid_pointer_inj:
  forall b1 ofs b2 delta,
  f b1 = Some(b2, delta) ->
  Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true ->
  Mem.weak_valid_pointer m2 b2 (Ptrofs.unsigned (Ptrofs.add ofs (Ptrofs.repr delta))) = true.

Hypothesis weak_valid_pointer_no_overflow:
  forall b1 ofs b2 delta,
  f b1 = Some(b2, delta) ->
  Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs) = true ->
  0 <= Ptrofs.unsigned ofs + Ptrofs.unsigned (Ptrofs.repr delta) <= Ptrofs.max_unsigned.

Hypothesis valid_different_pointers_inj:
  forall b1 ofs1 b2 ofs2 b1' delta1 b2' delta2,
  b1 <> b2 ->
  Mem.valid_pointer m1 b1 (Ptrofs.unsigned ofs1) = true ->
  Mem.valid_pointer m1 b2 (Ptrofs.unsigned ofs2) = true ->
  f b1 = Some (b1', delta1) ->
  f b2 = Some (b2', delta2) ->
  b1' <> b2' \/
  Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta1)) <> Ptrofs.unsigned (Ptrofs.add ofs2 (Ptrofs.repr delta2)).

Lemma map_operation_correct:
  forall op sp1 sp2 vl1 vl2 v1,
  (forall id ofs,
    In id (globals_operation op) ->
    let '(id', ofs') := map_sym id ofs in
    Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id' ofs')) ->
  Val.inject f sp1 sp2 ->
  Val.inject_list f vl1 vl2 ->
  eval_operation ge1 sp1 op vl1 m1 = Some v1 ->
  exists v2, eval_operation ge2 sp2 (map_operation op) vl2 m2 = Some v2
          /\ Val.inject f v1 v2.
Proof.
  intros until v1; intros GL SP INJ EVAL.
  destruct op;
  try (eapply eval_operation_inj with (m1 := m1) (m2 := m2); eauto;
       [ intros; contradiction ]).
  - (* Oaddrsymbol q i *)
    simpl in EVAL.
    destruct vl1; try discriminate. inv INJ. inv EVAL.
    specialize (GL q i (or_introl eq_refl)).
    simpl.
    destruct (map_sym q i) as [id' ofs']; simpl;
      eexists; split; eauto.
Qed.

Lemma map_addressing_inject:
  forall addr sp1 sp2 vl1 vl2 v1,
  (forall id ofs,
    In id (globals_addressing addr) ->
    let '(id', ofs') := map_sym id ofs in
    Val.inject f (Genv.symbol_address ge1 id ofs) (Genv.symbol_address ge2 id' ofs')) ->
  Val.inject f sp1 sp2 ->
  Val.inject_list f vl1 vl2 ->
  eval_addressing ge1 sp1 addr vl1 = Some v1 ->
  exists v2, eval_addressing ge2 sp2 (map_addressing addr) vl2 = Some v2
          /\ Val.inject f v1 v2.
Proof.
  intros. unfold map_addressing.
  eapply eval_addressing_inj; eauto.
  (* On ARM, globals_addressing returns nil for all addressing modes,
     so the GL hypothesis of eval_addressing_inj is vacuously true. *)
  intros. destruct addr; simpl in H3; contradiction.
Qed.

End MAP_INJECT.

Lemma map_operation_ext:
  forall (f g: qualident -> ptrofs -> qualident * ptrofs) op,
  (forall id ofs, In id (globals_operation op) -> f id ofs = g id ofs) ->
  map_operation f op = map_operation g op.
Proof.
  intros f g [] H; simpl; auto.
  rewrite H by (simpl; auto). destruct (g _ _); auto.
Qed.

Lemma map_addressing_ext:
  forall (f g: qualident -> ptrofs -> qualident * ptrofs) addr,
  (forall id ofs, In id (globals_addressing addr) -> f id ofs = g id ofs) ->
  map_addressing f addr = map_addressing g addr.
Proof.
  intros f g addr H. unfold map_addressing. auto.
Qed.

Handling of builtin arguments


Definition builtin_arg_ok_1
       (A: Type) (ba: builtin_arg A) (c: builtin_arg_constraint) :=
  match c, ba with
  | OK_all, _ => true
  | OK_const, (BA_int _ | BA_long _ | BA_float _ | BA_single _) => true
  | OK_addrstack, BA_addrstack _ => true
  | OK_addressing, BA_addrstack _ => true
  | OK_addressing, BA_addptr (BA _) (BA_int _) => true
  | _, _ => false
  end.

Definition builtin_arg_ok
       (A: Type) (ba: builtin_arg A) (c: builtin_arg_constraint) :=
  match ba with
  | (BA _ | BA_splitlong (BA _) (BA _)) => true
  | _ => builtin_arg_ok_1 ba c
  end.

Definition getcanary : option operation := Some Ogetcanary.
Definition clearcanary :=Ointconst Int.zero.
Definition canary_cmp := Ccompu Ceq.

Links between addressing and builtin_arg

Require Import OptionMonad.

Addressing builtin_arg reg: a subset of builtin_arg corresponding to an addressing mode Currently: we only focus on addressing mode used for memcpy.

Inductive abarg {A:Type} : Type :=
  | ABA (r: A)
  | ABA_indexed (r: A) (n: int)
  | ABA_addrstack (ofs: ptrofs)
  .
Arguments abarg: clear implicits.

Definition from_abarg {A} (aba: abarg A) : builtin_arg A :=
  match aba with
  | ABA r => BA r
  | ABA_indexed r n => BA_addptr (BA r) (BA_int n)
  | ABA_addrstack ofs => BA_addrstack ofs
  end
  .

Coercion from_abarg: abarg >-> builtin_arg.

Definition to_abarg {A} (ba: builtin_arg A): option (abarg A) :=
  match ba with
  | BA r => Some (ABA r)
  | BA_addptr (BA r) (BA_int n) => Some (ABA_indexed r n)
  | BA_addrstack ofs => Some (ABA_addrstack ofs)
  | _ => None
  end.

Lemma from_abarg_injection {A} (aba: abarg A): to_abarg (from_abarg aba) = Some aba.
Proof.
  induction aba; simplify_option.
Qed.

Import ListNotations.
Open Scope list_scope.
Open Scope option_monad_scope.

Definition addr_of_abarg {A} (aba: abarg A) : addressing * list A :=
  match aba with
  | ABA r => (Aindexed Int.zero, [r])
  | ABA_indexed r n => (Aindexed n, [r])
  | ABA_addrstack ofs => (Ainstack ofs, [])
  end
  .

Local Opaque Val.addnull.

Lemma addr_of_abarg_correct {A} (aba: abarg A) {F V: Type} (genv: Genv.t F V) (sem: A -> val) sp m l addr:
  addr_of_abarg aba = (addr, l) ->
  eval_addressing genv sp addr (List.map sem l) = SOME v <- evalopt_builtin_arg genv sem sp m (from_abarg aba) IN Some (Val.addnull v).
Proof.
  destruct aba; injection 1 as <- <-; cbn; simplify_option;
  rewrite ?Val.addnull_add, ?Val.addnull_offset_ptr; auto.
Qed.

Definition addr_to_abarg {A:Type} (xaddr: addressing * list A) : option (abarg A) :=
  match fst xaddr, snd xaddr with
  | Aindexed n, [r] => Some (ABA_indexed r n)
  | Ainstack ofs, nil => Some (ABA_addrstack ofs)
  | _, _ => None
  end.

Lemma addr_to_abarg_correct {A} (aba: abarg A) {F V: Type} (genv: Genv.t F V) (sem: A -> val) sp m addr l:
  addr_to_abarg (addr, l) = Some aba ->
  eval_addressing genv sp addr (List.map sem l) = SOME v <- evalopt_builtin_arg genv sem sp m (from_abarg aba) IN Some (Val.addnull v).
Proof.
  destruct addr; cbn; simplify_option;
  rewrite ?Val.addnull_add, ?Val.addnull_offset_ptr; auto.
Qed.
Generated by coq2html