(*
 * Copyright © 2013 http://io7m.com
 *
 * Permission to use, copy, modify, and/or distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *)
(** Virtual paths. *)
Require Coq.Lists.List.
Require Coq.Strings.String.
Require ListAux.
Require ListMapWeak.
Require ListSetWeak.
Require MapWeak.
Require Names.
Require SetWeak.

Import ListAux.Notations.

Open Scope string_scope.
Open Scope list_scope.

(** A virtual path represents a path in the virtual filesystem.

Virtual paths are always absolute.

The concrete syntax of virtual paths is given by the following EBNF
grammar (where [name] indicates a string representing a
valid [Names.name]):

<<
path = "/" , [ name , ("/" , name)* ] ;
>>

A virtual path is conceptually a list of [Names.name],
with the empty list representing the root directory. *)
Definition t := list Names.t.

Definition root : t := nil.

(** Some example virtual paths include: [/bin], and
[/usr/bin/ps]. *)
Example bin        : t := Names.bin :: nil.

Example usr_bin_ps : t := Names.usr :: Names.bin :: Names.ps :: nil.

(** Because equality of [Names.name] is decidable, equality
    of [t] is too. *)
Theorem eq_decidable : forall (p0 p1 : t),
  {p0 = p1}+{~p0 = p1}.
Proof.
  apply List.list_eq_dec.
  apply Names.eq_decidable.
Qed.

(** The property of [p0] being an ancestor of [p1]. [p0] is an ancestor
of [p1] iff:
- [p0] is not equal to [p1], and
- [p0] is a prefix of [p1]
*)
Definition is_ancestor_of (p0 p1 : t) : Prop :=
  (p0 <> p1) /\ (ListAux.is_prefix p0 p1).

(** The property of [p0] being the parent of [p1]. [p0] is the parent
of [p1] iff:
- [p0] is an ancestor of [p1], and
- There exists some [x] such that [p0 @@ x = p1]
*)
Definition is_parent_of (p0 p1 : t) : Prop :=
  (is_ancestor_of p0 p1) /\ (exists x, p0 @@ x = p1).

(** The [root] path is an ancestor of any non-[root] path. *)
Theorem is_ancestor_of_root : forall (p : t),
  p <> root -> is_ancestor_of root p.
Proof.
  unfold is_ancestor_of.
  intros p Hn.
  split.
    apply not_eq_sym.
    assumption.
    induction p as [|px pr].
      contradict Hn; reflexivity.
      exact I.
Qed.

(** The [root] path has no ancestors. *)
Theorem is_ancestor_of_root_false : forall (p : t),
  ~is_ancestor_of p root.
Proof.
  unfold is_ancestor_of.
  induction p; intuition.
Qed.

(** The [root] path has no parent. *)
Theorem is_parent_of_root_false : forall (p : t),
  ~is_parent_of p root.
Proof.
  unfold root.
  unfold is_parent_of.
  induction p; intuition.
    inversion H1.
    contradict H. apply ListAux.append_element_not_equal.
    inversion H0.
    contradict H3.
Qed.

(** Iff a path has a single element, then its parent is the [root]. *)
Theorem is_parent_of_root_single : forall (x : Names.t),
  is_parent_of root (x :: nil).
Proof.
  unfold root.
  unfold is_parent_of.
  unfold is_ancestor_of.
  intro x.
  split.
  split.
    discriminate.
    exact I.
    exists x; reflexivity.
Qed.

(** Being an ancestor is decidable. *)
Theorem is_ancestor_of_decidable : forall (p0 p1 : t),
  {is_ancestor_of p0 p1}+{~is_ancestor_of p0 p1}.
Proof.
  unfold is_ancestor_of.
  intros p0 p1.
  destruct (eq_decidable p0 p1).
    right; rewrite e; intuition.
    destruct (ListAux.is_prefix_decidable Names.eq_decidable p0 p1).
      left; intuition.
      right; intuition.
Qed.

(** Being a parent is decidable. *)
Theorem is_parent_of_decidable : forall (p0 p1 : t),
  {is_parent_of p0 p1}+{~is_parent_of p0 p1}.
Proof.
  intros p0 p1.
  unfold is_parent_of   in *.
  unfold is_ancestor_of in *.
  destruct (is_ancestor_of_decidable p0 p1).
    destruct i.
    destruct (ListAux.append_element_decidable Names.eq_decidable p0 p1).
      left; intuition.
      right; intuition.
    unfold is_parent_of   in *.
    unfold is_ancestor_of in *.
    right; intuition.
Qed.

(** Being an ancestor is transitive. *)
Theorem is_ancestor_of_transitive : forall (p0 p1 p2 : t),
  is_ancestor_of p0 p1 -> is_ancestor_of p1 p2 -> is_ancestor_of p0 p2.
Proof.
Admitted.

(** The property of [p0] containing [p1]. The path [p0] is said to
contain [p1] iff:
- [p0 = p1], or
- [p0] is an ancestor of [p1] *)
Definition contains (p0 p1 : t) :=
  (p0 = p1) \/ (is_ancestor_of p0 p1).

(** [contains] is decidable. *)
Theorem contains_decidable : forall (p0 p1 : t),
  {contains p0 p1}+{~contains p0 p1}.
Proof.
  unfold contains.
  intros p0 p1.
  destruct (eq_decidable p0 p1).
  destruct (is_ancestor_of_decidable p0 p1).
    left; left; assumption.
    left; left; assumption.
  destruct (is_ancestor_of_decidable p0 p1).
    left; right; assumption.
    right; tauto.
Qed.

(** All paths contain themselves. *)
Theorem contains_self : forall (p : t),
  contains p p.
Proof.
  left; reflexivity.
Qed.

(** If [p] is contained by [root], then [p = root]. *)
Theorem contains_is_root : forall (p : t),
  contains p root -> p = root.
Proof.
  unfold contains.
  unfold is_ancestor_of.
  intros p Hc.
  induction p as [|ph pr].
    reflexivity.
    destruct Hc as [HL|HR].
      assumption.
      destruct HR as [HRL HRR].
        inversion HRR.
Qed.

(** Containment is transitive. *)
Theorem contains_trans : forall (p q r : t),
  contains p q -> contains q r -> contains p r.
Proof.
  intros p q r Hpq Hqr.
  unfold contains in *.
  unfold is_ancestor_of in *.
  destruct Hpq as [HpqL|HpqR].
    destruct Hqr as [HqrL|HqrR].
      left; apply (eq_trans HpqL HqrL).
      rewrite HpqL.
      right; assumption.
    destruct Hqr as [HqrL|HqrR].
      rewrite <- HqrL.
      right; assumption.
Admitted.

(** Paths can be "subtracted" to remove common prefixes. This
is useful for calculating the paths of files inside archives mounted
into a filesystem. As an example, if an archive [A] is mounted at
[/usr] and [A] contains the path [/bin/ps], then
[subtract /usr/bin/ps /usr = /bin/ps].

So, if [contains p1 p0], then subtraction removes the first
[length p1] elements of [p0]. *)
Definition subtract (p0 p1 : t) : t :=
  match contains_decidable p1 p0 with
  | left _  => List.skipn (length p1) p0
  | right _ => p0
  end.

(** As stated, [subtract /usr/bin/ps /usr = /bin/ps]. *)
Example subtract_usr : subtract usr_bin_ps (Names.usr :: nil) = Names.bin :: Names.ps :: nil.
Proof.
  compute.
  destruct contains_decidable as [Hc|Hnc].
    reflexivity.
    contradict Hnc.
      right; compute; intuition.
      inversion H.
Qed.

(** Attempting to subtract [p1] from [p0] when [p1] does not contain [p0]
does nothing. *)
Theorem contains_subtract_false : forall (p0 p1 : t),
  ~contains p1 p0 -> subtract p0 p1 = p0.
Proof.
  intros p0 p1 Hna.
  unfold subtract.
  destruct (contains_decidable p1 p0).
    contradiction.
    reflexivity.
Qed.

(** If [p1] contains [p0], then subtracting [p1] from [p0] reduces
the length of [p0] by [length p1]. *)
Theorem contains_subtract_length : forall (p0 p1 : t),
  contains p1 p0 -> length (subtract p0 p1) = length p0 - length p1.
Proof.
  intros p0 p1.
  unfold subtract.
  destruct (contains_decidable p1 p0).
    intros; apply ListAux.skipn_length.
    intros; contradiction.
Qed.

