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

(** Strength reduction for operators and conditions.
    This is the machine-dependent part of [Constprop]. *)

Require Import Coqlib.
Require Import Compopts.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Op.
Require Import Registers.
Require Import ValueDomain.

(** * Operator strength reduction *)

(** We now define auxiliary functions for strength reduction of
  operators and addressing modes: replacing an operator with a cheaper
  one if some of its arguments are statically known.  These are again
  large pattern-matchings expressed in indirect style. *)

(** Original definition:
<<
Nondetfunction cond_strength_reduction
              (cond: condition) (args: list reg) (vl: list aval) :=
  match cond, args, vl with
  | Ccomp c, r1 :: r2 :: nil, I n1 :: v2 :: nil =>
      (Ccompimm (swap_comparison c) n1, r2 :: nil)
  | Ccomp c, r1 :: r2 :: nil, v1 :: I n2 :: nil =>
      (Ccompimm c n2, r1 :: nil)
  | Ccompu c, r1 :: r2 :: nil, I n1 :: v2 :: nil =>
      (Ccompuimm (swap_comparison c) n1, r2 :: nil)
  | Ccompu c, r1 :: r2 :: nil, v1 :: I n2 :: nil =>
      (Ccompuimm c n2, r1 :: nil)
  | _, _, _ =>
      (cond, args)
  end.
>>
*)

Inductive cond_strength_reduction_cases: forall (cond: condition) (args: list reg) (vl: list aval), Type :=
  | cond_strength_reduction_case1: forall c r1 r2 n1 v2, cond_strength_reduction_cases (Ccomp c) (r1 :: r2 :: nil) (I n1 :: v2 :: nil)
  | cond_strength_reduction_case2: forall c r1 r2 v1 n2, cond_strength_reduction_cases (Ccomp c) (r1 :: r2 :: nil) (v1 :: I n2 :: nil)
  | cond_strength_reduction_case3: forall c r1 r2 n1 v2, cond_strength_reduction_cases (Ccompu c) (r1 :: r2 :: nil) (I n1 :: v2 :: nil)
  | cond_strength_reduction_case4: forall c r1 r2 v1 n2, cond_strength_reduction_cases (Ccompu c) (r1 :: r2 :: nil) (v1 :: I n2 :: nil)
  | cond_strength_reduction_default: forall (cond: condition) (args: list reg) (vl: list aval), cond_strength_reduction_cases cond args vl.

Definition cond_strength_reduction_match (cond: condition) (args: list reg) (vl: list aval) :=
  match cond as zz1, args as zz2, vl as zz3 return cond_strength_reduction_cases zz1 zz2 zz3 with
  | Ccomp c, r1 :: r2 :: nil, I n1 :: v2 :: nil => cond_strength_reduction_case1 c r1 r2 n1 v2
  | Ccomp c, r1 :: r2 :: nil, v1 :: I n2 :: nil => cond_strength_reduction_case2 c r1 r2 v1 n2
  | Ccompu c, r1 :: r2 :: nil, I n1 :: v2 :: nil => cond_strength_reduction_case3 c r1 r2 n1 v2
  | Ccompu c, r1 :: r2 :: nil, v1 :: I n2 :: nil => cond_strength_reduction_case4 c r1 r2 v1 n2
  | cond, args, vl => cond_strength_reduction_default cond args vl
  end.

Definition cond_strength_reduction (cond: condition) (args: list reg) (vl: list aval) :=
  match cond_strength_reduction_match cond args vl with
  | cond_strength_reduction_case1 c r1 r2 n1 v2 => (* Ccomp c, r1 :: r2 :: nil, I n1 :: v2 :: nil *)
      (Ccompimm (swap_comparison c) n1, r2 :: nil)
  | cond_strength_reduction_case2 c r1 r2 v1 n2 => (* Ccomp c, r1 :: r2 :: nil, v1 :: I n2 :: nil *)
      (Ccompimm c n2, r1 :: nil)
  | cond_strength_reduction_case3 c r1 r2 n1 v2 => (* Ccompu c, r1 :: r2 :: nil, I n1 :: v2 :: nil *)
      (Ccompuimm (swap_comparison c) n1, r2 :: nil)
  | cond_strength_reduction_case4 c r1 r2 v1 n2 => (* Ccompu c, r1 :: r2 :: nil, v1 :: I n2 :: nil *)
      (Ccompuimm c n2, r1 :: nil)
  | cond_strength_reduction_default cond args vl =>
      (cond, args)
  end.

Definition make_cmp_base (c: condition) (args: list reg) (vl: list aval) :=
  let (c', args') := cond_strength_reduction c args vl in (Ocmp c', args').

(** Original definition:
<<
Nondetfunction make_cmp (c: condition) (args: list reg) (vl: list aval) :=
  match c, args, vl with
  | Ccompimm Ceq n, r1 :: nil, v1 :: nil =>
      if Int.eq_dec n Int.one && vincl v1 (Uns 1) then (Omove, r1 :: nil)
      else if Int.eq_dec n Int.zero && vincl v1 (Uns 1) then (Oxorimm Int.one, r1 :: nil)
      else make_cmp_base c args vl
  | Ccompimm Cne n, r1 :: nil, v1 :: nil =>
      if Int.eq_dec n Int.zero && vincl v1 (Uns 1) then (Omove, r1 :: nil)
      else if Int.eq_dec n Int.one && vincl v1 (Uns 1) then (Oxorimm Int.one, r1 :: nil)
      else make_cmp_base c args vl
  | _, _, _ =>
      make_cmp_base c args vl
  end.
>>
*)

Inductive make_cmp_cases: forall (c: condition) (args: list reg) (vl: list aval), Type :=
  | make_cmp_case1: forall n r1 v1, make_cmp_cases (Ccompimm Ceq n) (r1 :: nil) (v1 :: nil)
  | make_cmp_case2: forall n r1 v1, make_cmp_cases (Ccompimm Cne n) (r1 :: nil) (v1 :: nil)
  | make_cmp_default: forall (c: condition) (args: list reg) (vl: list aval), make_cmp_cases c args vl.

Definition make_cmp_match (c: condition) (args: list reg) (vl: list aval) :=
  match c as zz1, args as zz2, vl as zz3 return make_cmp_cases zz1 zz2 zz3 with
  | Ccompimm Ceq n, r1 :: nil, v1 :: nil => make_cmp_case1 n r1 v1
  | Ccompimm Cne n, r1 :: nil, v1 :: nil => make_cmp_case2 n r1 v1
  | c, args, vl => make_cmp_default c args vl
  end.

Definition make_cmp (c: condition) (args: list reg) (vl: list aval) :=
  match make_cmp_match c args vl with
  | make_cmp_case1 n r1 v1 => (* Ccompimm Ceq n, r1 :: nil, v1 :: nil *)
      if Int.eq_dec n Int.one && vincl v1 (Uns 1) then (Omove, r1 :: nil) else if Int.eq_dec n Int.zero && vincl v1 (Uns 1) then (Oxorimm Int.one, r1 :: nil) else make_cmp_base c args vl
  | make_cmp_case2 n r1 v1 => (* Ccompimm Cne n, r1 :: nil, v1 :: nil *)
      if Int.eq_dec n Int.zero && vincl v1 (Uns 1) then (Omove, r1 :: nil) else if Int.eq_dec n Int.one && vincl v1 (Uns 1) then (Oxorimm Int.one, r1 :: nil) else make_cmp_base c args vl
  | make_cmp_default c args vl =>
      make_cmp_base c args vl
  end.

