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

(** Register allocation by external oracle and a posteriori validation. *)

Require Import FSets FSetAVLplus.
Require Import Coqlib Ordered Maps Errors Integers Floats.
Require Import AST Lattice Kildall Memdata.
Require Archi.
Require Import Op Registers RTL Locations Conventions RTLtyping LTL.

(** The validation algorithm used here is described in
  "Validating register allocation and spilling",
  by Silvain Rideau and Xavier Leroy,
  in Compiler Construction (CC 2010), LNCS 6011, Springer, 2010. *)

(** * Structural checks *)

(** As a first pass, we check the LTL code returned by the external oracle
  against the original RTL code for structural conformance.
  Each RTL instruction was transformed into a LTL basic block whose
  shape must agree with the RTL instruction.  For example, if the RTL
  instruction is [Istore(Mint32, addr, args, src, s)], the LTL basic block
  must be of the following shape:
- zero, one or several "move" instructions
- a store instruction [Lstore(Mint32, addr, args', src')]
- a [Lbranch s] instruction.

  The [block_shape] type below describes all possible cases of structural
  matching between an RTL instruction and an LTL basic block.
*)

Inductive move: Type :=
  | MV (src dst: loc)
  | MVmakelong (src1 src2 dst: mreg)
  | MVlowlong (src dst: mreg)
  | MVhighlong (src dst: mreg).

Definition moves := list move.