(** If [p0 = p1], then [subtract p0 p1 = root]. *)
Theorem contains_subtract_is_root : forall (p0 p1 : t),
  p0 = p1 -> subtract p0 p1 = root.
Proof.
  intros p0 p1 H_eq.
  unfold subtract.
  rewrite H_eq.
  destruct (contains_decidable p1 p1) as [Hc|Hnc].
    apply ListAux.skipn_0.
    contradict Hnc.
    left; reflexivity.
Qed.

(** Subtracting anything from [root] results in [root]. *)
Theorem subtract_root : forall (p : t),
  subtract root p = root.
Proof.
  intros p.
  unfold subtract.
  destruct (contains_decidable p root).
    destruct p; reflexivity.
    reflexivity.
Qed.

(** Subtracting anything from [root] results in [root]. *)
Theorem subtract_from_root : forall (p : t),
   subtract root p = root.
 Proof.
   intros p.
   unfold subtract.
   destruct (contains_decidable p root).
     destruct p; reflexivity.
     reflexivity.
 Qed.

(** Subtracting [root] from [p] results in [p]. *)
Theorem subtract_root_from : forall p,
  subtract p root = p.
Proof.
  intros p.
  unfold subtract.
  destruct (contains_decidable root p); reflexivity.
Qed.

(** Subtracting [p] from itself results in [root]. *)
Theorem subtract_self : forall p,
  subtract p p = root.
Proof.
  intros p.
  unfold subtract.
  destruct (contains_decidable p p) as [Hc|Hnc].
    induction p.
      reflexivity.
      apply IHp.
      left; reflexivity.
    contradict Hnc.
      left; reflexivity.
Qed.

Theorem contains_subtract_id : forall (p0 p1 : t),
  contains p0 p1 -> p0 ++ (subtract p1 p0) = p1.
Proof.
  unfold contains.
  unfold is_ancestor_of.
  induction p0 as [|p0h p0r].
    destruct p1 as [|p1h p1r].
      intros; simpl. apply subtract_from_root.
      intros; simpl. apply subtract_root_from.
    intros p1 H.
    destruct H as [HL|HR].
      rewrite HL.
      rewrite subtract_self.
      unfold root.
      auto with *.
    destruct p1 as [|p1h p1r].
      destruct HR as [HRL HRR].
        contradict HRR.
      destruct HR as [HRL HRR].
        destruct HRR as [HRRL HRRR].
          simpl in *.
          rewrite HRRL.
Admitted.

(** The sequential enumeration of the ancestors of [p] is
a list of the ancestors of [p] starting with the most distant
ancestor first.

As an example, given a path [/usr/bin/ps], a sequential
enumeration of the ancestors would result in a list
[/ :: /usr :: /usr/bin :: nil].

The [Enumeration] module provides a function to calculate the
enumeration. *)
Module Type EnumerationSignature.
Parameter enumeration : t -> list t.

(** The [enumeration] of the [root] is empty. *)
Parameter enumeration_root : enumeration root = nil.

(** Therefore, if the enumeration of [p] is empty, then [p = root]. *)
Parameter enumeration_is_root : forall (p : t),
  enumeration p = nil -> p = root.

(** All paths returned by [enumeration] are ancestors of the original non-empty path. *)
Parameter enumeration_ancestors : forall (p q : t),
  p <> root -> (List.In q (enumeration p) <-> is_ancestor_of q p).
End EnumerationSignature.

(** The actual implementation of the [enumeration] function. *)
Module Enumeration <: EnumerationSignature.

Definition enumeration (e : t) :=
  match e with
  | nil    => nil
  | _ :: _ => ListAux.prefixes e
  end.

(** The [enumeration] of the [root] is empty. *)
Theorem enumeration_root :
  enumeration nil = nil.
Proof.
  reflexivity.
Qed.

(** Therefore, if the enumeration of [p] is empty, then [p = root]. *)
Theorem enumeration_is_root : forall (p : t),
  enumeration p = nil -> p = root.
Proof.
  induction p as [|ph pr].
    auto.
    intros.
    simpl in H.
    inversion H.
Qed.

(** All paths returned by [enumeration] are ancestors of the original non-empty path. *)
Theorem enumeration_ancestors : forall (p q : t),
  p <> root -> (List.In q (enumeration p) <-> is_ancestor_of q p).
Proof.
  intros p q H.
  destruct p.
    contradict H; reflexivity.
    unfold enumeration.
    unfold is_ancestor_of.
    apply ListAux.prefixes_correct.
Qed.

End Enumeration.

(** As stated, [enumeration /usr/bin/ps = [/, /usr, /usr/bin]]. *)
Theorem enum_example : Enumeration.enumeration usr_bin_ps =
  nil :: (Names.usr :: nil) :: (Names.usr :: Names.bin :: nil) :: nil.
Proof.
  compute.
  reflexivity.
Qed.

(** A map with virtual paths as keys. *)
Module PathVirtualMapsKey : MapWeak.Parameters with Definition key := t.
  Definition key              := t.
  Definition key_eq_decidable := eq_decidable.
End PathVirtualMapsKey.

Module Maps := ListMapWeak.Make(PathVirtualMapsKey).

(** A finite set of virtual paths. *)
Module PathVirtualSetParameters : SetWeak.Parameters with Definition t := t.
  Definition t              := t.
  Definition t_eq_decidable := eq_decidable.
End PathVirtualSetParameters.

Module Sets := ListSetWeak.Make(PathVirtualSetParameters).


(** This module proves Theorem 4.3 from the paper. *)

From Coq Require Import Program.Equality Omega.
From Rattus Require Export Streams FundamentalProperty.

From Rattus Require Import Tactics.

Import ListNotations.

(* We start with the two central lemmas that prove the essence of the
causality property. *)

Lemma causality1 A B nu t vs :
  closed_type A -> (forall n, isvalue (vs n)) -> (forall n, ctx_empty ⊢ (vs n) ∶ A) ->
  ctx_empty ⊢ t ∶ Arrow (Str A) (Str B) ->
  trrel B nu vs (app t (adv (ref thel)),heap_empty).
Proof.
  intros CTA VT' Cvs' Ty.
  assert (forall n, vrel_vtype A (vs n)) as VT
      by (intros; apply trel_vrel;eauto using fund_prop_closed).
  assert (forall n, closed_term (vs n)) as Cvs
      by (intros n; eapply typed_closed;eauto).
  constructor; eauto using closed_heap_empty, typed_closed, heap_empty_fresh.
  intros s Ts Cs.
  pose Ty as Ty'.
  eapply fund_prop with (g:= nil) (Hs := (str_heapseq (tl (tl vs))))
                        (s := (Some (heap_single thel (vs 0 ∷ ref thel)),
                                         heap_single thel (vs 1 ∷ ref thel)))
    in Ty';eauto. rewrite sub_empty_app in Ty' by auto.
  eapply trel_app; eauto using typed_closed. eauto using str_heapseq_closed.
  eapply trel_adv. auto using mapsto_heap_cons.
  apply vrel_trel. autorewrite with vrel. eexists. split. reflexivity. simpl.
  autorewrite with vrel. do 2 eexists. split. reflexivity. split.
  rewrite closed_tsubst by auto. eauto using vtype_vrel.
  apply trel_vrel;eauto.  constructor; eauto using closed_heap_alloc, typed_closed.

  apply  fund_prop_closed;eauto.
  eauto using str_heapseq_closed, closed_heapseq_tail.
  constructor; eauto using closed_heap_alloc, typed_closed.

  eapply vrel_mono; try eapply thel_vrel;eauto.
  eauto using str_heapseq_closed.
  eauto using str_heapseq_closed.
  constructor;  eauto using vtype_vrel_closed,closed_heap_alloc, closed_heap_empty.
Qed.

(** This is part (ii) of Theorem 3.2 in the paper. *)
Lemma causality2 A B nu s vs :
  vtype B -> (forall n, isvalue (vs n)) -> (forall n, ctx_empty ⊢ (vs n) ∶ A) ->
  trrel B (S nu) vs s -> exists v' s', tred s (vs 0) v' s' /\ trrel B nu (tl vs) s' /\ ctx_empty ⊢ v' ∶ B.