(** Original definition:
<<
Nondetfunction addr_strength_reduction
                (addr: addressing) (args: list reg) (vl: list aval) :=
  match addr, args, vl with

  | Aindexed ofs, r1 :: nil, Ptr(Gl symb n) :: nil =>
      (Aglobal symb (Int.add n ofs), nil)
  | Aindexed ofs, r1 :: nil, Ptr(Stk n) :: nil =>
      (Ainstack (Int.add n ofs), nil)

  | Aindexed2 ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: I n2 :: nil =>
      (Aglobal symb (Int.add (Int.add n1 n2) ofs), nil)
  | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: Ptr(Gl symb n2) :: nil =>
      (Aglobal symb (Int.add (Int.add n1 n2) ofs), nil)
  | Aindexed2 ofs, r1 :: r2 :: nil, Ptr(Stk n1) :: I n2 :: nil =>
      (Ainstack (Int.add (Int.add n1 n2) ofs), nil)
  | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: Ptr(Stk n2) :: nil =>
      (Ainstack (Int.add (Int.add n1 n2) ofs), nil)
  | Aindexed2 ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: v2 :: nil =>
      (Abased symb (Int.add n1 ofs), r2 :: nil)
  | Aindexed2 ofs, r1 :: r2 :: nil, v1 :: Ptr(Gl symb n2) :: nil =>
      (Abased symb (Int.add n2 ofs), r1 :: nil)
  | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: v2 :: nil =>
      (Aindexed (Int.add n1 ofs), r2 :: nil)
  | Aindexed2 ofs, r1 :: r2 :: nil, v1 :: I n2 :: nil =>
      (Aindexed (Int.add n2 ofs), r1 :: nil)

  | Aindexed2scaled sc ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: I n2 :: nil =>
      (Aglobal symb (Int.add (Int.add n1 (Int.mul n2 sc)) ofs), nil)
  | Aindexed2scaled sc ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: v2 :: nil =>
      (Abasedscaled sc symb (Int.add n1 ofs), r2 :: nil)
  | Aindexed2scaled sc ofs, r1 :: r2 :: nil, v1 :: I n2 :: nil =>
      (Aindexed (Int.add (Int.mul n2 sc) ofs), r1 :: nil)

  | Abased id ofs, r1 :: nil, I n1 :: nil =>
      (Aglobal id (Int.add ofs n1), nil)

  | Abasedscaled sc id ofs, r1 :: nil, I n1 :: nil =>
      (Aglobal id (Int.add ofs (Int.mul sc n1)), nil)

  | _, _ =>
      (addr, args)
  end.
>>
*)

Inductive addr_strength_reduction_cases: forall (addr: addressing) (args: list reg) (vl: list aval), Type :=
  | addr_strength_reduction_case1: forall ofs r1 symb n, addr_strength_reduction_cases (Aindexed ofs) (r1 :: nil) (Ptr(Gl symb n) :: nil)
  | addr_strength_reduction_case2: forall ofs r1 n, addr_strength_reduction_cases (Aindexed ofs) (r1 :: nil) (Ptr(Stk n) :: nil)
  | addr_strength_reduction_case3: forall ofs r1 r2 symb n1 n2, addr_strength_reduction_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (Ptr(Gl symb n1) :: I n2 :: nil)
  | addr_strength_reduction_case4: forall ofs r1 r2 n1 symb n2, addr_strength_reduction_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (I n1 :: Ptr(Gl symb n2) :: nil)
  | addr_strength_reduction_case5: forall ofs r1 r2 n1 n2, addr_strength_reduction_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (Ptr(Stk n1) :: I n2 :: nil)
  | addr_strength_reduction_case6: forall ofs r1 r2 n1 n2, addr_strength_reduction_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (I n1 :: Ptr(Stk n2) :: nil)
  | addr_strength_reduction_case7: forall ofs r1 r2 symb n1 v2, addr_strength_reduction_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (Ptr(Gl symb n1) :: v2 :: nil)
  | addr_strength_reduction_case8: forall ofs r1 r2 v1 symb n2, addr_strength_reduction_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (v1 :: Ptr(Gl symb n2) :: nil)
  | addr_strength_reduction_case9: forall ofs r1 r2 n1 v2, addr_strength_reduction_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (I n1 :: v2 :: nil)
  | addr_strength_reduction_case10: forall ofs r1 r2 v1 n2, addr_strength_reduction_cases (Aindexed2 ofs) (r1 :: r2 :: nil) (v1 :: I n2 :: nil)
  | addr_strength_reduction_case11: forall sc ofs r1 r2 symb n1 n2, addr_strength_reduction_cases (Aindexed2scaled sc ofs) (r1 :: r2 :: nil) (Ptr(Gl symb n1) :: I n2 :: nil)
  | addr_strength_reduction_case12: forall sc ofs r1 r2 symb n1 v2, addr_strength_reduction_cases (Aindexed2scaled sc ofs) (r1 :: r2 :: nil) (Ptr(Gl symb n1) :: v2 :: nil)
  | addr_strength_reduction_case13: forall sc ofs r1 r2 v1 n2, addr_strength_reduction_cases (Aindexed2scaled sc ofs) (r1 :: r2 :: nil) (v1 :: I n2 :: nil)
  | addr_strength_reduction_case14: forall id ofs r1 n1, addr_strength_reduction_cases (Abased id ofs) (r1 :: nil) (I n1 :: nil)
  | addr_strength_reduction_case15: forall sc id ofs r1 n1, addr_strength_reduction_cases (Abasedscaled sc id ofs) (r1 :: nil) (I n1 :: nil)
  | addr_strength_reduction_default: forall (addr: addressing) (args: list reg) (vl: list aval), addr_strength_reduction_cases addr args vl.