Inductive block_shape: Type :=
  | BSnop (mv: moves) (s: node)
  | BSmove (src: reg) (dst: reg) (mv: moves) (s: node)
  | BSmakelong (src1 src2: reg) (dst: reg) (mv: moves) (s: node)
  | BSlowlong (src: reg) (dst: reg) (mv: moves) (s: node)
  | BShighlong (src: reg) (dst: reg) (mv: moves) (s: node)
  | BSop (op: operation) (args: list reg) (res: reg)
         (mv1: moves) (args': list mreg) (res': mreg)
         (mv2: moves) (s: node)
  | BSopdead (op: operation) (args: list reg) (res: reg)
         (mv: moves) (s: node)
  | BSload (chunk: memory_chunk) (addr: addressing) (args: list reg) (dst: reg)
         (mv1: moves) (args': list mreg) (dst': mreg)
         (mv2: moves) (s: node)
  | BSloaddead (chunk: memory_chunk) (addr: addressing) (args: list reg) (dst: reg)
         (mv: moves) (s: node)
  | BSload2 (addr1 addr2: addressing) (args: list reg) (dst: reg)
         (mv1: moves) (args1': list mreg) (dst1': mreg)
         (mv2: moves) (args2': list mreg) (dst2': mreg)
         (mv3: moves) (s: node)
  | BSload2_1 (addr: addressing) (args: list reg) (dst: reg)
         (mv1: moves) (args': list mreg) (dst': mreg)
         (mv2: moves) (s: node)
  | BSload2_2 (addr addr': addressing) (args: list reg) (dst: reg)
         (mv1: moves) (args': list mreg) (dst': mreg)
         (mv2: moves) (s: node)
  | BSstore (chunk: memory_chunk) (addr: addressing) (args: list reg) (src: reg)
         (mv1: moves) (args': list mreg) (src': mreg)
         (s: node)
  | BSstore2 (addr1 addr2: addressing) (args: list reg) (src: reg)
         (mv1: moves) (args1': list mreg) (src1': mreg)
         (mv2: moves) (args2': list mreg) (src2': mreg)
         (s: node)
  | BScall (sg: signature) (ros: reg + ident) (args: list reg) (res: reg)
         (mv1: moves) (ros': mreg + ident) (mv2: moves) (s: node)
  | BStailcall (sg: signature) (ros: reg + ident) (args: list reg)
         (mv1: moves) (ros': mreg + ident)
  | BSbuiltin (ef: external_function)
         (args: list (builtin_arg reg)) (res: builtin_res reg)
         (mv1: moves) (args': list (builtin_arg loc)) (res': builtin_res mreg)
         (mv2: moves) (s: node)
  | BScond (cond: condition) (args: list reg)
         (mv: moves) (args': list mreg) (s1 s2: node)
  | BSjumptable (arg: reg)
         (mv: moves) (arg': mreg) (tbl: list node)
  | BSreturn (arg: option reg)
         (mv: moves).

(** Classify operations into moves, 64-bit split integer operations, and other
  arithmetic/logical operations. *)

Inductive operation_kind {A: Type}: operation -> list A -> Type :=
  | operation_Omove: forall arg, operation_kind Omove (arg :: nil)
  | operation_Omakelong: forall arg1 arg2, operation_kind Omakelong (arg1 :: arg2 :: nil)
  | operation_Olowlong: forall arg, operation_kind Olowlong (arg :: nil)
  | operation_Ohighlong: forall arg, operation_kind Ohighlong (arg :: nil)
  | operation_other: forall op args, operation_kind op args.

Definition classify_operation {A: Type} (op: operation) (args: list A) : operation_kind op args :=
  match op, args with
  | Omove, arg::nil => operation_Omove arg
  | Omakelong, arg1::arg2::nil => operation_Omakelong arg1 arg2
  | Olowlong, arg::nil => operation_Olowlong arg
  | Ohighlong, arg::nil => operation_Ohighlong arg
  | op, args => operation_other op args
  end.

(** Extract the move instructions at the beginning of block [b].
  Return the list of moves and the suffix of [b] after the moves.
  Two versions are provided: [extract_moves], which extracts only
  "true" moves, and [extract_moves_ext], which also extracts
  the [makelong], [lowlong] and [highlong] operations over 64-bit integers.
*)

Fixpoint extract_moves (accu: moves) (b: bblock) {struct b} : moves * bblock :=
  match b with
  | Lgetstack sl ofs ty dst :: b' =>
      extract_moves (MV (S sl ofs ty) (R dst) :: accu) b'
  | Lsetstack src sl ofs ty :: b' =>
      extract_moves (MV (R src) (S sl ofs ty) :: accu) b'
  | Lop op args res :: b' =>
      match is_move_operation op args with
      | Some arg =>
          extract_moves (MV (R arg) (R res) :: accu) b'
      | None =>
          (List.rev accu, b)
      end
  | _ =>
      (List.rev accu, b)
  end.

Fixpoint extract_moves_ext (accu: moves) (b: bblock) {struct b} : moves * bblock :=
  match b with
  | Lgetstack sl ofs ty dst :: b' =>
      extract_moves_ext (MV (S sl ofs ty) (R dst) :: accu) b'
  | Lsetstack src sl ofs ty :: b' =>
      extract_moves_ext (MV (R src) (S sl ofs ty) :: accu) b'
  | Lop op args res :: b' =>
      match classify_operation op args with
      | operation_Omove arg =>
          extract_moves_ext (MV (R arg) (R res) :: accu) b'
      | operation_Omakelong arg1 arg2 =>
          extract_moves_ext (MVmakelong arg1 arg2 res :: accu) b'
      | operation_Olowlong arg =>
          extract_moves_ext (MVlowlong arg res :: accu) b'
      | operation_Ohighlong arg =>
          extract_moves_ext (MVhighlong arg res :: accu) b'
      | operation_other _ _ =>
          (List.rev accu, b)
      end
  | _ =>
      (List.rev accu, b)
  end.

Definition check_succ (s: node) (b: LTL.bblock) : bool :=
  match b with
  | Lbranch s' :: _ => peq s s'
  | _ => false
  end.

Declare Scope option_monad_scope.

Notation "'do' X <- A ; B" := (match A with Some X => B | None => None end)
         (at level 200, X ident, A at level 100, B at level 200)
         : option_monad_scope.

Notation "'assertion' A ; B" := (if A then B else None)
         (at level 200, A at level 100, B at level 200)
         : option_monad_scope.

Local Open Scope option_monad_scope.

(** Check RTL instruction [i] against LTL basic block [b].
  On success, return [Some] with a [block_shape] describing the correspondence.
  On error, return [None]. *)

Definition pair_Iop_block (op: operation) (args: list reg) (res: reg) (s: node) (b: LTL.bblock) :=
  let (mv1, b1) := extract_moves nil b in
  match b1 with
  | Lop op' args' res' :: b2 =>
      let (mv2, b3) := extract_moves nil b2 in
      assertion (eq_operation op op');
      assertion (check_succ s b3);
      Some(BSop op args res mv1 args' res' mv2 s)
  | _ =>
      assertion (check_succ s b1);
      Some(BSopdead op args res mv1 s)
  end.

Definition pair_instr_block
               (i: RTL.instruction) (b: LTL.bblock) : option block_shape :=
  match i with
  | Inop s =>
      let (mv, b1) := extract_moves nil b in
      assertion (check_succ s b1); Some(BSnop mv s)
  | Iop op args res s =>
      match classify_operation op args with
      | operation_Omove arg =>
          let (mv, b1) := extract_moves nil b in
          assertion (check_succ s b1); Some(BSmove arg res mv s)
      | operation_Omakelong arg1 arg2 =>
          if Archi.splitlong then
           (let (mv, b1) := extract_moves nil b in
            assertion (check_succ s b1); Some(BSmakelong arg1 arg2 res mv s))
          else
            pair_Iop_block op args res s b
      | operation_Olowlong arg =>
          if Archi.splitlong then
           (let (mv, b1) := extract_moves nil b in
            assertion (check_succ s b1); Some(BSlowlong arg res mv s))
          else
            pair_Iop_block op args res s b
      | operation_Ohighlong arg =>
          if Archi.splitlong then
           (let (mv, b1) := extract_moves nil b in
            assertion (check_succ s b1); Some(BShighlong arg res mv s))
          else
            pair_Iop_block op args res s b
      | operation_other _ _ =>
          pair_Iop_block op args res s b
      end
  | Iload chunk addr args dst s =>
      let (mv1, b1) := extract_moves nil b in
      match b1 with
      | Lload chunk' addr' args' dst' :: b2 =>
          if chunk_eq chunk Mint64 && Archi.splitlong then
            assertion (chunk_eq chunk' Mint32);
            let (mv2, b3) := extract_moves nil b2 in
            match b3 with
            | Lload chunk'' addr'' args'' dst'' :: b4 =>
                let (mv3, b5) := extract_moves nil b4 in
                assertion (chunk_eq chunk'' Mint32);
                assertion (eq_addressing addr addr');
                assertion (option_eq eq_addressing (offset_addressing addr 4) (Some addr''));
                assertion (check_succ s b5);
                Some(BSload2 addr addr'' args dst mv1 args' dst' mv2 args'' dst'' mv3 s)
            | _ =>
                assertion (check_succ s b3);
                if (eq_addressing addr addr') then
                  Some(BSload2_1 addr args dst mv1 args' dst' mv2 s)
                else
                 (assertion (option_eq eq_addressing (offset_addressing addr 4) (Some addr'));
                  Some(BSload2_2 addr addr' args dst mv1 args' dst' mv2 s))
            end
          else (
            let (mv2, b3) := extract_moves nil b2 in
            assertion (chunk_eq chunk chunk');
            assertion (eq_addressing addr addr');
            assertion (check_succ s b3);
            Some(BSload chunk addr args dst mv1 args' dst' mv2 s))
      | _ =>
          assertion (check_succ s b1);
          Some(BSloaddead chunk addr args dst mv1 s)
      end
  | Istore chunk addr args src s =>
      let (mv1, b1) := extract_moves nil b in
      match b1 with
      | Lstore chunk' addr' args' src' :: b2 =>
          if chunk_eq chunk Mint64 && Archi.splitlong then
            let (mv2, b3) := extract_moves nil b2 in
            match b3 with
            | Lstore chunk'' addr'' args'' src'' :: b4 =>
                assertion (chunk_eq chunk' Mint32);
                assertion (chunk_eq chunk'' Mint32);
                assertion (eq_addressing addr addr');
                assertion (option_eq eq_addressing (offset_addressing addr 4) (Some addr''));
                assertion (check_succ s b4);
                Some(BSstore2 addr addr'' args src mv1 args' src' mv2 args'' src'' s)
            | _ => None
            end
          else (
            assertion (chunk_eq chunk chunk');
            assertion (eq_addressing addr addr');
            assertion (check_succ s b2);
            Some(BSstore chunk addr args src mv1 args' src' s))
      | _ => None
      end
  | Icall sg ros args res s =>
      let (mv1, b1) := extract_moves_ext nil b in
      match b1 with
      | Lcall sg' ros' :: b2 =>
          let (mv2, b3) := extract_moves_ext nil b2 in
          assertion (signature_eq sg sg');
          assertion (check_succ s b3);
          Some(BScall sg ros args res mv1 ros' mv2 s)
      | _ => None
      end
  | Itailcall sg ros args =>
      let (mv1, b1) := extract_moves_ext nil b in
      match b1 with
      | Ltailcall sg' ros' :: b2 =>
          assertion (signature_eq sg sg');
          Some(BStailcall sg ros args mv1 ros')
      | _ => None
      end
  | Ibuiltin ef args res s =>
      let (mv1, b1) := extract_moves nil b in
      match b1 with
      | Lbuiltin ef' args' res' :: b2 =>
          let (mv2, b3) := extract_moves nil b2 in
          assertion (external_function_eq ef ef');
          assertion (check_succ s b3);
          Some(BSbuiltin ef args res mv1 args' res' mv2 s)
      | _ => None
      end
  | Icond cond args s1 s2 =>
      let (mv1, b1) := extract_moves nil b in
      match b1 with
      | Lcond cond' args' s1' s2' :: b2 =>
          assertion (eq_condition cond cond');
          assertion (peq s1 s1');
          assertion (peq s2 s2');
          Some(BScond cond args mv1 args' s1 s2)
      | _ => None
      end
  | Ijumptable arg tbl =>
      let (mv1, b1) := extract_moves nil b in
      match b1 with
      | Ljumptable arg' tbl' :: b2 =>
          assertion (list_eq_dec peq tbl tbl');
          Some(BSjumptable arg mv1 arg' tbl)
      | _ => None
      end
  | Ireturn arg =>
      let (mv1, b1) := extract_moves_ext nil b in
      match b1 with
      | Lreturn :: b2 => Some(BSreturn arg mv1)
      | _ => None
      end
  end.

(** Check all instructions of the RTL function [f1] against the corresponding
  basic blocks of LTL function [f2].  Return a map from CFG nodes to
  [block_shape] info. *)

Definition pair_codes (f1: RTL.function) (f2: LTL.function) : PTree.t block_shape :=
  PTree.combine
    (fun opti optb => do i <- opti; do b <- optb; pair_instr_block i b)
    (RTL.fn_code f1) (LTL.fn_code f2).

(** Check the entry point code of the LTL function [f2].  It must be
  a sequence of moves that branches to the same node as the entry point
  of RTL function [f1]. *)

Definition pair_entrypoints (f1: RTL.function) (f2: LTL.function) : option moves :=
  do b <- (LTL.fn_code f2)!(LTL.fn_entrypoint f2);
  let (mv, b1) := extract_moves_ext nil b in
  assertion (check_succ (RTL.fn_entrypoint f1) b1);
  Some mv.

(** * Representing sets of equations between RTL registers and LTL locations. *)

(** The Rideau-Leroy validation algorithm manipulates sets of equations of
  the form [pseudoreg = location [kind]], meaning:
- if [kind = Full], the value of [location] in the generated LTL code is
  the same as (or more defined than) the value of [pseudoreg] in the original
  RTL code;
- if [kind = Low], the value of [location] in the generated LTL code is
  the same as (or more defined than) the low 32 bits of the 64-bit
  integer value of [pseudoreg] in the original RTL code;
- if [kind = High], the value of [location] in the generated LTL code is
  the same as (or more defined than) the high 32 bits of the 64-bit
  integer value of [pseudoreg] in the original RTL code.
*)

Inductive equation_kind : Type := Full | Low | High.

Record equation := Eq {
  ekind: equation_kind;
  ereg: reg;
  eloc: loc
}.

(** We use AVL finite sets to represent sets of equations.  Therefore, we need
  total orders over equations and their components. *)

Module IndexedEqKind <: INDEXED_TYPE.
  Definition t := equation_kind.
  Definition index (x: t) :=
    match x with Full => 1%positive | Low => 2%positive | High => 3%positive end.
  Lemma index_inj: forall x y, index x = index y -> x = y.
  Proof. destruct x; destruct y; simpl; congruence. Qed.
  Definition eq (x y: t) : {x=y} + {x<>y}.
  Proof. decide equality. Defined.
End IndexedEqKind.

Module OrderedEqKind := OrderedIndexed(IndexedEqKind).

(** This is an order over equations that is lexicographic on [ereg], then
  [eloc], then [ekind]. *)

Module OrderedEquation <: OrderedType.
  Definition t := equation.
  Definition eq (x y: t) := x = y.
  Definition lt (x y: t) :=
    Plt (ereg x) (ereg y) \/ (ereg x = ereg y /\
    (OrderedLoc.lt (eloc x) (eloc y) \/ (eloc x = eloc y /\
    OrderedEqKind.lt (ekind x) (ekind y)))).
  Lemma eq_refl : forall x : t, eq x x.
  Proof (@eq_refl t).
  Lemma eq_sym : forall x y : t, eq x y -> eq y x.
  Proof (@eq_sym t).
  Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
  Proof (@eq_trans t).
  Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
  Proof.
    unfold lt; intros.
    destruct H.
    destruct H0. left; eapply Plt_trans; eauto.
    destruct H0. rewrite <- H0. auto.
    destruct H. rewrite H.
    destruct H0. auto.
    destruct H0. right; split; auto.
    intuition.
    left; eapply OrderedLoc.lt_trans; eauto.
    left; congruence.
    left; congruence.
    right; split. congruence. eapply OrderedEqKind.lt_trans; eauto.
  Qed.
  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
  Proof.
    unfold lt, eq; intros; red; intros. subst y. intuition.
    eelim Plt_strict; eauto.
    eelim OrderedLoc.lt_not_eq; eauto. red; auto.
    eelim OrderedEqKind.lt_not_eq; eauto. red; auto.
  Qed.
  Definition compare : forall x y : t, Compare lt eq x y.
  Proof.
    intros.
    destruct (OrderedPositive.compare (ereg x) (ereg y)).
  - apply LT. red; auto.
  - destruct (OrderedLoc.compare (eloc x) (eloc y)).
    + apply LT. red; auto.
    + destruct (OrderedEqKind.compare (ekind x) (ekind y)).
      * apply LT. red; auto.
      * apply EQ. red in e; red in e0; red in e1; red.
        destruct x; destruct y; simpl in *; congruence.
      * apply GT. red; auto.
   + apply GT. red; auto.
  - apply GT. red; auto.
  Defined.
  Definition eq_dec (x y: t) : {x = y} + {x <> y}.
  Proof.
    intros. decide equality.
    apply Loc.eq.
    apply peq.
    apply IndexedEqKind.eq.
  Defined.
End OrderedEquation.

(** This is an alternate order over equations that is lexicgraphic on
  [eloc], then [ereg], then [ekind]. *)

Module OrderedEquation' <: OrderedType.
  Definition t := equation.
  Definition eq (x y: t) := x = y.
  Definition lt (x y: t) :=
    OrderedLoc.lt (eloc x) (eloc y) \/ (eloc x = eloc y /\
    (Plt (ereg x) (ereg y) \/ (ereg x = ereg y /\
    OrderedEqKind.lt (ekind x) (ekind y)))).
  Lemma eq_refl : forall x : t, eq x x.
  Proof (@eq_refl t).
  Lemma eq_sym : forall x y : t, eq x y -> eq y x.
  Proof (@eq_sym t).
  Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
  Proof (@eq_trans t).
  Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
  Proof.
    unfold lt; intros.
    destruct H.
    destruct H0. left; eapply OrderedLoc.lt_trans; eauto.
    destruct H0. rewrite <- H0. auto.
    destruct H. rewrite H.
    destruct H0. auto.
    destruct H0. right; split; auto.
    intuition.
    left; eapply Plt_trans; eauto.
    left; congruence.
    left; congruence.
    right; split. congruence. eapply OrderedEqKind.lt_trans; eauto.
  Qed.
  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
  Proof.
    unfold lt, eq; intros; red; intros. subst y. intuition.
    eelim OrderedLoc.lt_not_eq; eauto. red; auto.
    eelim Plt_strict; eauto.
    eelim OrderedEqKind.lt_not_eq; eauto. red; auto.
  Qed.
  Definition compare : forall x y : t, Compare lt eq x y.
  Proof.
    intros.
    destruct (OrderedLoc.compare (eloc x) (eloc y)).
  - apply LT. red; auto.
  - destruct (OrderedPositive.compare (ereg x) (ereg y)).
    + apply LT. red; auto.
    + destruct (OrderedEqKind.compare (ekind x) (ekind y)).
      * apply LT. red; auto.
      * apply EQ. red in e; red in e0; red in e1; red.
        destruct x; destruct y; simpl in *; congruence.
      * apply GT. red; auto.
   + apply GT. red; auto.
  - apply GT. red; auto.
  Defined.
  Definition eq_dec: forall (x y: t), {x = y} + {x <> y} := OrderedEquation.eq_dec.
End OrderedEquation'.

Module EqSet := FSetAVLplus.Make(OrderedEquation).
Module EqSet2 := FSetAVLplus.Make(OrderedEquation').

(** We use a redundant representation for sets of equations, comprising
  two AVL finite sets, containing the same elements, but ordered along
  the two orders defined above.  Playing on properties of lexicographic
  orders, this redundant representation enables us to quickly find
  all equations involving a given RTL pseudoregister, or all equations
  involving a given LTL location or overlapping location. *)

Record eqs := mkeqs {
  eqs1 :> EqSet.t;
  eqs2 : EqSet2.t;
  eqs_same: forall q, EqSet2.In q eqs2 <-> EqSet.In q eqs1
}.

(** * Operations on sets of equations *)

(** The empty set of equations. *)

Program Definition empty_eqs := mkeqs EqSet.empty EqSet2.empty _.
Next Obligation.
  split; intros. eelim EqSet2.empty_1; eauto. eelim EqSet.empty_1; eauto.
Qed.

(** Adding or removing an equation from a set. *)

Program Definition add_equation (q: equation) (e: eqs) :=
  mkeqs (EqSet.add q (eqs1 e)) (EqSet2.add q (eqs2 e)) _.
Next Obligation.
  split; intros.
  destruct (OrderedEquation'.eq_dec q q0).
  apply EqSet.add_1; auto.
  apply EqSet.add_2. apply (eqs_same e). apply EqSet2.add_3 with q; auto.
  destruct (OrderedEquation.eq_dec q q0).
  apply EqSet2.add_1; auto.
  apply EqSet2.add_2. apply (eqs_same e). apply EqSet.add_3 with q; auto.
Qed.

Program Definition remove_equation (q: equation) (e: eqs) :=
  mkeqs (EqSet.remove q (eqs1 e)) (EqSet2.remove q (eqs2 e)) _.
Next Obligation.
  split; intros.
  destruct (OrderedEquation'.eq_dec q q0).
  eelim EqSet2.remove_1; eauto.
  apply EqSet.remove_2; auto. apply (eqs_same e). apply EqSet2.remove_3 with q; auto.
  destruct (OrderedEquation.eq_dec q q0).
  eelim EqSet.remove_1; eauto.
  apply EqSet2.remove_2; auto. apply (eqs_same e). apply EqSet.remove_3 with q; auto.
Qed.

(** [reg_unconstrained r e] is true if [e] contains no equations involving
  the RTL pseudoregister [r].  In other words, all equations [r' = l [kind]]
  in [e] are such that [r' <> r]. *)

Definition select_reg_l (r: reg) (q: equation) := Pos.leb r (ereg q).
Definition select_reg_h (r: reg) (q: equation) := Pos.leb (ereg q) r.

Definition reg_unconstrained (r: reg) (e: eqs) : bool :=
  negb (EqSet.mem_between (select_reg_l r) (select_reg_h r) (eqs1 e)).

(** [loc_unconstrained l e] is true if [e] contains no equations involving
  the LTL location [l] or a location that partially overlaps with [l].
  In other words, all equations [r = l' [kind]] in [e] are such that
  [Loc.diff l' l]. *)

Definition select_loc_l (l: loc) :=
  let lb := OrderedLoc.diff_low_bound l in
  fun (q: equation) => match OrderedLoc.compare (eloc q) lb with LT _ => false | _ => true end.
Definition select_loc_h (l: loc) :=
  let lh := OrderedLoc.diff_high_bound l in
  fun (q: equation) => match OrderedLoc.compare (eloc q) lh with GT _ => false | _ => true end.

Definition loc_unconstrained (l: loc) (e: eqs) : bool :=
  negb (EqSet2.mem_between (select_loc_l l) (select_loc_h l) (eqs2 e)).

Definition reg_loc_unconstrained (r: reg) (l: loc) (e: eqs) : bool :=
  reg_unconstrained r e && loc_unconstrained l e.

(** [subst_reg r1 r2 e] simulates the effect of assigning [r2] to [r1] on [e].
  All equations of the form [r1 = l [kind]] are replaced by [r2 = l [kind]].
*)

Definition subst_reg (r1 r2: reg) (e: eqs) : eqs :=
  EqSet.fold
    (fun q e => add_equation (Eq (ekind q) r2 (eloc q)) (remove_equation q e))
    (EqSet.elements_between (select_reg_l r1) (select_reg_h r1) (eqs1 e))
    e.

(** [subst_reg_kind r1 k1 r2 k2 e] simulates the effect of assigning
  the [k2] part of [r2] to the [k1] part of [r1] on [e].
  All equations of the form [r1 = l [k1]] are replaced by [r2 = l [k2]].
*)

Definition subst_reg_kind (r1: reg) (k1: equation_kind) (r2: reg) (k2: equation_kind) (e: eqs) : eqs :=
  EqSet.fold
    (fun q e =>
      if IndexedEqKind.eq (ekind q) k1
      then add_equation (Eq k2 r2 (eloc q)) (remove_equation q e)
      else e)
    (EqSet.elements_between (select_reg_l r1) (select_reg_h r1) (eqs1 e))
    e.

(** [subst_loc l1 l2 e] simulates the effect of assigning [l2] to [l1] on [e].
  All equations of the form [r = l1 [kind]] are replaced by [r = l2 [kind]].
  Return [None] if [e] contains an equation of the form [r = l] with [l]
  partially overlapping [l1].
*)

Definition subst_loc (l1 l2: loc) (e: eqs) : option eqs :=
  EqSet2.fold
    (fun q opte =>
      match opte with
      | None => None
      | Some e =>
          if Loc.eq l1 (eloc q) then
            Some (add_equation (Eq (ekind q) (ereg q) l2) (remove_equation q e))
          else
            None
      end)
     (EqSet2.elements_between (select_loc_l l1) (select_loc_h l1) (eqs2 e))
     (Some e).

(** [subst_loc_part l1 l2 k e] simulates the effect of assigning
  [l2] to the [k] part of [l1] on [e].
  All equations of the form [r = l1 [k]] are replaced by [r = l2 [Full]].
  Return [None] if [e] contains an equation of the form [r = l] with [l]
  partially overlapping [l1], or an equation of the form [r = l1] with
  a kind different from [k1].
*)

Definition subst_loc_part (l1: loc) (l2: loc) (k: equation_kind) (e: eqs) : option eqs :=
  EqSet2.fold
    (fun q opte =>
      match opte with
      | None => None
      | Some e =>
          if Loc.eq l1 (eloc q) then
            if IndexedEqKind.eq (ekind q) k
            then Some (add_equation (Eq Full (ereg q) l2) (remove_equation q e))
            else None
          else
            None
      end)
     (EqSet2.elements_between (select_loc_l l1) (select_loc_h l1) (eqs2 e))
     (Some e).

(** [subst_loc_pair l1 l2 l2'] simulates the effect of assigning
  [makelong l2 l2'] to [l1].  All equations of the form [r = l1 [Full]]
  are replaced by the two equations [r = l2 [High], r = l2' [Low]].
  Return [None] if [e] contains an equation of the form [r = l] with [l]
  partially overlapping [l1], or an equation of the form [r = l1] with
  a kind different from [Full]. *)

Definition subst_loc_pair (l1 l2 l2': loc) (e: eqs) : option eqs :=
  EqSet2.fold
    (fun q opte =>
      match opte with
      | None => None
      | Some e =>
          if Loc.eq l1 (eloc q) then
            if IndexedEqKind.eq (ekind q) Full
            then Some (add_equation (Eq High (ereg q) l2)
                        (add_equation (Eq Low (ereg q) l2')
                           (remove_equation q e)))
            else None
          else
            None
      end)
     (EqSet2.elements_between (select_loc_l l1) (select_loc_h l1) (eqs2 e))
     (Some e).

(** [loc_type_compat env l e] checks that for all equations [r = l] in [e],
  the type [env r] of [r] is compatible with the type of [l]. *)

Definition sel_type (k: equation_kind) (ty: typ) : typ :=
  match k with
  | Full => ty
  | Low | High => Tint
  end.

Definition loc_type_compat (env: regenv) (l: loc) (e: eqs) : bool :=
  EqSet2.for_all_between
    (fun q => subtype (sel_type (ekind q) (env (ereg q))) (Loc.type l))
    (select_loc_l l) (select_loc_h l) (eqs2 e).

(** [long_type_compat env l e] checks that for all equations [r = l] in [e].
  then type [env r] of [r] is compatible with the type [Tlong]. *)

Definition long_type_compat (env: regenv) (l: loc) (e: eqs) : bool :=
  EqSet2.for_all_between
    (fun q => subtype (env (ereg q)) Tlong)
    (select_loc_l l) (select_loc_h l) (eqs2 e).

(** [add_equations [r1...rN] [m1...mN] e] adds to [e] the [N] equations
    [ri = R mi [Full]].  Return [None] if the two lists have different lengths.
*)

Fixpoint add_equations (rl: list reg) (ml: list mreg) (e: eqs) : option eqs :=
  match rl, ml with
  | nil, nil => Some e
  | r1 :: rl, m1 :: ml => add_equations rl ml (add_equation (Eq Full r1 (R m1)) e)
  | _, _ => None
  end.

(** [add_equations_args] is similar but additionally handles the splitting
  of pseudoregisters of type [Tlong] in two locations containing the
  two 32-bit halves of the 64-bit integer. *)

Function add_equations_args (rl: list reg) (tyl: list typ) (ll: list (rpair loc)) (e: eqs) : option eqs :=
  match rl, tyl, ll with
  | nil, nil, nil => Some e
  | r1 :: rl, ty :: tyl, One l1 :: ll =>
      add_equations_args rl tyl ll (add_equation (Eq Full r1 l1) e)
  | r1 :: rl, Tlong :: tyl, Twolong l1 l2 :: ll =>
      if Archi.ptr64 then None else
      add_equations_args rl tyl ll (add_equation (Eq Low r1 l2) (add_equation (Eq High r1 l1) e))
  | _, _, _ => None
  end.

(** [add_equations_res] is similar but is specialized to the case where
  there is only one pseudo-register. *)

Function add_equations_res (r: reg) (ty: typ) (p: rpair mreg) (e: eqs) : option eqs :=
  match p, ty with
  | One mr, _ =>
      Some (add_equation (Eq Full r (R mr)) e)
  | Twolong mr1 mr2, Tlong =>
      if Archi.ptr64 then None else
      Some (add_equation (Eq Low r (R mr2)) (add_equation (Eq High r (R mr1)) e))
  | _, _ =>
      None
  end.

(** [remove_equations_res] is similar to [add_equations_res] but removes
  equations instead of adding them. *)

Function remove_equations_res (r: reg) (p: rpair mreg) (e: eqs) : option eqs :=
  match p with
  | One mr =>
      Some (remove_equation (Eq Full r (R mr)) e)
  | Twolong mr1 mr2 =>
      if mreg_eq mr2 mr1
      then None
      else Some (remove_equation (Eq Low r (R mr2)) (remove_equation (Eq High r (R mr1)) e))
  end.

(** [add_equations_ros] adds an equation, if needed, between an optional
  pseudoregister and an optional machine register.  It is used for the
  function argument of the [Icall] and [Itailcall] instructions. *)

Definition add_equation_ros (ros: reg + ident) (ros': mreg + ident) (e: eqs) : option eqs :=
  match ros, ros' with
  | inl r, inl mr => Some(add_equation (Eq Full r (R mr)) e)
  | inr id, inr id' => assertion (ident_eq id id'); Some e
  | _, _ => None
  end.

(** [add_equations_builtin_arg] adds the needed equations for arguments
    to builtin functions. *)

Fixpoint add_equations_builtin_arg
     (env: regenv) (arg: builtin_arg reg) (arg': builtin_arg loc) (e: eqs) : option eqs :=
  match arg, arg' with
  | BA r, BA l =>
      Some (add_equation (Eq Full r l) e)
  | BA r, BA_splitlong (BA lhi) (BA llo) =>
      assertion (typ_eq (env r) Tlong);
      assertion (Archi.splitlong);
      Some (add_equation (Eq Low r llo) (add_equation (Eq High r lhi) e))
  | BA_int n, BA_int n' =>
      assertion (Int.eq_dec n n'); Some e
  | BA_long n, BA_long n' =>
      assertion (Int64.eq_dec n n'); Some e
  | BA_float f, BA_float f' =>
      assertion (Float.eq_dec f f'); Some e
  | BA_single f, BA_single f' =>
      assertion (Float32.eq_dec f f'); Some e
  | BA_loadstack chunk ofs, BA_loadstack chunk' ofs' =>
      assertion (chunk_eq chunk chunk');
      assertion (Ptrofs.eq_dec ofs ofs');
      Some e
  | BA_addrstack ofs, BA_addrstack ofs' =>
      assertion (Ptrofs.eq_dec ofs ofs');
      Some e
  | BA_loadglobal chunk id ofs, BA_loadglobal chunk' id' ofs' =>
      assertion (chunk_eq chunk chunk');
      assertion (ident_eq id id');
      assertion (Ptrofs.eq_dec ofs ofs');
      Some e
  | BA_addrglobal id ofs, BA_addrglobal id' ofs' =>
      assertion (ident_eq id id');
      assertion (Ptrofs.eq_dec ofs ofs');
      Some e
  | BA_splitlong hi lo, BA_splitlong hi' lo' =>
      do e1 <- add_equations_builtin_arg env hi hi' e;
      add_equations_builtin_arg env lo lo' e1
  | BA_addptr a1 a2, BA_addptr a1' a2' =>
      do e1 <- add_equations_builtin_arg env a1 a1' e;
      add_equations_builtin_arg env a2 a2' e1
  | _, _ =>
      None
  end.

Fixpoint add_equations_builtin_args
   (env: regenv) (args: list (builtin_arg reg))
   (args': list (builtin_arg loc)) (e: eqs) : option eqs :=
  match args, args' with
  | nil, nil => Some e
  | a1 :: al, a1' :: al' =>
      do e1 <- add_equations_builtin_arg env a1 a1' e;
      add_equations_builtin_args env al al' e1
  | _, _ => None
  end.

(** For [EF_debug] builtins, some arguments can be removed. *)

Fixpoint add_equations_debug_args
   (env: regenv) (args: list (builtin_arg reg))
   (args': list (builtin_arg loc)) (e: eqs) : option eqs :=
  match args, args' with
  | _, nil => Some e
  | a1 :: al, a1' :: al' =>
      match add_equations_builtin_arg env a1 a1' e with
      | None => add_equations_debug_args env al args' e
      | Some e1 => add_equations_debug_args env al al' e1
      end
  | _, _ => None
  end.

(** Checking of the result of a builtin *)

Definition remove_equations_builtin_res
    (env: regenv) (res: builtin_res reg) (res': builtin_res mreg) (e: eqs) : option eqs :=
  match res, res' with
  | BR r, BR r' => Some (remove_equation (Eq Full r (R r')) e)
  | BR r, BR_splitlong (BR rhi) (BR rlo) =>
      assertion (typ_eq (env r) Tlong);
      if mreg_eq rhi rlo then None else
        Some (remove_equation (Eq Low r (R rlo))
                (remove_equation (Eq High r (R rhi)) e))
  | BR_none, BR_none => Some e
  | _, _ => None
  end.

(** [can_undef ml] returns true if all machine registers in [ml] are
  unconstrained and can harmlessly be undefined. *)

Fixpoint can_undef (ml: list mreg) (e: eqs) : bool :=
  match ml with
  | nil => true
  | m1 :: ml => loc_unconstrained (R m1) e && can_undef ml e
  end.

Fixpoint can_undef_except (l: loc) (ml: list mreg) (e: eqs) : bool :=
  match ml with
  | nil => true
  | m1 :: ml =>
      (Loc.eq l (R m1) || loc_unconstrained (R m1) e) && can_undef_except l ml e
  end.

(** [no_caller_saves e] returns [e] if all caller-save locations are
  unconstrained in [e].  In other words, [e] contains no equations
  involving a caller-save register or [Outgoing] stack slot. *)

Definition no_caller_saves (e: eqs) : bool :=
  EqSet.for_all
   (fun eq =>
     match eloc eq with
       | R r => is_callee_save r
       | S Outgoing _ _ => false
       | S _ _ _ => true
       end)
    e.

(** [compat_left r l e] returns true if all equations in [e] that involve
    [r] are of the form [r = l [Full]]. *)

Definition compat_left (r: reg) (l: loc) (e: eqs) : bool :=
  EqSet.for_all_between
    (fun q =>
        match ekind q with
        | Full => Loc.eq l (eloc q)
        | _ => false
        end)
    (select_reg_l r) (select_reg_h r)
    (eqs1 e).

(** [compat_left2 r l1 l2 e] returns true if all equations in [e] that involve
    [r] are of the form [r = l1 [High]] or [r = l2 [Low]]. *)

Definition compat_left2 (r: reg) (l1 l2: loc) (e: eqs) : bool :=
  EqSet.for_all_between
    (fun q =>
        match ekind q with
        | High => Loc.eq l1 (eloc q)
        | Low => Loc.eq l2 (eloc q)
        | _ => false
        end)
    (select_reg_l r) (select_reg_h r)
    (eqs1 e).

(** [ros_compatible_tailcall ros] returns true if [ros] is a function
  name or a caller-save register.  This is used to check [Itailcall]
  instructions. *)

Definition ros_compatible_tailcall (ros: mreg + ident) : bool :=
  match ros with
  | inl r => negb (is_callee_save r)
  | inr id => true
  end.

(** * The validator *)

Definition destroyed_by_move (src dst: loc) :=
  match src, dst with
  | S sl ofs ty, _ => destroyed_by_getstack sl
  | _, S sl ofs ty => destroyed_by_setstack ty
  | _, _ => destroyed_by_op Omove
  end.

Definition well_typed_move (env: regenv) (dst: loc) (e: eqs) : bool :=
  match dst with
  | R r => true
  | S sl ofs ty => loc_type_compat env dst e
  end.

(** Simulate the effect of a sequence of moves [mv] on a set of
  equations [e].  The set [e] is the equations that must hold
  after the sequence of moves.  Return the set of equations that
  must hold before the sequence of moves.  Return [None] if the
  set of equations [e] cannot hold after the sequence of moves. *)

Fixpoint track_moves (env: regenv) (mv: moves) (e: eqs) : option eqs :=
  match mv with
  | nil => Some e
  | MV src dst :: mv =>
      do e1 <- track_moves env mv e;
      assertion (can_undef_except dst (destroyed_by_move src dst)) e1;
      assertion (well_typed_move env dst e1);
      subst_loc dst src e1
  | MVmakelong src1 src2 dst :: mv =>
      assertion (negb Archi.ptr64);
      do e1 <- track_moves env mv e;
      assertion (long_type_compat env (R dst) e1);
      subst_loc_pair (R dst) (R src1) (R src2) e1
  | MVlowlong src dst :: mv =>
      assertion (negb Archi.ptr64);
      do e1 <- track_moves env mv e;
      subst_loc_part (R dst) (R src) Low e1
  | MVhighlong src dst :: mv =>
      assertion (negb Archi.ptr64);
      do e1 <- track_moves env mv e;
      subst_loc_part (R dst) (R src) High e1
  end.

(** [transfer_use_def args res args' res' undefs e] returns the set
  of equations that must hold "before" in order for the equations [e]
  to hold "after" the execution of RTL and LTL code of the following form:
<<
                RTL                            LTL
         use pseudoregs args            use machine registers args'
         define pseudoreg res           undefine machine registers undef
                                        define machine register res'
>>
  As usual, [None] is returned if the equations [e] cannot hold after
  this execution.
*)

Definition transfer_use_def (args: list reg) (res: reg) (args': list mreg) (res': mreg)
                            (undefs: list mreg) (e: eqs) : option eqs :=
  let e1 := remove_equation (Eq Full res (R res')) e in
  assertion (reg_loc_unconstrained res (R res') e1);
  assertion (can_undef undefs e1);
  add_equations args args' e1.

Definition kind_first_word := if Archi.big_endian then High else Low.
Definition kind_second_word := if Archi.big_endian then Low else High.

(** The core transfer function.  It takes a set [e] of equations that must
  hold "after" and a block shape [shape] representing a matching pair
  of an RTL instruction and an LTL basic block.  It returns the set of
  equations that must hold "before" these instructions, or [None] if
  impossible. *)

Definition transfer_aux (f: RTL.function) (env: regenv)
                        (shape: block_shape) (e: eqs) : option eqs :=
  match shape with
  | BSnop mv s =>
      track_moves env mv e
  | BSmove src dst mv s =>
      track_moves env mv (subst_reg dst src e)
  | BSmakelong src1 src2 dst mv s =>
      let e1 := subst_reg_kind dst High src1 Full e in
      let e2 := subst_reg_kind dst Low src2 Full e1 in
      assertion (reg_unconstrained dst e2);
      track_moves env mv e2
  | BSlowlong src dst mv s =>
      let e1 := subst_reg_kind dst Full src Low e in
      assertion (reg_unconstrained dst e1);
      track_moves env mv e1
  | BShighlong src dst mv s =>
      let e1 := subst_reg_kind dst Full src High e in
      assertion (reg_unconstrained dst e1);
      track_moves env mv e1
  | BSop op args res mv1 args' res' mv2 s =>
      do e1 <- track_moves env mv2 e;
      do e2 <- transfer_use_def args res args' res' (destroyed_by_op op) e1;
      track_moves env mv1 e2
  | BSopdead op args res mv s =>
      assertion (reg_unconstrained res e);
      track_moves env mv e
  | BSload chunk addr args dst mv1 args' dst' mv2 s =>
      do e1 <- track_moves env mv2 e;
      do e2 <- transfer_use_def args dst args' dst' (destroyed_by_load chunk addr) e1;
      track_moves env mv1 e2
  | BSload2 addr addr' args dst mv1 args1' dst1' mv2 args2' dst2' mv3 s =>
      do e1 <- track_moves env mv3 e;
      let e2 := remove_equation (Eq kind_second_word dst (R dst2')) e1 in
      assertion (loc_unconstrained (R dst2') e2);
      assertion (can_undef (destroyed_by_load Mint32 addr') e2);
      do e3 <- add_equations args args2' e2;
      do e4 <- track_moves env mv2 e3;
      let e5 := remove_equation (Eq kind_first_word dst (R dst1')) e4 in
      assertion (loc_unconstrained (R dst1') e5);
      assertion (can_undef (destroyed_by_load Mint32 addr) e5);
      assertion (reg_unconstrained dst e5);
      do e6 <- add_equations args args1' e5;
      track_moves env mv1 e6
  | BSload2_1 addr args dst mv1 args' dst' mv2 s =>
      do e1 <- track_moves env mv2 e;
      let e2 := remove_equation (Eq kind_first_word dst (R dst')) e1 in
      assertion (reg_loc_unconstrained dst (R dst') e2);
      assertion (can_undef (destroyed_by_load Mint32 addr) e2);
      do e3 <- add_equations args args' e2;
      track_moves env mv1 e3
  | BSload2_2 addr addr' args dst mv1 args' dst' mv2 s =>
      do e1 <- track_moves env mv2 e;
      let e2 := remove_equation (Eq kind_second_word dst (R dst')) e1 in
      assertion (reg_loc_unconstrained dst (R dst') e2);
      assertion (can_undef (destroyed_by_load Mint32 addr') e2);
      do e3 <- add_equations args args' e2;
      track_moves env mv1 e3
  | BSloaddead chunk addr args dst mv s =>
      assertion (reg_unconstrained dst e);
      track_moves env mv e
  | BSstore chunk addr args src mv args' src' s =>
      assertion (can_undef (destroyed_by_store chunk addr) e);
      do e1 <- add_equations (src :: args) (src' :: args') e;
      track_moves env mv e1
  | BSstore2 addr addr' args src mv1 args1' src1' mv2 args2' src2' s =>
      assertion (can_undef (destroyed_by_store Mint32 addr') e);
      do e1 <- add_equations args args2'
                  (add_equation (Eq kind_second_word src (R src2')) e);
      do e2 <- track_moves env mv2 e1;
      assertion (can_undef (destroyed_by_store Mint32 addr) e2);
      do e3 <- add_equations args args1'
                  (add_equation (Eq kind_first_word src (R src1')) e2);
      track_moves env mv1 e3
  | BScall sg ros args res mv1 ros' mv2 s =>
      let args' := loc_arguments sg in
      let res' := loc_result sg in
      do e1 <- track_moves env mv2 e;
      do e2 <- remove_equations_res res res' e1;
      assertion (forallb (fun l => reg_loc_unconstrained res l e2)
                         (map R (regs_of_rpair res')));
      assertion (no_caller_saves e2);
      do e3 <- add_equation_ros ros ros' e2;
      do e4 <- add_equations_args args (sig_args sg) args' e3;
      track_moves env mv1 e4
  | BStailcall sg ros args mv1 ros' =>
      let args' := loc_arguments sg in
      assertion (tailcall_is_possible sg);
      assertion (rettype_eq sg.(sig_res) f.(RTL.fn_sig).(sig_res));
      assertion (ros_compatible_tailcall ros');
      do e1 <- add_equation_ros ros ros' empty_eqs;
      do e2 <- add_equations_args args (sig_args sg) args' e1;
      track_moves env mv1 e2
  | BSbuiltin ef args res mv1 args' res' mv2 s =>
      do e1 <- track_moves env mv2 e;
      do e2 <- remove_equations_builtin_res env res res' e1;
      assertion (forallb (fun r => reg_unconstrained r e2)
                         (params_of_builtin_res res));
      assertion (forallb (fun mr => loc_unconstrained (R mr) e2)
                         (params_of_builtin_res res'));
      assertion (can_undef (destroyed_by_builtin ef) e2);
      do e3 <-
        match ef with
        | EF_debug _ _ _ => add_equations_debug_args env args args' e2
        | _              => add_equations_builtin_args env args args' e2
        end;
      track_moves env mv1 e3
  | BScond cond args mv args' s1 s2 =>
      assertion (can_undef (destroyed_by_cond cond) e);
      do e1 <- add_equations args args' e;
      track_moves env mv e1
  | BSjumptable arg mv arg' tbl =>
      assertion (can_undef destroyed_by_jumptable e);
      track_moves env mv (add_equation (Eq Full arg (R arg')) e)
  | BSreturn None mv =>
      track_moves env mv empty_eqs
  | BSreturn (Some arg) mv =>
      let arg' := loc_result (RTL.fn_sig f) in
      do e1 <- add_equations_res arg (proj_sig_res (RTL.fn_sig f)) arg' empty_eqs;
      track_moves env mv e1
  end.

(** The main transfer function for the dataflow analysis.  Like [transfer_aux],
  it infers the equations that must hold "before" as a function of the
  equations that must hold "after".  It also handles error propagation
  and reporting. *)

Definition transfer (f: RTL.function) (env: regenv) (shapes: PTree.t block_shape)
                    (pc: node) (after: res eqs) : res eqs :=
  match after with
  | Error _ => after
  | OK e =>
      match shapes!pc with
      | None => Error(MSG "At PC " :: POS pc :: MSG ": unmatched block" :: nil)
      | Some shape =>
          match transfer_aux f env shape e with
          | None => Error(MSG "At PC " :: POS pc :: MSG ": invalid register allocation" :: nil)
          | Some e' => OK e'
          end
      end
  end.

(** The semilattice for dataflow analysis.  Operates on analysis results
  of type [res eqs], that is, either a set of equations or an error
  message.  Errors correspond to [Top].  Sets of equations are ordered
  by inclusion. *)

Module LEq <: SEMILATTICE.

  Definition t := res eqs.

  Definition eq (x y: t) :=
    match x, y with
    | OK a, OK b => EqSet.Equal a b
    | Error _, Error _ => True
    | _, _ => False
    end.

  Lemma eq_refl: forall x, eq x x.
  Proof.
    intros; destruct x; simpl; auto. red; tauto.
  Qed.

  Lemma eq_sym: forall x y, eq x y -> eq y x.
  Proof.
    unfold eq; intros; destruct x; destruct y; auto.
    red in H; red; intros. rewrite H; tauto.
  Qed.

  Lemma eq_trans: forall x y z, eq x y -> eq y z -> eq x z.
  Proof.
    unfold eq; intros. destruct x; destruct y; try contradiction; destruct z; auto.
    red in H; red in H0; red; intros. rewrite H. auto.
  Qed.

  Definition beq (x y: t) :=
    match x, y with
    | OK a, OK b => EqSet.equal a b
    | Error _, Error _ => true
    | _, _ => false
    end.

  Lemma beq_correct: forall x y, beq x y = true -> eq x y.
  Proof.
    unfold beq, eq; intros. destruct x; destruct y.
    apply EqSet.equal_2. auto.
    discriminate.
    discriminate.
    auto.
  Qed.

  Definition ge (x y: t) :=
    match x, y with
    | OK a, OK b => EqSet.Subset b a
    | Error _, _ => True
    | _, Error _ => False
    end.

  Lemma ge_refl: forall x y, eq x y -> ge x y.
  Proof.
    unfold eq, ge, EqSet.Equal, EqSet.Subset; intros.
    destruct x; destruct y; auto. intros; rewrite H; auto.
  Qed.
  Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z.
  Proof.
    unfold ge, EqSet.Subset; intros.
    destruct x; auto; destruct y; try contradiction.
    destruct z; eauto.
  Qed.

  Definition bot: t := OK empty_eqs.

  Lemma ge_bot: forall x, ge x bot.
  Proof.
    unfold ge, bot, EqSet.Subset; simpl; intros.
    destruct x; auto. intros. elim (EqSet.empty_1 H).
  Qed.

  Program Definition lub (x y: t) : t :=
    match x, y return _ with
    | OK a, OK b =>
        OK (mkeqs (EqSet.union (eqs1 a) (eqs1 b))
                  (EqSet2.union (eqs2 a) (eqs2 b)) _)
    | OK _, Error _ => y
    | Error _, _ => x
    end.
  Next Obligation.
    split; intros.
    apply EqSet2.union_1 in H. destruct H; rewrite eqs_same in H.
    apply EqSet.union_2; auto. apply EqSet.union_3; auto.
    apply EqSet.union_1 in H. destruct H; rewrite <- eqs_same in H.
    apply EqSet2.union_2; auto. apply EqSet2.union_3; auto.
  Qed.

  Lemma ge_lub_left: forall x y, ge (lub x y) x.
  Proof.
    unfold lub, ge, EqSet.Subset; intros.
    destruct x; destruct y; auto.
    intros; apply EqSet.union_2; auto.
  Qed.

  Lemma ge_lub_right: forall x y, ge (lub x y) y.
  Proof.
    unfold lub, ge, EqSet.Subset; intros.
    destruct x; destruct y; auto.
    intros; apply EqSet.union_3; auto.
  Qed.

End LEq.

(** The backward dataflow solver is an instantiation of Kildall's algorithm. *)

Module DS := Backward_Dataflow_Solver(LEq)(NodeSetBackward).

(** The control-flow graph that the solver operates on is the CFG of
  block shapes built by the structural check phase.  Here is its notion
  of successors. *)

Definition successors_block_shape (bsh: block_shape) : list node :=
  match bsh with
  | BSnop mv s => s :: nil
  | BSmove src dst mv s => s :: nil
  | BSmakelong src1 src2 dst mv s => s :: nil
  | BSlowlong src dst mv s => s :: nil
  | BShighlong src dst mv s => s :: nil
  | BSop op args res mv1 args' res' mv2 s => s :: nil
  | BSopdead op args res mv s => s :: nil
  | BSload chunk addr args dst mv1 args' dst' mv2 s => s :: nil
  | BSload2 addr addr' args dst mv1 args1' dst1' mv2 args2' dst2' mv3 s => s :: nil
  | BSload2_1 addr args dst mv1 args' dst' mv2 s => s :: nil
  | BSload2_2 addr addr' args dst mv1 args' dst' mv2 s => s :: nil
  | BSloaddead chunk addr args dst mv s => s :: nil
  | BSstore chunk addr args src mv1 args' src' s => s :: nil
  | BSstore2 addr addr' args src mv1 args1' src1' mv2 args2' src2' s => s :: nil
  | BScall sg ros args res mv1 ros' mv2 s => s :: nil
  | BStailcall sg ros args mv1 ros' => nil
  | BSbuiltin ef args res mv1 args' res' mv2 s => s :: nil
  | BScond cond args mv args' s1 s2 => s1 :: s2 :: nil
  | BSjumptable arg mv arg' tbl => tbl
  | BSreturn optarg mv => nil
  end.

Definition analyze (f: RTL.function) (env: regenv) (bsh: PTree.t block_shape) :=
  DS.fixpoint_allnodes bsh successors_block_shape (transfer f env bsh).

(** * Validating and translating functions and programs *)

(** Checking equations at function entry point.  The RTL function receives
  its arguments in the list [rparams] of pseudoregisters.  The LTL function
  receives them in the list [lparams] of locations dictated by the
  calling conventions, with arguments of type [Tlong] being split in
  two 32-bit halves.  We check that the equations [e] that must hold
  at the beginning of the functions are compatible with these calling
  conventions, in the sense that all equations involving a pseudoreg
  [r] from [rparams] is of the form [r = l [Full]] or [r = l [Low]]
  or [r = l [High]], where [l] is the corresponding element of [lparams].

  Note that [e] can contain additional equations [r' = l [kind]]
  involving pseudoregs [r'] not in [rparams]: these equations are
  automatically satisfied since the initial value of [r'] is [Vundef]. *)

Function compat_entry (rparams: list reg) (lparams: list (rpair loc)) (e: eqs)
                      {struct rparams} : bool :=
  match rparams, lparams with
  | nil, nil => true
  | r1 :: rl,  One l1 :: ll =>
      compat_left r1 l1 e && compat_entry rl ll e
  | r1 :: rl, Twolong l1 l2 :: ll =>
      compat_left2 r1 l1 l2 e && compat_entry rl ll e
  | _, _ => false
  end.

(** Checking the satisfiability of equations inferred at function entry
  point.  We also check that the RTL and LTL functions agree in signature
  and stack size. *)

Definition check_entrypoints_aux (rtl: RTL.function) (ltl: LTL.function)
                                 (env: regenv) (e1: eqs) : option unit :=
  do mv <- pair_entrypoints rtl ltl;
  do e2 <- track_moves env mv e1;
  assertion (compat_entry (RTL.fn_params rtl)
                          (loc_parameters (RTL.fn_sig rtl)) e2);
  assertion (can_undef destroyed_at_function_entry e2);
  assertion (zeq (RTL.fn_stacksize rtl) (LTL.fn_stacksize ltl));
  assertion (signature_eq (RTL.fn_sig rtl) (LTL.fn_sig ltl));
  Some tt.

Local Close Scope option_monad_scope.
Local Open Scope error_monad_scope.

Definition check_entrypoints (rtl: RTL.function) (ltl: LTL.function)
                             (env: regenv) (bsh: PTree.t block_shape)
                             (a: PMap.t LEq.t): res unit :=
  do e1 <- transfer rtl env bsh (RTL.fn_entrypoint rtl) a!!(RTL.fn_entrypoint rtl);
  match check_entrypoints_aux rtl ltl env e1 with
  | None => Error (msg "invalid register allocation at entry point")
  | Some _ => OK tt
  end.

(** Putting it all together, this is the validation function for
  a source RTL function and an LTL function generated by the external
  register allocator. *)

Definition check_function (rtl: RTL.function) (ltl: LTL.function) (env: regenv): res unit :=
  let bsh := pair_codes rtl ltl in
  match analyze rtl env bsh with
  | None => Error (msg "allocation analysis diverges")
  | Some a => check_entrypoints rtl ltl env bsh a
  end.

(** [regalloc] is the external register allocator.  It is written in OCaml
  in file [backend/Regalloc.ml]. *)

Parameter regalloc: RTL.function -> res LTL.function.

(** Register allocation followed by validation. *)

Definition transf_function (f: RTL.function) : res LTL.function :=
  match type_function f with
  | Error m => Error m
  | OK env =>
      match regalloc f with
      | Error m => Error m
      | OK tf => do x <- check_function f tf env; OK tf
      end
  end.

Definition transf_fundef (fd: RTL.fundef) : res LTL.fundef :=
  AST.transf_partial_fundef transf_function fd.

Definition transf_program (p: RTL.program) : res LTL.program :=
  transform_partial_program transf_fundef p.


Require Import Coq.Lists.List.
Import ListNotations.
Require Import Tactics.
Require Import Sequence.
Require Import Relation.
Require Import Syntax.
Require Import Subst.
Require Import SimpSub.
Require Import Promote.
Require Import Hygiene.
Require Import Rules.
Require Import DerivedRules.
Require Defs.
Require Import Obligations.
Require Import Morphism.
Require Import DefsEquiv.
Require Import Equivalence.
Require Import Dots.

Require Import ValidationUtil.
Require Import Dynamic.
Require MuIndExtract.

Lemma muForm_valid : muForm_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a ext1 ext0 Ha Hpos.
rewrite -> def_istp in Ha.
rewrite -> def_positive in Hpos.
rewrite -> def_istp.
unfold Defs.triv.
rewrite -> def_mu.
apply tr_mu_formation.
  {
  eapply tr_eqtype_eta2; eauto.
  }

  {
  eapply tr_positive_eta2; eauto.
  }

  {
  eapply tr_positive_eta2; eauto.
  }
Qed.

Lemma muEq_valid : muEq_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a b ext2 ext1 ext0 Ha Hposa Hposb.
rewrite -> def_eqtp in Ha.
rewrite -> def_positive in Hposa, Hposb.
rewrite -> def_eqtp.
unfold Defs.triv.
rewrite -> !def_mu.
apply tr_mu_formation.
  {
  eapply tr_eqtype_eta2; eauto.
  }

  {
  eapply tr_positive_eta2; eauto.
  }

  {
  eapply tr_positive_eta2; eauto.
  }
Qed.

Lemma muFormUniv_valid : muFormUniv_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a i ext2 ext1 ext0 Hi Ha Hpos.
rewrite -> def_of in Hi, Ha |- *.
rewrite -> def_positive in Hpos.
unfold Defs.triv.
rewrite -> !def_univ.
rewrite -> !def_univ in Ha.
unfold Defs.level in Hi.
rewrite -> def_mu.
apply tr_equal_intro.
apply tr_mu_formation_univ.
  {
  apply tr_equal_elim.
  eapply tr_equal_eta2; eauto.
  }

  {
  apply tr_equal_elim.
  eapply tr_equal_eta2; eauto.
  }

  {
  eapply tr_positive_eta2; eauto.
  }

  {
  eapply tr_positive_eta2; eauto.
  }
Qed.

Lemma muEqUniv_valid : muEqUniv_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a b i ext3 ext2 ext1 ext0 Hi Hab Hposa Hposb.
rewrite -> def_eq in Hab |- *.
rewrite -> def_of in Hi.
rewrite -> def_positive in Hposa, Hposb.
unfold Defs.triv.
rewrite -> !def_univ.
rewrite -> !def_univ in Hab.
unfold Defs.level in Hi.
rewrite -> !def_mu.
apply tr_equal_intro.
apply tr_mu_formation_univ.
  {
  apply tr_equal_elim.
  eapply tr_equal_eta2; eauto.
  }

  {
  apply tr_equal_elim.
  eapply tr_equal_eta2; eauto.
  }

  {
  eapply tr_positive_eta2; eauto.
  }

  {
  eapply tr_positive_eta2; eauto.
  }
Qed.

Lemma def_eeqtp :
  forall a b,
    equiv (app (app Defs.eeqtp a) b) (prod (subtype a b) (subtype b a)).
Proof.
intros a b.
unfold Defs.eeqtp.
apply steps_equiv.
eapply star_step.
  {
  apply step_app1.
  apply step_app2.
  }
simpsub.
eapply star_step.
  {
  apply step_app2.
  }
simpsub.
apply star_refl.
Qed.

Hint Rewrite def_eeqtp def_mu def_positive : prepare.

Lemma tr_prod_intro :
  forall G a b m m' n n',
    tr G (deq m m' a)
    -> tr G (deq n n' b)
    -> tr G (deq (ppair m n) (ppair m' n') (prod a b)).
Proof.
intros G a b m m' n n' Hm Hn.
apply (tr_eqtype_convert _#3 (sigma a (subst sh1 b))).
  {
  apply tr_eqtype_symmetry.
  apply tr_prod_sigma_equal.
    {
    eapply tr_inhabitation_formation; eauto.
    }

    {
    eapply tr_inhabitation_formation; eauto.
    }
  }
apply tr_sigma_intro; auto.
  {
  simpsub.
  auto.
  }

  {
  eapply (weakening _ [_] []).
    {
    cbn [length unlift].
    auto.
    }

    {
    cbn [length unlift].
    simpsub.
    auto.
    }
  cbn [length unlift].
  simpsub.
  cbn [List.app].
  eapply tr_inhabitation_formation; eauto.
  }
Qed.

Lemma muUnroll_valid : muUnroll_obligation.
Proof.
prepare.
intros G a ext1 ext0 Ha Hpos.
apply tr_prod_intro.
  {
  apply tr_mu_unroll; auto.
  eapply tr_positive_eta2; eauto.
  }

  {
  apply tr_mu_roll; auto.
  eapply tr_positive_eta2; eauto.
  }
Qed.

Lemma muUnrollUniv_valid : muUnrollUniv_obligation.
Proof.
prepare.
intros G a i ext2 ext1 ext0 Hlv Ha Hpos.
apply tr_prod_intro.
  {
  eapply tr_mu_unroll_univ; eauto.
  eapply tr_positive_eta2; eauto.
  }

  {
  eapply tr_mu_roll_univ; eauto.
  eapply tr_positive_eta2; eauto.
  }
Qed.

Lemma muInd_valid : muInd_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a b m ext2 ext1 n ext0 Hhide Ha Hpos Hb Hm.
unfold Defs.theta.
unfold Defs.triv.
rewrite -> def_istp in Ha.
rewrite -> def_of in Hm.
rewrite -> def_pi in Hb.
rewrite -> def_subtype in Hb.
rewrite -> def_mu in Hb, Hm.
rewrite -> def_positive in Hpos.
replace (subst (dot (var 1) (dot triv (dot (var 0) (dot triv (sh 2))))) n)
  with  (subst (dot (var 1) (dot triv (dot (var 0) (sh 2))))
           (subst (under 3 (dot triv id)) n)).
2:{
  simpsub.
  auto.
  }
eapply MuIndExtract.tr_mu_ind_extract.
  {
  eapply tr_eqtype_eta2; eauto.
  }

  {
  eapply tr_positive_eta2; eauto.
  }

  {
  simpsub.
  cbn [Nat.add].
  rewrite <- (subst_into_absent_single _ _ _ triv Hhide) in Hb.
  simpsubin Hb.
  cbn [Nat.add] in Hb.
  exact Hb.
  }

  {
  apply tr_equal_elim.
  eapply tr_equal_eta2; eauto.
  }
Qed.

Lemma muIndUniv_valid : muIndUniv_obligation.
Proof.
unfoldtop.
unfold Defs.dof.
intros G a b i m ext3 ext2 ext1 n ext0 Hhide Hi Ha Hpos Hb Hm.
unfold Defs.theta.
unfold Defs.triv.
unfold Defs.level in Hi.
rewrite -> !def_univ in Ha, Hb.
rewrite -> def_of in Hm, Ha, Hi, Hb.
rewrite -> def_pi in Hb.
rewrite -> def_subtype in Hb.
rewrite -> def_mu in Hb, Hm.
rewrite -> def_positive in Hpos.
rewrite -> def_prod in Hb.
replace (ppi1 (subst (dot (var 1) (dot triv (dot (var 0) (dot triv (sh 2))))) n))
  with  (subst (dot (var 1) (dot triv (dot (var 0) (sh 2))))
           (subst (under 3 (dot triv id)) (ppi1 n))).
2:{
  simpsub.
  auto.
  }
eapply (MuIndExtract.tr_mu_ind_univ_extract _ i a).
  {
  apply tr_equal_elim.
  eapply tr_equal_eta2; eauto.
  }

  {
  apply tr_equal_elim.
  eapply tr_equal_eta2; eauto.
  }

  {
  eapply tr_positive_eta2; eauto.
  }

  {
  simpsub.
  cbn [Nat.add].
  rewrite <- (subst_into_absent_single _ _ _ triv Hhide) in Hb.
  simpsubin Hb.
  cbn [Nat.add] in Hb.
  apply tr_equal_elim.
  apply (tr_equal_eta2 _#4 (ppi2 (subst (dot (var 0) (dot (var 1) (dot (var 2) (dot triv (sh 4))))) n)) (ppi2 (subst (dot (var 0) (dot (var 1) (dot (var 2) (dot triv (sh 4))))) n))).
  eapply tr_prod_elim2.
  exact Hb.
  }

  {
  simpsub.
  cbn [Nat.add].
  rewrite <- (subst_into_absent_single _ _ _ triv Hhide) in Hb.
  simpsubin Hb.
  cbn [Nat.add] in Hb.
  eapply tr_prod_elim1.
  exact Hb.
  }

  {
  apply tr_equal_elim.
  eapply tr_equal_eta2; eauto.
  }
Qed.


From Undecidability.FOL Require Import Syntax.Facts Syntax.Asimpl Deduction.FragmentNDFacts Deduction.FragmentNDConsistency Syntax.Theories Semantics.Tarski.FragmentFacts Semantics.Tarski.FragmentSoundness.
From Undecidability.Synthetic Require Import Definitions DecidabilityFacts MPFacts EnumerabilityFacts ListEnumerabilityFacts ReducibilityFacts.
From Undecidability Require Import Shared.ListAutomation Shared.Dec.
From Undecidability Require Import Shared.Libs.PSL.Vectors.Vectors Shared.Libs.PSL.Vectors.VectorForall.
Import ListAutomationNotations.
From Undecidability.FOL.Completeness Require Export TarskiConstructions EnumerationUtils.
(* ** Completeness *)

(* ** Standard Models **)

Section Completeness.
  Context {Σf : funcs_signature} {Σp : preds_signature}.
  Context {HdF : eq_dec Σf} {HdP : eq_dec Σp}.
  Variable eF : nat -> option Σf.
  Context {HeF : enumerator__T eF Σf}.
  Variable eP : nat -> option Σp.
  Context {HeP : enumerator__T eP Σp}.

  #[local] Hint Constructors bounded : core.

  Section BotModel.
    #[local] Existing Instance falsity_on | 0.
    Variable T : theory.
    Hypothesis T_closed : closed_T T.

    Definition input_bot : ConstructionInputs :=
      {|
        NBot := ⊥ ;
        NBot_closed := bounded_falsity 0;

        variant := falsity_on ;

        In_T := T ;
        In_T_closed := T_closed ;
        TarskiConstructions.enum := form_enum_with_default ⊥;
        TarskiConstructions.enum_enum := form_default_is_enum _;
        TarskiConstructions.enum_bounded := form_default_is_bounded (bounded_falsity _)
      |}.

    Definition output_bot := construct_construction input_bot.

    Instance model_bot : interp term :=
      {| i_func := func; i_atom := fun P v => atom P v ∈ Out_T output_bot|}.

    Lemma eval_ident rho (t : term) :
      eval rho t = subst_term rho t.
    Proof.
      induction t in rho|-*.
      - easy.
      - cbn. easy.
    Qed.
    Hypothesis Hcon : consistent class T.

    Lemma model_bot_correct phi rho :
      (phi[rho] ∈ Out_T output_bot <-> rho ⊨ phi).
    Proof.
      revert rho. induction phi using form_ind_falsity; intros rho. 1,2,3: cbn.
      - split; try tauto. intros H. apply Hcon.
        apply Out_T_econsistent with output_bot. exists [⊥].
        split; try apply Ctx. 2: now left. intros a [<-|[]]; easy.
      - erewrite (Vector.map_ext_in _ _ _ (eval rho)). 1:easy.
        easy.
      - destruct b0. rewrite <- IHphi1. rewrite <- IHphi2. apply Out_T_impl.
      - destruct q. cbn. setoid_rewrite <- IHphi. setoid_rewrite Out_T_all.
        split; intros H t; asimpl; specialize (H t); now asimpl in H.
    Qed.

    Lemma model_bot_classical :
      classical model_bot.
    Proof.
      intros rho phi psi. apply model_bot_correct, Out_T_prv.
      use_theory (nil : list form). apply Pc.
    Qed.

    Lemma valid_T_model_bot phi :
      phi ∈ T -> var ⊨ phi.
    Proof.
      intros H % (Out_T_sub output_bot). apply model_bot_correct. now rewrite subst_id.
    Qed.
  End BotModel.

  Section StandardCompleteness.
    Variables (T : @theory _ _ _ falsity_on) (phi : @form _ _ _ falsity_on).
    Hypothesis (HT : closed_T T) (Hphi : closed phi).

    Lemma semi_completeness_standard_classical_model :
      valid_theory_C (classical (ff:=falsity_on)) T phi -> ~ ~ T ⊢TC phi.
    Proof.
      intros Hval Hcons. rewrite refutation_prv in Hcons.
      assert (Hcl : closed_T (T ⋄ (¬ phi))) by (apply closed_T_extend; try econstructor; eauto).
      unshelve eapply (model_bot_correct (T_closed := Hcl) Hcons (¬ phi) var).
      - apply Out_T_sub. cbn. right. now asimpl.
      - apply Hval. 1: apply model_bot_classical, Hcons. intros ? ?. apply valid_T_model_bot; intuition.
    Qed.

    Lemma semi_completeness_standard :
      valid_theory T phi -> ~ ~ T ⊢TC phi.
    Proof.
      intros H. apply semi_completeness_standard_classical_model.
      intros D I rho _. apply (H D I rho).
    Qed.

    Definition stable P := ~~P -> P.

    Lemma completeness_standard_stability :
      stable (T ⊢TC phi) -> valid_theory T phi -> T ⊢TC phi.
    Proof.
      intros Hstab Hsem. now apply Hstab, semi_completeness_standard.
    Qed.

    Lemma completeness_classical_stability :
      stable (T ⊢TC phi) -> valid_theory_C (classical (ff := falsity_on)) T phi -> T ⊢TC phi.
    Proof.
      intros Hstab Hsem. now apply Hstab, semi_completeness_standard_classical_model.
    Qed.

    Lemma completeness_standard_stability' :
      (valid_theory_C (classical (ff := falsity_on)) T phi -> T ⊢TC phi) -> stable (T ⊢TC phi).
    Proof.
      intros Hcomp Hdn. apply Hcomp.
      intros D I rho Hclass Hsat. unfold classical in Hclass. cbn in Hclass.
      eapply (Hclass _ _ ⊥). intros Hsat2. exfalso. apply Hdn. intros [A [HA Hc]]. apply Hsat2.
      eapply sound_for_classical_model.
      - easy.
      - exact Hc.
      - intros a Ha. apply Hsat. apply HA, Ha.
    Qed.
  End StandardCompleteness.

  Section ExplodingCompletenessConstr.
    Variables (T : @theory _ _ _ falsity_on).
    Hypothesis (HT : closed_T T).

    Definition expl_interp := (model_bot HT).
    Existing Instance expl_interp.

    Lemma model_expl_correct phi rho :
      (phi[rho] ∈ Out_T (output_bot HT) <-> sat_bot (falsity ∈ Out_T (output_bot HT)) rho phi).
    Proof.
      revert rho. induction phi using form_ind_falsity; intros rho. 1,2,3: cbn.
      - easy.
      - erewrite (Vector.map_ext_in _ _ _ (eval rho)). 1:easy.
        easy.
      - destruct b0. unfold sat_bot in *. rewrite <- IHphi1. rewrite <- IHphi2. apply Out_T_impl.
      - destruct q. cbn. unfold sat_bot in *. setoid_rewrite <- IHphi. setoid_rewrite Out_T_all.
        split; intros H t; asimpl; specialize (H t); now asimpl in H.
    Qed.

    Lemma model_bot_exploding :
      FragmentFacts.exploding (model_bot HT) (falsity ∈ Out_T (output_bot HT)).
    Proof.
      intros rho phi. cbn. intros H. apply model_expl_correct.
      apply (Out_T_impl (output_bot HT) ⊥ (phi[rho])). 2: easy.
      apply Out_T_prv. exists []. split.
      - intros ? [].
      - apply II. apply FragmentND.Exp. apply Ctx. now left.
    Qed.

    Lemma valid_T_model_exploding phi :
      phi ∈ T -> sat_bot (falsity ∈ Out_T (output_bot HT)) var phi.
    Proof.
      intros H % (Out_T_sub (output_bot HT)). apply model_expl_correct. now rewrite subst_id.
    Qed.
  End ExplodingCompletenessConstr.
  Section ExplodingCompleteness.

    #[local] Existing Instance falsity_on | 0.
    Lemma semi_completeness_exploding T phi :
      closed_T T -> closed phi -> valid_exploding_theory T phi -> T ⊢TC phi.
    Proof.
      intros HT Hphi Hval.
      assert (Hcl : closed_T (T ⋄ (¬ phi))).
      1: { intros ? ?; subst; eauto. destruct H as [Hl| ->].
           + apply HT, Hl.
           + repeat econstructor. apply Hphi. }
      apply refutation_prv.
      apply (@Out_T_econsistent _ _ _ (output_bot Hcl)).
      use_theory [⊥]. 2: { apply Ctx. now left. }
      intros ? [<-|[]].
      specialize (Hval term (model_bot Hcl) (falsity ∈ Out_T (output_bot Hcl)) var (@model_bot_exploding _ Hcl)).
      rewrite <- (@subst_id _ _ _ _ ⊥ var). 2: easy.
      apply (@model_expl_correct _ Hcl (¬ phi) var).
      - apply Out_T_sub. cbn. rewrite subst_id. 2:easy. now right.
      - apply Hval. intros psi Hpsi. apply model_expl_correct. rewrite subst_id; [|easy].
        apply Out_T_sub. left. apply Hpsi.
    Qed.

  End ExplodingCompleteness.

  Section FragmentCompleteness.
    #[local] Existing Instance falsity_off | 0.
  End FragmentCompleteness.

  Section MPStrongCompleteness.
    Hypothesis mp : MP.
    Variables (T : @theory _ _ _ falsity_on) (phi : @form _ _ _ falsity_on).
    Hypothesis (HT : closed_T T) (Hphi : closed phi).
    Hypothesis (He : list_enumerable T).

    Lemma mp_tprv_stability :
      ~ ~ T ⊢TC phi -> T ⊢TC phi.
    Proof.
      apply (MP_stable_enumerable mp). 2: apply dec_form; eauto.
      apply list_enumerable_enumerable. destruct He as [L HL]. eexists. apply enum_tprv. apply HL.
    Qed.

    Lemma mp_standard_completeness :
      valid_theory T phi -> T ⊢TC phi.
    Proof.
      apply completeness_standard_stability; eauto. unfold stable.
      apply mp_tprv_stability.
    Qed.
  End MPStrongCompleteness.

(* *** Minimal Models **)

  Section FragmentModel.
    #[local] Existing Instance falsity_off | 0.
    Variable T : theory.
    Hypothesis T_closed : closed_T T.

    Variable GBot : form.
    Hypothesis GBot_closed : closed GBot.

    Definition input_fragment :=
      {|
        NBot := GBot ;
        NBot_closed := GBot_closed ;

        variant := falsity_off ;

        In_T := T ;
        In_T_closed := T_closed ;

        TarskiConstructions.enum := form_enum_with_default GBot;
        TarskiConstructions.enum_enum := form_default_is_enum _;
        TarskiConstructions.enum_bounded := form_default_is_bounded (GBot_closed)
      |}.

    Definition output_fragment := construct_construction input_fragment.

    Instance model_fragment : interp term :=
      {| i_func := func; i_atom := fun P v => atom P v ∈ Out_T output_fragment|}.

    Lemma model_fragment_correct phi rho :
      (phi[rho] ∈ Out_T output_fragment <-> rho ⊨ phi).
    Proof.
      revert rho. unfold model_fragment, output_fragment, input_fragment in *; cbn in *.
      remember falsity_off as ff eqn:Hff.
      induction phi; intros rho. 1,2,3: cbn.
      - split; try tauto. discriminate Hff.
      - erewrite (Vector.map_ext_in _ _ _ (eval rho)). 1:easy.
        easy.
      - destruct b0. rewrite <- IHphi1. rewrite <- IHphi2. apply Out_T_impl. 1-2:congruence.
      - destruct q. cbn. setoid_rewrite <- IHphi. setoid_rewrite Out_T_all. 2:congruence.
        split; intros H t; asimpl; specialize (H t); now asimpl in H.
    Qed.

    Lemma model_fragment_classical :
      classical model_fragment.
    Proof.
      intros rho phi psi. apply model_fragment_correct, Out_T_prv.
      use_theory (nil : list form). apply Pc.
    Qed.

    Lemma valid_T_fragment phi :
      phi ∈ T -> var ⊨ phi.
    Proof.
      intros H % (Out_T_sub output_fragment). apply model_fragment_correct. rewrite subst_id. 1:easy. easy.
    Qed.
  End FragmentModel.

  Section FragmentCompleteness.
    #[local] Existing Instance falsity_off | 0.
    Lemma semi_completeness_fragment T phi :
      closed_T T -> closed phi -> valid_theory T phi -> T ⊢TC phi.
    Proof.
      intros HT Hphi Hval.
      apply (@Out_T_econsistent _ _ _ (@output_fragment T HT phi Hphi)).
      use_theory [phi[var]]. 2: apply Ctx; left; now rewrite subst_id.
      intros ? [<- | []].
      apply (@model_fragment_correct T HT phi Hphi phi var).
      apply Hval. intros psi Hpsi.
      apply valid_T_fragment, Hpsi.
    Qed.
  End FragmentCompleteness.

  Section LEM_Equivalence.
    Definition completeness_arbitrary :=
      forall (T : @theory _ _ _ falsity_on) (phi : @form _ _ _ falsity_on),
             closed_T T -> closed phi ->
             valid_theory_C (classical (ff := falsity_on)) T phi -> T ⊢TC phi.
    Definition LEM := forall (P:Prop), P \/ ~ P.

    Lemma bot_valid_stable (T : @theory _ _ _ falsity_on) : closed_T T -> stable (valid_theory_C (classical (ff := falsity_on)) T ⊥).
    Proof.
      intros Hclosed HH D I rho Hclass H.
      apply HH. intros Hc. apply (Hc D I rho Hclass H).
    Qed.
    Lemma bot_deriv_stable (T : @theory _ _ _ falsity_on) : completeness_arbitrary -> closed_T T -> stable (@tprv _ _ _ class T ⊥).
    Proof.
      intros Hcomp Hclosed Hc. apply (Hcomp T ⊥). 1: eauto. 1: econstructor.
      apply bot_valid_stable. 1:easy. intros Hd. apply Hc. intros [L [HT HL]]. apply Hd.
      intros D I rho Hclass Harg.
      eapply sound_for_classical_model; try easy. 1: exact HL.
      intros l Hl. apply Harg. now apply HT.
    Qed.
    Existing Instance falsity_on.
    Lemma arbitrary_completeness_is_LEM : completeness_arbitrary -> LEM.
    Proof.
      intros HC P.
      pose (fun x : form => closed x /\ (P \/ ~P)) as T.
      assert (closed_T T) as Hclosed by (intros k; cbv; tauto).
      pose proof (@bot_deriv_stable T HC Hclosed).
      enough (T ⊢TC ⊥) as [[|lx lr] [HL HL']].
      - exfalso. eapply consistent_ND. apply HL'.
      - eapply HL. now left.
      - enough (~~ (P \/ ~P)).
        + apply H. intros Hc. apply H0. intros Hc2. apply Hc. exists [⊥]. split; try (apply Ctx; now left).
          intros ? [<- | []]. cbv. split; try apply Hc2. econstructor.
        + tauto.
    Qed.

    Lemma LEM_is_arbitrary_completeness : LEM -> completeness_arbitrary.
    Proof.
      intros Hlem T phi HT Hphi Hvalid.
      apply completeness_classical_stability; eauto.
      intros H. destruct (Hlem (T ⊢TC phi)); tauto.
    Qed.
  End LEM_Equivalence.

  Section MP_Equivalence.
    Definition completeness_enumerable :=
      forall (T : @theory _ _ _ falsity_on) (phi : @form _ _ _ falsity_on),
             closed_T T -> closed phi -> enumerable T ->
             valid_theory_C (classical (ff := falsity_on)) T phi -> T ⊢TC phi.

    Lemma bot_deriv_stable_enum (T : @theory _ _ _ falsity_on) : completeness_enumerable -> closed_T T -> enumerable T ->
      stable (@tprv _ _ _ class T ⊥).
    Proof.
      intros Hcomp Hclosed Henum Hc. apply (Hcomp T ⊥). 1: eauto. 1: econstructor. 1: apply Henum.
      apply bot_valid_stable. 1:easy. intros Hd. apply Hc. intros [L [HT HL]]. apply Hd.
      intros D I rho Hclass Harg.
      eapply sound_for_classical_model; try easy. 1: exact HL.
      intros l Hl. apply Harg. now apply HT.
    Qed.
    Existing Instance falsity_on.

    Lemma MP_is_enumerable_completeness : MP -> completeness_enumerable.
    Proof.
      intros Hmp T phi HT Hphi Henum Hvalid.
      apply completeness_classical_stability; eauto. unfold stable.
      eapply mp_tprv_stability; try tauto. now eapply enumerable_list_enumerable.
    Qed.

    Lemma enumerable_completeness_is_MP : completeness_enumerable -> MP.
    Proof.
      intros HC f Hf.
      pose (fun x : form => exists n, x = ⊥ /\ f n = true) as T.
      assert (closed_T T) as Hclosed by now intros k [n [-> Hn]].
      assert (enumerable T) as Henum.
      { exists (fun n => if f n then Some (⊥) else None). intros phi; split; intros H.
        + destruct H as (n & Heq & Hfn). exists n. rewrite Hfn. now rewrite Heq.
        + destruct H as (n & Hn). unfold T. exists n. destruct (f n); try congruence.
          split; try easy. congruence.
       }
      pose proof (@bot_deriv_stable_enum T HC Hclosed Henum).
      enough (T ⊢TC ⊥) as [[|lx lr] [HL HL']].
      - exfalso. eapply consistent_ND. apply HL'.
      - destruct (HL lx) as (n & Heq & Hfn). 1:now left. now exists n.
      - apply H. intros Hc. apply Hf. intros [n Hn]. apply Hc. exists [⊥]. split.
        + intros ? [<- | []]. unfold T. exists n. split; try easy.
        + apply Ctx; now left.
    Qed.

  End MP_Equivalence.

End Completeness.

(* ** Extending the Completeness Results *)
(*
Section FiniteCompleteness.
  Context {Sigma : Signature}.
  Context {HdF : eq_dec Funcs} {HdP : eq_dec Preds}.
  Context {HeF : enumT Funcs} {HeP : enumT Preds}.

  Lemma list_completeness_standard A phi :
    ST__f -> valid_L SM A phi -> A ⊢CE phi.
  Proof.
    intros stf Hval % valid_L_to_single. apply prv_from_single.
    apply con_T_correct. apply completeness_standard_stability.
    1: intros ? ? []. 1: apply close_closed. 2: now apply valid_L_valid_T in Hval.
    apply stf, fin_T_con_T.
    - intros ? ? [].
    - eapply close_closed.
  Qed.

  Lemma list_completeness_expl A phi :
    valid_L EM A phi -> A ⊢CE phi.
  Proof.
    intros Hval % valid_L_to_single. apply prv_from_single.
    apply tprv_list_T. apply completeness_expl. 1: intros ? ? [].
    1: apply close_closed. now apply valid_L_valid_T in Hval.
  Qed.

  Lemma list_completeness_fragment A phi :
    valid_L BLM A phi -> A ⊢CL phi.
  Proof.
    intros Hval % valid_L_to_single. apply prv_from_single.
    apply tprv_list_T. apply semi_completeness_fragment. 1: intros ? ? [].
    1: apply close_closed. now apply valid_L_valid_T in Hval.
  Qed.
End FiniteCompleteness.

Section StrongCompleteness.
  Context {Sigma : Signature}.
  Context {HdF : eq_dec Funcs} {HdP : eq_dec Preds}.
  Context {HeF : enumT Funcs} {HeP : enumT Preds}.

  Lemma dn_inherit (P Q : Prop) :
    (P -> Q) -> ~ ~ P -> ~ ~ Q.
  Proof. tauto. Qed.

  Lemma strong_completeness_standard (S : stab_class) T phi :
    (forall (T : theory) (phi : form), S Sigma T -> stable (tmap (fun psi : form => (sig_lift psi)[ext_c]) T ⊢TC phi)) -> @map_closed S Sigma (sig_ext Sigma) (fun phi => (sig_lift phi)[ext_c]) -> S Sigma T -> T ⊫S phi -> T ⊢TC phi.
  Proof.
    intros sts cls HT Hval. apply sig_lift_out_T. apply completeness_standard_stability.
    1: apply lift_ext_c_closes_T. 1: apply lift_ext_c_closes. 2: apply (sig_lift_subst_valid droppable_S Hval).
    now apply sts.
  Qed.

  Lemma strong_completeness_expl T phi :
    T ⊫E phi -> T ⊢TC phi.
  Proof.
    intros Hval. apply sig_lift_out_T, completeness_expl.
    1: apply lift_ext_c_closes_T. 1: apply lift_ext_c_closes.
    apply (sig_lift_subst_valid droppable_E Hval).
  Qed.

  Lemma strong_completeness_fragment T phi :
    T ⊫M phi -> T ⊩CL phi.
  Proof.
    intros Hval. apply sig_lift_out_T, semi_completeness_fragment.
    1: apply lift_ext_c_closes_T. 1: apply lift_ext_c_closes.
    apply (sig_lift_subst_valid droppable_BL Hval).
  Qed.

End StrongCompleteness.

*)


(* En este archivo se demuestra la corrección de la acción receiveIntent *)
Require Export Exec.
Require Export Implementacion.
Require Export AuxFunsCorrect.
Require Export ListAuxFuns.
Require Import Classical.
Require Import Estado.
Require Import DefBasicas.
Require Import Semantica.
Require Import Operaciones.
Require Import ErrorManagement.
Require Import Maps.
Require Import Tacticas.
Require Import ValidStateLemmas.
Require Export Coq.Arith.PeanoNat.
Import PeanoNat.Nat.

Section VerifyOldApp.

Lemma verifyOldAppCorrect : forall (s:System) (a:idApp) (sValid: validstate s),
    (pre (verifyOldApp a) s) -> post_verifyOldApp a s (verifyOldApp_post a s).
Proof.
    simpl.
    unfold pre_verifyOldApp, post_verifyOldApp.
    intros.
    destruct_conj H.
    unfold verifyOldApp_post.
    repeat split; auto; simpl.
  - intros a' lPerm' H3.
    elim (classic (a=a')); intros.
    rewrite H1 in H3.
    rewrite <- addAndApply in H3.
    inversion H3.
    destructVS sValid.
    destructSC statesConsistencyVS a'.
    clear certSC defPermsSC grantedPermGroupsSC.

    assert (In a' (apps (state s)) \/
          (exists sysapp : SysImgApp,
             In sysapp (systemImage (environment s)) /\ idSI sysapp = a')).
    rewrite <- H1. auto.
    apply permsSC in H4.
    destruct H4 as [lPerm H4].
    exists lPerm. split; auto.
    intros. inversion H6.

    rewrite overrideNotEq in H3; auto.
    exists lPerm'. auto.
  - intros a' lPerm H3.
    elim (classic (a=a')); intros.
    exists nil. rewrite H1.
    split. rewrite <- addAndApply. auto.
    intros; auto.

    exists lPerm.
    rewrite overrideNotEq.
    split. auto.
    intros. contradiction. auto.

  - rewrite <- addAndApply. auto.

  - apply addPreservesCorrectness.
    apply permsCorrect;auto.

  - intros a' lGroup' H3.
    elim (classic (a=a')); intros.
    rewrite H1 in H3.
    rewrite <- addAndApply in H3.
    inversion H3.
    destructVS sValid.
    destructSC statesConsistencyVS a'.
    clear mfstSC certSC defPermsSC permsSC.

    assert (In a' (apps (state s)) \/
          (exists sysapp : SysImgApp,
             In sysapp (systemImage (environment s)) /\ idSI sysapp = a')).
    rewrite <- H1. auto.
    apply grantedPermGroupsSC in H4.
    destruct H4 as [lPerm H4].
    exists lPerm. split; auto.
    intros. inversion H6.

    rewrite overrideNotEq in H3; auto.
    exists lGroup'. auto.

  - intros a' lGroup H3.
    elim (classic (a=a')); intros.
    exists nil. rewrite H1.
    split. rewrite <- addAndApply. auto.
    intros; auto.

    exists lGroup.
    rewrite overrideNotEq.
    split. auto.
    intros. contradiction. auto.

  - rewrite <- addAndApply. auto.

  - apply addPreservesCorrectness.
    apply grantedPermGroupsCorrect;auto.

  - intros a' H1. right. auto.

  - intros. destruct H1; auto.

  - auto.
Qed.

Lemma notPreVerifyThenError : forall (s : System) (a : idApp),
  ~ pre (verifyOldApp a) s -> validstate s ->
    exists ec : ErrorCode,
      response (step s (verifyOldApp a)) = error ec /\
      ErrorMsg s (verifyOldApp a) ec /\ s = system (step s (verifyOldApp a)).
Proof.
    intros. simpl in H.
    simpl. unfold verifyOldApp_safe, verifyOldApp_pre.
    case_eq (negb (isAppInstalledBool a s)); intros; simpl.

    exists no_such_app.
    split; auto. split; auto.
    unfold not. intros.
    rewrite negb_true_iff in H1.
    apply isAppInstalled_iff in H2.
    rewrite H1 in H2. inversion H2.

    case_eq (InBool idApp idApp_eq a (alreadyVerified (state s))); intros; simpl.

    exists already_verified.
    repeat split;auto.
    unfold InBool in H2.
    rewrite existsb_exists in H2.
    destruct H2 as [a' [H2 H3]].
    destruct (idApp_eq a a').
    rewrite e. auto.
    inversion H3.

    case_eq (negb (isOldAppBool a s)); intros; simpl.

    exists no_verification_needed.
    repeat split;auto.
    unfold not. intros.
    rewrite negb_true_iff in H3.
    apply isOld_isOldBool in H4.
    rewrite H3 in H4. inversion H4.
    auto.

    destruct H.
    unfold pre_verifyOldApp.
    rewrite negb_false_iff in H1.
    split.
  - rewrite isAppInstalled_iff. auto.
  - split.
 -- unfold not. intros.
    apply (In_InBool idApp idApp_eq) in H.
    rewrite H2 in H. inversion H.
 -- rewrite negb_false_iff in H3.
    apply isOldBool_isOld.
    auto. auto.
Qed.

Lemma verifyOldAppIsSound : forall (s:System) (a:idApp),
        validstate s -> exec s (verifyOldApp a) (system (step s (verifyOldApp a))) (response (step s (verifyOldApp a))).
Proof.
    intros s a vs.
    unfold exec.
    split; auto.
    elim (classic (pre (verifyOldApp a) s));intro.
  - left. assert (verifyOldApp_pre a s = None).
    unfold verifyOldApp_pre.
    destruct H. destruct H0.
    rewrite isAppInstalled_iff in H.
    rewrite <- negb_false_iff in H.
    rewrite H.
    case_eq (InBool idApp idApp_eq a (alreadyVerified (state s))); intros.
    unfold InBool in H2.
    apply existsb_exists in H2. destruct H2 as [a' [H2 H3]].
    destruct (idApp_eq a a').
    rewrite <- e in H2. contradiction.
    inversion H3.
    clear H2.
    apply isOld_isOldBool in H1.
    rewrite <- negb_false_iff in H1.
    rewrite H1. auto. auto.

    simpl.
    unfold verifyOldApp_safe;simpl.
    rewrite H0. simpl.
    split; auto.
    split; auto.
    apply verifyOldAppCorrect;auto.
  - right. apply notPreVerifyThenError; auto.
Qed.

End VerifyOldApp.


From Coq Require Import ssreflect ssrfun ssrbool.

From Ltac2 Require Import Ltac2.

From Coq Require Import Ensembles Bool.
From Coq.Logic Require Import FunctionalExtensionality Eqdep_dec.
From Equations Require Import Equations.

Require Import Coq.Program.Tactics.

From MatchingLogic Require Import
    Syntax
    DerivedOperators_Syntax
    ProofSystem
    IndexManipulation
    wftactics
    ProofInfo
    BasicProofSystemLemmas
.
From MatchingLogic.ProofMode Require Import Basics
                                            Propositional
                                            Firstorder.

From stdpp Require Import list tactics fin_sets coGset gmap sets.

From MatchingLogic.Utils Require Import stdpp_ext.

Import extralibrary.

Import
  MatchingLogic.Syntax.Notations
  MatchingLogic.Substitution.Notations
  MatchingLogic.DerivedOperators_Syntax.Notations
  MatchingLogic.ProofInfo.Notations
.

Set Default Proof Mode "Classic".

Open Scope ml_scope.
Open Scope string_scope.
Open Scope list_scope.

Lemma Knaster_tarski {Σ : Signature}
  (Γ : Theory) (ϕ ψ : Pattern)  (i : ProofInfo)
  {pile : ProofInfoLe (
        {| pi_generalized_evars := ∅;
           pi_substituted_svars := ∅;
           pi_uses_kt := true ;
           pi_uses_advanced_kt := has_bound_variable_under_mu ϕ ; (* TODO depends on ϕ*)
        |}) i} :
  well_formed (mu, ϕ) ->
  Γ ⊢i (instantiate (mu, ϕ) ψ) ---> ψ using i ->
  Γ ⊢i (mu, ϕ) ---> ψ using i.
Proof.
  intros Hfev [pf Hpf].
  unshelve (eexists).
  {
    apply ProofSystem.Knaster_tarski.
    { exact Hfev. }
    { exact pf. }
  }
  {
    simpl.
    constructor; simpl.
    {
      destruct Hpf as [Hpf2 Hpf3 Hpf4].
      apply Hpf2.
    }
    {
      destruct Hpf as [Hpf2 Hpf3 Hpf4].
      apply Hpf3.
    }
    {
      destruct Hpf as [Hpf2 Hpf3 Hpf4 Hpf5].
      unfold is_true in Hpf4.
      rewrite implb_true_iff in Hpf4.
      destruct i. cbn in *.
      destruct pile as [Hpile1 [Hpile2 [Hpile3 Hpile4 ] ] ]. cbn in *.
      exact Hpile3.
    }
    {
      destruct Hpf as [Hpf2 Hpf3 Hpf4 Hpf5].
      unfold is_true in Hpf4.
      rewrite implb_true_iff in Hpf4.
      destruct i. cbn in *.
      destruct pile as [Hpile1 [Hpile2 [Hpile3 Hpile4 ] ] ]. cbn in *.
      unfold is_true.
      rewrite implb_true_iff. intros H1.
      rewrite andb_true_r.
      rewrite orb_true_iff in H1.
      destruct H1 as [H1|H1].
      {
        rewrite H1 in Hpile4. simpl in Hpile4.
        exact Hpile4.
      }
      {
        rewrite H1 in Hpf5. simpl in Hpf5.
        destruct_and!. assumption.
      }
    }
  }
Defined.

Lemma Svar_subst {Σ : Signature}
  (Γ : Theory) (ϕ ψ : Pattern) (X : svar)  (i : ProofInfo)
  {pile : ProofInfoLe (
        {| pi_generalized_evars := ∅;
           pi_substituted_svars := {[X]};
           pi_uses_kt := false ;
           pi_uses_advanced_kt := false ;
        |}) i} :
  well_formed ψ ->
  Γ ⊢i ϕ using i ->
  Γ ⊢i (ϕ^[[svar: X ↦ ψ]]) using i.
Proof.
  intros wfψ [pf Hpf].
  unshelve (eexists).
  {
   apply ProofSystem.Svar_subst.
   { pose proof (Hwf := proved_impl_wf _ _ pf). exact Hwf. }
   { exact wfψ. }
   { exact pf. }
  }
  {
    simpl.
    constructor; simpl.
    {
      destruct Hpf as [Hpf2 Hpf3 Hpf4].
      apply Hpf2.
    }
    {
      destruct Hpf as [Hpf2 Hpf3 Hpf4].
      pose proof (Hpile := pile_impl_allows_svsubst_X _ _ _ _ pile).
      clear -Hpile Hpf3.
      set_solver.
    }
    {
      destruct Hpf as [Hpf2 Hpf3 Hpf4].
      exact Hpf4.
    }
    {
      destruct Hpf as [Hpf2 Hpf3 Hpf4 Hpf5].
      exact Hpf5.
    }
  }
Defined.

Lemma Pre_fixp {Σ : Signature}
  (Γ : Theory) (ϕ : Pattern) :
  well_formed (patt_mu ϕ) ->
  Γ ⊢i (instantiate (patt_mu ϕ) (patt_mu ϕ) ---> (patt_mu ϕ))
  using BasicReasoning.
Proof.
  intros wfϕ.
  unshelve (eexists).
  {
    apply ProofSystem.Pre_fixp.
    { exact wfϕ. }
  }
  {
    simpl.
    abstract(solve_pim_simple).
  }
Defined.

Lemma mu_monotone {Σ : Signature} Γ ϕ₁ ϕ₂ X (i : ProofInfo):
  ProofInfoLe ( (ExGen := ∅, SVSubst := {[X]}, KT := true, AKT := has_bound_variable_under_mu ϕ₁^{{svar:X↦0}})) i ->
  svar_has_negative_occurrence X ϕ₁ = false ->
  svar_has_negative_occurrence X ϕ₂ = false ->
  Γ ⊢i ϕ₁ ---> ϕ₂ using i->
  Γ ⊢i (patt_mu (ϕ₁^{{svar: X ↦ 0}})) ---> (patt_mu (ϕ₂^{{svar: X ↦ 0}}))
  using i.
Proof.
  intros pile nonegϕ₁ nonegϕ₂ Himp.
  pose proof (wfϕ12 := proved_impl_wf _ _ (proj1_sig Himp)).
  assert(wfϕ₁ : well_formed ϕ₁) by wf_auto2.
  assert(wfϕ₂ : well_formed ϕ₂) by wf_auto2.

  apply Knaster_tarski.
  { try_solve_pile. }
  {
    wf_auto2.
  }

  pose proof (Htmp := @Svar_subst Σ Γ (ϕ₁ ---> ϕ₂) (mu, ϕ₂^{{svar: X ↦ 0}}) X i).
  feed specialize Htmp.
  { try_solve_pile. }
  { wf_auto2. }
  { exact Himp. }
  unfold free_svar_subst in Htmp.
  simpl in Htmp.
  fold free_svar_subst in Htmp.

  pose proof (Hpf := Pre_fixp Γ (ϕ₂^{{svar: X ↦ 0}})).
  simpl in Hpf.

  unshelve (eapply (cast_proof' Γ _ _) in Hpf).
  3: {
  erewrite bound_to_free_set_variable_subst.
    5: { apply svar_quantify_not_free. }
    4: {
     apply svar_quantify_closed_mu.
     unfold well_formed, well_formed_closed in *. destruct_and!. auto.
    }
    3: {
       apply svar_quantify_closed_mu.
       unfold well_formed, well_formed_closed in *. destruct_and!. auto.
    }
    2: lia.
    reflexivity.
  }

  2: abstract (wf_auto2).

  eapply (cast_proof' Γ) in Hpf.
  2: {
    rewrite svar_open_svar_quantify.
    { unfold well_formed, well_formed_closed in *. destruct_and!. auto. }
    reflexivity.
  }

  assert(well_formed_positive (ϕ₂^[[svar: X ↦ mu , ϕ₂^{{svar: X ↦ 0}}]]) = true).
  {
    unfold well_formed, well_formed_closed in *. destruct_and!. simpl; split_and?.
    apply wfp_free_svar_subst; auto.
    { apply svar_quantify_closed_mu. auto. }
    { simpl. split_and!.
      2: apply well_formed_positive_svar_quantify; assumption.
      apply no_negative_occurrence_svar_quantify; auto.
    }
  }

  assert(well_formed_closed_mu_aux (ϕ₂^[[svar: X ↦ mu , ϕ₂^{{svar: X ↦ 0}}]]) 0 = true).
  {
    unfold well_formed, well_formed_closed in *. destruct_and!. simpl; split_and?; auto.
    replace 0 with (0 + 0) at 3 by lia.
    apply wfc_mu_free_svar_subst; auto.
    simpl.
    apply svar_quantify_closed_mu. assumption.
  }

  assert(well_formed_closed_ex_aux (ϕ₂^[[svar: X ↦ mu , ϕ₂^{{svar: X ↦ 0}}]]) 0 = true).
  {
    unfold well_formed, well_formed_closed in *. destruct_and!. simpl; split_and?; auto.
    replace 0 with (0 + 0) at 3 by lia.
    apply wfc_ex_free_svar_subst; auto.
    simpl.
    apply svar_quantify_closed_ex. assumption.
  }

  assert(well_formed_positive (ϕ₁^[[svar: X ↦ mu , ϕ₂^{{svar: X ↦ 0}}]]) = true).
  {
    unfold well_formed, well_formed_closed in *. destruct_and!. simpl; split_and?.
    apply wfp_free_svar_subst; auto.
    { apply svar_quantify_closed_mu. auto. }
    { simpl. split_and!.
      2: apply well_formed_positive_svar_quantify; assumption.
      apply no_negative_occurrence_svar_quantify; auto.
    }
  }

  assert(well_formed_closed_mu_aux (ϕ₁^[[svar: X ↦ mu , ϕ₂^{{svar: X ↦ 0}}]]) 0 = true).
  {
    unfold well_formed, well_formed_closed in *. destruct_and!. simpl; split_and?; auto.
    replace 0 with (0 + 0) at 3 by lia.
    apply wfc_mu_free_svar_subst; auto.
    simpl.
    apply svar_quantify_closed_mu. assumption.
  }

  assert(well_formed_closed_ex_aux (ϕ₁^[[svar: X ↦ mu , ϕ₂^{{svar: X ↦ 0}}]]) 0 = true).
  {
    unfold well_formed, well_formed_closed in *. destruct_and!. simpl; split_and?; auto.
    replace 0 with (0 + 0) at 3 by lia.
    apply wfc_ex_free_svar_subst; auto.
    simpl.
    apply svar_quantify_closed_ex. assumption.
  }

  apply useBasicReasoning with (i := i) in Hpf.
  epose proof (Hsi := syllogism_meta _ _ _ Htmp Hpf).
  simpl.

  eapply (@cast_proof' Σ Γ).
  1: {
    erewrite bound_to_free_set_variable_subst with (X := X).
    5: { apply svar_quantify_not_free. }
    4: {
         apply svar_quantify_closed_mu.
         unfold well_formed, well_formed_closed in *. destruct_and!. auto.
    }
    3: {
         apply svar_quantify_closed_mu.
         unfold well_formed, well_formed_closed in *. destruct_and!. auto.
    }
    2: lia.
    reflexivity.
  }

  eapply (cast_proof' Γ).
  1: {
    rewrite svar_open_svar_quantify.
    { unfold well_formed, well_formed_closed in *. destruct_and!. auto. }
    reflexivity.
  }
  apply Hsi.
  Unshelve.
  all: abstract(wf_auto2).
Defined.

Close Scope ml_scope.
Close Scope string_scope.
Close Scope list_scope.