Proof.
  intros VTB V Ty TR. inversion TR;subst.
  assert (vrel_vtype A (vs 0))  as Ty' by (apply trel_vrel;eauto using fund_prop_closed).

  assert (exists (v' : term) (s : store),
  {t, (Some (heap_cons h thel (vs 0 ∷ ref thel)), heap_single thel (vs 1 ∷ ref thel))}⇓ {v', s} /\
  vrel (S nu) (Str B) (str_heapseq (tl (tl vs))) s v') as Red.
  eapply H1; try eassumption;eauto using tick_le_refl,str_heapseq_closed, tick_le_refl.
  constructor; eauto using vtype_vrel_closed,closed_heap_alloc,closed_heap_empty,typed_closed.
  destruct Red as (v'& s&R&VR).

  pose (red_extensive _ _ _ _ R) as SL. dependent destruction SL.
  eapply red_not_later with (u:=unit) in R; eauto using heap_dom_cons'.
  rewrite heap_cons_eq in R.
  autorewrite with vrel in VR. simpl in VR. destruct VR as (v'' & E & VR). subst.
  autorewrite with vrel in VR. simpl in VR. destruct VR as (v1 & v2 & E & VR). subst.

  destruct VR as (VR1 & VR2). autorewrite with vrel' in VR2.
  destruct VR2 as (l & u & E & M & LR). subst.

  do 2 eexists. split. econstructor. apply R. split. constructor.
  - assert (heap_mapsto thel (vs 1 ∷ ref thel) h2') by eauto using mapsto_heap_cons.
    assert (closed_term (vs 1 ∷ ref thel)) by eauto using vtype_vrel_closed, typed_closed.
    assert (closed_heap (heap_cons h2' thel unit)). apply red_closed in R;eauto.
    destruct R as [C1 C2]. inversion C2. auto.
    constructor;eauto using closed_heap_empty,
                closed_heap_alloc,vtype_vrel_closed.
    eauto using closed_heap_alloc, typed_closed.
    eauto using closed_heap_delete, closed_heap_cons_rev.
  - eauto using vrel_delay_closed.
  - rewrite heap_cons_delete'. rewrite heap_cons_eq.
    inversion M. subst. simpl in LR.
    rewrite heap_overwrite'; eauto using mapsto_heap_cons.
    eapply trel_adv; try eassumption.
  - rewrite tsubst_vtype in VR1. eauto using vtype_typing. assumption.
Qed.

(* Finally we use the above two lemmas to prove the causality
property. In particular we construct infinite reduction sequences of
the form

  (t0,h0) --[v0/v'0]--> (t1,h1) --[v1/v'1]--> (t2,h2) --[v2/v'2]-->
  ...

where vi is the input value (of type A) given at the ith step and
each v'i is the corresponding output value (of type B). Such infinite
reduction sequences are represented by the coinductive type [Sred B vs
(t0,h0)] defined below, where vs maps i to vi.  *)

(* [Tred A vs s] indicates that there is an infinite stream transducer
reduction that takes inputs [vs], starts with state [s], and produces
well-typed output of type A. *)

CoInductive Tred (A : type) (vs : nat -> term) (s : state) : Prop :=
  mkSred (nextState : state) (output : term) :
         ctx_empty ⊢ output ∶ A ->
         tred s (vs 0) output nextState ->
         Tred A (tl vs) nextState -> Tred A vs s.

(* [Tred' A vs n s] represents finitary approximations of [Tred A vs
s] of length n, i.e. the first n reductions. This type is used for
constructing the proof of [Tred]. *)

Inductive Tred' (A : type) (vs : nat -> term) :  nat -> state -> Prop :=
| mkSred' n s (nextState' : state)
          (output' : term) :
    ctx_empty ⊢ output' ∶ A ->
    tred s (vs 0) output' nextState' ->
    Tred' A (tl vs) n nextState' -> Tred' A vs (S n) s
| doneSred' s : Tred' A vs 0 s.

#[global] Hint Constructors Tred' : core.

Lemma tred_determ s v v1 v2 s1 s2 : tred s v v1 s1 -> tred s v v2 s2 -> v1 = v2 /\ s1 = s2.
Proof.
  intros SR1. intros SR2. dependent destruction SR1. dependent destruction SR2.
  eapply red_determ in H; eauto. destruct H as (H1 & H2).
  inversion H1. inversion H2. subst. eauto.
Qed.

Lemma tred'_tred' A s vs :
  (forall n vs, Tred' A vs n s) -> Tred A vs s.
Proof.
  generalize dependent s. generalize dependent vs. cofix IH. intros vs s SR.

  pose (SR 1 vs) as S1. dependent destruction S1. subst.
  econstructor;try eassumption.
  apply IH. intros n vs'.

  pose (SR (S n) (cons (vs 0) vs')) as Sn. dependent destruction Sn.
  eapply tred_determ in H0;eauto. destruct H0; subst. assumption.
Qed.

Lemma tred'_tred A s vs P : (forall n, P (vs n)) ->
  (forall n vs, (forall n, P (vs n)) -> Tred' A vs n s) ->  Tred A vs s.
Proof.
  generalize dependent s. generalize dependent vs. cofix IH. intros vs s PS SR .

  pose (SR 1 vs) as S1. dependent destruction S1. subst. auto.
  econstructor;try eassumption.
  apply IH. eauto. intros n vs' PS'.
  assert (forall n : nat, P (cons (vs 0) vs' n)) as PS''.
  intros. destruct n0; simpl; eauto.
  pose (SR (S n) (cons (vs 0) vs') PS'') as Sn. dependent destruction Sn.
  eapply tred_determ in H0;eauto. destruct H0; subst. assumption.
Qed.

Lemma causality' A B t vs:
  closed_type A -> vtype B -> ctx_empty ⊢ t ∶ Arrow (Str A) (Str B) ->
  (forall n, isvalue (vs n)) -> (forall n, ctx_empty ⊢ (vs n) ∶ A) ->
  forall n, Tred' B vs n (app t (adv (ref thel)), heap_empty).
Proof.
  intros CTA VTB Ty Vs Ts n.
  apply causality1 with (nu := n) (vs :=vs) in Ty; eauto.
  generalize dependent (app t (adv (ref thel)),heap_empty).
  clear t. generalize dependent vs. induction n;intros.
  - constructor.
  - eapply causality2 in Ty;eauto. autodest.
Qed.

(* Theorem 4.2 from the paper *)
Theorem causality A B t vs :
  closed_type A -> vtype B -> ctx_empty ⊢ t ∶ Arrow (Str A) (Str B) ->
  (forall n, isvalue (vs n)) -> (forall n, ctx_empty ⊢ (vs n) ∶ A) ->
  Tred B vs (app t (adv (ref thel)), heap_empty).
Proof.
  intros. remember (fun v => isvalue v /\ ctx_empty ⊢ v ∶ A) as P.
  assert (forall n, P (vs n)) as Pn by (subst;split;eauto).

  eapply tred'_tred with (P:=P). apply Pn. subst. intros.
  eapply causality'. apply H. eauto. eauto.
  intros m. pose (H4 m). tauto. intros m. pose (H4 m). tauto.
Qed.


(*********************************************************************)
(*             Stability in Weak Memory Models                       *)
(*                                                                   *)
(*   Jade Alglave INRIA Paris-Rocquencourt, France                   *)
(*                University of Oxford, UK                           *)
(*                                                                   *)
(*  Copyright 2010 Institut National de Recherche en Informatique et *)
(*  en Automatique. All rights reserved. This file is distributed    *)
(*  under the terms of the Lesser GNU General Public License.        *)
(*********************************************************************)

Require Import Ensembles.
Require Import Bool.
From CoqCat Require Import util.
From CoqCat Require Import wmm.
From CoqCat Require Import basic.
From CoqCat Require Import hierarchy.
From CoqCat Require Import valid.
From CoqCat Require Import covering.
From CoqCat Require Import crit_sc.
Require Import Classical_Prop.
Import OEEvt.
Set Implicit Arguments.

Module StableSC (A1 A2: Archi) (dp:Dp).
Module Wk := (* Hierarchy.*)Weaker A1 A2 dp.
Import Wk.
Module Covering := Covering A1b A2 dp.
Import Covering.
Module Crit := CritSC A1b A2 dp.
Import Crit.
Module VA1 := Valid A1b dp.
Import VA1.
Module A1Basic := Basic A1b dp.

Module Preservation := Preservation Cm.
Import Preservation.

(*A2n=SC*)
Hypothesis rfe2_glob : forall E X,
  rel_incl (rf_inter X) (A2nWmm.mhb E X).
Hypothesis ppo2_po : forall E, A2.ppo E = po_iico E.
Hypothesis rfi2_ppo2 : forall E X,
  rel_incl (rf_intra X) (A2.ppo E).

Lemma v1_and_no_cy_implies_covered :
  forall E X,
  well_formed_event_structure E ->
  A1bWmm.valid_execution E X ->
  ~ (exists cy : Rln Event, crit_cy E cy) ->
  Cm.covered E X Cm.s.
Proof.
intros E X Hwf Hv1 Hncy e1 e2 [Hc12 [sigma [Hsigma ?]]].
assert (exists cy : Rln Event, crit_cy E cy) as Hc.
  exists sigma; auto.
contradiction.
Qed.

Lemma write_or_read :
  forall E x,
  events E x ->
  writes E x \/ reads E x.
Proof.
intros E x Hex.
case_eq (action x); intros d l v Hax;
case_eq d; intro Hd; [right | left];
  split; auto; exists l; exists v; subst; auto.
Qed.

Lemma tc_dom_in_evts :
  forall E cy e1 e2,
  well_formed_event_structure E ->
  tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))) e1 e2 ->
  In _ (events E) e1.
Proof.
intros E cy e1 e2 Hwf Htc.
induction Htc as [e1 e2 Hu |]; auto.
  inversion Hu as [Hcy | Hpo].
    destruct Hcy as [? [? [? ?]]]; auto.
    apply A1Basic.po_iico_domain_in_events with e2; auto.
      inversion Hpo as [Hppo | Hpio].
      apply A1b.ppo_valid; auto.
      destruct Hpio as [? [? ?]]; auto.
Qed.

Lemma tc_ran_in_evts :
  forall E cy e1 e2,
  well_formed_event_structure E ->
  tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))) e1 e2 ->
  In _ (events E) e2.
Proof.
intros E cy e1 e2 Hwf Htc.
induction Htc as [e1 e2 Hu |]; auto.
  inversion Hu as [Hcy | Hpo].
    destruct Hcy as [? [? [? ?]]]; auto.
    apply A1Basic.po_iico_range_in_events with e1; auto.
      inversion Hpo as [Hppo | Hpio].
      apply A1b.ppo_valid; auto.
      destruct Hpio as [? [? ?]]; auto.
Qed.

Lemma cy_inter_conflict_ppo1_partial_order :
  forall E cy,
  well_formed_event_structure E ->
  acyclic (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))) ->
  partial_order (tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))))
  (events E).
Proof.
intros E cy Hwf Hac.
  split; [|split].

    intros e1 Hu; inversion Hu as [e Hd | e Hr].
    destruct Hd as [e2 H12].
      apply tc_dom_in_evts with cy e2; auto.

    destruct Hr as [e2 H12].
      apply tc_ran_in_evts with cy e2; auto.

    intros x1 x2 x3 [H12 H23]; apply trc_ind with x2; auto.

    intros e He; apply (Hac e He).
Qed.

Lemma ppo1_in_le :
  forall E cy,
  well_formed_event_structure E ->
  acyclic (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))) ->
  rel_incl (A1b.ppo E) (LE (tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))))).