Definition addr_strength_reduction_match (addr: addressing) (args: list reg) (vl: list aval) :=
  match addr as zz1, args as zz2, vl as zz3 return addr_strength_reduction_cases zz1 zz2 zz3 with
  | Aindexed ofs, r1 :: nil, Ptr(Gl symb n) :: nil => addr_strength_reduction_case1 ofs r1 symb n
  | Aindexed ofs, r1 :: nil, Ptr(Stk n) :: nil => addr_strength_reduction_case2 ofs r1 n
  | Aindexed2 ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: I n2 :: nil => addr_strength_reduction_case3 ofs r1 r2 symb n1 n2
  | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: Ptr(Gl symb n2) :: nil => addr_strength_reduction_case4 ofs r1 r2 n1 symb n2
  | Aindexed2 ofs, r1 :: r2 :: nil, Ptr(Stk n1) :: I n2 :: nil => addr_strength_reduction_case5 ofs r1 r2 n1 n2
  | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: Ptr(Stk n2) :: nil => addr_strength_reduction_case6 ofs r1 r2 n1 n2
  | Aindexed2 ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: v2 :: nil => addr_strength_reduction_case7 ofs r1 r2 symb n1 v2
  | Aindexed2 ofs, r1 :: r2 :: nil, v1 :: Ptr(Gl symb n2) :: nil => addr_strength_reduction_case8 ofs r1 r2 v1 symb n2
  | Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: v2 :: nil => addr_strength_reduction_case9 ofs r1 r2 n1 v2
  | Aindexed2 ofs, r1 :: r2 :: nil, v1 :: I n2 :: nil => addr_strength_reduction_case10 ofs r1 r2 v1 n2
  | Aindexed2scaled sc ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: I n2 :: nil => addr_strength_reduction_case11 sc ofs r1 r2 symb n1 n2
  | Aindexed2scaled sc ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: v2 :: nil => addr_strength_reduction_case12 sc ofs r1 r2 symb n1 v2
  | Aindexed2scaled sc ofs, r1 :: r2 :: nil, v1 :: I n2 :: nil => addr_strength_reduction_case13 sc ofs r1 r2 v1 n2
  | Abased id ofs, r1 :: nil, I n1 :: nil => addr_strength_reduction_case14 id ofs r1 n1
  | Abasedscaled sc id ofs, r1 :: nil, I n1 :: nil => addr_strength_reduction_case15 sc id ofs r1 n1
  | addr, args, vl => addr_strength_reduction_default addr args vl
  end.

Definition addr_strength_reduction (addr: addressing) (args: list reg) (vl: list aval) :=
  match addr_strength_reduction_match addr args vl with
  | addr_strength_reduction_case1 ofs r1 symb n => (* Aindexed ofs, r1 :: nil, Ptr(Gl symb n) :: nil *)
      (Aglobal symb (Int.add n ofs), nil)
  | addr_strength_reduction_case2 ofs r1 n => (* Aindexed ofs, r1 :: nil, Ptr(Stk n) :: nil *)
      (Ainstack (Int.add n ofs), nil)
  | addr_strength_reduction_case3 ofs r1 r2 symb n1 n2 => (* Aindexed2 ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: I n2 :: nil *)
      (Aglobal symb (Int.add (Int.add n1 n2) ofs), nil)
  | addr_strength_reduction_case4 ofs r1 r2 n1 symb n2 => (* Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: Ptr(Gl symb n2) :: nil *)
      (Aglobal symb (Int.add (Int.add n1 n2) ofs), nil)
  | addr_strength_reduction_case5 ofs r1 r2 n1 n2 => (* Aindexed2 ofs, r1 :: r2 :: nil, Ptr(Stk n1) :: I n2 :: nil *)
      (Ainstack (Int.add (Int.add n1 n2) ofs), nil)
  | addr_strength_reduction_case6 ofs r1 r2 n1 n2 => (* Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: Ptr(Stk n2) :: nil *)
      (Ainstack (Int.add (Int.add n1 n2) ofs), nil)
  | addr_strength_reduction_case7 ofs r1 r2 symb n1 v2 => (* Aindexed2 ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: v2 :: nil *)
      (Abased symb (Int.add n1 ofs), r2 :: nil)
  | addr_strength_reduction_case8 ofs r1 r2 v1 symb n2 => (* Aindexed2 ofs, r1 :: r2 :: nil, v1 :: Ptr(Gl symb n2) :: nil *)
      (Abased symb (Int.add n2 ofs), r1 :: nil)
  | addr_strength_reduction_case9 ofs r1 r2 n1 v2 => (* Aindexed2 ofs, r1 :: r2 :: nil, I n1 :: v2 :: nil *)
      (Aindexed (Int.add n1 ofs), r2 :: nil)
  | addr_strength_reduction_case10 ofs r1 r2 v1 n2 => (* Aindexed2 ofs, r1 :: r2 :: nil, v1 :: I n2 :: nil *)
      (Aindexed (Int.add n2 ofs), r1 :: nil)
  | addr_strength_reduction_case11 sc ofs r1 r2 symb n1 n2 => (* Aindexed2scaled sc ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: I n2 :: nil *)
      (Aglobal symb (Int.add (Int.add n1 (Int.mul n2 sc)) ofs), nil)
  | addr_strength_reduction_case12 sc ofs r1 r2 symb n1 v2 => (* Aindexed2scaled sc ofs, r1 :: r2 :: nil, Ptr(Gl symb n1) :: v2 :: nil *)
      (Abasedscaled sc symb (Int.add n1 ofs), r2 :: nil)
  | addr_strength_reduction_case13 sc ofs r1 r2 v1 n2 => (* Aindexed2scaled sc ofs, r1 :: r2 :: nil, v1 :: I n2 :: nil *)
      (Aindexed (Int.add (Int.mul n2 sc) ofs), r1 :: nil)
  | addr_strength_reduction_case14 id ofs r1 n1 => (* Abased id ofs, r1 :: nil, I n1 :: nil *)
      (Aglobal id (Int.add ofs n1), nil)
  | addr_strength_reduction_case15 sc id ofs r1 n1 => (* Abasedscaled sc id ofs, r1 :: nil, I n1 :: nil *)
      (Aglobal id (Int.add ofs (Int.mul sc n1)), nil)
  | addr_strength_reduction_default addr args vl =>
      (addr, args)
  end.

Definition make_addimm (n: int) (r: reg) :=
  if Int.eq n Int.zero
  then (Omove, r :: nil)
  else (Olea (Aindexed n), r :: nil).

Definition make_shlimm (n: int) (r1 r2: reg) :=
  if Int.eq n Int.zero then (Omove, r1 :: nil)
  else if Int.ltu n Int.iwordsize then (Oshlimm n, r1 :: nil)
  else (Oshl, r1 :: r2 :: nil).

Definition make_shrimm (n: int) (r1 r2: reg) :=
  if Int.eq n Int.zero then (Omove, r1 :: nil)
  else if Int.ltu n Int.iwordsize then (Oshrimm n, r1 :: nil)
  else (Oshr, r1 :: r2 :: nil).

Definition make_shruimm (n: int) (r1 r2: reg) :=
  if Int.eq n Int.zero then (Omove, r1 :: nil)
  else if Int.ltu n Int.iwordsize then (Oshruimm n, r1 :: nil)
  else (Oshru, r1 :: r2 :: nil).

Definition make_mulimm (n: int) (r: reg) :=
  if Int.eq n Int.zero then
    (Ointconst Int.zero, nil)
  else if Int.eq n Int.one then
    (Omove, r :: nil)
  else
    match Int.is_power2 n with
    | Some l => (Oshlimm l, r :: nil)
    | None => (Omulimm n, r :: nil)
    end.

Definition make_andimm (n: int) (r: reg) (a: aval) :=
  if Int.eq n Int.zero then (Ointconst Int.zero, nil)
  else if Int.eq n Int.mone then (Omove, r :: nil)
  else if match a with Uns m => Int.eq (Int.zero_ext m (Int.not n)) Int.zero
                     | _ => false end
  then (Omove, r :: nil)
  else (Oandimm n, r :: nil).

