Require Import Coq.Structures.OrderedTypeEx.
Require Import Coq.PArith.PArith.
Require Import Coq.FSets.FMapPositive.
Require Import Crypto.Util.Option.
Require Import Crypto.Util.Equality.
Require Import Crypto.Util.Structures.OrdersEx.
Require Import Crypto.Util.Tactics.Head.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.SetEvars.
Require Import Crypto.Util.FSets.FMapTrie.Shape.
Require Import Crypto.Util.FSets.FMapN.
Require Import Crypto.Util.FSets.FMapZ.
Import EqNotations.
Import EverythingGen.

Local Set Implicit Arguments.
Local Set Primitive Projections.
Local Unset Strict Implicit.
(* TODO: move to global settings *)
Local Set Keyed Unification.

Inductive option_dep A : bool -> Type :=
| Some_dep b : A -> option_dep b
| None_dep : option_dep false.
Arguments Some_dep {A b} _.
Arguments None_dep {A}.

Local Ltac t :=
  first [ instantiate (1:=ltac:(eassumption)); reflexivity
        | match goal with
          | [ |- ?LHS = (fun b : ?T => @?RHS b) ]
            => lazymatch RHS with
               | fun '(a, b) => _
                 => is_evar LHS; instantiate (1:=ltac:(first [ intros [a b] | intros [? ?] ]));
                    try t
               end
          end
        | try instantiate (1:=ltac:(intros)); progress cbv beta iota; t
        | instantiate (1:=ltac:(intros)); cbv beta;
          first [ reflexivity | apply f_equal | apply f_equal2 | apply f_equal3 | apply fg_equal
                | match goal with
                  | [ |- ?LHS = (fun b : ?T => @?RHS b) ]
                    => cut (forall a : T, LHS a = RHS a); [ shelve | intro ]
                  end
                | break_innermost_match_step ];
          instantiate (1:=ltac:(intros)); cbv beta iota;
          t
        | idtac ].

Local Ltac handle_id_fix :=
  intros;
  cbv beta;
  set_evars;
  (tryif (match goal with |- context[id_fix] => idtac | |- context[id_fix_2] => idtac end)
    then (intros;
          let m := fresh "m" in
          let x := fresh "x" in
          let IH := fresh "IH" in
          lazymatch goal with
          | [ |- id_fix   _ ] => cbv [id_fix  ]; fix IH 1; intros m; revert m
          | [ |- id_fix_2 _ ] => cbv [id_fix_2]; fix IH 2; intros x m; revert x m
          end;
          revert IH)
    else idtac);
  shelve_unifiable.

Local Ltac subst_partial_evars :=
  repeat match goal with
         | [ H := ?ev |- _ ]
           => has_evar ev; assert_fails is_evar ev; revert H; set_evars; intro
         end.
Local Ltac partial_unify e :=
  let do_rep evb e m IH IHm eIHm
    := (is_evar evb;
        let v1 := fresh in
        let v2 := fresh in
        set (v1 := IHm);
        pose eIHm as v2;
        destruct m;
        change v1 with v2; subst v1 v2 e) in
  lazymatch goal with
  | [ ev := ?evb, IH := _ : id_fix _ |- _ ]
    => let m := lazymatch goal with |- context G[IH ?m] => m end in
       do_rep evb e m IH (IH m) (e IH m)
  | [ ev := ?evb, IH := _ : id_fix_2 _ |- _ ]
    => let x := lazymatch goal with |- context[IH ?x ?m] => x end in
       let m := lazymatch goal with |- context[IH x ?m] => m end in
       do_rep evb e m IH (IH x m) (e IH x m)
  | _ => idtac
  end.

