Library State

Adding State to the Language. Your job is to replace the "cheats" in the

proof of the compiler preservation with an actual proof.
Require Import Eqdep.
Require Import String.
Require Import List.
Require Import Omega.
Require Import Recdef.
Set Implicit Arguments.
Unset Automatic Introduction.
Local Open Scope string_scope.

Abstract Syntax

Definition var := string.

Inductive binop : Set := Plus_op | Minus_op | Eq_op.

Inductive exp : Set :=
| Var_e : var -> exp
| Lam_e : var -> exp -> exp
| App_e : exp -> exp -> exp
| Num_e : nat -> exp
| Binop_e : binop -> exp -> exp -> exp
| Bool_e : bool -> exp
| If_e : exp -> exp -> exp -> exp
| Let_e : var -> exp -> exp -> exp
| Unit_e : exp
| Pair_e : exp -> exp -> exp
| Fst_e : exp -> exp
| Snd_e : exp -> exp
| Ref_e : exp -> exp
| Read_e : exp -> exp
| Write_e : exp -> exp -> exp.

We're going to represent heaps as lists of values, and references as a position in that list.
Definition ref := nat.

Inductive value : Set :=
| Unit_v : value
| Lam_v : list (var * value) -> var -> exp -> value
| Num_v : nat -> value
| Bool_v : bool -> value
| Pair_v : value -> value -> value
| Ref_v : ref -> value.

Definition heap := list value.

Environments

Definition env_t(A:Type) := list (var * A).
Fixpoint lookup A (env:env_t A) (x:var) : option A :=
  match env with
    | nil => None
    | (y,v)::env' => if string_dec x y then Some v else lookup env' x
  end.

Our denotations will be computations. Notice that this time, successful computations return not only a value, but also a heap. Also notice that the continuation of a bind takes a value as well as a heap as arguments, and that our Delayed computations capture the current heap.
Inductive answer : Set :=
| Value : heap -> value -> answer
| TypeError : answer.

Inductive comp :=
| Ret : answer -> comp
| Bind : comp -> (value -> heap -> comp) -> comp
| Delay : exp -> list (var * value) -> heap -> comp.

Notation "'ret' x" := (fun h => Ret (Value h x)) (at level 75) : comp_scope.
Notation "x <- c1 ; c2" := (fun h => Bind (c1 h) (fun x h' => c2 h'))
  (right associativity, at level 84, c1 at next level) : comp_scope.
Local Open Scope comp_scope.
Definition Terr := (fun h:heap => Ret TypeError).

Binop Evaluation

Definition eval_binop(b:binop)(v1 v2:value) : heap -> comp :=
  match b, v1, v2 with
    | Plus_op, Num_v n1, Num_v n2 => ret Num_v (n1+n2)
    | Minus_op, Num_v n1, Num_v n2 => ret Num_v (n1-n2)
    | Eq_op, Num_v n1, Num_v n2 =>
      ret Bool_v (if eq_nat_dec n1 n2 then true else false)
    | _, _, _ => Terr
  end.

We need some operations on heaps to support the Ref_e, Read_e, and Write_e operations.

Allocate a new cell in the heap so it holds the value v, and return its position as a reference.
Definition malloc(v:value)(h:heap) : comp :=
  Ret (Value (List.app h (v::nil)) (Ref_v (length h))).

Fixpoint nth_option (A:Type) (n:nat) (xs:list A) : option A :=
  match n, xs with
    | 0, h::_ => Some h
    | S n, _::t => nth_option n t
    | _, _ => None
  end.

Read out the contents of the reference r from the heap h.
Definition read(r:ref)(h:heap) : comp :=
  match nth_option r h with
    | None => Ret TypeError
    | Some v => Ret (Value h v)
  end.

Fixpoint replace(n:nat)(h:heap)(v:value) : option heap :=
  match n, h with
    | 0, _::t => Some (v::t)
    | S n, h::t =>
      match replace n t v with
        | Some t' => Some (h::t')
        | None => None
      end
    | _, _ => None
  end.

Replace the contents of ref r in heap h with the value v.
Definition write(r:ref)(v:value)(h:heap) : comp :=
  match replace r h v with
    | None => Ret TypeError
    | Some h' => Ret (Value h' Unit_v)
  end.