Proof.
intros E cy Hwf Hacy;
generalize (cy_inter_conflict_ppo1_partial_order Hwf Hacy);
intro Hpart.
    assert (Included _ (events E) (events E)) as Htriv.
    intros e He; auto.
    generalize (OE Htriv Hpart); intros [Hinc Hle].
intros x y Hxy.
apply Hinc; apply trc_step; right; left; auto.
Qed.

Lemma pio_in_le :
  forall E cy,
  well_formed_event_structure E ->
  acyclic (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))) ->
  rel_incl (pio_llh E) (LE (tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))))).
Proof.
intros E cy Hwf Hacy;
generalize (cy_inter_conflict_ppo1_partial_order Hwf Hacy);
intro Hpart.
    assert (Included _ (events E) (events E)) as Htriv.
    intros e He; auto.
    generalize (OE Htriv Hpart); intros [Hinc Hle].
intros x y Hxy.
apply Hinc; apply trc_step; right; right; auto.
Qed.

Lemma le_ac :
  forall E cy,
  linear_strict_order
        (LE (tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E)))))
        (events E) ->
  acyclic (LE (tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))))).
Proof.
intros E cy Hle x Hx; generalize Hle; intro Hlin;
destruct_lin Hle; apply (Hac x).
rewrite (lso_is_tc Hlin) in Hx; auto.
Qed.

Lemma cy_inter_conflict_ppo1_vexec :
  forall E cy,
  well_formed_event_structure E ->
  acyclic (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))) ->
  vexec E (tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E)))).
Proof.
intros E cy Hwf Hacy;
generalize (cy_inter_conflict_ppo1_partial_order Hwf Hacy);
intro Hpart.
    assert (Included _ (events E) (events E)) as Htriv.
    intros e He; auto.
    generalize (OE Htriv Hpart); intros [Hinc Hle].
split; [|split]; auto.

  apply ac_incl with (LE (tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))))); auto.
    apply le_ac; auto.
    intros x y Hxy; inversion Hxy; auto.
    apply ppo1_in_le; auto.

  apply ac_incl with (LE (tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))))); auto.
    apply le_ac; auto.
    intros x y Hxy; inversion Hxy; auto.
    apply pio_in_le; auto.
Qed.

Lemma cy_is_or :
  forall E Y cy,
  well_formed_event_structure E ->
  A1bWmm.valid_execution E Y ->
  acyclic (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))) ->
  rel_incl cy (tc (rel_union (rel_inter cy (conflict E)) (A2n.ppo E))) ->
  (rf Y =
      so_rfm E (tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))))) ->
  (ws Y = so_ws (tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))))) ->
  rel_incl cy (tc (rel_union ((mhbd E Y)) (A2n.ppo E))).
Proof.
intros E Y cy Hwf Hv Hacy Hi Hrf Hws x y Hxy.
generalize (cy_inter_conflict_ppo1_partial_order Hwf Hacy);
intro Hpart.
    assert (Included _ (events E) (events E)) as Htriv.
    intros e He; auto.
    generalize (OE Htriv Hpart); intros [Hinc Hle].

