(* Just reexport Iris mdoule *)
From iris.base_logic Require Export lib.ghost_map.

(* Add some Perennial-specific stuff *)
From iris.proofmode Require Import tactics.
From Perennial.algebra Require Import own_discrete atleast.
From Perennial.Helpers Require Import Map.

Set Default Proof Using "Type".

Section lemmas.
  Context `{ghost_mapG Σ K V}.
  Implicit Types (k : K) (v : V) (dq : dfrac) (q : Qp) (m : gmap K V).

  Lemma ghost_map_elem_big_exist γ m :
    ([∗ map] l↦_ ∈ m, ∃ v', l ↪[γ] v') -∗
    ∃ m', ⌜dom m' = dom m⌝ ∗
          [∗ map] l↦v ∈ m', l ↪[γ] v.
  Proof.
    induction m as [|l v m] using map_ind.
    - rewrite big_sepM_empty.
      iIntros "_". iExists ∅.
      iSplit; first done.
      rewrite big_sepM_empty; done.
    - rewrite big_sepM_insert //.
      iIntros "[Hl Hm]".
      iDestruct "Hl" as (v') "Hl".
      iDestruct (IHm with "Hm") as (m0 Hdom) "Hm".
      iExists (<[l:=v']> m0).
      iSplit.
      + iPureIntro.
        rewrite !dom_insert_L. congruence.
      + rewrite big_sepM_insert; [ by iFrame | ].
        apply not_elem_of_dom.
        apply not_elem_of_dom in H1.
        congruence.
  Qed.

  Lemma ghost_map_update_big_exist {γ m} m1 :
    ghost_map_auth γ 1 m -∗
    ( [∗ map] l↦v ∈ m1, ∃ v', l ↪[γ] v' ) ==∗
      ghost_map_auth γ 1 (m1 ∪ m) ∗
      ( [∗ map] l↦v ∈ m1, l ↪[γ] v ).
  Proof.
    iIntros "Hauth Hm0".
    iDestruct (ghost_map_elem_big_exist with "Hm0") as (m0 Hdom) "Hm0".
    iMod (ghost_map_update_big with "Hauth Hm0") as "[$ Hm]"; auto.
  Qed.

  Global Instance ghost_map_auth_discrete γ q m : Discretizable (ghost_map_auth γ q m).
  Proof. rewrite ghost_map.ghost_map_auth_unseal. apply _. Qed.

  Global Instance ghost_map_auth_abs_timeless γ q m : AbsolutelyTimeless (ghost_map_auth γ q m).
  Proof. rewrite ghost_map.ghost_map_auth_unseal. apply _. Qed.

  Global Instance ghost_map_elem_discrete γ dq k v : Discretizable (k ↪[γ]{dq} v).
  Proof. rewrite ghost_map.ghost_map_elem_unseal. apply _. Qed.

  Global Instance ghost_map_elem_abs_timeless γ dq k v : AbsolutelyTimeless (k ↪[γ]{dq} v).
  Proof. rewrite ghost_map.ghost_map_elem_unseal. apply _. Qed.

End lemmas.


(* *********************************************************************)
(*                                                                     *)
(*              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 GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(* A solver for unification constraints. *)

Require Import Recdef Coqlib Maps Errors.

Local Open Scope nat_scope.
Local Open Scope error_monad_scope.

(** This module provides a solver for sets of unification constraints of the
  following kinds: [T(x) = base-type] or [T(x) = T(y)].
  The unknowns are the types [T(x)] of every identifier [x]. *)

(** The interface for base types. *)

Module Type TYPE_ALGEBRA.

Parameter t: Type.
Parameter eq: forall (x y: t), {x=y} + {x<>y}.
Parameter default: t.

End TYPE_ALGEBRA.

(** The constraint solver. *)

Module UniSolver (T: TYPE_ALGEBRA).

(* The current set of constraints is represented by a record with two components:
- [te_typ]: a partial map from variables to types
- [te_equ]: a list of pairs [(x,y)] of variables, indicating that
  the type of [x] must be equal to the type of [y].
*)

Definition constraint : Type := (positive * positive)%type.

Record typenv : Type := Typenv {
  te_typ: PTree.t T.t;       (**r mapping var -> typ *)
  te_equ: list constraint    (**r additional equality constraints *)
}.

Definition initial : typenv := {| te_typ := PTree.empty _; te_equ := nil |}.

(** Add the constraint [T(x) = ty]. *)

Definition set (e: typenv) (x: positive) (ty: T.t) : res typenv :=
  match e.(te_typ)!x with
  | None =>
      OK {| te_typ := PTree.set x ty e.(te_typ);
            te_equ := e.(te_equ) |}
  | Some ty' =>
      if T.eq ty ty'
      then OK e
      else Error (MSG "bad definition/use of variable " :: POS x :: nil)
  end.

Fixpoint set_list (e: typenv) (rl: list positive) (tyl: list T.t) {struct rl}: res typenv :=
  match rl, tyl with
  | nil, nil => OK e
  | r1::rs, ty1::tys => do e1 <- set e r1 ty1; set_list e1 rs tys
  | _, _ => Error (msg "arity mismatch")
  end.

(** Add the constraint [T(x) = T(y)].
    The boolean result is [true] if the types of [x] or [y] could be
    made more precise.  Otherwise, [te_typ] does not change and
    [false] is returned. *)

Definition move (e: typenv) (r1 r2: positive) : res (bool * typenv) :=
  if peq r1 r2 then OK (false, e) else
  match e.(te_typ)!r1, e.(te_typ)!r2 with
  | None, None =>
      OK (false, {| te_typ := e.(te_typ); te_equ := (r1, r2) :: e.(te_equ) |})
  | Some ty1, None =>
      OK (true, {| te_typ := PTree.set r2 ty1 e.(te_typ); te_equ := e.(te_equ) |})
  | None, Some ty2 =>
      OK (true, {| te_typ := PTree.set r1 ty2 e.(te_typ); te_equ := e.(te_equ) |})
  | Some ty1, Some ty2 =>
      if T.eq ty1 ty2
      then OK (false, e)
      else Error(MSG "ill-typed move from " :: POS r1 :: MSG " to " :: POS r2 :: nil)
  end.

(** Solve the remaining subtyping constraints by iteration. *)

Fixpoint solve_rec (e: typenv) (changed: bool) (q: list constraint) : res (typenv * bool) :=
  match q with
  | nil =>
      OK (e, changed)
  | (r1, r2) :: q' =>
      do (changed1, e1) <- move e r1 r2; solve_rec e1 (changed || changed1) q'
  end.

(** Measuring the state *)

Lemma move_shape:
  forall e r1 r2 changed e',
  move e r1 r2 = OK (changed, e') ->
  (e'.(te_equ) = e.(te_equ) \/ e'.(te_equ) = (r1, r2) :: e.(te_equ))
  /\ (changed = true -> e'.(te_equ) = e.(te_equ)).
Proof.
  unfold move; intros.
  destruct (peq r1 r2). inv H. auto.
  destruct e.(te_typ)!r1 as [ty1|]; destruct e.(te_typ)!r2 as [ty2|]; inv H; simpl.
  destruct (T.eq ty1 ty2); inv H1. auto.
  auto.
  auto.
  split. auto. intros. discriminate.
Qed.

Lemma length_move:
  forall e r1 r2 changed e',
  move e r1 r2 = OK (changed, e') ->
  length e'.(te_equ) + (if changed then 1 else 0) <= S(length e.(te_equ)).
Proof.
  unfold move; intros.
  destruct (peq r1 r2). inv H. omega.
  destruct e.(te_typ)!r1 as [ty1|]; destruct e.(te_typ)!r2 as [ty2|]; inv H; simpl.
  destruct (T.eq ty1 ty2); inv H1. omega.
  omega.
  omega.
  omega.
Qed.

Lemma length_solve_rec:
  forall q e ch e' ch',
  solve_rec e ch q = OK (e', ch') ->
  length e'.(te_equ) + (if ch' && negb ch then 1 else 0) <= length e.(te_equ) + length q.
Proof.
  induction q; simpl; intros.
- inv H. replace (ch' && negb ch') with false. omega. destruct ch'; auto.
- destruct a as [r1 r2]; monadInv H. rename x0 into e0. rename x into ch0.
  exploit IHq; eauto. intros A.
  exploit length_move; eauto. intros B.
  set (X := (if ch' && negb (ch || ch0) then 1 else 0)) in *.
  set (Y := (if ch0 then 1 else 0)) in *.
  set (Z := (if ch' && negb ch then 1 else 0)) in *.
  cut (Z <= X + Y). intros. omega.
  unfold X, Y, Z. destruct ch'; destruct ch; destruct ch0; simpl; auto.
Qed.

Definition weight_typenv (e: typenv) : nat := length e.(te_equ).

(** Iterative solving of the remaining constraints *)

Function solve_constraints (e: typenv) {measure weight_typenv e}: res typenv :=
  match solve_rec {| te_typ := e.(te_typ); te_equ := nil |} false e.(te_equ) with
  | OK(e', false) => OK e                   (**r no more changes, fixpoint reached *)
  | OK(e', true)  => solve_constraints e'   (**r one more iteration *)
  | Error msg => Error msg
  end.
Proof.
  intros. exploit length_solve_rec; eauto. simpl. intros.
  unfold weight_typenv. omega.
Qed.

Definition typassign := positive -> T.t.

Definition makeassign (e: typenv) : typassign :=
  fun x => match e.(te_typ)!x with Some ty => ty | None => T.default end.

Definition solve (e: typenv) : res typassign :=
  do e' <- solve_constraints e; OK(makeassign e').

(** What it means to be a solution *)

Definition satisf (te: typassign) (e: typenv) : Prop :=
   (forall x ty, e.(te_typ)!x = Some ty -> te x = ty)
/\ (forall x y, In (x, y) e.(te_equ) -> te x = te y).

Lemma satisf_initial: forall te, satisf te initial.
Proof.
  unfold initial; intros; split; simpl; intros.
  rewrite PTree.gempty in H; discriminate.
  contradiction.
Qed.

(** Soundness proof *)

Lemma set_incr:
  forall te x ty e e', set e x ty = OK e' -> satisf te e' -> satisf te e.
Proof.
  unfold set; intros. destruct (te_typ e)!x as [ty'|] eqn:E.
- destruct (T.eq ty ty'); inv H. auto.
- inv H. destruct H0 as [A B]; simpl in *. red; split; intros; auto.
  apply A. rewrite PTree.gso by congruence. auto.
Qed.

Hint Resolve set_incr: ty.

Lemma set_sound:
  forall te x ty e e', set e x ty = OK e' -> satisf te e' -> te x = ty.
Proof.
  unfold set; intros. destruct H0 as [P Q].
  destruct (te_typ e)!x as [ty'|] eqn:E.
- destruct (T.eq ty ty'); inv H. eauto.
- inv H. simpl in P. apply P. apply PTree.gss.
Qed.

Lemma set_list_incr:
  forall te xl tyl e e', set_list e xl tyl = OK e' -> satisf te e' -> satisf te e.
Proof.
  induction xl; destruct tyl; simpl; intros; monadInv H; eauto with ty.
Qed.

Hint Resolve set_list_incr: ty.

Lemma set_list_sound:
  forall te xl tyl e e', set_list e xl tyl = OK e' -> satisf te e' -> map te xl = tyl.
Proof.
  induction xl; destruct tyl; simpl; intros; monadInv H.
  auto.
  f_equal. eapply set_sound; eauto with ty. eauto.
Qed.

Lemma move_incr:
  forall te e r1 r2 e' changed,
  move e r1 r2 = OK(changed, e') -> satisf te e' -> satisf te e.
Proof.
  unfold move; intros. destruct H0 as [P Q].
  destruct (peq r1 r2). inv H; split; auto.
  destruct (te_typ e)!r1 as [ty1|] eqn:E1;
  destruct (te_typ e)!r2 as [ty2|] eqn:E2.
- destruct (T.eq ty1 ty2); inv H. split; auto.
- inv H; simpl in *; split; auto. intros. apply P.
  rewrite PTree.gso by congruence. auto.
- inv H; simpl in *; split; auto. intros. apply P.
  rewrite PTree.gso by congruence. auto.
- inv H; simpl in *; split; auto.
Qed.

Hint Resolve move_incr: ty.

Lemma move_sound:
  forall te e r1 r2 e' changed,
  move e r1 r2 = OK(changed, e') -> satisf te e' -> te r1 = te r2.
Proof.
  unfold move; intros. destruct H0 as [P Q].
  destruct (peq r1 r2). congruence.
  destruct (te_typ e)!r1 as [ty1|] eqn:E1;
  destruct (te_typ e)!r2 as [ty2|] eqn:E2.
- destruct (T.eq ty1 ty2); inv H. erewrite ! P by eauto. auto.
- inv H; simpl in *. rewrite (P r1 ty1). rewrite (P r2 ty1). auto.
  apply PTree.gss. rewrite PTree.gso by congruence. auto.
- inv H; simpl in *. rewrite (P r1 ty2). rewrite (P r2 ty2). auto.
  rewrite PTree.gso by congruence. auto. apply PTree.gss.
- inv H; simpl in *. apply Q; auto.
Qed.

Lemma solve_rec_incr:
  forall te q e changed e' changed',
  solve_rec e changed q = OK(e', changed') -> satisf te e' -> satisf te e.
Proof.
  induction q; simpl; intros.
- inv H. auto.
- destruct a as [r1 r2]; monadInv H. eauto with ty.
Qed.

Lemma solve_rec_sound:
  forall te r1 r2 q e changed e' changed',
  solve_rec e changed q = OK(e', changed') -> In (r1, r2) q -> satisf te e' ->
  te r1 = te r2.
Proof.
  induction q; simpl; intros.
- contradiction.
- destruct a as [r3 r4]; monadInv H. destruct H0.
  + inv H. eapply move_sound; eauto. eapply solve_rec_incr; eauto.
  + eapply IHq; eauto with ty.
Qed.

Lemma move_false:
  forall e r1 r2 e',
  move e r1 r2 = OK(false, e') ->
  te_typ e' = te_typ e /\ makeassign e r1 = makeassign e r2.
Proof.
  unfold move; intros.
  destruct (peq r1 r2). inv H. split; auto.
  unfold makeassign;
  destruct (te_typ e)!r1 as [ty1|] eqn:E1;
  destruct (te_typ e)!r2 as [ty2|] eqn:E2.
- destruct (T.eq ty1 ty2); inv H. auto.
- discriminate.
- discriminate.
- inv H. split; auto.
Qed.

Lemma solve_rec_false:
  forall r1 r2 q e changed e',
  solve_rec e changed q = OK(e', false) ->
  changed = false /\
  (In (r1, r2) q -> makeassign e r1 = makeassign e r2).
Proof.
  induction q; simpl; intros.
- inv H. tauto.
- destruct a as [r3 r4]; monadInv H.
  exploit IHq; eauto. intros [P Q].
  destruct changed; try discriminate. destruct x; try discriminate.
  exploit move_false; eauto. intros [U V].
  split. auto. intros [A|A]. inv A. auto. exploit Q; auto.
  unfold makeassign; rewrite U; auto.
Qed.

Lemma solve_constraints_incr:
  forall te e e', solve_constraints e = OK e' -> satisf te e' -> satisf te e.
Proof.
  intros te e; functional induction (solve_constraints e); intros.
- inv H. auto.
- exploit solve_rec_incr; eauto. intros [A B].
  split; auto. intros; eapply solve_rec_sound; eauto.
- discriminate.
Qed.

Lemma solve_constraints_sound:
  forall e e', solve_constraints e = OK e' -> satisf (makeassign e') e'.
Proof.
  intros e0; functional induction (solve_constraints e0); intros.
- inv H. split; intros.
  unfold makeassign; rewrite H. split; auto with ty.
  exploit solve_rec_false. eauto. intros [A B]. eapply B; eauto.
- eauto.
- discriminate.
Qed.

Theorem solve_sound:
  forall e te, solve e = OK te -> satisf te e.
Proof.
  unfold solve; intros. monadInv H.
  eapply solve_constraints_incr. eauto. eapply solve_constraints_sound; eauto.
Qed.

(** Completeness proof *)

Lemma set_complete:
  forall te e x ty,
  satisf te e -> te x = ty -> exists e', set e x ty = OK e' /\ satisf te e'.
Proof.
  unfold set; intros. generalize H; intros [P Q].
  destruct (te_typ e)!x as [ty1|] eqn:E.
- replace ty1 with ty. rewrite dec_eq_true. exists e; auto.
  exploit P; eauto. congruence.
- econstructor; split; eauto. split; simpl; intros; auto.
  rewrite PTree.gsspec in H1. destruct (peq x0 x). congruence. eauto.
Qed.

Lemma set_list_complete:
  forall te xl tyl e,
  satisf te e -> map te xl = tyl ->
  exists e', set_list e xl tyl = OK e' /\ satisf te e'.
Proof.
  induction xl; intros; inv H0; simpl.
  econstructor; eauto.
  exploit (set_complete te e a (te a)); auto. intros (e1 & P & Q).
  exploit (IHxl (map te xl) e1); auto. intros (e2 & U & V).
  exists e2; split; auto. rewrite P; auto.
Qed.

Lemma move_complete:
  forall te e r1 r2,
  satisf te e -> te r1 = te r2 ->
  exists changed e', move e r1 r2 = OK(changed, e') /\ satisf te e'.
Proof.
  unfold move; intros. elim H; intros P Q.
  assert (Q': forall x y, In (x, y) ((r1, r2) :: te_equ e) -> te x = te y).
  { intros. destruct H1; auto. congruence. }
  destruct (peq r1 r2). econstructor; econstructor; eauto.
  destruct (te_typ e)!r1 as [ty1|] eqn:E1;
  destruct (te_typ e)!r2 as [ty2|] eqn:E2.
- replace ty2 with ty1. rewrite dec_eq_true. econstructor; econstructor; eauto.
  exploit (P r1); eauto. exploit (P r2); eauto. congruence.
- econstructor; econstructor; split; eauto.
  split; simpl; intros; auto. rewrite PTree.gsspec in H1. destruct (peq x r2).
  inv H1. rewrite <- H0. eauto.
  eauto.
- econstructor; econstructor; split; eauto.
  split; simpl; intros; auto. rewrite PTree.gsspec in H1. destruct (peq x r1).
  inv H1. rewrite H0. eauto.
  eauto.
- econstructor; econstructor; split; eauto.
  split; eauto.
Qed.

Lemma solve_rec_complete:
  forall te q e changed,
  satisf te e ->
  (forall r1 r2, In (r1, r2) q -> te r1 = te r2) ->
  exists e' changed', solve_rec e changed q = OK(e', changed') /\ satisf te e'.
Proof.
  induction q; simpl; intros.
- econstructor; econstructor; eauto.
- destruct a as [r1 r2].
  exploit (move_complete te e r1 r2); auto. intros (changed1 & e1 & A & B).
  exploit (IHq e1 (changed || changed1)); auto. intros (e' & changed' & C & D).
  exists e'; exists changed'. rewrite A; simpl; rewrite C; auto.
Qed.

Lemma solve_constraints_complete:
  forall te e, satisf te e -> exists e', solve_constraints e = OK e' /\ satisf te e'.
Proof.
  intros te e. functional induction (solve_constraints e); intros.
- exists e; auto.
- exploit (solve_rec_complete te (te_equ e) {| te_typ := te_typ e; te_equ := nil |} false).
  destruct H; split; auto. simpl; tauto.
  destruct H; auto.
  intros (e1 & changed1 & P & Q).
  apply IHr. congruence.
- exploit (solve_rec_complete te (te_equ e) {| te_typ := te_typ e; te_equ := nil |} false).
  destruct H; split; auto. simpl; tauto.
  destruct H; auto.
  intros (e1 & changed1 & P & Q).
  congruence.
Qed.

Lemma solve_complete:
  forall te e, satisf te e -> exists te', solve e = OK te'.
Proof.
  intros. unfold solve.
  destruct (solve_constraints_complete te e H) as (e' & P & Q).
  econstructor. rewrite P. simpl. eauto.
Qed.

End UniSolver.


Welcome to Coq ciosx:/builds/workspace/coq-8.5pl3-macos,(detached from 2290dbb) (2290dbb9c95b63e693ced647731623e64297f5c8)

Coq < Section UseAuto002.

Coq < Require Import Arith Classical.
[Loading ML file z_syntax_plugin.cmxs ... done]
[Loading ML file quote_plugin.cmxs ... done]
[Loading ML file newring_plugin.cmxs ... done]
<W> Grammar extension: in [tactic:simple_tactic], some rule has been masked
<W> Grammar extension: in [tactic:simple_tactic], some rule has been masked
<W> Grammar extension: in [tactic:simple_tactic], some rule has been masked
<W> Grammar extension: in [tactic:simple_tactic], some rule has been masked
<W> Grammar extension: in [tactic:simple_tactic], some rule has been masked

Coq < Goal 2 + 3 = 5.
1 subgoal

  ============================
  2 + 3 = 5

Unnamed_thm < info_auto.
Debug: (* info auto : *)
Debug:  apply @eq_refl.
No more subgoals.

Unnamed_thm < Qed.
info_auto.

Qed.
Unnamed_thm is defined


(**************************************************************************)
(*  This file is part of CertrBPF,                                        *)
(*  a formally verified rBPF verifier + interpreter + JIT in Coq.         *)
(*                                                                        *)
(*  Copyright (C) 2022 Inria                                              *)
(*                                                                        *)
(*  This program is free software; you can redistribute it and/or modify  *)
(*  it under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation; either version 2 of the License, or     *)
(*  (at your option) any later version.                                   *)
(*                                                                        *)
(*  This program is distributed in the hope that it will be useful,       *)
(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         *)
(*  GNU General Public License for more details.                          *)
(*                                                                        *)
(**************************************************************************)

From Coq Require Import List ZArith.
Import ListNotations.

From compcert.cfrontend Require Csyntax Ctypes Cop.
From compcert.common Require Values.
From compcert.lib Require Import Integers.

Module MyList.

  Definition t := list int64.
  Definition index_s32 (l: t) (idx: int): int64 :=
    match List.nth_error l (Z.to_nat (Int.unsigned idx)) with
    | Some i => i
    | None => Integers.Int64.zero
    end.
  Definition index_nat (l: t) (idx: nat): int64 :=
    List.nth idx l Integers.Int64.zero.

End MyList.

(** length of MyList should be a extern variable? *)

Definition MyListType := MyList.t.
Definition MyListIndexs32 := MyList.index_s32.
Definition MyListIndexnat := MyList.index_nat.

Definition default_list: MyListType :=  [].


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2009-2018 Sylvie Boldo
#<br />#
Copyright (C) 2009-2018 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

(** * Fixed-point format *)
Require Import Raux Defs Round_pred Generic_fmt Ulp Round_NE.

Section RND_FIX.

Variable beta : radix.

Notation bpow := (bpow beta).

Variable emin : Z.

Inductive FIX_format (x : R) : Prop :=
  FIX_spec (f : float beta) :
    x = F2R f -> (Fexp f = emin)%Z -> FIX_format x.

Definition FIX_exp (e : Z) := emin.

(** Properties of the FIX format *)

Global Instance FIX_exp_valid : Valid_exp FIX_exp.
Proof.
intros k.
unfold FIX_exp.
split ; intros H.
now apply Zlt_le_weak.
split.
apply Z.le_refl.
now intros _ _.
Qed.

Theorem generic_format_FIX :
  forall x, FIX_format x -> generic_format beta FIX_exp x.
Proof.
intros x [[xm xe] Hx1 Hx2].
rewrite Hx1.
now apply generic_format_canonical.
Qed.

Theorem FIX_format_generic :
  forall x, generic_format beta FIX_exp x -> FIX_format x.
Proof.
intros x H.
rewrite H.
eexists ; repeat split.
Qed.

Theorem FIX_format_satisfies_any :
  satisfies_any FIX_format.
Proof.
refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FIX_exp)).
intros x.
split.
apply FIX_format_generic.
apply generic_format_FIX.
Qed.

Global Instance FIX_exp_monotone : Monotone_exp FIX_exp.
Proof.
intros ex ey H.
apply Z.le_refl.
Qed.

Theorem ulp_FIX :
  forall x, ulp beta FIX_exp x = bpow emin.
Proof.
intros x; unfold ulp.
case Req_bool_spec; intros Zx.
case (negligible_exp_spec FIX_exp).
intros T; specialize (T (emin-1)%Z); contradict T.
unfold FIX_exp; omega.
intros n _; reflexivity.
reflexivity.
Qed.

End RND_FIX.


(***
 * Oqarina
 * Copyright 2021 Carnegie Mellon University.
 *
 * NO WARRANTY. THIS CARNEGIE MELLON UNIVERSITY AND SOFTWARE ENGINEERING
 * INSTITUTE MATERIAL IS FURNISHED ON AN "AS-IS" BASIS. CARNEGIE MELLON
 * UNIVERSITY MAKES NO WARRANTIES OF ANY KIND, EITHER EXPRESSED OR
 * IMPLIED, AS TO ANY MATTER INCLUDING, BUT NOT LIMITED TO, WARRANTY OF
 * FITNESS FOR PURPOSE OR MERCHANTABILITY, EXCLUSIVITY, OR RESULTS
 * OBTAINED FROM USE OF THE MATERIAL. CARNEGIE MELLON UNIVERSITY DOES NOT
 * MAKE ANY WARRANTY OF ANY KIND WITH RESPECT TO FREEDOM FROM PATENT,
 * TRADEMARK, OR COPYRIGHT INFRINGEMENT.
 *
 * Released under a BSD (SEI)-style license, please see license.txt or
 * contact permission@sei.cmu.edu for full terms.
 *
 * [DISTRIBUTION STATEMENT A] This material has been approved for public
 * release and unlimited distribution.  Please see Copyright notice for
 * non-US Government use and distribution.
 *
 * This Software includes and/or makes use of the following Third-Party
 * Software subject to its own license:
 *
 * 1. Coq theorem prover (https://github.com/coq/coq/blob/master/LICENSE)
 * Copyright 2021 INRIA.
 *
 * 2. Coq JSON (https://github.com/liyishuai/coq-json/blob/comrade/LICENSE)
 * Copyright 2021 Yishuai Li.
 *
 * DM21-0762
***)

(*| .. coq:: none |*)

(** Coq Library *)
Require Import Coq.Bool.Bool.
Require Import Coq.Strings.String.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Import ListNotations.
Require Import Coq.Logic.Decidable.

(** Oqarina library *)
Require Import Oqarina.AADL.Kernel.categories.
Require Import Oqarina.core.identifiers.
Require Import Oqarina.coq_utils.utils.
(* end hide *)

#[local] Open Scope Z_scope.
#[local] Open Scope string_scope.
(*| .. coq:: |*)

(*|

Properties
==========

|*)

Definition INT := Z.
Definition REAL := Z.

(*+ Property Types *)

(* should we use this? *)
Inductive enumeration_literal :=
| EnumLiteral (name : identifier).

Definition enumeration_type :=
  list identifier.
(* !!! unique identifiers *)

Inductive unit_literal :=
| BaseUnit (name : identifier)
| DerivedUnit (name : identifier) (base: identifier) (factor: nat).

Definition units_type :=
  list unit_literal.
(* !!! unique identifiers, derived/base unit consistency, factor int or real *)

Inductive int_range_constraint :=
  IRC (min max : INT).

Inductive real_range_constraint :=
  RRC (rmin rmax : REAL).

Inductive range_constraint :=
| C_IntRange (irc : int_range_constraint)
| C_RealRange (rrc : real_range_constraint).

Inductive property_type :=
(* Predeclared types are constructors for performance *)
| aadlboolean | aadlstring | aadlinteger | aadlreal
| PT_Enumeration (literals : list identifier)
| PT_Units (units : units_type)
| PT_Number (p : property_type) (* must be aadlinteger or aadlreal *)
            (range: option range_constraint)
            (units: option property_type)
| PT_Range (p : property_type) (* must be numeric *)
| PT_Classifier (* TBD *)
| PT_Reference
| PT_Record (fields: list field_decl)
| PT_List (of: property_type) (* not allowed in named types in AADL2 (why???) *)
| PT_TypeRef (qname : ps_qname)
with field_decl :=
| FieldDecl (name: identifier) (type: property_type).

Lemma unit_literal_eq_dec : eq_dec unit_literal.
Proof.
  unfold eq_dec.
  decide equality ;
   apply identifier_eq_dec ||
   apply PeanoNat.Nat.eq_dec.
Qed.

Lemma units_type_eq_dec : eq_dec units_type.
Proof.
  unfold eq_dec.
  apply list_eq_dec.
  apply unit_literal_eq_dec.
Qed.

Lemma int_range_constraint_eq_dec (a b : int_range_constraint): {a=b}+{a<>b}.
Proof.
  decide equality;
  apply Z.eq_dec.
Qed.

Lemma real_range_constraint_eq_dec (a b : real_range_constraint): {a=b}+{a<>b}.
Proof.
  decide equality;
  apply Z.eq_dec.
Qed.

Lemma range_constraint_eq_dec (a b : range_constraint): {a=b}+{a<>b}.
Proof.
  decide equality.
  apply int_range_constraint_eq_dec.
  apply real_range_constraint_eq_dec.
Qed.

Local Hint Resolve units_type_eq_dec identifier_eq_dec range_constraint_eq_dec:core.

Lemma property_type_eq_dec (a b : property_type) : {a=b}+{a<>b}
  with field_decl_eq_dec (a b : field_decl): {a=b}+{a<>b}.
Proof.
  (* proof for property_type *)
  repeat decide equality.

  (* proof for field_decl_eq *)
  decide equality.
Qed.

(*! Examples *)

Check PT_TypeRef (PSQN "ps" "pt") : property_type.
Check aadlboolean : property_type.
Check PT_Units [BaseUnit (Id "m"); DerivedUnit (Id "cm") (Id "m") 100] : property_type.
Check PT_Number aadlinteger None None : property_type.
Check PT_Range aadlinteger : property_type.

Definition is_numeric_predef (p : property_type) : bool :=
  match p with
  | aadlinteger | aadlreal => true
  | _ => false
  end.

Inductive is_numeric_predefR : property_type -> Prop :=
| Predef_Int : is_numeric_predefR aadlinteger
| Predef_Real : is_numeric_predefR aadlstring.

Definition property_type_wf (t : property_type) : bool :=
  match t with
  | PT_Number p _ _ => is_numeric_predef p
  | PT_Range p => is_numeric_predef p
  (* !!! add more *)
  | _ => true
  end.

(*+ Property Expressions and Values *)

Inductive property_value :=
| PV_Bool (b : bool)
| PV_String (s : string)
| PV_Int (n : Z)
| PV_Real (r : REAL)
| PV_IntU (n : Z) (unit : property_value)
| PV_RealU (r : REAL) (unit : property_value)
| PV_Enum (i : identifier)
| PV_Unit (i : identifier)
| PV_IntRange (min max : property_value)
| PV_RealRange (min max : property_value)
| PV_IntRangeD (min max : property_value) (delta : property_value)
| PV_RealRangeD (min max : property_value) (delta : property_value)
| PV_PropertyRef (qname : ps_qname) (* ref to property or constant *)
| PV_Classifier (* TBD *)
| PV_ModelRef (path : list identifier)
| PV_Record (fields : list field_value)
| PV_List (elements: list property_value)
| PV_Computed (function : string)
with field_value :=
| FieldVal (name : identifier) (value : property_value).

Local Hint Resolve bool_dec string_dec Z.eq_dec ps_qname_eq_dec: core.

Lemma property_value_eq_dec (a b : property_value) : {a=b}+{a<>b}
with field_value_eq_dec (a b : field_value) : {a=b}+{a<>b}.
Proof.
  decide equality;
  apply list_eq_dec; auto || auto.

  decide equality.
Defined.

(*+ Property Sets *)

Inductive property_set_declaration :=
| PropertyTypeDecl (name : identifier) (type : property_type)
| PropertyConstantDecl (name : identifier) (type: property_type)
                       (value: property_value)
| PropertyDecl (name : identifier) (type: property_type)
               (default: option property_value)
               (appliesTo : list AppliesToCategory).

Notation "s ':type' t" := (PropertyTypeDecl (Id s) t) (at level 75).
Notation "s ':const' t '=>' v" := (PropertyConstantDecl (Id s) t v)
                                   (at level 75, t at next level).
Notation "s ':prop' t '=>' d 'applies' a" :=
  (PropertyDecl (Id s) t d a)
    (at level 75, t at next level, d at next level, a at next level ).

Definition Applicable_ComponentCategory (p : property_set_declaration) :=
  match p with
  | PropertyDecl _ _ _ lcat => lcat
  | _ => nil
  end.

(** Property Association *)

(** %\begin{definition}[Property association]
A property association binds a property value to a property type.
  \end{definition} %

*)

Record property_association := {
    P : ps_qname;
    PV : property_value }.

Lemma property_association_eq_dec (a b : property_association): {a=b}+{a<>b}.
Proof.
  decide equality.
  apply property_value_eq_dec.
Defined.

(** AADL Property set *)

Inductive property_set :=
| PropertySet (name : identifier) (declarations : list property_set_declaration).

Definition property_set_name (ps : property_set) :=
  match ps with
  | PropertySet name _ => name
  end .

Definition property_sets := list property_set.


(*
 * Copyright (c) 2017-present,
 * Programming Research Laboratory (ROPAS), Seoul National University, Korea
 * This software is distributed under the term of the BSD-3 clause license.
 *)
Set Implicit Arguments.

Require Import Morphisms.
Require Import vgtac.
Require Import Monad.
Require Import DLat DPow.

Module Type FOLDABLE (A : KEY).

Axiom t : Type.

Axiom empty : t.

Axiom mem : A.t -> t -> bool.

Axiom empty_1 : forall e, mem e empty = false.

Axiom add : A.t -> t -> t.

Axiom mem_add_1 : forall l1 l2 s (Hl : A.eq l1 l2), mem l1 (add l2 s) = true.

Axiom mem_add_2 :
  forall l1 l2 s (Hl : not (A.eq l1 l2)), mem l1 (add l2 s) = mem l1 s.

Axiom fold : forall T (f : A.t -> T -> T) (s : t) (init : T), T.

Axiom fold_1 :
  forall (T : Type) (P : T -> Prop) f e s (Hmem : mem e s = true)
     (He : forall (x : T), P (f e x))
     (Hf_mono : forall e' (x : T) (Hx : P x), P (f e' x))
     (Hf_eq : forall e1 e2 (He1 : A.eq e1 e2) (x : T) (He1 : P (f e1 x)),
         P (f e2 x))
     (x : T),
    P (fold f s x).

Axiom fold_3  :
  forall (T : Type) (P : T -> Prop) f s
     (Hf_mono : forall e x (He : mem e s = true) (Hx : P x), P (f e x))
     (x : T) (Hx : P x),
    P (fold f s x).

Axiom fold2_1 :
  forall T (P : T -> T -> Prop) (P_trans : forall x y z, P x y -> P y z -> P x z)
         f f' i
         (Hf_ext : forall e x, P x (f e x))
         (Hff' : forall e x1 x2 (Hi : P i x1) (Hx : P x1 x2),
                   P (f e x1) (f' e x2))
         s (x1 x2 : T) (Hi : P i x1) (Hx : P x1 x2),
    P (fold f s x1) (fold f' s x2).

End FOLDABLE.

Module SetMap (K1 : KEY) (A : FOLDABLE K1) (K2 : KEY) (B : FOLDABLE K2).

Definition map f s := A.fold (fun e acc => B.add (f e) acc) s B.empty.

Lemma map_1 :
  forall f s e (Hf: Proper (K1.eq ==> K2.eq) f) (Hmem : A.mem e s = true),
    B.mem (f e) (map f s) = true.
Proof.
i. unfold map. eapply A.fold_1.
- apply Hmem.
- i. apply B.mem_add_1. apply K2.eq_refl.
- i. elim (K2.eq_dec (f e) (f e')); i.
  + by apply B.mem_add_1.
  + rewrite B.mem_add_2; by auto.
- i. elim (K2.eq_dec (f e) (f e2)); i.
  + apply B.mem_add_1. by auto.
  + rewrite B.mem_add_2; [|by auto].
    rewrite B.mem_add_2 in He0; [by auto|].
    intro. elim b. apply K2.eq_trans with (f e1); [by auto|by apply Hf].
Qed.

Lemma map_diff :
  forall f s e (Hf : forall e', ~ K2.eq e (f e')), B.mem e (map f s) = false.
Proof.
i. unfold map. eapply A.fold_3; [|by apply B.empty_1].
i. rewrite B.mem_add_2; [by auto|].
intro Hinv. eapply Hf. by apply Hinv.
Qed.

End SetMap.

Module BigJoin (K : KEY) (A : FOLDABLE K) (B : LAT).

(* Set comprehension style 1

big_join { f e x | e \in s }

- Type of f is (Foldable.elt -> T.t -> T.t)
- T is a lattice module
*)

Definition big_join f s x :=
  A.fold (fun s acc => B.join acc (f s x)) s x.

Lemma big_join_1' :
  forall f e s x (Ha : A.mem e s = true)
         (Hf: Proper (K.eq ==> B.eq ==> B.eq) f),
    B.le (f e x) (A.fold (fun s acc => B.join acc (f s x)) s x).
Proof.
i. unfold big_join.
apply A.fold_1 with e.
- by apply Ha.
- i; by apply B.join_right.
- i; eapply B.le_trans; [by apply Hx|by apply B.join_left].
- i. eapply B.le_trans; [by apply He0|].
  apply B.join_le; [apply B.le_refl; by apply B.eq_refl|].
  apply B.le_refl. apply Hf; [by apply He1|by apply B.eq_refl].
Qed.

Lemma big_join_1 :
  forall f e s x (Ha : A.mem e s = true)
         (Hf: Proper (K.eq ==> B.eq ==> B.eq) f),
    B.le (f e x) (big_join f s x).
Proof. by apply big_join_1'. Qed.

Definition weak_big_join (f : K.t -> B.t -> B.t) s x := A.fold f s x.

Lemma weak_big_join_1' :
  forall f e s x (Ha : A.mem e s = true)
         (Hf_mono: Proper (K.eq ==> B.le ==> B.le) f)
         (Hf_ext: forall e x, B.le x (f e x)),
    B.le (f e x) (A.fold f s x).
Proof.
i. eapply B.le_trans; [apply big_join_1; [by apply Ha|]|].
- intros k1 k2 Hk v1 v2 Hv. apply B.le_antisym.
  + apply Hf_mono; by auto using B.le_refl.
  + apply Hf_mono; by auto using K.eq_sym, B.le_refl, B.eq_sym.
- unfold big_join. eapply A.fold2_1.
  + by apply B.le_trans.
  + i. by apply B.join_left.
  + i. apply B.join_lub.
    * eapply B.le_trans; [by apply Hx|].
      eapply B.le_trans; [by apply Hf_ext|].
      apply Hf_mono; [by apply K.eq_refl|apply B.le_refl; by apply B.eq_refl].
    * apply Hf_mono; [by apply K.eq_refl|].
      eapply B.le_trans; [by apply Hi|by apply Hx].
  + apply B.le_refl; by apply B.eq_refl.
  + apply B.le_refl; by apply B.eq_refl.
Qed.

Lemma weak_big_join_1 :
  forall f e s x (Ha : A.mem e s = true)
         (Hf_mono: Proper (K.eq ==> B.le ==> B.le) f)
         (Hf_ext: forall e x, B.le x (f e x)),
    B.le (f e x) (weak_big_join f s x).
Proof. by apply weak_big_join_1'. Qed.

End BigJoin.

Module BigJoinM (Import M : Monad) (K : KEY) (A : FOLDABLE K) (B : LAT).

(* Set comprehension style 1

big_join { f e x | e \in s }

- Type of f is (Foldable.elt -> T.t -> M.m T.t)
- T is a lattice module
*)

Definition big_join f s x :=
  let f' s acc :=
      do acc' <- acc;
      do v <- f s x;
      ret (B.join acc' v) in
  A.fold f' s (ret x).

Definition weak_big_join (f : K.t -> B.t -> m B.t) s x :=
  let f' s acc :=
      do acc' <- acc;
      f s acc' in
  A.fold f' s x.

Section Locs.

Lemma b_equiv : zb_equiv B.eq.
Proof.
constructor.
- intro. by apply B.eq_refl.
- intros x y. by apply B.eq_sym.
- intros x y z. by apply B.eq_trans.
Qed.

Definition eq_refl := zb_equiv_refl (eq_equiv b_equiv).

Definition eq_sym := zb_equiv_sym (eq_equiv b_equiv).

Definition eq_trans := zb_equiv_trans (eq_equiv b_equiv).

Lemma b_order : zb_order B.eq B.le.
Proof.
constructor.
- intro. by apply B.le_refl.
- intros x y. by apply B.le_antisym.
- intros x y z. by apply B.le_trans.
Qed.

Definition le_refl := zb_order_refl (le_order b_equiv b_order).

Definition le_antisym := zb_order_antisym (le_order b_equiv b_order).

Definition le_trans := zb_order_trans (le_order b_equiv b_order).

Lemma big_join_1' :
  forall f e s x (Ha : A.mem e s = true)
         (Hf : Proper (K.eq ==> B.le ==> le b_order) f),
    let f' s acc :=
        do acc' <- acc;
        do v <- f s x;
        ret (B.join acc' v) in
    le b_order (f e x) (A.fold f' s (ret x)).
Proof.
i. apply A.fold_1 with e.
- by apply Ha.
- unfold f'. i.
  apply le_1; i.
  apply le_2; i.
  apply ret_mono.
  apply B.join_right.
- i. eapply le_trans; [by apply Hx|].
  unfold f'.
  apply le_2; i.
  apply le_1; i.
  apply ret_mono.
  apply B.join_left.
- i. eapply le_trans; [by apply He0|].
  unfold f'.
  eapply bind_mono; [ apply le_refl; apply eq_refl |].
  intros v1 v2 Hv.
  eapply bind_mono
  ; [eapply Hf; [by apply He1|apply B.le_refl; by apply B.eq_refl]|].
  intros v1' v2' Hv'.
  apply ret_mono.
  apply B.join_lub.
  + eapply B.le_trans; [by apply Hv|by apply B.join_left].
  + eapply B.le_trans; [by apply Hv'|by apply B.join_right].
Qed.

Lemma big_join_1 :
  forall f e s x (Ha : A.mem e s = true)
         (Hf : Proper (K.eq ==> B.le ==> le b_order) f),
    le b_order (f e x) (big_join f s x).
Proof. by apply big_join_1'. Qed.

Lemma weak_big_join_1' :
  forall f e s x (Ha : A.mem e s = true)
         (Hf_mono : Proper (K.eq ==> B.le ==> le b_order) f)
         (Hf_ext : forall e x, le b_order (ret x) (f e x)),
    let f' s acc :=
        do acc' <- acc;
        f s acc' in
    le b_order (f e x) (A.fold f' s (ret x)).
Proof.
i. eapply le_trans; [apply big_join_1; [by apply Ha|by apply Hf_mono]|].
unfold big_join. eapply A.fold2_1.
- by apply le_trans.
- i. apply le_2; i.
  apply le_1; i.
  apply ret_mono.
  apply B.join_left.
- unfold f'. i. apply le_3.
  + apply le_trans with x2; [by auto|].
    apply le_2. by apply Hf_ext.
  + i. apply le_3.
    * eapply le_trans; [apply le_refl; by apply left_unit|].
      eapply bind_mono; [eapply le_trans; [by apply Hi|by apply Hx]|].
      apply Hf_mono. by apply K.eq_refl.
    * i. apply ret_join_lub; [by auto|by auto|by apply B.join_lub].
- apply le_refl; apply eq_refl.
- apply le_refl; apply eq_refl.
Qed.

Lemma weak_big_join_1 :
  forall f e s x (Ha : A.mem e s = true)
         (Hf_mono : Proper (K.eq ==> B.le ==> le b_order) f)
         (Hf_ext : forall e x, le b_order (ret x) (f e x)),
    le b_order (f e x) (weak_big_join f s (ret x)).
Proof. by apply weak_big_join_1'. Qed.

End Locs.

End BigJoinM.


Require Import Coq.omega.Omega.
Require Import Platform.Thread Platform.Arrays8 Platform.MoreArrays.

Local Hint Extern 1 (@eq W _ _) => words.

Module Type S.
  Variables globalSched globalSock : W.
End S.

Module Make(M : S).
Import M.

Module M'''.
  Definition globalSched := M.globalSched.

  Open Scope Sep_scope.

  Definition globalInv (fs : files) : HProp := Ex fr, globalSock =*> fr * [| fr %in fs |].
End M'''.

Ltac unf := unfold M'''.globalSched, M'''.globalInv in *.

Module T := Thread.Make(M''').

Import T M'''.
Export T M'''.

Definition hints : TacPackage.
  prepare (materialize_buffer, buffer_split_tagged) buffer_join_tagged.
Defined.

Ltac sep := T.sep unf hints.

Definition handlerS := SPEC reserving 49
  Al fs, PREmain[_] sched fs * globalInv fs * mallocHeap 0.

Definition mainS := SPEC reserving 49
  PREmain[_] globalSched =?> 1 * globalSock =?> 1 * mallocHeap 0.

Definition writeSomeS := SPEC("fr", "buf", "len") reserving 36
  Al fs, Al len,
  PRE[V] [| V "fr" %in fs |] * V "buf" =?>8 len * [| (wordToNat (V "len") <= len)%nat |]
    * sched fs * globalInv fs * mallocHeap 0
  POST[_] Ex fs', [| fs %<= fs' |] * V "buf" =?>8 len * sched fs' * globalInv fs' * mallocHeap 0.

Definition m := bimport [[ "malloc"!"malloc" @ [mallocS],
                           "scheduler"!"init" @ [initS], "scheduler"!"exit" @ [exitS],
                           "scheduler"!"spawn" @ [spawnS], "scheduler"!"listen" @ [listenS],
                           "scheduler"!"accept" @ [acceptS], "scheduler"!"read" @ [readS],
                           "scheduler"!"write" @ [writeS], "scheduler"!"close" @ [closeS] ]]
  bmodule "test" {{
    bfunction "writeSome"("fr", "buf", "len") [writeSomeS]
      Assert [Al fs, Al len,
        PRE[V] [| V "fr" %in fs |] * buffer_splitAt (wordToNat (V "len")) (V "buf") len
          * [| (wordToNat (V "len") <= len)%nat |] * sched fs * globalInv fs * mallocHeap 0
        POST[_] Ex fs', [| fs %<= fs' |] * buffer_joinAt (wordToNat (V "len")) (V "buf") len
          * sched fs' * globalInv fs' * mallocHeap 0];;

      Call "scheduler"!"write"("fr", "buf", "len")
      [PRE[_] Emp POST[_] Emp];;
      Return 0
    end with bfunctionNoRet "handler"("buf", "fr", "n") [handlerS]
      "buf" <-- Call "malloc"!"malloc"(0, 10)
      [Al fs, PREmain[_, R] R =?> 10 * sched fs * globalInv fs * mallocHeap 0];;

      Note [please_materialize_buffer 10];;

      [Al fs, PREmain[V] V "buf" =?>8 40 * sched fs * globalInv fs * mallocHeap 0]
      While (0 = 0) {
        "fr" <-- Call "scheduler"!"accept"($[globalSock])
        [Al fs, PREmain[V, R] [| R %in fs |] * V "buf" =?>8 40 * sched fs * globalInv fs * mallocHeap 0];;

        "n" <-- Call "scheduler"!"read"("fr", "buf", 40)
        [Al fs, PREmain[V] [| V "fr" %in fs |] * V "buf" =?>8 40 * sched fs * globalInv fs * mallocHeap 0];;

        [Al fs, PREmain[V] [| V "fr" %in fs |] * V "buf" =?>8 40 * sched fs * globalInv fs * mallocHeap 0]
        While ("n" <> 0) {
          If ("n" <= 40) {
            Call "test"!"writeSome"("fr", "buf", "n")
            [Al fs, PREmain[V] [| V "fr" %in fs |] * V "buf" =?>8 40 * sched fs * globalInv fs * mallocHeap 0]
          } else {
            Skip
          };;

          "n" <-- Call "scheduler"!"read"("fr", "buf", 40)
          [Al fs, PREmain[V] [| V "fr" %in fs |] * V "buf" =?>8 40 * sched fs * globalInv fs * mallocHeap 0]
        };;

        Call "scheduler"!"close"("fr")
        [Al fs, PREmain[V] V "buf" =?>8 40 * sched fs * globalInv fs * mallocHeap 0]
      }
    end with bfunctionNoRet "main"("fr", "x") [mainS]
      Init
      [Al fs, Al v, PREmain[_] sched fs * globalSock =*> v * mallocHeap 0];;

      "fr" <-- Call "scheduler"!"listen"(8080%N)
      [Al fs, Al v, PREmain[_, R] [| R %in fs |] * sched fs * globalSock =*> v * mallocHeap 0];;

      globalSock *<- "fr";;

      Spawn("test"!"handler", 50)
      [Al fs, PREmain[_] sched fs * globalInv fs * mallocHeap 0];;

      Spawn("test"!"handler", 50)
      [Al fs, PREmain[_] sched fs * globalInv fs * mallocHeap 0];;

      Exit 50
    end
  }}.

Opaque allocated.

Lemma single_cell : forall p,
  (p =?> 1 = (Ex v, p =*> v) * Emp)%Sep.
  auto.
Qed.

Lemma le_40 : forall w : W,
  w <= natToW 40
  -> (wordToNat w <= 40)%nat.
  intros; pre_nomega.
  rewrite wordToNat_natToWord_idempotent in * by reflexivity; omega.
Qed.

Hint Immediate le_40.

Ltac t' := try rewrite (single_cell globalSock); sep; auto.
Ltac t := solve [ t'
  | post; evaluate hints; descend; try match_locals; t' ].

Theorem ok : moduleOk m.
  vcgen; abstract t.
Qed.

End Make.


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
(* *********************************************************************)
(*                                                                     *)
(*              Object Primitives                                      *)
(*                                                                     *)
(*          Ronghui Gu <ronghui.gu@yale.edu>                           *)
(*                                                                     *)
(*          Yale Flint Group                                           *)
(*                                                                     *)
(* *********************************************************************)

Require Import Coqlib.
Require Import Maps.
Require Import AuxStateDataType.
Require Import FlatMemory.
Require Import AbstractDataType.
Require Import Integers.
Require Import Values.
Require Import Constant.

Section OBJ_VMM.

  (** primitve: set the value of n-th page table's i-th first level entry*)
  (** Since the page table is statically allocated, the contents of the first level page table can be calculated by their index*)
  (** primitve: returns the contents of the n-th page table with the fisrt level index i and second level index vadr *)
  Definition PDE_Arg (n i: Z) : bool :=
    if zle_lt 0 n num_proc then
      if zle_le 0 i (PDX Int.max_unsigned) then
        true
      else false
    else false.

  Function setPDEU_spec (n i pi: Z) (adt: RData): option RData :=
    match (ikern adt, ihost adt, init adt, ipt adt, PDE_Arg n i) with
      | (true, true, true, true, true) =>
        if zeq n (PT adt) then None
        else
          if zlt_lt 0 pi (nps adt) then
            match ZMap.get pi (pperm adt) with
              | PGAlloc  =>
                let pt':= ZMap.set i (PDEValid pi (ZMap.init PTEUndef)) (ZMap.get n (ptpool adt)) in
                Some adt {HP: FlatMem.free_page pi (HP adt)}
                     {pperm: ZMap.set pi (PGHide (PGPMap n i)) (pperm adt)}
                     {ptpool: ZMap.set n pt' (ptpool adt)}
              | _ => None
            end
          else None
      |_ => None
    end.

  Function rmvPDE_spec (n i: Z) (adt: RData): option RData :=
    match (ikern adt, ihost adt, init adt, ipt adt, PDE_Arg n i) with
      | (true, true, true, true, true) =>
        let pt':= ZMap.set i PDEUnPresent (ZMap.get n (ptpool adt)) in
        if (if (zeq n (PT adt)) then
              if (pg adt) then true
              else false
            else false) then None
        else
          match ZMap.get i (ZMap.get n (ptpool adt)) with
            | PDEValid pi _ =>
              match ZMap.get pi (pperm adt) with
                | PGHide (PGPMap _ _)  =>
                  Some adt {pperm: ZMap.set pi PGAlloc (pperm adt)}
                       {ptpool: ZMap.set n pt' (ptpool adt)}
                | _ => None
              end
            | _ => Some adt {ptpool: ZMap.set n pt' (ptpool adt)}
          end
      |_ => None
    end.

  Definition PTE_Arg (n i vadr: Z): bool :=
    if PDE_Arg n i then
      if zle_le 0 vadr (PTX Int.max_unsigned) then
        true
      else false
    else false.

  Function getPTE_spec (n i vadr: Z) (adt: RData) : option Z :=
    match (ikern adt, ihost adt, init adt, ipt adt, PTE_Arg n i vadr) with
      | (true, true, true, true, true) =>
        let pt:= ZMap.get n (ptpool adt) in
        match ZMap.get i pt with
          | PDEValid _ pdt =>
            match ZMap.get vadr pdt with
              | PTEValid padr p =>
                Some (padr * PgSize + PermtoZ p)
              | PTEUnPresent => Some 0
              | _ => None
            end
          | _ => None
        end
      | _ => None
    end.

  Function setPTE_spec (n i vadr padr perm: Z) (adt: RData) : option RData :=
    match (ikern adt, ihost adt, init adt, ipt adt, PTE_Arg n i vadr, ZtoPerm perm) with
      | (true, true, true, true, true, Some p) =>
        if zeq n (PT adt) then None
        else
          if zlt_lt 0 padr (nps adt) then
            let pt:= ZMap.get n (ptpool adt) in
            match ZMap.get i pt with
              | PDEValid pi pdt =>
                let pdt':= ZMap.set vadr (PTEValid padr p) pdt in
                let pt' := ZMap.set i (PDEValid pi pdt') pt in
                Some adt {ptpool: ZMap.set n pt' (ptpool adt)}
              | _ => None
            end
          else None
      | _ => None
    end.

End OBJ_VMM.


Require Import List.
Import ListNotations.

Require Export Meta.
Require Export Shared.

(*
======
Types
======
*)

Inductive ty : Type :=
  | TClass : class_id -> bool -> ty
  | TInterface : interface_id -> bool -> ty
  | TUnit : ty.

Definition nullable (t : ty) :=
  match t with
  | TClass c _ => TClass c true
  | TInterface i _ => TInterface i true
  | TUnit => TUnit
  end.

Hint Unfold nullable.

Inductive isNullable : ty -> Prop :=
  | Nullable_Class :
      forall c,
        isNullable (TClass c true)
  | Nullable_Interface :
      forall i,
        isNullable (TInterface i true)
  | Nullable_TUnit :
        isNullable TUnit.

Hint Constructors isNullable.
(*
============
Expressions
============
*)

Inductive val : Type :=
  | VNull : val
  | VLoc  : loc -> val.

Inductive var : Type :=
  | SV : svar -> var
  | DV : dvar -> var.

Inductive expr : Type :=
  | EVal : val -> expr
  | EVar : var -> expr
  | ENew : class_id -> expr
  | ECall : var -> method_id -> expr -> expr
  | ESelect : var -> field_id -> expr
  | EUpdate : var -> field_id -> expr -> expr
  | ELet : svar -> expr -> expr -> expr
  | ECast : ty -> expr -> expr
  | EPar : expr -> expr -> expr -> expr
  | ELock : var -> expr -> expr
  | ELocked : lock -> expr -> expr
.

Tactic Notation "expr_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "EVal"
  | Case_aux c "EVar"
  | Case_aux c "ENew"
  | Case_aux c "ECall"
  | Case_aux c "ESelect"
  | Case_aux c "EUpdate"
  | Case_aux c "ELet"
  | Case_aux c "ECast"
  | Case_aux c "EPar"
  | Case_aux c "ELock"
  | Case_aux c "ELocked"
].

Definition econtext := expr -> expr.

Definition ctx_call (x : _) (m : _) : econtext := (fun e => ECall x m e).
Hint Unfold ctx_call.
Definition ctx_update (x : _) (f : _) : econtext := (fun e => EUpdate x f e).
Hint Unfold ctx_update.
Definition ctx_let (x : _) (body : _) : econtext := (fun e => ELet x e body).
Hint Unfold ctx_let.
Definition ctx_cast (t : _) : econtext := (fun e => ECast t e).
Hint Unfold ctx_cast.
Definition ctx_locked (L : _) : econtext := (fun e => ELocked L e).
Hint Unfold ctx_locked.

Inductive is_econtext : econtext -> Prop :=
  | EC_Call :
      forall x m,
        is_econtext (ctx_call x m)
  | EC_Update :
      forall x f,
        is_econtext (ctx_update x f)
  | EC_Let :
      forall x body,
        is_econtext (ctx_let x body)
  | EC_Cast :
      forall t,
        is_econtext (ctx_cast t)
  | EC_Locked :
      forall L,
        is_econtext (ctx_locked L).

Definition isVal (e : expr) : Prop :=
  match e with
    | EVal _ => True
    | _ => False
  end.

Inductive exprStatic : expr -> Prop :=
  | StaticVar : forall x, exprStatic (EVar (SV x))
  | StaticNull : exprStatic (EVal VNull)
  | StaticNew : forall c, exprStatic (ENew c)
  | StaticCall : forall x m arg, exprStatic arg -> exprStatic (ECall (SV x) m arg)
  | StaticSelect : forall x f, exprStatic (ESelect (SV x) f)
  | StaticUpdate : forall x f e, exprStatic e -> exprStatic (EUpdate (SV x) f e)
  | StaticLet : forall x e body, exprStatic e -> exprStatic body -> exprStatic (ELet x e body)
  | StaticPar : forall e1 e2 e3, exprStatic e1 -> exprStatic e2 -> exprStatic e3 -> exprStatic (EPar e1 e2 e3)
  | StaticCast : forall t e, exprStatic e -> exprStatic (ECast t e)
  | StaticLock : forall x e, exprStatic e -> exprStatic (ELock (SV x) e)
.

Fixpoint freeVars (e : expr) : list svar :=
  match e with
    | EVar (SV x) => [x]
    | ECall (SV x) _ arg => x :: (freeVars arg)
    | ECall (DV _) _ arg => (freeVars arg)
    | ESelect (SV x) _ => [x]
    | EUpdate (SV x) _ rhs => x :: (freeVars rhs)
    | EUpdate (DV _) _ rhs => freeVars rhs
    | ELet x e body =>
      (freeVars e) ++
      (List.remove id_eq_dec x (freeVars body))
    | EPar e1 e2 e3 => (freeVars e1) ++ (freeVars e2) ++ (freeVars e3)
    | ECast t e => freeVars e
    | ELock (SV x) e => x :: (freeVars e)
    | ELock (DV _) e => freeVars e
    | ELocked _ e => freeVars e
    | _ => nil
  end.

Definition subst_var (x : svar) (y : dvar) (z : var) : var :=
  match z with
    | (SV z) => if id_eq_dec x z then DV y else SV z
    | (DV z) => (DV z)
  end.

Hint Unfold subst_var.

Fixpoint subst (x : svar) (y : dvar) (e : expr) : expr :=
  match e with
    | EVar z => EVar (subst_var x y z)
    | ELet z e' body =>
        ELet z (subst x y e')
             (if id_eq_dec x z then
                body
              else
                (subst x y body))
    | ECall z m arg =>
        ECall (subst_var x y z)
              m (subst x y arg)
    | ESelect z f => ESelect (subst_var x y z) f
    | EUpdate z f rhs =>
        EUpdate (subst_var x y z)
                f (subst x y rhs)
    | EPar e1 e2 e3 =>
        EPar (subst x y e1)
             (subst x y e2)
             (subst x y e3)
    | ECast t e =>
        ECast t (subst x y e)
    | ELock z e =>
        ELock (subst_var x y z) (subst x y e)
    | ELocked L e =>
        ELocked L (subst x y e)
    | _ => e
  end.

Fixpoint locks (e : expr) : list lock :=
  match e with
    | ECall _ _ arg => locks arg
    | EUpdate _ _ rhs => locks rhs
    | ELet _ e body => locks e ++ locks body
    | ECast _ e => locks e
    | EPar e1 e2 e3 => locks e1 ++ locks e2 ++ locks e3
    | ELock _ e => locks e
    | ELocked L e => L :: locks e
    | _ => nil
  end.

Definition no_locks (e : expr) : Prop :=
  locks e = nil.

(*
==============
Configuration
==============
*)

(*
------
Stack
------
*)

Definition dvar_map := partial_map dvar val.

(*
------
Locks
------
*)

Inductive lock_status : Type :=
  | LLocked : lock_status
  | LUnlocked : lock_status.

(*
-----
Heap
-----
*)

Definition dyn_fields := partial_map field_id val.

Definition object := (class_id * dyn_fields * lock_status)%type.

Definition heap := list object.

Definition heapExtend (H : heap) (obj : object) := snoc H obj.

Definition heapLookup (H : heap) (l : loc) :=
  nth_error H l.

Fixpoint heapUpdate (H : heap) (l : loc) (obj : object) :=
  match H with
  | nil => nil
  | obj' :: H' =>
    match l with
    | O    => obj :: H'
    | S l' => obj' :: (heapUpdate H' l' obj)
    end
  end.

(*
--------
Threads
--------
*)

Inductive threads :=
  | T_EXN    : list lock -> threads
  | T_Thread : list lock -> expr -> threads
  | T_Async  : threads -> threads -> expr -> threads.

Definition threads_done (thr : threads) :=
  match thr with
    | T_Thread _ (EVal _) => True
    | _ => False
  end.

Definition threads_exn (thr : threads) :=
  match thr with
    | T_EXN _ => True
    | _ => False
  end.

Fixpoint heldLocks (T : threads) :=
  match T with
    | T_EXN Ls => Ls
    | T_Thread Ls _ => Ls
    | T_Async T1 T2 _ => heldLocks T1 ++ heldLocks T2
  end.

Fixpoint leftmost_locks (T : threads) : list lock :=
  match T with
    | T_EXN Ls => Ls
    | T_Thread Ls _ => Ls
    | T_Async T1 _ _ => leftmost_locks T1
  end.

Fixpoint t_locks (T : threads) :=
  match T with
    | T_EXN _ => nil
    | T_Thread _ e => locks e
    | T_Async T1 T2 e => t_locks T1 ++ t_locks T2 ++ locks e
  end.

(*
--------------
Configuration
--------------
*)

Definition configuration := (heap * dvar_map * nat * threads)%type.

Definition cfg_done (cfg : configuration) : Prop :=
  match cfg with
    | (_, _, _, thr) => threads_done thr
  end.

Definition cfg_exn (cfg : configuration) : Prop :=
  match cfg with
    | (_, _, _, thr) => threads_exn thr
  end.

(*
========
Program
========
*)

Inductive fieldDecl : Type :=
  | Field : field_id -> ty -> fieldDecl.

Inductive methodDecl : Type :=
  | Method : method_id -> (svar * ty) -> ty -> expr -> methodDecl.

Inductive classDecl : Type :=
  | Cls : class_id -> interface_id -> list fieldDecl -> list methodDecl -> classDecl.

Inductive methodSig : Type :=
  | MethodSig : method_id -> (svar * ty) -> ty -> methodSig.

Inductive interfaceDecl : Type :=
  | Interface : interface_id -> list methodSig -> interfaceDecl
  | ExtInterface : interface_id -> interface_id -> interface_id -> interfaceDecl.

Definition program := (list classDecl * list interfaceDecl * expr)%type.

Definition classLookup(P : program)(c : class_id) : option classDecl :=
  match P with
    | (cs, _, _) =>
      let c_eq c cls := match cls with
                          | Cls c' _ _ _ => beq_nat c c'
                        end
      in
      find (c_eq c) cs
  end.

Definition interfaceLookup(P : program)(i : interface_id) : option interfaceDecl :=
  match P with
    | (_, ids, _) =>
      let i_eq i intr := match intr with
                          | Interface i' _ => beq_nat i i'
                          | ExtInterface i' _ _ => beq_nat i i'
                        end
      in
      find (i_eq i) ids
  end.

Definition fieldLookup(fs : list fieldDecl)(f : field_id) :=
  let f_eq f fld := match fld with
                     | Field f' _ => beq_nat f f'
                    end
  in
  find (f_eq f) fs.

Definition fields(P : program)(t : ty) :=
  match t with
    | TClass c _ => match classLookup P c with
                    | Some (Cls _ _ fs _) => Some fs
                    | None => None
                    end
    | _ => None
  end.

Definition methodLookup(ms : list methodDecl)(m : method_id) :=
  let m_eq m mtd := match mtd with
                      | Method m' _ _ _ => beq_nat m m'
                    end
  in
  find (m_eq m) ms.

Definition methods(P : program)(t : ty) :=
  match t with
    | TClass c _ => match classLookup P c with
                    | Some (Cls _ _ _ ms) => Some ms
                    | None => None
                    end
    | _ => None
  end.

Definition methodSigLookup(ms : list methodSig)(m : method_id) :=
  let m_eq m mtd := match mtd with
                      | MethodSig m' _ _ => beq_nat m m'
                    end
  in
  find (m_eq m) ms.

Definition extractSigs(ms : list methodDecl) :=
  let extract := fun mtd => match mtd with
                              | Method m param t e => MethodSig m param t
                            end
  in
  map extract ms.

Inductive methodSigs(P : program) : ty -> list methodSig -> Prop :=
  | MSigs_Class :
      forall c n i fs ms,
        classLookup P c = Some (Cls c i fs ms) ->
        methodSigs P (TClass c n) (extractSigs ms)
  | MSigs_Interface :
      forall i n msigs,
        interfaceLookup P i = Some (Interface i msigs) ->
        methodSigs P (TInterface i n) msigs
  | MSigs_ExtInterface :
      forall i i1 i2 n n1 n2 msigs1 msigs2,
        interfaceLookup P i = Some (ExtInterface i i1 i2) ->
        methodSigs P (TInterface i1 n1) msigs1 ->
        methodSigs P (TInterface i2 n2) msigs2 ->
        methodSigs P (TInterface i n) (msigs1 ++ msigs2)
  | MSigs_Unit :
      methodSigs P TUnit [].

Fixpoint declsToFields (l : list fieldDecl) :=
  match l with
    | nil => empty
    | fd :: fs =>
      match fd with
        | Field f _ =>
          extend (declsToFields fs) f VNull
      end
  end.