Our new compiler to computations is pleasantly nice.
Fixpoint compile (e:exp) (env:env_t value) : heap -> comp :=
  match e return heap -> comp with
    | Var_e x =>
      match lookup env x with
        | None => Terr
        | Some v => ret v
      end
    | Lam_e x e => ret (Lam_v env x e)
    | App_e e1 e2 =>
      v1 <- compile e1 env ;
      v2 <- compile e2 env ;
      match v1 with
        | Lam_v env' x e' => Delay e' ((x,v2)::env')
        | _ => Terr
      end
    | Num_e n => ret Num_v n
    | Binop_e b e1 e2 =>
      v1 <- compile e1 env ;
      v2 <- compile e2 env ;
      eval_binop b v1 v2
    | Bool_e b => ret Bool_v b
    | If_e e1 e2 e3 =>
      v1 <- compile e1 env ;
      match v1 with
        | Bool_v b =>
          if b then compile e2 env else compile e3 env
        | _ => Terr
      end
    | Let_e x e1 e2 =>
      v1 <- compile e1 env ;
      compile e2 ((x,v1)::env)
    | Unit_e => ret Unit_v
    | Pair_e e1 e2 =>
      v1 <- compile e1 env ;
      v2 <- compile e2 env ;
      ret (Pair_v v1 v2)
    | Fst_e e =>
      v <- compile e env ;
      match v with
        | Pair_v v1 v2 => ret v1
        | _ => Terr
      end
    | Snd_e e =>
      v <- compile e env ;
      match v with
        | Pair_v v1 v2 => ret v2
        | _ => Terr
      end
    | Ref_e e => v <- compile e env ; malloc v
    | Read_e e =>
      v <- compile e env ;
      match v with
        | Ref_v r => read r
        | _ => Terr
      end
    | Write_e e1 e2 =>
      v1 <- compile e1 env ;
      v2 <- compile e2 env ;
      match v1 with
        | Ref_v r => write r v2
        | _ => Terr
      end
  end.

Implicit Arguments inl [A B].
Implicit Arguments inr [A B].
Fixpoint step_fn(c:comp) : comp + answer :=
  match c with
    | Ret a => inr a
    | Delay e env h => inl (compile e env h)
    | Bind c1 f =>
      match step_fn c1 with
        | inl c2 => inl (Bind c2 f)
        | inr (Value h v) => inl (f v h)
        | inr TypeError => inl (Ret TypeError)
      end
  end.

Now we can define the 1-step evaluation relation in terms of the step function.
Definition step1(c1 c2:comp) : Prop := step_fn c1 = inl c2.

And we can define the steps relations as the reflexive, transitive closure of the 1-step relation.
Require Import Relation_Operators.
Definition steps := clos_refl_trans comp step1.
Hint Constructors clos_refl_trans : evals_db.

Notation "c1 '==>1' c2" := (step1 c1 c2) (at level 80) : evals_scope.
Notation "c1 '==>*' c2" := (steps c1 c2) (at level 80) : evals_scope.
Local Open Scope evals_scope.

Typing


We add reference types.
Definition tvar := nat.
Inductive type : Set :=
| Tvar_t : tvar -> type
| Unit_t : type
| Nat_t : type
| Bool_t : type
| Arrow_t : type -> type -> type
| Pair_t : type -> type -> type
| Ref_t : type -> type.

Reserved Notation "G |-- e ; t" (at level 80).

The typing judgment on expressions is largely the same.
Inductive hasType : env_t type -> exp -> type -> Prop :=
| Var_ht : forall G x t,
    lookup G x = Some t ->
      G |-- Var_e x ; t
| Lam_ht : forall G x e t1 t2,
    ((x,t1)::G) |-- e ; t2 ->
      G |-- Lam_e x e ; Arrow_t t1 t2
| App_ht : forall G e1 e2 t1 t2,
    G |-- e1 ; (Arrow_t t1 t2) ->
    G |-- e2 ; t1 ->
      G |-- App_e e1 e2 ; t2
| Num_ht : forall G n,
    G |-- Num_e n ; Nat_t
| Binop_ht : forall G b e1 e2,
    G |-- e1 ; Nat_t ->
    G |-- e2 ; Nat_t ->
      G |-- Binop_e b e1 e2 ; match b with | Eq_op => Bool_t | _ => Nat_t end
| Bool_ht : forall G b,
    G |-- Bool_e b ; Bool_t
