(* An intermediate language between our IR and RTL *)
Require Import RTL.
Require Import Globalenvs.
Require Import Coqlib.
Require Import Values.
Require Import Integers.
Require Import Maps.
Require Import common.
Require Import Smallstep.
Require Import primitives.
Require Import Registers.

(** * RTLblock  *)
(* we first define an alternate version of RTL where we have blocks of instructions *)
(* The IR will first be transformed to RTLblock, then to RTL *)

(* Instructions inside of blocks *)
(* Compared to RTL, we don't see the next PC, these will be put in a list *)
(* The only possible calls are calls to external primitives *)
Inductive block_instr : Type :=
| Bop: Op.operation -> list reg -> reg -> block_instr
| Bcall: ext_primitive -> list reg -> reg -> block_instr.

(* At the end of a block *)
(* All possible returns need return a register (not an option) *)
Inductive exit_instr: Type :=
| Bnop : label -> exit_instr
| Bcond : Op.condition -> list reg -> label -> label -> exit_instr
| Breturn : reg -> exit_instr.

(* Blocks that we generate that correspond to our IR instructions *)
(* Either Basic blocks: sequential instructions ending in an exit_instr *)
(* Or a Conditional block: first, an instruction to evaluate the assume guard
   then, a condition. either the condition evaluates to TRUE, then we go to the next label  *)
(* And if false we go through another basic block: the DEOPT branch *)
(* NEW version of the Cblock *)
(* Now, we include the operation and the list of registers that correspond to evaluating the guard expression *)
Definition basic_block : Type := list block_instr * exit_instr.

Inductive block : Type :=
| Bblock : basic_block -> block
| Cblock : Op.operation -> list reg -> label -> basic_block -> block.

(* Blocks are indexed by labels *)
Definition block_code: Type := PTree.t block.

(* A program can hold a single RTL function during compilation *)
Definition cont_idx: Type := PTree.t label.
Definition RTLblockfun: Type := fun_id * block_code * label * cont_idx.

Definition get_block (rtlb:RTLblockfun) (lbl:positive) : option block :=
  match rtlb with
  | (fid, blkc, entry, contidx) =>
    PTree.get lbl blkc
  end.

(** * Semantic States *)
(* no memory, no stack: our instructions don't modify them *)
Inductive block_state : Type :=
| BPF: label -> regset -> block_state (* Pre-fetching: At a label *)
| BState: block -> regset -> block_state (* Inside a block *)
| BFinal: int -> block_state.

Definition init_regset : regset :=
  Regmap.init Vundef.

(** * Evaluating Operations *)
(* Partial functions that don't need a global env or a stack pointer *)
(* We'll show that all the expr we generated work for these functions *)
(* And we'll show that these coincide with the full functions *)
Require Import Op.

(* Only for the addressing we generate *)
Definition block_eval_addressing32 (addr: addressing) (vl: list val) : option val :=
  match addr, vl with
  | Aindexed n, v1::nil =>
    Some (Val.add v1 (Vint (Int.repr n)))
  | Aindexed2 n, v1::v2::nil =>
    Some (Val.add (Val.add v1 v2) (Vint (Int.repr n)))
  | _, _ => None
  end.

Lemma eval_addressing_correct:
  forall F V (ge:Genv.t F V) sp addr vl v,
    block_eval_addressing32 addr vl = Some v ->
    eval_addressing32 ge sp addr vl = Some v.
Proof.
  intros F V ge sp addr vl v H. destruct addr; simpl; inv H; auto.
Qed.

(* Only for the conditions we generate *)
Definition block_eval_condition (cond: condition) (vl: list val): option bool :=
  match cond, vl with
  | Ccomp c, v1 :: v2 :: nil => Val.cmp_bool c v1 v2
  | Ccompimm c n, v1 :: nil => Val.cmp_bool c v1 (Vint n)
  | _, _ => None
  end.

Lemma eval_condition_correct:
  forall m cond vl b,
    block_eval_condition cond vl = Some b ->
    eval_condition cond vl m = Some b.
Proof.
  intros m cond vl b H. destruct cond; inv H; auto.
Qed.

Definition optval_of_optbool (ob:option bool) : option val :=
  match ob with
  | Some true => Some Vtrue
  | Some false => Some Vfalse
  | None => None
  end.

(* Only for the operations we generate *)
Definition block_eval_operation (op: operation) (vl: list val): option val :=
  match op, vl with
  | Ointconst n, nil => Some (Vint n)
  | Oneg, v1::nil => Some (Val.neg v1)
  | Osub, v1::v2::nil => Some (Val.sub v1 v2)
  | Omul, v1::v2::nil => Some (Val.mul v1 v2)
  | Omulimm n, v1::nil => Some (Val.mul v1 (Vint n))
  | Olea addr, _ => block_eval_addressing32 addr vl (* partial version *)
  | Ocmp c, _ => optval_of_optbool (block_eval_condition c vl) (* partial version *)
  | Omod, v1::v2::nil => Val.mods v1 v2
  | _, _ => None
  end.

Lemma eval_operation_correct:
  forall F V (ge:Genv.t F V) sp m op vl v,
    block_eval_operation op vl = Some v ->
    eval_operation ge sp op vl m = Some v.
Proof.
  intros F V ge sp m op vl v H. destruct op; simpl; inv H; auto.
  - rewrite H1. eapply eval_addressing_correct in H1. eauto.
  - destruct (block_eval_condition cond vl) eqn:COND; inv H1.
    eapply eval_condition_correct in COND. rewrite COND. destruct b; inv H0; simpl; auto.
Qed.


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

(** Correctness proof for code linearization *)

Require Import FSets.
Require Import Coqlib Maps Ordered Errors Lattice Kildall Integers.
Require Import AST Linking.
Require Import Values Memory Events Globalenvs Smallstep.
Require Import Op Locations LTL Linear.
Require Import Linearize.

Module NodesetFacts := FSetFacts.Facts(Nodeset).

Definition match_prog (p: LTL.program) (tp: Linear.program) :=
  match_program (fun ctx f tf => transf_fundef f = OK tf) eq p tp.

Lemma transf_program_match:
  forall p tp, transf_program p = OK tp -> match_prog p tp.
Proof.
  intros. eapply match_transform_partial_program; eauto.
Qed.

Section LINEARIZATION.
Context `{external_calls_prf: ExternalCalls}.

Variable prog: LTL.program.
Variable tprog: Linear.program.

Hypothesis TRANSF: match_prog prog tprog.

Let ge := Genv.globalenv prog.
Let tge := Genv.globalenv tprog.

Lemma functions_translated:
  forall v f,
  Genv.find_funct ge v = Some f ->
  exists tf,
  Genv.find_funct tge v = Some tf /\ transf_fundef f = OK tf.
Proof (Genv.find_funct_transf_partial TRANSF).

Lemma function_ptr_translated:
  forall v f,
  Genv.find_funct_ptr ge v = Some f ->
  exists tf,
  Genv.find_funct_ptr tge v = Some tf /\ transf_fundef f = OK tf.
Proof (Genv.find_funct_ptr_transf_partial TRANSF).

Lemma symbols_preserved:
  forall id,
  Genv.find_symbol tge id = Genv.find_symbol ge id.
Proof (Genv.find_symbol_transf_partial TRANSF).

Lemma senv_preserved:
  Senv.equiv ge tge.
Proof (Genv.senv_transf_partial TRANSF).

Lemma genv_next_preserved:
  Genv.genv_next tge = Genv.genv_next ge.
Proof.
  apply senv_preserved.
Qed.

Lemma sig_preserved:
  forall f tf,
  transf_fundef f = OK tf ->
  Linear.funsig tf = LTL.funsig f.
Proof.
  unfold transf_fundef, transf_partial_fundef; intros.
  destruct f. monadInv H. monadInv EQ. reflexivity.
  inv H. reflexivity.
Qed.

Lemma stacksize_preserved:
  forall f tf,
  transf_function f = OK tf ->
  Linear.fn_stacksize tf = LTL.fn_stacksize f.
Proof.
  intros. monadInv H. auto.
Qed.

Lemma find_function_translated:
  forall ros ls f,
  LTL.find_function ge ros ls = Some f ->
  exists tf,
  find_function tge ros ls = Some tf /\ transf_fundef f = OK tf.
Proof.
  unfold LTL.find_function; intros; destruct ros; simpl.
  apply functions_translated; auto.
  rewrite symbols_preserved. destruct (Genv.find_symbol ge i).
  apply function_ptr_translated; auto.
  congruence.
Qed.

(** * Correctness of reachability analysis *)

(** The entry point of the function is reachable. *)

Lemma reachable_entrypoint:
  forall f, (reachable f)!!(f.(fn_entrypoint)) = true.
Proof.
  intros. unfold reachable.
  caseEq (reachable_aux f).
  unfold reachable_aux; intros reach A.
  assert (LBoolean.ge reach!!(f.(fn_entrypoint)) true).
  eapply DS.fixpoint_entry. eexact A. auto.
  unfold LBoolean.ge in H. tauto.
  intros. apply PMap.gi.
Qed.

(** The successors of a reachable instruction are reachable. *)

Lemma reachable_successors:
  forall f pc pc' b,
  f.(LTL.fn_code)!pc = Some b -> In pc' (successors_block b) ->
  (reachable f)!!pc = true ->
  (reachable f)!!pc' = true.
Proof.
  intro f. unfold reachable.
  caseEq (reachable_aux f).
  unfold reachable_aux. intro reach; intros.
  assert (LBoolean.ge reach!!pc' reach!!pc).
  change (reach!!pc) with ((fun pc r => r) pc (reach!!pc)).
  eapply DS.fixpoint_solution; eauto. intros; apply DS.L.eq_refl.
  elim H3; intro. congruence. auto.
  intros. apply PMap.gi.
Qed.

(** * Properties of node enumeration *)

(** An enumeration of CFG nodes is correct if the following conditions hold:
- All nodes for reachable basic blocks must be in the list.
- The list is without repetition (so that no code duplication occurs).

We prove that the result of the [enumerate] function satisfies both
conditions. *)

Lemma nodeset_of_list_correct:
  forall l s s',
  nodeset_of_list l s = OK s' ->
  list_norepet l
  /\ (forall pc, Nodeset.In pc s' <-> Nodeset.In pc s \/ In pc l)
  /\ (forall pc, In pc l -> ~Nodeset.In pc s).
Proof.
  induction l; simpl; intros.
  inv H. split. constructor. split. intro; tauto. intros; tauto.
  generalize H; clear H; caseEq (Nodeset.mem a s); intros.
  inv H0.
  exploit IHl; eauto. intros [A [B C]].
  split. constructor; auto. red; intro. elim (C a H1). apply Nodeset.add_1. hnf. auto.
  split. intros. rewrite B. rewrite NodesetFacts.add_iff.
  unfold Nodeset.E.eq. unfold OrderedPositive.eq. tauto.
  intros. destruct H1. subst pc. rewrite NodesetFacts.not_mem_iff. auto.
  generalize (C pc H1). rewrite NodesetFacts.add_iff. tauto.
Qed.

Lemma check_reachable_correct:
  forall f reach s pc i,
  check_reachable f reach s = true ->
  f.(LTL.fn_code)!pc = Some i ->
  reach!!pc = true ->
  Nodeset.In pc s.
Proof.
  intros f reach s.
  assert (forall l ok,
    List.fold_left (fun a p => check_reachable_aux reach s a (fst p) (snd p)) l ok = true ->
    ok = true /\
    (forall pc i,
     In (pc, i) l ->
     reach!!pc = true ->
     Nodeset.In pc s)).
  induction l; simpl; intros.
  split. auto. intros. destruct H0.
  destruct a as [pc1 i1]. simpl in H.
  exploit IHl; eauto. intros [A B].
  unfold check_reachable_aux in A.
  split. destruct (reach!!pc1). elim (andb_prop _ _ A). auto. auto.
  intros. destruct H0. inv H0. rewrite H1 in A. destruct (andb_prop _ _ A).
  apply Nodeset.mem_2; auto.
  eauto.

  intros pc i. unfold check_reachable. rewrite PTree.fold_spec. intros.
  exploit H; eauto. intros [A B]. eapply B; eauto.
  apply PTree.elements_correct. eauto.
Qed.

Lemma enumerate_complete:
  forall f enum pc i,
  enumerate f = OK enum ->
  f.(LTL.fn_code)!pc = Some i ->
  (reachable f)!!pc = true ->
  In pc enum.
Proof.
  intros until i. unfold enumerate.
  set (reach := reachable f).
  intros. monadInv H.
  generalize EQ0; clear EQ0. caseEq (check_reachable f reach x); intros; inv EQ0.
  exploit check_reachable_correct; eauto. intro.
  exploit nodeset_of_list_correct; eauto. intros [A [B C]].
  rewrite B in H2. destruct H2. elim (Nodeset.empty_1 H2). auto.
Qed.

Lemma enumerate_norepet:
  forall f enum,
  enumerate f = OK enum ->
  list_norepet enum.
Proof.
  intros until enum. unfold enumerate.
  set (reach := reachable f).
  intros. monadInv H.
  generalize EQ0; clear EQ0. caseEq (check_reachable f reach x); intros; inv EQ0.
  exploit nodeset_of_list_correct; eauto. intros [A [B C]]. auto.
Qed.

(** * Properties related to labels *)

(** If labels are globally unique and the Linear code [c] contains
  a subsequence [Llabel lbl :: c1], then [find_label lbl c] returns [c1].
*)

Fixpoint unique_labels (c: code) : Prop :=
  match c with
  | nil => True
  | Llabel lbl :: c => ~(In (Llabel lbl) c) /\ unique_labels c
  | i :: c => unique_labels c
  end.

Lemma find_label_unique:
  forall lbl c1 c2 c3,
  is_tail (Llabel lbl :: c1) c2 ->
  unique_labels c2 ->
  find_label lbl c2 = Some c3 ->
  c1 = c3.
Proof.
  induction c2.
  simpl; intros; discriminate.
  intros c3 TAIL UNIQ. simpl.
  generalize (is_label_correct lbl a). case (is_label lbl a); intro ISLBL.
  subst a. intro. inversion TAIL. congruence.
  elim UNIQ; intros. elim H4. apply is_tail_in with c1; auto.
  inversion TAIL. congruence. apply IHc2. auto.
  destruct a; simpl in UNIQ; tauto.
Qed.

(** Correctness of the [starts_with] test. *)

Lemma starts_with_correct:
  forall lm,
  forall lbl c1 c2 c3 s f sp ls m,
  is_tail c1 c2 ->
  unique_labels c2 ->
  starts_with lbl c1 = true ->
  find_label lbl c2 = Some c3 ->
  plus (step lm) tge (State s f sp c1 ls m)
             E0 (State s f sp c3 ls m).
Proof.
  induction c1.
  simpl; intros; discriminate.
  simpl starts_with. destruct a; try (intros; discriminate).
  intros.
  apply plus_left with E0 (State s f sp c1 ls m) E0.
  simpl. constructor.
  destruct (peq lbl l).
  subst l. replace c3 with c1. constructor.
  apply find_label_unique with lbl c2; auto.
  apply plus_star.
  apply IHc1 with c2; auto. eapply is_tail_cons_left; eauto.
  traceEq.
Qed.

(** Connection between [find_label] and linearization. *)

Lemma find_label_add_branch:
  forall lbl k s,
  find_label lbl (add_branch s k) = find_label lbl k.
Proof.
  intros. unfold add_branch. destruct (starts_with s k); auto.
Qed.

Lemma find_label_lin_block:
  forall lbl k b,
  find_label lbl (linearize_block b k) = find_label lbl k.
Proof.
  intros lbl k. generalize (find_label_add_branch lbl k); intro.
  induction b; simpl; auto. destruct a; simpl; auto.
  case (starts_with s1 k); simpl; auto.
Qed.

Remark linearize_body_cons:
  forall f pc enum,
  linearize_body f (pc :: enum) =
  match f.(LTL.fn_code)!pc with
  | None => linearize_body f enum
  | Some b => Llabel pc :: linearize_block b (linearize_body f enum)
  end.
Proof.
  intros. unfold linearize_body. rewrite list_fold_right_eq.
  unfold linearize_node. destruct (LTL.fn_code f)!pc; auto.
Qed.

Lemma find_label_lin_rec:
  forall f enum pc b,
  In pc enum ->
  f.(LTL.fn_code)!pc = Some b ->
  exists k, find_label pc (linearize_body f enum) = Some (linearize_block b k).
Proof.
  induction enum; intros.
  elim H.
  rewrite linearize_body_cons.
  destruct (peq a pc).
  subst a. exists (linearize_body f enum).
  rewrite H0. simpl. rewrite peq_true. auto.
  assert (In pc enum). simpl in H. tauto.
  destruct (IHenum pc b H1 H0) as [k FIND].
  exists k. destruct (LTL.fn_code f)!a.
  simpl. rewrite peq_false. rewrite find_label_lin_block. auto. auto.
  auto.
Qed.

Lemma find_label_lin:
  forall f tf pc b,
  transf_function f = OK tf ->
  f.(LTL.fn_code)!pc = Some b ->
  (reachable f)!!pc = true ->
  exists k,
  find_label pc (fn_code tf) = Some (linearize_block b k).
Proof.
  intros. monadInv H. simpl.
  rewrite find_label_add_branch. apply find_label_lin_rec.
  eapply enumerate_complete; eauto. auto.
Qed.

Lemma find_label_lin_inv:
  forall f tf pc b k,
  transf_function f = OK tf ->
  f.(LTL.fn_code)!pc = Some b ->
  (reachable f)!!pc = true ->
  find_label pc (fn_code tf) = Some k ->
  exists k', k = linearize_block b k'.
Proof.
  intros. exploit find_label_lin; eauto. intros [k' FIND].
  exists k'. congruence.
Qed.

(** Unique label property for linearized code. *)

Lemma label_in_add_branch:
  forall lbl s k,
  In (Llabel lbl) (add_branch s k) -> In (Llabel lbl) k.
Proof.
  intros until k; unfold add_branch.
  destruct (starts_with s k); simpl; intuition congruence.
Qed.

Lemma label_in_lin_block:
  forall lbl k b,
  In (Llabel lbl) (linearize_block b k) -> In (Llabel lbl) k.
Proof.
  induction b; simpl; intros. auto.
  destruct a; simpl in H; try (intuition congruence).
  apply label_in_add_branch with s; intuition congruence.
  destruct (starts_with s1 k); simpl in H.
  apply label_in_add_branch with s1; intuition congruence.
  apply label_in_add_branch with s2; intuition congruence.
Qed.

Lemma label_in_lin_rec:
  forall f lbl enum,
  In (Llabel lbl) (linearize_body f enum) -> In lbl enum.
Proof.
  induction enum.
  simpl; auto.
  rewrite linearize_body_cons. destruct (LTL.fn_code f)!a.
  simpl. intros [A|B]. left; congruence.
  right. apply IHenum. eapply label_in_lin_block; eauto.
  intro; right; auto.
Qed.

Lemma unique_labels_add_branch:
  forall lbl k,
  unique_labels k -> unique_labels (add_branch lbl k).
Proof.
  intros; unfold add_branch.
  destruct (starts_with lbl k); simpl; intuition.
Qed.

Lemma unique_labels_lin_block:
  forall k b,
  unique_labels k -> unique_labels (linearize_block b k).
Proof.
  induction b; intros; simpl. auto.
  destruct a; auto; try (apply unique_labels_add_branch; auto).
  case (starts_with s1 k); simpl; apply unique_labels_add_branch; auto.
Qed.

Lemma unique_labels_lin_rec:
  forall f enum,
  list_norepet enum ->
  unique_labels (linearize_body f enum).
Proof.
  induction enum.
  simpl; auto.
  rewrite linearize_body_cons.
  intro. destruct (LTL.fn_code f)!a.
  simpl. split. red. intro. inversion H. elim H3.
  apply label_in_lin_rec with f.
  apply label_in_lin_block with b. auto.
  apply unique_labels_lin_block. apply IHenum. inversion H; auto.
  apply IHenum. inversion H; auto.
Qed.

Lemma unique_labels_transf_function:
  forall f tf,
  transf_function f = OK tf ->
  unique_labels (fn_code tf).
Proof.
  intros. monadInv H. simpl.
  apply unique_labels_add_branch.
  apply unique_labels_lin_rec. eapply enumerate_norepet; eauto.
Qed.

(** Correctness of [add_branch]. *)

Lemma is_tail_find_label:
  forall lbl c2 c1,
  find_label lbl c1 = Some c2 -> is_tail c2 c1.
Proof.
  induction c1; simpl.
  intros; discriminate.
  case (is_label lbl a). intro. injection H; intro. subst c2.
  constructor. constructor.
  intro. constructor. auto.
Qed.

Lemma is_tail_add_branch:
  forall lbl c1 c2, is_tail (add_branch lbl c1) c2 -> is_tail c1 c2.
Proof.
  intros until c2. unfold add_branch. destruct (starts_with lbl c1).
  auto. eauto with coqlib.
Qed.

Lemma is_tail_lin_block:
  forall b c1 c2,
  is_tail (linearize_block b c1) c2 -> is_tail c1 c2.
Proof.
  induction b; simpl; intros.
  auto.
  destruct a; eauto with coqlib.
  eapply is_tail_add_branch; eauto.
  destruct (starts_with s1 c1); eapply is_tail_add_branch; eauto with coqlib.
Qed.

Lemma add_branch_correct:
  forall lm,
  forall lbl c k s f tf sp ls m,
  transf_function f = OK tf ->
  is_tail k tf.(fn_code) ->
  find_label lbl tf.(fn_code) = Some c ->
  plus (step lm) tge (State s tf sp (add_branch lbl k) ls m)
             E0 (State s tf sp c ls m).
Proof.
  intros. unfold add_branch.
  caseEq (starts_with lbl k); intro SW.
  eapply starts_with_correct; eauto.
  eapply unique_labels_transf_function; eauto.
  apply plus_one. apply exec_Lgoto. auto.
Qed.

(** * Correctness of linearization *)

(** The proof of semantic preservation is a simulation argument of the "star" kind:
<<
           st1 --------------- st2
            |                   |
           t|                  t| + or ( 0 \/ |st1'| < |st1| )
            |                   |
            v                   v
           st1'--------------- st2'
>>
  The invariant (horizontal lines above) is the [match_states]
  predicate defined below.  It captures the fact that the flow
  of data is the same in the source and linearized codes.
  Moreover, whenever the source state is at node [pc] in its
  control-flow graph, the transformed state is at a code
  sequence [c] that starts with the label [pc]. *)

Inductive match_stackframes: LTL.stackframe -> Linear.stackframe -> Prop :=
  | match_stackframe_intro:
      forall f sp bb ls tf c,
      transf_function f = OK tf ->
      (forall pc, In pc (successors_block bb) -> (reachable f)!!pc = true) ->
      is_tail c tf.(fn_code) ->
      match_stackframes
        (LTL.Stackframe f sp ls bb)
        (Linear.Stackframe tf sp ls (linearize_block bb c)).

Inductive match_states: LTL.state -> Linear.state -> Prop :=
  | match_states_add_branch:
      forall s f sp pc ls m tf ts c
        (STACKS: list_forall2 match_stackframes s ts)
        (TRF: transf_function f = OK tf)
        (REACH: (reachable f)!!pc = true)
        (TAIL: is_tail c tf.(fn_code)),
      match_states (LTL.State s f sp pc ls m)
                   (Linear.State ts tf sp (add_branch pc c) ls m)
  | match_states_cond_taken:
      forall s f sp pc ls m tf ts cond args c
        (STACKS: list_forall2 match_stackframes s ts)
        (TRF: transf_function f = OK tf)
        (REACH: (reachable f)!!pc = true)
        (JUMP: eval_condition cond (reglist ls args) m = Some true),
      match_states (LTL.State s f sp pc (undef_regs (destroyed_by_cond cond) ls) m)
                   (Linear.State ts tf sp (Lcond cond args pc :: c) ls m)
  | match_states_jumptable:
      forall s f sp pc ls m tf ts arg tbl c n
        (STACKS: list_forall2 match_stackframes s ts)
        (TRF: transf_function f = OK tf)
        (REACH: (reachable f)!!pc = true)
        (ARG: ls (R arg) = Vint n)
        (JUMP: list_nth_z tbl (Int.unsigned n) = Some pc),
      match_states (LTL.State s f sp pc (undef_regs destroyed_by_jumptable ls) m)
                   (Linear.State ts tf sp (Ljumptable arg tbl :: c) ls m)
  | match_states_block:
      forall s f sp bb ls m tf ts c
        (STACKS: list_forall2 match_stackframes s ts)
        (TRF: transf_function f = OK tf)
        (REACH: forall pc, In pc (successors_block bb) -> (reachable f)!!pc = true)
        (TAIL: is_tail c tf.(fn_code)),
      match_states (LTL.Block s f sp bb ls m)
                   (Linear.State ts tf sp (linearize_block bb c) ls m)
  | match_states_call:
      forall s f ls m tf ts,
      list_forall2 match_stackframes s ts ->
      transf_fundef f = OK tf ->
      match_states (LTL.Callstate s f ls m)
                   (Linear.Callstate ts tf ls m)
  | match_states_return:
      forall s ls m ts,
      list_forall2 match_stackframes s ts ->
      match_states (LTL.Returnstate s ls m)
                   (Linear.Returnstate ts ls m).

Definition measure (S: LTL.state) : nat :=
  match S with
  | LTL.State s f sp pc ls m => 0%nat
  | LTL.Block s f sp bb ls m => 1%nat
  | _ => 0%nat
  end.

Section WITHINITLS.

Variable init_ls: locset.

Remark match_parent_locset:
  forall s ts, list_forall2 match_stackframes s ts -> parent_locset init_ls ts = LTL.parent_locset init_ls s.
Proof.
  induction 1; simpl. auto. inv H; auto.
Qed.

Theorem transf_step_correct:
  forall s1 t s2, LTL.step init_ls ge s1 t s2 ->
  forall s1' (MS: match_states s1 s1'),
  (exists s2', plus (Linear.step init_ls) tge s1' t s2' /\ match_states s2 s2')
  \/ (measure s2 < measure s1 /\ t = E0 /\ match_states s2 s1')%nat.
Proof.
  induction 1; intros; try (inv MS).

  (* start of block, at an [add_branch] *)
  exploit find_label_lin; eauto. intros [k F].
  left; econstructor; split.
  eapply add_branch_correct; eauto.
  econstructor; eauto.
  intros; eapply reachable_successors; eauto.
  eapply is_tail_lin_block; eauto. eapply is_tail_find_label; eauto.

  (* start of block, target of an [Lcond] *)
  exploit find_label_lin; eauto. intros [k F].
  left; econstructor; split.
  apply plus_one. eapply exec_Lcond_true; eauto.
  econstructor; eauto.
  intros; eapply reachable_successors; eauto.
  eapply is_tail_lin_block; eauto. eapply is_tail_find_label; eauto.

  (* start of block, target of an [Ljumptable] *)
  exploit find_label_lin; eauto. intros [k F].
  left; econstructor; split.
  apply plus_one. eapply exec_Ljumptable; eauto.
  econstructor; eauto.
  intros; eapply reachable_successors; eauto.
  eapply is_tail_lin_block; eauto. eapply is_tail_find_label; eauto.

  (* Lop *)
  left; econstructor; split. simpl.
  apply plus_one. econstructor; eauto.
  instantiate (1 := v); rewrite <- H; apply eval_operation_preserved.
  exact symbols_preserved.
  econstructor; eauto.

  (* Lload *)
  left; econstructor; split. simpl.
  apply plus_one. econstructor.
  instantiate (1 := a). rewrite <- H; apply eval_addressing_preserved.
  exact symbols_preserved. eauto. eauto.
  econstructor; eauto.

  (* Lgetstack *)
  left; econstructor; split. simpl.
  apply plus_one. econstructor; eauto.
  econstructor; eauto.

  (* Lsetstack *)
  left; econstructor; split. simpl.
  apply plus_one. econstructor; eauto.
  econstructor; eauto.

  (* Lstore *)
  left; econstructor; split. simpl.
  apply plus_one. econstructor.
  instantiate (1 := a). rewrite <- H; apply eval_addressing_preserved.
  exact symbols_preserved. eauto. eauto.
  econstructor; eauto.

  (* Lcall *)
  exploit find_function_translated; eauto. intros [tfd [A B]].
  left; econstructor; split. simpl.
  apply plus_one. econstructor; eauto.
  symmetry; eapply sig_preserved; eauto.
  econstructor; eauto. constructor; auto. econstructor; eauto.

  (* Ltailcall *)
  exploit find_function_translated; eauto. intros [tfd [A B]].
  left; econstructor; split. simpl.
  apply plus_one. econstructor; eauto.
  rewrite (match_parent_locset _ _ STACKS). eauto.
  symmetry; eapply sig_preserved; eauto.
  rewrite (stacksize_preserved _ _ TRF); eauto.
  rewrite (match_parent_locset _ _ STACKS).
  econstructor; eauto.

  (* Lbuiltin *)
  left; econstructor; split. simpl.
  apply plus_one. eapply exec_Lbuiltin; eauto.
  eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved.
  eapply external_call_symbols_preserved; eauto. apply senv_preserved.
  econstructor; eauto.

  (* Lbranch *)
  assert ((reachable f)!!pc = true). apply REACH; simpl; auto.
  right; split. simpl; omega. split. auto. simpl. econstructor; eauto.

  (* Lcond *)
  assert (REACH1: (reachable f)!!pc1 = true) by (apply REACH; simpl; auto).
  assert (REACH2: (reachable f)!!pc2 = true) by (apply REACH; simpl; auto).
  simpl linearize_block.
  destruct (starts_with pc1 c).
  (* branch if cond is false *)
  assert (DC: destroyed_by_cond (negate_condition cond) = destroyed_by_cond cond).
    destruct cond; reflexivity.
  destruct b.
  (* cond is true: no branch *)
  left; econstructor; split.
  apply plus_one. eapply exec_Lcond_false.
  rewrite eval_negate_condition. rewrite H. auto. eauto.
  rewrite DC. econstructor; eauto.
  (* cond is false: branch is taken *)
  right; split. simpl; omega. split. auto.  rewrite <- DC. econstructor; eauto.
  rewrite eval_negate_condition. rewrite H. auto.
  (* branch if cond is true *)
  destruct b.
  (* cond is true: branch is taken *)
  right; split. simpl; omega. split. auto. econstructor; eauto.
  (* cond is false: no branch *)
  left; econstructor; split.
  apply plus_one. eapply exec_Lcond_false. eauto. eauto.
  econstructor; eauto.

  (* Ljumptable *)
  assert (REACH': (reachable f)!!pc = true).
    apply REACH. simpl. eapply list_nth_z_in; eauto.
  right; split. simpl; omega. split. auto. econstructor; eauto.

  (* Lreturn *)
  left; econstructor; split.
  simpl. apply plus_one. econstructor; eauto.
  rewrite (stacksize_preserved _ _ TRF). eauto.
  rewrite (match_parent_locset _ _ STACKS). econstructor; eauto.

  (* internal functions *)
  assert (REACH: (reachable f)!!(LTL.fn_entrypoint f) = true).
    apply reachable_entrypoint.
  monadInv H7.
  left; econstructor; split.
  apply plus_one. eapply exec_function_internal; eauto.
  rewrite (stacksize_preserved _ _ EQ). eauto.
  generalize EQ; intro EQ'; monadInv EQ'. simpl.
  econstructor; eauto. simpl. eapply is_tail_add_branch. constructor.

  (* external function *)
  monadInv H8. left; econstructor; split.
  apply plus_one. eapply exec_function_external; eauto.
  eapply external_call_symbols_preserved; eauto. apply senv_preserved.
  econstructor; eauto.

  (* return *)
  inv H3. inv H1.
  left; econstructor; split.
  apply plus_one. econstructor.
  econstructor; eauto.
Qed.

Lemma transf_initial_states:
  forall st1, LTL.initial_state prog st1 ->
  exists st2, Linear.initial_state tprog st2 /\ match_states st1 st2.
Proof.
  intros. inversion H.
  exploit function_ptr_translated; eauto. intros [tf [A B]].
  exists (Callstate nil tf (Locmap.init Vundef) m0); split.
  econstructor; eauto. eapply (Genv.init_mem_transf_partial TRANSF); eauto.
  rewrite (match_program_main TRANSF).
  rewrite symbols_preserved. eauto.
  rewrite <- H3. apply sig_preserved. auto.
  constructor. constructor. auto.
Qed.

Lemma transf_final_states:
  forall st1 st2 r,
  match_states st1 st2 -> LTL.final_state st1 r -> Linear.final_state st2 r.
Proof.
  intros. inv H0. inv H. inv H5. econstructor; eauto.
Qed.

End WITHINITLS.

Theorem transf_program_correct:
  forward_simulation (LTL.semantics prog) (Linear.semantics tprog).
Proof.
  eapply forward_simulation_star.
  apply senv_preserved.
  eexact transf_initial_states.
  eexact transf_final_states.
  apply transf_step_correct.
Qed.

End LINEARIZATION.


Require Import VST.floyd.proofauto.
Require Import linking.
Require Import malloc.
Require Import main_bss.
Require Import malloc_lemmas.
Require Import spec_malloc.

Definition linked_prog : Clight.program :=
 ltac: (linking.link_progs_list [malloc.prog; main_bss.prog]).

Instance CompSpecs : compspecs. make_compspecs linked_prog. Defined.

Definition Vprog : varspecs. mk_varspecs linked_prog. Defined.

Local Open Scope assert.

Definition main_spec :=
 DECLARE _main
 WITH gv: globals
 PRE [ ] main_pre linked_prog tt nil gv
 POST[ tint ]
    PROP()
    LOCAL(temp ret_temp (Vint (Int.repr 0)))
    SEP(TT).

(* proof using simple resource-tracking spec of malloc *)

Definition user_specs_R' :=
[pre_fill_spec'; try_pre_fill_spec'; malloc_spec_R_simple'; free_spec_R'].

Definition Gprog' : funspecs := [main_spec] ++ external_specs ++ user_specs_R'.

Lemma body_main': semax_body Vprog Gprog' f_main main_spec.
Proof.
start_function.
change 8 with BINS.
sep_apply (create_mem_mgr_R gv); auto.
forward. (* bb = heap *)
change 524296 with (BIGBLOCK + WORD*ALIGN).
replace Ews with Tsh by admit. (* TODO UNSOUND workaround *)
rewrite <- memory_block_data_at_.
forward_if (
    EX bb,
    (PROP (malloc_compatible BIGBLOCK bb)
     LOCAL (temp _bb bb; gvars gv)
     SEP (mem_mgr_R gv emptyResvec;
          memory_block Tsh BIGBLOCK bb;
          has_ext tt))).
admit.
(* case bb%(WORD*ALIGN) != 0 *)
forward. (* bb = bb + WORD*ALIGN - (uintptr_t)bb%(WORD*ALIGN) *)
entailer!.
admit.
Exists (offset_val (WORD*ALIGN) (gv _heap)).
entailer!.
admit.
admit. (* use memory_block_split_offset *)
(* case bb%(WORD*ALIGN) == 0 *)
forward.
Exists (gv _heap).
entailer!.
admit.
admit.
Intros bb.
rewrite <- seq_assoc.
forward_call (100, bb, gv, emptyResvec).
split; [rep_omega | auto].
admit.  (* WORKING HERE *)
Admitted.


(** A small-steps semantics for computations with constraints on the model. *)
Require Import Coq.Bool.Bool.
Require Import FunctionNinjas.All.
Require Import ErrorHandlers.All.

Module Effect.
  Record t := New {
    command : Type;
    answer : command -> Type }.
End Effect.

Module Model.
  Record t (E : Effect.t) (S : Type) := New {
    condition : Effect.command E -> S -> Prop;
    answer : forall c, S -> Effect.answer E c;
    state : Effect.command E -> S -> S }.
  Arguments New {E S} _ _ _.
  Arguments condition {E S} _ _ _.
  Arguments answer {E S} _ _ _.
  Arguments state {E S} _ _ _.
End Model.

(*Module C.
  (** The description of a computation. *)
  Inductive t (E : Effect.t) (A : Type) : Type :=
  | Ret : A -> t E A
  | Call : forall c, (Effect.answer E c -> t E A) -> t E A
  | Join : forall {B C : Type}, t E B -> t E C -> (B * C -> t E A) -> t E A.
  Arguments Ret {E A} _.
  Arguments Call {E A} _ _.
  Arguments Join {E A B C} _ _ _.

  Module Step.
    Inductive t {E : Effect.t} {S : Type} (m : Model.t E S) {A : Type} (s : S)
      : C.t E A -> S -> C.t E A -> Type :=
    | Call : forall c h,
      Model.condition m c s ->
      t m s (C.Call c h) (Model.state m c s) (h (Model.answer m c s))
    | JoinLeft : forall B C (x : C.t E B) (y : C.t E C) h s' x',
      t m (A := B) s x s' x' ->
      t m s (C.Join x y h) s' (C.Join x' y h)
    | JoinRight : forall B C (x : C.t E B) (y : C.t E C) h s' y',
      t m (A := C) s y s' y' ->
      t m s (C.Join x y h) s' (C.Join x y' h)
    | Join : forall B C (x : B) (y : C) h,
      t m s (C.Join (C.Ret x) (C.Ret y) h) s (h (x, y)).
  End Step.

  Module DeadLockFree.
    Inductive t {E : Effect.t} {S : Type} (m : Model.t E S) {A : Type} (s : S)
      : C.t E A -> Prop :=
    | Value : forall x, t m s (C.Ret x)
    | Step : forall x, (forall s' x', Step.t m s x s' x' -> t m s' x') ->
      t m s x.
  End DeadLockFree.

  Module Choose.
    Inductive t (E : Effect.t) (A : Type) : Type :=
    | Ret : A -> t E A
    | Call : forall c, (Effect.answer E c -> t E A) -> t E A
    | Choose : t E A -> t E A -> t E A.
    Arguments Ret {E A} _.
    Arguments Call {E A} _ _.
    Arguments Choose {E A} _ _.

    Module Join.
      Inductive t {E : Effect.t} {A B : Type}
        : Choose.t E A -> Choose.t E B -> Choose.t E (A * B) -> Type :=
      | RetRet : forall x y, t (Choose.Ret x) (Choose.Ret y) (Choose.Ret (x, y))
      | RetCall : .
    End Join.
  End Choose.

  Module ToChoose.
    Inductive t {E : Effect.t} {A : Type} : C.t E A -> Choose.t E A -> Type :=
    | Ret : forall x, t (C.Ret x) (Choose.Ret x)
    | Call : forall (c : Effect.command E) (h : Effect.answer E c -> C.t E A),
      (forall s, t () h') -> .
  End ToChoose.

  Module Unroll.
    Inductive t {E : Effect.t} {S : Type} (m : Model.t E S) (A : Type) : Type :=
    | Undef : t m A
    | Ret : A -> t m A
    | Condition : forall c s, (Model.condition m c s -> t m A) -> t m A
    | Schedule : (bool -> t m A) -> t m A.
    Arguments Undef {E S m A}.
    Arguments Ret {E S m A} _.
    Arguments Condition {E S m A} _ _ _.
    Arguments Schedule {E S m A} _.

    Fixpoint compile {E : Effect.t} {S : Type} (m : Model.t E S) {A : Type}
      (s : S) (x : C.t E A) : t m A :=
      match x with
      | C.Re t x => Ret x
      | C.Call c h =>
        Condition c s (fun _ =>
          compile m (Model.state m c s) (h (Model.answer m c s)))
      | C.Join _ _ (C.Ret x) (C.Ret y) h => compile m s (h (x, y))
      | C.Join _ _ x y h =>
        Schedule (fun b =>
          if b then
            )
      end.
  End Unroll.

  Module Step'.
    Inductive t {E : Effect.t} {S : Type} (m : Model.t E S) {A : Type} (s : S)
      : C.t E A -> S -> C.t E A -> Prop :=
    | Call : forall c h, Model.condition m c s ->
      t m s (C.Call c h) (Model.state m c s) (h (Model.answer m c s))
    | JoinLeft : forall B C (x : C.t E B) (y : C.t E C) h s' x',
      t m (A := B) s x s' x' ->
      t m s (C.Join x y h) s' (C.Join x' y h)
    | JoinRight : forall B C (x : C.t E B) (y : C.t E C) h s' y',
      t m (A := C) s y s' y' ->
      t m s (C.Join x y h) s' (C.Join x y' h)
    | Join : forall B C (x : B) (y : C) h,
      t m s (C.Join (C.Ret x) (C.Ret y) h) s (h (x, y)).
  End Step'.

  Module NotStuck.
    Inductive t {E : Effect.t} {S : Type} (m : Model.t E S) {A : Type}
      : S -> C.t E A -> Prop :=
    | Value : forall s x, t m s (C.Ret x)
    | Step : forall s x s' x', Step.t m s x s' x' -> t m s x.

    Fixpoint is_not_stuck {E : Effect.t} {S : Type} (m : Model.t E S) {A : Type}
      (dec : forall c s, option (Model.condition m c s)) (s : S) (x : C.t E A)
      : option (t m s x) :=
      match x with
      | Ret x => Some (Value m s x)
      | Call c h =>
        Option.bind (dec c s) (fun H =>
        Some (Step m s _ _ _ (Step.Call m s c h H)))
      | Join _ _ x y h =>
        Option.bind (is_not_stuck m dec s x) (fun H =>
          )
      end.

    Fixpoint is_not_stuck {E : Effect.t} {S : Type} (m : Model.t E S) {A : Type}
      (dec : Effect.command E -> S -> bool) (s : S) (x : C.t E A) : bool :=
      match x with
      | Ret _ => true
      | Call c h => dec c s
      | Join _ _ x y h => orb (is_not_stuck m dec s x) (is_not_stuck m dec s y)
      end.

    Fixpoint is_not_stuck_ok {E : Effect.t} {S : Type} (m : Model.t E S)
      {A : Type} (dec : Effect.command E -> S -> bool)
      (dec_ok : forall c s, dec c s = true -> Model.condition m c s) (s : S)
      (x : C.t E A) : is_not_stuck m dec s x = true -> t m s x.
      intro H.
      destruct x as [x | c h | B C x y h].
      - apply Value.
      - eapply Step.
        apply Step.Call.
        now apply dec_ok.
      - destruct (orb_prop _ _ H) as [H_x | H_y].
        + destruct (is_not_stuck_ok _ _ m _ dec dec_ok s x H_x).
    Qed.
  End NotStuck.

  Module DeadLockFree.
    Inductive t {E : Effect.t} {S : Type} (m : Model.t E S) {A : Type}
      (s : S) (x : C.t E A) : Prop :=
    | New : NotStuck.t m s x ->
      (forall s' x', Step.t m s x s' x' -> t m s' x') -> t m s x.
  End DeadLockFree.

  (*Module DeadLockFree.
    Inductive t {E : Effect.t} {S : Type} (m : Model.t E S) {A : Type}
      : S -> C.t E A -> Prop :=
    | Ret : forall s x, t m s (C.Ret x)
    | Call : forall s c h,
      (Model.condition m c s ->
        NotStuck.t m (Model.state m c s) (h (Model.answer m c s)) /\
        t m (Model.state m c s) (h (Model.answer m c s))) ->
      t m s (C.Call c h)
    | Join : .
      (s : S) (x : C.t E A) : Prop :=
      forall (x' : C.t E A) (s' : S), Steps.t m x s x' s' -> NotStuck.t m x' s'.
  End DeadLockFree.*)
End C.

Module M.
  Inductive t {E : Effect.t} {S : Type} (m : Model.t E S) (A : Type) : Type :=
  | Ret : A -> t m A
  | Call : Effect.command E -> (S -> t m A) -> t m A
  | Choose : t m A -> t m A -> t m A.
  Arguments Ret {E S m A} _.
  Arguments Call {E S m A} _ _.
  Arguments Choose {E S m A} _ _.

  (** If a computation is not stuck. *)
  Module NotStuck.
    Inductive t {E : Effect.t} {S : Type} {m : Model.t E S} {A : Type}
      : M.t m A -> S -> Prop :=
    | Ret : forall x s, t (M.Ret x) s
    | Call : forall c h s, Model.condition m c s -> t (M.Call c h) s
    | ChooseLeft : forall x1 x2 s, t x1 s -> t (M.Choose x1 x2) s
    | ChooseRight : forall x1 x2 s, t x2 s -> t (M.Choose x1 x2) s.
  End NotStuck.

  Module DeadLockFree.
    Inductive t {E : Effect.t} {S : Type} {m : Model.t E S} {A : Type}
      : M.t m A -> S -> Prop :=
    | Ret : forall x s, t (M.Ret x) s
    | Call : forall c h s,
      (Model.condition m c s ->
        let s := Model.state m c s in
        NotStuck.t (h s) s /\ t (h s) s) ->
      t (M.Call c h) s
    | Choose : forall x1 x2 s, t x1 s -> t x2 s -> t (M.Choose x1 x2) s.
  End DeadLockFree.

  Fixpoint bind {E : Effect.t} {S : Type} {m : Model.t E S} {A B : Type}
    (x : t m A) (f : A -> t m B) : t m B :=
    match x with
    | Ret x => f x
    | Call c h => Call c (fun s => bind (h s) f)
    | Choose x1 x2 => Choose (bind x1 f) (bind x2 f)
    end.

  Fixpoint join_aux {E : Effect.t} {S : Type} {m : Model.t E S} {B C : Type}
    (join : S -> t m B -> t m C) (c_x : Effect.command E)
    (y : t m B) (k : B -> t m C) : t m C :=
    match y with
    | Ret y => k y
    | Call c_y h_y =>
      Choose
        (Call c_x (fun s => join s y))
        (Call c_y (fun s => join_aux join c_x (h_y s) k))
    | Choose y1 y2 => Choose (join_aux join c_x y1 k) (join_aux join c_x y2 k)
    end.

  Fixpoint join {E : Effect.t} {S : Type} {m : Model.t E S} {A B C : Type}
    (x : t m A) (y : t m B) (k : A * B -> t m C) : t m C :=
    match x with
    | Ret x => bind y (fun y => k (x, y))
    | Call c_x h_x => join_aux (fun s y => join (h_x s) y k) c_x y (fun y => bind x (fun x => k (x, y)))
    | Choose x1 x2 => Choose (join x1 y k) (join x2 y k)
    end.

  Fixpoint compile {E : Effect.t} {S : Type} (m : Model.t E S) {A B : Type}
    (x : C.t E A) : (A -> t m B) -> t m B :=
    match x with
    | C.Ret _ x => fun k => k x
    | C.Call c => fun k => Call c (fun s => k (Model.answer m c s))
    | C.Let _ _ x f => fun k => compile m x (fun x => compile m (f x) k)
    | C.Join  _ _ x y => fun k => join (compile m x Ret) (compile m y Ret) k
    end.

  Lemma ok {E : Effect.t} {S : Type} (m : Model.t E S) {A : Type} (x : C.t E A)
    (s : S) : DeadLockFree.t (compile m x Ret) s -> C.DeadLockFree.t m x s.
  Qed.
End M.

Module ClosedCall.
  Record t {E : Effect.t} {S : Type} (m : Model.t E S) (T : Type) := New {
    c : Effect.command E;
    s : S;
    h : T }.
  Arguments New {E S m T} _ _ _.
  Arguments c {E S m T} _.
  Arguments s {E S m T} _.
  Arguments h {E S m T} _.
End ClosedCall.

(** We link the states. *)
Module ClosedM.
  Inductive t {E : Effect.t} {S : Type} (m : Model.t E S) (A : Type) : Type :=
  | Ret : A -> t m A
  | Call : Tree.t (ClosedCall.t m (t m A)) -> t m A.
  Arguments Ret {E S m A} _.
  Arguments Call {E S m A} _.

  Fixpoint compile {E : Effect.t} {S : Type} {m : Model.t E S} {A : Type}
    (x : M.t m A) (s : S) : t m A :=
    let fix compiles (tree : Tree.t (Call.t m (M.t m A)))
      : Tree.t (ClosedCall.t m (t m A)) :=
      match tree with
      | Tree.Leaf (Call.New c h) =>
        Tree.Leaf (ClosedCall.New c s (compile (h s) (Model.state m c s)))
      | Tree.Node tree1 tree2 => Tree.Node (compiles tree1) (compiles tree2)
      end in
    match x with
    | M.Ret x => Ret x
    | M.Call tree => Call (compiles tree)
    end.

  Definition of_C {E : Effect.t} {S : Type} (m : Model.t E S) {A : Type}
    (x : C.t E A) (s : S) : t m A :=
    compile (M.compile x) s.

  Module Tree.
    Module NotStuck.
      Inductive t {E : Effect.t} {S : Type} {m : Model.t E S} {A : Type}
        : Tree.t (ClosedCall.t m (ClosedM.t m A)) -> Prop :=
      | Leaf : forall c s h, Model.condition m c s ->
        t (Tree.Leaf (ClosedCall.New c s h))
      | NodeLeft : forall tree1 tree2, t tree1 -> t (Tree.Node tree1 tree2)
      | NodeRight : forall tree1 tree2, t tree2 -> t (Tree.Node tree1 tree2).
    End NotStuck.

    Module ForAll.
      Inductive t {E : Effect.t} {S : Type} {m : Model.t E S} {A : Type}
        (P : ClosedM.t m A -> Prop)
        : Tree.t (ClosedCall.t m (ClosedM.t m A)) -> Prop :=
      | Leaf : forall c s h, (Model.condition m c s -> P h) ->
        t P (Tree.Leaf (ClosedCall.New c s h))
      | Node : forall tree1 tree2, t P tree1 -> t P tree2 ->
        t P (Tree.Node tree1 tree2).
    End ForAll.
  End Tree.
End ClosedM.

Module Progress.
  Inductive t {E : Effect.t} {S : Type} {m : Model.t E S} {A : Type}
    : ClosedM.t m A -> Prop :=
  | Ret : forall x, t (ClosedM.Ret x)
  | Call : forall tree,
    ClosedM.Tree.NotStuck.t tree -> ClosedM.Tree.ForAll.t t tree ->
    t (ClosedM.Call tree).

  Definition of_C {E : Effect.t} {S : Type} (m : Model.t E S) {A : Type}
    (x : C.t E A) (s : S) : Prop :=
    t (ClosedM.of_C m x s).
End Progress.

(** Try to solve automatically the [Progress.t] predicate. *)
Module Solve.
  Module Tree.
    Fixpoint not_stuck {E : Effect.t} {S : Type} {m : Model.t E S} {A : Type}
      (dec : Effect.command E -> S -> bool)
      (tree : Tree.t (ClosedCall.t m (ClosedM.t m A))) : bool :=
      match tree with
      | Tree.Leaf (ClosedCall.New c s h) => dec c s
      | Tree.Node tree1 tree2 => orb (not_stuck dec tree1) (not_stuck dec tree2)
      end.

    Fixpoint not_stuck_ok {E : Effect.t} {S : Type} {m : Model.t E S} {A : Type}
      {dec : Effect.command E -> S -> bool}
      (dec_ok : forall c s, dec c s = true -> Model.condition m c s)
      (tree : Tree.t (ClosedCall.t m (ClosedM.t m A)))
      : not_stuck dec tree = true -> ClosedM.Tree.NotStuck.t tree.
      intro H.
      destruct tree as [call | tree1 tree2].
      - destruct call as [c s h].
        apply ClosedM.Tree.NotStuck.Leaf.
        now apply dec_ok.
      - destruct (orb_prop _ _ H).
        + apply ClosedM.Tree.NotStuck.NodeLeft.
          now apply not_stuck_ok with (dec := dec).
        + apply ClosedM.Tree.NotStuck.NodeRight.
          now apply not_stuck_ok with (dec := dec).
    Qed.
  End Tree.

  Fixpoint solve {E : Effect.t} {S : Type} {m : Model.t E S} {A : Type}
    (dec : Effect.command E -> S -> bool) (x : ClosedM.t m A)
    : option (Tree.t (ClosedCall.t m (ClosedM.t m A))) :=
    let fix for_all (tree : Tree.t (ClosedCall.t m (ClosedM.t m A)))
      : option (Tree.t (ClosedCall.t m (ClosedM.t m A))) :=
      match tree with
      | Tree.Leaf (ClosedCall.New c s h) =>
        if dec c s then
          solve dec h
        else
          None
      | Tree.Node tree1 tree2 =>
        match for_all tree1 with
        | None => for_all tree2
        | Some err => Some err
        end
      end in
    match x with
    | ClosedM.Ret _ => None
    | ClosedM.Call tree =>
      if Tree.not_stuck dec tree then
        for_all tree
      else
        Some tree
    end.

  (*Fixpoint solve_ok {E : Effect.t} {S : Type} {m : Model.t E S} {A : Type}
    {dec : Effect.command E -> S -> bool}
    (dec_true_ok : forall c s, dec c s = true -> Model.condition m c s)
    (dec_false_ok : forall c s, dec c s = false -> ~ Model.condition m c s)
    (x : ClosedM.t m A) : solve dec x = None -> Progress.t x.
    intro H.
    destruct x as [x | tree].
    - apply Progress.Ret.
    - assert (H_not_stuck : Tree.not_stuck dec tree = true) by (
        case_eq (Tree.not_stuck dec tree); trivial;
        intro Heq; simpl in H; rewrite Heq in H; congruence).
      apply Progress.Call.
      + now apply (Tree.not_stuck_ok dec_true_ok).
      + refine (
          let fix for_all t : Tree.not_stuck dec t = true ->
            ClosedM.Tree.ForAll.t Progress.t t := _ in
          for_all tree H_not_stuck).
        intro H_t_not_stuck.
        destruct t as [call | t1 t2].
        * destruct call as [c s h].
          apply ClosedM.Tree.ForAll.Leaf.
          case_eq (dec c s); intros H_dec H_condition.
          apply solve_ok with (dec := dec); trivial.
          ++ intro.
            apply solve_ok with (dec := dec); trivial.
            apply dec_true_ok.

    refine (
      let fix for_all (tree : Tree.t (ClosedCall.t m (ClosedM.t m A)))
        : ClosedM.Tree.ForAll.t Progress.t tree := _ in _).
    - destruct tree as [call | tree1 tree2].
      + destruct call as [c s h].
        apply ClosedM.Tree.ForAll.Leaf.
        case_eq (dec c s); intro H_dec.
        * intro.
          apply solve_ok with (dec := dec); trivial.
          apply dec_true_ok.
    -
  Qed.*)

  Fixpoint solve_ok {E : Effect.t} {S : Type} {m : Model.t E S} {A : Type}
    {dec : Effect.command E -> S -> bool}
    (dec_true_ok : forall c s, dec c s = true -> Model.condition m c s)
    (dec_false_ok : forall c s, dec c s = false -> ~ Model.condition m c s)
    (x : ClosedM.t m A) : solve dec x = None -> Progress.t x.
  Admitted.

  (*Fixpoint solve {E : Effect.t} {S : Type} {m : Model.t E S} {A : Type}
    (dec : forall c s, option (Model.condition m c s))
    (dec_not : forall c s, option (~ Model.condition m c s))
    (x : ClosedM.t m A)
    : Progress.t x + Tree.t (ClosedCall.t m (ClosedM.t m A)) :=
    let fix for_all (tree : Tree.t (ClosedCall.t m (ClosedM.t m A)))
      : ClosedM.Tree.ForAll.t Progress.t tree + _ :=
      match tree with
      | Tree.Leaf (ClosedCall.New c s h) =>
        match dec_not c s with
        | Some H_not =>
          inl (ClosedM.Tree.ForAll.Leaf Progress.t c s h (fun H =>
            match H_not H with end))
        | None =>
          Sum.bind (solve dec dec_not h) (fun H =>
          inl (ClosedM.Tree.ForAll.Leaf Progress.t c s h (fun _ => H)))
        end
      | Tree.Node tree1 tree2 =>
        Sum.bind (for_all tree1) (fun H1 =>
        Sum.bind (for_all tree2) (fun H2 =>
        inl (ClosedM.Tree.ForAll.Node Progress.t tree1 tree2 H1 H2)))
      end in
    match x with
    | ClosedM.Ret x => inl (Progress.Ret x)
    | ClosedM.Call tree =>
      match Tree.not_stuck dec tree with
      | Some H_not_stuck =>
        Sum.bind (for_all tree) (fun H_for_all =>
        inl (Progress.Call tree H_not_stuck H_for_all))
      | None => inr tree
      end
    end.*)
End Solve.

Module Lock.
  Definition S := bool.

  Module Command.
    Inductive t :=
    | Lock
    | Unlock.
  End Command.

  Definition E : Effect.t :=
    Effect.New Command.t (fun _ => unit).

  Definition lock : C.t E unit :=
    call E Command.Lock.

  Definition unlock : C.t E unit :=
    call E Command.Unlock.

  Module Condition.
    Inductive t : Effect.command E -> S -> Prop :=
    | Lock : t Command.Lock false
    | Unlock : t Command.Unlock true.
  End Condition.

  Definition answer (c : Effect.command E) (s : S) : Effect.answer E c :=
    tt.

  Definition state (c : Effect.command E) (s : S) : S :=
    match c with
    | Command.Lock => true
    | Command.Unlock => false
    end.

  Definition m : Model.t E S :=
    Model.New Condition.t answer state.

  Definition dec (c : Effect.command E) (s : S) : bool :=
    match (c, s) with
    | (Command.Lock, false) | (Command.Unlock, true) => true
    | (Command.Lock, true) | (Command.Unlock, false) => false
    end.

  Definition dec_true_ok (c : Effect.command E) (s : S)
    : dec c s = true -> Model.condition m c s.
  Admitted.

  Definition dec_false_ok (c : Effect.command E) (s : S)
    : dec c s = false -> ~ Model.condition m c s.
  Admitted.

  Lemma solve_ok {A : Type} (x : C.t E A) (s : S)
    : Solve.solve dec (ClosedM.of_C m x s) = None -> Progress.of_C m x s.
    apply Solve.solve_ok.
    - exact dec_true_ok.
    - exact dec_false_ok.
  Qed.

  Definition ex1 : C.t E unit :=
    do! lock in
    unlock.

  (*Compute (M.compile (m := m) ex1).
  Compute (ClosedM.compile (M.compile (m := m) ex1) false).*)

  Lemma ex1_progress : Progress.of_C m ex1 false.
    now apply solve_ok.
  Qed.

  Definition ex2 : C.t E (nat * nat) :=
    join (ret 3) (ret 4).

  (*Compute (M.compile (m := m) ex2).
  Compute (ClosedM.compile (M.compile (m := m) ex2) false).*)

  Lemma ex2_progress : Progress.of_C m ex2 false.
    now apply solve_ok.
  Qed.

  Definition ex3 : C.t E (nat * unit) :=
    join (ret 3) (
      do! lock in
      unlock).

  (*Compute (M.compile (m := m) ex3).
  Compute (ClosedM.compile (M.compile (m := m) ex3) false).*)

  Lemma ex3_progress : Progress.of_C m ex3 false.
    now apply solve_ok.
  Qed.

  Definition ex4 : C.t E (unit * unit) :=
    join (do! lock in unlock) (do! lock in unlock).

  (*Compute (M.compile (m := m) ex4).
  Compute (ClosedM.compile (M.compile (m := m) ex4) false).*)

  Lemma ex4_progress : Progress.of_C m ex4 false.
    now apply solve_ok.
  Qed.

  Fixpoint ex5 (n : nat) : C.t E unit :=
    match n with
    | O => ret tt
    | Datatypes.S n =>
      let! _ : unit * unit := join (do! lock in unlock) (ex5 n) in
      ret tt
    end.

  Lemma ex5_progress_0 : Progress.of_C m (ex5 0) false.
    Time now apply solve_ok.
  Qed.

  Lemma ex5_progress_1 : Progress.of_C m (ex5 1) false.
    Time now apply solve_ok.
  Qed.

  Lemma ex5_progress_2 : Progress.of_C m (ex5 2) false.
    Time now apply solve_ok.
  Qed.

  Lemma ex5_progress_3 : Progress.of_C m (ex5 3) false.
    Time now apply solve_ok.
  Qed.

  Lemma ex5_progress_4 : Progress.of_C m (ex5 4) false.
    Time now apply solve_ok.
  Qed.

  Lemma ex5_progress_5 : Progress.of_C m (ex5 5) false.
    Time now apply solve_ok.
  Qed.

  Lemma ex5_progress_6 : Progress.of_C m (ex5 6) false.
    Time now apply solve_ok.
  Qed.

  Lemma ex5_progress_7 : Progress.of_C m (ex5 7) false.
    Time now apply solve_ok.
  Qed.

  Fixpoint ex6 (n : nat) : C.t E nat :=
    match n with
    | O => ret 0
    | Datatypes.S n' =>
      let! sv : nat * nat :=
        join (ex6 n') (
          do! lock in
          let v := n in
          do! unlock in
          ret v) in
      let (s, v) := sv in
      ret (s + v)
    end.

  Lemma ex6_progress_0 : Progress.of_C m (ex6 0) false.
    Time now apply solve_ok.
  Qed.

  Lemma ex6_progress_1 : Progress.of_C m (ex6 1) false.
    Time now apply solve_ok.
  Qed.

  Lemma ex6_progress_2 : Progress.of_C m (ex6 2) false.
    Time now apply solve_ok.
  Qed.

  Lemma ex6_progress_3 : Progress.of_C m (ex6 3) false.
    Time now apply solve_ok.
  Qed.

  Lemma ex6_progress_4 : Progress.of_C m (ex6 4) false.
    Time now apply solve_ok.
  Qed.

  Lemma ex6_progress_5 : Progress.of_C m (ex6 5) false.
    Time now apply solve_ok.
  Qed.

  Lemma ex6_progress_6 : Progress.of_C m (ex6 6) false.
    Time now apply solve_ok.
  Qed.

  Lemma ex6_progress_7 : Progress.of_C m (ex6 7) false.
    Time now apply solve_ok.
  Qed.
End Lock.*)


(** * Functors involving coproduct categories *)
Require Import Category.Sum Functor.Core Functor.Composition.Core Functor.Identity.
Require Import Functor.Paths HoTT.Tactics Types.Forall.
Require Import Basics.Tactics.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

(** We save [inl] and [inr] so we can use them to refer to the functors, too.  Outside of the [Categories/] directory, they should always be referred to as [Functor.inl] and [Functor.inr], after a [Require Functor].  Outside of this file, but in the [Categories/] directory, if you do not want to depend on all of [Functor] (for e.g., speed reasons), they should be referred to as [Functor.Sum.inl] and [Functor.Sum.inr] after a [Require Functor.Sum]. *)
Local Notation type_inl := inl.
Local Notation type_inr := inr.

(** ** Injections [inl : C → C + D] and [inr : D → C + D] *)
Section sum_functors.
  Variables C D : PreCategory.

  Definition inl : Functor C (C + D)
    := Build_Functor C (C + D)
                     (@inl _ _)
                     (fun _ _ m => m)
                     (fun _ _ _ _ _ => idpath)
                     (fun _ => idpath).

  Definition inr : Functor D (C + D)
    := Build_Functor D (C + D)
                     (@inr _ _)
                     (fun _ _ m => m)
                     (fun _ _ _ _ _ => idpath)
                     (fun _ => idpath).
End sum_functors.

(** ** Coproduct of functors [F + F' : C + C' → D] *)
Section sum.
  Variables C C' D : PreCategory.

  Definition sum (F : Functor C D) (F' : Functor C' D)
  : Functor (C + C') D.
  Proof.
    refine (Build_Functor
              (C + C') D
              (fun cc'
               => match cc' with
                    | type_inl c => F c
                    | type_inr c' => F' c'
                  end)
              (fun s d
               => match s, d with
                    | type_inl cs, type_inl cd
                      => fun m : morphism _ cs cd => F _1 m
                    | type_inr c's, type_inr c'd
                      => fun m : morphism _ c's c'd => F' _1 m
                    | _, _ => fun m => match m with end
                  end%morphism)
              _
              _);
    abstract (
        repeat (intros [] || intro);
        simpl in *;
          auto with functor
      ).
  Defined.
End sum.

(** ** swap : [C + D → D + C] *)
Section swap_functor.
  Definition swap C D
  : Functor (C + D) (D + C)
    := sum (inr _ _) (inl _ _).

  Local Open Scope functor_scope.

  Definition swap_involutive_helper {C D} c
  : (swap C D) ((swap D C) c)
    = c
    := match c with type_inl _ => idpath | type_inr _ => idpath end.

  Lemma swap_involutive `{Funext} C D
  : swap C D o swap D C = 1.
  Proof.
    path_functor.
    exists (path_forall _ _ swap_involutive_helper).
    repeat (apply (@path_forall _); intro).
    repeat match goal with
               | [ |- context[transport (fun x' => forall y, @?C x' y) ?p ?f ?x] ]
                 => simpl rewrite (@transport_forall_constant _ _ C _ _ p f x)
           end.
    transport_path_forall_hammer.
      by repeat match goal with
                  | [ H : Empty |- _ ] => destruct H
                  | [ H : (_ + _)%type |- _ ] => destruct H
                  | _ => progress hnf in *
                end.
  Qed.
End swap_functor.

Module Export FunctorSumNotations.
  Notation "F + G" := (sum F G) : functor_scope.
End FunctorSumNotations.


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

(** Recognition of combined operations, addressing modes and conditions
  during the [CSE] phase. *)

Require Import Coqlib.
Require Import AST.
Require Import Integers.
Require Import Values.
Require Import Memory.
Require Import Op.
Require Import Registers.
Require Import RTL.
Require Import CSEdomain.
Require Import CombineOp.

Section COMBINE.

Variable ge: genv.
Variable sp: val.
Variable m: mem.
Variable get: valnum -> option rhs.
Variable valu: valnum -> val.
Hypothesis get_sound: forall v rhs, get v = Some rhs -> rhs_eval_to valu ge sp m rhs (valu v).

Lemma get_op_sound:
  forall v op vl, get v = Some (Op op vl) -> eval_operation ge sp op (map valu vl) m = Some (valu v).
Proof.
  intros. exploit get_sound; eauto. intros REV; inv REV; auto.
Qed.

Ltac UseGetSound :=
  match goal with
  | [ H: get _ = Some _ |- _ ] =>
      let x := fresh "EQ" in (generalize (get_op_sound _ _ _ H); intros x; simpl in x; FuncInv)
  end.

Lemma combine_compimm_ne_0_sound:
  forall x cond args,
  combine_compimm_ne_0 get x = Some(cond, args) ->
  eval_condition cond (map valu args) m = Val.cmp_bool Cne (valu x) (Vint Int.zero) /\
  eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Cne (valu x) (Vint Int.zero).
Proof.
  intros until args. functional induction (combine_compimm_ne_0 get x); intros EQ; inv EQ.
  (* of cmp *)
  UseGetSound. rewrite <- H.
  destruct (eval_condition cond (map valu args) m); simpl; auto. destruct b; auto.
Qed.

Lemma combine_compimm_eq_0_sound:
  forall x cond args,
  combine_compimm_eq_0 get x = Some(cond, args) ->
  eval_condition cond (map valu args) m = Val.cmp_bool Ceq (valu x) (Vint Int.zero) /\
  eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Ceq (valu x) (Vint Int.zero).
Proof.
  intros until args. functional induction (combine_compimm_eq_0 get x); intros EQ; inv EQ.
  (* of cmp *)
  UseGetSound. rewrite <- H.
  rewrite eval_negate_condition.
  destruct (eval_condition c (map valu args) m); simpl; auto. destruct b; auto.
Qed.

Lemma combine_compimm_eq_1_sound:
  forall x cond args,
  combine_compimm_eq_1 get x = Some(cond, args) ->
  eval_condition cond (map valu args) m = Val.cmp_bool Ceq (valu x) (Vint Int.one) /\
  eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Ceq (valu x) (Vint Int.one).
Proof.
  intros until args. functional induction (combine_compimm_eq_1 get x); intros EQ; inv EQ.
  (* of cmp *)
  UseGetSound. rewrite <- H.
  destruct (eval_condition cond (map valu args) m); simpl; auto. destruct b; auto.
Qed.

Lemma combine_compimm_ne_1_sound:
  forall x cond args,
  combine_compimm_ne_1 get x = Some(cond, args) ->
  eval_condition cond (map valu args) m = Val.cmp_bool Cne (valu x) (Vint Int.one) /\
  eval_condition cond (map valu args) m = Val.cmpu_bool (Mem.valid_pointer m) Cne (valu x) (Vint Int.one).
Proof.
  intros until args. functional induction (combine_compimm_ne_1 get x); intros EQ; inv EQ.
  (* of cmp *)
  UseGetSound. rewrite <- H.
  rewrite eval_negate_condition.
  destruct (eval_condition c (map valu args) m); simpl; auto. destruct b; auto.
Qed.

Theorem combine_cond_sound:
  forall cond args cond' args',
  combine_cond get cond args = Some(cond', args') ->
  eval_condition cond' (map valu args') m = eval_condition cond (map valu args) m.
Proof.
  intros. functional inversion H; subst.
  (* compimm ne zero *)
  simpl; eapply combine_compimm_ne_0_sound; eauto.
  (* compimm ne one *)
  simpl; eapply combine_compimm_ne_1_sound; eauto.
  (* compimm eq zero *)
  simpl; eapply combine_compimm_eq_0_sound; eauto.
  (* compimm eq one *)
  simpl; eapply combine_compimm_eq_1_sound; eauto.
  (* compuimm ne zero *)
  simpl; eapply combine_compimm_ne_0_sound; eauto.
  (* compuimm ne one *)
  simpl; eapply combine_compimm_ne_1_sound; eauto.
  (* compuimm eq zero *)
  simpl; eapply combine_compimm_eq_0_sound; eauto.
  (* compuimm eq one *)
  simpl; eapply combine_compimm_eq_1_sound; eauto.
Qed.

Theorem combine_addr_sound:
  forall addr args addr' args',
  combine_addr get addr args = Some(addr', args') ->
  eval_addressing ge sp addr' (map valu args') = eval_addressing ge sp addr (map valu args).
Proof.
  intros. functional inversion H; subst.
  (* indexed - addimm *)
  UseGetSound. simpl. rewrite <- H0. rewrite Val.add_assoc. auto.
Qed.

Theorem combine_op_sound:
  forall op args op' args',
  combine_op get op args = Some(op', args') ->
  eval_operation ge sp op' (map valu args') m = eval_operation ge sp op (map valu args) m.
Proof.
  intros. functional inversion H; subst.
(* addimm - addimm *)
  UseGetSound. FuncInv. simpl.
  rewrite <- H0. rewrite Val.add_assoc. auto.
(* addimm - subimm *)
Opaque Val.sub.
  UseGetSound. FuncInv. simpl.
  change (Vint (Int.add m0 n)) with (Val.add (Vint m0) (Vint n)).
  rewrite <- H0. rewrite Val.sub_add_l. auto.
(* subimm - addimm *)
  UseGetSound. FuncInv. simpl. rewrite <- H0.
Transparent Val.sub.
  destruct v; simpl; auto. repeat rewrite Int.sub_add_opp. rewrite Int.add_assoc.
  rewrite Int.neg_add_distr. decEq. decEq. decEq. apply Int.add_commut.
(* andimm - andimm *)
  UseGetSound; simpl.
  generalize (Int.eq_spec p m0); rewrite H7; intros.
  rewrite <- H0. rewrite Val.and_assoc. simpl. fold p. rewrite H1. auto.
  UseGetSound; simpl.
  rewrite <- H0. rewrite Val.and_assoc. auto.
(* orimm - orimm *)
  UseGetSound. simpl. rewrite <- H0. rewrite Val.or_assoc. auto.
(* xorimm - xorimm *)
  UseGetSound. simpl. rewrite <- H0. rewrite Val.xor_assoc. auto.
(* cmp *)
  simpl. decEq; decEq. eapply combine_cond_sound; eauto.
Qed.

End COMBINE.