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

(** Correctness of instruction selection for 64-bit integer operations *)

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

Local Open Scope cminorsel_scope.
Local Open Scope string_scope.

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

Section CMCONSTR.
Context mem `{external_calls_prf: ExternalCalls mem}.
Context `{i64_helpers_correct_prf: !I64HelpersCorrect mem}.

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

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

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

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

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

Theorem eval_longconst:
  forall le n, eval_expr ge sp e m le (longconst n) (Vlong n).
Proof.
  unfold longconst; intros; destruct Archi.splitlong.
  apply SplitLongproof.eval_longconst.
  EvalOp.
Qed.

Lemma is_longconst_sound:
  forall v a n le,
  is_longconst a = Some n -> eval_expr ge sp e m le a v -> v = Vlong n.
Proof with (try discriminate).
  intros. unfold is_longconst in *. destruct Archi.splitlong.
  eapply SplitLongproof.is_longconst_sound; eauto.
  assert (a = Eop (Olongconst n) Enil).
  { destruct a... destruct o... destruct e0... congruence. }
  subst a. InvEval. auto.
Qed.

Theorem eval_intoflong: unary_constructor_sound intoflong Val.loword.
Proof.
  unfold intoflong; destruct Archi.splitlong. apply SplitLongproof.eval_intoflong.
  red; intros. destruct (is_longconst a) as [n|] eqn:C.
- TrivialExists. simpl. erewrite (is_longconst_sound x) by eauto. auto.
- TrivialExists.
Qed.

Theorem eval_longofintu: unary_constructor_sound longofintu Val.longofintu.
Proof.
  unfold longofintu; destruct Archi.splitlong. apply SplitLongproof.eval_longofintu.
  red; intros. destruct (is_intconst a) as [n|] eqn:C.
- econstructor; split. apply eval_longconst.
  exploit is_intconst_sound; eauto. intros; subst x. auto.
- TrivialExists.
Qed.

Theorem eval_longofint: unary_constructor_sound longofint Val.longofint.
Proof.
  unfold longofint; destruct Archi.splitlong. apply SplitLongproof.eval_longofint.
  red; intros. destruct (is_intconst a) as [n|] eqn:C.
- econstructor; split. apply eval_longconst.
  exploit is_intconst_sound; eauto. intros; subst x. auto.
- TrivialExists.
Qed.

Theorem eval_notl: unary_constructor_sound notl Val.notl.
Proof.
  unfold notl; destruct Archi.splitlong. apply SplitLongproof.eval_notl.
  red; intros. destruct (notl_match a).
- InvEval. econstructor; split. apply eval_longconst. auto.
- InvEval. subst. exists v1; split; auto. destruct v1; simpl; auto. rewrite Int64.not_involutive; auto.
- TrivialExists.
Qed.

Theorem eval_andlimm: forall n, unary_constructor_sound (andlimm n) (fun v => Val.andl v (Vlong n)).
Proof.
  unfold andlimm; intros; red; intros.
  predSpec Int64.eq Int64.eq_spec n Int64.zero.
  exists (Vlong Int64.zero); split. apply eval_longconst.
  subst. destruct x; simpl; auto. rewrite Int64.and_zero; auto.
  predSpec Int64.eq Int64.eq_spec n Int64.mone.
  exists x; split. assumption.
  subst. destruct x; simpl; auto. rewrite Int64.and_mone; auto.
  destruct (andlimm_match a); InvEval; subst.
- econstructor; split. apply eval_longconst. simpl. rewrite Int64.and_commut; auto.
- TrivialExists. simpl. rewrite Val.andl_assoc. rewrite Int64.and_commut; auto.
- TrivialExists.
Qed.

Theorem eval_andl: binary_constructor_sound andl Val.andl.
Proof.
  unfold andl; destruct Archi.splitlong. apply SplitLongproof.eval_andl.
  red; intros. destruct (andl_match a b).
- InvEval. rewrite Val.andl_commut. apply eval_andlimm; auto.
- InvEval. apply eval_andlimm; auto.
- TrivialExists.
Qed.

Theorem eval_orlimm: forall n, unary_constructor_sound (orlimm n) (fun v => Val.orl v (Vlong n)).
Proof.
  unfold orlimm; intros; red; intros.
  predSpec Int64.eq Int64.eq_spec n Int64.zero.
  exists x; split; auto. subst. destruct x; simpl; auto. rewrite Int64.or_zero; auto.
  predSpec Int64.eq Int64.eq_spec n Int64.mone.
  econstructor; split. apply eval_longconst. subst. destruct x; simpl; auto. rewrite Int64.or_mone; auto.
  destruct (orlimm_match a); InvEval; subst.
- econstructor; split. apply eval_longconst. simpl. rewrite Int64.or_commut; auto.
- TrivialExists. simpl. rewrite Val.orl_assoc. rewrite Int64.or_commut; auto.
- TrivialExists.
Qed.

Theorem eval_orl: binary_constructor_sound orl Val.orl.
Proof.
  unfold orl; destruct Archi.splitlong. apply SplitLongproof.eval_orl.
  red; intros.
  assert (DEFAULT: exists v, eval_expr ge sp e m le (Eop Oorl (a:::b:::Enil)) v /\ Val.lessdef (Val.orl x y) v) by TrivialExists.
  assert (ROR: forall v n1 n2,
    Int.add n1 n2 = Int64.iwordsize' ->
    Val.lessdef (Val.orl (Val.shll v (Vint n1)) (Val.shrlu v (Vint n2)))
                (Val.rorl v (Vint n2))).
  { intros. destruct v; simpl; auto.
    destruct (Int.ltu n1 Int64.iwordsize') eqn:N1; auto.
    destruct (Int.ltu n2 Int64.iwordsize') eqn:N2; auto.
    simpl. rewrite <- Int64.or_ror'; auto. }
  destruct (orl_match a b).
- InvEval. rewrite Val.orl_commut. apply eval_orlimm; auto.
- InvEval. apply eval_orlimm; auto.
- predSpec Int.eq Int.eq_spec (Int.add n1 n2) Int64.iwordsize'; auto.
  destruct (same_expr_pure t1 t2) eqn:?; auto.
  InvEval. exploit eval_same_expr; eauto. intros [EQ1 EQ2]; subst.
  exists (Val.rorl v0 (Vint n2)); split. EvalOp. apply ROR; auto.
- predSpec Int.eq Int.eq_spec (Int.add n1 n2) Int64.iwordsize'; auto.
  destruct (same_expr_pure t1 t2) eqn:?; auto.
  InvEval. exploit eval_same_expr; eauto. intros [EQ1 EQ2]; subst.
  exists (Val.rorl v1 (Vint n2)); split. EvalOp. rewrite Val.orl_commut. apply ROR; auto.
- apply DEFAULT.
Qed.

Theorem eval_xorlimm: forall n, unary_constructor_sound (xorlimm n) (fun v => Val.xorl v (Vlong n)).
Proof.
  unfold xorlimm; intros; red; intros.
  predSpec Int64.eq Int64.eq_spec n Int64.zero.
  exists x; split; auto. subst. destruct x; simpl; auto. rewrite Int64.xor_zero; auto.
  predSpec Int64.eq Int64.eq_spec n Int64.mone.
  replace (Val.xorl x (Vlong n)) with (Val.notl x). apply eval_notl; auto.
  subst n. destruct x; simpl; auto.
  destruct (xorlimm_match a); InvEval; subst.
- econstructor; split. apply eval_longconst. simpl. rewrite Int64.xor_commut; auto.
- TrivialExists. simpl. rewrite Val.xorl_assoc. rewrite Int64.xor_commut; auto.
- TrivialExists. simpl. destruct v1; simpl; auto. unfold Int64.not.
  rewrite Int64.xor_assoc. apply f_equal. apply f_equal. apply f_equal.
  apply Int64.xor_commut.
- TrivialExists.
Qed.

Theorem eval_xorl: binary_constructor_sound xorl Val.xorl.
Proof.
  unfold xorl; destruct Archi.splitlong. apply SplitLongproof.eval_xorl.
  red; intros. destruct (xorl_match a b).
- InvEval. rewrite Val.xorl_commut. apply eval_xorlimm; auto.
- InvEval. apply eval_xorlimm; auto.
- TrivialExists.
Qed.

Theorem eval_shllimm: forall n, unary_constructor_sound (fun e => shllimm e n) (fun v => Val.shll v (Vint n)).
Proof.
  intros; unfold shllimm. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shllimm; auto.
  red; intros.
  predSpec Int.eq Int.eq_spec n Int.zero.
  exists x; split; auto. subst n; destruct x; simpl; auto.
  destruct (Int.ltu Int.zero Int64.iwordsize'); auto.
  change (Int64.shl' i Int.zero) with (Int64.shl i Int64.zero). rewrite Int64.shl_zero; auto.
  destruct (Int.ltu n Int64.iwordsize') eqn:LT; simpl.
  assert (DEFAULT: exists v, eval_expr ge sp e m le (Eop (Oshllimm n) (a:::Enil)) v
                         /\  Val.lessdef (Val.shll x (Vint n)) v) by TrivialExists.
  destruct (shllimm_match a); InvEval.
- TrivialExists. simpl; rewrite LT; auto.
- destruct (Int.ltu (Int.add n n1) Int64.iwordsize') eqn:LT'; auto.
  subst. econstructor; split. EvalOp. simpl; eauto.
  destruct v1; simpl; auto. rewrite LT'.
  destruct (Int.ltu n1 Int64.iwordsize') eqn:LT1; auto.
  simpl; rewrite LT. rewrite Int.add_commut, Int64.shl'_shl'; auto. rewrite Int.add_commut; auto.
- destruct (shift_is_scale n); auto.
  TrivialExists. simpl. destruct v1; simpl; auto.
  rewrite LT. rewrite ! Int64.repr_unsigned. rewrite Int64.shl'_one_two_p.
  rewrite ! Int64.shl'_mul_two_p.  rewrite Int64.mul_add_distr_l. auto.
- destruct (shift_is_scale n); auto.
  TrivialExists. simpl. destruct x; simpl; auto.
  rewrite LT. rewrite ! Int64.repr_unsigned. rewrite Int64.shl'_one_two_p.
  rewrite ! Int64.shl'_mul_two_p. rewrite Int64.add_zero. auto.
- TrivialExists. constructor; eauto. constructor. EvalOp. simpl; eauto. constructor. auto.
Qed.

Theorem eval_shrluimm: forall n, unary_constructor_sound (fun e => shrluimm e n) (fun v => Val.shrlu v (Vint n)).
Proof.
  intros; unfold shrluimm. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shrluimm; auto.
  red; intros.
  predSpec Int.eq Int.eq_spec n Int.zero.
  exists x; split; auto. subst n; destruct x; simpl; auto.
  destruct (Int.ltu Int.zero Int64.iwordsize'); auto.
  change (Int64.shru' i Int.zero) with (Int64.shru i Int64.zero). rewrite Int64.shru_zero; auto.
  destruct (Int.ltu n Int64.iwordsize') eqn:LT; simpl.
  assert (DEFAULT: exists v, eval_expr ge sp e m le (Eop (Oshrluimm n) (a:::Enil)) v
                         /\  Val.lessdef (Val.shrlu x (Vint n)) v) by TrivialExists.
  destruct (shrluimm_match a); InvEval.
- TrivialExists. simpl; rewrite LT; auto.
- destruct (Int.ltu (Int.add n n1) Int64.iwordsize') eqn:LT'; auto.
  subst. econstructor; split. EvalOp. simpl; eauto.
  destruct v1; simpl; auto. rewrite LT'.
  destruct (Int.ltu n1 Int64.iwordsize') eqn:LT1; auto.
  simpl; rewrite LT. rewrite Int.add_commut, Int64.shru'_shru'; auto. rewrite Int.add_commut; auto.
- apply DEFAULT.
- TrivialExists. constructor; eauto. constructor. EvalOp. simpl; eauto. constructor. auto.
Qed.

Theorem eval_shrlimm: forall n, unary_constructor_sound (fun e => shrlimm e n) (fun v => Val.shrl v (Vint n)).
Proof.
  intros; unfold shrlimm. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shrlimm; auto.
  red; intros.
  predSpec Int.eq Int.eq_spec n Int.zero.
  exists x; split; auto. subst n; destruct x; simpl; auto.
  destruct (Int.ltu Int.zero Int64.iwordsize'); auto.
  change (Int64.shr' i Int.zero) with (Int64.shr i Int64.zero). rewrite Int64.shr_zero; auto.
  destruct (Int.ltu n Int64.iwordsize') eqn:LT; simpl.
  assert (DEFAULT: exists v, eval_expr ge sp e m le (Eop (Oshrlimm n) (a:::Enil)) v
                         /\  Val.lessdef (Val.shrl x (Vint n)) v) by TrivialExists.
  destruct (shrlimm_match a); InvEval.
- TrivialExists. simpl; rewrite LT; auto.
- destruct (Int.ltu (Int.add n n1) Int64.iwordsize') eqn:LT'; auto.
  subst. econstructor; split. EvalOp. simpl; eauto.
  destruct v1; simpl; auto. rewrite LT'.
  destruct (Int.ltu n1 Int64.iwordsize') eqn:LT1; auto.
  simpl; rewrite LT. rewrite Int.add_commut, Int64.shr'_shr'; auto. rewrite Int.add_commut; auto.
- apply DEFAULT.
- TrivialExists. constructor; eauto. constructor. EvalOp. simpl; eauto. constructor. auto.
Qed.

Theorem eval_shll: binary_constructor_sound shll Val.shll.
Proof.
  unfold shll. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shll; auto.
  red; intros. destruct (is_intconst b) as [n2|] eqn:C.
- exploit is_intconst_sound; eauto. intros EQ; subst y. apply eval_shllimm; auto.
- TrivialExists.
Qed.

Theorem eval_shrlu: binary_constructor_sound shrlu Val.shrlu.
Proof.
  unfold shrlu. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shrlu; auto.
  red; intros. destruct (is_intconst b) as [n2|] eqn:C.
- exploit is_intconst_sound; eauto. intros EQ; subst y. apply eval_shrluimm; auto.
- TrivialExists.
Qed.

Theorem eval_shrl: binary_constructor_sound shrl Val.shrl.
Proof.
  unfold shrl. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_shrl; auto.
  red; intros. destruct (is_intconst b) as [n2|] eqn:C.
- exploit is_intconst_sound; eauto. intros EQ; subst y. apply eval_shrlimm; auto.
- TrivialExists.
Qed.

Theorem eval_negl: unary_constructor_sound negl Val.negl.
Proof.
  unfold negl. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_negl; auto.
  red; intros. destruct (is_longconst a) as [n|] eqn:C.
- exploit is_longconst_sound; eauto. intros EQ; subst x.
  econstructor; split. apply eval_longconst. auto.
- TrivialExists.
Qed.

Theorem eval_addlimm: forall n, unary_constructor_sound (addlimm n) (fun v => Val.addl v (Vlong n)).
Proof.
  unfold addlimm; intros; red; intros.
  predSpec Int64.eq Int64.eq_spec n Int64.zero.
  subst. exists x; split; auto.
  destruct x; simpl; rewrite ?Int64.add_zero, ?Ptrofs.add_zero; auto.
  destruct (addlimm_match a); InvEval.
- econstructor; split. apply eval_longconst. rewrite Int64.add_commut; auto.
- inv H. simpl in H6. TrivialExists. simpl.
  erewrite eval_offset_addressing_total_64 by eauto. rewrite Int64.repr_signed; auto.
- TrivialExists. simpl. rewrite Int64.repr_signed; auto.
Qed.

Theorem eval_addl: binary_constructor_sound addl Val.addl.
Proof.
  assert (A: forall x y, Int64.repr (x + y) = Int64.add (Int64.repr x) (Int64.repr y)).
  { intros; apply Int64.eqm_samerepr; auto with ints. }
  assert (B: forall id ofs n, Archi.ptr64 = true ->
             Genv.symbol_address ge id (Ptrofs.add ofs (Ptrofs.repr n)) =
             Val.addl (Genv.symbol_address ge id ofs) (Vlong (Int64.repr n))).
  { intros. replace (Ptrofs.repr n) with (Ptrofs.of_int64 (Int64.repr n)) by auto with ptrofs.
    apply Genv.shift_symbol_address_64; auto. }
  unfold addl. destruct Archi.splitlong eqn:SL.
  apply SplitLongproof.eval_addl. eauto. apply Archi.splitlong_ptr32; auto.
  red; intros; destruct (addl_match a b); InvEval.
- rewrite Val.addl_commut. apply eval_addlimm; auto.
- apply eval_addlimm; auto.
- subst. TrivialExists. simpl. rewrite A, Val.addl_permut_4. auto.
- subst. TrivialExists. simpl. rewrite A, Val.addl_assoc. decEq; decEq. rewrite Val.addl_permut. auto.
- subst. TrivialExists. simpl. rewrite A, Val.addl_permut_4. rewrite <- Val.addl_permut. rewrite <- Val.addl_assoc. auto.
- subst. TrivialExists. simpl. rewrite Val.addl_commut; auto.
- subst. TrivialExists.
- subst. TrivialExists. simpl. rewrite ! Val.addl_assoc. rewrite (Val.addl_commut y). auto.
- subst. TrivialExists. simpl. rewrite ! Val.addl_assoc. auto.
- TrivialExists. simpl.
  unfold Val.addl. destruct Archi.ptr64, x, y; auto.
  + rewrite Int64.add_zero; auto.
  + rewrite Ptrofs.add_assoc, Ptrofs.add_zero. auto.
  + rewrite Ptrofs.add_assoc, Ptrofs.add_zero. auto.
  + rewrite Int64.add_zero; auto.
Qed.

Theorem eval_subl: binary_constructor_sound subl Val.subl.
Proof.
  unfold subl. destruct Archi.splitlong eqn:SL.
  apply SplitLongproof.eval_subl. eauto. apply Archi.splitlong_ptr32; auto.
  red; intros; destruct (subl_match a b); InvEval.
- rewrite Val.subl_addl_opp. apply eval_addlimm; auto.
- subst. rewrite Val.subl_addl_l. rewrite Val.subl_addl_r.
  rewrite Val.addl_assoc. simpl. rewrite Int64.add_commut. rewrite <- Int64.sub_add_opp.
  replace (Int64.repr (n1 - n2)) with (Int64.sub (Int64.repr n1) (Int64.repr n2)).
  apply eval_addlimm; EvalOp.
  apply Int64.eqm_samerepr; auto with ints.
- subst. rewrite Val.subl_addl_l. apply eval_addlimm; EvalOp.
- subst. rewrite Val.subl_addl_r.
  replace (Int64.repr (-n2)) with (Int64.neg (Int64.repr n2)).
  apply eval_addlimm; EvalOp.
  apply Int64.eqm_samerepr; auto with ints.
- TrivialExists.
Qed.

Theorem eval_mullimm_base: forall n, unary_constructor_sound (mullimm_base n) (fun v => Val.mull v (Vlong n)).
Proof.
  intros; unfold mullimm_base. red; intros.
  generalize (Int64.one_bits'_decomp n); intros D.
  destruct (Int64.one_bits' n) as [ | i [ | j [ | ? ? ]]] eqn:B.
- TrivialExists.
- replace (Val.mull x (Vlong n)) with (Val.shll x (Vint i)).
  apply eval_shllimm; auto.
  simpl in D. rewrite D, Int64.add_zero. destruct x; simpl; auto.
  rewrite (Int64.one_bits'_range n) by (rewrite B; auto with coqlib).
  rewrite Int64.shl'_mul; auto.
- set (le' := x :: le).
  assert (A0: eval_expr ge sp e m le' (Eletvar O) x) by (constructor; reflexivity).
  exploit (eval_shllimm i). eexact A0. intros (v1 & A1 & B1).
  exploit (eval_shllimm j). eexact A0. intros (v2 & A2 & B2).
  exploit (eval_addl). eexact A1. eexact A2. intros (v3 & A3 & B3).
  exists v3; split. econstructor; eauto.
  rewrite D. simpl. rewrite Int64.add_zero. destruct x; auto.
  simpl in *.
  rewrite (Int64.one_bits'_range n) in B1 by (rewrite B; auto with coqlib).
  rewrite (Int64.one_bits'_range n) in B2 by (rewrite B; auto with coqlib).
  inv B1; inv B2. simpl in B3; inv B3.
  rewrite Int64.mul_add_distr_r. rewrite <- ! Int64.shl'_mul. auto.
- TrivialExists.
Qed.

Theorem eval_mullimm: forall n, unary_constructor_sound (mullimm n) (fun v => Val.mull v (Vlong n)).
Proof.
  unfold mullimm. intros; red; intros.
  destruct Archi.splitlong eqn:SL.
  eapply SplitLongproof.eval_mullimm; eauto.
  predSpec Int64.eq Int64.eq_spec n Int64.zero.
  exists (Vlong Int64.zero); split. apply eval_longconst.
  destruct x; simpl; auto. subst n; rewrite Int64.mul_zero; auto.
  predSpec Int64.eq Int64.eq_spec n Int64.one.
  exists x; split; auto.
  destruct x; simpl; auto. subst n; rewrite Int64.mul_one; auto.
  destruct (mullimm_match a); InvEval.
- econstructor; split. apply eval_longconst. rewrite Int64.mul_commut; auto.
- exploit (eval_mullimm_base n); eauto. intros (v2 & A2 & B2).
  exploit (eval_addlimm (Int64.mul n (Int64.repr n2))). eexact A2. intros (v3 & A3 & B3).
  exists v3; split; auto.
  destruct v1; simpl; auto.
  simpl in B2; inv B2. simpl in B3; inv B3. rewrite Int64.mul_add_distr_l.
  rewrite (Int64.mul_commut n). auto.
- apply eval_mullimm_base; auto.
Qed.

Theorem eval_mull: binary_constructor_sound mull Val.mull.
Proof.
  unfold mull. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_mull; auto.
  red; intros; destruct (mull_match a b); InvEval.
- rewrite Val.mull_commut. apply eval_mullimm; auto.
- apply eval_mullimm; auto.
- TrivialExists.
Qed.

Theorem eval_mullhu:
  forall n, unary_constructor_sound (fun a => mullhu a n) (fun v => Val.mullhu v (Vlong n)).
Proof.
  unfold mullhu; intros. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_mullhu; auto.
  red; intros. TrivialExists. constructor. eauto. constructor. apply eval_longconst. constructor. auto.
Qed.

Theorem eval_mullhs:
  forall n, unary_constructor_sound (fun a => mullhs a n) (fun v => Val.mullhs v (Vlong n)).
Proof.
  unfold mullhs; intros. destruct Archi.splitlong eqn:SL. apply SplitLongproof.eval_mullhs; auto.
  red; intros. TrivialExists. constructor. eauto. constructor. apply eval_longconst. constructor. auto.
Qed.

Theorem eval_shrxlimm:
  forall le a n x z,
  eval_expr ge sp e m le a x ->
  Val.shrxl x (Vint n) = Some z ->
  exists v, eval_expr ge sp e m le (shrxlimm a n) v /\ Val.lessdef z v.
Proof.
  unfold shrxlimm; intros. destruct Archi.splitlong eqn:SL.
+ eapply SplitLongproof.eval_shrxlimm; eauto using Archi.splitlong_ptr32.
+ predSpec Int.eq Int.eq_spec n Int.zero.
- subst n. destruct x; simpl in H0; inv H0. econstructor; split; eauto.
  change (Int.ltu Int.zero (Int.repr 63)) with true. simpl. rewrite Int64.shrx'_zero; auto.
- TrivialExists.
Qed.

Theorem eval_divls_base: partial_binary_constructor_sound divls_base Val.divls.
Proof.
  unfold divls_base; red; intros. destruct Archi.splitlong eqn:SL.
  eapply SplitLongproof.eval_divls_base; eauto.
  TrivialExists.
Qed.

Theorem eval_modls_base: partial_binary_constructor_sound modls_base Val.modls.
Proof.
  unfold modls_base; red; intros. destruct Archi.splitlong eqn:SL.
  eapply SplitLongproof.eval_modls_base; eauto.
  TrivialExists.
Qed.

Theorem eval_divlu_base: partial_binary_constructor_sound divlu_base Val.divlu.
Proof.
  unfold divlu_base; red; intros. destruct Archi.splitlong eqn:SL.
  eapply SplitLongproof.eval_divlu_base; eauto.
  TrivialExists.
Qed.

Theorem eval_modlu_base: partial_binary_constructor_sound modlu_base Val.modlu.
Proof.
  unfold modlu_base; red; intros. destruct Archi.splitlong eqn:SL.
  eapply SplitLongproof.eval_modlu_base; eauto.
  TrivialExists.
Qed.

Theorem eval_cmplu:
  forall c le a x b y v,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  Val.cmplu (Mem.valid_pointer m) c x y = Some v ->
  eval_expr ge sp e m le (cmplu c a b) v.
Proof.
  unfold cmplu; intros. destruct Archi.splitlong eqn:SL.
  eapply SplitLongproof.eval_cmplu; eauto using Archi.splitlong_ptr32.
  unfold Val.cmplu in H1.
  destruct (Val.cmplu_bool (Mem.valid_pointer m) c x y) as [vb|] eqn:C; simpl in H1; inv H1.
  destruct (is_longconst a) as [n1|] eqn:LC1; destruct (is_longconst b) as [n2|] eqn:LC2;
  try (assert (x = Vlong n1) by (eapply is_longconst_sound; eauto));
  try (assert (y = Vlong n2) by (eapply is_longconst_sound; eauto));
  subst.
- simpl in C; inv C. EvalOp. destruct (Int64.cmpu c n1 n2); reflexivity.
- EvalOp. simpl. rewrite Val.swap_cmplu_bool. rewrite C; auto.
- EvalOp. simpl; rewrite C; auto.
- EvalOp. simpl; rewrite C; auto.
Qed.

Theorem eval_cmpl:
  forall c le a x b y v,
  eval_expr ge sp e m le a x ->
  eval_expr ge sp e m le b y ->
  Val.cmpl c x y = Some v ->
  eval_expr ge sp e m le (cmpl c a b) v.
Proof.
  unfold cmpl; intros. destruct Archi.splitlong eqn:SL.
  eapply SplitLongproof.eval_cmpl; eauto.
  unfold Val.cmpl in H1.
  destruct (Val.cmpl_bool c x y) as [vb|] eqn:C; simpl in H1; inv H1.
  destruct (is_longconst a) as [n1|] eqn:LC1; destruct (is_longconst b) as [n2|] eqn:LC2;
  try (assert (x = Vlong n1) by (eapply is_longconst_sound; eauto));
  try (assert (y = Vlong n2) by (eapply is_longconst_sound; eauto));
  subst.
- simpl in C; inv C. EvalOp. destruct (Int64.cmp c n1 n2); reflexivity.
- EvalOp. simpl. rewrite Val.swap_cmpl_bool. rewrite C; auto.
- EvalOp. simpl; rewrite C; auto.
- EvalOp. simpl; rewrite C; auto.
Qed.

Theorem eval_longoffloat: partial_unary_constructor_sound longoffloat Val.longoffloat.
Proof.
  unfold longoffloat; red; intros. destruct Archi.splitlong eqn:SL.
  eapply SplitLongproof.eval_longoffloat; eauto.
  TrivialExists.
Qed.

Theorem eval_floatoflong: partial_unary_constructor_sound floatoflong Val.floatoflong.
Proof.
  unfold floatoflong; red; intros. destruct Archi.splitlong eqn:SL.
  eapply SplitLongproof.eval_floatoflong; eauto.
  TrivialExists.
Qed.

Theorem eval_longofsingle: partial_unary_constructor_sound longofsingle Val.longofsingle.
Proof.
  unfold longofsingle; red; intros. destruct Archi.splitlong eqn:SL.
  eapply SplitLongproof.eval_longofsingle; eauto.
  TrivialExists.
Qed.

Theorem eval_singleoflong: partial_unary_constructor_sound singleoflong Val.singleoflong.
Proof.
  unfold singleoflong; red; intros. destruct Archi.splitlong eqn:SL.
  eapply SplitLongproof.eval_singleoflong; eauto.
  TrivialExists.
Qed.

End CMCONSTR.


Require Import oeuf.Common oeuf.Monads.
Require Import oeuf.Metadata.
Require String.
Require Import oeuf.ListLemmas.
Require Import oeuf.StepLib.
Require Import oeuf.HigherValue.

Require Import Psatz.

Require oeuf.ElimFunc4.
Require oeuf.SelfClose.

Module A := ElimFunc4.
Module B := SelfClose.

Definition compile :=
    let fix go e :=
        let fix go_list es :=
            match es with
            | [] => []
            | e :: es => go e :: go_list es
            end in
        match e with
        | A.Value v => B.Value v
        | A.Arg => B.Arg
        | A.UpVar n => B.Deref B.Self n
        | A.Deref e off => B.Deref (go e) off
        | A.Call f a => B.Call (go f) (go a)
        | A.MkConstr tag args => B.MkConstr tag (go_list args)
        | A.Elim loop cases target => B.Elim (go loop) (go_list cases) (go target)
        | A.MkClose fname free => B.MkClose fname (go_list free)
        | A.OpaqueOp op args => B.OpaqueOp op (go_list args)
        end in go.

Definition compile_list :=
    let go := compile in
    let fix go_list es :=
        match es with
        | [] => []
        | e :: es => go e :: go_list es
        end in go_list.

Ltac refold_compile :=
    fold compile_list in *.

Definition compile_cu (cu : list A.expr * list metadata) : list B.expr * list metadata :=
    let '(exprs, metas) := cu in
    let exprs' := compile_list exprs in
    (exprs', metas).

Lemma compile_list_Forall : forall aes bes,
    compile_list aes = bes ->
    Forall2 (fun a b => compile a = b) aes bes.
induction aes; destruct bes; intros0 Hcomp; simpl in Hcomp; try discriminate.
- constructor.
- invc Hcomp. eauto.
Qed.

Lemma compile_list_length : forall es,
    length (compile_list es) = length es.
intros. induction es.
- reflexivity.
- simpl. f_equal. eauto.
Qed.

Inductive I_expr : A.expr -> B.expr -> Prop :=
| IArg : I_expr A.Arg B.Arg
| IUpVar : forall n,
        I_expr (A.UpVar n)
               (B.Deref B.Self n)
| IDeref : forall ae be off,
        I_expr ae be ->
        I_expr (A.Deref ae off)
               (B.Deref be off)
| ICall : forall af aa bf ba,
        I_expr af bf ->
        I_expr aa ba ->
        I_expr (A.Call af aa) (B.Call bf ba)
| IConstr : forall tag aargs bargs,
        Forall2 I_expr aargs bargs ->
        I_expr (A.MkConstr tag aargs) (B.MkConstr tag bargs)
| IElim : forall aloop bloop acases bcases atarget btarget,
        I_expr aloop bloop ->
        Forall2 I_expr acases bcases ->
        I_expr atarget btarget ->
        I_expr (A.Elim aloop acases atarget) (B.Elim bloop bcases btarget)
| IClose : forall fname afree bfree,
        Forall2 (I_expr) afree bfree ->
        I_expr (A.MkClose fname afree) (B.MkClose fname bfree)
| IValue : forall v,
        I_expr (A.Value v) (B.Value v)
| IOpaqueOp : forall op aargs bargs,
        Forall2 I_expr aargs bargs ->
        I_expr (A.OpaqueOp op aargs) (B.OpaqueOp op bargs)
.

Inductive I : A.state -> B.state -> Prop :=
| IRun : forall ae al ak be ba fname free bk,
        I_expr ae be -> (* current expressions match *)
        al = (ba :: free) -> (* arg and local environments match *)
        (forall v, (* closures match when given a value *)
            I (ak v) (bk v)) ->
        I (A.Run ae al ak) (B.Run be ba (Close fname free) bk)

| IStop : forall v,
        I (A.Stop v) (B.Stop v).

Lemma I_expr_value : forall a b,
    I_expr a b ->
    A.is_value a ->
    B.is_value b.
induction a using A.expr_ind'; intros0 II Aval; invc Aval; invc II.
- constructor.
Qed.
Hint Resolve I_expr_value.

Lemma I_expr_value' : forall b a,
    I_expr a b ->
    B.is_value b ->
    A.is_value a.
induction b using B.expr_ind'; intros0 II Bval; invc Bval; invc II.
- constructor.
Qed.

Lemma I_expr_not_value : forall a b,
    I_expr a b ->
    ~A.is_value a ->
    ~B.is_value b.
intros. intro. fwd eapply I_expr_value'; eauto.
Qed.
Hint Resolve I_expr_not_value.

Lemma I_expr_not_value' : forall a b,
    I_expr a b ->
    ~B.is_value b ->
    ~A.is_value a.
intros. intro. fwd eapply I_expr_value; eauto.
Qed.

Lemma Forall_I_expr_value : forall aes bes,
    Forall2 I_expr aes bes ->
    Forall A.is_value aes ->
    Forall B.is_value bes.
intros. list_magic_on (aes, (bes, tt)).
Qed.
Hint Resolve Forall_I_expr_value.

Lemma I_expr_map_value : forall vs bes,
    Forall2 I_expr (map A.Value vs) bes ->
    bes = map B.Value vs.
induction vs; intros0 II; invc II.
- reflexivity.
- simpl. f_equal.
  + on >I_expr, invc. reflexivity.
  + apply IHvs. eauto.
Qed.

Theorem compile_I_expr : forall ae be,
    compile ae = be ->
    I_expr ae be.
induction ae using A.expr_rect_mut with
    (Pl := fun aes => forall bes,
        compile_list aes = bes ->
        Forall2 I_expr aes bes);
intros0 Hcomp;
simpl in Hcomp; refold_compile; try rewrite <- Hcomp in *;
try solve [eauto | constructor; eauto].
Qed.

Ltac i_ctor := intros; constructor; eauto.
Ltac i_lem H := intros; eapply H; eauto.

Theorem I_sim : forall AE BE a a' b,
    compile_list AE = BE ->
    I a b ->
    A.sstep AE a a' ->
    exists b',
        B.splus BE b b' /\
        I a' b'.

destruct a as [ae al ak | ae];
intros0 Henv II Astep; [ | solve [invc Astep] ].

inv Astep; invc II; try on (I_expr _ _), invc.

- (* SArg *)
  eexists. split. eapply B.SPlusOne, B.SArg.
  simpl in *. inject_some. eauto.

- (* SUpVar *)
  eexists. split.
    { eapply B.SPlusCons. eapply B.SDerefStep. inversion 1.
      eapply B.SPlusCons. eapply B.SSelf.
      eapply B.SPlusOne.  eapply B.SDerefinateClose; eauto. }
  eauto.

- (* SDerefStep *)
  eexists. split. eapply B.SPlusOne, B.SDerefStep; eauto.
  i_ctor. i_ctor. i_ctor. i_ctor.

- (* SDerefinate *)
  on (I_expr (A.Value (Constr _ _)) _), invc.

  eexists. split. eapply B.SPlusOne, B.SDerefinateConstr; eauto.
  eauto.

- (* SCloseStep *)
  on _, invc_using Forall2_3part_inv.
  eexists. split. eapply B.SPlusOne, B.SCloseStep; eauto.
  i_ctor. i_ctor. i_ctor.
  i_lem Forall2_app. i_lem Forall2_app. i_ctor. i_ctor.

- (* SCloseDone *)
  fwd i_lem I_expr_map_value. subst.
  eexists. split. eapply B.SPlusOne, B.SCloseDone; eauto.
  eauto.

- (* SConstrStep *)
  on _, invc_using Forall2_3part_inv.
  eexists. split. eapply B.SPlusOne, B.SConstrStep; eauto.
  i_ctor. i_ctor. i_ctor.
  i_lem Forall2_app. i_lem Forall2_app. i_ctor. i_ctor.

- (* SConstrDone *)
  fwd i_lem I_expr_map_value. subst.
  eexists. split. eapply B.SPlusOne, B.SConstrDone; eauto.
  eauto.

- (* SOpaqueOpStep *)
  on _, invc_using Forall2_3part_inv.
  eexists. split. eapply B.SPlusOne, B.SOpaqueOpStep; eauto.
  i_ctor. i_ctor. i_ctor.
  i_lem Forall2_app. i_lem Forall2_app. i_ctor. i_ctor.

- (* SOpaqueOpDone *)
  fwd i_lem I_expr_map_value. subst.
  eexists. split. eapply B.SPlusOne, B.SOpaqueOpDone; eauto.
  eauto.

- (* SCallL *)
  eexists. split. eapply B.SPlusOne, B.SCallL; eauto.
  i_ctor. i_ctor. i_ctor. i_ctor.

- (* SCallR *)
  eexists. split. eapply B.SPlusOne, B.SCallR; eauto.
  i_ctor. i_ctor. i_ctor. i_ctor.

- (* SMakeCall *)
  on (I_expr (A.Value (Close _ _)) _), invc.

  fwd eapply Forall2_nth_error_ex with (xs := AE) (ys := compile_list AE); eauto.
    { eapply compile_list_Forall. reflexivity. }
    break_exists. break_and.
  eexists. split.
  eapply B.SPlusOne.
  on (I_expr _ _ ), invc.
  try eapply B.SMakeCall; eauto using compile_I_expr.
  i_ctor.
  eauto using compile_I_expr.

- (* SElimStepLoop *)
  eexists. split. eapply B.SPlusOne. i_lem B.SElimStepLoop.
  i_ctor. i_ctor. i_ctor. i_ctor.

- (* SElimStep *)
  eexists. split. eapply B.SPlusOne. i_lem B.SElimStep.
  i_ctor. i_ctor. i_ctor. i_ctor.

- (* SEliminate *)
  fwd i_lem Forall2_nth_error_ex as HH. destruct HH as (bcase & ? & ?).
  on (I_expr (A.Value _) _), invc.

  eexists. split. eapply B.SPlusOne. i_lem B.SEliminate.
  i_ctor. i_ctor; i_ctor.
Qed.

Lemma compile_cu_Forall : forall A Ameta B Bmeta,
    compile_cu (A, Ameta) = (B, Bmeta) ->
    Forall2 (fun a b => compile a = b) A B.
intros. simpl in *. inject_pair.
eapply compile_list_Forall. auto.
Qed.

Lemma compile_cu_metas : forall A Ameta B Bmeta,
    compile_cu (A, Ameta) = (B, Bmeta) ->
    Ameta = Bmeta.
simpl. inversion 1. break_bind_option. inject_some. auto.
Qed.

Require oeuf.Semantics.

Section Preservation.

  Variable prog : A.prog_type.
  Variable tprog : B.prog_type.

  Hypothesis TRANSF : compile_cu prog = tprog.

  Theorem fsim :
    Semantics.forward_simulation (A.semantics prog) (B.semantics tprog).
  Proof.
    destruct prog as [A Ameta], tprog as [B Bmeta].
    fwd eapply compile_cu_Forall; eauto.
    fwd eapply compile_cu_metas; eauto.

    eapply Semantics.forward_simulation_plus with
        (match_states := I)
        (match_values := @eq value).

    - simpl. intros. on >B.is_callstate, invc. simpl in *.
        destruct ltac:(i_lem Forall2_nth_error_ex') as (abody & ? & ?).
      eexists. split. 1: econstructor. all: eauto.
      + i_lem compile_I_expr.
      + i_ctor.
      + i_ctor.

    - intros0 II Afinal. invc Afinal. invc II.
      eexists; split; eauto.
      i_ctor.

    - simpl. eauto.
    - simpl. intros. tauto.

    - intros0 Astep. intros0 II.
      eapply splus_semantics_sim, I_sim; try eassumption.
      simpl. simpl in TRANSF. congruence.

  Qed.

End Preservation.


(** In this file, we repackage an instance for
[compcert.backend.ValueDomain.MMatch] for the concrete memory
model implemented in [compcertx.common.MemimplX].

Indeed, those two memory models are different as they use different
implementations of [inject_neutral].

Fortunately, [MMatch] does not use [inject_neutral], so we have nothing to prove. We just need to unpack/repack.
*)

Require compcert.backend.ValueDomainImpl.
Require MemimplX.

Import Coqlib.
Export ValueDomain.
Export MemimplX.
Import ValueDomainImpl.

Lemma mmatch_inj:
   forall (bc : block_classification) (m : Memimpl.mem) (am : amem),
   ValueDomain.mmatch bc m am ->
   bc_below bc (Mem.nextblock m) -> Mem.inject (inj_of_bc bc) m m.
Proof.
  intros. eapply ValueDomainImpl.mmatch_inj; eauto.
  instantiate (1 := am). inversion H; constructor; auto.
Qed.

Global Instance mmatch_prf: MMatch Memimpl.mem (memory_model_ops := MemimplX.memory_model_ops).
Proof.
  econstructor.
  exact mmatch_stack.
  exact mmatch_glob.
  exact mmatch_nonstack.
  exact mmatch_top.
  exact mmatch_below.
  exact load_sound.
  exact store_sound.
  exact loadbytes_sound.
  exact storebytes_sound.
  exact mmatch_ext.
  exact mmatch_free.
  exact mmatch_top'.
  exact mbeq_sound.
  exact mmatch_lub_l.
  exact mmatch_lub_r.
  exact mmatch_inj.
  exact mmatch_inj_top.
Qed.


Require Import SyntaxProp.
Require Import StaticProp.
Require Import DynamicProp.
Require Import WellFormednessProp.

Lemma actor_progress :
  forall M H n l L C Q e id,
    wf_cfg (M, H, n) ->
    wf_actor M H id (l, L, C, Q, e) ->
    id < length H ->
    (exists M' H' n' e', id / (M, H, n) ; e ==> (M', H', n') ; e') \/ is_val e.
Proof with eauto 6 using is_val, step_actor, is_econtext.
  introv wfCfg wfActor Hlt.
  assert (exists t, empty |- e \in t) as [t hasType].
    inv wfActor...
  remember empty as Gamma.
  hasType_cases(induction hasType) Case; subst...
  + Case "T_Var".
    inv Hlookup.
  + Case "T_AtStart".
    eapply wf_actor_ctx with (ctx := ctx_atstart) in wfActor as wfActor'...
    crush.
    - eapply EvalContext in H0...
    - left. destruct a; inv Hactive.
      * SCase "Actor".
        inv H0; try solve[inv hasType].
        find_actor id. remember (C0 id0) as conv...
        symmetry in Heqconv. destruct conv.
        ++ repeat eexists. eapply EvalAtomicStartActorFail...
        ++ assert (id0 < length H) as Hlt
               by (inv wfActor; simpls; eauto).
           find_actor id0. heap_case id id0.
           -- repeat eexists. eapply EvalAtomicStartActor; hauto.
           -- repeat eexists. eapply EvalAtomicStartActor...
              rewrite lookup_heapUpdate_neq...
      * SCase "Bestowed".
        inv H0; try solve[inv hasType].
        find_actor id. remember (C0 id0) as conv...
        symmetry in Heqconv. destruct conv.
        ++ repeat eexists. eapply EvalAtomicStartBestowedFail...
        ++ assert (id0 < length H) as Hlt.
             inv wfActor. simpls. specializes H13 l0 id0 ___.
             find_actor id0. heap_case id id0.
           -- repeat eexists. eapply EvalAtomicStartBestowed; hauto.
           -- repeat eexists. eapply EvalAtomicStartBestowed...
              rewrite lookup_heapUpdate_neq...
  + Case "T_AtEnd".
    eapply wf_actor_ctx with (ctx := ctx_atend) in wfActor as wfActor'...
    crush.
    - eapply EvalContext in H0...
    - left. destruct a; inv Hactive.
      * SCase "Actor".
        inv H0; try solve[inv hasType].
        find_actor id. remember (C0 id0) as conv...
        symmetry in Heqconv. destruct conv.
        ++ inverts wfCfg as wfH _ _ _.
           inverts wfH as _ _ wfActors.
           eapply wfActors in Hlookup as wfActor''.
           inv wfActor''.
           assert (exists Q, M q = Some (Q, id0)) as [?Q HM]...
           repeat eexists. eapply EvalAtomicEndActor...
        ++ repeat eexists. eapply EvalAtomicEndActorFail...
      * SCase "Bestowed".
        inv H0; try solve[inv hasType].
        find_actor id. remember (C0 id0) as conv...
        symmetry in Heqconv. destruct conv.
        ++ inverts wfCfg as wfH _ _ _.
           inverts wfH as _ _ wfActors.
           eapply wfActors in Hlookup as wfActor''.
           inv wfActor''.
           assert (exists Q, M q = Some (Q, id0)) as [?Q HM]...
           repeat eexists. eapply EvalAtomicEndBestowed...
        ++ repeat eexists. eapply EvalAtomicEndBestowedFail...
  + Case "T_NewPassive".
    left. find_actor id...
  + Case "T_Mutate".
    apply wf_actor_ctx in wfActor...
    crush.
    - left...
    - inv H0; inv hasType...
  + Case "T_Bestow".
    apply wf_actor_ctx in wfActor...
    crush.
    - left...
    - inv H0; inv hasType...
  + Case "T_Apply".
    apply wf_actor_ctx with (ctx := ctx_appl e2) in wfActor as wfActor'...
    crush.
    - apply EvalContext with (ctx := ctx_appl e2) in H0...
    - apply wf_actor_ctx with (ctx := ctx_appr e1) in wfActor as wfActor''...
      crush.
      * apply EvalContext with (ctx := ctx_appr e1) in H1...
      * inv H0; try solve[inv hasType1]...
        constructors...
  + Case "T_Send".
    apply wf_actor_ctx with (ctx := ctx_send x TPas e') in wfActor as wfActor'...
    crush.
    - apply EvalContext with (ctx := ctx_send x TPas e') in H1...
    - left. unfold is_active in Hactive.
      destruct a; inv Hactive.
      * SCase "ActorSend".
        inv H1; try solve[inv hasType1]...
        inv wfActor'. simpls.
        find_actor id.
        remember (C0 id0) as conv.
        symmetry in Heqconv.
        destruct conv.
        ++ SSCase "Atomic".
           inverts wfCfg as wfH _ _ _.
           inverts wfH as _ _ wfActors.
           eapply wfActors in Hlookup as wfActor''.
           inv wfActor''.
           assert (exists Q, M q = Some (Q, id0)) as [?Q HM]...
           repeat eexists. eapply EvalSendActorAtomic; hauto.
        ++ SSCase "Regular".
           assert (id0 < length H) as Hlt'...
           find_actor id0...
           repeat eexists... eapply EvalSendActor; hauto.
      * SCase "BestowedSend".
        inv H1; try solve[inv hasType1]...
        inv wfActor'. simpls.
        find_actor id.
        remember (C0 id0) as conv.
        symmetry in Heqconv.
        destruct conv.
        ++ SSCase "Atomic".
           inverts wfCfg as wfH _ _ _.
           inverts wfH as _ _ wfActors.
           eapply wfActors in Hlookup as wfActor''.
           inv wfActor''.
           assert (exists Q, M q = Some (Q, id0)) as [?Q HM]...
           repeat eexists. eapply EvalSendBestowedAtomic; hauto.
        ++ SSCase "Regular".
           assert (id0 < length H) as Hlt' by
             specializes H14 l0 id0 ___.
           find_actor id0...
           repeat eexists... eapply EvalSendBestowed; hauto.
Qed.

Theorem progress :
  forall M H n id,
    wf_cfg (M, H, n) ->
    id < length H ->
    (exists cfg', step id (M, H, n) cfg') \/ actor_done (M, H, n) id.
Proof with eauto using step, step_preserves_this.
  introv wfCfg Hlt.
  assert (exists a, heapLookup H id = Some a) as [a Hlookup].
    apply heapLookup_lt in Hlt...
  destruct_actor a.
  assert (wf_actor M H id (l, L, C, Q, e)) as wfActor.
    inverts wfCfg as wfH _ _ _. inverts wfH as [_ _ wfActors]...
  assert (wf_queueMap M H) as wfM
    by (inv wfCfg; eauto).
  apply actor_progress with (l := l) (L := L) (C := C) (Q := Q) (e := e) (id := id) in wfCfg as Halt...
  inv Halt as [Hex | Hdone].
  + Case "e steps".
    left.
    inv Hex as [M' [H' [n' [e' Hstep]]]].
    assert (exists L' C' Q' e'', heapLookup H' id = Some (l, L', C', Q', e'')) as Hlookup'...
    destruct Hlookup' as [? [? [? [? ?]]]].
    eapply EvalActorRun in Hstep...
  + Case "is_val e".
    destruct Q.
    - SCase "Q empty".
      right.
      unfolds. rewrite Hlookup.
      constructors...
    - SCase "Q non-empty".
      destruct m.
      * SSCase "Regular message".
        left. eexists. eapply EvalActorMsg...
      * SSCase "Atomic".
        inverts wfActor as _ _ wfQueue.
        assert (wf_msg M H L id (Atomic q)) as wfMsg
            by (specializes wfQueue (Atomic q) ___; constructors; eauto).
        inverts wfMsg as HM. destruct Q0.
        ++ right... unfolds. hauto. constructors...
        ++ destruct m.
           -- left. eexists. eapply EvalActorPrivateMsg...
           -- eapply wfM in HM as [Hneq [Hend [?L wfQueue']]]; hauto.
              specializes Hneq (Atomic q0) q0 ___. constructors...
              contradiction.
           -- left. eexists... eapply EvalActorPrivateEnd...
      * SSCase "EndAtomic (absurd)".
        inverts wfActor as _ _ _ Hneq.
        specializes Hneq EndAtomic ___. constructors...
        contradiction.
Qed.


Require Export Program.Basics. Open Scope program_scope.
From Paco Require Import paco.
From Paco Require Import paconotation_internal paco_internal pacotac_internal.
From Paco Require Export paconotation.
From Fairness Require Import pind_internal.
Set Implicit Arguments.

Section PIND13.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.
Variable T2 : forall (x0: @T0) (x1: @T1 x0), Type.
Variable T3 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1), Type.
Variable T4 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2), Type.
Variable T5 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3), Type.
Variable T6 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4), Type.
Variable T7 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4) (x6: @T6 x0 x1 x2 x3 x4 x5), Type.
Variable T8 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4) (x6: @T6 x0 x1 x2 x3 x4 x5) (x7: @T7 x0 x1 x2 x3 x4 x5 x6), Type.
Variable T9 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4) (x6: @T6 x0 x1 x2 x3 x4 x5) (x7: @T7 x0 x1 x2 x3 x4 x5 x6) (x8: @T8 x0 x1 x2 x3 x4 x5 x6 x7), Type.
Variable T10 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4) (x6: @T6 x0 x1 x2 x3 x4 x5) (x7: @T7 x0 x1 x2 x3 x4 x5 x6) (x8: @T8 x0 x1 x2 x3 x4 x5 x6 x7) (x9: @T9 x0 x1 x2 x3 x4 x5 x6 x7 x8), Type.
Variable T11 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4) (x6: @T6 x0 x1 x2 x3 x4 x5) (x7: @T7 x0 x1 x2 x3 x4 x5 x6) (x8: @T8 x0 x1 x2 x3 x4 x5 x6 x7) (x9: @T9 x0 x1 x2 x3 x4 x5 x6 x7 x8) (x10: @T10 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9), Type.
Variable T12 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2) (x4: @T4 x0 x1 x2 x3) (x5: @T5 x0 x1 x2 x3 x4) (x6: @T6 x0 x1 x2 x3 x4 x5) (x7: @T7 x0 x1 x2 x3 x4 x5 x6) (x8: @T8 x0 x1 x2 x3 x4 x5 x6 x7) (x9: @T9 x0 x1 x2 x3 x4 x5 x6 x7 x8) (x10: @T10 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9) (x11: @T11 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10), Type.

(** ** Predicates of Arity 13
*)

Definition pind13(gf : rel13 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 T12 -> rel13 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 T12)(r: rel13 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 T12) : rel13 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 T12 :=
  @curry13 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 T12 (pind (fun R0 => @uncurry13 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 T12 (gf (@curry13 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 T12 R0))) (@uncurry13 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 T12 r)).

Definition upind13(gf : rel13 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 T12 -> rel13 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 T12)(r: rel13 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 T12) := pind13 gf r /13\ r.
Arguments pind13 : clear implicits.
Arguments upind13 : clear implicits.
#[local] Hint Unfold upind13 : core.

Lemma monotone13_inter (gf gf': rel13 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 T12 -> rel13 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 T12)
      (MON1: monotone13 gf)
      (MON2: monotone13 gf'):
  monotone13 (gf /14\ gf').
Proof.
  red; intros. destruct IN. split; eauto.
Qed.

Lemma _pind13_mon_gen (gf gf': rel13 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 T12 -> rel13 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 T12) r r'
    (LEgf: gf <14= gf')
    (LEr: r <13= r'):
  pind13 gf r <13== pind13 gf' r'.
Proof.
  apply curry_map13. red; intros. eapply pind_mon_gen. apply PR.
  - intros. apply LEgf, PR0.
  - intros. apply LEr, PR0.
Qed.

Lemma pind13_mon_gen (gf gf': rel13 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 T12 -> rel13 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 T12) r r' x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12
    (REL: pind13 gf r x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12)
    (LEgf: gf <14= gf')
    (LEr: r <13= r'):
  pind13 gf' r' x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12.
Proof.
  eapply _pind13_mon_gen; [apply LEgf | apply LEr | apply REL].
Qed.

Lemma pind13_mon_bot (gf gf': rel13 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 T12 -> rel13 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 T12) r' x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12
    (REL: pind13 gf bot13 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12)
    (LEgf: gf <14= gf'):
  pind13 gf' r' x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12.
Proof.
  eapply pind13_mon_gen; [apply REL | apply LEgf | intros; contradiction PR].
Qed.

Definition top13 { T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 T12} (x0: T0) (x1: T1 x0) (x2: T2 x0 x1) (x3: T3 x0 x1 x2) (x4: T4 x0 x1 x2 x3) (x5: T5 x0 x1 x2 x3 x4) (x6: T6 x0 x1 x2 x3 x4 x5) (x7: T7 x0 x1 x2 x3 x4 x5 x6) (x8: T8 x0 x1 x2 x3 x4 x5 x6 x7) (x9: T9 x0 x1 x2 x3 x4 x5 x6 x7 x8) (x10: T10 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9) (x11: T11 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10) (x12: T12 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11) := True.

Lemma pind13_mon_top (gf gf': rel13 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 T12 -> rel13 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 T12) r x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12
    (REL: pind13 gf r x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12)
    (LEgf: gf <14= gf'):
  pind13 gf' top13 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12.
Proof.
  eapply pind13_mon_gen; eauto. red. auto.
Qed.

Lemma upind13_mon_gen (gf gf': rel13 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 T12 -> rel13 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 T12) r r' x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12
    (REL: upind13 gf r x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12)
    (LEgf: gf <14= gf')
    (LEr: r <13= r'):
  upind13 gf' r' x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12.
Proof.
  destruct REL. split; eauto.
  eapply pind13_mon_gen; [apply H | apply LEgf | apply LEr].
Qed.

Lemma upind13_mon_bot (gf gf': rel13 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 T12 -> rel13 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 T12) r' x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12
    (REL: upind13 gf bot13 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12)
    (LEgf: gf <14= gf'):
  upind13 gf' r' x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12.
Proof.
  eapply upind13_mon_gen; [apply REL | apply LEgf | intros; contradiction PR].
Qed.

Lemma upind13mon_top (gf gf': rel13 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 T12 -> rel13 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 T12) r x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12
    (REL: upind13 gf r x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12)
    (LEgf: gf <14= gf'):
  upind13 gf' top13 x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12.
Proof.
  eapply upind13_mon_gen; eauto. red. auto.
Qed.

Section Arg13.

Variable gf : rel13 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 T12 -> rel13 T0 T1 T2 T3 T4 T5 T6 T7 T8 T9 T10 T11 T12.
Arguments gf : clear implicits.

Theorem _pind13_mon: _monotone13 (pind13 gf).
Proof.
  red; intros. eapply curry_map13, _pind_mon; apply uncurry_map13; assumption.
Qed.

Theorem _pind13_acc: forall
  l r (OBG: forall rr (DEC: rr <13== r) (IH: rr <13== l), pind13 gf rr <13== l),
  pind13 gf r <13== l.
Proof.
  intros. apply curry_adjoint2_13.
  eapply _pind_acc. intros.
  apply curry_adjoint2_13 in DEC. apply curry_adjoint2_13 in IH.
  apply curry_adjoint1_13.
  eapply le13_trans. 2: eapply (OBG _ DEC IH).
  apply curry_map13.
  apply _pind_mon; try apply le1_refl; apply curry_bij2_13.
Qed.

Theorem _pind13_mult_strong: forall r,
  pind13 gf r <13== pind13 gf (upind13 gf r).
Proof.
  intros. apply curry_map13.
  eapply le1_trans; [eapply _pind_mult_strong |].
  apply _pind_mon; intros [] H. apply H.
Qed.

Theorem _pind13_fold: forall r,
  gf (upind13 gf r) <13== pind13 gf r.
Proof.
  intros. apply uncurry_adjoint1_13.
  eapply le1_trans; [| apply _pind_fold]. apply le1_refl.
Qed.

Theorem _pind13_unfold: forall (MON: _monotone13 gf) r,
  pind13 gf r <13== gf (upind13 gf r).
Proof.
  intros. apply curry_adjoint2_13.
  eapply _pind_unfold; apply monotone13_map; assumption.
Qed.

Theorem pind13_acc: forall
  l r (OBG: forall rr (DEC: rr <13= r) (IH: rr <13= l), pind13 gf rr <13= l),
  pind13 gf r <13= l.
Proof.
  apply _pind13_acc.
Qed.

Theorem pind13_mon: monotone13 (pind13 gf).
Proof.
  apply monotone13_eq.
  apply _pind13_mon.
Qed.

Theorem upind13_mon: monotone13 (upind13 gf).
Proof.
  red; intros.
  destruct IN. split; eauto.
  eapply pind13_mon. apply H. apply LE.
Qed.

Theorem pind13_mult_strong: forall r,
  pind13 gf r <13= pind13 gf (upind13 gf r).
Proof.
  apply _pind13_mult_strong.
Qed.

Corollary pind13_mult: forall r,
  pind13 gf r <13= pind13 gf (pind13 gf r).
Proof. intros; eapply pind13_mult_strong in PR. eapply pind13_mon; eauto. intros. destruct PR0. eauto. Qed.

Theorem pind13_fold: forall r,
  gf (upind13 gf r) <13= pind13 gf r.
Proof.
  apply _pind13_fold.
Qed.

Theorem pind13_unfold: forall (MON: monotone13 gf) r,
  pind13 gf r <13= gf (upind13 gf r).
Proof.
  intro. eapply _pind13_unfold; apply monotone13_eq; assumption.
Qed.

End Arg13.

Arguments pind13_acc : clear implicits.
Arguments pind13_mon : clear implicits.
Arguments upind13_mon : clear implicits.
Arguments pind13_mult_strong : clear implicits.
Arguments pind13_mult : clear implicits.
Arguments pind13_fold : clear implicits.
Arguments pind13_unfold : clear implicits.

End PIND13.

Global Opaque pind13.

#[export] Hint Unfold upind13 : core.
#[export] Hint Resolve pind13_fold : core.
#[export] Hint Unfold monotone13 : core.


(* *****************************************************************)
(*                                                                 *)
(*               Verified polyhedral AST generation                *)
(*                                                                 *)
(*                 Nathanaël Courant, Inria Paris                  *)
(*                                                                 *)
(*  Copyright Inria. All rights reserved. This file is distributed *)
(*  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.         *)
(*                                                                 *)
(* *****************************************************************)

Require Import Result.
Require Import Vpl.Impure Vpl.Debugging.
Require Import ImpureOperations.
Require Import Semantics.

Require Vpl.ImpureConfig.

Module CoreAlarmed := AlarmImpureMonad Vpl.ImpureConfig.Core.
Export CoreAlarmed.

Module Export ImpOps := ImpureOps CoreAlarmed.
Module Export IIS := IterImpureSemantics CoreAlarmed.

Definition res_to_alarm {A : Type} (d : A) (x : result A) : imp A :=
  match x with
  | Ok a => pure a
  | Err s => alarm s (failwith INTERN s d)
  end.

Lemma res_to_alarm_correct :
  forall (A : Type) (d : A) (x : result A) (y : A),
    mayReturn (res_to_alarm d x) y -> x = Ok y.
Proof.
  intros A d x y. destruct x; simpl.
  - intros H. f_equal. apply mayReturn_pure. auto.
  - intros H. apply mayReturn_alarm in H. tauto.
Qed.


(** * Every parse tree has a corresponding minimal parse tree *)
Require Import Coq.Strings.String Coq.Lists.List Coq.Program.Program Coq.Classes.RelationClasses Coq.Classes.Morphisms Coq.Setoids.Setoid Coq.Arith.Compare_dec.
Require Import Coq.Program.Wf Coq.Arith.Wf_nat.
Require Import Parsers.ContextFreeGrammar Parsers.ContextFreeGrammarProperties Parsers.WellFoundedParse.
Require Export Parsers.MinimalParse.
Require Import Common Common.Wf.

Set Implicit Arguments.
Local Open Scope string_like_scope.

Local Notation "f ∘ g" := (fun x => f (g x)).

Section cfg.
  Context CharType (String : string_like CharType) (G : grammar CharType).
  Context (names_listT : Type)
          (initial_names_data : names_listT)
          (is_valid_name : names_listT -> string -> bool)
          (remove_name : names_listT -> string -> names_listT)
          (names_listT_R : names_listT -> names_listT -> Prop)
          (remove_name_dec : forall ls name,
                               is_valid_name ls name = true
                               -> names_listT_R (remove_name ls name) ls)
          (remove_name_1
           : forall ls ps ps',
               is_valid_name (remove_name ls ps) ps' = true
               -> is_valid_name ls ps' = true)
          (remove_name_2
           : forall ls ps ps',
               is_valid_name (remove_name ls ps) ps' = false
               <-> is_valid_name ls ps' = false \/ ps = ps')
          (ntl_wf : well_founded names_listT_R).

  Context (names_listT_R_respectful : forall x y,
                                        sub_names_listT is_valid_name x y
                                        -> x <> y
                                        -> names_listT_R x y).

  Local Notation minimal_parse_of_production := (@minimal_parse_of_production CharType String G names_listT initial_names_data is_valid_name remove_name).
  Local Notation minimal_parse_of := (@minimal_parse_of CharType String G names_listT initial_names_data is_valid_name remove_name).
  Local Notation minimal_parse_of_name := (@minimal_parse_of_name CharType String G names_listT initial_names_data is_valid_name remove_name).
  Local Notation minimal_parse_of_item := (@minimal_parse_of_item CharType String G names_listT initial_names_data is_valid_name remove_name).

  Lemma strle_from_min_parse_of_production {str0 valid strs pats}
        (p1 : minimal_parse_of_production str0 valid strs pats)
  : strs ≤s str0.
  Proof.
    destruct p1; trivial; [].
    destruct (stringlike_dec str0 (Empty _)) as [|n];
      subst; [ reflexivity | left ].
    rewrite Length_Empty.
    case_eq (Length str0); intro H; [ exfalso | ];
    eauto using Empty_Length with arith.
  Qed.

  Definition parse_of_item_name__of__minimal_parse_of_name'
             (parse_of__of__minimal_parse_of
              : forall str0 valid str prods,
                  @minimal_parse_of str0 valid str prods -> parse_of String G str prods)
             {str0 valid str name} (p : @minimal_parse_of_name str0 valid str name)
  : parse_of_item String G str (NonTerminal _ name)
    := ParseNonTerminal
         name
         (@parse_of__of__minimal_parse_of
            _ _ _ _
            (match p as p in (@MinimalParse.minimal_parse_of_name _ _ _ _ _ _ _ str0 valid str name)
                   return minimal_parse_of (match p with
                                              | MinParseNonTerminalStrLt _ _ _ _ _ _ => _
                                              | MinParseNonTerminalStrEq _ _ _ _ _ => _
                                            end)
                                           (match p with
                                              | MinParseNonTerminalStrLt _ _ _ _ _ _ => _
                                              | MinParseNonTerminalStrEq _ _ _ _ _ => _
                                            end)
                                           str (Lookup G name) with
               | MinParseNonTerminalStrLt str0 valid name str pf p' => p'
               | MinParseNonTerminalStrEq str valid name H p' => p'
             end)).

  Definition parse_of_item__of__minimal_parse_of_item'
             (parse_of__of__minimal_parse_of
              : forall str0 valid str prods,
                  @minimal_parse_of str0 valid str prods -> parse_of String G str prods)
             {str0 valid str it} (p : @minimal_parse_of_item str0 valid str it)
  : parse_of_item String G str it
    := match p in (@MinimalParse.minimal_parse_of_item _ _ _ _ _ _ _ str0 valid str it) return parse_of_item String G str it with
         | MinParseTerminal str0 valid x
           => ParseTerminal String G x
         | MinParseNonTerminal str0 valid _ _ p'
           => @parse_of_item_name__of__minimal_parse_of_name' (@parse_of__of__minimal_parse_of) _ _ _ _ p'
       end.

  Fixpoint parse_of__of__minimal_parse_of {str0 valid str pats} (p : @minimal_parse_of str0 valid str pats)
  : parse_of String G str pats
    := match p with
         | MinParseHead str0 valid str pat pats p'
           => ParseHead pats (parse_of_production__of__minimal_parse_of_production p')
         | MinParseTail str0 valid str pat pats p'
           => ParseTail pat (parse_of__of__minimal_parse_of p')
       end
  with parse_of_production__of__minimal_parse_of_production {str0 valid str pat} (p : @minimal_parse_of_production str0 valid str pat)
       : parse_of_production String G str pat
       := match p with
            | MinParseProductionNil str0 valid
              => ParseProductionNil _ _
            | MinParseProductionCons str0 valid str strs pat pats pf p' p''
              => ParseProductionCons
                   (parse_of_item__of__minimal_parse_of_item' (@parse_of__of__minimal_parse_of) p')
                   (parse_of_production__of__minimal_parse_of_production p'')
          end.

  Definition parse_of_item_name__of__minimal_parse_of_name
  : forall {str0 valid str name} (p : @minimal_parse_of_name str0 valid str name),
      parse_of_item String G str (NonTerminal _ name)
    := @parse_of_item_name__of__minimal_parse_of_name' (@parse_of__of__minimal_parse_of).

  Definition parse_of_item__of__minimal_parse_of_item
  : forall {str0 valid str it},
      @minimal_parse_of_item str0 valid str it
      -> parse_of_item String G str it
    := @parse_of_item__of__minimal_parse_of_item' (@parse_of__of__minimal_parse_of).

  Section contract.
    Local Hint Constructors MinimalParse.minimal_parse_of_name.

    Definition contract_minimal_parse_of_name_lt
               {str0 str valid valid' name}
               (Hlt : Length str < Length str0)
               (p : @minimal_parse_of_name str0 valid str name)
    : @minimal_parse_of_name str0 valid' str name.
    Proof.
      destruct p.
      { constructor (assumption). }
      { exfalso; clear -Hlt; omega. }
    Defined.

    Definition contract_minimal_parse_of_item_lt
               {str0 str valid valid' it}
               (Hlt : Length str < Length str0)
               (p : @minimal_parse_of_item str0 valid str it)
    : @minimal_parse_of_item str0 valid' str it.
    Proof.
      destruct p as [p|p].
      { constructor. }
      { constructor (eapply contract_minimal_parse_of_name_lt; eassumption). }
    Defined.

    Definition contract_minimal_parse_of_production_lt
               {str0 str valid valid' pat}
               (Hlt : Length str < Length str0)
               (p : @minimal_parse_of_production str0 valid str pat)
    : @minimal_parse_of_production str0 valid' str pat.
    Proof.
      induction p.
      { constructor. }
      { constructor;
        try first [ eapply contract_minimal_parse_of_item_lt; try eassumption
                  | eapply IHp; try eassumption
                  | assumption ];
        clear -Hlt;
        abstract (
            rewrite <- Length_correct in Hlt;
            eauto using le_S, Lt.le_lt_trans, Plus.le_plus_l, Plus.le_plus_r with nocore
          ). }
    Defined.

    Definition contract_minimal_parse_of_lt
               {str0 str valid valid' pats}
               (Hlt : Length str < Length str0)
               (p : @minimal_parse_of str0 valid str pats)
    : @minimal_parse_of str0 valid' str pats.
    Proof.
      induction p.
      { constructor (eapply contract_minimal_parse_of_production_lt; eassumption). }
      { constructor (eapply IHp; assumption). }
    Defined.

    Section contract_eq.
      Lemma parse_of_contract_minimal_parse_of_item_lt
            {str0 str : String} {valid valid' : names_listT}
            {Hlt : Length str < Length str0}
            {it}
            (p : @minimal_parse_of_item str0 valid str it)
      : parse_of_item__of__minimal_parse_of_item
          (contract_minimal_parse_of_item_lt (valid' := valid') Hlt p)
        = parse_of_item__of__minimal_parse_of_item p.
      Proof.
        destruct_head MinimalParse.minimal_parse_of_item; simpl; try reflexivity.
        destruct_head MinimalParse.minimal_parse_of_name; try reflexivity.
        unfold False_rect.
        match goal with
          | [ |- appcontext[match ?e with end] ] => destruct e
        end.
      Qed.

      Lemma parse_of_contract_minimal_parse_of_production_lt
            {str0 str : String} {valid valid' : names_listT}
            {Hlt : Length str < Length str0}
            {pat}
            (p : @minimal_parse_of_production str0 valid str pat)
      : parse_of_production__of__minimal_parse_of_production
          (contract_minimal_parse_of_production_lt (valid' := valid') Hlt p)
        = parse_of_production__of__minimal_parse_of_production p.
      Proof.
        induction p; simpl; try reflexivity.
        rewrite IHp, parse_of_contract_minimal_parse_of_item_lt.
        reflexivity.
      Qed.

      Lemma parse_of_contract_minimal_parse_of_lt
            {str0 str : String} {valid valid' : names_listT}
            {Hlt : Length str < Length str0}
            {pats}
            (p : @minimal_parse_of str0 valid str pats)
      : parse_of__of__minimal_parse_of
          (contract_minimal_parse_of_lt (valid' := valid') Hlt p)
        = parse_of__of__minimal_parse_of p.
      Proof.
        induction p; simpl;
        progress rewrite ?IHp, ?parse_of_contract_minimal_parse_of_production_lt;
        reflexivity.
      Qed.
    End contract_eq.
  End contract.

  (** Re-add this so rewrite works *)
  Global Add Parametric Morphism : remove_name
  with signature (sub_names_listT is_valid_name) ==> eq ==> (sub_names_listT is_valid_name)
    as remove_name_mor.
  Proof.
    intros; apply (@remove_name_mor); try assumption; reflexivity.
  Qed.

  Definition expand_minimal_parse_of_name'
             (expand_minimal_parse_of
              : forall {str0 str0' valid valid' str prods}
                       (Hstr : str0 ≤s str0')
                       (H : sub_names_listT is_valid_name valid valid')
                       (Hinit : sub_names_listT is_valid_name valid' initial_names_data)
                       (p : @minimal_parse_of str0 valid str prods),
                  @minimal_parse_of str0' valid' str prods)
             {str0 str0' valid valid' str name}
             (Hstr : str0 ≤s str0')
             (H : sub_names_listT is_valid_name valid valid')
             (Hinit : sub_names_listT is_valid_name valid' initial_names_data)
             (p : @minimal_parse_of_name str0 valid str name)
  : @minimal_parse_of_name str0' valid' str name.
  Proof.
    destruct p;
    first [ apply MinParseNonTerminalStrLt;
            solve [ eapply length_le_trans; eassumption
                  | assumption ]
          | idtac ]; [].
    { destruct (strle_to_sumbool _ Hstr); subst;
      [ apply MinParseNonTerminalStrLt
      | apply MinParseNonTerminalStrEq ];
      solve [ assumption
            | apply H; assumption
            | eapply expand_minimal_parse_of; [ .. | eassumption ];
              solve [ reflexivity
                    | rewrite ?H, ?Hinit;
                      eauto using sub_names_listT_remove;
                      reflexivity ] ]. }
  Defined.

  Definition expand_minimal_parse_of_item'
             (expand_minimal_parse_of
              : forall {str0 str0' valid valid' str prods}
                       (Hstr : str0 ≤s str0')
                       (H : sub_names_listT is_valid_name valid valid')
                       (Hinit : sub_names_listT is_valid_name valid' initial_names_data)
                       (p : @minimal_parse_of str0 valid str prods),
                  @minimal_parse_of str0' valid' str prods)
             {str0 str0' valid valid' str it}
             (Hstr : str0 ≤s str0')
             (H : sub_names_listT is_valid_name valid valid')
             (Hinit : sub_names_listT is_valid_name valid' initial_names_data)
             (p : @minimal_parse_of_item str0 valid str it)
  : @minimal_parse_of_item str0' valid' str it.
  Proof.
    destruct p.
    { apply MinParseTerminal. }
    { apply MinParseNonTerminal; [].
      eapply expand_minimal_parse_of_name'; [..| eassumption ];
      try assumption. }
  Defined.

  Fixpoint expand_minimal_parse_of
           {str0 str0' valid valid' str pats}
           (Hstr : str0 ≤s str0')
           (H : sub_names_listT is_valid_name valid valid')
           (Hinit : sub_names_listT is_valid_name valid' initial_names_data)
           (p : @minimal_parse_of str0 valid str pats)
  : @minimal_parse_of str0' valid' str pats
    := match p in (@MinimalParse.minimal_parse_of _ _ _ _ _ _ _ str0 valid str pats)
             return (str0 ≤s str0'
                     -> sub_names_listT is_valid_name valid valid'
                     -> @minimal_parse_of str0' valid' str pats)
       with
         | MinParseHead str0 valid str pat pats p'
           => fun Hstr H => MinParseHead pats (expand_minimal_parse_of_production Hstr H Hinit p')
         | MinParseTail str0 valid str pat pats p'
           => fun Hstr H => MinParseTail pat (expand_minimal_parse_of Hstr H Hinit p')
       end Hstr H
  with expand_minimal_parse_of_production
         {str0 str0' valid valid' str pat}
         (Hstr : str0 ≤s str0')
         (H : sub_names_listT is_valid_name valid valid')
         (Hinit : sub_names_listT is_valid_name valid' initial_names_data)
         (p : @minimal_parse_of_production str0 valid str pat)
       : @minimal_parse_of_production str0' valid' str pat
       := match p in (@MinimalParse.minimal_parse_of_production _ _ _ _ _ _ _ str0 valid str pats)
                return (str0 ≤s str0' -> sub_names_listT is_valid_name valid valid' -> minimal_parse_of_production str0' valid' str pats)
          with
            | MinParseProductionNil str0 valid
              => fun _ _ => MinimalParse.MinParseProductionNil _ _ _ _ _ _ _
            | MinParseProductionCons str0 valid str strs pat pats pf p' p''
              => fun Hstr H => MinParseProductionCons
                                 (transitivity pf Hstr)
                                 (expand_minimal_parse_of_item' (@expand_minimal_parse_of) Hstr H Hinit p')
                                 (expand_minimal_parse_of_production Hstr H Hinit p'')
          end Hstr H.

  Definition expand_minimal_parse_of_name
  : forall {str0 str0' valid valid' str name}
           (Hstr : str0 ≤s str0')
           (H : sub_names_listT is_valid_name valid valid')
           (Hinit : sub_names_listT is_valid_name valid' initial_names_data)
           (p : @minimal_parse_of_name str0 valid str name),
      @minimal_parse_of_name str0' valid' str name
    := @expand_minimal_parse_of_name' (@expand_minimal_parse_of).

  Definition expand_minimal_parse_of_item
  : forall {str0 str0' valid valid' str it}
           (Hstr : str0 ≤s str0')
           (H : sub_names_listT is_valid_name valid valid')
           (Hinit : sub_names_listT is_valid_name valid' initial_names_data)
           (p : @minimal_parse_of_item str0 valid str it),
      @minimal_parse_of_item str0' valid' str it
    := @expand_minimal_parse_of_item' (@expand_minimal_parse_of).

  Section minimize.
    Let P : String -> string -> Prop
      := fun _ p => is_valid_name initial_names_data p = true.

    Let alt_option h valid str
      := { name : _ & (is_valid_name valid name = false /\ P str name)
                      * { p : parse_of String G str (Lookup G name)
                              & (size_of_parse p < h)
                                * Forall_parse_of P p } }%type.

    Lemma not_alt_all {h str} (ps : alt_option h initial_names_data str)
    : False.
    Proof.
      subst P; simpl in *.
      destruct ps as [ ? [ H' _ ] ].
      revert H'; clear; intros [? ?].
      congruence.
    Qed.

    Definition alt_all_elim {h str T} (ps : T + alt_option h initial_names_data str)
    : T.
    Proof.
      destruct ps as [|ps]; [ assumption | exfalso ].
      eapply not_alt_all; eassumption.
    Defined.

    Definition expand_alt_option' {h h' str str' valid valid'}
               (H : h <= h') (H' : sub_names_listT is_valid_name valid' valid) (H'' : str = str')
    : alt_option h valid str -> alt_option h' valid' str'.
    Proof.
      hnf in H'; unfold alt_option.
      repeat match goal with
               | [ |- sigT _ -> _ ] => intros []
               | [ |- sig _ -> _ ] => intros []
               | [ |- prod _ _ -> _ ] => intros []
               | [ |- and _ _ -> _ ] => intros []
               | _ => intro
               | _ => progress subst
               | [ |- sigT _ ] => esplit
               | [ |- sig _ ] => esplit
               | [ |- prod _ _ ] => esplit
               | [ |- and _ _ ] => esplit
               | [ H : _ = false |- _ = false ]
                 => apply Bool.not_true_iff_false in H;
                   apply Bool.not_true_iff_false;
                   intro; apply H
               | _ => eapply H'; eassumption
               | _ => assumption
               | [ |- _ < _ ] => eapply Lt.lt_trans; eassumption
               | [ |- _ < _ ] => eapply Lt.lt_le_trans; eassumption
             end.
    Defined.

    Definition expand_alt_option {h h' str str' valid valid'}
               (H : h < h') (H' : sub_names_listT is_valid_name valid' valid) (H'' : str = str')
    : alt_option h valid str -> alt_option h' valid' str'.
    Proof.
      apply expand_alt_option'; try assumption.
      apply Lt.lt_le_weak; assumption.
    Defined.

    Section wf_parts.
      Let of_parse_item_T' h
          {str0 str : String} (pf : str ≤s str0)
          (valid : names_listT) {it : item CharType}
          (p : parse_of_item String G str it)
        := forall (p_small : size_of_parse_item p < h),
             sub_names_listT is_valid_name valid initial_names_data
             -> Forall_parse_of_item P p
             -> ({ p' : @minimal_parse_of_item str0 valid str it
                        & (size_of_parse_item (parse_of_item__of__minimal_parse_of_item p') <= size_of_parse_item p)
                          * Forall_parse_of_item P (parse_of_item__of__minimal_parse_of_item p') })%type
                + alt_option (size_of_parse_item p) valid str.

      Let of_parse_item_T str0 h
        := forall str pf valid it p, @of_parse_item_T' h str0 str pf valid it p.

      Let of_parse_production_T' h
          {str0 str : String} (pf : str ≤s str0)
          (valid : names_listT) {pat : production CharType}
          (p : parse_of_production String G str pat)
        := forall (p_small : size_of_parse_production p < h),
             sub_names_listT is_valid_name valid initial_names_data
             -> Forall_parse_of_production P p
             -> ({ p' : @minimal_parse_of_production str0 valid str pat
                        & (size_of_parse_production (parse_of_production__of__minimal_parse_of_production p') <= size_of_parse_production p)
                          * Forall_parse_of_production P (parse_of_production__of__minimal_parse_of_production p') })%type
                + alt_option (size_of_parse_production p) valid str.

      Let of_parse_production_T str0 h
        := forall str pf valid pat p, @of_parse_production_T' h str0 str pf valid pat p.

      Let of_parse_T' h
          {str0 str : String} (pf : str ≤s str0)
          (valid : names_listT) {pats : productions CharType}
          (p : parse_of String G str pats)
        := forall (p_small : size_of_parse p < h),
             sub_names_listT is_valid_name valid initial_names_data
             -> Forall_parse_of P p
             -> ({ p' : @minimal_parse_of str0 valid str pats
                        & (size_of_parse (parse_of__of__minimal_parse_of p') <= size_of_parse p)
                          * Forall_parse_of P (parse_of__of__minimal_parse_of p') })%type
                + alt_option (size_of_parse p) valid str.

      Let of_parse_T str0 h
        := forall str pf valid pats p, @of_parse_T' h str0 str pf valid pats p.

      Let of_parse_name_T {str0 str valid name} (p : parse_of String G str (Lookup G name)) h
        := size_of_parse_item (ParseNonTerminal name p) < h
           -> str ≤s str0
           -> sub_names_listT is_valid_name valid initial_names_data
           -> Forall_parse_of_item P (ParseNonTerminal name p)
           -> ({ p' : @minimal_parse_of_name str0 valid str name
                      & (size_of_parse_item (parse_of_item__of__minimal_parse_of_item (MinParseNonTerminal p')) <= size_of_parse_item (ParseNonTerminal name p))
                        * Forall_parse_of_item P (parse_of_item__of__minimal_parse_of_item (MinParseNonTerminal p')) })%type
              + alt_option (size_of_parse_item (ParseNonTerminal name p)) valid str.

      Section item.
        Context {str0 str : String} {valid : names_listT}.

        Definition minimal_parse_of_item__of__parse_of_item
                   h
                   (minimal_parse_of_name__of__parse_of_name
                    : forall h' (pf : h' < S (S h)) {str0 str valid name}
                             (p : parse_of String G str (Lookup G name)),
                        @of_parse_name_T str0 str valid name p h')
        : of_parse_item_T str h.
        Proof.
          intros str' pf valid' pats p H_h Hinit' H_forall.
          destruct h as [|h']; [ exfalso; omega | ].
          destruct p as [|name' str'' p'].
          { left.
            eexists (@MinimalParse.MinParseTerminal _ _ _ _ _ _ _ _ _ _);
              split; simpl; constructor. }
          { edestruct (fun pf => @minimal_parse_of_name__of__parse_of_name (S h') pf str _ valid' _ p') as [ [p'' H''] | p'' ];
            try solve [ repeat (apply Lt.lt_n_Sn || apply Lt.lt_S)
                      | exact Hinit'
                      | exact H_h
                      | exact H_forall
                      | exact pf ];
            [|];
            [ left | right ].
            { exists (MinParseNonTerminal p'').
              simpl in *.
              exact H''. }
            { exact p''. } }
        Defined.
      End item.

      Section production.
        Context {str0 str : String} {valid : names_listT}.

        Local Ltac min_parse_prod_t' :=
          idtac;
          match goal with
            | _ => assumption
            | [ |- ?R ?x ?x ]
              => reflexivity
            | _ => progress destruct_head prod
            | [ H : False |- _ ]
              => solve [ destruct H ]
            | _ => progress simpl
            | _ => progress rewrite ?parse_of_contract_minimal_parse_of_item_lt, ?parse_of_contract_minimal_parse_of_production_lt, ?parse_of_contract_minimal_parse_of_lt
            | [ |- context G[size_of_parse_production (ParseProductionCons ?a ?b)] ]
              => let G' := context G[S (size_of_parse_item a + size_of_parse_production b)] in
                 change G'
            | [ H : alt_option _ initial_names_data _ |- _ ]
              => apply not_alt_all in H
            | [ p0 : minimal_parse_of_item _ _ ?s0 ?pat,
                     p1 : minimal_parse_of_production _ _ ?s1 ?pats,
                          H : ?s0 ++ ?s1 ≤s ?s'
                |- ({ p' : minimal_parse_of_production ?s' _ (?s0 ++ ?s1) (?pat :: ?pats) & _ } + _)%type ]
              => left; exists (MinParseProductionCons H p0 p1)
            | [ p0 : minimal_parse_of_item ?s' _ ?s0 ?pat,
                     p1 : minimal_parse_of_production ?s' _ ?s1 ?pats,
                          H : ?s0 ++ ?s1 ≤s ?s',
                              H' : Length ?s0 < Length ?s'
                |- ({ p' : minimal_parse_of_production ?s' ?v (?s0 ++ ?s1) (?pat :: ?pats) & _ } + _)%type ]
              => left; exists (MinParseProductionCons
                                 H
                                 (contract_minimal_parse_of_item_lt (valid' := v) H' p0)
                                 p1)
            | [ p0 : minimal_parse_of_item ?s' _ ?s0 ?pat,
                     p1 : minimal_parse_of_production ?s' _ ?s1 ?pats,
                          H : ?s0 ++ ?s1 ≤s ?s',
                              H' : Length ?s1 < Length ?s'
                |- ({ p' : minimal_parse_of_production ?s' ?v (?s0 ++ ?s1) (?pat :: ?pats) & _ } + _)%type ]
              => left; exists (MinParseProductionCons
                                 H
                                 p0
                                 (contract_minimal_parse_of_production_lt (valid' := v) H' p1))
            | [ p0 : minimal_parse_of_item ?s' _ ?s0 ?pat,
                     p1 : minimal_parse_of_production ?s' _ ?s1 ?pats,
                          H : ?s0 ++ ?s1 ≤s ?s',
                              H' : Length ?s0 < Length ?s',
                                   H'' : Length ?s1 < Length ?s'
                |- ({ p' : minimal_parse_of_production ?s' ?v (?s0 ++ ?s1) (?pat :: ?pats) & _ } + _)%type ]
              => left; exists (MinParseProductionCons
                                 H
                                 (contract_minimal_parse_of_item_lt (valid' := v) H' p0)
                                 (contract_minimal_parse_of_production_lt (valid' := v) H'' p1))
            | [ |- (_ * _)%type ]
              => split
            | [ H : _ <= _ |- _ <= _ ] => apply H
            | _ => apply Le.le_n_S
            | _ => apply Plus.plus_le_compat
            | [ H0 : Forall_parse_of_item _ _,
                     H1 : Forall_parse_of_production _ _
                |- Forall_parse_of_production _ _ ]
              => exact (H0, H1)
            | [ H : alt_option _ ?v ?x
                |- (_ + alt_option _ ?v (?x ++ Empty _))%type ]
              => right; eapply expand_alt_option'; [ .. | exact H ]
            | [ H : alt_option _ ?v ?x
                |- (_ + alt_option _ ?v (Empty _ ++ ?x))%type ]
              => right; eapply expand_alt_option'; [ .. | exact H ]
            | [ |- _ = _ ]
              => progress rewrite ?LeftId, ?RightId
            | _
              => solve [ eauto using le_S, Le.le_trans, Plus.le_plus_l, Plus.le_plus_r with nocore ]
          end.
        Local Ltac min_parse_prod_pose_t' :=
          idtac;
          match goal with
            | [ H : ?a <> Empty _,
                    H' : ?a ++ _ ≤s _ |- _ ]
              => unique pose proof (strle_to_lt_nonempty_r H H')
            | [ H : ?a <> Empty _,
                    H' : _ ++ ?a ≤s _ |- _ ]
              => unique pose proof (strle_to_lt_nonempty_l H H')
          end.
        Local Ltac min_parse_prod_pose_t := repeat min_parse_prod_pose_t'.
        Local Ltac min_parse_prod_t := repeat min_parse_prod_t'.

        (** This is the proof where we pay the proof for conceptual
            mismatch.  We are, conceptually, simultaneously
            "minimizing parse trees" and "producing parse traces".  It
            is marginally nicer(!!) to contain the ugliness in this
            single proof, rather than have it infect everything.  So
            we must conceptually minimize the passed parse tree while
            in fact building a trace of the parse algorithm.  To do
            this, in the cons case, we need to figure out how we're
            decreasing.  According with conceptual minimization, when
            we have parsed [s0 ++ s1] as a cons of [p0] and [p1],
            having a smaller parse tree for, say [s0], with any other
            pattern, does us no good, unless [s1] is empty (and [s0 =
            s0 ++ s1]), when we can simply pass that smaller parse up
            the function call tree.  So we must eliminate the
            "alternate" option, by expanding the valid list to the
            initial data.  Luckily(?!), in the case where [s1] is
            non-empty, [s0] is strictly smaller than [s0 ++ s1], and
            thus we can rebuild the minimal parse tree to contract it.
            This, finally, allows us to either build a minimal parse
            tree for the thing we are asked about (or to contract the
            "alternate option" parse tree, passing it back up?). *)

        Fixpoint minimal_parse_of_production__of__parse_of_production
                 h
                 (minimal_parse_of_name__of__parse_of_name
                  : forall h' (pf : h' < S (S h)) {str0 str valid name}
                           (p : parse_of String G str (Lookup G name)),
                      @of_parse_name_T str0 str valid name p h')
                 {struct h}
        : of_parse_production_T str h.
        Proof.
          intros str' pf valid' pats p H_h Hinit' H_forall.
          destruct h as [|h']; [ exfalso; omega | ].
          destruct p as [| str' strs' str'' pat' p0' p1' ].
          { clear minimal_parse_of_production__of__parse_of_production.
            left.
            eexists (@MinimalParse.MinParseProductionNil _ _ _ _ _ _ _ _ _);
              repeat (reflexivity || esplit). }
          { specialize (fun h' pf
                        => @minimal_parse_of_name__of__parse_of_name
                             h' (transitivity pf (Lt.lt_n_Sn _))).
            change (S ((size_of_parse_item p0')
                       + (size_of_parse_production p1'))
                    < S h') in H_h.
            apply Lt.lt_S_n in H_h.
            pose proof (Lt.le_lt_trans _ _ _ (Plus.le_plus_l _ _) H_h) as H_h0.
            pose proof (Lt.le_lt_trans _ _ _ (Plus.le_plus_r _ _) H_h) as H_h1.
            clear H_h.
            pose proof (fun valid Hinit => @minimal_parse_of_item__of__parse_of_item _ h'  minimal_parse_of_name__of__parse_of_name _ (transitivity (str_le1_append _ _ _) pf) valid _ p0' H_h0 Hinit (fst H_forall)) as p_it.
            pose proof (fun valid Hinit => @minimal_parse_of_production__of__parse_of_production h' minimal_parse_of_name__of__parse_of_name _ (transitivity (str_le2_append _ _ _) pf) valid _ p1' H_h1 Hinit (snd H_forall)) as p_prod.
            destruct (stringlike_dec str' (Empty _)), (stringlike_dec str'' (Empty _));
              subst.
            { (* empty, empty *)
              specialize (p_it valid' Hinit'); specialize (p_prod valid' Hinit').
              destruct p_it as [ [ p0'' H0''] |], p_prod as [ [ p1'' H1'' ] |];
                [ | | | ];
                min_parse_prod_t. }
            { (* empty, nonempty *)
              specialize (p_it initial_names_data (reflexivity _)); specialize (p_prod valid' Hinit').
              destruct p_it as [ [ p0'' H0''] |], p_prod as [ [ p1'' H1'' ] |];
                [ | | | ];
                min_parse_prod_t;
                min_parse_prod_pose_t;
                min_parse_prod_t. }
            { (* nonempty, empty *)
              specialize (p_it valid' Hinit'); specialize (p_prod initial_names_data (reflexivity _)).
              destruct p_it as [ [ p0'' H0''] |], p_prod as [ [ p1'' H1'' ] |];
                [ | | | ];
                min_parse_prod_t;
                min_parse_prod_pose_t;
                min_parse_prod_t. }
            { (* nonempty, nonempty *)
              specialize (p_it initial_names_data (reflexivity _)); specialize (p_prod initial_names_data (reflexivity _)).
              destruct p_it as [ [ p0'' H0''] |], p_prod as [ [ p1'' H1'' ] |];
                [ | | | ];
                min_parse_prod_t;
                min_parse_prod_pose_t;
                min_parse_prod_t. } }
        Defined.
      End production.

      Section productions.
        Context {str0 str : String} {valid : names_listT}.

        Fixpoint minimal_parse_of_productions__of__parse_of_productions
                 h
                 (minimal_parse_of_name__of__parse_of_name
                  : forall h' (pf : h' < S h) {str0 str valid name}
                           (p : parse_of String G str (Lookup G name)),
                      @of_parse_name_T str0 str valid name p h')
                 {struct h}
        : of_parse_T str h.
        Proof.
          intros str' pf valid' pats p H_h Hinit' H_forall.
          destruct h as [|h']; [ exfalso; omega | ].
          destruct p as [str' pat pats p' | str' pat pats p'].
          { clear minimal_parse_of_productions__of__parse_of_productions.
            edestruct (@minimal_parse_of_production__of__parse_of_production _ h' minimal_parse_of_name__of__parse_of_name _ pf valid' _ p') as [ [p'' p''H] | [name' H'] ];
            try solve [ exact (Lt.lt_S_n _ _ H_h)
                      | exact H_forall
                      | exact Hinit' ];
            [|].
            { left.
              exists (MinParseHead pats p'').
              simpl.
              split;
                solve [ exact (Le.le_n_S _ _ (fst p''H))
                      | exact (snd p''H) ]. }
            { right.
              exists name'.
              split;
                try solve [ exact (fst H') ];
                [].
              exists (projT1 (snd H'));
                split;
                try solve [ exact (snd (projT2 (snd H')))
                          | exact (Lt.lt_S _ _ (fst (projT2 (snd H')))) ]. } }
          { specialize (fun h' pf
                        => @minimal_parse_of_name__of__parse_of_name
                             h' (transitivity pf (Lt.lt_n_Sn _))).
            edestruct (minimal_parse_of_productions__of__parse_of_productions h'  minimal_parse_of_name__of__parse_of_name _ pf valid' _ p') as [ [p'' p''H] | [name' H'] ];
            try solve [ exact (Lt.lt_S_n _ _ H_h)
                      | exact Hinit'
                      | exact H_forall ];
            [|].
            { left.
              exists (MinParseTail pat p'').
              simpl.
              split;
                solve [ exact (Le.le_n_S _ _ (fst p''H))
                      | exact (snd p''H) ]. }
            { right.
              exists name'.
              split;
                try solve [ exact (fst H') ];
                [].
              exists (projT1 (snd H'));
                split;
                try solve [ exact (snd (projT2 (snd H')))
                          | exact (Lt.lt_S _ _ (fst (projT2 (snd H')))) ]. } }
        Defined.
      End productions.

      Section name.
        Section step.
          Definition minimal_parse_of_name__of__parse_of_name_step
                     h
                     (minimal_parse_of_name__of__parse_of_name
                      : forall h' (pf : h' < h) {str0 str valid name}
                               (p : parse_of String G str (Lookup G name)),
                          @of_parse_name_T str0 str valid name p h')
                     {str0 str valid name}
                     (p : parse_of String G str (Lookup G name))
          : @of_parse_name_T str0 str valid name p h.
          Proof.
            destruct h as [|h]; [ clear; repeat intro; exfalso; omega | ].
            intros pf Hstr Hinit' H_forall.
            let H := match goal with H : str ≤s str0 |- _ => constr:H end in
            destruct (strle_to_sumbool _ H) as [pf_lt|pf_eq].
            { (** [str] got smaller, so we reset the valid names list *)
              destruct (@minimal_parse_of_productions__of__parse_of_productions str h minimal_parse_of_name__of__parse_of_name str (reflexivity _) initial_names_data (Lookup G name) p (Lt.lt_S_n _ _ pf) (reflexivity _) (snd H_forall)) as [p'|p'].
              { left.
                exists (MinParseNonTerminalStrLt _ valid _ pf_lt (projT1 p'));
                  simpl.
                simpl in *.
                split;
                  [ exact (Le.le_n_S _ _ (fst (projT2 p')))
                  | split;
                    [ exact (fst H_forall)
                    | exact (snd (projT2 p')) ] ]. }
              { simpl.
                right; eapply expand_alt_option; [..| exact p' ];
                solve [ apply Lt.lt_n_Sn
                      | assumption
                      | reflexivity ]. } }
            { (** [str] didn't get smaller, so we cache the fact that we've hit this name already *)
              destruct (Sumbool.sumbool_of_bool (is_valid_name valid name)) as [ Hvalid | Hinvalid ].
              { destruct (@minimal_parse_of_productions__of__parse_of_productions str h minimal_parse_of_name__of__parse_of_name str (reflexivity _) (remove_name valid name) (Lookup G name) p (Lt.lt_S_n _ _ pf) (transitivity (R := sub_names_listT is_valid_name) (@sub_names_listT_remove _ is_valid_name _ remove_name_1 _ _) Hinit') (snd H_forall)) as [p'|p'].
                { left.
                  subst str.
                  eexists (@MinimalParse.MinParseNonTerminalStrEq _ _ _ _ _ _ _ _ _ _ Hvalid (projT1 p')).
                  simpl in *.
                  split;
                    [ exact (Le.le_n_S _ _ (fst (projT2 p')))
                    | split;
                      [ exact (fst H_forall)
                      | exact (snd (projT2 p')) ] ]. }
                { destruct p' as [name' p'].
                  destruct (string_dec name name') as [|n].
                  { subst name; simpl in *.
                    edestruct (@minimal_parse_of_name__of__parse_of_name (S (size_of_parse p)) pf str0 _ valid name' (projT1 (snd p'))) as [p''|p''];
                    try solve [ apply Lt.lt_n_S, (fst (projT2 (snd p')))
                              | subst; reflexivity
                              | assumption
                              | split; [ exact (proj2 (fst p'))
                                       | exact (snd (projT2 (snd p'))) ] ];
                    [|].
                    { left.
                      exists (projT1 p'').
                      split.
                      { etransitivity;
                        [ exact (fst (projT2 p''))
                        | exact (Lt.lt_le_weak _ _ (Lt.lt_n_S _ _ (fst (projT2 (snd p'))))) ]. }
                      { exact (snd (projT2 p'')). } }
                    { right.
                      exists (projT1 p'').
                      split;
                        [ exact (fst (projT2 p''))
                        | ].
                      exists (projT1 (snd (projT2 p''))).
                      split;
                        [ etransitivity;
                          [ exact (fst (projT2 (snd (projT2 p''))))
                          | exact (Lt.lt_n_S _ _ (fst (projT2 (snd p')))) ]
                        | exact (snd (projT2 (snd (projT2 p'')))) ]. } }
                  { right.
                    exists name'.
                    destruct p' as [p'H p'p].
                    split.
                    { rewrite remove_name_5 in p'H by assumption.
                      exact p'H. }
                    { exists (projT1 p'p).
                      split; [ exact (Lt.lt_S _ _ (fst (projT2 p'p)))
                             | exact (snd (projT2 p'p)) ]. } } } }
              { (** oops, we already saw this name in the past.  ABORT! *)
                right.
                exists name.
                destruct H_forall.
                split; [ split; assumption
                       | ].
                exists p.
                split; solve [ assumption
                             | apply Lt.lt_n_Sn ]. } }
          Defined.
        End step.

        Section wf.
          Definition minimal_parse_of_name__of__parse_of_name
          : forall h
                   {str0 str valid name}
                   (p : parse_of String G str (Lookup G name)),
              @of_parse_name_T str0 str valid name p h
            := @Fix
                 _ lt lt_wf
                 (fun h => forall {str0 str valid name}
                                  (p : parse_of String G str (Lookup G name)),
                             @of_parse_name_T str0 str valid name p h)
                 (@minimal_parse_of_name__of__parse_of_name_step).
        End wf.
      End name.
    End wf_parts.
  End minimize.
End cfg.


Require Import Maps.
Require Import AST.
Require Import Integers.
Require Import Values.
Require Import Memory.
Require Import Events.
Require Import Smallstep.
Require Import GlobalenvsC.
Require Import LinkingC.
Require Import CoqlibC.
Require Import sflib.

Require Import ModSem Mod Skeleton System.
Require Export Syntax.

Set Implicit Arguments.

Module Frame.

  Record t: Type := mk {
    ms: ModSem.t;
    st: ms.(ModSem.state); (* local state *)
  }.

  Definition update_st (fr0: t) (st0: fr0.(ms).(ModSem.state)): t := (mk fr0.(ms) st0).

End Frame.

Module Ge.

  (* NOTE: Ge.(snd) is not used in semantics. It seems it is just for convenience in meta theory *)
  Definition t: Type := (list ModSem.t * SkEnv.t).

  Inductive find_fptr_owner (ge: t) (fptr: val) (ms: ModSem.t): Prop :=
  | find_fptr_owner_intro
      (MODSEM: In ms (fst ge))
      if_sig
      (INTERNAL: Genv.find_funct ms.(ModSem.skenv) fptr = Some (Internal if_sig)).

  Inductive disjoint (ge: t): Prop :=
  | disjoint_intro
      (DISJOINT: forall fptr ms0 ms1
          (FIND0: ge.(find_fptr_owner) fptr ms0)
          (FIND1: ge.(find_fptr_owner) fptr ms1),
          ms0 = ms1).

End Ge.

Inductive state: Type :=
| Callstate
    (args: Args.t)
    (frs: list Frame.t)
| State
    (frs: list Frame.t).

Inductive step (ge: Ge.t): state -> trace -> state -> Prop :=
| step_call
    fr0 frs args
    (AT: fr0.(Frame.ms).(ModSem.at_external) fr0.(Frame.st) args):
    step ge (State (fr0 :: frs))
         E0 (Callstate args (fr0 :: frs))

| step_init
    args frs ms st_init
    (MSFIND: ge.(Ge.find_fptr_owner) (Args.get_fptr args) ms)
    (INIT: ms.(ModSem.initial_frame) args st_init):
    step ge (Callstate args frs)
         E0 (State ((Frame.mk ms st_init) :: frs))

| step_internal
    fr0 frs tr st0
    (STEP: Step (fr0.(Frame.ms)) fr0.(Frame.st) tr st0):
    step ge (State (fr0 :: frs))
         tr (State (((Frame.update_st fr0) st0) :: frs))
| step_return
    fr0 fr1 frs retv st0
    (FINAL: fr0.(Frame.ms).(ModSem.final_frame) fr0.(Frame.st) retv)
    (AFTER: fr1.(Frame.ms).(ModSem.after_external) fr1.(Frame.st) retv st0):
    step ge (State (fr0 :: fr1 :: frs))
         E0 (State (((Frame.update_st fr1) st0) :: frs)).

Section SEMANTICS.

  Variable p: program.

  Definition link_sk: option Sk.t := link_list (List.map Mod.sk p).

  Definition skenv_fill_internals (skenv: SkEnv.t): SkEnv.t :=
    (Genv_map_defs skenv) (fun _ gd => Some
                                      match gd with
                                      | Gfun (External ef) => (Gfun (Internal (ef_sig ef)))
                                      | Gfun _ => gd
                                      | Gvar gv => gd
                                      end).

  Definition load_system (skenv: SkEnv.t): (ModSem.t * SkEnv.t) :=
    (System.modsem skenv, (skenv_fill_internals skenv)).

  Definition load_modsems (skenv: SkEnv.t): list ModSem.t := List.map ((flip Mod.modsem) skenv) p.

  Definition load_genv (init_skenv: SkEnv.t): Ge.t :=
    let (system, skenv) := load_system init_skenv in
    (system :: (load_modsems init_skenv), init_skenv).

  (* Making dummy_module that calls main? => Then what is sk of it? Memory will be different with physical linking *)
  Inductive initial_state: state -> Prop :=
  | initial_state_intro
      sk_link skenv_link m_init fptr_init
      (INITSK: link_sk = Some sk_link)
      (INITSKENV: (Sk.load_skenv sk_link) = skenv_link)
      (INITMEM: (Sk.load_mem sk_link) = Some m_init)
      (FPTR: fptr_init = (Genv.symbol_address skenv_link sk_link.(prog_main) Ptrofs.zero))
      (SIG: (Genv.find_funct skenv_link) fptr_init = Some (Internal signature_main))
      (WF: forall md (IN: In md p), <<WF: Sk.wf md>>):
      initial_state (Callstate (Args.mk fptr_init [] m_init) []).

  Inductive final_state: state -> int -> Prop :=
  | final_state_intro
      fr0 retv i
      (FINAL: fr0.(Frame.ms).(ModSem.final_frame) fr0.(Frame.st) retv)
      (INT: (Retv.v retv) = Vint i):
      final_state (State [fr0]) i.

  Definition sem: semantics :=
    (Semantics_gen (fun _ => step) initial_state final_state
                   (match link_sk with
                    | Some sk_link => load_genv (Sk.load_skenv sk_link)
                    | None => (nil, SkEnv.empty)
                    end)
                   (* NOTE: The symbolenv here is never actually evoked in our semantics. Putting this value is merely for our convenience. (lifting receptive/determinate) Whole proof should be sound even if we put dummy data here. *)
                   (match link_sk with
                    | Some sk_link => (Sk.load_skenv sk_link)
                    | None => SkEnv.empty
                    end)).
  (* Note: I don't want to make it option type. If it is option type, there is a problem. *)
  (* I have to state this way:
```
Variable sem_src: semantics.
Hypothesis LOADSRC: load p_src = Some sem_src.
```
Then, sem_src.(state) is not evaluatable.
   *)
  (* However, if it is not option type.
```
Let sem_src := semantics prog.
```
Then, sem_src.(state) is evaluatable.
   *)

End SEMANTICS.

Hint Unfold link_sk load_modsems load_genv.