Commit d73b0ae1 authored by Adam Chlipala's avatar Adam Chlipala

CcExp_correct

parent 63f6560a
...@@ -808,7 +808,7 @@ Fixpoint map_funcs var T1 T2 (f : T1 -> T2) (fs : funcs var T1) {struct fs} ...@@ -808,7 +808,7 @@ Fixpoint map_funcs var T1 T2 (f : T1 -> T2) (fs : funcs var T1) {struct fs}
| Abs _ _ _ e fs' => Abs e (fun x => map_funcs f (fs' x)) | Abs _ _ _ e fs' => Abs e (fun x => map_funcs f (fs' x))
end. end.
Definition CcTerm' t (E : Source.Exp t) (Hwf : wfExp (envT := nil) tt (E _)) : Prog (ccType t) := Definition CcExp' t (E : Source.Exp t) (Hwf : wfExp (envT := nil) tt (E _)) : Prog (ccType t) :=
fun _ => map_funcs (fun f => f tt) (ccExp (E _) (envT := nil) tt Hwf). fun _ => map_funcs (fun f => f tt) (ccExp (E _) (envT := nil) tt Hwf).
...@@ -953,7 +953,7 @@ Fixpoint lr (t : Source.type) : Source.typeDenote t -> Closed.typeDenote (ccType ...@@ -953,7 +953,7 @@ Fixpoint lr (t : Source.type) : Source.typeDenote t -> Closed.typeDenote (ccType
-> lr ran (f1 x1) (f2 x2) -> lr ran (f1 x1) (f2 x2)
end. end.
Theorem ccTerm_correct : forall t G Theorem ccExp_correct : forall t G
(e1 : Source.exp Source.typeDenote t) (e1 : Source.exp Source.typeDenote t)
(e2 : Source.exp natvar t), (e2 : Source.exp natvar t),
exp_equiv G e1 e2 exp_equiv G e1 e2
...@@ -1044,64 +1044,51 @@ Qed. ...@@ -1044,64 +1044,51 @@ Qed.
(** * Parametric version *) (** * Parametric version *)
Section wf. Section wf.
Variable result : ptype. Lemma Exp_wf' : forall G t (e1 e2 : Source.exp natvar t),
exp_equiv G e1 e2
Lemma Pterm_wf' : forall G (e1 e2 : pterm natvar result),
pterm_equiv G e1 e2
-> forall envT (fvs : isfree envT), -> forall envT (fvs : isfree envT),
(forall t (v1 v2 : natvar t), In (vars (v1, v2)) G (forall t (v1 v2 : natvar t), In (existT _ _ (v1, v2)) G
-> lookup_type v1 fvs = Some t) -> lookup_type v1 fvs = Some t)
-> wfTerm fvs e1. -> wfExp fvs e1.
Hint Extern 3 (Some _ = Some _) => contradictory; eapply lookup_bound_contra; eauto. Hint Extern 3 (Some _ = Some _) => elimtype False; eapply lookup_bound_contra; eauto.
apply (pterm_equiv_mut induction 1; crush.
(fun G (e1 e2 : pterm natvar result) => eapply H0.
forall envT (fvs : isfree envT), eauto.
(forall t (v1 v2 : natvar t), In (vars (v1, v2)) G
-> lookup_type v1 fvs = Some t) apply H0 with (length envT).
-> wfTerm (envT:=envT) fvs e1) my_crush.
(fun G t (p1 p2 : pprimop natvar result t) => eauto.
forall envT (fvs : isfree envT),
(forall t (v1 v2 : natvar t), In (vars (v1, v2)) G
-> lookup_type v1 fvs = Some t)
-> wfPrimop (envT:=envT) fvs p1));
simpler;
match goal with
| [ envT : list ptype, H : _ |- _ ] =>
apply (H (length envT) (length envT)); simpler
end.
Qed. Qed.
Theorem Pterm_wf : forall (E : Pterm result), Theorem Exp_wf : forall t (E : Source.Exp t),
wfTerm (envT := nil) tt (E _). wfExp (envT := nil) tt (E _).
intros; eapply Pterm_wf'; intros; eapply Exp_wf';
[apply Pterm_equiv [apply Exp_equiv
| simpler]. | crush].
Qed. Qed.
End wf. End wf.
Definition CcTerm result (E : Pterm result) : Cprog result := Definition CcExp t (E : Source.Exp t) : Prog (ccType t) :=
CcTerm' E (Pterm_wf E). CcExp' E (Exp_wf E).
Lemma map_funcs_correct : forall result T1 T2 (f : T1 -> T2) (fs : cfuncs ctypeDenote result T1) k, Lemma map_funcs_correct : forall T1 T2 (f : T1 -> T2) (fs : funcs Closed.typeDenote T1),
cfuncsDenote (map_funcs f fs) k = f (cfuncsDenote fs k). funcsDenote (map_funcs f fs) = f (funcsDenote fs).
induction fs; equation. induction fs; crush.
Qed. Qed.
Theorem CcTerm_correct : forall result (E : Pterm result) k, Theorem CcExp_correct : forall (E : Source.Exp Nat),
PtermDenote E k Source.ExpDenote E
= CprogDenote (CcTerm E) k. = ProgDenote (CcExp E).
Hint Rewrite map_funcs_correct : ltamer. Hint Rewrite map_funcs_correct : cpdt.
unfold PtermDenote, CprogDenote, CcTerm, CcTerm', cprogDenote; unfold Source.ExpDenote, ProgDenote, CcExp, CcExp', progDenote; crush;
simpler; apply (ccExp_correct
apply (ccTerm_correct (result := result)
(G := nil) (G := nil)
(e1 := E _) (e1 := E _)
(e2 := E _) (e2 := E _)
(Pterm_equiv _ _ _) (Exp_equiv _ _ _)
nil nil
tt tt
tt); tt); crush.
simpler.
Qed. Qed.
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