ReferencesTyping Mutable References
Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
Set Warnings "-deprecated-syntactic-definition".
From Coq Require Import Strings.String.
From Coq Require Import Init.Nat.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.PeanoNat.
From Coq Require Import Lia.
From PLF Require Import Maps.
From PLF Require Import Smallstep.
From Coq Require Import Lists.List. Import Datatypes.
Check length.
Import Nat.
Set Warnings "-deprecated-syntactic-definition".
From Coq Require Import Strings.String.
From Coq Require Import Init.Nat.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.PeanoNat.
From Coq Require Import Lia.
From PLF Require Import Maps.
From PLF Require Import Smallstep.
From Coq Require Import Lists.List. Import Datatypes.
Check length.
Import Nat.
Definitions
Syntax
The basic operations on references are allocation,
dereferencing, and assignment.
- To allocate a reference, we use the ref operator, providing
an initial value for the new cell.
- To read the current value of this cell, we use the
dereferencing operator !.
- To change the value stored in a cell, we use the assignment
operator.
Types
T ::= Nat
| Unit
| T → T
| Ref T
Terms
t ::= ... Terms
| ref t allocation
| !t dereference
| t := t assignment
| l location
Inductive tm : Type :=
(* STLC with numbers: *)
| tm_var : string → tm
| tm_app : tm → tm → tm
| tm_abs : string → ty → tm → tm
| tm_const : nat → tm
| tm_succ : tm → tm
| tm_pred : tm → tm
| tm_mult : tm → tm → tm
| tm_if0 : tm → tm → tm → tm
(* New terms: *)
| tm_unit : tm
| tm_ref : tm → tm
| tm_deref : tm → tm
| tm_assign : tm → tm → tm
| tm_loc : nat → tm.
Declare Custom Entry stlc_ty.
Declare Custom Entry stlc_tm.
Declare Scope stlc_scope.
Notation "x" := x (in custom stlc_ty at level 0, x global) : stlc_scope.
Notation "<{{ x }}>" := x (x custom stlc_ty).
Notation "( t )" := t (in custom stlc_ty at level 0, t custom stlc_ty) : stlc_scope.
Notation "S -> T" := (Ty_Arrow S T) (in custom stlc_ty at level 99, right associativity) : stlc_scope.
Notation "$( t )" := t (in custom stlc_ty at level 0, t constr) : stlc_scope.
Notation "$( x )" := x (in custom stlc_tm at level 0, x constr, only parsing) : stlc_scope.
Notation "x" := x (in custom stlc_tm at level 0, x constr at level 0) : stlc_scope.
Notation "<{ e }>" := e (e custom stlc_tm at level 200) : stlc_scope.
Notation "( x )" := x (in custom stlc_tm at level 0, x custom stlc_tm) : stlc_scope.
Notation "x y" := (tm_app x y) (in custom stlc_tm at level 10, left associativity) : stlc_scope.
Notation "\ x : t , y" :=
(tm_abs x t y) (in custom stlc_tm at level 200, x global,
t custom stlc_ty,
y custom stlc_tm at level 200,
left associativity).
Coercion tm_var : string >-> tm.
Arguments tm_var _%_string.
Notation "'Nat'" := Ty_Nat (in custom stlc_ty at level 0).
Notation "'succ' x" := (tm_succ x) (in custom stlc_tm at level 10,
x custom stlc_tm at level 0) : stlc_scope.
Notation "'pred' x" := (tm_pred x) (in custom stlc_tm at level 10,
x custom stlc_tm at level 0) : stlc_scope.
Notation "x * y" := (tm_mult x y) (in custom stlc_tm at level 95,
right associativity) : stlc_scope.
Notation "'if0' x 'then' y 'else' z" :=
(tm_if0 x y z) (in custom stlc_tm at level 0,
x custom stlc_tm at level 0,
y custom stlc_tm at level 0,
z custom stlc_tm at level 0) : stlc_scope.
Coercion tm_const : nat >-> tm.
Notation "'Unit'" :=
(Ty_Unit) (in custom stlc_ty at level 0) : stlc_scope.
Notation "'unit'" := tm_unit (in custom stlc_tm at level 0) : stlc_scope.
Notation "'Ref' t" :=
(Ty_Ref t) (in custom stlc_ty at level 4).
Notation "'loc' x" := (tm_loc x) (in custom stlc_tm at level 2) : stlc_scope.
Notation "'ref' x" := (tm_ref x) (in custom stlc_tm at level 2) : stlc_scope.
Notation "'!' x " := (tm_deref x) (in custom stlc_tm at level 2) : stlc_scope.
Notation " e1 ':=' e2 " := (tm_assign e1 e2) (in custom stlc_tm at level 21) : stlc_scope.
Open Scope stlc_scope.
(* STLC with numbers: *)
| tm_var : string → tm
| tm_app : tm → tm → tm
| tm_abs : string → ty → tm → tm
| tm_const : nat → tm
| tm_succ : tm → tm
| tm_pred : tm → tm
| tm_mult : tm → tm → tm
| tm_if0 : tm → tm → tm → tm
(* New terms: *)
| tm_unit : tm
| tm_ref : tm → tm
| tm_deref : tm → tm
| tm_assign : tm → tm → tm
| tm_loc : nat → tm.
Declare Custom Entry stlc_ty.
Declare Custom Entry stlc_tm.
Declare Scope stlc_scope.
Notation "x" := x (in custom stlc_ty at level 0, x global) : stlc_scope.
Notation "<{{ x }}>" := x (x custom stlc_ty).
Notation "( t )" := t (in custom stlc_ty at level 0, t custom stlc_ty) : stlc_scope.
Notation "S -> T" := (Ty_Arrow S T) (in custom stlc_ty at level 99, right associativity) : stlc_scope.
Notation "$( t )" := t (in custom stlc_ty at level 0, t constr) : stlc_scope.
Notation "$( x )" := x (in custom stlc_tm at level 0, x constr, only parsing) : stlc_scope.
Notation "x" := x (in custom stlc_tm at level 0, x constr at level 0) : stlc_scope.
Notation "<{ e }>" := e (e custom stlc_tm at level 200) : stlc_scope.
Notation "( x )" := x (in custom stlc_tm at level 0, x custom stlc_tm) : stlc_scope.
Notation "x y" := (tm_app x y) (in custom stlc_tm at level 10, left associativity) : stlc_scope.
Notation "\ x : t , y" :=
(tm_abs x t y) (in custom stlc_tm at level 200, x global,
t custom stlc_ty,
y custom stlc_tm at level 200,
left associativity).
Coercion tm_var : string >-> tm.
Arguments tm_var _%_string.
Notation "'Nat'" := Ty_Nat (in custom stlc_ty at level 0).
Notation "'succ' x" := (tm_succ x) (in custom stlc_tm at level 10,
x custom stlc_tm at level 0) : stlc_scope.
Notation "'pred' x" := (tm_pred x) (in custom stlc_tm at level 10,
x custom stlc_tm at level 0) : stlc_scope.
Notation "x * y" := (tm_mult x y) (in custom stlc_tm at level 95,
right associativity) : stlc_scope.
Notation "'if0' x 'then' y 'else' z" :=
(tm_if0 x y z) (in custom stlc_tm at level 0,
x custom stlc_tm at level 0,
y custom stlc_tm at level 0,
z custom stlc_tm at level 0) : stlc_scope.
Coercion tm_const : nat >-> tm.
Notation "'Unit'" :=
(Ty_Unit) (in custom stlc_ty at level 0) : stlc_scope.
Notation "'unit'" := tm_unit (in custom stlc_tm at level 0) : stlc_scope.
Notation "'Ref' t" :=
(Ty_Ref t) (in custom stlc_ty at level 4).
Notation "'loc' x" := (tm_loc x) (in custom stlc_tm at level 2) : stlc_scope.
Notation "'ref' x" := (tm_ref x) (in custom stlc_tm at level 2) : stlc_scope.
Notation "'!' x " := (tm_deref x) (in custom stlc_tm at level 2) : stlc_scope.
Notation " e1 ':=' e2 " := (tm_assign e1 e2) (in custom stlc_tm at level 21) : stlc_scope.
Open Scope stlc_scope.
Intuitively:
In informal examples, we'll also freely use the extensions
of the STLC developed in the MoreStlc chapter; however, to keep
the proofs small, we won't bother formalizing them again here. (It
would be easy to do so, since there are no very interesting
interactions between those features and references.)
- ref t (formally, ref t) allocates a new reference cell
with the value t and reduces to the location of the newly
allocated cell;
- !t (formally, deref t) reduces to the contents of the
cell referenced by t;
- t1 := t2 (formally, assign t1 t2) assigns t2 to the
cell referenced by t1; and
- l (formally, loc l) is a reference to the cell at location l. We'll discuss locations later.
Typing (Preview)
Gamma |-- t1 ∈ T1 | (T_Ref) |
Gamma |-- ref t1 ∈ Ref T1 |
Gamma |-- t1 ∈ Ref T1 | (T_Deref) |
Gamma |-- !t1 ∈ T1 |
Gamma |-- t1 ∈ Ref T2 | |
Gamma |-- t2 ∈ T2 | (T_Assign) |
Gamma |-- t1 := t2 : Unit |
Values and Substitution
Inductive value : tm → Prop :=
| v_abs : ∀ x T2 t1,
value <{\x:T2, t1}>
| v_nat : ∀ n : nat ,
value <{ n }>
| v_unit :
value <{ unit }>
| v_loc : ∀ l,
value <{ loc l }>.
Hint Constructors value : core.
| v_abs : ∀ x T2 t1,
value <{\x:T2, t1}>
| v_nat : ∀ n : nat ,
value <{ n }>
| v_unit :
value <{ unit }>
| v_loc : ∀ l,
value <{ loc l }>.
Hint Constructors value : core.
Extending substitution to handle the new syntax of terms is
straightforward: substituting in a pointer leaves it
unchanged.
Reserved Notation "'[' x ':=' s ']' t" (in custom stlc_tm at level 5, x global, s custom stlc_tm,
t custom stlc_tm at next level, right associativity).
Fixpoint subst (x : string) (s : tm) (t : tm) : tm :=
match t with
(* pure STLC *)
| tm_var y ⇒
if String.eqb x y then s else t
| <{\y:T, t1}> ⇒
if String.eqb x y then t else <{\y:T, [x:=s] t1}>
| <{t1 t2}> ⇒
<{([x:=s] t1) ([x:=s] t2)}>
(* numbers *)
| tm_const _ ⇒
t
| <{succ t1}> ⇒
<{succ [x := s] t1}>
| <{pred t1}> ⇒
<{pred [x := s] t1}>
| <{t1 × t2}> ⇒
<{ ([x := s] t1) × ([x := s] t2)}>
| <{if0 t1 then t2 else t3}> ⇒
<{if0 [x := s] t1 then [x := s] t2 else [x := s] t3}>
(* unit *)
| <{ unit }> ⇒
<{ unit }>
(* references *)
| <{ ref t1 }> ⇒
<{ ref ([x:=s] t1) }>
| <{ !t1 }> ⇒
<{ !([x:=s] t1) }>
| <{ t1 := t2 }> ⇒
<{ ([x:=s] t1) := ([x:=s] t2) }>
| <{ loc _ }> ⇒
t
end
where "'[' x ':=' s ']' t" := (subst x s t) (in custom stlc_tm) : stlc_scope.
t custom stlc_tm at next level, right associativity).
Fixpoint subst (x : string) (s : tm) (t : tm) : tm :=
match t with
(* pure STLC *)
| tm_var y ⇒
if String.eqb x y then s else t
| <{\y:T, t1}> ⇒
if String.eqb x y then t else <{\y:T, [x:=s] t1}>
| <{t1 t2}> ⇒
<{([x:=s] t1) ([x:=s] t2)}>
(* numbers *)
| tm_const _ ⇒
t
| <{succ t1}> ⇒
<{succ [x := s] t1}>
| <{pred t1}> ⇒
<{pred [x := s] t1}>
| <{t1 × t2}> ⇒
<{ ([x := s] t1) × ([x := s] t2)}>
| <{if0 t1 then t2 else t3}> ⇒
<{if0 [x := s] t1 then [x := s] t2 else [x := s] t3}>
(* unit *)
| <{ unit }> ⇒
<{ unit }>
(* references *)
| <{ ref t1 }> ⇒
<{ ref ([x:=s] t1) }>
| <{ !t1 }> ⇒
<{ !([x:=s] t1) }>
| <{ t1 := t2 }> ⇒
<{ ([x:=s] t1) := ([x:=s] t2) }>
| <{ loc _ }> ⇒
t
end
where "'[' x ':=' s ']' t" := (subst x s t) (in custom stlc_tm) : stlc_scope.
Side Effects and Sequencing
r:=succ(!r); !ras an abbreviation for
(\x:Unit, !r) (r:=succ(!r)).This has the effect of reducing two expressions in order and returning the value of the second. Restricting the type of the first expression to Unit helps the typechecker to catch some silly errors by permitting us to throw away the first value only if it is really guaranteed to be trivial.
r:=succ(!r); r:=succ(!r); r:=succ(!r); r:=succ(!r); !rFormally, we introduce sequencing as a derived form tseq that expands into an abstraction and an application.
Definition x : string := "x".
Definition y : string := "y".
Definition z : string := "z".
Hint Unfold x : core.
Hint Unfold y : core.
Hint Unfold z : core.
Definition tseq t1 t2 :=
<{ (\ x : Unit, t2) t1 }>.
Notation "t1 ; t2" := (tseq t1 t2) (in custom stlc_tm at level 3) : stlc_scope.
Definition y : string := "y".
Definition z : string := "z".
Hint Unfold x : core.
Hint Unfold y : core.
Hint Unfold z : core.
Definition tseq t1 t2 :=
<{ (\ x : Unit, t2) t1 }>.
Notation "t1 ; t2" := (tseq t1 t2) (in custom stlc_tm at level 3) : stlc_scope.
References and Aliasing
let r = ref 5 in let s = r in s := 82; (!r)+1the cell referenced by r will contain the value 82, while the result of the whole expression will be 83. The references r and s are said to be aliases for the same cell.
r := 5; r := !sassigns 5 to r and then immediately overwrites it with s's current value; this has exactly the same effect as the single assignment
r := !sunless we happen to do it in a context where r and s are aliases for the same cell!
let r = ref 0 in let s = r in r := 5; r := !s
Shared State
let c = ref 0 in let incc = \_:Unit, (c := succ (!c); !c) in let decc = \_:Unit, (c := pred (!c); !c) in ...
Objects
newcounter = \_:Unit, let c = ref 0 in let incc = \_:Unit, (c := succ (!c); !c) in let decc = \_:Unit, (c := pred (!c); !c) in {i=incc, d=decc}
let c1 = newcounter unit in let c2 = newcounter unit in // Note that we've allocated two separate storage cells now! let r1 = c1.i unit in let r2 = c2.i unit in r2 // yields 1, not 2!
Exercise: 1 star, standard, optional (store_draw)
Draw (on paper) the contents of the store at the point in execution where the first two lets have finished and the third one is about to begin.
(* FILL IN HERE *)
☐
☐
References to Compound Types
equal = fix (\eq:Nat->Nat->Bool, \m:Nat, \n:Nat, if m=0 then iszero n else if n=0 then false else eq (pred m) (pred n))
newarray = \_:Unit, ref (\n:Nat,0)
lookup = \a:NatArray, \n:Nat, (!a) n
update = \a:NatArray, \m:Nat, \v:Nat, let oldf = !a in a := (\n:Nat, if equal m n then v else oldf n);
Exercise: 2 stars, standard, especially useful (compact_update)
If we defined update more compactly like thisupdate = \a:NatArray, \m:Nat, \v:Nat, a := (\n:Nat, if equal m n then v else (!a) n)would it behave the same?
(* FILL IN HERE *)
(* Do not modify the following line: *)
Definition manual_grade_for_compact_update : option (nat×string) := None.
☐
(* Do not modify the following line: *)
Definition manual_grade_for_compact_update : option (nat×string) := None.
☐
Null References
Garbage Collection
Exercise: 2 stars, standard (type_safety_violation)
Show how this can lead to a violation of type safety.
(* FILL IN HERE *)
(* Do not modify the following line: *)
Definition manual_grade_for_type_safety_violation : option (nat×string) := None.
☐
(* Do not modify the following line: *)
Definition manual_grade_for_type_safety_violation : option (nat×string) := None.
☐
Locations
Stores
We use store_lookup n st to retrieve the value of the reference
cell at location n in the store st. Note that we must give a
default value to nth in case we try looking up an index which is
too large. (In fact, we will never actually do this, but proving
that we don't will require a bit of work.)
To update the store, we use the replace function, which replaces
the contents of a cell at a particular index.
Fixpoint replace {A:Type} (n:nat) (x:A) (l:list A) : list A :=
match l with
| nil ⇒ nil
| h :: t ⇒
match n with
| O ⇒ x :: t
| S n' ⇒ h :: replace n' x t
end
end.
match l with
| nil ⇒ nil
| h :: t ⇒
match n with
| O ⇒ x :: t
| S n' ⇒ h :: replace n' x t
end
end.
As might be expected, we will also need some technical
lemmas about replace; they are straightforward to prove.
Lemma replace_nil : ∀ A n (x:A),
replace n x nil = nil.
Lemma length_replace : ∀ A n x (l:list A),
length (replace n x l) = length l.
Lemma lookup_replace_eq : ∀ l t st,
l < length st →
store_lookup l (replace l t st) = t.
Lemma lookup_replace_neq : ∀ l1 l2 t st,
l1 ≠ l2 →
store_lookup l1 (replace l2 t st) = store_lookup l1 st.
replace n x nil = nil.
Lemma length_replace : ∀ A n x (l:list A),
length (replace n x l) = length l.
Proof with auto.
intros A n x l. generalize dependent n.
induction l; intros n.
destruct n...
destruct n...
simpl. rewrite IHl...
Qed.
intros A n x l. generalize dependent n.
induction l; intros n.
destruct n...
destruct n...
simpl. rewrite IHl...
Qed.
Lemma lookup_replace_eq : ∀ l t st,
l < length st →
store_lookup l (replace l t st) = t.
Proof with auto.
intros l t st.
unfold store_lookup.
generalize dependent l.
induction st as [|t' st']; intros l Hlen.
- (* st = *)
inversion Hlen.
- (* st = t' :: st' *)
destruct l; simpl...
apply IHst'. simpl in Hlen. lia.
Qed.
intros l t st.
unfold store_lookup.
generalize dependent l.
induction st as [|t' st']; intros l Hlen.
- (* st = *)
inversion Hlen.
- (* st = t' :: st' *)
destruct l; simpl...
apply IHst'. simpl in Hlen. lia.
Qed.
Lemma lookup_replace_neq : ∀ l1 l2 t st,
l1 ≠ l2 →
store_lookup l1 (replace l2 t st) = store_lookup l1 st.
Proof with auto.
unfold store_lookup.
induction l1 as [|l1']; intros l2 t st Hneq.
- (* l1 = 0 *)
destruct st.
+ (* st = *) rewrite replace_nil...
+ (* st = _ :: _ *) destruct l2... contradict Hneq...
- (* l1 = S l1' *)
destruct st as [|t2 st2].
+ (* st = *) destruct l2...
+ (* st = t2 :: st2 *)
destruct l2...
simpl; apply IHl1'...
Qed.
unfold store_lookup.
induction l1 as [|l1']; intros l2 t st Hneq.
- (* l1 = 0 *)
destruct st.
+ (* st = *) rewrite replace_nil...
+ (* st = _ :: _ *) destruct l2... contradict Hneq...
- (* l1 = S l1' *)
destruct st as [|t2 st2].
+ (* st = *) destruct l2...
+ (* st = t2 :: st2 *)
destruct l2...
simpl; apply IHl1'...
Qed.
Reduction
(ST_RefValue) | |
ref v / st --> loc |st| / st,v |
t1 / st --> t1' / st' | (ST_Ref) |
ref t1 / st --> ref t1' / st' |
l < |st| | (ST_DerefLoc) |
!(loc l) / st --> lookup l st / st |
t1 / st --> t1' / st' | (ST_Deref) |
!t1 / st --> !t1' / st' |
l < |st| | (ST_Assign) |
loc l := v / st --> unit / replace l v st |
t1 / st --> t1' / st' | (ST_Assign1) |
t1 := t2 / st --> t1' := t2 / st' |
t2 / st --> t2' / st' | (ST_Assign2) |
v1 := t2 / st --> v1 := t2' / st' |
value v2 | (ST_AppAbs) |
(\x:T2,t1) v2 / st --> [x:=v2]t1 / st |
t1 / st --> t1' / st' | (ST_App1) |
t1 t2 / st --> t1' t2 / st' |
value v1 t2 / st --> t2' / st' | (ST_App2) |
v1 t2 / st --> v1 t2' / st' |
t1 / st --> t1' / st' | (ST_Deref) |
!t1 / st --> !t1' / st' |
l < |st| | (ST_DerefLoc) |
!(loc l) / st --> lookup l st / st |
t1 / st --> t1' / st' | (ST_Assign1) |
t1 := t2 / st --> t1' := t2 / st' |
t2 / st --> t2' / st' | (ST_Assign2) |
v1 := t2 / st --> v1 := t2' / st' |
l < |st| | (ST_Assign) |
loc l := v / st --> unit / [l:=v]st |
t1 / st --> t1' / st' | (ST_Ref) |
ref t1 / st --> ref t1' / st' |
(ST_RefValue) | |
ref v / st --> loc |st| / st,v |
Inductive step : tm × store → tm × store → Prop :=
| ST_AppAbs : ∀ x T2 t1 v2 st,
value v2 →
<{ (\x : T2, t1) v2 }> / st --> <{ [x := v2] t1 }> / st
| ST_App1 : ∀ t1 t1' t2 st st',
t1 / st --> t1' / st' →
<{ t1 t2 }> / st --> <{ t1' t2 }> / st'
| ST_App2 : ∀ v1 t2 t2' st st',
value v1 →
t2 / st --> t2' / st' →
<{ v1 t2 }> / st --> <{ v1 t2' }> / st'
(* numbers *)
| ST_SuccNat : ∀ (n : nat) st,
<{ succ n }> / st --> tm_const (S n) / st
| ST_Succ : ∀ t1 t1' st st',
t1 / st --> t1' / st' →
<{ succ t1 }> / st --> <{ succ t1' }> / st'
| ST_PredNat : ∀ (n : nat) st,
<{ pred n }> / st --> tm_const (n - 1) / st
| ST_Pred : ∀ t1 t1' st st',
t1 / st --> t1' / st' →
<{ pred t1 }> / st --> <{ pred t1' }> / st'
| ST_MultNats : ∀ (n1 n2 : nat) st,
<{ n1 × n2 }> / st --> tm_const (n1 × n2) / st
| ST_Mult1 : ∀ t1 t2 t1' st st',
t1 / st --> t1' / st' →
<{ t1 × t2 }> / st --> <{ t1' × t2 }> / st'
| ST_Mult2 : ∀ v1 t2 t2' st st',
value v1 →
t2 / st --> t2' / st' →
<{ v1 × t2 }> / st --> <{ v1 × t2' }> / st'
| ST_If0 : ∀ t1 t1' t2 t3 st st',
t1 / st --> t1' / st' →
<{ if0 t1 then t2 else t3 }> / st --> <{ if0 t1' then t2 else t3 }> / st'
| ST_If0_Zero : ∀ t2 t3 st,
<{ if0 0 then t2 else t3 }> / st --> t2 / st
| ST_If0_Nonzero : ∀ n t2 t3 st,
<{ if0 $(S n) then t2 else t3 }> / st --> t3 / st
(* references *)
| ST_RefValue : ∀ v st,
value v →
<{ ref v }> / st --> <{ loc $(length st) }> / (st ++ v::nil)
| ST_Ref : ∀ t1 t1' st st',
t1 / st --> t1' / st' →
<{ ref t1 }> / st --> <{ ref t1' }> / st'
| ST_DerefLoc : ∀ st l,
l < length st →
<{ !(loc l) }> / st --> <{ $(store_lookup l st) }> / st
| ST_Deref : ∀ t1 t1' st st',
t1 / st --> t1' / st' →
<{ ! t1 }> / st --> <{ ! t1' }> / st'
| ST_Assign : ∀ v l st,
value v →
l < length st →
<{ (loc l) := v }> / st --> <{ unit }> / replace l v st
| ST_Assign1 : ∀ t1 t1' t2 st st',
t1 / st --> t1' / st' →
<{ t1 := t2 }> / st --> <{ t1' := t2 }> / st'
| ST_Assign2 : ∀ v1 t2 t2' st st',
value v1 →
t2 / st --> t2' / st' →
<{ v1 := t2 }> / st --> <{ v1 := t2' }> / st'
where "t '/' st '-->' t' '/' st'" := (step (t,st) (t',st')).
One slightly ugly point should be noted here: In the
ST_RefValue rule, we extend the state by writing st ++ v::nil
rather than the more natural st ++ [v]. The reason for this is
that the notation we've defined for substitution uses square
brackets, which clash with the standard library's notation for
lists.
Hint Constructors step : core.
Definition multistep := (multi step).
Notation "t '/' st '-->*' t' '/' st'" :=
(multistep (t,st) (t',st'))
(at level 40, st at level 39, t' at level 39).
Definition multistep := (multi step).
Notation "t '/' st '-->*' t' '/' st'" :=
(multistep (t,st) (t',st'))
(at level 40, st at level 39, t' at level 39).
Typing
Store typings
Gamma |-- lookup l st : T1 | |
Gamma |-- loc l : Ref T1 |
Gamma; st |-- lookup l st : T1 | |
Gamma; st |-- loc l : Ref T1 |
[\x:Nat, (!(loc 1)) x, \x:Nat, (!(loc 0)) x]
Exercise: 3 stars, standard (cyclic_store)
Can you find a term whose reduction will create this particular cyclic store?
Theorem cyclic_store:
∃ t,
t / nil -->*
<{ unit }> / (<{ \x:Nat, (!(loc 1)) x }> :: <{ \x:Nat, (!(loc 0)) x }> :: nil).
Proof.
(* FILL IN HERE *) Admitted.
☐
∃ t,
t / nil -->*
<{ unit }> / (<{ \x:Nat, (!(loc 1)) x }> :: <{ \x:Nat, (!(loc 0)) x }> :: nil).
Proof.
(* FILL IN HERE *) Admitted.
☐
The store_Tlookup function retrieves the type at a particular
index.
Suppose we are given a store typing ST describing the store
st in which some term t will be reduced. Then we can use
ST to calculate the type of the result of t without ever
looking directly at st. For example, if ST is [Unit,
Unit→Unit], then we can immediately infer that !(loc 1) has
type Unit→Unit. More generally, the typing rule for locations
can be reformulated in terms of store typings like this:
That is, as long as l is a valid location, we can compute the
type of l just by looking it up in ST. Typing is again a
four-place relation, but it is parameterized on a store typing
rather than a concrete store. The rest of the typing rules are
analogously augmented with store typings.
l < |ST| | |
Gamma; ST |-- loc l : Ref (store_Tlookup l ST) |
The Typing Relation
l < |ST| | (T_Loc) |
Gamma; ST |-- loc l : Ref (store_Tlookup l ST) |
Gamma; ST |-- t1 : T1 | (T_Ref) |
Gamma; ST |-- ref t1 : Ref T1 |
Gamma; ST |-- t1 : Ref T1 | (T_Deref) |
Gamma; ST |-- !t1 : T1 |
Gamma; ST |-- t1 : Ref T2 | |
Gamma; ST |-- t2 : T2 | (T_Assign) |
Gamma; ST |-- t1 := t2 : Unit |
Inductive has_type (ST : store_ty) : context → tm → ty → Prop :=
| T_Var : ∀ Gamma x T1,
Gamma x = Some T1 →
<{ Gamma / ST |-- x \in T1 }>
| T_Abs : ∀ Gamma x T1 T2 t1,
<{ x ⊢> T2; Gamma / ST |-- t1 \in T1 }> →
<{ Gamma / ST |-- \x:T2, t1 \in T2 → T1 }>
| T_App : ∀ T1 T2 Gamma t1 t2,
<{ Gamma / ST |-- t1 \in T2 → T1 }> →
<{ Gamma / ST |-- t2 \in T2 }> →
<{ Gamma / ST |-- t1 t2 \in T1 }>
| T_Nat : ∀ Gamma (n : nat),
<{ Gamma / ST |-- n \in Nat }>
| T_Succ : ∀ Gamma t1,
<{ Gamma / ST |-- t1 \in Nat }> →
<{ Gamma / ST |-- succ t1 \in Nat }>
| T_Pred : ∀ Gamma t1,
<{ Gamma / ST |-- t1 \in Nat }> →
<{ Gamma / ST |-- pred t1 \in Nat }>
| T_Mult : ∀ Gamma t1 t2,
<{ Gamma / ST |-- t1 \in Nat }> →
<{ Gamma / ST |-- t2 \in Nat }> →
<{ Gamma / ST |-- t1 × t2 \in Nat }>
| T_If0 : ∀ Gamma t1 t2 t3 T0,
<{ Gamma / ST |-- t1 \in Nat }> →
<{ Gamma / ST |-- t2 \in T0 }> →
<{ Gamma / ST |-- t3 \in T0 }> →
<{ Gamma / ST |-- if0 t1 then t2 else t3 \in T0 }>
| T_Unit : ∀ Gamma,
<{ Gamma / ST |-- unit \in Unit }>
| T_Loc : ∀ Gamma l,
l < length ST →
<{ Gamma / ST |-- (loc l) \in Ref $(store_Tlookup l ST) }>
| T_Ref : ∀ Gamma t1 T1,
<{ Gamma / ST |-- t1 \in T1 }> →
<{ Gamma / ST |-- (ref t1) \in Ref T1 }>
| T_Deref : ∀ Gamma t1 T1,
<{ Gamma / ST |-- t1 \in Ref T1 }> →
<{ Gamma / ST |-- (! t1) \in T1 }>
| T_Assign : ∀ Gamma t1 t2 T2,
<{ Gamma / ST |-- t1 \in Ref T2 }> →
<{ Gamma / ST |-- t2 \in T2 }> →
<{ Gamma / ST |-- (t1 := t2) \in Unit }>
where "<{ Gamma '/' ST '|--' t '∈' T }>" := (has_type ST Gamma t T).
Hint Constructors has_type : core.
Of course, these typing rules will accurately predict the results
of reduction only if the concrete store used during reduction
actually conforms to the store typing that we assume for purposes
of typechecking. This proviso exactly parallels the situation
with free variables in the basic STLC: the substitution lemma
promises that, if Gamma |-- t : T, then we can replace the free
variables in t with values of the types listed in Gamma to
obtain a closed term of type T, which, by the type preservation
theorem will reduce to a final result of type T if it yields
any result at all. We will see below how to formalize an
analogous intuition for stores and store typings.
However, for purposes of typechecking the terms that programmers
actually write, we do not need to do anything tricky to guess what
store typing we should use. Concrete locations arise only in
terms that are the intermediate results of reduction; they are
not in the language that programmers write. Thus, we can simply
typecheck the programmer's terms with respect to the empty store
typing. As reduction proceeds and new locations are created, we
will always be able to see how to extend the store typing by
looking at the type of the initial values being placed in newly
allocated cells; this intuition is formalized in the statement of
the type preservation theorem below.
Properties
Well-Typed Stores
Theorem preservation_wrong1 : ∀ ST T t st t' st',
<{ empty / ST |-- t \in T }> →
t / st --> t' / st' →
<{ empty / ST |-- t' \in T }>.
Abort.
<{ empty / ST |-- t \in T }> →
t / st --> t' / st' →
<{ empty / ST |-- t' \in T }>.
Abort.
If we typecheck with respect to some set of assumptions about the
types of the values in the store and then reduce with respect to
a store that violates these assumptions, the result will be
disaster. We say that a store st is well typed with respect a
store typing ST if the term at each location l in st has the
type at location l in ST. Since only closed terms ever get
stored in locations (why?), it suffices to type them in the empty
context. The following definition of store_well_typed formalizes
this.
Definition store_well_typed (ST:store_ty) (st:store) :=
length ST = length st ∧
(∀ l, l < length st →
<{ empty / ST |-- $(store_lookup l st) \in $(store_Tlookup l ST) }>).
length ST = length st ∧
(∀ l, l < length st →
<{ empty / ST |-- $(store_lookup l st) \in $(store_Tlookup l ST) }>).
Informally, we will write ST |-- st for store_well_typed ST st.
Intuitively, a store st is consistent with a store typing
ST if every value in the store has the type predicted by the
store typing. The only subtle point is the fact that, when
typing the values in the store, we supply the very same store
typing to the typing relation. This allows us to type circular
stores like the one we saw above.
Exercise: 3 stars, standard (store_not_unique)
Can you find a store st, and two different store typings ST1 and ST2 such that both ST1 |-- st and ST2 |-- st?
(* FILL IN HERE *)
Theorem store_not_unique:
∃ st, ∃ ST1, ∃ ST2,
store_well_typed ST1 st ∧
store_well_typed ST2 st ∧
ST1 ≠ ST2.
Proof.
(* FILL IN HERE *) Admitted.
☐
Theorem store_not_unique:
∃ st, ∃ ST1, ∃ ST2,
store_well_typed ST1 st ∧
store_well_typed ST2 st ∧
ST1 ≠ ST2.
Proof.
(* FILL IN HERE *) Admitted.
☐
Theorem preservation_wrong2 : ∀ ST T t st t' st',
<{ empty / ST |-- t \in T }> →
t / st --> t' / st' →
store_well_typed ST st →
<{ empty / ST |-- t' \in T }>.
Abort.
<{ empty / ST |-- t \in T }> →
t / st --> t' / st' →
store_well_typed ST st →
<{ empty / ST |-- t' \in T }>.
Abort.
This statement is fine for all of the reduction rules except
the allocation rule ST_RefValue. The problem is that this rule
yields a store with a larger domain than the initial store, which
falsifies the conclusion of the above statement: if st' includes
a binding for a fresh location l, then l cannot be in the
domain of ST, and it will not be the case that t' (which
definitely mentions l) is typable under ST.
Extending Store Typings
Inductive extends : store_ty → store_ty → Prop :=
| extends_nil : ∀ ST',
extends ST' nil
| extends_cons : ∀ x ST' ST,
extends ST' ST →
extends (x::ST') (x::ST).
Hint Constructors extends : core.
| extends_nil : ∀ ST',
extends ST' nil
| extends_cons : ∀ x ST' ST,
extends ST' ST →
extends (x::ST') (x::ST).
Hint Constructors extends : core.
We'll need a few technical lemmas about extended contexts.
First, looking up a type in an extended store typing yields the
same result as in the original:
Lemma extends_lookup : ∀ l ST ST',
l < length ST →
extends ST' ST →
store_Tlookup l ST' = store_Tlookup l ST.
l < length ST →
extends ST' ST →
store_Tlookup l ST' = store_Tlookup l ST.
Proof with auto.
intros l ST.
generalize dependent l.
induction ST as [|a ST2]; intros l ST' Hlen HST'.
- (* nil *) inversion Hlen.
- (* cons *) unfold store_Tlookup in ×.
destruct ST'.
+ (* ST' = nil *) inversion HST'.
+ (* ST' = a' :: ST'2 *)
inversion HST'; subst.
destruct l as [|l'].
× (* l = 0 *) auto.
× (* l = S l' *) simpl. apply IHST2...
simpl in Hlen; lia.
Qed.
intros l ST.
generalize dependent l.
induction ST as [|a ST2]; intros l ST' Hlen HST'.
- (* nil *) inversion Hlen.
- (* cons *) unfold store_Tlookup in ×.
destruct ST'.
+ (* ST' = nil *) inversion HST'.
+ (* ST' = a' :: ST'2 *)
inversion HST'; subst.
destruct l as [|l'].
× (* l = 0 *) auto.
× (* l = S l' *) simpl. apply IHST2...
simpl in Hlen; lia.
Qed.
Next, if ST' extends ST, the length of ST' is at least that
of ST.
Finally, ST ++ T extends ST, and extends is reflexive.
Preservation, Finally
Definition preservation_theorem := ∀ ST t t' T st st',
<{ empty / ST |-- t \in T }> →
store_well_typed ST st →
t / st --> t' / st' →
∃ ST',
extends ST' ST ∧
<{ empty / ST' |-- t' \in T }> ∧
store_well_typed ST' st'.
<{ empty / ST |-- t \in T }> →
store_well_typed ST st →
t / st --> t' / st' →
∃ ST',
extends ST' ST ∧
<{ empty / ST' |-- t' \in T }> ∧
store_well_typed ST' st'.
Note that the preservation theorem merely asserts that there is
some store typing ST' extending ST (i.e., agreeing with ST
on the values of all the old locations) such that the new term
t' is well typed with respect to ST'; it does not tell us
exactly what ST' is. It is intuitively clear, of course, that
ST' is either ST or else exactly ST ++ T1::nil, where
T1 is the type of the value v1 in the extended store st ++
v1::nil, but stating this explicitly would complicate the statement of
the theorem without actually making it any more useful: the weaker
version above is already in the right form (because its conclusion
implies its hypothesis) to "turn the crank" repeatedly and
conclude that every sequence of reduction steps preserves
well-typedness. Combining this with the progress property, we
obtain the usual guarantee that "well-typed programs never go
wrong."
In order to prove this, we'll need a few lemmas, as usual.
Substitution Lemma
Lemma weakening : ∀ Gamma Gamma' ST t T,
includedin Gamma Gamma' →
<{ Gamma / ST |-- t \in T }> →
<{ Gamma' / ST |-- t \in T }>.
Proof.
intros Gamma Gamma' ST t T H Ht.
generalize dependent Gamma'.
induction Ht; eauto using includedin_update.
Qed.
Lemma weakening_empty : ∀ Gamma ST t T,
<{ empty / ST |-- t \in T }> →
<{ Gamma / ST |-- t \in T }>.
Proof.
intros Gamma ST t T.
eapply weakening.
discriminate.
Qed.
Lemma substitution_preserves_typing : ∀ Gamma ST x U t v T,
<{ x ⊢> U; Gamma / ST |-- t \in T }> →
<{ empty / ST |-- v \in U }> →
<{ Gamma / ST |-- [x:=v]t \in T }>.
includedin Gamma Gamma' →
<{ Gamma / ST |-- t \in T }> →
<{ Gamma' / ST |-- t \in T }>.
Proof.
intros Gamma Gamma' ST t T H Ht.
generalize dependent Gamma'.
induction Ht; eauto using includedin_update.
Qed.
Lemma weakening_empty : ∀ Gamma ST t T,
<{ empty / ST |-- t \in T }> →
<{ Gamma / ST |-- t \in T }>.
Proof.
intros Gamma ST t T.
eapply weakening.
discriminate.
Qed.
Lemma substitution_preserves_typing : ∀ Gamma ST x U t v T,
<{ x ⊢> U; Gamma / ST |-- t \in T }> →
<{ empty / ST |-- v \in U }> →
<{ Gamma / ST |-- [x:=v]t \in T }>.
Proof.
intros Gamma ST x U t v T Ht Hv.
generalize dependent Gamma. generalize dependent T.
induction t; intros T Gamma H;
(* in each case, we'll want to get at the derivation of H *)
inversion H; clear H; subst; simpl; eauto.
- (* var *)
rename s into y. destruct (String.eqb_spec x y); subst.
+ (* x=y *)
rewrite update_eq in H2.
injection H2 as H2; subst.
apply weakening_empty. assumption.
+ (* x<>y *)
apply T_Var. rewrite update_neq in H2; auto.
- (* abs *)
rename s into y.
destruct (String.eqb_spec x y); subst; apply T_Abs.
+ (* x=y *)
rewrite update_shadow in H5. assumption.
+ (* x<>y *)
apply IHt.
rewrite update_permute; auto.
Qed.
intros Gamma ST x U t v T Ht Hv.
generalize dependent Gamma. generalize dependent T.
induction t; intros T Gamma H;
(* in each case, we'll want to get at the derivation of H *)
inversion H; clear H; subst; simpl; eauto.
- (* var *)
rename s into y. destruct (String.eqb_spec x y); subst.
+ (* x=y *)
rewrite update_eq in H2.
injection H2 as H2; subst.
apply weakening_empty. assumption.
+ (* x<>y *)
apply T_Var. rewrite update_neq in H2; auto.
- (* abs *)
rename s into y.
destruct (String.eqb_spec x y); subst; apply T_Abs.
+ (* x=y *)
rewrite update_shadow in H5. assumption.
+ (* x<>y *)
apply IHt.
rewrite update_permute; auto.
Qed.
Assignment Preserves Store Typing
Lemma assign_pres_store_typing : ∀ ST st l t,
l < length st →
store_well_typed ST st →
<{ empty / ST |-- t \in $(store_Tlookup l ST) }> →
store_well_typed ST (replace l t st).
l < length st →
store_well_typed ST st →
<{ empty / ST |-- t \in $(store_Tlookup l ST) }> →
store_well_typed ST (replace l t st).
Proof with auto.
intros ST st l t Hlen HST Ht.
inversion HST; subst.
split. rewrite length_replace...
intros l' Hl'.
destruct (l' =? l) eqn: Heqll'.
- (* l' = l *)
apply eqb_eq in Heqll'; subst.
rewrite lookup_replace_eq...
- (* l' <> l *)
apply eqb_neq in Heqll'.
rewrite lookup_replace_neq...
rewrite length_replace in Hl'.
apply H0...
Qed.
intros ST st l t Hlen HST Ht.
inversion HST; subst.
split. rewrite length_replace...
intros l' Hl'.
destruct (l' =? l) eqn: Heqll'.
- (* l' = l *)
apply eqb_eq in Heqll'; subst.
rewrite lookup_replace_eq...
- (* l' <> l *)
apply eqb_neq in Heqll'.
rewrite lookup_replace_neq...
rewrite length_replace in Hl'.
apply H0...
Qed.
Weakening for Stores
Lemma store_weakening : ∀ Gamma ST ST' t T,
extends ST' ST →
<{ Gamma / ST |-- t \in T }> →
<{ Gamma / ST' |-- t \in T }>.
extends ST' ST →
<{ Gamma / ST |-- t \in T }> →
<{ Gamma / ST' |-- t \in T }>.
We can use the store_weakening lemma to prove that if a store is
well typed with respect to a store typing, then the store extended
with a new term t will still be well typed with respect to the
store typing extended with t's type.
Lemma store_well_typed_app : ∀ ST st t1 T1,
store_well_typed ST st →
<{ empty / ST |-- t1 \in T1 }> →
store_well_typed (ST ++ T1::nil) (st ++ t1::nil).
store_well_typed ST st →
<{ empty / ST |-- t1 \in T1 }> →
store_well_typed (ST ++ T1::nil) (st ++ t1::nil).
Proof with auto.
intros.
unfold store_well_typed in ×.
destruct H as [Hlen Hmatch].
rewrite app_length, add_comm. simpl.
rewrite app_length, add_comm. simpl.
split...
- (* types match. *)
intros l Hl.
unfold store_lookup, store_Tlookup.
apply le_lt_eq_dec in Hl; destruct Hl as [Hlt | Heq].
+ (* l < length st *)
apply <-Nat.succ_lt_mono in Hlt.
rewrite !app_nth1...
× apply store_weakening with ST. apply extends_app.
apply Hmatch...
× rewrite Hlen...
+ (* l = length st *)
injection Heq as Heq; subst.
rewrite app_nth2; try lia.
rewrite <- Hlen.
rewrite sub_diag. simpl.
apply store_weakening with ST...
{ apply extends_app. }
rewrite app_nth2; [|lia].
rewrite sub_diag. simpl. assumption.
Qed.
intros.
unfold store_well_typed in ×.
destruct H as [Hlen Hmatch].
rewrite app_length, add_comm. simpl.
rewrite app_length, add_comm. simpl.
split...
- (* types match. *)
intros l Hl.
unfold store_lookup, store_Tlookup.
apply le_lt_eq_dec in Hl; destruct Hl as [Hlt | Heq].
+ (* l < length st *)
apply <-Nat.succ_lt_mono in Hlt.
rewrite !app_nth1...
× apply store_weakening with ST. apply extends_app.
apply Hmatch...
× rewrite Hlen...
+ (* l = length st *)
injection Heq as Heq; subst.
rewrite app_nth2; try lia.
rewrite <- Hlen.
rewrite sub_diag. simpl.
apply store_weakening with ST...
{ apply extends_app. }
rewrite app_nth2; [|lia].
rewrite sub_diag. simpl. assumption.
Qed.
Preservation!
And here, at last, is the preservation theorem:
Theorem preservation : ∀ ST t t' T st st',
<{ empty / ST |-- t \in T }> →
store_well_typed ST st →
t / st --> t' / st' →
∃ ST',
extends ST' ST ∧
<{ empty / ST' |-- t' \in T }> ∧
store_well_typed ST' st'.
<{ empty / ST |-- t \in T }> →
store_well_typed ST st →
t / st --> t' / st' →
∃ ST',
extends ST' ST ∧
<{ empty / ST' |-- t' \in T }> ∧
store_well_typed ST' st'.
Proof with eauto using store_weakening, extends_refl.
remember empty as Gamma.
intros ST t t' T st st' Ht.
generalize dependent t'.
induction Ht; intros t' HST Hstep;
subst; try solve_by_invert; inversion Hstep; subst;
try (eauto using store_weakening, extends_refl).
(* T_App *)
- (* ST_AppAbs *) ∃ ST.
inversion Ht1; subst.
split; try split... eapply substitution_preserves_typing...
- (* ST_App1 *)
eapply IHHt1 in H0...
destruct H0 as [ST' [Hext [Hty Hsty]]].
∃ ST'...
- (* ST_App2 *)
eapply IHHt2 in H5...
destruct H5 as [ST' [Hext [Hty Hsty]]].
∃ ST'...
- (* T_Succ *)
+ (* ST_Succ *)
eapply IHHt in H0...
destruct H0 as [ST' [Hext [Hty Hsty]]].
∃ ST'...
- (* T_Pred *)
+ (* ST_Pred *)
eapply IHHt in H0...
destruct H0 as [ST' [Hext [Hty Hsty]]].
∃ ST'...
(* T_Mult *)
- (* ST_Mult1 *)
eapply IHHt1 in H0...
destruct H0 as [ST' [Hext [Hty Hsty]]].
∃ ST'...
- (* ST_Mult2 *)
eapply IHHt2 in H5...
destruct H5 as [ST' [Hext [Hty Hsty]]].
∃ ST'...
- (* T_If0 *)
+ (* ST_If0_1 *)
eapply IHHt1 in H0...
destruct H0 as [ST' [Hext [Hty Hsty]]].
∃ ST'. split...
(* T_Ref *)
- (* ST_RefValue *)
∃ (ST ++ T1::nil).
inversion HST; subst.
split.
{ apply extends_app. }
split.
{ replace <{{ Ref T1 }}>
with <{{ Ref $(store_Tlookup (length st) (ST ++ T1::nil)) }}>.
{ apply T_Loc.
rewrite <- H. rewrite app_length, add_comm. simpl. lia. }
unfold store_Tlookup. rewrite <- H. rewrite nth_eq_last.
reflexivity. }
apply store_well_typed_app; assumption.
- (* ST_Ref *)
eapply IHHt in H0...
destruct H0 as [ST' [Hext [Hty Hsty]]].
∃ ST'...
(* T_Deref *)
- (* ST_DerefLoc *)
∃ ST. split; try split...
destruct HST as [_ Hsty].
replace T1 with (store_Tlookup l ST).
apply Hsty...
inversion Ht; subst...
- (* ST_Deref *)
eapply IHHt in H0...
destruct H0 as [ST' [Hext [Hty Hsty]]].
∃ ST'...
(* T_Assign *)
- (* ST_Assign *)
∃ ST. split; try split...
eapply assign_pres_store_typing...
inversion Ht1; subst...
- (* ST_Assign1 *)
eapply IHHt1 in H0...
destruct H0 as [ST' [Hext [Hty Hsty]]].
∃ ST'...
- (* ST_Assign2 *)
eapply IHHt2 in H5...
destruct H5 as [ST' [Hext [Hty Hsty]]].
∃ ST'...
Qed.
remember empty as Gamma.
intros ST t t' T st st' Ht.
generalize dependent t'.
induction Ht; intros t' HST Hstep;
subst; try solve_by_invert; inversion Hstep; subst;
try (eauto using store_weakening, extends_refl).
(* T_App *)
- (* ST_AppAbs *) ∃ ST.
inversion Ht1; subst.
split; try split... eapply substitution_preserves_typing...
- (* ST_App1 *)
eapply IHHt1 in H0...
destruct H0 as [ST' [Hext [Hty Hsty]]].
∃ ST'...
- (* ST_App2 *)
eapply IHHt2 in H5...
destruct H5 as [ST' [Hext [Hty Hsty]]].
∃ ST'...
- (* T_Succ *)
+ (* ST_Succ *)
eapply IHHt in H0...
destruct H0 as [ST' [Hext [Hty Hsty]]].
∃ ST'...
- (* T_Pred *)
+ (* ST_Pred *)
eapply IHHt in H0...
destruct H0 as [ST' [Hext [Hty Hsty]]].
∃ ST'...
(* T_Mult *)
- (* ST_Mult1 *)
eapply IHHt1 in H0...
destruct H0 as [ST' [Hext [Hty Hsty]]].
∃ ST'...
- (* ST_Mult2 *)
eapply IHHt2 in H5...
destruct H5 as [ST' [Hext [Hty Hsty]]].
∃ ST'...
- (* T_If0 *)
+ (* ST_If0_1 *)
eapply IHHt1 in H0...
destruct H0 as [ST' [Hext [Hty Hsty]]].
∃ ST'. split...
(* T_Ref *)
- (* ST_RefValue *)
∃ (ST ++ T1::nil).
inversion HST; subst.
split.
{ apply extends_app. }
split.
{ replace <{{ Ref T1 }}>
with <{{ Ref $(store_Tlookup (length st) (ST ++ T1::nil)) }}>.
{ apply T_Loc.
rewrite <- H. rewrite app_length, add_comm. simpl. lia. }
unfold store_Tlookup. rewrite <- H. rewrite nth_eq_last.
reflexivity. }
apply store_well_typed_app; assumption.
- (* ST_Ref *)
eapply IHHt in H0...
destruct H0 as [ST' [Hext [Hty Hsty]]].
∃ ST'...
(* T_Deref *)
- (* ST_DerefLoc *)
∃ ST. split; try split...
destruct HST as [_ Hsty].
replace T1 with (store_Tlookup l ST).
apply Hsty...
inversion Ht; subst...
- (* ST_Deref *)
eapply IHHt in H0...
destruct H0 as [ST' [Hext [Hty Hsty]]].
∃ ST'...
(* T_Assign *)
- (* ST_Assign *)
∃ ST. split; try split...
eapply assign_pres_store_typing...
inversion Ht1; subst...
- (* ST_Assign1 *)
eapply IHHt1 in H0...
destruct H0 as [ST' [Hext [Hty Hsty]]].
∃ ST'...
- (* ST_Assign2 *)
eapply IHHt2 in H5...
destruct H5 as [ST' [Hext [Hty Hsty]]].
∃ ST'...
Qed.
Exercise: 3 stars, standard (preservation_informal)
Write a careful informal proof of the preservation theorem, concentrating on the T_App, T_Deref, T_Assign, and T_Ref cases.
(* Do not modify the following line: *)
Definition manual_grade_for_preservation_informal : option (nat×string) := None.
☐
Definition manual_grade_for_preservation_informal : option (nat×string) := None.
☐
Progress
Theorem progress : ∀ ST t T st,
<{ empty / ST |-- t \in T }> →
store_well_typed ST st →
(value t ∨ ∃ t' st', t / st --> t' / st').
<{ empty / ST |-- t \in T }> →
store_well_typed ST st →
(value t ∨ ∃ t' st', t / st --> t' / st').
Proof with eauto.
intros ST t T st Ht HST. remember empty as Gamma.
induction Ht; subst; try solve_by_invert...
- (* T_App *)
right. destruct IHHt1 as [Ht1p | Ht1p]...
+ (* t1 is a value *)
inversion Ht1p; subst; try solve_by_invert.
destruct IHHt2 as [Ht2p | Ht2p]...
× (* t2 steps *)
destruct Ht2p as [t2' [st' Hstep]].
∃ <{ (\ x0 : T0, t0) t2' }>, st'...
+ (* t1 steps *)
destruct Ht1p as [t1' [st' Hstep]].
∃ <{ t1' t2 }>, st'...
- (* T_Succ *)
right. destruct IHHt as [Ht1p | Ht1p]...
+ (* t1 is a value *)
inversion Ht1p; subst; try solve [ inversion Ht ].
× (* t1 is a const *)
∃ <{ $(S n) }>, st...
+ (* t1 steps *)
destruct Ht1p as [t1' [st' Hstep]].
∃ <{ succ t1' }>, st'...
- (* T_Pred *)
right. destruct IHHt as [Ht1p | Ht1p]...
+ (* t1 is a value *)
inversion Ht1p; subst; try solve [inversion Ht ].
× (* t1 is a const *)
∃ <{ $(n - 1) }>, st...
+ (* t1 steps *)
destruct Ht1p as [t1' [st' Hstep]].
∃ <{ pred t1' }>, st'...
- (* T_Mult *)
right. destruct IHHt1 as [Ht1p | Ht1p]...
+ (* t1 is a value *)
inversion Ht1p; subst; try solve [inversion Ht1].
destruct IHHt2 as [Ht2p | Ht2p]...
× (* t2 is a value *)
inversion Ht2p; subst; try solve [inversion Ht2].
∃ <{ $(n × n0) }>, st...
× (* t2 steps *)
destruct Ht2p as [t2' [st' Hstep]].
∃ <{ n × t2' }>, st'...
+ (* t1 steps *)
destruct Ht1p as [t1' [st' Hstep]].
∃ <{ t1' × t2 }>, st'...
- (* T_If0 *)
right. destruct IHHt1 as [Ht1p | Ht1p]...
+ (* t1 is a value *)
inversion Ht1p; subst; try solve [inversion Ht1].
destruct n.
× (* n = 0 *) ∃ t2, st...
× (* n = S n' *) ∃ t3, st...
+ (* t1 steps *)
destruct Ht1p as [t1' [st' Hstep]].
∃ <{ if0 t1' then t2 else t3 }>, st'...
- (* T_Ref *)
right. destruct IHHt as [Ht1p | Ht1p]...
+ (* t1 steps *)
destruct Ht1p as [t1' [st' Hstep]].
∃ <{ref t1'}>, st'...
- (* T_Deref *)
right. destruct IHHt as [Ht1p | Ht1p]...
+ (* t1 is a value *)
inversion Ht1p; subst; try solve_by_invert.
eexists. eexists. apply ST_DerefLoc...
inversion Ht; subst. inversion HST; subst.
rewrite <- H...
+ (* t1 steps *)
destruct Ht1p as [t1' [st' Hstep]].
∃ <{ ! t1' }>, st'...
- (* T_Assign *)
right. destruct IHHt1 as [Ht1p|Ht1p]...
+ (* t1 is a value *)
destruct IHHt2 as [Ht2p|Ht2p]...
× (* t2 is a value *)
inversion Ht1p; subst; try solve_by_invert.
eexists. eexists. apply ST_Assign...
inversion HST; subst. inversion Ht1; subst.
rewrite H in H4...
× (* t2 steps *)
destruct Ht2p as [t2' [st' Hstep]].
∃ <{ t1 := t2' }>, st'...
+ (* t1 steps *)
destruct Ht1p as [t1' [st' Hstep]].
∃ <{ t1' := t2 }>, st'...
Qed.
intros ST t T st Ht HST. remember empty as Gamma.
induction Ht; subst; try solve_by_invert...
- (* T_App *)
right. destruct IHHt1 as [Ht1p | Ht1p]...
+ (* t1 is a value *)
inversion Ht1p; subst; try solve_by_invert.
destruct IHHt2 as [Ht2p | Ht2p]...
× (* t2 steps *)
destruct Ht2p as [t2' [st' Hstep]].
∃ <{ (\ x0 : T0, t0) t2' }>, st'...
+ (* t1 steps *)
destruct Ht1p as [t1' [st' Hstep]].
∃ <{ t1' t2 }>, st'...
- (* T_Succ *)
right. destruct IHHt as [Ht1p | Ht1p]...
+ (* t1 is a value *)
inversion Ht1p; subst; try solve [ inversion Ht ].
× (* t1 is a const *)
∃ <{ $(S n) }>, st...
+ (* t1 steps *)
destruct Ht1p as [t1' [st' Hstep]].
∃ <{ succ t1' }>, st'...
- (* T_Pred *)
right. destruct IHHt as [Ht1p | Ht1p]...
+ (* t1 is a value *)
inversion Ht1p; subst; try solve [inversion Ht ].
× (* t1 is a const *)
∃ <{ $(n - 1) }>, st...
+ (* t1 steps *)
destruct Ht1p as [t1' [st' Hstep]].
∃ <{ pred t1' }>, st'...
- (* T_Mult *)
right. destruct IHHt1 as [Ht1p | Ht1p]...
+ (* t1 is a value *)
inversion Ht1p; subst; try solve [inversion Ht1].
destruct IHHt2 as [Ht2p | Ht2p]...
× (* t2 is a value *)
inversion Ht2p; subst; try solve [inversion Ht2].
∃ <{ $(n × n0) }>, st...
× (* t2 steps *)
destruct Ht2p as [t2' [st' Hstep]].
∃ <{ n × t2' }>, st'...
+ (* t1 steps *)
destruct Ht1p as [t1' [st' Hstep]].
∃ <{ t1' × t2 }>, st'...
- (* T_If0 *)
right. destruct IHHt1 as [Ht1p | Ht1p]...
+ (* t1 is a value *)
inversion Ht1p; subst; try solve [inversion Ht1].
destruct n.
× (* n = 0 *) ∃ t2, st...
× (* n = S n' *) ∃ t3, st...
+ (* t1 steps *)
destruct Ht1p as [t1' [st' Hstep]].
∃ <{ if0 t1' then t2 else t3 }>, st'...
- (* T_Ref *)
right. destruct IHHt as [Ht1p | Ht1p]...
+ (* t1 steps *)
destruct Ht1p as [t1' [st' Hstep]].
∃ <{ref t1'}>, st'...
- (* T_Deref *)
right. destruct IHHt as [Ht1p | Ht1p]...
+ (* t1 is a value *)
inversion Ht1p; subst; try solve_by_invert.
eexists. eexists. apply ST_DerefLoc...
inversion Ht; subst. inversion HST; subst.
rewrite <- H...
+ (* t1 steps *)
destruct Ht1p as [t1' [st' Hstep]].
∃ <{ ! t1' }>, st'...
- (* T_Assign *)
right. destruct IHHt1 as [Ht1p|Ht1p]...
+ (* t1 is a value *)
destruct IHHt2 as [Ht2p|Ht2p]...
× (* t2 is a value *)
inversion Ht1p; subst; try solve_by_invert.
eexists. eexists. apply ST_Assign...
inversion HST; subst. inversion Ht1; subst.
rewrite H in H4...
× (* t2 steps *)
destruct Ht2p as [t2' [st' Hstep]].
∃ <{ t1 := t2' }>, st'...
+ (* t1 steps *)
destruct Ht1p as [t1' [st' Hstep]].
∃ <{ t1' := t2 }>, st'...
Qed.
References and Nontermination
(\r:Ref (Unit -> Unit),
r := (\x:Unit,(!r) unit); (!r) unit)
(ref (\x:Unit,unit))
Module ExampleVariables.
Open Scope string_scope.
Definition x := "x".
Definition y := "y".
Definition r := "r".
Definition s := "s".
End ExampleVariables.
Module RefsAndNontermination.
Import ExampleVariables.
Definition loop_fun :=
<{ \x : Unit, (!r) unit }>.
Definition loop :=
<{ (\r : Ref (Unit → Unit), (( r := loop_fun ); ( (! r) unit ) )) (ref (\x : Unit, unit)) }> .
Open Scope string_scope.
Definition x := "x".
Definition y := "y".
Definition r := "r".
Definition s := "s".
End ExampleVariables.
Module RefsAndNontermination.
Import ExampleVariables.
Definition loop_fun :=
<{ \x : Unit, (!r) unit }>.
Definition loop :=
<{ (\r : Ref (Unit → Unit), (( r := loop_fun ); ( (! r) unit ) )) (ref (\x : Unit, unit)) }> .
This term is well typed:
Import ListNotations.
Lemma loop_typeable : ∃ T, <{ empty / [] |-- loop \in T }>.
Lemma loop_typeable : ∃ T, <{ empty / [] |-- loop \in T }>.
Proof with eauto.
eexists. unfold loop. unfold loop_fun.
eapply T_App...
eapply T_Abs...
eapply T_App...
eapply T_Abs. eapply T_App. eapply T_Deref. eapply T_Var.
rewrite update_neq; [|intros; discriminate].
rewrite update_eq. reflexivity. auto.
eapply T_Assign.
eapply T_Var. rewrite update_eq. reflexivity.
eapply T_Abs.
eapply T_App...
eapply T_Deref. eapply T_Var. reflexivity.
Qed.
eexists. unfold loop. unfold loop_fun.
eapply T_App...
eapply T_Abs...
eapply T_App...
eapply T_Abs. eapply T_App. eapply T_Deref. eapply T_Var.
rewrite update_neq; [|intros; discriminate].
rewrite update_eq. reflexivity. auto.
eapply T_Assign.
eapply T_Var. rewrite update_eq. reflexivity.
eapply T_Abs.
eapply T_App...
eapply T_Deref. eapply T_Var. reflexivity.
Qed.
To show formally that the term diverges, we first define the
step_closure of the single-step reduction relation, written
-->+. This is just like the reflexive step closure of
single-step reduction (which we're been writing -->*), except
that it is not reflexive: t -->+ t' means that t can reach
t' by one or more steps of reduction.
Inductive step_closure {X:Type} (R: relation X) : X → X → Prop :=
| sc_one : ∀ (x y : X),
R x y → step_closure R x y
| sc_step : ∀ (x y z : X),
R x y →
step_closure R y z →
step_closure R x z.
Definition multistep1 := (step_closure step).
Notation "t1 '/' st '-->+' t2 '/' st'" :=
(multistep1 (t1,st) (t2,st'))
(at level 40, st at level 39, t2 at level 39).
| sc_one : ∀ (x y : X),
R x y → step_closure R x y
| sc_step : ∀ (x y z : X),
R x y →
step_closure R y z →
step_closure R x z.
Definition multistep1 := (step_closure step).
Notation "t1 '/' st '-->+' t2 '/' st'" :=
(multistep1 (t1,st) (t2,st'))
(at level 40, st at level 39, t2 at level 39).
Now, we can show that the expression loop reduces to the
expression !(loc 0) unit and the size-one store
[r:=(loc 0)]loop_fun.
As a convenience, we introduce a slight variant of the normalize
tactic, called reduce, which tries solving the goal with
multi_refl at each step, instead of waiting until the goal can't
be reduced any more. Of course, the whole point is that loop
doesn't normalize, so the old normalize tactic would just go
into an infinite loop reducing it forever!
Ltac print_goal := match goal with ⊢ ?x ⇒ idtac x end.
Ltac reduce :=
repeat (print_goal; eapply multi_step ;
[ (eauto 10; fail) | compute];
try solve [apply multi_refl]).
Ltac reduce :=
repeat (print_goal; eapply multi_step ;
[ (eauto 10; fail) | compute];
try solve [apply multi_refl]).
Next, we use reduce to show that loop steps to
!(loc 0) unit, starting from the empty store.
Lemma loop_steps_to_loop_fun :
loop / nil -->*
<{ (! (loc 0)) unit }> / cons <{ [r := loc 0] loop_fun }> nil.
Proof.
unfold loop.
reduce.
Qed.
loop / nil -->*
<{ (! (loc 0)) unit }> / cons <{ [r := loc 0] loop_fun }> nil.
Proof.
unfold loop.
reduce.
Qed.
Finally, we show that the latter expression reduces in
two steps to itself!
Lemma loop_fun_step_self :
<{ (! (loc 0)) unit }> / cons <{ [r := loc 0] loop_fun }> nil -->+
<{ (! (loc 0)) unit }> / cons <{ [r := loc 0] loop_fun }> nil.
<{ (! (loc 0)) unit }> / cons <{ [r := loc 0] loop_fun }> nil -->+
<{ (! (loc 0)) unit }> / cons <{ [r := loc 0] loop_fun }> nil.
Exercise: 4 stars, standard (factorial_ref)
Use the above ideas to implement a factorial function in STLC with references. (There is no need to prove formally that it really behaves like the factorial. Just uncomment the example below to make sure it gives the correct result when applied to the argument 4.)
Definition factorial : tm
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.
Lemma factorial_type : <{ empty / nil |-- factorial \in (Nat → Nat) }>.
Proof with eauto.
(* FILL IN HERE *) Admitted.
(* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.
Lemma factorial_type : <{ empty / nil |-- factorial \in (Nat → Nat) }>.
Proof with eauto.
(* FILL IN HERE *) Admitted.
If your definition is correct, you should be able to just
uncomment the example below; the proof should be fully
automatic using the reduce tactic.
(*
Lemma factorial_4 : exists st,
<{ factorial 4 }> / nil -->* tm_const 24 / st.
Proof.
eexists. unfold factorial. reduce.
Qed.
*)
☐
Lemma factorial_4 : exists st,
<{ factorial 4 }> / nil -->* tm_const 24 / st.
Proof.
eexists. unfold factorial. reduce.
Qed.
*)
☐