Definition make_orimm (n: int) (r: reg) :=
  if Int.eq n Int.zero then (Omove, r :: nil)
  else if Int.eq n Int.mone then (Ointconst Int.mone, nil)
  else (Oorimm n, r :: nil).

Definition make_xorimm (n: int) (r: reg) :=
  if Int.eq n Int.zero then (Omove, r :: nil)
  else if Int.eq n Int.mone then (Onot, r :: nil)
  else (Oxorimm n, r :: nil).

Definition make_divimm n (r1 r2: reg) :=
  match Int.is_power2 n with
  | Some l => if Int.ltu l (Int.repr 31)
              then (Oshrximm l, r1 :: nil)
              else (Odiv, r1 :: r2 :: nil)
  | None   => (Odiv, r1 :: r2 :: nil)
  end.

Definition make_divuimm n (r1 r2: reg) :=
  match Int.is_power2 n with
  | Some l => (Oshruimm l, r1 :: nil)
  | None   => (Odivu, r1 :: r2 :: nil)
  end.

Definition make_moduimm n (r1 r2: reg) :=
  match Int.is_power2 n with
  | Some l => (Oandimm (Int.sub n Int.one), r1 :: nil)
  | None   => (Omodu, r1 :: r2 :: nil)
  end.

Definition make_mulfimm (n: float) (r r1 r2: reg) :=
  if Float.eq_dec n (Float.of_int (Int.repr 2))
  then (Oaddf, r :: r :: nil)
  else (Omulf, r1 :: r2 :: nil).

Definition make_mulfsimm (n: float32) (r r1 r2: reg) :=
  if Float32.eq_dec n (Float32.of_int (Int.repr 2))
  then (Oaddfs, r :: r :: nil)
  else (Omulfs, r1 :: r2 :: nil).

Definition make_cast8signed (r: reg) (a: aval) :=
  if vincl a (Sgn 8) then (Omove, r :: nil) else (Ocast8signed, r :: nil).
Definition make_cast8unsigned (r: reg) (a: aval) :=
  if vincl a (Uns 8) then (Omove, r :: nil) else (Ocast8unsigned, r :: nil).
Definition make_cast16signed (r: reg) (a: aval) :=
  if vincl a (Sgn 16) then (Omove, r :: nil) else (Ocast16signed, r :: nil).
Definition make_cast16unsigned (r: reg) (a: aval) :=
  if vincl a (Uns 16) then (Omove, r :: nil) else (Ocast16unsigned, r :: nil).

(** Original definition:
<<
Nondetfunction op_strength_reduction
              (op: operation) (args: list reg) (vl: list aval) :=
  match op, args, vl with
  | Ocast8signed, r1 :: nil, v1 :: nil => make_cast8signed r1 v1
  | Ocast8unsigned, r1 :: nil, v1 :: nil => make_cast8unsigned r1 v1
  | Ocast16signed, r1 :: nil, v1 :: nil => make_cast16signed r1 v1
  | Ocast16unsigned, r1 :: nil, v1 :: nil => make_cast16unsigned r1 v1
  | Osub, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_addimm (Int.neg n2) r1
  | Omul, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_mulimm n1 r2
  | Omul, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_mulimm n2 r1
  | Odiv, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_divimm n2 r1 r2
  | Odivu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_divuimm n2 r1 r2
  | Omodu, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_moduimm n2 r1 r2
  | Oand, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_andimm n1 r2 v2
  | Oand, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_andimm n2 r1 v1
  | Oandimm n, r1 :: nil, v1 :: nil => make_andimm n r1 v1
  | Oor, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_orimm n1 r2
  | Oor, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_orimm n2 r1
  | Oxor, r1 :: r2 :: nil, I n1 :: v2 :: nil => make_xorimm n1 r2
  | Oxor, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_xorimm n2 r1
  | Oshl, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shlimm n2 r1 r2
  | Oshr, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shrimm n2 r1 r2
  | Oshru, r1 :: r2 :: nil, v1 :: I n2 :: nil => make_shruimm n2 r1 r2
  | Olea addr, args, vl =>
      let (addr', args') := addr_strength_reduction addr args vl in
      (Olea addr', args')
  | Ocmp c, args, vl => make_cmp c args vl
  | Omulf, r1 :: r2 :: nil, v1 :: F n2 :: nil => make_mulfimm n2 r1 r1 r2
  | Omulf, r1 :: r2 :: nil, F n1 :: v2 :: nil => make_mulfimm n1 r2 r1 r2
  | Omulfs, r1 :: r2 :: nil, v1 :: FS n2 :: nil => make_mulfsimm n2 r1 r1 r2
  | Omulfs, r1 :: r2 :: nil, FS n1 :: v2 :: nil => make_mulfsimm n1 r2 r1 r2
  | _, _, _ => (op, args)
  end.
>>
*)