Module PositiveMapTypFunctor <: TypFunctor.
  Local Unset Primitive Projections.
  Local Set Nonrecursive Elimination Schemes.
  Local Set Boolean Equality Schemes.
  Local Set Decidable Equality Schemes.
  Inductive t' (elt : Type) := Node' { data : option elt ; map : option_dep (PositiveMap.t (t' elt)) (Option.is_None data) }.
  Definition t := t'.
  Local Notation node_NonEmpty x y := match x, y with None, None => False | _, _ => True end.
  Definition Node elt (data : option elt) (map : option (PositiveMap.t (t elt))) (pf : node_NonEmpty data map) : t elt
    := @Node' _ data (match map, data return node_NonEmpty data map -> option_dep _ (Option.is_None data) with
                      | Some m, _ => fun _ => Some_dep m
                      | None, Some _ => fun _ => None_dep
                      | None, None => fun pf => match pf with end
                      end pf).
  Global Arguments Node [elt] _ _ _.
  Definition t_rect elt (P : t elt -> Type)
             (val : forall (v : option elt) (m : option (PositiveMap.t (t elt))) (pf : node_NonEmpty v m), P (Node v m pf))
             (m : t elt)
    : P m
    := Eval cbv beta in
      match m return P m with
      | {| data := d ; map := m |}
        => match m in option_dep _ b, d return forall pf : is_None d = b, P {| data := d ; map := rew <- [option_dep _] pf in m |} with
           | None_dep, None
             => fun pf => match pf with
                          | eq_refl => I
                          end
           | Some_dep _ m, Some d
             => fun pf => match pf with
                          | eq_refl => val (Some d) (Some m) I
                          end
           | None_dep as m, Some d
             => fun pf => match pf with
                          | eq_refl => ltac:(refine (fun x => x)) (val (Some d) None I)
                          end
           | Some_dep _ m, None
             => fun pf => match pf with
                          | eq_refl => val None (Some m) I
                          end
           end eq_refl
      end.
End PositiveMapTypFunctor.

Module PositiveMapTrieInd <: Trie PositiveOrderedTypeBits PositiveMap.
  Definition t := PositiveMapTypFunctor.t.
  Include TrieShape PositiveOrderedTypeBits PositiveMap.

  Definition PositiveMap_find_alt A
    := fix find (i : PositiveMap.key) (m : PositiveMap.t A) {struct m} : option A :=
      match m with
      | @PositiveMap.Leaf _ => None
      | PositiveMap.Node l o r =>
          match i with
          | BinNums.xI ii => find ii r
          | BinNums.xO ii => find ii l
          | BinNums.xH => o
          end
      end.
  Lemma eq_PositiveMap_find_alt A : forall i m, @PositiveMap.find A i m = @PositiveMap_find_alt A i m.
  Proof using Type.
    induction i, m; cbn in *; auto.
  Qed.

  Definition t_ind_full elt (P : t elt -> Prop)
             (H : forall d m pf,
                 (forall k v, match m with Some m => PositiveMap.find k m = Some v -> P v | None => True end)
                 -> P (PositiveMapTypFunctor.Node d m pf))
    : forall m, P m.
  Proof using Type.
    fix t_ind_full 1.
    induction m as [d m pf] using PositiveMapTypFunctor.t_rect.
    specialize (H d m pf).
    apply H; clear H.
    destruct m as [m|]; [ | intros; exact I ].
    induction m;
      [ clear t_ind_full
      | match goal with
        | [ H : option _ |- _ ]
          => let x := fresh "x" in
             destruct H as [x|];
             [ specialize (t_ind_full x)
             | clear t_ind_full ]
        end ].
    all: intros k v H.
    all: try solve [ exfalso; clear -H; abstract (destruct k; cbn in H; inversion_option) ].
    all: destruct k; cbn [PositiveMap.find] in *.
    all: lazymatch goal with
         | [ H : None = Some _ |- _ ] => exfalso; clear -H; abstract inversion_option
         | [ H : ?P ?x, H' : Some ?x = Some ?y |- ?P ?y ]
           => refine (rew [P] (f_equal (fun v => Option.value v x) H') in H)
         | _ => idtac
         end.
    all: eauto with nocore.
  Defined.

  Section everything.
    Let everything' : Everything.
    Proof.
      unshelve esplit.
      all: try exact PositiveMapTypFunctor.Node.
      all: try exact PositiveMapTypFunctor.t_rect.
      all: try exact t_ind_full.
      all: try exact PositiveMapAdditionalFacts.xmap2_lr.
      all: try exact PositiveMap.xgmap2_l.
      all: try exact PositiveMap.xgmap2_r.
      all: handle_id_fix.
      all: subst_partial_evars.
      all: try (destruct_head' option; destruct_head'_True; destruct_head'_False; reflexivity).
      all: partial_unify e.
      all: try reflexivity.
    Defined.
    Definition everything := Eval cbv [everything'] in everything'.
  End everything.
End PositiveMapTrieInd.

Module NMapTypFunctor <: TypFunctor.
  Local Unset Primitive Projections.
  Local Set Nonrecursive Elimination Schemes.
  Local Set Boolean Equality Schemes.
  Local Set Decidable Equality Schemes.
  Inductive t' (elt : Type) := Node' { data : option elt ; map : option_dep (NMap.t (t' elt)) (Option.is_None data) }.
  Definition t := t'.
  Local Notation node_NonEmpty x y := match x, y with None, None => False | _, _ => True end.
  Definition Node elt (data : option elt) (map : option (NMap.t (t elt))) (pf : node_NonEmpty data map) : t elt
    := @Node' _ data (match map, data return node_NonEmpty data map -> option_dep _ (Option.is_None data) with
                      | Some m, _ => fun _ => Some_dep m
                      | None, Some _ => fun _ => None_dep
                      | None, None => fun pf => match pf with end
                      end pf).
  Global Arguments Node [elt] _ _ _.
  Definition t_rect elt (P : t elt -> Type)
             (val : forall (v : option elt) (m : option (NMap.t (t elt))) (pf : node_NonEmpty v m), P (Node v m pf))
             (m : t elt)
    : P m
    := Eval cbv beta in
      match m return P m with
      | {| data := d ; map := m |}
        => match m in option_dep _ b, d return forall pf : is_None d = b, P {| data := d ; map := rew <- [option_dep _] pf in m |} with
           | None_dep, None
             => fun pf => match pf with
                          | eq_refl => I
                          end
           | Some_dep _ m, Some d
             => fun pf => match pf with
                          | eq_refl => val (Some d) (Some m) I
                          end
           | None_dep as m, Some d
             => fun pf => match pf with
                          | eq_refl => ltac:(refine (fun x => x)) (val (Some d) None I)
                          end
           | Some_dep _ m, None
             => fun pf => match pf with
                          | eq_refl => val None (Some m) I
                          end
           end eq_refl
      end.
End NMapTypFunctor.

Module NMapTrieInd <: Trie NOrderedTypeBits NMap.
  Definition t := NMapTypFunctor.t.
  Include TrieShape NOrderedTypeBits NMap.

  Definition NMap_find_alt
    := ltac:(let v := (eval cbv -[PositiveMap.find fst snd] in NMap.find) in
             lazymatch (eval pattern PositiveMap.find in v) with
             | ?P _ => let v := (eval cbv beta in (P PositiveMapTrieInd.PositiveMap_find_alt)) in
                       exact v
             end).

  Lemma eq_NMap_find_alt A : forall i m, @NMap.find A i m = @NMap_find_alt A i m.
  Proof using Type.
    cbv -[PositiveMap.find PositiveMapTrieInd.PositiveMap_find_alt].
    intros; break_innermost_match; rewrite ?PositiveMapTrieInd.eq_PositiveMap_find_alt; reflexivity.
  Qed.

  Definition t_ind_full elt (P : t elt -> Prop)
             (H : forall d m pf,
                 (forall k v, match m with Some m => NMap.find k m = Some v -> P v | None => True end)
                 -> P (NMapTypFunctor.Node d m pf))
    : forall m, P m.
  Proof using Type.
    fix t_ind_full 1.
    induction m as [d m pf] using NMapTypFunctor.t_rect.
    specialize (H d m pf).
    apply H; clear H.
    destruct m as [[[m0 m]]|]; [ | intros; exact I ].
    intros [|k]; [ | revert k ].
    { cbn.
      destruct m0 as [m0|]; [ | clear; intros; inversion_option ].
      specialize (t_ind_full m0).
      intro v.
      refine (fun pf => match pf with
                        | eq_refl => t_ind_full
                        end). }
    cbv -[PositiveMap.find t].
    induction m;
      [ clear t_ind_full
      | match goal with
        | [ H : option _ |- _ ]
          => let x := fresh "x" in
             destruct H as [x|];
             [ specialize (t_ind_full x)
             | clear t_ind_full ]
        end ].
    all: intros k v H.
    all: try solve [ exfalso; clear -H; abstract (destruct k; cbn in H; inversion_option) ].
    all: destruct k; cbn [PositiveMap.find] in *.
    all: lazymatch goal with
         | [ H : None = Some _ |- _ ] => exfalso; clear -H; abstract inversion_option
         | [ H : ?P ?x, H' : Some ?x = Some ?y |- ?P ?y ]
           => refine (rew [P] (f_equal (fun v => Option.value v x) H') in H)
         | _ => idtac
         end.
    all: eauto with nocore.
  Defined.

  Section map2.
    Variable A B C : Type.
    Variable f : option A -> option B -> option C.

    Definition NMap_xmap2_l (m : NMap.t A) : NMap.t C
      := ltac:(let v := (eval cbv -[PositiveMap.map2] in (NMap.map2 f m (@NMap.empty _))) in
               lazymatch (eval pattern (PositiveMap.map2 f) in v) with
               | ?P _ => let v := (eval cbv beta in (P (fun m _ => PositiveMap.xmap2_l f m))) in
                         exact v
               end).

    Definition NMap_xmap2_r (m : NMap.t B) : NMap.t C
      := ltac:(let v := (eval cbv -[PositiveMap.map2] in (NMap.map2 f (@NMap.empty _) m)) in
               lazymatch (eval pattern (PositiveMap.map2 f) in v) with
               | ?P _ => let v := (eval cbv beta in (P (fun _ m => PositiveMap.xmap2_r f m))) in
                         exact v
               end).

    Lemma NMap_xgmap2_l : forall (i : NMap.key) (m : NMap.t A),
        f None None = None -> NMap.find i (NMap_xmap2_l m) = f (NMap.find i m) None.
    Proof using Type.
      cbv -[PositiveMap.find PositiveMap.xmap2_l]; intros; break_innermost_match; eauto.
      all: now rewrite PositiveMap.xgmap2_l by assumption.
    Qed.

    Lemma NMap_xgmap2_r : forall (i : NMap.key) (m : NMap.t B),
        f None None = None -> NMap.find i (NMap_xmap2_r m) = f None (NMap.find i m).
    Proof using Type.
      cbv -[PositiveMap.find PositiveMap.xmap2_r]; intros; break_innermost_match; eauto.
      all: now rewrite PositiveMap.xgmap2_r by assumption.
    Qed.
  End map2.
  Lemma NMap_xmap2_lr :
    forall (A B : Type)(f g: option A -> option A -> option B)(m : NMap.t A),
      (forall (i j : option A), f i j = g j i) ->
      NMap_xmap2_l f m = NMap_xmap2_r g m.
  Proof.
    cbv -[PositiveMap.xmap2_r PositiveMap.xmap2_l].
    intros; break_innermost_match; repeat (f_equal; eauto using PositiveMapAdditionalFacts.xmap2_lr).
  Qed.

  Section everything.
    Let everything' : Everything.
    Proof.
      unshelve esplit.
      all: try exact NMapTypFunctor.Node.
      all: try exact NMapTypFunctor.t_rect.
      all: try exact t_ind_full.
      all: try exact NMap_xmap2_lr.
      all: try exact NMap_xgmap2_l.
      all: try exact NMap_xgmap2_r.
      all: handle_id_fix.
      all: subst_partial_evars.
      all: try (destruct_head' option; destruct_head'_True; destruct_head'_False; reflexivity).
      all: partial_unify e.
      all: try reflexivity.
    Defined.
    Definition everything := Eval cbv [everything'] in everything'.
  End everything.
End NMapTrieInd.

Module ZMapTypFunctor <: TypFunctor.
  Local Unset Primitive Projections.
  Local Set Nonrecursive Elimination Schemes.
  Local Set Boolean Equality Schemes.
  Local Set Decidable Equality Schemes.
  Inductive t' (elt : Type) := Node' { data : option elt ; map : option_dep (ZMap.t (t' elt)) (Option.is_None data) }.
  Definition t := t'.
  Local Notation node_NonEmpty x y := match x, y with None, None => False | _, _ => True end.
  Definition Node elt (data : option elt) (map : option (ZMap.t (t elt))) (pf : node_NonEmpty data map) : t elt
    := @Node' _ data (match map, data return node_NonEmpty data map -> option_dep _ (Option.is_None data) with
                      | Some m, _ => fun _ => Some_dep m
                      | None, Some _ => fun _ => None_dep
                      | None, None => fun pf => match pf with end
                      end pf).
  Global Arguments Node [elt] _ _ _.
  Definition t_rect elt (P : t elt -> Type)
             (val : forall (v : option elt) (m : option (ZMap.t (t elt))) (pf : node_NonEmpty v m), P (Node v m pf))
             (m : t elt)
    : P m
    := Eval cbv beta in
      match m return P m with
      | {| data := d ; map := m |}
        => match m in option_dep _ b, d return forall pf : is_None d = b, P {| data := d ; map := rew <- [option_dep _] pf in m |} with
           | None_dep, None
             => fun pf => match pf with
                          | eq_refl => I
                          end
           | Some_dep _ m, Some d
             => fun pf => match pf with
                          | eq_refl => val (Some d) (Some m) I
                          end
           | None_dep as m, Some d
             => fun pf => match pf with
                          | eq_refl => ltac:(refine (fun x => x)) (val (Some d) None I)
                          end
           | Some_dep _ m, None
             => fun pf => match pf with
                          | eq_refl => val None (Some m) I
                          end
           end eq_refl
      end.
End ZMapTypFunctor.

Module ZMapTrieInd <: Trie ZOrderedTypeBits ZMap.
  Definition t := ZMapTypFunctor.t.
  Include TrieShape ZOrderedTypeBits ZMap.

  Definition ZMap_find_alt
    := ltac:(let v := (eval cbv -[PositiveMap.find fst snd] in ZMap.find) in
             lazymatch (eval pattern PositiveMap.find in v) with
             | ?P _ => let v := (eval cbv beta in (P PositiveMapTrieInd.PositiveMap_find_alt)) in
                       exact v
             end).

  Lemma eq_ZMap_find_alt A : forall i m, @ZMap.find A i m = @ZMap_find_alt A i m.
  Proof using Type.
    cbv -[PositiveMap.find PositiveMapTrieInd.PositiveMap_find_alt].
    intros; break_innermost_match; rewrite ?PositiveMapTrieInd.eq_PositiveMap_find_alt; reflexivity.
  Qed.

  Definition t_ind_full elt (P : t elt -> Prop)
             (H : forall d m pf,
                 (forall k v, match m with Some m => ZMap.find k m = Some v -> P v | None => True end)
                 -> P (ZMapTypFunctor.Node d m pf))
    : forall m, P m.
  Proof using Type.
    fix t_ind_full 1.
    induction m as [d m pf] using ZMapTypFunctor.t_rect.
    specialize (H d m pf).
    apply H; clear H.
    destruct m as [[[mn [[m0 m]]]]|]; [ | intros; exact I ].
    intros [|k|k]; [ | revert k | revert k ].
    all: cbv -[PositiveMap.find t].
    { destruct m0 as [m0|]; [ | clear; intros; inversion_option ].
      specialize (t_ind_full m0).
      intro v.
      refine (fun pf => match pf with
                        | eq_refl => t_ind_full
                        end). }
    all: let m := lazymatch goal with |- context[PositiveMap.find _ ?m] => m end in
         induction m;
         [ clear t_ind_full
         | match goal with
           | [ H : option _ |- _ ]
             => let x := fresh "x" in
                destruct H as [x|];
                [ specialize (t_ind_full x)
                | clear t_ind_full ]
           end ].
    all: intros k v H.
    all: try solve [ exfalso; clear -H; abstract (destruct k; cbn in H; inversion_option) ].
    all: destruct k; cbn [PositiveMap.find] in *.
    all: lazymatch goal with
         | [ H : None = Some _ |- _ ] => exfalso; clear -H; abstract inversion_option
         | [ H : ?P ?x, H' : Some ?x = Some ?y |- ?P ?y ]
           => refine (rew [P] (f_equal (fun v => Option.value v x) H') in H)
         | _ => idtac
         end.
    all: eauto with nocore.
  Defined.

  Section map2.
    Variable A B C : Type.
    Variable f : option A -> option B -> option C.

    Definition ZMap_xmap2_l (m : ZMap.t A) : ZMap.t C
      := ltac:(let v := (eval cbv -[PositiveMap.map2] in (ZMap.map2 f m (@ZMap.empty _))) in
               lazymatch (eval pattern (PositiveMap.map2 f) in v) with
               | ?P _ => let v := (eval cbv beta in (P (fun m _ => PositiveMap.xmap2_l f m))) in
                         exact v
               end).

    Definition ZMap_xmap2_r (m : ZMap.t B) : ZMap.t C
      := ltac:(let v := (eval cbv -[PositiveMap.map2] in (ZMap.map2 f (@ZMap.empty _) m)) in
               lazymatch (eval pattern (PositiveMap.map2 f) in v) with
               | ?P _ => let v := (eval cbv beta in (P (fun _ m => PositiveMap.xmap2_r f m))) in
                         exact v
               end).

    Lemma ZMap_xgmap2_l : forall (i : ZMap.key) (m : ZMap.t A),
        f None None = None -> ZMap.find i (ZMap_xmap2_l m) = f (ZMap.find i m) None.
    Proof using Type.
      cbv -[PositiveMap.find PositiveMap.xmap2_l]; intros; break_innermost_match; eauto.
      all: now rewrite PositiveMap.xgmap2_l by assumption.
    Qed.

    Lemma ZMap_xgmap2_r : forall (i : ZMap.key) (m : ZMap.t B),
        f None None = None -> ZMap.find i (ZMap_xmap2_r m) = f None (ZMap.find i m).
    Proof using Type.
      cbv -[PositiveMap.find PositiveMap.xmap2_r]; intros; break_innermost_match; eauto.
      all: now rewrite PositiveMap.xgmap2_r by assumption.
    Qed.
  End map2.
  Lemma ZMap_xmap2_lr :
    forall (A B : Type)(f g: option A -> option A -> option B)(m : ZMap.t A),
      (forall (i j : option A), f i j = g j i) ->
      ZMap_xmap2_l f m = ZMap_xmap2_r g m.
  Proof.
    cbv -[PositiveMap.xmap2_r PositiveMap.xmap2_l].
    intros; break_innermost_match; repeat (f_equal; eauto using PositiveMapAdditionalFacts.xmap2_lr).
  Qed.

  Section everything.
    Let everything' : Everything.
    Proof.
      unshelve esplit.
      all: try exact ZMapTypFunctor.Node.
      all: try exact ZMapTypFunctor.t_rect.
      all: try exact t_ind_full.
      all: try exact ZMap_xmap2_lr.
      all: try exact ZMap_xgmap2_l.
      all: try exact ZMap_xgmap2_r.
      all: handle_id_fix.
      all: subst_partial_evars.
      all: try (destruct_head' option; destruct_head'_True; destruct_head'_False; reflexivity).
      all: partial_unify e.
      all: try reflexivity.
    Defined.
    Definition everything := Eval cbv [everything'] in everything'.
  End everything.
End ZMapTrieInd.


(* (c) Copyright 2006-2018 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat seq.
From fourcolor Require Import cfmap cfreducible configurations.

(******************************************************************************)
(* Reducibility of configurations number 271 to 278, whose indices in         *)
(* the_configs range over segment [270, 278).                                 *)
(******************************************************************************)

Lemma red270to278 : reducible_in_range 270 278 the_configs.
Proof. CheckReducible. Qed.


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

(** Branch tunneling (optimization of branches to branches). *)

Require Import Coqlib.
Require Import Maps.
Require Import UnionFind.
Require Import AST.
Require Import LTL.

(** Branch tunneling shortens sequences of branches (with no intervening
  computations) by rewriting the branch and conditional branch instructions
  so that they jump directly to the end of the branch sequence.
  For example:
<<
     L1: nop L2;                          L1: nop L3;
     L2; nop L3;               becomes    L2: nop L3;
     L3: instr;                           L3: instr;
     L4: if (cond) goto L1;               L4: if (cond) goto L3;
>>
  This optimization can be applied to several of our intermediate
  languages.  We choose to perform it on the [LTL] language,
  after register allocation but before code linearization.
  Register allocation can delete instructions (such as dead
  computations or useless moves), therefore there are more
  opportunities for tunneling after allocation than before.
  Symmetrically, prior tunneling helps linearization to produce
  better code, e.g. by revealing that some [nop] instructions are
  dead code (as the "nop L3" in the example above).
*)

(** The naive implementation of branch tunneling would replace
  any branch to a node [pc] by a branch to the node
  [branch_target f pc], defined as follows:
<<
  branch_target f pc = branch_target f pc'  if f(pc) = nop pc'
                     = pc                   otherwise
>>
  However, this definition can fail to terminate if
  the program can contain loops consisting only of branches, as in
<<
     L1: nop L1;
>>
  or
<<   L1: nop L2;
     L2: nop L1;
>>
  Coq warns us of this fact by not accepting the definition
  of [branch_target] above.

  To handle this problem, we proceed in two passes.  The first pass
  populates a union-find data structure, adding equalities [pc = pc']
  for every instruction [pc: nop pc'] in the function. *)

Module U := UnionFind.UF(PTree).

Definition record_goto (uf: U.t) (pc: node) (b: bblock) : U.t :=
  match b with
  | Lbranch s :: _ => U.union uf pc s
  | _ => uf
  end.

Definition record_gotos (f: LTL.function) : U.t :=
  PTree.fold record_goto f.(fn_code) U.empty.

(** The second pass rewrites all LTL instructions, replacing every
  successor [s] of every instruction by the canonical representative
  of its equivalence class in the union-find data structure. *)

Definition tunnel_instr (uf: U.t) (i: instruction) : instruction :=
  match i with
  | Lbranch s => Lbranch (U.repr uf s)
  | Lcond cond args s1 s2 => Lcond cond args (U.repr uf s1) (U.repr uf s2)
  | Ljumptable arg tbl => Ljumptable arg (List.map (U.repr uf) tbl)
  | _ => i
  end.

Definition tunnel_block (uf: U.t) (b: bblock) : bblock :=
  List.map (tunnel_instr uf) b.

Definition tunnel_function (f: LTL.function) : LTL.function :=
  let uf := record_gotos f in
  mkfunction
    (fn_sig f)
    (fn_stacksize f)
    (PTree.map1 (tunnel_block uf) (fn_code f))
    (U.repr uf (fn_entrypoint f)).

Definition tunnel_fundef (f: LTL.fundef) : LTL.fundef :=
  transf_fundef tunnel_function f.

Definition tunnel_program (p: LTL.program) : LTL.program :=
  transform_program tunnel_fundef p.


Require Import VST.floyd.proofauto.
Require Import VST.progs.load_demo.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs.  mk_varspecs prog. Defined.

Definition pair_pair_t := (Tstruct _pair_pair noattr).

Definition array_size := 100.

Definition get22_spec :=
 DECLARE _get22
  WITH pps: val, i: Z, x11: int, x12: int, x21: int, x22: int, sh : share
  PRE [ tptr pair_pair_t, tint ]
    PROP  (readable_share sh; 0 <= i < array_size)
    PARAMS (pps; Vint (Int.repr i))
    SEP   (field_at sh (tarray pair_pair_t array_size) [ArraySubsc i]
                    ((Vint x11, Vint x12), (Vint x21, Vint x22)) pps)
  POST [ tint ]
        PROP () RETURN (Vint x22)
    SEP   (field_at sh (tarray pair_pair_t array_size) [ArraySubsc i]
                    ((Vint x11, Vint x12), (Vint x21, Vint x22)) pps).

Definition uint_sum (contents : list Z) : int :=
  fold_right (fun el sum => Int.add sum (Int.repr el)) Int.zero contents.

Definition fiddle_spec :=
 DECLARE _fiddle
  WITH p: val, n: Z, tag: Z, contents: list Z
  PRE [ tptr tuint ]
          PROP  (Int.unsigned (Int.shru (Int.repr tag) (Int.repr 10)) = n)
          PARAMS (p)
          SEP (data_at Ews (tarray tuint (1+n))
                      (map Vint (map Int.repr (tag::contents)))
                      (offset_val (-sizeof tuint) p))
  POST [ tint ]
          PROP ( )
          RETURN (Vint (Int.add (Int.repr (Z.land tag 255)) (uint_sum contents)))
          SEP (data_at Ews (tarray tuint (1+n))
                      (map Vint (map Int.repr (tag::contents)))
                      (offset_val (-sizeof tuint) p)).

Definition get_uint32_le (arr: list Z) : int :=
 (Int.or (Int.or (Int.or
            (Int.repr (Znth 0 arr))
   (Int.shl (Int.repr (Znth 1 arr)) (Int.repr  8)))
   (Int.shl (Int.repr (Znth 2 arr)) (Int.repr 16)))
   (Int.shl (Int.repr (Znth 3 arr)) (Int.repr 24))).

Definition get_little_endian_spec :=
  DECLARE _get_little_endian
  WITH input : val, in_sh : share, arr : list Z
  PRE [ tptr tuchar ]
    PROP (Zlength arr = 4;
          readable_share in_sh;
          forall i, 0 <= i < 4 -> 0 <= Znth i arr <= Byte.max_unsigned)
    PARAMS (input)
    SEP (data_at in_sh (tarray tuchar 4) (map Vint (map Int.repr arr)) input)
  POST [ tuint ]
    PROP() RETURN (Vint (get_uint32_le arr))
    SEP (data_at in_sh (tarray tuchar 4) (map Vint (map Int.repr arr)) input).

Definition Gprog : funspecs := ltac:(with_library prog
  [get22_spec; fiddle_spec; get_little_endian_spec]).

Ltac solve_arr_range H :=
 match goal with |- context [Znth ?i _] =>
   specialize (H i); spec H; [ computable | ];
   rewrite Int.unsigned_repr; rep_lia
 end.

Lemma body_get_little_endian: semax_body Vprog Gprog f_get_little_endian get_little_endian_spec.
Proof.
start_function.
assert (BMU: Byte.max_unsigned=255) by reflexivity.
forward.
entailer!. solve_arr_range H0.
forward.
forward.
entailer!. solve_arr_range H0.
forward.
forward.
entailer!. solve_arr_range H0.
forward.
entailer!. solve_arr_range H0.
forward.
Qed.

Lemma uint_sum_app: forall a b, uint_sum (a++b) = Int.add (uint_sum a) (uint_sum b).
Proof.
  intros. induction a; simpl.
  - symmetry. apply Int.add_zero_l.
  - rewrite IHa. rewrite !Int.add_assoc. f_equal. apply Int.add_commut.
Qed.

Lemma body_fiddle: semax_body Vprog Gprog f_fiddle fiddle_spec.
Proof.
start_function. simpl map.
rename H into Htag.
assert_PROP (Zlength contents = n) as LEN. {
  entailer!.
  forget (Int.unsigned (Int.shru (Int.repr tag) (Int.repr 10))) as n.
  clear - H0.
  rewrite Zlength_cons, !Zlength_map in H0.
  destruct (zlt n 0); [elimtype False | ].
  rewrite Z.max_l in H0 by lia.
  pose proof (Zlength_nonneg contents).
  lia.
  rewrite Z.max_r in H0 by lia. lia.
}
assert (Zlength (tag :: contents) = 1 + n) as LEN1. {
  rewrite Zlength_cons. lia.
}
assert (N0: 0 <= n). {
  pose proof (Zlength_nonneg contents). lia.
}
assert_PROP (isptr p) as P by entailer!.

(* forward fails, but tells us to prove this: *)
assert_PROP (force_val (sem_add_ptr_int tuint Signed p (eval_unop Oneg tint (Vint (Int.repr 1))))
  = field_address (tarray tuint (1+n)) [ArraySubsc 0] (offset_val (-sizeof tuint) p)). {
  entailer!.
  destruct p; inversion P. simpl.
  rewrite field_compatible_field_address by auto with field_compatible.
  simpl.
  rewrite ptrofs_add_repr_0_r. reflexivity.
}
forward.
(* sum = tagword & 0xff; *)
forward.
(* size = tagword >> 10; *)
forward.
(* rewrite !Znth_0_cons. *)
forward_for_simple_bound (Int.unsigned (Int.shru (Int.repr tag) (Int.repr 10))) (EX i: Z,
  PROP ( )
  LOCAL (
    temp _size (Vint (Int.shru (Int.repr tag) (Int.repr 10)));
    temp _sum (Vint (Int.add (Int.and (Int.repr tag) (Int.repr 255))
                             (uint_sum (sublist 0 i contents))));
    temp _tagword (Vint (Int.repr tag));
    temp _p p
  )
  SEP (data_at Ews (tarray tuint (1 + n)) (map Vint (map Int.repr (tag :: contents)))
          (offset_val (- sizeof tuint) p))).
- (* precondition implies invariant: *)
  entailer!.
- (* body preserves invariant: *)
  (* forward fails, but tells us to prove this: *)
  assert_PROP (force_val (sem_add_ptr_int tuint Unsigned p (Vint (Int.repr i)))
    = field_address (tarray tuint (1 + n)) [ArraySubsc (1 + i)] (offset_val (- sizeof tuint) p)). {
    entailer!.
    destruct p; inversion P. simpl.
    rewrite field_compatible_field_address by auto with field_compatible.
    simpl.
    rewrite Ptrofs.add_assoc, ptrofs_add_repr.
    f_equal. f_equal. f_equal. unfold sizeof; simpl. lia.
  }
  forward.
  forward.
  entailer!.
  rewrite Znth_pos_cons by lia.
  autorewrite with sublist. simpl.
  f_equal. rewrite Int.add_assoc. f_equal.
  rewrite (sublist_split 0 i (i+1)) by lia.
  rewrite sublist_len_1 by lia.
  replace (1 + i - 1) with i by lia.
  rewrite uint_sum_app. f_equal. simpl. apply Int.add_zero_l.
- (* return sum; *)
  forward. rewrite sublist_same by auto. entailer!.
Qed.

Lemma body_get22_root_expr: semax_body Vprog Gprog f_get22 get22_spec.
 Proof.
 start_function.
 (* int_pair_t* p = &pps[i].right; *)
 forward.
 simpl (temp _p _).
 (* Assert_PROP what forward asks us for (only for the root expression "p"):  *)
 assert_PROP (offset_val 8 (force_val (sem_add_ptr_int (Tstruct _pair_pair noattr) Signed pps (Vint (Int.repr i))))
   = field_address (tarray pair_pair_t array_size) [StructField _right; ArraySubsc i] pps) as E. {
   entailer!. rewrite field_compatible_field_address by auto with field_compatible.
  simpl. normalize.
 }
 (* int res = p->snd; *)
 forward.
 (* return res; *)
 forward.
 Qed.

Lemma body_get22_full_expr: semax_body Vprog Gprog f_get22 get22_spec.
Proof.
start_function.
(* int_pair_t* p = &pps[i].right; *)
forward.
simpl (temp _p _).

(* Assert_PROP what forward asks us for (for the full expression "p->snd"): *)
assert_PROP (
  offset_val 4 (offset_val 8 (force_val
    (sem_add_ptr_int (Tstruct _pair_pair noattr) Signed pps (Vint (Int.repr i)))))
  = (field_address (tarray pair_pair_t array_size)
                   [StructField _snd; StructField _right; ArraySubsc i] pps)). {
  entailer!. rewrite field_compatible_field_address by auto with field_compatible.
  simpl. f_equal. unfold sizeof; simpl. lia.
}
(* int res = p->snd; *)
forward.
(* return res; *)
forward.
Qed.

Lemma body_get22_alt: semax_body Vprog Gprog f_get22 get22_spec.
Proof.
start_function.
(* int_pair_t* p = &pps[i].right; *)
forward.
simpl (temp _p _).

(* Alternative: Make p nice enough so that no hint is required: *)
assert_PROP (offset_val 8 (force_val (sem_add_ptr_int (Tstruct _pair_pair noattr) Signed pps (Vint (Int.repr i))))
  = field_address (tarray pair_pair_t array_size) [StructField _right; ArraySubsc i] pps) as E. {
  entailer!. rewrite field_compatible_field_address by auto with field_compatible.
  simpl.
  normalize.
}
rewrite E. clear E.
(* int res = p->snd; *)
forward.
(* return res; *)
forward.
Qed.