(* ************************************************************************ *)
(*  Sail and the Sail architecture models here, comprising all files and    *)
(*  directories except the ASL-derived Sail code in the aarch64 directory,  *)
(*  are subject to the BSD two-clause licence below.                        *)
(*                                                                          *)
(*  The ASL derived parts of the ARMv8.3 specification in                   *)
(*  aarch64/no_vector and aarch64/full are copyright ARM Ltd.               *)
(*                                                                          *)
(*  Copyright (c) 2013-2026                                                 *)
(*    Kathyrn Gray                                                          *)
(*    Shaked Flur                                                           *)
(*    Stephen Kell                                                          *)
(*    Gabriel Kerneis                                                       *)
(*    Robert Norton-Wright                                                  *)
(*    Christopher Pulte                                                     *)
(*    Peter Sewell                                                          *)
(*    Alasdair Armstrong                                                    *)
(*    Brian Campbell                                                        *)
(*    Thomas Bauereiss                                                      *)
(*    Anthony Fox                                                           *)
(*    Jon French                                                            *)
(*    Dominic Mulligan                                                      *)
(*    Stephen Kell                                                          *)
(*    Mark Wassell                                                          *)
(*    Alastair Reid (Arm Ltd)                                               *)
(*                                                                          *)
(*  All rights reserved.                                                    *)
(*                                                                          *)
(*  This work was partially supported by EPSRC grant EP/K008528/1 REMS:     *)
(*  Rigorous Engineering for Mainstream Systems, an ARM iCASE award, EPSRC  *)
(*  IAA KTF funding, and donations from Arm. This project has received      *)
(*  funding from the European Research Council (ERC) under the European     *)
(*  Union's Horizon 2020 research and innovation programme (grant agreement *)
(*  No 789108, ELVER).                                                      *)
(*                                                                          *)
(*  This software was developed by SRI International and the University of  *)
(*  Cambridge Computer Laboratory (Department of Computer Science and       *)
(*  Technology) under DARPA/AFRL contracts FA8650-18-C-7809 ("CIFV")        *)
(*  and FA8750-10-C-0237 ("CTSRD").                                         *)
(*                                                                          *)
(*  SPDX-License-Identifier: BSD-2-Clause                                   *)
(* ************************************************************************ *)

From Stdlib Require Import Lia.
From Stdlib Require Import ZArith.

From stdpp Require Import base.

From Sail Require Import Ast.
From Sail Require Import ListUtil.

(** * Induction principles for AST nodes

The various induction rules generated by Rocq are insufficient for
many of the theorems we wish to prove, so we are required to prove our
own.

Allthough this is tedious we do gain one additional benefit - each
Sail AST constructor [X_whatever] is wrapped in an [X_aux] constructor
that stores additional annotation data, and we can make our custom
induction rules work around this. *)

Section pat_ind_g.
  Variables (A : Set)
            (P : pat A → Prop)
            (H_lit : ∀ lit ann, P (P_aux (P_lit lit) ann))
            (H_wild : ∀ ann, P (P_aux P_wild ann))
            (H_or : ∀ pat1 pat2 ann, P pat1 → P pat2 → P (P_aux (P_or pat1 pat2) ann))
            (H_not : ∀ pat ann, P pat → P (P_aux (P_not pat) ann))
            (H_as : ∀ pat id ann, P pat → P (P_aux (P_as pat id) ann))
            (H_typ : ∀ typ pat ann, P pat → P (P_aux (P_typ typ pat) ann))
            (H_id : ∀ id ann, P (P_aux (P_id id) ann))
            (H_var : ∀ pat typ_pat ann, P pat → P (P_aux (P_var pat typ_pat) ann))
            (H_app : ∀ id pats ann, Forall P pats → P (P_aux (P_app id pats) ann))
            (H_vector : ∀ pats ann, Forall P pats → P (P_aux (P_vector pats) ann))
            (H_vector_concat : ∀ pats ann, Forall P pats → P (P_aux (P_vector_concat pats) ann))
            (H_vector_subrange : ∀ id n m ann, P (P_aux (P_vector_subrange id n m) ann))
            (H_tuple : ∀ pats ann, Forall P pats → P (P_aux (P_tuple pats) ann))
            (H_list : ∀ pats ann, Forall P pats → P (P_aux (P_list pats) ann))
            (H_cons : ∀ pat1 pat2 ann, P pat1 → P pat2 → P (P_aux (P_cons pat1 pat2) ann))
            (H_string_append : ∀ pats ann, Forall P pats → P (P_aux (P_string_append pats) ann))
            (H_struct : ∀ sname fields wild ann,
              Forall (λ f, P (snd f)) fields → P (P_aux (P_struct sname fields wild) ann)).

  Fixpoint pat_ind_g pat : P pat.
  Proof using All.
    destruct pat as [aux ann].
    destruct aux.
    - apply H_lit.
    - apply H_wild.
    - apply H_or; trivial.
    - apply H_not; trivial.
    - apply H_as; trivial.
    - apply H_typ; trivial.
    - apply H_id.
    - apply H_var; trivial.
    - apply H_app.
      induction l.
      + trivial.
      + apply Forall_cons; [trivial | assumption].
    - apply H_vector.
      induction l.
      + trivial.
      + apply Forall_cons; [trivial | assumption].
    - apply H_vector_concat.
      induction l.
      + trivial.
      + apply Forall_cons; [trivial | assumption].
    - apply H_vector_subrange.
    - apply H_tuple.
      induction l.
      + trivial.
      + apply Forall_cons; [trivial | assumption].
    - apply H_list.
      induction l.
      + trivial.
      + apply Forall_cons; [trivial | assumption].
    - apply H_cons; trivial.
    - apply H_string_append.
      induction l.
      + trivial.
      + apply Forall_cons; [trivial | assumption].
    - apply H_struct.
      induction l.
      + trivial.
      + apply Forall_cons; [trivial | assumption].
  Qed.