| If_ht : forall G e1 e2 e3 t,
    G |-- e1 ; Bool_t ->
    G |-- e2 ; t ->
    G |-- e3 ; t ->
      G |-- If_e e1 e2 e3 ; t
| Let_ht : forall G x e1 e2 t1 t2,
    G |-- e1 ; t1 -> ((x,t1)::G) |-- e2 ; t2 -> G |-- Let_e x e1 e2 ; t2
| Unit_ht : forall G, G |-- Unit_e ; Unit_t
| Pair_ht : forall G e1 e2 t1 t2,
    G |-- e1 ; t1 -> G |-- e2 ; t2 -> G |-- Pair_e e1 e2 ; Pair_t t1 t2
| Fst_ht : forall G e t1 t2,
    G |-- e ; Pair_t t1 t2 -> G |-- Fst_e e ; t1
| Snd_ht : forall G e t1 t2,
    G |-- e ; Pair_t t1 t2 -> G |-- Snd_e e ; t2
| Ref_ht : forall G e t,
    G |-- e ; t -> G |-- Ref_e e ; Ref_t t
| Read_ht : forall G e t,
    G |-- e ; Ref_t t -> G |-- Read_e e ; t
| Write_ht : forall G e1 e2 t,
    G |-- e1 ; Ref_t t -> G |-- e2 ; t -> G |-- Write_e e1 e2 ; Unit_t
where "G |-- e ; t" := (hasType G e t) : typing_scope.
Local Open Scope typing_scope.
Hint Constructors hasType : type_db.

Heap, Value, Environment, and Answer Typing


The type of a heap is the list of types of the values in the heap.
Definition heap_type := list type.

Values now include references, and we need to make sure that the reference holds a value of the type that we claim it should. Consequently, the valType and envType judgments take an extra argument which describes the type of the heap.
Inductive valType : heap_type -> value -> type -> Prop :=
| Unit_vt : forall HT, valType HT Unit_v Unit_t
| Num_vt : forall HT n, valType HT (Num_v n) Nat_t
| Bool_vt : forall HT b, valType HT (Bool_v b) Bool_t
| Lam_vt : forall env x e HT G t1 t2,
  envType HT env G ->
  (x,t1)::G |-- e ; t2 ->
    valType HT (Lam_v env x e) (Arrow_t t1 t2)
| Pair_vt : forall HT v1 v2 t1 t2,
  valType HT v1 t1 -> valType HT v2 t2 -> valType HT (Pair_v v1 v2) (Pair_t t1 t2)
| Ref_vt : forall HT n t, nth_option n HT = Some t -> valType HT (Ref_v n) (Ref_t t)
with envType : heap_type -> env_t value -> env_t type -> Prop :=
| Nil_et : forall HT, envType HT nil nil
| Cons_et : forall HT x v t env G,
  valType HT v t ->
  envType HT env G ->
  envType HT ((x,v)::env) ((x,t)::G).

This time, we're going to need the refined induction scheme.
Scheme valType_ind_2 := Induction for valType Sort Prop
  with envType_ind_2 := Induction for envType Sort Prop.
Combined Scheme valenvType_ind from valType_ind_2, envType_ind_2.

To check that a heap h has type HT, we first assume that all of the references have types as ascribed by HT, and then check that all of the values in the heap have the types we ascribed them. This sort of "circular" reasoning is what allows us to have cycles in the heap. Try removing this and see what breaks.
Local Open Scope list_scope.
Inductive heapType : heap_type -> heap -> heap_type -> Prop :=
| Nil_ht : forall HT, heapType HT nil nil
| Cons_ht : forall HT v t h HT',
  valType HT v t -> heapType HT h HT' -> heapType HT (h ++ v::nil) (HT' ++ t::nil).

Definition hType h HT := heapType HT h HT.

Hint Constructors valType envType heapType : type_db.

Local Open Scope list_scope.

A successful answer is described by both a heap type and a type for the heap and value carried by the answer.
Inductive ansType : answer -> heap_type -> type -> Prop :=
| Val_ans : forall h v HT t,
  hType h HT -> valType HT v t -> ansType (Value h v) HT t.
Hint Constructors ansType : type_db.

Typing for computations: The type for Bind is considerably more complicated than before. This is because we must allow for the heap to grow when we run intermediate computations, but we must also make sure that we don't invalidate typing assumptions about the existing world.

