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


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Coq.extraction.Extraction.
Declare ML Module "recdef_plugin".


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


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import PSCIAux2.Spec.
Require Import AbsAccessor.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Definition psci_system_reset_spec0 (rec: Pointer) (adt: RData) : option RData :=
    match rec with
    | (_rec_base, _rec_ofst) =>
      when adt == system_off_reboot_spec (_rec_base, _rec_ofst) adt;
      when adt == set_psci_result_forward_psci_call_spec 1 adt;
      Some adt
     end
    .

End SpecLow.


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