Inductive op_strength_reduction_cases: forall (op: operation) (args: list reg) (vl: list aval), Type :=
  | op_strength_reduction_case1: forall r1 v1, op_strength_reduction_cases (Ocast8signed) (r1 :: nil) (v1 :: nil)
  | op_strength_reduction_case2: forall r1 v1, op_strength_reduction_cases (Ocast8unsigned) (r1 :: nil) (v1 :: nil)
  | op_strength_reduction_case3: forall r1 v1, op_strength_reduction_cases (Ocast16signed) (r1 :: nil) (v1 :: nil)
  | op_strength_reduction_case4: forall r1 v1, op_strength_reduction_cases (Ocast16unsigned) (r1 :: nil) (v1 :: nil)
  | op_strength_reduction_case5: forall r1 r2 v1 n2, op_strength_reduction_cases (Osub) (r1 :: r2 :: nil) (v1 :: I n2 :: nil)
  | op_strength_reduction_case6: forall r1 r2 n1 v2, op_strength_reduction_cases (Omul) (r1 :: r2 :: nil) (I n1 :: v2 :: nil)
  | op_strength_reduction_case7: forall r1 r2 v1 n2, op_strength_reduction_cases (Omul) (r1 :: r2 :: nil) (v1 :: I n2 :: nil)
  | op_strength_reduction_case8: forall r1 r2 v1 n2, op_strength_reduction_cases (Odiv) (r1 :: r2 :: nil) (v1 :: I n2 :: nil)
  | op_strength_reduction_case9: forall r1 r2 v1 n2, op_strength_reduction_cases (Odivu) (r1 :: r2 :: nil) (v1 :: I n2 :: nil)
  | op_strength_reduction_case10: forall r1 r2 v1 n2, op_strength_reduction_cases (Omodu) (r1 :: r2 :: nil) (v1 :: I n2 :: nil)
  | op_strength_reduction_case11: forall r1 r2 n1 v2, op_strength_reduction_cases (Oand) (r1 :: r2 :: nil) (I n1 :: v2 :: nil)
  | op_strength_reduction_case12: forall r1 r2 v1 n2, op_strength_reduction_cases (Oand) (r1 :: r2 :: nil) (v1 :: I n2 :: nil)
  | op_strength_reduction_case13: forall n r1 v1, op_strength_reduction_cases (Oandimm n) (r1 :: nil) (v1 :: nil)
  | op_strength_reduction_case14: forall r1 r2 n1 v2, op_strength_reduction_cases (Oor) (r1 :: r2 :: nil) (I n1 :: v2 :: nil)
  | op_strength_reduction_case15: forall r1 r2 v1 n2, op_strength_reduction_cases (Oor) (r1 :: r2 :: nil) (v1 :: I n2 :: nil)
  | op_strength_reduction_case16: forall r1 r2 n1 v2, op_strength_reduction_cases (Oxor) (r1 :: r2 :: nil) (I n1 :: v2 :: nil)
  | op_strength_reduction_case17: forall r1 r2 v1 n2, op_strength_reduction_cases (Oxor) (r1 :: r2 :: nil) (v1 :: I n2 :: nil)
  | op_strength_reduction_case18: forall r1 r2 v1 n2, op_strength_reduction_cases (Oshl) (r1 :: r2 :: nil) (v1 :: I n2 :: nil)
  | op_strength_reduction_case19: forall r1 r2 v1 n2, op_strength_reduction_cases (Oshr) (r1 :: r2 :: nil) (v1 :: I n2 :: nil)
  | op_strength_reduction_case20: forall r1 r2 v1 n2, op_strength_reduction_cases (Oshru) (r1 :: r2 :: nil) (v1 :: I n2 :: nil)
  | op_strength_reduction_case21: forall addr args vl, op_strength_reduction_cases (Olea addr) (args) (vl)
  | op_strength_reduction_case22: forall c args vl, op_strength_reduction_cases (Ocmp c) (args) (vl)
  | op_strength_reduction_case23: forall r1 r2 v1 n2, op_strength_reduction_cases (Omulf) (r1 :: r2 :: nil) (v1 :: F n2 :: nil)
  | op_strength_reduction_case24: forall r1 r2 n1 v2, op_strength_reduction_cases (Omulf) (r1 :: r2 :: nil) (F n1 :: v2 :: nil)
  | op_strength_reduction_case25: forall r1 r2 v1 n2, op_strength_reduction_cases (Omulfs) (r1 :: r2 :: nil) (v1 :: FS n2 :: nil)
  | op_strength_reduction_case26: forall r1 r2 n1 v2, op_strength_reduction_cases (Omulfs) (r1 :: r2 :: nil) (FS n1 :: v2 :: nil)
  | op_strength_reduction_default: forall (op: operation) (args: list reg) (vl: list aval), op_strength_reduction_cases op args vl.

Definition op_strength_reduction_match (op: operation) (args: list reg) (vl: list aval) :=
  match op as zz1, args as zz2, vl as zz3 return op_strength_reduction_cases zz1 zz2 zz3 with
  | Ocast8signed, r1 :: nil, v1 :: nil => op_strength_reduction_case1 r1 v1
  | Ocast8unsigned, r1 :: nil, v1 :: nil => op_strength_reduction_case2 r1 v1
  | Ocast16signed, r1 :: nil, v1 :: nil => op_strength_reduction_case3 r1 v1
  | Ocast16unsigned, r1 :: nil, v1 :: nil => op_strength_reduction_case4 r1 v1
  | Osub, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case5 r1 r2 v1 n2
  | Omul, r1 :: r2 :: nil, I n1 :: v2 :: nil => op_strength_reduction_case6 r1 r2 n1 v2
  | Omul, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case7 r1 r2 v1 n2
  | Odiv, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case8 r1 r2 v1 n2
  | Odivu, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case9 r1 r2 v1 n2
  | Omodu, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case10 r1 r2 v1 n2
  | Oand, r1 :: r2 :: nil, I n1 :: v2 :: nil => op_strength_reduction_case11 r1 r2 n1 v2
  | Oand, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case12 r1 r2 v1 n2
  | Oandimm n, r1 :: nil, v1 :: nil => op_strength_reduction_case13 n r1 v1
  | Oor, r1 :: r2 :: nil, I n1 :: v2 :: nil => op_strength_reduction_case14 r1 r2 n1 v2
  | Oor, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case15 r1 r2 v1 n2
  | Oxor, r1 :: r2 :: nil, I n1 :: v2 :: nil => op_strength_reduction_case16 r1 r2 n1 v2
  | Oxor, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case17 r1 r2 v1 n2
  | Oshl, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case18 r1 r2 v1 n2
  | Oshr, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case19 r1 r2 v1 n2
  | Oshru, r1 :: r2 :: nil, v1 :: I n2 :: nil => op_strength_reduction_case20 r1 r2 v1 n2
  | Olea addr, args, vl => op_strength_reduction_case21 addr args vl
  | Ocmp c, args, vl => op_strength_reduction_case22 c args vl
  | Omulf, r1 :: r2 :: nil, v1 :: F n2 :: nil => op_strength_reduction_case23 r1 r2 v1 n2
  | Omulf, r1 :: r2 :: nil, F n1 :: v2 :: nil => op_strength_reduction_case24 r1 r2 n1 v2
  | Omulfs, r1 :: r2 :: nil, v1 :: FS n2 :: nil => op_strength_reduction_case25 r1 r2 v1 n2
  | Omulfs, r1 :: r2 :: nil, FS n1 :: v2 :: nil => op_strength_reduction_case26 r1 r2 n1 v2
  | op, args, vl => op_strength_reduction_default op args vl
  end.