More abstractly, we can think of a computation as transporting us from one world (a heap) to another world (a new heap, with a possibly larger domain). The accessible worlds have an important invariant: the type of a location in the heap doesn't change, so that once we can show a value has type Ref_t t in one world, we can assume it continues to have that type in all accessible worlds.

So the way to read the Bind_ct rule is that if c is a computation that demands a heap satisfying HT, then after we run it, we'll be in some world that extends HT with some possible new locations HTc. So that's what we assume before we run the continuation f. While we run f, we may allocate more locations, hence the requirement that the final heap extends HT ++ HTc. Note that this ensures that once we are done running f, all of the locations in the heap that were around before f have the same types.
Inductive compType : comp -> heap_type -> type -> Prop :=
| Ret_ct : forall a HT t, ansType a HT t -> compType (Ret a) HT t
| Delay_ct : forall e env G t h HT,
  hType h HT -> envType HT env G -> G |-- e ; t -> compType (Delay e env h) HT t
| Bind_ct : forall c f HT t1 t,
  compType c HT t1 ->
  (forall HTc h v, ansType (Value h v) (HT ++ HTc) t1 ->
    exists HTf, compType (f v h) (HT ++ HTc ++ HTf) t) ->
  compType (Bind c f) HT t.

Hint Constructors compType : type_db.

Ltac mysimp :=
  match goal with
    | [ H : (if string_dec ?x1 ?x2 then _ else _) = Some _ |- _ ] =>
      destruct (string_dec x1 x2) ; subst
    | [ H : _ /\ _ |- _ ] => destruct H
    | [ H : exists _,_ |- _ ] => destruct H
    | [ H : Some _ = Some _ |- _ ] => injection H ; clear H ; intros ; subst
    | [ H : None = Some _ |- _ ] => congruence
    | [ H : Some _ = None |- _ ] => congruence
    | [ |- forall _, _ ] => intros
    | [ |- _ /\ _ ] => split
    | _ => eauto with type_db
  end.

As before, proving progress is trivial for our little language.
Lemma progress c HT t :
  compType c HT t ->
  (exists h, exists v, c = Ret (Value h v)) \/ (exists c', c ==>1 c').
Proof.
  unfold step1 ; induction 1 ; simpl. inversion H. subst. left ; eauto.
  right. eauto. right. destruct IHcompType. repeat mysimp. subst. simpl. eauto.
  destruct H1. rewrite H1. eauto.
Qed.

To prove preservation, we're going to need to show that both values and environments retain their types as we are transported to future worlds (i.e., heaps with a bigger domain but otherwise with the same types for the locations.) Here, we must take advantage of the simultaneous induction principle we derived for both values and environments to prove the result.
Lemma ht_weaken_value HT v t :
  valType HT v t -> forall HT', valType (HT ++ HT') v t.