generalize (Hi x y Hxy); intro Htc.
clear Hxy.
induction Htc as [x y Hu |]; auto.
  inversion Hu as [Hc | Hppo].
  destruct Hc as [Hxy Hc].
  generalize Hc; intros [Hex [Hey [? [? Hw]]]].
  inversion Hw as [Hwx | Hwy].

    generalize (write_or_read E y Hey); intro Hory.
    inversion Hory as [Hwy | Hry].

    (*Wx Wy*)
      apply trc_step; left;
      split; auto.
       (*split; auto.*)
       apply A2nBasic.ws_in_mhb.
        rewrite Hws; split.
          apply Hinc; apply trc_step; left; split; auto.
          exists (loc x); split; split.
            left; exists y.
              apply Hinc; apply trc_step; left; split; auto.
              destruct Hwx as [? [lx [vx Hax]]]; unfold write_to; rewrite Hax.
              exists vx; unfold loc; rewrite Hax; auto.
            right; exists x.
              apply Hinc; apply trc_step; left; split; auto.
              destruct Hwy as [? [ly [vy Hay]]]; unfold write_to; rewrite Hay.
              exists vy; rewrite H; unfold loc; rewrite Hay; auto.

     (*Wx Ry -> (ws)?;rf*)
     destruct_valid Hv.
     generalize (Hrf_init y Hry); intros [wy [Hwy ?]].
     generalize (eqEv_dec x wy); intros [Heq | Hneq].
     apply trc_step; left; split; auto.
     (*split; auto.*) apply rfe2_glob; split; auto.
       subst; auto.

       apply trc_ind with wy.
     assert (ws Y x wy \/ ws Y wy x) as Horxwy.
       generalize (Hws_tot (loc x)); intro Hl.
       destruct_lin Hl.
         assert (In Event (writes_to_same_loc_l (events E) (loc x)) x) as Hx.
           split; auto.
             destruct Hwx as [? [? [vx Hwx]]]; unfold write_to;
             rewrite Hwx; unfold loc; exists vx; rewrite Hwx; auto.
         assert (In Event (writes_to_same_loc_l (events E) (loc x)) wy) as Hwwy.
           split.
             apply A1Basic.dom_rf_in_events with Y y; auto.
               split; auto.
             rewrite H.
               rewrite <- A1Basic.rf_implies_same_loc2 with E Y wy y.
             generalize (A1Basic.dom_rf_is_write E Y wy y Hrf_cands H1);
             intros [? [vy Hwwy]]; unfold write_to;
             rewrite Hwwy; unfold loc; exists vy; rewrite Hwwy; auto.
       split; split; auto. auto.
       generalize (Htot x wy Hneq Hx Hwwy); intro Hor;
       inversion Hor as [Hxwy | Hwyx]; [left | right].
         destruct Hxwy; auto. destruct Hwyx; auto.

     inversion Horxwy as [Hxwy | Hwyx].
     destruct (eqProc_dec (proc_of x) (proc_of wy)) as [Heqp | Hneqp].
       apply trc_step; right; rewrite ppo2_po.
       assert (In _ (events E) wy) as Hewy.
         apply A2nBasic.ran_ws_in_events with Y x; auto.
         split; auto.
       generalize (A2nBasic.same_proc_implies_po x wy Hwf Heqp Hex Hewy);
       intro Hor; inversion Hor; auto.
       assert (tc (rel_union (com E Y) (pio_llh E)) x x) as Hcuni.
         apply trc_ind with wy; apply trc_step.
           left; right; auto.
           right; split; [|split]; auto.
           apply sym_eq.
           apply A1bBasic.ws_implies_same_loc with E Y; auto.
             split; split; auto.
           intros [Hrwy [? [lx [vx Hax]]]].
           destruct Hwx as [? [? [? Hwx]]].
           rewrite Hax in Hwx; inversion Hwx.
           unfold acyclic in Hsp; generalize (Hsp x); intro; contradiction.

       apply trc_step; left; split; auto.
         apply A2nBasic.ws_in_mhb; auto.

       rewrite Hrf in H1; destruct H1 as [? [? Hmax]].
       assert (In Event
         (previous_writes E
            (LE (tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))))) y)
         x) as Hpwx.
         split; auto.
         split; auto.
         apply Hinc; apply trc_step; inversion Hu as [|Hppo2]; [left | right]; auto.
         generalize (A2.ppo_valid Hppo2); intro Hpo.
         generalize (A2nBasic.po_implies_same_proc Hwf Hex Hey Hpo); intro; contradiction.

       assert (LE (tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E)))) wy x) as Hle_wyx.
         rewrite Hws in Hwyx.
         destruct Hwyx; auto.

       assert (In Event
         (previous_writes E
            (LE (tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))))) y)
         x /\
       LE (tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E)))) wy x) as Hand.
         split; auto.

      generalize (Hmax x Hand); intro Heqwyx.
      assert (x = wy) as Heq'.
        auto.
      contradiction.

     destruct (eqProc_dec (proc_of wy) (proc_of y)) as [Heqp | Hneqp].
       apply trc_step; right.
       assert (rf_intra Y wy y) as Hrfi.
         split; auto.
       apply (rfi2_ppo2 E Hrfi).

       apply trc_step; left; split; auto.
       apply rfe2_glob; auto. split; auto.

    generalize (write_or_read E x Hex); intro Horx.
    inversion Horx as [Hwx | Hrx];
      apply trc_step; left; split; auto.

    (*Wx Wy*)
       (*split; auto.*)
       apply A2nBasic.ws_in_mhb.
        rewrite Hws; split.
          apply Hinc; apply trc_step; left; split; auto.
          exists (loc x); split; split.
            left; exists y.
              apply Hinc; apply trc_step; left; split; auto.
              destruct Hwx as [? [lx [vx Hax]]]; unfold write_to; rewrite Hax.
              unfold loc; exists vx; rewrite Hax; auto.
            right; exists x.
              apply Hinc; apply trc_step; left; split; auto.
              destruct Hwy as [? [ly [vy Hay]]]; unfold write_to; exists vy; rewrite Hay.
              rewrite H; unfold loc; rewrite Hay; auto.

   (*Rx Wy*)
      (*split; auto.*)
      apply A2nBasic.fr_in_mhb.
        generalize Hrx; intros [Heex Hrrx]; destruct Hwy as [Heey Hwy];
        split; [|split]; auto.
        destruct_valid Hv.
          generalize (Hrf_init x Hrx); intros [wx [Hewx Hwx]];
          exists wx; split; auto.
          rewrite Hws; split.
          destruct_lin Hle.
          apply Htrans with x; split.
            rewrite Hrf in Hwx; destruct Hwx as [? Hmax].
            destruct Hmax as [[? [? ?]] ?]; auto.
            apply Hinc; apply trc_step; left; split; auto.

            exists (loc x); split; split.
              left; exists x.
                rewrite Hrf in Hwx; destruct Hwx as [Hrfx Hmax].
                destruct Hmax as [Hpw ?].
                destruct Hpw as [? [? ?]]; auto.
                generalize (Hrf_cands wx x Hwx);
                intros [? [? [lx [Hwwx [[vx Hrrrx] ?]]]]].
                unfold loc; rewrite Hrrrx; auto.

              right; exists x.
                apply Hinc; apply trc_step; left; split; auto.
              destruct Hwy as [ly [vy Hay]]; unfold write_to; rewrite Hay.
              rewrite H; unfold loc; exists vy; rewrite Hay; auto.

  (*x ppo2 y*)
  apply trc_step; right; auto.

  apply trc_ind with z; auto.
Qed.

Lemma mv_implies_mvor :
  forall E X cy,
  well_formed_event_structure E ->
  A1bWmm.valid_execution E X ->
  crit_cy E cy ->
  (exists Y, A1bWmm.valid_execution E Y /\
     exists cy', crit_cy_or E Y cy').
Proof.
intros E X cy Hwf Hv1 Hcy.
destruct Hcy as [Hmcy [Hnac [Hi Hac1]]].

assert (exists so, vexec E so /\
    so_rfm E so = so_rfm E (tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))))  /\
    so_ws so = so_ws (tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E))))) as Heex.
  exists (tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E)))); split; [|split]; auto.
  apply cy_inter_conflict_ppo1_vexec; auto.

generalize (VA1.ScModel.vexec_is_valid E
  (so_rfm E (tc (rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E)))))
  (so_ws (tc ((rel_union (rel_inter cy (conflict E)) (rel_union (A1b.ppo E) (pio_llh E)))))) Hwf Heex);
intros [Y [HvY [Hrf Hws]]]; exists Y; split; auto.

exists cy; split; [|split]; auto.
  apply cy_is_or; auto.
  unfold sigma_wf in Hmcy; rewrite union_triv in Hmcy; auto.
Qed.

Lemma cy_or_in_ghb2 :
  forall E X cy,
  well_formed_event_structure E ->
  crit_cy_or E X cy ->
  rel_incl cy (tc (A2nWmm.ghb E X)).
Proof.
intros E X cy Hwf [Hmcy [? [? ?]]] x y Hxy.
rewrite ghb2_is_mhb_ppo2.
generalize (Hmcy x y Hxy); intro Htc.
generalize Htc; apply tc_incl.
intros e1 e2 Hor.
inversion Hor as [Hmhbd | Hppo2].
  destruct Hmhbd as [Hmhb ?].
    left; auto.
  right; auto.
Qed.

Set Implicit Arguments.
Lemma tc_tc :
  forall A (r: Rln A) x y,
  tc (tc r) x y ->
  tc r x y.
Proof.
intros A r x y Hxy.
induction Hxy; auto.
apply trc_ind with z; auto.
Qed.

Lemma ac_implies_tc_ac :
  forall A (r:Rln A),
  acyclic r ->
  acyclic (tc r).
Proof.
intros A r Hac x Hx.
generalize (tc_tc Hx); intro Htc.
apply (Hac x Htc); auto.
Qed.
Unset Implicit Arguments.

Lemma stability_to_SC :
  forall E, well_formed_event_structure E ->
               (exists X, A1bWmm.valid_execution E X) ->
  ((forall X, (A1bWmm.valid_execution E X -> A2nWmm.valid_execution E X)) <->
  (~(exists cy, crit_cy E cy))).