Definition op_strength_reduction (op: operation) (args: list reg) (vl: list aval) :=
  match op_strength_reduction_match op args vl with
  | op_strength_reduction_case1 r1 v1 => (* Ocast8signed, r1 :: nil, v1 :: nil *)
      make_cast8signed r1 v1
  | op_strength_reduction_case2 r1 v1 => (* Ocast8unsigned, r1 :: nil, v1 :: nil *)
      make_cast8unsigned r1 v1
  | op_strength_reduction_case3 r1 v1 => (* Ocast16signed, r1 :: nil, v1 :: nil *)
      make_cast16signed r1 v1
  | op_strength_reduction_case4 r1 v1 => (* Ocast16unsigned, r1 :: nil, v1 :: nil *)
      make_cast16unsigned r1 v1
  | op_strength_reduction_case5 r1 r2 v1 n2 => (* Osub, r1 :: r2 :: nil, v1 :: I n2 :: nil *)
      make_addimm (Int.neg n2) r1
  | op_strength_reduction_case6 r1 r2 n1 v2 => (* Omul, r1 :: r2 :: nil, I n1 :: v2 :: nil *)
      make_mulimm n1 r2
  | op_strength_reduction_case7 r1 r2 v1 n2 => (* Omul, r1 :: r2 :: nil, v1 :: I n2 :: nil *)
      make_mulimm n2 r1
  | op_strength_reduction_case8 r1 r2 v1 n2 => (* Odiv, r1 :: r2 :: nil, v1 :: I n2 :: nil *)
      make_divimm n2 r1 r2
  | op_strength_reduction_case9 r1 r2 v1 n2 => (* Odivu, r1 :: r2 :: nil, v1 :: I n2 :: nil *)
      make_divuimm n2 r1 r2
  | op_strength_reduction_case10 r1 r2 v1 n2 => (* Omodu, r1 :: r2 :: nil, v1 :: I n2 :: nil *)
      make_moduimm n2 r1 r2
  | op_strength_reduction_case11 r1 r2 n1 v2 => (* Oand, r1 :: r2 :: nil, I n1 :: v2 :: nil *)
      make_andimm n1 r2 v2
  | op_strength_reduction_case12 r1 r2 v1 n2 => (* Oand, r1 :: r2 :: nil, v1 :: I n2 :: nil *)
      make_andimm n2 r1 v1
  | op_strength_reduction_case13 n r1 v1 => (* Oandimm n, r1 :: nil, v1 :: nil *)
      make_andimm n r1 v1
  | op_strength_reduction_case14 r1 r2 n1 v2 => (* Oor, r1 :: r2 :: nil, I n1 :: v2 :: nil *)
      make_orimm n1 r2
  | op_strength_reduction_case15 r1 r2 v1 n2 => (* Oor, r1 :: r2 :: nil, v1 :: I n2 :: nil *)
      make_orimm n2 r1
  | op_strength_reduction_case16 r1 r2 n1 v2 => (* Oxor, r1 :: r2 :: nil, I n1 :: v2 :: nil *)
      make_xorimm n1 r2
  | op_strength_reduction_case17 r1 r2 v1 n2 => (* Oxor, r1 :: r2 :: nil, v1 :: I n2 :: nil *)
      make_xorimm n2 r1
  | op_strength_reduction_case18 r1 r2 v1 n2 => (* Oshl, r1 :: r2 :: nil, v1 :: I n2 :: nil *)
      make_shlimm n2 r1 r2
  | op_strength_reduction_case19 r1 r2 v1 n2 => (* Oshr, r1 :: r2 :: nil, v1 :: I n2 :: nil *)
      make_shrimm n2 r1 r2
  | op_strength_reduction_case20 r1 r2 v1 n2 => (* Oshru, r1 :: r2 :: nil, v1 :: I n2 :: nil *)
      make_shruimm n2 r1 r2
  | op_strength_reduction_case21 addr args vl => (* Olea addr, args, vl *)
      let (addr', args') := addr_strength_reduction addr args vl in (Olea addr', args')
  | op_strength_reduction_case22 c args vl => (* Ocmp c, args, vl *)
      make_cmp c args vl
  | op_strength_reduction_case23 r1 r2 v1 n2 => (* Omulf, r1 :: r2 :: nil, v1 :: F n2 :: nil *)
      make_mulfimm n2 r1 r1 r2
  | op_strength_reduction_case24 r1 r2 n1 v2 => (* Omulf, r1 :: r2 :: nil, F n1 :: v2 :: nil *)
      make_mulfimm n1 r2 r1 r2
  | op_strength_reduction_case25 r1 r2 v1 n2 => (* Omulfs, r1 :: r2 :: nil, v1 :: FS n2 :: nil *)
      make_mulfsimm n2 r1 r1 r2
  | op_strength_reduction_case26 r1 r2 n1 v2 => (* Omulfs, r1 :: r2 :: nil, FS n1 :: v2 :: nil *)
      make_mulfsimm n1 r2 r1 r2
  | op_strength_reduction_default op args vl =>
      (op, args)
  end.


(*===========================================================================
  Macros for defining and calling functions using x86 calling conventions
  used by C compilers.
  ===========================================================================*)
Require Import ssreflect ssrbool ssrfun ssrnat eqtype seq fintype tuple.
Require Import procstate procstatemonad bitsrep bitsops bitsprops bitsopsprops.
Require Import SPred septac spec safe basic program macros call.
Require Import instr instrsyntax.
Require Import NaryFunctions.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Local Open Scope instr_scope.

(*---------------------------------------------------------------------------
    Calling-convention-independent definitions
  ---------------------------------------------------------------------------*)

(* A function signature is simply an arity and a bool
   denoting the presence or absence of a return value. In future we could
   extend this to deal with other types e.g. floats, 64-bit integers *)
(*=FunSig *)
Structure FunSig := mkFunSig { arity: nat; nonvoid: bool }.
(*=End *)

(* A function body can be defined independently of calling convention by
   parameterizing it on InstrSrc arguments. Result is assumed to be in EAX. *)
Definition programWithSig sig :=
  InstrSrc ^^ arity sig --> program.

(* Here is an example: \n.n+1 *)
Example incBody : programWithSig (mkFunSig 1 true) :=
  fun arg => makeMOV EAX arg;; INC EAX.

(*---------------------------------------------------------------------------
    Helpers for calling
  ---------------------------------------------------------------------------*)

(* Push n arguments on the stack *)
Fixpoint pushArgs n (p:program) : nfun Src n program :=
  if n is n.+1
  then fun arg => pushArgs n (PUSH arg;; p)
  else p.

Definition makeMOVsrc (r:Reg) (s: Src) : program :=
  match s with
  | SrcI c => MOV r, c
  | SrcM m => MOV r, m
  | SrcR r' => if r==r' then prog_skip else MOV r, r'
  end.

(* Put first argument in ECX, second in EDX, and the rest on the stack *)
Definition pushFastArgs n (p:program) : nfun Src n program :=
  match n with
  | 0 => p
  | 1 => fun arg => (makeMOVsrc ECX arg;; p)
  | n.+2 => fun arg1 arg2 => pushArgs n (makeMOVsrc ECX arg1;; makeMOVsrc EDX arg2;; p)
  end.

(*---------------------------------------------------------------------------
    We support three x86 calling conventions:
    * cdecl
      - arguments pushed right to left
      - result (if any) in EAX
      - EAX, ECX, EDX are caller-saved, rest callee-saved
      - caller cleans up stack (typically using ADD ESP, n)
    * stdcall
      - arguments pushed right to left
      - result (if any) in EAX
      - EAX, ECX, EDX are caller-saved, rest callee-saved
      - callee cleans up stack (typically using RET n)
    * fastcall
      - first argument passed in ECX, second in EDX, remainder pushed right to left
      - result (if any) in EAX
      - EAX, ECX, EDX are caller-saved, rest callee-saved
      - callee cleans up stack (typically using RET n)
  ---------------------------------------------------------------------------*)

(*=CallConv *)
Inductive CallConv := cdecl | stdcall | fastcall.
(*=End *)

(*---------------------------------------------------------------------------
    Generate calling sequence for cdecl, stdcall and fastcall conventions
  ---------------------------------------------------------------------------*)
Definition call_cdecl_with (n:nat) (f:JmpTgt) :=
  pushArgs n (CALL f;; ADD ESP, n*4).

Definition call_std_with (n:nat) (f: JmpTgt) :=
  pushArgs n (CALL f).

Definition call_fast_with (n:nat) (f: JmpTgt) :=
  pushFastArgs n (CALL f).

Definition call_with (cc: CallConv) :=
  match cc with
  | cdecl => call_cdecl_with
  | stdcall => call_std_with
  | fastcall => call_fast_with
  end.

(*---------------------------------------------------------------------------
    Helper for creating function prologues and epilogues
  ---------------------------------------------------------------------------*)
Fixpoint introParams n offset : InstrSrc ^^ n --> program -> program :=
  if n is n'.+1
  then fun p => introParams (offset + 4) (p [EBP + offset]%ms)
  else fun p => p.
Implicit Arguments introParams [].

(*---------------------------------------------------------------------------
    Create function definitions for cdecl, stdcall and fastcall conventions
  ---------------------------------------------------------------------------*)
Definition def_cdecl sig : programWithSig sig -> program :=
  match sig return programWithSig sig -> program with
  | mkFunSig n _ =>
    fun body =>
    PUSH EBP;; MOV EBP, ESP;;
    introParams n 8 body;; POP EBP;; RET 0
  end.
Implicit Arguments def_cdecl [].

Definition def_std sig : programWithSig sig -> program :=
  match sig return programWithSig sig -> program with
  | mkFunSig n _ =>
    fun body =>
    PUSH EBP;; MOV EBP, ESP;;
    introParams n 8 body;; POP EBP;; RET (n*4)

  end.
Implicit Arguments def_std [].

Definition def_fast sig :=
  match sig return programWithSig sig -> program with
  | mkFunSig 0 _ => fun body => body;; RET 0
  | mkFunSig 1 _ => fun body => body ECX;; RET 0
  | mkFunSig 2 _ => fun body => body ECX EDX;; RET 0
  | mkFunSig n.+2 _ =>
    fun body => PUSH EBP;; MOV EBP, ESP;; introParams n 8 (body ECX EDX);; POP EBP;; RET 0
  end.
Implicit Arguments def_fast [].

Definition def_fun cc :=
  match cc with
  | cdecl => def_cdecl
  | stdcall => def_std
  | fastcall => def_fast
  end.
Implicit Arguments def_fun [].

Definition callconv cc sig := (call_with cc sig.(arity), def_fun cc sig).