Proof.
  intros.
  apply (valType_ind_2
    (fun HT v t (H:valType HT v t) => forall HT', valType (HT ++ HT') v t)
    (fun HT env G (H:envType HT env G) => forall HT', envType (HT ++ HT') env G)) ;
  intros ; eauto with type_db.
  assert (nth_option n (HT0 ++ HT'0) = Some t0).
  generalize n HT0 e. clear H HT v t HT' HT0 n e.
  induction n ; destruct HT0 ; simpl in * ; repeat mysimp.
  eauto with type_db.
Qed.
Hint Resolve ht_weaken_value : type_db.

Lemma ht_weaken_env HT env G :
  envType HT env G -> forall HT', envType (HT ++ HT') env G.
Proof.
  induction 1 ; eauto with type_db.
Qed.
Hint Resolve ht_weaken_env : type_db.

Lemma lookup_env HT env G x t:
  envType HT env G -> lookup G x = Some t ->
  match lookup env x with
    | Some v => valType HT v t
    | None => False
  end.
Proof.
  induction 1 ; simpl ; intros ; try congruence ; repeat mysimp.
  specialize (IHenvType H1). auto.
Qed.
Hint Resolve lookup_env : type_db.

Here is a little lemma that shows that adding a new value to the end of the heap transports us to a world that preserves the old heap.
Lemma ht_malloc H0 h H:
  heapType H0 h H ->
  forall v t,
  valType H0 v t ->
  heapType (H0 ++ t::nil) (h ++ v::nil) (H ++ t::nil).
Proof.
  intros. eapply Cons_ht. eauto with type_db.
  induction H1 ; eauto with type_db.
Qed.
Hint Resolve ht_malloc : type_db.

I defined this to put some "holes" in the proof of compiler preservation below. You should get rid of it!
Axiom cheat : forall P : Prop, P.

The compiler preserves types. At least we hope it does -- you need to fill in (and hopefully "Adam"-ize) the proof. Warning: I haven't done the whole thing, so am not sure that it's setup correctly.
Lemma CompPreserves : forall G e t, G |-- e ; t ->
  forall HT env h,
    envType HT env G ->
    hType h HT ->
      compType (compile e env h) HT t.
Proof.
  induction 1 ; simpl ; intros ; subst ; mysimp.
  generalize (lookup_env _ H0 H). destruct (lookup env x) ; try tauto. intro.
  eauto with type_db.

  specialize (IHhasType1 _ _ _ H1 H2). econstructor ; eauto.
  clear IHhasType1 H H2. intros. generalize (ht_weaken_env H1 HTc).
  intros. inversion H. subst. clear H. inversion H8 ; subst ; clear H8.
  specialize (IHhasType2 _ _ _ H2 H5).
  exists nil. rewrite <- app_nil_end. econstructor ; eauto with type_db.
  intros. exists nil. rewrite <- app_nil_end. inversion H ; subst ; clear H.
  econstructor ; eauto. econstructor. eauto. eauto with type_db.

  eapply cheat.
  eapply cheat.
  eapply cheat.
  eapply cheat.
  eapply cheat.
  eapply cheat.

  specialize (IHhasType _ _ _ H0 H1). econstructor ; eauto. intros.
  inversion H2 ; subst ; clear H2. unfold malloc. exists (t::nil).
  econstructor. econstructor. unfold hType. rewrite app_assoc.
  eapply ht_malloc ; eauto. eapply cheat.

  specialize (IHhasType _ _ _ H0 H1). econstructor ; eauto. intros.
  inversion H2 ; subst ; clear H2 IHhasType H0 H1. exists nil.
  rewrite <- app_nil_end. inversion H8. subst ; clear H8. unfold read.
  eapply cheat.

  specialize (IHhasType1 _ _ _ H1 H2). econstructor ; eauto.
  clear IHhasType1 H2. intros. inversion H2. subst ; clear H2.
  specialize (IHhasType2 _ _ _ (ht_weaken_env H1 _) H5). exists nil.
  inversion H8. subst. clear H8. rewrite <- app_nil_end.
  econstructor ; eauto. clear IHhasType2. intros. exists nil.
  rewrite <- app_nil_end. unfold write. eapply cheat.
Qed.

A small step using the step_fn preserves types
Lemma Step1Preserves' : forall c HT t,
  compType c HT t ->
  match step_fn c with
    | inl c' => exists HT', compType c' (HT ++ HT') t
    | inr a => ansType a HT t
  end.
Proof.
  induction 1 ; simpl. auto. exists nil ; rewrite <- app_nil_end.
  eapply CompPreserves ; eauto.
  remember (step_fn c) as x. destruct x. destruct IHcompType.
  econstructor. econstructor. eauto. intros. rewrite app_ass in H2.
  specialize (H0 _ _ _ H2). destruct H0. rewrite app_ass in H0.
  exists x0. rewrite app_ass. auto. inversion IHcompType. subst.
  specialize (H0 nil h v). rewrite <- app_nil_end in H0.
  specialize (H0 IHcompType). destruct H0. exists (nil ++ x). auto.
Qed.

A small step using step_fn preserves types
Lemma Step1Preserves : forall c c',
  c ==>1 c' -> forall HT t, compType c HT t -> exists HT', compType c' (HT ++ HT') t.
Proof.
  unfold step1. intros. generalize (Step1Preserves' H0). rewrite H. auto.
Qed.

The reflexive/transitive closure of the step relation preserves types.
Lemma StepsPreserves : forall c c' t, c ==>* c' ->
  forall HT, compType c HT t -> exists HT', compType c' (HT ++ HT') t.
Proof.
  induction 1 ; intros ; auto. eapply Step1Preserves ; eauto. exists nil.
  rewrite <- app_nil_end. auto. destruct (IHclos_refl_trans1 _ H1).
  destruct (IHclos_refl_trans2 _ H2). rewrite app_ass in H3.
  exists (x0 ++ x1). auto.
Qed.