End pat_ind_g.

Section lexp_ind_g.
  Variables (A : Set)
            (P : lexp A → Prop)
            (H_id : ∀ id ann, P (LE_aux (LE_id id) ann))
            (H_deref : ∀ x ann, P (LE_aux (LE_deref x) ann))
            (H_app : ∀ f xs ann, P (LE_aux (LE_app f xs) ann))
            (H_typ : ∀ id typ ann, P (LE_aux (LE_typ typ id) ann))
            (H_tuple : ∀ ls ann, Forall P ls → P (LE_aux (LE_tuple ls) ann))
            (H_vector_concat : ∀ ls ann, Forall P ls → P (LE_aux (LE_vector_concat ls) ann))
            (H_vector : ∀ l n ann, P l → P (LE_aux (LE_vector l n) ann))
            (H_vector_range : ∀ l n m ann, P l → P (LE_aux (LE_vector_range l n m) ann))
            (H_field : ∀ (l : lexp A) f ann, P l → P (LE_aux (LE_field l f) ann)).

  Fixpoint lexp_ind_g l : P l.
  Proof using All.
    destruct l as [aux ann].
    destruct aux.
    - apply H_id.
    - apply H_deref.
    - apply H_app.
    - apply H_typ.
    - apply H_tuple.
      induction l.
      + trivial.
      + apply Forall_cons. trivial. assumption.
    - apply H_vector_concat.
      induction l.
      + trivial.
      + apply Forall_cons. trivial. assumption.
    - apply H_vector. trivial.
    - apply H_vector_range. trivial.
    - apply H_field. trivial.
  Qed.
End lexp_ind_g.

Definition fexp_name {A : Set} (f : fexp A) : id :=
  let 'FE_aux (FE_fexp id _) _ := f in id.

Definition fexp_exp {A : Set} (f : fexp A) : exp A :=
  let 'FE_aux (FE_fexp _ x) _ := f in x.

Definition fexp_annot {A : Set} (f : fexp A) : annot A :=
  let 'FE_aux (FE_fexp _ _) ann := f in ann.

Definition MatchArm {A : Set} (P : exp A → Prop) (arm : pexp A) : Prop :=
  match arm with
  | Pat_aux (Pat_exp _ x) _ => P x
  | Pat_aux (Pat_when _ g x) _ => P g ∧ P x
  end.

(** ** L-expression subexpressions

Some L-expression forms can contain nested subexpressions. This
function returns them in left-to-right (evaluation) order. *)

Fixpoint lexp_subexps {A : Set} (l : lexp A) : list (exp A) :=
  let 'LE_aux aux _ := l in
  match aux with
  | LE_id _ | LE_typ _ _ => []
  | LE_deref x => [x]
  | LE_app _ xs => xs
  | LE_tuple ls
  | LE_vector_concat ls =>
      concat (map lexp_subexps ls)
  | LE_vector l x => lexp_subexps l ++ [x]
  | LE_vector_range l n m => lexp_subexps l ++ [n; m]
  | LE_field l _ => lexp_subexps l
  end.

(** Once extracted by [lexp_subexps], this function puts
subexpressions back into an L-expression, replacing the existing
subexpressions. *)