(* Examples: compare http://en.wikibooks.org/wiki/X86_Disassembly/Calling_Conventions *)

(*=addfun *)
Example addfun (cc: CallConv) :=
  let (call, def) := callconv cc (mkFunSig 3 true) in
  LOCAL AddThree; LOCAL ExampleUse;
    AddThree:;;
      def (fun a b c =>  MOV EAX, a;; ADD EAX, b;; ADD EAX, c);;
    ExampleUse:;;
      call AddThree 2 3 4.
(*=End *)

(*
Eval showinstr in linearize (addfun cdecl).
Eval showinstr in linearize (addfun stdcall).
Eval showinstr in linearize (addfun fastcall).
*)


From sflib Require Import sflib.
Require Import Coq.Classes.RelationClasses.
From Fairness Require Import Axioms NatStructs.
From Fairness Require Import LPCM World.
From Fairness Require Import Mod.
Require Import String Lia Program.

Set Implicit Arguments.

Section THREADS_RA_DEF.

  Inductive threadsRA_car : Type :=
  | global_local
      (ths_ctx ths_usr : TIdSet.t)
      (ths_ctx' ths_usr' : TIdSet.t)
  | local (ths_ctx' ths_usr' : TIdSet.t)
  | boom
  .

  Inductive threadsRA_wf : threadsRA_car -> Prop :=
  | wf_global_local ths_ctx ths_usr ths_ctx' ths_usr'
      (DISJOINT : NatMapP.Disjoint ths_ctx ths_usr)
      (LE_CTX : KeySetLE ths_ctx' ths_ctx)
      (LE_USR : KeySetLE ths_usr' ths_usr)
    : threadsRA_wf (global_local ths_ctx ths_usr ths_ctx' ths_usr')
  | wf_local ths_ctx' ths_usr'
    : threadsRA_wf (local ths_ctx' ths_usr')
  .

  Definition add (r1 r2 : threadsRA_car) : threadsRA_car :=
    match r1, r2 with
    | global_local ths_ctx ths_usr ths_ctx' ths_usr', global_local _ _ _ _      => boom
    | global_local ths_ctx ths_usr ths_ctx' ths_usr', local ths_ctx'' ths_usr'' =>
        if (disjoint ths_ctx' ths_ctx'' && disjoint ths_usr' ths_usr'')%bool
        then global_local ths_ctx ths_usr (NatMapP.update ths_ctx' ths_ctx'') (NatMapP.update ths_usr' ths_usr'')
        else boom
    | global_local ths_ctx ths_usr ths_ctx' ths_usr', boom                      => boom
    | local ths_ctx' ths_usr', global_local ths_ctx ths_usr ths_ctx'' ths_usr'' =>
        if (disjoint ths_ctx' ths_ctx'' && disjoint ths_usr' ths_usr'')%bool
        then global_local ths_ctx ths_usr (NatMapP.update ths_ctx' ths_ctx'') (NatMapP.update ths_usr' ths_usr'')
        else boom
    | local ths_ctx' ths_usr', local ths_ctx'' ths_usr''                        =>
        if (disjoint ths_ctx' ths_ctx'' && disjoint ths_usr' ths_usr'')%bool
        then local (NatMapP.update ths_ctx' ths_ctx'') (NatMapP.update ths_usr' ths_usr'')
        else boom
    | local ths_ctx' ths_usr', boom                                             => boom
    | boom, _                                                                   => boom
    end.
  Program Instance threadsRA: URA.t :=
    {|
      URA.car := threadsRA_car;
      URA.unit := local NatSet.empty NatSet.empty;
      URA._wf := threadsRA_wf;
      URA._add := add;
      URA.core := fun _ => local NatSet.empty NatSet.empty;
    |}.
  Next Obligation.
    destruct a, b; ss.
    all: rewrite disjoint_comm with (x := ths_ctx').
    all: rewrite disjoint_comm with (x := ths_usr').
    all: rewrite union_comm with (x := ths_ctx').
    all: rewrite union_comm with (x := ths_usr').
    all: ss.
  Qed.
  Next Obligation.
    destruct a, b, c; try (ss; des_ifs; fail).
    all: unfold add; des_ifs; try (rewrite 2 union_assoc; ss); solve_disjoint!.
  Qed.
  Next Obligation.
    unseal "ra". destruct a; try easy.
    all:
      unfold add; des_ifs; try (do 2 rewrite union_comm, union_empty; ss);
      unfold NatSet.empty in Heq; solve_disjoint!.
  Qed.
  Next Obligation.
    unseal "ra". econs.
  Qed.
  Next Obligation.
    unseal "ra". destruct a, b; inv H; unfold add; des_ifs; econs; ss.
    - assert (KeySetLE ths_ctx' (NatMapP.update ths_ctx' ths_ctx'0)) by eapply union_KeySetLE.
      unfold KeySetLE in *. auto.
    - assert (KeySetLE ths_usr' (NatMapP.update ths_usr' ths_usr'0)) by eapply union_KeySetLE.
      unfold KeySetLE in *. auto.
  Qed.
  Next Obligation.
    unseal "ra". destruct a; ss.
    - f_equal; rewrite union_comm; ss.
    - f_equal; rewrite union_comm; ss.
  Qed.
  Next Obligation.
    exists (local NatSet.empty NatSet.empty). unseal "ra". ss.
  Qed.

End THREADS_RA_DEF.

Section THREADS_RA.

  Definition global_th (ths_ctx ths_usr : TIdSet.t) : threadsRA := global_local ths_ctx ths_usr TIdSet.empty TIdSet.empty.

  Definition local_th_context (tid: thread_id): threadsRA := local (TIdSet.add tid TIdSet.empty) TIdSet.empty.

  Definition local_th_user (tid: thread_id): threadsRA := local TIdSet.empty (TIdSet.add tid TIdSet.empty).

  Lemma local_th_context_in_context ths_ctx ths_usr tid r_ctx
        (VALID: URA.wf (global_th ths_ctx ths_usr ⋅ local_th_context tid ⋅ r_ctx))
    :
    TIdSet.In tid ths_ctx.
  Proof.
    eapply URA.wf_mon in VALID. unfold URA.add, URA.wf in VALID. unseal "ra".
    unfold global_th, local_th_context in *. ss.
    inv VALID. eapply LE_CTX. (do 3 econs); ss.
  Qed.

  Lemma local_th_user_in_user ths_ctx ths_usr tid r_ctx
        (VALID: URA.wf (global_th ths_ctx ths_usr ⋅ local_th_user tid ⋅ r_ctx))
    :
    TIdSet.In tid ths_usr.
    eapply URA.wf_mon in VALID. unfold URA.add, URA.wf in VALID. unseal "ra".
    inv VALID. eapply LE_USR. (do 3 econs); ss.
  Qed.

  Lemma initial_global_th_valid
    :
    URA.wf (global_th TIdSet.empty TIdSet.empty).
  Proof.
    unfold URA.wf. unseal "ra". econs; eauto using Disjoint_empty, KeySetLE_empty.
  Qed.

  Lemma global_th_alloc_context ths_ctx0 ths_usr r_ctx
        tid ths_ctx1
        (VALID: URA.wf (global_th ths_ctx0 ths_usr ⋅ r_ctx))
        (ADD: TIdSet.add_new tid ths_ctx0 ths_ctx1)
        (NONE: ~ TIdSet.In tid ths_usr)
    :
    URA.wf (global_th ths_ctx1 ths_usr ⋅ local_th_context tid ⋅ r_ctx).
  Proof.
    unfold URA.wf, URA.add in *. unseal "ra". destruct r_ctx; ss.
    rewrite ! union_empty in *. unfold union, NatMap.fold; ss. inv VALID. inv ADD. des_ifs.
    - econs; ss.
      + ii. des. eapply NatMapP.F.add_in_iff in H. des.
        * subst. eauto.
        * eapply DISJOINT. eauto.
      + ii. eapply NatMapP.F.add_in_iff. rewrite union_comm in H. eapply NatMapP.F.add_in_iff in H. des; eauto.
    - eapply NatMapP.F.not_find_in_iff in NEW. solve_andb.
      + eapply disjoint_false_iff' in H. des.
        eapply NatMapP.F.add_in_iff in H. rewrite NatMapP.F.empty_in_iff in H.
        des; ss; subst. firstorder.
      + unfold TIdSet.empty in H. solve_disjoint.
  Qed.

  Lemma global_th_alloc_user ths_ctx ths_usr0 r_ctx
        tid ths_usr1
        (VALID: URA.wf (global_th ths_ctx ths_usr0 ⋅ r_ctx))
        (ADD: TIdSet.add_new tid ths_usr0 ths_usr1)
        (NONE: ~ TIdSet.In tid ths_ctx)
    :
    URA.wf (global_th ths_ctx ths_usr1 ⋅ local_th_user tid ⋅ r_ctx).
  Proof.
    unfold URA.wf, URA.add in *. unseal "ra". destruct r_ctx; ss.
    rewrite ! union_empty in *. unfold union, NatMap.fold; ss. inv VALID. inv ADD. des_ifs.
    - econs; ss.
      + ii. des. eapply NatMapP.F.add_in_iff in H0. des.
        * subst. eauto.
        * eapply DISJOINT. eauto.
      + ii. eapply NatMapP.F.add_in_iff. rewrite union_comm in H. eapply NatMapP.F.add_in_iff in H. des; eauto.
    - eapply NatMapP.F.not_find_in_iff in NEW.
      eapply disjoint_false_iff' in Heq. des.
      eapply NatMapP.F.add_in_iff in Heq. rewrite NatMapP.F.empty_in_iff in Heq.
      des; ss; subst. firstorder.
  Qed.

  Lemma global_th_dealloc_context ths_ctx0 ths_usr r_ctx
        tid ths_ctx1
        (VALID: URA.wf (global_th ths_ctx0 ths_usr ⋅ local_th_context tid ⋅ r_ctx))
        (REMOVE: TIdSet.remove tid ths_ctx0 = ths_ctx1)
    :
    URA.wf (global_th ths_ctx1 ths_usr ⋅ URA.unit ⋅ r_ctx).

  Proof.
    rewrite URA.unit_id. unfold URA.wf, URA.add in *. unseal "ra". destruct r_ctx; ss.
    rewrite ! union_empty in *. unfold union, NatMap.fold in VALID; ss. des_ifs; inv VALID.
    econs; ss.
    - ii. des. eapply NatMapP.F.remove_in_iff in H; des. firstorder.
    - unfold TIdSet.empty, TIdSet.add in *. solve_andb; solve_disjoint.
      ii. eapply NatMapP.F.remove_in_iff. assert (tid = k \/ tid <> k) by lia; des.
      + subst. tauto.
      + unfold KeySetLE in LE_CTX. rewrite union_comm in LE_CTX. setoid_rewrite NatMapP.F.add_in_iff in LE_CTX. eauto.
  Qed.

  Lemma global_th_dealloc_user ths_ctx ths_usr0 r_ctx
        tid ths_usr1
        (VALID: URA.wf (global_th ths_ctx ths_usr0 ⋅ local_th_user tid ⋅ r_ctx))
        (REMOVE: TIdSet.remove tid ths_usr0 = ths_usr1)
    :
    URA.wf (global_th ths_ctx ths_usr1 ⋅ URA.unit ⋅ r_ctx).
  Proof.
    rewrite URA.unit_id. unfold URA.wf, URA.add in *. unseal "ra". destruct r_ctx; ss.
    rewrite ! union_empty in *. unfold union, NatMap.fold in VALID; ss. des_ifs; inv VALID.
    unfold TIdSet.empty, TIdSet.add in *. solve_disjoint.
    unfold KeySetLE in LE_USR. rewrite union_comm in LE_USR. setoid_rewrite NatMapP.F.add_in_iff in LE_USR.
    econs; ss.
    - ii. des. eapply NatMapP.F.remove_in_iff in H1. firstorder.
    - ii. rewrite NatMapP.F.remove_in_iff. split.
      + ii. subst. tauto.
      + firstorder.
  Qed.

End THREADS_RA.