Require Import floyd.proofauto.
Import ListNotations.
Local Open Scope logic.

Require Import hmacdrbg.hmac_drbg.
Require Import hmacdrbg.HMAC256_DRBG_functional_prog.
Require Import hmacdrbg.DRBG_functions.
Require Import hmacdrbg.HMAC_DRBG_algorithms.
Require Import hmacdrbg.entropy.
Require Import sha.protocol_spec_hmac.
Require Import sha.general_lemmas.
Require Import sha.HMAC256_functional_prog.

(* mocked_md *)
Require Import sha.spec_sha.
Require Import floyd.library.

Require Import hmacdrbg.hmac_drbg_compspecs.

Declare Module UNDER_SPEC : HMAC_ABSTRACT_SPEC.
Definition mdstate: Type := (val * (val * val))%type.

Definition md_info_state: Type := val%type.

Definition t_struct_md_ctx_st := Tstruct _mbedtls_md_context_t noattr.

Definition md_relate (h: UNDER_SPEC.HABS) (r:mdstate) :=
  UNDER_SPEC.REP h (snd (snd r)).

Definition md_full (key: list Z) (r:mdstate) :=
  UNDER_SPEC.FULL key (snd (snd r)).

Definition md_empty (r:mdstate) :=
  UNDER_SPEC.EMPTY (snd (snd r)).

Lemma FULL_isptr k q:
  UNDER_SPEC.FULL k q = !!isptr q && UNDER_SPEC.FULL k q.
Proof.
apply pred_ext.
+ apply andp_right; trivial. apply UNDER_SPEC.FULL_isptr.
+ entailer!.
Qed.

Lemma EMPTY_isptr q:
  UNDER_SPEC.EMPTY q = !!isptr q && UNDER_SPEC.EMPTY q.
Proof.
apply pred_ext.
+ apply andp_right; trivial. apply UNDER_SPEC.EMPTY_isptr.
+ entailer!.
Qed.

Lemma REP_isptr abs q:
  UNDER_SPEC.REP abs q = !!isptr q && UNDER_SPEC.REP abs q.
Proof.
destruct abs.
apply pred_ext.
+ apply andp_right; trivial. apply UNDER_SPEC.REP_isptr.
+ entailer!.
Qed.

Definition md_free_spec :=
 DECLARE _mbedtls_md_free
  WITH ctx:val, r:mdstate
  PRE  [ _ctx OF tptr (Tstruct _mbedtls_md_context_t noattr) ]
       PROP()
       LOCAL(temp _ctx ctx)
       SEP (data_at Tsh t_struct_md_ctx_st r ctx;
            UNDER_SPEC.EMPTY (snd (snd r));
            malloc_token Tsh (sizeof (Tstruct _hmac_ctx_st noattr)) (snd (snd r)))
  POST [ tvoid ]
    SEP (data_at Tsh t_struct_md_ctx_st r ctx).

Definition mbedtls_zeroize_spec :=
  DECLARE _mbedtls_zeroize
   WITH n: Z, v:val
    PRE [_v OF tptr tvoid, _n OF tuint ]
       PROP (0<=n<= Int.max_unsigned)
       LOCAL (temp _n (Vint (Int.repr n)); temp _v v)
       SEP (data_at_ Tsh (tarray tuchar n ) v)
    POST [ tvoid ]
       SEP (data_block Tsh (list_repeat (Z.to_nat n) 0) v).

Definition drbg_memcpy_spec :=
  DECLARE _memcpy
   WITH sh : share*share, p: val, q: val, n: Z, contents: list int
   PRE [ 1%positive OF tptr tvoid, 2%positive OF tptr tvoid, 3%positive OF tuint ]
       PROP (readable_share (fst sh); writable_share (snd sh); 0 <= n <= Int.max_unsigned)
       LOCAL (temp 1%positive p; temp 2%positive q; temp 3%positive (Vint (Int.repr n)))
       SEP (data_at (fst sh) (tarray tuchar n) (map Vint contents) q;
              memory_block (snd sh) n p)
    POST [ tptr tvoid ]
       PROP() LOCAL(temp ret_temp p)
       SEP(data_at (fst sh) (tarray tuchar n) (map Vint contents) q;
             data_at (snd sh) (tarray tuchar n) (map Vint contents) p).

Definition drbg_memset_spec :=
  DECLARE _memset
   WITH sh : share, p: val, n: Z, c: int
   PRE [ 1%positive OF tptr tvoid, 2%positive OF tint, 3%positive OF tuint ]
       PROP (writable_share sh; 0 <= n <= Int.max_unsigned)
       LOCAL (temp 1%positive p; temp 2%positive (Vint c);
                   temp 3%positive (Vint (Int.repr n)))
       SEP (memory_block sh n p)
    POST [ tptr tvoid ]
       PROP() LOCAL(temp ret_temp p)
       SEP(data_at sh (tarray tuchar n) (list_repeat (Z.to_nat n) (Vint c)) p).
(*This results in using sha's compspecs
Definition drbg_memset_spec := (_memset, snd spec_sha.memset_spec).
Definition drbg_memcpy_spec := (_memcpy, snd spec_sha.memcpy_spec).
*)

Definition md_get_size_spec :=
  DECLARE _mbedtls_md_get_size
   WITH u:unit
   PRE [ _md_info OF tptr (Tstruct _mbedtls_md_info_t noattr)]
         PROP ()
         LOCAL ()
         SEP ()
  POST [ tuchar ]
     PROP ()
     LOCAL (temp ret_temp (Vint (Int.repr (32 (*Z.of_nat SHA256.DigestLength*)))))
     SEP ().

Definition md_reset_spec :=
  DECLARE _mbedtls_md_hmac_reset
   WITH c : val, r: mdstate, key:list Z, kv:val
   PRE [ _ctx OF tptr (Tstruct _mbedtls_md_context_t noattr)]
         PROP ()
         LOCAL (temp _ctx c; gvar sha._K256 kv)
         SEP (UNDER_SPEC.FULL key (snd (snd r));
              data_at Tsh (Tstruct _mbedtls_md_context_t noattr) r c; K_vector kv)
  POST [ tint ]
     PROP ()
     LOCAL (temp ret_temp (Vint (Int.zero)))
     SEP (md_relate (UNDER_SPEC.hABS key nil) r;
          data_at Tsh (Tstruct _mbedtls_md_context_t noattr) r c;
          K_vector kv).

Definition md_starts_spec :=
  DECLARE _mbedtls_md_hmac_starts
   WITH c : val, r: mdstate, l:Z, key:list Z, kv:val, b:block, i:Int.int
   PRE [ _ctx OF tptr t_struct_md_ctx_st,
         _key OF tptr tuchar,
         _keylen OF tuint ]
         PROP (sha.spec_hmac.has_lengthK l key; Forall isbyteZ key)
         LOCAL (temp _ctx c; temp _key (Vptr b i); temp _keylen (Vint (Int.repr l));
                gvar sha._K256 kv)
         SEP (UNDER_SPEC.EMPTY (snd (snd r));
              data_at Tsh t_struct_md_ctx_st r c;
              data_at Tsh (tarray tuchar (Zlength key)) (map Vint (map Int.repr key)) (Vptr b i); K_vector kv)
  POST [ tint ]
     PROP (Forall isbyteZ key)
     LOCAL (temp ret_temp (Vint (Int.zero)))
     SEP (md_relate (UNDER_SPEC.hABS key nil) r;
          data_at Tsh t_struct_md_ctx_st r c;
          data_at Tsh (tarray tuchar (Zlength key)) (map Vint (map Int.repr key)) (Vptr b i);
          K_vector kv).

Definition md_update_spec :=
  DECLARE _mbedtls_md_hmac_update
   WITH key: list Z, c : val, r:mdstate, d:val, data:list Z, data1:list Z, kv:val
   PRE [ _ctx OF tptr t_struct_md_ctx_st,
         _input OF tptr tuchar,
         _ilen OF tuint]
         PROP (0 <= Zlength data1 <= Int.max_unsigned;
               Zlength data1 + Zlength data + 64 < two_power_pos 61;
               Forall isbyteZ data1)
         LOCAL (temp _ctx c; temp _input d; temp  _ilen (Vint (Int.repr (Zlength data1)));
                gvar sha._K256 kv)
         SEP(md_relate (UNDER_SPEC.hABS key data) r;
             data_at Tsh t_struct_md_ctx_st r c;
             data_at Tsh (tarray tuchar (Zlength data1)) (map Vint (map Int.repr data1)) d; K_vector kv)
  POST [ tint ]
          PROP (Forall isbyteZ data1)
          LOCAL (temp ret_temp (Vint (Int.zero)))
          SEP(md_relate (UNDER_SPEC.hABS key (data ++ data1)) r;
              data_at Tsh t_struct_md_ctx_st r c;
              data_at Tsh (tarray tuchar (Zlength data1)) (map Vint (map Int.repr data1)) d; K_vector kv).

Definition md_final_spec :=
  DECLARE _mbedtls_md_hmac_finish
   WITH data:list Z, key:list Z, c : val, r:mdstate, md:val, shmd: share, kv:val
   PRE [ _ctx OF tptr t_struct_md_ctx_st,
         _output OF tptr tuchar ]
       PROP (writable_share shmd)
       LOCAL (temp _output md; temp _ctx c;
              gvar sha._K256 kv)
       SEP((md_relate (UNDER_SPEC.hABS key data) r);
           (data_at Tsh t_struct_md_ctx_st r c);
           (K_vector kv);
           (memory_block shmd 32 md))
  POST [ tint ]
          PROP (Forall isbyteZ (HMAC256 data key))
          LOCAL (temp ret_temp (Vint (Int.zero)))
          SEP(K_vector kv;
              UNDER_SPEC.FULL key (snd (snd r));
              data_at Tsh t_struct_md_ctx_st r c;
              data_at shmd (tarray tuchar (Zlength (HMAC256 data key))) (map Vint (map Int.repr (HMAC256 data key))) md).

Definition md_setup_spec :=
  DECLARE _mbedtls_md_setup
   WITH md_ctx : mdstate, c:val, h:val, info:val
   PRE [ _ctx OF tptr (Tstruct _mbedtls_md_context_t noattr),
         _md_info OF tptr (Tstruct _mbedtls_md_info_t noattr),
         _hmac OF tint]
       PROP ()
       LOCAL (temp _md_info info; temp _ctx c; temp _hmac h)
       SEP(data_at Tsh (Tstruct _mbedtls_md_context_t noattr) md_ctx c)
  POST [ tint ] EX r:_,
          PROP (r=0 \/ r=-20864)
          LOCAL (temp ret_temp (Vint (Int.repr r)))
          SEP(
              if zeq r 0
              then (EX p:_, !!malloc_compatible (sizeof (Tstruct _hmac_ctx_st noattr)) p &&
                              memory_block Tsh (sizeof (Tstruct _hmac_ctx_st noattr)) p *
                              malloc_token Tsh (sizeof (Tstruct _hmac_ctx_st noattr)) p *
                              data_at Tsh (Tstruct _mbedtls_md_context_t noattr) (info, (fst(snd md_ctx), p)) c)
              else data_at Tsh (Tstruct _mbedtls_md_context_t noattr) md_ctx c).
(* end mocked_md *)

Inductive hmac256drbgabs :=
  HMAC256DRBGabs: forall (key: list Z) (V: list Z) (reseed_counter entropy_len: Z) (prediction_resistance: bool) (reseed_interval: Z), hmac256drbgabs.

Definition hmac256drbgstate: Type := (mdstate * (list val * (val * (val * (val * val)))))%type.

Definition hmac256drbg_relate (a: hmac256drbgabs) (r: hmac256drbgstate) : mpred :=
  match a with HMAC256DRBGabs key V reseed_counter entropy_len prediction_resistance reseed_interval =>
               match r with (md_ctx', (V', (reseed_counter', (entropy_len', (prediction_resistance', reseed_interval'))))) =>
                            md_full key md_ctx'
                                      && !! (
                                        map Vint (map Int.repr V) = V'
                                        /\ Zlength V = 32 /\ Forall isbyteZ V
                                        /\ Vint (Int.repr reseed_counter) = reseed_counter'
                                        /\ Vint (Int.repr entropy_len) = entropy_len'
                                        /\ Vint (Int.repr reseed_interval) = reseed_interval'
                                        /\ Val.of_bool prediction_resistance = prediction_resistance'
                                      )
               end
  end.

Definition hmac256drbgstate_md_FULL key (r: hmac256drbgstate) : mpred :=
  md_full key (fst r).

Definition hmac256drbgabs_entropy_len (a: hmac256drbgabs): Z :=
  match a with HMAC256DRBGabs _ _ _ entropy_len _ _ => entropy_len end.

Definition hmac256drbgabs_value (a: hmac256drbgabs): list Z :=
  match a with HMAC256DRBGabs _ V _ _ _ _ => V end.

Definition hmac256drbgabs_key (a: hmac256drbgabs): list Z :=
  match a with HMAC256DRBGabs key _ _ _ _ _ => key end.

Definition hmac256drbgabs_prediction_resistance (a: hmac256drbgabs): bool :=
  match a with HMAC256DRBGabs _ _ _ _ pr _ => pr end.

Definition hmac256drbgabs_reseed_counter (a: hmac256drbgabs): Z :=
  match a with HMAC256DRBGabs _ _ reseed_counter _ _ _ => reseed_counter end.

Definition hmac256drbgabs_reseed_interval (a: hmac256drbgabs): Z :=
  match a with HMAC256DRBGabs _ _ _ _ _ reseed_interval => reseed_interval end.

Definition hmac256drbgabs_increment_reseed_counter (a: hmac256drbgabs): hmac256drbgabs :=
  match a with HMAC256DRBGabs key V reseed_counter entropy_len prediction_resistance reseed_interval => HMAC256DRBGabs key V (reseed_counter + 1) entropy_len prediction_resistance reseed_interval end.

Definition hmac256drbgabs_update_value (a: hmac256drbgabs) (new_value: list Z): hmac256drbgabs :=
  match a with HMAC256DRBGabs key _ reseed_counter entropy_len prediction_resistance reseed_interval => HMAC256DRBGabs key new_value reseed_counter entropy_len prediction_resistance reseed_interval end.

Definition hmac256drbgabs_update_key (a: hmac256drbgabs) (new_key: list Z): hmac256drbgabs :=
  match a with HMAC256DRBGabs _ V reseed_counter entropy_len prediction_resistance reseed_interval => HMAC256DRBGabs new_key V reseed_counter entropy_len prediction_resistance reseed_interval end.

Definition hmac256drbgabs_update_reseed_counter (a: hmac256drbgabs) (new_counter: Z): hmac256drbgabs :=
  match a with HMAC256DRBGabs key V _ entropy_len prediction_resistance reseed_interval => HMAC256DRBGabs key V new_counter entropy_len prediction_resistance reseed_interval end.

Definition hmac256drbgabs_metadata_same (a: hmac256drbgabs) (b: hmac256drbgabs): Prop :=
  match a with HMAC256DRBGabs _ _ reseed_counter entropy_len prediction_resistance reseed_interval =>
               match b with HMAC256DRBGabs _ _ reseed_counter' entropy_len' prediction_resistance' reseed_interval' =>
                            reseed_counter = reseed_counter'
                            /\ entropy_len = entropy_len'
                            /\ prediction_resistance = prediction_resistance'
                            /\ reseed_interval = reseed_interval'
               end
  end.

Definition hmac256drbgabs_of_state_handle (a: DRBG_state_handle) entropy_len reseed_interval: hmac256drbgabs :=
  match a with ((V, key, reseed_counter),_, prediction_resistance) =>
               HMAC256DRBGabs key V reseed_counter entropy_len prediction_resistance reseed_interval
  end.

Definition hmac256drbgabs_to_state_handle (a: hmac256drbgabs): DRBG_state_handle :=
  match a with HMAC256DRBGabs key V reseed_counter entropy_len prediction_resistance reseed_interval =>
               ((V, key, reseed_counter), 32(*256*) (* security strength, not used *), prediction_resistance)
  end.

Definition hmac256drbgstate_md_info_pointer (a: hmac256drbgstate): val := fst (fst a).

Definition t_struct_mbedtls_md_info := Tstruct _mbedtls_md_info_t noattr.

Definition t_struct_hmac256drbg_context_st := Tstruct _mbedtls_hmac_drbg_context noattr.

Definition hmac256drbgabs_to_state (a: hmac256drbgabs) (old: hmac256drbgstate):hmac256drbgstate :=
  match a with HMAC256DRBGabs key V reseed_counter entropy_len prediction_resistance reseed_interval =>
               match old with (md_ctx', _) =>
                            (md_ctx', (map Vint (map Int.repr V), (Vint (Int.repr reseed_counter), (Vint (Int.repr entropy_len), (Val.of_bool prediction_resistance, Vint (Int.repr reseed_interval))))))
               end
  end.

Definition hmac256drbgabs_common_mpreds (final_state_abs: hmac256drbgabs) (old_state: hmac256drbgstate) (ctx: val) (info_contents: reptype t_struct_mbedtls_md_info): mpred :=
                  let st := hmac256drbgabs_to_state final_state_abs old_state in
                  (data_at Tsh t_struct_hmac256drbg_context_st st ctx) *
                  (data_at Tsh t_struct_mbedtls_md_info info_contents (hmac256drbgstate_md_info_pointer st)) *
                  (hmac256drbg_relate final_state_abs st).

Definition hmac256drbgabs_hmac_drbg_update (a:hmac256drbgabs) (additional_data: list Z): hmac256drbgabs :=
  match a with HMAC256DRBGabs key V reseed_counter entropy_len prediction_resistance reseed_interval =>
               let (key', V') := HMAC256_DRBG_update additional_data key V in
               HMAC256DRBGabs key' V' reseed_counter entropy_len prediction_resistance reseed_interval
  end.

Definition da_emp sh t v p := !! (p = nullval) && emp ||
                              !!(sizeof t > 0) && data_at sh t v p. (*in particular: weak_valid_ptr p in RHS case*)

Definition contents_with_add additional add_len contents:list Z :=
  if (andb (negb (eq_dec additional nullval)) (negb (eq_dec add_len 0))) then contents else [].

Definition hmac_drbg_update_spec :=
  DECLARE _mbedtls_hmac_drbg_update
   WITH contents: list Z,
        additional: val, add_len: Z,
        ctx: val, initial_state: hmac256drbgstate,
        initial_state_abs: hmac256drbgabs,
        kv: val, info_contents: md_info_state
     PRE [ _ctx OF (tptr t_struct_hmac256drbg_context_st),
           _additional OF (tptr tuchar), _add_len OF tuint ]
       PROP (
         0 <= add_len <= Int.max_unsigned;
         Zlength (hmac256drbgabs_value initial_state_abs) = 32 (*Z.of_nat SHA256.DigestLength*);
         add_len = Zlength contents \/ add_len = 0;
         Forall isbyteZ (hmac256drbgabs_value initial_state_abs);
         Forall isbyteZ contents
       )
       LOCAL (temp _ctx ctx;
              temp _additional additional;
              temp _add_len (Vint (Int.repr add_len));
              gvar sha._K256 kv)
       SEP (
         da_emp Tsh (tarray tuchar (Zlength contents)) (map Vint (map Int.repr contents)) additional;
         data_at Tsh t_struct_hmac256drbg_context_st initial_state ctx;
         hmac256drbg_relate initial_state_abs initial_state;
         data_at Tsh t_struct_mbedtls_md_info
                  info_contents (hmac256drbgstate_md_info_pointer initial_state);
         K_vector kv)
    POST [ tvoid ]
       PROP (
         )
       LOCAL ()
       SEP (
         hmac256drbgabs_common_mpreds
            (hmac256drbgabs_hmac_drbg_update initial_state_abs
               (contents_with_add additional add_len contents))
            initial_state ctx info_contents;
         da_emp Tsh (tarray tuchar (Zlength contents)) (map Vint (map Int.repr contents)) additional;
         K_vector kv).

Definition mbedtls_HMAC256_DRBG_reseed_function (entropy_stream: ENTROPY.stream) (a:hmac256drbgabs)
           (additional_input: list Z): ENTROPY.result DRBG_state_handle :=
  match a with HMAC256DRBGabs key V reseed_counter entropy_len prediction_resistance reseed_interval =>
               let sec_strength:Z := 32 (*not used -- measured in bytes, since that's how the calculations in DRBG_instantiate_function work *) in
               let state_handle: DRBG_state_handle := ((V, key, reseed_counter), sec_strength, prediction_resistance) in
               let max_additional_input_length := 256
               in HMAC256_DRBG_reseed_function entropy_len entropy_len max_additional_input_length
                     entropy_stream state_handle prediction_resistance additional_input
  end.

Definition hmac256drbgabs_reseed (a: hmac256drbgabs) (s: ENTROPY.stream) (additional_data: list Z) : hmac256drbgabs :=
  match a with HMAC256DRBGabs key V reseed_counter entropy_len prediction_resistance reseed_interval =>
               match (mbedtls_HMAC256_DRBG_reseed_function s a additional_data) with
                 | ENTROPY.success ((V', key', reseed_counter'), _, pr') _ =>
                   HMAC256DRBGabs key' V' reseed_counter' entropy_len pr' reseed_interval
                 | ENTROPY.error _ _ => a
               end
  end.

Definition get_stream_result {X} (result: ENTROPY.result X): ENTROPY.stream :=
  match result with
    | ENTROPY.success _ s => s
    | ENTROPY.error _ s => s
  end.

Definition result_success {X} (result: ENTROPY.result X): Prop :=
  match result with
    | ENTROPY.success _ _ => True
    | ENTROPY.error _ _ => False
  end.

Parameter ENT_GenErr: Z.
Parameter ENT_GenErrAx: Vzero <> Vint (Int.repr ENT_GenErr)  /\ Int.repr ENT_GenErr <> Int.repr (-20864).

Definition return_value_relate_result {X} (result: ENTROPY.result X) (ret_value: val): Prop :=
  match result with
    | ENTROPY.error e _ => match e with
                             | ENTROPY.generic_error => ret_value = Vint (Int.repr ENT_GenErr) (*WAS: ret_value <> Vzero*)
                             | ENTROPY.catastrophic_error => ret_value = Vint (Int.repr (-9))
                           end
    | ENTROPY.success _ _ => ret_value = Vzero
  end.

Parameter Stream: ENTROPY.stream -> mpred.

Definition reseedPOST rv contents additional add_len s
          initial_state_abs ctx
          info_contents kv (initial_state: reptype t_struct_hmac256drbg_context_st):=
  if ((zlt 256 add_len) || (zlt 384 (hmac256drbgabs_entropy_len initial_state_abs + add_len)))%bool
  then (!!(rv = Vint (Int.neg (Int.repr 5))) &&
       (da_emp Tsh (tarray tuchar add_len) (map Vint (map Int.repr contents)) additional *
         data_at Tsh t_struct_hmac256drbg_context_st initial_state ctx *
         hmac256drbg_relate initial_state_abs initial_state *
         data_at Tsh t_struct_mbedtls_md_info info_contents (hmac256drbgstate_md_info_pointer initial_state) *
         Stream s * K_vector kv))
  else (!!(return_value_relate_result (mbedtls_HMAC256_DRBG_reseed_function s initial_state_abs
            (contents_with_add additional add_len contents)) rv)
        && (hmac256drbgabs_common_mpreds (hmac256drbgabs_reseed initial_state_abs s
             (contents_with_add additional add_len contents)) initial_state ctx info_contents *
         da_emp Tsh (tarray tuchar add_len) (map Vint (map Int.repr contents)) additional *
         Stream (get_stream_result (mbedtls_HMAC256_DRBG_reseed_function s initial_state_abs (contents_with_add additional add_len contents))) *
         spec_sha.K_vector kv)).

(*384 equals MBEDTLS_HMAC_DRBG_MAX_SEED_INPUT*)

Definition hmac_drbg_reseed_spec :=
  DECLARE _mbedtls_hmac_drbg_reseed
   WITH contents: list Z,
        additional: val, add_len: Z,
        ctx: val, initial_state: hmac256drbgstate,
        initial_state_abs: hmac256drbgabs,
        kv: val, info_contents: md_info_state,
        s: ENTROPY.stream
    PRE [ _ctx OF (tptr t_struct_hmac256drbg_context_st), _additional OF (tptr tuchar), _len OF tuint ]
       PROP (
         0 <= add_len <= Int.max_unsigned;
         Zlength (hmac256drbgabs_value initial_state_abs) = 32 (*Z.of_nat SHA256.DigestLength*);
         add_len = Zlength contents;
         0 <= hmac256drbgabs_entropy_len initial_state_abs;
         hmac256drbgabs_entropy_len initial_state_abs+ Zlength contents < Int.modulus;
         0 < hmac256drbgabs_entropy_len initial_state_abs + Zlength (contents_with_add additional add_len contents) < Int.modulus;
         Forall isbyteZ (hmac256drbgabs_value initial_state_abs);
         Forall isbyteZ contents
       )
       LOCAL (temp _ctx ctx; temp _additional additional; temp _len (Vint (Int.repr add_len)); gvar sha._K256 kv)
       SEP (
         da_emp Tsh (tarray tuchar add_len) (map Vint (map Int.repr contents)) additional;
         data_at Tsh t_struct_hmac256drbg_context_st initial_state ctx;
         hmac256drbg_relate initial_state_abs initial_state;
         data_at Tsh t_struct_mbedtls_md_info info_contents (hmac256drbgstate_md_info_pointer initial_state);
         Stream s;
         K_vector kv)
    POST [ tint ]
       EX ret_value:_,
       PROP ()
       LOCAL (temp ret_temp ret_value)
       SEP (reseedPOST ret_value contents additional add_len s
          initial_state_abs ctx
          info_contents kv initial_state).

Definition mbedtls_HMAC256_DRBG_generate_function (entropy_stream: ENTROPY.stream) (a:hmac256drbgabs)
            (requested_number_of_bytes: Z) (additional_input: list Z): ENTROPY.result (list Z * DRBG_state_handle) :=
  match a with HMAC256DRBGabs key V reseed_counter entropy_len prediction_resistance reseed_interval =>
               HMAC256_DRBG_generate_function (HMAC256_DRBG_reseed_function entropy_len entropy_len 256)
                      10000(* reseed_interval *)
                      1024 (*max_number_of_bytes_per_request*)
                      256 (*max_additional_input_length*)
                      entropy_stream
                      ((V, key, reseed_counter),
                        32(*256*) (*max security strength in bytes, not used *),
                        prediction_resistance)
                      requested_number_of_bytes
                      32 (*requested security strength, not used *)
                      prediction_resistance additional_input
  end.

Definition hmac256drbgabs_generate (a: hmac256drbgabs) (s: ENTROPY.stream) (bytes: Z) (additional_data: list Z) : hmac256drbgabs :=
  match a with HMAC256DRBGabs key V reseed_counter entropy_len prediction_resistance reseed_interval =>
               match (mbedtls_HMAC256_DRBG_generate_function s a bytes additional_data) with
                 | ENTROPY.success (_, ((V', key', reseed_counter'), _, pr')) _ =>
                   HMAC256DRBGabs key' V' reseed_counter' entropy_len pr' reseed_interval
                 | ENTROPY.error _ _ => a
               end
  end.

Definition generatePOST ret_value contents additional add_len output out_len ctx initial_state initial_state_abs kv info_contents s :=
if out_len >? 1024
then (!!(ret_value = Vint (Int.neg (Int.repr 3))) &&
       (data_at_ Tsh (tarray tuchar out_len) output *
         da_emp Tsh (tarray tuchar add_len) (map Vint (map Int.repr contents)) additional *
         data_at Tsh t_struct_hmac256drbg_context_st initial_state ctx *
         hmac256drbg_relate initial_state_abs initial_state *
         data_at Tsh t_struct_mbedtls_md_info info_contents (hmac256drbgstate_md_info_pointer initial_state) *
         Stream s *
         K_vector kv))
else
  if (add_len >? 256)
  then (!!(ret_value = Vint (Int.neg (Int.repr 5))) &&
       (data_at_ Tsh (tarray tuchar out_len) output *
         da_emp Tsh (tarray tuchar add_len) (map Vint (map Int.repr contents)) additional *
         data_at Tsh t_struct_hmac256drbg_context_st initial_state ctx *
         hmac256drbg_relate initial_state_abs initial_state *
         data_at Tsh t_struct_mbedtls_md_info info_contents (hmac256drbgstate_md_info_pointer initial_state) *
         Stream s *
         K_vector kv))
  else let g := (mbedtls_HMAC256_DRBG_generate_function s initial_state_abs out_len (*contents*)(contents_with_add additional add_len contents))
       in (!!(return_value_relate_result g ret_value)) &&
          (match g with
            | ENTROPY.error _ _ => (data_at_ Tsh (tarray tuchar out_len) output)
            | ENTROPY.success (bytes, _) _ => (data_at Tsh (tarray tuchar out_len) (map Vint (map Int.repr bytes)) output)
          end *
          hmac256drbgabs_common_mpreds (hmac256drbgabs_generate initial_state_abs s out_len (*contents*)(contents_with_add additional add_len contents)) initial_state ctx info_contents *
          da_emp Tsh (tarray tuchar add_len) (map Vint (map Int.repr contents)) additional *
          Stream (get_stream_result g) *
          K_vector kv).

Definition hmac_drbg_generate_spec :=
  DECLARE _mbedtls_hmac_drbg_random_with_add
   WITH contents: list Z,
        additional: val, add_len: Z,
        output: val, out_len: Z,
        ctx: val, initial_state: hmac256drbgstate,
        initial_state_abs: hmac256drbgabs,
        kv: val, info_contents: md_info_state,
        s: ENTROPY.stream
    PRE [ _p_rng OF (tptr tvoid), _output OF (tptr tuchar), _out_len OF tuint, _additional OF (tptr tuchar), _add_len OF tuint ]
       PROP (
         0 <= add_len <= Int.max_unsigned;
         0 <= out_len <= Int.max_unsigned;
         Zlength (hmac256drbgabs_value initial_state_abs) = 32 (*Z.of_nat SHA256.DigestLength*);
         add_len = Zlength contents;
         0 < hmac256drbgabs_entropy_len initial_state_abs;
         hmac256drbgabs_entropy_len initial_state_abs + Zlength contents <= 384;
         hmac256drbgabs_reseed_interval initial_state_abs = 10000;
         0 <= hmac256drbgabs_reseed_counter initial_state_abs <= Int.max_signed;
         Forall isbyteZ (hmac256drbgabs_value initial_state_abs);
         Forall isbyteZ contents
       )
       LOCAL (temp _p_rng ctx; temp _output output; temp _out_len (Vint (Int.repr out_len));
              temp _additional additional; temp _add_len (Vint (Int.repr add_len)); gvar sha._K256 kv)
       SEP (
         data_at_ Tsh (tarray tuchar out_len) output;
         da_emp Tsh (tarray tuchar add_len) (map Vint (map Int.repr contents)) additional;
         data_at Tsh t_struct_hmac256drbg_context_st initial_state ctx;
         hmac256drbg_relate initial_state_abs initial_state;
         data_at Tsh t_struct_mbedtls_md_info info_contents (hmac256drbgstate_md_info_pointer initial_state);
         Stream s;
         K_vector kv)
    POST [ tint ]
       EX ret_value:_,
       PROP ()
       LOCAL (temp ret_temp ret_value)
       SEP (generatePOST ret_value contents additional add_len output out_len ctx initial_state initial_state_abs kv info_contents s).

Definition hmac_drbg_seed_buf_spec :=
  DECLARE _mbedtls_hmac_drbg_seed_buf
   WITH ctx: val, info:val, d_len: Z, data:val, Data: list Z,
        Ctx: hmac256drbgstate,
        CTX: hmac256drbgabs,
        kv: val, Info: md_info_state
    PRE [_ctx OF tptr (Tstruct _mbedtls_hmac_drbg_context noattr),
         _md_info OF (tptr (Tstruct _mbedtls_md_info_t noattr)),
         _data OF tptr tuchar, _data_len OF tuint ]
       PROP ( (d_len = Zlength Data \/ d_len=0) /\
              0 <= d_len <= Int.max_unsigned /\ Forall isbyteZ Data)
       LOCAL (temp _ctx ctx; temp _md_info info;
              temp _data_len (Vint (Int.repr d_len)); temp _data data; gvar sha._K256 kv)
       SEP (
         data_at Tsh t_struct_hmac256drbg_context_st Ctx ctx;
         hmac256drbg_relate CTX Ctx;
         data_at Tsh t_struct_mbedtls_md_info Info info;
         da_emp Tsh (tarray tuchar (Zlength Data)) (map Vint (map Int.repr Data)) data;
         K_vector kv)
    POST [ tint ]
       EX ret_value:_,
       PROP ()
       LOCAL (temp ret_temp ret_value)
       SEP (data_at Tsh t_struct_mbedtls_md_info Info info *
            da_emp Tsh (tarray tuchar (Zlength Data)) (map Vint (map Int.repr Data)) data *
            K_vector kv;
            orp ( !!(ret_value = Vint (Int.repr (-20864))) &&
                  data_at Tsh t_struct_hmac256drbg_context_st Ctx ctx *
                  hmac256drbg_relate CTX Ctx)
                ( !!(ret_value <> Vint (Int.repr (-20864))) &&
                  match Ctx, CTX
                  with (mds, (V', (RC', (EL', (PR', RI'))))),
                              HMAC256DRBGabs key V RC EL PR RI
                     => EX KEY:list Z, EX VAL:list Z, EX p:val,
                          !!(HMAC256_DRBG_update (contents_with_add data d_len Data) V (list_repeat 32 1) = (KEY, VAL))
                          && md_full key mds * malloc_token Tsh (sizeof (Tstruct _hmac_ctx_st noattr)) p *
                             data_at Tsh t_struct_hmac256drbg_context_st ((info, (fst(snd mds), p)), (map Vint (map Int.repr VAL), (RC', (EL', (PR', RI'))))) ctx *
                             hmac256drbg_relate (HMAC256DRBGabs KEY VAL RC EL PR RI) ((info, (fst(snd mds), p)), (map Vint (map Int.repr VAL), (RC', (EL', (PR', RI')))))
                  end)
       ).

Definition get_entropy_spec :=
  DECLARE _get_entropy
   WITH
        sh: share,
        s: ENTROPY.stream,
        buf: val, len: Z
    PRE [ 1%positive OF (tptr tuchar), 2%positive OF tuint ]
       PROP (
         0 <= len <= Int.max_unsigned;
         writable_share sh
       )
       LOCAL (temp 1%positive buf; temp 2%positive (Vint (Int.repr len)))
       SEP (
         memory_block sh len buf;
         (Stream s)
           )
    POST [ tint ]
       EX ret_value:_,
       PROP (
           return_value_relate_result (get_entropy 0 len len false s) ret_value
         )
       LOCAL (temp ret_temp ret_value)
       SEP (
         Stream (get_stream_result (get_entropy 0 len len false s));
         (match ENTROPY.get_bytes (Z.to_nat len) s with
            | ENTROPY.error _ _ => memory_block sh len buf
            | ENTROPY.success bytes _ =>
              data_at sh (tarray tuchar len) (map Vint (map Int.repr (bytes))) buf
                 end)
       ).

Definition size_of_HMACDRBGCTX:Z:= sizeof (Tstruct _mbedtls_hmac_drbg_context noattr).

Definition hmac_drbg_init_spec :=
  DECLARE _mbedtls_hmac_drbg_init
   WITH c : val
   PRE [ _ctx OF tptr (Tstruct _mbedtls_hmac_drbg_context noattr) ]
         PROP ()
         LOCAL (temp _ctx c)
         SEP(memory_block Tsh size_of_HMACDRBGCTX c)
  POST [ tvoid ]
          PROP ()
          LOCAL ()
          SEP(data_at Tsh (tarray tuchar size_of_HMACDRBGCTX)
                (list_repeat (Z.to_nat size_of_HMACDRBGCTX) (Vint Int.zero)) c).

Definition hmac_drbg_random_spec :=
  DECLARE _mbedtls_hmac_drbg_random
   WITH output: val, out_len: Z,
        ctx: val, initial_state: hmac256drbgstate,
        initial_state_abs: hmac256drbgabs,
        kv: val, info_contents: md_info_state,
        s: ENTROPY.stream
    PRE [_p_rng OF tptr tvoid, _output OF tptr tuchar, _out_len OF tuint ]
       PROP (
         0 <= out_len <= Int.max_unsigned;
         Zlength (hmac256drbgabs_value initial_state_abs) = 32 (*Z.of_nat SHA256.DigestLength*);
         0 < hmac256drbgabs_entropy_len initial_state_abs <= 384;
         hmac256drbgabs_reseed_interval initial_state_abs = 10000;
         0 <= hmac256drbgabs_reseed_counter initial_state_abs <= Int.max_signed;
         Forall isbyteZ (hmac256drbgabs_value initial_state_abs))
       LOCAL (temp _p_rng ctx; temp _output output;
              temp _out_len (Vint (Int.repr out_len)); gvar sha._K256 kv)
       SEP (
         data_at_ Tsh (tarray tuchar out_len) output;
         data_at Tsh t_struct_hmac256drbg_context_st initial_state ctx;
         hmac256drbg_relate initial_state_abs initial_state;
         data_at Tsh t_struct_mbedtls_md_info info_contents (hmac256drbgstate_md_info_pointer initial_state);
         Stream s;
         K_vector kv)
    POST [ tint ]
       EX ret_value:_,
       PROP ()
       LOCAL (temp ret_temp ret_value)
       SEP (generatePOST ret_value nil nullval 0 output out_len ctx initial_state initial_state_abs kv info_contents s).

Definition setPR_ABS res (a: hmac256drbgabs): hmac256drbgabs :=
  match a with HMAC256DRBGabs key V x el r reseed_interval =>
               HMAC256DRBGabs key V x el res reseed_interval
  end.

Definition setPR_CTX res (r: hmac256drbgstate): hmac256drbgstate :=
  match r with (md_ctx, (V, (rc, (el, (r, ri))))) =>
               (md_ctx, (V, (rc, (el, (res, ri)))))
  end.

Definition hmac_drbg_setPredictionResistance_spec :=
  DECLARE _mbedtls_hmac_drbg_set_prediction_resistance
   WITH ctx:val, CTX:hmac256drbgstate, ABS:_, r:bool
    PRE [_ctx OF tptr (Tstruct _mbedtls_hmac_drbg_context noattr),
         _resistance OF tint ]
       PROP ( )
       LOCAL (temp _ctx ctx; temp _resistance (Val.of_bool r))
       SEP (data_at Tsh t_struct_hmac256drbg_context_st CTX ctx;
            hmac256drbg_relate ABS CTX)
    POST [ tvoid ]
       SEP (data_at Tsh t_struct_hmac256drbg_context_st (setPR_CTX (Val.of_bool r) CTX) ctx;
            hmac256drbg_relate (setPR_ABS r ABS) (setPR_CTX (Val.of_bool r) CTX)).

Definition setEL_ABS el (a: hmac256drbgabs): hmac256drbgabs :=
  match a with HMAC256DRBGabs key V x _ pr reseed_interval =>
               HMAC256DRBGabs key V x el pr reseed_interval
  end.

Definition setEL_CTX el (r: hmac256drbgstate): hmac256drbgstate :=
  match r with (md_ctx, (V, (rc, (_, (pr, ri))))) =>
               (md_ctx, (V, (rc, (el, (pr, ri)))))
  end.

Definition hmac_drbg_setEntropyLen_spec :=
  DECLARE _mbedtls_hmac_drbg_set_entropy_len
   WITH ctx:val, CTX:hmac256drbgstate, ABS:_, l:_
    PRE [_ctx OF tptr (Tstruct _mbedtls_hmac_drbg_context noattr),
         _len OF tuint ]
       PROP ( )
       LOCAL (temp _ctx ctx; temp _len (Vint (Int.repr l)))
       SEP (data_at Tsh t_struct_hmac256drbg_context_st CTX ctx;
            hmac256drbg_relate ABS CTX)
    POST [ tvoid ]
       SEP (data_at Tsh t_struct_hmac256drbg_context_st (setEL_CTX (Vint (Int.repr l)) CTX) ctx;
            hmac256drbg_relate (setEL_ABS l ABS) (setEL_CTX (Vint (Int.repr l)) CTX)).

Definition setRI_ABS ri (a: hmac256drbgabs): hmac256drbgabs :=
  match a with HMAC256DRBGabs key V x el pr _ =>
               HMAC256DRBGabs key V x el pr ri
  end.

Definition setRI_CTX ri (r: hmac256drbgstate): hmac256drbgstate :=
  match r with (md_ctx, (V, (rc, (el, (pr, _))))) =>
               (md_ctx, (V, (rc, (el, (pr, ri)))))
  end.

Definition hmac_drbg_setReseedInterval_spec :=
  DECLARE _mbedtls_hmac_drbg_set_reseed_interval
   WITH ctx:val, CTX:hmac256drbgstate, ABS:_, l:_
    PRE [_ctx OF tptr (Tstruct _mbedtls_hmac_drbg_context noattr),
         _interval OF tint ]
       PROP ( )
       LOCAL (temp _ctx ctx; temp _interval (Vint (Int.repr l)))
       SEP (data_at Tsh t_struct_hmac256drbg_context_st CTX ctx;
            hmac256drbg_relate ABS CTX)
    POST [ tvoid ]
       SEP (data_at Tsh t_struct_hmac256drbg_context_st (setRI_CTX (Vint (Int.repr l)) CTX) ctx;
            hmac256drbg_relate (setRI_ABS l ABS) (setRI_CTX (Vint (Int.repr l)) CTX)).

Definition hmac_drbg_free_spec :=
  DECLARE _mbedtls_hmac_drbg_free
   WITH ctx:val, CTX:hmac256drbgstate, ABS:_
    PRE [_ctx OF tptr (Tstruct _mbedtls_hmac_drbg_context noattr) ]
       PROP ( )
       LOCAL (temp _ctx ctx)
       SEP (da_emp Tsh t_struct_hmac256drbg_context_st CTX ctx;
            if Val.eq ctx nullval then emp else
                 (hmac256drbg_relate ABS CTX *
                  malloc_token Tsh 324 (snd(snd (fst CTX)))))
    POST [ tvoid ]
      EX vret:unit, PROP ()
       LOCAL ()
       SEP (if Val.eq ctx nullval then emp else data_block Tsh (list_repeat (Z.to_nat size_of_HMACDRBGCTX) 0) ctx).

Definition HmacDrbgVarSpecs : varspecs := (sha._K256, tarray tuint 64)::nil.

Definition ndfs_merge fA cA A PA QA FSA (HFSA: FSA = NDmk_funspec fA cA A PA QA)
                    fB cB B PB QB FSB (HFSB: FSB = NDmk_funspec fB cB B PB QB): option funspec.
destruct (eq_dec fA fB); subst.
+ destruct (eq_dec cA cB); subst.
  - apply Some. eapply (NDmk_funspec fB cB (A+B)
         (fun x => match x with inl a => PA a | inr b => PB b end)
         (fun x => match x with inl a => QA a | inr b => QB b end)).
  - apply None.
+ apply None.
Defined.
(*
Definition fs_merge (fA fB: funspec): option funspec :=
 match fA, fB with (mk_funspec sgA ccA A PreA PostA), (mk_funspec sgB ccB B PreB PostB) =>
  if eq_dec sgA sgB
  then if eq_dec ccA ccB
       then Some (mk_funspec sgB ccB (A+B)
                   (fun x => match x with inl a => PreA a | inr b => PreB b end)
                   (fun x => match x with inl a => PostA a | inr b => PostB b end))
       else None
  else None
 end.
*)

Definition hmac_init_funspec:=
    (WITH x : val * Z * list Z * val + val * Z * list Z * val * block * int PRE
     [(hmac._ctx, tptr spec_hmac.t_struct_hmac_ctx_st), (hmac._key, tptr tuchar),
     (hmac._len, tint)] match x with
                        | inl (c, l, key, kv) =>
                            PROP ( )
                            LOCAL (temp hmac._ctx c; temp hmac._key nullval;
                            temp hmac._len (Vint (Int.repr l));
                            gvar sha._K256 kv)
                            SEP (UNDER_SPEC.FULL key c;
                            spec_sha.K_vector kv)
                        | inr (c, l, key, kv, b0, i) =>
                            PROP (spec_hmac.has_lengthK l key)
                            LOCAL (temp hmac._ctx c; temp hmac._key (Vptr b0 i);
                            temp hmac._len (Vint (Int.repr l));
                            gvar sha._K256 kv)
                            SEP (UNDER_SPEC.EMPTY c;
                            spec_sha.data_block Tsh key (Vptr b0 i);
                            spec_sha.K_vector kv)
                        end
     POST [tvoid] match x with
                  | inl (c, _, key, kv) =>
                      PROP ( )
                      LOCAL ()
                      SEP (UNDER_SPEC.REP
                             (UNDER_SPEC.hABS key []) c;
                      spec_sha.K_vector kv)
                  | inr (c, _, key, kv, b0, i) =>
                      PROP ( )
                      LOCAL ()
                      SEP (UNDER_SPEC.REP
                             (UNDER_SPEC.hABS key []) c;
                      spec_sha.data_block Tsh key (Vptr b0 i);
                      spec_sha.K_vector kv)
                  end).
(*
Lemma hmac_init_merge:
  fs_merge (snd UNDER_SPEC.hmac_reset_spec)
           (snd UNDER_SPEC.hmac_starts_spec)
  = Some hmac_init_funspec.
Proof. simpl. rewrite if_true; trivial. Qed.*)

Lemma hmac_init_merge:
  ndfs_merge _ _ _ _ _ (snd UNDER_SPEC.hmac_reset_spec) (eq_refl _)
             _ _ _ _ _ (snd UNDER_SPEC.hmac_starts_spec) (eq_refl _)
  = Some hmac_init_funspec.
Proof. unfold ndfs_merge. simpl. rewrite if_true; trivial. Qed.

Definition HmacDrbgFunSpecs : funspecs :=  ltac:(with_library prog (
  md_free_spec ::hmac_drbg_free_spec::mbedtls_zeroize_spec::
  hmac_drbg_setReseedInterval_spec::hmac_drbg_setEntropyLen_spec::
  hmac_drbg_setPredictionResistance_spec::hmac_drbg_random_spec::hmac_drbg_init_spec::
  hmac_drbg_update_spec::
  hmac_drbg_reseed_spec::
  hmac_drbg_generate_spec::hmac_drbg_seed_buf_spec ::
  get_entropy_spec::
  md_reset_spec::md_final_spec::md_update_spec::
  md_starts_spec::md_setup_spec::md_get_size_spec::

  UNDER_SPEC.hmac_update_spec::
  UNDER_SPEC.hmac_final_spec::
  (hmac._HMAC_Init,hmac_init_funspec)::

  drbg_memcpy_spec:: drbg_memset_spec::
  sha.spec_hmac.sha256init_spec::sha.spec_hmac.sha256update_spec::sha.spec_hmac.sha256final_spec::nil)).


From cap_machine Require Import rules_base.
From iris.base_logic Require Export invariants gen_heap.
From iris.program_logic Require Export weakestpre ectx_lifting.
From iris.proofmode Require Import tactics.
From iris.algebra Require Import frac.

Section cap_lang_rules.
  Context `{memG Σ, regG Σ}.
  Context `{MachineParameters}.
  Implicit Types P Q : iProp Σ.
  Implicit Types σ : ExecConf.
  Implicit Types c : cap_lang.expr.
  Implicit Types a b : Addr.
  Implicit Types r : RegName.
  Implicit Types v : cap_lang.val.
  Implicit Types w : Word.
  Implicit Types reg : gmap RegName Word.
  Implicit Types ms : gmap Addr Word.

  Inductive Jnz_spec (regs: Reg) (dst src: RegName) : Reg → cap_lang.val → Prop :=
  | Jnz_spec_failure w:
      regs !! src = Some w →
      nonZero w = false →
      incrementPC regs = None →
      Jnz_spec regs dst src regs FailedV
  | Jnz_spec_success1 w regs':
      regs !! src = Some w →
      nonZero w = false →
      incrementPC regs = Some regs' →
      Jnz_spec regs dst src regs' NextIV
  | Jnz_spec_success2 w w':
      regs !! src = Some w →
      regs !! dst = Some w' →
      nonZero w = true →
      Jnz_spec regs dst src (<[PC := updatePcPerm w' ]> regs) NextIV.

  Lemma wp_Jnz Ep pc_p pc_g pc_b pc_e pc_a w dst src regs :
    decodeInstrW w = Jnz dst src ->

    isCorrectPC (inr ((pc_p, pc_g), pc_b, pc_e, pc_a)) →
    regs !! PC = Some (inr ((pc_p, pc_g), pc_b, pc_e, pc_a)) →
    regs_of (Jnz dst src) ⊆ dom _ regs →
    {{{ ▷ pc_a ↦ₐ w ∗
        ▷ [∗ map] k↦y ∈ regs, k ↦ᵣ y }}}
      Instr Executable @ Ep
    {{{ regs' retv, RET retv;
        ⌜ Jnz_spec regs dst src regs' retv ⌝ ∗
        pc_a ↦ₐ w ∗
        [∗ map] k↦y ∈ regs', k ↦ᵣ y }}}.
  Proof.
    iIntros (Hinstr Hvpc HPC Dregs φ) "(>Hpc_a & >Hmap) Hφ".
    iApply wp_lift_atomic_head_step_no_fork; auto.
    iIntros (σ1 l1 l2 n) "Hσ1 /=". destruct σ1 as [r m]; simpl.
    iDestruct "Hσ1" as "[Hr Hm]".
    iDestruct (gen_heap_valid_inclSepM with "Hr Hmap") as %Hregs.
    have HPC' := regs_lookup_eq _ _ _ HPC.
    have ? := lookup_weaken _ _ _ _ HPC Hregs.
    iDestruct (@gen_heap_valid with "Hm Hpc_a") as %Hpc_a; auto.
    iModIntro. iSplitR. by iPureIntro; apply normal_always_head_reducible.
    iNext. iIntros (e2 σ2 efs Hpstep).
    apply prim_step_exec_inv in Hpstep as (-> & -> & (c & -> & Hstep)).
    iSplitR; auto. eapply step_exec_inv in Hstep; eauto.

    specialize (indom_regs_incl _ _ _ Dregs Hregs) as Hri.
    unfold regs_of in Hri, Dregs.
    destruct (Hri src) as [wsrc [H'src Hsrc]]. by set_solver+.
    destruct (Hri dst) as [wdst [H'dst Hdst]]. by set_solver+.

    destruct (nonZero wsrc) eqn:Hnz; pose proof Hnz as H'nz;
      cbn in Hstep; rewrite /RegLocate Hsrc Hdst Hnz in Hstep.
    { inv Hstep. simplify_pair_eq.
      iMod ((gen_heap_update_inSepM _ _ PC) with "Hr Hmap") as "[Hr Hmap]"; eauto.
      iFrame. iApply "Hφ". iFrame. iPureIntro. econstructor 3; eauto. }

    destruct (incrementPC regs) eqn:HX; pose proof HX as H'X; cycle 1.
    { apply incrementPC_fail_updatePC with (m:=m) in HX.
      eapply updatePC_fail_incl with (m':=m) in HX; eauto. simplify_pair_eq.
      inv Hstep. iFrame. iApply "Hφ". iFrame. iPureIntro; econstructor; eauto. }

    destruct (incrementPC_success_updatePC _ m _ HX)
      as (p' & g' & b' & e' & a'' & a_pc' & HPC'' & Ha_pc' & HuPC & -> & ?).
    eapply updatePC_success_incl with (m':=m) in HuPC; eauto. simplify_pair_eq.
    iMod ((gen_heap_update_inSepM _ _ PC) with "Hr Hmap") as "[Hr Hmap]"; eauto.
    iFrame. iApply "Hφ". iFrame. iPureIntro. econstructor 2; eauto.
  Qed.

  Lemma wp_jnz_success_jmp E r1 r2 pc_p pc_g pc_b pc_e pc_a w w1 w2 :
    decodeInstrW w = Jnz r1 r2 →
    isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) →
    w2 ≠ inl 0%Z →

    {{{ ▷ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ ▷ pc_a ↦ₐ w
        ∗ ▷ r1 ↦ᵣ w1
        ∗ ▷ r2 ↦ᵣ w2 }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ updatePcPerm w1
          ∗ pc_a ↦ₐ w
          ∗ r1 ↦ᵣ w1
          ∗ r2 ↦ᵣ w2 }}}.
  Proof.
    iIntros (Hinstr Hvpc Hne ϕ) "(>HPC & >Hpc_a & >Hr1 & >Hr2) Hφ".
    iDestruct (map_of_regs_3 with "HPC Hr1 Hr2") as "[Hmap (%&%&%)]".
    iApply (wp_Jnz with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by unfold regs_of; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    assert (nonZero w2 = true).
    { unfold nonZero, Zneq_bool in *.
      repeat case_match; try congruence; subst. exfalso.
      apply Hne. f_equal. by apply Z.compare_eq. }

   destruct Hspec as [ | | ].
   { exfalso. simplify_map_eq. congruence. }
   { exfalso. simplify_map_eq. congruence. }
   { iApply "Hφ". iFrame. simplify_map_eq. rewrite insert_insert.
     iDestruct (regs_of_map_3 with "Hmap") as "(?&?&?)"; eauto; iFrame. }
  Qed.

  Lemma wp_jnz_success_jmp2 E r2 pc_p pc_g pc_b pc_e pc_a w w2 :
    decodeInstrW w = Jnz r2 r2 →
    isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) →
    w2 ≠ inl 0%Z →

    {{{ ▷ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ ▷ pc_a ↦ₐ w
        ∗ ▷ r2 ↦ᵣ w2 }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ updatePcPerm w2
          ∗ pc_a ↦ₐ w
          ∗ r2 ↦ᵣ w2 }}}.
  Proof.
    iIntros (Hinst Hvpc Hne ϕ) "(>HPC & >Hpc_a & >Hr2) Hφ".
    iDestruct (map_of_regs_2 with "HPC Hr2") as "[Hmap %]".
    iApply (wp_Jnz with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by unfold regs_of; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    assert (nonZero w2 = true).
    { unfold nonZero, Zneq_bool in *.
      repeat case_match; try congruence; subst. exfalso.
      apply Hne. f_equal. by apply Z.compare_eq. }

   destruct Hspec as [ | | ].
   { exfalso. simplify_map_eq. congruence. }
   { exfalso. simplify_map_eq. congruence. }
   { iApply "Hφ". iFrame. simplify_map_eq. rewrite insert_insert.
     iDestruct (regs_of_map_2 with "Hmap") as "(?&?)"; eauto; iFrame. }
  Qed.

  Lemma wp_jnz_success_jmpPC E pc_p pc_g pc_b pc_e pc_a w  :
    decodeInstrW w = Jnz PC PC →
    isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) →

    {{{ ▷ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ ▷ pc_a ↦ₐ w }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ updatePcPerm (inr ((pc_p,pc_g),pc_b,pc_e,pc_a))
          ∗ pc_a ↦ₐ w }}}.
  Proof.
    iIntros (Hinstr Hvpc ϕ) "(>HPC & >Hpc_a) Hφ".
    iDestruct (map_of_regs_1 with "HPC") as "Hmap".
    iApply (wp_Jnz with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by unfold regs_of; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

   destruct Hspec as [ | | ]; [ by simplify_map_eq .. | ].
   { iApply "Hφ". iFrame. simplify_map_eq. rewrite insert_insert.
     iDestruct (regs_of_map_1 with "Hmap") as "?"; eauto; iFrame. }
  Qed.

  Lemma wp_jnz_success_jmpPC1 E r2 pc_p pc_g pc_b pc_e pc_a w w2 :
    decodeInstrW w = Jnz PC r2 →
    isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) →
    w2 ≠ inl 0%Z →

    {{{ ▷ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ ▷ pc_a ↦ₐ w
        ∗ ▷ r2 ↦ᵣ w2 }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ updatePcPerm (inr ((pc_p,pc_g),pc_b,pc_e,pc_a))
          ∗ pc_a ↦ₐ w
          ∗ r2 ↦ᵣ w2 }}}.
  Proof.
    iIntros (Hinstr Hvpc Hne ϕ) "(>HPC & >Hpc_a & >Hr2) Hφ".
    iDestruct (map_of_regs_2 with "HPC Hr2") as "[Hmap %]".
    iApply (wp_Jnz with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by unfold regs_of; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

    assert (nonZero w2 = true).
    { unfold nonZero, Zneq_bool in *.
      repeat case_match; try congruence; subst. exfalso.
      apply Hne. f_equal. by apply Z.compare_eq. }

   destruct Hspec as [ | | ].
   { exfalso. simplify_map_eq. congruence. }
   { exfalso. simplify_map_eq. congruence. }
   { iApply "Hφ". iFrame. simplify_map_eq. rewrite insert_insert.
     iDestruct (regs_of_map_2 with "Hmap") as "(?&?)"; eauto; iFrame. }
  Qed.

  Lemma wp_jnz_success_jmpPC2 E r1 pc_p pc_g pc_b pc_e pc_a w w1 :
    decodeInstrW w = Jnz r1 PC →
    isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) →

    {{{ ▷ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ ▷ pc_a ↦ₐ w
        ∗ ▷ r1 ↦ᵣ w1 }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ updatePcPerm w1
          ∗ pc_a ↦ₐ w
          ∗ r1 ↦ᵣ w1 }}}.
  Proof.
    iIntros (Hinstr Hvpc ϕ) "(>HPC & >Hpc_a & >Hr1) Hφ".
    iDestruct (map_of_regs_2 with "HPC Hr1") as "[Hmap %]".
    iApply (wp_Jnz with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by unfold regs_of; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

   destruct Hspec as [ | | ]; [ by simplify_map_eq .. | ].
   { iApply "Hφ". iFrame. simplify_map_eq. rewrite insert_insert.
     iDestruct (regs_of_map_2 with "Hmap") as "(?&?)"; eauto; iFrame. }
  Qed.

  Lemma wp_jnz_success_next E r1 r2 pc_p pc_g pc_b pc_e pc_a pc_a' w w1 :
    decodeInstrW w = Jnz r1 r2 →
    isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) →
    (pc_a + 1)%a = Some pc_a' →

    {{{ ▷ PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a)
        ∗ ▷ pc_a ↦ₐ w
        ∗ ▷ r1 ↦ᵣ w1
        ∗ ▷ r2 ↦ᵣ inl 0%Z }}}
      Instr Executable @ E
      {{{ RET NextIV;
          PC ↦ᵣ inr ((pc_p,pc_g),pc_b,pc_e,pc_a')
          ∗ pc_a ↦ₐ w
          ∗ r1 ↦ᵣ w1
          ∗ r2 ↦ᵣ inl 0%Z }}}.
  Proof.
    iIntros (Hinstr Hvpc Hpc_a' ϕ) "(>HPC & >Hpc_a & >Hr1 & >Hr2) Hφ".
    iDestruct (map_of_regs_3 with "HPC Hr1 Hr2") as "[Hmap (%&%&%)]".
    iApply (wp_Jnz with "[$Hmap Hpc_a]"); eauto; simplify_map_eq; eauto.
    by unfold regs_of; rewrite !dom_insert; set_solver+.
    iNext. iIntros (regs' retv) "(#Hspec & Hpc_a & Hmap)". iDestruct "Hspec" as %Hspec.

   destruct Hspec as [ | | ]; try incrementPC_inv; simplify_map_eq; eauto.
   { destruct H7; try congruence. inv Hvpc. naive_solver. }
   { iApply "Hφ". iFrame. rewrite insert_insert.
     iDestruct (regs_of_map_3 with "Hmap") as "(?&?&?)"; eauto; iFrame. }
  Qed.

End cap_lang_rules.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Export DistributedReferenceCounting.machine4.machine.
Require Export DistributedReferenceCounting.machine4.cardinal.
Require Export DistributedReferenceCounting.machine4.comm.

Unset Standard Proposition Elimination Names.

Section IN_Q_BEFORE.

Variable data : Set.

(* This predicate tells us if we can find a data d
   - before the first occurrence of d1, if d1 belongs to q,
   - otherwise it returns true when d1 does not belong to q.
*)

Hypothesis eq_data_dec : eq_dec data.

Fixpoint In_queue_before_data (d d1 : data) (q : queue data) {struct q} :
 Prop :=
  match q with
  | empty => True
  | input d' q' =>
      if eq_data_dec d' d1
      then False
      else d' = d \/ In_queue_before_data d d1 q'
  end.

(* same except that I pass a predicate to recognise d1 *)

Fixpoint In_queue_before (d : data) (f1 : data -> bool)
 (q : queue data) {struct q} : Prop :=
  match q with
  | empty => True
  | input d' q' =>
      if eq_bool_dec (f1 d')
      then False
      else d' = d \/ In_queue_before d f1 q'
  end.

End IN_Q_BEFORE.

Section ALTERNATE.

Definition is_inc_dec (m : Message) :=
  match m with
  | inc_dec _ => true
  | _ => false
  end.

Inductive alternate : queue Message -> Prop :=
  | alt_null : alternate (empty Message)
  | alt_any_alt :
      forall (qm : queue Message) (m : Message),
      (forall s : Site, m <> inc_dec s) ->
      alternate qm -> alternate (input Message m qm)
  | alt_inc_dec :
      forall (qm : queue Message) (s0 : Site),
      alternate qm ->
      In_queue_before Message dec is_inc_dec qm ->
      alternate (input Message (inc_dec s0) qm).

Lemma dec_is_not_inc : forall s : Site, dec <> inc_dec s.
Proof.
 intro; discriminate.
Qed.

Inductive D_queue : queue Message -> Prop :=
  | D_empty : D_queue (empty Message)
  | D_dec :
      forall qm : queue Message,
      alternate qm -> In_queue_before Message dec is_inc_dec qm -> D_queue qm.

Lemma not_D_queue :
 forall (q0 : queue Message) (m : Message),
 ~ D_queue q0 -> m <> dec -> ~ D_queue (input Message m q0).
Proof.
  intros; red in |- *; intro.
  inversion H1.
  elim H.
  generalize H3.
  generalize H2.
  generalize H0.
  case q0.
  intros.
  apply D_empty.

  simpl in |- *.
  intros.
  apply D_dec.
  inversion H6.
  auto.

  auto.

  simpl in |- *.
  generalize H5 H7.
  case m.
  intro.
  elim H8; auto.

  intro.
  case (eq_bool_dec (is_inc_dec (inc_dec s))).
  intros; contradiction.

  intros.
  elim H9; intro.
  elim H8; auto.

  auto.

  case (eq_bool_dec (is_inc_dec copy)).
  intros; contradiction.

  intros.
  elim H9; intro.
  elim H8; auto.

  auto.
Qed.

Lemma D_queue_is_alternate :
 forall q0 : queue Message, D_queue q0 -> alternate q0.
Proof.
  intros.
  elim H.
  apply alt_null.
  intros.
  auto.
Qed.

Lemma in_q_before_first_out :
 forall q : queue Message,
 In_queue_before Message dec is_inc_dec q ->
 In_queue_before Message dec is_inc_dec (first_out Message q).
Proof.
  simple induction q.
  simpl in |- *.
  auto.

  simpl in |- *.
  intro.
  case d.
  case (eq_bool_dec (is_inc_dec dec)).
  simpl in |- *.
  intro; discriminate.

  intro; intro.
  case q0.
  simpl in |- *.
  auto.

  simpl in |- *.
  intros.
  case (eq_bool_dec false).
  intro; discriminate.

  auto.

  intro.
  case (eq_bool_dec (is_inc_dec (inc_dec s))).
  intros; contradiction.

  simpl in |- *; intro.
  discriminate.

  simpl in |- *.
  case (eq_bool_dec false).
  intro; discriminate.

  intro; intro.
  case q0.
  simpl in |- *.
  auto.

  intros.
  elim H0.
  intro; discriminate.

  intro.
  generalize (H H1).
  simpl in |- *.
  intros.
  case (eq_bool_dec false); intro.
  discriminate.

  right; auto.
Qed.

Lemma alt_first_out :
 forall q0 : queue Message, alternate q0 -> alternate (first_out Message q0).
Proof.
  intros; elim H; simpl in |- *.
  apply alt_null.

  intros qm m; intro.
  case qm.
  intros; apply alt_null.

  simpl in |- *.
  generalize H0.
  case m.
  auto.
  intros.
  apply alt_any_alt.
  auto.

  auto.

  intros.
  apply alt_any_alt.
  auto.

  auto.

  intros.
  apply alt_any_alt.
  auto.

  auto.

  intro.
  intro.
  case qm.
  auto.

  intros.
  apply alt_inc_dec.
  auto.

  apply in_q_before_first_out.
  auto.
Qed.

Lemma D_first_out :
 forall q0 : queue Message, D_queue q0 -> D_queue (first_out Message q0).
Proof.
  intros.
  elim H.
  simpl in |- *.
  apply D_empty.

  simple destruct qm.
  simpl in |- *.
  intros.
  apply D_empty.

  intros.
  apply D_dec.
  apply alt_first_out.
  auto.

  apply in_q_before_first_out.
  auto.
Qed.

Lemma D_input :
 forall q : queue Message, D_queue (input Message copy q) -> D_queue q.
Proof.
  intros.
  inversion H.
  inversion H0.
  apply D_dec.
  auto.
  generalize H1; simpl in |- *.
  case (eq_bool_dec false); intro.
  discriminate.
  intro.
  elim H7; intro.
  discriminate.

  auto.
Qed.

End ALTERNATE.

Section MESS_ALT.

(* consequence sur la structure alternee *)

Variable b0 : Bag_of_Data Message.

Variable s0 : Site.

Lemma D_collect :
 forall s1 s2 : Site,
 D_queue (b0 s0 owner) -> D_queue (Collect_message Message b0 s1 s2 s0 owner).
Proof.
 intros; case (eq_queue_dec s1 s0 s2 owner); intro.
 decompose [and] a; rewrite H0; rewrite H1.
 rewrite collect_here; apply D_first_out; trivial.

 rewrite collect_elsewhere; auto.
Qed.

Lemma D_post_elsewhere :
 forall (s1 s2 : Site) (m : Message),
 s1 <> s0 \/ s2 <> owner ->
 D_queue (b0 s0 owner) -> D_queue (Post_message Message m b0 s1 s2 s0 owner).
Proof.
 intros; rewrite post_elsewhere; trivial.
Qed.

Lemma D_post_dec :
 alternate (b0 s0 owner) ->
 D_queue (Post_message Message dec b0 s0 owner s0 owner).
Proof.
  intros; rewrite post_here.
  apply D_dec.
  apply alt_any_alt.
  intro; discriminate.
  auto.
  simpl in |- *.
  case (eq_bool_dec false); intro.
  discriminate.
  auto.
Qed.

Lemma alt_collect :
 forall s1 s2 : Site,
 alternate (b0 s0 owner) ->
 alternate (Collect_message Message b0 s1 s2 s0 owner).
Proof.
 intros; case (eq_queue_dec s1 s0 s2 owner); intro.
 decompose [and] a; rewrite H0; rewrite H1.
 rewrite collect_here; apply alt_first_out; trivial.

 rewrite collect_elsewhere; auto.
Qed.

Lemma alt_post_elsewhere :
 forall (s1 s2 : Site) (m : Message),
 s1 <> s0 \/ s2 <> owner ->
 alternate (b0 s0 owner) ->
 alternate (Post_message Message m b0 s1 s2 s0 owner).
Proof.
 intros; rewrite post_elsewhere; trivial.
Qed.

Lemma alt_post_any :
 forall m : Message,
 (forall s : Site, m <> inc_dec s) ->
 alternate (b0 s0 owner) ->
 alternate (Post_message Message m b0 s0 owner s0 owner).
Proof.
 intros; rewrite post_here; apply alt_any_alt; auto.
Qed.

Lemma alt_post_inc :
 forall s1 : Site,
 alternate (b0 s0 owner) ->
 In_queue_before Message dec is_inc_dec (b0 s0 owner) ->
 alternate (Post_message Message (inc_dec s1) b0 s0 owner s0 owner).
Proof.
  intros s1 H; rewrite post_here.
  inversion H; intros.
  apply alt_inc_dec.
  apply alt_null.

  auto.

  generalize H1 H2 H3.
  case m.
  intros.
  apply alt_inc_dec.
  apply alt_any_alt.
  intro; discriminate.

  auto.

  auto.

  intros.
  elim (H4 s); auto.

  intros.
  apply alt_inc_dec.
  apply alt_any_alt.
  auto.

  auto.

  auto.

  generalize H3.
  simpl in |- *.
  case (eq_bool_dec true); intro.
  intro; contradiction.

  discriminate.
Qed.

(* no longer useful 'cos copy is out of band and could be last *)

Lemma alt_post_inc_old :
 forall s1 : Site,
 alternate (b0 s0 owner) ->
 b0 s0 owner = empty Message \/
 last Message (b0 s0 owner) = value Message dec ->
 alternate (Post_message Message (inc_dec s1) b0 s0 owner s0 owner).
Proof.
  intros s1 H; rewrite post_here.
  inversion H; simpl in |- *; intros.
  apply alt_inc_dec.
  apply alt_null.
  simpl in |- *.
  auto.
  replace m with dec.
  apply alt_inc_dec.
  apply alt_any_alt.
  intro; discriminate.
  auto.
  simpl in |- *.
  case (eq_bool_dec false); intro.
  discriminate.
  auto.
  elim H3; intro.
  discriminate.
  inversion H4.
  auto.
  elim H3; intro.
  discriminate.
  discriminate.
Qed.

Lemma in_q_before_append :
 forall q1 q2 : queue Message,
 In_queue_before Message dec is_inc_dec (append Message q1 q2) ->
 In_queue_before Message dec is_inc_dec
   (append Message q1 (input Message copy q2)).
Proof.
  simple induction q1; simpl in |- *.
  case (eq_bool_dec false); intro.
  discriminate.
  intros.
  right; auto.
  intro.
  case d.
  simpl in |- *.
  case (eq_bool_dec false); intro.
  discriminate.
  intros.
  auto.
  intro.
  simpl in |- *.
  case (eq_bool_dec true).
  auto.
  intro; discriminate.
  simpl in |- *.
  case (eq_bool_dec false); intro.
  discriminate.
  intros.
  right.
  apply H.
  elim H0; intro.
  discriminate.
  auto.
Qed.

Lemma in_q_before_append2 :
 forall q1 q2 : queue Message,
 In_queue_before Message dec is_inc_dec
   (append Message q1 (input Message copy q2)) ->
 In_queue_before Message dec is_inc_dec (append Message q1 q2).
Proof.
  simple induction q1; simpl in |- *.
  intros.
  elim H; intro.
  discriminate.

  auto.

  intro.
  case d.
  simpl in |- *.
  intros.
  auto.

  intro.
  simpl in |- *.
  auto.

  simpl in |- *.
  intros.
  right.
  elim H0; intro.
  discriminate.

  auto.
Qed.

Lemma alt_shuffle_copy1 :
 forall q1 q2 : queue Message,
 alternate (input Message copy (append Message q1 q2)) ->
 alternate (append Message q1 (input Message copy q2)).
Proof.
  intros q1 q2.
  elim q1.
  simpl in |- *.
  auto.

  simpl in |- *.
  intro.
  case d; intros.
  apply alt_any_alt.
  intro; discriminate.

  apply H.
  inversion H0.
  apply alt_any_alt.
  intro; discriminate.

  inversion H4; auto.

  inversion H0.
  apply alt_inc_dec.
  apply H.
  inversion H4.
  apply alt_any_alt.
  intro; discriminate.

  auto.

  inversion H4.
  elim (H11 s); auto.

  apply alt_any_alt.
  intro; discriminate; auto.

  auto.

  inversion H4.
  elim (H7 s); auto.

  apply in_q_before_append.
  auto.

  apply alt_any_alt.
  intro; discriminate.

  apply H.
  inversion H0.
  auto.
Qed.

Lemma alt_shuffle_copy2 :
 forall q1 q2 : queue Message,
 alternate (append Message q1 (input Message copy q2)) ->
 alternate (append Message q1 q2).
Proof.
  intros q1 q2.
  elim q1.
  simpl in |- *.
  auto.
  intro.
  inversion H.
  auto.

  simpl in |- *.
  intro.
  case d; intros.
  apply alt_any_alt.
  intro; discriminate.

  apply H.
  inversion H0.
  auto.

  inversion H0.
  apply alt_inc_dec.
  apply H.
  auto.

  elim (H3 s); auto.

  apply alt_inc_dec.
  apply H.
  auto.

  apply in_q_before_append2.
  auto.

  apply alt_any_alt.
  intro; discriminate.

  inversion H0.
  apply H.
  auto.
Qed.

Lemma alt_shuffle_copy :
 forall q1 q2 q3 q4 : queue Message,
 append Message q1 q2 = append Message q3 q4 ->
 alternate (append Message q1 (input Message copy q2)) ->
 alternate (append Message q3 (input Message copy q4)).
Proof.
  intros.
  apply alt_shuffle_copy1.
  rewrite <- H.
  apply alt_any_alt.
  intro; discriminate.

  generalize H0.
  elim q1; simpl in |- *.
  intro.
  inversion H1; auto.

  intro.
  case d; intros.
  apply alt_any_alt.
  intro; discriminate.

  apply H1.
  inversion H2; auto.

  inversion H2.
  elim (H5 s); auto.

  apply alt_inc_dec.
  apply H1.
  auto.

  apply in_q_before_append2.
  auto.

  apply alt_any_alt.
  intro; discriminate.

  apply H1.
  inversion H2.
  auto.
Qed.

Lemma D_shuffle_copy1 :
 forall q1 q2 : queue Message,
 D_queue (input Message copy (append Message q1 q2)) ->
 D_queue (append Message q1 (input Message copy q2)).
Proof.
  intros q1 q2.
  elim q1.
  simpl in |- *.
  auto.

  simpl in |- *.
  intro.
  case d; intros.
  apply D_dec.
  apply alt_any_alt.
  intro; discriminate.

  apply alt_shuffle_copy1.
  inversion H0.
  inversion H1.
  inversion H7.
  apply alt_any_alt.
  intro; discriminate.

  auto.

  simpl in |- *.
  case (eq_bool_dec false); intro.
  discriminate.

  auto.

  inversion H0.
  generalize H2.
  simpl in |- *.
  case (eq_bool_dec false); intro.
  discriminate.

  case (eq_bool_dec true); intro.
  intro.
  elim H4; intro.
  discriminate.

  contradiction.

  discriminate.

  apply D_dec.
  apply alt_any_alt.
  intro; discriminate.

  apply alt_shuffle_copy1.
  inversion H0.
  inversion H1.
  inversion H7.
  apply alt_any_alt.
  intro; discriminate.

  auto.

  simpl in |- *.
  case (eq_bool_dec false); intro.
  discriminate.

  right.
  inversion H0.
  generalize H2.
  simpl in |- *.
  case (eq_bool_dec false); intro.
  discriminate.

  intro.
  elim H4; intro.
  discriminate.

  elim H5; intro.
  discriminate.

  apply in_q_before_append.
  auto.
Qed.

Lemma D_shuffle_copy :
 forall q1 q2 q3 q4 : queue Message,
 append Message q1 q2 = append Message q3 q4 ->
 D_queue (append Message q1 (input Message copy q2)) ->
 D_queue (append Message q3 (input Message copy q4)).
Proof.
  intros.
  apply D_shuffle_copy1.
  apply D_dec.
  inversion H0.
  generalize H2.
  case q1; simpl in |- *.
  intro; discriminate.

  intros; discriminate.

  apply alt_any_alt.
  intro; discriminate.

  apply alt_shuffle_copy2.
  apply alt_shuffle_copy with (q1 := q1) (q2 := q2).
  auto.

  auto.

  inversion H0.
  generalize H2.
  case q1; simpl in |- *; intros; discriminate.

  rewrite <- H.
  simpl in |- *.
  case (eq_bool_dec false); intro.
  discriminate.

  right.
  apply in_q_before_append2.
  auto.
Qed.

End MESS_ALT.


Require Import RefProofDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import RefTactics.
Require Import CtxtSwitchAux.Spec.
Require Import AbsAccessor.Spec.
Require Import CtxtSwitch.Specs.save_ns_state.
Require Import CtxtSwitch.LowSpecs.save_ns_state.
Require Import CtxtSwitch.RefProof.RefRel.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Opaque Z.add Z.mul Z.div Z.shiftl Z.shiftr Z.land Z.lor.

Section Refine.

  Hint Unfold
       save_ns_state_sysreg_state_spec
       sysreg_read_spec
       set_ns_state_spec
    .

  Lemma save_ns_state_spec_exists:
    forall habd habd'  labd
      (Hspec: save_ns_state_spec  habd = Some habd')
      (Hrel: relate_RData habd labd),
    exists labd', save_ns_state_spec0  labd = Some labd' /\ relate_RData habd' labd'.
  Proof.
    Local Opaque ptr_eq.
    intros. destruct Hrel.
    unfold save_ns_state_spec, save_ns_state_spec0 in *.
    repeat autounfold in *. simpl in *.
    hsimpl_hyp Hspec; inv Hspec; simpl_query_oracle; extract_prop_dec;
      repeat destruct_con; bool_rel; simpl in *; srewrite;
        repeat (simpl_htarget; grewrite; simpl in * ).
    destruct regs_is_int64_dec in *. autounfold in e. repeat rewrite e.
    repeat simpl_update_reg.
    eexists; split. reflexivity. constructor. reflexivity.
    inv C.
  Qed.

End Refine.


Require Import ExtLib.Data.Fun.
Require Import ExtLib.Tactics.
Require Import MirrorCore.TypesI.
Require Import MirrorCore.SymI.
Require Import MirrorCore.SubstI.
Require Import MirrorCore.EnvI.
Require Import MirrorCore.ExprI.
Require Import MirrorCore.ExprSem.
Require Import MirrorCore.Lambda.Expr.
Require Import MirrorCore.Lambda.AppN.
Require Import ILogic BILogic Pure.
Require Import MirrorCharge.BILNormalize.
Require Import MirrorCharge.SynSepLog.
Require Import MirrorCharge.OrderedCanceller.

Set Implicit Arguments.
Set Strict Implicit.

Section better_ordering.
  Variable typ : Type.
  Variable RType_typ : RType typ.
  Variable Typ2_Fun : Typ2 _ Fun.
  Variable func : Type.
  Variable RSym_func : RSym func.

  Variable tySL : typ.
  Variable ILogicOps_SL : ILogicOps (typD tySL).
  Variable BILOperators_SL : BILOperators (typD tySL).
  Hypothesis ILogic_SL : @ILogic _ ILogicOps_SL.
  Hypothesis BILogic_SL : @BILogic _ ILogicOps_SL BILOperators_SL.

  (** dependencies are like [a -> b] **)
  (** put things in as soon as they are solvable **)

  (** NOTE: These are like a functor **)
  Variable dependency : Type.
  Variable dep_satisfied : dependency -> dependency -> option dependency.
  Variable dep_for : expr typ func -> dependency.

  Inductive Decorated :=
  | DPure (_ : dependency) (_ : expr typ func) (_ : Decorated)
  | DImpure (_ : dependency) (f : expr typ func) (xs : list (expr typ func)) (_ : Decorated)
  | DFrame (_ : dependency) (_ : expr typ func) (xs : list (expr typ func)) (_ : Decorated)
  | DEmp
  | DTru.

  Fixpoint forget_Decorated (d : Decorated) : Conjuncts typ func :=
    match d with
      | DPure _ p d => Pure p (forget_Decorated d)
      | DImpure _ f xs d => Impure f xs (forget_Decorated d)
      | DFrame _ f xs d => Frame f xs (forget_Decorated d)
      | DEmp => Emp _ _
      | DTru => Tru _ _
    end.

  Fixpoint insert_into (d : dependency) (dec : Decorated)
           (here : Decorated -> Decorated)
  : Decorated :=
    match dec with
      | DEmp => here DEmp
      | DTru => here DTru
      | DFrame d' xs ys rst => here (DFrame d' xs ys rst)
      | DPure d' P rst =>
        match dep_satisfied d' d with
          | None => here (DPure d' P rst)
          | Some d => DPure d' P (insert_into d rst here)
        end
      | DImpure d' f xs rst =>
        match dep_satisfied d' d with
          | None => here (DImpure d' f xs rst)
          | Some d => DImpure d' f xs (insert_into d rst here)
        end
    end.

  Definition better_order_decorated (c : conjunctives typ func)
  : Decorated :=
    List.fold_right (fun x acc =>
                       match fst x with
                         | UVar _ =>
                           let d := dep_for (apps (fst x) (snd x)) in
                           insert_into d acc (DFrame d (fst x) (snd x))
                         | _ =>
                           let d := dep_for (apps (fst x) (snd x)) in
                           insert_into d acc (DImpure d (fst x) (snd x))
                       end)
                    (List.fold_right (fun x acc =>
                                        let d := dep_for x in
                                        insert_into d acc (DPure d x))
                                     (if c.(star_true) then DTru else DEmp)
                                     c.(pure))
                    c.(spatial).

  Definition better_order (c : conjunctives typ func) : Conjuncts typ func :=
    forget_Decorated (better_order_decorated c).

  Variable SSL : SynSepLog typ func.
  Variable SSLO : SynSepLogOk _ _ _ _ _ SSL.

  Variable PureOp_SL : @Pure.PureOp (typD tySL).
  Variable Pure_SL : Pure.Pure PureOp_SL.
  Hypothesis Pure_ltrue : Pure.pure ltrue.
  Hypothesis Pure_land : forall a b,
                           Pure.pure a -> Pure.pure b -> Pure.pure (a //\\ b).

(*
  Theorem simple_orderOk
  : @order_spec ts func _ tySL ILogicOps_SL SSL _ simple_order.
  Proof.
    red.
    intros; destruct c; simpl.
    unfold conjunctives_to_expr_star, simple_order; simpl.
    match goal with
      | |- match ?X with _ => _ end =>
        consider X; intros
    end.
    { repeat go_crazy SSL SSLO.
      revert H0. generalize dependent x1.
      induction spatial.
     { simpl. admit. }
      { simpl. intros.
        eapply exprD'_iterated_base_cons_Some in H0; eauto.
        destruct H0 as [ ? [ ? [ ? [ ? ? ] ] ] ].
        assert (forall us vs,
                  x0 us vs -|- x4 us vs ** x2 us vs).
        { intros. rewrite H3. rewrite H5.
          specialize (fun z => IHspatial _ z H4).
          admit. }
        { admit. } } }
    { forward.
(*      repeat go_crazy SSL SSLO. *)
      admit. }
  Qed.
*)
End better_ordering.


Require Import Coq.Program.Basics.
Require Import Coq.Relations.Relations.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Classes.RelationPairs.
Require Import Coqlib.
Require Import AST.
Require Import Memory.
Require Import Globalenvs.
Require Import Events.
Require Import Lens.
Require Import LiftMem.
Require Import PowersetMonad.

Section LIFTEXTCALL.
  Context `{Hlm: LiftModel}.
  Context `{ef_ops: ExtFunOps}.
  Context `{ec_ops: !ExtCallOps bmem external_function}.
  Context `{Hec: !ExternalCalls bmem external_function}.

  Global Instance liftmem_ec_ops: ExtCallOps mem external_function := {
    external_call ef F V ge args m tr ret m' :=
      lift (fun m => external_call ef ge args m tr ret) m m'
  }.

  Lemma lift_mem_unchanged_on P m1 m2:
    mem_unchanged_on P m1 m2 <->
    mem_unchanged_on P (get π m1) (get π m2).
  Proof.
    tauto.
  Qed.

  Lemma lift_loc_out_of_reach f m1:
    loc_out_of_reach f m1 = lift (loc_out_of_reach f) m1.
  Proof.
    reflexivity.
  Qed.

  Lemma lift_loc_out_of_bounds m:
    loc_out_of_bounds m = lift loc_out_of_bounds m.
  Proof.
    reflexivity.
  Qed.

  Hint Rewrite
      @lift_mem_unchanged_on
      @lift_loc_out_of_reach
      @lift_loc_out_of_bounds
    using typeclasses eauto : lift.

  Hint Resolve
    lens_same_context_eq : lift.

  Global Instance liftmem_ec_spec: ExternalCalls mem external_function := {}.
  Proof.
    intro ef; split.
    lift (ec_well_typed (external_call_spec ef)).
    lift (ec_arity (external_call_spec ef)).
    lift (ec_symbols_preserved (external_call_spec ef)).
    lift (ec_valid_block (external_call_spec ef)).
    lift (ec_max_perm (external_call_spec ef)).
    lift (ec_readonly (external_call_spec ef)).
    lift (ec_mem_extends (external_call_spec ef)).
    lift_partial (ec_mem_inject (external_call_spec ef)).
      split.
      assumption.
      eapply liftmem_inject_same_context_2; eassumption || congruence.
    lift (ec_trace_length (external_call_spec ef)).
    lift (ec_receptive (external_call_spec ef)).
    lift (ec_determ (external_call_spec ef)).
  Qed.
End LIFTEXTCALL.


Require Import Relations RelationClasses.
Require Import List.
Require Import compcert.lib.Coqlib.
Require Import compcert.common.LanguageInterface.
Require Import compcert.common.Events.
Require Import compcert.common.Globalenvs.
Require Import compcert.common.Smallstep.
Require Import models.Coherence.

Unset Program Cases.
Local Obligation Tactic := cbn.

(** * Coherence spaces for CompCertO semantics *)

(** ** Language interfaces *)

Coercion li_space (li : language_interface) : space :=
  input (query li) ;; output (reply li).

(** ** CompCert events *)

(*
Inductive ev_coh : relation event :=
  | Event_syscall_coh s1 s2 args1 args2 res1 res2 :
      (s1 = s2 -> args1 = args2 -> res1 = res2) ->
      ev_coh (Event_syscall s1 args1 res1) (Event_syscall s2 args2 res2)
  | Event_vload_coh ...

Program Definition Ev :=
  {|
    token := event;
    coh e1 e2 :=
*)

(** * CompCert semantics *)

(** Note that Reddy's object semantics have a rather coarse-grained
  handling of undefined behaviors, which is inherited by our CompCert
  semantics. Silent divergence and undefined behaviors are also
  conflated.

  The preliminary definition below loses information about the domains
  of component, which would make it impossible to define mutually
  recursive horizontal composition in a satisfactory way. However for
  now we don't need it so we don't care. Ultimately we could
  incoroporate it in the type of the semantics by using
  [input (query li) ;; (1 + output (reply li)] instead of [li_space]
  for the codomain.

  Finally, everything in CompCertO happens in the context of a global
  symbol table, so we need to specify one to get the component's
  semantics. Again this could be an [input Genv.symtbl ;; ...] component
  in the interaction but for now this is the simpler approach. *)

(** ** Semantics of transition systems *)

Section LTS.
  Context {liA liB S} (L : lts liA liB S).

  (** [lts_trace s t r] asserts that the transition system [L] reaches
    a final state with reply [r] from the state [s], with the sequence
    of external calls encoded by the trace [t]. *)

  Inductive lts_trace : S -> token !liA -> reply liB -> Prop :=
    | lts_trace_final (s : S) (r : reply liB) :
        final_state L s r ->
        lts_trace s nil r
    | lts_trace_step (s s' : S) (t : token !liA) (r : reply liB) :
        Step L s E0 s' ->
        lts_trace s' t r ->
        lts_trace s t r
    | lts_trace_external s qx rx s' t r :
        at_external L s qx ->
        after_external L s rx s' ->
        lts_trace s' t r ->
        lts_trace s ((qx, rx) :: t) r.

  Inductive lts_lmaps : token !liA -> token liB -> Prop :=
    | lts_lmaps_intro q s t r :
        valid_query L q = true ->
        initial_state L q s ->
        lts_trace s t r ->
        lts_lmaps t (q, r).

End LTS.

Ltac determ_solve' :=
  auto ||
       match goal with
       | [ |- False -> _ ] => inversion 1
       | [ |- _ = _ -> _ ] => intros <-
       | [ |- _ = _ /\ _ = _ -> _ ] => intros [<- <-]
       | [ |- _ = _ /\ _ = _ /\ _ = _ -> _ ] => intros [<- [<- <-]]
       | [ |- _ -> _ ] => intros
       end.

Ltac determ_solve determ :=
  match goal with
  | [ P : _ , Q : _ |- _ ] =>
    exploit determ;
    [ exact P | exact Q | determ_solve' ]
  | _ => fail
  end.

Section SEMANTICS.
  Context {liA liB} (L : semantics liA liB) (HL : determinate L).

  Lemma trace_determ se s es es' r r' :
    list_coh liA es es' ->
    lts_trace (L se) s es r ->
    lts_trace (L se) s es' r' ->
    es = es' /\ r = r'.
  Proof.
    intros coh h h'.
    revert es' coh h'.
    induction h; intros es' coh lts; inversion lts; subst.
    + determ_solve (sd_final_determ (HL se)).
    + determ_solve (sd_final_nostep (HL se)).
    + determ_solve (sd_final_noext (HL se)).
    + determ_solve (sd_final_nostep (HL se)).
    + determ_solve (sd_determ_2 (HL se)).
      eapply IHh. apply coh. apply H1.
    + determ_solve (sd_at_external_nostep (HL se)).
    + determ_solve (sd_final_noext (HL se)).
    + determ_solve (sd_at_external_nostep (HL se)).
    + specialize (IHh t0).
      determ_solve (sd_at_external_determ (HL se)).
      inversion coh as [ | | ? ? ? ? cohx cohxs]; subst.
      destruct cohx as [cohq cohr].
      exploit cohr. auto. intros <-.
      determ_solve (sd_after_external_determ (HL se)).
      split; f_equal; apply IHh; try apply cohxs; auto.
  Qed.

  Program Definition compcerto_lmap se : !liA --o liB :=
    {|
      has '(t, u) := lts_lmaps (L se) t u;
    |}.
  Next Obligation.
    intros se [eas [qb rb]] [eas' [qb' rb']] lmap lmap' coheas.
    split.
    - split; auto.
      intros <-.
      inversion lmap as [? ? ? ? valid_q init_q transition_q]. subst.
      inversion lmap' as [? ? ? ? valid_q' init_q' transition_q']. subst.
      determ_solve (sd_initial_determ (HL se)).
      exploit trace_determ.
      exact coheas. exact transition_q. exact transition_q'.
      intuition.
    - intros h. destruct h.
      inversion lmap as [? ? ? ? valid_q init_q transition_q]. subst.
      inversion lmap' as [? ? ? ? valid_q' init_q' transition_q']. subst.
      determ_solve (sd_initial_determ (HL se)).
      exploit trace_determ.
      exact coheas. exact transition_q. exact transition_q'.
      intuition.
  Qed.
End SEMANTICS.

(** ** Clight semantics *)

(** As an example, here is the semantics of Clight programs in terms
  of linear maps. *)

Require Clight.

(** *** Proof of determinism *)

Section EXPR_DETERM.
  Variable ge: Clight.genv.
  Variable e: Clight.env.
  Variable le: Clight.temp_env.
  Variable m: Memory.Mem.mem.

  Lemma deref_loc_determ t mem loc ofs v1 v2:
    Clight.deref_loc t mem loc ofs v1 ->
    Clight.deref_loc t mem loc ofs v2 ->
    v1 = v2.
  Proof.
    induction 1; inversion 1; subst; congruence.
  Qed.

  Ltac find_specialize :=
    match goal with
    | [ H : forall x, ?P x -> _, X : _, H1 : ?P ?X |- _ ] => specialize (H _ H1)
    | [ H : forall x y, ?P x y -> _, X : _, Y : _,  H1 : ?P ?X ?Y |- _ ] => specialize (H _ _ H1)
    | _ => idtac
    end.

  Ltac expr_determ_solve :=
    repeat find_specialize; try split; f_equal; congruence || easy.

  Lemma expr_determ:
    (forall a v1,
        Clight.eval_expr ge e le m a v1 ->
        forall v2,
          Clight.eval_expr ge e le m a v2 ->
          v1 = v2)
    /\
    (forall a b1 ofs1,
        Clight.eval_lvalue ge e le m a b1 ofs1 ->
        forall b2 ofs2,
          Clight.eval_lvalue ge e le m a b2 ofs2 ->
          b1 = b2 /\ ofs1 = ofs2).
  Proof.
    apply Clight.eval_expr_lvalue_ind.
    - inversion 1; expr_determ_solve.
    - inversion 1; expr_determ_solve.
    - inversion 1; expr_determ_solve.
    - inversion 1; expr_determ_solve.
    - inversion 2; expr_determ_solve.
    - intros. inversion H1; expr_determ_solve.
    - intros. inversion H2; expr_determ_solve.
    - intros. inversion H4; expr_determ_solve.
    - intros. inversion H2; expr_determ_solve.
    - inversion 1; expr_determ_solve.
    - inversion 1; expr_determ_solve.
    - intros. inversion H2; subst; try easy.
      exploit H0. exact H3.
      intros [<- <-].
      determ_solve deref_loc_determ.
    - inversion 2; expr_determ_solve.
    - inversion 3; expr_determ_solve.
    - inversion 3; expr_determ_solve.
    - intros. inversion H4; expr_determ_solve.
    - intros. inversion H3; expr_determ_solve.
  Qed.

  Lemma eval_expr_determ:
    forall a v1,
      Clight.eval_expr ge e le m a v1 ->
        forall v2,
          Clight.eval_expr ge e le m a v2 ->
          v1 = v2.
  Proof.
    intros. eapply expr_determ; eauto.
  Qed.

  Lemma eval_lvalue_determ:
    forall a b1 ofs1,
      Clight.eval_lvalue ge e le m a b1 ofs1 ->
      forall b2 ofs2,
        Clight.eval_lvalue ge e le m a b2 ofs2 ->
        b1 = b2 /\ ofs1 = ofs2.
  Proof.
    intros. eapply expr_determ; eauto.
  Qed.

  Lemma eval_exprlist_determ es ty vs1 vs2:
    Clight.eval_exprlist ge e le m es ty vs1 ->
    Clight.eval_exprlist ge e le m es ty vs2 ->
    vs1 = vs2.
  Proof.
    intros eval1. revert vs2.
    induction eval1.
    - inversion 1. auto.
    - intros vs2 eval2.
      inversion eval2; subst.
      determ_solve eval_expr_determ.
      exploit IHeval1.
      exact H8. congruence.
  Qed.
End EXPR_DETERM.

Lemma assign_loc_determ ge t m loc ofs v m1 m2:
    Clight.assign_loc ge t m loc ofs v m1 ->
    Clight.assign_loc ge t m loc ofs v m2 ->
    m1 = m2.
Proof.
  inversion 1; inversion 1; congruence.
Qed.

Lemma alloc_variables_determ ge e m vars e1 e2 m1 m2:
    Clight.alloc_variables ge e m vars e1 m1 ->
    Clight.alloc_variables ge e m vars e2 m2 ->
    e1 = e2 /\ m1 = m2.
Proof.
  intros alloc1. revert e2 m2.
  induction alloc1.
  - inversion 1. auto.
  - inversion 1; subst.
    rewrite H in H8. injection H8. intros <- <-.
    exploit IHalloc1. exact H9. auto.
Qed.

Lemma bind_parameters_determ ge e m params vargs m1 m2:
  Clight.bind_parameters ge e m params vargs m1 ->
  Clight.bind_parameters ge e m params vargs m2 ->
  m1 = m2.
Proof.
  intros bind1. revert m2.
  induction bind1.
  - inversion 1. auto.
  - inversion 1; subst.
    assert (b = b0) by congruence. subst.
    determ_solve assign_loc_determ.
    exploit IHbind1. exact H11. auto.
Qed.

Lemma func_entry1_determ ge f vargs m e1 le1 m1 e2 le2 m2:
  Clight.function_entry1 ge f vargs m e1 le1 m1 ->
  Clight.function_entry1 ge f vargs m e2 le2 m2 ->
  e1 = e2 /\ le1 = le2 /\ m1 = m2.
Proof.
  inversion 1. inversion 1.
  determ_solve alloc_variables_determ.
  firstorder. congruence.
  determ_solve bind_parameters_determ.
Qed.

Ltac false_solve :=
  match goal with
  | [ H : _ \/ _ |- _ ] => inversion H; easy
  | _ => idtac
  end.

Hint Constructors match_traces.
Ltac autoc := auto || congruence || easy.

Lemma step_determ p se s t1 s1 t2 s2:
  Step ((Clight.semantics1 p) se) s t1 s1 ->
  Step ((Clight.semantics1 p) se) s t2 s2 ->
  match_traces se t1 t2 /\ (t1 = t2 -> s1 = s2).
Proof.
  intros step1 step2.
  inversion step1; subst;
    inversion step2; subst; false_solve;
      try (split; autoc).
  + determ_solve eval_expr_determ.
    determ_solve eval_lvalue_determ.
    assert (v = v1) as <- by congruence.
    determ_solve assign_loc_determ.
    split; autoc.
  + determ_solve eval_expr_determ.
    split; auto.
  + determ_solve eval_expr_determ.
    assert (tyargs0 = tyargs) by congruence. subst.
    determ_solve eval_exprlist_determ.
    split; auto.
  + determ_solve eval_exprlist_determ.
    determ_solve external_call_determ.
    split. apply H1.
    intros. exploit (proj2 H1).
    auto. intros [<- <-]. auto.
  + determ_solve eval_expr_determ.
    split. auto.
    assert (b = b0) by congruence. subst; auto.
  + split; try autoc.
    determ_solve eval_expr_determ. autoc.
  + determ_solve eval_expr_determ. split; autoc.
  + assert (f = f0) by congruence. subst.
    determ_solve func_entry1_determ.
    split; autoc.
  + assert (ef = ef0) by congruence. subst.
    determ_solve external_call_determ.
    split. apply H0.
    intros. exploit (proj2 H0). auto.
    intros [<- <-]. auto.
Qed.

Lemma clight_single_event p se:
  single_events ((Clight.semantics1 p) se).
Proof.
  unfold single_events. intros.
  inversion H; auto; eapply external_call_trace_length; eauto.
Qed.

Hint Unfold globalenv.
Hint Unfold Clight.globalenv.

Lemma clight_determinate p :
  determinate (Clight.semantics1 p).
Proof.
  split.
  - apply step_determ.
  - apply clight_single_event.
  - inversion 1; inversion 1; congruence.
  - inversion 1.
    replace (Clight.globalenv se p) with (globalenv ((Clight.semantics1 p) se)) in H0 by auto.
    inversion 1; subst; rewrite H0 in FIND; subst f.
    + easy.
    + injection FIND. intros <- <- <- <-.
      easy.
  - inversion 1; inversion 1; subst. f_equal.
    assert (f = f0) by congruence.
    subst f f0. congruence.
  - inversion 1; inversion 1; subst. auto.
  - inversion 1; inversion 1.
  - inversion 1; inversion 1.
  - inversion 1; inversion 1; subst. auto.
Qed.

(** *** Coherence space Clight semantics *)

Definition clight (p : Clight.program) se : !li_c --o li_c :=
  compcerto_lmap (Clight.semantics1 p) (clight_determinate p) se.

(** ** Soundness of forward simulations *)

(** Since for now, our model doesn't support abstraction, we can only
  consider simulations which use the [cc_id] simulation convention. *)

Section FSIM.
  Context {liA liB} (L1 L2 : semantics liA liB).
  Context (H1 : determinate L1).
  Context (H2 : determinate L2).
  Context (FSIM : forward_simulation 1 1 L1 L2).
  Context (se : Genv.symtbl) (Hse : Genv.valid_for (skel L1) se).

  (** XXX: we need a notion of refinement on linear maps themselves,
    or perhaps just define linear maps as cliques in the function
    space. *)

  Lemma fsim_sound :
    ref (compcerto_lmap L1 H1 se) (compcerto_lmap L2 H2 se).
  Proof.
    intros [t u] Ht. cbn in *.
    destruct FSIM as [[ind ord match_states _ H _]]. cbn in *.
    specialize (H se se tt eq_refl Hse).
    destruct Ht as [q s1 t1 r Hq1 Hs1 Ht1].
    edestruct @fsim_match_initial_states as (i & s2 & Hs2 & Hs);
      eauto; try reflexivity.
    econstructor.
    - erewrite fsim_match_valid_query; eauto. reflexivity.
    - eauto.
    - clear - H Hs Ht1. revert i s2 Hs.
      induction Ht1; cbn; intros.
      + (* final state *)
        edestruct @fsim_match_final_states as (xr & Hs2 & Hxr); eauto.
        destruct Hxr.
        constructor; auto.
      + (* step *)
        edestruct @simulation_star as (j & s2' & Hs2' & Hs'); eauto using star_one.
        revert Hs'. pattern s2, s2'.
        eapply star_E0_ind; eauto using lts_trace_step.
      + (* external interaction *)
        edestruct @fsim_match_external as (w & xq & Hq2 & Hxq & _ & Hrx); eauto.
        destruct Hxq.
        edestruct Hrx as (j & s2' & Hs2' & Hs'); cbn; eauto using lts_trace_external.
  Qed.
End FSIM.