Fixpoint update_lexp_subexps {A : Set} (xs : list (exp A)) (l : lexp A) : lexp A * list (exp A) :=
  let 'LE_aux aux annot := l in
  match aux with
  | LE_id _ | LE_typ _ _ => (l, xs)
  | LE_deref _ =>
      match xs with
      | y :: ys =>
          (LE_aux (LE_deref y) annot, ys)
      | _ => (l, xs)
      end
  | LE_field l f =>
      let '(l', ys) := update_lexp_subexps xs l in
      (LE_aux (LE_field l' f) annot, ys)
  | LE_app id args =>
      let '(ys, zs) := take_drop (length args) xs in
      (LE_aux (LE_app id ys) annot, zs)
  | LE_tuple ls =>
      let '(ls, xs) :=
        fold_left
          (fun acc l =>
             let '(ls, xs) := acc in
             let '(l, xs) := update_lexp_subexps xs l in
             (ls ++ [l], xs)
          )
          ls
          ([], xs)
      in
      (LE_aux (LE_tuple ls) annot, xs)
  | LE_vector_concat ls =>
      let '(ls, xs) :=
        fold_left
          (fun acc l =>
             let '(ls, xs) := acc in
             let '(l, xs) := update_lexp_subexps xs l in
             (ls ++ [l], xs)
          )
          ls
          ([], xs)
      in
      (LE_aux (LE_vector_concat ls) annot, xs)
  | LE_vector l n =>
      match update_lexp_subexps xs l with
      | (l, n :: xs) =>
          (LE_aux (LE_vector l n) annot, xs)
      | _ =>
          (l, [])
      end
  | LE_vector_range l n m =>
      match update_lexp_subexps xs l with
      | (l, n :: m :: xs) =>
          (LE_aux (LE_vector_range l n m) annot, xs)
      | _ =>
          (l, [])
      end
  end.

Lemma fst_let_fx : ∀ A B C (P : A * B) (f : A → C),
  fst (let '(x, y) := P in (f x, y)) = f (fst P).
Proof.
  intros.
  destruct P.
  reflexivity.
Qed.

Lemma snd_let_fx : ∀ A B C (P : A * B) (f : A → C),
  snd (let '(x, y) := P in (f x, y)) = snd P.
Proof.
  intros.
  destruct P.
  reflexivity.
Qed.

Lemma foldl_acc_h1 : ∀ A B C (xs : list A) (y : B) (ys : list B) (zs : list C) (f : list C → A → B * list C),
  y ::
  fst
    (fold_left
       (fun (acc : list B * list C) (x0 : A) =>
        let
        '(ys0, zs0) := acc in let '(y0, zs1) := f zs0 x0 in (ys0 ++ [y0], zs1))
       xs (ys, zs)) =
  fst
    (fold_left
       (fun (acc : list B * list C) (x0 : A) =>
        let
        '(ys0, zs0) := acc in let '(y0, zs1) := f zs0 x0 in (ys0 ++ [y0], zs1))
       xs (y :: ys, zs)).
Proof.
  induction xs.
  - reflexivity.
  - intros.
    cbn.
    destruct (f zs a).
    rewrite IHxs.
    reflexivity.
Qed.

Lemma foldl_acc_h2 : ∀ A B C (xs : list A) (ys1 ys2 : list B) (zs : list C) (f : list C → A → B * list C),
  snd
    (fold_left
       (fun (acc : list B * list C) (x0 : A) =>
        let
        '(ys0, zs0) := acc in let '(y0, zs1) := f zs0 x0 in (ys0 ++ [y0], zs1))
       xs (ys1, zs)) =
  snd
    (fold_left
       (fun (acc : list B * list C) (x0 : A) =>
        let
        '(ys0, zs0) := acc in let '(y0, zs1) := f zs0 x0 in (ys0 ++ [y0], zs1))
       xs (ys2, zs)).
Proof.
  induction xs.
  - reflexivity.
  - intros.
    cbn.
    destruct (f zs a).
    rewrite (IHxs (ys1 ++ [b]) (ys2 ++ [b])).
    reflexivity.
Qed.

Lemma foldl_acc : ∀ A B C (xs : list A) (ys : list B) (zs : list C) (f : list C → A → B * list C),
  fold_left
    (fun acc x =>
       let '(ys, zs) := acc in
       let '(y, zs) := f zs x in
       (ys ++ [y], zs))
    xs
    (ys, zs)
  =
  let '(a, b) := fold_left
    (fun acc x =>
       let '(ys, zs) := acc in
       let '(y, zs) := f zs x in
       (ys ++ [y], zs))
    xs
    ([], zs)
  in
  (ys ++ a, b).
Proof.
  induction xs as [| x xs].
  - intros.
    cbn.
    rewrite app_nil_r.
    reflexivity.
  - intros.
    cbn.
    destruct (f zs x) as [y zs'].
    rewrite IHxs.
    apply injective_projections.
    + rewrite fst_let_fx.
      rewrite fst_let_fx.
      rewrite <- app_assoc.
      rewrite app_inv_head_iff.
      cbn.
      apply foldl_acc_h1.
    + rewrite snd_let_fx.
      rewrite snd_let_fx.
      apply foldl_acc_h2.
Qed.

Definition cons_lexp {A : Set} (lx : lexp A) (acc : lexp A * list (exp A)) : lexp A * list (exp A) :=
  let '(LE_aux aux ann, xs) := acc in
  match aux with
  | (LE_tuple lxs) => (LE_aux (LE_tuple (lx :: lxs)) ann, xs)
  | (LE_vector_concat lxs) => (LE_aux (LE_vector_concat (lx :: lxs)) ann, xs)
  | _ => acc
  end.

Lemma cons_lexp_tuple : ∀ (A : Set) (P : list (lexp A) * list (exp A)) (a : lexp A) ann,
  (let '(ls0, xs) := let '(a0, b) := P in (a :: a0, b) in (LE_aux (LE_tuple ls0) ann, xs))
  = cons_lexp a (let '(a0, b) := P in (LE_aux (LE_tuple a0) ann, b)).
Proof.
  destruct P.
  reflexivity.
Qed.

Lemma cons_lexp_vector_concat : ∀ (A : Set) (P : list (lexp A) * list (exp A)) (a : lexp A) ann,
  (let '(ls0, xs) := let '(a0, b) := P in (a :: a0, b) in (LE_aux (LE_vector_concat ls0) ann, xs))
  = cons_lexp a (let '(a0, b) := P in (LE_aux (LE_vector_concat a0) ann, b)).
Proof.
  destruct P.
  cbn. reflexivity.
Qed.

Lemma lexp_subexps_identity_g : ∀ (A : Set) (l : lexp A) (es : list (exp A)),
  update_lexp_subexps (lexp_subexps l ++ es) l = (l, es).
Proof.
  induction l using lexp_ind_g.
  all: try reflexivity.
  - cbn. intros. rewrite take_drop_app. reflexivity.
  - induction ls.
    + reflexivity.
    + rewrite Forall_cons_iff in H.
      inversion H as [Hhd Htl].
      pose proof (IHls Htl) as Htl2.
      intros.
      cbn.
      rewrite <- app_assoc.
      rewrite Hhd.
      cbn in Htl2.
      rewrite foldl_acc.
      cbn.
      rewrite cons_lexp_tuple.
      rewrite Htl2.
      reflexivity.
  - induction ls.
    + reflexivity.
    + rewrite Forall_cons_iff in H.
      inversion H as [Hhd Htl].
      pose proof (IHls Htl) as Htl2.
      intros.
      cbn.
      rewrite <- app_assoc.
      rewrite Hhd.
      cbn in Htl2.
      rewrite foldl_acc.
      cbn.
      rewrite cons_lexp_vector_concat.
      rewrite Htl2.
      reflexivity.
  - cbn. intros. rewrite <- app_assoc. rewrite IHl. reflexivity.
  - cbn. intros. rewrite <- app_assoc. rewrite IHl. reflexivity.
  - cbn. intros. rewrite IHl. reflexivity.
Qed.

(** The key property is extracting the subexpressions with
[lexp_subexps] then putting them back with [update_lexp_subexps]
returns the original L-expression. *)

Lemma lexp_subexps_identity : ∀ (A : Set) (l : lexp A), update_lexp_subexps (lexp_subexps l) l = (l, []).
Proof.
  intros A l.
  pose proof (lexp_subexps_identity_g A l []) as H.
  rewrite app_nil_r in H.
  assumption.
Qed.

(** Induction rule for expressions. *)

Section exp_ind_g.
  Variables
    (A : Set)
    (P : exp A → Prop)
    (H_block : ∀ xs ann, Forall P xs → P (E_aux (E_block xs) ann))
    (H_id : ∀ id ann, P (E_aux (E_id id) ann))
    (H_lit : ∀ lit ann, P (E_aux (E_lit lit) ann))
    (H_typ : ∀ t x ann, P x → P (E_aux (E_typ t x) ann))
    (H_app : ∀ f xs ann, Forall P xs → P (E_aux (E_app f xs) ann))
    (H_tuple : ∀ xs ann, Forall P xs → P (E_aux (E_tuple xs) ann))
    (H_if : ∀ i t e ann, P i → P t → P e → P (E_aux (E_if i t e) ann))
    (H_loop : ∀ lt measure cond body ann, P cond → P body → P (E_aux (E_loop lt measure cond body) ann))
    (H_for : ∀ id from to amount ord body ann,
      P from → P to → P amount → P body → P (E_aux (E_for id from to amount ord body) ann))
    (H_vector : ∀ xs ann, Forall P xs → P (E_aux (E_vector xs) ann))
    (H_vector_append : ∀ x y ann, P x → P y → P (E_aux (E_vector_append x y) ann))
    (H_list : ∀ xs ann, Forall P xs → P (E_aux (E_list xs) ann))
    (H_cons : ∀ x xs ann, P x → P xs → P (E_aux (E_cons x xs) ann))
    (H_struct : ∀ name fields ann, Forall (λ f, P (fexp_exp f)) fields → P (E_aux (E_struct name fields) ann))
    (H_struct_update : ∀ x fields ann,
      P x → Forall (λ f, P (fexp_exp f)) fields → P (E_aux (E_struct_update x fields) ann))
    (H_field : ∀ x f ann, P x → P (E_aux (E_field x f) ann))
    (H_match : ∀ x arms ann, P x → Forall (MatchArm P) arms → P (E_aux (E_match x arms) ann))
    (H_let : ∀ p x body ann, P x → P body → P (E_aux (E_let p x body) ann))
    (H_assign : ∀ lx x ann, P x → P (E_aux (E_assign lx x) ann))
    (H_sizeof : ∀ n ann, P (E_aux (E_sizeof n) ann))
    (H_return : ∀ x ann, P x → P (E_aux (E_return x) ann))
    (H_exit : ∀ x ann, P x → P (E_aux (E_exit x) ann))
    (H_config : ∀ opt ann, P (E_aux (E_config opt) ann))
    (H_ref : ∀ id ann, P (E_aux (E_ref id) ann))
    (H_throw : ∀ x ann, P (E_aux (E_throw x) ann))
    (H_try : ∀ x arms ann, P x → Forall (MatchArm P) arms → P (E_aux (E_try x arms) ann))
    (H_assert : ∀ x msg ann, P x → P msg → P (E_aux (E_assert x msg) ann))
    (H_var : ∀ lx x body ann, P x → P body → P (E_aux (E_var lx x body) ann))
    (H_undef : ∀ ann, P (E_aux E_undef ann))
    (H_internal_plet : ∀ p x y ann, P x → P y → P (E_aux (E_internal_plet p x y) ann))
    (H_internal_return : ∀ x ann, P x → P (E_aux (E_internal_return x) ann))
    (H_internal_value : ∀ v ann, P (E_aux (E_internal_value v) ann))
    (H_internal_assume : ∀ c x ann, P x → P (E_aux (E_internal_assume c x) ann))
    (H_constraint : ∀ c ann, P (E_aux (E_constraint c) ann)).

  Fixpoint exp_ind_g x : P x.
  Proof using All.
    destruct x as [aux ann].
    destruct aux.
    - apply H_block.
      induction l.
      + trivial.
      + rewrite Forall_cons_iff. easy.
    - apply H_id.
    - apply H_lit.
    - apply H_typ. trivial.
    - apply H_app.
      induction l.
      + trivial.
      + rewrite Forall_cons_iff. easy.
    - apply H_tuple.
      induction l.
      + trivial.
      + rewrite Forall_cons_iff. easy.
    - apply H_if; trivial.
    - apply H_loop; trivial.
    - apply H_for; trivial.
    - apply H_vector.
      induction l.
      + trivial.
      + rewrite Forall_cons_iff. easy.
    - apply H_vector_append; trivial.
    - apply H_list.
      induction l.
      + trivial.
      + rewrite Forall_cons_iff. easy.
    - apply H_cons; trivial.
    - apply H_struct.
      induction l.
      + trivial.
      + rewrite Forall_cons_iff. easy.
    - apply H_struct_update.
      + trivial.
      + induction l.
        * trivial.
        * rewrite Forall_cons_iff. easy.
    - apply H_field; trivial.
    - apply H_match.
      + trivial.
      + induction l.
        * trivial.
        * rewrite Forall_cons_iff.
          split.
          destruct a as [pat_aux].
          destruct pat_aux.
          unfold MatchArm; trivial.
          unfold MatchArm; split; trivial.
          assumption.
    - apply H_let; trivial.
    - apply H_assign; trivial.
    - apply H_sizeof.
    - apply H_return; trivial.
    - apply H_exit; trivial.
    - apply H_config.
    - apply H_ref.
    - apply H_throw; trivial.
    - apply H_try.
      + trivial.
      + induction l.
        * trivial.
        * rewrite Forall_cons_iff.
          split.
          destruct a as [pat_aux].
          destruct pat_aux.
          unfold MatchArm; trivial.
          unfold MatchArm; split; trivial.
          assumption.
    - apply H_assert; trivial.
    - apply H_var; trivial.
    - apply H_undef; trivial.
    - apply H_internal_plet; trivial.
    - apply H_internal_return; trivial.
    - apply H_internal_value.
    - apply H_internal_assume; trivial.
    - apply H_constraint.
  Qed.
End exp_ind_g.

(** Combined induction rule for expressions and l-expressions. *)

Section exp_and_lexp_ind_g.
  Variables
    (A : Set)
    (Q : lexp A → Prop)
    (P : exp A → Prop)
    (H_block : ∀ xs ann, Forall P xs → P (E_aux (E_block xs) ann))
    (H_id : ∀ id ann, P (E_aux (E_id id) ann))
    (H_lit : ∀ lit ann, P (E_aux (E_lit lit) ann))
    (H_typ : ∀ t x ann, P x → P (E_aux (E_typ t x) ann))
    (H_app : ∀ f xs ann, Forall P xs → P (E_aux (E_app f xs) ann))
    (H_tuple : ∀ xs ann, Forall P xs → P (E_aux (E_tuple xs) ann))
    (H_if : ∀ i t e ann, P i → P t → P e → P (E_aux (E_if i t e) ann))
    (H_loop : ∀ lt measure cond body ann, P cond → P body → P (E_aux (E_loop lt measure cond body) ann))
    (H_for : ∀ id from to amount ord body ann,
      P from → P to → P amount → P body → P (E_aux (E_for id from to amount ord body) ann))
    (H_vector : ∀ xs ann, Forall P xs → P (E_aux (E_vector xs) ann))
    (H_vector_append : ∀ x y ann, P x → P y → P (E_aux (E_vector_append x y) ann))
    (H_list : ∀ xs ann, Forall P xs → P (E_aux (E_list xs) ann))
    (H_cons : ∀ x xs ann, P x → P xs → P (E_aux (E_cons x xs) ann))
    (H_struct : ∀ name fields ann, Forall (λ f, P (fexp_exp f)) fields → P (E_aux (E_struct name fields) ann))
    (H_struct_update : ∀ x fields ann,
      P x → Forall (λ f, P (fexp_exp f)) fields → P (E_aux (E_struct_update x fields) ann))
    (H_field : ∀ x f ann, P x → P (E_aux (E_field x f) ann))
    (H_match : ∀ x arms ann, P x → Forall (MatchArm P) arms → P (E_aux (E_match x arms) ann))
    (H_let : ∀ p x body ann, P x → P body → P (E_aux (E_let p x body) ann))
    (H_assign : ∀ lx x ann, Q lx → P x → P (E_aux (E_assign lx x) ann))
    (H_sizeof : ∀ n ann, P (E_aux (E_sizeof n) ann))
    (H_return : ∀ x ann, P x → P (E_aux (E_return x) ann))
    (H_exit : ∀ x ann, P x → P (E_aux (E_exit x) ann))
    (H_config : ∀ opt ann, P (E_aux (E_config opt) ann))
    (H_ref : ∀ id ann, P (E_aux (E_ref id) ann))
    (H_throw : ∀ x ann, P x → P (E_aux (E_throw x) ann))
    (H_try : ∀ x arms ann, P x → Forall (MatchArm P) arms → P (E_aux (E_try x arms) ann))
    (H_assert : ∀ x msg ann, P x → P msg → P (E_aux (E_assert x msg) ann))
    (H_var : ∀ lx x body ann, Q lx → P x → P body → P (E_aux (E_var lx x body) ann))
    (H_undef : ∀ ann, P (E_aux E_undef ann))
    (H_internal_plet : ∀ p x y ann, P x → P y → P (E_aux (E_internal_plet p x y) ann))
    (H_internal_return : ∀ x ann, P x → P (E_aux (E_internal_return x) ann))
    (H_internal_value : ∀ v ann, P (E_aux (E_internal_value v) ann))
    (H_internal_assume : ∀ c x ann, P x → P (E_aux (E_internal_assume c x) ann))
    (H_constraint : ∀ c ann, P (E_aux (E_constraint c) ann))
    (HL_id : ∀ id ann, Q (LE_aux (LE_id id) ann))
    (HL_deref : ∀ x ann, P x → Q (LE_aux (LE_deref x) ann))
    (HL_app : ∀ f xs ann, Forall P xs → Q (LE_aux (LE_app f xs) ann))
    (HL_typ : ∀ typ id ann, Q (LE_aux (LE_typ typ id) ann))
    (HL_tuple : ∀ lxs ann, Forall Q lxs → Q (LE_aux (LE_tuple lxs) ann))
    (HL_vector_concat : ∀ lxs ann, Forall Q lxs → Q (LE_aux (LE_vector_concat lxs) ann))
    (HL_vector : ∀ lx x ann, Q lx → P x → Q (LE_aux (LE_vector lx x) ann))
    (HL_vector_range : ∀ lx x y ann, Q lx → P x → P y → Q (LE_aux (LE_vector_range lx x y) ann))
    (HL_field : ∀ lx f ann, Q lx → Q (LE_aux (LE_field lx f) ann)).

  Fixpoint exp_ind_mutual_g x : P x
  with lexp_ind_mutual_g lx : Q lx.
  Proof using All.
    - {
      destruct x as [aux ann].
      destruct aux.
      - apply H_block.
        induction l.
        + trivial.
        + rewrite Forall_cons_iff. easy.
      - apply H_id.
      - apply H_lit.
      - apply H_typ. trivial.
      - apply H_app.
        induction l.
        + trivial.
        + rewrite Forall_cons_iff. easy.
      - apply H_tuple.
        induction l.
        + trivial.
        + rewrite Forall_cons_iff. easy.
      - apply H_if; trivial.
      - apply H_loop; trivial.
      - apply H_for; trivial.
      - apply H_vector.
        induction l.
        + trivial.
        + rewrite Forall_cons_iff. easy.
      - apply H_vector_append; trivial.
      - apply H_list.
        induction l.
        + trivial.
        + rewrite Forall_cons_iff. easy.
      - apply H_cons; trivial.
      - apply H_struct.
        induction l.
        + trivial.
        + rewrite Forall_cons_iff. easy.
      - apply H_struct_update.
        + trivial.
        + induction l.
          * trivial.
          * rewrite Forall_cons_iff. easy.
      - apply H_field; trivial.
      - apply H_match.
        + trivial.
        + induction l.
          * trivial.
          * rewrite Forall_cons_iff.
            split.
            destruct a as [pat_aux].
            destruct pat_aux.
            unfold MatchArm; trivial.
            unfold MatchArm; split; trivial.
            assumption.
      - apply H_let; trivial.
      - apply H_assign; trivial.
      - apply H_sizeof.
      - apply H_return; trivial.
      - apply H_exit; trivial.
      - apply H_config.
      - apply H_ref.
      - apply H_throw; trivial.
      - apply H_try.
        + trivial.
        + induction l.
          * trivial.
          * rewrite Forall_cons_iff.
            split.
            destruct a as [pat_aux].
            destruct pat_aux.
            unfold MatchArm; trivial.
            unfold MatchArm; split; trivial.
            assumption.
      - apply H_assert; trivial.
      - apply H_var; trivial.
      - apply H_undef; trivial.
      - apply H_internal_plet; trivial.
      - apply H_internal_return; trivial.
      - apply H_internal_value.
      - apply H_internal_assume; trivial.
      - apply H_constraint.
    }
    - {
      destruct lx as [aux ?].
      destruct aux.
      - apply HL_id.
      - apply HL_deref. trivial.
      - apply HL_app.
        induction l.
        + trivial.
        + rewrite Forall_cons_iff.
          easy.
      - apply HL_typ.
      - apply HL_tuple.
        induction l.
        + trivial.
        + rewrite Forall_cons_iff.
          easy.
      - apply HL_vector_concat.
        induction l.
        + trivial.
        + rewrite Forall_cons_iff.
          easy.
      - apply HL_vector; trivial.
      - apply HL_vector_range; trivial.
      - apply HL_field; trivial.
    }
  Qed.
End exp_and_lexp_ind_g.

(** * AST depth

This provides a notion of how 'deep' an AST is (i.e. how deeply nested
the nodes are). The main semantics step function uses this to provide
a termination measure, as it always recurses deeper in the AST, but
due to the complexities of implementing the correct evaluation order,
this cannot be made obviously structural for Rocq (at least without
refactoring the AST type significantly, which we don't want to do, as
it would require changing a huge amount of Sail). *)

Fixpoint depth {A : Set} (x : exp A) {struct x} : nat :=
  let 'E_aux aux _ := x in
  match aux with
  | E_block xs | E_tuple xs | E_app _ xs | E_vector xs | E_list xs =>
      fold_right max 0 (map depth xs) + 1
  | E_return x | E_field x _ | E_throw x => depth x + 1
  | E_assign l x => max (lexp_depth l) (depth x) + 1
  | E_match x arms | E_try x arms =>
      let arm_depths :=
        map (fun arm =>
               match arm with
               | Pat_aux (Pat_exp _ y) _ => depth y
               | Pat_aux (Pat_when _ guard y) _ => max (depth guard) (depth y)
               end
          ) arms in
      max (depth x) (fold_right max 0 arm_depths) + 1
  | E_struct _ fields =>
      let field_depths :=
        map (fun f => let 'FE_aux (FE_fexp _ y) _ := f in depth y) fields
      in
      fold_right max 0 field_depths + 1
  | E_struct_update x fields =>
      let field_depths :=
        map (fun f => let 'FE_aux (FE_fexp _ y) _ := f in depth y) fields
      in
      max (depth x) (fold_right max 0 field_depths) + 1
  | E_let  _ x body => max (depth x) (depth body) + 1
  | E_cons x y => max (depth x) (depth y) + 1
  | E_if i t e => max (depth i) (max (depth t) (depth e)) + 1
  | E_assert x msg => max (depth x) (depth msg) + 1
  | E_for _ from to amount _ body =>
      let f := depth from in
      let t := depth to in
      let a := depth amount in
      let b := depth body in
      fold_right max 0 [f; t; a; b] + 1
  | E_typ _ x => depth x + 1
  | E_loop _ _ cond body => max (depth cond) (depth body) + 1
  | E_vector_append x y => max (depth x) (depth y) + 1
  | E_exit x => depth x + 1
  | E_var l x y => max (lexp_depth l) (max (depth x) (depth y)) + 1
  | E_id _ | E_lit _ | E_sizeof _ | E_constraint _ | E_config _ | E_ref _ | E_undef | E_internal_value _ => 0
  (* Internal constructors we can ignore for now *)
  | E_internal_plet _ _ _ => 0
  | E_internal_return _ => 0
  | E_internal_assume _ _ => 0
  end
with lexp_depth {A : Set} (l : lexp A) {struct l} : nat :=
  let 'LE_aux aux _ := l in
  match aux with
  | LE_deref x => depth x + 1
  | LE_app _ xs => fold_right max 0 (map depth xs) + 1
  | LE_tuple ls
  | LE_vector_concat ls => fold_right max 0 (map lexp_depth ls) + 1
  | LE_vector l n => lexp_depth l + depth n + 1
  | LE_vector_range l n m => lexp_depth l + depth n + depth m + 1
  | LE_field l _ => lexp_depth l + 1
  | LE_id _ | LE_typ _ _ => 0
  end.

Lemma fold_max_app : ∀ xs ys, fold_right max 0 (xs ++ ys) = max (fold_right max 0 xs) (fold_right max 0 ys).
Proof.
  induction xs.
  - reflexivity.
  - cbn.
    intros.
    rewrite (IHxs ys).
    lia.
Qed.

Lemma lexp_subexps_depth : ∀ (A : Set) (l : lexp A),
  fold_right max 0 (map depth (lexp_subexps l)) ≤ lexp_depth l.
Proof.
   intros.
   induction l using lexp_ind_g.
   - reflexivity.
   - cbn. lia.
   - cbn. lia.
   - reflexivity.
   - induction ls.
     + cbn. lia.
     + cbn.
       cbn in IHls.
       rewrite map_app.
       rewrite Forall_cons_iff in H.
       inversion H.
       apply IHls in H1.
       rewrite fold_max_app.
       lia.
   - induction ls.
     + cbn. lia.
     + cbn.
       cbn in IHls.
       rewrite map_app.
       rewrite Forall_cons_iff in H.
       inversion H.
       apply IHls in H1.
       rewrite fold_max_app.
       lia.
   - cbn.
     rewrite map_app.
     rewrite fold_max_app.
     cbn.
     lia.
   - cbn.
     rewrite map_app.
     rewrite fold_max_app.
     cbn.
     lia.
   - cbn. lia.
Qed.