Proof.
intros E Hwf [X Hv1]; split.
  intros Hp [cy Hcy].
  generalize (mv_implies_mvor Hwf Hv1 Hcy);
    intros [Y [Hv1Y [cy' Hcy']]].
  generalize (Hp Y Hv1Y); intro Hv2.
  generalize (cy_or_in_ghb2 Hwf Hcy'); intro Hincl.
  destruct_valid Hv2.
  assert (acyclic (tc (A2nWmm.ghb E Y))) as Hac.
    apply ac_implies_tc_ac; auto.
  generalize (incl_ac Hincl Hac); intro Haccy.
  destruct Hcy' as [? [? [Hnac ?]]].
  contradiction.

  intros Hncy Y Hv1Y.
      generalize (v1_and_no_cy_implies_covered Hwf Hv1Y Hncy); intro Hc.
      apply prop_implies_v2; auto.
Qed.

End StableSC.


Require Import Blech.Defaults.

Require Import Blech.Bishop.
Require Import Blech.Category.
Require Import Blech.Category.Bsh.
Require Import Blech.Category.Op.
Require Import Blech.Category.Funct.

Import OpNotations.

Definition PSh (C: Category): Category := Funct (C ᵒᵖ) Bsh.


(* *********************************************************************)
(*                                                                     *)
(*              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.     *)
(*                                                                     *)
(* *********************************************************************)

(** Computation of resource bounds for Linear code. *)

Require Import FSets FSetAVL.
Require Import Coqlib Ordered.
Require Intv.
Require Import AST.
Require Import Op.
Require Import Machregs Locations.
Require Import Linear.
Require Import Conventions.

Module RegOrd := OrderedIndexed (IndexedMreg).
Module RegSet := FSetAVL.Make (RegOrd).

(** * Resource bounds for a function *)

(** The [bounds] record capture how many local and outgoing stack slots
  and callee-save registers are used by a function. *)

(** We demand that all bounds are positive or null.
  These properties are used later to reason about the layout of
  the activation record. *)

Record bounds : Type := mkbounds {
  used_callee_save: list mreg;
  bound_local: Z;
  bound_outgoing: Z;
  bound_stack_data: Z;
  bound_local_pos: bound_local >= 0;
  bound_outgoing_pos: bound_outgoing >= 0;
  bound_stack_data_pos: bound_stack_data >= 0;
  used_callee_save_norepet: list_norepet used_callee_save;
  used_callee_save_prop: forall r, In r used_callee_save -> is_callee_save r = true
}.

(** The following predicates define the correctness of a set of bounds
    for the code of a function. *)

Section WITHIN_BOUNDS.

Variable b: bounds.

Definition mreg_within_bounds (r: mreg) :=
  is_callee_save r = true -> In r (used_callee_save b).

Definition slot_within_bounds (sl: slot) (ofs: Z) (ty: typ) :=
  match sl with
  | Local => ofs + typesize ty <= bound_local b
  | Outgoing => ofs + typesize ty <= bound_outgoing b
  | Incoming => True
  end.

Definition instr_within_bounds (i: instruction) :=
  match i with
  | Lgetstack sl ofs ty r => slot_within_bounds sl ofs ty /\ mreg_within_bounds r
  | Lsetstack r sl ofs ty => slot_within_bounds sl ofs ty
  | Lop op args res => mreg_within_bounds res
  | Lload chunk addr args dst => mreg_within_bounds dst
  | Lcall sig ros => size_arguments sig <= bound_outgoing b
  | Lbuiltin ef args res =>
       (forall r, In r (params_of_builtin_res res) \/ In r (destroyed_by_builtin ef) -> mreg_within_bounds r)
    /\ (forall sl ofs ty, In (S sl ofs ty) (params_of_builtin_args args) -> slot_within_bounds sl ofs ty)
  | _ => True
  end.

End WITHIN_BOUNDS.

Definition function_within_bounds (f: function) (b: bounds) : Prop :=
  forall instr, In instr f.(fn_code) -> instr_within_bounds b instr.

(** * Inference of resource bounds for a function *)

(** The resource bounds for a function are computed by a linear scan
  of its instructions. *)

Section BOUNDS.

Variable f: function.

Definition record_reg (u: RegSet.t) (r: mreg) : RegSet.t :=
  if is_callee_save r then RegSet.add r u else u.

Definition record_regs (u: RegSet.t) (rl: list mreg) : RegSet.t :=
  fold_left record_reg rl u.

(** In the proof of the [Stacking] pass, we only need to bound the
  registers written by an instruction.  Therefore, we examine the
  result registers only, not the argument registers. *)

Definition record_regs_of_instr (u: RegSet.t) (i: instruction) : RegSet.t :=
  match i with
  | Lgetstack sl ofs ty r => record_reg u r
  | Lsetstack r sl ofs ty => record_reg u r
  | Lop op args res => record_reg u res
  | Lload chunk addr args dst => record_reg u dst
  | Lstore chunk addr args src => u
  | Lcall sig ros => u
  | Ltailcall sig ros => u
  | Lbuiltin ef args res =>
      record_regs (record_regs u (params_of_builtin_res res)) (destroyed_by_builtin ef)
  | Llabel lbl => u
  | Lgoto lbl => u
  | Lcond cond args lbl => u
  | Ljumptable arg tbl => u
  | Lreturn => u
  end.

Definition record_regs_of_function : RegSet.t :=
  fold_left record_regs_of_instr f.(fn_code) RegSet.empty.

Fixpoint slots_of_locs (l: list loc) : list (slot * Z * typ) :=
  match l with
  | nil => nil
  | S sl ofs ty :: l' => (sl, ofs, ty) :: slots_of_locs l'
  | R r :: l' => slots_of_locs l'
  end.

Definition slots_of_instr (i: instruction) : list (slot * Z * typ) :=
  match i with
  | Lgetstack sl ofs ty r => (sl, ofs, ty) :: nil
  | Lsetstack r sl ofs ty => (sl, ofs, ty) :: nil
  | Lbuiltin ef args res => slots_of_locs (params_of_builtin_args args)
  | _ => nil
  end.

Definition max_over_list {A: Type} (valu: A -> Z) (l: list A) : Z :=
  List.fold_left (fun m l => Z.max m (valu l)) l 0.

Definition max_over_instrs (valu: instruction -> Z) : Z :=
  max_over_list valu f.(fn_code).

Definition max_over_slots_of_instr (valu: slot * Z * typ -> Z) (i: instruction) : Z :=
  max_over_list valu (slots_of_instr i).

Definition max_over_slots_of_funct (valu: slot * Z * typ -> Z) : Z :=
  max_over_instrs (max_over_slots_of_instr valu).

Definition local_slot (s: slot * Z * typ) :=
  match s with (Local, ofs, ty) => ofs + typesize ty | _ => 0 end.

Definition outgoing_slot (s: slot * Z * typ) :=
  match s with (Outgoing, ofs, ty) => ofs + typesize ty | _ => 0 end.

Definition outgoing_space (i: instruction) :=
  match i with Lcall sig _ => size_arguments sig | _ => 0 end.

Lemma max_over_list_pos:
  forall (A: Type) (valu: A -> Z) (l: list A),
  max_over_list valu l >= 0.
Proof.
  intros until valu. unfold max_over_list.
  assert (forall l z, fold_left (fun x y => Z.max x (valu y)) l z >= z).
  induction l; simpl; intros.
  lia. apply Zge_trans with (Z.max z (valu a)).
  auto. apply Z.le_ge. apply Z.le_max_l. auto.
Qed.

Lemma max_over_slots_of_funct_pos:
  forall (valu: slot * Z * typ -> Z), max_over_slots_of_funct valu >= 0.
Proof.
  intros. unfold max_over_slots_of_funct.
  unfold max_over_instrs. apply max_over_list_pos.
Qed.

(* Move elsewhere? *)

Remark fold_left_preserves:
  forall (A B: Type) (f: A -> B -> A) (P: A -> Prop),
  (forall a b, P a -> P (f a b)) ->
  forall l a, P a -> P (fold_left f l a).
Proof.
  induction l; simpl; auto.
Qed.

Remark fold_left_ensures:
  forall (A B: Type) (f: A -> B -> A) (P: A -> Prop) b0,
  (forall a b, P a -> P (f a b)) ->
  (forall a, P (f a b0)) ->
  forall l a, In b0 l -> P (fold_left f l a).
Proof.
  induction l; simpl; intros. contradiction.
  destruct H1. subst a. apply fold_left_preserves; auto. apply IHl; auto.
Qed.

Definition only_callee_saves (u: RegSet.t) : Prop :=
  forall r, RegSet.In r u -> is_callee_save r = true.

Lemma record_reg_only: forall u r, only_callee_saves u -> only_callee_saves (record_reg u r).
Proof.
  unfold only_callee_saves, record_reg; intros.
  destruct (is_callee_save r) eqn:CS; auto.
  destruct (mreg_eq r r0). congruence. apply H; eapply RegSet.add_3; eauto.
Qed.

Lemma record_regs_only: forall rl u, only_callee_saves u -> only_callee_saves (record_regs u rl).
Proof.
  intros. unfold record_regs. apply fold_left_preserves; auto using record_reg_only.
Qed.

Lemma record_regs_of_instr_only: forall u i, only_callee_saves u -> only_callee_saves (record_regs_of_instr u i).
Proof.
  intros. destruct i; simpl; auto using record_reg_only, record_regs_only.
Qed.

Lemma record_regs_of_function_only:
  only_callee_saves record_regs_of_function.
Proof.
  intros. unfold record_regs_of_function.
  apply fold_left_preserves. apply record_regs_of_instr_only.
  red; intros. eelim RegSet.empty_1; eauto.
Qed.

Program Definition function_bounds := {|
  used_callee_save := RegSet.elements record_regs_of_function;
  bound_local := max_over_slots_of_funct local_slot;
  bound_outgoing := Z.max (max_over_instrs outgoing_space) (max_over_slots_of_funct outgoing_slot);
  bound_stack_data := Z.max f.(fn_stacksize) 0
|}.
Next Obligation.
  apply max_over_slots_of_funct_pos.
Qed.
Next Obligation.
  apply Z.le_ge. eapply Z.le_trans. 2: apply Z.le_max_r.
  apply Z.ge_le. apply max_over_slots_of_funct_pos.
Qed.
Next Obligation.
  apply Z.le_ge. apply Z.le_max_r.
Qed.
Next Obligation.
  generalize (RegSet.elements_3w record_regs_of_function).
  generalize (RegSet.elements record_regs_of_function).
  induction 1. constructor. constructor; auto.
  red; intros; elim H. apply InA_alt. exists x; auto.
Qed.
Next Obligation.
  apply record_regs_of_function_only. apply RegSet.elements_2.
  apply InA_alt. exists r; auto.
Qed.

(** We now show the correctness of the inferred bounds. *)

Lemma record_reg_incr: forall u r r', RegSet.In r' u -> RegSet.In r' (record_reg u r).
Proof.
  unfold record_reg; intros. destruct (is_callee_save r); auto. apply RegSet.add_2; auto.
Qed.

Lemma record_reg_ok: forall u r, is_callee_save r = true -> RegSet.In r (record_reg u r).
Proof.
  unfold record_reg; intros. rewrite H. apply RegSet.add_1; auto.
Qed.

Lemma record_regs_incr: forall r' rl u, RegSet.In r' u -> RegSet.In r' (record_regs u rl).
Proof.
  intros. unfold record_regs. apply fold_left_preserves; auto using record_reg_incr.
Qed.

Lemma record_regs_ok: forall r rl u, In r rl -> is_callee_save r = true -> RegSet.In r (record_regs u rl).
Proof.
  intros. unfold record_regs. eapply fold_left_ensures; eauto using record_reg_incr, record_reg_ok.
Qed.

Lemma record_regs_of_instr_incr: forall r' u i, RegSet.In r' u -> RegSet.In r' (record_regs_of_instr u i).
Proof.
  intros. destruct i; simpl; auto using record_reg_incr, record_regs_incr.
Qed.

Definition defined_by_instr (r': mreg) (i: instruction) :=
  match i with
  | Lgetstack sl ofs ty r => r' = r
  | Lop op args res => r' = res
  | Lload chunk addr args dst => r' = dst
  | Lbuiltin ef args res => In r' (params_of_builtin_res res) \/ In r' (destroyed_by_builtin ef)
  | _ => False
  end.

Lemma record_regs_of_instr_ok: forall r' u i, defined_by_instr r' i -> is_callee_save r' = true -> RegSet.In r' (record_regs_of_instr u i).
Proof.
  intros. destruct i; simpl in *; try contradiction; subst; auto using record_reg_ok.
  destruct H; auto using record_regs_incr, record_regs_ok.
Qed.

Lemma record_regs_of_function_ok:
  forall r i, In i f.(fn_code) -> defined_by_instr r i -> is_callee_save r = true -> RegSet.In r record_regs_of_function.
Proof.
  intros. unfold record_regs_of_function.
  eapply fold_left_ensures; eauto using record_regs_of_instr_incr, record_regs_of_instr_ok.
Qed.

Lemma max_over_list_bound:
  forall (A: Type) (valu: A -> Z) (l: list A) (x: A),
  In x l -> valu x <= max_over_list valu l.
Proof.
  intros until x. unfold max_over_list.
  assert (forall c z,
            let f := fold_left (fun x y => Z.max x (valu y)) c z in
            z <= f /\ (In x c -> valu x <= f)).
    induction c; simpl; intros.
    split. lia. tauto.
    elim (IHc (Z.max z (valu a))); intros.
    split. apply Z.le_trans with (Z.max z (valu a)). apply Z.le_max_l. auto.
    intro H1; elim H1; intro.
    subst a. apply Z.le_trans with (Z.max z (valu x)).
    apply Z.le_max_r. auto. auto.
  intro. elim (H l 0); intros. auto.
Qed.

Lemma max_over_instrs_bound:
  forall (valu: instruction -> Z) i,
  In i f.(fn_code) -> valu i <= max_over_instrs valu.
Proof.
  intros. unfold max_over_instrs. apply max_over_list_bound; auto.
Qed.

Lemma max_over_slots_of_funct_bound:
  forall (valu: slot * Z * typ -> Z) i s,
  In i f.(fn_code) -> In s (slots_of_instr i) ->
  valu s <= max_over_slots_of_funct valu.
Proof.
  intros. unfold max_over_slots_of_funct.
  apply Z.le_trans with (max_over_slots_of_instr valu i).
  unfold max_over_slots_of_instr. apply max_over_list_bound. auto.
  apply max_over_instrs_bound. auto.
Qed.

Lemma local_slot_bound:
  forall i ofs ty,
  In i f.(fn_code) -> In (Local, ofs, ty) (slots_of_instr i) ->
  ofs + typesize ty <= bound_local function_bounds.
Proof.
  intros.
  unfold function_bounds, bound_local.
  change (ofs + typesize ty) with (local_slot (Local, ofs, ty)).
  eapply max_over_slots_of_funct_bound; eauto.
Qed.

Lemma outgoing_slot_bound:
  forall i ofs ty,
  In i f.(fn_code) -> In (Outgoing, ofs, ty) (slots_of_instr i) ->
  ofs + typesize ty <= bound_outgoing function_bounds.
Proof.
  intros. change (ofs + typesize ty) with (outgoing_slot (Outgoing, ofs, ty)).
  unfold function_bounds, bound_outgoing.
  apply Zmax_bound_r. eapply max_over_slots_of_funct_bound; eauto.
Qed.

Lemma size_arguments_bound:
  forall sig ros,
  In (Lcall sig ros) f.(fn_code) ->
  size_arguments sig <= bound_outgoing function_bounds.
Proof.
  intros. change (size_arguments sig) with (outgoing_space (Lcall sig ros)).
  unfold function_bounds, bound_outgoing.
  apply Zmax_bound_l. apply max_over_instrs_bound; auto.
Qed.

(** Consequently, all machine registers or stack slots mentioned by one
  of the instructions of function [f] are within bounds. *)

Lemma mreg_is_within_bounds:
  forall i, In i f.(fn_code) ->
  forall r, defined_by_instr r i ->
  mreg_within_bounds function_bounds r.
Proof.
  intros. unfold mreg_within_bounds. intros.
  exploit record_regs_of_function_ok; eauto. intros.
  apply RegSet.elements_1 in H2. rewrite InA_alt in H2. destruct H2 as (r' & A & B).
  subst r'; auto.
Qed.

Lemma slot_is_within_bounds:
  forall i, In i f.(fn_code) ->
  forall sl ty ofs, In (sl, ofs, ty) (slots_of_instr i) ->
  slot_within_bounds function_bounds sl ofs ty.
Proof.
  intros. unfold slot_within_bounds.
  destruct sl.
  eapply local_slot_bound; eauto.
  auto.
  eapply outgoing_slot_bound; eauto.
Qed.

Lemma slots_of_locs_charact:
  forall sl ofs ty l, In (sl, ofs, ty) (slots_of_locs l) <-> In (S sl ofs ty) l.
Proof.
  induction l; simpl; intros.
  tauto.
  destruct a; simpl; intuition congruence.
Qed.

(** It follows that every instruction in the function is within bounds,
    in the sense of the [instr_within_bounds] predicate. *)

Lemma instr_is_within_bounds:
  forall i,
  In i f.(fn_code) ->
  instr_within_bounds function_bounds i.
Proof.
  intros;
  destruct i;
  generalize (mreg_is_within_bounds _ H); generalize (slot_is_within_bounds _ H);
  simpl; intros; auto.
(* call *)
  eapply size_arguments_bound; eauto.
(* builtin *)
  split; intros.
  apply H1; auto.
  apply H0. rewrite slots_of_locs_charact; auto.
Qed.

Lemma function_is_within_bounds:
  function_within_bounds f function_bounds.
Proof.
  intros; red; intros. apply instr_is_within_bounds; auto.
Qed.

End BOUNDS.

(** Helper to determine the size of the frame area that holds the contents of saved registers. *)

Fixpoint size_callee_save_area_rec (l: list mreg) (ofs: Z) : Z :=
  match l with
  | nil => ofs
  | r :: l =>
      let ty := mreg_type r in
      let sz := AST.typesize ty in
      size_callee_save_area_rec l (align ofs sz + sz)
  end.

Definition size_callee_save_area (b: bounds) (ofs: Z) : Z :=
  size_callee_save_area_rec (used_callee_save b) ofs.

Lemma size_callee_save_area_rec_incr:
  forall l ofs, ofs <= size_callee_save_area_rec l ofs.
Proof.
Local Opaque mreg_type.
  induction l as [ | r l]; intros; simpl.
- lia.
- eapply Z.le_trans. 2: apply IHl.
  generalize (AST.typesize_pos (mreg_type r)); intros.
  apply Z.le_trans with (align ofs (AST.typesize (mreg_type r))).
  apply align_le; auto.
  lia.
Qed.

Lemma size_callee_save_area_incr:
  forall b ofs, ofs <= size_callee_save_area b ofs.
Proof.
  intros. apply size_callee_save_area_rec_incr.
Qed.

(** Layout of the stack frame and its properties.  These definitions
  are used in the machine-dependent [Stacklayout] module and in the
  [Stacking] pass. *)

Record frame_env : Type := mk_frame_env {
  fe_size: Z;
  fe_ofs_link: Z;
  fe_ofs_retaddr: Z;
  fe_ofs_local: Z;
  fe_ofs_callee_save: Z;
  fe_stack_data: Z;
  fe_used_callee_save: list mreg
}.


Require Import Crypto.Compilers.Named.Context.
Require Import Crypto.Compilers.Named.Syntax.
Require Import Crypto.Compilers.Named.Wf.
Require Import Crypto.Compilers.Named.ContextDefinitions.
Require Import Crypto.Compilers.Named.ContextProperties.
Require Import Crypto.Compilers.Named.ContextProperties.SmartMap.
Require Import Crypto.Compilers.Named.InterpretToPHOAS.
Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Compilers.Wf.
Require Import Crypto.Util.PointedProp.
Require Import Crypto.Util.Decidable.
Require Import Crypto.Util.Option.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.DestructHead.

Section language.
  Context {base_type_code : Type}
          {op : flat_type base_type_code -> flat_type base_type_code -> Type}
          {Name : Type}
          {base_type_code_dec : DecidableRel (@eq base_type_code)}
          {Name_dec : DecidableRel (@eq Name)}.
  Section with_var.
    Context {var1 var2 : base_type_code -> Type}
            {Context1 : Context Name var1}
            {Context2 : Context Name var2}
            {Context1Ok : ContextOk Context1}
            {Context2Ok : ContextOk Context2}
            (failb1 : forall t, @Syntax.exprf base_type_code op var1 (Tbase t))
            (failb2 : forall t, @Syntax.exprf base_type_code op var2 (Tbase t)).

    Local Ltac t_step :=
      first [ progress intros
            | progress unfold dec in *
            | reflexivity
            | progress subst
            | progress inversion_option
            | erewrite lookupb_extend by assumption
            | rewrite <- !find_Name_and_val_None_iff
            | progress break_innermost_match_step
            | progress break_match_hyps
            | solve [ eauto using find_Name_and_val_flatten_binding_list ]
            | congruence
            | tauto
            | match goal with
              | [ H : lookupb (extend _ _ _) _ = _ |- _ ]
                => erewrite (lookupb_extend _ _ _) in H by assumption
              | [ H : context[List.In _ (_ ++ _)] |- _ ]
                => setoid_rewrite List.in_app_iff in H
              | [ |- context[List.In _ (_ ++ _)] ]
                => rewrite List.in_app_iff
              | [ |- context[find_Name_and_val ?tdec ?ndec ?a ?b ?c ?d ?default] ]
                => lazymatch default with None => fail | _ => idtac end;
                   rewrite (find_Name_and_val_split tdec ndec (default:=default))
              | [ H : context[find_Name_and_val ?tdec ?ndec ?a ?b ?c ?d ?default] |- _ ]
                => lazymatch default with None => fail | _ => idtac end;
                   rewrite (find_Name_and_val_split tdec ndec (default:=default)) in H
              | [ H : forall n t, lookupb _ n = None <-> lookupb _ n = None |- context[lookupb _ _ = None] ]
                => rewrite H
              | [ H : forall n t, lookupb _ n = None |- context[lookupb _ _ = None] ]
                => rewrite H
              end ].
    Local Ltac t := repeat t_step.

    Lemma wff_interpf_to_phoas
          (ctx1 : Context1) (ctx2 : Context2)
          {t} (e : @Named.exprf base_type_code op Name t)
          (Hwf1 : prop_of_option (Named.wff ctx1 e))
          (Hwf2 : prop_of_option (Named.wff ctx2 e))
          G
          (HG : forall n t v1 v2,
              lookupb t ctx1 n = Some v1
              -> lookupb t ctx2 n = Some v2
              -> List.In (existT _ t (v1, v2)%core) G)
          (Hctx1_ctx2 : forall n t,
              lookupb t ctx1 n = None <-> lookupb t ctx2 n = None)
      : wff G (interpf_to_phoas failb1 ctx1 e) (interpf_to_phoas failb2 ctx2 e).
    Proof using Context1Ok Context2Ok Name_dec base_type_code_dec.
      revert dependent G; revert dependent ctx1; revert dependent ctx2; induction e;
        repeat first [ progress intros
                     | progress destruct_head' and
                     | progress break_innermost_match_step
                     | progress simpl in *
                     | progress autorewrite with push_prop_of_option in *
                     | solve [ eauto | tauto ]
                     | match goal with
                       | [ |- wff _ _ _ ] => constructor
                       end ].
      match goal with H : _ |- _ => eapply H end; t.
    Qed.

    Lemma wf_interp_to_phoas_gen
          (ctx1 : Context1) (ctx2 : Context2)
          {t} (e : @Named.expr base_type_code op Name t)
          (Hwf1 : Named.wf ctx1 e)
          (Hwf2 : Named.wf ctx2 e)
          (Hctx1 : forall n t, lookupb t ctx1 n = None)
          (Hctx2 : forall n t, lookupb t ctx2 n = None)
      : wf (interp_to_phoas failb1 ctx1 e) (interp_to_phoas failb2 ctx2 e).
    Proof using Context1Ok Context2Ok Name_dec base_type_code_dec.
      constructor; intros.
      apply wff_interpf_to_phoas; t.
    Qed.

    Lemma wf_interp_to_phoas
          {t} (e : @Named.expr base_type_code op Name t)
          (Hwf1 : Named.wf (Context:=Context1) empty e)
          (Hwf2 : Named.wf (Context:=Context2) empty e)
      : wf (interp_to_phoas (Context:=Context1) failb1 empty e) (interp_to_phoas (Context:=Context2) failb2 empty e).
    Proof using Context1Ok Context2Ok Name_dec base_type_code_dec.
      apply wf_interp_to_phoas_gen; auto using lookupb_empty.
    Qed.
  End with_var.

  Section all.
    Context {Context : forall var, @Context base_type_code Name var}
            {ContextOk : forall var, ContextOk (Context var)}
            (failb : forall var t, @Syntax.exprf base_type_code op var (Tbase t)).

    Lemma Wf_InterpToPHOAS_gen
          {ctx : forall var, Context var}
          {t} (e : @Named.expr base_type_code op Name t)
          (Hctx : forall var n t, lookupb t (ctx var) n = None)
          (Hwf : forall var, Named.wf (ctx var) e)
      : Wf (InterpToPHOAS_gen failb ctx e).
    Proof using ContextOk Name_dec base_type_code_dec.
      intros ??; apply wf_interp_to_phoas_gen; auto.
    Qed.

    Lemma Wf_InterpToPHOAS
          {t} (e : @Named.expr base_type_code op Name t)
          (Hwf : Named.Wf Context e)
      : Wf (InterpToPHOAS (Context:=Context) failb e).
    Proof using ContextOk Name_dec base_type_code_dec.
      intros ??; apply wf_interp_to_phoas; auto.
    Qed.
  End all.
End language.

Hint Resolve Wf_InterpToPHOAS : wf.