Commit 0816e06e authored by Raphaël Monat's avatar Raphaël Monat

new typing done with heiko

/ ! \ not compiling
parent 1ace1fdf
...@@ -14,6 +14,12 @@ Inductive cmd (V:Type) :Type := ...@@ -14,6 +14,12 @@ Inductive cmd (V:Type) :Type :=
Let: mType -> nat -> exp V -> cmd V -> cmd V Let: mType -> nat -> exp V -> cmd V -> cmd V
| Ret: exp V -> cmd V. | Ret: exp V -> cmd V.
Fixpoint getRetExp (V:Type) (f:cmd V) :=
match f with
|Let m x e g => getRetExp g
| Ret e => e
end.
Fixpoint toRCmd (f:cmd Q) := Fixpoint toRCmd (f:cmd Q) :=
match f with match f with
...@@ -46,15 +52,27 @@ Inductive sstep : cmd R -> env -> R -> cmd R -> env -> Prop := ...@@ -46,15 +52,27 @@ Inductive sstep : cmd R -> env -> R -> cmd R -> env -> Prop :=
Define big step semantics for the Daisy language, terminating on a "returned" Define big step semantics for the Daisy language, terminating on a "returned"
result value result value
**) **)
(* meaning of this -> mType ??? *)
(* Inductive bstep : cmd R -> env -> R -> mType -> Prop := *)
(* let_b m x e s E v res: *)
(* eval_exp E e v m -> *)
(* bstep s (updEnv x m v E) res m -> *)
(* bstep (Let m x e s) E res m *)
(* |ret_b m e E v: *)
(* eval_exp E e v m -> *)
(* bstep (Ret e) E v m. *)
Inductive bstep : cmd R -> env -> R -> mType -> Prop := Inductive bstep : cmd R -> env -> R -> mType -> Prop :=
let_b m x e s E v res: let_b m m' x e s E v res:
eval_exp E e v m -> eval_exp E e v m ->
bstep s (updEnv x m v E) res m -> bstep s (updEnv x m v E) res m' ->
bstep (Let m x e s) E res m bstep (Let m x e s) E res m'
|ret_b m e E v: |ret_b m e E v:
eval_exp E e v m -> eval_exp E e v m ->
bstep (Ret e) E v m. bstep (Ret e) E v m.
(** (**
The free variables of a command are all used variables of expressions The free variables of a command are all used variables of expressions
without the let bound variables without the let bound variables
......
...@@ -2665,7 +2665,10 @@ Qed. ...@@ -2665,7 +2665,10 @@ Qed.
Fixpoint typeExpressionCmd (f:cmd Q) (f':exp Q) : option mType := Fixpoint typeExpressionCmd (f:cmd Q) (f':exp Q) : option mType :=
match f with match f with
|Let m n e c => if expEqBool f' (Var Q m n) then |Let m n e c => if expEqBool f' (Var Q m n) then
Some m match typeExpression e f' with
|None => None
|Some m1 => if mTypeEqBool m1 m then Some m else None
end
else else
let te := typeExpression e in let te := typeExpression e in
let tc := typeExpressionCmd c in let tc := typeExpressionCmd c in
...@@ -2678,6 +2681,29 @@ Fixpoint typeExpressionCmd (f:cmd Q) (f':exp Q) : option mType := ...@@ -2678,6 +2681,29 @@ Fixpoint typeExpressionCmd (f:cmd Q) (f':exp Q) : option mType :=
|Ret e => (typeExpression e) f' |Ret e => (typeExpression e) f'
end. end.
(* Lemma soundnessTypeCmd f n m0 m1 fV dV oV: *)
(* ssaPrg f (NatSet.union fV dV) oV -> *)
(* (typeExpressionCmd f) (Var Q m1 n) = Some m1 -> *)
(* (typeExpressionCmd f) (Var Q m0 n) = Some m0 -> *)
(* m1 = m0. *)
(* Proof. *)
(* revert f; induction f; intros. *)
(* - simpl in H0,H1. *)
(* case_eq (n =? n0); intros; rewrite H2 in H0, H1. *)
(* + admit. *)
(* + rewrite andb_false_r in H0, H1. *)
(* case_eq (typeExpression e (Var Q m1 n)); intros; case_eq (typeExpression e (Var Q m0 n)); intros; rewrite H3 in H0; rewrite H4 in H1. *)
(* * case_eq (typeExpressionCmd f (Var Q m1 n)); intros; case_eq (typeExpressionCmd f (Var Q m0 n)); intros; rewrite H5 in H0; rewrite H6 in H1. *)
(* { *)
(* } *)
(* case_eq (mTypeEqBool m1 m); intros; case_eq (mTypeEqBool m0 m); intros; rewrite H3 in H0; rewrite H in H1. *)
(* + *)
Fixpoint cmdEqBool (f f': cmd Q): bool := Fixpoint cmdEqBool (f f': cmd Q): bool :=
match f, f' with match f, f' with
|Let m1 n1 e1 c1, Let m2 n2 e2 c2 => |Let m1 n1 e1 c1, Let m2 n2 e2 c2 =>
...@@ -2696,7 +2722,8 @@ Fixpoint isSubCmd (f':cmd Q) (f:cmd Q): bool := ...@@ -2696,7 +2722,8 @@ Fixpoint isSubCmd (f':cmd Q) (f:cmd Q): bool :=
Theorem validErrorboundCmd_sound (f:cmd Q) (absenv:analysisResult): Theorem validErrorboundCmd_sound (f:cmd Q) (absenv:analysisResult):
forall E1 E2 outVars fVars dVars vR vF elo ehi err P m, forall E1 E2 outVars fVars dVars vR vF elo ehi err P m tEnv,
tEnv = typeExpressionCmd f ->
approxEnv E1 absenv fVars dVars E2 -> approxEnv E1 absenv fVars dVars E2 ->
ssaPrg f (NatSet.union fVars dVars) outVars -> ssaPrg f (NatSet.union fVars dVars) outVars ->
NatSet.Subset (NatSet.diff (Commands.freeVars f) dVars) fVars -> NatSet.Subset (NatSet.diff (Commands.freeVars f) dVars) fVars ->
...@@ -2704,8 +2731,8 @@ Theorem validErrorboundCmd_sound (f:cmd Q) (absenv:analysisResult): ...@@ -2704,8 +2731,8 @@ Theorem validErrorboundCmd_sound (f:cmd Q) (absenv:analysisResult):
bstep (toRCmd f) E2 vF m -> bstep (toRCmd f) E2 vF m ->
validErrorboundCmd f (* (typeExpressionCmd f) *) absenv dVars = true -> validErrorboundCmd f (* (typeExpressionCmd f) *) absenv dVars = true ->
validIntervalboundsCmd f absenv P dVars = true -> validIntervalboundsCmd f absenv P dVars = true ->
(forall e1 v1 m1, NatSet.mem v1 dVars = true -> (forall v1 m1, NatSet.mem v1 dVars = true ->
(typeExpressionCmd e1) (Var Q m1 v1) = Some m1 -> tEnv (Var Q m1 v1) = Some m1 ->
exists vR, E1 v1 = Some (vR, M0) /\ exists vR, E1 v1 = Some (vR, M0) /\
(Q2R (fst (fst (absenv (Var Q m1 v1)))) <= vR <= Q2R (snd (fst (absenv (Var Q m1 v1)))))%R) -> (Q2R (fst (fst (absenv (Var Q m1 v1)))) <= vR <= Q2R (snd (fst (absenv (Var Q m1 v1)))))%R) ->
(forall v, NatSet.mem v fVars= true -> (forall v, NatSet.mem v fVars= true ->
...@@ -2715,7 +2742,7 @@ Theorem validErrorboundCmd_sound (f:cmd Q) (absenv:analysisResult): ...@@ -2715,7 +2742,7 @@ Theorem validErrorboundCmd_sound (f:cmd Q) (absenv:analysisResult):
(Rabs (vR - vF) <= (Q2R err))%R. (Rabs (vR - vF) <= (Q2R err))%R.
Proof. Proof.
induction f; induction f;
intros * (*type_f*) approxc1c2 ssa_f freeVars_subset eval_real eval_float (*issubcmd_ok*) valid_bounds valid_intv fVars_sound P_valid absenv_res. intros * type_f approxc1c2 ssa_f freeVars_subset eval_real eval_float (*issubcmd_ok*) valid_bounds valid_intv fVars_sound P_valid absenv_res.
- simpl in eval_real, eval_float. - simpl in eval_real, eval_float.
inversion eval_float; inversion eval_real; subst. inversion eval_float; inversion eval_real; subst.
inversion ssa_f; subst. inversion ssa_f; subst.
...@@ -2761,9 +2788,10 @@ Proof. ...@@ -2761,9 +2788,10 @@ Proof.
- -
intros e0 v1 m2 natset typeexpr. intros e0 v1 m2 natset typeexpr.
specialize (fVars_sound (Ret e0) v1 m2 natset). specialize (fVars_sound v1 m2 natset).
assert (typeExpressionCmd (Ret e0) (Var Q m2 v1) = Some m2) by (simpl; auto). admit.
apply fVars_sound; auto. (*assert (typeExpressionCmd (Ret e0) (Var Q m2 v1) = Some m2) by (simpl; auto).
apply fVars_sound; auto.*)
- instantiate (1 := q0). instantiate (1 := q). - instantiate (1 := q0). instantiate (1 := q).
rewrite absenv_e; auto. } rewrite absenv_e; auto. }
(* * inversion ssa_f; subst. (* * inversion ssa_f; subst.
...@@ -2805,7 +2833,7 @@ Proof. ...@@ -2805,7 +2833,7 @@ Proof.
simpl. simpl.
rewrite NatSet.diff_spec, NatSet.remove_spec, NatSet.union_spec. rewrite NatSet.diff_spec, NatSet.remove_spec, NatSet.union_spec.
split; try auto. split; try auto.
* intros e1 v1 m1 v1_mem typing_e1. * intros v1 m1 v1_mem typing_e1.
unfold updEnv. unfold updEnv.
case_eq (v1 =? n); intros v1_eq. case_eq (v1 =? n); intros v1_eq.
{ rename R1 into eq_lo; { rename R1 into eq_lo;
...@@ -2817,6 +2845,11 @@ Proof. ...@@ -2817,6 +2845,11 @@ Proof.
apply Nat.eqb_eq in v1_eq; subst. apply Nat.eqb_eq in v1_eq; subst.
exists v0; split; try auto. exists v0; split; try auto.
(* Let n:m0 = e in f *)
(* typeExpressionCmd f (Var Q m1 n) = Some m1 *)
(* Want to prove: typeExpressionCmd f (Var Q m0 n) = Some m0 /\ m1 = m0. (because variable n is used in f). *)
admit. admit.
......
...@@ -195,12 +195,6 @@ Proof. ...@@ -195,12 +195,6 @@ Proof.
apply le_neq_bool_to_lt_prop; auto. apply le_neq_bool_to_lt_prop; auto.
Qed. Qed.
Fixpoint getRetExp (V:Type) (f:cmd V) :=
match f with
|Let m x e g => getRetExp g
| Ret e => e
end.
Lemma validVarsUnfolding_l (E:env) (absenv:analysisResult) (f1 f2: exp Q) dVars (b:binop) m0: Lemma validVarsUnfolding_l (E:env) (absenv:analysisResult) (f1 f2: exp Q) dVars (b:binop) m0:
(typeExpression (Binop b f1 f2)) (Binop b f1 f2) = Some m0 -> (typeExpression (Binop b f1 f2)) (Binop b f1 f2) = Some m0 ->
(forall (v : NatSet.elt) (m : mType), (forall (v : NatSet.elt) (m : mType),
......
Require Import Coq.Reals.Reals Coq.micromega.Psatz Coq.QArith.QArith Coq.QArith.Qreals Coq.MSets.MSets. Require Import Coq.Reals.Reals Coq.micromega.Psatz Coq.QArith.QArith Coq.QArith.Qreals Coq.MSets.MSets.
Require Import Daisy.Infra.RealRationalProps Daisy.Expressions Daisy.Infra.Ltacs. Require Import Daisy.Infra.RealRationalProps Daisy.Expressions Daisy.Infra.Ltacs Daisy.Commands Daisy.ssaPrgs.
Require Export Daisy.Infra.Abbrevs Daisy.Infra.RealSimps Daisy.Infra.NatSet Daisy.IntervalArithQ Daisy.IntervalArith Daisy.Infra.MachineType. Require Export Daisy.Infra.Abbrevs Daisy.Infra.RealSimps Daisy.Infra.NatSet Daisy.IntervalArithQ Daisy.IntervalArith Daisy.Infra.MachineType.
(** (**
Now we want a TypeEnv function, taking an expression and returning a exp -> option mType Now we want a TypeEnv function, taking an expression and returning a exp -> option mType
Soundness property is: TypeEnv e = T -> eval_exp e E v m -> T e = m. Soundness property is: TypeEnv e = T -> eval_exp e E v m -> T e = m.
**) **)
(** A good function computing a map of expression types **) Definition updTEnv (e:exp Q) (t:mType) (cont:exp Q-> option mType) :=
Fixpoint typeExpression (e:exp Q) (e':exp Q) : option mType := (fun e' =>
if expEqBool e e'
then Some t
else cont e').
Definition emptyTEnv :exp Q -> option mType := fun e => None.
Fixpoint typeExpression_trec e (cont:exp Q -> option mType) : exp Q -> option mType :=
match e with match e with
| Var _ m n => if expEqBool e e' then Some m else None | Var _ m v => updTEnv e m cont
| Const m n => if expEqBool e e' then Some m else None | Const m n => updTEnv e m cont
| Unop u e1 => | Unop u e1 =>
let tE1 := typeExpression e1 in let tEnv := typeExpression_trec e1 cont in
if expEqBool e e' then (tE1 e1) let t := tEnv e1 in
else (tE1 e') match t with
| Some m => updTEnv e m tEnv
| None => emptyTEnv
end
| Binop b e1 e2 => | Binop b e1 e2 =>
let tE1 := typeExpression e1 in let tEnv_e1 := typeExpression_trec e1 cont in
let tE2 := typeExpression e2 in let tEnv_e2 := typeExpression_trec e2 tEnv_e1 in (* TODO: This may cause trouble e.g. in (x:F) + (x:D) *)
let m := match (tE1 e1), (tE2 e2) with let (t_e1,t_e2) := (tEnv_e2 e1, tEnv_e2 e2) in
|Some m1, Some m2 => Some (computeJoin m1 m2) match t_e1, t_e2 with
|_, _ => None |Some m, Some m' => updTEnv e (computeJoin m m') tEnv_e2
end in | _, _ => emptyTEnv
if expEqBool e e' then m
else match (tE1 e'), (tE2 e') with
|Some m1, Some m2 => if (mTypeEqBool m1 m2) then
Some m1
else
None
|Some m1, None => Some m1
|None, Some m2 => Some m2
|None, None => None
end end
| Downcast m e1 => | Downcast m e1 =>
let tE1 := typeExpression e1 in let tEnv_e1 := typeExpression_trec e1 cont in
let m := match (tE1 e1) with let t := tEnv_e1 e1 in
| Some m1 => if (isMorePrecise m1 m) then Some m else None match t with
| _ => None |Some m1 => if (isMorePrecise m1 m) then updTEnv e m tEnv_e1
end in else emptyTEnv
if expEqBool e e' then m |_ => emptyTEnv
else (tE1 e') end
end.
Definition typeExpression e := typeExpression_trec e emptyTEnv.
Definition updNatEnv (x:nat) (m:mType) (env: nat -> option mType) :=
(fun n => if (n =? x) then Some m else (env n)).
Definition emptyNatEnv :nat -> option mType := fun n => None.
Fixpoint typeCmd_trec1 (f:cmd Q) (cont: exp Q -> option mType) (env: nat -> option mType) :=
match f with
| Let m x e g => (* check that env x = None ? or this is already done by ssa ? *)
let gamma := typeExpression_trec e cont in
match (gamma e) with
| Some m' => if mTypeEqBool m m' then
(* hum. Should we just return tEnv_g ? *)
typeCmd_trec1 g gamma (updNatEnv x m' env)
else
emptyTEnv
| None => emptyTEnv
end
| Ret e =>
typeExpression_trec e cont
end.
(* Definition typeCmd f := typeCmd_trec1 f emptyTEnv emptyNatEnv. *)
(* Eval compute in typeCmd (Let M32 1 (Const M32 (1#1)) (Ret (Binop Plus (Var Q M32 1) (Const M64 (2#1))))). *)
(* Eval compute in typeCmd (Let M64 1 (Const M32 (1#1)) (Ret (Binop Plus (Var Q M64 1) (Const M64 (2#1))))). *)
(* Eval compute in typeCmd (Let M64 1 (Const M32 (1#1)) (Ret (Binop Plus (Var Q M32 1) (Const M32 (2#1))))). *)
(* do we need this env:nat -> option mType ? The updTEnv does the same kind of thing I guess... *)
(* issue here is that we may have (Var Q m x) and (Var Q m' x). But this should not happen... *)
Fixpoint typeCmd_trec2 (f:cmd Q) (cont: exp Q -> option mType) :=
match f with
| Let m x e g =>
let gamma := typeExpression_trec e cont in
match (gamma e) with
| Some m' => if mTypeEqBool m m' then
let newCont := updTEnv (Var Q m x) m gamma in
typeCmd_trec2 g newCont
else
emptyTEnv
| None => emptyTEnv
end
| Ret e =>
typeExpression_trec e cont
end. end.
Definition typeCmd f := typeCmd_trec2 f emptyTEnv.
Eval compute in typeCmd (Let M32 1 (Const M32 (1#1)) (Ret (Binop Plus (Var Q M32 1) (Const M64 (2#1))))).
Eval compute in typeCmd (Let M64 1 (Const M32 (1#1)) (Ret (Binop Plus (Var Q M64 1) (Const M64 (2#1))))).
Eval compute in typeCmd (Let M64 1 (Const M32 (1#1)) (Ret (Binop Plus (Var Q M32 1) (Const M32 (2#1))))).
Eval compute in typeCmd (Let M32 1 (Const M32 (1#1))
(Let M64 1 (Const M64 (1#1))
(Ret (Binop Plus (Var Q M32 1) (Var Q M64 1))))).
Theorem typeCmd_sound (f:cmd Q) inVars E v m:
validSSA f inVars = true ->
bstep (toRCmd f) E v m ->
typeCmd f (getRetExp f) = Some m.
Proof.
Admitted.
(* NB: one might be tempted to prove the following lemma: *) (* NB: one might be tempted to prove the following lemma: *)
(* Lemma typeExpressionPropagatesNone e e0: *) (* Lemma typeExpressionPropagatesNone e e0: *)
...@@ -609,4 +682,3 @@ Proof. ...@@ -609,4 +682,3 @@ Proof.
rewrite (stupid _ _ H1). rewrite (stupid _ _ H1).
apply orb_true_r. apply orb_true_r.
Qed. Qed.
\ No newline at end of file
...@@ -235,16 +235,16 @@ Proof. ...@@ -235,16 +235,16 @@ Proof.
revert E1 E2 vR. revert E1 E2 vR.
induction f; intros E1 E2 vR agree_on_vars. induction f; intros E1 E2 vR agree_on_vars.
- split; intros bstep_Let; inversion bstep_Let; subst. - split; intros bstep_Let; inversion bstep_Let; subst.
+ erewrite shadowing_free_rewriting_exp in H5; auto. + erewrite shadowing_free_rewriting_exp in H6; auto.
econstructor; eauto. econstructor; eauto.
rewrite <- IHf. rewrite <- IHf.
apply H6. apply H7.
intros n'; unfold updEnv. intros n'; unfold updEnv.
case_eq (n' =? n); auto. case_eq (n' =? n); auto.
+ erewrite <- shadowing_free_rewriting_exp in H5; auto. + erewrite <- shadowing_free_rewriting_exp in H6; auto.
econstructor; eauto. econstructor; eauto.
rewrite IHf. rewrite IHf.
apply H6. apply H7.
intros n'; unfold updEnv. intros n'; unfold updEnv.
case_eq (n' =? n); auto. case_eq (n' =? n); auto.
- split; intros bstep_Ret; inversion bstep_Ret; subst. - split; intros bstep_Ret; inversion bstep_Ret; subst.
...@@ -436,8 +436,8 @@ Proof. ...@@ -436,8 +436,8 @@ Proof.
* eapply ssa_shadowing_free. * eapply ssa_shadowing_free.
apply ssa_f. apply ssa_f.
apply x_free. apply x_free.
apply H5. apply H6.
* erewrite (shadowing_free_rewriting_cmd _ _ _ _) in H6; try eauto. * erewrite (shadowing_free_rewriting_cmd _ _ _ _) in H7; try eauto.
simpl in *. simpl in *.
econstructor; eauto. econstructor; eauto.
{ rewrite <- exp_subst_correct; eauto. } { rewrite <- exp_subst_correct; eauto. }
...@@ -450,10 +450,10 @@ Proof. ...@@ -450,10 +450,10 @@ Proof.
inversion ssa_f; subst. inversion ssa_f; subst.
econstructor; try auto. econstructor; try auto.
rewrite exp_subst_correct; eauto. rewrite exp_subst_correct; eauto.
rewrite <- IHf in H6; eauto. rewrite <- IHf in H7; eauto.
* rewrite <- shadowing_free_rewriting_cmd in H6; eauto. * rewrite <- shadowing_free_rewriting_cmd in H7; eauto.
eapply ssa_shadowing_free; eauto. eapply ssa_shadowing_free; eauto.
rewrite <- exp_subst_correct in H5; eauto. rewrite <- exp_subst_correct in H6; eauto.
* rewrite NatSet.add_spec; auto. * rewrite NatSet.add_spec; auto.
* apply validVars_add; auto. * apply validVars_add; auto.
* eapply dummy_bind_ok; eauto. * eapply dummy_bind_ok; eauto.
...@@ -493,7 +493,7 @@ Proof. ...@@ -493,7 +493,7 @@ Proof.
simpl in subst_step. simpl in subst_step.
case_eq (let_subst f). case_eq (let_subst f).
+ intros f_subst subst_f_eq. + intros f_subst subst_f_eq.
specialize (IHf (updEnv n M0 v E) vR (NatSet.add n inVars) outVars f_subst H9 H6 subst_f_eq). specialize (IHf (updEnv n M0 v E) vR (NatSet.add n inVars) outVars f_subst H9 H7 subst_f_eq).
rewrite subst_f_eq in subst_step. rewrite subst_f_eq in subst_step.
inversion IHf; subst. inversion IHf; subst.
constructor. constructor.
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment