From be4776e6a33b4a860a019c2f7d3cacb737b74648 Mon Sep 17 00:00:00 2001 From: Gabriel Ebner Date: Fri, 27 Feb 2026 02:40:09 +0000 Subject: [PATCH 01/18] Remove Soundness modules and make typing tokens trivial - Delete all 34 Pulse.Soundness.* files - Make tot_typing, ghost_typing, universe_of, typing = unit - Remove typing token fields from st_typing, comp_typing, st_comp_typing, bind_comp, st_equiv constructors - Remove effect_annot_typing body (= unit) - Remove post_typing RT field from post_hint_t - Simplify post_hint_typing to return unit values - Move stt_env and check_top_level_environment to Pulse.Typing.Env - Update Pulse.Main.fst to remove soundness_lemma, replace elab_st_typing with RU.magic() - Remove Pulse.Soundness.Common import from Pulse.Typing.FV Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/checker/Pulse.Checker.Abs.fst | 6 +- src/checker/Pulse.Checker.Admit.fst | 6 +- .../Pulse.Checker.AssertWithBinders.fst | 2 +- src/checker/Pulse.Checker.Base.fst | 82 ++-- src/checker/Pulse.Checker.Comp.fst | 6 +- src/checker/Pulse.Checker.Exists.fst | 4 +- src/checker/Pulse.Checker.Goto.fst | 2 +- src/checker/Pulse.Checker.If.fst | 2 +- src/checker/Pulse.Checker.IntroPure.fst | 2 +- src/checker/Pulse.Checker.Match.fst | 2 +- .../Pulse.Checker.Prover.Normalize.fst | 2 +- src/checker/Pulse.Checker.Prover.fst | 8 +- src/checker/Pulse.Checker.Pure.fst | 20 +- src/checker/Pulse.Checker.Return.fst | 5 +- src/checker/Pulse.Checker.Rewrite.fst | 2 +- src/checker/Pulse.Checker.ST.fst | 4 +- src/checker/Pulse.Checker.While.fst | 12 +- src/checker/Pulse.Checker.WithLocal.fst | 5 +- src/checker/Pulse.Checker.WithLocalArray.fst | 7 +- src/checker/Pulse.Elaborate.Core.fst | 136 +----- src/checker/Pulse.JoinComp.fst | 4 +- src/checker/Pulse.Main.fst | 28 +- src/checker/Pulse.Soundness.Admit.fst | 50 --- src/checker/Pulse.Soundness.Admit.fsti | 34 -- src/checker/Pulse.Soundness.Bind.fst | 229 ---------- src/checker/Pulse.Soundness.Bind.fsti | 54 --- src/checker/Pulse.Soundness.Common.fst | 400 ------------------ src/checker/Pulse.Soundness.Comp.fst | 84 ---- src/checker/Pulse.Soundness.Comp.fsti | 47 -- src/checker/Pulse.Soundness.Exists.fst | 109 ----- src/checker/Pulse.Soundness.Exists.fsti | 45 -- src/checker/Pulse.Soundness.Frame.fst | 127 ------ src/checker/Pulse.Soundness.Frame.fsti | 34 -- src/checker/Pulse.Soundness.Lift.fst | 72 ---- src/checker/Pulse.Soundness.Lift.fsti | 72 ---- src/checker/Pulse.Soundness.Match.fst | 88 ---- src/checker/Pulse.Soundness.Match.fsti | 39 -- src/checker/Pulse.Soundness.Return.fst | 158 ------- src/checker/Pulse.Soundness.Return.fsti | 34 -- src/checker/Pulse.Soundness.Rewrite.fst | 50 --- src/checker/Pulse.Soundness.Rewrite.fsti | 34 -- src/checker/Pulse.Soundness.SLPropEquiv.fst | 269 ------------ src/checker/Pulse.Soundness.SLPropEquiv.fsti | 31 -- src/checker/Pulse.Soundness.STEquiv.fst | 238 ----------- src/checker/Pulse.Soundness.STEquiv.fsti | 32 -- src/checker/Pulse.Soundness.STT.fsti | 60 --- src/checker/Pulse.Soundness.Sub.fst | 43 -- src/checker/Pulse.Soundness.Sub.fsti | 36 -- src/checker/Pulse.Soundness.While.fst | 17 - src/checker/Pulse.Soundness.While.fsti | 17 - src/checker/Pulse.Soundness.WithLocal.fst | 69 --- src/checker/Pulse.Soundness.WithLocal.fsti | 35 -- .../Pulse.Soundness.WithLocalArray.fst | 72 ---- .../Pulse.Soundness.WithLocalArray.fsti | 35 -- src/checker/Pulse.Soundness.fst | 324 -------------- src/checker/Pulse.Soundness.fsti | 33 -- src/checker/Pulse.Syntax.Naming.fst | 2 +- src/checker/Pulse.Typing.Combinators.fst | 60 ++- src/checker/Pulse.Typing.Env.fst | 8 + src/checker/Pulse.Typing.Env.fsti | 5 + src/checker/Pulse.Typing.FV.fst | 208 ++------- src/checker/Pulse.Typing.LN.fst | 141 ++---- src/checker/Pulse.Typing.Metatheory.Base.fst | 45 +- src/checker/Pulse.Typing.fst | 122 +----- 64 files changed, 229 insertions(+), 3780 deletions(-) delete mode 100644 src/checker/Pulse.Soundness.Admit.fst delete mode 100644 src/checker/Pulse.Soundness.Admit.fsti delete mode 100644 src/checker/Pulse.Soundness.Bind.fst delete mode 100644 src/checker/Pulse.Soundness.Bind.fsti delete mode 100644 src/checker/Pulse.Soundness.Common.fst delete mode 100644 src/checker/Pulse.Soundness.Comp.fst delete mode 100644 src/checker/Pulse.Soundness.Comp.fsti delete mode 100644 src/checker/Pulse.Soundness.Exists.fst delete mode 100644 src/checker/Pulse.Soundness.Exists.fsti delete mode 100644 src/checker/Pulse.Soundness.Frame.fst delete mode 100644 src/checker/Pulse.Soundness.Frame.fsti delete mode 100644 src/checker/Pulse.Soundness.Lift.fst delete mode 100644 src/checker/Pulse.Soundness.Lift.fsti delete mode 100644 src/checker/Pulse.Soundness.Match.fst delete mode 100644 src/checker/Pulse.Soundness.Match.fsti delete mode 100644 src/checker/Pulse.Soundness.Return.fst delete mode 100644 src/checker/Pulse.Soundness.Return.fsti delete mode 100644 src/checker/Pulse.Soundness.Rewrite.fst delete mode 100644 src/checker/Pulse.Soundness.Rewrite.fsti delete mode 100644 src/checker/Pulse.Soundness.SLPropEquiv.fst delete mode 100644 src/checker/Pulse.Soundness.SLPropEquiv.fsti delete mode 100644 src/checker/Pulse.Soundness.STEquiv.fst delete mode 100644 src/checker/Pulse.Soundness.STEquiv.fsti delete mode 100644 src/checker/Pulse.Soundness.STT.fsti delete mode 100644 src/checker/Pulse.Soundness.Sub.fst delete mode 100644 src/checker/Pulse.Soundness.Sub.fsti delete mode 100644 src/checker/Pulse.Soundness.While.fst delete mode 100644 src/checker/Pulse.Soundness.While.fsti delete mode 100644 src/checker/Pulse.Soundness.WithLocal.fst delete mode 100644 src/checker/Pulse.Soundness.WithLocal.fsti delete mode 100644 src/checker/Pulse.Soundness.WithLocalArray.fst delete mode 100644 src/checker/Pulse.Soundness.WithLocalArray.fsti delete mode 100644 src/checker/Pulse.Soundness.fst delete mode 100644 src/checker/Pulse.Soundness.fsti diff --git a/src/checker/Pulse.Checker.Abs.fst b/src/checker/Pulse.Checker.Abs.fst index 9e8495049..281f62b9c 100644 --- a/src/checker/Pulse.Checker.Abs.fst +++ b/src/checker/Pulse.Checker.Abs.fst @@ -424,7 +424,7 @@ let maybe_rewrite_body_typing magic () in let tok' : st_equiv g (C_Tot t') (C_Tot t) = - ST_TotEquiv _ t' t u t'_typing + ST_TotEquiv _ t' t u (RT.Rel_sym _ _ _ (RT.Rel_eq_token _ _ _ sq)) in (| C_Tot t, T_Equiv _ _ _ _ d tok' |) @@ -506,7 +506,7 @@ let rec check_abs_core |> FStar.Sealed.seal in let b = {binder_ty=t;binder_ppname=ppname;binder_attrs} in - let tt = T_Abs g x qual b u body_closed c_body t_typing body_typing in + let tt = T_Abs g x qual b u body_closed c_body body_typing in let tres = tm_arrow {binder_ty=t;binder_ppname=ppname;binder_attrs} qual (close_comp c_body x) in (| _, C_Tot tres, tt |) | _ -> @@ -607,7 +607,7 @@ let rec check_abs_core let body_closed = close_st_term body x in assume (open_st_term body_closed x == body); let b = {binder_ty=t;binder_ppname=ppname;binder_attrs} in - let tt = T_Abs g x qual b u body_closed c_body t_typing body_typing in + let tt = T_Abs g x qual b u body_closed c_body body_typing in let tres = tm_arrow {binder_ty=t;binder_ppname=ppname;binder_attrs} qual (close_comp c_body x) in (| _, C_Tot tres, tt |) diff --git a/src/checker/Pulse.Checker.Admit.fst b/src/checker/Pulse.Checker.Admit.fst index ff332d273..a1d321a71 100644 --- a/src/checker/Pulse.Checker.Admit.fst +++ b/src/checker/Pulse.Checker.Admit.fst @@ -66,11 +66,11 @@ let check let post = close_term post_opened x in let s : st_comp = {u;res=t;pre;post} in assume (open_term (close_term post_opened x) x == post_opened); - let d_s : st_comp_typing _ s = STC _ s x t_typing pre_typing post_typing in + let d_s : st_comp_typing _ s = STC _ s x in (match c with | STT -> (| _, CT_ST _ _ d_s |) - | STT_Ghost -> (| _, CT_STGhost _ tm_emp_inames _ (RU.magic ()) d_s |) - | STT_Atomic -> (| _, CT_STAtomic _ tm_emp_inames Neutral _ (RU.magic ()) d_s |)) + | STT_Ghost -> (| _, CT_STGhost _ tm_emp_inames _ d_s |) + | STT_Atomic -> (| _, CT_STAtomic _ tm_emp_inames Neutral _ d_s |)) | _, PostHint post -> Pulse.Typing.Combinators.comp_for_post_hint pre_typing post x in diff --git a/src/checker/Pulse.Checker.AssertWithBinders.fst b/src/checker/Pulse.Checker.AssertWithBinders.fst index 78ff876c0..7d5b547fb 100644 --- a/src/checker/Pulse.Checker.AssertWithBinders.fst +++ b/src/checker/Pulse.Checker.AssertWithBinders.fst @@ -518,7 +518,7 @@ let check assume (v == v'); //sorry---ideally, we would retype everything proving that it is stable after normalization let v = v' in let body = body in // TODO compress - let h: tot_typing g1 v tm_slprop = PC.core_check_term _ _ _ _ in + let h: tot_typing g1 v tm_slprop = PC.core_check_term g1 v T.E_Total tm_slprop in let h: tot_typing g1 (tm_star v pre') tm_slprop = RU.magic () in // TODO: propagate through prover let (| x, x_ty, pre'', g2, k |) = check g1 (tm_star v pre') h post_hint res_ppname body in diff --git a/src/checker/Pulse.Checker.Base.fst b/src/checker/Pulse.Checker.Base.fst index 05380724f..952474f93 100644 --- a/src/checker/Pulse.Checker.Base.fst +++ b/src/checker/Pulse.Checker.Base.fst @@ -68,7 +68,7 @@ let intro_comp_typing (g:env) comp_res c == st.res /\ comp_post c == st.post } ) : T.Tac (st_comp_typing g st) - = STC g st x res_typing pre_typing post_typing + = STC g st x in match c with | C_ST st -> @@ -76,10 +76,10 @@ let intro_comp_typing (g:env) CT_ST _ _ stc | C_STAtomic i obs st -> let stc = intro_st_comp_typing st in - CT_STAtomic _ i obs _ i_typing stc + CT_STAtomic _ i obs _ stc | C_STGhost i st -> let stc = intro_st_comp_typing st in - CT_STGhost _ i _ i_typing stc + CT_STGhost _ i _ stc irreducible let post_typing_as_abstraction @@ -101,8 +101,7 @@ let equiv_preserves_typing (eq : squash (T.equiv_token (elab_env g) t1 t2)) (t1_typing : typing g t1 T.E_Total typ) : typing g t2 T.E_Total typ - = match t1_typing with - | E pf -> E (fstar_equiv_preserves_typing _ t1 typ t2 eq pf) + = () let check_effect_annot (g:env) (e:effect_annot) : T.Tac (e':effect_annot { effect_annot_labels_match e e' } & effect_annot_typing g e') = @@ -147,8 +146,7 @@ let intro_post_hint g effect_annot ret_ty_opt post = effect_annot_typing; ret_ty; u; ty_typing; post=post'; - x; post_typing_src=post_typing; - post_typing=post_typing_as_abstraction #_ #_ #_ #post' post_typing } + x; post_typing_src=post_typing } let comp_typing_as_effect_annot_typing (#g:env) (#c:comp_st) (ct:comp_typing_u g c) : effect_annot_typing g (effect_annot_of_comp c) @@ -171,8 +169,7 @@ let post_hint_from_comp_typing #g #c ct = ty_typing=Mkdtuple4?._1 inv; post=comp_post c; x=Mkdtuple4?._3 inv; - post_typing_src=Mkdtuple4?._4 inv; - post_typing=post_typing_as_abstraction (Mkdtuple4?._4 inv) } + post_typing_src=Mkdtuple4?._4 inv } in p @@ -220,16 +217,11 @@ let extend_post_hint g p x tx conjunct conjunct_typing = = Pulse.Typing.star_typing p_post_typing_src'' conjunct_typing'' in assume (fresh_wrt y g'' (freevars new_post)); - let new_post_abs_typing - : Ghost.erased (RT.tot_typing (elab_env g'') (mk_abs p.ret_ty new_post) (mk_arrow p.ret_ty tm_slprop)) - = post_typing_as_abstraction new_post_typing - in { p with g=g'; post=new_post; x=y; - post_typing_src=new_post_typing; - post_typing=new_post_abs_typing } + post_typing_src=new_post_typing } let k_elab_unit (g:env) (ctxt:term) : continuation_elaborator g ctxt g ctxt @@ -265,7 +257,7 @@ let st_equiv_post (#g:env) (#t:st_term) (#c:comp_st) (d:st_typing g t c) let (| u_of, pre_typing, x, post_typing |) = Metatheory.(st_comp_typing_inversion (fst (comp_typing_inversion (st_typing_correctness d)))) in let veq = veq x in let st_equiv : st_equiv g c c' = - ST_SLPropEquiv g c c' x pre_typing u_of post_typing (RT.Rel_refl _ _ _) (VE_Refl _ _) veq + ST_SLPropEquiv g c c' x (RT.Rel_refl _ _ _) (VE_Refl _ _) veq in t_equiv d st_equiv @@ -309,7 +301,7 @@ let st_equiv_pre (#g:env) (#t:st_term) (#c:comp_st) (d:st_typing g t c) let (| u_of, pre_typing, x, post_typing |) = Metatheory.(st_comp_typing_inversion (fst (comp_typing_inversion (st_typing_correctness d)))) in let st_equiv : st_equiv g c c' = - ST_SLPropEquiv g c c' x pre_typing u_of post_typing (RT.Rel_refl _ _ _) veq (VE_Refl _ _) + ST_SLPropEquiv g c c' x (RT.Rel_refl _ _ _) veq (VE_Refl _ _) in t_equiv d st_equiv @@ -500,12 +492,10 @@ let st_comp_typing_with_post_hint RU.magic () in let ty_typing : universe_of ph.g st.res st.u = ph.ty_typing in - let ty_typing : universe_of g st.res st.u = - Pulse.Typing.Metatheory.tot_typing_weakening_standard ph.g ty_typing g - in + let ty_typing : universe_of g st.res st.u = () in assert (st.res == ph.ret_ty); assert (st.post == ph.post); - STC g st x ty_typing ctxt_typing post_typing_src + STC g st x #pop-options let continuation_elaborator_with_bind_fn (#g:env) (#ctxt:term) @@ -526,7 +516,7 @@ let continuation_elaborator_with_bind_fn (#g:env) (#ctxt:term) let e2_closed = close_st_term e2 x in assume (open_st_term (close_st_term e2 x) x == e2); let e = wrst c2 (Tm_Bind {binder=b; head=e1; body=e2_closed}) in - let (| u, c1_typing |) = Pulse.Typing.Metatheory.Base.st_typing_correctness_ctot e1_typing in + let (| u, _ |) = Pulse.Typing.Metatheory.Base.st_typing_correctness_ctot e1_typing in let c2_typing : comp_typing g c2 (universe_of_comp c2) = match c2 with | C_ST st -> @@ -535,16 +525,14 @@ let continuation_elaborator_with_bind_fn (#g:env) (#ctxt:term) | C_STAtomic i obs st -> let stc = st_comp_typing_with_post_hint ctxt_typing post_hint c2 in - let i_typing = CP.core_check_term g i T.E_Total tm_inames in - CT_STAtomic _ _ obs _ i_typing stc + CT_STAtomic _ i obs _ stc | C_STGhost i st -> - let i_typing = CP.core_check_term g i T.E_Total tm_inames in let stc = st_comp_typing_with_post_hint ctxt_typing post_hint c2 in - CT_STGhost _ i _ i_typing stc + CT_STGhost _ i _ stc in let d : st_typing g e c2 = - T_BindFn g e1 e2_closed c1 c2 b x e1_typing u c1_typing d2 c2_typing + T_BindFn g e1 e2_closed c1 c2 b x e1_typing u d2 c2_typing in (| e, c2, d |) @@ -585,9 +573,7 @@ let return_in_ctxt (g:env) (y:var) (y_ppname:ppname) (u:universe) (ty:term) (ctx | EffectAnnotSTT -> STT in let y_tm = tm_var {nm_index=y;nm_ppname=y_ppname} in - let d = T_Return g ctag false u ty y_tm post_hint.post x ty_typing - (RU.magic ()) // that null_var y is well typed at ty in g, we know since lookup g y == Some ty - (RU.magic ()) // typing of (open post x) in (g, x) ... post_hint is well-typed, so should get + let d = T_Return g ctag false u ty y_tm post_hint.post x in let t = wtag (Some ctag) (Tm_Return {expected_type=tm_unknown;insert_eq=false;term=y_tm}) in let c = comp_return ctag false u ty y_tm post_hint.post x in @@ -642,7 +628,7 @@ let match_comp_res_with_post_hint (#g:env) (#t:st_term) (#c:comp_st) let (| cres_typing, cpre_typing, x, cpost_typing |) = st_comp_typing_inversion (fst <| comp_typing_inversion (st_typing_correctness d)) in let d_stequiv : st_equiv g c c' = - ST_SLPropEquiv _ c c' _ cpre_typing cres_typing cpost_typing d_equiv (VE_Refl _ _) (VE_Refl _ _) + ST_SLPropEquiv _ c c' x d_equiv (VE_Refl _ _) (VE_Refl _ _) in (| c', Pulse.Typing.Combinators.t_equiv d d_stequiv |) @@ -706,9 +692,9 @@ let checker_result_for_st_typing (#g:env) (#ctxt:slprop) (#post_hint:post_hint_o | _ -> () in assert (g' `env_extends` g); - let u_of_1_g' : universe_of _ _ _ = Pulse.Typing.Metatheory.tot_typing_weakening_standard g u_of_1 g' in + let u_of_1_g' : universe_of g' (comp_res c1) (comp_u c1) = () in assert (~ (x `Set.mem` freevars (comp_post c1))); - (| x, g', (| _, _, u_of_1_g' |), (| ctxt', post_typing |), k |) + (| x, g', (| comp_u c1, comp_res c1, u_of_1_g' |), (| ctxt', post_typing |), k |) #pop-options let readback_comp_res_as_comp (c:T.comp) : option comp = @@ -813,27 +799,17 @@ let apply_conversion (#t1:term) (eq:Ghost.erased (RT.related (elab_env g) t0 RT.R_Eq t1)) : typing g e eff t1 - = let d : RT.typing (elab_env g) e (eff, t0) = d._0 in - let r : RT.related (elab_env g) t0 RT.R_Eq t1 = eq in - let r = RT.Rel_equiv _ _ _ RT.R_Sub r in - let s : RT.sub_comp (elab_env g) (eff, t0) (eff, t1) = - RT.Relc_typ _ _ _ _ _ r - in - E (RT.T_Sub _ _ _ _ d s) + = () let norm_typing (g:env) (e:term) (eff:_) (t0:term) (d:typing g e eff t0) (steps:list norm_step) : T.Tac (t':term & typing g e eff t') - = let u_t_typing : Ghost.erased (u:R.universe & RT.typing _ _ _) = - Pulse.Typing.Metatheory.Base.typing_correctness d._0 + = let (| t', _, _ |) = + CP.norm_well_typed_term_alt #(elab_env g) #e #eff #t0 (magic()) steps in - let (| t', t'_typing, related_t_t' |) = - CP.norm_well_typed_term_alt (dsnd u_t_typing) steps - in - let d : typing g e eff t' = apply_conversion d related_t_t' in - (| t', d |) + (| t', () |) module TermEq = FStar.Reflection.TermEq let norm_typing_inverse @@ -845,14 +821,10 @@ let norm_typing_inverse (steps:list norm_step) : T.Tac (option (typing g e eff t1)) = let (| t1', t1'_typing, related_t1_t1' |) = - let d1 = Ghost.hide d1._0 in - CP.norm_well_typed_term_alt d1 steps + CP.norm_well_typed_term_alt #(elab_env g) #t1 #T.E_Total #(R.pack_ln (R.Tv_Type u)) (Ghost.hide (magic())) steps in if TermEq.term_eq t0 t1' - then ( - let related_t1'_t1 = Ghost.hide (RT.Rel_sym _ _ _ related_t1_t1') in - Some (apply_conversion d related_t1'_t1) - ) + then Some () else None @@ -866,7 +838,7 @@ let norm_st_typing_inverse : T.Tac (option (st_typing g e (C_Tot t1))) = let d1 : Ghost.erased (RT.tot_typing (elab_env g) t1 (RT.tm_type u)) - = Ghost.hide (coerce_eq d1._0 ()) + = Ghost.hide (magic()) in let (| t1', t1'_typing, related_t1_t1' |) = CP.norm_well_typed_term_alt d1 steps @@ -882,7 +854,7 @@ let norm_st_typing_inverse = Ghost.hide (RT.Rel_sym _ _ _ related_t1_t1') in let steq : st_equiv g (C_Tot t0) (C_Tot t1) = - ST_TotEquiv _ _ _ u (E (coerce_eq (Ghost.reveal t0_typing) ())) eq + ST_TotEquiv _ _ _ u eq in Some (Pulse.Typing.Combinators.t_equiv d steq) ) diff --git a/src/checker/Pulse.Checker.Comp.fst b/src/checker/Pulse.Checker.Comp.fst index 2a14d6844..e7d5ffed5 100644 --- a/src/checker/Pulse.Checker.Comp.fst +++ b/src/checker/Pulse.Checker.Comp.fst @@ -53,7 +53,7 @@ let check (g:env) (Printf.sprintf "check_comp: ill-typed postcondition %s" (P.term_to_string (comp_post c))) else ( assert (ty == tm_slprop); - STC g st x t_u pre_typing post_typing + STC g st x ) ) in @@ -68,7 +68,7 @@ let check (g:env) then fail g None (Printf.sprintf "check_comp (atomic): type of inames term %s is %s, expected %s" (P.term_to_string i) (P.term_to_string ty) (P.term_to_string tm_inames)) - else CT_STAtomic _ _ obs _ i_typing stc + else CT_STAtomic _ i obs _ stc | C_STGhost i st -> let (| ty, i_typing |) = core_compute_tot_term_type g i in if not (eq_tm ty tm_inames) @@ -77,4 +77,4 @@ let check (g:env) (P.term_to_string i) (P.term_to_string ty) (P.term_to_string tm_inames)) else let stc = check_st_comp st in - CT_STGhost _ _ _ i_typing stc + CT_STGhost _ i _ stc diff --git a/src/checker/Pulse.Checker.Exists.fst b/src/checker/Pulse.Checker.Exists.fst index 983ffee75..78a01906a 100644 --- a/src/checker/Pulse.Checker.Exists.fst +++ b/src/checker/Pulse.Checker.Exists.fst @@ -88,7 +88,7 @@ let check_elim_exists let (| u', ty_typing |) = universe_of_well_typed_term g ty in if eq_univ u u' then let x = fresh g in - let d = T_ElimExists g u ty p x ty_typing t_typing in + let d = T_ElimExists g u ty p x in let (|_,d|) = match_comp_res_with_post_hint d post_hint in prove_post_hint (try_frame_pre false pre_typing (|_,_,d|) res_ppname) post_hint t_rng else fail g (Some t_rng) @@ -130,7 +130,7 @@ let check_intro_exists let ty_typing, _ = Metatheory.tm_exists_inversion #g #u #b.binder_ty #p t_typing x in let (| witness, witness_typing |) = check_term g witness T.E_Ghost b.binder_ty in - let d = T_IntroExists g u b p witness ty_typing t_typing witness_typing in + let d = T_IntroExists g u b p witness in let (| c, d |) : (c:_ & st_typing g _ c) = (| _, d |) in let (| c, d |) = match_comp_res_with_post_hint d post_hint in prove_post_hint (try_frame_pre false pre_typing (|_,_,d|) res_ppname) diff --git a/src/checker/Pulse.Checker.Goto.fst b/src/checker/Pulse.Checker.Goto.fst index 884f3a70c..5d19c6634 100644 --- a/src/checker/Pulse.Checker.Goto.fst +++ b/src/checker/Pulse.Checker.Goto.fst @@ -52,7 +52,7 @@ let check' let typing: st_typing g t c' = let x' = fresh g in assume fresh_wrt x' g (freevars ph.post); let pht = post_hint_typing g ph x' in - T_Goto _ (lbln, v) arg lbl_c arg_typ ph.u ph.ret_ty pht.ty_typing ph.post x' pht.post_typing in + T_Goto _ (lbln, v) arg lbl_c ph.u ph.ret_ty ph.post x' in let (| c'', typing'' |) = match_comp_res_with_post_hint typing post_hint in prove_post_hint #g (try_frame_pre false #g pre_typing (|_,c'',typing''|) res_ppname) diff --git a/src/checker/Pulse.Checker.If.fst b/src/checker/Pulse.Checker.If.fst index c6b1955db..67fcae6b2 100644 --- a/src/checker/Pulse.Checker.If.fst +++ b/src/checker/Pulse.Checker.If.fst @@ -139,7 +139,7 @@ let check let c_typing = comp_typing_from_post_hint c pre_typing post_hint' in let d : st_typing_in_ctxt g pre (PostHint post_hint') = - (| _, c, T_If g b e1 e2 c hyp b_typing e1_typing e2_typing (E c_typing) |) in + (| _, c, T_If g b e1 e2 c hyp e1_typing e2_typing (E c_typing) |) in let res : checker_result_t g pre (PostHint post_hint') = checker_result_for_st_typing d res_ppname in retype_checker_result_post_hint post_hint' post_hint res diff --git a/src/checker/Pulse.Checker.IntroPure.fst b/src/checker/Pulse.Checker.IntroPure.fst index 2337efd15..e41951bda 100644 --- a/src/checker/Pulse.Checker.IntroPure.fst +++ b/src/checker/Pulse.Checker.IntroPure.fst @@ -58,6 +58,6 @@ let check let Tm_IntroPure { p } = t.term in let (| p, p_typing |) = check_prop g p in let pv = check_prop_validity g p p_typing in - let st_typing = T_IntroPure _ _ p_typing pv in + let st_typing = T_IntroPure _ _ pv in let (| c,d |) = match_comp_res_with_post_hint st_typing post_hint in prove_post_hint (try_frame_pre false pre_typing (|_,c,d|) res_ppname) post_hint t.range diff --git a/src/checker/Pulse.Checker.Match.fst b/src/checker/Pulse.Checker.Match.fst index 6c4ea982b..bea128047 100644 --- a/src/checker/Pulse.Checker.Match.fst +++ b/src/checker/Pulse.Checker.Match.fst @@ -603,6 +603,6 @@ let check (* Provable *) assume (L.map (fun br -> elab_pat br.pat) brs == elab_pats'); let c_typing = comp_typing_from_post_hint c pre_typing post_hint in - let d = T_Match g sc_u sc_ty sc sc_ty_typing sc_typing c (E c_typing) brs brs_d complete_d in + let d = T_Match g sc_u sc_ty sc c (E c_typing) brs brs_d complete_d in checker_result_for_st_typing (| _, _, d |) res_ppname #pop-options \ No newline at end of file diff --git a/src/checker/Pulse.Checker.Prover.Normalize.fst b/src/checker/Pulse.Checker.Prover.Normalize.fst index ed08e5109..eed67b829 100644 --- a/src/checker/Pulse.Checker.Prover.Normalize.fst +++ b/src/checker/Pulse.Checker.Prover.Normalize.fst @@ -74,4 +74,4 @@ let normalize_slprop_welltyped = let (| v', v_equiv_v' |) = normalize_slprop g v true in // FIXME: prove (or add axiom) that equiv preserves typing - (| v', v_equiv_v', E (magic()) |) \ No newline at end of file + (| v', v_equiv_v', () |) \ No newline at end of file diff --git a/src/checker/Pulse.Checker.Prover.fst b/src/checker/Pulse.Checker.Prover.fst index 8412aa78c..71e0b086f 100644 --- a/src/checker/Pulse.Checker.Prover.fst +++ b/src/checker/Pulse.Checker.Prover.fst @@ -351,7 +351,7 @@ let intro_pure (g: env) (frame: slprop) (p: term) let frame_typ : tot_typing g frame tm_slprop = RU.magic () in // implied by t2_typing let h: tot_typing g (tm_star frame (comp_pre (comp_intro_pure p))) tm_slprop = RU.magic () in debug_prover g (fun _ -> Printf.sprintf "intro_pure p=%s\nframe=%s\n" (show p) (show frame)); - k_elab_equiv (continuation_elaborator_with_bind_nondep frame (T_IntroPure g p p_typing pv) h) (RU.magic ()) (RU.magic ()) + k_elab_equiv (continuation_elaborator_with_bind_nondep frame (T_IntroPure g p pv) h) (RU.magic ()) (RU.magic ()) post t let is_uvar (t:term) : bool = @@ -448,7 +448,7 @@ let intro_exists (g: env) (frame: slprop) (u: universe) (b: binder) (body: slpro let h2: slprop_equiv g (tm_star frame (comp_pre (comp_intro_exists u b body e))) (tm_star frame (open_term' body e 0)) = RU.magic () in let h3: slprop_equiv g (tm_star (comp_post (comp_intro_exists u b body e)) frame) (tm_star frame (tm_exists_sl u b body)) = RU.magic () in debug_prover g (fun _ -> Printf.sprintf "intro_exists %s\nframe=%s\n" (show (tm_exists_sl u b body)) (show frame)); - k_elab_equiv (continuation_elaborator_with_bind_nondep frame (T_IntroExists g u b body e binder_ty_typ tm_ex_typ e_typ) h1) h2 h3 + k_elab_equiv (continuation_elaborator_with_bind_nondep frame (T_IntroExists g u b body e) h1) h2 h3 post t let prove_exists (g: env) (ctxt: list slprop_view) (goal: slprop_view) : @@ -636,7 +636,7 @@ let elim_exists (g: env) (frame: slprop) u b body (x: nvar { ~(Set.mem (snd x) ( let c = comp_elim_exists u b.binder_ty body x in let h1: tot_typing g b.binder_ty (tm_type u) = RU.magic () in let h2: tot_typing g (tm_exists_sl u (as_binder b.binder_ty) body) tm_slprop = RU.magic () in - let typing: st_typing g _ c = T_ElimExists g u b.binder_ty body (snd x) h1 h2 in + let typing: st_typing g _ c = T_ElimExists g u b.binder_ty body (snd x) in let h: tot_typing g (tm_star frame (comp_pre c)) tm_slprop = RU.magic () in let c_post_x = open_term' body (mk_reveal u b.binder_ty (term_of_nvar x)) 0 in assume open_term (comp_post c) (snd x) == c_post_x; @@ -1486,4 +1486,4 @@ let try_frame_pre (allow_ambiguous : bool) (#g:env) let (| g', ctxt', k |) = prove t.range g ctxt (comp_pre c) allow_ambiguous in let d: st_typing g' t c = RU.magic () in // weakening from g to g' let h1: tot_typing g' ctxt' tm_slprop = RU.magic() in // weakening from to g' - checker_result_for_st_typing (k _ (| t, add_frame c ctxt', T_Frame _ _ _ ctxt' h1 d |)) res_ppname \ No newline at end of file + checker_result_for_st_typing (k _ (| t, add_frame c ctxt', T_Frame _ _ _ ctxt' d |)) res_ppname \ No newline at end of file diff --git a/src/checker/Pulse.Checker.Pure.fst b/src/checker/Pulse.Checker.Pure.fst index 530bb0e6f..611081970 100644 --- a/src/checker/Pulse.Checker.Pure.fst +++ b/src/checker/Pulse.Checker.Pure.fst @@ -147,7 +147,7 @@ let squash_prop_validity_token f p (t:prop_validity_token f (mk_squash0 p)) let rtb_check_prop_validity (g:env) (sync:bool) (f:_{f == elab_env g }) (p:_) (pf:tot_typing g p tm_prop) = let _ : squash (typing_token f p (E_Total, tm_prop)) = - let E pf = pf in FStar.Squash.return_squash (coerce_eq () <| RT.typing_to_token pf) + magic () in debug g (fun _ -> Printf.sprintf "(%s) Calling check_prop_validity on %s" @@ -317,7 +317,7 @@ let check_universe_aux (g:env) (t:term) (t_well_typed:bool) FStar.Squash.get_proof _ in let proof : RT.typing f t (E_Total, R.pack_ln (R.Tv_Type ru)) = RT.T_Token _ _ _ proof in - (| ru, E proof |) + (| ru, () |) in RU.record_stats "check_universe" aux @@ -353,7 +353,7 @@ let compute_term_type (g:env) (t:term) match res with | None -> fail_doc_with_subissues g (Some rng) issues (ill_typed_term t None None) - | Some (| rt, eff, ty', tok |) -> (| rt, eff, ty', E tok |) + | Some (| rt, eff, ty', tok |) -> (| rt, eff, ty', () |) in RU.record_stats "Pulse.compute_term_type" aux @@ -371,7 +371,7 @@ let compute_term_type_and_u (g:env) (t:term) fail_doc_with_subissues g (Some rng) issues (ill_typed_term t None None) | Some (| rt, eff, ty', tok |) -> let (| u, uty |) = check_universe_aux g ty' true in //ty' is well-typed; we just need to find its universe - (| rt, eff, ty', (| u, uty |), E tok |) + (| rt, eff, ty', (| u, uty |), () |) in RU.record_stats "Pulse.compute_term_type_and_u" aux @@ -389,7 +389,7 @@ let check_term (g:env) (e:term) (eff:T.tot_or_ghost) (t:term) match topt with | None -> fail_doc_with_subissues g (Some rng) issues (ill_typed_term e (Some t) None) - | Some tok -> (| e, E (RT.T_Token _ _ _ (FStar.Squash.return_squash tok)) |) + | Some tok -> (| e, () |) in RU.record_stats "Pulse.check_term" aux @@ -408,7 +408,7 @@ let check_term_at_type (g:env) (e:term) (t:term) | None -> fail_doc_with_subissues g (Some rng) issues (ill_typed_term e (Some t) None) | Some eff -> - (| e, eff, E (RT.T_Token _ _ _ (FStar.Squash.get_proof _)) |) + (| e, eff, () |) in RU.record_stats "Pulse.check_term_at_type" aux @@ -471,7 +471,7 @@ let core_compute_term_type (g:env) (t:term) match res with | None -> fail_doc_with_subissues g (Some <| RU.range_of_term t) issues (ill_typed_term t None None) - | Some (| eff, ty', tok |) -> (| eff, ty', E tok |) + | Some (| eff, ty', tok |) -> (| eff, ty', () |) in RU.record_stats "Pulse.core_compute_term_type" aux @@ -486,7 +486,7 @@ let core_check_term' g e eff t extra_msg match topt with | None -> fail_doc_with_subissues g (Some <| RU.range_of_term e) issues (extra_msg () @ ill_typed_term e (Some t) None) - | Some tok -> E (RT.T_Token _ _ _ (FStar.Squash.return_squash tok)) + | Some tok -> () in RU.record_stats "Pulse.core_check_term" aux @@ -506,7 +506,7 @@ let core_check_term_at_type g e t | None -> fail_doc_with_subissues g (Some <| RU.range_of_term e) issues (ill_typed_term e (Some t) None) | Some eff -> - (| eff, E (RT.T_Token _ _ _ (FStar.Squash.get_proof _)) |) + (| eff, () |) in RU.record_stats "Pulse.core_check_term_at_type" aux @@ -601,7 +601,7 @@ let try_get_non_informative_witness_aux (g:env) (u:universe) (ty:term) (ty_typin let dict = wr r_dict (RU.range_of_term ty) in let r_dict_typing_token : squash (typing_token r_env r_dict (E_Total, goal)) = () in let r_dict_typing : RT.typing r_env r_dict (E_Total, goal) = RT.T_Token _ _ _ () in - let dict_typing : tot_typing g dict (non_informative_class u ty) = E r_dict_typing in + let dict_typing : tot_typing g dict (non_informative_class u ty) = () in Some (| dict, dict_typing |), issues ) diff --git a/src/checker/Pulse.Checker.Return.fst b/src/checker/Pulse.Checker.Return.fst index ef10c914e..a4d9bb6fe 100644 --- a/src/checker/Pulse.Checker.Return.fst +++ b/src/checker/Pulse.Checker.Return.fst @@ -88,8 +88,7 @@ let check_core match post_hint with | PostHint post -> assert (g `env_extends` post.g); - let ty_typing : universe_of g post.ret_ty post.u = - Metatheory.tot_typing_weakening_standard post.g post.ty_typing g in + let ty_typing : universe_of g post.ret_ty post.u = () in Some (| post.ret_ty, post.u, ty_typing |) | _ -> match inspect_term expected_type with @@ -136,7 +135,7 @@ let check_core let use_eq = use_eq || (not (PostHint? post_hint) && not (T.term_eq ty (`unit))) in assume (open_term (close_term post_opened x) x == post_opened); let post = close_term post_opened x in - let d = T_Return g c use_eq u ty t post x uty d post_typing in + let d = T_Return g c use_eq u ty t post x in let (|c',d'|) = match_comp_res_with_post_hint d post_hint in Pulse.Checker.Util.debug g "pulse.return" (fun _ -> Printf.sprintf "Return comp is: %s" diff --git a/src/checker/Pulse.Checker.Rewrite.fst b/src/checker/Pulse.Checker.Rewrite.fst index 3e9b04964..ed1d45cd2 100644 --- a/src/checker/Pulse.Checker.Rewrite.fst +++ b/src/checker/Pulse.Checker.Rewrite.fst @@ -140,6 +140,6 @@ let check (T.moduleof (fstar_env g)) "Pulse.Checker.Rewrite.check_slprop_equiv_tac" in - let d = T_Rewrite _ p q p_typing equiv_p_q in + let d = T_Rewrite _ p q equiv_p_q in let (| c,d |) = match_comp_res_with_post_hint d post_hint in prove_post_hint (try_frame_pre false pre_typing (| _,c,d |) res_ppname) post_hint t.range diff --git a/src/checker/Pulse.Checker.ST.fst b/src/checker/Pulse.Checker.ST.fst index d3514f44a..522e5c584 100644 --- a/src/checker/Pulse.Checker.ST.fst +++ b/src/checker/Pulse.Checker.ST.fst @@ -107,12 +107,12 @@ let check in let h: tot_typing g' ctxt' tm_slprop = RU.magic () in // TODO: thread through prover if comp_post c `eq_tm` tm_is_unreachable then - let framed = checker_result_for_st_typing (k _ (| t, add_frame c ctxt', T_Frame _ _ _ ctxt' h d |)) res_ppname in + let framed = checker_result_for_st_typing (k _ (| t, add_frame c ctxt', T_Frame _ _ _ ctxt' d |)) res_ppname in RU.record_stats "prove_post_hint" fun _ -> prove_post_hint framed post_hint range else // TODO: not sure why we need the type equality check below.. let (| c, d |) = match_comp_res_with_post_hint d post_hint in - let framed = checker_result_for_st_typing (k _ (| t, add_frame c ctxt', T_Frame _ _ _ ctxt' h d |)) res_ppname in + let framed = checker_result_for_st_typing (k _ (| t, add_frame c ctxt', T_Frame _ _ _ ctxt' d |)) res_ppname in RU.record_stats "prove_post_hint" fun _ -> prove_post_hint framed post_hint range ) #pop-options \ No newline at end of file diff --git a/src/checker/Pulse.Checker.While.fst b/src/checker/Pulse.Checker.While.fst index 1e0c1a397..36966c286 100644 --- a/src/checker/Pulse.Checker.While.fst +++ b/src/checker/Pulse.Checker.While.fst @@ -48,7 +48,7 @@ let inv_as_post_hint (#g:env) (#inv:slprop) (inv_typing:tot_typing g inv tm_slpr = let (| x, post_typing_src |) = inv_typing_weakening inv_typing in { g; effect_annot=EffectAnnotSTT; effect_annot_typing=(); ret_ty=tm_unit; u=u0; ty_typing=unit_typing g; post=inv; - x; post_typing_src; post_typing=RU.magic() } + x; post_typing_src } let tm_l_true : term = FStar.Reflection.V2.Formula.(formula_as_term True_) let tm_l_or (a b: term) : term = FStar.Reflection.V2.Formula.(formula_as_term (Or a b)) @@ -253,7 +253,7 @@ let check_while let r_body = check (push_context "check_while_body" body.range g2) - _ body_pre_typing (PostHint body_ph) ppname_default body + (open_term' body_pre_open tm_true 0) body_pre_typing (PostHint body_ph) ppname_default body in let (| cond, comp_cond, cond_typing |) = r_cond in let (| body, comp_body, body_typing |) = apply_checker_result_k r_body ppname_default in @@ -270,11 +270,10 @@ let check_while assume ~(snd x_meas `Set.mem` freevars_st cond); assume ~(snd x_meas `Set.mem` freevars_st body); let d: st_typing g1' while (comp_while u_meas ty_meas x_meas inv body_pre_open) = - let h = RU.magic () in T_While g1' inv body_pre_open cond body - u_meas ty_meas typ_meas is_tot + u_meas ty_meas is_tot x_meas g2 - inv_typing2 h cond_typing body_typing + cond_typing body_typing in let C_ST cst = comp_while u_meas ty_meas x_meas inv body_pre_open in let loop_pre = tm_exists_sl u_meas (as_binder ty_meas) (close_term inv (snd x_meas)) in @@ -291,8 +290,7 @@ let check_while ty_typing=RU.magic(); //unit typing post=break_pred; x; - post_typing_src=RU.magic(); //from inv typing and body_open_pre_typing - post_typing=RU.magic() + post_typing_src=RU.magic() //from inv typing and body_open_pre_typing } in let res = prove_post_hint res (PostHint post_hint_for_while) t.range in diff --git a/src/checker/Pulse.Checker.WithLocal.fst b/src/checker/Pulse.Checker.WithLocal.fst index 38596fb63..8a252e7f7 100644 --- a/src/checker/Pulse.Checker.WithLocal.fst +++ b/src/checker/Pulse.Checker.WithLocal.fst @@ -39,7 +39,7 @@ let extend_post_hint_for_local (g:env) (p:post_hint_for_env g) = let conjunct = withlocal_post init_t (term_of_nvar (n, x)) in let g' = extend_env g x n init_t in let c_typing = Pulse.Checker.Pure.core_check_term (push_binding g x n (mk_ref init_t)) conjunct T.E_Total tm_slprop in - let res = Pulse.Checker.Base.extend_post_hint g p x (mk_ref init_t) _ c_typing in + let res = Pulse.Checker.Base.extend_post_hint g p x (mk_ref init_t) conjunct c_typing in res let with_local_pre_typing (#g:env) (#pre:term) (pre_typing:tot_typing g pre tm_slprop) @@ -162,14 +162,11 @@ let check match init with | None -> let d = T_WithLocalUninit g binder.binder_ppname body init_t c x - init_t_typing c_typing body_typing in checker_result_for_st_typing (| _, _, d |) res_ppname | Some init -> let d = T_WithLocal g binder.binder_ppname init body init_t c x - init_typing - init_t_typing c_typing body_typing in checker_result_for_st_typing (| _, _, d |) res_ppname diff --git a/src/checker/Pulse.Checker.WithLocalArray.fst b/src/checker/Pulse.Checker.WithLocalArray.fst index 348799338..7a24e5a65 100644 --- a/src/checker/Pulse.Checker.WithLocalArray.fst +++ b/src/checker/Pulse.Checker.WithLocalArray.fst @@ -49,7 +49,7 @@ let extend_post_hint | None -> mk_array_pts_to_uninit_post init_t arr) in let g' = push_binding g x n (mk_array init_t) in let c_typing = Pulse.Checker.Pure.core_check_term g' conjunct T.E_Total tm_slprop in - let res = Pulse.Checker.Base.extend_post_hint g p x (mk_array init_t) _ c_typing in + let res = Pulse.Checker.Base.extend_post_hint g p x (mk_array init_t) conjunct c_typing in res @@ -184,16 +184,11 @@ let check match init with | Some init -> let d = T_WithLocalArray g binder.binder_ppname init len body init_t c x - init_typing - len_typing - init_t_typing c_typing body_typing in checker_result_for_st_typing (| _, _, d |) res_ppname | None -> let d = T_WithLocalArrayUninit g binder.binder_ppname len body init_t c x - len_typing - init_t_typing c_typing body_typing in checker_result_for_st_typing (| _, _, d |) res_ppname diff --git a/src/checker/Pulse.Elaborate.Core.fst b/src/checker/Pulse.Elaborate.Core.fst index 4eaa01235..257957d5e 100644 --- a/src/checker/Pulse.Elaborate.Core.fst +++ b/src/checker/Pulse.Elaborate.Core.fst @@ -170,132 +170,7 @@ let rec elab_st_typing (#g:env) (#c:comp) (d:st_typing g t c) : GTot R.term (decreases d) - = match d with - | T_Abs _ x qual b _u body _c ty_typing body_typing -> - let ty = b.binder_ty in - let ppname = b.binder_ppname.name in - let body = elab_st_typing body_typing in - mk_abs_with_name ppname ty (elab_qual qual) (RT.close_term body x) //this closure should be provably redundant by strengthening the conditions on x - - | T_ST _ t _ _ - | T_STGhost _ t _ _ _ -> t - - | T_Return _ c use_eq u ty t post _ _ _ _ -> - let rp = mk_abs ty R.Q_Explicit post in - (match c, use_eq with - | STT, true -> mk_stt_return u ty t rp - | STT, false -> mk_stt_return_noeq u ty t rp - | STT_Atomic, true -> mk_stt_atomic_return u ty t rp - | STT_Atomic, false -> mk_stt_atomic_return_noeq u ty t rp - | STT_Ghost, true -> mk_stt_ghost_return u ty t rp - | STT_Ghost, false -> mk_stt_ghost_return_noeq u ty t rp) - - | T_Bind _ e1 e2 c1 c2 b x c e1_typing t_typing e2_typing bc -> - let e1 = elab_st_typing e1_typing in - let e2 = elab_st_typing e2_typing in - let ty1 = comp_res c1 in - elab_bind bc e1 (mk_abs_with_name b.binder_ppname.name ty1 R.Q_Explicit (RT.close_term e2 x)) - - | T_BindFn _ _ _ c1 c2 b x e1_typing _u t_typing e2_typing c2_typing -> - let e1 = elab_st_typing e1_typing in - let e2 = elab_st_typing e2_typing in - let ty1 = comp_res c1 in - RT.mk_let RT.pp_name_default e1 ty1 (RT.close_term e2 x) - - | T_Frame _ _ c frame _frame_typing e_typing -> - let e = elab_st_typing e_typing in - elab_frame c frame e - - | T_Equiv _ _ c1 c2 e_typing (ST_TotEquiv _ _ _ _ _ _) -> - let e = elab_st_typing e_typing in - e - - | T_Equiv _ _ c1 c2 e_typing _ -> - let e = elab_st_typing e_typing in - elab_sub c1 c2 e - - | T_Sub _ _ c1 c2 e_typing d_sub -> - let e = elab_st_typing e_typing in - let (| coercion, _ |) = elab_st_sub d_sub in - R.mk_e_app coercion [e] - - | T_Lift _ _ c1 c2 e_typing lc -> - let e = elab_st_typing e_typing in - elab_lift lc e - - | T_If _ b _ _ _ _ _ e1_typing e2_typing _c_typing -> - let re1 = elab_st_typing e1_typing in - let re2 = elab_st_typing e2_typing in - RT.mk_if b re1 re2 - - | T_Match _ _ _ sc _ _ _ _ _ brty _ -> - let brs = elab_branches brty in - R.pack_ln (R.Tv_Match sc None brs) - - | T_IntroPure _ p _ _ -> - let head = - tm_pureapp (tm_fvar (as_fv (mk_pulse_lib_core_lid "intro_pure"))) - None - p - in - let arg = (`()) in - R.mk_app head [(arg, elab_qual None)] - - | T_ElimExists _ u t p _ d_t d_exists -> - mk_elim_exists u t (mk_abs t R.Q_Explicit p) - - | T_IntroExists _ u b p e _ _ _ -> - let rt = b.binder_ty in - mk_intro_exists u rt (mk_abs rt R.Q_Explicit p) e - - | T_While .. -> - admit () - // let cond = elab_st_typing cond_typing in - // let body = elab_st_typing body_typing in - // mk_while inv (mk_abs bool_tm R.Q_Explicit post) cond body - - | T_Rewrite _ p q _ _ -> - mk_rewrite p q - - | T_WithLocal _ _ init _ init_t c x _ _ _ body_typing -> - let rret_u = comp_u c in - let rret_t = comp_res c in - let rpre = comp_pre c in - let rpost = mk_abs rret_t R.Q_Explicit (comp_post c) in - let rbody = elab_st_typing body_typing in - let rbody = RT.close_term rbody x in - let rbody = mk_abs (mk_ref init_t) R.Q_Explicit rbody in - mk_withlocal rret_u init_t init rpre rret_t rpost rbody - - | T_WithLocalUninit .. -> - admit () - - | T_WithLocalArray _ _ init len _ init_t c x _ _ _ _ body_typing -> - let rret_u = comp_u c in - let rret_t = comp_res c in - let rpre = comp_pre c in - let rpost = mk_abs rret_t R.Q_Explicit (comp_post c) in - let rbody = elab_st_typing body_typing in - let rbody = RT.close_term rbody x in - let rbody = mk_abs (mk_array init_t) R.Q_Explicit rbody in - mk_withlocalarray rret_u init_t init len rpre rret_t rpost rbody - - | T_WithLocalArrayUninit .. -> - admit () - - | T_Admit _ c _ -> - let {u; res; pre; post} = st_comp_of_comp c in - let rpost = mk_abs res R.Q_Explicit post in - (match c with - | C_ST _ -> mk_stt_admit u res pre rpost - | C_STAtomic _ _ _ -> mk_stt_atomic_admit u res pre rpost - | C_STGhost _ _ -> mk_stt_ghost_admit u res pre rpost) - - | T_ForwardJumpLabel .. -> admit () - | T_Goto .. -> admit () - - | T_Unreachable .. -> - `("IOU: elab_st_typing of T_Unreachable") + = RU.magic () and elab_br (#g:env) (#c:comp_st) @@ -304,9 +179,7 @@ and elab_br (#g:env) (#e:st_term) (d : br_typing g sc_u sc_ty sc p e c) : GTot R.branch (decreases d) - = let TBR _ _ _ _ _ _ _ _ bs _ _ _ ed = d in - let e = elab_st_typing ed in - (elab_pat p, e) + = RU.magic () and elab_branches (#g:env) (#c:comp_st) (#sc_u:universe) (#sc_ty:typ) (#sc:term) @@ -314,7 +187,4 @@ and elab_branches (#g:env) (d : brs_typing g sc_u sc_ty sc brs c) : GTot (list R.branch) (decreases d) - = match d with - | TBRS_0 _ -> [] - | TBRS_1 _ p e bd _ d' -> - elab_br bd :: elab_branches d' + = RU.magic () diff --git a/src/checker/Pulse.JoinComp.fst b/src/checker/Pulse.JoinComp.fst index 9bd245a06..4b4622973 100644 --- a/src/checker/Pulse.JoinComp.fst +++ b/src/checker/Pulse.JoinComp.fst @@ -132,7 +132,7 @@ let infer_post' (g:env) (g':env { g' `env_extends` g }) { g; effect_annot=EffectAnnotSTT; effect_annot_typing=(); ret_ty=t; u; ty_typing; - post; x; post_typing_src; post_typing=RU.magic() + post; x; post_typing_src } in let post = RU.beta_lax (elab_env g) post in // clean up spurious dependencies on variables @@ -371,7 +371,7 @@ let join_post #g #hyp #b let res : post_hint_for_env g = {g; effect_annot=eff; effect_annot_typing=eff_ty; ret_ty=p1.ret_ty; u=u; ty_typing; x; - post=joined_post; post_typing_src; post_typing=RU.magic()} + post=joined_post; post_typing_src} in res diff --git a/src/checker/Pulse.Main.fst b/src/checker/Pulse.Main.fst index 3783a7fb7..c31e5092e 100644 --- a/src/checker/Pulse.Main.fst +++ b/src/checker/Pulse.Main.fst @@ -25,7 +25,6 @@ open Pulse.Syntax open Pulse.Typing open Pulse.Checker open Pulse.Elaborate -open Pulse.Soundness module RU = Pulse.RuntimeUtils module P = Pulse.Syntax.Printer module Rec = Pulse.Recursion @@ -44,7 +43,7 @@ let set_impl src_g #g #t (se: RT.sigelt_for g t) (r: bool) (impl: R.term) : T.Ta #push-options "--z3rlimit_factor 4" let check_fndefn (d : decl{FnDefn? d.d}) - (g : Soundness.Common.stt_env{bindings g == []}) + (g : stt_env{bindings g == []}) (expected_t : option term) (* Both of these unused: *) (pre : term) (pre_typing : tot_typing g pre tm_slprop) @@ -70,7 +69,7 @@ let check_fndefn let rng = body.range in debug_main g (fun _ -> Printf.sprintf "\nbody after mk_abs:\n%s\n" (P.st_term_to_string body)); - let (| body, c, t_typing |) = Pulse.Checker.Abs.check_abs g body Pulse.Checker.check in + let (| body, c, _t_typing |) = Pulse.Checker.Abs.check_abs g body Pulse.Checker.check in Pulse.Checker.Prover.Util.debug_prover g (fun _ -> Printf.sprintf "\ncheck call returned in main with:\n%s\nat type %s\n" @@ -88,7 +87,6 @@ let check_fndefn it since it will go directly into the checked files. If we do not, a lambda could remain here, and cause an error in output_value. *) let blob = "pulse", refl_e in - soundness_lemma g body c t_typing; let cur_module = T.cur_module () in @@ -110,9 +108,9 @@ let check_fndefn let mk_main_decl (refl_t:typ) - (_:squash (RT.tot_typing (elab_env g) (elab_st_typing t_typing) refl_t)) = + (_:squash (RT.tot_typing (elab_env g) (RU.magic #R.term ()) refl_t)) = let nm = fst (inspect_ident id) in - Reflection.Util.mk_opaque_let (fstar_env g) cur_module nm us (elab_st_typing t_typing) refl_t + Reflection.Util.mk_opaque_let (fstar_env g) cur_module nm us (RU.magic #R.term ()) refl_t in if fn_d.isrec @@ -124,7 +122,7 @@ let check_fndefn // // So, nothing to be done for expected type here // - let main_decl = mk_main_decl refl_t () in + let main_decl = mk_main_decl refl_t (FStar.Squash.return_squash (RU.magic ())) in let main_decl : RT.sigelt_for (elab_env g) None = main_decl in let (chk, se, _) = main_decl in let nm = R.pack_ln (R.Tv_Const (R.C_String nm_orig)) in @@ -144,16 +142,16 @@ let check_fndefn // let (| refl_t, _ |) : refl_t:term { Some? expected_t ==> Some refl_t == expected_t } & - squash (RT.tot_typing (elab_env g) (elab_st_typing t_typing) refl_t) = + squash (RT.tot_typing (elab_env g) (RU.magic #R.term ()) refl_t) = match expected_t with - | None -> (| refl_t, FStar.Squash.get_proof _ |) + | None -> (| refl_t, FStar.Squash.return_squash (RU.magic ()) |) | Some t -> let tok = Pulse.Checker.Pure.check_subtyping g refl_t t in let refl_t_typing - : squash (RT.tot_typing (elab_env g) (elab_st_typing t_typing) refl_t) = () in - let sq : squash (RT.tot_typing (elab_env g) (elab_st_typing t_typing) t) = + : squash (RT.tot_typing (elab_env g) (RU.magic #R.term ()) refl_t) = FStar.Squash.return_squash (RU.magic ()) in + let sq : squash (RT.tot_typing (elab_env g) (RU.magic #R.term ()) t) = FStar.Squash.bind_squash refl_t_typing (fun refl_t_typing -> FStar.Squash.return_squash ( RT.T_Sub _ _ _ _ @@ -164,7 +162,7 @@ let check_fndefn (| t, sq |) in - let main_decl = mk_main_decl refl_t () in + let main_decl = mk_main_decl refl_t (FStar.Squash.return_squash (RU.magic ())) in let chk, se, _ = main_decl in let main_decl = chk, se, Some blob in [], maybe_add_impl (Some refl_t) main_decl, [] @@ -173,7 +171,7 @@ let check_fndefn let check_fndecl (d : decl{FnDecl? d.d}) - (g : Soundness.Common.stt_env{bindings g == []}) + (g : stt_env{bindings g == []}) : T.Tac (RT.dsl_tac_result_t (fstar_env g) None) = let FnDecl { id; us; bs; comp } = d.d in @@ -196,7 +194,7 @@ let check_fndecl in let body = Pulse.Checker.Abs.mk_abs g bs body comp in let rng = body.range in - let (| _, c, t_typing |) = + let (| _, c, _t_typing |) = (* We don't want to print the diagnostic for the admit in the body. *) RU.with_extv "pulse:no_admit_diag" "1" (fun () -> Pulse.Checker.Abs.check_abs g body Pulse.Checker.check @@ -215,7 +213,7 @@ let check_fndecl let main' (d:decl) (pre:term) (g:RT.fstar_top_env) (expected_t:option term) : T.Tac (RT.dsl_tac_result_t g expected_t) - = match Pulse.Soundness.Common.check_top_level_environment g with + = match check_top_level_environment g with | None -> T.fail "pulse main: top-level environment does not include stt at the expected types" | Some g -> if RU.debug_at_level (fstar_env g) "Pulse" then diff --git a/src/checker/Pulse.Soundness.Admit.fst b/src/checker/Pulse.Soundness.Admit.fst deleted file mode 100644 index cd99a04bc..000000000 --- a/src/checker/Pulse.Soundness.Admit.fst +++ /dev/null @@ -1,50 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Soundness.Admit - -module RT = FStar.Reflection.Typing - -open Pulse.Syntax -open Pulse.Reflection.Util -open Pulse.Typing -open Pulse.Elaborate.Pure -open Pulse.Elaborate.Core -open Pulse.Elaborate -open Pulse.Soundness.Common - -module WT = Pulse.Lib.Core.Typing -module Comp = Pulse.Soundness.Comp - -let admit_soundess - (#g:stt_env) - (#t:st_term) - (#c:comp) - (d:st_typing g t c{T_Admit? d}) - : GTot (RT.tot_typing (elab_env g) - (elab_st_typing d) - (elab_comp c)) = - - let T_Admit _ c c_typing = d in - let st_typing, _ = Pulse.Typing.Metatheory.Base.comp_typing_inversion c_typing in - - let rt_typing, rpre_typing, rpost_typing = Comp.stc_soundness st_typing in - match c with - | C_ST _ -> - WT.stt_admit_typing rt_typing rpre_typing rpost_typing - | C_STAtomic _ _ _ -> admit () - | C_STGhost _ _ -> admit () - diff --git a/src/checker/Pulse.Soundness.Admit.fsti b/src/checker/Pulse.Soundness.Admit.fsti deleted file mode 100644 index 3b4973fdb..000000000 --- a/src/checker/Pulse.Soundness.Admit.fsti +++ /dev/null @@ -1,34 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Soundness.Admit - -open Pulse.Syntax -open Pulse.Typing -open Pulse.Elaborate.Pure -open Pulse.Elaborate.Core -open Pulse.Soundness.Common - -module RT = FStar.Reflection.Typing - -val admit_soundess - (#g:stt_env) - (#t:st_term) - (#c:comp) - (d:st_typing g t c{T_Admit? d}) - : GTot (RT.tot_typing (elab_env g) - (elab_st_typing d) - (elab_comp c)) diff --git a/src/checker/Pulse.Soundness.Bind.fst b/src/checker/Pulse.Soundness.Bind.fst deleted file mode 100644 index e68578f40..000000000 --- a/src/checker/Pulse.Soundness.Bind.fst +++ /dev/null @@ -1,229 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Soundness.Bind -module RT = FStar.Reflection.Typing -module R = FStar.Reflection.V2 -module T = FStar.Tactics.V2 -open FStar.List.Tot -open Pulse.Syntax -open Pulse.Typing -open Pulse.Elaborate -open Pulse.Soundness.Common - -#set-options "--z3rlimit_factor 5" -(*** Soundness of bind elaboration *) - - -(* x:t1 -> stt t2 pre post ~ x:t1 -> stt t2 ((fun x -> pre) x) post *) -let mequiv_arrow (g:R.env) (t1:R.term) (u2:R.universe) (t2:R.term) (pre:R.term) (post:R.term) //need some ln preconditions - : GTot (RT.equiv g (mk_arrow (t1, R.Q_Explicit) - (mk_stt_comp u2 t2 pre post)) - (mk_arrow (t1, R.Q_Explicit) - (mk_stt_comp u2 t2 (R.mk_app (mk_abs t1 R.Q_Explicit pre) [bound_var 0, R.Q_Explicit]) post))) - = admit() - - -#push-options "--fuel 2 --ifuel 1" -let inst_bind_t1 #u1 #u2 #g #head - (head_typing: RT.tot_typing g head (bind_type u1 u2)) - (#t1:_) - (t1_typing: RT.tot_typing g t1 (RT.tm_type u1)) - : GTot (RT.tot_typing g (R.mk_app head [(t1, R.Q_Implicit)]) (bind_type_t1 u1 u2 t1)) - = let open_with_spec (t v:R.term) - : Lemma (RT.open_with t v == RT.subst_term t [ RT.DT 0 v ]) - [SMTPat (RT.open_with t v)] - = RT.open_with_spec t v - in - let d : RT.tot_typing g (R.mk_app head [(t1, R.Q_Implicit)]) _ = - RT.T_App _ _ _ _ - (RT.subst_term (bind_type_t1 u1 u2 (mk_name 4)) [ RT.ND 4 0 ]) - _ head_typing t1_typing - in - assume (bind_type_t1 u1 u2 t1 == - RT.open_with (RT.subst_term (bind_type_t1 u1 u2 (mk_name 4)) - [ RT.ND 4 0 ]) - t1); - - d -#pop-options - -let inst_bind_t2 #u1 #u2 #g #head #t1 - (head_typing: RT.tot_typing g head (bind_type_t1 u1 u2 t1)) - (#t2:_) - (t2_typing: RT.tot_typing g t2 (RT.tm_type u2)) - : RT.tot_typing g (R.mk_app head [(t2, R.Q_Implicit)]) (bind_type_t1_t2 u1 u2 t1 t2) - = admit() - - -let inst_bind_pre #u1 #u2 #g #head #t1 #t2 - (head_typing: RT.tot_typing g head (bind_type_t1_t2 u1 u2 t1 t2)) - (#pre:_) - (pre_typing: RT.tot_typing g pre slprop_tm) - : RT.tot_typing g (R.mk_app head [(pre, R.Q_Implicit)]) (bind_type_t1_t2_pre u1 u2 t1 t2 pre) - = admit() - -let inst_bind_post1 #u1 #u2 #g #head #t1 #t2 #pre - (head_typing: RT.tot_typing g head (bind_type_t1_t2_pre u1 u2 t1 t2 pre)) - (#post1:_) - (post1_typing: RT.tot_typing g post1 (post1_type_bind t1)) - : RT.tot_typing g (R.mk_app head [(post1, R.Q_Implicit)]) (bind_type_t1_t2_pre_post1 u1 u2 t1 t2 pre post1) - = admit() - -let inst_bind_post2 #u1 #u2 #g #head #t1 #t2 #pre #post1 - (head_typing: RT.tot_typing g head (bind_type_t1_t2_pre_post1 u1 u2 t1 t2 pre post1)) - (#post2:_) - (post2_typing: RT.tot_typing g post2 (post2_type_bind t2)) - : RT.tot_typing g (R.mk_app head [(post2, R.Q_Implicit)]) (bind_type_t1_t2_pre_post1_post2 u1 u2 t1 t2 pre post1 post2) - = admit() - -let inst_bind_f #u1 #u2 #g #head #t1 #t2 #pre #post1 #post2 - (head_typing: RT.tot_typing g head (bind_type_t1_t2_pre_post1_post2 u1 u2 t1 t2 pre post1 post2)) - (#f:_) - (f_typing: RT.tot_typing g f (mk_stt_comp u1 t1 pre post1)) - : RT.tot_typing g (R.mk_app head [(f, R.Q_Explicit)]) (bind_type_t1_t2_pre_post1_post2_f u1 u2 t1 t2 pre post1 post2) - = admit() - -let inst_bind_g #u1 #u2 #g #head #t1 #t2 #pre #post1 #post2 - (head_typing: RT.tot_typing g head (bind_type_t1_t2_pre_post1_post2_f u1 u2 t1 t2 pre post1 post2)) - (#gg:_) - (g_typing: RT.tot_typing g gg (g_type_bind u2 t1 t2 post1 post2)) - : RT.tot_typing g (R.mk_app head [(gg, R.Q_Explicit)]) (bind_res u2 t2 pre post2) - = let open_with_spec (t v:R.term) - : Lemma (RT.open_with t v == RT.subst_term t [ RT.DT 0 v ]) - [SMTPat (RT.open_with t v)] - = RT.open_with_spec t v - in - let d : RT.tot_typing g (R.mk_app head [(gg, R.Q_Explicit)]) _ = - RT.T_App _ _ _ _ (bind_res u2 t2 pre post2) _ head_typing g_typing - in - admit(); - d - -#push-options "--z3rlimit_factor 8" -let elab_bind_typing (g:stt_env) - (c1 c2 c:ln_comp) - (x:var { ~ (x `Set.mem` freevars_comp c1) }) - (r1:R.term) - (r1_typing: RT.tot_typing (elab_env g) r1 (elab_comp c1)) - (r2:R.term) - (r2_typing: RT.tot_typing (elab_env g) r2 - (tm_arrow (null_binder (comp_res c1)) None (close_comp c2 x))) - (bc:bind_comp g x c1 c2 c) - (t2_typing : RT.tot_typing (elab_env g) (comp_res c2) (RT.tm_type (comp_u c2))) - (post2_typing: RT.tot_typing (elab_env g) - (elab_comp_post c2) - (post2_type_bind (comp_res c2))) - = assume (C_ST? c1 /\ C_ST? c2); - let rg = elab_env g in - let u1 = comp_u c1 in - let u2 = comp_u c2 in - let bind_lid = mk_pulse_lib_core_lid "bind_stt" in - let bind_fv = R.pack_fv bind_lid in - let head = R.pack_ln (R.Tv_UInst bind_fv [u1;u2]) in - assume (RT.lookup_fvar_uinst rg bind_fv [u1; u2] == Some (bind_type u1 u2)); - let head_typing : RT.tot_typing _ _ (bind_type u1 u2) = RT.T_UInst rg bind_fv [u1;u2] in - let (| _, c1_typing |) = RT.type_correctness _ _ _ r1_typing in - let t1_typing, pre_typing, post_typing = inversion_of_stt_typing _ _ c1_typing in - let t1 = (comp_res c1) in - let t2 = (comp_res c2) in - let t1_typing : RT.tot_typing rg t1 (RT.tm_type u1) = t1_typing in - let post1 = elab_comp_post c1 in - let c2_x = close_comp c2 x in - assume (comp_res c2_x == comp_res c2); - assume (comp_post c2_x == comp_post c2); - assert (open_term (comp_post c1) x == comp_pre c2); - assert (~ (x `Set.mem` freevars (comp_post c1))); - close_open_inverse (comp_post c1) x; - assert (comp_post c1 == close_term (comp_pre c2) x); - assert (post1 == mk_abs t1 R.Q_Explicit (comp_post c1)); - assert (comp_post c1 == comp_pre (close_comp c2 x)); - //ln (comp_post c1) 0 - let g_typing - : RT.tot_typing _ _ - (mk_arrow (t1, R.Q_Explicit) - (mk_stt_comp u2 t2 (comp_post c1) (elab_comp_post c2))) - = r2_typing in - let g_typing - : RT.tot_typing _ _ - (mk_arrow (t1, R.Q_Explicit) - (mk_stt_comp u2 t2 - (R.mk_app (mk_abs t1 R.Q_Explicit (comp_post c1)) - [bound_var 0, R.Q_Explicit]) - (elab_comp_post c2))) - = RT.T_Sub _ _ _ _ r2_typing - (RT.Relc_typ _ _ _ _ _ - (RT.Rel_equiv _ _ _ _ (mequiv_arrow _ _ _ _ _ _))) - in - let d : RT.tot_typing _ (elab_bind bc r1 r2) _ = - inst_bind_g - (inst_bind_f - (inst_bind_post2 - (inst_bind_post1 - (inst_bind_pre - (inst_bind_t2 - (inst_bind_t1 head_typing t1_typing) - t2_typing) - pre_typing) - post_typing) - post2_typing) - r1_typing) - g_typing - in - d -#pop-options - -assume -val open_close_inverse_t (e:R.term { RT.ln e }) (x:var) (t:R.term) - : Lemma (RT.open_with (RT.close_term e x) t == e) - -#push-options "--z3rlimit_factor 4 --split_queries no" -let bind_fn_typing #g #t #c d soundness = - let T_BindFn _ e1 e2 c1 c2 b x e1_typing u t1_typing e2_typing c2_typing = d in - let t1 = comp_res c1 in - let g_x = push_binding g x ppname_default t1 in - - let re1 = elab_st_typing e1_typing in - let re2 = elab_st_typing e2_typing in - - let re1_typing : RT.tot_typing (elab_env g) re1 t1 = - soundness g e1 c1 e1_typing in - - let re2_typing : RT.tot_typing (elab_env g_x) re2 (elab_comp c2) = - soundness g_x (open_st_term_nv e2 (v_as_nv x)) c2 e2_typing in - - RT.well_typed_terms_are_ln _ _ _ re2_typing; - calc (==) { - RT.open_term (RT.close_term re2 x) x; - (==) { RT.open_term_spec (RT.close_term re2 x) x } - RT.subst_term (RT.close_term re2 x) (RT.open_with_var x 0); - (==) { RT.close_term_spec re2 x } - RT.subst_term (RT.subst_term re2 [ RT.ND x 0 ]) (RT.open_with_var x 0); - (==) { RT.open_close_inverse' 0 re2 x } - re2; - }; - let elab_t = RT.mk_let RT.pp_name_default re1 t1 (RT.close_term re2 x) in - let res - : RT.tot_typing (elab_env g) elab_t (RT.open_with (RT.close_term (elab_comp c2) x) re1) - = RT.T_Let (elab_env g) x re1 t1 (RT.close_term re2 x) (elab_comp c2) T.E_Total RT.pp_name_default re1_typing re2_typing in - Pulse.Typing.LN.comp_typing_ln c2_typing; - Pulse.Elaborate.elab_ln_comp c (-1); - assert (RT.ln (elab_comp c2)); - open_close_inverse_t (elab_comp c2) x re1; - assert (RT.open_with (RT.close_term (elab_comp c2) x) re1 == elab_comp c2); - res - -#pop-options diff --git a/src/checker/Pulse.Soundness.Bind.fsti b/src/checker/Pulse.Soundness.Bind.fsti deleted file mode 100644 index 142d9ef0e..000000000 --- a/src/checker/Pulse.Soundness.Bind.fsti +++ /dev/null @@ -1,54 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Soundness.Bind -module RT = FStar.Reflection.Typing -module R = FStar.Reflection.V2 -open FStar.List.Tot -open Pulse.Syntax -open Pulse.Reflection.Util -open Pulse.Typing -open Pulse.Elaborate -open Pulse.Soundness.Common - - -// Wrapper.bind_stt and Wrapper.bind_sttg -val elab_bind_typing (g:stt_env) - (c1 c2 c:ln_comp) - (x:var { ~ (x `Set.mem` freevars_comp c1) }) - (r1:R.term) - (r1_typing: RT.tot_typing (elab_env g) r1 (elab_comp c1)) - (r2:R.term) - (r2_typing: RT.tot_typing (elab_env g) r2 - (tm_arrow (null_binder (comp_res c1)) None (close_comp c2 x))) - (bc:bind_comp g x c1 c2 c) - (t2_typing : RT.tot_typing (elab_env g) (comp_res c2) (RT.tm_type (comp_u c2))) - (post2_typing: RT.tot_typing (elab_env g) - (elab_comp_post c2) - (post2_type_bind (comp_res c2))) - : Ghost (RT.tot_typing (elab_env g) (elab_bind bc r1 r2) (elab_comp c)) - (requires Bind_comp? bc) - (ensures fun _ -> True) - -val bind_fn_typing - (#g:stt_env) - (#t:st_term) - (#c:comp) - (d:st_typing g t c{T_BindFn? d}) - (soundness:soundness_t d) - : GTot (RT.tot_typing (elab_env g) - (elab_st_typing d) - (elab_comp c)) diff --git a/src/checker/Pulse.Soundness.Common.fst b/src/checker/Pulse.Soundness.Common.fst deleted file mode 100644 index 330e18ed8..000000000 --- a/src/checker/Pulse.Soundness.Common.fst +++ /dev/null @@ -1,400 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Soundness.Common -module RT = FStar.Reflection.Typing -module R = FStar.Reflection.V2 -module T = FStar.Tactics.V2 -open FStar.List.Tot -open Pulse.Syntax -open Pulse.Reflection.Util -open Pulse.Typing -open Pulse.Elaborate - -let ln_comp = c:comp_st { ln_c c } - -let rec extend_env_l_lookup_fvar (g:R.env) (sg:env_bindings) (fv:R.fv) (us:R.universes) - : Lemma - (ensures - RT.lookup_fvar_uinst (bindings_extend_env g sg) fv us == - RT.lookup_fvar_uinst g fv us) - [SMTPat (RT.lookup_fvar_uinst (bindings_extend_env g sg) fv us)] - = match sg with - | [] -> () - | hd::tl -> admit (); extend_env_l_lookup_fvar g tl fv us - -// let rec extend_env_l_lookup_bvar (g:R.env) (sg:env_bindings) (x:var) -// : Lemma -// (requires (forall x. RT.lookup_bvar g x == None)) -// (ensures (RT.lookup_bvar (extend_env_l g sg) x == elab_term_opt (lookup sg x))) -// (decreases sg) -// [SMTPat (RT.lookup_bvar (extend_env_l g sg) x)] -// = match sg with -// | [] -> () -// | hd :: tl -> extend_env_l_lookup_bvar g tl x - -let lookup_elab_env (g:env) (x:var) - : Lemma - (ensures (RT.lookup_bvar (elab_env g) x == lookup g x)) - [SMTPat (RT.lookup_bvar (elab_env g) x)] - = admit () // TODO: FIX ME!!!! - -let tot_typing_soundness (#g:env) - (#e:term) - (#t:term) - (d:tot_typing g e t) - : GTot (RT.tot_typing (elab_env g) e t) - = let E d = d in - d - -let ghost_typing_soundness (#g:env) - (#e:term) - (#t:term) - (d:ghost_typing g e t) - : GTot (RT.ghost_typing (elab_env g) e t) - = let E d = d in - d - -#push-options "--z3rlimit_factor 4" -let mk_t_abs_tot (g:env) - (#u:universe) - (#q:option qualifier) - (#ty:term) - (ppname:ppname) - (t_typing:tot_typing g ty (tm_type u)) - (#body:term) - (#body_ty:term) - (#x:var { freshv g x /\ ~(x `Set.mem` freevars body) }) - (body_typing:tot_typing (push_binding g x ppname ty) (open_term body x) body_ty) - : GTot (RT.tot_typing (elab_env g) - (mk_abs_with_name ppname.name ty (elab_qual q) body) - (tm_arrow (mk_binder_ppname ty ppname) q (close_comp (C_Tot body_ty) x))) - = let c = C_Tot body_ty in - let r_body = open_term body x in - let r_c = elab_comp c in - let r_t_typing = tot_typing_soundness t_typing in - let r_body_typing = tot_typing_soundness body_typing in - RT.well_typed_terms_are_ln _ _ _ r_body_typing; - RT.open_close_inverse r_body x; - elab_comp_close_commute c x; - assert (~ (x `Set.mem` RT.freevars body)); - assume (~ (x `Set.mem` RT.freevars (RT.close_term r_body x))); - RT.close_term_spec (elab_comp c) x; - let r_t_typing : RT.tot_typing (elab_env g) ty (RT.tm_type u) - = coerce_eq () r_t_typing //strange that this coercion is needed - in - let d : RT.tot_typing (elab_env g) - (mk_abs_with_name ppname.name ty (elab_qual q) - (RT.close_term (open_term body x) x)) - (tm_arrow (mk_binder_ppname ty ppname) q (close_comp (C_Tot body_ty) x)) - = - RT.T_Abs (elab_env g) - x - ty - (RT.close_term r_body x) - (T.E_Total, r_c) - u ppname.name (elab_qual q) - _ - r_t_typing - r_body_typing - in - elab_open_commute' body (null_var x) 0; - RT.open_term_spec body x; - let d : RT.typing _ - (mk_abs_with_name ppname.name ty (elab_qual q) - (RT.close_term (RT.open_term body x) x)) - _ - = d - in - RT.close_open_inverse body x; - d -#pop-options - -let mk_t_abs (g:env) - (#u:universe) - (#ty:term) - (#q:option qualifier) - (#t_typing:typing g ty T.E_Total (tm_type u)) - (ppname:ppname) - (r_t_typing:RT.tot_typing (elab_env g) - ty - (elab_comp (C_Tot (tm_type u)))) - (#body:st_term) - (#x:var { freshv g x /\ ~(x `Set.mem` freevars_st body) }) - (#c:comp) - (#body_typing:st_typing (push_binding g x ppname ty) (open_st_term body x) c) - (r_body_typing:RT.tot_typing (elab_env (push_binding g x ppname ty)) - (elab_st_typing body_typing) - (elab_comp c)) - : GTot (RT.tot_typing (elab_env g) - (mk_abs_with_name ppname.name ty (elab_qual q) (RT.close_term (elab_st_typing body_typing) x)) - (tm_arrow (mk_binder_ppname ty ppname) q (close_comp c x))) - = let r_body = elab_st_typing body_typing in - let r_c = elab_comp c in - RT.well_typed_terms_are_ln _ _ _ r_body_typing; - RT.open_close_inverse r_body x; - elab_comp_close_commute c x; - assume (~ (x `Set.mem` RT.freevars (RT.close_term r_body x))); - RT.close_term_spec (elab_comp c) x; - RT.T_Abs (elab_env g) - x - ty - (RT.close_term r_body x) - (T.E_Total, r_c) - u ppname.name (elab_qual q) - _ - r_t_typing - r_body_typing - -(*** Typing of combinators used - in the elaboration **) - - -(** Type of bind **) - -let bind_res (u2:R.universe) (t2 pre post2:R.term) = - mk_stt_comp u2 t2 pre post2 - -let g_type_bind (u2:R.universe) (t1 t2 post1 post2:R.term) = - mk_arrow (t1, R.Q_Explicit) - (bind_res u2 t2 (R.mk_app post1 [bound_var 0 (* x *), R.Q_Explicit]) post2) - -let bind_type_t1_t2_pre_post1_post2_f (u1 u2:R.universe) (t1 t2 pre post1 post2:R.term) = - mk_arrow (g_type_bind u2 t1 t2 post1 post2, R.Q_Explicit) - (bind_res u2 t2 pre post2) - -let bind_type_t1_t2_pre_post1_post2 (u1 u2:R.universe) (t1 t2 pre post1 post2:R.term) = - let f_type = mk_stt_comp u1 t1 pre post1 in - mk_arrow (f_type, R.Q_Explicit) - (bind_type_t1_t2_pre_post1_post2_f u1 u2 t1 t2 pre post1 post2) - -let post2_type_bind t2 = mk_arrow (t2, R.Q_Explicit) slprop_tm -let bind_type_t1_t2_pre_post1 (u1 u2:R.universe) (t1 t2 pre post1:R.term) = - let var = 0 in - let post2 = mk_name var in - mk_arrow (post2_type_bind t2, R.Q_Implicit) - (RT.subst_term (bind_type_t1_t2_pre_post1_post2 u1 u2 t1 t2 pre post1 post2) - [ RT.ND var 0 ]) - -let post1_type_bind t1 = mk_arrow (t1, R.Q_Explicit) slprop_tm -let bind_type_t1_t2_pre (u1 u2:R.universe) (t1 t2 pre:R.term) = - let var = 1 in - let post1 = mk_name var in - mk_arrow (post1_type_bind t1, R.Q_Implicit) - (RT.subst_term (bind_type_t1_t2_pre_post1 u1 u2 t1 t2 pre post1) - [ RT.ND var 0 ]) - -let bind_type_t1_t2 (u1 u2:R.universe) (t1 t2:R.term) = - let var = 2 in - let pre = mk_name var in - let pre_type = slprop_tm in - mk_arrow (pre_type, R.Q_Implicit) - (RT.subst_term (bind_type_t1_t2_pre u1 u2 t1 t2 pre) - [ RT.ND var 0 ]) - -let bind_type_t1 (u1 u2:R.universe) (t1:R.term) = - let var = 3 in - let t2 = mk_name var in - let t2_type = RT.tm_type u2 in - mk_arrow (t2_type, R.Q_Implicit) - (RT.subst_term (bind_type_t1_t2 u1 u2 t1 t2) - [ RT.ND var 0 ]) - -let bind_type (u1 u2:R.universe) = - let var = 4 in - let t1 = mk_name var in - let t1_type = RT.tm_type u1 in - mk_arrow (t1_type, R.Q_Implicit) - (RT.subst_term (bind_type_t1 u1 u2 t1) - [ RT.ND var 0 ]) - -(** Type of frame **) - -let mk_star (l r:R.term) = - let open R in - let head = pack_ln (Tv_FVar (pack_fv star_lid)) in - R.mk_app head [(l, Q_Explicit); (r, Q_Explicit)] - -let frame_res (u:R.universe) (t pre post frame:R.term) = - mk_stt_comp u t - (mk_star pre frame) - (mk_abs t R.Q_Explicit (mk_star (R.mk_app post [bound_var 0, R.Q_Explicit]) frame)) - -let frame_type_t_pre_post_frame (u:R.universe) (t pre post frame:R.term) = - let open R in - let f_type = mk_stt_comp u t pre post in - mk_arrow (f_type, Q_Explicit) - (frame_res u t pre post frame) - -let frame_type_t_pre_post (u:R.universe) (t pre post:R.term) = - let var = 0 in - let frame = mk_name var in - mk_arrow (slprop_tm, R.Q_Explicit) - (RT.close_term (frame_res u t pre post frame) var) - -let frame_type_t_pre (u:R.universe) (t pre:R.term) = - let var = 1 in - let post = mk_name var in - let post_type = mk_arrow (t, R.Q_Explicit) slprop_tm in - mk_arrow (post_type, R.Q_Implicit) - (RT.close_term (frame_type_t_pre_post u t pre post) var) - -let frame_type_t (u:R.universe) (t:R.term) = - let var = 2 in - let pre = mk_name var in - let pre_type = slprop_tm in - mk_arrow (pre_type, R.Q_Implicit) - (RT.close_term (frame_type_t_pre u t pre) var) - -let frame_type (u:R.universe) = - let var = 3 in - let t = mk_name var in - let t_type = RT.tm_type u in - mk_arrow (t_type, R.Q_Implicit) - (RT.close_term (frame_type_t u t) var) - - -(** Type of sub_stt **) - -let stt_slprop_post_equiv_fv = R.pack_fv (mk_pulse_lib_core_lid "slprop_post_equiv") -let stt_slprop_post_equiv_univ_inst u = R.pack_ln (R.Tv_UInst stt_slprop_post_equiv_fv [u]) -let stt_slprop_post_equiv (u:R.universe) (t t1 t2:R.term) = - R.mk_app (stt_slprop_post_equiv_univ_inst u) - [(t, R.Q_Implicit); (t1, R.Q_Explicit); (t2, R.Q_Explicit)] - -let sub_stt_res u t pre post = mk_stt_comp u t pre post - -let sub_stt_equiv_post u t pre1 post1 pre2 post2 = - mk_arrow (stt_slprop_post_equiv u t post1 post2, R.Q_Explicit) - (sub_stt_res u t pre2 post2) - -let sub_stt_equiv_pre u t pre1 post1 pre2 post2 = - mk_arrow (stt_slprop_equiv pre1 pre2, R.Q_Explicit) - (sub_stt_equiv_post u t pre1 pre2 post1 post2) - -let sub_stt_post2 u t pre1 post1 pre2 = - let var = 0 in - let post2 = mk_name var in - let post2_type = mk_arrow (t, R.Q_Explicit) slprop_tm in - mk_arrow (post2_type, R.Q_Explicit) - (RT.close_term (sub_stt_equiv_pre u t pre1 pre2 post1 post2) var) - -let sub_stt_pre2 u t pre1 post1 = - let var = 1 in - let pre2 = mk_name var in - let pre2_type = slprop_tm in - mk_arrow (pre2_type, R.Q_Explicit) - (RT.close_term (sub_stt_post2 u t pre1 post1 pre2) var) - -let sub_stt_post1 u t pre1 = - let var = 2 in - let post1 = mk_name var in - let post1_type = mk_arrow (t, R.Q_Explicit) slprop_tm in - mk_arrow (post1_type, R.Q_Explicit) - (RT.close_term (sub_stt_pre2 u t pre1 post1) var) - -let sub_stt_pre1 u t = - let var = 3 in - let pre1 = mk_name var in - let pre1_type = slprop_tm in - mk_arrow (pre1_type, R.Q_Explicit) - (RT.close_term (sub_stt_post1 u t pre1) var) - -let sub_stt_type u = - let var = 4 in - let t = mk_name var in - let ty_typ = RT.tm_type u in - mk_arrow (ty_typ, R.Q_Explicit) - (RT.close_term (sub_stt_pre1 u t) var) - -(** Properties of environments suitable for elaboration **) - -let has_stt_bindings (f:RT.fstar_top_env) = - RT.lookup_fvar f RT.bool_fv == Some (RT.tm_type RT.u_zero) /\ - RT.lookup_fvar f slprop_fv == Some (RT.tm_type u2) /\ True - //(forall (u1 u2:R.universe). RT.lookup_fvar_uinst f bind_fv [u1; u2] == Some (bind_type u1 u2)) /\ - //(forall (u:R.universe). RT.lookup_fvar_uinst f frame_fv [u] == Some (frame_type u)) /\ - //(forall (u:R.universe). RT.lookup_fvar_uinst f subsumption_fv [u] == Some (sub_stt_type u)) - -let stt_env = e:env { has_stt_bindings (fstar_env e) } - -let check_top_level_environment (f:RT.fstar_top_env) - : option stt_env - = admit(); Some (mk_env f) //we should implement this as a runtime check - -let elab_comp_post (c:comp_st) : R.term = - let t = comp_res c in - let post = comp_post c in - mk_abs t R.Q_Explicit post - -let comp_post_type (c:comp_st) : R.term = - let t = comp_res c in - mk_arrow (t, R.Q_Explicit) slprop_tm - -assume -val inversion_of_stt_typing (g:env) (c:comp_st) - (#u:R.universe) - // _ |- stt u#u t pre (fun (x:t) -> post) : Type _ - (_:RT.tot_typing (elab_env g) (elab_comp c) (RT.tm_type u)) - : GTot (x:( // _ |- t : Type u#u - RT.tot_typing (elab_env g) - (comp_res c) - (RT.tm_type (comp_u c)) & - // _ |- pre : slprop - RT.tot_typing (elab_env g) - (comp_pre c) - tm_slprop & - // _ |- (fun (x:t) -> post) : t -> slprop - RT.tot_typing (elab_env g) - (elab_comp_post c) - (tm_arrow (null_binder (comp_res c)) None (C_Tot tm_slprop))){ u == universe_of_comp c }) - -let soundness_t (d:'a) = - g:stt_env -> - t:st_term -> - c:comp -> - d':st_typing g t c{d' << d} -> - GTot (RT.tot_typing (elab_env g) - (elab_st_typing d') - (elab_comp c)) - -let elab_open_commute' (e:term) (v:term) (n:index) - : Lemma (ensures - RT.subst_term e - [ RT.DT n v] == - (open_term' e v n)) - [SMTPat (open_term' e v n)] = - - elab_open_commute' e v n - -let elab_close_commute' (e:term) (v:var) (n:index) - : Lemma (RT.subst_term e [ RT.ND v n ] == - (close_term' e v n)) - [SMTPat (close_term' e v n)] = - - elab_close_commute' e v n - -let elab_comp_close_commute (c:comp) (x:var) - : Lemma (ensures elab_comp (close_comp c x) == RT.close_term (elab_comp c) x) - [SMTPat (elab_comp (close_comp c x))] = - - elab_comp_close_commute c x - -let elab_comp_open_commute (c:comp) (x:term) - : Lemma (ensures elab_comp (open_comp_with c x) == RT.open_with (elab_comp c) x) - [SMTPat (elab_comp (open_comp_with c x))] = - - elab_comp_open_commute c x diff --git a/src/checker/Pulse.Soundness.Comp.fst b/src/checker/Pulse.Soundness.Comp.fst deleted file mode 100644 index 3b36671f2..000000000 --- a/src/checker/Pulse.Soundness.Comp.fst +++ /dev/null @@ -1,84 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Soundness.Comp - -open Pulse.Syntax -open Pulse.Reflection.Util -open Pulse.Typing -open Pulse.Elaborate.Core -open Pulse.Elaborate -open Pulse.Soundness.Common - -module STT = Pulse.Soundness.STT - -let stc_soundness - (#g:stt_env) - (#st:st_comp) - (d_st:st_comp_typing g st) - - : GTot (RT.tot_typing (elab_env g) - st.res - (RT.tm_type st.u) & - RT.tot_typing (elab_env g) - st.pre - slprop_tm & - RT.tot_typing (elab_env g) - (mk_abs st.res R.Q_Explicit st.post) - (post1_type_bind st.res)) = - - let STC _ st x dres dpre dpost = d_st in - let res_typing = tot_typing_soundness dres in - let pre_typing = tot_typing_soundness dpre in - calc (==) { - RT.close_term (open_term st.post x) x; - (==) { RT.open_term_spec st.post x } - RT.close_term (RT.open_term st.post x) x; - (==) { - RT.close_open_inverse st.post x - } - st.post; - }; - let post_typing = mk_t_abs_tot g ppname_default dres dpost in - res_typing, pre_typing, post_typing - -#push-options "--fuel 2 --ifuel 2 --z3rlimit_factor 2" -let comp_typing_soundness (g:stt_env) - (c:comp) - (uc:universe) - (d:comp_typing g c uc) - : GTot (RT.tot_typing (elab_env g) - (elab_comp c) - (RT.tm_type uc)) - (decreases d) - = match d with - | CT_Tot _ t _ dt -> - tot_typing_soundness dt - - | CT_ST _ st d_st -> - let res_typing, pre_typing, post_typing = stc_soundness d_st in - STT.stt_typing res_typing pre_typing post_typing - - | CT_STAtomic _ i obs st d_i d_st -> - let i_typing = tot_typing_soundness d_i in - let res_typing, pre_typing, post_typing = stc_soundness d_st in - STT.stt_atomic_typing #(elab_observability obs) res_typing i_typing pre_typing post_typing - - | CT_STGhost _ i st d_i d_st -> - let i_typing = tot_typing_soundness d_i in - let res_typing, pre_typing, post_typing = stc_soundness d_st in - STT.stt_ghost_typing res_typing i_typing pre_typing post_typing -#pop-options diff --git a/src/checker/Pulse.Soundness.Comp.fsti b/src/checker/Pulse.Soundness.Comp.fsti deleted file mode 100644 index c74b213c8..000000000 --- a/src/checker/Pulse.Soundness.Comp.fsti +++ /dev/null @@ -1,47 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Soundness.Comp - -open Pulse.Syntax -open Pulse.Reflection.Util -open Pulse.Typing -open Pulse.Elaborate.Core -open Pulse.Soundness.Common - -module R = FStar.Reflection.V2 -module RT = FStar.Reflection.Typing - -val stc_soundness - (#g:stt_env) - (#st:st_comp) - (d_st:st_comp_typing g st) - - : GTot (RT.tot_typing (elab_env g) - st.res - (RT.tm_type st.u) & - RT.tot_typing (elab_env g) - st.pre - slprop_tm & - RT.tot_typing (elab_env g) - (mk_abs st.res R.Q_Explicit st.post) - (post1_type_bind st.res)) - -val comp_typing_soundness (g:stt_env) - (c:comp) - (uc:universe) - (d:comp_typing g c uc) - : GTot (RT.tot_typing (elab_env g) (elab_comp c) (RT.tm_type uc)) diff --git a/src/checker/Pulse.Soundness.Exists.fst b/src/checker/Pulse.Soundness.Exists.fst deleted file mode 100644 index a8924f7e3..000000000 --- a/src/checker/Pulse.Soundness.Exists.fst +++ /dev/null @@ -1,109 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Soundness.Exists - -module R = FStar.Reflection.V2 -module RT = FStar.Reflection.Typing - -open Pulse.Syntax -open Pulse.Reflection.Util -open Pulse.Typing -open Pulse.Elaborate.Core -open Pulse.Elaborate -open Pulse.Soundness.Common - -module WT = Pulse.Lib.Core.Typing -module FV = Pulse.Typing.FV - -let intro_exists_soundness - (#g:stt_env) - (#t:st_term) - (#c:comp) - (d:st_typing g t c{T_IntroExists? d }) - : GTot (RT.tot_typing (elab_env g) - (elab_st_typing d) - (elab_comp c)) = - - let t0 = t in - let T_IntroExists _ u b p e t_typing p_typing e_typing = d in - let rt = b.binder_ty in - let rt_typing : RT.tot_typing _ rt (R.pack_ln (R.Tv_Type u)) = - tot_typing_soundness t_typing in - let rp_typing - : RT.tot_typing _ - (mk_exists u rt (mk_abs rt R.Q_Explicit p)) slprop_tm = - tot_typing_soundness p_typing in - let rp_typing - : RT.tot_typing _ - (mk_abs rt R.Q_Explicit p) - (mk_arrow (rt, R.Q_Explicit) slprop_tm) = - WT.exists_inversion rp_typing - in - let re_typing : RT.ghost_typing _ e _ = - ghost_typing_soundness e_typing - in - - let d = WT.intro_exists_typing rt_typing rp_typing re_typing in - assume (RT.ln' p 0); - assume (RT.ln e); - RT.T_Sub _ _ _ _ d - (RT.Relc_typ _ _ _ _ _ - (RT.Rel_equiv _ _ _ _ - (elab_stghost_equiv _ c _ _ - (RT.Rel_beta _ rt R.Q_Explicit p e) (RT.Rel_refl _ _ _)))) - -#push-options "--z3rlimit_factor 4 --fuel 4 --ifuel 2" -let elim_exists_soundness - (#g:stt_env) - (#t:st_term) - (#c:comp) - (d:st_typing g t c{T_ElimExists? d}) - : GTot (RT.tot_typing (elab_env g) - (elab_st_typing d) - (elab_comp c)) = - - let T_ElimExists _ u t p x t_typing p_typing = d in - let rt_typing = tot_typing_soundness t_typing in - let rp_typing - : RT.tot_typing (elab_env g) - (mk_exists u t - (mk_abs t R.Q_Explicit p)) - slprop_tm - = tot_typing_soundness p_typing in - let rp_typing = WT.exists_inversion rp_typing in - - FV.st_typing_freevars_inv d x; - assert (~ (Set.mem x (freevars t))); - assert (~ (Set.mem x (freevars p))); - - let x_tm = tm_var {nm_index=x;nm_ppname=ppname_default} in - let rx_tm = R.pack_ln (R.Tv_Var (R.pack_namedv (RT.make_namedv x))) in - - let rreveal_x = Pulse.Reflection.Util.mk_reveal u t rx_tm in - - let post_eq = - assume (RT.ln' p 0); - assume (RT.ln rreveal_x); - RT.equiv_abs_close (Pulse.Reflection.Util.mk_erased u t) R.Q_Explicit x - (RT.Rel_beta (RT.extend_env (elab_env g) _ _) t R.Q_Explicit p rreveal_x) in - - let comp_equiv = elab_stghost_equiv (elab_env g) c _ _ (RT.Rel_refl _ _ _) post_eq in - let d = WT.elim_exists_typing #_ #u x rt_typing rp_typing in - RT.T_Sub _ _ _ _ d - (RT.Relc_typ _ _ _ _ _ - (RT.Rel_equiv _ _ _ _ comp_equiv)) -#pop-options diff --git a/src/checker/Pulse.Soundness.Exists.fsti b/src/checker/Pulse.Soundness.Exists.fsti deleted file mode 100644 index f40b1102e..000000000 --- a/src/checker/Pulse.Soundness.Exists.fsti +++ /dev/null @@ -1,45 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Soundness.Exists - -open Pulse.Syntax -open Pulse.Typing -open Pulse.Elaborate.Pure -open Pulse.Elaborate.Core -open Pulse.Soundness.Common - -module RT = FStar.Reflection.Typing - -val intro_exists_soundness - (#g:stt_env) - (#t:st_term) - (#c:comp) - (d:st_typing g t c{T_IntroExists? d }) - : GTot (RT.tot_typing (elab_env g) - (elab_st_typing d) - (elab_comp c)) - -val elim_exists_soundness - (#g:stt_env) - (#t:st_term) - (#c:comp) - (d:st_typing g t c{T_ElimExists? d}) - : GTot (RT.tot_typing (elab_env g) - (elab_st_typing d) - (elab_comp c)) - - diff --git a/src/checker/Pulse.Soundness.Frame.fst b/src/checker/Pulse.Soundness.Frame.fst deleted file mode 100644 index c5866c75a..000000000 --- a/src/checker/Pulse.Soundness.Frame.fst +++ /dev/null @@ -1,127 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Soundness.Frame -module RT = FStar.Reflection.Typing -module R = FStar.Reflection.V2 -open FStar.List.Tot -open Pulse.Syntax -open Pulse.Reflection.Util -open Pulse.Typing -open Pulse.Elaborate -open Pulse.Soundness.Common -(*** Soundness of frame elaboration *) - -#push-options "--fuel 2 --ifuel 1" -let inst_frame_t #u #g #head - (head_typing: RT.tot_typing g head (frame_type u)) - (#t:_) - (t_typing: RT.tot_typing g t (RT.tm_type u)) - : GTot (RT.tot_typing g (R.mk_app head [(t, R.Q_Implicit)]) (frame_type_t u t)) - = admit() - -let inst_frame_pre #u #g #head #t - (head_typing: RT.tot_typing g head (frame_type_t u t)) - (#pre:_) - (pre_typing: RT.tot_typing g pre slprop_tm) - : GTot (RT.tot_typing g (R.mk_app head [(pre, R.Q_Implicit)]) (frame_type_t_pre u t pre)) - = admit() - -let inst_frame_post #u #g #head #t #pre - (head_typing: RT.tot_typing g head (frame_type_t_pre u t pre)) - (#post:_) - (post_typing: RT.tot_typing g post (mk_arrow (t, R.Q_Explicit) slprop_tm)) - : GTot (RT.tot_typing g (R.mk_app head [(post, R.Q_Implicit)]) - (frame_type_t_pre_post u t pre post)) - = admit() - -let inst_frame_frame #u #g #head #t #pre #post - (head_typing: RT.tot_typing g head (frame_type_t_pre_post u t pre post)) - (#frame:_) - (frame_typing: RT.tot_typing g frame slprop_tm) - : GTot (RT.tot_typing g (R.mk_app head [(frame, R.Q_Explicit)]) - (frame_type_t_pre_post_frame u t pre post frame)) - = admit() - -let inst_frame_comp #u #g #head #t #pre #post #frame - (head_typing: RT.tot_typing g head (frame_type_t_pre_post_frame u t pre post frame)) - (#f:_) - (f_typing:RT.tot_typing g f (mk_stt_comp u t pre post)) - : GTot (RT.tot_typing g (R.mk_app head [(f, R.Q_Explicit)]) - (frame_res u t pre post frame)) - = admit() - -(* stt t pre (fun x -> (fun x -> post) x * frame) ~ - stt t pre (fun x -> post * frame) *) -let equiv_frame_post (g:R.env) - (u:R.universe) - (t:R.term) - (pre:R.term) - (post:term) // ln 1 - (frame:R.term) //ln 0 - : GTot (RT.equiv g (mk_stt_comp u t pre (mk_abs t R.Q_Explicit (mk_star (R.mk_app (mk_abs t R.Q_Explicit post) - [bound_var 0, R.Q_Explicit]) frame))) - (mk_stt_comp u t pre (mk_abs t R.Q_Explicit (mk_star post frame)))) - = admit() - -#push-options "--z3rlimit_factor 4 --ifuel 1 --fuel 4" -let elab_frame_typing (g:stt_env) - (e:R.term) - (c:ln_comp) - (frame:term) - (frame_typing: tot_typing g frame tm_slprop) - (e_typing: RT.tot_typing (elab_env g) e (elab_comp c)) - : GTot (RT.tot_typing (elab_env g) - (elab_frame c frame e) - (elab_comp (add_frame c frame))) - = if C_ST? c then - let frame_typing = tot_typing_soundness frame_typing in - let rg = elab_env g in - let u = comp_u c in - let frame_fv = R.pack_fv (mk_pulse_lib_core_lid "frame_stt") in - let head = R.pack_ln (R.Tv_UInst frame_fv [u]) in - assume (RT.lookup_fvar_uinst rg frame_fv [u] == Some (frame_type u)); - let head_typing : RT.tot_typing _ _ (frame_type u) = RT.T_UInst rg frame_fv [u] in - let (| _, c_typing |) = RT.type_correctness _ _ _ e_typing in - let t_typing, pre_typing, post_typing = inversion_of_stt_typing _ _ c_typing in - let t = comp_res c in - let t_typing : RT.tot_typing rg t (RT.tm_type u) = t_typing in - let d : RT.tot_typing (elab_env g) - (elab_frame c frame e) - (frame_res u t (comp_pre c) - (elab_comp_post c) - frame) = - inst_frame_comp - (inst_frame_frame - (inst_frame_post - (inst_frame_pre - (inst_frame_t head_typing t_typing) - pre_typing) - post_typing) - frame_typing) - e_typing - in - RT.T_Sub _ _ _ _ d - (RT.Relc_typ _ _ _ _ _ - (RT.Rel_equiv _ _ _ _ - (equiv_frame_post rg u t - (tm_star (comp_pre c) frame) - (comp_post c) - frame))) - else admit () -#pop-options - -#pop-options diff --git a/src/checker/Pulse.Soundness.Frame.fsti b/src/checker/Pulse.Soundness.Frame.fsti deleted file mode 100644 index 46272a83e..000000000 --- a/src/checker/Pulse.Soundness.Frame.fsti +++ /dev/null @@ -1,34 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Soundness.Frame -module RT = FStar.Reflection.Typing -module R = FStar.Reflection.V2 -open FStar.List.Tot -open Pulse.Syntax -open Pulse.Typing -open Pulse.Elaborate -open Pulse.Soundness.Common - -val elab_frame_typing (g:stt_env) - (e:R.term) - (c:ln_comp) - (frame:term) - (frame_typing: tot_typing g frame tm_slprop) - (e_typing: RT.tot_typing (elab_env g) e (elab_comp c)) - : GTot (RT.tot_typing (elab_env g) - (elab_frame c frame e) - (elab_comp (add_frame c frame))) diff --git a/src/checker/Pulse.Soundness.Lift.fst b/src/checker/Pulse.Soundness.Lift.fst deleted file mode 100644 index 7a14d6e86..000000000 --- a/src/checker/Pulse.Soundness.Lift.fst +++ /dev/null @@ -1,72 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Soundness.Lift -module RT = FStar.Reflection.Typing -module R = FStar.Reflection.V2 -open FStar.List.Tot -open Pulse.Syntax -open Pulse.Typing -open Pulse.Elaborate -open Pulse.Soundness.Common - -let elab_lift_stt_atomic_st_typing - (g:stt_env) - (c1 c2:ln_comp) - (e:R.term) - (e_typing:RT.tot_typing (elab_env g) e (elab_comp c1)) - (lc:lift_comp g c1 c2) - : Ghost (RT.tot_typing (elab_env g) (elab_lift lc e) (elab_comp c2)) - (requires Lift_STAtomic_ST? lc) - (ensures fun _ -> True) - = admit() - -let elab_lift_ghost_neutral_typing - (g:stt_env) - (c1 c2:ln_comp) - (e:R.term) - (e_typing:RT.tot_typing (elab_env g) e (elab_comp c1)) - (lc:lift_comp g c1 c2) - (reveal_a:R.term) - (reveal_a_typing:RT.tot_typing (elab_env g) reveal_a - (non_informative_rt (comp_u c1) - (comp_res c1))) - : Ghost (RT.tot_typing (elab_env g) (elab_lift lc e) (elab_comp c2)) - (requires Lift_Ghost_Neutral? lc) - (ensures fun _ -> True) - = admit() - -let elab_lift_neutral_ghost_typing - (g:stt_env) - (c1 c2:ln_comp) - (e:R.term) - (e_typing:RT.tot_typing (elab_env g) e (elab_comp c1)) - (lc:lift_comp g c1 c2) - : Ghost (RT.tot_typing (elab_env g) (elab_lift lc e) (elab_comp c2)) - (requires Lift_Neutral_Ghost? lc) - (ensures fun _ -> True) -= admit() - -let elab_lift_observability_typing - (g:stt_env) - (c1 c2:ln_comp) - (e:R.term) - (e_typing:RT.tot_typing (elab_env g) e (elab_comp c1)) - (lc:lift_comp g c1 c2) - : Ghost (RT.tot_typing (elab_env g) (elab_lift lc e) (elab_comp c2)) - (requires Lift_Observability? lc) - (ensures fun _ -> True) -= admit() \ No newline at end of file diff --git a/src/checker/Pulse.Soundness.Lift.fsti b/src/checker/Pulse.Soundness.Lift.fsti deleted file mode 100644 index 2f338e260..000000000 --- a/src/checker/Pulse.Soundness.Lift.fsti +++ /dev/null @@ -1,72 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Soundness.Lift -module RT = FStar.Reflection.Typing -module R = FStar.Reflection.V2 -open FStar.List.Tot -open Pulse.Syntax -open Pulse.Reflection.Util -open Pulse.Typing -open Pulse.Elaborate -open Pulse.Soundness.Common - -(*** Soundness of lift elaboration *) - -val elab_lift_stt_atomic_st_typing - (g:stt_env) - (c1 c2:ln_comp) - (e:R.term) - (e_typing:RT.tot_typing (elab_env g) e (elab_comp c1)) - (lc:lift_comp g c1 c2) - : Ghost (RT.tot_typing (elab_env g) (elab_lift lc e) (elab_comp c2)) - (requires Lift_STAtomic_ST? lc) - (ensures fun _ -> True) - -val elab_lift_ghost_neutral_typing - (g:stt_env) - (c1 c2:ln_comp) - (e:R.term) - (e_typing:RT.tot_typing (elab_env g) e (elab_comp c1)) - (lc:lift_comp g c1 c2) - (reveal_a:R.term) - (reveal_a_typing:RT.tot_typing (elab_env g) reveal_a - (non_informative_rt (comp_u c1) - (comp_res c1))) - : Ghost (RT.tot_typing (elab_env g) (elab_lift lc e) (elab_comp c2)) - (requires Lift_Ghost_Neutral? lc) - (ensures fun _ -> True) - -val elab_lift_neutral_ghost_typing - (g:stt_env) - (c1 c2:ln_comp) - (e:R.term) - (e_typing:RT.tot_typing (elab_env g) e (elab_comp c1)) - (lc:lift_comp g c1 c2) - : Ghost (RT.tot_typing (elab_env g) (elab_lift lc e) (elab_comp c2)) - (requires Lift_Neutral_Ghost? lc) - (ensures fun _ -> True) - - -val elab_lift_observability_typing - (g:stt_env) - (c1 c2:ln_comp) - (e:R.term) - (e_typing:RT.tot_typing (elab_env g) e (elab_comp c1)) - (lc:lift_comp g c1 c2) - : Ghost (RT.tot_typing (elab_env g) (elab_lift lc e) (elab_comp c2)) - (requires Lift_Observability? lc) - (ensures fun _ -> True) diff --git a/src/checker/Pulse.Soundness.Match.fst b/src/checker/Pulse.Soundness.Match.fst deleted file mode 100644 index 6bc92ceb9..000000000 --- a/src/checker/Pulse.Soundness.Match.fst +++ /dev/null @@ -1,88 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Soundness.Match - -open Pulse.Soundness.Common -open Pulse.Syntax.Base -open Pulse.Syntax.Pure -open Pulse.Typing -open Pulse.Elaborate.Core -open Pulse.Elaborate.Pure -module RU = Pulse.RuntimeUtils -module RT = FStar.Reflection.Typing -module R = FStar.Reflection.V2 -module T = FStar.Tactics.V2 -module L = FStar.List.Tot - -let complete_soundness - (g:stt_env) - (#sc_u:universe) - (#sc_ty:term) - (#sc:term) - (brs:list branch) - (c:comp_st) - (d : brs_typing g sc_u sc_ty sc brs c) - (comp : pats_complete g sc sc_ty (L.map (fun br -> elab_pat br.pat) brs)) - (bs : list (list R.binding)) - : Ghost.erased (RT.match_is_complete (elab_env g) sc sc_ty - (List.Tot.map fst (elab_branches d)) - bs) - = let PC_Elab _ _ _ _ bs' s = comp in - assume (L.map fst (elab_branches d) == L.map (fun br -> elab_pat br.pat) brs); // FIXME - assume (bs == bs'); // FIXME - s - - -let coerce_eq (#a #b:Type) (x:a) (_:squash (a == b)) : y:b{y == x} = x - -let match_soundness - (g:stt_env) - (t:st_term) - (c:comp) - (d:st_typing g t c{T_Match? d}) - (soundness:soundness_t d) - (ct_soundness: (g:stt_env -> c:comp -> uc:universe -> - d':comp_typing g c uc{d' << d} -> - GTot (RT.tot_typing (elab_env g) - (elab_comp c) - (RT.tm_type uc)))) - : GTot (RT.tot_typing (elab_env g) - (elab_st_typing d) - (elab_comp c)) - = - let T_Match _g sc_u sc_ty sc (E sc_ty_d) (E sc_d) _c _ctyping brs brs_ty brs_complete = d in - - let sc_e_ty_t : RT.typing (elab_env g) sc_ty (T.E_Total, RT.tm_type sc_u) = coerce_eq sc_ty_d () in - - let sc_e = sc in - let sc_e_t : RT.typing (elab_env g) sc_e (T.E_Total, sc_ty) = sc_d in - - let brs_e : list R.branch = - elab_branches brs_ty - in - let rcty = (T.E_Total, elab_comp c) in - let PC_Elab _ _ _ _ bnds _ = brs_complete in - let brs_e_ty : RT.branches_typing (elab_env g) sc_u sc_ty sc_e rcty brs_e bnds = - RU.magic () - in - let brs_complete - : RT.match_is_complete (elab_env g) sc sc_ty (List.Tot.map fst brs_e) bnds - = assume (L.map fst (elab_branches brs_ty) == L.map fst brs_e); - complete_soundness g brs c brs_ty brs_complete bnds - in - assume (elab_st_typing d == R.pack_ln (R.Tv_Match sc_e None brs_e)); - RT.T_Match _ _ _ sc_e T.E_Total sc_e_ty_t T.E_Total sc_e_t brs_e rcty bnds brs_complete brs_e_ty diff --git a/src/checker/Pulse.Soundness.Match.fsti b/src/checker/Pulse.Soundness.Match.fsti deleted file mode 100644 index c1db02f4e..000000000 --- a/src/checker/Pulse.Soundness.Match.fsti +++ /dev/null @@ -1,39 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Soundness.Match - -open Pulse.Soundness.Common -open Pulse.Syntax.Base -open Pulse.Typing -open Pulse.Elaborate.Core -open Pulse.Elaborate.Pure -module RT = FStar.Reflection.Typing - -val match_soundness - (g:stt_env) - (t:st_term) - (c:comp) - (d:st_typing g t c{T_Match? d}) - (soundness:soundness_t d) - (ct_soundness: (g:stt_env -> c:comp -> uc:universe -> - d':comp_typing g c uc{d' << d} -> - GTot (RT.tot_typing (elab_env g) - (elab_comp c) - (RT.tm_type uc)))) - : GTot (RT.tot_typing (elab_env g) - (elab_st_typing d) - (elab_comp c)) diff --git a/src/checker/Pulse.Soundness.Return.fst b/src/checker/Pulse.Soundness.Return.fst deleted file mode 100644 index 47fac958a..000000000 --- a/src/checker/Pulse.Soundness.Return.fst +++ /dev/null @@ -1,158 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Soundness.Return - -open Pulse.Syntax -open Pulse.Reflection.Util -open Pulse.Typing -open Pulse.Elaborate.Core -open Pulse.Elaborate -open Pulse.Soundness.Common - -module R = FStar.Reflection.V2 - -module PReflUtil = Pulse.Reflection.Util -module WT = Pulse.Lib.Core.Typing - -#push-options "--z3rlimit_factor 8 --split_queries no --fuel 4 --ifuel 2" -let return_soundness - (#g:stt_env) - (#t:st_term) - (#c:comp) - (d:st_typing g t c{T_Return? d}) - : GTot (RT.tot_typing (elab_env g) - (elab_st_typing d) - (elab_comp c)) = - - let T_Return _ ctag use_eq u t e post x t_typing e_typing post_typing = d in - let rpost_abs = mk_abs t R.Q_Explicit post in - let rt_typing : RT.tot_typing _ t (R.pack_ln (R.Tv_Type u)) = - tot_typing_soundness t_typing in - let re_typing : RT.typing _ e (eff_of_ctag ctag, t) = - match ctag with - | STT_Ghost -> ghost_typing_soundness e_typing - | _ -> tot_typing_soundness e_typing in - let rpost_abs_typing - : RT.tot_typing _ rpost_abs - (mk_arrow (t, R.Q_Explicit) slprop_tm) = - mk_t_abs_tot g #_ #None ppname_default t_typing post_typing in - - let rx_tm = RT.var_as_term x in - let elab_c_pre = RT.subst_term post [ RT.DT 0 e ] in - let pre_eq - : RT.equiv (elab_env g) - (R.pack_ln (R.Tv_App rpost_abs (e, R.Q_Explicit))) - elab_c_pre - = assume (RT.ln' post 0); - assume (RT.ln e); - RT.Rel_beta (elab_env g) t R.Q_Explicit post e in - - let comp_equiv_noeq (_:unit{use_eq == false}) - : (match ctag with - | STT -> RT.equiv (elab_env g) - (WT.return_stt_noeq_comp u t e rpost_abs) - (elab_comp c) - | STT_Atomic -> - RT.equiv (elab_env g) - (WT.return_stt_atomic_noeq_comp u t e rpost_abs) - (elab_comp c) - - | STT_Ghost -> - RT.equiv (elab_env g) - (WT.return_stt_ghost_noeq_comp u t e rpost_abs) - (elab_comp c)) = - - - match ctag with - | STT -> elab_stt_equiv _ c _ _ pre_eq (RT.Rel_refl _ _ _) - | STT_Atomic -> elab_statomic_equiv _ c _ _ pre_eq (RT.Rel_refl _ _ _) - | STT_Ghost -> elab_stghost_equiv _ c _ _ pre_eq (RT.Rel_refl _ _ _) in - - let comp_equiv_eq (_:unit{use_eq == true}) - : GTot (match ctag with - | STT -> RT.equiv (elab_env g) - (WT.return_stt_comp u t e rpost_abs x) - (elab_comp c) - | STT_Atomic -> - RT.equiv (elab_env g) - (WT.return_stt_atomic_comp u t e rpost_abs x) - (elab_comp c) - | STT_Ghost -> - RT.equiv (elab_env g) - (WT.return_stt_ghost_comp u t e rpost_abs x) - (elab_comp c)) = - - assert (close_term' (tm_star (open_term' post (null_var x) 0) - (tm_pure (mk_eq2 u t (null_var x) e))) x 0 == - RT.subst_term (tm_star (open_term' post (null_var x) 0) - (tm_pure (mk_eq2 u t (null_var x) e))) - [ RT. ND x 0 ]); - let elab_c_post = - mk_abs t R.Q_Explicit - (RT.subst_term - (mk_star - (RT.subst_term post [ RT.DT 0 rx_tm ]) - (PReflUtil.mk_pure (PReflUtil.mk_eq2 u t rx_tm e))) - [ RT.ND x 0 ]) in - - let post_body_eq - : RT.equiv (RT.extend_env (elab_env g) x _) - (mk_star - (R.pack_ln (R.Tv_App rpost_abs (rx_tm, R.Q_Explicit))) - (PReflUtil.mk_pure (PReflUtil.mk_eq2 u t rx_tm e))) - (mk_star - (RT.subst_term post [ RT.DT 0 rx_tm ]) - (PReflUtil.mk_pure (PReflUtil.mk_eq2 u t rx_tm e))) - = mk_star_equiv _ _ _ _ _ (RT.Rel_beta _ t _ _ _) (RT.Rel_refl _ _ _) in - - let post_eq - : RT.equiv (elab_env g) - (WT.return_post_with_eq u t e rpost_abs x) - elab_c_post - = RT.equiv_abs_close t R.Q_Explicit x post_body_eq in - - match ctag with - | STT -> - assert (elab_comp c == mk_stt_comp u t elab_c_pre elab_c_post); - elab_stt_equiv _ c _ _ pre_eq post_eq - | STT_Atomic -> - assert (elab_comp c == mk_stt_atomic_comp WT.neutral_fv u t tm_emp_inames elab_c_pre elab_c_post); - elab_statomic_equiv _ c _ _ pre_eq post_eq - | STT_Ghost -> - assert (elab_comp c == mk_stt_ghost_comp u t tm_emp_inames elab_c_pre elab_c_post); - elab_stghost_equiv _ c _ _ pre_eq post_eq - in - match ctag, use_eq with - | STT, true -> - let d = WT.return_stt_typing x rt_typing re_typing rpost_abs_typing in - RT.T_Sub _ _ _ _ d (RT.Relc_typ _ _ _ _ _ (RT.Rel_equiv _ _ _ _ (comp_equiv_eq ()))) - | STT, false -> - let d = WT.return_stt_noeq_typing rt_typing re_typing rpost_abs_typing in - RT.T_Sub _ _ _ _ d (RT.Relc_typ _ _ _ _ _ (RT.Rel_equiv _ _ _ _ (comp_equiv_noeq ()))) - | STT_Atomic, true -> - let d = WT.return_stt_atomic_typing x rt_typing re_typing rpost_abs_typing in - RT.T_Sub _ _ _ _ d (RT.Relc_typ _ _ _ _ _ (RT.Rel_equiv _ _ _ _ (comp_equiv_eq ()))) - | STT_Atomic, false -> - let d = WT.return_stt_atomic_noeq_typing rt_typing re_typing rpost_abs_typing in - RT.T_Sub _ _ _ _ d (RT.Relc_typ _ _ _ _ _ (RT.Rel_equiv _ _ _ _ (comp_equiv_noeq ()))) - | STT_Ghost, true -> - let d = WT.return_stt_ghost_typing x rt_typing re_typing rpost_abs_typing in - RT.T_Sub _ _ _ _ d (RT.Relc_typ _ _ _ _ _ (RT.Rel_equiv _ _ _ _ (comp_equiv_eq ()))) - | STT_Ghost, false -> - let d = WT.return_stt_ghost_noeq_typing rt_typing re_typing rpost_abs_typing in - RT.T_Sub _ _ _ _ d (RT.Relc_typ _ _ _ _ _ (RT.Rel_equiv _ _ _ _ (comp_equiv_noeq ()))) -#pop-options diff --git a/src/checker/Pulse.Soundness.Return.fsti b/src/checker/Pulse.Soundness.Return.fsti deleted file mode 100644 index e688358ce..000000000 --- a/src/checker/Pulse.Soundness.Return.fsti +++ /dev/null @@ -1,34 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Soundness.Return - -open Pulse.Syntax -open Pulse.Typing -open Pulse.Elaborate.Pure -open Pulse.Elaborate.Core -open Pulse.Soundness.Common - -module RT = FStar.Reflection.Typing - -val return_soundness - (#g:stt_env) - (#t:st_term) - (#c:comp) - (d:st_typing g t c{T_Return? d}) - : GTot (RT.tot_typing (elab_env g) - (elab_st_typing d) - (elab_comp c)) diff --git a/src/checker/Pulse.Soundness.Rewrite.fst b/src/checker/Pulse.Soundness.Rewrite.fst deleted file mode 100644 index c1d9c5f0d..000000000 --- a/src/checker/Pulse.Soundness.Rewrite.fst +++ /dev/null @@ -1,50 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Soundness.Rewrite - -open Pulse.Syntax -open Pulse.Reflection.Util -open Pulse.Typing -open Pulse.Typing.Combinators -open Pulse.Elaborate.Pure -open Pulse.Elaborate.Core -open Pulse.Soundness.Common -open Pulse.Checker.SLPropEquiv - -module RT = FStar.Reflection.Typing -module WT = Pulse.Lib.Core.Typing - -let rewrite_soundness - (#g:stt_env) - (#t:st_term) - (#c:comp) - (d:st_typing g t c{T_Rewrite? d}) - : GTot (RT.tot_typing (elab_env g) - (elab_st_typing d) - (elab_comp c)) = - - let T_Rewrite _ p q p_typing equiv_p_q = d in - let rp_typing : RT.tot_typing _ p slprop_tm = - tot_typing_soundness p_typing in - let rq_typing : RT.tot_typing _ q slprop_tm = - tot_typing_soundness (let f, _ = slprop_equiv_typing equiv_p_q in - f p_typing) in - let d_stt_slprop_equiv = - Pulse.Soundness.SLPropEquiv.slprop_equiv_unit_soundness - p_typing equiv_p_q in - - WT.rewrite_typing rp_typing rq_typing d_stt_slprop_equiv diff --git a/src/checker/Pulse.Soundness.Rewrite.fsti b/src/checker/Pulse.Soundness.Rewrite.fsti deleted file mode 100644 index 04c4c4dad..000000000 --- a/src/checker/Pulse.Soundness.Rewrite.fsti +++ /dev/null @@ -1,34 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Soundness.Rewrite - -open Pulse.Syntax -open Pulse.Typing -open Pulse.Elaborate.Pure -open Pulse.Elaborate.Core -open Pulse.Soundness.Common - -module RT = FStar.Reflection.Typing - -val rewrite_soundness - (#g:stt_env) - (#t:st_term) - (#c:comp) - (d:st_typing g t c{T_Rewrite? d}) - : GTot (RT.tot_typing (elab_env g) - (elab_st_typing d) - (elab_comp c)) diff --git a/src/checker/Pulse.Soundness.SLPropEquiv.fst b/src/checker/Pulse.Soundness.SLPropEquiv.fst deleted file mode 100644 index b111b4786..000000000 --- a/src/checker/Pulse.Soundness.SLPropEquiv.fst +++ /dev/null @@ -1,269 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Soundness.SLPropEquiv -module RT = FStar.Reflection.Typing -module R = FStar.Reflection.V2 -open FStar.List.Tot -open Pulse.Syntax -open Pulse.Reflection.Util -open Pulse.Elaborate.Pure -open Pulse.Typing -open Pulse.Typing.Combinators -open Pulse.Elaborate -open Pulse.Soundness.Common -open Pulse.Checker.SLPropEquiv - -(*** Soundness of slprop equivalence **) - -let slprop_equiv_refl_type = - let var = 0 in - let v = mk_name var in - mk_arrow (tm_slprop, R.Q_Explicit) - (RT.close_term (stt_slprop_equiv v v) var) - -let inst_slprop_equiv_refl #g #v - (d:RT.tot_typing g v tm_slprop) - : GTot (pf:R.term & - RT.tot_typing g pf (stt_slprop_equiv v v)) - = admit() - -let slprop_equiv_sym_type = - let var0 = 0 in - let v0 = mk_name var0 in - let var1 = 1 in - let v1 = mk_name var1 in - mk_arrow - (tm_slprop, R.Q_Implicit) - (RT.close_term - (mk_arrow - (tm_slprop, R.Q_Implicit) - (RT.close_term - (mk_arrow - (stt_slprop_equiv v0 v1, R.Q_Explicit) - (stt_slprop_equiv v0 v1)) var1)) - var0) - -let inst_slprop_equiv_sym #g #v0 #v1 - (d0:RT.tot_typing g v0 tm_slprop) - (d1:RT.tot_typing g v1 tm_slprop) - (#pf:_) - (deq:RT.tot_typing g pf (stt_slprop_equiv v0 v1)) - : GTot (pf:R.term & - RT.tot_typing g pf (stt_slprop_equiv v1 v0)) - = admit() - -let inst_slprop_equiv_trans #g #v0 #v1 #v2 - (d0:RT.tot_typing g v0 tm_slprop) - (d1:RT.tot_typing g v1 tm_slprop) - (d2:RT.tot_typing g v2 tm_slprop) - (#pf01:_) - (d01:RT.tot_typing g pf01 (stt_slprop_equiv v0 v1)) - (#pf12:_) - (d12:RT.tot_typing g pf12 (stt_slprop_equiv v1 v2)) - : GTot (pf:R.term & - RT.tot_typing g pf (stt_slprop_equiv v0 v2)) - = admit() - - -let inst_slprop_equiv_cong #g #v0 #v1 #v0' #v1' - (d0:RT.tot_typing g v0 tm_slprop) - (d1:RT.tot_typing g v1 tm_slprop) - (d0':RT.tot_typing g v0' tm_slprop) - (d1':RT.tot_typing g v1' tm_slprop) - (#pf0:_) - (eq0:RT.tot_typing g pf0 (stt_slprop_equiv v0 v0')) - (#pf1:_) - (eq1:RT.tot_typing g pf1 (stt_slprop_equiv v1 v1')) - : GTot (pf:R.term & - RT.tot_typing g pf (stt_slprop_equiv (mk_star v0 v1) (mk_star v0' v1'))) - = admit() - - -let inst_slprop_equiv_unit #g #v - (d:RT.tot_typing g v tm_slprop) - : GTot (pf:R.term & - RT.tot_typing g pf (stt_slprop_equiv (mk_star tm_emp v) v)) - = admit() - - -let inst_slprop_equiv_comm #g #v0 #v1 - (d0:RT.tot_typing g v0 tm_slprop) - (d1:RT.tot_typing g v1 tm_slprop) - : GTot (pf:R.term & - RT.tot_typing g pf (stt_slprop_equiv (mk_star v0 v1) (mk_star v1 v0))) - = admit() - - -let inst_slprop_equiv_assoc #g #v0 #v1 #v2 - (d0:RT.tot_typing g v0 tm_slprop) - (d1:RT.tot_typing g v1 tm_slprop) - (d2:RT.tot_typing g v2 tm_slprop) - : GTot (pf:R.term & - RT.tot_typing g pf (stt_slprop_equiv (mk_star v0 (mk_star v1 v2)) (mk_star (mk_star v0 v1) v2))) - = admit() - - -let slprop_tm = R.pack_ln (R.Tv_FVar (R.pack_fv slprop_lid)) - -let slprop_equiv_ext_type : R.term = - let open R in - let v_typ = pack_ln (Tv_FVar (pack_fv slprop_lid)) in - let mk_bv index = pack_ln (Tv_BVar (pack_bv { - ppname = RT.pp_name_default; - index = index; - sort = Sealed.seal tun; - })) in - - mk_arrow - (slprop_tm, Q_Explicit) - ( - mk_arrow - (slprop_tm, Q_Explicit) - ( - mk_arrow - (slprop_eq_tm (mk_bv 1) (mk_bv 0), Q_Explicit) - ( - stt_slprop_equiv (mk_bv 2) (mk_bv 1) - ) - ) - ) - -let inst_slprop_equiv_ext_aux #g #v0 #v1 - (equiv:RT.equiv g v0 v1) - : GTot (RT.equiv g (stt_slprop_equiv v0 v0) (stt_slprop_equiv v0 v1)) = - - let ctxt = RT.Ctxt_app_arg - (R.pack_ln (R.Tv_App stt_slprop_equiv_tm (v0, R.Q_Explicit))) - R.Q_Explicit - RT.Ctxt_hole in - - RT.Rel_ctxt _ _ _ ctxt equiv - -let inst_slprop_equiv_ext #g #v0 #v1 - (d0:RT.tot_typing g v0 slprop_tm) - (d1:RT.tot_typing g v1 slprop_tm) - (token:RT.equiv g v0 v1) - : GTot (pf:R.term & - RT.tot_typing g pf (stt_slprop_equiv v0 v1)) = - - let (| pf, typing |) - : (pf:R.term & - RT.tot_typing g pf (stt_slprop_equiv v0 v0)) = - inst_slprop_equiv_refl d0 in - - let d_st_equiv - : RT.equiv g (stt_slprop_equiv v0 v0) (stt_slprop_equiv v0 v1) = - inst_slprop_equiv_ext_aux token in - - let sub_typing - : RT.sub_typing g (stt_slprop_equiv v0 v0) (stt_slprop_equiv v0 v1) - = RT.Rel_equiv _ _ _ _ d_st_equiv in - - let pf_typing - : RT.tot_typing g pf (stt_slprop_equiv v0 v1) = - RT.T_Sub _ _ _ _ typing - (RT.Relc_typ _ _ _ _ _ sub_typing) in - - (| pf, pf_typing |) - -#push-options "--z3rlimit_factor 4" -let rec slprop_equiv_soundness (#g:stt_env) (#v0 #v1:term) - (d:tot_typing g v0 tm_slprop) - (eq:slprop_equiv g v0 v1) - : GTot (pf:R.term & - RT.tot_typing (elab_env g) - pf - (stt_slprop_equiv v0 v1)) - (decreases eq) - = match eq with - | VE_Refl _ _ -> - let d = tot_typing_soundness d in - inst_slprop_equiv_refl d - - | VE_Sym g _v1 _v0 eq' -> - let fwd, _ = slprop_equiv_typing eq in - let d' = fwd d in - let (| pf, dd |) = slprop_equiv_soundness d' eq' in - inst_slprop_equiv_sym (tot_typing_soundness d') - (tot_typing_soundness d) - dd - - | VE_Trans _ _ v _ eq_0v eq_v1 -> - let dv = fst (slprop_equiv_typing eq_0v) d in - let d1 = fst (slprop_equiv_typing eq_v1) dv in - let (| pf_0v, eq_0v |) = slprop_equiv_soundness d eq_0v in - let (| pf_v1, eq_v1 |) = slprop_equiv_soundness dv eq_v1 in - inst_slprop_equiv_trans - (tot_typing_soundness d) - (tot_typing_soundness dv) - (tot_typing_soundness d1) - eq_0v - eq_v1 - - | VE_Ctxt _ t0 t1 t0' t1' eq0 eq1 -> - let t0_typing, t1_typing = star_typing_inversion d in - let t0'_typing = fst (slprop_equiv_typing eq0) t0_typing in - let t1'_typing = fst (slprop_equiv_typing eq1) t1_typing in - let (| pf0, dd0 |) = slprop_equiv_soundness t0_typing eq0 in - let (| pf1, dd1 |) = slprop_equiv_soundness t1_typing eq1 in - inst_slprop_equiv_cong (tot_typing_soundness t0_typing) - (tot_typing_soundness t1_typing) - (tot_typing_soundness t0'_typing) - (tot_typing_soundness t1'_typing) - dd0 dd1 - - | VE_Unit _ _v1 -> - let v1_typing = fst (slprop_equiv_typing eq) d in - inst_slprop_equiv_unit (tot_typing_soundness v1_typing) - - | VE_Comm _ t0 t1 -> - let t0_typing, t1_typing = star_typing_inversion #_ #t0 #t1 d in - inst_slprop_equiv_comm (tot_typing_soundness t0_typing) - (tot_typing_soundness t1_typing) - - | VE_Assoc _ t0 t1 t2 -> - let t0_typing, t12_typing = star_typing_inversion #_ #t0 #(tm_star t1 t2) d in - let t1_typing, t2_typing = star_typing_inversion #_ #t1 #t2 t12_typing in - inst_slprop_equiv_assoc (tot_typing_soundness t0_typing) - (tot_typing_soundness t1_typing) - (tot_typing_soundness t2_typing) - - | VE_Ext _ t0 t1 token -> - let t0_typing, t1_typing = slprop_eq_typing_inversion _ t0 t1 token in - inst_slprop_equiv_ext (tot_typing_soundness t0_typing) - (tot_typing_soundness t1_typing) - token - - | VE_Fa _ _ _ _ _ _ _ -> - (* see Pulse.Lib.Core.slprop_equiv_forall *) - admit() -#pop-options - -let stt_slprop_equiv_is_prop (#g:R.env) (#v0 #v1:R.term) - (d0: RT.tot_typing g v0 tm_slprop) - (d1: RT.tot_typing g v1 tm_slprop) - : GTot (RT.tot_typing g (stt_slprop_equiv v0 v1) RT.tm_prop) - = admit() - -let slprop_equiv_unit_soundness (#g:stt_env) (#v0 #v1:term) - (d0:tot_typing g v0 tm_slprop) - (eq:slprop_equiv g v0 v1) - : GTot (RT.tot_typing (elab_env g) (`()) (stt_slprop_equiv v0 v1)) - = let (| pf, s |) = slprop_equiv_soundness d0 eq in - let d1 = fst (slprop_equiv_typing eq) d0 in - let s_prop = stt_slprop_equiv_is_prop (tot_typing_soundness d0) (tot_typing_soundness d1) in - RT.T_PropIrrelevance _ _ _ _ _ s s_prop diff --git a/src/checker/Pulse.Soundness.SLPropEquiv.fsti b/src/checker/Pulse.Soundness.SLPropEquiv.fsti deleted file mode 100644 index 6ea66d1db..000000000 --- a/src/checker/Pulse.Soundness.SLPropEquiv.fsti +++ /dev/null @@ -1,31 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Soundness.SLPropEquiv -module RT = FStar.Reflection.Typing -open FStar.List.Tot -open Pulse.Syntax -open Pulse.Reflection.Util -open Pulse.Elaborate.Pure -open Pulse.Typing -open Pulse.Elaborate -open Pulse.Soundness.Common - -val slprop_equiv_unit_soundness (#g:stt_env) (#v0 #v1:term) - (d0:tot_typing g v0 tm_slprop) - (eq:slprop_equiv g v0 v1) - : GTot (RT.tot_typing (elab_env g) (`()) - (stt_slprop_equiv v0 v1)) diff --git a/src/checker/Pulse.Soundness.STEquiv.fst b/src/checker/Pulse.Soundness.STEquiv.fst deleted file mode 100644 index 533da38f4..000000000 --- a/src/checker/Pulse.Soundness.STEquiv.fst +++ /dev/null @@ -1,238 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Soundness.STEquiv -module RT = FStar.Reflection.Typing -module R = FStar.Reflection.V2 -module T = FStar.Tactics.V2 -open FStar.List.Tot -open Pulse.Syntax -open Pulse.Reflection.Util -open Pulse.Elaborate.Pure -open Pulse.Typing -open Pulse.Typing.Combinators -open Pulse.Elaborate -open Pulse.Soundness.Common -open Pulse.Checker.SLPropEquiv - - -let stt_slprop_equiv_closing (t0 t1:R.term) (x:var) - : Lemma (RT.close_term (stt_slprop_equiv t0 t1) x == - stt_slprop_equiv (RT.close_term t0 x) (RT.close_term t1 x)) - [SMTPat (RT.close_term (stt_slprop_equiv t0 t1) x)] - = RT.close_term_spec (stt_slprop_equiv t0 t1) x; - RT.close_term_spec t0 x; - RT.close_term_spec t1 x - -let app0 t = R.mk_app t [bound_var 0, R.Q_Explicit] - -let abs_and_app0 (ty:R.term) (b:R.term) = - R.mk_app (mk_abs ty R.Q_Explicit b) [bound_var 0, R.Q_Explicit] - - -// x:ty -> slprop_equiv p q ~ x:ty -> slprop_equiv ((fun y -> p) x) ((fun y -> q) x) -let stt_slprop_equiv_abstract (#g:stt_env) (#post0 #post1:term) (#pf:_) (#ty:_) - (d:RT.tot_typing (elab_env g) pf - (mk_arrow (ty, R.Q_Explicit) - (stt_slprop_equiv post0 post1))) - : GTot (RT.tot_typing (elab_env g) pf - (mk_arrow (ty, R.Q_Explicit) - (stt_slprop_equiv (abs_and_app0 ty post0) - (abs_and_app0 ty post1)))) - = admit() - -let inst_intro_slprop_post_equiv (#g:R.env) (#ty:R.term) (#u:_) - (d_ty:RT.tot_typing g ty (RT.tm_type u)) - (#post0 #post1:R.term) - (d_0:RT.tot_typing g post0 - (mk_arrow (ty, R.Q_Explicit) tm_slprop)) - (d_1:RT.tot_typing g post1 - (mk_arrow (ty, R.Q_Explicit) tm_slprop)) - (#pf:_) - (eq:RT.tot_typing g pf (mk_arrow (ty, R.Q_Explicit) - (stt_slprop_equiv (app0 post0) (app0 post1)))) - : GTot ( pf: R.term & - RT.tot_typing g pf (stt_slprop_post_equiv u ty post0 post1) ) - = admit() - - -let stt_slprop_post_equiv_is_prop (#g:R.env) (#ty:R.term) (#u:_) - (d_ty:RT.tot_typing g ty (RT.tm_type u)) - (#post0 #post1:R.term) - (d_0:RT.tot_typing g post0 - (mk_arrow (ty, R.Q_Explicit) tm_slprop)) - (d_1:RT.tot_typing g post1 - (mk_arrow (ty, R.Q_Explicit) tm_slprop)) - : GTot (RT.tot_typing g (stt_slprop_post_equiv u ty post0 post1) RT.tm_prop) - = admit() - -let inst_sub_stt (#g:R.env) (#u:_) (#a #pre1 #pre2 #post1 #post2 #r:R.term) - (d_a: RT.tot_typing g a (RT.tm_type u)) - (d_pre1: RT.tot_typing g pre1 tm_slprop) - (d_pre2: RT.tot_typing g pre2 tm_slprop) - (d_post1:RT.tot_typing g post1 (mk_arrow (a, R.Q_Explicit) tm_slprop)) - (d_post2:RT.tot_typing g post2 (mk_arrow (a, R.Q_Explicit) tm_slprop)) - (pre_equiv:RT.tot_typing g (`()) (stt_slprop_equiv pre1 pre2)) - (post_equiv:RT.tot_typing g (`()) (stt_slprop_post_equiv u a post1 post2)) - (d_r:RT.tot_typing g r (mk_stt_comp u a pre1 post1)) - : GTot (RT.tot_typing g (mk_sub_stt u a pre1 pre2 post1 post2 r) (mk_stt_comp u a pre2 post2)) - = admit() - -let slprop_arrow (t:term) : term = tm_arrow (null_binder t) None (C_Tot tm_slprop) - -#push-options "--fuel 2 --ifuel 1 --z3rlimit_factor 4" -let st_equiv_soundness_aux (g:stt_env) - (c0:ln_comp) (c1:ln_comp { comp_res c0 == comp_res c1 }) - (d:st_equiv g c0 c1) - (r:R.term) - (d_r:RT.tot_typing (elab_env g) r (elab_comp c0)) - : GTot (RT.tot_typing (elab_env g) (elab_sub c0 c1 r) (elab_comp c1)) - = if C_ST? c0 && C_ST? c1 then - let ST_SLPropEquiv _ _ _ x pre_typing res_typing post_typing _eq_res eq_pre eq_post = d in - // assert (None? (lookup_ty g x)); - assert (None? (lookup g x)); - assume (~(x `Set.mem` RT.freevars (comp_post c0))); - assume (~(x `Set.mem` RT.freevars (comp_post c1))); - let open_term_spec (e:R.term) (x:var) - : Lemma - (RT.open_term e x == RT.subst_term e (RT.open_with_var x 0)) - [SMTPat (RT.open_term e x)] - = RT.open_term_spec e x - in - let pre_equiv = SLPropEquiv.slprop_equiv_unit_soundness pre_typing eq_pre in - let g' = push_binding g x ppname_default (comp_res c0) in - let post_equiv - : RT.tot_typing (RT.extend_env (elab_env g) x (comp_res c0)) - (`()) - (stt_slprop_equiv - (RT.open_term (comp_post c0) x) - (RT.open_term (comp_post c1) x)) - = SLPropEquiv.slprop_equiv_unit_soundness post_typing eq_post - in - let t0 = comp_res c0 in - let r_res_typing = tot_typing_soundness res_typing in - RT.close_open_inverse (comp_post c0) x; - RT.close_open_inverse (comp_post c1) x; - let d - : RT.tot_typing (elab_env g) _ - (mk_arrow (t0, R.Q_Explicit) - (stt_slprop_equiv (comp_post c0) - (comp_post c1))) - = assume (stt_slprop_equiv (comp_post c0) - (comp_post c1) == - RT.subst_term - (stt_slprop_equiv - (RT.open_term (comp_post c0) x) - (RT.open_term (comp_post c1) x)) - [ RT.ND x 0 ]); - RT.T_Abs _ _ _ (`()) _ (comp_u c1) _ R.Q_Explicit _ r_res_typing post_equiv - in - let d = stt_slprop_equiv_abstract d in - let abs_post0_typing - : RT.tot_typing (elab_env g) - (elab_comp_post c0) // mk_abs t0 (elab_pure (comp_post c0))) - (slprop_arrow (comp_res c0)) - = mk_t_abs_tot _ _ res_typing post_typing - in - let abs_post1_typing - : RT.tot_typing (elab_env g) - (elab_comp_post c1) //mk_abs t0 (elab_pure (comp_post c1))) - (slprop_arrow (comp_res c0)) - = mk_t_abs_tot _ _ res_typing (fst (slprop_equiv_typing eq_post) post_typing) - in - let (| pf, d |) = - inst_intro_slprop_post_equiv r_res_typing abs_post0_typing abs_post1_typing d in - let post_equiv = - RT.T_PropIrrelevance _ _ _ _ _ d - (RT.T_Sub _ _ _ _ - (stt_slprop_post_equiv_is_prop r_res_typing abs_post0_typing abs_post1_typing) - (RT.Relc_total_ghost _ _)) - in - inst_sub_stt #_ #(comp_u c1) r_res_typing - (tot_typing_soundness pre_typing) - (tot_typing_soundness (fst (slprop_equiv_typing eq_pre) pre_typing)) - abs_post0_typing - abs_post1_typing - pre_equiv - post_equiv - d_r - else admit () -#pop-options - -let coerce_eq (#a #b:Type) (x:a) (_:squash (a == b)) : y:b{y == x} = x - -let st_equiv_soundness (g:stt_env) - (c0 c1:ln_comp) - (d:st_equiv g c0 c1) - (r:R.term) - (d_r:RT.tot_typing (elab_env g) r (elab_comp c0)) - : GTot (RT.tot_typing (elab_env g) (elab_sub c0 c1 r) (elab_comp c1)) = - - if C_ST? c0 && C_ST? c1 then - let ST_SLPropEquiv _ _ _ x pre_typing res_typing post_typing eq_res eq_pre eq_post = d in - let c1' = with_st_comp c1 {(st_comp_of_comp c1) with res = comp_res c0} in - assert (comp_post c1 == comp_post c1'); - let rpost1' = - Pulse.Reflection.Util.mk_abs - (comp_res c1') R.Q_Explicit (comp_post c1') in - let rpost1 = - Pulse.Reflection.Util.mk_abs - (comp_res c1) R.Q_Explicit (comp_post c1) in - - // these two should follow, since we know x is not free in comp_post c1 and c2 - // from the ST_SLPropEquiv rule - assume (~ (x `Set.mem` (RT.freevars (comp_post c1)))); - assume (~ (x `Set.mem` (RT.freevars (comp_post c1')))); - - let d : RT.equiv (elab_env g) rpost1' rpost1 = - RT.Rel_abs (elab_env g) - (comp_res c1') - (comp_res c1) - R.Q_Explicit - (comp_post c1') - (comp_post c1) - x - eq_res - (RT.Rel_refl _ _ _) in - - let d_eq : RT.equiv (elab_env g) (elab_comp c1') (elab_comp c1) = - mk_stt_comp_equiv (elab_env g) - (comp_u c1) - (comp_res c1') - (comp_pre c1') - rpost1' - (comp_res c1) - (comp_pre c1) - rpost1 - eq_res - (RT.Rel_refl _ _ _) - d - in - let d_steq : st_equiv g c0 c1' = - ST_SLPropEquiv g c0 c1' x pre_typing res_typing post_typing (RT.Rel_refl _ _ _) eq_pre eq_post - in - let d : RT.tot_typing (elab_env g) (elab_sub c0 c1' r) (elab_comp c1') = - st_equiv_soundness_aux g c0 c1' d_steq r d_r in - assert (elab_sub c0 c1' r == elab_sub c0 c1 r); - let d : RT.tot_typing (elab_env g) (elab_sub c0 c1 r) (elab_comp c1') = - st_equiv_soundness_aux g c0 c1' d_steq r d_r in - RT.T_Sub (elab_env g) - (elab_sub c0 c1 r) - (T.E_Total, elab_comp c1') - (T.E_Total, elab_comp c1) - d - (RT.Relc_typ _ _ _ T.E_Total _ (RT.Rel_equiv _ _ _ _ d_eq)) - else admit () diff --git a/src/checker/Pulse.Soundness.STEquiv.fsti b/src/checker/Pulse.Soundness.STEquiv.fsti deleted file mode 100644 index f41e6a418..000000000 --- a/src/checker/Pulse.Soundness.STEquiv.fsti +++ /dev/null @@ -1,32 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Soundness.STEquiv -module RT = FStar.Reflection.Typing -module R = FStar.Reflection.V2 -open FStar.List.Tot -open Pulse.Syntax -open Pulse.Elaborate.Pure -open Pulse.Typing -open Pulse.Elaborate -open Pulse.Soundness.Common - -val st_equiv_soundness (g:stt_env) - (c0 c1:ln_comp) - (d:st_equiv g c0 c1) - (r:R.term) - (d_r:RT.tot_typing (elab_env g) r (elab_comp c0)) - : GTot (RT.tot_typing (elab_env g) (elab_sub c0 c1 r) (elab_comp c1)) diff --git a/src/checker/Pulse.Soundness.STT.fsti b/src/checker/Pulse.Soundness.STT.fsti deleted file mode 100644 index 6904236d6..000000000 --- a/src/checker/Pulse.Soundness.STT.fsti +++ /dev/null @@ -1,60 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Soundness.STT - -module R = FStar.Reflection.V2 -module RT = FStar.Reflection.Typing - -open Pulse.Reflection.Util - -let post_type t = mk_arrow (t, R.Q_Explicit) slprop_tm -let inames_tm = R.(pack_ln (Tv_FVar (pack_fv inames_lid))) - -val stt_typing (#f:RT.fstar_env)//needs to bind stt - (#u:R.universe) - (#t:R.term) - (#pre:R.term) - (#post:R.term) - (_:RT.tot_typing f t (RT.tm_type u)) - (_:RT.tot_typing f pre slprop_tm) - (_:RT.tot_typing f post (post_type t)) - : GTot (RT.tot_typing f (mk_stt_comp u t pre post) (RT.tm_type RT.u_zero)) - -val stt_atomic_typing (#obs:R.term) - (#f:RT.fstar_env)//needs to bind stt - (#u:R.universe) - (#inames:R.term) - (#t:R.term) - (#pre:R.term) - (#post:R.term) - (_:RT.tot_typing f t (RT.tm_type u)) - (_:RT.tot_typing f inames inames_tm) - (_:RT.tot_typing f pre slprop_tm) - (_:RT.tot_typing f post (post_type t)) - : GTot (RT.tot_typing f (mk_stt_atomic_comp obs u t inames pre post) (RT.tm_type (u_atomic_ghost u))) - -val stt_ghost_typing (#f:RT.fstar_env)//needs to bind stt - (#u:R.universe) - (#t:R.term) - (#inames:R.term) - (#pre:R.term) - (#post:R.term) - (_:RT.tot_typing f t (RT.tm_type u)) - (_:RT.tot_typing f inames inames_tm) - (_:RT.tot_typing f pre slprop_tm) - (_:RT.tot_typing f post (post_type t)) - : GTot (RT.tot_typing f (mk_stt_ghost_comp u t inames pre post) (RT.tm_type (u_atomic_ghost u))) diff --git a/src/checker/Pulse.Soundness.Sub.fst b/src/checker/Pulse.Soundness.Sub.fst deleted file mode 100644 index bf53e59c0..000000000 --- a/src/checker/Pulse.Soundness.Sub.fst +++ /dev/null @@ -1,43 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Soundness.Sub -module RT = FStar.Reflection.Typing -module R = FStar.Reflection.V2 -module RU = Pulse.RuntimeUtils -open FStar.List.Tot -open Pulse.Syntax -open Pulse.Typing -open Pulse.Elaborate -open Pulse.Soundness.Common - -(* For simple_arr and elab_st_sub *) -open Pulse.Elaborate.Core - -(* should be trivial *) -let app_typing (g:R.env) (ty1 ty2 f tm : R.term) - (df : RT.tot_typing g f (simple_arr ty1 ty2)) - (dt : RT.tot_typing g tm ty1) - : GTot (RT.tot_typing g (R.pack_ln (R.Tv_App f (tm, R.Q_Explicit))) ty2) - = RU.magic() - -let sub_soundness #g #t #c d (cb : soundness_t d) = - let T_Sub _ e c1 c2 d_t d_sub = d in - let (| coercion, c_typ |) : (t:R.term & RT.tot_typing (elab_env g) t (simple_arr (elab_comp c1) (elab_comp c2))) = - elab_st_sub d_sub - in - let e_typing = cb g _ _ d_t in - app_typing _ _ _ coercion (elab_st_typing d_t) c_typ e_typing diff --git a/src/checker/Pulse.Soundness.Sub.fsti b/src/checker/Pulse.Soundness.Sub.fsti deleted file mode 100644 index f1c65d3c2..000000000 --- a/src/checker/Pulse.Soundness.Sub.fsti +++ /dev/null @@ -1,36 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Soundness.Sub -module RT = FStar.Reflection.Typing -open FStar.List.Tot -open Pulse.Syntax -open Pulse.Reflection.Util -open Pulse.Typing -open Pulse.Elaborate -open Pulse.Soundness.Common - -(*** Soundness of comp subtyping elaboration *) - -val sub_soundness - (#g:stt_env) - (#t:st_term) - (#c:comp) - (d:st_typing g t c{T_Sub? d}) - (cb : soundness_t d) - : GTot (RT.tot_typing (elab_env g) - (elab_st_typing d) - (elab_comp c)) diff --git a/src/checker/Pulse.Soundness.While.fst b/src/checker/Pulse.Soundness.While.fst deleted file mode 100644 index 2672a1a8b..000000000 --- a/src/checker/Pulse.Soundness.While.fst +++ /dev/null @@ -1,17 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Soundness.While \ No newline at end of file diff --git a/src/checker/Pulse.Soundness.While.fsti b/src/checker/Pulse.Soundness.While.fsti deleted file mode 100644 index 3dd9a8e05..000000000 --- a/src/checker/Pulse.Soundness.While.fsti +++ /dev/null @@ -1,17 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Soundness.While diff --git a/src/checker/Pulse.Soundness.WithLocal.fst b/src/checker/Pulse.Soundness.WithLocal.fst deleted file mode 100644 index b0a494420..000000000 --- a/src/checker/Pulse.Soundness.WithLocal.fst +++ /dev/null @@ -1,69 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Soundness.WithLocal - -open Pulse.Syntax -open Pulse.Reflection.Util -open Pulse.Typing -open Pulse.Elaborate.Core -open Pulse.Elaborate -open Pulse.Soundness.Common - -module WT = Pulse.Lib.Core.Typing - -#push-options "--z3rlimit_factor 8 --ifuel 1 --fuel 8" -let withlocal_soundness #g #t #c d soundness = - let T_WithLocal _ _ init body init_t c x init_typing init_t_typing c_typing body_typing = d in - let CT_ST _ st st_typing = c_typing in - - let rg = elab_env g in - let ru = comp_u c in - let rpre = comp_pre c in - let rret_t = comp_res c in - let rpost = comp_post c in - let rbody = elab_st_typing body_typing in - - let a_typing = tot_typing_soundness init_t_typing in - let rinit_typing = tot_typing_soundness init_typing in - let cres_typing, cpre_typing, cpost_typing = - Pulse.Soundness.Comp.stc_soundness st_typing in - - let pre_typing = cpre_typing in - let ret_t_typing = cres_typing in - let post_typing = cpost_typing in - - elab_push_binding g x (mk_ref init_t); - let rbody_typing = soundness _ _ _ body_typing in - - admit () - // WT.with_local_typing - // #rg - // #ru - // #init_t - // #init - // #rpre - // #rret_t - // #rpost - // #rbody - // x - // a_typing - // rinit_typing - // pre_typing - // ret_t_typing - // post_typing - // rbody_typing -#pop-options diff --git a/src/checker/Pulse.Soundness.WithLocal.fsti b/src/checker/Pulse.Soundness.WithLocal.fsti deleted file mode 100644 index 26880333a..000000000 --- a/src/checker/Pulse.Soundness.WithLocal.fsti +++ /dev/null @@ -1,35 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Soundness.WithLocal - -open Pulse.Syntax -open Pulse.Typing -open Pulse.Elaborate.Pure -open Pulse.Elaborate.Core -open Pulse.Soundness.Common - -module RT = FStar.Reflection.Typing - -val withlocal_soundness - (#g:stt_env) - (#t:st_term) - (#c:comp) - (d:st_typing g t c{T_WithLocal? d}) - (soundness:soundness_t d) - : GTot (RT.tot_typing (elab_env g) - (elab_st_typing d) - (elab_comp c)) diff --git a/src/checker/Pulse.Soundness.WithLocalArray.fst b/src/checker/Pulse.Soundness.WithLocalArray.fst deleted file mode 100644 index 7decafaa6..000000000 --- a/src/checker/Pulse.Soundness.WithLocalArray.fst +++ /dev/null @@ -1,72 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Soundness.WithLocalArray - -open Pulse.Syntax -open Pulse.Reflection.Util -open Pulse.Typing -open Pulse.Elaborate.Core -open Pulse.Elaborate -open Pulse.Soundness.Common - -module WT = Pulse.Lib.Core.Typing - -#push-options "--ifuel 1 --fuel 8 --z3rlimit_factor 10" -let withlocalarray_soundness #g #t #c d soundness = - let T_WithLocalArray _ _ init len body init_t c x init_typing len_typing init_t_typing c_typing body_typing = d in - let CT_ST _ st st_typing = c_typing in - - let rg = elab_env g in - let ru = comp_u c in - let rpre = comp_pre c in - let rret_t = comp_res c in - let rpost = comp_post c in - let rbody = elab_st_typing body_typing in - - let a_typing = tot_typing_soundness init_t_typing in - let rinit_typing = tot_typing_soundness init_typing in - let rlen_typing = tot_typing_soundness len_typing in - let cres_typing, cpre_typing, cpost_typing = - Pulse.Soundness.Comp.stc_soundness st_typing in - - let pre_typing = cpre_typing in - let ret_t_typing = cres_typing in - let post_typing = cpost_typing in - - elab_push_binding g x (mk_array init_t); - let rbody_typing = soundness _ _ _ body_typing in - - admit() - // WT.with_localarray_typing - // #rg - // #ru - // #init_t - // #init - // #len - // #rpre - // #rret_t - // #rpost - // #rbody - // x - // a_typing - // rinit_typing - // rlen_typing - // pre_typing - // ret_t_typing - // post_typing - // rbody_typing -#pop-options diff --git a/src/checker/Pulse.Soundness.WithLocalArray.fsti b/src/checker/Pulse.Soundness.WithLocalArray.fsti deleted file mode 100644 index dfb1d6403..000000000 --- a/src/checker/Pulse.Soundness.WithLocalArray.fsti +++ /dev/null @@ -1,35 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Soundness.WithLocalArray - -open Pulse.Syntax -open Pulse.Typing -open Pulse.Elaborate.Pure -open Pulse.Elaborate.Core -open Pulse.Soundness.Common - -module RT = FStar.Reflection.Typing - -val withlocalarray_soundness - (#g:stt_env) - (#t:st_term) - (#c:comp) - (d:st_typing g t c{T_WithLocalArray? d}) - (soundness:soundness_t d) - : GTot (RT.tot_typing (elab_env g) - (elab_st_typing d) - (elab_comp c)) diff --git a/src/checker/Pulse.Soundness.fst b/src/checker/Pulse.Soundness.fst deleted file mode 100644 index 7fc6e7b1d..000000000 --- a/src/checker/Pulse.Soundness.fst +++ /dev/null @@ -1,324 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Soundness -module RT = FStar.Reflection.Typing -module R = FStar.Reflection.V2 -module T = FStar.Tactics.V2 -open FStar.List.Tot -open Pulse.Syntax -open Pulse.Reflection.Util -open Pulse.Typing -open Pulse.Elaborate -open Pulse.Soundness.Common -module Bind = Pulse.Soundness.Bind -module Lift = Pulse.Soundness.Lift -module Frame = Pulse.Soundness.Frame -module STEquiv = Pulse.Soundness.STEquiv -module Return = Pulse.Soundness.Return -module Exists = Pulse.Soundness.Exists -module While = Pulse.Soundness.While -module Admit = Pulse.Soundness.Admit -module WithLocal = Pulse.Soundness.WithLocal -module WithLocalArray = Pulse.Soundness.WithLocalArray -module Rewrite = Pulse.Soundness.Rewrite -module Comp = Pulse.Soundness.Comp -module LN = Pulse.Typing.LN -module FV = Pulse.Typing.FV -module Sub = Pulse.Soundness.Sub -module RU = Pulse.RuntimeUtils -module Typing = Pulse.Typing - -let tabs_t (d:'a) = - #g:stt_env -> - #u:universe -> - #ty:term -> - q:option qualifier -> - ppname:ppname -> - t_typing:tot_typing g ty (tm_type u) { t_typing << d } -> - #body:st_term -> - #x:var { freshv g x /\ ~(x `Set.mem` freevars_st body) } -> - #c:comp -> - body_typing:st_typing (push_binding g x ppname ty) (open_st_term body x) c { body_typing << d } -> - GTot (RT.tot_typing (elab_env g) - (mk_abs_with_name ppname.name ty (elab_qual q) (RT.close_term (elab_st_typing body_typing) x)) - (tm_arrow (mk_binder_ppname ty ppname) q (close_comp c x))) - -#push-options "--z3rlimit_factor 4 --split_queries no" -let lift_soundness - (g:stt_env) - (t:st_term) - (c:comp) - (d:st_typing g t c{T_Lift? d}) - (soundness:soundness_t d) - : GTot (RT.tot_typing (elab_env g) (elab_st_typing d) (elab_comp c)) = - LN.st_typing_ln d; - let T_Lift _ e c1 c2 e_typing lc = d in - LN.st_typing_ln e_typing; - match lc with - | Lift_STAtomic_ST _ _ -> - Lift.elab_lift_stt_atomic_st_typing g - c1 c2 _ (soundness _ _ _ e_typing) lc - - | Lift_Ghost_Neutral _ _ w -> - let (| reveal_a, reveal_a_typing |) = w in - Lift.elab_lift_ghost_neutral_typing g - c1 c2 _ (soundness _ _ _ e_typing) lc - _ (tot_typing_soundness reveal_a_typing) - - | Lift_Neutral_Ghost _ _ -> - Lift.elab_lift_neutral_ghost_typing g - c1 c2 _ (soundness _ _ _ e_typing) lc - - | Lift_Observability _ _ _ -> - Lift.elab_lift_observability_typing g - c1 c2 _ (soundness _ _ _ e_typing) lc -#pop-options - -let frame_soundness - (g:stt_env) - (t:st_term) - (c:comp) - (d:st_typing g t c{T_Frame? d}) - (soundness:soundness_t d) - : GTot (RT.tot_typing (elab_env g) (elab_st_typing d) (elab_comp c)) = - - let T_Frame _ e c frame frame_typing e_typing = d in - let r_e_typing = soundness _ _ _ e_typing in - LN.st_typing_ln e_typing; - Frame.elab_frame_typing g _ _ frame frame_typing r_e_typing - -let stequiv_soundness - (g:stt_env) - (t:st_term) - (c:comp) - (d:st_typing g t c{T_Equiv? d}) - (soundness:soundness_t d) - : GTot (RT.tot_typing (elab_env g) (elab_st_typing d) (elab_comp c)) = - - let T_Equiv _ e c c' e_typing equiv = d in - LN.st_typing_ln d; - LN.st_typing_ln e_typing; - let r_e_typing = soundness _ _ _ e_typing in - match equiv with - | ST_TotEquiv _ t1 t2 _ _ eq -> - let r_e_typing : RT.tot_typing (elab_env g) (elab_st_typing e_typing) t1 = - r_e_typing - in - let eq = RT.Rel_equiv _ _ _ RT.R_Sub eq in - RT.T_Sub _ _ _ _ r_e_typing (RT.Relc_typ _ _ _ _ _ eq) - | _ -> - STEquiv.st_equiv_soundness _ _ _ equiv _ r_e_typing - - -#push-options "--fuel 2 --ifuel 2 --z3rlimit_factor 30" - -let bind_soundness - (#g:stt_env) - (#t:st_term) - (#c:comp) - (d:st_typing g t c{T_Bind? d}) - (soundness: soundness_t d) - (mk_t_abs: tabs_t d) - : GTot (RT.tot_typing (elab_env g) - (elab_st_typing d) - (elab_comp c)) - = let T_Bind _ e1 e2 c1 c2 _ x c e1_typing t_typing e2_typing bc = d in - LN.st_typing_ln e1_typing; - LN.st_typing_ln e2_typing; - FV.st_typing_freevars_inv e1_typing x; - let r1_typing - : RT.tot_typing _ _ (elab_comp c1) - = soundness _ _ _ e1_typing - in - let r2_typing - : RT.tot_typing _ _ (tm_arrow (null_binder (comp_res c1)) None (close_comp c2 x)) - = mk_t_abs None _ t_typing e2_typing - in - match bc with - | Bind_comp _ _ _ _ t2_typing y post2_typing -> - Bind.elab_bind_typing g _ _ _ x _ r1_typing _ r2_typing bc - (tot_typing_soundness t2_typing) - (mk_t_abs_tot _ ppname_default t2_typing post2_typing) -#pop-options - -#push-options "--z3rlimit_factor 4 --fuel 4 --ifuel 2" -let retype_hyp #g #hyp #t0 #t1 #e #t - (_:RT.tot_typing (RT.extend_env g hyp t0) e t) - (equiv:RT.equiv g t0 t1) -: GTot (RT.tot_typing (RT.extend_env g hyp t1) e t) -= admit() - -let equiv_rw #u #t #x #y g -: GTot (RT.equiv g (mk_sq_rewrites_to_p u t x y) (RT.eq2 u t x y)) -= admit() - -let if_soundness - (g:stt_env) - (t:st_term) - (c:comp) - (d:st_typing g t c{T_If? d}) - (soundness:soundness_t d) - (ct_soundness: (g:stt_env -> c:comp -> uc:universe -> - d':comp_typing g c uc{d' << d} -> - GTot (RT.tot_typing (elab_env g) - (elab_comp c) - (RT.tm_type uc)))) - : GTot (RT.tot_typing (elab_env g) - (elab_st_typing d) - (elab_comp c)) = - - let T_If _ b e1 e2 _ hyp b_typing e1_typing e2_typing (E c_typing) = d in - let rb_typing : RT.tot_typing (elab_env g) - b - RT.bool_ty = - tot_typing_soundness b_typing in - let g_then = g_with_eq g hyp b tm_true in - let rw_true = (mk_sq_rewrites_to_p u0 tm_bool b tm_true) in - elab_push_binding g hyp rw_true; - let re1_typing - : RT.tot_typing (RT.extend_env (elab_env g) - hyp - (RT.eq2 u0 tm_bool b tm_true)) - (elab_st_typing e1_typing) - (elab_comp c) = - retype_hyp (soundness g_then e1 c e1_typing) (equiv_rw _) in - let g_else = g_with_eq g hyp b tm_false in - let rw_false = (mk_sq_rewrites_to_p u0 tm_bool b tm_false) in - elab_push_binding g hyp rw_false; - let re2_typing - : RT.tot_typing (RT.extend_env (elab_env g) - hyp - (RT.eq2 u0 tm_bool b tm_false)) - (elab_st_typing e2_typing) - (elab_comp c) = - retype_hyp (soundness g_else e2 c e2_typing) (equiv_rw _) in - let c_typing = - ct_soundness _ _ _ c_typing - in - assume (~(hyp `Set.mem` RT.freevars (elab_st_typing e1_typing))); - assume (~(hyp `Set.mem` RT.freevars (elab_st_typing e2_typing))); - RT.T_If _ _ _ _ _ _ _ _ _ rb_typing re1_typing re2_typing c_typing -#pop-options - -#push-options "--fuel 2 --ifuel 2" -let rec soundness (g:stt_env) - (t:st_term) - (c:comp) - (d:st_typing g t c) - : GTot (RT.tot_typing (elab_env g) (elab_st_typing d) (elab_comp c)) - (decreases d) - = let mk_t_abs (#g:stt_env) - (#u:universe) - (#ty:term) - (q:option qualifier) - (ppname:ppname) - (t_typing:tot_typing g ty (tm_type u) { t_typing << d }) - (#body:st_term) - (#x:var { freshv g x /\ ~(x `Set.mem` freevars_st body) }) - (#c:comp) - (body_typing:st_typing (push_binding g x ppname ty) (open_st_term body x) c { body_typing << d }) - : GTot (RT.tot_typing (elab_env g) - (mk_abs_with_name ppname.name ty (elab_qual q) (RT.close_term (elab_st_typing body_typing) x)) - (tm_arrow (mk_binder_ppname ty ppname) q (close_comp c x))) - = let r_t_typing = tot_typing_soundness t_typing in - let r_body_typing = soundness _ _ _ body_typing in - mk_t_abs g #_ #_ #_ #t_typing ppname r_t_typing r_body_typing - in - LN.st_typing_ln d; - match d with - | T_Lift .. -> - lift_soundness _ _ _ d soundness - | T_Frame .. -> - frame_soundness _ _ _ d soundness - - | T_Abs _ x q ty u body c t_typing body_typing -> - admit () - - | T_ST .. - | T_STGhost .. -> admit() - - | T_Bind .. -> - bind_soundness d soundness mk_t_abs - - | T_BindFn .. -> - Bind.bind_fn_typing d soundness - - | T_Equiv .. -> - stequiv_soundness _ _ _ d soundness - - | T_Return .. -> - Return.return_soundness d - - | T_If .. -> - let ct_soundness g c uc (d':_ {d' << d}) = - Comp.comp_typing_soundness g c uc d' - in - if_soundness _ _ _ d soundness ct_soundness - - | T_Match .. -> - let ct_soundness g c uc (d':_ {d' << d}) = - Comp.comp_typing_soundness g c uc d' - in - Pulse.Soundness.Match.match_soundness _ _ _ d soundness ct_soundness - - | T_IntroPure .. -> - admit() - - | T_ElimExists .. -> - Exists.elim_exists_soundness d - - | T_IntroExists .. -> - Exists.intro_exists_soundness d - - | T_While .. -> - admit() - - | T_WithLocal .. -> - WithLocal.withlocal_soundness d soundness - | T_WithLocalUninit .. -> - admit () - - | T_WithLocalArray .. -> - WithLocalArray.withlocalarray_soundness d soundness - | T_WithLocalArrayUninit .. -> - admit () - - | T_Rewrite .. -> - Rewrite.rewrite_soundness d - - | T_Admit .. -> Admit.admit_soundess d - - | T_Unreachable .. -> RU.magic() - - | T_Sub .. -> Sub.sub_soundness d soundness - - | T_ForwardJumpLabel .. -> admit () - | T_Goto .. -> admit () -#pop-options - -let soundness_lemma - (g:stt_env) - (t:st_term) - (c:comp) - (d:st_typing g t c) - : Lemma (ensures RT.tot_typing (elab_env g) - (elab_st_typing d) - (elab_comp c)) - = FStar.Squash.bind_squash - #(st_typing g t c) - () - (fun dd -> FStar.Squash.return_squash (soundness g t c d)) diff --git a/src/checker/Pulse.Soundness.fsti b/src/checker/Pulse.Soundness.fsti deleted file mode 100644 index 85fcc8346..000000000 --- a/src/checker/Pulse.Soundness.fsti +++ /dev/null @@ -1,33 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Soundness -module RT = FStar.Reflection.Typing -open FStar.List.Tot -open Pulse.Syntax -open Pulse.Reflection.Util -open Pulse.Typing -open Pulse.Elaborate -open Pulse.Soundness.Common - -val soundness_lemma - (g:stt_env) - (t:st_term) - (c:comp) - (d:st_typing g t c) - : Lemma (ensures RT.tot_typing (elab_env g) - (elab_st_typing d) - (elab_comp c)) diff --git a/src/checker/Pulse.Syntax.Naming.fst b/src/checker/Pulse.Syntax.Naming.fst index a5f01257c..2166cbaae 100644 --- a/src/checker/Pulse.Syntax.Naming.fst +++ b/src/checker/Pulse.Syntax.Naming.fst @@ -133,7 +133,7 @@ let close_open_inverse_ascription' (t:comp_ascription) | None -> () | Some c -> close_open_inverse_comp' c x i) -#push-options "--z3rlimit_factor 20 --fuel 2 --ifuel 2 --split_queries no" +#push-options "--z3rlimit_factor 40 --fuel 2 --ifuel 2 --split_queries no" #restart-solver let rec close_open_inverse_st' (t:st_term) (x:var { ~(x `Set.mem` freevars_st t) } ) diff --git a/src/checker/Pulse.Typing.Combinators.fst b/src/checker/Pulse.Typing.Combinators.fst index 5f6e3dc1d..377034030 100644 --- a/src/checker/Pulse.Typing.Combinators.fst +++ b/src/checker/Pulse.Typing.Combinators.fst @@ -51,25 +51,25 @@ let st_equiv_trans (#g:env) (#c0 #c1 #c2:comp) (d01:st_equiv g c0 c1) (d12:st_eq : st_equiv g c0 c2 = match d01 with - | ST_SLPropEquiv _f _c0 _c1 x c0_pre_typing c0_res_typing c0_post_typing eq_res_01 eq_pre_01 eq_post_01 -> ( - let ST_SLPropEquiv _f _c1 _c2 y c1_pre_typing c1_res_typing c1_post_typing eq_res_12 eq_pre_12 eq_post_12 = d12 in + | ST_SLPropEquiv _f _c0 _c1 x eq_res_01 eq_pre_01 eq_post_01 -> ( + let ST_SLPropEquiv _f _c1 _c2 y eq_res_12 eq_pre_12 eq_post_12 = d12 in let eq_res_10 = RT.Rel_sym _ _ _ eq_res_01 in let eq_post_12_x = Pulse.Typing.Metatheory.Base.slprop_equiv_rename y x _ _ eq_res_10 eq_post_12 in Pulse.Typing.FV.freevars_open_term_both y (comp_post c2); Pulse.Typing.Metatheory.Base.freevars_slprop_equiv eq_post_12; assert ~(Set.mem x (freevars (comp_post c2))); let eq = - ST_SLPropEquiv g c0 c2 x c0_pre_typing c0_res_typing c0_post_typing + ST_SLPropEquiv g c0 c2 x (RT.Rel_trans _ _ _ _ _ eq_res_01 eq_res_12) (VE_Trans _ _ _ _ eq_pre_01 eq_pre_12) (VE_Trans _ _ _ _ eq_post_01 eq_post_12_x) in eq ) - | ST_TotEquiv g t1 t2 u typing eq -> - let ST_TotEquiv _g _t1 t3 _ _ eq' = d12 in + | ST_TotEquiv g t1 t2 u eq -> + let ST_TotEquiv _g _t1 t3 _ eq' = d12 in let eq'' = Ghost.hide (RT.Rel_trans _ _ _ _ _ eq eq') in - ST_TotEquiv g t1 t3 u typing eq'' + ST_TotEquiv g t1 t3 u eq'' let t_equiv #g #st #c (d:st_typing g st c) (#c':comp) (eq:st_equiv g c c') : st_typing g st c' @@ -203,8 +203,8 @@ let mk_bind_st_st = fun g pre e1 e2 c1 c2 px d_e1 d_c1res d_e2 res_typing post_typing _ -> let _, x = px in let b = nvar_as_binder px (comp_res c1) in - let bc = Bind_comp g x c1 c2 res_typing x post_typing in - (| _, _, T_Bind _ e1 e2 _ _ b _ _ d_e1 d_c1res d_e2 bc |) + let bc = Bind_comp g x c1 c2 x in + (| _, _, T_Bind _ e1 e2 _ _ b _ _ d_e1 d_e2 bc |) #pop-options let inames_of (c:comp_st) : term = match c with @@ -274,16 +274,16 @@ let mk_bind_ghost_ghost : bind_t C_STGhost? C_STGhost? = let C_STGhost inames2 sc2 = c2 in if eq_tm inames1 inames2 then begin - let bc = Bind_comp g x c1 c2 res_typing x post_typing in - (| _, _, T_Bind _ e1 e2 _ _ b _ _ d_e1 d_c1res d_e2 bc |) + let bc = Bind_comp g x c1 c2 x in + (| _, _, T_Bind _ e1 e2 _ _ b _ _ d_e1 d_e2 bc |) end else if (PostHint? post_hint) then ( let pv = check_prop_validity _ _ (tm_inames_subset_typing _ _ _) in let d_e1 = T_Sub _ _ _ _ d_e1 (STS_GhostInvs _ sc1 inames1 inames2 pv) in let c1 = C_STGhost inames2 sc1 in - let bc = Bind_comp g x c1 c2 res_typing x post_typing in - (| _, _, T_Bind _ e1 e2 _ _ b _ _ d_e1 d_c1res d_e2 bc |) + let bc = Bind_comp g x c1 c2 x in + (| _, _, T_Bind _ e1 e2 _ _ b _ _ d_e1 d_e2 bc |) ) else begin let new_inames = tm_join_inames inames1 inames2 in @@ -293,8 +293,8 @@ let mk_bind_ghost_ghost : bind_t C_STGhost? C_STGhost? = let d_e2 = T_Sub _ _ _ _ d_e2 (STS_GhostInvs _ sc2 inames2 new_inames pv2) in let c1 = C_STGhost new_inames sc1 in let c2 = C_STGhost new_inames sc2 in - let bc = Bind_comp g x c1 c2 res_typing x post_typing in - (| _, _, T_Bind _ e1 e2 _ _ b _ _ d_e1 d_c1res d_e2 bc |) + let bc = Bind_comp g x c1 c2 x in + (| _, _, T_Bind _ e1 e2 _ _ b _ _ d_e1 d_e2 bc |) end let mk_bind_atomic_atomic @@ -308,16 +308,16 @@ let mk_bind_atomic_atomic then ( if eq_tm inames1 inames2 then begin - let bc = Bind_comp g x c1 c2 res_typing x post_typing in - (| _, _, T_Bind _ e1 e2 _ _ b _ _ d_e1 d_c1res d_e2 bc |) + let bc = Bind_comp g x c1 c2 x in + (| _, _, T_Bind _ e1 e2 _ _ b _ _ d_e1 d_e2 bc |) end else if (PostHint? post_hint) then ( let pv = check_prop_validity _ _ (tm_inames_subset_typing _ _ _) in let d_e1 = T_Sub _ _ _ _ d_e1 (STS_AtomicInvs _ sc1 inames1 inames2 obs1 obs1 pv) in let c1 = C_STAtomic inames2 obs1 sc1 in - let bc = Bind_comp g x c1 c2 res_typing x post_typing in - (| _, _, T_Bind _ e1 e2 _ _ b _ _ d_e1 d_c1res d_e2 bc |) + let bc = Bind_comp g x c1 c2 x in + (| _, _, T_Bind _ e1 e2 _ _ b _ _ d_e1 d_e2 bc |) ) else begin let new_inames = tm_join_inames inames1 inames2 in @@ -327,8 +327,8 @@ let mk_bind_atomic_atomic let d_e2 = T_Sub _ _ _ _ d_e2 (STS_AtomicInvs _ sc2 inames2 new_inames obs2 obs2 pv2) in let c1 = C_STAtomic new_inames obs1 sc1 in let c2 = C_STAtomic new_inames obs2 sc2 in - let bc = Bind_comp g x c1 c2 res_typing x post_typing in - (| _, _, T_Bind _ e1 e2 _ _ b _ _ d_e1 d_c1res d_e2 bc |) + let bc = Bind_comp g x c1 c2 x in + (| _, _, T_Bind _ e1 e2 _ _ b _ _ d_e1 d_e2 bc |) end ) else ( @@ -488,7 +488,7 @@ let add_frame (#g:env) (#t:st_term) (#c:comp_st) (t_typing:st_typing g t c) c':comp_st { c' == add_frame c frame } & st_typing g t' c' = - (| t, add_frame c frame, T_Frame _ _ _ _ frame_typing t_typing |) + (| t, add_frame c frame, T_Frame _ _ _ _ t_typing |) #push-options "--fuel 0 --ifuel 0" let apply_frame (#g:env) @@ -507,7 +507,7 @@ let apply_frame (#g:env) let (| frame, frame_typing, ve |) = frame_t in let t_typing : st_typing g t (Pulse.Typing.add_frame c frame) - = T_Frame g t c frame frame_typing t_typing in + = T_Frame g t c frame t_typing in let c' = Pulse.Typing.add_frame c frame in let c'_typing = Metatheory.st_typing_correctness t_typing in let s' = st_comp_of_comp c' in @@ -517,8 +517,8 @@ let apply_frame (#g:env) assert (comp_post c' == comp_post c''); let ve: slprop_equiv g (comp_pre c') (comp_pre c'') = ve in let st_typing = fst <| Metatheory.comp_typing_inversion c'_typing in - let (| res_typing, pre_typing, x, post_typing |) = Metatheory.st_comp_typing_inversion st_typing in - let st_equiv = ST_SLPropEquiv g c' c'' x pre_typing res_typing post_typing (RT.Rel_refl _ _ _) ve (VE_Refl _ _) in + let (| _, _, x, _ |) = Metatheory.st_comp_typing_inversion st_typing in + let st_equiv = ST_SLPropEquiv g c' c'' x (RT.Rel_refl _ _ _) ve (VE_Refl _ _) in let t_typing = t_equiv t_typing st_equiv in (| c'', t_typing |) @@ -538,20 +538,14 @@ let comp_for_post_hint #g (#pre:slprop) (pre_typing:tot_typing g pre tm_slprop) assume (close_term post_opened x == post.post); let s : st_comp = {u=post.u;res=post.ret_ty;pre;post=post.post} in let d_s : st_comp_typing _ s = - STC _ s x post_typing_rec.ty_typing pre_typing post_typing_rec.post_typing in + STC _ s x in match post.effect_annot with | EffectAnnotSTT -> (| _, CT_ST _ _ d_s |) | EffectAnnotGhost { opens } -> - let d_opens : tot_typing post.g opens tm_inames = post.effect_annot_typing in - assert (g `env_extends` post.g); - let d_opens : tot_typing g opens tm_inames = RU.magic () in // weakening - (| _, CT_STGhost _ opens _ d_opens d_s |) + (| _, CT_STGhost _ opens _ d_s |) | EffectAnnotAtomic { opens } | EffectAnnotAtomicOrGhost { opens } -> - let d_opens : tot_typing post.g opens tm_inames = post.effect_annot_typing in - assert (g `env_extends` post.g); - let d_opens : tot_typing g opens tm_inames = RU.magic () in // weakening - (| _, CT_STAtomic _ opens Neutral _ d_opens d_s |) + (| _, CT_STAtomic _ opens Neutral _ d_s |) | _ -> T.fail "Impossible" #pop-options \ No newline at end of file diff --git a/src/checker/Pulse.Typing.Env.fst b/src/checker/Pulse.Typing.Env.fst index c44d593be..ad0b810be 100644 --- a/src/checker/Pulse.Typing.Env.fst +++ b/src/checker/Pulse.Typing.Env.fst @@ -391,3 +391,11 @@ let info_doc_with_subissues (g:env) (r:option range) concat) ] in info_doc g r msg + +let has_stt_bindings (f:RT.fstar_top_env) = + RT.lookup_fvar f RT.bool_fv == Some (RT.tm_type RT.u_zero) /\ + RT.lookup_fvar f Pulse.Reflection.Util.slprop_fv == Some (RT.tm_type Pulse.Syntax.Pure.u2) /\ True + +let check_top_level_environment (f:RT.fstar_top_env) + : option (g:stt_env{fstar_env g == f /\ bindings g == []}) + = admit(); Some (mk_env f) diff --git a/src/checker/Pulse.Typing.Env.fsti b/src/checker/Pulse.Typing.Env.fsti index a063528e7..818e5451e 100644 --- a/src/checker/Pulse.Typing.Env.fsti +++ b/src/checker/Pulse.Typing.Env.fsti @@ -251,3 +251,8 @@ val info_doc_with_subissues (g:env) (r:option range) (sub : list Issue.issue) (msg : list Pprint.document) : T.Tac unit + +val has_stt_bindings (f:RT.fstar_top_env) : prop +let stt_env = e:env { has_stt_bindings (fstar_env e) } +val check_top_level_environment (f:RT.fstar_top_env) + : option (g:stt_env{fstar_env g == f /\ bindings g == []}) diff --git a/src/checker/Pulse.Typing.FV.fst b/src/checker/Pulse.Typing.FV.fst index 67ac9736e..2c49bafd2 100644 --- a/src/checker/Pulse.Typing.FV.fst +++ b/src/checker/Pulse.Typing.FV.fst @@ -22,7 +22,6 @@ open FStar.List.Tot open Pulse.Syntax open Pulse.Typing open Pulse.Elaborate -open Pulse.Soundness.Common // let vars_of_rt_env (g:R.env) = Set.intension (fun x -> Some? (RT.lookup_bvar g x)) @@ -287,10 +286,7 @@ let tot_or_ghost_typing_freevars : Lemma (ensures freevars t `Set.subset` vars_of_env g /\ freevars ty `Set.subset` vars_of_env g) - = let E d = d in - refl_typing_freevars d; - admit (); - assert (vars_of_env_r (elab_env g) `Set.equal` (vars_of_env g)) + = admit () let tot_typing_freevars (#g:_) (#t:_) (#ty:_) @@ -298,7 +294,7 @@ let tot_typing_freevars : Lemma (ensures freevars t `Set.subset` vars_of_env g /\ freevars ty `Set.subset` vars_of_env g) - = tot_or_ghost_typing_freevars d + = admit () #push-options "--z3rlimit 10" let bind_comp_freevars (#g:_) (#x:_) (#c1 #c2 #c:_) @@ -308,7 +304,7 @@ let bind_comp_freevars (#g:_) (#x:_) (#c1 #c2 #c:_) freevars_comp c2 `Set.subset` (Set.union (vars_of_env g) (Set.singleton x))) (ensures freevars_comp c `Set.subset` vars_of_env g) = match d with - | Bind_comp _ _ _ _ dt _ _ -> tot_or_ghost_typing_freevars dt + | Bind_comp _ _ _ _ _ -> admit () #pop-options let rec slprop_equiv_freevars (#g:_) (#t0 #t1:_) (v:slprop_equiv g t0 t1) @@ -330,9 +326,7 @@ let rec slprop_equiv_freevars (#g:_) (#t0 #t1:_) (v:slprop_equiv g t0 t1) | VE_Comm g t0 t1 -> () | VE_Assoc g t0 t1 t2 -> () | VE_Ext g t0 t1 token -> - let d0, d1 = slprop_eq_typing_inversion _ _ _ token in - tot_or_ghost_typing_freevars d0; - tot_or_ghost_typing_freevars d1 + admit () | VE_Fa g x u b t0 t1 d -> slprop_equiv_freevars d; close_open_inverse t0 x @@ -344,17 +338,7 @@ let st_equiv_freevars #g (#c1 #c2:_) : Lemma (requires freevars_comp c1 `Set.subset` vars_of_env g) (ensures freevars_comp c2 `Set.subset` vars_of_env g) - = match d with - | ST_SLPropEquiv _ _ _ x _ _ _ eq_res eq_pre eq_post -> ( - slprop_equiv_freevars eq_pre; - slprop_equiv_freevars eq_post; - freevars_open_term_inv (comp_post c1) x; - freevars_open_term_inv (comp_post c2) x; - refl_equiv_freevars eq_res - ) - | ST_TotEquiv _ t1 t2 u t1_typing eq -> - let t2_typing = Pulse.Typing.Metatheory.Base.rt_equiv_typing eq t1_typing._0 in - tot_or_ghost_typing_freevars (E (Ghost.reveal t2_typing)) + = admit () let prop_validity_fv (g:env) (p:term) : Lemma @@ -389,27 +373,15 @@ let st_comp_typing_freevars #g #st (d:st_comp_typing g st) : Lemma (ensures freevars_st_comp st `Set.subset` vars_of_env g) (decreases d) - = let STC _ _ x dt pre post = d in - tot_or_ghost_typing_freevars dt; - tot_or_ghost_typing_freevars pre; - tot_or_ghost_typing_freevars post + = let STC _ _ x = d in + admit () let comp_typing_freevars (#g:_) (#c:_) (#u:_) (d:comp_typing g c u) : Lemma (ensures freevars_comp c `Set.subset` vars_of_env g) (decreases d) - = match d with - | CT_Tot _ _ _ dt -> - tot_or_ghost_typing_freevars dt - - | CT_ST _ _ dst -> - st_comp_typing_freevars dst - - | CT_STGhost _ _ _ it dst - | CT_STAtomic _ _ _ _ it dst -> - tot_or_ghost_typing_freevars it; - st_comp_typing_freevars dst + = admit () let freevars_open_st_term_inv (e:st_term) (x:var {~ (x `Set.mem` freevars_st e) }) @@ -502,194 +474,64 @@ let st_typing_freevars_case let st_typing_freevars_abs : st_typing_freevars_case T_Abs? = fun d cb -> - match d with - | T_Abs _ x q ty _ body cres dt db -> - tot_or_ghost_typing_freevars dt; - cb db; - freevars_close_comp cres x 0; - freevars_open_st_term_inv body x; - freevars_tm_arrow ty q (close_comp cres x) + admit () #push-options "--z3rlimit_factor 20 --fuel 3 --ifuel 2 --split_queries no" #restart-solver let st_typing_freevars_return : st_typing_freevars_case T_Return? = fun d cb -> - match d with - | T_Return _ c use_eq u t e post x t_typing e_typing post_typing -> - tot_or_ghost_typing_freevars t_typing; - tot_or_ghost_typing_freevars e_typing; - tot_or_ghost_typing_freevars post_typing; - let post_maybe_eq = - if use_eq - then let post = open_term' post (null_var x) 0 in - let post = tm_star post (tm_pure (mk_eq2 u t (null_var x) e)) in - let post = close_term post x in - post - else post - in - freevars_open_term post (null_var x) 0; - freevars_mk_eq2 u t (null_var x) e; - freevars_close_term - (tm_star (open_term' post (null_var x) 0) (tm_pure (mk_eq2 u t (null_var x) e))) - x 0; - freevars_open_term post e 0 + admit () #pop-options #restart-solver #push-options "--z3rlimit_factor 4 --fuel 1 --ifuel 1 --split_queries always" let st_typing_freevars_bind : st_typing_freevars_case T_Bind? = fun d cb -> - match d with - | T_Bind _ e1 e2 _ _ _ x c d1 dc1 d2 bc -> - cb d1; - tot_or_ghost_typing_freevars dc1; - cb d2; - bind_comp_freevars bc; - freevars_open_st_term_inv e2 x + admit () let st_typing_freevars_bind_fn : st_typing_freevars_case T_BindFn? = fun d cb -> - match d with - | T_BindFn _g _e1 e2 _c1 _c2 _b x d1 _u dc1 d2 c -> - cb d1; - tot_or_ghost_typing_freevars dc1; - cb d2; - comp_typing_freevars c; - freevars_open_st_term_inv e2 x + admit () let st_typing_freevars_if : st_typing_freevars_case T_If? = fun #g #t #c d cb -> - match d with - | T_If _ _b e1 e2 _c hyp tb d1 d2 (E ct) -> - assert (t.term == (Tm_If { b = _b; then_=e1; else_=e2; post=None })); - calc (Set.subset) { - freevars_st t; - (==) {} - ((Set.union (freevars _b) (freevars_st e1)) `Set.union` - (freevars_st e2 `Set.union` freevars_term_opt None)); - (Set.equal) {} - (freevars _b `Set.union` (freevars_st e1 `Set.union` freevars_st e2)); - (Set.subset) { tot_or_ghost_typing_freevars tb } - (vars_of_env g `Set.union` (freevars_st e1 `Set.union` freevars_st e2)); - (Set.subset) { cb d1 ; cb d2 } - vars_of_env g; - }; - comp_typing_freevars ct + admit () #pop-options #restart-solver #push-options "--z3rlimit_factor 8" let st_typing_freevars_frame : st_typing_freevars_case T_Frame? = fun d cb -> - match d with - | T_Frame _ _ _ _ df dc -> - tot_or_ghost_typing_freevars df; - cb dc + admit () #pop-options #restart-solver #push-options "--z3rlimit_factor 4 --fuel 2 --ifuel 1" let st_typing_freevars_elimexists : st_typing_freevars_case T_ElimExists? = fun #g #t #c d cb -> - match d with - | T_ElimExists _ u t p x dt dv -> - let x_tm = tm_var {nm_index=x;nm_ppname=ppname_default} in - tot_or_ghost_typing_freevars dt; - tot_or_ghost_typing_freevars dv; - freevars_mk_reveal u t x_tm; - assert (Set.equal (freevars (Pulse.Typing.mk_reveal u t x_tm)) - (Set.union (freevars t) (Set.singleton x))); - freevars_open_term p (Pulse.Typing.mk_reveal u t x_tm) 0; - assert (Set.subset (freevars (open_term' p (Pulse.Typing.mk_reveal u t x_tm) 0)) - (Set.union (freevars p) - (Set.union (freevars t) - (Set.singleton x)))); - assert (~ (Set.mem x (freevars t))); - assert (~ (Set.mem x (freevars p))); - assert (Set.subset (set_minus (freevars (open_term' p (Pulse.Typing.mk_reveal u t x_tm) 0)) x) - (Set.union (freevars p) - (freevars t))); - assert (Set.subset - (set_minus (freevars (open_term' p (Pulse.Typing.mk_reveal u t x_tm) 0)) x) - (vars_of_env g)); - freevars_mk_erased u t + admit () let st_typing_freevars_introexists : st_typing_freevars_case T_IntroExists? = fun #g #t #c d cb -> - match d with - | T_IntroExists _ u b p w dt dv dw -> - tot_or_ghost_typing_freevars dt; - tot_or_ghost_typing_freevars dv; - tot_or_ghost_typing_freevars dw; - assert (freevars_st t `Set.subset` vars_of_env g); - calc (Set.subset) { - freevars_comp c; - (Set.equal) {} - freevars_comp (comp_intro_exists u b p w); - (Set.equal) {} - freevars tm_emp_inames `Set.union` - (freevars tm_unit `Set.union` - (freevars (open_term' p w 0) `Set.union` - freevars (tm_exists_sl u b p))); - (Set.equal) {} - (freevars (open_term' p w 0) `Set.union` - freevars (tm_exists_sl u b p)); - (Set.subset) { freevars_open_term p w 0 } - (freevars p `Set.union` - freevars w `Set.union` - freevars_st t `Set.union` - freevars p); - } + admit () let st_typing_freevars_rewrite : st_typing_freevars_case T_Rewrite? = fun d cb -> - match d with - | T_Rewrite _ _ _ p_typing equiv_p_q -> - tot_or_ghost_typing_freevars p_typing; - slprop_equiv_freevars equiv_p_q + admit () let st_typing_freevars_withlocal : st_typing_freevars_case T_WithLocal? = fun d cb -> - match d with - | T_WithLocal _ _ init body init_t c x init_typing u_typing c_typing body_typing -> - tot_or_ghost_typing_freevars init_typing; - cb body_typing; - freevars_open_st_term_inv body x; - comp_typing_freevars c_typing; - tot_or_ghost_typing_freevars u_typing; - freevars_ref init_t + admit () let st_typing_freevars_withlocalarray : st_typing_freevars_case T_WithLocalArray? = fun d cb -> - match d with - | T_WithLocalArray _ _ init len body init_t c x init_typing len_typing u_typing c_typing body_typing -> - tot_or_ghost_typing_freevars init_typing; - tot_or_ghost_typing_freevars len_typing; - cb body_typing; - freevars_open_st_term_inv body x; - comp_typing_freevars c_typing; - tot_or_ghost_typing_freevars u_typing; - freevars_array init_t + admit () let st_typing_freevars_admit : st_typing_freevars_case T_Admit? = fun d cb -> - match d with - | T_Admit _ c c_typing -> - comp_typing_freevars c_typing; - let st_typing, _ = Pulse.Typing.Metatheory.Base.comp_typing_inversion c_typing in - let STC _ _ x t_typing pre_typing post_typing = st_typing in - tot_or_ghost_typing_freevars t_typing; - tot_or_ghost_typing_freevars post_typing; - freevars_open_term (comp_post c) (term_of_no_name_var x) 0 + admit () let st_typing_freevars_unreachable : st_typing_freevars_case T_Unreachable? = fun d cb -> - match d with - | T_Unreachable _ c c_typing -> - comp_typing_freevars c_typing; - let st_typing, _ = Pulse.Typing.Metatheory.Base.comp_typing_inversion c_typing in - let STC _ _ x t_typing pre_typing post_typing = st_typing in - tot_or_ghost_typing_freevars t_typing; - tot_or_ghost_typing_freevars post_typing; - freevars_open_term (comp_post c) (term_of_no_name_var x) 0 + admit () let rec st_typing_freevars (#g:_) (#t:_) (#c:_) @@ -717,11 +559,11 @@ let rec st_typing_freevars admit () // IOU | T_Frame .. -> st_typing_freevars_frame d st_typing_freevars - | T_IntroPure _ p prop_typing _ -> - tot_or_ghost_typing_freevars prop_typing - | T_ElimExists _ u t p x dt dv -> + | T_IntroPure _ p _ -> + admit () + | T_ElimExists _ u t p x -> st_typing_freevars_elimexists d st_typing_freevars - | T_IntroExists _ u b p w dt dv dw -> + | T_IntroExists _ u b p w -> st_typing_freevars_introexists d st_typing_freevars | T_Equiv _ _ _ _ d2 deq -> st_typing_freevars d2; diff --git a/src/checker/Pulse.Typing.LN.fst b/src/checker/Pulse.Typing.LN.fst index b106cb20d..424ed9282 100644 --- a/src/checker/Pulse.Typing.LN.fst +++ b/src/checker/Pulse.Typing.LN.fst @@ -934,15 +934,14 @@ let tot_or_ghost_typing_ln (d:typing g e eff t) : Lemma (ensures ln e /\ ln t) - = let E dt = d in - well_typed_terms_are_ln _ _ _ dt + = admit () let tot_typing_ln (#g:_) (#e:_) (#t:_) (d:tot_typing g e t) : Lemma (ensures ln e /\ ln t) - = tot_or_ghost_typing_ln d + = admit () #push-options "--fuel 4 --ifuel 4" let rec slprop_equiv_ln (#g:_) (#t0 #t1:_) (v:slprop_equiv g t0 t1) : Lemma (ensures ln t0 <==> ln t1) @@ -961,9 +960,7 @@ let rec slprop_equiv_ln (#g:_) (#t0 #t1:_) (v:slprop_equiv g t0 t1) | VE_Comm g t0 t1 -> () | VE_Assoc g t0 t1 t2 -> () | VE_Ext g t0 t1 token -> - let d0, d1 = slprop_eq_typing_inversion _ _ _ token in - tot_or_ghost_typing_ln d0; - tot_or_ghost_typing_ln d1 + admit () | VE_Fa g x u b t0' t1' d -> slprop_equiv_ln d; let xtm = (term_of_nvar (v_as_nv x)) in @@ -986,16 +983,15 @@ let st_equiv_ln #g #c1 #c2 (d:st_equiv g c1 c2) (requires ln_c c1) (ensures ln_c c2) = match d with - | ST_SLPropEquiv _ _ _ x (E dpre) _dres _dpost eq_res eq_pre eq_post -> + | ST_SLPropEquiv _ _ _ x eq_res eq_pre eq_post -> slprop_equiv_ln eq_pre; open_term_ln_inv' (comp_post c1) (term_of_no_name_var x) 0; slprop_equiv_ln eq_post; rt_equiv_ln _ _ _ eq_res; open_term_ln' (comp_post c2) (term_of_no_name_var x) 0 - | ST_TotEquiv g t1 t2 u t1_typing eq -> - let t2_typing = Pulse.Typing.Metatheory.Base.rt_equiv_typing eq t1_typing._0 in - tot_or_ghost_typing_ln (E (Ghost.reveal t2_typing)) + | ST_TotEquiv g t1 t2 u eq -> + admit () let prop_valid_must_be_ln (g:env) (t:term) (d:prop_validity g t) : Lemma (ensures ln t) = @@ -1026,23 +1022,11 @@ let bind_comp_ln #g #x #c1 #c2 #c (d:bind_comp g x c1 c2 c) let st_comp_typing_ln (#g:_) (#st:_) (d:st_comp_typing g st) : Lemma (ensures ln_st_comp st (-1)) = - - let STC _ {post} x res_typing pre_typing post_typing = d in - tot_or_ghost_typing_ln res_typing; - tot_or_ghost_typing_ln pre_typing; - tot_or_ghost_typing_ln post_typing; - open_term_ln' post (null_var x) 0 + admit () let comp_typing_ln (#g:_) (#c:_) (#u:_) (d:comp_typing g c u) : Lemma (ensures ln_c c) = - - match d with - | CT_Tot _ _ _ t_typing -> tot_or_ghost_typing_ln t_typing - | CT_ST _ _ st_typing -> st_comp_typing_ln st_typing - | CT_STGhost _ _ _ inames_typing st_typing - | CT_STAtomic _ _ _ _ inames_typing st_typing -> - tot_or_ghost_typing_ln inames_typing; - st_comp_typing_ln st_typing + admit () #pop-options let ln_mk_reveal (u:universe) (t:term) (e:term) (n:int) @@ -1110,28 +1094,17 @@ let rec st_typing_ln (#g:_) (#t:_) (#c:_) (ensures ln_st t /\ ln_c c) (decreases d) = match d with - | T_Frame _ _ c frame df dc -> + | T_Frame _ _ c frame dc -> FStar.Pure.BreakVC.break_vc (); - tot_or_ghost_typing_ln df; st_typing_ln dc; - assert (ln' (comp_post c) 0); - assert (ln' frame 0); - assert (ln' (tm_star (comp_post c) frame) 0) + admit () - | T_IntroPure _ p t _ -> + | T_IntroPure _ p _ -> FStar.Pure.BreakVC.break_vc (); - tot_or_ghost_typing_ln t; - assert (ln p); - assert (ln' p 0); - assert (ln' (tm_pure p) 0) + admit () - | T_Abs _g x _q ty _u body c dt db -> - FStar.Pure.BreakVC.break_vc (); - tot_or_ghost_typing_ln dt; - st_typing_ln db; - open_st_term_ln body x; - close_comp_ln c x; - Pulse.Elaborate.elab_ln_comp (close_comp c x) 0 + | T_Abs _g x _q ty _u body c db -> + admit () | T_ST .. | T_STGhost .. -> admit() @@ -1141,67 +1114,40 @@ let rec st_typing_ln (#g:_) (#t:_) (#c:_) st_typing_ln d1; lift_comp_ln l - | T_Return _ c use_eq u t e post x t_typing e_typing post_typing -> + | T_Return _ c use_eq u t e post x -> FStar.Pure.BreakVC.break_vc (); - tot_or_ghost_typing_ln t_typing; - tot_or_ghost_typing_ln e_typing; - tot_or_ghost_typing_ln post_typing; - open_term_ln' post (term_of_no_name_var x) 0; - open_term_ln_inv' post e 0; - if not use_eq - then () - else begin - // Add some lemmas about ln' of tm_pureapp etc. - assume (ln' (mk_eq2 u t (null_var x) e) (-1)); - let e = tm_star - (open_term' post (null_var x) 0) - (tm_pure (mk_eq2 u t (null_var x) e)) in - close_term_ln' e x 0 - end - - | T_Bind _ _ e2 _ _ _ x _ d1 dc1 d2 bc -> + admit () + + | T_Bind _ _ e2 _ _ _ x _ d1 d2 bc -> FStar.Pure.BreakVC.break_vc (); st_typing_ln d1; - tot_or_ghost_typing_ln dc1; st_typing_ln d2; open_st_term_ln e2 x; bind_comp_ln bc - | T_BindFn _g _e1 e2 _c1 _c2 _b x d1 _u dc1 d2 c -> + | T_BindFn _g _e1 e2 _c1 _c2 _b x d1 _u d2 c -> FStar.Pure.BreakVC.break_vc (); st_typing_ln d1; - tot_or_ghost_typing_ln dc1; st_typing_ln d2; open_st_term_ln e2 x; comp_typing_ln c - | T_If _ _ _ _ _ _ tb d1 d2 _ -> + | T_If _ _ _ _ _ _ d1 d2 _ -> FStar.Pure.BreakVC.break_vc (); - tot_or_ghost_typing_ln tb; - st_typing_ln d1; - st_typing_ln d2 + admit () - | T_Match _ _ _ sc _ scd c _ _ _ _ -> + | T_Match _ _ _ sc c _ _ _ _ -> FStar.Pure.BreakVC.break_vc (); - tot_or_ghost_typing_ln scd; admit () - | T_ElimExists _ u t p x dt dv -> + | T_ElimExists _ u t p x -> FStar.Pure.BreakVC.break_vc (); - tot_or_ghost_typing_ln dt; - tot_or_ghost_typing_ln dv; - let x_tm = tm_var {nm_index=x;nm_ppname=ppname_default} in - ln_mk_reveal u t x_tm (-1); - open_term_ln_inv' p (Pulse.Typing.mk_reveal u t x_tm) 0; - close_term_ln' (open_term' p (Pulse.Typing.mk_reveal u t x_tm) 0) x 0 + admit () - | T_IntroExists _ u t p e dt dv dw -> + | T_IntroExists _ u t p e -> FStar.Pure.BreakVC.break_vc (); - tot_or_ghost_typing_ln dt; - tot_or_ghost_typing_ln dv; - tot_or_ghost_typing_ln dw; - open_term_ln_inv' p e 0 + admit () | T_Equiv _ _ _ _ d2 deq -> FStar.Pure.BreakVC.break_vc (); @@ -1217,32 +1163,17 @@ let rec st_typing_ln (#g:_) (#t:_) (#c:_) // st_typing_ln body_typing; // open_term_ln_inv' post tm_false 0 - | T_Rewrite _ _ _ p_typing equiv_p_q -> - FStar.Pure.BreakVC.break_vc (); - tot_or_ghost_typing_ln p_typing; - slprop_equiv_ln equiv_p_q + | T_Rewrite _ _ _ equiv_p_q -> + admit () - | T_WithLocal g _ init body init_t c x init_typing init_t_typing c_typing body_typing -> - FStar.Pure.BreakVC.break_vc (); - tot_or_ghost_typing_ln init_typing; - st_typing_ln body_typing; - open_st_term_ln' body (null_var x) 0; - comp_typing_ln c_typing; - tot_or_ghost_typing_ln init_t_typing; - ln_mk_ref init_t (-1) + | T_WithLocal g _ init body init_t c x c_typing body_typing -> + admit () | T_WithLocalUninit .. -> admit() - | T_WithLocalArray g _ init len body init_t c x init_typing len_typing init_t_typing c_typing body_typing -> - FStar.Pure.BreakVC.break_vc (); - tot_or_ghost_typing_ln init_typing; - tot_or_ghost_typing_ln len_typing; - st_typing_ln body_typing; - open_st_term_ln' body (null_var x) 0; - comp_typing_ln c_typing; - tot_or_ghost_typing_ln init_t_typing; - ln_mk_array init_t (-1) + | T_WithLocalArray g _ init len body init_t c x c_typing body_typing -> + admit () | T_WithLocalArrayUninit .. -> admit() @@ -1250,13 +1181,7 @@ let rec st_typing_ln (#g:_) (#t:_) (#c:_) | T_Admit _ c c_typing | T_Unreachable _ c c_typing -> FStar.Pure.BreakVC.break_vc (); - comp_typing_ln c_typing; - let st_typing, _ = Pulse.Typing.Metatheory.Base.comp_typing_inversion c_typing in - let STC _ _ x t_typing pre_typing post_typing = st_typing in - tot_or_ghost_typing_ln t_typing; - tot_or_ghost_typing_ln pre_typing; - tot_or_ghost_typing_ln post_typing; - open_term_ln' (comp_post c) (term_of_no_name_var x) 0 + comp_typing_ln c_typing | T_Sub _ e c c' d d_sub -> FStar.Pure.BreakVC.break_vc (); diff --git a/src/checker/Pulse.Typing.Metatheory.Base.fst b/src/checker/Pulse.Typing.Metatheory.Base.fst index d5583428b..6cd966c7e 100644 --- a/src/checker/Pulse.Typing.Metatheory.Base.fst +++ b/src/checker/Pulse.Typing.Metatheory.Base.fst @@ -31,9 +31,9 @@ let admit_comp_typing (g:env) (c:comp_st) | C_ST st -> CT_ST g st (admit_st_comp_typing g st) | C_STAtomic inames obs st -> - CT_STAtomic g inames obs st (admit()) (admit_st_comp_typing g st) + CT_STAtomic g inames obs st (admit_st_comp_typing g st) | C_STGhost inames st -> - CT_STGhost g inames st (admit ()) (admit_st_comp_typing g st) + CT_STGhost g inames st (admit_st_comp_typing g st) let st_typing_correctness_ctot (#g:env) (#t:st_term) (#c:comp{C_Tot? c}) (_:st_typing g t c) @@ -52,28 +52,25 @@ let add_frame_well_typed (#g:env) (#c:comp_st) (ct:comp_typing_u g c) : Dv (comp_typing_u g (add_frame c f)) = admit_comp_typing _ _ -let emp_inames_typing (g:env) : tot_typing g tm_emp_inames tm_inames = RU.magic() +let emp_inames_typing (g:env) : tot_typing g tm_emp_inames tm_inames = () let comp_typing_inversion #g #c ct = match ct with - | CT_ST _ _ st -> st, emp_inames_typing g - | CT_STGhost _ _ _ it st - | CT_STAtomic _ _ _ _ it st -> st, it + | CT_ST _ _ st -> st, () + | CT_STGhost _ _ _ st + | CT_STAtomic _ _ _ _ st -> st, () let st_comp_typing_inversion_cofinite (#g:env) (#st:_) (ct:st_comp_typing g st) = admit(), admit(), (fun _ -> admit()) -let stc_ty (#g:env) (#st:_) (ct:st_comp_typing g st) : universe_of g st.res st.u = - let STC g st x ty pre post = ct in ty -let stc_pre (#g:env) (#st:_) (ct:st_comp_typing g st) : tot_typing g st.pre tm_slprop = - let STC g st x ty pre post = ct in pre +let stc_ty (#g:env) (#st:_) (ct:st_comp_typing g st) : universe_of g st.res st.u = () +let stc_pre (#g:env) (#st:_) (ct:st_comp_typing g st) : tot_typing g st.pre tm_slprop = () let stc_x (#g:env) (#st:_) (ct:st_comp_typing g st) : x:Ghost.erased var{fresh_wrt x g (freevars st.post)} = - let STC g st x ty pre post = ct in Ghost.hide x + let STC g st x = ct in Ghost.hide x let stc_post (#g:env) (#st:_) (ct:st_comp_typing g st) : tot_typing (push_binding g (stc_x ct) ppname_default st.res) (open_term st.post (stc_x ct)) tm_slprop = - let STC g st x ty pre post = ct in - post + () let st_comp_typing_inversion (#g:env) (#st:_) (ct:st_comp_typing g st) = (| stc_ty ct, stc_pre ct, stc_x ct, stc_post ct |) @@ -144,13 +141,13 @@ let st_equiv_weakening (g:env) (g':env { disjoint g g' }) (g1:env { pairwise_disjoint g g1 g' }) : st_equiv (push_env (push_env g g1) g') c1 c2 = match d with - | ST_SLPropEquiv _ c1 c2 x _ _ _ hequiv _ _ -> + | ST_SLPropEquiv _ c1 c2 x hequiv _ _ -> assume (~ (x `Set.mem` dom g')); assume (~ (x `Set.mem` dom g1)); - ST_SLPropEquiv _ c1 c2 x (RU.magic ()) (RU.magic ()) (RU.magic ()) + ST_SLPropEquiv _ c1 c2 x (equiv_weakening _ _ hequiv _) (RU.magic ()) (RU.magic ()) - | ST_TotEquiv _ t1 t2 u _ _ -> - ST_TotEquiv _ t1 t2 u (RU.magic ()) (RU.magic ()) + | ST_TotEquiv _ t1 t2 u _ -> + ST_TotEquiv _ t1 t2 u (RU.magic ()) // TODO: add precondition that g1 extends g' let prop_validity_token_weakening (#g:env) (#t:term) @@ -184,22 +181,22 @@ let st_comp_typing_weakening (g:env) (g':env { disjoint g g' }) (g1:env { pairwise_disjoint g g1 g' }) : st_comp_typing (push_env (push_env g g1) g') s = match d with - | STC _ st x _ _ _ -> + | STC _ st x -> assume (~ (x `Set.mem` dom g')); assume (~ (x `Set.mem` dom g1)); - STC _ st x (RU.magic ()) (RU.magic ()) (RU.magic ()) + STC _ st x let comp_typing_weakening (g:env) (g':env { disjoint g g' }) (#c:comp) (#u:universe) (d:comp_typing (push_env g g') c u) (g1:env { pairwise_disjoint g g1 g' }) : comp_typing (push_env (push_env g g1) g') c u = match d with - | CT_Tot _ t u _ -> CT_Tot _ t u (RU.magic ()) + | CT_Tot _ t u -> CT_Tot _ t u | CT_ST _ _ d -> CT_ST _ _ (st_comp_typing_weakening g g' d g1) - | CT_STAtomic _ inames obs _ _ d -> - CT_STAtomic _ inames obs _ (RU.magic ()) (st_comp_typing_weakening g g' d g1) - | CT_STGhost _ inames _ _ d -> - CT_STGhost _ inames _ (RU.magic ()) (st_comp_typing_weakening g g' d g1) + | CT_STAtomic _ inames obs _ d -> + CT_STAtomic _ inames obs _ (st_comp_typing_weakening g g' d g1) + | CT_STGhost _ inames _ d -> + CT_STGhost _ inames _ (st_comp_typing_weakening g g' d g1) #push-options "--split_queries no --z3rlimit_factor 8 --fuel 1 --ifuel 1" let st_typing_weakening g g' t c d g1 diff --git a/src/checker/Pulse.Typing.fst b/src/checker/Pulse.Typing.fst index 13db565da..7eb8e62b8 100644 --- a/src/checker/Pulse.Typing.fst +++ b/src/checker/Pulse.Typing.fst @@ -542,25 +542,17 @@ let comp_rewrite (p q:slprop) : comp = noeq type my_erased (a:Type) = | E of a -let typing (g:env) (e:term) (eff:T.tot_or_ghost) (t:term) = - my_erased (RT.typing (elab_env g) e (eff, t)) +let typing (g:env) (e:term) (eff:T.tot_or_ghost) (t:term) = unit -let tot_typing (g:env) (e:term) (t:term) = - typing g e T.E_Total t +let tot_typing (g:env) (e:term) (t:term) = unit -let ghost_typing (g:env) (e:term) (t:typ) = - typing g e T.E_Ghost t +let ghost_typing (g:env) (e:term) (t:typ) = unit let lift_typing_to_ghost_typing (#g:env) (#e:term) (#eff:T.tot_or_ghost) (#t:term) (d:typing g e eff t) - : ghost_typing g e t = - if eff = T.E_Ghost - then d - else let E d = d in - E (RT.T_Sub _ _ _ _ d (RT.Relc_total_ghost _ _)) + : ghost_typing g e t = () -let universe_of (g:env) (t:term) (u:universe) = - tot_typing g t (tm_type u) +let universe_of (g:env) (t:term) (u:universe) = unit let non_informative_t (g:env) (u:universe) (t:term) = w:term & tot_typing g w (non_informative_class u t) @@ -604,9 +596,6 @@ type st_equiv : env -> comp -> comp -> Type = x:var { freshv g x /\ ~(x `Set.mem` freevars (comp_post c1)) /\ ~(x `Set.mem` freevars (comp_post c2)) } -> - tot_typing g (comp_pre c1) tm_slprop -> - tot_typing g (comp_res c1) (tm_type (comp_u c1)) -> - tot_typing (push_binding g x ppname_default (comp_res c1)) (open_term (comp_post c1) x) tm_slprop -> RT.equiv (elab_env g) (comp_res c1) (comp_res c2) -> slprop_equiv g (comp_pre c1) (comp_pre c2) -> slprop_equiv (push_binding g x ppname_default (comp_res c1)) @@ -618,8 +607,7 @@ type st_equiv : env -> comp -> comp -> Type = g:env -> t1:term -> t2:term -> - u:_ -> - universe_of g t1 u -> + u:universe -> Ghost.erased (RT.equiv (elab_env g) t1 t2) -> st_equiv g (C_Tot t1) (C_Tot t2) @@ -709,24 +697,18 @@ type st_comp_typing : env -> st_comp -> Type = g:env -> st:st_comp -> x:var { freshv g x /\ ~(x `Set.mem` freevars st.post) } -> - universe_of g st.res st.u -> - tot_typing g st.pre tm_slprop -> - tot_typing (push_binding g x ppname_default st.res) (open_term st.post x) tm_slprop -> st_comp_typing g st [@@ erasable; no_auto_projectors] noeq type bind_comp : env -> var -> comp -> comp -> comp -> Type = - | Bind_comp : // (C_ST and C_ST) or (C_STGhost and C_STGhost) or (C_STAtomic and C_STAtomic) + | Bind_comp : g:env -> x:var { freshv g x } -> c1:comp_st -> c2:comp_st {bind_comp_pre x c1 c2} -> - universe_of g (comp_res c2) (comp_u c2) -> - //or in the result post; free var check isn't enough; we need typability y:var { freshv g y /\ ~(y `Set.mem` freevars (comp_post c2)) } -> - tot_typing (push_binding g y ppname_default (comp_res c2)) (open_term (comp_post c2) y) tm_slprop -> bind_comp g x c1 c2 (bind_comp_out c1 c2) let tr_binding (vt : var & typ) : Tot R.binding = @@ -746,7 +728,6 @@ type comp_typing : env -> comp -> universe -> Type = g:env -> t:term -> u:universe -> - universe_of g t u -> comp_typing g (C_Tot t) u | CT_ST : @@ -760,7 +741,6 @@ type comp_typing : env -> comp -> universe -> Type = inames:term -> obs:observability -> st:st_comp -> - tot_typing g inames tm_inames -> st_comp_typing g st -> comp_typing g (C_STAtomic inames obs st) (universe_of_comp (C_STAtomic inames obs st)) @@ -768,7 +748,6 @@ type comp_typing : env -> comp -> universe -> Type = g:env -> inames:term -> st:st_comp -> - tot_typing g inames tm_inames -> st_comp_typing g st -> comp_typing g (C_STGhost inames st) (universe_of_comp (C_STGhost inames st)) @@ -813,7 +792,6 @@ type st_typing : env -> st_term -> comp -> Type = u:universe -> body:st_term {~ (x `Set.mem` freevars_st body) } -> c:comp -> - tot_typing g b.binder_ty (tm_type u) -> st_typing (push_binding (clear_goto g) x ppname_default b.binder_ty) (open_st_term_nv body (b.binder_ppname, x)) c -> st_typing g (wtag None (Tm_Abs { b; q; body; ascription=empty_ascription})) (C_Tot (tm_arrow b q (close_comp c x))) @@ -842,9 +820,6 @@ type st_typing : env -> st_term -> comp -> Type = e:term -> post:term -> x:var { freshv g x /\ ~ (x `Set.mem` freevars post) } -> - universe_of g t u -> - typing g e (eff_of_ctag c) t -> - tot_typing (push_binding g x ppname_default t) (open_term post x) tm_slprop -> st_typing g (wtag (Some c) (Tm_Return { expected_type=tm_unknown; insert_eq=use_eq; term=e })) (comp_return c use_eq u t e post x) @@ -867,7 +842,6 @@ type st_typing : env -> st_term -> comp -> Type = x:var { freshv g x /\ ~(x `Set.mem` freevars_st e2) } -> c:comp -> st_typing g e1 c1 -> - tot_typing g (comp_res c1) (tm_type (comp_u c1)) -> //type-correctness; would be nice to derive it instead st_typing (push_binding g x ppname_default (comp_res c1)) (open_st_term_nv e2 (b.binder_ppname, x)) c2 -> bind_comp g x c1 c2 c -> st_typing g (wrst c (Tm_Bind { binder=b; head=e1; body=e2 })) c @@ -882,7 +856,6 @@ type st_typing : env -> st_term -> comp -> Type = x:var { freshv g x /\ ~(x `Set.mem` freevars_st e2) } -> st_typing g e1 c1 -> u:Ghost.erased universe -> - tot_typing g (comp_res c1) (tm_type u) -> //type-correctness; would be nice to derive it instead st_typing (push_binding g x ppname_default (comp_res c1)) (open_st_term_nv e2 (b.binder_ppname, x)) c2 -> comp_typing_u g c2 -> st_typing g (wrst c2 (Tm_Bind { binder=b; head=e1; body=e2 })) c2 @@ -893,15 +866,9 @@ type st_typing : env -> st_term -> comp -> Type = e1:st_term -> e2:st_term -> c:comp_st -> - (* This is a little weird, we introduce a name hyp in the environment, - but the branches are not allowed to use it (except perhaps in a silent way for proofs). - Maybe more natural to have one free var in e1,e2 and to open it with hyp? - But that's also a change to FStar.Reflection.Typing - *) hyp:var { freshv g hyp /\ ~(hyp `Set.mem` (freevars_st e1 `Set.union` freevars_st e2)) } -> - tot_typing g b tm_bool -> st_typing (g_with_eq g hyp b tm_true) e1 c -> st_typing (g_with_eq g hyp b tm_false) e2 c -> my_erased (comp_typing_u g c) -> @@ -912,8 +879,6 @@ type st_typing : env -> st_term -> comp -> Type = sc_u:universe -> sc_ty:typ -> sc:term -> - tot_typing g sc_ty (tm_type sc_u) -> - tot_typing g sc sc_ty -> c:comp_st -> my_erased (comp_typing_u g c) -> brs:list branch -> @@ -926,7 +891,6 @@ type st_typing : env -> st_term -> comp -> Type = e:st_term -> c:comp_st -> frame:term -> - tot_typing g frame tm_slprop -> st_typing g e c -> st_typing g e (add_frame c frame) @@ -951,7 +915,6 @@ type st_typing : env -> st_term -> comp -> Type = | T_IntroPure: g:env -> p:term -> - tot_typing g p tm_prop -> prop_validity g p -> st_typing g (wtag (Some STT_Ghost) (Tm_IntroPure { p })) (comp_intro_pure p) @@ -962,8 +925,6 @@ type st_typing : env -> st_term -> comp -> Type = t:term -> p:term -> x:var { freshv g x } -> - tot_typing g t (tm_type u) -> - tot_typing g (tm_exists_sl u (as_binder t) p) tm_slprop -> st_typing g (wtag (Some STT_Ghost) (Tm_ElimExists { p = tm_exists_sl u (as_binder t) p })) (comp_elim_exists u t p (v_as_nv x)) @@ -973,9 +934,6 @@ type st_typing : env -> st_term -> comp -> Type = b:binder -> p:term -> e:term -> - tot_typing g b.binder_ty (tm_type u) -> - tot_typing g (tm_exists_sl u b p) tm_slprop -> - ghost_typing g e b.binder_ty -> st_typing g (wtag (Some STT_Ghost) (Tm_IntroExists { p = tm_exists_sl u b p; witnesses= [e] })) (comp_intro_exists u b p e) @@ -986,12 +944,10 @@ type st_typing : env -> st_term -> comp -> Type = post_cond:term -> cond:st_term -> body:st_term -> - u_meas: universe -> ty_meas: term -> universe_of g ty_meas u_meas -> + u_meas: universe -> ty_meas: term -> is_tot: bool -> x:nvar { freshv g (snd x) /\ ~(snd x `Set.mem` freevars_st cond) /\ ~(snd x `Set.mem` freevars_st cond) } -> gx:env { gx == push_binding g (snd x) (fst x) ty_meas } -> - tot_typing gx inv tm_slprop -> - tot_typing gx (tm_exists_sl u0 (as_binder tm_bool) post_cond) tm_slprop -> st_typing gx cond (comp_while_cond inv post_cond) -> st_typing gx body (comp_while_body u_meas ty_meas is_tot x inv post_cond) -> st_typing g (wtag (Some STT) (Tm_While { invariant = inv; @@ -1009,8 +965,6 @@ type st_typing : env -> st_term -> comp -> Type = init_t:term -> c:comp { C_ST? c } -> x:var { freshv g x /\ ~(x `Set.mem` freevars_st body) } -> - tot_typing g init init_t -> - universe_of g init_t u0 -> comp_typing_u g c -> st_typing (push_post (push_binding g x ppname_default (mk_ref init_t)) (withlocal_post init_t (null_var x))) (open_st_term_nv body (v_as_nv x)) @@ -1024,7 +978,6 @@ type st_typing : env -> st_term -> comp -> Type = init_t:term -> c:comp { C_ST? c } -> x:var { freshv g x /\ ~(x `Set.mem` freevars_st body) } -> - universe_of g init_t u0 -> comp_typing_u g c -> st_typing (push_post (push_binding g x ppname_default (mk_ref init_t)) (withlocal_post init_t (null_var x))) (open_st_term_nv body (v_as_nv x)) @@ -1040,9 +993,6 @@ type st_typing : env -> st_term -> comp -> Type = a:term -> c:comp { C_ST? c } -> x:var { freshv g x /\ ~(x `Set.mem` freevars_st body) } -> - tot_typing g initializer a -> - tot_typing g length tm_szt -> - universe_of g a u0 -> comp_typing_u g c -> st_typing (push_post (push_binding g x ppname_default (mk_array a)) (withlocal_array_post a (null_var x) (Some initializer))) (open_st_term_nv body (v_as_nv x)) @@ -1057,8 +1007,6 @@ type st_typing : env -> st_term -> comp -> Type = a:term -> c:comp { C_ST? c } -> x:var { freshv g x /\ ~(x `Set.mem` freevars_st body) } -> - tot_typing g length tm_szt -> - universe_of g a u0 -> comp_typing_u g c -> st_typing (push_post (push_binding g x ppname_default (mk_array a)) (withlocal_array_post a (null_var x) None)) (open_st_term_nv body (v_as_nv x)) @@ -1069,14 +1017,7 @@ type st_typing : env -> st_term -> comp -> Type = g:env -> p:slprop -> q:slprop -> - tot_typing g p tm_slprop -> slprop_equiv g p q -> - (* Note: we always set the tactic to None. We already have a proof - of slprop_equiv so we don't need the tactic, and we can just elaborate - into a normal rewrite with the explicit proof that was constructed by the - tactic during Pulse checking time. - - The alternative is taking an optional tactic + typing, which is quite annoying. *) st_typing g (wtag (Some STT_Ghost) (Tm_Rewrite { t1=p; t2=q; tac_opt=None; elaborated=true } )) (comp_rewrite p q) @@ -1110,9 +1051,8 @@ type st_typing : env -> st_term -> comp -> Type = lbl:nvar -> arg:term -> lbl_c:comp_st { lookup_goto g (snd lbl) == Some (fst lbl, lbl_c) } -> - tot_typing g arg (comp_res lbl_c) -> - u:universe -> res:typ -> universe_of g res u -> - post:term -> post_x: var { freshv g post_x } -> tot_typing (push_binding_def g post_x res) (open_term post post_x) tm_slprop -> + u:universe -> res:typ -> + post:term -> post_x: var { freshv g post_x } -> st_typing g (wtag (Some (ctag_of_comp_st lbl_c)) (Tm_Goto { lbl = term_of_nvar lbl; arg })) (with_st_comp lbl_c { u; res; pre = open_term' (comp_pre lbl_c) arg 0; post }) @@ -1183,15 +1123,15 @@ and br_typing : env -> universe -> typ -> term -> pattern -> st_term -> comp_st *) let star_typing_inversion_l (#g:_) (#t0 #t1:term) (d:tot_typing g (tm_star t0 t1) tm_slprop) : tot_typing g t0 tm_slprop - = admit () + = () let star_typing_inversion_r (#g:_) (#t0 #t1:term) (d:tot_typing g (tm_star t0 t1) tm_slprop) : tot_typing g t1 tm_slprop - = admit () + = () let star_typing_inversion (#g:_) (#t0 #t1:term) (d:tot_typing g (tm_star t0 t1) tm_slprop) : GTot (tot_typing g t0 tm_slprop & tot_typing g t1 tm_slprop) - = admit () + = ((), ()) let slprop_eq_typing_inversion g (t0 t1:term) (token:RT.equiv (elab_env g) @@ -1199,30 +1139,23 @@ let slprop_eq_typing_inversion g (t0 t1:term) t1) : GTot (tot_typing g t0 tm_slprop & tot_typing g t1 tm_slprop) - = admit () + = ((), ()) -(* These I can easily prove *) let star_typing (#g:_) (#t0 #t1:term) (d0:tot_typing g t0 tm_slprop) (d1:tot_typing g t1 tm_slprop) : tot_typing g (tm_star t0 t1) tm_slprop - = admit () + = () let emp_typing (#g:_) : tot_typing g tm_emp tm_slprop - = admit () + = () let fresh_wrt (x:var) (g:env) (vars:_) = freshv g x /\ ~(x `Set.mem` vars) -let effect_annot_typing (g:env) (e:effect_annot) = - match e with - | EffectAnnotGhost { opens } - | EffectAnnotAtomic { opens } - | EffectAnnotAtomicOrGhost { opens } -> - tot_typing g opens tm_inames - | _ -> unit +let effect_annot_typing (g:env) (e:effect_annot) = unit noeq type post_hint_t = { @@ -1235,10 +1168,6 @@ type post_hint_t = { post:term; x:(x:FStar.Ghost.erased var { fresh_wrt x g (freevars post) }); post_typing_src:tot_typing (push_binding g x ppname_default ret_ty) (open_term post x) tm_slprop; - post_typing: - FStar.Ghost.erased (RT.tot_typing (elab_env g) - (RT.(mk_abs ret_ty T.Q_Explicit post)) - (RT.mk_arrow ret_ty T.Q_Explicit tm_slprop)) } let post_hint_for_env_p (g:env) (p:post_hint_t) = g `env_extends` p.g @@ -1271,19 +1200,10 @@ let post_hint_typing (g:env) (p:post_hint_for_env g) (x:var { fresh_wrt x g (freevars p.post) }) : post_hint_typing_t g p x - = let effect_annot_typing : effect_annot_typing g p.effect_annot = - match p.effect_annot with - | EffectAnnotAtomic { opens } - | EffectAnnotGhost { opens } - | EffectAnnotAtomicOrGhost { opens } -> - let opens_typing : tot_typing g opens tm_inames = RU.magic () in //weakening - opens_typing - | _ -> () - in - { - effect_annot_typing; - ty_typing = RU.magic (); //weakening - post_typing = RU.magic (); + = { + effect_annot_typing = (); + ty_typing = (); + post_typing = (); } From 5ef220d5c6cd89b99846c243d7711f4db22232b3 Mon Sep 17 00:00:00 2001 From: Gabriel Ebner Date: Fri, 27 Feb 2026 07:26:14 +0000 Subject: [PATCH 02/18] Fix all checker files for unit typing types All typing types (st_typing, comp_typing, st_comp_typing, bind_comp, st_equiv, st_sub, slprop_equiv, lift_comp, br_typing, brs_typing, pats_complete, non_informative) are now defined as unit. Replace all removed constructor calls with () including: - T_WithLocal, T_WithLocalUninit, T_WithLocalArray, T_WithLocalArrayUninit - T_Admit, T_Return, T_If, T_While, T_Abs, T_Match, T_Frame - T_IntroPure, T_IntroExists, T_ElimExists, T_Rewrite, T_Goto - T_ST, T_STGhost, T_Equiv, T_Sub, T_Lift, T_ForwardJumpLabel - T_Unreachable - STC, CT_ST, CT_STGhost, CT_STAtomic - VE_Refl, VE_Ext, VE_Trans, VE_Sym, VE_Comm, VE_Unit, VE_Ctxt - VE_Fa, VE_Assoc - PC_Elab, TBRS_0, TBRS_1, TBR - ST_TotEquiv, ST_SLPropEquiv - STS_Refl, STS_AtomicInvs, STS_GhostInvs - Lift_Observability, Lift_Neutral_Ghost Update comp_for_post_hint calls with explicit g and pre args. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/checker/Pulse.Checker.Abs.fst | 27 +++--- src/checker/Pulse.Checker.Admit.fst | 12 +-- src/checker/Pulse.Checker.Comp.fst | 8 +- src/checker/Pulse.Checker.Exists.fst | 4 +- src/checker/Pulse.Checker.Goto.fst | 2 +- src/checker/Pulse.Checker.If.fst | 2 +- src/checker/Pulse.Checker.IntroPure.fst | 2 +- src/checker/Pulse.Checker.Match.fst | 16 ++-- .../Pulse.Checker.Prover.Normalize.fst | 6 +- src/checker/Pulse.Checker.Prover.fst | 82 +++++++++---------- src/checker/Pulse.Checker.Return.fst | 2 +- src/checker/Pulse.Checker.Rewrite.fst | 15 ++-- src/checker/Pulse.Checker.SLPropEquiv.fst | 57 ++++++------- src/checker/Pulse.Checker.ST.fst | 10 +-- src/checker/Pulse.Checker.While.fst | 8 +- src/checker/Pulse.Checker.WithLocal.fst | 13 +-- src/checker/Pulse.Checker.WithLocalArray.fst | 13 +-- src/checker/Pulse.JoinComp.fst | 8 +- 18 files changed, 126 insertions(+), 161 deletions(-) diff --git a/src/checker/Pulse.Checker.Abs.fst b/src/checker/Pulse.Checker.Abs.fst index 281f62b9c..05d6392d9 100644 --- a/src/checker/Pulse.Checker.Abs.fst +++ b/src/checker/Pulse.Checker.Abs.fst @@ -326,11 +326,11 @@ let sub_effect_comp g r (asc:comp_ascription) (c_computed:comp) : T.Tac (option | C_ST _, C_ST _ -> nop | C_STGhost _ _, C_STGhost _ _ -> nop | C_STAtomic i Neutral c1, C_STGhost _ _ -> - let lift = Lift_Neutral_Ghost g c_computed in + let lift : lift_comp g c_computed (C_STGhost i c1) = () in Some (| C_STGhost i c1, lift |) | C_STAtomic i o1 c1, C_STAtomic j o2 c2 -> if sub_observability o1 o2 - then let lift = Lift_Observability g c_computed o2 in + then let lift : lift_comp g c_computed (C_STAtomic i o2 c1) = () in Some (| C_STAtomic i o2 c1, lift |) else nop @@ -338,7 +338,7 @@ let sub_effect_comp g r (asc:comp_ascription) (c_computed:comp) : T.Tac (option | _ -> nop let check_effect_annotation g r (asc:comp_ascription) (c_computed:comp) : T.Tac (c2:comp & st_sub g c_computed c2) = - let nop = (| c_computed, STS_Refl _ _ |) in + let nop = (| c_computed, () |) in match asc.elaborated with | None -> nop | Some c -> @@ -377,8 +377,8 @@ let check_effect_annotation g r (asc:comp_ascription) (c_computed:comp) : T.Tac let d_sub : st_sub g c_computed c = match c_computed with - | C_STAtomic _ obs _ -> STS_AtomicInvs g c2 j i obs obs tok - | C_STGhost _ _ -> STS_GhostInvs g c2 j i tok + | C_STAtomic _ obs _ -> () + | C_STGhost _ _ -> () in (| c, d_sub |) @@ -424,10 +424,9 @@ let maybe_rewrite_body_typing magic () in let tok' : st_equiv g (C_Tot t') (C_Tot t) = - ST_TotEquiv _ t' t u - (RT.Rel_sym _ _ _ (RT.Rel_eq_token _ _ _ sq)) + () in - (| C_Tot t, T_Equiv _ _ _ _ d tok' |) + (| C_Tot t, () |) ) (* c is not a C_Tot *) @@ -481,14 +480,14 @@ let rec check_abs_core match sub_effect_comp g' body.range asc c_body with | None -> (| c_body, body_typing |) | Some (| c_body, lift |) -> - let body_typing = T_Lift _ _ _ _ body_typing lift in + let body_typing : st_typing g' body c_body = () in (| c_body, body_typing |) in (* Check if it matches annotation (if any, likely not), and adjust derivation if needed. Currently this only subtypes the invariants. *) let (| c_body, d_sub |) = check_effect_annotation g' body.range asc c_body in - let body_typing = T_Sub _ _ _ _ body_typing d_sub in + let body_typing : st_typing g' body c_body = () in (* Similar to above, fixes the type of the computation if we need to match its annotation. TODO: merge these two by adding a tot subtyping (or equiv) case to the st_sub judg. *) @@ -506,7 +505,7 @@ let rec check_abs_core |> FStar.Sealed.seal in let b = {binder_ty=t;binder_ppname=ppname;binder_attrs} in - let tt = T_Abs g x qual b u body_closed c_body body_typing in + let tt : st_typing g _ (C_Tot (tm_arrow {binder_ty=t;binder_ppname=ppname;binder_attrs} qual (close_comp c_body x))) = () in let tres = tm_arrow {binder_ty=t;binder_ppname=ppname;binder_attrs} qual (close_comp c_body x) in (| _, C_Tot tres, tt |) | _ -> @@ -594,12 +593,12 @@ let rec check_abs_core match sub_effect_comp g' body.range c_opened c_body with | None -> (| c_body, body_typing |) | Some (| c_body, lift |) -> - let body_typing = T_Lift _ _ _ _ body_typing lift in + let body_typing : st_typing g' body c_body = () in (| c_body, body_typing |) in let (| c_body, d_sub |) = check_effect_annotation g' body.range c_opened c_body in - let body_typing = T_Sub _ _ _ _ body_typing d_sub in + let body_typing : st_typing g' body c_body = () in let (| c_body, body_typing |) = maybe_rewrite_body_typing body_typing asc in @@ -607,7 +606,7 @@ let rec check_abs_core let body_closed = close_st_term body x in assume (open_st_term body_closed x == body); let b = {binder_ty=t;binder_ppname=ppname;binder_attrs} in - let tt = T_Abs g x qual b u body_closed c_body body_typing in + let tt : st_typing g _ (C_Tot (tm_arrow {binder_ty=t;binder_ppname=ppname;binder_attrs} qual (close_comp c_body x))) = () in let tres = tm_arrow {binder_ty=t;binder_ppname=ppname;binder_attrs} qual (close_comp c_body x) in (| _, C_Tot tres, tt |) diff --git a/src/checker/Pulse.Checker.Admit.fst b/src/checker/Pulse.Checker.Admit.fst index a1d321a71..c62fefb51 100644 --- a/src/checker/Pulse.Checker.Admit.fst +++ b/src/checker/Pulse.Checker.Admit.fst @@ -66,16 +66,16 @@ let check let post = close_term post_opened x in let s : st_comp = {u;res=t;pre;post} in assume (open_term (close_term post_opened x) x == post_opened); - let d_s : st_comp_typing _ s = STC _ s x in + let d_s : st_comp_typing _ s = () in (match c with - | STT -> (| _, CT_ST _ _ d_s |) - | STT_Ghost -> (| _, CT_STGhost _ tm_emp_inames _ d_s |) - | STT_Atomic -> (| _, CT_STAtomic _ tm_emp_inames Neutral _ d_s |)) + | STT -> (| _, () |) + | STT_Ghost -> (| _, () |) + | STT_Atomic -> (| _, () |)) - | _, PostHint post -> Pulse.Typing.Combinators.comp_for_post_hint pre_typing post x + | _, PostHint post -> Pulse.Typing.Combinators.comp_for_post_hint g pre pre_typing post x in let (| c, d_c |) = res in - let d = T_Admit _ _ d_c in + let d : st_typing g _ c = () in FStar.Tactics.BreakVC.break_vc (); // ^ This makes a big difference! Would be good to distill into // a smaller F*-only example and file an issue. diff --git a/src/checker/Pulse.Checker.Comp.fst b/src/checker/Pulse.Checker.Comp.fst index e7d5ffed5..5b54d5aee 100644 --- a/src/checker/Pulse.Checker.Comp.fst +++ b/src/checker/Pulse.Checker.Comp.fst @@ -53,14 +53,14 @@ let check (g:env) (Printf.sprintf "check_comp: ill-typed postcondition %s" (P.term_to_string (comp_post c))) else ( assert (ty == tm_slprop); - STC g st x + () ) ) in match c with | C_ST st -> let stc = check_st_comp st in - CT_ST _ _ stc + () | C_STAtomic i obs st -> let stc = check_st_comp st in let (| ty, i_typing |) = core_compute_tot_term_type g i in @@ -68,7 +68,7 @@ let check (g:env) then fail g None (Printf.sprintf "check_comp (atomic): type of inames term %s is %s, expected %s" (P.term_to_string i) (P.term_to_string ty) (P.term_to_string tm_inames)) - else CT_STAtomic _ i obs _ stc + else () | C_STGhost i st -> let (| ty, i_typing |) = core_compute_tot_term_type g i in if not (eq_tm ty tm_inames) @@ -77,4 +77,4 @@ let check (g:env) (P.term_to_string i) (P.term_to_string ty) (P.term_to_string tm_inames)) else let stc = check_st_comp st in - CT_STGhost _ i _ stc + () diff --git a/src/checker/Pulse.Checker.Exists.fst b/src/checker/Pulse.Checker.Exists.fst index 78a01906a..6a6a0d9be 100644 --- a/src/checker/Pulse.Checker.Exists.fst +++ b/src/checker/Pulse.Checker.Exists.fst @@ -88,7 +88,7 @@ let check_elim_exists let (| u', ty_typing |) = universe_of_well_typed_term g ty in if eq_univ u u' then let x = fresh g in - let d = T_ElimExists g u ty p x in + let d : st_typing g _ _ = () in let (|_,d|) = match_comp_res_with_post_hint d post_hint in prove_post_hint (try_frame_pre false pre_typing (|_,_,d|) res_ppname) post_hint t_rng else fail g (Some t_rng) @@ -130,7 +130,7 @@ let check_intro_exists let ty_typing, _ = Metatheory.tm_exists_inversion #g #u #b.binder_ty #p t_typing x in let (| witness, witness_typing |) = check_term g witness T.E_Ghost b.binder_ty in - let d = T_IntroExists g u b p witness in + let d : st_typing g _ _ = () in let (| c, d |) : (c:_ & st_typing g _ c) = (| _, d |) in let (| c, d |) = match_comp_res_with_post_hint d post_hint in prove_post_hint (try_frame_pre false pre_typing (|_,_,d|) res_ppname) diff --git a/src/checker/Pulse.Checker.Goto.fst b/src/checker/Pulse.Checker.Goto.fst index 5d19c6634..2bf34332b 100644 --- a/src/checker/Pulse.Checker.Goto.fst +++ b/src/checker/Pulse.Checker.Goto.fst @@ -52,7 +52,7 @@ let check' let typing: st_typing g t c' = let x' = fresh g in assume fresh_wrt x' g (freevars ph.post); let pht = post_hint_typing g ph x' in - T_Goto _ (lbln, v) arg lbl_c ph.u ph.ret_ty ph.post x' in + () in let (| c'', typing'' |) = match_comp_res_with_post_hint typing post_hint in prove_post_hint #g (try_frame_pre false #g pre_typing (|_,c'',typing''|) res_ppname) diff --git a/src/checker/Pulse.Checker.If.fst b/src/checker/Pulse.Checker.If.fst index 67fcae6b2..280adc7bd 100644 --- a/src/checker/Pulse.Checker.If.fst +++ b/src/checker/Pulse.Checker.If.fst @@ -139,7 +139,7 @@ let check let c_typing = comp_typing_from_post_hint c pre_typing post_hint' in let d : st_typing_in_ctxt g pre (PostHint post_hint') = - (| _, c, T_If g b e1 e2 c hyp e1_typing e2_typing (E c_typing) |) in + (| _, c, () |) in let res : checker_result_t g pre (PostHint post_hint') = checker_result_for_st_typing d res_ppname in retype_checker_result_post_hint post_hint' post_hint res diff --git a/src/checker/Pulse.Checker.IntroPure.fst b/src/checker/Pulse.Checker.IntroPure.fst index e41951bda..56c526c13 100644 --- a/src/checker/Pulse.Checker.IntroPure.fst +++ b/src/checker/Pulse.Checker.IntroPure.fst @@ -58,6 +58,6 @@ let check let Tm_IntroPure { p } = t.term in let (| p, p_typing |) = check_prop g p in let pv = check_prop_validity g p p_typing in - let st_typing = T_IntroPure _ _ pv in + let st_typing : st_typing g _ _ = () in let (| c,d |) = match_comp_res_with_post_hint st_typing post_hint in prove_post_hint (try_frame_pre false pre_typing (|_,c,d|) res_ppname) post_hint t.range diff --git a/src/checker/Pulse.Checker.Match.fst b/src/checker/Pulse.Checker.Match.fst index bea128047..73e213d0b 100644 --- a/src/checker/Pulse.Checker.Match.fst +++ b/src/checker/Pulse.Checker.Match.fst @@ -376,7 +376,7 @@ let weaken_branch_observability else ( let d : br_typing_vis g sc_u sc_ty sc br.pat br.e c = let TBRV g sc_u sc_ty sc c p e bs p1 p2 p3 hyp st_typing = typing in - let st_typing = T_Lift _ _ _ _ st_typing (Lift_Observability _ c obs) in + let st_typing : st_typing _ _ _ = () in let d = TBRV g sc_u sc_ty sc _ p e bs p1 p2 p3 hyp st_typing in d in @@ -464,7 +464,7 @@ let weaken_branch_tag_to | STT_Atomic, C_STGhost _ _ -> ( let TBRV g sc_u sc_ty sc c p e bs pf1 pf2 pf3 h d = d in - let d = Pulse.Typing.Combinators.lift_ghost_atomic d in + let d : st_typing _ _ _ = () in let d = TBRV g sc_u sc_ty sc _ p e bs pf1 pf2 pf3 h d in (| pe, _, d |) ) @@ -501,7 +501,7 @@ let maybe_weaken_branch_tags let erase_br_typing #g #sc_u #sc_ty #sc #p #e #c (d: br_typing_vis g sc_u sc_ty sc p e c) : br_typing g sc_u sc_ty sc p e c = let TBRV g sc_u sc_ty sc c p e bs pf1 pf2 pf3 hyp d = d in - TBR g sc_u sc_ty sc c p e bs pf1 pf2 pf3 hyp d + () (* Hoisting this makes the proof much faster and more stable. *) let rec check_branches_aux2 @@ -513,10 +513,12 @@ let rec check_branches_aux2 (brs : list (br:branch & br_typing_vis g sc_u sc_ty sc br.pat br.e c0)) : brs_typing g sc_u sc_ty sc (List.Tot.map dfst brs) c0 = match brs with - | [] -> TBRS_0 c0 + | [] -> () | (| br, d|)::rest -> let { pat; e } = br in - TBRS_1 c0 pat e (erase_br_typing d) (List.Tot.map dfst rest) (check_branches_aux2 g sc_u sc_ty sc c0 rest) + let _ = erase_br_typing d in + let _ = check_branches_aux2 g sc_u sc_ty sc c0 rest in + () let check_branches (g:env) @@ -577,7 +579,7 @@ let check text "Could not verify that this match is exhaustive."; ] | Some (elab_pats', bnds), _ -> - (| elab_pats', bnds, PC_Elab _ _ _ _ _ (RT.MC_Tok _ _ _ _ bnds ()) |) + (| elab_pats', bnds, () |) in let new_pats = map_opt readback_pat elab_pats' in if None? new_pats then @@ -603,6 +605,6 @@ let check (* Provable *) assume (L.map (fun br -> elab_pat br.pat) brs == elab_pats'); let c_typing = comp_typing_from_post_hint c pre_typing post_hint in - let d = T_Match g sc_u sc_ty sc c (E c_typing) brs brs_d complete_d in + let d : st_typing g _ c = () in checker_result_for_st_typing (| _, _, d |) res_ppname #pop-options \ No newline at end of file diff --git a/src/checker/Pulse.Checker.Prover.Normalize.fst b/src/checker/Pulse.Checker.Prover.Normalize.fst index eed67b829..d686d372f 100644 --- a/src/checker/Pulse.Checker.Prover.Normalize.fst +++ b/src/checker/Pulse.Checker.Prover.Normalize.fst @@ -48,7 +48,7 @@ let __normalize_slprop let v' = PCP.norm_well_typed_term (elab_env g) steps v in let v' = Pulse.Simplify.simplify v' in (* NOTE: the simplify stage is unverified *) - let v_equiv_v' = VE_Ext _ _ _ (RU.magic ()) in + let v_equiv_v' : slprop_equiv g v v' = () in (| v', v_equiv_v' |) let normalize_slprop @@ -60,9 +60,9 @@ let normalize_slprop if use_rewrites_to then let rwr = Pulse.Checker.Prover.RewritesTo.get_subst_from_env g in let v' = PS.ss_term v rwr in - let eq_v_v' : slprop_equiv g v v' = VE_Ext _ _ _ (RU.magic ()) in + let eq_v_v' : slprop_equiv g v v' = () in let (| v'', eq_v'_v'' |) = __normalize_slprop g v' in - (| v'', VE_Trans _ _ _ _ eq_v_v' eq_v'_v'' |) + (| v'', () |) else __normalize_slprop g v diff --git a/src/checker/Pulse.Checker.Prover.fst b/src/checker/Pulse.Checker.Prover.fst index 71e0b086f..5b3daab85 100644 --- a/src/checker/Pulse.Checker.Prover.fst +++ b/src/checker/Pulse.Checker.Prover.fst @@ -80,7 +80,7 @@ let slprop_eqv (p q: slprop) : prop = forall g. squash (slprop_equiv g p q) let slprop_eqv_intro #p #q (h: (g:env -> slprop_equiv g p q)) : squash (slprop_eqv p q) = admit () -let slprop_eqv_refl (p: slprop) : squash (slprop_eqv p p) = slprop_eqv_intro fun g -> VE_Refl g p +let slprop_eqv_refl (p: slprop) : squash (slprop_eqv p p) = slprop_eqv_intro fun g -> () let slprop_eqv_trans (p q r: slprop) : Lemma (requires slprop_eqv p q /\ slprop_eqv q r) (ensures slprop_eqv p r) = admit () let slprop_eqv_star p1 q1 p2 q2 : Lemma (requires slprop_eqv p1 p2 /\ slprop_eqv q1 q2) (ensures slprop_eqv (tm_star p1 q1) (tm_star p2 q2)) = admit () let elab_slprops_append ps qs : squash (elab_slprops (ps@qs) `slprop_eqv` (elab_slprops ps `tm_star` elab_slprops qs)) = admit () @@ -206,14 +206,14 @@ let cont_elab g ps g' ps' = frame: list slprop_view -> continuation_elaborator g (elab_slprops (frame @ ps)) g' (elab_slprops (frame @ ps')) let cont_elab_refl g ps ps' (h: slprop_equiv g (elab_slprops ps) (elab_slprops ps')) : cont_elab g ps g ps' = - fun frame -> k_elab_equiv (k_elab_unit g (elab_slprops (frame @ ps))) (VE_Refl _ _) (RU.magic ()) + fun frame -> k_elab_equiv (k_elab_unit g (elab_slprops (frame @ ps))) (()) (RU.magic ()) let cont_elab_trans #g1 (#g2: env { g2 `env_extends` g1 }) (#g3: env { g3 `env_extends` g2 }) #ps1 #ps2 #ps2' #ps3 (k1: cont_elab g1 ps1 g2 ps2) (k2: cont_elab g2 ps2' g3 ps3) (h: slprop_equiv g2 (elab_slprops ps2) (elab_slprops ps2')) : cont_elab g1 ps1 g3 ps3 = - fun frame -> k_elab_trans (k1 frame) (k_elab_equiv (k2 frame) (RU.magic ()) (VE_Refl _ _)) + fun frame -> k_elab_trans (k1 frame) (k_elab_equiv (k2 frame) (RU.magic ()) (())) let cont_elab_equiv #g1 #ps1 #ps1' #g2 #ps2 #ps2' (k: cont_elab g1 ps1 g2 ps2) @@ -351,7 +351,7 @@ let intro_pure (g: env) (frame: slprop) (p: term) let frame_typ : tot_typing g frame tm_slprop = RU.magic () in // implied by t2_typing let h: tot_typing g (tm_star frame (comp_pre (comp_intro_pure p))) tm_slprop = RU.magic () in debug_prover g (fun _ -> Printf.sprintf "intro_pure p=%s\nframe=%s\n" (show p) (show frame)); - k_elab_equiv (continuation_elaborator_with_bind_nondep frame (T_IntroPure g p pv) h) (RU.magic ()) (RU.magic ()) + k_elab_equiv (continuation_elaborator_with_bind_nondep frame (() <: st_typing g _ (comp_intro_pure p)) h) (RU.magic ()) (RU.magic ()) post t let is_uvar (t:term) : bool = @@ -392,7 +392,7 @@ let prove_pure (g: env) (ctxt: list slprop_view) (skip_eq_uvar: bool) (goal: slp Some (| g, ctxt, [], [], fun g'' -> let p_typing: tot_typing g'' p tm_prop = RU.magic() in // implied by t2_typing let pv = check_prop_validity g'' p p_typing in - cont_elab_refl g ctxt ([] @ ctxt) (VE_Refl _ _), + cont_elab_refl g ctxt ([] @ ctxt) (()), (fun frame -> let h1: slprop_equiv g'' (elab_slprops frame) (elab_slprops (frame @ [] @ [])) = RU.magic () in let h2: slprop_equiv g'' (tm_star (elab_slprops frame) (tm_pure p)) (elab_slprops (frame @ [goal])) = RU.magic () in @@ -426,7 +426,7 @@ let prove_with_pure (g: env) (ctxt: list slprop_view) skip_eq_uvar (goal: slprop if pure_eq_unif g p skip_eq_uvar then None else Some (| g, ctxt, [Unknown v], [], fun g'' -> - cont_elab_refl g ctxt ([] @ ctxt) (VE_Refl _ _), + cont_elab_refl g ctxt ([] @ ctxt) (()), (fun frame -> let h1: slprop_equiv g'' (tm_star (elab_slprops frame) v) (elab_slprops (frame @ [Unknown v] @ [])) = RU.magic () in let h2: slprop_equiv g'' (tm_star (elab_slprops frame) (tm_with_pure p n v)) @@ -448,7 +448,7 @@ let intro_exists (g: env) (frame: slprop) (u: universe) (b: binder) (body: slpro let h2: slprop_equiv g (tm_star frame (comp_pre (comp_intro_exists u b body e))) (tm_star frame (open_term' body e 0)) = RU.magic () in let h3: slprop_equiv g (tm_star (comp_post (comp_intro_exists u b body e)) frame) (tm_star frame (tm_exists_sl u b body)) = RU.magic () in debug_prover g (fun _ -> Printf.sprintf "intro_exists %s\nframe=%s\n" (show (tm_exists_sl u b body)) (show frame)); - k_elab_equiv (continuation_elaborator_with_bind_nondep frame (T_IntroExists g u b body e) h1) h2 h3 + k_elab_equiv (continuation_elaborator_with_bind_nondep frame (() <: st_typing g _ (comp_intro_exists u b body e)) h1) h2 h3 post t let prove_exists (g: env) (ctxt: list slprop_view) (goal: slprop_view) : @@ -458,7 +458,7 @@ let prove_exists (g: env) (ctxt: list slprop_view) (goal: slprop_view) : // unnecessarily restrictive environment for uvar let e = RU.new_implicit_var "witness for exists*" (RU.range_of_term body) (elab_env g) b.binder_ty false in Some (| g, ctxt, [Unknown (open_term' body e 0)], [], fun g'' -> - cont_elab_refl g ctxt ([] @ ctxt) (VE_Refl _ _), + cont_elab_refl g ctxt ([] @ ctxt) (()), (fun frame -> let h1: slprop_equiv g'' (tm_star (elab_slprops frame) (open_term' body e 0)) (elab_slprops (frame @ [] @ [Unknown (open_term' body e 0)])) = RU.magic () in let h2: slprop_equiv g'' (tm_star (elab_slprops frame) (tm_exists_sl u b body)) (elab_slprops (frame @ [goal])) = RU.magic () in @@ -476,7 +476,7 @@ let unpack_and_norm_goal (g: env) (ctxt: list slprop_view) (goal: slprop_view) : | [Unknown _] -> None | _ -> Some (| g, ctxt, goal'', [], fun g' -> let h: slprop_equiv g' (elab_slprops ([] @ goal'')) (elab_slprops [Unknown goal]) = RU.magic () in - cont_elab_refl _ _ _ (VE_Refl _ _), cont_elab_refl _ _ _ h + cont_elab_refl _ _ _ (()), cont_elab_refl _ _ _ h <: T.Tac _ |)) | _ -> None @@ -551,7 +551,7 @@ let elim_is_unreachable' (g: env) (ctxt goals: list slprop_view) : let h1 : slprop_equiv g (elab_slprops ctxt) (elab_slprops ([IsUnreachable] @ [IsUnreachable])) = RU.magic () in let h2: slprop_equiv g'' (elab_slprops [IsUnreachable]) (elab_slprops ([IsUnreachable] @ goals)) = RU.magic () in cont_elab_refl _ _ _ h1, - cont_elab_equiv (unreachable_elim g'' goals) h2 (VE_Refl _ _) + cont_elab_equiv (unreachable_elim g'' goals) h2 (()) <: T.Tac _)|) let unpack_and_norm_ctxt (g: env) (ctxt: slprop_view) : @@ -564,7 +564,7 @@ let unpack_and_norm_ctxt (g: env) (ctxt: slprop_view) : | [Unknown _] -> None | _ -> Some (| g, ctxt'', [], [], fun g' -> let h: slprop_equiv g ctxt (elab_slprops ([] @ ctxt'')) = RU.magic () in - cont_elab_refl _ _ _ h, cont_elab_refl _ _ _ (VE_Refl _ _) + cont_elab_refl _ _ _ h, cont_elab_refl _ _ _ (()) <: T.Tac _ |)) | _ -> None @@ -579,7 +579,7 @@ let elim_pure (g: env) (frame: slprop) (p: term) (x: nvar { ~(Set.mem (snd x) (d let h2: slprop_equiv g' (tm_star (open_term_nv (comp_post c) x) frame) frame = RU.magic () in let k: continuation_elaborator g (tm_star frame (tm_pure p)) g' (tm_star tm_emp frame) = continuation_elaborator_with_bind frame typing h x in - k_elab_equiv k (VE_Refl _ _) h2 post t + k_elab_equiv k (()) h2 post t let elim_pure_step (g: env) (ctxt: slprop_view) : T.Tac (option (prover_result_nogoals g [ctxt])) = @@ -593,7 +593,7 @@ let elim_pure_step (g: env) (ctxt: slprop_view) : let h1: slprop_equiv g (tm_star (elab_slprops frame) (tm_pure p)) (elab_slprops (frame @ [ctxt])) = RU.magic () in let h2: slprop_equiv g' (elab_slprops frame) (elab_slprops (frame @ [] @ [])) = RU.magic () in k_elab_equiv (elim_pure g (elab_slprops frame) p x g') h1 h2), - cont_elab_refl _ _ _ (VE_Refl _ _) + cont_elab_refl _ _ _ (()) <: T.Tac _ |) | _ -> None @@ -610,7 +610,7 @@ let elim_with_pure (g: env) (frame: slprop) (p: term) (x: nvar { ~(Set.mem (snd let h2: slprop_equiv g' (tm_star (open_term_nv (comp_post c) x) frame) (tm_star frame v) = RU.magic () in let k: continuation_elaborator g (tm_star frame (tm_with_pure p (fst x) v)) g' (tm_star v frame) = continuation_elaborator_with_bind frame typing h x in - k_elab_equiv k (VE_Refl _ _) h2 post t + k_elab_equiv k (()) h2 post t let elim_with_pure_step (g: env) (ctxt: slprop_view) : T.Tac (option (prover_result_nogoals g [ctxt])) = @@ -624,7 +624,7 @@ let elim_with_pure_step (g: env) (ctxt: slprop_view) : let h1: slprop_equiv g (tm_star (elab_slprops frame) (tm_with_pure p (fst x) v)) (elab_slprops (frame @ [ctxt])) = RU.magic () in let h2: slprop_equiv g' (tm_star (elab_slprops frame) v) (elab_slprops (frame @ [Unknown v] @ [])) = RU.magic () in k_elab_equiv (elim_with_pure g (elab_slprops frame) p x v g') h1 h2), - cont_elab_refl _ _ _ (VE_Refl _ _) + cont_elab_refl _ _ _ (()) <: T.Tac _ |) | _ -> None @@ -636,14 +636,14 @@ let elim_exists (g: env) (frame: slprop) u b body (x: nvar { ~(Set.mem (snd x) ( let c = comp_elim_exists u b.binder_ty body x in let h1: tot_typing g b.binder_ty (tm_type u) = RU.magic () in let h2: tot_typing g (tm_exists_sl u (as_binder b.binder_ty) body) tm_slprop = RU.magic () in - let typing: st_typing g _ c = T_ElimExists g u b.binder_ty body (snd x) in + let typing: st_typing g _ c = () in let h: tot_typing g (tm_star frame (comp_pre c)) tm_slprop = RU.magic () in let c_post_x = open_term' body (mk_reveal u b.binder_ty (term_of_nvar x)) 0 in assume open_term (comp_post c) (snd x) == c_post_x; let h2: slprop_equiv g' (tm_star c_post_x frame) (tm_star frame c_post_x) = RU.magic () in let k: continuation_elaborator g (tm_star frame (tm_exists_sl u b body)) g' (tm_star c_post_x frame) = continuation_elaborator_with_bind frame typing h x in - k_elab_equiv k (VE_Refl _ _) h2 post t + k_elab_equiv k (()) h2 post t let elim_exists_step (g: env) (ctxt: slprop_view) : T.Tac (option (prover_result_nogoals g [ctxt])) = @@ -660,7 +660,7 @@ let elim_exists_step (g: env) (ctxt: slprop_view) : let h1: slprop_equiv g (tm_star (elab_slprops frame) (tm_exists_sl u b body)) (elab_slprops (frame @ [ctxt])) = RU.magic () in let h2: slprop_equiv g' (tm_star (elab_slprops frame) result) (elab_slprops (frame @ [] @ [Unknown result])) = RU.magic () in k_elab_equiv (elim_exists g (elab_slprops frame) u b body x g') h1 h2), - cont_elab_refl _ _ _ (VE_Refl _ _) + cont_elab_refl _ _ _ (()) <: T.Tac _ |) | _ -> None @@ -693,7 +693,7 @@ let check_slprop_equiv_ext r (g:env) (p q:slprop) pp q; ] | Some token -> - VE_Ext g p q (RT.Rel_eq_token _ _ _ ()) + () : slprop_equiv g p q let on_name = R.inspect_fv (R.pack_fv <| Pulse.Reflection.Util.mk_pulse_lib_core_lid "on") @@ -1025,15 +1025,15 @@ let try_apply_elim_lemma (g: env) (lid: R.name) (i: nat) (ctxt: slprop_view) : let typing = core_check_term g t T.E_Ghost ty in let t' = wtag (Some STT_Ghost) (Tm_ST { t; args=[] }) in let ni: non_informative g c = RU.magic () in - let typing: st_typing g t' c = T_STGhost g t c typing ni in + let typing: st_typing g t' c = () in let h1: tot_typing g (comp_pre c) tm_slprop = RU.magic () in let h2: slprop_equiv g (elab_slprops [Unknown (comp_pre c)]) (elab_slprops [ctxt]) = - assume elab_slprop ctxt == pre; VE_Refl _ _ in + assume elab_slprop ctxt == pre; () in let h3: slprop_equiv g (elab_slprops [Unknown (open_term' (comp_post c) unit_const 0)]) - (elab_slprops ([] @ [Unknown post'])) = VE_Refl _ _ in + (elab_slprops ([] @ [Unknown post'])) = () in let k_t = cont_elab_with_bind_nondep_unit typing h1 in cont_elab_equiv k_t h2 h3, - cont_elab_refl g'' ([] @ []) [] (VE_Refl _ _) |) + cont_elab_refl g'' ([] @ []) [] (()) |) ) else None | _ -> None) @@ -1069,12 +1069,12 @@ let try_apply_eager_intro_lemma (g: env) (lid: R.name) (i: nat) ctxt (goal: slpr let typing = core_check_term g'' t T.E_Ghost ty in let t' = wtag (Some STT_Ghost) (Tm_ST { t; args=[] }) in let ni: non_informative g'' c = RU.magic () in - let typing: st_typing g'' t' c = T_STGhost g'' t c typing ni in + let typing: st_typing g'' t' c = () in let h1: tot_typing g'' (comp_pre c) tm_slprop = RU.magic () in - let h2: slprop_equiv g'' (elab_slprops [Unknown (comp_pre c)]) (elab_slprops ([] @ [Unknown pre])) = VE_Refl _ _ in + let h2: slprop_equiv g'' (elab_slprops [Unknown (comp_pre c)]) (elab_slprops ([] @ [Unknown pre])) = () in let h3: slprop_equiv g'' (elab_slprops [Unknown (open_term' (comp_post c) unit_const 0)]) (elab_slprops [goal]) = RU.magic () in let k_typing = cont_elab_with_bind_nondep_unit typing h1 in - cont_elab_refl g ctxt ([] @ ctxt) (VE_Refl _ _), + cont_elab_refl g ctxt ([] @ ctxt) (()), cont_elab_equiv k_typing h2 h3 |) ) else @@ -1173,7 +1173,7 @@ let try_apply_intro_lemma (g: env) (lid: R.name) (i: nat) ctxt (goal: slprop_vie let typing = core_check_term g' t T.E_Ghost ty in let t' = wtag (Some STT_Ghost) (Tm_ST { t; args=[] }) in let ni: non_informative g' c = RU.magic () in - let typing: st_typing g' t' c = T_STGhost g' t c typing ni in + let typing: st_typing g' t' c = () in let h1: tot_typing g' (comp_pre c) tm_slprop = RU.magic () in let h2: slprop_equiv g' (elab_slprops (ctxt' @ [Unknown (comp_pre c)])) (elab_slprops (ctxt' @ [Unknown pre])) = RU.magic () in @@ -1184,8 +1184,8 @@ let try_apply_intro_lemma (g: env) (lid: R.name) (i: nat) ctxt (goal: slprop_vie let k_typing = cont_elab_frame k_typing ctxt' in let k_typing: cont_elab g' (ctxt' @ [Unknown pre]) g' ([goal] @ ctxt' @ post''_rest) = cont_elab_equiv k_typing h2 h3 in - cont_elab_trans k k_typing (VE_Refl _ _), - cont_elab_refl g'' ([goal] @ []) [goal] (VE_Refl _ _) + cont_elab_trans k k_typing (()), + cont_elab_refl g'' ([goal] @ []) [goal] (()) <: cont_elab g ctxt g' ([goal] @ ctxt' @ post''_rest) & cont_elab g'' ([goal] @ []) g'' [goal] |) <: T.Tac (prover_result g ctxt [goal]) @@ -1316,8 +1316,8 @@ let rec try_prove_core (pg: penv) (ctxt goals: list slprop_view) : T.Tac (prover prover_result_join step step2 | None -> (| g, ctxt, goals, [], fun g'' -> - cont_elab_refl g _ _ (VE_Refl _ _), - cont_elab_refl g'' ([] @ goals) goals (VE_Refl _ _) + cont_elab_refl g _ _ (()), + cont_elab_refl g'' ([] @ goals) goals (()) <: T.Tac _ |) let try_prove (g: env) (ctxt goals: slprop) allow_amb : T.Tac (prover_result g [Unknown ctxt] [Unknown goals]) = @@ -1332,8 +1332,8 @@ let try_prove (g: env) (ctxt goals: slprop) allow_amb : T.Tac (prover_result g [ let before, after = k1 g2 in let h1: slprop_equiv g ctxt' ctxt = RU.magic () in let h2: slprop_equiv g2 goals' goals = RU.magic () in - cont_elab_equiv before h1 (VE_Refl _ _), - cont_elab_equiv after (VE_Refl _ _) h2 |) + cont_elab_equiv before h1 (()), + cont_elab_equiv after (()) h2 |) let prove rng (g: env) (ctxt goals: slprop) allow_amb : T.Tac (g':env { env_extends g' g } & @@ -1356,7 +1356,7 @@ let prove rng (g: env) (ctxt goals: slprop) allow_amb : let h: slprop_equiv g' (elab_slprops ([] @ ctxt' @ [Unknown goals])) (tm_star goals (RU.deep_compress_safe (elab_slprops ctxt'))) = RU.magic () in - (| g', RU.deep_compress_safe (elab_slprops ctxt'), k_elab_equiv (k []) (VE_Refl _ _) h |) + (| g', RU.deep_compress_safe (elab_slprops ctxt'), k_elab_equiv (k []) (()) h |) let rec try_elim_core (pg: penv) (ctxt: list slprop_view) : T.Tac (prover_result_nogoals pg.penv_env ctxt) = @@ -1364,8 +1364,8 @@ let rec try_elim_core (pg: penv) (ctxt: list slprop_view) : let g = pg.penv_env in let noop () : prover_result g ctxt [] = (| g, ctxt, [], [], fun g'' -> - cont_elab_refl g _ _ (VE_Refl _ _), - cont_elab_refl g'' [] [] (VE_Refl _ _) + cont_elab_refl g _ _ (()), + cont_elab_refl g'' [] [] (()) <: T.Tac _ |) in debug_prover g (fun _ -> Printf.sprintf "eliminating\n%s\n" (show_slprops ctxt)); let step : option (prover_result_nogoals g ctxt) = @@ -1394,14 +1394,14 @@ let elim_exists_and_pure (#g:env) (#ctxt:slprop) let h2: slprop_equiv g' (elab_slprops (ctxt'' @ solved @ goals'')) (elab_slprops ([] @ solved @ ctxt'')) = RU.magic () in let h3: slprop_equiv g' (elab_slprops (ctxt'' @ [])) (elab_slprops ctxt'') = RU.magic () in let before, after = k g' in - k_elab_trans (k_elab_equiv (before []) h1 (VE_Refl _ _)) + k_elab_trans (k_elab_equiv (before []) h1 (())) (k_elab_equiv (after ctxt'') h2 h3) post_hint post_hint_typ |) let k_unreach (g: env) (x: nvar { freshv g (snd x) }) (post_hint: post_hint_t { g `env_extends` post_hint.g }) : T.Tac (continuation_elaborator g tm_is_unreachable (push_binding g (snd x) (fst x) post_hint.ret_ty) (open_term_nv post_hint.post x)) = let h: tot_typing g tm_is_unreachable tm_slprop = RU.magic () in - let (| c, c_typ |) = Pulse.Typing.Combinators.comp_for_post_hint h post_hint (snd x) in - let typ = T_Unreachable g c c_typ in + let (| c, c_typ |) = Pulse.Typing.Combinators.comp_for_post_hint g tm_is_unreachable h post_hint (snd x) in + let typ : st_typing g _ c = () in let g' = push_binding g (snd x) (fst x) post_hint.ret_ty in let post_opened = open_term_nv post_hint.post x in let k_elim: continuation_elaborator g (tm_star tm_emp tm_is_unreachable) g' (tm_star post_opened tm_emp) = @@ -1474,7 +1474,7 @@ let prove_post_hint (#g:env) (#ctxt:slprop) (r:checker_result_t g ctxt NoHint) ( // for the typing of post_hint_opened, again post_hint is well-typed in g, and g3 `env_extends` g let h2: tot_typing g3 post_hint_opened tm_slprop = RU.magic () in (| x, g3, (| u_ty, ty, h1 |), (| post_hint_opened, h2 |), - k_elab_trans k (k_elab_equiv k_post (VE_Refl _ _) h3) |) + k_elab_trans k (k_elab_equiv k_post (()) h3) |) #pop-options let try_frame_pre (allow_ambiguous : bool) (#g:env) @@ -1486,4 +1486,4 @@ let try_frame_pre (allow_ambiguous : bool) (#g:env) let (| g', ctxt', k |) = prove t.range g ctxt (comp_pre c) allow_ambiguous in let d: st_typing g' t c = RU.magic () in // weakening from g to g' let h1: tot_typing g' ctxt' tm_slprop = RU.magic() in // weakening from to g' - checker_result_for_st_typing (k _ (| t, add_frame c ctxt', T_Frame _ _ _ ctxt' d |)) res_ppname \ No newline at end of file + checker_result_for_st_typing (k _ (| t, add_frame c ctxt', () |)) res_ppname \ No newline at end of file diff --git a/src/checker/Pulse.Checker.Return.fst b/src/checker/Pulse.Checker.Return.fst index a4d9bb6fe..998493bfe 100644 --- a/src/checker/Pulse.Checker.Return.fst +++ b/src/checker/Pulse.Checker.Return.fst @@ -135,7 +135,7 @@ let check_core let use_eq = use_eq || (not (PostHint? post_hint) && not (T.term_eq ty (`unit))) in assume (open_term (close_term post_opened x) x == post_opened); let post = close_term post_opened x in - let d = T_Return g c use_eq u ty t post x in + let d : st_typing g _ _ = () in let (|c',d'|) = match_comp_res_with_post_hint d post_hint in Pulse.Checker.Util.debug g "pulse.return" (fun _ -> Printf.sprintf "Return comp is: %s" diff --git a/src/checker/Pulse.Checker.Rewrite.fst b/src/checker/Pulse.Checker.Rewrite.fst index ed1d45cd2..0a569780f 100644 --- a/src/checker/Pulse.Checker.Rewrite.fst +++ b/src/checker/Pulse.Checker.Rewrite.fst @@ -39,7 +39,7 @@ let check_slprop_equiv_ext r (g:env) (p q:slprop) pp q; ] | Some token -> - VE_Ext g p q (RT.Rel_eq_token _ _ _ ()) + () : slprop_equiv g p q let check_slprop_equiv_tac r (g:env) (p q:slprop) (tac_tm : term) : T.Tac (slprop_equiv g p q) @@ -75,15 +75,12 @@ let check_slprop_equiv_tac r (g:env) (p q:slprop) (tac_tm : term) text "Using tactic:" ^/^ pp tac_tm ] | Some token -> - // Need a VE_ rule to turn an arbitrary proof into a slprop_equiv. - // Or use enough core lemmas to show that slprop_equiv implies equality here, - // and then use VE_Ext. - VE_Ext g p q (RU.magic ()) + () : slprop_equiv g p q let rec check_slprop_equiv r (g:env) (p q:slprop) : T.Tac (slprop_equiv g p q) = if eq_tm p q - then VE_Refl g p + then () else ( match inspect_term p, inspect_term q with | Tm_ForallSL u1 b1 t1, Tm_ForallSL u2 b2 t2 -> @@ -96,13 +93,13 @@ let rec check_slprop_equiv r (g:env) (p q:slprop) let g' = push_binding g x b1.binder_ppname b1.binder_ty in let nx = b1.binder_ppname, x in let ext = check_slprop_equiv r g' (open_term_nv t1 nx) (open_term_nv t2 nx) in - VE_Fa g x u1 b1 t1 t2 ext + () ) else check_slprop_equiv_ext r g p q | Tm_Star p1 p2, Tm_Star q1 q2 -> let ext1 = check_slprop_equiv r g p1 q1 in let ext2 = check_slprop_equiv r g p2 q2 in - VE_Ctxt g p1 p2 q1 q2 ext1 ext2 + () | _ -> check_slprop_equiv_ext r g p q ) @@ -140,6 +137,6 @@ let check (T.moduleof (fstar_env g)) "Pulse.Checker.Rewrite.check_slprop_equiv_tac" in - let d = T_Rewrite _ p q equiv_p_q in + let d : st_typing g _ _ = () in let (| c,d |) = match_comp_res_with_post_hint d post_hint in prove_post_hint (try_frame_pre false pre_typing (| _,c,d |) res_ppname) post_hint t.range diff --git a/src/checker/Pulse.Checker.SLPropEquiv.fst b/src/checker/Pulse.Checker.SLPropEquiv.fst index 905ab61d5..13574a9a1 100644 --- a/src/checker/Pulse.Checker.SLPropEquiv.fst +++ b/src/checker/Pulse.Checker.SLPropEquiv.fst @@ -20,7 +20,7 @@ open Pulse.Typing open FStar.List.Tot let ve_unit_r g (p:term) : slprop_equiv g (tm_star p tm_emp) p = - VE_Trans _ _ _ _ (VE_Comm _ _ _) (VE_Unit _ _) + () let rec list_as_slprop_append g (vp0 vp1:list term) : GTot (slprop_equiv g (list_as_slprop (vp0 @ vp1)) @@ -30,27 +30,24 @@ let rec list_as_slprop_append g (vp0 vp1:list term) = match vp0 with | [] -> let v : slprop_equiv g (list_as_slprop vp1) - (tm_star tm_emp (list_as_slprop vp1)) = VE_Sym _ _ _ (VE_Unit _ _) + (tm_star tm_emp (list_as_slprop vp1)) = () in v | [hd] -> (* Need to check vp1 too in this case *) begin match vp1 with - | [] -> - VE_Sym _ _ _ - (VE_Trans _ _ _ _ (VE_Comm g hd tm_emp) (VE_Unit _ hd)) - | _::_ -> - VE_Refl _ _ + | [] -> () + | _::_ -> () end | hd::tl -> let tl_vp1 = list_as_slprop_append g tl vp1 in let d : slprop_equiv g (list_as_slprop (vp0 @ vp1)) (tm_star hd (tm_star (list_as_slprop tl) (list_as_slprop vp1))) - = VE_Ctxt _ _ _ _ _ (VE_Refl _ hd) tl_vp1 + = () in let d : slprop_equiv g (list_as_slprop (vp0 @ vp1)) (tm_star (tm_star hd (list_as_slprop tl)) (list_as_slprop vp1)) - = VE_Trans _ _ _ _ d (VE_Assoc _ _ _ _) in + = () in d @@ -58,15 +55,14 @@ let list_as_slprop_comm g (vp0 vp1:list term) : GTot (slprop_equiv g (list_as_slprop (vp0 @ vp1)) (list_as_slprop (vp1 @ vp0))) = let d1 : _ = list_as_slprop_append g vp0 vp1 in - let d2 : _ = VE_Sym _ _ _ (list_as_slprop_append g vp1 vp0) in - let d1 : _ = VE_Trans _ _ _ _ d1 (VE_Comm _ _ _) in - VE_Trans _ _ _ _ d1 d2 + let d2 : _ = list_as_slprop_append g vp1 vp0 in + () let list_as_slprop_assoc g (vp0 vp1 vp2:list term) : GTot (slprop_equiv g (list_as_slprop (vp0 @ (vp1 @ vp2))) (list_as_slprop ((vp0 @ vp1) @ vp2))) = List.Tot.append_assoc vp0 vp1 vp2; - VE_Refl _ _ + () let list_as_slprop_ctx g (vp0 vp0' vp1 vp1':list term) (d0:slprop_equiv g (list_as_slprop vp0) (list_as_slprop vp0')) @@ -75,8 +71,7 @@ let list_as_slprop_ctx g (vp0 vp0' vp1 vp1':list term) = let split_app = list_as_slprop_append _ vp0 vp1 in let split_app' = list_as_slprop_append _ vp0' vp1' in - let ctxt = VE_Ctxt _ _ _ _ _ d0 d1 in - VE_Trans _ _ _ _ split_app (VE_Trans _ _ _ _ ctxt (VE_Sym _ _ _ split_app')) + () let list_as_slprop_singleton g (p q:term) @@ -89,7 +84,7 @@ let rec slprop_list_equiv (g:env) : GTot (slprop_equiv g vp (canon_slprop vp)) (decreases vp) = match inspect_term vp with - | Tm_Emp -> VE_Refl _ _ + | Tm_Emp -> () | Tm_Star vp0 vp1 -> let eq0 = slprop_list_equiv g vp0 in let eq1 = slprop_list_equiv g vp1 in @@ -97,13 +92,9 @@ let rec slprop_list_equiv (g:env) : slprop_equiv _ (canon_slprop vp) (tm_star (canon_slprop vp0) (canon_slprop vp1)) = list_as_slprop_append g (slprop_as_list vp0) (slprop_as_list vp1) in - let step - : slprop_equiv _ vp (tm_star (canon_slprop vp0) (canon_slprop vp1)) - = VE_Ctxt _ _ _ _ _ eq0 eq1 - in - VE_Trans _ _ _ _ step (VE_Sym _ _ _ app_eq) + () - | _ -> VE_Refl _ _ + | _ -> () let slprop_equiv_swap_equiv (g:_) (l0 l2:list term) @@ -112,22 +103,20 @@ let slprop_equiv_swap_equiv (g:_) (list_as_slprop ([p] @ (l0 @ l2))) = let d : slprop_equiv g (list_as_slprop ((l0 @ [q]) @ l2)) (list_as_slprop (([q] @ l0) @ l2)) - = list_as_slprop_ctx g (l0 @ [q]) ([q] @ l0) l2 l2 - (list_as_slprop_comm g l0 [q]) - (VE_Refl _ _) in + = () in let d' : slprop_equiv g (list_as_slprop (([q] @ l0) @ l2)) (list_as_slprop ([q] @ (l0 @ l2))) = List.Tot.append_assoc [q] l0 l2; - VE_Refl _ _ in + () in let d : slprop_equiv g (list_as_slprop ((l0 @ [q]) @ l2)) (list_as_slprop ([q] @ (l0 @ l2))) - = VE_Trans _ _ _ _ d d' in - let d_q_p = VE_Sym _ _ _ d_p_q in + = () in + let d_q_p = d_p_q in let d' : slprop_equiv g (list_as_slprop [q]) (list_as_slprop [p]) = d_q_p in let d' : slprop_equiv g (list_as_slprop ([q] @ (l0 @ l2))) (list_as_slprop ([p] @ (l0 @ l2))) - = list_as_slprop_ctx g [q] [p] (l0 @ l2) _ d' (VE_Refl _ _) in - VE_Trans _ _ _ _ d d' + = () in + () let slprop_equiv_split_frame (g:_) (ctxt req:term) (frame:list term) @@ -141,19 +130,19 @@ let slprop_equiv_split_frame (g:_) (ctxt req:term) (frame:list term) let d1 : slprop_equiv _ (tm_star (canon_slprop req) (list_as_slprop frame)) (list_as_slprop (req_l @ frame)) - = VE_Sym _ _ _ (list_as_slprop_append g req_l frame) + = () in let d1 : slprop_equiv _ (tm_star req (list_as_slprop frame)) (list_as_slprop (req_l @ frame)) - = VE_Trans _ _ _ _ (VE_Ctxt _ _ _ _ _ (slprop_list_equiv g req) (VE_Refl _ _)) d1 + = () in let d : slprop_equiv _ (tm_star req (list_as_slprop frame)) (canon_slprop ctxt) = - VE_Trans _ _ _ _ d1 veq + () in let d : slprop_equiv _ (tm_star req (list_as_slprop frame)) ctxt = - VE_Trans _ _ _ _ d (VE_Sym _ _ _ (slprop_list_equiv g ctxt)) + () in d diff --git a/src/checker/Pulse.Checker.ST.fst b/src/checker/Pulse.Checker.ST.fst index 522e5c584..fccdee497 100644 --- a/src/checker/Pulse.Checker.ST.fst +++ b/src/checker/Pulse.Checker.ST.fst @@ -82,7 +82,7 @@ let check let t = { t with term = Tm_ST { t=e; args=[] }; effect_tag = T.seal (Some (ctag_of_comp_st c)) } in let d : st_typing g' t c = if eff = T.E_Total - then T_ST g' e c typing + then () else ( match c with | C_ST _ | C_STAtomic .. -> @@ -100,19 +100,19 @@ let check fail g' (Some range) (Printf.sprintf "Unexpected informative result for %s" (P.comp_to_string c)) | Some token -> - E <| RT.Non_informative_token _ _ (FStar.Squash.return_squash token) + () in - T_STGhost g' e c typing d_non_info + () ) in let h: tot_typing g' ctxt' tm_slprop = RU.magic () in // TODO: thread through prover if comp_post c `eq_tm` tm_is_unreachable then - let framed = checker_result_for_st_typing (k _ (| t, add_frame c ctxt', T_Frame _ _ _ ctxt' d |)) res_ppname in + let framed = checker_result_for_st_typing (k _ (| t, add_frame c ctxt', () |)) res_ppname in RU.record_stats "prove_post_hint" fun _ -> prove_post_hint framed post_hint range else // TODO: not sure why we need the type equality check below.. let (| c, d |) = match_comp_res_with_post_hint d post_hint in - let framed = checker_result_for_st_typing (k _ (| t, add_frame c ctxt', T_Frame _ _ _ ctxt' d |)) res_ppname in + let framed = checker_result_for_st_typing (k _ (| t, add_frame c ctxt', () |)) res_ppname in RU.record_stats "prove_post_hint" fun _ -> prove_post_hint framed post_hint range ) #pop-options \ No newline at end of file diff --git a/src/checker/Pulse.Checker.While.fst b/src/checker/Pulse.Checker.While.fst index 36966c286..4f5f36b88 100644 --- a/src/checker/Pulse.Checker.While.fst +++ b/src/checker/Pulse.Checker.While.fst @@ -270,11 +270,7 @@ let check_while assume ~(snd x_meas `Set.mem` freevars_st cond); assume ~(snd x_meas `Set.mem` freevars_st body); let d: st_typing g1' while (comp_while u_meas ty_meas x_meas inv body_pre_open) = - T_While g1' inv body_pre_open cond body - u_meas ty_meas is_tot - x_meas g2 - cond_typing body_typing - in + () in let C_ST cst = comp_while u_meas ty_meas x_meas inv body_pre_open in let loop_pre = tm_exists_sl u_meas (as_binder ty_meas) (close_term inv (snd x_meas)) in assert comp_pre (comp_while u_meas ty_meas x_meas inv body_pre_open) == loop_pre; @@ -309,7 +305,7 @@ let check_while admit (); assert break_lbl_c == goto_comp_of_block_comp while_comp; let fjl_d: st_typing g0 fjl while_comp = - T_ForwardJumpLabel g0 (breaklbln, breaklblx) (close_st_term while breaklblx) while_comp while_d in + () in let d_st: Pulse.Typing.Combinators.st_typing_in_ctxt g0 loop_pre (TypeHint tm_unit) = (| _, _, fjl_d |) in let d_st: Pulse.Typing.Combinators.st_typing_in_ctxt g0 loop_pre0 (TypeHint tm_unit) = diff --git a/src/checker/Pulse.Checker.WithLocal.fst b/src/checker/Pulse.Checker.WithLocal.fst index 8a252e7f7..b97e2896e 100644 --- a/src/checker/Pulse.Checker.WithLocal.fst +++ b/src/checker/Pulse.Checker.WithLocal.fst @@ -159,15 +159,6 @@ let check in assert (freshv g x); assert (~(Set.mem x (freevars_st body))); - match init with - | None -> - let d = T_WithLocalUninit g binder.binder_ppname body init_t c x - c_typing - body_typing in - checker_result_for_st_typing (| _, _, d |) res_ppname - | Some init -> - let d = T_WithLocal g binder.binder_ppname init body init_t c x - c_typing - body_typing in - checker_result_for_st_typing (| _, _, d |) res_ppname + let d : st_typing g _ c = () in + checker_result_for_st_typing (| _, _, d |) res_ppname #pop-options diff --git a/src/checker/Pulse.Checker.WithLocalArray.fst b/src/checker/Pulse.Checker.WithLocalArray.fst index 7a24e5a65..198b20959 100644 --- a/src/checker/Pulse.Checker.WithLocalArray.fst +++ b/src/checker/Pulse.Checker.WithLocalArray.fst @@ -181,15 +181,6 @@ let check post_typing_rec.ty_typing x post_typing_rec.post_typing in - match init with - | Some init -> - let d = T_WithLocalArray g binder.binder_ppname init len body init_t c x - c_typing - body_typing in - checker_result_for_st_typing (| _, _, d |) res_ppname - | None -> - let d = T_WithLocalArrayUninit g binder.binder_ppname len body init_t c x - c_typing - body_typing in - checker_result_for_st_typing (| _, _, d |) res_ppname + let d : st_typing g _ c = () in + checker_result_for_st_typing (| _, _, d |) res_ppname #pop-options diff --git a/src/checker/Pulse.JoinComp.fst b/src/checker/Pulse.JoinComp.fst index 4b4622973..c787a7499 100644 --- a/src/checker/Pulse.JoinComp.fst +++ b/src/checker/Pulse.JoinComp.fst @@ -414,8 +414,8 @@ let rec join_comps match c_then, c_else with | C_STAtomic _ obs1 _, C_STAtomic _ obs2 _ -> let obs = join_obs obs1 obs2 in - let e_then_typing = T_Lift _ _ _ _ e_then_typing (Lift_Observability g_then c_then obs) in - let e_else_typing = T_Lift _ _ _ _ e_else_typing (Lift_Observability g_else c_else obs) in + let e_then_typing : st_typing g_then e_then _ = () in + let e_else_typing : st_typing g_else e_else _ = () in (| _, e_then_typing, e_else_typing |) | C_STGhost _ _, C_STGhost _ _ | C_ST _, C_ST _ -> (| _, e_then_typing, e_else_typing |) @@ -425,12 +425,12 @@ let rec join_comps match c_then, c_else with | C_STGhost _ _, C_STAtomic _ _ _ -> let d : st_typing g_then e_then (st_ghost_as_atomic c_then) = - lift_ghost_atomic e_then_typing in + () in st_ghost_as_atomic_matches_post_hint c_then post; join_comps _ _ _ d _ _ _ e_else_typing post | C_STAtomic _ _ _, C_STGhost _ _ -> - let d = lift_ghost_atomic e_else_typing in + let d : st_typing g_else e_else (st_ghost_as_atomic c_else) = () in st_ghost_as_atomic_matches_post_hint c_else post; join_comps _ _ _ e_then_typing _ _ _ d post #pop-options From d147c6c443d77320a41b0f4b81519a6ec21152c2 Mon Sep 17 00:00:00 2001 From: Gabriel Ebner Date: Fri, 27 Feb 2026 08:53:20 +0000 Subject: [PATCH 03/18] Make all typing tokens unit and convert implicit args to explicit All remaining inductive typing types (st_typing, comp_typing, st_comp_typing, bind_comp, st_equiv, st_sub, slprop_equiv, lift_comp, non_informative, pats_complete, brs_typing, br_typing) are now unit type aliases. Implicit arguments that were previously inferred from these typing tokens (e.g., #g, #t, #c in functions taking st_typing g t c) are now explicit, since F* can no longer infer them from unit-typed parameters. Key changes: - Pulse.Typing.fst: All remaining inductive types changed to unit - Function signatures updated in Metatheory, Combinators, Checker.Base, FV - All call sites updated to pass explicit arguments - Constructor calls replaced with () - Pattern matches on constructors replaced with admit() or () - br_typing_vis in Checker.Match made into unit alias Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/checker/Pulse.Checker.Abs.fst | 12 +- src/checker/Pulse.Checker.Admit.fst | 12 +- .../Pulse.Checker.AssertWithBinders.fst | 4 +- src/checker/Pulse.Checker.Base.fst | 175 ++---- src/checker/Pulse.Checker.Base.fsti | 20 +- src/checker/Pulse.Checker.Bind.fst | 4 +- src/checker/Pulse.Checker.Exists.fst | 21 +- .../Pulse.Checker.ForwardJumpLabel.fst | 9 +- src/checker/Pulse.Checker.Goto.fst | 2 +- src/checker/Pulse.Checker.If.fst | 6 +- src/checker/Pulse.Checker.IntroPure.fst | 10 +- src/checker/Pulse.Checker.Match.fst | 49 +- src/checker/Pulse.Checker.Prover.fst | 105 ++-- src/checker/Pulse.Checker.Return.fst | 8 +- src/checker/Pulse.Checker.Rewrite.fst | 12 +- src/checker/Pulse.Checker.SLPropEquiv.fst | 14 +- src/checker/Pulse.Checker.SLPropEquiv.fsti | 8 +- src/checker/Pulse.Checker.ST.fst | 2 +- src/checker/Pulse.Checker.While.fst | 4 +- src/checker/Pulse.Checker.WithLocal.fst | 4 +- src/checker/Pulse.Checker.WithLocalArray.fst | 4 +- src/checker/Pulse.Elaborate.Core.fst | 79 +-- src/checker/Pulse.JoinComp.fst | 15 +- src/checker/Pulse.Typing.Combinators.fst | 292 +++------- src/checker/Pulse.Typing.Combinators.fsti | 20 +- src/checker/Pulse.Typing.FV.fst | 196 +------ src/checker/Pulse.Typing.FV.fsti | 10 +- src/checker/Pulse.Typing.LN.fst | 165 +----- src/checker/Pulse.Typing.Metatheory.Base.fst | 141 ++--- src/checker/Pulse.Typing.Metatheory.Base.fsti | 22 +- src/checker/Pulse.Typing.Metatheory.fst | 86 +-- src/checker/Pulse.Typing.Metatheory.fsti | 10 +- src/checker/Pulse.Typing.fst | 543 +----------------- 33 files changed, 418 insertions(+), 1646 deletions(-) diff --git a/src/checker/Pulse.Checker.Abs.fst b/src/checker/Pulse.Checker.Abs.fst index 05d6392d9..9084ddfe0 100644 --- a/src/checker/Pulse.Checker.Abs.fst +++ b/src/checker/Pulse.Checker.Abs.fst @@ -493,7 +493,7 @@ let rec check_abs_core case to the st_sub judg. *) let (| c_body, body_typing |) = maybe_rewrite_body_typing body_typing asc in - FV.st_typing_freevars body_typing; + FV.st_typing_freevars g' body c_body body_typing; let body_closed = close_st_term body x in assume (open_st_term body_closed x == body); @@ -505,9 +505,9 @@ let rec check_abs_core |> FStar.Sealed.seal in let b = {binder_ty=t;binder_ppname=ppname;binder_attrs} in - let tt : st_typing g _ (C_Tot (tm_arrow {binder_ty=t;binder_ppname=ppname;binder_attrs} qual (close_comp c_body x))) = () in let tres = tm_arrow {binder_ty=t;binder_ppname=ppname;binder_attrs} qual (close_comp c_body x) in - (| _, C_Tot tres, tt |) + let tt : st_typing g body_closed (C_Tot tres) = () in + (| body_closed, C_Tot tres, tt |) | _ -> let elab_c, pre_opened, inames_opened, ret_ty, post_hint_body = match asc.elaborated with @@ -602,14 +602,14 @@ let rec check_abs_core let (| c_body, body_typing |) = maybe_rewrite_body_typing body_typing asc in - FV.st_typing_freevars body_typing; + FV.st_typing_freevars g' body c_body body_typing; let body_closed = close_st_term body x in assume (open_st_term body_closed x == body); let b = {binder_ty=t;binder_ppname=ppname;binder_attrs} in - let tt : st_typing g _ (C_Tot (tm_arrow {binder_ty=t;binder_ppname=ppname;binder_attrs} qual (close_comp c_body x))) = () in let tres = tm_arrow {binder_ty=t;binder_ppname=ppname;binder_attrs} qual (close_comp c_body x) in + let tt : st_typing g body_closed (C_Tot tres) = () in - (| _, C_Tot tres, tt |) + (| body_closed, C_Tot tres, tt |) #pop-options let check_abs (g:env) (t:st_term{Tm_Abs? t.term}) (check:check_t) diff --git a/src/checker/Pulse.Checker.Admit.fst b/src/checker/Pulse.Checker.Admit.fst index c62fefb51..ea7186f0f 100644 --- a/src/checker/Pulse.Checker.Admit.fst +++ b/src/checker/Pulse.Checker.Admit.fst @@ -66,16 +66,16 @@ let check let post = close_term post_opened x in let s : st_comp = {u;res=t;pre;post} in assume (open_term (close_term post_opened x) x == post_opened); - let d_s : st_comp_typing _ s = () in + let d_s : st_comp_typing g s = () in (match c with - | STT -> (| _, () |) - | STT_Ghost -> (| _, () |) - | STT_Atomic -> (| _, () |)) + | STT -> (| C_ST s, () |) + | STT_Ghost -> (| C_STGhost tm_emp_inames s, () |) + | STT_Atomic -> (| C_STAtomic tm_emp_inames Neutral s, () |)) | _, PostHint post -> Pulse.Typing.Combinators.comp_for_post_hint g pre pre_typing post x in let (| c, d_c |) = res in - let d : st_typing g _ c = () in + let d : st_typing g t0 c = () in FStar.Tactics.BreakVC.break_vc (); // ^ This makes a big difference! Would be good to distill into // a smaller F*-only example and file an issue. @@ -92,4 +92,4 @@ let check ] in info_doc_env g (Some t0.range) msg end else ()) <: T.Tac unit; - checker_result_for_st_typing (| _, _, d |) res_ppname + checker_result_for_st_typing (| t0, c, d |) res_ppname diff --git a/src/checker/Pulse.Checker.AssertWithBinders.fst b/src/checker/Pulse.Checker.AssertWithBinders.fst index 7d5b547fb..bef2d3061 100644 --- a/src/checker/Pulse.Checker.AssertWithBinders.fst +++ b/src/checker/Pulse.Checker.AssertWithBinders.fst @@ -355,7 +355,7 @@ let check_renaming let h2: slprop_equiv g rhs pre = RU.magic () in let h1: tot_typing g rhs tm_slprop = RU.magic () in let (| x, g', ty, ctxt', k |) = check g rhs h1 post_hint res_ppname body in - (| x, g', ty, ctxt', k_elab_equiv k h2 (VE_Refl _ _) |) + (| x, g', ty, ctxt', k_elab_equiv pre (dfst ctxt') k h2 () |) | [], Some goal -> ( let rhs, _ = rewrite_all st.range (T.unseal st.source) g pairs goal pre elaborated tac_opt true in @@ -560,4 +560,4 @@ let check let (| x, g'', ty, ctxt', k' |) = check g' (tm_star pre_remaining rhs') h1 post_hint res_ppname body in - (| x, g'', ty, ctxt', k_elab_trans k (k_elab_equiv k' h2 (VE_Refl _ _)) |) + (| x, g'', ty, ctxt', k_elab_trans k (k_elab_equiv (tm_star lhs pre_remaining) (dfst ctxt') k' h2 ()) |) diff --git a/src/checker/Pulse.Checker.Base.fst b/src/checker/Pulse.Checker.Base.fst index 952474f93..984b707de 100644 --- a/src/checker/Pulse.Checker.Base.fst +++ b/src/checker/Pulse.Checker.Base.fst @@ -63,27 +63,11 @@ let intro_comp_typing (g:env) (x:var { fresh_wrt x g (freevars (comp_post c)) }) (post_typing:tot_typing (push_binding g x ppname_default (comp_res c)) (open_term (comp_post c) x) tm_slprop) : T.Tac (comp_typing g c (universe_of_comp c)) - = let intro_st_comp_typing (st:st_comp { comp_u c == st.u /\ - comp_pre c == st.pre /\ - comp_res c == st.res /\ - comp_post c == st.post } ) - : T.Tac (st_comp_typing g st) - = STC g st x - in - match c with - | C_ST st -> - let stc = intro_st_comp_typing st in - CT_ST _ _ stc - | C_STAtomic i obs st -> - let stc = intro_st_comp_typing st in - CT_STAtomic _ i obs _ stc - | C_STGhost i st -> - let stc = intro_st_comp_typing st in - CT_STGhost _ i _ stc + = () irreducible let post_typing_as_abstraction - (#g:env) (#x:var) (#ty:term) (#t:term { fresh_wrt x g (freevars t) }) + (g:env) (x:var) (ty:term) (t:term { fresh_wrt x g (freevars t) }) (_:tot_typing (push_binding g x ppname_default ty) (open_term t x) tm_slprop) : FStar.Ghost.erased (RT.tot_typing (elab_env g) (mk_abs ty t) (mk_arrow ty tm_slprop)) = admit() @@ -150,17 +134,13 @@ let intro_post_hint g effect_annot ret_ty_opt post = let comp_typing_as_effect_annot_typing (#g:env) (#c:comp_st) (ct:comp_typing_u g c) : effect_annot_typing g (effect_annot_of_comp c) -= let iname_typing = snd <| Metatheory.comp_typing_inversion ct in - match c with - | C_ST _ -> () - | C_STGhost _ _ - | C_STAtomic _ _ _ -> iname_typing += () let post_hint_from_comp_typing #g #c ct = - let st_comp_typing = fst <| Metatheory.comp_typing_inversion ct in + let st_comp_typing = fst <| Metatheory.comp_typing_inversion g c ct in let effect_annot_typing = comp_typing_as_effect_annot_typing ct in - let inv = Metatheory.st_comp_typing_inversion st_comp_typing in + let inv = Metatheory.st_comp_typing_inversion g (st_comp_of_comp c) st_comp_typing in let p : post_hint_t = { g; effect_annot=_; @@ -242,7 +222,7 @@ let comp_st_with_post (c:comp_st) (post:term) | C_STAtomic i obs st -> C_STAtomic i obs {st with post} let ve_unit_r g (p:term) : slprop_equiv g (tm_star p tm_emp) p = - VE_Trans _ _ _ _ (VE_Comm _ _ _) (VE_Unit _ _) + () let st_equiv_post (#g:env) (#t:st_term) (#c:comp_st) (d:st_typing g t c) (post:term { freevars post `Set.subset` freevars (comp_post c)}) @@ -254,12 +234,8 @@ let st_equiv_post (#g:env) (#t:st_term) (#c:comp_st) (d:st_typing g t c) = if eq_tm post (comp_post c) then d else let c' = comp_st_with_post c post in - let (| u_of, pre_typing, x, post_typing |) = Metatheory.(st_comp_typing_inversion (fst (comp_typing_inversion (st_typing_correctness d)))) in - let veq = veq x in - let st_equiv : st_equiv g c c' = - ST_SLPropEquiv g c c' x (RT.Rel_refl _ _ _) (VE_Refl _ _) veq - in - t_equiv d st_equiv + let st_equiv : st_equiv g c c' = () in + Pulse.Typing.Combinators.t_equiv g t c d c' st_equiv let simplify_post (#g:env) (#t:st_term) (#c:comp_st) (d:st_typing g t c) (post:term { comp_post c == tm_star post tm_emp}) @@ -279,9 +255,9 @@ let simplify_lemma (c:comp_st) (c':comp_st) (post_hint:post_hint_opt_t) = () let slprop_equiv_typing_bk (#g:env) (#ctxt:_) (ctxt_typing:tot_typing g ctxt tm_slprop) - (#p:_) (d:slprop_equiv g p ctxt) + (p:_) (d:slprop_equiv g p ctxt) : tot_typing g p tm_slprop - = let _, bk = slprop_equiv_typing d in + = let _, bk = slprop_equiv_typing g p ctxt d in bk ctxt_typing let comp_with_pre (c:comp_st) (pre:term) = @@ -298,14 +274,10 @@ let st_equiv_pre (#g:env) (#t:st_term) (#c:comp_st) (d:st_typing g t c) = if eq_tm pre (comp_pre c) then d else let c' = comp_with_pre c pre in - let (| u_of, pre_typing, x, post_typing |) = - Metatheory.(st_comp_typing_inversion (fst (comp_typing_inversion (st_typing_correctness d)))) in - let st_equiv : st_equiv g c c' = - ST_SLPropEquiv g c c' x (RT.Rel_refl _ _ _) veq (VE_Refl _ _) - in - t_equiv d st_equiv + let st_equiv : st_equiv g c c' = () in + Pulse.Typing.Combinators.t_equiv g t c d c' st_equiv -let k_elab_equiv_continuation (#g1:env) (#g2:env { g2 `env_extends` g1 }) (#ctxt #ctxt1 #ctxt2:term) +let k_elab_equiv_continuation (#g1:env) (#g2:env { g2 `env_extends` g1 }) (#ctxt #ctxt1:term) (ctxt2:term) (k:continuation_elaborator g1 ctxt g2 ctxt1) (d:slprop_equiv g2 ctxt1 ctxt2) : continuation_elaborator g1 ctxt g2 ctxt2 = @@ -313,48 +285,48 @@ let k_elab_equiv_continuation (#g1:env) (#g2:env { g2 `env_extends` g1 }) (#ctxt let (| st, c, st_d |) = res in let st_d : st_typing g2 st c = st_d in assert (comp_pre c == ctxt2); - let st_d' : st_typing g2 st (comp_with_pre c ctxt1) = st_equiv_pre st_d _ (VE_Sym _ _ _ d) in - k post_hint (| st, _, st_d' |) + let st_d' : st_typing g2 st (comp_with_pre c ctxt1) = st_equiv_pre st_d _ () in + k post_hint (| st, comp_with_pre c ctxt1, st_d' |) let slprop_equiv_typing_fwd (#g:env) (#ctxt:_) (ctxt_typing:tot_typing g ctxt tm_slprop) - (#p:_) (d:slprop_equiv g ctxt p) + (p:_) (d:slprop_equiv g ctxt p) : tot_typing g p tm_slprop - = let fwd, _ = slprop_equiv_typing d in + = let fwd, _ = slprop_equiv_typing g ctxt p d in fwd ctxt_typing let k_elab_equiv_prefix - (#g1:env) (#g2:env { g2 `env_extends` g1 }) (#ctxt1 #ctxt2 #ctxt:term) + (#g1:env) (#g2:env { g2 `env_extends` g1 }) (#ctxt1 #ctxt:term) (ctxt2:term) (k:continuation_elaborator g1 ctxt1 g2 ctxt) (d:slprop_equiv g1 ctxt1 ctxt2) : continuation_elaborator g1 ctxt2 g2 ctxt = fun post_hint res -> let framing_token : frame_for_req_in_ctxt g1 ctxt2 ctxt1 = - let d = VE_Trans _ _ _ _ (VE_Comm _ _ _) (VE_Trans _ _ _ _ (VE_Unit _ _) d) in + let d = () in (| tm_emp, emp_typing, d |) in let res = k post_hint res in let (| st, c, st_d |) = res in assert (comp_pre c == ctxt1); - (| _, _, st_equiv_pre st_d _ d |) + (| st, comp_with_pre c ctxt2, st_equiv_pre st_d ctxt2 d |) let k_elab_equiv - (#g1:env) (#g2:env { g2 `env_extends` g1 }) (#ctxt1 #ctxt1' #ctxt2 #ctxt2':term) + (#g1:env) (#g2:env { g2 `env_extends` g1 }) (#ctxt1 #ctxt2:term) (ctxt1' ctxt2':term) (k:continuation_elaborator g1 ctxt1 g2 ctxt2) (d1:slprop_equiv g1 ctxt1 ctxt1') (d2:slprop_equiv g2 ctxt2 ctxt2') : continuation_elaborator g1 ctxt1' g2 ctxt2' = let k : continuation_elaborator g1 ctxt1 g2 ctxt2' = - k_elab_equiv_continuation k d2 in + k_elab_equiv_continuation ctxt2' k d2 in let k : continuation_elaborator g1 ctxt1' g2 ctxt2' = - k_elab_equiv_prefix k d1 in + k_elab_equiv_prefix ctxt1' k d1 in k #push-options "--fuel 3 --ifuel 1 --split_queries no --z3rlimit_factor 20" open Pulse.PP let continuation_elaborator_with_bind' (#g:env) (ctxt:term) - (#c1:comp{stateful_comp c1}) - (#e1:st_term) + (c1:comp{stateful_comp c1}) + (e1:st_term) (e1_typing:st_typing g e1 c1) (ctxt_pre1_typing:tot_typing g (tm_star ctxt (comp_pre c1)) tm_slprop) (x:nvar {freshv g (snd x)}) @@ -369,18 +341,18 @@ let continuation_elaborator_with_bind' (#g:env) (ctxt:term) let post1 = comp_post c1 in let ctxt_typing = star_typing_inversion_l ctxt_pre1_typing in // let p_prop = Metatheory.pure_typing_inversion pure_typing in - let v_eq = VE_Comm g ctxt pre1 in + let v_eq = () in let framing_token : frame_for_req_in_ctxt g (tm_star ctxt pre1) pre1 = - (| ctxt, ctxt_typing, VE_Comm g pre1 ctxt |) + (| ctxt, ctxt_typing, () |) in Pulse.Checker.Prover.Util.debug_prover g (fun _ -> Printf.sprintf "Applying frame %s to computation %s\n" (show ctxt) (show c1)); let (| c1, e1_typing |) = - apply_frame ctxt_pre1_typing e1_typing framing_token in + apply_frame g e1 (tm_star ctxt pre1) ctxt_pre1_typing c1 e1_typing framing_token in let (| u_of_1, pre_typing, _, _ |) = - Metatheory.(st_comp_typing_inversion (fst <| comp_typing_inversion (st_typing_correctness e1_typing))) in + Metatheory.(st_comp_typing_inversion g (st_comp_of_comp c1) (fst <| comp_typing_inversion g c1 (st_typing_correctness g e1 c1 e1_typing))) in let b = res1 in let ppname, x = x in let g' = push_binding g x ppname b in @@ -432,8 +404,8 @@ let continuation_elaborator_with_bind' (#g:env) (ctxt:term) #pop-options let continuation_elaborator_with_bind (#g:env) (ctxt:term) - (#c1:comp{stateful_comp c1}) - (#e1:st_term) + (c1:comp{stateful_comp c1}) + (e1:st_term) (e1_typing:st_typing g e1 c1) (ctxt_pre1_typing:tot_typing g (tm_star ctxt (comp_pre c1)) tm_slprop) (x:nvar { freshv g (snd x) }) @@ -443,7 +415,7 @@ let continuation_elaborator_with_bind (#g:env) (ctxt:term) (push_binding g (snd x) (fst x) (comp_res c1)) (tm_star (open_term (comp_post c1) (snd x)) ctxt)) = RU.record_stats "continuation_elaborator_with_bind" fun _ -> - continuation_elaborator_with_bind' ctxt e1_typing ctxt_pre1_typing x + continuation_elaborator_with_bind' ctxt c1 e1 e1_typing ctxt_pre1_typing x let coerce_eq (#a #b:Type) (x:a) (_:squash (a == b)) : y:b{y == x} = x @@ -495,13 +467,13 @@ let st_comp_typing_with_post_hint let ty_typing : universe_of g st.res st.u = () in assert (st.res == ph.ret_ty); assert (st.post == ph.post); - STC g st x + () #pop-options -let continuation_elaborator_with_bind_fn (#g:env) (#ctxt:term) +let continuation_elaborator_with_bind_fn (#g:env) (ctxt:term) (ctxt_typing:tot_typing g ctxt tm_slprop) - (#e1:st_term) - (#c1:comp { C_Tot? c1 }) + (e1:st_term) + (c1:comp { C_Tot? c1 }) (b:binder{b.binder_ty == comp_res c1}) (e1_typing:st_typing g e1 c1) (x:nvar { freshv g (snd x) }) @@ -516,38 +488,19 @@ let continuation_elaborator_with_bind_fn (#g:env) (#ctxt:term) let e2_closed = close_st_term e2 x in assume (open_st_term (close_st_term e2 x) x == e2); let e = wrst c2 (Tm_Bind {binder=b; head=e1; body=e2_closed}) in - let (| u, _ |) = Pulse.Typing.Metatheory.Base.st_typing_correctness_ctot e1_typing in - let c2_typing : comp_typing g c2 (universe_of_comp c2) = - match c2 with - | C_ST st -> - let stc = st_comp_typing_with_post_hint ctxt_typing post_hint c2 in - CT_ST _ _ stc - - | C_STAtomic i obs st -> - let stc = st_comp_typing_with_post_hint ctxt_typing post_hint c2 in - CT_STAtomic _ i obs _ stc - - | C_STGhost i st -> - let stc = st_comp_typing_with_post_hint ctxt_typing post_hint c2 in - CT_STGhost _ i _ stc - in - let d : st_typing g e c2 = - T_BindFn g e1 e2_closed c1 c2 b x e1_typing u d2 c2_typing - in + let (| u, _ |) = Pulse.Typing.Metatheory.Base.st_typing_correctness_ctot g e1 c1 e1_typing in + let c2_typing : comp_typing g c2 (universe_of_comp c2) = () in + let d : st_typing g e c2 = () in (| e, c2, d |) let rec check_equiv_emp (g:env) (vp:term) : option (slprop_equiv g vp tm_emp) = match inspect_term vp with - | Tm_Emp -> Some (VE_Refl _ _) + | Tm_Emp -> Some () | Tm_Star vp1 vp2 -> (match check_equiv_emp g vp1, check_equiv_emp g vp2 with | Some d1, Some d2 -> - let d3 : slprop_equiv g (tm_star vp1 vp2) (tm_star tm_emp tm_emp) - = VE_Ctxt _ _ _ _ _ d1 d2 in - let d4 : slprop_equiv g (tm_star tm_emp tm_emp) tm_emp = - VE_Unit _ _ in - Some (VE_Trans _ _ _ _ d3 d4) + Some () | _, _ -> None) | _ -> None @@ -573,33 +526,31 @@ let return_in_ctxt (g:env) (y:var) (y_ppname:ppname) (u:universe) (ty:term) (ctx | EffectAnnotSTT -> STT in let y_tm = tm_var {nm_index=y;nm_ppname=y_ppname} in - let d = T_Return g ctag false u ty y_tm post_hint.post x - in let t = wtag (Some ctag) (Tm_Return {expected_type=tm_unknown;insert_eq=false;term=y_tm}) in let c = comp_return ctag false u ty y_tm post_hint.post x in - let d : st_typing g t c = d in + let d : st_typing g t c = () in assume (comp_u c == post_hint.u); // this u should follow from equality of t match c, post_hint.effect_annot with - | C_STAtomic _ obs _, EffectAnnotAtomic { opens } - | C_STAtomic _ obs _, EffectAnnotAtomicOrGhost { opens } -> + | C_STAtomic _ obs st, EffectAnnotAtomic { opens } + | C_STAtomic _ obs st, EffectAnnotAtomicOrGhost { opens } -> assert (comp_inames c == tm_emp_inames); let pht = post_hint_typing g post_hint x in let validity = emp_inames_included g opens pht.effect_annot_typing in - let d = T_Sub _ _ _ _ d (STS_AtomicInvs _ (st_comp_of_comp c) tm_emp_inames opens obs obs validity) in - (| _, _, d |) - | C_STGhost _ _, EffectAnnotGhost { opens } - | C_STGhost _ _, EffectAnnotAtomicOrGhost { opens } -> + let c' = C_STAtomic opens obs st in + (| t, c', () |) + | C_STGhost _ st, EffectAnnotGhost { opens } + | C_STGhost _ st, EffectAnnotAtomicOrGhost { opens } -> assert (comp_inames c == tm_emp_inames); let pht = post_hint_typing g post_hint x in let validity = emp_inames_included g opens pht.effect_annot_typing in - let d = T_Sub _ _ _ _ d (STS_GhostInvs _ (st_comp_of_comp c) tm_emp_inames opens validity) in - (| _, _, d |) + let c' = C_STGhost opens st in + (| t, c', () |) | _ -> - (| _, _, d |) + (| t, c, d |) #push-options "--z3rlimit_factor 4 --ifuel 1 --split_queries always" #restart-solver -let match_comp_res_with_post_hint (#g:env) (#t:st_term) (#c:comp_st) +let match_comp_res_with_post_hint (#g:env) (t:st_term) (c:comp_st) (d:st_typing g t c) (post_hint:post_hint_opt g) : T.Tac (c':comp_st { comp_pre c' == comp_pre c } & @@ -625,13 +576,9 @@ let match_comp_res_with_post_hint (#g:env) (#t:st_term) (#c:comp_st) RT.Rel_eq_token _ _ _ (FStar.Squash.return_squash tok) in let c' = with_st_comp c {(st_comp_of_comp c) with res = ret_ty } in - let (| cres_typing, cpre_typing, x, cpost_typing |) = - st_comp_typing_inversion (fst <| comp_typing_inversion (st_typing_correctness d)) in - let d_stequiv : st_equiv g c c' = - ST_SLPropEquiv _ c c' x d_equiv (VE_Refl _ _) (VE_Refl _ _) - in + let d_stequiv : st_equiv g c c' = () in - (| c', Pulse.Typing.Combinators.t_equiv d d_stequiv |) + (| c', Pulse.Typing.Combinators.t_equiv g t c d c' d_stequiv |) #pop-options #pop-options @@ -660,7 +607,7 @@ let checker_result_for_st_typing (#g:env) (#ctxt:slprop) (#post_hint:post_hint_o let x = fresh g in assume (~ (x `Set.mem` freevars (comp_post c1))); let u_of_1, pre_typing, post_typing = - Metatheory.(st_comp_typing_inversion_with_name (fst <| comp_typing_inversion (st_typing_correctness d1)) x) in + Metatheory.(st_comp_typing_inversion_with_name g (st_comp_of_comp c1) (fst <| comp_typing_inversion g c1 (st_typing_correctness g e1 c1 d1)) x) in let g' = push_binding g x ppname (comp_res c1) in let ctxt' = open_term_nv (comp_post c1) (ppname, x) in let k @@ -770,8 +717,8 @@ let checker_result_t_equiv_ctxt (g:env) (ctxt ctxt' : slprop) (equiv : slprop_equiv g ctxt ctxt') (r : checker_result_t g ctxt post_hint) : checker_result_t g ctxt' post_hint -= let (| x, g1, t, ctxt', k |) = r in - (| x, g1, t, ctxt', k_elab_equiv k equiv (VE_Refl _ _) |) += let (| x, g1, t, ctxt_r, k |) = r in + (| x, g1, t, ctxt_r, k_elab_equiv ctxt' (dfst ctxt_r) k equiv () |) module RU = Pulse.RuntimeUtils let as_stateful_application (e:term) (head:term) (args:list T.argv { Cons? args }) @@ -829,7 +776,7 @@ let norm_typing_inverse let norm_st_typing_inverse - (#g:env) (#e:st_term) (#t0:term) + (g:env) (e:st_term) (t0:term) (d:st_typing g e (C_Tot t0)) (#u:_) (t1:term) @@ -853,10 +800,8 @@ let norm_st_typing_inverse : Ghost.erased (RT.equiv (elab_env g) t0 t1) = Ghost.hide (RT.Rel_sym _ _ _ related_t1_t1') in - let steq : st_equiv g (C_Tot t0) (C_Tot t1) = - ST_TotEquiv _ _ _ u eq - in - Some (Pulse.Typing.Combinators.t_equiv d steq) + let steq : st_equiv g (C_Tot t0) (C_Tot t1) = () in + Some (Pulse.Typing.Combinators.t_equiv g e (C_Tot t0) d (C_Tot t1) steq) ) else None diff --git a/src/checker/Pulse.Checker.Base.fsti b/src/checker/Pulse.Checker.Base.fsti index 4a085b6c8..6163400a0 100644 --- a/src/checker/Pulse.Checker.Base.fsti +++ b/src/checker/Pulse.Checker.Base.fsti @@ -38,7 +38,7 @@ val intro_comp_typing (g:env) : T.Tac (comp_typing g c (universe_of_comp c)) val post_typing_as_abstraction - (#g:env) (#x:var) (#ty:term) (#t:term { fresh_wrt x g (freevars t) }) + (g:env) (x:var) (ty:term) (t:term { fresh_wrt x g (freevars t) }) (_:tot_typing (push_binding g x ppname_default ty) (open_term t x) tm_slprop) : FStar.Ghost.erased (RT.tot_typing (elab_env g) (RT.mk_abs ty T.Q_Explicit t) @@ -100,13 +100,13 @@ val k_elab_trans (k1:continuation_elaborator g1 ctxt1 g2 ctxt2) : continuation_elaborator g0 ctxt0 g2 ctxt2 -val k_elab_equiv_continuation (#g1:env) (#g2:env { g2 `env_extends` g1 }) (#ctxt #ctxt1 #ctxt2:term) +val k_elab_equiv_continuation (#g1:env) (#g2:env { g2 `env_extends` g1 }) (#ctxt #ctxt1:term) (ctxt2:term) (k:continuation_elaborator g1 ctxt g2 ctxt1) (d:slprop_equiv g2 ctxt1 ctxt2) : continuation_elaborator g1 ctxt g2 ctxt2 val k_elab_equiv - (#g1:env) (#g2:env { g2 `env_extends` g1 }) (#ctxt1 #ctxt1' #ctxt2 #ctxt2':term) + (#g1:env) (#g2:env { g2 `env_extends` g1 }) (#ctxt1 #ctxt2:term) (ctxt1' ctxt2':term) (k:continuation_elaborator g1 ctxt1 g2 ctxt2) (d1:slprop_equiv g1 ctxt1 ctxt1') (d2:slprop_equiv g2 ctxt2 ctxt2') @@ -116,8 +116,8 @@ val k_elab_equiv // A canonical continuation elaborator for Bind // val continuation_elaborator_with_bind (#g:env) (ctxt:term) - (#c1:comp{stateful_comp c1}) - (#e1:st_term) + (c1:comp{stateful_comp c1}) + (e1:st_term) (e1_typing:st_typing g e1 c1) (ctxt_pre1_typing:tot_typing g (tm_star ctxt (comp_pre c1)) tm_slprop) (x:nvar { freshv g (snd x) }) @@ -127,10 +127,10 @@ val continuation_elaborator_with_bind (#g:env) (ctxt:term) (push_binding g (snd x) (fst x) (comp_res c1)) (tm_star (open_term (comp_post c1) (snd x)) ctxt)) -val continuation_elaborator_with_bind_fn (#g:env) (#ctxt:term) +val continuation_elaborator_with_bind_fn (#g:env) (ctxt:term) (ctxt_typing:tot_typing g ctxt tm_slprop) - (#e1:st_term) - (#c1:comp { C_Tot? c1 }) + (e1:st_term) + (c1:comp { C_Tot? c1 }) (b:binder{b.binder_ty == comp_res c1}) (e1_typing:st_typing g e1 c1) (x:nvar { freshv g (snd x) }) @@ -192,7 +192,7 @@ type check_t = t:st_term -> T.Tac (checker_result_t g ctxt post_hint) -val match_comp_res_with_post_hint (#g:env) (#t:st_term) (#c:comp_st) +val match_comp_res_with_post_hint (#g:env) (t:st_term) (c:comp_st) (d:st_typing g t c) (post_hint:post_hint_opt g) : T.Tac (c':comp_st { comp_pre c' == comp_pre c } & @@ -233,7 +233,7 @@ val norm_typing_inverse : T.Tac (option (typing g e eff t1)) val norm_st_typing_inverse - (#g:env) (#e:st_term) (#t0:term) + (g:env) (e:st_term) (t0:term) (d:st_typing g e (C_Tot t0)) (#u:_) (t1:term) diff --git a/src/checker/Pulse.Checker.Bind.fst b/src/checker/Pulse.Checker.Bind.fst index 3145e79c6..1485a5720 100644 --- a/src/checker/Pulse.Checker.Bind.fst +++ b/src/checker/Pulse.Checker.Bind.fst @@ -54,10 +54,10 @@ let check_bind_fn let b = { binder with binder_ty = comp_res c } in let g' = push_binding g x (binder.binder_ppname) b.binder_ty in let ctxt_typing' : tot_typing g' ctxt tm_slprop = - Metatheory.tot_typing_weakening_single ctxt_typing x b.binder_ty in + Metatheory.tot_typing_weakening_single g ctxt tm_slprop ctxt_typing x b.binder_ty in let r = check g' _ ctxt_typing' post_hint res_ppname (open_st_term_nv body (binder.binder_ppname, x)) in let body_typing = apply_checker_result_k #_ #_ #(PostHint?.v post_hint) r res_ppname in - let k = Pulse.Checker.Base.continuation_elaborator_with_bind_fn ctxt_typing b head_typing (binder.binder_ppname, x) in + let k = Pulse.Checker.Base.continuation_elaborator_with_bind_fn ctxt ctxt_typing t c b head_typing (binder.binder_ppname, x) in let d = k post_hint body_typing in checker_result_for_st_typing d res_ppname ) diff --git a/src/checker/Pulse.Checker.Exists.fst b/src/checker/Pulse.Checker.Exists.fst index 6a6a0d9be..fb9cc31e3 100644 --- a/src/checker/Pulse.Checker.Exists.fst +++ b/src/checker/Pulse.Checker.Exists.fst @@ -88,9 +88,11 @@ let check_elim_exists let (| u', ty_typing |) = universe_of_well_typed_term g ty in if eq_univ u u' then let x = fresh g in - let d : st_typing g _ _ = () in - let (|_,d|) = match_comp_res_with_post_hint d post_hint in - prove_post_hint (try_frame_pre false pre_typing (|_,_,d|) res_ppname) post_hint t_rng + let elim_st = wtag (Some STT_Ghost) (Tm_ElimExists { p = tm_exists_sl u (as_binder ty) p }) in + let elim_c = comp_elim_exists u ty p (ppname_default, x) in + let d : st_typing g elim_st elim_c = () in + let (|c,d|) = match_comp_res_with_post_hint elim_st elim_c d post_hint in + prove_post_hint (try_frame_pre false pre_typing (|elim_st,c,d|) res_ppname) post_hint t_rng else fail g (Some t_rng) (Printf.sprintf "check_elim_exists: universe checking failed, computed %s, expected %s" (P.univ_to_string u') (P.univ_to_string u)) @@ -125,15 +127,16 @@ let check_intro_exists let Tm_ExistsSL u b p = tv in - Pulse.Typing.FV.tot_typing_freevars t_typing; + Pulse.Typing.FV.tot_typing_freevars g t tm_slprop t_typing; let x = fresh g in - let ty_typing, _ = Metatheory.tm_exists_inversion #g #u #b.binder_ty #p t_typing x in + let ty_typing, _ = Metatheory.tm_exists_inversion g u b.binder_ty p t_typing x in let (| witness, witness_typing |) = check_term g witness T.E_Ghost b.binder_ty in - let d : st_typing g _ _ = () in - let (| c, d |) : (c:_ & st_typing g _ c) = (| _, d |) in - let (| c, d |) = match_comp_res_with_post_hint d post_hint in - prove_post_hint (try_frame_pre false pre_typing (|_,_,d|) res_ppname) + let intro_st = wtag (Some STT_Ghost) (Tm_IntroExists { p = tm_exists_sl u b p; witnesses = [witness] }) in + let intro_c = C_STGhost tm_emp_inames { u=u0; res=tm_unit; pre=open_term' p witness 0; post=tm_exists_sl u (as_binder b.binder_ty) p } in + let d : st_typing g intro_st intro_c = () in + let (| c, d |) = match_comp_res_with_post_hint intro_st intro_c d post_hint in + prove_post_hint (try_frame_pre false pre_typing (|intro_st, c, d|) res_ppname) post_hint (Pulse.RuntimeUtils.range_of_term t) #pop-options diff --git a/src/checker/Pulse.Checker.ForwardJumpLabel.fst b/src/checker/Pulse.Checker.ForwardJumpLabel.fst index 677e61b99..a58ba6991 100644 --- a/src/checker/Pulse.Checker.ForwardJumpLabel.fst +++ b/src/checker/Pulse.Checker.ForwardJumpLabel.fst @@ -92,15 +92,14 @@ let check post = body'_c; }) in assume open_st_term' body (term_of_nvar (lbl, lbl_x)) 0 == body'; - let typing: st_typing g t body'_c = - T_ForwardJumpLabel g (lbl, lbl_x) body body'_c body'_typing in + let typing: st_typing g t body'_c = () in if not has_explicit_post then ( assert post_hint0 == PostHint post; - checker_result_for_st_typing (| _, _, typing |) res_ppname + checker_result_for_st_typing (| t, body'_c, typing |) res_ppname ) else ( - let (| c'', typing'' |) = match_comp_res_with_post_hint typing post_hint0 in + let (| c'', typing'' |) = match_comp_res_with_post_hint t body'_c typing post_hint0 in prove_post_hint #g - (try_frame_pre false #g pre_typing (|_,c'',typing''|) res_ppname) + (try_frame_pre false #g pre_typing (|t,c'',typing''|) res_ppname) post_hint0 rng ) diff --git a/src/checker/Pulse.Checker.Goto.fst b/src/checker/Pulse.Checker.Goto.fst index 2bf34332b..6f0be518c 100644 --- a/src/checker/Pulse.Checker.Goto.fst +++ b/src/checker/Pulse.Checker.Goto.fst @@ -53,7 +53,7 @@ let check' let x' = fresh g in assume fresh_wrt x' g (freevars ph.post); let pht = post_hint_typing g ph x' in () in - let (| c'', typing'' |) = match_comp_res_with_post_hint typing post_hint in + let (| c'', typing'' |) = match_comp_res_with_post_hint t c' typing post_hint in prove_post_hint #g (try_frame_pre false #g pre_typing (|_,c'',typing''|) res_ppname) post_hint diff --git a/src/checker/Pulse.Checker.If.fst b/src/checker/Pulse.Checker.If.fst index 280adc7bd..cf301d831 100644 --- a/src/checker/Pulse.Checker.If.fst +++ b/src/checker/Pulse.Checker.If.fst @@ -67,6 +67,7 @@ let check : T.Tac (checker_result_t (g_with_eq eq_v) pre post_hint) = let pre_typing = Metatheory.tot_typing_weakening_single + g pre tm_slprop pre_typing hyp (mk_sq_rewrites_to_p u0 tm_bool b eq_v) @@ -134,12 +135,13 @@ let check let (| e1, c1, e1_typing |) = extract then_ true in let (| e2, c2, e2_typing |) = extract else_ false in let (| c, e1_typing, e2_typing |) = - J.join_comps _ _ _ e1_typing _ _ _ e2_typing post_hint' in + J.join_comps (g_with_eq tm_true) e1 c1 e1_typing (g_with_eq tm_false) e2 c2 e2_typing post_hint' in let c_typing = comp_typing_from_post_hint c pre_typing post_hint' in + let if_st = wrst c (Tm_If { b; then_=e1; else_=e2; post=None }) in let d : st_typing_in_ctxt g pre (PostHint post_hint') = - (| _, c, () |) in + (| if_st, c, () |) in let res : checker_result_t g pre (PostHint post_hint') = checker_result_for_st_typing d res_ppname in retype_checker_result_post_hint post_hint' post_hint res diff --git a/src/checker/Pulse.Checker.IntroPure.fst b/src/checker/Pulse.Checker.IntroPure.fst index 56c526c13..0816620b4 100644 --- a/src/checker/Pulse.Checker.IntroPure.fst +++ b/src/checker/Pulse.Checker.IntroPure.fst @@ -31,7 +31,7 @@ let check_prop (g:env) (p:term) let (| p, p_typing |) = Pulse.Checker.Pure.check_slprop g (tm_pure p) in match inspect_term p with | Tm_Pure pp -> - let prop_typing = Pulse.Typing.Metatheory.pure_typing_inversion #_ #pp p_typing in + let prop_typing = Pulse.Typing.Metatheory.pure_typing_inversion _ pp p_typing in (| pp, prop_typing |) | _ -> fail g None @@ -58,6 +58,8 @@ let check let Tm_IntroPure { p } = t.term in let (| p, p_typing |) = check_prop g p in let pv = check_prop_validity g p p_typing in - let st_typing : st_typing g _ _ = () in - let (| c,d |) = match_comp_res_with_post_hint st_typing post_hint in - prove_post_hint (try_frame_pre false pre_typing (|_,c,d|) res_ppname) post_hint t.range + let intro_st = wtag (Some STT_Ghost) (Tm_IntroPure { p }) in + let intro_c = C_STGhost tm_emp_inames { u=u0; res=tm_unit; pre=tm_emp; post=tm_pure p } in + let st_typing : st_typing g intro_st intro_c = () in + let (| c,d |) = match_comp_res_with_post_hint intro_st intro_c st_typing post_hint in + prove_post_hint (try_frame_pre false pre_typing (|intro_st,c,d|) res_ppname) post_hint t.range diff --git a/src/checker/Pulse.Checker.Match.fst b/src/checker/Pulse.Checker.Match.fst index 73e213d0b..cf05b2e5c 100644 --- a/src/checker/Pulse.Checker.Match.fst +++ b/src/checker/Pulse.Checker.Match.fst @@ -29,28 +29,7 @@ module R = FStar.Reflection.V2 module RT = FStar.Reflection.Typing module RU = Pulse.RuntimeUtils -noeq -type br_typing_vis : env -> universe -> typ -> term -> pattern -> st_term -> comp_st -> Type = - | TBRV : - g:env -> - sc_u : universe -> - sc_ty : typ -> - sc:term -> - c:comp_st -> - p:pattern -> - e:st_term -> - bs:(list R.binding){RT.bindings_ok_for_pat (fstar_env g) bs (elab_pat p)} -> - _ : squash (all_fresh g (L.map readback_binding bs)) -> - _ : squash (Some? (RT.elaborate_pat (elab_pat p) bs)) -> - _ : squash (~(R.Tv_Unknown? (R.inspect_ln (fst (Some?.v (RT.elaborate_pat (elab_pat p) bs)))))) -> // should be provable from defn of elaborate_pat - hyp:var {freshv (push_bindings g (L.map readback_binding bs)) hyp} -> - st_typing ( - push_binding (push_bindings g (L.map readback_binding bs)) - hyp - ({name=Sealed.seal "branch equality"; range=FStar.Range.range_0}) - (mk_sq_eq2 sc_u sc_ty sc (wr (fst (Some?.v (RT.elaborate_pat (elab_pat p) bs))) Range.range_0)) - ) e c -> - br_typing_vis g sc_u sc_ty sc p (close_st_term_n e (L.map (fun b -> (readback_binding b).x) bs)) c +let br_typing_vis (g:env) (_:universe) (_:typ) (_:term) (_:pattern) (_:st_term) (_:comp_st) : Type = unit let rec readback_pat (p : R.pattern) : option pattern = match p with @@ -209,7 +188,7 @@ let rec tot_typing_weakening_n bs d = match bs with | [] -> d | {x; ty} :: bs -> - let d = Pulse.Typing.Metatheory.tot_typing_weakening_single d x ty in + let d = Pulse.Typing.Metatheory.tot_typing_weakening_single _ _ _ d x ty in tot_typing_weakening_n bs d let patof (b:branch) : pattern = b.pat @@ -297,13 +276,13 @@ let check_branch { t with effect_tag = e.effect_tag } in let pre_typing = tot_typing_weakening_n pulse_bs pre_typing in // weaken w/ binders - let pre_typing = Pulse.Typing.Metatheory.tot_typing_weakening_single pre_typing hyp_var eq_typ in // weaken w/ branch eq + let pre_typing = Pulse.Typing.Metatheory.tot_typing_weakening_single _ _ _ pre_typing hyp_var eq_typ in // weaken w/ branch eq let (| e, c, e_d |) = let ppname = mk_ppname_no_range "_br" in let r = check g' pre pre_typing (PostHint post_hint) ppname e in apply_checker_result_k r ppname in - let br_d : br_typing_vis g sc_u sc_ty sc p (close_st_term_n e (L.map (fun (b: var_binding) -> b.x) pulse_bs)) c = TBRV g sc_u sc_ty sc c p e bs () () () hyp_var e_d in + let br_d : br_typing_vis g sc_u sc_ty sc p (close_st_term_n e (L.map (fun (b: var_binding) -> b.x) pulse_bs)) c = () in (| p, close_st_term_n e (L.map (fun (b: var_binding) -> b.x) pulse_bs), c, br_d |) #pop-options @@ -374,12 +353,7 @@ let weaken_branch_observability if not (sub_observability obs' obs) then T.fail "Cannot weaken observability" else ( - let d : br_typing_vis g sc_u sc_ty sc br.pat br.e c = - let TBRV g sc_u sc_ty sc c p e bs p1 p2 p3 hyp st_typing = typing in - let st_typing : st_typing _ _ _ = () in - let d = TBRV g sc_u sc_ty sc _ p e bs p1 p2 p3 hyp st_typing in - d - in + let d : br_typing_vis g sc_u sc_ty sc br.pat br.e c = () in (| br, d |) ) #pop-options @@ -463,10 +437,9 @@ let weaken_branch_tag_to fail g (Some r) "Cannot lift a branch to ST" | STT_Atomic, C_STGhost _ _ -> ( - let TBRV g sc_u sc_ty sc c p e bs pf1 pf2 pf3 h d = d in - let d : st_typing _ _ _ = () in - let d = TBRV g sc_u sc_ty sc _ p e bs pf1 pf2 pf3 h d in - (| pe, _, d |) + let c' = Pulse.Typing.Combinators.st_ghost_as_atomic c in + let d : br_typing_vis g sc_u sc_ty sc pe.pat pe.e c' = () in + (| pe, c', d |) ) @@ -500,7 +473,6 @@ let maybe_weaken_branch_tags #pop-options let erase_br_typing #g #sc_u #sc_ty #sc #p #e #c (d: br_typing_vis g sc_u sc_ty sc p e c) : br_typing g sc_u sc_ty sc p e c = - let TBRV g sc_u sc_ty sc c p e bs pf1 pf2 pf3 hyp d = d in () (* Hoisting this makes the proof much faster and more stable. *) @@ -605,6 +577,7 @@ let check (* Provable *) assume (L.map (fun br -> elab_pat br.pat) brs == elab_pats'); let c_typing = comp_typing_from_post_hint c pre_typing post_hint in - let d : st_typing g _ c = () in - checker_result_for_st_typing (| _, _, d |) res_ppname + let t = wtag (Some (ctag_of_comp_st c)) (Tm_Match {sc; returns_=None; brs}) in + let d : st_typing g t c = () in + checker_result_for_st_typing (| t, c, d |) res_ppname #pop-options \ No newline at end of file diff --git a/src/checker/Pulse.Checker.Prover.fst b/src/checker/Pulse.Checker.Prover.fst index 5b3daab85..4ddfbc1b6 100644 --- a/src/checker/Pulse.Checker.Prover.fst +++ b/src/checker/Pulse.Checker.Prover.fst @@ -206,25 +206,25 @@ let cont_elab g ps g' ps' = frame: list slprop_view -> continuation_elaborator g (elab_slprops (frame @ ps)) g' (elab_slprops (frame @ ps')) let cont_elab_refl g ps ps' (h: slprop_equiv g (elab_slprops ps) (elab_slprops ps')) : cont_elab g ps g ps' = - fun frame -> k_elab_equiv (k_elab_unit g (elab_slprops (frame @ ps))) (()) (RU.magic ()) + fun frame -> k_elab_equiv (elab_slprops (frame @ ps)) (elab_slprops (frame @ ps')) (k_elab_unit g (elab_slprops (frame @ ps))) (()) (RU.magic ()) let cont_elab_trans #g1 (#g2: env { g2 `env_extends` g1 }) (#g3: env { g3 `env_extends` g2 }) #ps1 #ps2 #ps2' #ps3 (k1: cont_elab g1 ps1 g2 ps2) (k2: cont_elab g2 ps2' g3 ps3) (h: slprop_equiv g2 (elab_slprops ps2) (elab_slprops ps2')) : cont_elab g1 ps1 g3 ps3 = - fun frame -> k_elab_trans (k1 frame) (k_elab_equiv (k2 frame) (RU.magic ()) (())) + fun frame -> k_elab_trans (k1 frame) (k_elab_equiv (elab_slprops (frame @ ps2)) (elab_slprops (frame @ ps3)) (k2 frame) (RU.magic ()) (())) let cont_elab_equiv #g1 #ps1 #ps1' #g2 #ps2 #ps2' (k: cont_elab g1 ps1 g2 ps2) (h1: slprop_equiv g1 (elab_slprops ps1) (elab_slprops ps1')) (h2: slprop_equiv g2 (elab_slprops ps2) (elab_slprops ps2')) : cont_elab g1 ps1' g2 ps2' = - fun frame -> k_elab_equiv (k frame) (RU.magic ()) (RU.magic ()) + fun frame -> k_elab_equiv (elab_slprops (frame @ ps1')) (elab_slprops (frame @ ps2')) (k frame) (RU.magic ()) (RU.magic ()) let cont_elab_frame #g #ps #g' #ps' (k: cont_elab g ps g' ps') frame : cont_elab g (frame @ ps) g' (frame @ ps') = - fun frame' -> k_elab_equiv (k (frame' @ frame)) (RU.magic()) (RU.magic()) + fun frame' -> k_elab_equiv (elab_slprops (frame' @ (frame @ ps))) (elab_slprops (frame' @ (frame @ ps'))) (k (frame' @ frame)) (RU.magic()) (RU.magic()) let cont_elab_thunk #g #ps #g' #ps' (k: unit -> T.Tac (cont_elab g ps g' ps')) : cont_elab g ps g' ps' = fun frame posth typing -> k () frame posth typing @@ -250,11 +250,11 @@ let prover_result_join #g #ctxt #goals #g1 #ctxt1 #goals1 (fun frame -> let h1: slprop_equiv g1 (elab_slprops ((frame @ solved1) @ ctxt1)) (elab_slprops (frame @ solved1 @ ctxt1)) = RU.magic () in let h2: slprop_equiv g2 (elab_slprops ((frame @ solved1) @ solved2 @ ctxt2)) (elab_slprops (frame @ (solved1 @ solved2) @ ctxt2)) = RU.magic () in - k_elab_trans (before1 frame) (k_elab_equiv (before2 (frame @ solved1)) h1 h2)), + k_elab_trans (before1 frame) (k_elab_equiv (elab_slprops (frame @ solved1 @ ctxt1)) (elab_slprops (frame @ (solved1 @ solved2) @ ctxt2)) (before2 (frame @ solved1)) h1 h2)), (fun frame -> let h1: slprop_equiv g3 (elab_slprops ((frame @ solved1) @ solved2 @ goals2)) (elab_slprops (frame @ (solved1 @ solved2) @ goals2)) = RU.magic () in let h2: slprop_equiv g3 (elab_slprops ((frame @ solved1) @ goals1)) (elab_slprops (frame @ solved1 @ goals1)) = RU.magic () in - k_elab_trans (k_elab_equiv (after2 (frame @ solved1)) h1 h2) (after1 frame)) + k_elab_trans (k_elab_equiv (elab_slprops (frame @ (solved1 @ solved2) @ goals2)) (elab_slprops (frame @ solved1 @ goals1)) (after2 (frame @ solved1)) h1 h2) (after1 frame)) <: T.Tac _ |) let prove_first (g: env) (ctxt goals: list slprop_view) @@ -278,7 +278,7 @@ let prove_first (g: env) (ctxt goals: list slprop_view) let h2 : slprop_equiv g'' (elab_slprops ((frame @ List.Tot.Base.rev goals_left_rev @ goals) @ [goal])) (elab_slprops (frame @ goals0)) = RU.magic () in - k_elab_equiv (after (frame @ List.rev goals_left_rev @ goals)) h1 h2) |) + k_elab_equiv (elab_slprops (frame @ solved @ List.Tot.Base.rev goals_left_rev @ goals' @ goals)) (elab_slprops (frame @ goals0)) (after (frame @ List.rev goals_left_rev @ goals)) h1 h2) |) | None -> assert List.rev goals_left_rev @ (goal::goals) == goals0; assume List.rev (goal::goals_left_rev) @ goals == goals0; @@ -292,8 +292,8 @@ let deep_compress_comp (c:comp {stateful_comp c}) : comp = with_st_comp c (deep_compress_st_comp (st_comp_of_comp c)) let continuation_elaborator_with_bind_nondep (#g:env) (ctxt:term) - (#c1:comp{stateful_comp c1}) - (#e1:st_term) + (c1:comp{stateful_comp c1}) + (e1:st_term) (e1_typing:st_typing g e1 c1) (ctxt_pre1_typing:tot_typing g (tm_star ctxt (comp_pre c1)) tm_slprop) : T.Tac (continuation_elaborator @@ -303,11 +303,11 @@ let continuation_elaborator_with_bind_nondep (#g:env) (ctxt:term) (tm_star (comp_post c1) ctxt)) = let x = fresh g in admit (); - continuation_elaborator_with_bind (RU.deep_compress_safe ctxt) #(deep_compress_comp c1) e1_typing ctxt_pre1_typing (ppname_default, x) + continuation_elaborator_with_bind (RU.deep_compress_safe ctxt) (deep_compress_comp c1) e1 e1_typing ctxt_pre1_typing (ppname_default, x) let continuation_elaborator_with_bind_nondep_unit (#g:env) (ctxt:term) - (#c1:comp_st{comp_res c1 == tm_unit }) - (#e1:st_term) + (c1:comp_st{comp_res c1 == tm_unit }) + (e1:st_term) (e1_typing:st_typing g e1 c1) (ctxt_pre1_typing:tot_typing g (tm_star ctxt (comp_pre c1)) tm_slprop) : T.Tac (continuation_elaborator @@ -317,11 +317,11 @@ let continuation_elaborator_with_bind_nondep_unit (#g:env) (ctxt:term) (tm_star (open_term' (comp_post c1) unit_const 0) ctxt)) = let c1 = with_st_comp c1 { st_comp_of_comp c1 with post = open_term' (comp_post c1) unit_const 0 } in let e1_typing: st_typing g e1 c1 = RU.magic () in - continuation_elaborator_with_bind_nondep #g ctxt #c1 #e1 e1_typing ctxt_pre1_typing + continuation_elaborator_with_bind_nondep #g ctxt c1 e1 e1_typing ctxt_pre1_typing let cont_elab_with_bind_nondep_unit (#g:env) - (#c1:comp_st{comp_res c1 == tm_unit }) - (#e1:st_term) + (c1:comp_st{comp_res c1 == tm_unit }) + (e1:st_term) (e1_typing:st_typing g e1 c1) (pre1_typing:tot_typing g (comp_pre c1) tm_slprop) : T.Tac (cont_elab @@ -338,7 +338,10 @@ let cont_elab_with_bind_nondep_unit (#g:env) (tm_star (open_term' (comp_post c1) unit_const 0) (elab_slprops frame)) (elab_slprops (frame @ [Unknown (open_term' (comp_post c1) unit_const 0)])) = RU.magic () in - k_elab_equiv (continuation_elaborator_with_bind_nondep_unit (elab_slprops frame) e1_typing h1) + k_elab_equiv + (elab_slprops (frame @ [Unknown (comp_pre c1)])) + (elab_slprops (frame @ [Unknown (open_term' (comp_post c1) unit_const 0)])) + (continuation_elaborator_with_bind_nondep_unit (elab_slprops frame) c1 e1 e1_typing h1) h2 h3 posth t let tot_typing_tm_unit (g: env) : tot_typing g tm_unit (tm_type u0) = RU.magic () @@ -350,8 +353,9 @@ let intro_pure (g: env) (frame: slprop) (p: term) fun post t -> let frame_typ : tot_typing g frame tm_slprop = RU.magic () in // implied by t2_typing let h: tot_typing g (tm_star frame (comp_pre (comp_intro_pure p))) tm_slprop = RU.magic () in + let st = wtag (Some STT_Ghost) (Tm_ST { t = tm_unknown; args = [] }) in debug_prover g (fun _ -> Printf.sprintf "intro_pure p=%s\nframe=%s\n" (show p) (show frame)); - k_elab_equiv (continuation_elaborator_with_bind_nondep frame (() <: st_typing g _ (comp_intro_pure p)) h) (RU.magic ()) (RU.magic ()) + k_elab_equiv frame (frame `tm_star` tm_pure p) (continuation_elaborator_with_bind_nondep frame (comp_intro_pure p) st () h) (RU.magic ()) (RU.magic ()) post t let is_uvar (t:term) : bool = @@ -396,7 +400,9 @@ let prove_pure (g: env) (ctxt: list slprop_view) (skip_eq_uvar: bool) (goal: slp (fun frame -> let h1: slprop_equiv g'' (elab_slprops frame) (elab_slprops (frame @ [] @ [])) = RU.magic () in let h2: slprop_equiv g'' (tm_star (elab_slprops frame) (tm_pure p)) (elab_slprops (frame @ [goal])) = RU.magic () in - k_elab_equiv + k_elab_equiv + (elab_slprops (frame @ [] @ [])) + (elab_slprops (frame @ [goal])) (intro_pure g'' (elab_slprops frame) p p_typing pv) h1 h2) <: T.Tac _ |) @@ -416,7 +422,7 @@ let intro_with_pure (g: env) (frame: slprop) (p: term) (n: ppname) (v: term) : let typing: st_typing g st c = RU.magic () in let h: tot_typing g (tm_star frame (comp_pre c)) tm_slprop = RU.magic () in debug_prover g (fun _ -> Printf.sprintf "intro_pure p=%s\nframe=%s\n" (show p) (show frame)); - k_elab_equiv (continuation_elaborator_with_bind_nondep frame typing h) (RU.magic ()) (RU.magic ()) + k_elab_equiv (frame `tm_star` v) (frame `tm_star` tm_with_pure p n v) (continuation_elaborator_with_bind_nondep frame c st typing h) (RU.magic ()) (RU.magic ()) post t let prove_with_pure (g: env) (ctxt: list slprop_view) skip_eq_uvar (goal: slprop_view) : @@ -431,7 +437,7 @@ let prove_with_pure (g: env) (ctxt: list slprop_view) skip_eq_uvar (goal: slprop let h1: slprop_equiv g'' (tm_star (elab_slprops frame) v) (elab_slprops (frame @ [Unknown v] @ [])) = RU.magic () in let h2: slprop_equiv g'' (tm_star (elab_slprops frame) (tm_with_pure p n v)) (elab_slprops (frame @ [goal])) = RU.magic () in - k_elab_equiv (intro_with_pure g'' (elab_slprops frame) p n v) h1 h2) + k_elab_equiv (elab_slprops (frame @ [Unknown v] @ [])) (elab_slprops (frame @ [goal])) (intro_with_pure g'' (elab_slprops frame) p n v) h1 h2) <: T.Tac _ |) | _ -> None @@ -447,8 +453,9 @@ let intro_exists (g: env) (frame: slprop) (u: universe) (b: binder) (body: slpro let h1: tot_typing g (tm_star frame (comp_pre (comp_intro_exists u b body e))) tm_slprop = RU.magic () in let h2: slprop_equiv g (tm_star frame (comp_pre (comp_intro_exists u b body e))) (tm_star frame (open_term' body e 0)) = RU.magic () in let h3: slprop_equiv g (tm_star (comp_post (comp_intro_exists u b body e)) frame) (tm_star frame (tm_exists_sl u b body)) = RU.magic () in + let st = wtag (Some STT_Ghost) (Tm_ST { t = tm_unknown; args = [] }) in debug_prover g (fun _ -> Printf.sprintf "intro_exists %s\nframe=%s\n" (show (tm_exists_sl u b body)) (show frame)); - k_elab_equiv (continuation_elaborator_with_bind_nondep frame (() <: st_typing g _ (comp_intro_exists u b body e)) h1) h2 h3 + k_elab_equiv (frame `tm_star` open_term' body e 0) (frame `tm_star` tm_exists_sl u b body) (continuation_elaborator_with_bind_nondep frame (comp_intro_exists u b body e) st () h1) h2 h3 post t let prove_exists (g: env) (ctxt: list slprop_view) (goal: slprop_view) : @@ -462,7 +469,7 @@ let prove_exists (g: env) (ctxt: list slprop_view) (goal: slprop_view) : (fun frame -> let h1: slprop_equiv g'' (tm_star (elab_slprops frame) (open_term' body e 0)) (elab_slprops (frame @ [] @ [Unknown (open_term' body e 0)])) = RU.magic () in let h2: slprop_equiv g'' (tm_star (elab_slprops frame) (tm_exists_sl u b body)) (elab_slprops (frame @ [goal])) = RU.magic () in - k_elab_equiv (intro_exists g'' (elab_slprops frame) u b body e) h1 h2) + k_elab_equiv (elab_slprops (frame @ [] @ [Unknown (open_term' body e 0)])) (elab_slprops (frame @ [goal])) (intro_exists g'' (elab_slprops frame) u b body e) h1 h2) <: T.Tac _ |) | _ -> None @@ -527,10 +534,11 @@ let unreachable_elim_typing (g: env) (u: universe) (res: term) (post: term) : (| st, typing |) let unreachable_elim (g: env) (goals: list slprop_view) : cont_elab g [IsUnreachable] g goals = fun frame post t -> - let frame = elab_slprops frame in - let (| st, typing |) = unreachable_elim_typing g u0 tm_unit frame in - let h: tot_typing g (tm_star frame tm_is_unreachable) tm_slprop = RU.magic () in - k_elab_equiv (continuation_elaborator_with_bind_nondep frame typing h) (RU.magic ()) (RU.magic ()) + let frame_t = elab_slprops frame in + let c = C_STGhost tm_emp_inames { u=u0; res=tm_unit; pre=tm_is_unreachable; post=frame_t } in + let (| st, typing |) = unreachable_elim_typing g u0 tm_unit frame_t in + let h: tot_typing g (tm_star frame_t tm_is_unreachable) tm_slprop = RU.magic () in + k_elab_equiv (elab_slprops (frame @ [IsUnreachable])) (elab_slprops (frame @ goals)) (continuation_elaborator_with_bind_nondep frame_t c st typing h) (RU.magic ()) (RU.magic ()) post t let elim_is_unreachable (g: env) (ctxt goals: list slprop_view) : @@ -578,8 +586,8 @@ let elim_pure (g: env) (frame: slprop) (p: term) (x: nvar { ~(Set.mem (snd x) (d let h: tot_typing g (tm_star frame (comp_pre c)) tm_slprop = RU.magic () in let h2: slprop_equiv g' (tm_star (open_term_nv (comp_post c) x) frame) frame = RU.magic () in let k: continuation_elaborator g (tm_star frame (tm_pure p)) g' (tm_star tm_emp frame) = - continuation_elaborator_with_bind frame typing h x in - k_elab_equiv k (()) h2 post t + continuation_elaborator_with_bind frame c st typing h x in + k_elab_equiv (frame `tm_star` tm_pure p) frame k () h2 post t let elim_pure_step (g: env) (ctxt: slprop_view) : T.Tac (option (prover_result_nogoals g [ctxt])) = @@ -592,7 +600,7 @@ let elim_pure_step (g: env) (ctxt: slprop_view) : (fun frame -> let h1: slprop_equiv g (tm_star (elab_slprops frame) (tm_pure p)) (elab_slprops (frame @ [ctxt])) = RU.magic () in let h2: slprop_equiv g' (elab_slprops frame) (elab_slprops (frame @ [] @ [])) = RU.magic () in - k_elab_equiv (elim_pure g (elab_slprops frame) p x g') h1 h2), + k_elab_equiv (elab_slprops (frame @ [ctxt])) (elab_slprops (frame @ [] @ [])) (elim_pure g (elab_slprops frame) p x g') h1 h2), cont_elab_refl _ _ _ (()) <: T.Tac _ |) | _ -> None @@ -609,8 +617,8 @@ let elim_with_pure (g: env) (frame: slprop) (p: term) (x: nvar { ~(Set.mem (snd let h: tot_typing g (tm_star frame (comp_pre c)) tm_slprop = RU.magic () in let h2: slprop_equiv g' (tm_star (open_term_nv (comp_post c) x) frame) (tm_star frame v) = RU.magic () in let k: continuation_elaborator g (tm_star frame (tm_with_pure p (fst x) v)) g' (tm_star v frame) = - continuation_elaborator_with_bind frame typing h x in - k_elab_equiv k (()) h2 post t + continuation_elaborator_with_bind frame c st typing h x in + k_elab_equiv (frame `tm_star` tm_with_pure p (fst x) v) (frame `tm_star` v) k () h2 post t let elim_with_pure_step (g: env) (ctxt: slprop_view) : T.Tac (option (prover_result_nogoals g [ctxt])) = @@ -623,7 +631,7 @@ let elim_with_pure_step (g: env) (ctxt: slprop_view) : (fun frame -> let h1: slprop_equiv g (tm_star (elab_slprops frame) (tm_with_pure p (fst x) v)) (elab_slprops (frame @ [ctxt])) = RU.magic () in let h2: slprop_equiv g' (tm_star (elab_slprops frame) v) (elab_slprops (frame @ [Unknown v] @ [])) = RU.magic () in - k_elab_equiv (elim_with_pure g (elab_slprops frame) p x v g') h1 h2), + k_elab_equiv (elab_slprops (frame @ [ctxt])) (elab_slprops (frame @ [Unknown v] @ [])) (elim_with_pure g (elab_slprops frame) p x v g') h1 h2), cont_elab_refl _ _ _ (()) <: T.Tac _ |) | _ -> None @@ -636,14 +644,15 @@ let elim_exists (g: env) (frame: slprop) u b body (x: nvar { ~(Set.mem (snd x) ( let c = comp_elim_exists u b.binder_ty body x in let h1: tot_typing g b.binder_ty (tm_type u) = RU.magic () in let h2: tot_typing g (tm_exists_sl u (as_binder b.binder_ty) body) tm_slprop = RU.magic () in - let typing: st_typing g _ c = () in + let st : st_term = wtag (Some STT_Ghost) (Tm_ElimExists { p = tm_exists_sl u (as_binder b.binder_ty) body }) in + let typing: st_typing g st c = () in let h: tot_typing g (tm_star frame (comp_pre c)) tm_slprop = RU.magic () in let c_post_x = open_term' body (mk_reveal u b.binder_ty (term_of_nvar x)) 0 in assume open_term (comp_post c) (snd x) == c_post_x; let h2: slprop_equiv g' (tm_star c_post_x frame) (tm_star frame c_post_x) = RU.magic () in let k: continuation_elaborator g (tm_star frame (tm_exists_sl u b body)) g' (tm_star c_post_x frame) = - continuation_elaborator_with_bind frame typing h x in - k_elab_equiv k (()) h2 post t + continuation_elaborator_with_bind frame c st typing h x in + k_elab_equiv (frame `tm_star` tm_exists_sl u b body) (frame `tm_star` c_post_x) k () h2 post t let elim_exists_step (g: env) (ctxt: slprop_view) : T.Tac (option (prover_result_nogoals g [ctxt])) = @@ -659,7 +668,7 @@ let elim_exists_step (g: env) (ctxt: slprop_view) : (fun frame -> let h1: slprop_equiv g (tm_star (elab_slprops frame) (tm_exists_sl u b body)) (elab_slprops (frame @ [ctxt])) = RU.magic () in let h2: slprop_equiv g' (tm_star (elab_slprops frame) result) (elab_slprops (frame @ [] @ [Unknown result])) = RU.magic () in - k_elab_equiv (elim_exists g (elab_slprops frame) u b body x g') h1 h2), + k_elab_equiv (elab_slprops (frame @ [ctxt])) (elab_slprops (frame @ [] @ [Unknown result])) (elim_exists g (elab_slprops frame) u b body x g') h1 h2), cont_elab_refl _ _ _ (()) <: T.Tac _ |) | _ -> None @@ -693,8 +702,7 @@ let check_slprop_equiv_ext r (g:env) (p q:slprop) pp q; ] | Some token -> - () : slprop_equiv g p q - + () let on_name = R.inspect_fv (R.pack_fv <| Pulse.Reflection.Util.mk_pulse_lib_core_lid "on") let on_head_id : head_id = FVarHead on_name @@ -1031,7 +1039,7 @@ let try_apply_elim_lemma (g: env) (lid: R.name) (i: nat) (ctxt: slprop_view) : assume elab_slprop ctxt == pre; () in let h3: slprop_equiv g (elab_slprops [Unknown (open_term' (comp_post c) unit_const 0)]) (elab_slprops ([] @ [Unknown post'])) = () in - let k_t = cont_elab_with_bind_nondep_unit typing h1 in + let k_t = cont_elab_with_bind_nondep_unit c t' typing h1 in cont_elab_equiv k_t h2 h3, cont_elab_refl g'' ([] @ []) [] (()) |) ) else @@ -1073,7 +1081,7 @@ let try_apply_eager_intro_lemma (g: env) (lid: R.name) (i: nat) ctxt (goal: slpr let h1: tot_typing g'' (comp_pre c) tm_slprop = RU.magic () in let h2: slprop_equiv g'' (elab_slprops [Unknown (comp_pre c)]) (elab_slprops ([] @ [Unknown pre])) = () in let h3: slprop_equiv g'' (elab_slprops [Unknown (open_term' (comp_post c) unit_const 0)]) (elab_slprops [goal]) = RU.magic () in - let k_typing = cont_elab_with_bind_nondep_unit typing h1 in + let k_typing = cont_elab_with_bind_nondep_unit c t' typing h1 in cont_elab_refl g ctxt ([] @ ctxt) (()), cont_elab_equiv k_typing h2 h3 |) @@ -1180,7 +1188,7 @@ let try_apply_intro_lemma (g: env) (lid: R.name) (i: nat) ctxt (goal: slprop_vie let h3: slprop_equiv g' (elab_slprops (ctxt' @ [Unknown (open_term' (comp_post c) unit_const 0)])) (elab_slprops ([goal] @ ctxt' @ post''_rest)) = RU.magic () in - let k_typing = cont_elab_with_bind_nondep_unit typing h1 in + let k_typing = cont_elab_with_bind_nondep_unit c t' typing h1 in let k_typing = cont_elab_frame k_typing ctxt' in let k_typing: cont_elab g' (ctxt' @ [Unknown pre]) g' ([goal] @ ctxt' @ post''_rest) = cont_elab_equiv k_typing h2 h3 in @@ -1356,7 +1364,7 @@ let prove rng (g: env) (ctxt goals: slprop) allow_amb : let h: slprop_equiv g' (elab_slprops ([] @ ctxt' @ [Unknown goals])) (tm_star goals (RU.deep_compress_safe (elab_slprops ctxt'))) = RU.magic () in - (| g', RU.deep_compress_safe (elab_slprops ctxt'), k_elab_equiv (k []) (()) h |) + (| g', RU.deep_compress_safe (elab_slprops ctxt'), k_elab_equiv ctxt (tm_star goals (RU.deep_compress_safe (elab_slprops ctxt'))) (k []) () h |) let rec try_elim_core (pg: penv) (ctxt: list slprop_view) : T.Tac (prover_result_nogoals pg.penv_env ctxt) = @@ -1394,22 +1402,23 @@ let elim_exists_and_pure (#g:env) (#ctxt:slprop) let h2: slprop_equiv g' (elab_slprops (ctxt'' @ solved @ goals'')) (elab_slprops ([] @ solved @ ctxt'')) = RU.magic () in let h3: slprop_equiv g' (elab_slprops (ctxt'' @ [])) (elab_slprops ctxt'') = RU.magic () in let before, after = k g' in - k_elab_trans (k_elab_equiv (before []) h1 (())) - (k_elab_equiv (after ctxt'') h2 h3) post_hint post_hint_typ |) + k_elab_trans (k_elab_equiv ctxt (elab_slprops ([] @ solved @ ctxt'')) (before []) h1 (())) + (k_elab_equiv (elab_slprops ([] @ solved @ ctxt'')) (elab_slprops ctxt'') (after ctxt'') h2 h3) post_hint post_hint_typ |) let k_unreach (g: env) (x: nvar { freshv g (snd x) }) (post_hint: post_hint_t { g `env_extends` post_hint.g }) : T.Tac (continuation_elaborator g tm_is_unreachable (push_binding g (snd x) (fst x) post_hint.ret_ty) (open_term_nv post_hint.post x)) = let h: tot_typing g tm_is_unreachable tm_slprop = RU.magic () in let (| c, c_typ |) = Pulse.Typing.Combinators.comp_for_post_hint g tm_is_unreachable h post_hint (snd x) in - let typ : st_typing g _ c = () in + let st = wtag (Some STT_Ghost) (Tm_ST { t = tm_unknown; args = [] }) in + let typ : st_typing g st c = () in let g' = push_binding g (snd x) (fst x) post_hint.ret_ty in let post_opened = open_term_nv post_hint.post x in let k_elim: continuation_elaborator g (tm_star tm_emp tm_is_unreachable) g' (tm_star post_opened tm_emp) = let h3: tot_typing g (tm_star tm_emp tm_is_unreachable) tm_slprop = RU.magic () in - continuation_elaborator_with_bind #g tm_emp typ h3 x in + continuation_elaborator_with_bind #g tm_emp c st typ h3 x in let h4: slprop_equiv g (tm_star tm_emp tm_is_unreachable) tm_is_unreachable = RU.magic () in let h5: slprop_equiv g' (tm_star post_opened tm_emp) post_opened = RU.magic () in - k_elab_equiv k_elim h4 h5 + k_elab_equiv tm_is_unreachable post_opened k_elim h4 h5 #restart-solver #push-options "--z3rlimit_factor 2 --split_queries always" @@ -1474,7 +1483,7 @@ let prove_post_hint (#g:env) (#ctxt:slprop) (r:checker_result_t g ctxt NoHint) ( // for the typing of post_hint_opened, again post_hint is well-typed in g, and g3 `env_extends` g let h2: tot_typing g3 post_hint_opened tm_slprop = RU.magic () in (| x, g3, (| u_ty, ty, h1 |), (| post_hint_opened, h2 |), - k_elab_trans k (k_elab_equiv k_post (()) h3) |) + k_elab_trans k (k_elab_equiv ctxt' post_hint_opened k_post () h3) |) #pop-options let try_frame_pre (allow_ambiguous : bool) (#g:env) diff --git a/src/checker/Pulse.Checker.Return.fst b/src/checker/Pulse.Checker.Return.fst index 998493bfe..d2e07c0b3 100644 --- a/src/checker/Pulse.Checker.Return.fst +++ b/src/checker/Pulse.Checker.Return.fst @@ -135,13 +135,15 @@ let check_core let use_eq = use_eq || (not (PostHint? post_hint) && not (T.term_eq ty (`unit))) in assume (open_term (close_term post_opened x) x == post_opened); let post = close_term post_opened x in - let d : st_typing g _ _ = () in - let (|c',d'|) = match_comp_res_with_post_hint d post_hint in + let ret_st = wtag (Some c) (Tm_Return {expected_type=tm_unknown; insert_eq=use_eq; term=t}) in + let ret_c = comp_return c use_eq u ty t post x in + let d : st_typing g ret_st ret_c = () in + let (|c',d'|) = match_comp_res_with_post_hint ret_st ret_c d post_hint in Pulse.Checker.Util.debug g "pulse.return" (fun _ -> Printf.sprintf "Return comp is: %s" (Pulse.Syntax.Printer.comp_to_string c')); prove_post_hint #g - (try_frame_pre false #g ctxt_typing (|_,c',d'|) res_ppname) + (try_frame_pre false #g ctxt_typing (|ret_st,c',d'|) res_ppname) post_hint st.range #pop-options diff --git a/src/checker/Pulse.Checker.Rewrite.fst b/src/checker/Pulse.Checker.Rewrite.fst index 0a569780f..e64c5b6e7 100644 --- a/src/checker/Pulse.Checker.Rewrite.fst +++ b/src/checker/Pulse.Checker.Rewrite.fst @@ -39,7 +39,7 @@ let check_slprop_equiv_ext r (g:env) (p q:slprop) pp q; ] | Some token -> - () : slprop_equiv g p q + () let check_slprop_equiv_tac r (g:env) (p q:slprop) (tac_tm : term) : T.Tac (slprop_equiv g p q) @@ -75,7 +75,7 @@ let check_slprop_equiv_tac r (g:env) (p q:slprop) (tac_tm : term) text "Using tactic:" ^/^ pp tac_tm ] | Some token -> - () : slprop_equiv g p q + () let rec check_slprop_equiv r (g:env) (p q:slprop) : T.Tac (slprop_equiv g p q) @@ -137,6 +137,8 @@ let check (T.moduleof (fstar_env g)) "Pulse.Checker.Rewrite.check_slprop_equiv_tac" in - let d : st_typing g _ _ = () in - let (| c,d |) = match_comp_res_with_post_hint d post_hint in - prove_post_hint (try_frame_pre false pre_typing (| _,c,d |) res_ppname) post_hint t.range + let rew_st = wtag (Some STT_Ghost) (Tm_Rewrite { t1=p; t2=q; tac_opt=None; elaborated=true }) in + let rew_c = C_STGhost tm_emp_inames { u=u0; res=tm_unit; pre=p; post=q } in + let d : st_typing g rew_st rew_c = () in + let (| c,d |) = match_comp_res_with_post_hint rew_st rew_c d post_hint in + prove_post_hint (try_frame_pre false pre_typing (| rew_st,c,d |) res_ppname) post_hint t.range diff --git a/src/checker/Pulse.Checker.SLPropEquiv.fst b/src/checker/Pulse.Checker.SLPropEquiv.fst index 13574a9a1..1f853be08 100644 --- a/src/checker/Pulse.Checker.SLPropEquiv.fst +++ b/src/checker/Pulse.Checker.SLPropEquiv.fst @@ -69,8 +69,8 @@ let list_as_slprop_ctx g (vp0 vp0' vp1 vp1':list term) (d1:slprop_equiv g (list_as_slprop vp1) (list_as_slprop vp1')) : GTot (slprop_equiv g (list_as_slprop (vp0 @ vp1)) (list_as_slprop (vp0' @ vp1'))) - = let split_app = list_as_slprop_append _ vp0 vp1 in - let split_app' = list_as_slprop_append _ vp0' vp1' in + = let split_app = list_as_slprop_append g vp0 vp1 in + let split_app' = list_as_slprop_append g vp0' vp1' in () let list_as_slprop_singleton g @@ -89,7 +89,7 @@ let rec slprop_list_equiv (g:env) let eq0 = slprop_list_equiv g vp0 in let eq1 = slprop_list_equiv g vp1 in let app_eq - : slprop_equiv _ (canon_slprop vp) (tm_star (canon_slprop vp0) (canon_slprop vp1)) + : slprop_equiv g (canon_slprop vp) (tm_star (canon_slprop vp0) (canon_slprop vp1)) = list_as_slprop_append g (slprop_as_list vp0) (slprop_as_list vp1) in () @@ -128,20 +128,20 @@ let slprop_equiv_split_frame (g:_) (ctxt req:term) (frame:list term) let veq : slprop_equiv g (list_as_slprop (req_l @ frame)) (list_as_slprop ctxt_l) = veq in let d1 - : slprop_equiv _ (tm_star (canon_slprop req) (list_as_slprop frame)) + : slprop_equiv g (tm_star (canon_slprop req) (list_as_slprop frame)) (list_as_slprop (req_l @ frame)) = () in let d1 - : slprop_equiv _ (tm_star req (list_as_slprop frame)) + : slprop_equiv g (tm_star req (list_as_slprop frame)) (list_as_slprop (req_l @ frame)) = () in - let d : slprop_equiv _ (tm_star req (list_as_slprop frame)) + let d : slprop_equiv g (tm_star req (list_as_slprop frame)) (canon_slprop ctxt) = () in - let d : slprop_equiv _ (tm_star req (list_as_slprop frame)) + let d : slprop_equiv g (tm_star req (list_as_slprop frame)) ctxt = () in diff --git a/src/checker/Pulse.Checker.SLPropEquiv.fsti b/src/checker/Pulse.Checker.SLPropEquiv.fsti index b8051aa91..c797da3f9 100644 --- a/src/checker/Pulse.Checker.SLPropEquiv.fsti +++ b/src/checker/Pulse.Checker.SLPropEquiv.fsti @@ -65,14 +65,14 @@ val slprop_equiv_split_frame (g:_) (ctxt req:term) (frame:list term) let slprop_equiv_typing_fwd (#g:env) (#ctxt:_) (ctxt_typing:tot_typing g ctxt tm_slprop) - (#p:_) (d:slprop_equiv g ctxt p) + (p:_) (d:slprop_equiv g ctxt p) : tot_typing g p tm_slprop - = let fwd, _ = slprop_equiv_typing d in + = let fwd, _ = slprop_equiv_typing g ctxt p d in fwd ctxt_typing let slprop_equiv_typing_bk (#g:env) (#ctxt:_) (ctxt_typing:tot_typing g ctxt tm_slprop) - (#p:_) (d:slprop_equiv g p ctxt) + (p:_) (d:slprop_equiv g p ctxt) : tot_typing g p tm_slprop - = let _, bk = slprop_equiv_typing d in + = let _, bk = slprop_equiv_typing g p ctxt d in bk ctxt_typing diff --git a/src/checker/Pulse.Checker.ST.fst b/src/checker/Pulse.Checker.ST.fst index fccdee497..d21dc2f40 100644 --- a/src/checker/Pulse.Checker.ST.fst +++ b/src/checker/Pulse.Checker.ST.fst @@ -111,7 +111,7 @@ let check RU.record_stats "prove_post_hint" fun _ -> prove_post_hint framed post_hint range else // TODO: not sure why we need the type equality check below.. - let (| c, d |) = match_comp_res_with_post_hint d post_hint in + let (| c, d |) = match_comp_res_with_post_hint t c d post_hint in let framed = checker_result_for_st_typing (k _ (| t, add_frame c ctxt', () |)) res_ppname in RU.record_stats "prove_post_hint" fun _ -> prove_post_hint framed post_hint range ) diff --git a/src/checker/Pulse.Checker.While.fst b/src/checker/Pulse.Checker.While.fst index 4f5f36b88..9e4f726fd 100644 --- a/src/checker/Pulse.Checker.While.fst +++ b/src/checker/Pulse.Checker.While.fst @@ -274,7 +274,7 @@ let check_while let C_ST cst = comp_while u_meas ty_meas x_meas inv body_pre_open in let loop_pre = tm_exists_sl u_meas (as_binder ty_meas) (close_term inv (snd x_meas)) in assert comp_pre (comp_while u_meas ty_meas x_meas inv body_pre_open) == loop_pre; - let d_st : Pulse.Typing.Combinators.st_typing_in_ctxt g1' loop_pre NoHint = (| _, _, d |) in + let d_st : Pulse.Typing.Combinators.st_typing_in_ctxt g1' loop_pre NoHint = (| while, comp_while u_meas ty_meas x_meas inv body_pre_open, d |) in let res = checker_result_for_st_typing d_st ppname_default in assume (fresh_wrt x g0 (freevars break_pred)); let post_hint_for_while : post_hint_for_env g0 = { @@ -307,7 +307,7 @@ let check_while let fjl_d: st_typing g0 fjl while_comp = () in - let d_st: Pulse.Typing.Combinators.st_typing_in_ctxt g0 loop_pre (TypeHint tm_unit) = (| _, _, fjl_d |) in + let d_st: Pulse.Typing.Combinators.st_typing_in_ctxt g0 loop_pre (TypeHint tm_unit) = (| fjl, while_comp, fjl_d |) in let d_st: Pulse.Typing.Combinators.st_typing_in_ctxt g0 loop_pre0 (TypeHint tm_unit) = let (| t, c, _ |) = d_st in let c = with_st_comp c { st_comp_of_comp c with pre = loop_pre0 } in diff --git a/src/checker/Pulse.Checker.WithLocal.fst b/src/checker/Pulse.Checker.WithLocal.fst index b97e2896e..f38ad12ef 100644 --- a/src/checker/Pulse.Checker.WithLocal.fst +++ b/src/checker/Pulse.Checker.WithLocal.fst @@ -159,6 +159,6 @@ let check in assert (freshv g x); assert (~(Set.mem x (freevars_st body))); - let d : st_typing g _ c = () in - checker_result_for_st_typing (| _, _, d |) res_ppname + let st = wrst c (Tm_WithLocal { binder = mk_binder_ppname (mk_ref init_t) binder.binder_ppname; initializer=init; body }) in + checker_result_for_st_typing (| st, c, () |) res_ppname #pop-options diff --git a/src/checker/Pulse.Checker.WithLocalArray.fst b/src/checker/Pulse.Checker.WithLocalArray.fst index 198b20959..6717644a3 100644 --- a/src/checker/Pulse.Checker.WithLocalArray.fst +++ b/src/checker/Pulse.Checker.WithLocalArray.fst @@ -181,6 +181,6 @@ let check post_typing_rec.ty_typing x post_typing_rec.post_typing in - let d : st_typing g _ c = () in - checker_result_for_st_typing (| _, _, d |) res_ppname + let st = wrst c (Tm_WithLocalArray { binder = mk_binder_ppname (mk_array init_t) binder.binder_ppname; initializer=init; length=len; body }) in + checker_result_for_st_typing (| st, c, () |) res_ppname #pop-options diff --git a/src/checker/Pulse.Elaborate.Core.fst b/src/checker/Pulse.Elaborate.Core.fst index 257957d5e..51d650715 100644 --- a/src/checker/Pulse.Elaborate.Core.fst +++ b/src/checker/Pulse.Elaborate.Core.fst @@ -59,85 +59,12 @@ let elab_sub (c1 c2:comp_st) (e:R.term) = let elab_bind #g #x #c1 #c2 #c (bc:bind_comp g x c1 c2 c) (e1 e2:R.term) - : R.term - = let t1 = comp_res c1 in - let t2 = comp_res c2 in - match c1 with - | C_ST _ -> - mk_bind_stt - (comp_u c1) - (comp_u c2) - t1 t2 - (comp_pre c1) - (mk_abs t1 R.Q_Explicit (comp_post c1)) - (mk_abs t2 R.Q_Explicit (comp_post c2)) - e1 e2 - | C_STGhost inames _ -> - mk_bind_ghost - (comp_u c1) - (comp_u c2) - t1 t2 - inames - (comp_pre c1) - (mk_abs t1 R.Q_Explicit (comp_post c1)) - (mk_abs t2 R.Q_Explicit (comp_post c2)) - e1 e2 - | C_STAtomic inames obs1 _ -> - let C_STAtomic _ obs2 _ = c2 in - mk_bind_atomic - (comp_u c1) - (comp_u c2) - (elab_observability obs1) - (elab_observability obs2) - (comp_inames c1) - t1 t2 - (comp_pre c1) - (mk_abs t1 R.Q_Explicit (comp_post c1)) - (mk_abs t2 R.Q_Explicit (comp_post c2)) - e1 e2 + : GTot R.term + = RU.magic () let elab_lift #g #c1 #c2 (d:lift_comp g c1 c2) (e:R.term) : GTot R.term - = match d with - | Lift_STAtomic_ST _ _ -> - let t = comp_res c1 in - mk_lift_atomic_stt - (comp_u c1) - (comp_res c1) - t - (mk_abs t R.Q_Explicit (comp_post c1)) - e - - | Lift_Observability _ c o2 -> - let t = comp_res c1 in - mk_lift_observability - (comp_u c1) - (elab_observability (C_STAtomic?.obs c)) - (elab_observability o2) - (comp_inames c1) - t - (comp_pre c1) - (mk_abs t R.Q_Explicit (comp_post c1)) - e - - | Lift_Ghost_Neutral _ _ (| reveal_a, reveal_a_typing |) -> - let t = comp_res c1 in - mk_lift_ghost_neutral - (comp_u c1) - t - (comp_pre c1) - (mk_abs t R.Q_Explicit (comp_post c1)) - e - reveal_a - - | Lift_Neutral_Ghost _ c -> - let t = comp_res c1 in - mk_lift_neutral_ghost - (comp_u c1) - t - (comp_pre c1) - (mk_abs t R.Q_Explicit (comp_post c1)) - e + = RU.magic () let intro_pure_tm (p:term) = let open Pulse.Reflection.Util in diff --git a/src/checker/Pulse.JoinComp.fst b/src/checker/Pulse.JoinComp.fst index c787a7499..0b6307c88 100644 --- a/src/checker/Pulse.JoinComp.fst +++ b/src/checker/Pulse.JoinComp.fst @@ -412,13 +412,14 @@ let rec join_comps = let g = g_then in assert (st_comp_of_comp c_then == st_comp_of_comp c_else); match c_then, c_else with - | C_STAtomic _ obs1 _, C_STAtomic _ obs2 _ -> + | C_STAtomic inames obs1 st, C_STAtomic _ obs2 _ -> let obs = join_obs obs1 obs2 in - let e_then_typing : st_typing g_then e_then _ = () in - let e_else_typing : st_typing g_else e_else _ = () in - (| _, e_then_typing, e_else_typing |) + let c = C_STAtomic inames obs st in + let e_then_typing : st_typing g_then e_then c = () in + let e_else_typing : st_typing g_else e_else c = () in + (| c, e_then_typing, e_else_typing |) | C_STGhost _ _, C_STGhost _ _ - | C_ST _, C_ST _ -> (| _, e_then_typing, e_else_typing |) + | C_ST _, C_ST _ -> (| c_then, e_then_typing, e_else_typing |) | _ -> assert (EffectAnnotAtomicOrGhost? post.effect_annot); @@ -427,10 +428,10 @@ let rec join_comps let d : st_typing g_then e_then (st_ghost_as_atomic c_then) = () in st_ghost_as_atomic_matches_post_hint c_then post; - join_comps _ _ _ d _ _ _ e_else_typing post + join_comps g_then e_then (st_ghost_as_atomic c_then) d g_else e_else c_else e_else_typing post | C_STAtomic _ _ _, C_STGhost _ _ -> let d : st_typing g_else e_else (st_ghost_as_atomic c_else) = () in st_ghost_as_atomic_matches_post_hint c_else post; - join_comps _ _ _ e_then_typing _ _ _ d post + join_comps g_then e_then c_then e_then_typing g_else e_else (st_ghost_as_atomic c_else) d post #pop-options diff --git a/src/checker/Pulse.Typing.Combinators.fst b/src/checker/Pulse.Typing.Combinators.fst index 377034030..1f3a9e61e 100644 --- a/src/checker/Pulse.Typing.Combinators.fst +++ b/src/checker/Pulse.Typing.Combinators.fst @@ -49,125 +49,16 @@ val construct_forall_typing let st_equiv_trans (#g:env) (#c0 #c1 #c2:comp) (d01:st_equiv g c0 c1) (d12:st_equiv g c1 c2) : st_equiv g c0 c2 - = - match d01 with - | ST_SLPropEquiv _f _c0 _c1 x eq_res_01 eq_pre_01 eq_post_01 -> ( - let ST_SLPropEquiv _f _c1 _c2 y eq_res_12 eq_pre_12 eq_post_12 = d12 in - let eq_res_10 = RT.Rel_sym _ _ _ eq_res_01 in - let eq_post_12_x = Pulse.Typing.Metatheory.Base.slprop_equiv_rename y x _ _ eq_res_10 eq_post_12 in - Pulse.Typing.FV.freevars_open_term_both y (comp_post c2); - Pulse.Typing.Metatheory.Base.freevars_slprop_equiv eq_post_12; - assert ~(Set.mem x (freevars (comp_post c2))); - let eq = - ST_SLPropEquiv g c0 c2 x - (RT.Rel_trans _ _ _ _ _ eq_res_01 eq_res_12) - (VE_Trans _ _ _ _ eq_pre_01 eq_pre_12) - (VE_Trans _ _ _ _ eq_post_01 eq_post_12_x) - in - eq - ) - | ST_TotEquiv g t1 t2 u eq -> - let ST_TotEquiv _g _t1 t3 _ eq' = d12 in - let eq'' = Ghost.hide (RT.Rel_trans _ _ _ _ _ eq eq') in - ST_TotEquiv g t1 t3 u eq'' + = () -let t_equiv #g #st #c (d:st_typing g st c) (#c':comp) (eq:st_equiv g c c') +let t_equiv (g:env) (st:st_term) (c:comp) (d:st_typing g st c) (c':comp) (eq:st_equiv g c c') : st_typing g st c' - = match d with - | T_Equiv _ _ _ _ d0 eq' -> - T_Equiv _ _ _ _ d0 (st_equiv_trans eq' eq) - | _ -> T_Equiv _ _ _ _ d eq + = () -let rec slprop_equiv_typing (#g:_) (#t0 #t1:term) (v:slprop_equiv g t0 t1) +let slprop_equiv_typing (g:env) (t0 t1:term) (v:slprop_equiv g t0 t1) : GTot ((tot_typing g t0 tm_slprop -> tot_typing g t1 tm_slprop) & (tot_typing g t1 tm_slprop -> tot_typing g t0 tm_slprop)) - (decreases v) - = match v with - | VE_Refl _ _ -> (fun x -> x), (fun x -> x) - - | VE_Sym _ _ _ v' -> - let f, g = slprop_equiv_typing v' in - g, f - - | VE_Trans g t0 t2 t1 v02 v21 -> - let f02, f20 = slprop_equiv_typing v02 in - let f21, f12 = slprop_equiv_typing v21 in - (fun x -> f21 (f02 x)), - (fun x -> f20 (f12 x)) - - | VE_Ctxt g s0 s1 s0' s1' v0 v1 -> - let f0, f0' = slprop_equiv_typing v0 in - let f1, f1' = slprop_equiv_typing v1 in - let ff (x:tot_typing g (tm_star s0 s1) tm_slprop) - : tot_typing g (tm_star s0' s1') tm_slprop - = let s0_typing = star_typing_inversion_l x in - let s1_typing = star_typing_inversion_r x in - let s0'_typing, s1'_typing = f0 s0_typing, f1 s1_typing in - star_typing s0'_typing s1'_typing - in - let gg (x:tot_typing g (tm_star s0' s1') tm_slprop) - : tot_typing g (tm_star s0 s1) tm_slprop - = let s0'_typing = star_typing_inversion_l x in - let s1'_typing = star_typing_inversion_r x in - star_typing (f0' s0'_typing) (f1' s1'_typing) - in - ff, gg - - | VE_Unit g t -> - let fwd (x:tot_typing g (tm_star tm_emp t) tm_slprop) - : tot_typing g t tm_slprop - = let r = star_typing_inversion_r x in - r - in - let bk (x:tot_typing g t tm_slprop) - : tot_typing g (tm_star tm_emp t) tm_slprop - = star_typing emp_typing x - in - fwd, bk - - | VE_Comm g t0 t1 -> - let f t0 t1 (x:tot_typing g (tm_star t0 t1) tm_slprop) - : tot_typing g (tm_star t1 t0) tm_slprop - = let tt0 = star_typing_inversion_l x in - let tt1 = star_typing_inversion_r x in - star_typing tt1 tt0 - in - f t0 t1, f t1 t0 - - | VE_Assoc g t0 t1 t2 -> - let fwd (x:tot_typing g (tm_star t0 (tm_star t1 t2)) tm_slprop) - : tot_typing g (tm_star (tm_star t0 t1) t2) tm_slprop - = let tt0 = star_typing_inversion_l x in - let tt12 = star_typing_inversion_r x in - let tt1 = star_typing_inversion_l tt12 in - let tt2 = star_typing_inversion_r tt12 in - star_typing (star_typing tt0 tt1) tt2 - in - let bk (x : tot_typing g (tm_star (tm_star t0 t1) t2) tm_slprop) - : tot_typing g (tm_star t0 (tm_star t1 t2)) tm_slprop - = let tt01 = star_typing_inversion_l x in - let tt2 = star_typing_inversion_r x in - let tt0 = star_typing_inversion_l tt01 in - let tt1 = star_typing_inversion_r tt01 in - star_typing tt0 (star_typing tt1 tt2) - in - fwd, bk - - | VE_Ext g t0 t1 token -> - let d1, d2 = slprop_eq_typing_inversion g t0 t1 token in - (fun _ -> d2), - (fun _ -> d1) - - | VE_Fa g x u b t0 t1 d -> - let d0, d1 = slprop_equiv_typing d in - (fun fa0_typing -> - let b_typing, t0_typing = invert_forall_typing fa0_typing x in - let t1_typing = d0 t0_typing in - construct_forall_typing #g #u x b_typing t1_typing), - (fun fa1_typing -> - let b_typing, t1_typing = invert_forall_typing fa1_typing x in - let t0_typing = d1 t1_typing in - construct_forall_typing #g #u #b #t0 x b_typing t0_typing) + = (fun _ -> ()), (fun _ -> ()) let bind_t (case_c1 case_c2:comp_st -> bool) = (g:env) -> @@ -203,8 +94,9 @@ let mk_bind_st_st = fun g pre e1 e2 c1 c2 px d_e1 d_c1res d_e2 res_typing post_typing _ -> let _, x = px in let b = nvar_as_binder px (comp_res c1) in - let bc = Bind_comp g x c1 c2 x in - (| _, _, T_Bind _ e1 e2 _ _ b _ _ d_e1 d_e2 bc |) + let c : comp_st = C_ST (st_comp_with_pre (st_comp_of_comp c2) pre) in + let t = wrst c (Tm_Bind {binder=b; head=e1; body=e2}) in + (| t, c, () |) #pop-options let inames_of (c:comp_st) : term = match c with @@ -224,34 +116,24 @@ let weaken_comp_inames (#g:env) (#e:st_term) (#c:comp_st) (d_e:st_typing g e c) = match c with | C_ST _ -> (| c, d_e |) | C_STGhost inames sc -> - let pv = check_prop_validity _ _ (tm_inames_subset_typing _ _ _) in - let d_e = T_Sub _ _ _ _ d_e (STS_GhostInvs _ sc inames new_inames pv) in - (| with_inames c new_inames, d_e |) + let _ = check_prop_validity g _ (tm_inames_subset_typing g inames new_inames) in + (| with_inames c new_inames, () |) | C_STAtomic inames obs sc -> - let pv = check_prop_validity _ _ (tm_inames_subset_typing _ _ _) in - let d_e = T_Sub _ _ _ _ d_e (STS_AtomicInvs _ sc inames new_inames obs obs pv) in - (| with_inames c new_inames, d_e |) + let _ = check_prop_validity g _ (tm_inames_subset_typing g inames new_inames) in + (| with_inames c new_inames, () |) -let try_lift_ghost_atomic (#g:env) (#e:st_term) (#c:comp_st { C_STGhost? c }) (d:st_typing g e c) +let try_lift_ghost_atomic (g:env) (e:st_term) (c:comp_st { C_STGhost? c }) (d:st_typing g e c) : T.Tac (option (st_typing g e (st_ghost_as_atomic c))) -= let comp_res_typing : universe_of g (comp_res c) (comp_u c) = - let open Metatheory in - let d = st_typing_correctness d in - let d, _ = comp_typing_inversion d in - let (| d, _, _, _ |) = st_comp_typing_inversion d in - d - in += let comp_res_typing : universe_of g (comp_res c) (comp_u c) = () in let w = try_get_non_informative_witness g (comp_u c) (comp_res c) comp_res_typing in match w with | None -> None - | Some w -> - let d = T_Lift _ _ _ _ d (Lift_Ghost_Neutral _ c w) in - Some d + | Some w -> Some () -let lift_ghost_atomic (#g:env) (#e:st_term) (#c:comp_st { C_STGhost? c }) (d:st_typing g e c) +let lift_ghost_atomic (g:env) (e:st_term) (c:comp_st { C_STGhost? c }) (d:st_typing g e c) : T.Tac (st_typing g e (st_ghost_as_atomic c)) -= let w = try_lift_ghost_atomic d in += let w = try_lift_ghost_atomic g e c d in match w with | None -> let open Pulse.PP in @@ -274,27 +156,24 @@ let mk_bind_ghost_ghost : bind_t C_STGhost? C_STGhost? = let C_STGhost inames2 sc2 = c2 in if eq_tm inames1 inames2 then begin - let bc = Bind_comp g x c1 c2 x in - (| _, _, T_Bind _ e1 e2 _ _ b _ _ d_e1 d_e2 bc |) + let c : comp_st = C_STGhost inames1 (st_comp_with_pre sc2 pre) in + let t = wrst c (Tm_Bind {binder=b; head=e1; body=e2}) in + (| t, c, () |) end else if (PostHint? post_hint) then ( - let pv = check_prop_validity _ _ (tm_inames_subset_typing _ _ _) in - let d_e1 = T_Sub _ _ _ _ d_e1 (STS_GhostInvs _ sc1 inames1 inames2 pv) in - let c1 = C_STGhost inames2 sc1 in - let bc = Bind_comp g x c1 c2 x in - (| _, _, T_Bind _ e1 e2 _ _ b _ _ d_e1 d_e2 bc |) + let _ = check_prop_validity g _ (tm_inames_subset_typing g inames1 inames2) in + let c : comp_st = C_STGhost inames2 (st_comp_with_pre sc2 pre) in + let t = wrst c (Tm_Bind {binder=b; head=e1; body=e2}) in + (| t, c, () |) ) else begin let new_inames = tm_join_inames inames1 inames2 in - let pv1 = check_prop_validity _ _ (tm_inames_subset_typing _ _ _) in - let pv2 = check_prop_validity _ _ (tm_inames_subset_typing _ _ _) in - let d_e1 = T_Sub _ _ _ _ d_e1 (STS_GhostInvs _ sc1 inames1 new_inames pv1) in - let d_e2 = T_Sub _ _ _ _ d_e2 (STS_GhostInvs _ sc2 inames2 new_inames pv2) in - let c1 = C_STGhost new_inames sc1 in - let c2 = C_STGhost new_inames sc2 in - let bc = Bind_comp g x c1 c2 x in - (| _, _, T_Bind _ e1 e2 _ _ b _ _ d_e1 d_e2 bc |) + let _ = check_prop_validity g _ (tm_inames_subset_typing g inames1 new_inames) in + let _ = check_prop_validity g _ (tm_inames_subset_typing g inames2 new_inames) in + let c : comp_st = C_STGhost new_inames (st_comp_with_pre sc2 pre) in + let t = wrst c (Tm_Bind {binder=b; head=e1; body=e2}) in + (| t, c, () |) end let mk_bind_atomic_atomic @@ -308,27 +187,24 @@ let mk_bind_atomic_atomic then ( if eq_tm inames1 inames2 then begin - let bc = Bind_comp g x c1 c2 x in - (| _, _, T_Bind _ e1 e2 _ _ b _ _ d_e1 d_e2 bc |) + let c : comp_st = C_STAtomic inames1 (join_obs obs1 obs2) (st_comp_with_pre sc2 pre) in + let t = wrst c (Tm_Bind {binder=b; head=e1; body=e2}) in + (| t, c, () |) end else if (PostHint? post_hint) then ( - let pv = check_prop_validity _ _ (tm_inames_subset_typing _ _ _) in - let d_e1 = T_Sub _ _ _ _ d_e1 (STS_AtomicInvs _ sc1 inames1 inames2 obs1 obs1 pv) in - let c1 = C_STAtomic inames2 obs1 sc1 in - let bc = Bind_comp g x c1 c2 x in - (| _, _, T_Bind _ e1 e2 _ _ b _ _ d_e1 d_e2 bc |) + let _ = check_prop_validity g _ (tm_inames_subset_typing g inames1 inames2) in + let c : comp_st = C_STAtomic inames2 (join_obs obs1 obs2) (st_comp_with_pre sc2 pre) in + let t = wrst c (Tm_Bind {binder=b; head=e1; body=e2}) in + (| t, c, () |) ) else begin let new_inames = tm_join_inames inames1 inames2 in - let pv1 = check_prop_validity _ _ (tm_inames_subset_typing _ _ _) in - let pv2 = check_prop_validity _ _ (tm_inames_subset_typing _ _ _) in - let d_e1 = T_Sub _ _ _ _ d_e1 (STS_AtomicInvs _ sc1 inames1 new_inames obs1 obs1 pv1) in - let d_e2 = T_Sub _ _ _ _ d_e2 (STS_AtomicInvs _ sc2 inames2 new_inames obs2 obs2 pv2) in - let c1 = C_STAtomic new_inames obs1 sc1 in - let c2 = C_STAtomic new_inames obs2 sc2 in - let bc = Bind_comp g x c1 c2 x in - (| _, _, T_Bind _ e1 e2 _ _ b _ _ d_e1 d_e2 bc |) + let _ = check_prop_validity g _ (tm_inames_subset_typing g inames1 new_inames) in + let _ = check_prop_validity g _ (tm_inames_subset_typing g inames2 new_inames) in + let c : comp_st = C_STAtomic new_inames (join_obs obs1 obs2) (st_comp_with_pre sc2 pre) in + let t = wrst c (Tm_Bind {binder=b; head=e1; body=e2}) in + (| t, c, () |) end ) else ( @@ -391,34 +267,32 @@ let rec mk_bind (g:env) else if (PostHint? post_hint) then fail_bias "atomic" else ( - let d_e1 = T_Lift _ _ _ _ d_e1 (Lift_STAtomic_ST _ c1) in - mk_bind g pre e1 e2 _ c2 px d_e1 d_c1res d_e2 res_typing post_typing post_hint + mk_bind g pre e1 e2 (C_ST (st_comp_of_comp c1)) c2 px () d_c1res d_e2 res_typing post_typing post_hint ) | C_STAtomic inames _ _, C_ST _ -> - let d_e1 = T_Lift _ _ _ _ d_e1 (Lift_STAtomic_ST _ c1) in - mk_bind g pre e1 e2 _ c2 px d_e1 d_c1res d_e2 res_typing post_typing post_hint + mk_bind g pre e1 e2 (C_ST (st_comp_of_comp c1)) c2 px () d_c1res d_e2 res_typing post_typing post_hint | C_ST _, C_STAtomic inames _ _ -> if (PostHint? post_hint) then fail_bias "atomic" else ( - let d_e2 = T_Lift _ _ _ _ d_e2 (Lift_STAtomic_ST _ c2) in - let (| t, c, d |) = mk_bind g pre e1 e2 _ _ px d_e1 d_c1res d_e2 res_typing post_typing post_hint in + let c2_lifted = C_ST (st_comp_of_comp c2) in + let (| t, c, d |) = mk_bind g pre e1 e2 c1 c2_lifted px () d_c1res () res_typing post_typing post_hint in (| t, c, d |) ) | C_STGhost _ _, C_STAtomic _ Neutral _ -> ( - match try_lift_ghost_atomic d_e1 with - | Some d_e1 -> - mk_bind g pre e1 e2 _ c2 px d_e1 d_c1res d_e2 res_typing post_typing post_hint + match try_lift_ghost_atomic g e1 c1 d_e1 with + | Some _ -> + mk_bind g pre e1 e2 (st_ghost_as_atomic c1) c2 px () d_c1res d_e2 res_typing post_typing post_hint | None -> match post_hint with | TypeHint _ | NoHint | PostHint { effect_annot = EffectAnnotAtomicOrGhost _ } -> - let d_e2 = T_Lift _ _ _ _ d_e2 (Lift_Neutral_Ghost _ c2) in - let (| t, c, d |) = mk_bind g pre e1 e2 _ _ px d_e1 d_c1res d_e2 res_typing post_typing post_hint in + let c2_lifted = C_STGhost (comp_inames c2) (st_comp_of_comp c2) in + let (| t, c, d |) = mk_bind g pre e1 e2 c1 c2_lifted px () d_c1res () res_typing post_typing post_hint in (| t, c, d |) | _ -> fail_bias "atomic" ) @@ -428,31 +302,33 @@ let rec mk_bind (g:env) | TypeHint _ | NoHint | PostHint { effect_annot = EffectAnnotGhost _ } -> - let d_e1 = T_Lift _ _ _ _ d_e1 (Lift_Neutral_Ghost _ c1) in - mk_bind g pre e1 e2 _ c2 px d_e1 d_c1res d_e2 res_typing post_typing post_hint + let c1_lifted = C_STGhost (comp_inames c1) (st_comp_of_comp c1) in + mk_bind g pre e1 e2 c1_lifted c2 px () d_c1res d_e2 res_typing post_typing post_hint | _ -> - match try_lift_ghost_atomic d_e2 with - | Some d_e2 -> - let (| t, c, d |) = mk_bind g pre e1 e2 _ _ px d_e1 d_c1res d_e2 res_typing post_typing post_hint in + match try_lift_ghost_atomic (push_binding g (snd px) (fst px) (comp_res c1)) (open_st_term_nv e2 px) c2 d_e2 with + | Some _ -> + let c2_lifted = st_ghost_as_atomic c2 in + let (| t, c, d |) = mk_bind g pre e1 e2 c1 c2_lifted px () d_c1res () res_typing post_typing post_hint in (| t, c, d |) | None -> - let d_e1 = T_Lift _ _ _ _ d_e1 (Lift_Neutral_Ghost _ c1) in - mk_bind g pre e1 e2 _ c2 px d_e1 d_c1res d_e2 res_typing post_typing post_hint + let c1_lifted = C_STGhost (comp_inames c1) (st_comp_of_comp c1) in + mk_bind g pre e1 e2 c1_lifted c2 px () d_c1res d_e2 res_typing post_typing post_hint ) | C_STGhost _ _, C_ST _ | C_STGhost _ _, C_STAtomic _ _ _ -> - let d_e1 = lift_ghost_atomic d_e1 in - mk_bind g pre e1 e2 _ c2 px d_e1 d_c1res d_e2 res_typing post_typing post_hint + let _ = lift_ghost_atomic g e1 c1 d_e1 in + mk_bind g pre e1 e2 (st_ghost_as_atomic c1) c2 px () d_c1res d_e2 res_typing post_typing post_hint | C_ST _, C_STGhost _ _ | C_STAtomic _ _ _, C_STGhost _ _ -> if (PostHint? post_hint) then fail_bias "ghost" else ( - let d_e2 = lift_ghost_atomic d_e2 in - let (| t, c, d |) = mk_bind g pre e1 e2 _ _ px d_e1 d_c1res d_e2 res_typing post_typing post_hint in + let _ = lift_ghost_atomic (push_binding g (snd px) (fst px) (comp_res c1)) (open_st_term_nv e2 px) c2 d_e2 in + let c2_lifted = st_ghost_as_atomic c2 in + let (| t, c, d |) = mk_bind g pre e1 e2 c1 c2_lifted px () d_c1res () res_typing post_typing post_hint in (| t, c, d |) ) | _ -> T.fail "Impossible: unexpected combination of effects" @@ -481,21 +357,21 @@ let bind_res_and_post_typing g c2 x post_hint let pr = post_hint_typing g post x in pr.ty_typing, pr.post_typing -let add_frame (#g:env) (#t:st_term) (#c:comp_st) (t_typing:st_typing g t c) - (#frame:slprop) +let add_frame (g:env) (t:st_term) (c:comp_st) (t_typing:st_typing g t c) + (frame:slprop) (frame_typing:tot_typing g frame tm_slprop) : t':st_term & c':comp_st { c' == add_frame c frame } & st_typing g t' c' = - (| t, add_frame c frame, T_Frame _ _ _ _ t_typing |) + (| t, add_frame c frame, () |) #push-options "--fuel 0 --ifuel 0" -let apply_frame (#g:env) - (#t:st_term) - (#ctxt:term) +let apply_frame (g:env) + (t:st_term) + (ctxt:term) (ctxt_typing: tot_typing g ctxt tm_slprop) - (#c:comp { stateful_comp c }) + (c:comp { stateful_comp c }) (t_typing: st_typing g t c) (frame_t:frame_for_req_in_ctxt g ctxt (comp_pre c)) : Dv (c':comp_st { comp_pre c' == ctxt /\ @@ -505,25 +381,16 @@ let apply_frame (#g:env) st_typing g t c') = let s = st_comp_of_comp c in let (| frame, frame_typing, ve |) = frame_t in - let t_typing - : st_typing g t (Pulse.Typing.add_frame c frame) - = T_Frame g t c frame t_typing in let c' = Pulse.Typing.add_frame c frame in - let c'_typing = Metatheory.st_typing_correctness t_typing in let s' = st_comp_of_comp c' in - let ve: slprop_equiv g s'.pre ctxt = ve in let s'' = { s' with pre = ctxt } in let c'' = c' `with_st_comp` s'' in assert (comp_post c' == comp_post c''); - let ve: slprop_equiv g (comp_pre c') (comp_pre c'') = ve in - let st_typing = fst <| Metatheory.comp_typing_inversion c'_typing in - let (| _, _, x, _ |) = Metatheory.st_comp_typing_inversion st_typing in - let st_equiv = ST_SLPropEquiv g c' c'' x (RT.Rel_refl _ _ _) ve (VE_Refl _ _) in - let t_typing = t_equiv t_typing st_equiv in - (| c'', t_typing |) + (| c'', () |) +#pop-options #push-options "--z3rlimit_factor 2" -let comp_for_post_hint #g (#pre:slprop) (pre_typing:tot_typing g pre tm_slprop) +let comp_for_post_hint (g:env) (pre:slprop) (pre_typing:tot_typing g pre tm_slprop) (post:post_hint_t { g `env_extends` post.g }) (x:var { freshv g x }) : T.Tac (c:comp_st { comp_pre c == pre /\ comp_post_matches_hint c (PostHint post) } & @@ -532,20 +399,13 @@ let comp_for_post_hint #g (#pre:slprop) (pre_typing:tot_typing g pre tm_slprop) if x `Set.mem` freevars post.post then fail g None "Impossible: unexpected freevar clash in comp_for_post_hint, please file a bug-report"; - let px = v_as_nv x in - let post_typing_rec = post_hint_typing g post x in - let post_opened = open_term_nv post.post px in - assume (close_term post_opened x == post.post); let s : st_comp = {u=post.u;res=post.ret_ty;pre;post=post.post} in - let d_s : st_comp_typing _ s = - STC _ s x in - match post.effect_annot with - | EffectAnnotSTT -> (| _, CT_ST _ _ d_s |) + | EffectAnnotSTT -> (| C_ST s, () |) | EffectAnnotGhost { opens } -> - (| _, CT_STGhost _ opens _ d_s |) + (| C_STGhost opens s, () |) | EffectAnnotAtomic { opens } | EffectAnnotAtomicOrGhost { opens } -> - (| _, CT_STAtomic _ opens Neutral _ d_s |) + (| C_STAtomic opens Neutral s, () |) | _ -> T.fail "Impossible" #pop-options \ No newline at end of file diff --git a/src/checker/Pulse.Typing.Combinators.fsti b/src/checker/Pulse.Typing.Combinators.fsti index 72c762336..39d59c5df 100644 --- a/src/checker/Pulse.Typing.Combinators.fsti +++ b/src/checker/Pulse.Typing.Combinators.fsti @@ -26,17 +26,17 @@ let st_comp_with_pre (st:st_comp) (pre:term) : st_comp = { st with pre } let nvar_as_binder (x:nvar) (t:term) : binder = mk_binder_ppname t (fst x) -val t_equiv #g #st #c (d:st_typing g st c) (#c':comp) (eq:st_equiv g c c') +val t_equiv (g:env) (st:st_term) (c:comp) (d:st_typing g st c) (c':comp) (eq:st_equiv g c c') : st_typing g st c' -val slprop_equiv_typing (#g:_) (#t0 #t1:term) (v:slprop_equiv g t0 t1) +val slprop_equiv_typing (g:env) (t0 t1:term) (v:slprop_equiv g t0 t1) : GTot ((tot_typing g t0 tm_slprop -> tot_typing g t1 tm_slprop) & (tot_typing g t1 tm_slprop -> tot_typing g t0 tm_slprop)) let st_ghost_as_atomic (c:comp_st { C_STGhost? c }) = C_STAtomic (comp_inames c) Neutral (st_comp_of_comp c) -val lift_ghost_atomic (#g:env) (#e:st_term) (#c:comp_st { C_STGhost? c }) (d:st_typing g e c) +val lift_ghost_atomic (g:env) (e:st_term) (c:comp_st { C_STGhost? c }) (d:st_typing g e c) : T.Tac (st_typing g e (st_ghost_as_atomic c)) val mk_bind (g:env) @@ -73,8 +73,8 @@ val bind_res_and_post_typing (g:env) (s2:comp_st) (x:var { fresh_wrt x g (freeva : T.Tac (universe_of g (comp_res s2) (comp_u s2) & tot_typing (push_binding g x ppname_default (comp_res s2)) (open_term_nv (comp_post s2) (v_as_nv x)) tm_slprop) -val add_frame (#g:env) (#t:st_term) (#c:comp_st) (t_typing:st_typing g t c) - (#frame:slprop) +val add_frame (g:env) (t:st_term) (c:comp_st) (t_typing:st_typing g t c) + (frame:slprop) (frame_typing:tot_typing g frame tm_slprop) : t':st_term & c':comp_st { c' == add_frame c frame } & @@ -88,11 +88,11 @@ let frame_for_req_in_ctxt (g:env) (ctxt:term) (req:term) let frame_of #g #ctxt #req (f:frame_for_req_in_ctxt g ctxt req) = let (| frame, _, _ |) = f in frame -val apply_frame (#g:env) - (#t:st_term) - (#ctxt:term) +val apply_frame (g:env) + (t:st_term) + (ctxt:term) (ctxt_typing: tot_typing g ctxt tm_slprop) - (#c:comp { stateful_comp c }) + (c:comp { stateful_comp c }) (t_typing: st_typing g t c) (frame_t:frame_for_req_in_ctxt g ctxt (comp_pre c)) : Dv (c':comp_st { comp_pre c' == ctxt /\ @@ -106,7 +106,7 @@ type st_typing_in_ctxt (g:env) (ctxt:slprop) (post_hint:post_hint_opt g) = c:comp_st { comp_pre c == ctxt /\ comp_post_matches_hint c post_hint } & st_typing g t c -val comp_for_post_hint #g (#pre:slprop) (pre_typing:tot_typing g pre tm_slprop) +val comp_for_post_hint (g:env) (pre:slprop) (pre_typing:tot_typing g pre tm_slprop) (post:post_hint_t { g `env_extends` post.g }) (x:var { freshv g x }) : T.Tac (c:comp_st { comp_pre c == pre /\ comp_post_matches_hint c (PostHint post) } & diff --git a/src/checker/Pulse.Typing.FV.fst b/src/checker/Pulse.Typing.FV.fst index 2c49bafd2..ebc5a3d2c 100644 --- a/src/checker/Pulse.Typing.FV.fst +++ b/src/checker/Pulse.Typing.FV.fst @@ -289,51 +289,29 @@ let tot_or_ghost_typing_freevars = admit () let tot_typing_freevars - (#g:_) (#t:_) (#ty:_) + (g:_) (t:_) (ty:_) (d:tot_typing g t ty) : Lemma (ensures freevars t `Set.subset` vars_of_env g /\ freevars ty `Set.subset` vars_of_env g) = admit () -#push-options "--z3rlimit 10" -let bind_comp_freevars (#g:_) (#x:_) (#c1 #c2 #c:_) +let bind_comp_freevars (g:_) (x:_) (c1:_) (c2:_) (c:_) (d:bind_comp g x c1 c2 c) : Lemma (requires freevars_comp c1 `Set.subset` vars_of_env g /\ freevars_comp c2 `Set.subset` (Set.union (vars_of_env g) (Set.singleton x))) (ensures freevars_comp c `Set.subset` vars_of_env g) - = match d with - | Bind_comp _ _ _ _ _ -> admit () -#pop-options + = admit () -let rec slprop_equiv_freevars (#g:_) (#t0 #t1:_) (v:slprop_equiv g t0 t1) +let slprop_equiv_freevars (g:_) (t0:_) (t1:_) (v:slprop_equiv g t0 t1) : Lemma (ensures (freevars t0 `Set.subset` vars_of_env g) <==> (freevars t1 `Set.subset` vars_of_env g)) - (decreases v) - = assume False; // TODO: AR - match v with - | VE_Refl _ _ -> () - | VE_Sym _ _ _ v' -> - slprop_equiv_freevars v' - | VE_Trans g t0 t2 t1 v02 v21 -> - slprop_equiv_freevars v02; - slprop_equiv_freevars v21 - | VE_Ctxt g s0 s1 s0' s1' v0 v1 -> - slprop_equiv_freevars v0; - slprop_equiv_freevars v1 - | VE_Unit g t -> () - | VE_Comm g t0 t1 -> () - | VE_Assoc g t0 t1 t2 -> () - | VE_Ext g t0 t1 token -> - admit () - | VE_Fa g x u b t0 t1 d -> - slprop_equiv_freevars d; - close_open_inverse t0 x + = admit () -let st_equiv_freevars #g (#c1 #c2:_) +let st_equiv_freevars (g:_) (c1:_) (c2:_) (d:st_equiv g c1 c2) : Lemma (requires freevars_comp c1 `Set.subset` vars_of_env g) @@ -346,41 +324,28 @@ let prop_validity_fv (g:env) (p:term) (ensures freevars p `Set.subset` vars_of_env g) = admit() -let rec st_sub_freevars #g (#c1 #c2:_) +let st_sub_freevars (g:_) (c1:_) (c2:_) (d:st_sub g c1 c2) : Lemma (requires freevars_comp c1 `Set.subset` vars_of_env g) (ensures freevars_comp c2 `Set.subset` vars_of_env g) - (decreases d) -= - match d with - | STS_Refl _ _ -> () - | STS_Trans _ _ _ _ d1 d2 -> - st_sub_freevars d1; - st_sub_freevars d2 - | STS_GhostInvs _ _ is1 is2 tok - | STS_AtomicInvs _ _ is1 is2 _ _ tok -> - assume (freevars is2 `Set.subset` freevars (tm_inames_subset is1 is2)); - prop_validity_fv g (tm_inames_subset is1 is2) + = admit () let src_typing_freevars_t (d':'a) = - (#g:_) -> (#t:_) -> (#c:_) -> (d:st_typing g t c { d << d' }) -> + (g:_) -> (t:_) -> (c:_) -> (d:st_typing g t c { d << d' }) -> Lemma (ensures freevars_st t `Set.subset` vars_of_env g /\ freevars_comp c `Set.subset` vars_of_env g) -let st_comp_typing_freevars #g #st (d:st_comp_typing g st) +let st_comp_typing_freevars (g:_) (st:_) (d:st_comp_typing g st) : Lemma (ensures freevars_st_comp st `Set.subset` vars_of_env g) - (decreases d) - = let STC _ _ x = d in - admit () + = admit () -let comp_typing_freevars (#g:_) (#c:_) (#u:_) +let comp_typing_freevars (g:_) (c:_) (u:_) (d:comp_typing g c u) : Lemma (ensures freevars_comp c `Set.subset` vars_of_env g) - (decreases d) = admit () let freevars_open_st_term_inv (e:st_term) @@ -452,141 +417,10 @@ let freevars_array (t:term) (** Big lemma follows. We have to split it to make it digestible to SMT. *) -let st_typing_freevars_cb_t - (#g0:_) (#t0:_) (#c0:_) - (d0:st_typing g0 t0 c0) -= - (#g:_) -> (#t:_) -> (#c:_) -> - (d:st_typing g t c{d << d0}) -> - Lemma (ensures freevars_st t `Set.subset` vars_of_env g /\ - freevars_comp c `Set.subset` vars_of_env g) - (decreases d) - -let st_typing_freevars_case - (pred : ( - (#g:_) -> (#t:_) -> (#c:_) -> - st_typing g t c -> GTot bool)) - : Type = - (#g:_) -> (#t:_) -> (#c:_) -> - (d : st_typing g t c{pred d}) -> - (cb : st_typing_freevars_cb_t d) -> - Lemma (freevars_st t `Set.subset` vars_of_env g /\ freevars_comp c `Set.subset` vars_of_env g) - -let st_typing_freevars_abs : st_typing_freevars_case T_Abs? = -fun d cb -> - admit () - -#push-options "--z3rlimit_factor 20 --fuel 3 --ifuel 2 --split_queries no" -#restart-solver -let st_typing_freevars_return : st_typing_freevars_case T_Return? = -fun d cb -> - admit () -#pop-options -#restart-solver -#push-options "--z3rlimit_factor 4 --fuel 1 --ifuel 1 --split_queries always" -let st_typing_freevars_bind : st_typing_freevars_case T_Bind? = -fun d cb -> - admit () - -let st_typing_freevars_bind_fn : st_typing_freevars_case T_BindFn? = -fun d cb -> - admit () - -let st_typing_freevars_if : st_typing_freevars_case T_If? = -fun #g #t #c d cb -> - admit () -#pop-options -#restart-solver -#push-options "--z3rlimit_factor 8" -let st_typing_freevars_frame : st_typing_freevars_case T_Frame? = -fun d cb -> - admit () -#pop-options - -#restart-solver -#push-options "--z3rlimit_factor 4 --fuel 2 --ifuel 1" -let st_typing_freevars_elimexists : st_typing_freevars_case T_ElimExists? = -fun #g #t #c d cb -> - admit () - -let st_typing_freevars_introexists : st_typing_freevars_case T_IntroExists? = -fun #g #t #c d cb -> - admit () - -let st_typing_freevars_rewrite : st_typing_freevars_case T_Rewrite? = -fun d cb -> - admit () - -let st_typing_freevars_withlocal : st_typing_freevars_case T_WithLocal? = -fun d cb -> - admit () - -let st_typing_freevars_withlocalarray : st_typing_freevars_case T_WithLocalArray? = -fun d cb -> - admit () - -let st_typing_freevars_admit : st_typing_freevars_case T_Admit? = -fun d cb -> - admit () - -let st_typing_freevars_unreachable : st_typing_freevars_case T_Unreachable? = -fun d cb -> - admit () - -let rec st_typing_freevars - (#g:_) (#t:_) (#c:_) +let st_typing_freevars + (g:_) (t:_) (c:_) (d:st_typing g t c) : Lemma (ensures freevars_st t `Set.subset` vars_of_env g /\ freevars_comp c `Set.subset` vars_of_env g) - (decreases d) -= match d with - | T_Abs .. -> - st_typing_freevars_abs d st_typing_freevars - | T_ST .. - | T_STGhost .. -> admit() - | T_Return .. -> - st_typing_freevars_return d st_typing_freevars - | T_Lift _ _ _ _ d1 _ -> - st_typing_freevars d1 - | T_Bind .. -> - st_typing_freevars_bind d st_typing_freevars - | T_BindFn .. -> - st_typing_freevars_bind_fn d st_typing_freevars - | T_If .. -> - st_typing_freevars_if d st_typing_freevars - | T_Match .. -> - admit () // IOU - | T_Frame .. -> - st_typing_freevars_frame d st_typing_freevars - | T_IntroPure _ p _ -> - admit () - | T_ElimExists _ u t p x -> - st_typing_freevars_elimexists d st_typing_freevars - | T_IntroExists _ u b p w -> - st_typing_freevars_introexists d st_typing_freevars - | T_Equiv _ _ _ _ d2 deq -> - st_typing_freevars d2; - st_equiv_freevars deq - | T_While .. -> - // st_typing_freevars_while d st_typing_freevars - admit () - | T_Rewrite .. -> - st_typing_freevars_rewrite d st_typing_freevars - | T_WithLocal .. -> - st_typing_freevars_withlocal d st_typing_freevars - | T_WithLocalUninit .. -> - admit () - | T_WithLocalArray .. -> - st_typing_freevars_withlocalarray d st_typing_freevars - | T_WithLocalArrayUninit .. -> - admit () - | T_Admit .. -> - st_typing_freevars_admit d st_typing_freevars - | T_Unreachable .. -> - st_typing_freevars_unreachable d st_typing_freevars - | T_Sub _ _ _ _ d_t d_sub -> - st_typing_freevars d_t; - st_sub_freevars d_sub - | T_ForwardJumpLabel .. -> admit () - | T_Goto .. -> admit () \ No newline at end of file += admit () \ No newline at end of file diff --git a/src/checker/Pulse.Typing.FV.fsti b/src/checker/Pulse.Typing.FV.fsti index 7c9b5327e..ce742eab8 100644 --- a/src/checker/Pulse.Typing.FV.fsti +++ b/src/checker/Pulse.Typing.FV.fsti @@ -48,29 +48,29 @@ val freevars_close_st_term (e:st_term) (x:var) (i:index) freevars_st e `set_minus` x) [SMTPat (freevars_st (close_st_term' e x i))] -val tot_typing_freevars (#g:_) (#t:_) (#ty:_) +val tot_typing_freevars (g:_) (t:_) (ty:_) (d:tot_typing g t ty) : Lemma (ensures freevars t `Set.subset` vars_of_env g /\ freevars ty `Set.subset` vars_of_env g) -val comp_typing_freevars (#g:_) (#c:_) (#u:_) +val comp_typing_freevars (g:_) (c:_) (u:_) (d:comp_typing g c u) : Lemma (ensures freevars_comp c `Set.subset` vars_of_env g) -val st_typing_freevars (#g:_) (#t:_) (#c:_) +val st_typing_freevars (g:_) (t:_) (c:_) (d:st_typing g t c) : Lemma (ensures freevars_st t `Set.subset` vars_of_env g /\ freevars_comp c `Set.subset` vars_of_env g) -let st_typing_freevars_inv (#g:_) (#t:_) (#c:_) +let st_typing_freevars_inv (g:_) (t:_) (c:_) (d:st_typing g t c) (x:var) : Lemma (requires freshv g x) (ensures ~(x `Set.mem` freevars_st t) /\ ~(x `Set.mem` freevars_comp c)) - = st_typing_freevars d \ No newline at end of file + = st_typing_freevars g t c d \ No newline at end of file diff --git a/src/checker/Pulse.Typing.LN.fst b/src/checker/Pulse.Typing.LN.fst index 424ed9282..40bc631e5 100644 --- a/src/checker/Pulse.Typing.LN.fst +++ b/src/checker/Pulse.Typing.LN.fst @@ -927,7 +927,7 @@ let lift_comp_ln #g #c1 #c2 (d:lift_comp g c1 c2) : Lemma (requires ln_c c1) (ensures ln_c c2) - = () + = admit () let tot_or_ghost_typing_ln (#g:_) (#e:_) (#t:_) (#eff:_) @@ -943,82 +943,32 @@ let tot_typing_ln (ensures ln e /\ ln t) = admit () #push-options "--fuel 4 --ifuel 4" -let rec slprop_equiv_ln (#g:_) (#t0 #t1:_) (v:slprop_equiv g t0 t1) +let slprop_equiv_ln (#g:_) (#t0 #t1:_) (v:slprop_equiv g t0 t1) : Lemma (ensures ln t0 <==> ln t1) - (decreases v) - = match v with - | VE_Refl _ _ -> () - | VE_Sym _ _ _ v' -> - slprop_equiv_ln v' - | VE_Trans g t0 t2 t1 v02 v21 -> - slprop_equiv_ln v02; - slprop_equiv_ln v21 - | VE_Ctxt g s0 s1 s0' s1' v0 v1 -> - slprop_equiv_ln v0; - slprop_equiv_ln v1 - | VE_Unit g t -> () - | VE_Comm g t0 t1 -> () - | VE_Assoc g t0 t1 t2 -> () - | VE_Ext g t0 t1 token -> - admit () - | VE_Fa g x u b t0' t1' d -> - slprop_equiv_ln d; - let xtm = (term_of_nvar (v_as_nv x)) in - introduce ln t0 ==> ln t1 - with _ . ( - open_term_ln_inv' t0' xtm 0; - open_term_ln t0' x; - open_term_ln t1' x - ); - introduce ln t1 ==> ln t0 - with _ . ( - open_term_ln_inv' t1' xtm 0; - open_term_ln t1' x; - open_term_ln t0' x - ) + = admit () #pop-options let st_equiv_ln #g #c1 #c2 (d:st_equiv g c1 c2) : Lemma (requires ln_c c1) (ensures ln_c c2) - = match d with - | ST_SLPropEquiv _ _ _ x eq_res eq_pre eq_post -> - slprop_equiv_ln eq_pre; - open_term_ln_inv' (comp_post c1) (term_of_no_name_var x) 0; - slprop_equiv_ln eq_post; - rt_equiv_ln _ _ _ eq_res; - open_term_ln' (comp_post c2) (term_of_no_name_var x) 0 - - | ST_TotEquiv g t1 t2 u eq -> - admit () + = admit () let prop_valid_must_be_ln (g:env) (t:term) (d:prop_validity g t) : Lemma (ensures ln t) = admit() -let rec st_sub_ln #g #c1 #c2 (d:st_sub g c1 c2) +let st_sub_ln #g #c1 #c2 (d:st_sub g c1 c2) : Lemma (requires ln_c c1) (ensures ln_c c2) - (decreases d) - = match d with - | STS_Refl _ _ -> () - - | STS_Trans _ _ _ _ d1 d2 -> - st_sub_ln d1; - st_sub_ln d2 - - | STS_GhostInvs g stc is1 is2 tok - | STS_AtomicInvs g stc is1 is2 _ _ tok -> - prop_valid_must_be_ln g (tm_inames_subset is1 is2) tok; - assume (ln (tm_inames_subset is1 is2) ==> ln is2) + = admit () let bind_comp_ln #g #x #c1 #c2 #c (d:bind_comp g x c1 c2 c) : Lemma (requires ln_c c1 /\ ln_c c2) (ensures ln_c c) - = () + = admit () let st_comp_typing_ln (#g:_) (#st:_) (d:st_comp_typing g st) : Lemma (ensures ln_st_comp st (-1)) = @@ -1088,107 +1038,10 @@ let comp_par_ln (cL : comp{C_ST? cL}) (cR : comp{C_ST? cR}) (x : var) // Note the use of break_vc in every case below. #push-options "--z3rlimit_factor 15 --fuel 4 --ifuel 1 --split_queries no --z3cliopt 'smt.qi.eager_threshold=100'" -let rec st_typing_ln (#g:_) (#t:_) (#c:_) +let st_typing_ln (#g:_) (#t:_) (#c:_) (d:st_typing g t c) : Lemma (ensures ln_st t /\ ln_c c) - (decreases d) - = match d with - | T_Frame _ _ c frame dc -> - FStar.Pure.BreakVC.break_vc (); - st_typing_ln dc; - admit () - - | T_IntroPure _ p _ -> - FStar.Pure.BreakVC.break_vc (); - admit () - - | T_Abs _g x _q ty _u body c db -> - admit () - - | T_ST .. - | T_STGhost .. -> admit() - - | T_Lift _ _ _ _ d1 l -> - FStar.Pure.BreakVC.break_vc (); - st_typing_ln d1; - lift_comp_ln l - - | T_Return _ c use_eq u t e post x -> - FStar.Pure.BreakVC.break_vc (); - admit () - - | T_Bind _ _ e2 _ _ _ x _ d1 d2 bc -> - FStar.Pure.BreakVC.break_vc (); - st_typing_ln d1; - st_typing_ln d2; - open_st_term_ln e2 x; - bind_comp_ln bc - - | T_BindFn _g _e1 e2 _c1 _c2 _b x d1 _u d2 c -> - FStar.Pure.BreakVC.break_vc (); - st_typing_ln d1; - st_typing_ln d2; - open_st_term_ln e2 x; - comp_typing_ln c - - | T_If _ _ _ _ _ _ d1 d2 _ -> - FStar.Pure.BreakVC.break_vc (); - admit () - - | T_Match _ _ _ sc c _ _ _ _ -> - FStar.Pure.BreakVC.break_vc (); - admit () - - | T_ElimExists _ u t p x -> - FStar.Pure.BreakVC.break_vc (); - admit () - - - | T_IntroExists _ u t p e -> - FStar.Pure.BreakVC.break_vc (); - admit () - - | T_Equiv _ _ _ _ d2 deq -> - FStar.Pure.BreakVC.break_vc (); - st_typing_ln d2; - st_equiv_ln deq - - | T_While .. -> - admit () - // FStar.Pure.BreakVC.break_vc (); - // tot_or_ghost_typing_ln inv_typing; - // tot_or_ghost_typing_ln post_typing; - // st_typing_ln cond_typing; - // st_typing_ln body_typing; - // open_term_ln_inv' post tm_false 0 - - | T_Rewrite _ _ _ equiv_p_q -> - admit () - - | T_WithLocal g _ init body init_t c x c_typing body_typing -> - admit () - - | T_WithLocalUninit .. -> - admit() - - | T_WithLocalArray g _ init len body init_t c x c_typing body_typing -> - admit () - - | T_WithLocalArrayUninit .. -> - admit() - - | T_Admit _ c c_typing - | T_Unreachable _ c c_typing -> - FStar.Pure.BreakVC.break_vc (); - comp_typing_ln c_typing - - | T_Sub _ e c c' d d_sub -> - FStar.Pure.BreakVC.break_vc (); - st_typing_ln d; - st_sub_ln d_sub - - | T_ForwardJumpLabel .. -> admit () - | T_Goto .. -> admit () + = admit () #pop-options \ No newline at end of file diff --git a/src/checker/Pulse.Typing.Metatheory.Base.fst b/src/checker/Pulse.Typing.Metatheory.Base.fst index 6cd966c7e..cbfd8ccf8 100644 --- a/src/checker/Pulse.Typing.Metatheory.Base.fst +++ b/src/checker/Pulse.Typing.Metatheory.Base.fst @@ -23,74 +23,58 @@ module RT = FStar.Reflection.Typing let admit_st_comp_typing (g:env) (st:st_comp) : st_comp_typing g st - = admit() + = () let admit_comp_typing (g:env) (c:comp_st) : comp_typing_u g c - = match c with - | C_ST st -> - CT_ST g st (admit_st_comp_typing g st) - | C_STAtomic inames obs st -> - CT_STAtomic g inames obs st (admit_st_comp_typing g st) - | C_STGhost inames st -> - CT_STGhost g inames st (admit_st_comp_typing g st) - -let st_typing_correctness_ctot (#g:env) (#t:st_term) (#c:comp{C_Tot? c}) + = () + +let st_typing_correctness_ctot (g:env) (t:st_term) (c:comp{C_Tot? c}) (_:st_typing g t c) : (u:Ghost.erased universe & universe_of g (comp_res c) u) = let u : Ghost.erased universe = RU.magic () in let ty : universe_of g (comp_res c) u = RU.magic() in (| u, ty |) -let st_typing_correctness (#g:env) (#t:st_term) (#c:comp_st) +let st_typing_correctness (g:env) (t:st_term) (c:comp_st) (_:st_typing g t c) : comp_typing_u g c - = admit_comp_typing g c + = () -let add_frame_well_typed (#g:env) (#c:comp_st) (ct:comp_typing_u g c) - (#f:term) (ft:tot_typing g f tm_slprop) +let add_frame_well_typed (g:env) (c:comp_st) (ct:comp_typing_u g c) + (f:term) (ft:tot_typing g f tm_slprop) : Dv (comp_typing_u g (add_frame c f)) - = admit_comp_typing _ _ + = () let emp_inames_typing (g:env) : tot_typing g tm_emp_inames tm_inames = () -let comp_typing_inversion #g #c ct = - match ct with - | CT_ST _ _ st -> st, () - | CT_STGhost _ _ _ st - | CT_STAtomic _ _ _ _ st -> st, () - -let st_comp_typing_inversion_cofinite (#g:env) (#st:_) (ct:st_comp_typing g st) = - admit(), admit(), (fun _ -> admit()) - -let stc_ty (#g:env) (#st:_) (ct:st_comp_typing g st) : universe_of g st.res st.u = () -let stc_pre (#g:env) (#st:_) (ct:st_comp_typing g st) : tot_typing g st.pre tm_slprop = () -let stc_x (#g:env) (#st:_) (ct:st_comp_typing g st) : x:Ghost.erased var{fresh_wrt x g (freevars st.post)} = - let STC g st x = ct in Ghost.hide x -let stc_post (#g:env) (#st:_) (ct:st_comp_typing g st) - : tot_typing (push_binding g (stc_x ct) ppname_default st.res) - (open_term st.post (stc_x ct)) tm_slprop = - () -let st_comp_typing_inversion (#g:env) (#st:_) (ct:st_comp_typing g st) = - (| stc_ty ct, stc_pre ct, stc_x ct, stc_post ct |) +let comp_typing_inversion g c ct = + ((), ()) + +let st_comp_typing_inversion_cofinite (g:env) (st:st_comp) (ct:st_comp_typing g st) = + (), (), (fun _ -> ()) + +let stc_x (g:env) (st:st_comp) (ct:st_comp_typing g st) : x:Ghost.erased var{fresh_wrt x g (freevars st.post)} = admit() + +let st_comp_typing_inversion (g:env) (st:st_comp) (ct:st_comp_typing g st) = + (| (), (), stc_x g st ct, () |) -let st_comp_typing_inversion_with_name (#g:env) (#st:_) (ct:st_comp_typing g st) (x:var{fresh_wrt x g (freevars st.post)}) +let st_comp_typing_inversion_with_name (g:env) (st:st_comp) (ct:st_comp_typing g st) (x:var{fresh_wrt x g (freevars st.post)}) : (universe_of g st.res st.u & tot_typing g st.pre tm_slprop & tot_typing (push_binding g x ppname_default st.res) (open_term st.post x) tm_slprop) -= assume (x == Ghost.reveal <| stc_x ct); - (stc_ty ct, stc_pre ct, stc_post ct) += ((), (), ()) -let tm_exists_inversion (#g:env) (#u:universe) (#ty:term) (#p:term) +let tm_exists_inversion (g:env) (u:universe) (ty:term) (p:term) (_:tot_typing g (tm_exists_sl u (as_binder ty) p) tm_slprop) (x:var { fresh_wrt x g (freevars p) } ) : universe_of g ty u & tot_typing (push_binding g x ppname_default ty) p tm_slprop - = admit(), admit() + = (), () -let pure_typing_inversion (#g:env) (#p:term) (_:tot_typing g (tm_pure p) tm_slprop) +let pure_typing_inversion (g:env) (p:term) (_:tot_typing g (tm_pure p) tm_slprop) : tot_typing g p (wr FStar.Reflection.Typing.tm_prop Range.range_0) - = admit () + = () let typing_correctness _ = admit() let tot_typing_renaming1 _ _ _ _ _ _ = admit() @@ -101,7 +85,7 @@ let non_informative_t_weakening (g g':env) (g1:env{ pairwise_disjoint g g1 g' }) (d:non_informative_t (push_env g g') u t) : non_informative_t (push_env (push_env g g1) g') u t = let (| w, _ |) = d in - (| w, RU.magic #(tot_typing _ _ _) () |) + (| w, () |) let non_informative_c_weakening (g g':env) (g1:env{ pairwise_disjoint g g1 g' }) (c:comp_st) @@ -110,23 +94,16 @@ let non_informative_c_weakening (g g':env) (g1:env{ pairwise_disjoint g g1 g' }) non_informative_t_weakening g g' g1 _ _ d let bind_comp_weakening (g:env) (g':env { disjoint g g' }) - (#x:var) (#c1 #c2 #c3:comp) (d:bind_comp (push_env g g') x c1 c2 c3) + (x:var) (c1 c2 c3:comp) (d:bind_comp (push_env g g') x c1 c2 c3) (g1:env { pairwise_disjoint g g1 g' }) : bind_comp (push_env (push_env g g1) g') x c1 c2 c3 - = admit() + = () let lift_comp_weakening (g:env) (g':env { disjoint g g'}) - (#c1 #c2:comp) (d:lift_comp (push_env g g') c1 c2) + (c1 c2:comp) (d:lift_comp (push_env g g') c1 c2) (g1:env { pairwise_disjoint g g1 g' }) - : Tot (lift_comp (push_env (push_env g g1) g') c1 c2) - (decreases d) = - - match d with - | Lift_STAtomic_ST _ c -> Lift_STAtomic_ST _ c - | Lift_Ghost_Neutral _ c non_informative_c -> - Lift_Ghost_Neutral _ c (non_informative_c_weakening g g' g1 _ non_informative_c) - | Lift_Neutral_Ghost _ c -> Lift_Neutral_Ghost _ c - | Lift_Observability _ obs c -> Lift_Observability _ obs c + : lift_comp (push_env (push_env g g1) g') c1 c2 + = () // TODO: the proof for RT.Equiv is not correct here let equiv_weakening (g:env) (g':env { disjoint g g' }) @@ -137,17 +114,10 @@ let equiv_weakening (g:env) (g':env { disjoint g g' }) d let st_equiv_weakening (g:env) (g':env { disjoint g g' }) - (#c1 #c2:comp) (d:st_equiv (push_env g g') c1 c2) + (c1 c2:comp) (d:st_equiv (push_env g g') c1 c2) (g1:env { pairwise_disjoint g g1 g' }) : st_equiv (push_env (push_env g g1) g') c1 c2 = - match d with - | ST_SLPropEquiv _ c1 c2 x hequiv _ _ -> - assume (~ (x `Set.mem` dom g')); - assume (~ (x `Set.mem` dom g1)); - ST_SLPropEquiv _ c1 c2 x - (equiv_weakening _ _ hequiv _) (RU.magic ()) (RU.magic ()) - | ST_TotEquiv _ t1 t2 u _ -> - ST_TotEquiv _ t1 t2 u (RU.magic ()) + () // TODO: add precondition that g1 extends g' let prop_validity_token_weakening (#g:env) (#t:term) @@ -157,49 +127,24 @@ let prop_validity_token_weakening (#g:env) (#t:term) admit (); token -let rec st_sub_weakening (g:env) (g':env { disjoint g g' }) - (#c1 #c2:comp) (d:st_sub (push_env g g') c1 c2) +let st_sub_weakening (g:env) (g':env { disjoint g g' }) + (c1 c2:comp) (d:st_sub (push_env g g') c1 c2) (g1:env { pairwise_disjoint g g1 g' }) - : Tot (st_sub (push_env (push_env g g1) g') c1 c2) - (decreases d) -= - let g'' = push_env (push_env g g1) g' in - match d with - | STS_Refl _ _ -> - STS_Refl _ _ - | STS_Trans _ _ _ _ dl dr -> - STS_Trans _ _ _ _ (st_sub_weakening g g' dl g1) (st_sub_weakening g g' dr g1) - | STS_GhostInvs _ stc is1 is2 tok -> - let tok : prop_validity g'' (tm_inames_subset is1 is2) = prop_validity_token_weakening tok g'' in - STS_GhostInvs g'' stc is1 is2 tok - | STS_AtomicInvs _ stc is1 is2 o1 o2 tok -> - let tok : prop_validity g'' (tm_inames_subset is1 is2) = prop_validity_token_weakening tok g'' in - STS_AtomicInvs g'' stc is1 is2 o1 o2 tok + : st_sub (push_env (push_env g g1) g') c1 c2 + = () let st_comp_typing_weakening (g:env) (g':env { disjoint g g' }) - (#s:st_comp) (d:st_comp_typing (push_env g g') s) + (s:st_comp) (d:st_comp_typing (push_env g g') s) (g1:env { pairwise_disjoint g g1 g' }) : st_comp_typing (push_env (push_env g g1) g') s = - match d with - | STC _ st x -> - assume (~ (x `Set.mem` dom g')); - assume (~ (x `Set.mem` dom g1)); - STC _ st x + () let comp_typing_weakening (g:env) (g':env { disjoint g g' }) - (#c:comp) (#u:universe) (d:comp_typing (push_env g g') c u) + (c:comp) (u:universe) (d:comp_typing (push_env g g') c u) (g1:env { pairwise_disjoint g g1 g' }) : comp_typing (push_env (push_env g g1) g') c u = - match d with - | CT_Tot _ t u -> CT_Tot _ t u - | CT_ST _ _ d -> CT_ST _ _ (st_comp_typing_weakening g g' d g1) - | CT_STAtomic _ inames obs _ d -> - CT_STAtomic _ inames obs _ (st_comp_typing_weakening g g' d g1) - | CT_STGhost _ inames _ d -> - CT_STGhost _ inames _ (st_comp_typing_weakening g g' d g1) - -#push-options "--split_queries no --z3rlimit_factor 8 --fuel 1 --ifuel 1" + () + let st_typing_weakening g g' t c d g1 : st_typing (push_env (push_env g g1) g') t c - = admit () -#pop-options \ No newline at end of file + = () \ No newline at end of file diff --git a/src/checker/Pulse.Typing.Metatheory.Base.fsti b/src/checker/Pulse.Typing.Metatheory.Base.fsti index ffded3287..65649cf6e 100644 --- a/src/checker/Pulse.Typing.Metatheory.Base.fsti +++ b/src/checker/Pulse.Typing.Metatheory.Base.fsti @@ -40,7 +40,7 @@ let rt_equiv_typing (#g:_) (#t0 #t1:_) (d:RT.equiv g t0 t1) : Ghost.erased (RT.tot_typing g t1 k) = admit() -val st_typing_correctness_ctot (#g:env) (#t:st_term) (#c:comp{C_Tot? c}) +val st_typing_correctness_ctot (g:env) (t:st_term) (c:comp{C_Tot? c}) (_:st_typing g t c) : (u:Ghost.erased universe & universe_of g (comp_res c) u) @@ -52,38 +52,38 @@ let inames_of_comp_st (c:comp_st) = let iname_typing (g:env) (c:comp_st) = tot_typing g (inames_of_comp_st c) tm_inames -val st_typing_correctness (#g:env) (#t:st_term) (#c:comp_st) +val st_typing_correctness (g:env) (t:st_term) (c:comp_st) (d:st_typing g t c) : comp_typing_u g c -val comp_typing_inversion (#g:env) (#c:comp_st) (ct:comp_typing_u g c) +val comp_typing_inversion (g:env) (c:comp_st) (ct:comp_typing_u g c) : erased (st_comp_typing g (st_comp_of_comp c) & iname_typing g c) -val st_comp_typing_inversion_cofinite (#g:env) (#st:_) (ct:st_comp_typing g st) +val st_comp_typing_inversion_cofinite (g:env) (st:st_comp) (ct:st_comp_typing g st) : ( universe_of g st.res st.u & tot_typing g st.pre tm_slprop & (x:var{fresh_wrt x g (freevars st.post)} -> //this part is tricky, to get the quantification on x tot_typing (push_binding g x ppname_default st.res) (open_term st.post x) tm_slprop)) -val st_comp_typing_inversion (#g:env) (#st:_) (ct:st_comp_typing g st) +val st_comp_typing_inversion (g:env) (st:st_comp) (ct:st_comp_typing g st) : (universe_of g st.res st.u & tot_typing g st.pre tm_slprop & x:erased var{fresh_wrt x g (freevars st.post)} & tot_typing (push_binding g x ppname_default st.res) (open_term st.post x) tm_slprop) -val st_comp_typing_inversion_with_name (#g:env) (#st:_) (ct:st_comp_typing g st) (x:var{fresh_wrt x g (freevars st.post)}) +val st_comp_typing_inversion_with_name (g:env) (st:st_comp) (ct:st_comp_typing g st) (x:var{fresh_wrt x g (freevars st.post)}) : universe_of g st.res st.u & tot_typing g st.pre tm_slprop & tot_typing (push_binding g x ppname_default st.res) (open_term st.post x) tm_slprop -val tm_exists_inversion (#g:env) (#u:universe) (#ty:term) (#p:term) +val tm_exists_inversion (g:env) (u:universe) (ty:term) (p:term) (_:tot_typing g (tm_exists_sl u (as_binder ty) p) tm_slprop) (x:var { fresh_wrt x g (freevars p) } ) : (universe_of g ty u & tot_typing (push_binding g x ppname_default ty) p tm_slprop) -val pure_typing_inversion (#g:env) (#p:term) (_:tot_typing g (tm_pure p) tm_slprop) +val pure_typing_inversion (g:env) (p:term) (_:tot_typing g (tm_pure p) tm_slprop) : tot_typing g p (S.wr FStar.Reflection.Typing.tm_prop Range.range_0) module RT = FStar.Reflection.Typing @@ -119,20 +119,20 @@ val st_typing_weakening let veq_weakening (g:env) (g':env { disjoint g g' }) - (#v1 #v2:slprop) (_:slprop_equiv (push_env g g') v1 v2) + (v1 v2:slprop) (_:slprop_equiv (push_env g g') v1 v2) (g1:env { pairwise_disjoint g g1 g' }) : slprop_equiv (push_env (push_env g g1) g') v1 v2 = RU.magic () let nt (x:var) (t:term) = [ RT.NT x t ] let slprop_equiv_rename - (#g:env) (#t0 #t1:term) + (g:env) (t0 t1:term) (x:var{freshv g x}) (y:var{freshv g y}) tx ty (eq:RT.equiv (elab_env g) tx ty) (v:slprop_equiv (push_binding g x ppname_default tx) (open_term t0 x) (open_term t1 x)) : slprop_equiv (push_binding g y ppname_default ty) (open_term t0 y) (open_term t1 y) = RU.magic() -let freevars_slprop_equiv (#g:env) (#t0 #t1:term) (d:slprop_equiv g t0 t1) +let freevars_slprop_equiv (g:env) (t0 t1:term) (d:slprop_equiv g t0 t1) : Lemma ((freevars t0 `Set.subset` dom g) /\ (freevars t1 `Set.subset` dom g)) = admit() diff --git a/src/checker/Pulse.Typing.Metatheory.fst b/src/checker/Pulse.Typing.Metatheory.fst index 3527adab0..4ef626342 100644 --- a/src/checker/Pulse.Typing.Metatheory.fst +++ b/src/checker/Pulse.Typing.Metatheory.fst @@ -20,88 +20,16 @@ open Pulse.Syntax open Pulse.Typing -let tot_typing_weakening_single #g #t #ty d x x_t = - let g1 = singleton_env (fstar_env g) x x_t in - let g' = mk_env (fstar_env g) in - assert (equal (push_env g g') g); - assert (equal (push_env (push_env g g1) g') (push_env g g1)); - assert (equal (push_env g g1) (push_binding g x ppname_default x_t)); - tot_typing_weakening g g' t ty d g1 +let tot_typing_weakening_single g t ty d x x_t = () -let tot_typing_weakening_standard g #t #ty d g2 = - let g1 = diff g2 g in - let g' = mk_env (fstar_env g) in - assert (equal (push_env g g1) g2); - assert (equal (push_env g g') g); - assert (equal (push_env (push_env g g1) g') g2); - tot_typing_weakening g g' t ty d g1 +let tot_typing_weakening_standard g t ty d g2 = () -let st_typing_weakening - (g:env) (g':env { disjoint g g' }) - (t:st_term) (c:comp) (d:st_typing (push_env g g') t c) - (g1:env { g1 `env_extends` g /\ disjoint g1 g' }) - : GTot (st_typing (push_env g1 g') t c) = +let st_typing_weakening g g' t c d g1 = () - let g2 = diff g1 g in - let d = st_typing_weakening g g' t c d g2 in - assert (equal (push_env (push_env g g2) g') (push_env g1 g')); - d +let st_typing_weakening_standard g t c d g1 = () -let st_typing_weakening_standard - (#g:env) (#t:st_term) (#c:comp) (d:st_typing g t c) - (g1:env { g1 `env_extends` g }) - : GTot (st_typing g1 t c) = +let st_typing_weakening_end g g' t c d g'' = () - let g' = mk_env (fstar_env g) in - assert (equal (push_env g g') g); - let d = st_typing_weakening g g' t c d g1 in - assert (equal (push_env g1 g') g1); - d +let veq_weakening g g' v1 v2 d g1 = () -let st_typing_weakening_end - (g:env) (g':env { disjoint g g' }) - (t:st_term) (c:comp) (d:st_typing (push_env g g') t c) - (g'':env { g'' `env_extends` g' /\ disjoint g'' g }) - : GTot (st_typing (push_env g g'') t c) = - - let g2 = diff g'' g' in - let emp_env = mk_env (fstar_env g) in - assert (equal (push_env g g') - (push_env (push_env g g') emp_env)); - let d - : st_typing (push_env (push_env (push_env g g') g2) emp_env) _ _ - = Pulse.Typing.Metatheory.Base.st_typing_weakening (push_env g g') emp_env t c (coerce_eq () d) g2 in - assert (equal (push_env (push_env (push_env g g') g2) emp_env) - (push_env (push_env g g') g2)); - push_env_assoc g g' g2; - assert (equal (push_env (push_env g g') g2) - (push_env g (push_env g' g2))); - assert (equal (push_env g (push_env g' g2)) - (push_env g g'')); - coerce_eq () d - -let veq_weakening - (g:env) (g':env { disjoint g g' }) - (#v1 #v2:slprop) (d:slprop_equiv (push_env g g') v1 v2) - (g1:env { g1 `env_extends` g /\ disjoint g1 g' }) - : slprop_equiv (push_env g1 g') v1 v2 = - - let g2 = diff g1 g in - let d = Pulse.Typing.Metatheory.Base.veq_weakening g g' d g2 in - assert (equal (push_env (push_env g g2) g') (push_env g1 g')); - d - -let veq_weakening_end g g' #v1 #v2 d g'' = - let g2 = diff g'' g' in - let emp_env = mk_env (fstar_env g) in - assert (equal (push_env g g') - (push_env (push_env g g') emp_env)); - let d = Pulse.Typing.Metatheory.Base.veq_weakening (push_env g g') emp_env #v1 #v2(coerce_eq () d) g2 in - assert (equal (push_env (push_env (push_env g g') g2) emp_env) - (push_env (push_env g g') g2)); - push_env_assoc g g' g2; - assert (equal (push_env (push_env g g') g2) - (push_env g (push_env g' g2))); - assert (equal (push_env g (push_env g' g2)) - (push_env g g'')); - coerce_eq () d +let veq_weakening_end g g' v1 v2 d g'' = () diff --git a/src/checker/Pulse.Typing.Metatheory.fsti b/src/checker/Pulse.Typing.Metatheory.fsti index a87eba66c..0bf82db2e 100644 --- a/src/checker/Pulse.Typing.Metatheory.fsti +++ b/src/checker/Pulse.Typing.Metatheory.fsti @@ -21,7 +21,7 @@ open Pulse.Typing include Pulse.Typing.Metatheory.Base -val tot_typing_weakening_single (#g:env) (#t #ty:term) +val tot_typing_weakening_single (g:env) (t ty:term) (d:tot_typing g t ty) (x:var { ~ (x `Set.mem` dom g)}) (x_t:typ) @@ -29,7 +29,7 @@ val tot_typing_weakening_single (#g:env) (#t #ty:term) : tot_typing (push_binding g x ppname_default x_t) t ty val tot_typing_weakening_standard (g:env) - (#t #ty:term) (d:tot_typing g t ty) + (t ty:term) (d:tot_typing g t ty) (g1:env { g1 `env_extends` g }) : tot_typing g1 t ty @@ -40,7 +40,7 @@ val st_typing_weakening : GTot (st_typing (push_env g1 g') t c) val st_typing_weakening_standard - (#g:env) (#t:st_term) (#c:comp) (d:st_typing g t c) + (g:env) (t:st_term) (c:comp) (d:st_typing g t c) (g1:env { g1 `env_extends` g }) : GTot (st_typing g1 t c) @@ -52,12 +52,12 @@ val st_typing_weakening_end val veq_weakening (g:env) (g':env { disjoint g g' }) - (#v1 #v2:slprop) (d:slprop_equiv (push_env g g') v1 v2) + (v1 v2:slprop) (d:slprop_equiv (push_env g g') v1 v2) (g1:env { g1 `env_extends` g /\ disjoint g1 g' }) : slprop_equiv (push_env g1 g') v1 v2 val veq_weakening_end (g:env) (g':env { disjoint g g' }) - (#v1 #v2:slprop) (d:slprop_equiv (push_env g g') v1 v2) + (v1 v2:slprop) (d:slprop_equiv (push_env g g') v1 v2) (g'':env { g'' `env_extends` g' /\ disjoint g'' g }) : slprop_equiv (push_env g g'') v1 v2 diff --git a/src/checker/Pulse.Typing.fst b/src/checker/Pulse.Typing.fst index 7eb8e62b8..2ab9e8cf4 100644 --- a/src/checker/Pulse.Typing.fst +++ b/src/checker/Pulse.Typing.fst @@ -140,82 +140,7 @@ let elab_push_binding (g:env) (x:var { ~ (Set.mem x (dom g)) }) (t:typ) RT.extend_env (elab_env g) x t) = () [@@ erasable; no_auto_projectors] -noeq -type slprop_equiv : env -> term -> term -> Type = - | VE_Refl: - g:env -> - t:term -> - slprop_equiv g t t - - | VE_Sym: - g:env -> - t1:term -> - t2:term -> - slprop_equiv g t1 t2 -> - slprop_equiv g t2 t1 - - | VE_Trans: - g:env -> - t0:term -> - t1:term -> - t2:term -> - slprop_equiv g t0 t1 -> - slprop_equiv g t1 t2 -> - slprop_equiv g t0 t2 - - | VE_Ctxt: - g:env -> - t0:term -> - t1:term -> - t0':term -> - t1':term -> - slprop_equiv g t0 t0' -> - slprop_equiv g t1 t1' -> - slprop_equiv g (tm_star t0 t1) (tm_star t0' t1') - - | VE_Unit: (* *) - g:env -> - t:term -> - slprop_equiv g (tm_star tm_emp t) t - - | VE_Comm: - g:env -> - t0:term -> - t1:term -> - slprop_equiv g (tm_star t0 t1) (tm_star t1 t0) - - | VE_Assoc: - g:env -> - t0:term -> - t1:term -> - t2:term -> - slprop_equiv g (tm_star t0 (tm_star t1 t2)) (tm_star (tm_star t0 t1) t2) - - | VE_Ext: - g:env -> - t0:term -> - t1:term -> - RT.equiv (elab_env g) t0 t1 -> - slprop_equiv g t0 t1 - - // | VE_Ex: - // g:env -> - // x:var { None? (lookup_ty g x) } -> - // ty:term -> - // t0:term -> - // t1:term -> - // slprop_equiv f ((x, Inl ty)::g) (open_term t0 x) (open_term t1 x) -> - // slprop_equiv f g (tm_exists_sl ty t0) (tm_exists_sl ty t1) - - | VE_Fa: - g:env -> - x:var { freshv g x } -> - u:universe -> - b:binder -> - t0:term { ~(x `Set.mem` freevars t0 ) } -> - t1:term { ~(x `Set.mem` freevars t1 ) } -> - slprop_equiv (push_binding g x ppname_default b.binder_ty) (open_term t0 x) (open_term t1 x) -> - slprop_equiv g (tm_forall_sl u b t0) (tm_forall_sl u b t1) +let slprop_equiv (g:env) (t1:term) (t2:term) = unit let add_frame (s:comp_st) (frame:term) @@ -587,93 +512,13 @@ let prop_validity (g:env) (t:term) = FTB.prop_validity_token (elab_env g) t [@@ erasable; no_auto_projectors] -noeq -type st_equiv : env -> comp -> comp -> Type = - | ST_SLPropEquiv : - g:env -> - c1:comp_st -> - c2:comp_st { st_equiv_pre c1 c2 } -> - x:var { freshv g x /\ - ~(x `Set.mem` freevars (comp_post c1)) /\ - ~(x `Set.mem` freevars (comp_post c2)) } -> - RT.equiv (elab_env g) (comp_res c1) (comp_res c2) -> - slprop_equiv g (comp_pre c1) (comp_pre c2) -> - slprop_equiv (push_binding g x ppname_default (comp_res c1)) - (open_term (comp_post c1) x) - (open_term (comp_post c2) x) -> - st_equiv g c1 c2 - - | ST_TotEquiv : - g:env -> - t1:term -> - t2:term -> - u:universe -> - Ghost.erased (RT.equiv (elab_env g) t1 t2) -> - st_equiv g (C_Tot t1) (C_Tot t2) +let st_equiv (g:env) (c1:comp) (c2:comp) = unit let sub_observability (o1 o2:observability) = o1 = Neutral || o1 = o2 || o2 = Observable -[@@ erasable; no_auto_projectors] -noeq -type st_sub : env -> comp -> comp -> Type = - | STS_Refl : - g:env -> - c:comp -> - st_sub g c c - - | STS_Trans : - g:env -> - c1:comp -> - c2:comp -> - c3:comp -> - st_sub g c1 c2 -> - st_sub g c2 c3 -> - st_sub g c1 c3 - - | STS_GhostInvs : - g:env -> - stc:st_comp -> - is1:term -> - is2:term -> - prop_validity g (tm_inames_subset is1 is2) -> - st_sub g (C_STGhost is1 stc) (C_STGhost is2 stc) - - | STS_AtomicInvs : - g:env -> - stc:st_comp -> - is1:term -> - is2:term -> - obs1:observability -> - obs2:observability { sub_observability obs1 obs2 } -> - prop_validity g (tm_inames_subset is1 is2) -> - st_sub g (C_STAtomic is1 obs1 stc) (C_STAtomic is2 obs2 stc) +let st_sub (g:env) (c1:comp) (c2:comp) = unit -[@@ erasable; no_auto_projectors] -noeq -type lift_comp : env -> comp -> comp -> Type = - | Lift_STAtomic_ST : - g:env -> - c:comp_st{C_STAtomic? c} -> // Note: we have to reflect a univerese bound here! - lift_comp g c (C_ST (st_comp_of_comp c)) - - | Lift_Observability: - g:env -> - c:comp_st{C_STAtomic? c } -> - o2:observability { sub_observability (C_STAtomic?.obs c) o2 } -> - lift_comp g - (C_STAtomic (comp_inames c) (C_STAtomic?.obs c) (st_comp_of_comp c)) - (C_STAtomic (comp_inames c) o2 (st_comp_of_comp c)) - - | Lift_Ghost_Neutral: - g:env -> - c:comp_st{C_STGhost? c} -> - non_informative_c:non_informative_c g c -> - lift_comp g c (C_STAtomic (comp_inames c) Neutral (st_comp_of_comp c)) - - | Lift_Neutral_Ghost: - g:env -> - c:comp_st{C_STAtomic? c /\ C_STAtomic?.obs c == Neutral } -> - lift_comp g c (C_STGhost (comp_inames c) (st_comp_of_comp c)) +let lift_comp (g:env) (c1:comp) (c2:comp) = unit let wrst (ct:comp_st) (t:st_term') : st_term = { term = t; @@ -690,26 +535,10 @@ let wtag (ct:option ctag) (t:st_term') : st_term = seq_lhs = Sealed.seal false; } -[@@ erasable; no_auto_projectors] -noeq -type st_comp_typing : env -> st_comp -> Type = - | STC: - g:env -> - st:st_comp -> - x:var { freshv g x /\ ~(x `Set.mem` freevars st.post) } -> - st_comp_typing g st +let st_comp_typing (g:env) (st:st_comp) = unit -[@@ erasable; no_auto_projectors] -noeq -type bind_comp : env -> var -> comp -> comp -> comp -> Type = - | Bind_comp : - g:env -> - x:var { freshv g x } -> - c1:comp_st -> - c2:comp_st {bind_comp_pre x c1 c2} -> - y:var { freshv g y /\ ~(y `Set.mem` freevars (comp_post c2)) } -> - bind_comp g x c1 c2 (bind_comp_out c1 c2) +let bind_comp (g:env) (x:var) (c1:comp) (c2:comp) (c:comp) = unit let tr_binding (vt : var & typ) : Tot R.binding = let v, t = vt in @@ -721,35 +550,7 @@ let tr_binding (vt : var & typ) : Tot R.binding = let tr_bindings = L.map tr_binding -[@@ erasable; no_auto_projectors] -noeq -type comp_typing : env -> comp -> universe -> Type = - | CT_Tot : - g:env -> - t:term -> - u:universe -> - comp_typing g (C_Tot t) u - - | CT_ST : - g:env -> - st:st_comp -> - st_comp_typing g st -> - comp_typing g (C_ST st) (universe_of_comp (C_ST st)) - - | CT_STAtomic : - g:env -> - inames:term -> - obs:observability -> - st:st_comp -> - st_comp_typing g st -> - comp_typing g (C_STAtomic inames obs st) (universe_of_comp (C_STAtomic inames obs st)) - - | CT_STGhost : - g:env -> - inames:term -> - st:st_comp -> - st_comp_typing g st -> - comp_typing g (C_STGhost inames st) (universe_of_comp (C_STGhost inames st)) +let comp_typing (g:env) (c:comp) (u:universe) = unit let comp_typing_u (e:env) (c:comp_st) = comp_typing e c (universe_of_comp c) @@ -759,8 +560,7 @@ let subtyping_token g t1 t2 = val readback_binding : R.binding -> var_binding let readback_binding b = { n = { name = b.ppname; range = Range.range_0 }; x = b.uniq; ty = b.sort } -let non_informative (g:env) (c:comp) = - my_erased (RT.non_informative (elab_env g) (elab_comp c)) +let non_informative (g:env) (c:comp) = unit let inv_disjointness (inames i:term) = let g = Pulse.Reflection.Util.inv_disjointness_goal inames i in @@ -782,326 +582,13 @@ let goto_comp_of_block_comp (c: comp_st) : comp_st = } [@@ erasable; no_auto_projectors] -noeq -type st_typing : env -> st_term -> comp -> Type = - | T_Abs: - g:env -> - x:var { freshv g x } -> - q:option qualifier -> - b:binder -> - u:universe -> - body:st_term {~ (x `Set.mem` freevars_st body) } -> - c:comp -> - st_typing (push_binding (clear_goto g) x ppname_default b.binder_ty) (open_st_term_nv body (b.binder_ppname, x)) c -> - st_typing g (wtag None (Tm_Abs { b; q; body; ascription=empty_ascription})) - (C_Tot (tm_arrow b q (close_comp c x))) - - | T_ST: - g:env -> - t:term -> - c:comp_st -> - tot_typing g t (elab_comp c) -> - st_typing g (wrst c (Tm_ST { t; args=[] } )) c - - | T_STGhost: - g:env -> - t:term -> - c:comp_st -> - ghost_typing g t (elab_comp c) -> - non_informative g c -> - st_typing g (wrst c (Tm_ST { t; args=[] } )) c - - | T_Return: - g:env -> - c:ctag -> - use_eq:bool -> - u:universe -> - t:term -> - e:term -> - post:term -> - x:var { freshv g x /\ ~ (x `Set.mem` freevars post) } -> - st_typing g (wtag (Some c) (Tm_Return { expected_type=tm_unknown; insert_eq=use_eq; term=e })) - (comp_return c use_eq u t e post x) - - | T_Lift: - g:env -> - e:st_term -> - c1:comp_st -> - c2:comp_st -> - st_typing g e c1 -> - lift_comp g c1 c2 -> - st_typing g e c2 - - | T_Bind: - g:env -> - e1:st_term -> - e2:st_term -> - c1:comp_st -> - c2:comp_st -> - b:binder { b.binder_ty == comp_res c1 }-> - x:var { freshv g x /\ ~(x `Set.mem` freevars_st e2) } -> - c:comp -> - st_typing g e1 c1 -> - st_typing (push_binding g x ppname_default (comp_res c1)) (open_st_term_nv e2 (b.binder_ppname, x)) c2 -> - bind_comp g x c1 c2 c -> - st_typing g (wrst c (Tm_Bind { binder=b; head=e1; body=e2 })) c - - | T_BindFn: - g:env -> - e1:st_term -> - e2:st_term -> - c1:comp { C_Tot? c1 } -> - c2:comp_st -> - b:binder { b.binder_ty == comp_res c1 }-> - x:var { freshv g x /\ ~(x `Set.mem` freevars_st e2) } -> - st_typing g e1 c1 -> - u:Ghost.erased universe -> - st_typing (push_binding g x ppname_default (comp_res c1)) (open_st_term_nv e2 (b.binder_ppname, x)) c2 -> - comp_typing_u g c2 -> - st_typing g (wrst c2 (Tm_Bind { binder=b; head=e1; body=e2 })) c2 - - | T_If: - g:env -> - b:term -> - e1:st_term -> - e2:st_term -> - c:comp_st -> - hyp:var { freshv g hyp /\ - ~(hyp `Set.mem` (freevars_st e1 `Set.union` freevars_st e2)) - } -> - st_typing (g_with_eq g hyp b tm_true) e1 c -> - st_typing (g_with_eq g hyp b tm_false) e2 c -> - my_erased (comp_typing_u g c) -> - st_typing g (wrst c (Tm_If { b; then_=e1; else_=e2; post=None })) c - - | T_Match : - g:env -> - sc_u:universe -> - sc_ty:typ -> - sc:term -> - c:comp_st -> - my_erased (comp_typing_u g c) -> - brs:list branch -> - brs_typing g sc_u sc_ty sc brs c -> - pats_complete g sc sc_ty (L.map (fun b -> elab_pat b.pat) brs) -> - st_typing g (wrst c (Tm_Match {sc; returns_=None; brs})) c - - | T_Frame: - g:env -> - e:st_term -> - c:comp_st -> - frame:term -> - st_typing g e c -> - st_typing g e (add_frame c frame) - - | T_Equiv: - g:env -> - e:st_term -> - c:comp -> - c':comp -> - st_typing g e c -> - st_equiv g c c' -> - st_typing g e c' - - | T_Sub : - g:env -> - e:st_term -> - c:comp -> - c':comp -> - st_typing g e c -> - st_sub g c c' -> - st_typing g e c' - - | T_IntroPure: - g:env -> - p:term -> - prop_validity g p -> - st_typing g (wtag (Some STT_Ghost) (Tm_IntroPure { p })) - (comp_intro_pure p) - - | T_ElimExists: - g:env -> - u:universe -> - t:term -> - p:term -> - x:var { freshv g x } -> - st_typing g (wtag (Some STT_Ghost) (Tm_ElimExists { p = tm_exists_sl u (as_binder t) p })) - (comp_elim_exists u t p (v_as_nv x)) - - | T_IntroExists: - g:env -> - u:universe -> - b:binder -> - p:term -> - e:term -> - st_typing g (wtag (Some STT_Ghost) (Tm_IntroExists { p = tm_exists_sl u b p; - witnesses= [e] })) - (comp_intro_exists u b p e) - - | T_While: - g:env -> - inv:term -> - post_cond:term -> - cond:st_term -> - body:st_term -> - u_meas: universe -> ty_meas: term -> - is_tot: bool -> - x:nvar { freshv g (snd x) /\ ~(snd x `Set.mem` freevars_st cond) /\ ~(snd x `Set.mem` freevars_st cond) } -> - gx:env { gx == push_binding g (snd x) (fst x) ty_meas } -> - st_typing gx cond (comp_while_cond inv post_cond) -> - st_typing gx body (comp_while_body u_meas ty_meas is_tot x inv post_cond) -> - st_typing g (wtag (Some STT) (Tm_While { invariant = inv; - loop_requires = tm_unknown; - meas = None; - condition = cond; - body })) - (comp_while u_meas ty_meas x inv post_cond) - - | T_WithLocal: - g:env -> - binder_ppname:ppname -> - init:term -> - body:st_term -> - init_t:term -> - c:comp { C_ST? c } -> - x:var { freshv g x /\ ~(x `Set.mem` freevars_st body) } -> - comp_typing_u g c -> - st_typing (push_post (push_binding g x ppname_default (mk_ref init_t)) (withlocal_post init_t (null_var x))) - (open_st_term_nv body (v_as_nv x)) - (comp_withlocal_body x init_t (Some init) c) -> - st_typing g (wrst c (Tm_WithLocal { binder = mk_binder_ppname (mk_ref init_t) binder_ppname; initializer=Some init; body } )) c - - | T_WithLocalUninit: - g:env -> - binder_ppname:ppname -> - body:st_term -> - init_t:term -> - c:comp { C_ST? c } -> - x:var { freshv g x /\ ~(x `Set.mem` freevars_st body) } -> - comp_typing_u g c -> - st_typing (push_post (push_binding g x ppname_default (mk_ref init_t)) (withlocal_post init_t (null_var x))) - (open_st_term_nv body (v_as_nv x)) - (comp_withlocal_body x init_t None c) -> - st_typing g (wrst c (Tm_WithLocal { binder = mk_binder_ppname (mk_ref init_t) binder_ppname; initializer=None; body } )) c - - | T_WithLocalArray: - g:env -> - binder_ppname:ppname -> - initializer:term -> - length:term -> - body:st_term -> - a:term -> - c:comp { C_ST? c } -> - x:var { freshv g x /\ ~(x `Set.mem` freevars_st body) } -> - comp_typing_u g c -> - st_typing (push_post (push_binding g x ppname_default (mk_array a)) (withlocal_array_post a (null_var x) (Some initializer))) - (open_st_term_nv body (v_as_nv x)) - (comp_withlocal_array_body x a (Some initializer) length c) -> - st_typing g (wrst c (Tm_WithLocalArray { binder = mk_binder_ppname (mk_array a) binder_ppname; initializer = Some initializer; length; body } )) c - - | T_WithLocalArrayUninit: - g:env -> - binder_ppname:ppname -> - length:term -> - body:st_term -> - a:term -> - c:comp { C_ST? c } -> - x:var { freshv g x /\ ~(x `Set.mem` freevars_st body) } -> - comp_typing_u g c -> - st_typing (push_post (push_binding g x ppname_default (mk_array a)) (withlocal_array_post a (null_var x) None)) - (open_st_term_nv body (v_as_nv x)) - (comp_withlocal_array_body x a None length c) -> - st_typing g (wrst c (Tm_WithLocalArray { binder = mk_binder_ppname (mk_array a) binder_ppname; initializer = None; length; body } )) c - - | T_Rewrite: - g:env -> - p:slprop -> - q:slprop -> - slprop_equiv g p q -> - st_typing g (wtag (Some STT_Ghost) (Tm_Rewrite { t1=p; t2=q; tac_opt=None; elaborated=true } )) - (comp_rewrite p q) - - | T_Admit: - g:env -> - c:comp_st -> - comp_typing g c (universe_of_comp c) -> - st_typing g (wtag (Some (ctag_of_comp_st c)) - (Tm_Admit { ctag=ctag_of_comp_st c; - u=comp_u c; - typ=comp_res c; - post=None })) - c - - | T_Unreachable: - g:env -> - c:comp_st { comp_pre c == tm_is_unreachable } -> - comp_typing g c (universe_of_comp c) -> - st_typing g (wtag (Some (ctag_of_comp_st c)) (Tm_Unreachable {c})) c - - | T_ForwardJumpLabel: - g:env -> - lbl:nvar { freshv g (snd lbl) } -> - body:st_term -> - c:comp_st -> - st_typing (push_goto g (snd lbl) (fst lbl) (goto_comp_of_block_comp c)) (open_st_term' body (term_of_nvar lbl) 0) c -> - st_typing g (wtag (Some (ctag_of_comp_st c)) (Tm_ForwardJumpLabel { lbl = fst lbl; body; post = c })) c - - | T_Goto: - g:env -> - lbl:nvar -> - arg:term -> - lbl_c:comp_st { lookup_goto g (snd lbl) == Some (fst lbl, lbl_c) } -> - u:universe -> res:typ -> - post:term -> post_x: var { freshv g post_x } -> - st_typing g (wtag (Some (ctag_of_comp_st lbl_c)) (Tm_Goto { lbl = term_of_nvar lbl; arg })) - (with_st_comp lbl_c { u; res; pre = open_term' (comp_pre lbl_c) arg 0; post }) - -and pats_complete : env -> term -> typ -> list R.pattern -> Type0 = - // just check the elaborated term with the core tc - | PC_Elab : - g:env -> - sc:term -> - sc_ty:typ -> - pats:list R.pattern -> - bnds:list (list R.binding) -> - RT.match_is_complete (elab_env g) sc sc_ty pats bnds -> - pats_complete g sc sc_ty pats - -and brs_typing (g:env) (sc_u:universe) (sc_ty:typ) (sc:term) : list branch -> comp_st -> Type = - | TBRS_0 : - c:comp_st -> - brs_typing g sc_u sc_ty sc [] c - - | TBRS_1 : - c:comp_st -> - pat:pattern -> - e:st_term -> - br_typing g sc_u sc_ty sc pat e c -> - rest:list branch -> - brs_typing g sc_u sc_ty sc rest c -> - brs_typing g sc_u sc_ty sc ({pat;e;norw=Sealed.seal false}::rest) c - -and br_typing : env -> universe -> typ -> term -> pattern -> st_term -> comp_st -> Type = - | TBR : - g:env -> - sc_u : universe -> - sc_ty : typ -> - sc:term -> - c:comp_st -> - p:pattern -> - e:st_term -> - bs:(list R.binding){RT.bindings_ok_for_pat (fstar_env g) bs (elab_pat p)} -> - _ : squash (all_fresh g (L.map readback_binding bs)) -> - _ : squash (Some? (RT.elaborate_pat (elab_pat p) bs)) -> - _ : squash (~(R.Tv_Unknown? (R.inspect_ln (fst (Some?.v (RT.elaborate_pat (elab_pat p) bs)))))) -> // should be provable from defn of elaborate_pat - hyp:var {freshv (push_bindings g (L.map readback_binding bs)) hyp} -> - st_typing ( - push_binding (push_bindings g (L.map readback_binding bs)) - hyp - ({name=Sealed.seal "branch equality"; range=FStar.Range.range_0}) - (mk_sq_eq2 sc_u sc_ty sc (S.wr (fst (Some?.v (RT.elaborate_pat (elab_pat p) bs))) Range.range_0)) - ) e c -> - br_typing g sc_u sc_ty sc p (close_st_term_n e (L.map (fun b -> (readback_binding b).x) bs)) c +let st_typing (g:env) (t:st_term) (c:comp) = unit + +let pats_complete (g:env) (sc:term) (sc_ty:typ) (pats:list R.pattern) = unit + +let brs_typing (g:env) (sc_u:universe) (sc_ty:typ) (sc:term) (brs:list branch) (c:comp_st) = unit + +let br_typing (g:env) (sc_u:universe) (sc_ty:typ) (sc:term) (p:pattern) (e:st_term) (c:comp_st) = unit (* this requires some metatheory on FStar.Reflection.Typing From ea694bf21d78b3f34ce45a71910fe78fe507ea98 Mon Sep 17 00:00:00 2001 From: Gabriel Ebner Date: Fri, 27 Feb 2026 17:46:16 +0000 Subject: [PATCH 04/18] Fix checker return terms to match original typing constructors When typing tokens were replaced with unit, the st_terms that were implicitly determined by typing constructors were lost in several files. This commit fixes: - Abs.fst: Return wtag None (Tm_Abs {...}) instead of body_closed - Admit.fst: Return wtag (Tm_Admit {...}) instead of t0 (user term) - Prover.fst: Use Tm_IntroPure instead of Tm_ST placeholder - Prover.fst: Use Tm_IntroExists instead of Tm_ST placeholder - Prover.fst: Use Tm_Unreachable instead of Tm_ST placeholder - Prover.fst: Fix k_unreach to use Tm_Unreachable with correct ctag Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/checker/Pulse.Checker.Abs.fst | 10 ++++++---- src/checker/Pulse.Checker.Admit.fst | 9 +++++++-- src/checker/Pulse.Checker.Prover.fst | 8 ++++---- 3 files changed, 17 insertions(+), 10 deletions(-) diff --git a/src/checker/Pulse.Checker.Abs.fst b/src/checker/Pulse.Checker.Abs.fst index 9084ddfe0..0835444e4 100644 --- a/src/checker/Pulse.Checker.Abs.fst +++ b/src/checker/Pulse.Checker.Abs.fst @@ -506,8 +506,9 @@ let rec check_abs_core let b = {binder_ty=t;binder_ppname=ppname;binder_attrs} in let tres = tm_arrow {binder_ty=t;binder_ppname=ppname;binder_attrs} qual (close_comp c_body x) in - let tt : st_typing g body_closed (C_Tot tres) = () in - (| body_closed, C_Tot tres, tt |) + let abs_st = wtag None (Tm_Abs { b; q=qual; body=body_closed; ascription=empty_ascription}) in + let tt : st_typing g abs_st (C_Tot tres) = () in + (| abs_st, C_Tot tres, tt |) | _ -> let elab_c, pre_opened, inames_opened, ret_ty, post_hint_body = match asc.elaborated with @@ -607,9 +608,10 @@ let rec check_abs_core assume (open_st_term body_closed x == body); let b = {binder_ty=t;binder_ppname=ppname;binder_attrs} in let tres = tm_arrow {binder_ty=t;binder_ppname=ppname;binder_attrs} qual (close_comp c_body x) in - let tt : st_typing g body_closed (C_Tot tres) = () in + let abs_st = wtag None (Tm_Abs { b; q=qual; body=body_closed; ascription=empty_ascription}) in + let tt : st_typing g abs_st (C_Tot tres) = () in - (| body_closed, C_Tot tres, tt |) + (| abs_st, C_Tot tres, tt |) #pop-options let check_abs (g:env) (t:st_term{Tm_Abs? t.term}) (check:check_t) diff --git a/src/checker/Pulse.Checker.Admit.fst b/src/checker/Pulse.Checker.Admit.fst index ea7186f0f..eed2bc1b5 100644 --- a/src/checker/Pulse.Checker.Admit.fst +++ b/src/checker/Pulse.Checker.Admit.fst @@ -75,7 +75,12 @@ let check | _, PostHint post -> Pulse.Typing.Combinators.comp_for_post_hint g pre pre_typing post x in let (| c, d_c |) = res in - let d : st_typing g t0 c = () in + let admit_st = wtag (Some (ctag_of_comp_st c)) + (Tm_Admit { ctag=ctag_of_comp_st c; + u=comp_u c; + typ=comp_res c; + post=None }) in + let d : st_typing g admit_st c = () in FStar.Tactics.BreakVC.break_vc (); // ^ This makes a big difference! Would be good to distill into // a smaller F*-only example and file an issue. @@ -92,4 +97,4 @@ let check ] in info_doc_env g (Some t0.range) msg end else ()) <: T.Tac unit; - checker_result_for_st_typing (| t0, c, d |) res_ppname + checker_result_for_st_typing (| admit_st, c, d |) res_ppname diff --git a/src/checker/Pulse.Checker.Prover.fst b/src/checker/Pulse.Checker.Prover.fst index 4ddfbc1b6..d292d7b43 100644 --- a/src/checker/Pulse.Checker.Prover.fst +++ b/src/checker/Pulse.Checker.Prover.fst @@ -353,7 +353,7 @@ let intro_pure (g: env) (frame: slprop) (p: term) fun post t -> let frame_typ : tot_typing g frame tm_slprop = RU.magic () in // implied by t2_typing let h: tot_typing g (tm_star frame (comp_pre (comp_intro_pure p))) tm_slprop = RU.magic () in - let st = wtag (Some STT_Ghost) (Tm_ST { t = tm_unknown; args = [] }) in + let st = wtag (Some STT_Ghost) (Tm_IntroPure { p }) in debug_prover g (fun _ -> Printf.sprintf "intro_pure p=%s\nframe=%s\n" (show p) (show frame)); k_elab_equiv frame (frame `tm_star` tm_pure p) (continuation_elaborator_with_bind_nondep frame (comp_intro_pure p) st () h) (RU.magic ()) (RU.magic ()) post t @@ -453,7 +453,7 @@ let intro_exists (g: env) (frame: slprop) (u: universe) (b: binder) (body: slpro let h1: tot_typing g (tm_star frame (comp_pre (comp_intro_exists u b body e))) tm_slprop = RU.magic () in let h2: slprop_equiv g (tm_star frame (comp_pre (comp_intro_exists u b body e))) (tm_star frame (open_term' body e 0)) = RU.magic () in let h3: slprop_equiv g (tm_star (comp_post (comp_intro_exists u b body e)) frame) (tm_star frame (tm_exists_sl u b body)) = RU.magic () in - let st = wtag (Some STT_Ghost) (Tm_ST { t = tm_unknown; args = [] }) in + let st = wtag (Some STT_Ghost) (Tm_IntroExists { p = tm_exists_sl u b body; witnesses = [e] }) in debug_prover g (fun _ -> Printf.sprintf "intro_exists %s\nframe=%s\n" (show (tm_exists_sl u b body)) (show frame)); k_elab_equiv (frame `tm_star` open_term' body e 0) (frame `tm_star` tm_exists_sl u b body) (continuation_elaborator_with_bind_nondep frame (comp_intro_exists u b body e) st () h1) h2 h3 post t @@ -528,8 +528,8 @@ let elim_first (g: env) (ctxt0 goals: list slprop_view) let unreachable_elim_typing (g: env) (u: universe) (res: term) (post: term) : t:st_term & st_typing g t (C_STGhost tm_emp_inames { u; res; pre=tm_is_unreachable; post }) = - let st = wtag (Some STT_Ghost) (Tm_ST { t = tm_unknown; args = [] }) in let c = C_STGhost tm_emp_inames { u; res; pre=tm_is_unreachable; post } in + let st = wtag (Some STT_Ghost) (Tm_Unreachable { c }) in let typing: st_typing g st c = RU.magic () in (| st, typing |) @@ -1409,7 +1409,7 @@ let k_unreach (g: env) (x: nvar { freshv g (snd x) }) (post_hint: post_hint_t { T.Tac (continuation_elaborator g tm_is_unreachable (push_binding g (snd x) (fst x) post_hint.ret_ty) (open_term_nv post_hint.post x)) = let h: tot_typing g tm_is_unreachable tm_slprop = RU.magic () in let (| c, c_typ |) = Pulse.Typing.Combinators.comp_for_post_hint g tm_is_unreachable h post_hint (snd x) in - let st = wtag (Some STT_Ghost) (Tm_ST { t = tm_unknown; args = [] }) in + let st = wtag (Some STT_Ghost) (Tm_Unreachable { c }) in let typ : st_typing g st c = () in let g' = push_binding g (snd x) (fst x) post_hint.ret_ty in let post_opened = open_term_nv post_hint.post x in From 0c9f3860a4d53a47801484bc3626b0fa3758d7ec Mon Sep 17 00:00:00 2001 From: Gabriel Ebner Date: Fri, 27 Feb 2026 18:29:05 +0000 Subject: [PATCH 05/18] Oops, the LLM was right after all. --- src/checker/Pulse.Checker.Prover.fst | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/checker/Pulse.Checker.Prover.fst b/src/checker/Pulse.Checker.Prover.fst index d292d7b43..190600596 100644 --- a/src/checker/Pulse.Checker.Prover.fst +++ b/src/checker/Pulse.Checker.Prover.fst @@ -1409,7 +1409,7 @@ let k_unreach (g: env) (x: nvar { freshv g (snd x) }) (post_hint: post_hint_t { T.Tac (continuation_elaborator g tm_is_unreachable (push_binding g (snd x) (fst x) post_hint.ret_ty) (open_term_nv post_hint.post x)) = let h: tot_typing g tm_is_unreachable tm_slprop = RU.magic () in let (| c, c_typ |) = Pulse.Typing.Combinators.comp_for_post_hint g tm_is_unreachable h post_hint (snd x) in - let st = wtag (Some STT_Ghost) (Tm_Unreachable { c }) in + let st = wtag (Some (ctag_of_comp_st c)) (Tm_Unreachable { c }) in let typ : st_typing g st c = () in let g' = push_binding g (snd x) (fst x) post_hint.ret_ty in let post_opened = open_term_nv post_hint.post x in From 961ffb089a72c1ccc8353544a0ccebd30b24d2c7 Mon Sep 17 00:00:00 2001 From: Gabriel Ebner Date: Fri, 27 Feb 2026 18:29:28 +0000 Subject: [PATCH 06/18] Fix. --- src/checker/Pulse.Checker.Exists.fst | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/checker/Pulse.Checker.Exists.fst b/src/checker/Pulse.Checker.Exists.fst index fb9cc31e3..6c108f56d 100644 --- a/src/checker/Pulse.Checker.Exists.fst +++ b/src/checker/Pulse.Checker.Exists.fst @@ -133,7 +133,7 @@ let check_intro_exists let (| witness, witness_typing |) = check_term g witness T.E_Ghost b.binder_ty in let intro_st = wtag (Some STT_Ghost) (Tm_IntroExists { p = tm_exists_sl u b p; witnesses = [witness] }) in - let intro_c = C_STGhost tm_emp_inames { u=u0; res=tm_unit; pre=open_term' p witness 0; post=tm_exists_sl u (as_binder b.binder_ty) p } in + let intro_c = C_STGhost tm_emp_inames { u=u0; res=tm_unit; pre=open_term' p witness 0; post=tm_exists_sl u b p } in let d : st_typing g intro_st intro_c = () in let (| c, d |) = match_comp_res_with_post_hint intro_st intro_c d post_hint in prove_post_hint (try_frame_pre false pre_typing (|intro_st, c, d|) res_ppname) From 2ceba87315d6f5dd16d218db98acff3224cbb807 Mon Sep 17 00:00:00 2001 From: Gabriel Ebner Date: Fri, 27 Feb 2026 18:52:57 +0000 Subject: [PATCH 07/18] Replace RU.magic() with () for unit-typed typing tokens Since all typing token types (tot_typing, slprop_equiv, st_typing, comp_typing, universe_of, etc.) are now unit, the RU.magic() calls used to construct them are unnecessary. Replace ~120 occurrences with (). Remaining RU.magic() calls are for non-unit types (erased vars, RT.tot_typing, prop_validity, R.term) and are left unchanged. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- .../Pulse.Checker.AssertWithBinders.fst | 16 +- src/checker/Pulse.Checker.Base.fst | 6 +- .../Pulse.Checker.ForwardJumpLabel.fst | 2 +- src/checker/Pulse.Checker.Prover.fst | 184 +++++++++--------- src/checker/Pulse.Checker.ST.fst | 2 +- src/checker/Pulse.Checker.While.fst | 24 +-- src/checker/Pulse.JoinComp.fst | 2 +- src/checker/Pulse.Typing.Metatheory.Base.fst | 2 +- src/checker/Pulse.Typing.Metatheory.Base.fsti | 4 +- 9 files changed, 121 insertions(+), 121 deletions(-) diff --git a/src/checker/Pulse.Checker.AssertWithBinders.fst b/src/checker/Pulse.Checker.AssertWithBinders.fst index bef2d3061..426101487 100644 --- a/src/checker/Pulse.Checker.AssertWithBinders.fst +++ b/src/checker/Pulse.Checker.AssertWithBinders.fst @@ -352,8 +352,8 @@ let check_renaming // if there is no goal, take the goal to be the full current pre let rhs, pairs = rewrite_all st.range (T.unseal st.source) g pairs pre pre elaborated tac_opt false in check_pairs g st.range pairs tac_opt; - let h2: slprop_equiv g rhs pre = RU.magic () in - let h1: tot_typing g rhs tm_slprop = RU.magic () in + let h2: slprop_equiv g rhs pre = () in + let h1: tot_typing g rhs tm_slprop = () in let (| x, g', ty, ctxt', k |) = check g rhs h1 post_hint res_ppname body in (| x, g', ty, ctxt', k_elab_equiv pre (dfst ctxt') k h2 () |) @@ -383,7 +383,7 @@ let rec peel_binders k (ex: slprop) pre r let ty = mk_erased u b.binder_ty in let g' = push_binding g (snd x) (fst x) ty in let t' = open_term' body (mk_reveal u b.binder_ty (term_of_nvar x)) 0 in - let t'_typ : tot_typing g' t' tm_slprop = RU.magic () in + let t'_typ : tot_typing g' t' tm_slprop = () in let (|g'', t'', bs', k'|) = peel_binders k ex pre r g' frame bs t' t'_typ in (| g'', t'', (u,b.binder_ty,x)::bs', k_elab_trans (Pulse.Checker.Prover.elim_exists g frame u b body x g') k' |) | _ -> @@ -433,10 +433,10 @@ let check_wild | [ex] -> let k = List.Tot.length bs in let frame = list_as_slprop rest in - let ex_typ : tot_typing g ex tm_slprop = RU.magic () in + let ex_typ : tot_typing g ex tm_slprop = () in let (|g', ex', bs, k|) = peel_binders k ex pre st.range g frame bs ex ex_typ in let body = open_st_term_with_reveals body bs in - let pre_typ : tot_typing g' (tm_star frame ex') tm_slprop = RU.magic () in + let pre_typ : tot_typing g' (tm_star frame ex') tm_slprop = () in let (| x'', g'', t'', ctxt'', k' |) = check g' (frame `tm_star` ex') pre_typ post_hint res_ppname body in assume pre == (frame `tm_star` ex); @@ -519,7 +519,7 @@ let check let v = v' in let body = body in // TODO compress let h: tot_typing g1 v tm_slprop = PC.core_check_term g1 v T.E_Total tm_slprop in - let h: tot_typing g1 (tm_star v pre') tm_slprop = RU.magic () in // TODO: propagate through prover + let h: tot_typing g1 (tm_star v pre') tm_slprop = () in // TODO: propagate through prover let (| x, x_ty, pre'', g2, k |) = check g1 (tm_star v pre') h post_hint res_ppname body in (| x, x_ty, pre'', g2, k_elab_trans k_frame k |) @@ -555,8 +555,8 @@ let check let _: tot_typing g v' tm_slprop = PC.check_slprop_with_core g v' in - let h1: tot_typing g' (tm_star pre_remaining rhs') tm_slprop = RU.magic () in - let h2: slprop_equiv g' (tm_star pre_remaining rhs') (tm_star lhs pre_remaining) = RU.magic () in + let h1: tot_typing g' (tm_star pre_remaining rhs') tm_slprop = () in + let h2: slprop_equiv g' (tm_star pre_remaining rhs') (tm_star lhs pre_remaining) = () in let (| x, g'', ty, ctxt', k' |) = check g' (tm_star pre_remaining rhs') h1 post_hint res_ppname body in diff --git a/src/checker/Pulse.Checker.Base.fst b/src/checker/Pulse.Checker.Base.fst index 984b707de..d0bf17f7c 100644 --- a/src/checker/Pulse.Checker.Base.fst +++ b/src/checker/Pulse.Checker.Base.fst @@ -181,7 +181,7 @@ let extend_post_hint g p x tx conjunct conjunct_typing = in let p_post_typing_src'' : tot_typing g'' (open_term p.post y) tm_slprop - = RU.magic () //weaken, rename + = () //weaken, rename in let conjunct_typing' : tot_typing g' conjunct tm_slprop @@ -189,7 +189,7 @@ let extend_post_hint g p x tx conjunct conjunct_typing = in let conjunct_typing'' : tot_typing g'' (open_term conjunct y) tm_slprop - = RU.magic () //weaken + = () //weaken in let new_post = tm_star p.post conjunct in let new_post_typing @@ -461,7 +461,7 @@ let st_comp_typing_with_post_hint : tot_typing (push_binding g x ppname_default ph.ret_ty) (open_term ph.post x) tm_slprop = //weakening: TODO - RU.magic () + () in let ty_typing : universe_of ph.g st.res st.u = ph.ty_typing in let ty_typing : universe_of g st.res st.u = () in diff --git a/src/checker/Pulse.Checker.ForwardJumpLabel.fst b/src/checker/Pulse.Checker.ForwardJumpLabel.fst index a58ba6991..1196d8afa 100644 --- a/src/checker/Pulse.Checker.ForwardJumpLabel.fst +++ b/src/checker/Pulse.Checker.ForwardJumpLabel.fst @@ -72,7 +72,7 @@ let check } in let lbl_x = fresh g in let g' = push_goto g lbl_x lbl lbl_c in - let pre_typing': tot_typing g' pre tm_slprop = RU.magic () in + let pre_typing': tot_typing g' pre tm_slprop = () in let post_hint' : post_hint_opt g' = assume post_hint_for_env_p g' post; PostHint post in diff --git a/src/checker/Pulse.Checker.Prover.fst b/src/checker/Pulse.Checker.Prover.fst index 190600596..c0ad3a63e 100644 --- a/src/checker/Pulse.Checker.Prover.fst +++ b/src/checker/Pulse.Checker.Prover.fst @@ -206,21 +206,21 @@ let cont_elab g ps g' ps' = frame: list slprop_view -> continuation_elaborator g (elab_slprops (frame @ ps)) g' (elab_slprops (frame @ ps')) let cont_elab_refl g ps ps' (h: slprop_equiv g (elab_slprops ps) (elab_slprops ps')) : cont_elab g ps g ps' = - fun frame -> k_elab_equiv (elab_slprops (frame @ ps)) (elab_slprops (frame @ ps')) (k_elab_unit g (elab_slprops (frame @ ps))) (()) (RU.magic ()) + fun frame -> k_elab_equiv (elab_slprops (frame @ ps)) (elab_slprops (frame @ ps')) (k_elab_unit g (elab_slprops (frame @ ps))) (()) (()) let cont_elab_trans #g1 (#g2: env { g2 `env_extends` g1 }) (#g3: env { g3 `env_extends` g2 }) #ps1 #ps2 #ps2' #ps3 (k1: cont_elab g1 ps1 g2 ps2) (k2: cont_elab g2 ps2' g3 ps3) (h: slprop_equiv g2 (elab_slprops ps2) (elab_slprops ps2')) : cont_elab g1 ps1 g3 ps3 = - fun frame -> k_elab_trans (k1 frame) (k_elab_equiv (elab_slprops (frame @ ps2)) (elab_slprops (frame @ ps3)) (k2 frame) (RU.magic ()) (())) + fun frame -> k_elab_trans (k1 frame) (k_elab_equiv (elab_slprops (frame @ ps2)) (elab_slprops (frame @ ps3)) (k2 frame) (()) (())) let cont_elab_equiv #g1 #ps1 #ps1' #g2 #ps2 #ps2' (k: cont_elab g1 ps1 g2 ps2) (h1: slprop_equiv g1 (elab_slprops ps1) (elab_slprops ps1')) (h2: slprop_equiv g2 (elab_slprops ps2) (elab_slprops ps2')) : cont_elab g1 ps1' g2 ps2' = - fun frame -> k_elab_equiv (elab_slprops (frame @ ps1')) (elab_slprops (frame @ ps2')) (k frame) (RU.magic ()) (RU.magic ()) + fun frame -> k_elab_equiv (elab_slprops (frame @ ps1')) (elab_slprops (frame @ ps2')) (k frame) (()) (()) let cont_elab_frame #g #ps #g' #ps' (k: cont_elab g ps g' ps') frame : cont_elab g (frame @ ps) g' (frame @ ps') = @@ -248,12 +248,12 @@ let prover_result_join #g #ctxt #goals #g1 #ctxt1 #goals1 let before1, after1 = k1 g3 in let before2, after2 = k2 g3 in (fun frame -> - let h1: slprop_equiv g1 (elab_slprops ((frame @ solved1) @ ctxt1)) (elab_slprops (frame @ solved1 @ ctxt1)) = RU.magic () in - let h2: slprop_equiv g2 (elab_slprops ((frame @ solved1) @ solved2 @ ctxt2)) (elab_slprops (frame @ (solved1 @ solved2) @ ctxt2)) = RU.magic () in + let h1: slprop_equiv g1 (elab_slprops ((frame @ solved1) @ ctxt1)) (elab_slprops (frame @ solved1 @ ctxt1)) = () in + let h2: slprop_equiv g2 (elab_slprops ((frame @ solved1) @ solved2 @ ctxt2)) (elab_slprops (frame @ (solved1 @ solved2) @ ctxt2)) = () in k_elab_trans (before1 frame) (k_elab_equiv (elab_slprops (frame @ solved1 @ ctxt1)) (elab_slprops (frame @ (solved1 @ solved2) @ ctxt2)) (before2 (frame @ solved1)) h1 h2)), (fun frame -> - let h1: slprop_equiv g3 (elab_slprops ((frame @ solved1) @ solved2 @ goals2)) (elab_slprops (frame @ (solved1 @ solved2) @ goals2)) = RU.magic () in - let h2: slprop_equiv g3 (elab_slprops ((frame @ solved1) @ goals1)) (elab_slprops (frame @ solved1 @ goals1)) = RU.magic () in + let h1: slprop_equiv g3 (elab_slprops ((frame @ solved1) @ solved2 @ goals2)) (elab_slprops (frame @ (solved1 @ solved2) @ goals2)) = () in + let h2: slprop_equiv g3 (elab_slprops ((frame @ solved1) @ goals1)) (elab_slprops (frame @ solved1 @ goals1)) = () in k_elab_trans (k_elab_equiv (elab_slprops (frame @ (solved1 @ solved2) @ goals2)) (elab_slprops (frame @ solved1 @ goals1)) (after2 (frame @ solved1)) h1 h2) (after1 frame)) <: T.Tac _ |) @@ -274,10 +274,10 @@ let prove_first (g: env) (ctxt goals: list slprop_view) (fun frame -> let h1 : slprop_equiv g'' (elab_slprops ((frame @ List.Tot.Base.rev goals_left_rev @ goals) @ solved @ goals')) - (elab_slprops (frame @ solved @ List.Tot.Base.rev goals_left_rev @ goals' @ goals)) = RU.magic () in + (elab_slprops (frame @ solved @ List.Tot.Base.rev goals_left_rev @ goals' @ goals)) = () in let h2 : slprop_equiv g'' (elab_slprops ((frame @ List.Tot.Base.rev goals_left_rev @ goals) @ [goal])) - (elab_slprops (frame @ goals0)) = RU.magic () in + (elab_slprops (frame @ goals0)) = () in k_elab_equiv (elab_slprops (frame @ solved @ List.Tot.Base.rev goals_left_rev @ goals' @ goals)) (elab_slprops (frame @ goals0)) (after (frame @ List.rev goals_left_rev @ goals)) h1 h2) |) | None -> assert List.rev goals_left_rev @ (goal::goals) == goals0; @@ -316,7 +316,7 @@ let continuation_elaborator_with_bind_nondep_unit (#g:env) (ctxt:term) g (tm_star (open_term' (comp_post c1) unit_const 0) ctxt)) = let c1 = with_st_comp c1 { st_comp_of_comp c1 with post = open_term' (comp_post c1) unit_const 0 } in - let e1_typing: st_typing g e1 c1 = RU.magic () in + let e1_typing: st_typing g e1 c1 = () in continuation_elaborator_with_bind_nondep #g ctxt c1 e1 e1_typing ctxt_pre1_typing let cont_elab_with_bind_nondep_unit (#g:env) @@ -330,32 +330,32 @@ let cont_elab_with_bind_nondep_unit (#g:env) g [Unknown (open_term' (comp_post c1) unit_const 0)]) = fun frame posth t -> - let h1: tot_typing g (tm_star (elab_slprops frame) (comp_pre c1)) tm_slprop = RU.magic () in + let h1: tot_typing g (tm_star (elab_slprops frame) (comp_pre c1)) tm_slprop = () in let h2: slprop_equiv g (tm_star (elab_slprops frame) (comp_pre c1)) - (elab_slprops (frame @ [Unknown (comp_pre c1)])) = RU.magic () in + (elab_slprops (frame @ [Unknown (comp_pre c1)])) = () in let h3: slprop_equiv g (tm_star (open_term' (comp_post c1) unit_const 0) (elab_slprops frame)) (elab_slprops (frame @ - [Unknown (open_term' (comp_post c1) unit_const 0)])) = RU.magic () in + [Unknown (open_term' (comp_post c1) unit_const 0)])) = () in k_elab_equiv (elab_slprops (frame @ [Unknown (comp_pre c1)])) (elab_slprops (frame @ [Unknown (open_term' (comp_post c1) unit_const 0)])) (continuation_elaborator_with_bind_nondep_unit (elab_slprops frame) c1 e1 e1_typing h1) h2 h3 posth t -let tot_typing_tm_unit (g: env) : tot_typing g tm_unit (tm_type u0) = RU.magic () +let tot_typing_tm_unit (g: env) : tot_typing g tm_unit (tm_type u0) = () let intro_pure (g: env) (frame: slprop) (p: term) (p_typing:tot_typing g p tm_prop) (pv:prop_validity g p): continuation_elaborator g frame g (frame `tm_star` tm_pure p) = fun post t -> - let frame_typ : tot_typing g frame tm_slprop = RU.magic () in // implied by t2_typing - let h: tot_typing g (tm_star frame (comp_pre (comp_intro_pure p))) tm_slprop = RU.magic () in + let frame_typ : tot_typing g frame tm_slprop = () in // implied by t2_typing + let h: tot_typing g (tm_star frame (comp_pre (comp_intro_pure p))) tm_slprop = () in let st = wtag (Some STT_Ghost) (Tm_IntroPure { p }) in debug_prover g (fun _ -> Printf.sprintf "intro_pure p=%s\nframe=%s\n" (show p) (show frame)); - k_elab_equiv frame (frame `tm_star` tm_pure p) (continuation_elaborator_with_bind_nondep frame (comp_intro_pure p) st () h) (RU.magic ()) (RU.magic ()) + k_elab_equiv frame (frame `tm_star` tm_pure p) (continuation_elaborator_with_bind_nondep frame (comp_intro_pure p) st () h) (()) (()) post t let is_uvar (t:term) : bool = @@ -394,12 +394,12 @@ let prove_pure (g: env) (ctxt: list slprop_view) (skip_eq_uvar: bool) (goal: slp debug_prover g (fun _ -> Printf.sprintf "prove_pure p=%s success" (show p)); Some (| g, ctxt, [], [], fun g'' -> - let p_typing: tot_typing g'' p tm_prop = RU.magic() in // implied by t2_typing + let p_typing: tot_typing g'' p tm_prop = () in // implied by t2_typing let pv = check_prop_validity g'' p p_typing in cont_elab_refl g ctxt ([] @ ctxt) (()), (fun frame -> - let h1: slprop_equiv g'' (elab_slprops frame) (elab_slprops (frame @ [] @ [])) = RU.magic () in - let h2: slprop_equiv g'' (tm_star (elab_slprops frame) (tm_pure p)) (elab_slprops (frame @ [goal])) = RU.magic () in + let h1: slprop_equiv g'' (elab_slprops frame) (elab_slprops (frame @ [] @ [])) = () in + let h2: slprop_equiv g'' (tm_star (elab_slprops frame) (tm_pure p)) (elab_slprops (frame @ [goal])) = () in k_elab_equiv (elab_slprops (frame @ [] @ [])) (elab_slprops (frame @ [goal])) @@ -413,16 +413,16 @@ let intro_with_pure (g: env) (frame: slprop) (p: term) (n: ppname) (v: term) : continuation_elaborator g (frame `tm_star` v) g (frame `tm_star` tm_with_pure p n v) = fun post t -> let g = push_context g "check_intro_with_pure" (RU.range_of_term p) in - let p_typing: tot_typing g p tm_prop = RU.magic() in // implied by t2_typing + let p_typing: tot_typing g p tm_prop = () in // implied by t2_typing let pv = check_prop_validity g p p_typing in - let frame_typ : tot_typing g frame tm_slprop = RU.magic () in // implied by t2_typing + let frame_typ : tot_typing g frame tm_slprop = () in // implied by t2_typing let ty = mk_squash u0 p in let st = wtag (Some STT_Ghost) (Tm_ST { t = tm_unknown; args = [] }) in let c = C_STGhost tm_emp_inames { u=u0; res=tm_unit; pre=v; post=tm_with_pure p n v } in - let typing: st_typing g st c = RU.magic () in - let h: tot_typing g (tm_star frame (comp_pre c)) tm_slprop = RU.magic () in + let typing: st_typing g st c = () in + let h: tot_typing g (tm_star frame (comp_pre c)) tm_slprop = () in debug_prover g (fun _ -> Printf.sprintf "intro_pure p=%s\nframe=%s\n" (show p) (show frame)); - k_elab_equiv (frame `tm_star` v) (frame `tm_star` tm_with_pure p n v) (continuation_elaborator_with_bind_nondep frame c st typing h) (RU.magic ()) (RU.magic ()) + k_elab_equiv (frame `tm_star` v) (frame `tm_star` tm_with_pure p n v) (continuation_elaborator_with_bind_nondep frame c st typing h) (()) (()) post t let prove_with_pure (g: env) (ctxt: list slprop_view) skip_eq_uvar (goal: slprop_view) : @@ -434,9 +434,9 @@ let prove_with_pure (g: env) (ctxt: list slprop_view) skip_eq_uvar (goal: slprop Some (| g, ctxt, [Unknown v], [], fun g'' -> cont_elab_refl g ctxt ([] @ ctxt) (()), (fun frame -> - let h1: slprop_equiv g'' (tm_star (elab_slprops frame) v) (elab_slprops (frame @ [Unknown v] @ [])) = RU.magic () in + let h1: slprop_equiv g'' (tm_star (elab_slprops frame) v) (elab_slprops (frame @ [Unknown v] @ [])) = () in let h2: slprop_equiv g'' (tm_star (elab_slprops frame) (tm_with_pure p n v)) - (elab_slprops (frame @ [goal])) = RU.magic () in + (elab_slprops (frame @ [goal])) = () in k_elab_equiv (elab_slprops (frame @ [Unknown v] @ [])) (elab_slprops (frame @ [goal])) (intro_with_pure g'' (elab_slprops frame) p n v) h1 h2) <: T.Tac _ |) | _ -> None @@ -445,14 +445,14 @@ let intro_exists (g: env) (frame: slprop) (u: universe) (b: binder) (body: slpro continuation_elaborator g (frame `tm_star` open_term' body e 0) g (frame `tm_star` tm_exists_sl u b body) = fun post t -> let g = push_context g "check_intro_exists" (RU.range_of_term body) in - let frame_typ : tot_typing g frame tm_slprop = RU.magic () in // implied by t2_typing - let binder_ty_typ : tot_typing g b.binder_ty (tm_type u) = RU.magic() in // implied by t2_typing - let tm_ex_typ : tot_typing g (tm_exists_sl u b body) tm_slprop = RU.magic() in // implied by t2_typing + let frame_typ : tot_typing g frame tm_slprop = () in // implied by t2_typing + let binder_ty_typ : tot_typing g b.binder_ty (tm_type u) = () in // implied by t2_typing + let tm_ex_typ : tot_typing g (tm_exists_sl u b body) tm_slprop = () in // implied by t2_typing let e_typ = core_check_term' g e T.E_Ghost b.binder_ty (fun _ -> let open Pulse.PP in [text "Cannot find witness for" ^/^ pp (tm_exists_sl u b body)]) in - let h1: tot_typing g (tm_star frame (comp_pre (comp_intro_exists u b body e))) tm_slprop = RU.magic () in - let h2: slprop_equiv g (tm_star frame (comp_pre (comp_intro_exists u b body e))) (tm_star frame (open_term' body e 0)) = RU.magic () in - let h3: slprop_equiv g (tm_star (comp_post (comp_intro_exists u b body e)) frame) (tm_star frame (tm_exists_sl u b body)) = RU.magic () in + let h1: tot_typing g (tm_star frame (comp_pre (comp_intro_exists u b body e))) tm_slprop = () in + let h2: slprop_equiv g (tm_star frame (comp_pre (comp_intro_exists u b body e))) (tm_star frame (open_term' body e 0)) = () in + let h3: slprop_equiv g (tm_star (comp_post (comp_intro_exists u b body e)) frame) (tm_star frame (tm_exists_sl u b body)) = () in let st = wtag (Some STT_Ghost) (Tm_IntroExists { p = tm_exists_sl u b body; witnesses = [e] }) in debug_prover g (fun _ -> Printf.sprintf "intro_exists %s\nframe=%s\n" (show (tm_exists_sl u b body)) (show frame)); k_elab_equiv (frame `tm_star` open_term' body e 0) (frame `tm_star` tm_exists_sl u b body) (continuation_elaborator_with_bind_nondep frame (comp_intro_exists u b body e) st () h1) h2 h3 @@ -467,8 +467,8 @@ let prove_exists (g: env) (ctxt: list slprop_view) (goal: slprop_view) : Some (| g, ctxt, [Unknown (open_term' body e 0)], [], fun g'' -> cont_elab_refl g ctxt ([] @ ctxt) (()), (fun frame -> - let h1: slprop_equiv g'' (tm_star (elab_slprops frame) (open_term' body e 0)) (elab_slprops (frame @ [] @ [Unknown (open_term' body e 0)])) = RU.magic () in - let h2: slprop_equiv g'' (tm_star (elab_slprops frame) (tm_exists_sl u b body)) (elab_slprops (frame @ [goal])) = RU.magic () in + let h1: slprop_equiv g'' (tm_star (elab_slprops frame) (open_term' body e 0)) (elab_slprops (frame @ [] @ [Unknown (open_term' body e 0)])) = () in + let h2: slprop_equiv g'' (tm_star (elab_slprops frame) (tm_exists_sl u b body)) (elab_slprops (frame @ [goal])) = () in k_elab_equiv (elab_slprops (frame @ [] @ [Unknown (open_term' body e 0)])) (elab_slprops (frame @ [goal])) (intro_exists g'' (elab_slprops frame) u b body e) h1 h2) <: T.Tac _ |) | _ -> None @@ -482,7 +482,7 @@ let unpack_and_norm_goal (g: env) (ctxt: list slprop_view) (goal: slprop_view) : (match goal'' with | [Unknown _] -> None | _ -> Some (| g, ctxt, goal'', [], fun g' -> - let h: slprop_equiv g' (elab_slprops ([] @ goal'')) (elab_slprops [Unknown goal]) = RU.magic () in + let h: slprop_equiv g' (elab_slprops ([] @ goal'')) (elab_slprops [Unknown goal]) = () in cont_elab_refl _ _ _ (()), cont_elab_refl _ _ _ h <: T.Tac _ |)) | _ -> None @@ -506,11 +506,11 @@ let elim_first' (g: env) (ctxt0 goals: list slprop_view) assert goals' == []; Some (| g', List.rev ctxt_left_rev @ ctxt' @ ctxt, goals, solved, fun (g'': env { env_extends g'' g' }) -> let before, after = res g'' in - let h1: slprop_equiv g (elab_slprops ((List.Tot.Base.rev ctxt_left_rev @ ctxt) @ [c])) (elab_slprops ctxt0) = RU.magic () in + let h1: slprop_equiv g (elab_slprops ((List.Tot.Base.rev ctxt_left_rev @ ctxt) @ [c])) (elab_slprops ctxt0) = () in let h2: slprop_equiv g' (elab_slprops ((List.Tot.Base.rev ctxt_left_rev @ ctxt) @ solved @ ctxt')) - (elab_slprops (solved @ List.Tot.Base.rev ctxt_left_rev @ ctxt' @ ctxt)) = RU.magic () in - let h3: slprop_equiv g'' (elab_slprops (goals @ solved @ goals')) (elab_slprops (solved @ goals)) = RU.magic () in - let h4: slprop_equiv g'' (elab_slprops (goals @ [])) (elab_slprops goals) = RU.magic () in + (elab_slprops (solved @ List.Tot.Base.rev ctxt_left_rev @ ctxt' @ ctxt)) = () in + let h3: slprop_equiv g'' (elab_slprops (goals @ solved @ goals')) (elab_slprops (solved @ goals)) = () in + let h4: slprop_equiv g'' (elab_slprops (goals @ [])) (elab_slprops goals) = () in cont_elab_equiv (cont_elab_frame before (List.rev ctxt_left_rev @ ctxt)) h1 h2, cont_elab_equiv (cont_elab_frame after goals) h3 h4 |) | None -> @@ -530,22 +530,22 @@ let unreachable_elim_typing (g: env) (u: universe) (res: term) (post: term) : t:st_term & st_typing g t (C_STGhost tm_emp_inames { u; res; pre=tm_is_unreachable; post }) = let c = C_STGhost tm_emp_inames { u; res; pre=tm_is_unreachable; post } in let st = wtag (Some STT_Ghost) (Tm_Unreachable { c }) in - let typing: st_typing g st c = RU.magic () in + let typing: st_typing g st c = () in (| st, typing |) let unreachable_elim (g: env) (goals: list slprop_view) : cont_elab g [IsUnreachable] g goals = fun frame post t -> let frame_t = elab_slprops frame in let c = C_STGhost tm_emp_inames { u=u0; res=tm_unit; pre=tm_is_unreachable; post=frame_t } in let (| st, typing |) = unreachable_elim_typing g u0 tm_unit frame_t in - let h: tot_typing g (tm_star frame_t tm_is_unreachable) tm_slprop = RU.magic () in - k_elab_equiv (elab_slprops (frame @ [IsUnreachable])) (elab_slprops (frame @ goals)) (continuation_elaborator_with_bind_nondep frame_t c st typing h) (RU.magic ()) (RU.magic ()) + let h: tot_typing g (tm_star frame_t tm_is_unreachable) tm_slprop = () in + k_elab_equiv (elab_slprops (frame @ [IsUnreachable])) (elab_slprops (frame @ goals)) (continuation_elaborator_with_bind_nondep frame_t c st typing h) (()) (()) post t let elim_is_unreachable (g: env) (ctxt goals: list slprop_view) : T.Tac (option (prover_result g ctxt goals)) = if not (List.existsb IsUnreachable? ctxt) then None else // TODO: maybe add `_: squash False` to the environment? - let h1 : slprop_equiv g (elab_slprops ctxt) (elab_slprops ([IsUnreachable] @ [IsUnreachable])) = RU.magic () in + let h1 : slprop_equiv g (elab_slprops ctxt) (elab_slprops ([IsUnreachable] @ [IsUnreachable])) = () in Some (| g, [IsUnreachable], [], [IsUnreachable], (fun g'' -> cont_elab_refl _ _ _ h1, unreachable_elim _ _ <: T.Tac _)|) let elim_is_unreachable' (g: env) (ctxt goals: list slprop_view) : @@ -556,8 +556,8 @@ let elim_is_unreachable' (g: env) (ctxt goals: list slprop_view) : if not (List.existsb IsUnreachable? ctxt) then None else // TODO: maybe add `_: squash False` to the environment? Some (| g, [IsUnreachable], goals, [IsUnreachable], (fun g'' -> - let h1 : slprop_equiv g (elab_slprops ctxt) (elab_slprops ([IsUnreachable] @ [IsUnreachable])) = RU.magic () in - let h2: slprop_equiv g'' (elab_slprops [IsUnreachable]) (elab_slprops ([IsUnreachable] @ goals)) = RU.magic () in + let h1 : slprop_equiv g (elab_slprops ctxt) (elab_slprops ([IsUnreachable] @ [IsUnreachable])) = () in + let h2: slprop_equiv g'' (elab_slprops [IsUnreachable]) (elab_slprops ([IsUnreachable] @ goals)) = () in cont_elab_refl _ _ _ h1, cont_elab_equiv (unreachable_elim g'' goals) h2 (()) <: T.Tac _)|) @@ -571,7 +571,7 @@ let unpack_and_norm_ctxt (g: env) (ctxt: slprop_view) : (match ctxt'' with | [Unknown _] -> None | _ -> Some (| g, ctxt'', [], [], fun g' -> - let h: slprop_equiv g ctxt (elab_slprops ([] @ ctxt'')) = RU.magic () in + let h: slprop_equiv g ctxt (elab_slprops ([] @ ctxt'')) = () in cont_elab_refl _ _ _ h, cont_elab_refl _ _ _ (()) <: T.Tac _ |)) | _ -> None @@ -582,9 +582,9 @@ let elim_pure (g: env) (frame: slprop) (p: term) (x: nvar { ~(Set.mem (snd x) (d let ty = mk_squash u0 p in let st = wtag (Some STT_Ghost) (Tm_ST { t = tm_unknown; args = [] }) in let c = C_STGhost tm_emp_inames { u=u0; res=ty; pre=tm_pure p; post=tm_emp } in - let typing: st_typing g st c = RU.magic () in - let h: tot_typing g (tm_star frame (comp_pre c)) tm_slprop = RU.magic () in - let h2: slprop_equiv g' (tm_star (open_term_nv (comp_post c) x) frame) frame = RU.magic () in + let typing: st_typing g st c = () in + let h: tot_typing g (tm_star frame (comp_pre c)) tm_slprop = () in + let h2: slprop_equiv g' (tm_star (open_term_nv (comp_post c) x) frame) frame = () in let k: continuation_elaborator g (tm_star frame (tm_pure p)) g' (tm_star tm_emp frame) = continuation_elaborator_with_bind frame c st typing h x in k_elab_equiv (frame `tm_star` tm_pure p) frame k () h2 post t @@ -598,8 +598,8 @@ let elim_pure_step (g: env) (ctxt: slprop_view) : let g' = push_binding g (snd x) (fst x) ty in Some (| g', [], [], [], fun g'' -> (fun frame -> - let h1: slprop_equiv g (tm_star (elab_slprops frame) (tm_pure p)) (elab_slprops (frame @ [ctxt])) = RU.magic () in - let h2: slprop_equiv g' (elab_slprops frame) (elab_slprops (frame @ [] @ [])) = RU.magic () in + let h1: slprop_equiv g (tm_star (elab_slprops frame) (tm_pure p)) (elab_slprops (frame @ [ctxt])) = () in + let h2: slprop_equiv g' (elab_slprops frame) (elab_slprops (frame @ [] @ [])) = () in k_elab_equiv (elab_slprops (frame @ [ctxt])) (elab_slprops (frame @ [] @ [])) (elim_pure g (elab_slprops frame) p x g') h1 h2), cont_elab_refl _ _ _ (()) <: T.Tac _ |) @@ -613,9 +613,9 @@ let elim_with_pure (g: env) (frame: slprop) (p: term) (x: nvar { ~(Set.mem (snd let st = wtag (Some STT_Ghost) (Tm_ST { t = tm_unknown; args = [] }) in let c = C_STGhost tm_emp_inames { u=u0; res=ty; pre=tm_with_pure p (fst x) v; post=v } in assume open_term v (snd x) == v; // no loose bvars - let typing: st_typing g st c = RU.magic () in - let h: tot_typing g (tm_star frame (comp_pre c)) tm_slprop = RU.magic () in - let h2: slprop_equiv g' (tm_star (open_term_nv (comp_post c) x) frame) (tm_star frame v) = RU.magic () in + let typing: st_typing g st c = () in + let h: tot_typing g (tm_star frame (comp_pre c)) tm_slprop = () in + let h2: slprop_equiv g' (tm_star (open_term_nv (comp_post c) x) frame) (tm_star frame v) = () in let k: continuation_elaborator g (tm_star frame (tm_with_pure p (fst x) v)) g' (tm_star v frame) = continuation_elaborator_with_bind frame c st typing h x in k_elab_equiv (frame `tm_star` tm_with_pure p (fst x) v) (frame `tm_star` v) k () h2 post t @@ -629,8 +629,8 @@ let elim_with_pure_step (g: env) (ctxt: slprop_view) : let g' = push_binding g (snd x) (fst x) ty in Some (| g', [Unknown v], [], [], fun g'' -> (fun frame -> - let h1: slprop_equiv g (tm_star (elab_slprops frame) (tm_with_pure p (fst x) v)) (elab_slprops (frame @ [ctxt])) = RU.magic () in - let h2: slprop_equiv g' (tm_star (elab_slprops frame) v) (elab_slprops (frame @ [Unknown v] @ [])) = RU.magic () in + let h1: slprop_equiv g (tm_star (elab_slprops frame) (tm_with_pure p (fst x) v)) (elab_slprops (frame @ [ctxt])) = () in + let h2: slprop_equiv g' (tm_star (elab_slprops frame) v) (elab_slprops (frame @ [Unknown v] @ [])) = () in k_elab_equiv (elab_slprops (frame @ [ctxt])) (elab_slprops (frame @ [Unknown v] @ [])) (elim_with_pure g (elab_slprops frame) p x v g') h1 h2), cont_elab_refl _ _ _ (()) <: T.Tac _ |) @@ -642,14 +642,14 @@ let elim_exists (g: env) (frame: slprop) u b body (x: nvar { ~(Set.mem (snd x) ( continuation_elaborator g (frame `tm_star` tm_exists_sl u b body) g' (frame `tm_star` open_term' body (mk_reveal u b.binder_ty (term_of_nvar x)) 0) = fun post t -> let c = comp_elim_exists u b.binder_ty body x in - let h1: tot_typing g b.binder_ty (tm_type u) = RU.magic () in - let h2: tot_typing g (tm_exists_sl u (as_binder b.binder_ty) body) tm_slprop = RU.magic () in + let h1: tot_typing g b.binder_ty (tm_type u) = () in + let h2: tot_typing g (tm_exists_sl u (as_binder b.binder_ty) body) tm_slprop = () in let st : st_term = wtag (Some STT_Ghost) (Tm_ElimExists { p = tm_exists_sl u (as_binder b.binder_ty) body }) in let typing: st_typing g st c = () in - let h: tot_typing g (tm_star frame (comp_pre c)) tm_slprop = RU.magic () in + let h: tot_typing g (tm_star frame (comp_pre c)) tm_slprop = () in let c_post_x = open_term' body (mk_reveal u b.binder_ty (term_of_nvar x)) 0 in assume open_term (comp_post c) (snd x) == c_post_x; - let h2: slprop_equiv g' (tm_star c_post_x frame) (tm_star frame c_post_x) = RU.magic () in + let h2: slprop_equiv g' (tm_star c_post_x frame) (tm_star frame c_post_x) = () in let k: continuation_elaborator g (tm_star frame (tm_exists_sl u b body)) g' (tm_star c_post_x frame) = continuation_elaborator_with_bind frame c st typing h x in k_elab_equiv (frame `tm_star` tm_exists_sl u b body) (frame `tm_star` c_post_x) k () h2 post t @@ -666,8 +666,8 @@ let elim_exists_step (g: env) (ctxt: slprop_view) : let result = open_term' body (mk_reveal u b.binder_ty (term_of_nvar x)) 0 in Some (| g', [Unknown result], [], [], fun g'' -> (fun frame -> - let h1: slprop_equiv g (tm_star (elab_slprops frame) (tm_exists_sl u b body)) (elab_slprops (frame @ [ctxt])) = RU.magic () in - let h2: slprop_equiv g' (tm_star (elab_slprops frame) result) (elab_slprops (frame @ [] @ [Unknown result])) = RU.magic () in + let h1: slprop_equiv g (tm_star (elab_slprops frame) (tm_exists_sl u b body)) (elab_slprops (frame @ [ctxt])) = () in + let h2: slprop_equiv g' (tm_star (elab_slprops frame) result) (elab_slprops (frame @ [] @ [Unknown result])) = () in k_elab_equiv (elab_slprops (frame @ [ctxt])) (elab_slprops (frame @ [] @ [Unknown result])) (elim_exists g (elab_slprops frame) u b body x g') h1 h2), cont_elab_refl _ _ _ (()) <: T.Tac _ |) @@ -929,7 +929,7 @@ let prove_atom_unamb (g: env) (ctxt: list slprop_view) (goal: slprop_view) : let rest_ctxt = List.Tot.filter (fun (j, _) -> j <> i) ictxt |> List.Tot.map snd in Some (| g, rest_ctxt, [], [cand], fun g' -> let h2: slprop_equiv g' (elab_slprop cand) goal = check_slprop_equiv_ext (RU.range_of_term goal) _ _ _ in - let h1: slprop_equiv g (elab_slprops ctxt) (elab_slprops ([cand] @ rest_ctxt)) = RU.magic () in + let h1: slprop_equiv g (elab_slprops ctxt) (elab_slprops ([cand] @ rest_ctxt)) = () in let h2: slprop_equiv g' (elab_slprops ([cand] @ [])) goal = h2 in cont_elab_refl _ _ _ h1, cont_elab_refl _ _ _ h2 @@ -958,7 +958,7 @@ let prove_atom (g: env) (ctxt: list slprop_view) (allow_amb: bool) (goal: slprop let rest_ctxt = List.Tot.filter (fun (j, _) -> j <> i) ictxt |> List.Tot.map snd in Some (| g, rest_ctxt, [], [cand], fun g' -> let h2: slprop_equiv g' (elab_slprop cand) goal = check_slprop_equiv_ext (RU.range_of_term goal) _ _ _ in - let h1: slprop_equiv g (elab_slprops ctxt) (elab_slprops ([cand] @ rest_ctxt)) = RU.magic () in + let h1: slprop_equiv g (elab_slprops ctxt) (elab_slprops ([cand] @ rest_ctxt)) = () in let h2: slprop_equiv g' (elab_slprops ([cand] @ [])) goal = h2 in cont_elab_refl _ _ _ h1, cont_elab_refl _ _ _ h2 @@ -1032,9 +1032,9 @@ let try_apply_elim_lemma (g: env) (lid: R.name) (i: nat) (ctxt: slprop_view) : Some (| g, [Unknown post'], [], [], fun g'' -> let typing = core_check_term g t T.E_Ghost ty in let t' = wtag (Some STT_Ghost) (Tm_ST { t; args=[] }) in - let ni: non_informative g c = RU.magic () in + let ni: non_informative g c = () in let typing: st_typing g t' c = () in - let h1: tot_typing g (comp_pre c) tm_slprop = RU.magic () in + let h1: tot_typing g (comp_pre c) tm_slprop = () in let h2: slprop_equiv g (elab_slprops [Unknown (comp_pre c)]) (elab_slprops [ctxt]) = assume elab_slprop ctxt == pre; () in let h3: slprop_equiv g (elab_slprops [Unknown (open_term' (comp_post c) unit_const 0)]) @@ -1076,11 +1076,11 @@ let try_apply_eager_intro_lemma (g: env) (lid: R.name) (i: nat) ctxt (goal: slpr Some (| g, ctxt, [Unknown pre], [], fun g'' -> let typing = core_check_term g'' t T.E_Ghost ty in let t' = wtag (Some STT_Ghost) (Tm_ST { t; args=[] }) in - let ni: non_informative g'' c = RU.magic () in + let ni: non_informative g'' c = () in let typing: st_typing g'' t' c = () in - let h1: tot_typing g'' (comp_pre c) tm_slprop = RU.magic () in + let h1: tot_typing g'' (comp_pre c) tm_slprop = () in let h2: slprop_equiv g'' (elab_slprops [Unknown (comp_pre c)]) (elab_slprops ([] @ [Unknown pre])) = () in - let h3: slprop_equiv g'' (elab_slprops [Unknown (open_term' (comp_post c) unit_const 0)]) (elab_slprops [goal]) = RU.magic () in + let h3: slprop_equiv g'' (elab_slprops [Unknown (open_term' (comp_post c) unit_const 0)]) (elab_slprops [goal]) = () in let k_typing = cont_elab_with_bind_nondep_unit c t' typing h1 in cont_elab_refl g ctxt ([] @ ctxt) (()), cont_elab_equiv k_typing h2 h3 @@ -1137,7 +1137,7 @@ let prover_result_solved_unpack #g #ctxt #goals (res: prover_result_solved g ctx let (| g', ctxt', goals', solved, k |) = res in (| g', ctxt', cont_elab_thunk fun _ -> let k1, k2 = k g' in - let h: slprop_equiv g' (elab_slprops (solved @ ctxt')) (elab_slprops (ctxt' @ solved @ goals')) = RU.magic () in + let h: slprop_equiv g' (elab_slprops (solved @ ctxt')) (elab_slprops (ctxt' @ solved @ goals')) = () in cont_elab_trans k1 (cont_elab_frame k2 ctxt') h |) #restart-solver @@ -1180,14 +1180,14 @@ let try_apply_intro_lemma (g: env) (lid: R.name) (i: nat) ctxt (goal: slprop_vie let c = C_STGhost inames { pre; post; res; u } in let typing = core_check_term g' t T.E_Ghost ty in let t' = wtag (Some STT_Ghost) (Tm_ST { t; args=[] }) in - let ni: non_informative g' c = RU.magic () in + let ni: non_informative g' c = () in let typing: st_typing g' t' c = () in - let h1: tot_typing g' (comp_pre c) tm_slprop = RU.magic () in + let h1: tot_typing g' (comp_pre c) tm_slprop = () in let h2: slprop_equiv g' (elab_slprops (ctxt' @ [Unknown (comp_pre c)])) (elab_slprops (ctxt' @ [Unknown pre])) = - RU.magic () in + () in let h3: slprop_equiv g' (elab_slprops (ctxt' @ [Unknown (open_term' (comp_post c) unit_const 0)])) - (elab_slprops ([goal] @ ctxt' @ post''_rest)) = RU.magic () in + (elab_slprops ([goal] @ ctxt' @ post''_rest)) = () in let k_typing = cont_elab_with_bind_nondep_unit c t' typing h1 in let k_typing = cont_elab_frame k_typing ctxt' in let k_typing: cont_elab g' (ctxt' @ [Unknown pre]) g' ([goal] @ ctxt' @ post''_rest) = @@ -1338,8 +1338,8 @@ let try_prove (g: env) (ctxt goals: slprop) allow_amb : T.Tac (prover_result g [ let (| g1, ctxt1, goals1, solved1, k1 |) = try_prove_core pg [Unknown ctxt'] [Unknown goals'] in (| g1, ctxt1, goals1, solved1, fun (g2: env { env_extends g2 g1 }) -> let before, after = k1 g2 in - let h1: slprop_equiv g ctxt' ctxt = RU.magic () in - let h2: slprop_equiv g2 goals' goals = RU.magic () in + let h1: slprop_equiv g ctxt' ctxt = () in + let h2: slprop_equiv g2 goals' goals = () in cont_elab_equiv before h1 (()), cont_elab_equiv after (()) h2 |) @@ -1363,7 +1363,7 @@ let prove rng (g: env) (ctxt goals: slprop) allow_amb : let (| g', ctxt', k |) = prover_result_solved_unpack res in let h: slprop_equiv g' (elab_slprops ([] @ ctxt' @ [Unknown goals])) - (tm_star goals (RU.deep_compress_safe (elab_slprops ctxt'))) = RU.magic () in + (tm_star goals (RU.deep_compress_safe (elab_slprops ctxt'))) = () in (| g', RU.deep_compress_safe (elab_slprops ctxt'), k_elab_equiv ctxt (tm_star goals (RU.deep_compress_safe (elab_slprops ctxt'))) (k []) () h |) let rec try_elim_core (pg: penv) (ctxt: list slprop_view) : @@ -1396,28 +1396,28 @@ let elim_exists_and_pure (#g:env) (#ctxt:slprop) let ctxt' = Pulse.Checker.Prover.Substs.ss_term ctxt ss in let pg = mk_penv g false in let (| g', ctxt'', goals'', solved, k |) = try_elim_core pg [Unknown ctxt'] in - let h: tot_typing g' (elab_slprops ctxt'') tm_slprop = RU.magic () in // TODO thread through prover + let h: tot_typing g' (elab_slprops ctxt'') tm_slprop = () in // TODO thread through prover (| g', elab_slprops ctxt'', h, fun post_hint post_hint_typ -> let h1: slprop_equiv g (elab_slprops ([] @ [Unknown ctxt'])) ctxt = (RU.magic() <: slprop_equiv g ctxt' ctxt) in - let h2: slprop_equiv g' (elab_slprops (ctxt'' @ solved @ goals'')) (elab_slprops ([] @ solved @ ctxt'')) = RU.magic () in - let h3: slprop_equiv g' (elab_slprops (ctxt'' @ [])) (elab_slprops ctxt'') = RU.magic () in + let h2: slprop_equiv g' (elab_slprops (ctxt'' @ solved @ goals'')) (elab_slprops ([] @ solved @ ctxt'')) = () in + let h3: slprop_equiv g' (elab_slprops (ctxt'' @ [])) (elab_slprops ctxt'') = () in let before, after = k g' in k_elab_trans (k_elab_equiv ctxt (elab_slprops ([] @ solved @ ctxt'')) (before []) h1 (())) (k_elab_equiv (elab_slprops ([] @ solved @ ctxt'')) (elab_slprops ctxt'') (after ctxt'') h2 h3) post_hint post_hint_typ |) let k_unreach (g: env) (x: nvar { freshv g (snd x) }) (post_hint: post_hint_t { g `env_extends` post_hint.g }) : T.Tac (continuation_elaborator g tm_is_unreachable (push_binding g (snd x) (fst x) post_hint.ret_ty) (open_term_nv post_hint.post x)) = - let h: tot_typing g tm_is_unreachable tm_slprop = RU.magic () in + let h: tot_typing g tm_is_unreachable tm_slprop = () in let (| c, c_typ |) = Pulse.Typing.Combinators.comp_for_post_hint g tm_is_unreachable h post_hint (snd x) in let st = wtag (Some (ctag_of_comp_st c)) (Tm_Unreachable { c }) in let typ : st_typing g st c = () in let g' = push_binding g (snd x) (fst x) post_hint.ret_ty in let post_opened = open_term_nv post_hint.post x in let k_elim: continuation_elaborator g (tm_star tm_emp tm_is_unreachable) g' (tm_star post_opened tm_emp) = - let h3: tot_typing g (tm_star tm_emp tm_is_unreachable) tm_slprop = RU.magic () in + let h3: tot_typing g (tm_star tm_emp tm_is_unreachable) tm_slprop = () in continuation_elaborator_with_bind #g tm_emp c st typ h3 x in - let h4: slprop_equiv g (tm_star tm_emp tm_is_unreachable) tm_is_unreachable = RU.magic () in - let h5: slprop_equiv g' (tm_star post_opened tm_emp) post_opened = RU.magic () in + let h4: slprop_equiv g (tm_star tm_emp tm_is_unreachable) tm_is_unreachable = () in + let h5: slprop_equiv g' (tm_star post_opened tm_emp) post_opened = () in k_elab_equiv tm_is_unreachable post_opened k_elim h4 h5 #restart-solver @@ -1445,8 +1445,8 @@ let prove_post_hint (#g:env) (#ctxt:slprop) (r:checker_result_t g ctxt NoHint) ( let ppname = mk_ppname_no_range "_posth" in let post_hint_opened = open_term_nv post_hint.post (ppname, y) in let g4 = push_binding g3 y ppname post_hint.ret_ty in - let h1: universe_of g4 post_hint.ret_ty post_hint.u = RU.magic () in - let h2: tot_typing g4 post_hint_opened tm_slprop = RU.magic () in + let h1: universe_of g4 post_hint.ret_ty post_hint.u = () in + let h2: tot_typing g4 post_hint_opened tm_slprop = () in let k_unreach: continuation_elaborator g3 ctxt3 g4 post_hint_opened = k_unreach g3 (ppname, y) post_hint in (| y, g4, (| post_hint.u, post_hint.ret_ty, h1 |), (| post_hint_opened, h2 |), @@ -1477,11 +1477,11 @@ let prove_post_hint (#g:env) (#ctxt:slprop) (r:checker_result_t g ctxt NoHint) ( else text "Did you forget to free this resource?"); ] else - let h3: slprop_equiv g3 (tm_star post_hint_opened remaining_ctxt) post_hint_opened = RU.magic () in + let h3: slprop_equiv g3 (tm_star post_hint_opened remaining_ctxt) post_hint_opened = () in // for the typing of ty in g3, we have typing of ty in g2 above, and g3 `env_extends` g2 - let h1: universe_of g3 ty u_ty = RU.magic () in + let h1: universe_of g3 ty u_ty = () in // for the typing of post_hint_opened, again post_hint is well-typed in g, and g3 `env_extends` g - let h2: tot_typing g3 post_hint_opened tm_slprop = RU.magic () in + let h2: tot_typing g3 post_hint_opened tm_slprop = () in (| x, g3, (| u_ty, ty, h1 |), (| post_hint_opened, h2 |), k_elab_trans k (k_elab_equiv ctxt' post_hint_opened k_post () h3) |) #pop-options @@ -1493,6 +1493,6 @@ let try_frame_pre (allow_ambiguous : bool) (#g:env) T.Tac (checker_result_t g ctxt NoHint) = let (| t, c, d |) = d in let (| g', ctxt', k |) = prove t.range g ctxt (comp_pre c) allow_ambiguous in - let d: st_typing g' t c = RU.magic () in // weakening from g to g' - let h1: tot_typing g' ctxt' tm_slprop = RU.magic() in // weakening from to g' + let d: st_typing g' t c = () in // weakening from g to g' + let h1: tot_typing g' ctxt' tm_slprop = () in // weakening from to g' checker_result_for_st_typing (k _ (| t, add_frame c ctxt', () |)) res_ppname \ No newline at end of file diff --git a/src/checker/Pulse.Checker.ST.fst b/src/checker/Pulse.Checker.ST.fst index d21dc2f40..c087f022b 100644 --- a/src/checker/Pulse.Checker.ST.fst +++ b/src/checker/Pulse.Checker.ST.fst @@ -105,7 +105,7 @@ let check () ) in - let h: tot_typing g' ctxt' tm_slprop = RU.magic () in // TODO: thread through prover + let h: tot_typing g' ctxt' tm_slprop = () in // TODO: thread through prover if comp_post c `eq_tm` tm_is_unreachable then let framed = checker_result_for_st_typing (k _ (| t, add_frame c ctxt', () |)) res_ppname in RU.record_stats "prove_post_hint" fun _ -> prove_post_hint framed post_hint range diff --git a/src/checker/Pulse.Checker.While.fst b/src/checker/Pulse.Checker.While.fst index 9e4f726fd..088ab8281 100644 --- a/src/checker/Pulse.Checker.While.fst +++ b/src/checker/Pulse.Checker.While.fst @@ -40,7 +40,7 @@ let unit_typing g : universe_of g tm_unit u0 = admit() let inv_typing_weakening (#g:env) (#inv:slprop) (inv_typing:tot_typing g inv tm_slprop) : (x:FStar.Ghost.erased var {fresh_wrt x g (freevars inv)} & tot_typing (push_binding g x ppname_default tm_unit) (open_term inv x) tm_slprop) = let x : (x:FStar.Ghost.erased var {fresh_wrt x g (freevars inv)}) = RU.magic () in - let tt : tot_typing (push_binding g x ppname_default tm_unit) (open_term inv x) tm_slprop = RU.magic () in + let tt : tot_typing (push_binding g x ppname_default tm_unit) (open_term inv x) tm_slprop = () in (|x, tt|) let inv_as_post_hint (#g:env) (#inv:slprop) (inv_typing:tot_typing g inv tm_slprop) @@ -176,7 +176,7 @@ let check_while assume freshv g0 (snd x_meas); let g1 = push_binding g0 (snd x_meas) (fst x_meas) ty_meas in let inv = tm_star (RU.deep_compress_safe inv) remaining in - let inv_typing : tot_typing g1 inv tm_slprop = RU.magic () in + let inv_typing : tot_typing g1 inv tm_slprop = () in let res_cond : checker_result_t g1 inv (TypeHint tm_bool) = check (push_context "check_while_condition" cond.range g1) inv inv_typing (TypeHint tm_bool) ppname_default cond in let (| post_cond, r_cond |) : (ph:post_hint_for_env g1 & Pulse.Typing.Combinators.st_typing_in_ctxt g1 inv (PostHint ph)) = @@ -209,16 +209,16 @@ let check_while assert g1 `env_extends` g0; assert g1' `env_extends` g1; assert g1'' `env_extends` g1'; - let loop_ensures_typ: tot_typing g1'' loop_ensures tm_slprop = RU.magic () in - let unit_typ: universe_of g1'' tm_unit u0 = RU.magic () in + let loop_ensures_typ: tot_typing g1'' loop_ensures tm_slprop = () in + let unit_typ: universe_of g1'' tm_unit u0 = () in let loop_ensures = Pulse.JoinComp.infer_post' g0 g1'' y unit_typ loop_ensures_typ in let loop_ensures = subst_loop_requires_marker_with_true loop_ensures.post in let loop_ensures = open_term' loop_ensures unit_const 0 in - let loop_ensures_typ: tot_typing g0 loop_ensures tm_slprop = RU.magic () in + let loop_ensures_typ: tot_typing g0 loop_ensures tm_slprop = () in (| loop_ensures, loop_ensures_typ |) | None -> let t: term = tm_exists_sl u_meas (as_binder ty_meas) (close_term (open_term' post_cond.post tm_false 0) (snd x_meas)) in - let typ: tot_typing g0 t tm_slprop = RU.magic () in + let typ: tot_typing g0 t tm_slprop = () in (| t, typ |) in let break_lbl_c = C_ST { @@ -238,17 +238,17 @@ let check_while let post_cond : post_hint_for_env g2 = assume post_hint_for_env_p g2 post_cond; post_cond in let r_cond : Pulse.Typing.Combinators.st_typing_in_ctxt g2 inv (PostHint post_cond) = let (| t, c, typ |) = r_cond in - let typ : st_typing g2 t c = RU.magic () in + let typ : st_typing g2 t c = () in (| t, c, typ |) in let body_pre_open = post_cond.post in - let body_post_typing : tot_typing g2 (comp_post (comp_while_body u_meas ty_meas is_tot x_meas inv body_pre_open)) tm_slprop = RU.magic () in + let body_post_typing : tot_typing g2 (comp_post (comp_while_body u_meas ty_meas is_tot x_meas inv body_pre_open)) tm_slprop = () in let body_ph : post_hint_for_env g2 = inv_as_post_hint body_post_typing in assert body_ph.ret_ty == tm_unit; let x = fresh g2 in assume (x == Ghost.reveal post_cond.x); let body_open_pre_typing : tot_typing (push_binding g2 x ppname_default tm_bool) (open_term body_pre_open x) tm_slprop = - RU.magic () in // post_cond.post_typing_src + () in // post_cond.post_typing_src let body_pre_typing = body_typing_subst_true body_open_pre_typing in let r_body = check @@ -263,10 +263,10 @@ let check_while assert (comp_u comp_body == comp_u (comp_while_body u_meas ty_meas is_tot x_meas inv body_pre_open)); assert (comp_res comp_body == comp_res (comp_while_body u_meas ty_meas is_tot x_meas inv body_pre_open)); assert (comp_body == comp_while_body u_meas ty_meas is_tot x_meas inv body_pre_open); - let inv_typing2 : tot_typing g2 inv tm_slprop = RU.magic () in + let inv_typing2 : tot_typing g2 inv tm_slprop = () in let while = wtag (Some STT) (Tm_While { invariant = inv; loop_requires = tm_unknown; meas = None; condition = cond; body }) in - let typ_meas: universe_of g1' ty_meas u_meas = RU.magic () in + let typ_meas: universe_of g1' ty_meas u_meas = () in assume ~(snd x_meas `Set.mem` freevars_st cond); assume ~(snd x_meas `Set.mem` freevars_st body); let d: st_typing g1' while (comp_while u_meas ty_meas x_meas inv body_pre_open) = @@ -311,7 +311,7 @@ let check_while let d_st: Pulse.Typing.Combinators.st_typing_in_ctxt g0 loop_pre0 (TypeHint tm_unit) = let (| t, c, _ |) = d_st in let c = with_st_comp c { st_comp_of_comp c with pre = loop_pre0 } in - let typ : st_typing g0 t c = RU.magic () in + let typ : st_typing g0 t c = () in (| t, c, typ |) in let d_st : Pulse.Typing.Combinators.st_typing_in_ctxt g pre NoHint = k NoHint d_st in diff --git a/src/checker/Pulse.JoinComp.fst b/src/checker/Pulse.JoinComp.fst index 0b6307c88..a3c83fd58 100644 --- a/src/checker/Pulse.JoinComp.fst +++ b/src/checker/Pulse.JoinComp.fst @@ -127,7 +127,7 @@ let infer_post' (g:env) (g':env { g' `env_extends` g }) let post' = open_term_nv post (ppname_default, x) in let g' = push_binding g x ppname_default t in // we just constructed it; should ideally prove it well-typed rather then re-checking it - let post_typing_src : tot_typing g' post' tm_slprop = RU.magic () in + let post_typing_src : tot_typing g' post' tm_slprop = () in assume (fresh_wrt x g (freevars post)); { g; effect_annot=EffectAnnotSTT; effect_annot_typing=(); diff --git a/src/checker/Pulse.Typing.Metatheory.Base.fst b/src/checker/Pulse.Typing.Metatheory.Base.fst index cbfd8ccf8..5fcc75401 100644 --- a/src/checker/Pulse.Typing.Metatheory.Base.fst +++ b/src/checker/Pulse.Typing.Metatheory.Base.fst @@ -33,7 +33,7 @@ let st_typing_correctness_ctot (g:env) (t:st_term) (c:comp{C_Tot? c}) (_:st_typing g t c) : (u:Ghost.erased universe & universe_of g (comp_res c) u) = let u : Ghost.erased universe = RU.magic () in - let ty : universe_of g (comp_res c) u = RU.magic() in + let ty : universe_of g (comp_res c) u = () in (| u, ty |) let st_typing_correctness (g:env) (t:st_term) (c:comp_st) diff --git a/src/checker/Pulse.Typing.Metatheory.Base.fsti b/src/checker/Pulse.Typing.Metatheory.Base.fsti index 65649cf6e..21ca280d1 100644 --- a/src/checker/Pulse.Typing.Metatheory.Base.fsti +++ b/src/checker/Pulse.Typing.Metatheory.Base.fsti @@ -121,7 +121,7 @@ let veq_weakening (g:env) (g':env { disjoint g g' }) (v1 v2:slprop) (_:slprop_equiv (push_env g g') v1 v2) (g1:env { pairwise_disjoint g g1 g' }) - : slprop_equiv (push_env (push_env g g1) g') v1 v2 = RU.magic () + : slprop_equiv (push_env (push_env g g1) g') v1 v2 = () let nt (x:var) (t:term) = [ RT.NT x t ] @@ -131,7 +131,7 @@ let slprop_equiv_rename (y:var{freshv g y}) tx ty (eq:RT.equiv (elab_env g) tx ty) (v:slprop_equiv (push_binding g x ppname_default tx) (open_term t0 x) (open_term t1 x)) : slprop_equiv (push_binding g y ppname_default ty) (open_term t0 y) (open_term t1 y) -= RU.magic() += () let freevars_slprop_equiv (g:env) (t0 t1:term) (d:slprop_equiv g t0 t1) : Lemma ((freevars t0 `Set.subset` dom g) /\ (freevars t1 `Set.subset` dom g)) From 7bb33aa67c7705e5d902a22781b93f0d074d6544 Mon Sep 17 00:00:00 2001 From: Gabriel Ebner Date: Fri, 27 Feb 2026 20:04:08 +0000 Subject: [PATCH 08/18] Simplify types by dropping unit-typed components from dependent tuples MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Drop st_typing, tot_typing, universe_of, slprop_equiv, comp_typing, and other unit-typed proof components from return types and destructuring patterns across the checker codebase. Key changes: - st_typing_in_ctxt: 3-tuple → 2-tuple (drop st_typing) - checker_result_t: simplify type_info from (universe & typ & universe_of) to (universe & typ), and ctxt from (slprop & tot_typing) to slprop - match_comp_res_with_post_hint: return comp_st directly - comp_for_post_hint: return comp_st directly - add_frame/apply_frame/mk_bind: return 2-tuples - check_universe: return universe directly - compute_tot_term_type: return (term & typ) instead of 3-tuple - compute_term_type_and_u: flatten universe out of nested tuple - normalize_slprop: return slprop directly - non_informative_t: simplify to just term - st_typing_correctness_ctot: return Ghost.erased universe directly - purify_and_check_spec: return slprop directly - check_abs/check_abs_core: return 2-tuple Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/checker/Pulse.Checker.Abs.fst | 49 +++++----- src/checker/Pulse.Checker.Abs.fsti | 2 +- src/checker/Pulse.Checker.Admit.fst | 15 ++-- .../Pulse.Checker.AssertWithBinders.fst | 8 +- src/checker/Pulse.Checker.Base.fst | 90 +++++++++---------- src/checker/Pulse.Checker.Base.fsti | 20 ++--- src/checker/Pulse.Checker.Bind.fst | 16 ++-- src/checker/Pulse.Checker.Comp.fst | 2 +- src/checker/Pulse.Checker.Exists.fst | 10 +-- .../Pulse.Checker.ForwardJumpLabel.fst | 8 +- src/checker/Pulse.Checker.Goto.fst | 4 +- src/checker/Pulse.Checker.If.fst | 10 +-- src/checker/Pulse.Checker.ImpureSpec.fst | 6 +- src/checker/Pulse.Checker.ImpureSpec.fsti | 2 +- src/checker/Pulse.Checker.IntroPure.fst | 4 +- src/checker/Pulse.Checker.Match.fst | 6 +- .../Pulse.Checker.Prover.Normalize.fst | 16 ++-- .../Pulse.Checker.Prover.Normalize.fsti | 6 +- src/checker/Pulse.Checker.Prover.fst | 22 ++--- src/checker/Pulse.Checker.Prover.fsti | 2 +- src/checker/Pulse.Checker.Pure.fst | 20 ++--- src/checker/Pulse.Checker.Pure.fsti | 12 ++- src/checker/Pulse.Checker.Return.fst | 16 ++-- src/checker/Pulse.Checker.Rewrite.fst | 4 +- src/checker/Pulse.Checker.ST.fst | 6 +- src/checker/Pulse.Checker.While.fst | 26 +++--- src/checker/Pulse.Checker.WithLocal.fst | 14 +-- src/checker/Pulse.Checker.WithLocalArray.fst | 12 +-- src/checker/Pulse.JoinComp.fst | 14 +-- src/checker/Pulse.JoinComp.fsti | 4 +- src/checker/Pulse.Main.fst | 8 +- src/checker/Pulse.Typing.Combinators.fst | 63 ++++++------- src/checker/Pulse.Typing.Combinators.fsti | 25 ++---- src/checker/Pulse.Typing.Metatheory.Base.fst | 8 +- src/checker/Pulse.Typing.Metatheory.Base.fsti | 2 +- src/checker/Pulse.Typing.fst | 2 +- 36 files changed, 249 insertions(+), 285 deletions(-) diff --git a/src/checker/Pulse.Checker.Abs.fst b/src/checker/Pulse.Checker.Abs.fst index 0835444e4..3211ffe17 100644 --- a/src/checker/Pulse.Checker.Abs.fst +++ b/src/checker/Pulse.Checker.Abs.fst @@ -399,13 +399,13 @@ let maybe_rewrite_body_typing (#g:_) (#e:st_term) (#c:comp) (d:st_typing g e c) (asc:comp_ascription) - : T.Tac (c':comp & st_typing g e c') + : T.Tac comp = let open Pulse.PP in match asc.annotated, c with - | None, _ -> (| c, d |) + | None, _ -> c | Some (C_Tot t), C_Tot t' -> ( let t, _ = Pulse.Checker.Pure.instantiate_term_implicits g t None false in - let (| u, t_typing |) = Pulse.Checker.Pure.check_universe g t in + let u = Pulse.Checker.Pure.check_universe g t in match T.t_check_equiv true true (elab_env g) t t' with | None, _ -> Env.fail_doc g (Some e.range) [ @@ -426,7 +426,7 @@ let maybe_rewrite_body_typing let tok' : st_equiv g (C_Tot t') (C_Tot t) = () in - (| C_Tot t, () |) + C_Tot t ) (* c is not a C_Tot *) @@ -455,15 +455,15 @@ let rec check_abs_core (g:env) (t:st_term{Tm_Abs? t.term}) (check:check_t) - : T.Tac (t:st_term & c:comp & st_typing g t c) = + : T.Tac (t:st_term & c:comp) = //warn g (Some t.range) (Printf.sprintf "check_abs_core, t = %s" (P.st_term_to_string t)); let range = t.range in match t.term with | Tm_Abs { b = {binder_ty=t;binder_ppname=ppname;binder_attrs}; q=qual; ascription=asc; body } -> //pre=pre_hint; body; ret_ty; post=post_hint_body } -> let qual = T.map_opt (check_qual g) qual in (* (fun (x:t) -> {pre_hint} body : t { post_hint } *) - let (| t, _, _ |) = compute_tot_term_type g t in //elaborate it first - let (| u, t_typing |) = universe_of_well_typed_term g t in //then check that its universe ... We could collapse the two calls + let (| t, _ |) = compute_tot_term_type g t in //elaborate it first + let u = universe_of_well_typed_term g t in //then check that its universe ... We could collapse the two calls let x = fresh g in let px = ppname, x in let var = tm_var {nm_ppname=ppname;nm_index=x} in @@ -473,25 +473,20 @@ let rec check_abs_core match body_opened.term with | Tm_Abs _ -> (* Check the opened body *) - let (| body, c_body, body_typing |) = check_abs_core g' body_opened check in + let (| body, c_body |) = check_abs_core g' body_opened check in (* First lift into annotated effect *) - let (| c_body, body_typing |) : ( c_body:comp & st_typing g' body c_body ) = + let c_body : comp = match sub_effect_comp g' body.range asc c_body with - | None -> (| c_body, body_typing |) - | Some (| c_body, lift |) -> - let body_typing : st_typing g' body c_body = () in - (| c_body, body_typing |) + | None -> c_body + | Some (| c_body, lift |) -> c_body in (* Check if it matches annotation (if any, likely not), and adjust derivation if needed. Currently this only subtypes the invariants. *) let (| c_body, d_sub |) = check_effect_annotation g' body.range asc c_body in let body_typing : st_typing g' body c_body = () in - (* Similar to above, fixes the type of the computation if we need to match - its annotation. TODO: merge these two by adding a tot subtyping (or equiv) - case to the st_sub judg. *) - let (| c_body, body_typing |) = maybe_rewrite_body_typing body_typing asc in + let c_body = maybe_rewrite_body_typing body_typing asc in FV.st_typing_freevars g' body c_body body_typing; let body_closed = close_st_term body x in @@ -507,8 +502,7 @@ let rec check_abs_core let b = {binder_ty=t;binder_ppname=ppname;binder_attrs} in let tres = tm_arrow {binder_ty=t;binder_ppname=ppname;binder_attrs} qual (close_comp c_body x) in let abs_st = wtag None (Tm_Abs { b; q=qual; body=body_closed; ascription=empty_ascription}) in - let tt : st_typing g abs_st (C_Tot tres) = () in - (| abs_st, C_Tot tres, tt |) + (| abs_st, C_Tot tres |) | _ -> let elab_c, pre_opened, inames_opened, ret_ty, post_hint_body = match asc.elaborated with @@ -583,25 +577,23 @@ let rec check_abs_core let r = Pulse.Checker.Prover.prove_post_hint r (PostHint ph) (T.range_of_term t) in (| PostHint ph, r |) in - let (| body, c_body, body_typing |) : st_typing_in_ctxt g' pre_opened post = + let (| body, c_body |) : st_typing_in_ctxt g' pre_opened post = RU.record_stats "apply_checker_result_k" fun _ -> apply_checker_result_k #_ #_ #(PostHint?.v post) r ppname_ret in let c_opened : comp_ascription = { annotated = None; elaborated = Some (open_comp_nv elab_c px) } in (* First lift into annotated effect *) - let (| c_body, body_typing |) : ( c_body:comp & st_typing g' body c_body ) = + let c_body : comp = match sub_effect_comp g' body.range c_opened c_body with - | None -> (| c_body, body_typing |) - | Some (| c_body, lift |) -> - let body_typing : st_typing g' body c_body = () in - (| c_body, body_typing |) + | None -> c_body + | Some (| c_body, lift |) -> c_body in let (| c_body, d_sub |) = check_effect_annotation g' body.range c_opened c_body in let body_typing : st_typing g' body c_body = () in - let (| c_body, body_typing |) = maybe_rewrite_body_typing body_typing asc in + let c_body = maybe_rewrite_body_typing body_typing asc in FV.st_typing_freevars g' body c_body body_typing; let body_closed = close_st_term body x in @@ -609,12 +601,11 @@ let rec check_abs_core let b = {binder_ty=t;binder_ppname=ppname;binder_attrs} in let tres = tm_arrow {binder_ty=t;binder_ppname=ppname;binder_attrs} qual (close_comp c_body x) in let abs_st = wtag None (Tm_Abs { b; q=qual; body=body_closed; ascription=empty_ascription}) in - let tt : st_typing g abs_st (C_Tot tres) = () in - (| abs_st, C_Tot tres, tt |) + (| abs_st, C_Tot tres |) #pop-options let check_abs (g:env) (t:st_term{Tm_Abs? t.term}) (check:check_t) - : T.Tac (t:st_term & c:comp & st_typing g t c) = + : T.Tac (t:st_term & c:comp) = let t = preprocess_abs g t in check_abs_core g t check diff --git a/src/checker/Pulse.Checker.Abs.fsti b/src/checker/Pulse.Checker.Abs.fsti index dd55ef5bb..fde798451 100644 --- a/src/checker/Pulse.Checker.Abs.fsti +++ b/src/checker/Pulse.Checker.Abs.fsti @@ -32,4 +32,4 @@ val check_abs (g:env) (t:st_term{Tm_Abs? t.term}) (check:check_t) - : T.Tac (t:st_term & c:comp & st_typing g t c) + : T.Tac (t:st_term & c:comp) diff --git a/src/checker/Pulse.Checker.Admit.fst b/src/checker/Pulse.Checker.Admit.fst index eed2bc1b5..87d0dc528 100644 --- a/src/checker/Pulse.Checker.Admit.fst +++ b/src/checker/Pulse.Checker.Admit.fst @@ -44,8 +44,7 @@ let check let x = fresh g in let px = v_as_nv x in let res - : (c:comp_st { comp_pre c == pre /\ comp_post_matches_hint c post_hint } & - comp_typing g c (universe_of_comp c)) + : c:comp_st { comp_pre c == pre /\ comp_post_matches_hint c post_hint } = match post, post_hint with | None, NoHint | None, TypeHint _ -> @@ -58,7 +57,7 @@ let check (P.term_to_string post2.post)) | Some post, _ -> - let (| u, t_typing |) = check_universe g t in + let u = check_universe g t in let post_opened = open_term_nv post px in let (| post_opened, post_typing |) = check_tot_term (push_binding g x (fst px) t) post_opened tm_slprop @@ -68,13 +67,13 @@ let check assume (open_term (close_term post_opened x) x == post_opened); let d_s : st_comp_typing g s = () in (match c with - | STT -> (| C_ST s, () |) - | STT_Ghost -> (| C_STGhost tm_emp_inames s, () |) - | STT_Atomic -> (| C_STAtomic tm_emp_inames Neutral s, () |)) + | STT -> C_ST s + | STT_Ghost -> C_STGhost tm_emp_inames s + | STT_Atomic -> C_STAtomic tm_emp_inames Neutral s) | _, PostHint post -> Pulse.Typing.Combinators.comp_for_post_hint g pre pre_typing post x in - let (| c, d_c |) = res in + let c = res in let admit_st = wtag (Some (ctag_of_comp_st c)) (Tm_Admit { ctag=ctag_of_comp_st c; u=comp_u c; @@ -97,4 +96,4 @@ let check ] in info_doc_env g (Some t0.range) msg end else ()) <: T.Tac unit; - checker_result_for_st_typing (| admit_st, c, d |) res_ppname + checker_result_for_st_typing (| admit_st, c |) res_ppname diff --git a/src/checker/Pulse.Checker.AssertWithBinders.fst b/src/checker/Pulse.Checker.AssertWithBinders.fst index 426101487..add3c6379 100644 --- a/src/checker/Pulse.Checker.AssertWithBinders.fst +++ b/src/checker/Pulse.Checker.AssertWithBinders.fst @@ -218,10 +218,10 @@ let rewrite_all rng (is_source:bool) (g:env) (p: list (term & term)) (t:term) pr rewrite. Otherwise, tactics may become brittle as the goal is changed unexpectedly by other things in the context. See tests/Match.fst. *) let use_rwr = None? tac_opt in - let norm (t:term) : T.Tac term = dfst <| normalize_slprop g t use_rwr in + let norm (t:term) : T.Tac term = normalize_slprop g t use_rwr in let t = let t, _ = Pulse.Checker.Pure.instantiate_term_implicits g t None true in - let t = dfst <| normalize_slprop g t use_rwr in + let t = normalize_slprop g t use_rwr in t in let maybe_purify t = if elaborated then t else purify_term g {ctxt_now=pre;ctxt_old=None} t in @@ -355,7 +355,7 @@ let check_renaming let h2: slprop_equiv g rhs pre = () in let h1: tot_typing g rhs tm_slprop = () in let (| x, g', ty, ctxt', k |) = check g rhs h1 post_hint res_ppname body in - (| x, g', ty, ctxt', k_elab_equiv pre (dfst ctxt') k h2 () |) + (| x, g', ty, ctxt', k_elab_equiv pre ctxt' k h2 () |) | [], Some goal -> ( let rhs, _ = rewrite_all st.range (T.unseal st.source) g pairs goal pre elaborated tac_opt true in @@ -560,4 +560,4 @@ let check let (| x, g'', ty, ctxt', k' |) = check g' (tm_star pre_remaining rhs') h1 post_hint res_ppname body in - (| x, g'', ty, ctxt', k_elab_trans k (k_elab_equiv (tm_star lhs pre_remaining) (dfst ctxt') k' h2 ()) |) + (| x, g'', ty, ctxt', k_elab_trans k (k_elab_equiv (tm_star lhs pre_remaining) ctxt' k' h2 ()) |) diff --git a/src/checker/Pulse.Checker.Base.fst b/src/checker/Pulse.Checker.Base.fst index d0bf17f7c..70813d6a6 100644 --- a/src/checker/Pulse.Checker.Base.fst +++ b/src/checker/Pulse.Checker.Base.fst @@ -119,7 +119,7 @@ let intro_post_hint g effect_annot ret_ty_opt post = | Some t -> t in let ret_ty, _ = CP.instantiate_term_implicits g ret_ty None false in - let (| u, ty_typing |) = CP.check_universe g ret_ty in + let u = CP.check_universe g ret_ty in let (| post, post_typing |) = CP.check_slprop (push_binding g x ppname_default ret_ty) (open_term_nv post (v_as_nv x)) in let post' = close_term post x in Pulse.Typing.FV.freevars_close_term post x 0; @@ -128,7 +128,7 @@ let intro_post_hint g effect_annot ret_ty_opt post = { g; effect_annot; effect_annot_typing; - ret_ty; u; ty_typing; + ret_ty; u; ty_typing=(); post=post'; x; post_typing_src=post_typing } @@ -282,11 +282,9 @@ let k_elab_equiv_continuation (#g1:env) (#g2:env { g2 `env_extends` g1 }) (#ctxt (d:slprop_equiv g2 ctxt1 ctxt2) : continuation_elaborator g1 ctxt g2 ctxt2 = fun post_hint res -> - let (| st, c, st_d |) = res in - let st_d : st_typing g2 st c = st_d in + let (| st, c |) = res in assert (comp_pre c == ctxt2); - let st_d' : st_typing g2 st (comp_with_pre c ctxt1) = st_equiv_pre st_d _ () in - k post_hint (| st, comp_with_pre c ctxt1, st_d' |) + k post_hint (| st, comp_with_pre c ctxt1 |) let slprop_equiv_typing_fwd (#g:env) (#ctxt:_) (ctxt_typing:tot_typing g ctxt tm_slprop) (p:_) (d:slprop_equiv g ctxt p) @@ -301,13 +299,12 @@ let k_elab_equiv_prefix : continuation_elaborator g1 ctxt2 g2 ctxt = fun post_hint res -> let framing_token : frame_for_req_in_ctxt g1 ctxt2 ctxt1 = - let d = () in - (| tm_emp, emp_typing, d |) + tm_emp in let res = k post_hint res in - let (| st, c, st_d |) = res in + let (| st, c |) = res in assert (comp_pre c == ctxt1); - (| st, comp_with_pre c ctxt2, st_equiv_pre st_d ctxt2 d |) + (| st, comp_with_pre c ctxt2 |) let k_elab_equiv (#g1:env) (#g2:env { g2 `env_extends` g1 }) (#ctxt1 #ctxt2:term) (ctxt1' ctxt2':term) @@ -343,16 +340,16 @@ let continuation_elaborator_with_bind' (#g:env) (ctxt:term) // let p_prop = Metatheory.pure_typing_inversion pure_typing in let v_eq = () in let framing_token : frame_for_req_in_ctxt g (tm_star ctxt pre1) pre1 = - (| ctxt, ctxt_typing, () |) + ctxt in Pulse.Checker.Prover.Util.debug_prover g (fun _ -> Printf.sprintf "Applying frame %s to computation %s\n" (show ctxt) (show c1)); - let (| c1, e1_typing |) = + let c1 = apply_frame g e1 (tm_star ctxt pre1) ctxt_pre1_typing c1 e1_typing framing_token in let (| u_of_1, pre_typing, _, _ |) = - Metatheory.(st_comp_typing_inversion g (st_comp_of_comp c1) (fst <| comp_typing_inversion g c1 (st_typing_correctness g e1 c1 e1_typing))) in + Metatheory.(st_comp_typing_inversion g (st_comp_of_comp c1) (fst <| comp_typing_inversion g c1 (st_typing_correctness g e1 c1 ()))) in let b = res1 in let ppname, x = x in let g' = push_binding g x ppname b in @@ -360,9 +357,8 @@ let continuation_elaborator_with_bind' (#g:env) (ctxt:term) let post1_opened = open_term_nv post1 (v_as_nv x) in let k : continuation_elaborator g (tm_star ctxt pre1) g' (tm_star post1_opened ctxt) = fun post_hint res -> - let (| e2, c2, e2_typing |) = res in + let (| e2, c2 |) = res in assert (comp_post_matches_hint c2 post_hint); - let e2_typing : st_typing g' e2 c2 = e2_typing in let e2_closed = close_st_term e2 x in assume (open_st_term e2_closed x == e2); assert (comp_pre c1 == (tm_star ctxt pre1)); @@ -377,7 +373,7 @@ let continuation_elaborator_with_bind' (#g:env) (ctxt:term) if x `Set.mem` freevars (RU.deep_compress_safe (comp_post c2)) then fail g' None ("Impossible: freevar clash when constructing continuation elaborator for bind, please file a bug-report" ^ show (comp_post c2)) else ( - let t_typing, post_typing = + let _ = RU.record_stats "bind_res_and_post_typing" fun _ -> Pulse.Typing.Combinators.bind_res_and_post_typing g c2 x post_hint in let g = push_context g "mk_bind" e1.range in @@ -387,17 +383,17 @@ let continuation_elaborator_with_bind' (#g:env) (ctxt:term) // prefix 4 1 (doc_of_string "mk_bind e2 = ") (doc_of_string (Pulse.Syntax.Printer.st_term_to_string e2)); // prefix 4 1 (doc_of_string "mk_bind c2 = ") (pp #comp c2)] // ; - let (| e, c, e_typing |) = + let (| e, c |) = Pulse.Typing.Combinators.mk_bind g (tm_star ctxt pre1) e1 e2_closed c1 c2 (ppname, x) e1_typing u_of_1 - e2_typing - t_typing - post_typing + () + () + () post_hint in - (| e, c, e_typing |) + (| e, c |) ) in k @@ -482,16 +478,15 @@ let continuation_elaborator_with_bind_fn (#g:env) (ctxt:term) (push_binding g (snd x) ppname_default (comp_res c1)) ctxt) = let t1 = comp_res c1 in assert ((push_binding g (snd x) (fst x) t1) `env_extends` g); - fun post_hint (| e2, c2, d2 |) -> + fun post_hint (| e2, c2 |) -> if not (PostHint? post_hint) then T.fail "bind_fn: expects the post_hint to be set"; let ppname, x = x in let e2_closed = close_st_term e2 x in assume (open_st_term (close_st_term e2 x) x == e2); let e = wrst c2 (Tm_Bind {binder=b; head=e1; body=e2_closed}) in - let (| u, _ |) = Pulse.Typing.Metatheory.Base.st_typing_correctness_ctot g e1 c1 e1_typing in + let u = Pulse.Typing.Metatheory.Base.st_typing_correctness_ctot g e1 c1 e1_typing in let c2_typing : comp_typing g c2 (universe_of_comp c2) = () in - let d : st_typing g e c2 = () in - (| e, c2, d |) + (| e, c2 |) let rec check_equiv_emp (g:env) (vp:term) : option (slprop_equiv g vp tm_emp) @@ -537,32 +532,31 @@ let return_in_ctxt (g:env) (y:var) (y_ppname:ppname) (u:universe) (ty:term) (ctx let pht = post_hint_typing g post_hint x in let validity = emp_inames_included g opens pht.effect_annot_typing in let c' = C_STAtomic opens obs st in - (| t, c', () |) + (| t, c' |) | C_STGhost _ st, EffectAnnotGhost { opens } | C_STGhost _ st, EffectAnnotAtomicOrGhost { opens } -> assert (comp_inames c == tm_emp_inames); let pht = post_hint_typing g post_hint x in let validity = emp_inames_included g opens pht.effect_annot_typing in let c' = C_STGhost opens st in - (| t, c', () |) + (| t, c' |) | _ -> - (| t, c, d |) + (| t, c |) #push-options "--z3rlimit_factor 4 --ifuel 1 --split_queries always" #restart-solver let match_comp_res_with_post_hint (#g:env) (t:st_term) (c:comp_st) (d:st_typing g t c) (post_hint:post_hint_opt g) - : T.Tac (c':comp_st { comp_pre c' == comp_pre c } & - st_typing g t c') = + : T.Tac (c':comp_st { comp_pre c' == comp_pre c }) = match post_hint with - | NoHint -> (| c, d |) + | NoHint -> c | TypeHint ret_ty | PostHint { ret_ty } -> let cres = comp_res c in if eq_tm cres ret_ty - then (| c, d |) + then c else match Pulse.Typing.Util.check_equiv_now (elab_env g) cres ret_ty with | None, issues -> let open Pulse.PP in @@ -578,7 +572,7 @@ let match_comp_res_with_post_hint (#g:env) (t:st_term) (c:comp_st) let c' = with_st_comp c {(st_comp_of_comp c) with res = ret_ty } in let d_stequiv : st_equiv g c c' = () in - (| c', Pulse.Typing.Combinators.t_equiv g t c d c' d_stequiv |) + c' #pop-options #pop-options @@ -588,12 +582,12 @@ let apply_checker_result_k (#g:env) (#ctxt:slprop) (#post_hint:post_hint_for_env : T.Tac (st_typing_in_ctxt g ctxt (PostHint post_hint)) = // TODO: FIXME add to checker result type? - let (| y, g1, (| u_ty, ty_y, d_ty_y |), (| pre', _ |), k |) = r in + let (| y, g1, (u_ty, ty_y), pre', k |) = r in - let (| u_ty_y, d_ty_y |) = Pulse.Checker.Pure.universe_of_well_typed_term g1 ty_y in + let u_ty_y = Pulse.Checker.Pure.universe_of_well_typed_term g1 ty_y in let d : st_typing_in_ctxt g1 pre' (PostHint post_hint) = - return_in_ctxt g1 y res_ppname u_ty_y ty_y pre' d_ty_y (PostHint post_hint) in + return_in_ctxt g1 y res_ppname u_ty_y ty_y pre' () (PostHint post_hint) in k (PostHint post_hint) d @@ -603,34 +597,34 @@ let checker_result_for_st_typing (#g:env) (#ctxt:slprop) (#post_hint:post_hint_o (d:st_typing_in_ctxt g ctxt post_hint) (ppname:ppname) : T.Tac (checker_result_t g ctxt post_hint) -= let (| e1, c1, d1 |) = d in += let (| e1, c1 |) = d in let x = fresh g in assume (~ (x `Set.mem` freevars (comp_post c1))); let u_of_1, pre_typing, post_typing = - Metatheory.(st_comp_typing_inversion_with_name g (st_comp_of_comp c1) (fst <| comp_typing_inversion g c1 (st_typing_correctness g e1 c1 d1)) x) in + Metatheory.(st_comp_typing_inversion_with_name g (st_comp_of_comp c1) (fst <| comp_typing_inversion g c1 (st_typing_correctness g e1 c1 ())) x) in let g' = push_binding g x ppname (comp_res c1) in let ctxt' = open_term_nv (comp_post c1) (ppname, x) in let k : continuation_elaborator g (comp_pre c1) g' ctxt' = fun post_hint st_k -> - let (| e2, c2, d2 |) = st_k in + let (| e2, c2 |) = st_k in let e2_closed = close_st_term e2 x in assume (open_st_term e2_closed x == e2); if x `Set.mem` freevars (comp_post c2) then fail g None "Impossible: freevar clash when constructing continuation elaborator for bind, please file a bug-report" else ( - let t_typing, post_typing = + let _ = Pulse.Typing.Combinators.bind_res_and_post_typing g c2 x post_hint in - let (| ee, cc, ee_typing |) = + let (| ee, cc |) = Pulse.Typing.Combinators.mk_bind g (comp_pre c1) e1 e2_closed c1 c2 (ppname, x) - d1 u_of_1 - d2 t_typing - post_typing + () u_of_1 + () () + () post_hint in - (| ee, cc, ee_typing |) + (| ee, cc |) ) in let _ : squash (checker_res_matches_post_hint g post_hint x (comp_res c1) ctxt') = @@ -641,7 +635,7 @@ let checker_result_for_st_typing (#g:env) (#ctxt:slprop) (#post_hint:post_hint_o assert (g' `env_extends` g); let u_of_1_g' : universe_of g' (comp_res c1) (comp_u c1) = () in assert (~ (x `Set.mem` freevars (comp_post c1))); - (| x, g', (| comp_u c1, comp_res c1, u_of_1_g' |), (| ctxt', post_typing |), k |) + (| x, g', (comp_u c1, comp_res c1), ctxt', k |) #pop-options let readback_comp_res_as_comp (c:T.comp) : option comp = @@ -718,7 +712,7 @@ let checker_result_t_equiv_ctxt (g:env) (ctxt ctxt' : slprop) (r : checker_result_t g ctxt post_hint) : checker_result_t g ctxt' post_hint = let (| x, g1, t, ctxt_r, k |) = r in - (| x, g1, t, ctxt_r, k_elab_equiv ctxt' (dfst ctxt_r) k equiv () |) + (| x, g1, t, ctxt_r, k_elab_equiv ctxt' ctxt_r k equiv () |) module RU = Pulse.RuntimeUtils let as_stateful_application (e:term) (head:term) (args:list T.argv { Cons? args }) @@ -1034,7 +1028,7 @@ let compose_checker_result_t (r1:checker_result_t g ctxt NoHint) (r2:checker_result_t g' ctxt' post_hint { composable r1 r2 }) : T.Tac (checker_result_t g ctxt post_hint) -= let (| x1, g1, t1, (| _, ctxt'_typing |), k1 |) = r1 in += let (| x1, g1, t1, ctxt1, k1 |) = r1 in let (| x2, g2, t2, ctxt2, k2 |) = r2 in let k = k_elab_trans k1 k2 in (| x2, g2, t2, ctxt2, k |) diff --git a/src/checker/Pulse.Checker.Base.fsti b/src/checker/Pulse.Checker.Base.fsti index 6163400a0..4f14bcfc7 100644 --- a/src/checker/Pulse.Checker.Base.fsti +++ b/src/checker/Pulse.Checker.Base.fsti @@ -155,11 +155,10 @@ let checker_res_matches_post_hint let checker_result_inv (g:env) (post_hint:post_hint_opt g) (x:var) (g1:env) - (t:(u:universe & t:term & universe_of g1 t u)) - (ctxt':(ctxt':slprop & tot_typing g1 ctxt' tm_slprop)) = + (u:universe) + (t:typ) + (ctxt':slprop) = - let (| _, t, _ |) = t in - let (| ctxt', _ |) = ctxt' in checker_res_matches_post_hint g post_hint x t ctxt' /\ lookup g1 x == Some t @@ -170,10 +169,10 @@ let checker_result_inv (g:env) (post_hint:post_hint_opt g) type checker_result_t (g:env) (ctxt:slprop) (post_hint:post_hint_opt g) = x:var & g1:env { g1 `env_extends` g } & - t:(u:universe & t:typ & universe_of g1 t u) & - ctxt':(ctxt':slprop & tot_typing g1 ctxt' tm_slprop) & - k:continuation_elaborator g ctxt g1 (dfst ctxt') { - checker_result_inv g post_hint x g1 t ctxt' + t:(universe & typ) & + ctxt':slprop & + k:continuation_elaborator g ctxt g1 ctxt' { + checker_result_inv g post_hint x g1 (fst t) (snd t) ctxt' } @@ -195,8 +194,7 @@ type check_t = val match_comp_res_with_post_hint (#g:env) (t:st_term) (c:comp_st) (d:st_typing g t c) (post_hint:post_hint_opt g) - : T.Tac (c':comp_st { comp_pre c' == comp_pre c } & - st_typing g t c') + : T.Tac (c':comp_st { comp_pre c' == comp_pre c }) val apply_checker_result_k (#g:env) (#ctxt:slprop) (#post_hint:post_hint_for_env g) (r:checker_result_t g ctxt (PostHint post_hint)) @@ -259,7 +257,7 @@ let composable (r2:checker_result_t g' ctxt' post_hint) = let (| x1, g1, t1, ctxt1, k1 |) = r1 in g1 == g' /\ - dfst ctxt1 == ctxt' + ctxt1 == ctxt' val compose_checker_result_t diff --git a/src/checker/Pulse.Checker.Bind.fst b/src/checker/Pulse.Checker.Bind.fst index 1485a5720..cf4befb30 100644 --- a/src/checker/Pulse.Checker.Bind.fst +++ b/src/checker/Pulse.Checker.Bind.fst @@ -44,7 +44,7 @@ let check_bind_fn = let Tm_Bind { binder; head; body } = t.term in match head.term with | Tm_Abs _ -> ( - let (| t, c, head_typing |) = Abs.check_abs g head check in + let (| t, c |) = Abs.check_abs g head check in if not (C_Tot? c) then fail g (Some t.range) "check_bind_fn: head is not a total abstraction"; if not (PostHint? post_hint) @@ -57,7 +57,7 @@ let check_bind_fn Metatheory.tot_typing_weakening_single g ctxt tm_slprop ctxt_typing x b.binder_ty in let r = check g' _ ctxt_typing' post_hint res_ppname (open_st_term_nv body (binder.binder_ppname, x)) in let body_typing = apply_checker_result_k #_ #_ #(PostHint?.v post_hint) r res_ppname in - let k = Pulse.Checker.Base.continuation_elaborator_with_bind_fn ctxt ctxt_typing t c b head_typing (binder.binder_ppname, x) in + let k = Pulse.Checker.Base.continuation_elaborator_with_bind_fn ctxt ctxt_typing t c b () (binder.binder_ppname, x) in let d = k post_hint body_typing in checker_result_for_st_typing d res_ppname ) @@ -69,7 +69,7 @@ let check_if_seq_lhs : T.Tac unit = if T.unseal e1.seq_lhs then begin - let (| _x, g, (| u, ty, ty_wf |), _ctxt', _k |) = r in + let (| _x, g, (u, ty), _ctxt', _k |) = r in let open Pulse.PP in if T.Tv_Arrow? ty then fail_doc g (Some e1.range) [ @@ -77,7 +77,7 @@ let check_if_seq_lhs text "Did you forget to apply some arguments?"; ] else if None? (fst <| T.is_non_informative (elab_env g) ty) then ( - if None? (Pulse.Checker.Pure.try_get_non_informative_witness g u ty ty_wf) then + if None? (Pulse.Checker.Pure.try_get_non_informative_witness g u ty ()) then fail_doc g (Some e1.range) [ prefix 2 1 (text "This statement returns a value of type:") (pp ty); text "Did you forget to assign it or ignore it?"; @@ -97,8 +97,8 @@ let check_binder_typ begin match inspect_term ty with | Tm_Unknown -> () | _ -> - let (| ty, _, _ |) = compute_tot_term_type g ty in //elaborate it first - let (| _, _, (| _, t, _ |), _, _ |) = r in + let (| ty, _ |) = compute_tot_term_type g ty in //elaborate it first + let (| _, _, (_, t), _, _ |) = r in // TODO: once we have the rename operation then we should // ditch this check and just elaborate the bind // let x : ty = stapp in ... @@ -153,9 +153,9 @@ let check_bind' let r0 = check g ctxt ctxt_typing NoHint binder.binder_ppname e1 in check_if_seq_lhs g ctxt _ r0 e1; check_binder_typ g ctxt _ r0 binder e1; - let (| x, g1, _, (| ctxt', ctxt'_typing |), k1 |) = r0 in + let (| x, g1, _, ctxt', k1 |) = r0 in let g1 = reset_context g1 g in - let r1 = check g1 ctxt' ctxt'_typing post_hint ppname_default (open_st_term_nv e2 (binder.binder_ppname, x)) in + let r1 = check g1 ctxt' () post_hint ppname_default (open_st_term_nv e2 (binder.binder_ppname, x)) in Pulse.Checker.Base.compose_checker_result_t r0 r1 in if not maybe_elaborate then dflt() diff --git a/src/checker/Pulse.Checker.Comp.fst b/src/checker/Pulse.Checker.Comp.fst index 5b54d5aee..fb16c5d28 100644 --- a/src/checker/Pulse.Checker.Comp.fst +++ b/src/checker/Pulse.Checker.Comp.fst @@ -34,7 +34,7 @@ let check (g:env) comp_res c == st.res /\ comp_post c == st.post } ) : T.Tac (st_comp_typing g st) - = let (| u, t_u |) = check_universe g st.res in + = let u = check_universe g st.res in if not (eq_univ u (comp_u c)) then fail g None (Printf.sprintf "check_comp: computed universe of %s as %s, whereas annotated as %s" diff --git a/src/checker/Pulse.Checker.Exists.fst b/src/checker/Pulse.Checker.Exists.fst index 6c108f56d..a9f3bfb06 100644 --- a/src/checker/Pulse.Checker.Exists.fst +++ b/src/checker/Pulse.Checker.Exists.fst @@ -85,14 +85,14 @@ let check_elim_exists let Tm_ExistsSL u { binder_ty=ty } p = tv in - let (| u', ty_typing |) = universe_of_well_typed_term g ty in + let u' = universe_of_well_typed_term g ty in if eq_univ u u' then let x = fresh g in let elim_st = wtag (Some STT_Ghost) (Tm_ElimExists { p = tm_exists_sl u (as_binder ty) p }) in let elim_c = comp_elim_exists u ty p (ppname_default, x) in let d : st_typing g elim_st elim_c = () in - let (|c,d|) = match_comp_res_with_post_hint elim_st elim_c d post_hint in - prove_post_hint (try_frame_pre false pre_typing (|elim_st,c,d|) res_ppname) post_hint t_rng + let c = match_comp_res_with_post_hint elim_st elim_c d post_hint in + prove_post_hint (try_frame_pre false pre_typing (|elim_st,c|) res_ppname) post_hint t_rng else fail g (Some t_rng) (Printf.sprintf "check_elim_exists: universe checking failed, computed %s, expected %s" (P.univ_to_string u') (P.univ_to_string u)) @@ -135,8 +135,8 @@ let check_intro_exists let intro_st = wtag (Some STT_Ghost) (Tm_IntroExists { p = tm_exists_sl u b p; witnesses = [witness] }) in let intro_c = C_STGhost tm_emp_inames { u=u0; res=tm_unit; pre=open_term' p witness 0; post=tm_exists_sl u b p } in let d : st_typing g intro_st intro_c = () in - let (| c, d |) = match_comp_res_with_post_hint intro_st intro_c d post_hint in - prove_post_hint (try_frame_pre false pre_typing (|intro_st, c, d|) res_ppname) + let c = match_comp_res_with_post_hint intro_st intro_c d post_hint in + prove_post_hint (try_frame_pre false pre_typing (|intro_st, c|) res_ppname) post_hint (Pulse.RuntimeUtils.range_of_term t) #pop-options diff --git a/src/checker/Pulse.Checker.ForwardJumpLabel.fst b/src/checker/Pulse.Checker.ForwardJumpLabel.fst index 1196d8afa..3bdd8c8ba 100644 --- a/src/checker/Pulse.Checker.ForwardJumpLabel.fst +++ b/src/checker/Pulse.Checker.ForwardJumpLabel.fst @@ -78,7 +78,7 @@ let check PostHint post in let body = open_st_term_nv body (lbl, lbl_x) in let body' = check g' pre pre_typing' post_hint' res_ppname body in - let (| body', body'_c, body'_typing |) = apply_checker_result_k #g' #pre #post body' res_ppname in + let (| body', body'_c |) = apply_checker_result_k #g' #pre #post body' res_ppname in assert comp_u body'_c == comp_u lbl_c; assert comp_res body'_c == comp_res lbl_c; assert comp_pre body'_c == pre; @@ -95,11 +95,11 @@ let check let typing: st_typing g t body'_c = () in if not has_explicit_post then ( assert post_hint0 == PostHint post; - checker_result_for_st_typing (| t, body'_c, typing |) res_ppname + checker_result_for_st_typing (| t, body'_c |) res_ppname ) else ( - let (| c'', typing'' |) = match_comp_res_with_post_hint t body'_c typing post_hint0 in + let c'' = match_comp_res_with_post_hint t body'_c typing post_hint0 in prove_post_hint #g - (try_frame_pre false #g pre_typing (|t,c'',typing''|) res_ppname) + (try_frame_pre false #g pre_typing (|t,c''|) res_ppname) post_hint0 rng ) diff --git a/src/checker/Pulse.Checker.Goto.fst b/src/checker/Pulse.Checker.Goto.fst index 6f0be518c..8030bb28b 100644 --- a/src/checker/Pulse.Checker.Goto.fst +++ b/src/checker/Pulse.Checker.Goto.fst @@ -53,9 +53,9 @@ let check' let x' = fresh g in assume fresh_wrt x' g (freevars ph.post); let pht = post_hint_typing g ph x' in () in - let (| c'', typing'' |) = match_comp_res_with_post_hint t c' typing post_hint in + let c' = match_comp_res_with_post_hint t c' typing post_hint in prove_post_hint #g - (try_frame_pre false #g pre_typing (|_,c'',typing''|) res_ppname) + (try_frame_pre false #g pre_typing (|t,c'|) res_ppname) post_hint rng | None -> diff --git a/src/checker/Pulse.Checker.If.fst b/src/checker/Pulse.Checker.If.fst index cf301d831..9e29f6506 100644 --- a/src/checker/Pulse.Checker.If.fst +++ b/src/checker/Pulse.Checker.If.fst @@ -91,8 +91,8 @@ let check let infer_post_branch (#eq_v:term) (r: checker_result_t (g_with_eq eq_v) pre NoHint) : T.Tac (p:post_hint_for_env g {p.g == g /\ p.effect_annot==EffectAnnotSTT}) = - let (| x, g', (| u, t, t_typ |), (| post, post_typing |), k |) = r in - J.infer_post' g g' x t_typ post_typing + let (| x, g', (u, t), post, k |) = r in + J.infer_post' g g' #u #t x () #post () in let then_ = check_branch tm_true e1 true in @@ -120,7 +120,7 @@ let check : T.Tac (br:st_term { ~(hyp `Set.mem` freevars_st br) } & c:comp_st { comp_pre c == pre /\ comp_post_matches_hint c (PostHint ph)} & st_typing g br c) - = let (| br, c, d |) = + = let (| br, c |) = let ppname = mk_ppname_no_range "_if_br" in apply_checker_result_k r ppname in @@ -130,7 +130,7 @@ let check // (Printf.sprintf "check_if: branch hypothesis is in freevars of checked %s branch" br_name) // else assume not (hyp `Set.mem` freevars_st br); - (| br, c, d |) + (| br, c, () |) in let (| e1, c1, e1_typing |) = extract then_ true in let (| e2, c2, e2_typing |) = extract else_ false in @@ -141,7 +141,7 @@ let check let if_st = wrst c (Tm_If { b; then_=e1; else_=e2; post=None }) in let d : st_typing_in_ctxt g pre (PostHint post_hint') = - (| if_st, c, () |) in + (| if_st, c |) in let res : checker_result_t g pre (PostHint post_hint') = checker_result_for_st_typing d res_ppname in retype_checker_result_post_hint post_hint' post_hint res diff --git a/src/checker/Pulse.Checker.ImpureSpec.fst b/src/checker/Pulse.Checker.ImpureSpec.fst index 074d368b6..90d53c310 100644 --- a/src/checker/Pulse.Checker.ImpureSpec.fst +++ b/src/checker/Pulse.Checker.ImpureSpec.fst @@ -77,7 +77,7 @@ let symb_eval_stateful_app (g: env) (ctxt: slprop) (t: term) : T.Tac R.term = let x_ppn = mk_ppname_no_range "result" in let g' = push_binding g x (mk_ppname_no_range "result") ty in let post = open_term_nv post (x_ppn, x) in - let (| post, _ |) = normalize_slprop g' post true in + let post = normalize_slprop g' post true in match get_rewrites_to_from_post g x post with | None -> let head, _ = T.collect_app_ln t in @@ -214,7 +214,7 @@ let rec run_elim_core (g: env) (ctxt: list slprop) : T.Tac (env & list nvar & li g', xs, c::ctxt' let run_elim (g: env) (ctxt: slprop) : T.Tac (env & list nvar & slprop) = - let (| ctxt, _ |) = normalize_slprop g ctxt true in + let ctxt = normalize_slprop g ctxt true in let g', xs, ctxt = run_elim_core g (slprop_as_list ctxt) in g', xs, list_as_slprop ctxt @@ -401,4 +401,4 @@ let purify_spec (g: env) (ctxt: ctxt) (t0: slprop) : T.Tac slprop = t let purify_and_check_spec (g: env) (ctxt: ctxt) (t: slprop) = - check_slprop g (purify_spec g ctxt t) \ No newline at end of file + dfst (check_slprop g (purify_spec g ctxt t)) \ No newline at end of file diff --git a/src/checker/Pulse.Checker.ImpureSpec.fsti b/src/checker/Pulse.Checker.ImpureSpec.fsti index d00d876d7..9330585b7 100644 --- a/src/checker/Pulse.Checker.ImpureSpec.fsti +++ b/src/checker/Pulse.Checker.ImpureSpec.fsti @@ -31,4 +31,4 @@ val purify_spec (g: env) (ctxt: ctxt) (t: slprop) : T.Tac slprop val purify_and_check_spec (g: env) (ctxt: ctxt) (t: slprop) : - T.Tac (t:slprop & tot_typing g t tm_slprop) \ No newline at end of file + T.Tac slprop \ No newline at end of file diff --git a/src/checker/Pulse.Checker.IntroPure.fst b/src/checker/Pulse.Checker.IntroPure.fst index 0816620b4..406d8639c 100644 --- a/src/checker/Pulse.Checker.IntroPure.fst +++ b/src/checker/Pulse.Checker.IntroPure.fst @@ -61,5 +61,5 @@ let check let intro_st = wtag (Some STT_Ghost) (Tm_IntroPure { p }) in let intro_c = C_STGhost tm_emp_inames { u=u0; res=tm_unit; pre=tm_emp; post=tm_pure p } in let st_typing : st_typing g intro_st intro_c = () in - let (| c,d |) = match_comp_res_with_post_hint intro_st intro_c st_typing post_hint in - prove_post_hint (try_frame_pre false pre_typing (|intro_st,c,d|) res_ppname) post_hint t.range + let c = match_comp_res_with_post_hint intro_st intro_c st_typing post_hint in + prove_post_hint (try_frame_pre false pre_typing (|intro_st,c|) res_ppname) post_hint t.range diff --git a/src/checker/Pulse.Checker.Match.fst b/src/checker/Pulse.Checker.Match.fst index cf05b2e5c..82073969b 100644 --- a/src/checker/Pulse.Checker.Match.fst +++ b/src/checker/Pulse.Checker.Match.fst @@ -278,7 +278,7 @@ let check_branch let pre_typing = tot_typing_weakening_n pulse_bs pre_typing in // weaken w/ binders let pre_typing = Pulse.Typing.Metatheory.tot_typing_weakening_single _ _ _ pre_typing hyp_var eq_typ in // weaken w/ branch eq - let (| e, c, e_d |) = + let (| e, c |) = let ppname = mk_ppname_no_range "_br" in let r = check g' pre pre_typing (PostHint post_hint) ppname e in apply_checker_result_k r ppname in @@ -531,7 +531,7 @@ let check let orig_brs = brs in let nbr = L.length brs in - let (| sc, sc_u, sc_ty, sc_ty_typing, sc_typing |) = compute_tot_term_type_and_u g sc in + let (| sc, sc_u, sc_ty |) = compute_tot_term_type_and_u g sc in let elab_pats = L.map elab_pat (L.map patof brs) in assertby (L.length elab_pats == L.length brs) (fun () -> @@ -579,5 +579,5 @@ let check let c_typing = comp_typing_from_post_hint c pre_typing post_hint in let t = wtag (Some (ctag_of_comp_st c)) (Tm_Match {sc; returns_=None; brs}) in let d : st_typing g t c = () in - checker_result_for_st_typing (| t, c, d |) res_ppname + checker_result_for_st_typing (| t, c |) res_ppname #pop-options \ No newline at end of file diff --git a/src/checker/Pulse.Checker.Prover.Normalize.fst b/src/checker/Pulse.Checker.Prover.Normalize.fst index d686d372f..852aeb378 100644 --- a/src/checker/Pulse.Checker.Prover.Normalize.fst +++ b/src/checker/Pulse.Checker.Prover.Normalize.fst @@ -28,7 +28,7 @@ open Pulse.Checker.Base let __normalize_slprop (g:env) (v:slprop) - : T.Tac (v':slprop & slprop_equiv g v v') + : T.Tac slprop = (* Keep things reduced *) let steps = [unascribe; primops; iota] in @@ -49,20 +49,20 @@ let __normalize_slprop let v' = PCP.norm_well_typed_term (elab_env g) steps v in let v' = Pulse.Simplify.simplify v' in (* NOTE: the simplify stage is unverified *) let v_equiv_v' : slprop_equiv g v v' = () in - (| v', v_equiv_v' |) + v' let normalize_slprop (g:env) (v:slprop) (use_rewrites_to : bool) - : T.Tac (v':slprop & slprop_equiv g v v') + : T.Tac slprop = if use_rewrites_to then let rwr = Pulse.Checker.Prover.RewritesTo.get_subst_from_env g in let v' = PS.ss_term v rwr in let eq_v_v' : slprop_equiv g v v' = () in - let (| v'', eq_v'_v'' |) = __normalize_slprop g v' in - (| v'', () |) + let v'' = __normalize_slprop g v' in + v'' else __normalize_slprop g v @@ -70,8 +70,8 @@ let normalize_slprop_welltyped (g:env) (v:slprop) (v_typing:tot_typing g v tm_slprop) - : T.Tac (v':slprop & slprop_equiv g v v' & tot_typing g v' tm_slprop) + : T.Tac slprop = - let (| v', v_equiv_v' |) = normalize_slprop g v true in + let v' = normalize_slprop g v true in // FIXME: prove (or add axiom) that equiv preserves typing - (| v', v_equiv_v', () |) \ No newline at end of file + v' \ No newline at end of file diff --git a/src/checker/Pulse.Checker.Prover.Normalize.fsti b/src/checker/Pulse.Checker.Prover.Normalize.fsti index 539d6a372..b857b1474 100644 --- a/src/checker/Pulse.Checker.Prover.Normalize.fsti +++ b/src/checker/Pulse.Checker.Prover.Normalize.fsti @@ -24,16 +24,16 @@ open Pulse.Typing val __normalize_slprop (g:env) (v:slprop) - : T.Tac (v':slprop & slprop_equiv g v v') + : T.Tac slprop val normalize_slprop (g:env) (v:slprop) (use_rewrites_to : bool) - : T.Tac (v':slprop & slprop_equiv g v v') + : T.Tac slprop val normalize_slprop_welltyped (g:env) (v:slprop) (v_typing:tot_typing g v tm_slprop) - : T.Tac (v':slprop & slprop_equiv g v v' & tot_typing g v' tm_slprop) + : T.Tac slprop diff --git a/src/checker/Pulse.Checker.Prover.fst b/src/checker/Pulse.Checker.Prover.fst index c0ad3a63e..9803791fd 100644 --- a/src/checker/Pulse.Checker.Prover.fst +++ b/src/checker/Pulse.Checker.Prover.fst @@ -477,7 +477,7 @@ let unpack_and_norm_goal (g: env) (ctxt: list slprop_view) (goal: slprop_view) : T.Tac (option (prover_result g ctxt [goal])) = match goal with | Unknown goal -> - let (| goal', goal_eq_goal' |) = normalize_slprop g goal false in + let goal' = normalize_slprop g goal false in let goal'' = inspect_slprop g goal' in (match goal'' with | [Unknown _] -> None @@ -566,7 +566,7 @@ let unpack_and_norm_ctxt (g: env) (ctxt: slprop_view) : T.Tac (option (prover_result_nogoals g [ctxt])) = match ctxt with | Unknown ctxt -> - let (| ctxt', ctxt_eq_ctxt' |) = normalize_slprop g ctxt false in + let ctxt' = normalize_slprop g ctxt false in let ctxt'' = inspect_slprop g ctxt' in (match ctxt'' with | [Unknown _] -> None @@ -1408,7 +1408,7 @@ let elim_exists_and_pure (#g:env) (#ctxt:slprop) let k_unreach (g: env) (x: nvar { freshv g (snd x) }) (post_hint: post_hint_t { g `env_extends` post_hint.g }) : T.Tac (continuation_elaborator g tm_is_unreachable (push_binding g (snd x) (fst x) post_hint.ret_ty) (open_term_nv post_hint.post x)) = let h: tot_typing g tm_is_unreachable tm_slprop = () in - let (| c, c_typ |) = Pulse.Typing.Combinators.comp_for_post_hint g tm_is_unreachable h post_hint (snd x) in + let c = Pulse.Typing.Combinators.comp_for_post_hint g tm_is_unreachable h post_hint (snd x) in let st = wtag (Some (ctag_of_comp_st c)) (Tm_Unreachable { c }) in let typ : st_typing g st c = () in let g' = push_binding g (snd x) (fst x) post_hint.ret_ty in @@ -1431,13 +1431,13 @@ let prove_post_hint (#g:env) (#ctxt:slprop) (r:checker_result_t g ctxt NoHint) ( | NoHint -> r | TypeHint _ -> retype_checker_result post_hint r | PostHint post_hint -> - let (| x, g2, (| u_ty, ty, ty_typing |), (| ctxt', ctxt'_typing |), k |) = r in + let (| x, g2, (u_ty, ty), ctxt', k |) = r in let k: continuation_elaborator g ctxt g2 ctxt' = k in // TODO: subtyping if not (eq_tm (RU.deep_compress_safe ty) (RU.deep_compress_safe post_hint.ret_ty)) then ( - let (| g3, ctxt3, ctxt3_typing, k3 |) = elim_exists_and_pure #g2 #ctxt' ctxt'_typing in + let (| g3, ctxt3, ctxt3_typing, k3 |) = elim_exists_and_pure #g2 #ctxt' () in let k3: continuation_elaborator g2 ctxt' g3 ctxt3 = k3 in if ctxt3 `eq_tm` tm_is_unreachable then ( @@ -1449,7 +1449,7 @@ let prove_post_hint (#g:env) (#ctxt:slprop) (r:checker_result_t g ctxt NoHint) ( let h2: tot_typing g4 post_hint_opened tm_slprop = () in let k_unreach: continuation_elaborator g3 ctxt3 g4 post_hint_opened = k_unreach g3 (ppname, y) post_hint in - (| y, g4, (| post_hint.u, post_hint.ret_ty, h1 |), (| post_hint_opened, h2 |), + (| y, g4, (post_hint.u, post_hint.ret_ty), post_hint_opened, k_elab_trans k (k_elab_trans k3 k_unreach) |) ) else fail_doc g (Some rng) [ @@ -1461,7 +1461,7 @@ let prove_post_hint (#g:env) (#ctxt:slprop) (r:checker_result_t g ctxt NoHint) ( let post_hint_opened = open_term_nv post_hint.post (ppname, x) in if eq_tm post_hint_opened ctxt' - then (| x, g2, (| u_ty, ty, ty_typing |), (| ctxt', ctxt'_typing |), k |) + then (| x, g2, (u_ty, ty), ctxt', k |) else let (| g3, remaining_ctxt, k_post |) = prove rng g2 ctxt' post_hint_opened false in @@ -1482,17 +1482,17 @@ let prove_post_hint (#g:env) (#ctxt:slprop) (r:checker_result_t g ctxt NoHint) ( let h1: universe_of g3 ty u_ty = () in // for the typing of post_hint_opened, again post_hint is well-typed in g, and g3 `env_extends` g let h2: tot_typing g3 post_hint_opened tm_slprop = () in - (| x, g3, (| u_ty, ty, h1 |), (| post_hint_opened, h2 |), + (| x, g3, (u_ty, ty), post_hint_opened, k_elab_trans k (k_elab_equiv ctxt' post_hint_opened k_post () h3) |) #pop-options let try_frame_pre (allow_ambiguous : bool) (#g:env) (#ctxt:slprop) (ctxt_typing:tot_typing g ctxt tm_slprop) - (d:(t:st_term & c:comp_st & st_typing g t c)) + (d:(t:st_term & c:comp_st)) (res_ppname:ppname) : T.Tac (checker_result_t g ctxt NoHint) = - let (| t, c, d |) = d in + let (| t, c |) = d in let (| g', ctxt', k |) = prove t.range g ctxt (comp_pre c) allow_ambiguous in let d: st_typing g' t c = () in // weakening from g to g' let h1: tot_typing g' ctxt' tm_slprop = () in // weakening from to g' - checker_result_for_st_typing (k _ (| t, add_frame c ctxt', () |)) res_ppname \ No newline at end of file + checker_result_for_st_typing (k _ (| t, add_frame c ctxt' |)) res_ppname \ No newline at end of file diff --git a/src/checker/Pulse.Checker.Prover.fsti b/src/checker/Pulse.Checker.Prover.fsti index 0a75a1804..d76be2d15 100644 --- a/src/checker/Pulse.Checker.Prover.fsti +++ b/src/checker/Pulse.Checker.Prover.fsti @@ -43,6 +43,6 @@ val prove_post_hint (#g:env) (#ctxt:slprop) (r:checker_result_t g ctxt NoHint) ( val try_frame_pre (allow_ambiguous : bool) (#g:env) (#ctxt:slprop) (ctxt_typing:tot_typing g ctxt tm_slprop) - (d:(t:st_term & c:comp_st & st_typing g t c)) + (d:(t:st_term & c:comp_st)) (res_ppname:ppname) : T.Tac (checker_result_t g ctxt NoHint) \ No newline at end of file diff --git a/src/checker/Pulse.Checker.Pure.fst b/src/checker/Pulse.Checker.Pure.fst index 611081970..230c51589 100644 --- a/src/checker/Pulse.Checker.Pure.fst +++ b/src/checker/Pulse.Checker.Pure.fst @@ -304,8 +304,8 @@ let instantiate_term_implicits_uvs (g:env) (t0:term) (inst_extra:bool) = (fun _ -> instantiate_term_implicits_uvs' g t0 inst_extra) let check_universe_aux (g:env) (t:term) (t_well_typed:bool) - : T.Tac (u:universe & universe_of g t u) - = let aux () : T.Tac (u:universe & universe_of g t u) = + : T.Tac universe + = let aux () : T.Tac universe = let rng, f = elab_env_with_term_range g t in let ru_opt, issues = catch_all (fun _ -> if t_well_typed then universe_of_well_typed_term_internal g f t else rtb_universe_of g f t) in match ru_opt with @@ -317,7 +317,7 @@ let check_universe_aux (g:env) (t:term) (t_well_typed:bool) FStar.Squash.get_proof _ in let proof : RT.typing f t (E_Total, R.pack_ln (R.Tv_Type ru)) = RT.T_Token _ _ _ proof in - (| ru, () |) + ru in RU.record_stats "check_universe" aux @@ -362,7 +362,7 @@ let compute_term_type_and_u (g:env) (t:term) : T.Tac (t:term & eff:T.tot_or_ghost & ty:term & - (u:universe & universe_of g ty u) & + universe & typing g t eff ty) = let rng, fg = elab_env_with_term_range g t in let res, issues = tc_meta_callback g fg t in @@ -370,8 +370,8 @@ let compute_term_type_and_u (g:env) (t:term) | None -> fail_doc_with_subissues g (Some rng) issues (ill_typed_term t None None) | Some (| rt, eff, ty', tok |) -> - let (| u, uty |) = check_universe_aux g ty' true in //ty' is well-typed; we just need to find its universe - (| rt, eff, ty', (| u, uty |), () |) + let u = check_universe_aux g ty' true in //ty' is well-typed; we just need to find its universe + (| rt, eff, ty', u, () |) in RU.record_stats "Pulse.compute_term_type_and_u" aux @@ -602,7 +602,7 @@ let try_get_non_informative_witness_aux (g:env) (u:universe) (ty:term) (ty_typin let r_dict_typing_token : squash (typing_token r_env r_dict (E_Total, goal)) = () in let r_dict_typing : RT.typing r_env r_dict (E_Total, goal) = RT.T_Token _ _ _ () in let dict_typing : tot_typing g dict (non_informative_class u ty) = () in - Some (| dict, dict_typing |), issues + Some dict, issues ) let try_get_non_informative_witness g u ty ty_typing = @@ -651,12 +651,12 @@ let fail_expected_tot_found_ghost (g:env) (t:term) = let compute_tot_term_type g t = let (| t, eff, ty, t_typing |) = compute_term_type g t in - if eff = T.E_Total then (| t, ty, t_typing |) + if eff = T.E_Total then (| t, ty |) else fail_expected_tot_found_ghost g t let compute_tot_term_type_and_u g t = - let (| t, eff, ty, (| u, ty_typing |), t_typing |) = compute_term_type_and_u g t in - if eff = T.E_Total then (| t, u, ty, ty_typing, t_typing |) + let (| t, eff, ty, u, t_typing |) = compute_term_type_and_u g t in + if eff = T.E_Total then (| t, u, ty |) else fail_expected_tot_found_ghost g t let check_tot_term g e t = diff --git a/src/checker/Pulse.Checker.Pure.fsti b/src/checker/Pulse.Checker.Pure.fsti index a08f55872..db02a8bad 100644 --- a/src/checker/Pulse.Checker.Pure.fsti +++ b/src/checker/Pulse.Checker.Pure.fsti @@ -35,10 +35,10 @@ val instantiate_term_implicits_uvs (g:env) (t:term) : T.Tac (uvs:env { disjoint g uvs } & term & term) // uvs val universe_of_well_typed_term (g:env) (t:term) - : T.Tac (u:universe & universe_of g t u) + : T.Tac universe val check_universe (g:env) (t:term) - : T.Tac (u:universe & universe_of g t u) + : T.Tac universe val compute_term_type (g:env) (t:term) : T.Tac (t:term & @@ -50,7 +50,7 @@ val compute_term_type_and_u (g:env) (t:term) : T.Tac (t:term & eff:T.tot_or_ghost & ty:term & - (u:universe & universe_of g ty u) & + universe & typing g t eff ty) val check_term (g:env) (e:term) (eff:T.tot_or_ghost) (t:term) @@ -101,14 +101,12 @@ val check_prop_validity (g:env) (p:term) (_:tot_typing g p tm_prop) : T.Tac (Pulse.Typing.prop_validity g p) val compute_tot_term_type (g:env) (t:term) - : T.Tac (t:term & ty:typ & tot_typing g t ty) + : T.Tac (t:term & ty:typ) val compute_tot_term_type_and_u (g:env) (t:term) : T.Tac (t:term & u:universe & - ty:typ & - universe_of g ty u & - tot_typing g t ty) + ty:typ) val check_tot_term (g:env) (e:term) (t:term) : T.Tac (e:term & diff --git a/src/checker/Pulse.Checker.Return.fst b/src/checker/Pulse.Checker.Return.fst index d2e07c0b3..16c352764 100644 --- a/src/checker/Pulse.Checker.Return.fst +++ b/src/checker/Pulse.Checker.Return.fst @@ -65,9 +65,9 @@ type result_of_typing (g:env) = let compute_tot_or_ghost_term_type_and_u (g:env) (e:term) (c:option ctag) : T.Tac (result_of_typing g) = RU.with_error_bound (RU.range_of_term e) fun () -> // stopgap, ideally remove - let (| t, eff, ty, (| u, ud |), d |) = compute_term_type_and_u g e in + let (| t, eff, ty, u, d |) = compute_term_type_and_u g e in let (| c, e, d |) = check_effect d c in - R c e u ty ud d + R c e u ty () d #push-options "--z3rlimit_factor 16 --fuel 0 --ifuel 1 --split_queries no" #restart-solver @@ -97,13 +97,13 @@ let check_core | NoHint -> None | TypeHint expected_type -> let ty, _ = Pulse.Checker.Pure.instantiate_term_implicits g expected_type None false in - let (| u, d |) = check_universe g ty in - Some (| ty, u, d |) + let u = check_universe g ty in + Some (| ty, u, () |) ) | _ -> let ty, _ = Pulse.Checker.Pure.instantiate_term_implicits g expected_type None false in - let (| u, d |) = check_universe g ty in - Some (| ty, u, d |) + let u = check_universe g ty in + Some (| ty, u, () |) in let R c t u ty uty d : result_of_typing g = match return_type with @@ -138,12 +138,12 @@ let check_core let ret_st = wtag (Some c) (Tm_Return {expected_type=tm_unknown; insert_eq=use_eq; term=t}) in let ret_c = comp_return c use_eq u ty t post x in let d : st_typing g ret_st ret_c = () in - let (|c',d'|) = match_comp_res_with_post_hint ret_st ret_c d post_hint in + let c' = match_comp_res_with_post_hint ret_st ret_c d post_hint in Pulse.Checker.Util.debug g "pulse.return" (fun _ -> Printf.sprintf "Return comp is: %s" (Pulse.Syntax.Printer.comp_to_string c')); prove_post_hint #g - (try_frame_pre false #g ctxt_typing (|ret_st,c',d'|) res_ppname) + (try_frame_pre false #g ctxt_typing (|ret_st,c'|) res_ppname) post_hint st.range #pop-options diff --git a/src/checker/Pulse.Checker.Rewrite.fst b/src/checker/Pulse.Checker.Rewrite.fst index e64c5b6e7..fdbfff732 100644 --- a/src/checker/Pulse.Checker.Rewrite.fst +++ b/src/checker/Pulse.Checker.Rewrite.fst @@ -140,5 +140,5 @@ let check let rew_st = wtag (Some STT_Ghost) (Tm_Rewrite { t1=p; t2=q; tac_opt=None; elaborated=true }) in let rew_c = C_STGhost tm_emp_inames { u=u0; res=tm_unit; pre=p; post=q } in let d : st_typing g rew_st rew_c = () in - let (| c,d |) = match_comp_res_with_post_hint rew_st rew_c d post_hint in - prove_post_hint (try_frame_pre false pre_typing (| rew_st,c,d |) res_ppname) post_hint t.range + let c = match_comp_res_with_post_hint rew_st rew_c d post_hint in + prove_post_hint (try_frame_pre false pre_typing (| rew_st,c |) res_ppname) post_hint t.range diff --git a/src/checker/Pulse.Checker.ST.fst b/src/checker/Pulse.Checker.ST.fst index c087f022b..500ac6e71 100644 --- a/src/checker/Pulse.Checker.ST.fst +++ b/src/checker/Pulse.Checker.ST.fst @@ -107,12 +107,12 @@ let check in let h: tot_typing g' ctxt' tm_slprop = () in // TODO: thread through prover if comp_post c `eq_tm` tm_is_unreachable then - let framed = checker_result_for_st_typing (k _ (| t, add_frame c ctxt', () |)) res_ppname in + let framed = checker_result_for_st_typing (k _ (| t, add_frame c ctxt' |)) res_ppname in RU.record_stats "prove_post_hint" fun _ -> prove_post_hint framed post_hint range else // TODO: not sure why we need the type equality check below.. - let (| c, d |) = match_comp_res_with_post_hint t c d post_hint in - let framed = checker_result_for_st_typing (k _ (| t, add_frame c ctxt', () |)) res_ppname in + let c = match_comp_res_with_post_hint t c d post_hint in + let framed = checker_result_for_st_typing (k _ (| t, add_frame c ctxt' |)) res_ppname in RU.record_stats "prove_post_hint" fun _ -> prove_post_hint framed post_hint range ) #pop-options \ No newline at end of file diff --git a/src/checker/Pulse.Checker.While.fst b/src/checker/Pulse.Checker.While.fst index 088ab8281..5566076d0 100644 --- a/src/checker/Pulse.Checker.While.fst +++ b/src/checker/Pulse.Checker.While.fst @@ -161,12 +161,12 @@ let check_while | None -> u0, tm_unit, unit_const, false | Some meas -> let meas' = purify_term g { ctxt_now = pre; ctxt_old = Some pre } meas in - let (| _, _, ty, (| u, _ |), _ |) = compute_term_type_and_u g meas' in + let (| _, _, ty, u, _ |) = compute_term_type_and_u g meas' in u, ty, meas, true in let inv_range = term_range inv in let g_meas = push_binding g (snd x_meas) (fst x_meas) ty_meas in - let inv = dfst <| + let inv = purify_and_check_spec (push_context "invariant" inv_range g_meas) { ctxt_now = pre; ctxt_old = Some pre } (inv `tm_star` tm_pure (mk_eq2 u_meas ty_meas (term_of_nvar x_meas) meas)) @@ -185,7 +185,7 @@ let check_while let r_cond = Pulse.Checker.Prover.prove_post_hint res_cond (PostHint ph) cond.range in (| ph, apply_checker_result_k r_cond ppname_default |) in - let (| cond, comp_cond, cond_typing |) = r_cond in + let (| cond, comp_cond |) = r_cond in if not (T.term_eq post_cond.ret_ty tm_bool) || not (T.univ_eq post_cond.u u0) then T.fail "Expected while condition to return a bool"; @@ -194,7 +194,7 @@ let check_while let (| break_pred, break_typ |) : t:term & tot_typing g0 t tm_slprop = match loop_ensures with | Some loop_ensures -> - let (| x_cond, g1', (| _, _, t_typ |), (| cond_post, _ |), k |) = res_cond in + let (| x_cond, g1', (_, _), cond_post, k |) = res_cond in let loop_ensures = (mk_eq2 u0 tm_bool (term_of_nvar (ppname_default, x_cond)) tm_false `tm_l_and` loop_requires) @@ -237,9 +237,9 @@ let check_while // lift post_cond across "g2 `env_extends` g1" let post_cond : post_hint_for_env g2 = assume post_hint_for_env_p g2 post_cond; post_cond in let r_cond : Pulse.Typing.Combinators.st_typing_in_ctxt g2 inv (PostHint post_cond) = - let (| t, c, typ |) = r_cond in + let (| t, c |) = r_cond in let typ : st_typing g2 t c = () in - (| t, c, typ |) in + (| t, c |) in let body_pre_open = post_cond.post in let body_post_typing : tot_typing g2 (comp_post (comp_while_body u_meas ty_meas is_tot x_meas inv body_pre_open)) tm_slprop = () in @@ -255,8 +255,8 @@ let check_while (push_context "check_while_body" body.range g2) (open_term' body_pre_open tm_true 0) body_pre_typing (PostHint body_ph) ppname_default body in - let (| cond, comp_cond, cond_typing |) = r_cond in - let (| body, comp_body, body_typing |) = apply_checker_result_k r_body ppname_default in + let (| cond, comp_cond |) = r_cond in + let (| body, comp_body |) = apply_checker_result_k r_body ppname_default in assert (comp_cond == (comp_while_cond inv body_pre_open)); assert (comp_post comp_body == comp_post (comp_while_body u_meas ty_meas is_tot x_meas inv body_pre_open)); assert (comp_pre comp_body == comp_pre (comp_while_body u_meas ty_meas is_tot x_meas inv body_pre_open)); @@ -274,7 +274,7 @@ let check_while let C_ST cst = comp_while u_meas ty_meas x_meas inv body_pre_open in let loop_pre = tm_exists_sl u_meas (as_binder ty_meas) (close_term inv (snd x_meas)) in assert comp_pre (comp_while u_meas ty_meas x_meas inv body_pre_open) == loop_pre; - let d_st : Pulse.Typing.Combinators.st_typing_in_ctxt g1' loop_pre NoHint = (| while, comp_while u_meas ty_meas x_meas inv body_pre_open, d |) in + let d_st : Pulse.Typing.Combinators.st_typing_in_ctxt g1' loop_pre NoHint = (| while, comp_while u_meas ty_meas x_meas inv body_pre_open |) in let res = checker_result_for_st_typing d_st ppname_default in assume (fresh_wrt x g0 (freevars break_pred)); let post_hint_for_while : post_hint_for_env g0 = { @@ -290,7 +290,7 @@ let check_while } in let res = prove_post_hint res (PostHint post_hint_for_while) t.range in - let (| while, while_comp, while_d |) = apply_checker_result_k res ppname_default in + let (| while, while_comp |) = apply_checker_result_k res ppname_default in assert post_hint_for_while.post == break_pred; assert post_hint_for_while.u == u0; assert post_hint_for_while.ret_ty == tm_unit; @@ -307,12 +307,12 @@ let check_while let fjl_d: st_typing g0 fjl while_comp = () in - let d_st: Pulse.Typing.Combinators.st_typing_in_ctxt g0 loop_pre (TypeHint tm_unit) = (| fjl, while_comp, fjl_d |) in + let d_st: Pulse.Typing.Combinators.st_typing_in_ctxt g0 loop_pre (TypeHint tm_unit) = (| fjl, while_comp |) in let d_st: Pulse.Typing.Combinators.st_typing_in_ctxt g0 loop_pre0 (TypeHint tm_unit) = - let (| t, c, _ |) = d_st in + let (| t, c |) = d_st in let c = with_st_comp c { st_comp_of_comp c with pre = loop_pre0 } in let typ : st_typing g0 t c = () in - (| t, c, typ |) in + (| t, c |) in let d_st : Pulse.Typing.Combinators.st_typing_in_ctxt g pre NoHint = k NoHint d_st in let res = checker_result_for_st_typing d_st ppname_default in diff --git a/src/checker/Pulse.Checker.WithLocal.fst b/src/checker/Pulse.Checker.WithLocal.fst index f38ad12ef..4d30138fb 100644 --- a/src/checker/Pulse.Checker.WithLocal.fst +++ b/src/checker/Pulse.Checker.WithLocal.fst @@ -95,7 +95,7 @@ let check let ty = binder.binder_ty in match inspect_term ty, init with | Tm_Unknown, Some init -> - let (| init, init_u, init_t, init_t_typing, init_typing |) = + let (| init, init_u, init_t |) = compute_tot_term_type_and_u g init in // Remove any refinements from this inferred type. The Core typechecker @@ -107,9 +107,9 @@ let check | _, Some init -> let ty, _ = tc_type_phase1 g ty in - let (| u, ty_typing |) = check_universe g ty in + let u = check_universe g ty in let (| init, init_typing |) = check_term g init T.E_Total ty in - let ty_typing : universe_of g ty u = ty_typing in + let ty_typing : universe_of g ty u = () in let init_typing : typing g init T.E_Total ty = init_typing in (| Some init, u, ty, ty_typing, init_typing |) @@ -119,8 +119,8 @@ let check | _, None -> let ty, _ = tc_type_phase1 g ty in - let (| u, ty_typing |) = check_universe g ty in - let ty_typing : universe_of g ty u = ty_typing in + let u = check_universe g ty in + let ty_typing : universe_of g ty u = () in (| None, u, ty, ty_typing, () |) in if not (eq_univ init_u u0) @@ -146,7 +146,7 @@ let check let body_post : post_hint_for_env g_extended = extend_post_hint_for_local g post init_t x binder.binder_ppname in let r = check g_extended body_pre body_pre_typing (PostHint body_post) binder.binder_ppname (open_st_term_nv body px) in let r: checker_result_t g_extended body_pre (PostHint body_post) = r in - let (| opened_body, c_body, body_typing |) = apply_checker_result_k #g_extended #body_pre #body_post r binder.binder_ppname in + let (| opened_body, c_body |) = apply_checker_result_k #g_extended #body_pre #body_post r binder.binder_ppname in let body = close_st_term opened_body x in assume (open_st_term (close_st_term opened_body x) x == opened_body); let c = C_ST {u=comp_u c_body;res=comp_res c_body;pre;post=post.post} in @@ -160,5 +160,5 @@ let check assert (freshv g x); assert (~(Set.mem x (freevars_st body))); let st = wrst c (Tm_WithLocal { binder = mk_binder_ppname (mk_ref init_t) binder.binder_ppname; initializer=init; body }) in - checker_result_for_st_typing (| st, c, () |) res_ppname + checker_result_for_st_typing (| st, c |) res_ppname #pop-options diff --git a/src/checker/Pulse.Checker.WithLocalArray.fst b/src/checker/Pulse.Checker.WithLocalArray.fst index 6717644a3..fa5f84cd1 100644 --- a/src/checker/Pulse.Checker.WithLocalArray.fst +++ b/src/checker/Pulse.Checker.WithLocalArray.fst @@ -121,8 +121,8 @@ let check | Tm_Unknown -> (match initializer with | Some initializer -> - let (| init, init_u, init_t, init_t_typing, init_typing |) = compute_tot_term_type_and_u g initializer in - (| Some init, init_u, init_t, init_t_typing, init_typing |) + let (| init, init_u, init_t |) = compute_tot_term_type_and_u g initializer in + (| Some init, init_u, init_t, (), () |) | None -> fail g (Some <| head_range t) "allocating a local array: type must be specified when there is no initializer") @@ -134,8 +134,8 @@ let check (Printf.sprintf "expected annotated type to be an array, found: %s" (P.term_to_string ty)) | Some ty -> - let (| u, ty_typing |) = check_universe g ty in - let ty_typing : universe_of g ty u = ty_typing in + let u = check_universe g ty in + let ty_typing : universe_of g ty u = () in match initializer with | Some initializer -> let (| init, init_typing |) = check_term g initializer T.E_Total ty in @@ -167,7 +167,7 @@ let check let post : post_hint_for_env g = post in assume ~(x `Set.mem` freevars post.post); let body_post = extend_post_hint g post init_t init x binder.binder_ppname in - let (| opened_body, c_body, body_typing |) = + let (| opened_body, c_body |) = let r = check g_extended body_pre body_pre_typing (PostHint body_post) binder.binder_ppname (open_st_term_nv body px) in apply_checker_result_k r binder.binder_ppname in @@ -182,5 +182,5 @@ let check x post_typing_rec.post_typing in let st = wrst c (Tm_WithLocalArray { binder = mk_binder_ppname (mk_array init_t) binder.binder_ppname; initializer=init; length=len; body }) in - checker_result_for_st_typing (| st, c, () |) res_ppname + checker_result_for_st_typing (| st, c |) res_ppname #pop-options diff --git a/src/checker/Pulse.JoinComp.fst b/src/checker/Pulse.JoinComp.fst index a3c83fd58..ff9d22fa3 100644 --- a/src/checker/Pulse.JoinComp.fst +++ b/src/checker/Pulse.JoinComp.fst @@ -39,7 +39,7 @@ let rec close_post x_ret dom_g g1 (bs1:env_bindings) (post:slprop) if not (y `Set.mem` freevars post) then post else ( let b = {binder_ty=ty; binder_ppname=n; binder_attrs=Sealed.seal []} in - let (| u, _ |) = Pulse.Checker.Pure.universe_of_well_typed_term g1 ty in + let u = Pulse.Checker.Pure.universe_of_well_typed_term g1 ty in tm_exists_sl u b (close_term post y) ) in @@ -122,7 +122,7 @@ let infer_post' (g:env) (g':env { g' `env_extends` g }) Pulse.PP.text " that escape its environment"] in let mk_post_hint (post:term) : T.Tac (p:post_hint_for_env g {p.g==g /\ p.effect_annot == EffectAnnotSTT }) = - let (| u, ty_typing |) = Pulse.Checker.Pure.check_universe g t in + let u = Pulse.Checker.Pure.check_universe g t in let x = fresh g in let post' = open_term_nv post (ppname_default, x) in let g' = push_binding g x ppname_default t in @@ -131,7 +131,7 @@ let infer_post' (g:env) (g':env { g' `env_extends` g }) assume (fresh_wrt x g (freevars post)); { g; effect_annot=EffectAnnotSTT; effect_annot_typing=(); - ret_ty=t; u; ty_typing; + ret_ty=t; u; ty_typing=(); post; x; post_typing_src } in @@ -354,9 +354,9 @@ let join_post #g #hyp #b let x = fresh g in let g' = push_binding g x ppname_default p1.ret_ty in let p1_post = open_term_nv p1.post (ppname_default, x) in - let (| p1_post, _ |) = normalize_slprop g' p1_post true in + let p1_post = normalize_slprop g' p1_post true in let p2_post = open_term_nv p2.post (ppname_default, x) in - let (| p2_post, _ |) = normalize_slprop g' p2_post true in + let p2_post = normalize_slprop g' p2_post true in let joined_post = join_slprop g' b [] [] p1_post p2_post in let joined_post = close_term joined_post x in Pulse.Checker.Util.debug g "pulse.join_comp" (fun _ -> @@ -364,13 +364,13 @@ let join_post #g #hyp #b (T.term_to_string joined_post) ); assume (fresh_wrt x g (freevars joined_post)); - let (| u, ty_typing |) = Pulse.Checker.Pure.check_universe g p1.ret_ty in + let u = Pulse.Checker.Pure.check_universe g p1.ret_ty in let joined_post' = open_term_nv joined_post (ppname_default, x) in let post_typing_src = Pulse.Checker.Pure.check_slprop_with_core g' joined_post' in let (| eff, eff_ty |) = join_effect_annot g p1.effect_annot p2.effect_annot in let res : post_hint_for_env g = {g; effect_annot=eff; effect_annot_typing=eff_ty; - ret_ty=p1.ret_ty; u=u; ty_typing; x; + ret_ty=p1.ret_ty; u=u; ty_typing=(); x; post=joined_post; post_typing_src} in res diff --git a/src/checker/Pulse.JoinComp.fsti b/src/checker/Pulse.JoinComp.fsti index b61e79789..b8557b312 100644 --- a/src/checker/Pulse.JoinComp.fsti +++ b/src/checker/Pulse.JoinComp.fsti @@ -28,8 +28,8 @@ val infer_post' (g:env) (g':env { g' `env_extends` g }) let infer_post #g #ctxt (r:checker_result_t g ctxt NoHint) : T.Tac (p:post_hint_for_env g {p.g == g /\ p.effect_annot==EffectAnnotSTT}) -= let (| x, g', (| u, t, t_typ |), (| post, post_typing |), k |) = r in - infer_post' g g' x t_typ post_typing += let (| x, g', (u, t), post, k |) = r in + infer_post' g g' #u #t x () #post () val join_post #g #hyp #b (p1:post_hint_for_env (g_with_eq g hyp b tm_true)) diff --git a/src/checker/Pulse.Main.fst b/src/checker/Pulse.Main.fst index c31e5092e..ae4038a39 100644 --- a/src/checker/Pulse.Main.fst +++ b/src/checker/Pulse.Main.fst @@ -69,7 +69,7 @@ let check_fndefn let rng = body.range in debug_main g (fun _ -> Printf.sprintf "\nbody after mk_abs:\n%s\n" (P.st_term_to_string body)); - let (| body, c, _t_typing |) = Pulse.Checker.Abs.check_abs g body Pulse.Checker.check in + let (| body, c |) = Pulse.Checker.Abs.check_abs g body Pulse.Checker.check in Pulse.Checker.Prover.Util.debug_prover g (fun _ -> Printf.sprintf "\ncheck call returned in main with:\n%s\nat type %s\n" @@ -194,7 +194,7 @@ let check_fndecl in let body = Pulse.Checker.Abs.mk_abs g bs body comp in let rng = body.range in - let (| _, c, _t_typing |) = + let (| _, c |) = (* We don't want to print the diagnostic for the admit in the body. *) RU.with_extv "pulse:no_admit_diag" "1" (fun () -> Pulse.Checker.Abs.check_abs g body Pulse.Checker.check @@ -218,10 +218,10 @@ let main' (d:decl) (pre:term) (g:RT.fstar_top_env) (expected_t:option term) | Some g -> if RU.debug_at_level (fstar_env g) "Pulse" then T.print (Printf.sprintf "About to check pulse decl:\n%s\n" (P.decl_to_string d)); - let (| pre, ty, pre_typing |) = Pulse.Checker.Pure.compute_tot_term_type g pre in + let (| pre, ty |) = Pulse.Checker.Pure.compute_tot_term_type g pre in if not (eq_tm ty tm_slprop) then fail g (Some (Pulse.RuntimeUtils.range_of_term pre)) "pulse main: cannot typecheck pre at type slprop"; //fix range - let pre_typing : tot_typing g pre tm_slprop = pre_typing in + let pre_typing : tot_typing g pre tm_slprop = () in match d.d with | FnDefn {} -> check_fndefn d g expected_t pre pre_typing | FnDecl {} -> diff --git a/src/checker/Pulse.Typing.Combinators.fst b/src/checker/Pulse.Typing.Combinators.fst index 1f3a9e61e..68d002d7d 100644 --- a/src/checker/Pulse.Typing.Combinators.fst +++ b/src/checker/Pulse.Typing.Combinators.fst @@ -78,8 +78,7 @@ let bind_t (case_c1 case_c2:comp_st -> bool) = (post_hint:post_hint_opt g { comp_post_matches_hint c2 post_hint }) -> T.TacH (t:st_term & c:comp_st { st_comp_of_comp c == st_comp_with_pre (st_comp_of_comp c2) pre /\ - comp_post_matches_hint c post_hint } & - st_typing g t c) + comp_post_matches_hint c post_hint }) (requires (let _, x = px in comp_pre c1 == pre /\ @@ -96,7 +95,7 @@ let mk_bind_st_st let b = nvar_as_binder px (comp_res c1) in let c : comp_st = C_ST (st_comp_with_pre (st_comp_of_comp c2) pre) in let t = wrst c (Tm_Bind {binder=b; head=e1; body=e2}) in - (| t, c, () |) + (| t, c |) #pop-options let inames_of (c:comp_st) : term = match c with @@ -158,14 +157,14 @@ let mk_bind_ghost_ghost : bind_t C_STGhost? C_STGhost? = then begin let c : comp_st = C_STGhost inames1 (st_comp_with_pre sc2 pre) in let t = wrst c (Tm_Bind {binder=b; head=e1; body=e2}) in - (| t, c, () |) + (| t, c |) end else if (PostHint? post_hint) then ( let _ = check_prop_validity g _ (tm_inames_subset_typing g inames1 inames2) in let c : comp_st = C_STGhost inames2 (st_comp_with_pre sc2 pre) in let t = wrst c (Tm_Bind {binder=b; head=e1; body=e2}) in - (| t, c, () |) + (| t, c |) ) else begin let new_inames = tm_join_inames inames1 inames2 in @@ -173,7 +172,7 @@ let mk_bind_ghost_ghost : bind_t C_STGhost? C_STGhost? = let _ = check_prop_validity g _ (tm_inames_subset_typing g inames2 new_inames) in let c : comp_st = C_STGhost new_inames (st_comp_with_pre sc2 pre) in let t = wrst c (Tm_Bind {binder=b; head=e1; body=e2}) in - (| t, c, () |) + (| t, c |) end let mk_bind_atomic_atomic @@ -189,14 +188,14 @@ let mk_bind_atomic_atomic then begin let c : comp_st = C_STAtomic inames1 (join_obs obs1 obs2) (st_comp_with_pre sc2 pre) in let t = wrst c (Tm_Bind {binder=b; head=e1; body=e2}) in - (| t, c, () |) + (| t, c |) end else if (PostHint? post_hint) then ( let _ = check_prop_validity g _ (tm_inames_subset_typing g inames1 inames2) in let c : comp_st = C_STAtomic inames2 (join_obs obs1 obs2) (st_comp_with_pre sc2 pre) in let t = wrst c (Tm_Bind {binder=b; head=e1; body=e2}) in - (| t, c, () |) + (| t, c |) ) else begin let new_inames = tm_join_inames inames1 inames2 in @@ -204,7 +203,7 @@ let mk_bind_atomic_atomic let _ = check_prop_validity g _ (tm_inames_subset_typing g inames2 new_inames) in let c : comp_st = C_STAtomic new_inames (join_obs obs1 obs2) (st_comp_with_pre sc2 pre) in let t = wrst c (Tm_Bind {binder=b; head=e1; body=e2}) in - (| t, c, () |) + (| t, c |) end ) else ( @@ -232,8 +231,7 @@ let rec mk_bind (g:env) : T.TacH (t:st_term & c:comp_st { st_comp_of_comp c == st_comp_with_pre (st_comp_of_comp c2) pre /\ - comp_post_matches_hint c post_hint } & - st_typing g t c) + comp_post_matches_hint c post_hint }) (requires (let _, x = px in comp_pre c1 == pre /\ @@ -278,8 +276,8 @@ let rec mk_bind (g:env) then fail_bias "atomic" else ( let c2_lifted = C_ST (st_comp_of_comp c2) in - let (| t, c, d |) = mk_bind g pre e1 e2 c1 c2_lifted px () d_c1res () res_typing post_typing post_hint in - (| t, c, d |) + let (| t, c |) = mk_bind g pre e1 e2 c1 c2_lifted px () d_c1res () res_typing post_typing post_hint in + (| t, c |) ) | C_STGhost _ _, C_STAtomic _ Neutral _ -> ( @@ -292,8 +290,8 @@ let rec mk_bind (g:env) | NoHint | PostHint { effect_annot = EffectAnnotAtomicOrGhost _ } -> let c2_lifted = C_STGhost (comp_inames c2) (st_comp_of_comp c2) in - let (| t, c, d |) = mk_bind g pre e1 e2 c1 c2_lifted px () d_c1res () res_typing post_typing post_hint in - (| t, c, d |) + let (| t, c |) = mk_bind g pre e1 e2 c1 c2_lifted px () d_c1res () res_typing post_typing post_hint in + (| t, c |) | _ -> fail_bias "atomic" ) @@ -309,8 +307,8 @@ let rec mk_bind (g:env) match try_lift_ghost_atomic (push_binding g (snd px) (fst px) (comp_res c1)) (open_st_term_nv e2 px) c2 d_e2 with | Some _ -> let c2_lifted = st_ghost_as_atomic c2 in - let (| t, c, d |) = mk_bind g pre e1 e2 c1 c2_lifted px () d_c1res () res_typing post_typing post_hint in - (| t, c, d |) + let (| t, c |) = mk_bind g pre e1 e2 c1 c2_lifted px () d_c1res () res_typing post_typing post_hint in + (| t, c |) | None -> let c1_lifted = C_STGhost (comp_inames c1) (st_comp_of_comp c1) in mk_bind g pre e1 e2 c1_lifted c2 px () d_c1res d_e2 res_typing post_typing post_hint @@ -328,8 +326,8 @@ let rec mk_bind (g:env) else ( let _ = lift_ghost_atomic (push_binding g (snd px) (fst px) (comp_res c1)) (open_st_term_nv e2 px) c2 d_e2 in let c2_lifted = st_ghost_as_atomic c2 in - let (| t, c, d |) = mk_bind g pre e1 e2 c1 c2_lifted px () d_c1res () res_typing post_typing post_hint in - (| t, c, d |) + let (| t, c |) = mk_bind g pre e1 e2 c1 c2_lifted px () d_c1res () res_typing post_typing post_hint in + (| t, c |) ) | _ -> T.fail "Impossible: unexpected combination of effects" #pop-options @@ -340,7 +338,7 @@ let bind_res_and_post_typing g c2 x post_hint | NoHint | TypeHint _ -> (* We're inferring a post, so these checks are unavoidable *) (* since we need to type the result in a smaller env g *) - let (| u, res_typing |) = check_universe g s2.res in + let u = check_universe g s2.res in if not (eq_univ u s2.u) then fail g None "Unexpected universe for result type" else if x `Set.mem` freevars (RU.deep_compress_safe s2.post) @@ -350,21 +348,20 @@ let bind_res_and_post_typing g c2 x post_hint let s2_post_opened = open_term_nv s2.post (v_as_nv y) in let post_typing = check_slprop_with_core (push_binding g y ppname_default s2.res) s2_post_opened in - res_typing, post_typing + () ) | PostHint post -> CU.debug g "pulse.main" (fun _ -> "bind_res_and_post_typing (with post_hint)\n"); let pr = post_hint_typing g post x in - pr.ty_typing, pr.post_typing + () let add_frame (g:env) (t:st_term) (c:comp_st) (t_typing:st_typing g t c) (frame:slprop) (frame_typing:tot_typing g frame tm_slprop) : t':st_term & - c':comp_st { c' == add_frame c frame } & - st_typing g t' c' = + c':comp_st { c' == add_frame c frame } = - (| t, add_frame c frame, () |) + (| t, add_frame c frame |) #push-options "--fuel 0 --ifuel 0" let apply_frame (g:env) @@ -377,35 +374,33 @@ let apply_frame (g:env) : Dv (c':comp_st { comp_pre c' == ctxt /\ comp_res c' == comp_res c /\ comp_u c' == comp_u c /\ - comp_post c' == tm_star (comp_post c) (frame_of frame_t) } & - st_typing g t c') + comp_post c' == tm_star (comp_post c) (frame_of frame_t) }) = let s = st_comp_of_comp c in - let (| frame, frame_typing, ve |) = frame_t in + let frame = frame_t in let c' = Pulse.Typing.add_frame c frame in let s' = st_comp_of_comp c' in let s'' = { s' with pre = ctxt } in let c'' = c' `with_st_comp` s'' in assert (comp_post c' == comp_post c''); - (| c'', () |) + c'' #pop-options #push-options "--z3rlimit_factor 2" let comp_for_post_hint (g:env) (pre:slprop) (pre_typing:tot_typing g pre tm_slprop) (post:post_hint_t { g `env_extends` post.g }) (x:var { freshv g x }) - : T.Tac (c:comp_st { comp_pre c == pre /\ comp_post_matches_hint c (PostHint post) } & - comp_typing g c (universe_of_comp c)) = + : T.Tac (c:comp_st { comp_pre c == pre /\ comp_post_matches_hint c (PostHint post) }) = if x `Set.mem` freevars post.post then fail g None "Impossible: unexpected freevar clash in comp_for_post_hint, please file a bug-report"; let s : st_comp = {u=post.u;res=post.ret_ty;pre;post=post.post} in match post.effect_annot with - | EffectAnnotSTT -> (| C_ST s, () |) + | EffectAnnotSTT -> C_ST s | EffectAnnotGhost { opens } -> - (| C_STGhost opens s, () |) + C_STGhost opens s | EffectAnnotAtomic { opens } | EffectAnnotAtomicOrGhost { opens } -> - (| C_STAtomic opens Neutral s, () |) + C_STAtomic opens Neutral s | _ -> T.fail "Impossible" #pop-options \ No newline at end of file diff --git a/src/checker/Pulse.Typing.Combinators.fsti b/src/checker/Pulse.Typing.Combinators.fsti index 39d59c5df..ed235cf83 100644 --- a/src/checker/Pulse.Typing.Combinators.fsti +++ b/src/checker/Pulse.Typing.Combinators.fsti @@ -56,8 +56,7 @@ val mk_bind (g:env) (post_hint:post_hint_opt g { comp_post_matches_hint c2 post_hint }) : T.TacH (t:st_term & c:comp_st { st_comp_of_comp c == st_comp_with_pre (st_comp_of_comp c2) pre /\ - comp_post_matches_hint c post_hint } & - st_typing g t c) + comp_post_matches_hint c post_hint }) (requires (let _, x = px in comp_pre c1 == pre /\ @@ -70,23 +69,18 @@ val mk_bind (g:env) val bind_res_and_post_typing (g:env) (s2:comp_st) (x:var { fresh_wrt x g (freevars (comp_post s2)) }) (post_hint:post_hint_opt g { comp_post_matches_hint s2 post_hint }) - : T.Tac (universe_of g (comp_res s2) (comp_u s2) & - tot_typing (push_binding g x ppname_default (comp_res s2)) (open_term_nv (comp_post s2) (v_as_nv x)) tm_slprop) + : T.Tac unit val add_frame (g:env) (t:st_term) (c:comp_st) (t_typing:st_typing g t c) (frame:slprop) (frame_typing:tot_typing g frame tm_slprop) : t':st_term & - c':comp_st { c' == add_frame c frame } & - st_typing g t' c' + c':comp_st { c' == add_frame c frame } let frame_for_req_in_ctxt (g:env) (ctxt:term) (req:term) - = (frame:term & - tot_typing g frame tm_slprop & - slprop_equiv g (tm_star req frame) ctxt) + = term -let frame_of #g #ctxt #req (f:frame_for_req_in_ctxt g ctxt req) = - let (| frame, _, _ |) = f in frame +let frame_of #g #ctxt #req (f:frame_for_req_in_ctxt g ctxt req) = f val apply_frame (g:env) (t:st_term) @@ -98,16 +92,13 @@ val apply_frame (g:env) : Dv (c':comp_st { comp_pre c' == ctxt /\ comp_res c' == comp_res c /\ comp_u c' == comp_u c /\ - comp_post c' == tm_star (comp_post c) (frame_of frame_t) } & - st_typing g t c') + comp_post c' == tm_star (comp_post c) (frame_of frame_t) }) type st_typing_in_ctxt (g:env) (ctxt:slprop) (post_hint:post_hint_opt g) = t:st_term & - c:comp_st { comp_pre c == ctxt /\ comp_post_matches_hint c post_hint } & - st_typing g t c + c:comp_st { comp_pre c == ctxt /\ comp_post_matches_hint c post_hint } val comp_for_post_hint (g:env) (pre:slprop) (pre_typing:tot_typing g pre tm_slprop) (post:post_hint_t { g `env_extends` post.g }) (x:var { freshv g x }) - : T.Tac (c:comp_st { comp_pre c == pre /\ comp_post_matches_hint c (PostHint post) } & - comp_typing g c (universe_of_comp c)) \ No newline at end of file + : T.Tac (c:comp_st { comp_pre c == pre /\ comp_post_matches_hint c (PostHint post) }) \ No newline at end of file diff --git a/src/checker/Pulse.Typing.Metatheory.Base.fst b/src/checker/Pulse.Typing.Metatheory.Base.fst index 5fcc75401..44059992b 100644 --- a/src/checker/Pulse.Typing.Metatheory.Base.fst +++ b/src/checker/Pulse.Typing.Metatheory.Base.fst @@ -31,10 +31,9 @@ let admit_comp_typing (g:env) (c:comp_st) let st_typing_correctness_ctot (g:env) (t:st_term) (c:comp{C_Tot? c}) (_:st_typing g t c) -: (u:Ghost.erased universe & universe_of g (comp_res c) u) +: Ghost.erased universe = let u : Ghost.erased universe = RU.magic () in - let ty : universe_of g (comp_res c) u = () in - (| u, ty |) + u let st_typing_correctness (g:env) (t:st_term) (c:comp_st) (_:st_typing g t c) @@ -84,8 +83,7 @@ let non_informative_t_weakening (g g':env) (g1:env{ pairwise_disjoint g g1 g' }) (u:universe) (t:term) (d:non_informative_t (push_env g g') u t) : non_informative_t (push_env (push_env g g1) g') u t = - let (| w, _ |) = d in - (| w, () |) + d let non_informative_c_weakening (g g':env) (g1:env{ pairwise_disjoint g g1 g' }) (c:comp_st) diff --git a/src/checker/Pulse.Typing.Metatheory.Base.fsti b/src/checker/Pulse.Typing.Metatheory.Base.fsti index 21ca280d1..4683087f8 100644 --- a/src/checker/Pulse.Typing.Metatheory.Base.fsti +++ b/src/checker/Pulse.Typing.Metatheory.Base.fsti @@ -42,7 +42,7 @@ let rt_equiv_typing (#g:_) (#t0 #t1:_) (d:RT.equiv g t0 t1) val st_typing_correctness_ctot (g:env) (t:st_term) (c:comp{C_Tot? c}) (_:st_typing g t c) - : (u:Ghost.erased universe & universe_of g (comp_res c) u) + : Ghost.erased universe let inames_of_comp_st (c:comp_st) = match c with diff --git a/src/checker/Pulse.Typing.fst b/src/checker/Pulse.Typing.fst index 2ab9e8cf4..dba87a094 100644 --- a/src/checker/Pulse.Typing.fst +++ b/src/checker/Pulse.Typing.fst @@ -480,7 +480,7 @@ let lift_typing_to_ghost_typing (#g:env) (#e:term) (#eff:T.tot_or_ghost) (#t:ter let universe_of (g:env) (t:term) (u:universe) = unit let non_informative_t (g:env) (u:universe) (t:term) = - w:term & tot_typing g w (non_informative_class u t) + term let non_informative_c (g:env) (c:comp_st) = non_informative_t g (comp_u c) (comp_res c) From 12a7eafbc86ffec5cb86f2078dce5ddd01000d40 Mon Sep 17 00:00:00 2001 From: Gabriel Ebner Date: Fri, 27 Feb 2026 21:00:09 +0000 Subject: [PATCH 09/18] Remove dependent tuples with unit-typed typing tokens Simplify function signatures and return types by removing unit-typed typing tokens (tot_typing, typing, universe_of, br_typing_vis, brs_typing, pats_complete, effect_annot_typing) from dependent tuples. Key changes: - check_term/check_tot_term now return term directly - compute_term_type returns 3-tuple (was 4-tuple) - compute_term_type_and_u returns 4-tuple (was 5-tuple) - core_compute_term_type returns 2-tuple (was 3-tuple) - core_check_term/core_check_term' return unit - core_check_term_at_type returns tot_or_ghost directly - check_slprop_with_core returns unit - try_get/get_non_informative_witness: removed t_typing param - try_check/check_prop_validity: removed tot_typing param - Match.fst: removed br_typing_vis/brs_typing/pats_complete from tuples - Return.fst: simplified return_type to (ty & u) from (ty & u & universe_of) - WithLocal/WithLocalArray: simplified init tuples - JoinComp: join_effect_annot returns effect_annot directly Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/checker/Pulse.Checker.Abs.fst | 29 +++--- src/checker/Pulse.Checker.Admit.fst | 2 +- .../Pulse.Checker.AssertWithBinders.fst | 6 +- src/checker/Pulse.Checker.Base.fst | 30 +++---- src/checker/Pulse.Checker.Bind.fst | 2 +- src/checker/Pulse.Checker.Comp.fst | 6 +- src/checker/Pulse.Checker.Exists.fst | 14 +-- src/checker/Pulse.Checker.Goto.fst | 2 +- src/checker/Pulse.Checker.If.fst | 2 +- src/checker/Pulse.Checker.ImpureSpec.fst | 2 +- src/checker/Pulse.Checker.IntroPure.fst | 17 ++-- src/checker/Pulse.Checker.Match.fst | 88 +++++++------------ src/checker/Pulse.Checker.Prover.fst | 14 +-- src/checker/Pulse.Checker.Pure.fst | 59 ++++++------- src/checker/Pulse.Checker.Pure.fsti | 37 ++++---- src/checker/Pulse.Checker.Return.fst | 58 ++++++------ src/checker/Pulse.Checker.Rewrite.fst | 2 +- src/checker/Pulse.Checker.ST.fst | 4 +- src/checker/Pulse.Checker.While.fst | 20 ++--- src/checker/Pulse.Checker.WithLocal.fst | 17 ++-- src/checker/Pulse.Checker.WithLocalArray.fst | 19 ++-- src/checker/Pulse.JoinComp.fst | 21 ++--- src/checker/Pulse.Typing.Combinators.fst | 21 +++-- 23 files changed, 212 insertions(+), 260 deletions(-) diff --git a/src/checker/Pulse.Checker.Abs.fst b/src/checker/Pulse.Checker.Abs.fst index 3211ffe17..2c52d4866 100644 --- a/src/checker/Pulse.Checker.Abs.fst +++ b/src/checker/Pulse.Checker.Abs.fst @@ -316,7 +316,7 @@ let preprocess_abs debug_abs g (fun _ -> Printf.sprintf "rebuild_abs = %s\n" (P.st_term_to_string abs)); abs -let sub_effect_comp g r (asc:comp_ascription) (c_computed:comp) : T.Tac (option (c2:comp & lift_comp g c_computed c2)) = +let sub_effect_comp g r (asc:comp_ascription) (c_computed:comp) : T.Tac (option comp) = let nop = None in match asc.elaborated with | None -> nop @@ -326,19 +326,17 @@ let sub_effect_comp g r (asc:comp_ascription) (c_computed:comp) : T.Tac (option | C_ST _, C_ST _ -> nop | C_STGhost _ _, C_STGhost _ _ -> nop | C_STAtomic i Neutral c1, C_STGhost _ _ -> - let lift : lift_comp g c_computed (C_STGhost i c1) = () in - Some (| C_STGhost i c1, lift |) + Some (C_STGhost i c1) | C_STAtomic i o1 c1, C_STAtomic j o2 c2 -> if sub_observability o1 o2 - then let lift : lift_comp g c_computed (C_STAtomic i o2 c1) = () in - Some (| C_STAtomic i o2 c1, lift |) + then Some (C_STAtomic i o2 c1) else nop (* FIXME: more lifts here *) | _ -> nop -let check_effect_annotation g r (asc:comp_ascription) (c_computed:comp) : T.Tac (c2:comp & st_sub g c_computed c2) = - let nop = (| c_computed, () |) in +let check_effect_annotation g r (asc:comp_ascription) (c_computed:comp) : T.Tac comp = + let nop = c_computed in match asc.elaborated with | None -> nop | Some c -> @@ -360,10 +358,9 @@ let check_effect_annotation g r (asc:comp_ascription) (c_computed:comp) : T.Tac let b = mk_binder "res" Range.range_0 c2.res in let phi = tm_inames_subset j i in - let typing = tm_inames_subset_typing g j i in // Or: // let typing = core_check_tot_term g phi tm_prop in - let tok = T.with_policy T.ForceSMT (fun () -> try_check_prop_validity g phi typing) in + let tok = T.with_policy T.ForceSMT (fun () -> try_check_prop_validity g phi) in if None? tok then ( let open Pulse.PP in fail_doc g (Some (RU.range_of_term i)) [ @@ -380,7 +377,7 @@ let check_effect_annotation g r (asc:comp_ascription) (c_computed:comp) : T.Tac | C_STAtomic _ obs _ -> () | C_STGhost _ _ -> () in - (| c, d_sub |) + c | _, _ -> let open Pulse.PP in @@ -479,12 +476,12 @@ let rec check_abs_core let c_body : comp = match sub_effect_comp g' body.range asc c_body with | None -> c_body - | Some (| c_body, lift |) -> c_body + | Some c_body -> c_body in (* Check if it matches annotation (if any, likely not), and adjust derivation if needed. Currently this only subtypes the invariants. *) - let (| c_body, d_sub |) = check_effect_annotation g' body.range asc c_body in + let c_body = check_effect_annotation g' body.range asc c_body in let body_typing : st_typing g' body c_body = () in let c_body = maybe_rewrite_body_typing body_typing asc in @@ -541,7 +538,7 @@ let rec check_abs_core Some (open_term_nv (comp_res c) px), Some (open_term' (comp_post c) var 1) in - let (| pre_opened, pre_typing |) = + let pre_opened = (* In some cases F* can mess up the range in error reporting and make it point outside of this term. Bound it here. See e.g. Bug59, if we remove this bound then the range points to the span between the 'x' and 'y' binders. *) @@ -565,7 +562,7 @@ let rec check_abs_core in let ppname_ret = mk_ppname_no_range "_fret" in - let r = check g' pre_opened pre_typing post ppname_ret body_opened in + let r = check g' pre_opened () post ppname_ret body_opened in let (| post, r |) : (ph:post_hint_opt g' & checker_result_t g' pre_opened ph) = match post with | PostHint _ -> (| post, r |) @@ -587,10 +584,10 @@ let rec check_abs_core let c_body : comp = match sub_effect_comp g' body.range c_opened c_body with | None -> c_body - | Some (| c_body, lift |) -> c_body + | Some c_body -> c_body in - let (| c_body, d_sub |) = check_effect_annotation g' body.range c_opened c_body in + let c_body = check_effect_annotation g' body.range c_opened c_body in let body_typing : st_typing g' body c_body = () in let c_body = maybe_rewrite_body_typing body_typing asc in diff --git a/src/checker/Pulse.Checker.Admit.fst b/src/checker/Pulse.Checker.Admit.fst index 87d0dc528..069eb8025 100644 --- a/src/checker/Pulse.Checker.Admit.fst +++ b/src/checker/Pulse.Checker.Admit.fst @@ -59,7 +59,7 @@ let check | Some post, _ -> let u = check_universe g t in let post_opened = open_term_nv post px in - let (| post_opened, post_typing |) = + let post_opened = check_tot_term (push_binding g x (fst px) t) post_opened tm_slprop in let post = close_term post_opened x in diff --git a/src/checker/Pulse.Checker.AssertWithBinders.fst b/src/checker/Pulse.Checker.AssertWithBinders.fst index add3c6379..8fb6cdec2 100644 --- a/src/checker/Pulse.Checker.AssertWithBinders.fst +++ b/src/checker/Pulse.Checker.AssertWithBinders.fst @@ -297,8 +297,8 @@ let check_equiv_maybe_tac (g:env) (rng:Range.range) (lhs rhs ty:term) (tac_opt:o check_equiv_with_tac g rng lhs rhs ty tac_tm let check_pair (g:env) rng (lhs rhs:term) (tac_opt:option term) : T.Tac unit = - let (| _, ty, _ |) = PC.core_compute_term_type g lhs in - let (| _, _ |) = PC.core_check_term_at_type g rhs ty in + let (| _, ty |) = PC.core_compute_term_type g lhs in + let _ = PC.core_check_term_at_type g rhs ty in let issues = check_equiv_maybe_tac g rng lhs rhs ty tac_opt in match issues with | Some issues -> @@ -553,7 +553,7 @@ let check let rhs' = norm rhs in let v' = norm v in - let _: tot_typing g v' tm_slprop = PC.check_slprop_with_core g v' in + let _ = PC.check_slprop_with_core g v' in let h1: tot_typing g' (tm_star pre_remaining rhs') tm_slprop = () in let h2: slprop_equiv g' (tm_star pre_remaining rhs') (tm_star lhs pre_remaining) = () in diff --git a/src/checker/Pulse.Checker.Base.fst b/src/checker/Pulse.Checker.Base.fst index 70813d6a6..c5a2483e8 100644 --- a/src/checker/Pulse.Checker.Base.fst +++ b/src/checker/Pulse.Checker.Base.fst @@ -88,28 +88,28 @@ let equiv_preserves_typing = () let check_effect_annot (g:env) (e:effect_annot) - : T.Tac (e':effect_annot { effect_annot_labels_match e e' } & effect_annot_typing g e') = - let check_opens opens : T.Tac (e:term & typing g e T.E_Total tm_inames) = - let (| opens, d |) = CP.check_term g opens T.E_Total tm_inames in + : T.Tac (e':effect_annot { effect_annot_labels_match e e' }) = + let check_opens opens : T.Tac term = + let opens = CP.check_term g opens T.E_Total tm_inames in let opens' = CP.norm_well_typed_term (elab_env g) [primops; iota; zeta; delta_attr ["Pulse.Lib.Core.unfold_check_opens"]] opens in - (| opens', equiv_preserves_typing _ _ _ _ () d |) + opens' in match e with - | EffectAnnotSTT -> (| e, () |) + | EffectAnnotSTT -> e | EffectAnnotGhost { opens } -> - let (| opens, d |) = check_opens opens in - (| EffectAnnotGhost { opens }, d |) + let opens = check_opens opens in + EffectAnnotGhost { opens } | EffectAnnotAtomic { opens } -> - let (| opens, d |) = check_opens opens in - (| EffectAnnotAtomic { opens }, d |) + let opens = check_opens opens in + EffectAnnotAtomic { opens } | EffectAnnotAtomicOrGhost { opens } -> - let (| opens, d |) = check_opens opens in - (| EffectAnnotAtomicOrGhost { opens }, d |) + let opens = check_opens opens in + EffectAnnotAtomicOrGhost { opens } let intro_post_hint g effect_annot ret_ty_opt post = let x = fresh g in @@ -120,17 +120,17 @@ let intro_post_hint g effect_annot ret_ty_opt post = in let ret_ty, _ = CP.instantiate_term_implicits g ret_ty None false in let u = CP.check_universe g ret_ty in - let (| post, post_typing |) = CP.check_slprop (push_binding g x ppname_default ret_ty) (open_term_nv post (v_as_nv x)) in + let post = CP.check_slprop (push_binding g x ppname_default ret_ty) (open_term_nv post (v_as_nv x)) in let post' = close_term post x in Pulse.Typing.FV.freevars_close_term post x 0; - let (| effect_annot, effect_annot_typing |) = check_effect_annot g effect_annot in + let effect_annot = check_effect_annot g effect_annot in assume (open_term post' x == post); { g; effect_annot; - effect_annot_typing; + effect_annot_typing = (); ret_ty; u; ty_typing=(); post=post'; - x; post_typing_src=post_typing } + x; post_typing_src=() } let comp_typing_as_effect_annot_typing (#g:env) (#c:comp_st) (ct:comp_typing_u g c) : effect_annot_typing g (effect_annot_of_comp c) diff --git a/src/checker/Pulse.Checker.Bind.fst b/src/checker/Pulse.Checker.Bind.fst index cf4befb30..e6201eead 100644 --- a/src/checker/Pulse.Checker.Bind.fst +++ b/src/checker/Pulse.Checker.Bind.fst @@ -77,7 +77,7 @@ let check_if_seq_lhs text "Did you forget to apply some arguments?"; ] else if None? (fst <| T.is_non_informative (elab_env g) ty) then ( - if None? (Pulse.Checker.Pure.try_get_non_informative_witness g u ty ()) then + if None? (Pulse.Checker.Pure.try_get_non_informative_witness g u ty) then fail_doc g (Some e1.range) [ prefix 2 1 (text "This statement returns a value of type:") (pp ty); text "Did you forget to assign it or ignore it?"; diff --git a/src/checker/Pulse.Checker.Comp.fst b/src/checker/Pulse.Checker.Comp.fst index fb16c5d28..9a8311a6b 100644 --- a/src/checker/Pulse.Checker.Comp.fst +++ b/src/checker/Pulse.Checker.Comp.fst @@ -47,7 +47,7 @@ let check (g:env) let px = v_as_nv x in assume (~(x `Set.mem` freevars (comp_post c))); let gx = push_binding g x (fst px) st.res in - let (| ty, post_typing |) = core_compute_tot_term_type gx (open_term_nv (comp_post c) px) in + let ty = core_compute_tot_term_type gx (open_term_nv (comp_post c) px) in if not (eq_tm ty tm_slprop) then fail g None (Printf.sprintf "check_comp: ill-typed postcondition %s" (P.term_to_string (comp_post c))) @@ -63,14 +63,14 @@ let check (g:env) () | C_STAtomic i obs st -> let stc = check_st_comp st in - let (| ty, i_typing |) = core_compute_tot_term_type g i in + let ty = core_compute_tot_term_type g i in if not (eq_tm ty tm_inames) then fail g None (Printf.sprintf "check_comp (atomic): type of inames term %s is %s, expected %s" (P.term_to_string i) (P.term_to_string ty) (P.term_to_string tm_inames)) else () | C_STGhost i st -> - let (| ty, i_typing |) = core_compute_tot_term_type g i in + let ty = core_compute_tot_term_type g i in if not (eq_tm ty tm_inames) then fail g None (Printf.sprintf "check_comp (ghost): type of inames term %s is %s, expected %s" diff --git a/src/checker/Pulse.Checker.Exists.fst b/src/checker/Pulse.Checker.Exists.fst index a9f3bfb06..919b5154d 100644 --- a/src/checker/Pulse.Checker.Exists.fst +++ b/src/checker/Pulse.Checker.Exists.fst @@ -55,7 +55,7 @@ let check_elim_exists let Tm_ElimExists { p = t } = t.term in let t_rng = Pulse.RuntimeUtils.range_of_term t in - let (| t, t_typing |) : (t:term & tot_typing g t tm_slprop ) = + let t : term = match inspect_term t with | Tm_Unknown -> ( //There should be exactly one exists_ slprop in the context and we eliminate it @@ -66,7 +66,7 @@ let check_elim_exists match exist_tms with | [one] -> assume (one `List.Tot.memP` ts); - (| one, slprop_as_list_typing pre_typing one |) //shouldn't need to check this again + one //shouldn't need to check this again | _ -> fail g (Some t_rng) (Printf.sprintf "Could not decide which exists term to eliminate: choices are\n%s" @@ -113,9 +113,9 @@ let check_intro_exists let g = Pulse.Typing.Env.push_context g "check_intro_exists_non_erased" st.range in let Tm_IntroExists { p=t; witnesses=[witness] } = st.term in - let (| t, t_typing |) = + let t = match slprop_typing with - | Some typing -> (| t, typing |) + | Some typing -> t | _ -> check_slprop g t in @@ -127,10 +127,10 @@ let check_intro_exists let Tm_ExistsSL u b p = tv in - Pulse.Typing.FV.tot_typing_freevars g t tm_slprop t_typing; + Pulse.Typing.FV.tot_typing_freevars g t tm_slprop (); let x = fresh g in - let ty_typing, _ = Metatheory.tm_exists_inversion g u b.binder_ty p t_typing x in - let (| witness, witness_typing |) = + let ty_typing, _ = Metatheory.tm_exists_inversion g u b.binder_ty p () x in + let witness = check_term g witness T.E_Ghost b.binder_ty in let intro_st = wtag (Some STT_Ghost) (Tm_IntroExists { p = tm_exists_sl u b p; witnesses = [witness] }) in let intro_c = C_STGhost tm_emp_inames { u=u0; res=tm_unit; pre=open_term' p witness 0; post=tm_exists_sl u b p } in diff --git a/src/checker/Pulse.Checker.Goto.fst b/src/checker/Pulse.Checker.Goto.fst index 8030bb28b..1da5ea177 100644 --- a/src/checker/Pulse.Checker.Goto.fst +++ b/src/checker/Pulse.Checker.Goto.fst @@ -41,7 +41,7 @@ let check' let v = (R.inspect_namedv v).uniq in (match lookup_goto g v with | Some (lbln, lbl_c) -> - let (| arg, arg_typ |) = check_tot_term g arg (comp_res lbl_c) in + let arg = check_tot_term g arg (comp_res lbl_c) in let c' = with_st_comp lbl_c { u = ph.u; res = ph.ret_ty; diff --git a/src/checker/Pulse.Checker.If.fst b/src/checker/Pulse.Checker.If.fst index 9e29f6506..c8ee6515c 100644 --- a/src/checker/Pulse.Checker.If.fst +++ b/src/checker/Pulse.Checker.If.fst @@ -57,7 +57,7 @@ let check let g = Pulse.Typing.Env.push_context g "check_if" e1.range in - let (| b, b_typing |) = + let b = check_tot_term g b tm_bool in let hyp = fresh g in diff --git a/src/checker/Pulse.Checker.ImpureSpec.fst b/src/checker/Pulse.Checker.ImpureSpec.fst index 90d53c310..201334e73 100644 --- a/src/checker/Pulse.Checker.ImpureSpec.fst +++ b/src/checker/Pulse.Checker.ImpureSpec.fst @@ -401,4 +401,4 @@ let purify_spec (g: env) (ctxt: ctxt) (t0: slprop) : T.Tac slprop = t let purify_and_check_spec (g: env) (ctxt: ctxt) (t: slprop) = - dfst (check_slprop g (purify_spec g ctxt t)) \ No newline at end of file + check_slprop g (purify_spec g ctxt t) \ No newline at end of file diff --git a/src/checker/Pulse.Checker.IntroPure.fst b/src/checker/Pulse.Checker.IntroPure.fst index 406d8639c..26025ceee 100644 --- a/src/checker/Pulse.Checker.IntroPure.fst +++ b/src/checker/Pulse.Checker.IntroPure.fst @@ -25,14 +25,14 @@ module T = FStar.Tactics.V2 module P = Pulse.Syntax.Printer let check_prop (g:env) (p:term) - : T.Tac (p:term & tot_typing g p tm_prop) = + : T.Tac term = let p0 = p in - let (| p, p_typing |) = Pulse.Checker.Pure.check_slprop g (tm_pure p) in + let p = Pulse.Checker.Pure.check_slprop g (tm_pure p) in match inspect_term p with | Tm_Pure pp -> - let prop_typing = Pulse.Typing.Metatheory.pure_typing_inversion _ pp p_typing in - (| pp, prop_typing |) + let prop_typing = Pulse.Typing.Metatheory.pure_typing_inversion g pp () in + pp | _ -> fail g None (Printf.sprintf "Impossible: check_intro_pure: checking a pure slprop %s returned a non-pure slprop %s,\ @@ -40,8 +40,8 @@ let check_prop (g:env) (p:term) (P.term_to_string (tm_pure p0)) (P.term_to_string p)) -let check_prop_validity (g:env) (p:term) (typing:tot_typing g p tm_prop): T.Tac (prop_validity g p) = - Pulse.Checker.Pure.check_prop_validity g p typing +let check_prop_validity (g:env) (p:term): T.Tac (prop_validity g p) = + Pulse.Checker.Pure.check_prop_validity g p let check (g:env) @@ -56,8 +56,9 @@ let check let g = Pulse.Typing.Env.push_context g "check_intro_pure" t.range in let Tm_IntroPure { p } = t.term in - let (| p, p_typing |) = check_prop g p in - let pv = check_prop_validity g p p_typing in + let p = check_prop g p in + let p_typing : tot_typing g p tm_prop = () in + let pv = check_prop_validity g p in let intro_st = wtag (Some STT_Ghost) (Tm_IntroPure { p }) in let intro_c = C_STGhost tm_emp_inames { u=u0; res=tm_unit; pre=tm_emp; post=tm_pure p } in let st_typing : st_typing g intro_st intro_c = () in diff --git a/src/checker/Pulse.Checker.Match.fst b/src/checker/Pulse.Checker.Match.fst index 82073969b..3af5c5393 100644 --- a/src/checker/Pulse.Checker.Match.fst +++ b/src/checker/Pulse.Checker.Match.fst @@ -233,15 +233,15 @@ let check_branch (p0:R.pattern) (e:st_term) (bs:list R.binding) - : T.Tac (p:pattern{elab_pat p == p0} + : T.Tac (p:pattern & e:st_term - & c:comp_st{comp_pre c == pre /\ comp_post_matches_hint c (PostHint post_hint)} - & br_typing_vis g sc_u sc_ty sc p e c) + & c:comp_st{comp_pre c == pre /\ comp_post_matches_hint c (PostHint post_hint)}) = let p = (match readback_pat p0 with | Some p -> p | None -> fail g (Some e.range) "readback_pat failed") in elab_readback_pat_x p0 p; + assume (elab_pat p == p0); let pulse_bs = L.map readback_binding bs in assume (all_fresh g pulse_bs); (* The reflection API in F* should give us a way to guarantee this, but currently does not *) assume (RT.bindings_ok_for_pat (fstar_env g) bs p0); @@ -282,8 +282,7 @@ let check_branch let ppname = mk_ppname_no_range "_br" in let r = check g' pre pre_typing (PostHint post_hint) ppname e in apply_checker_result_k r ppname in - let br_d : br_typing_vis g sc_u sc_ty sc p (close_st_term_n e (L.map (fun (b: var_binding) -> b.x) pulse_bs)) c = () in - (| p, close_st_term_n e (L.map (fun (b: var_binding) -> b.x) pulse_bs), c, br_d |) + (| p, close_st_term_n e (L.map (fun (b: var_binding) -> b.x) pulse_bs), c |) #pop-options @@ -295,8 +294,7 @@ let check_branches_aux_t (sc_ty : typ) (sc : term) = (br:branch - & c:comp_st{comp_pre c == pre /\ comp_post_matches_hint c (PostHint post_hint)} - & br_typing_vis g sc_u sc_ty sc br.pat br.e c) + & c:comp_st{comp_pre c == pre /\ comp_post_matches_hint c (PostHint post_hint)}) let check_branches_aux (g:env) @@ -311,18 +309,18 @@ let check_branches_aux (bnds: list (R.pattern & list R.binding){L.length brs0 == L.length bnds}) : T.Tac (brs:list (check_branches_aux_t pre post_hint sc_u sc_ty sc) { - samepats brs0 (L.map Mkdtuple3?._1 brs) + samepats brs0 (L.map dfst brs) }) = if L.isEmpty brs0 then fail g None "empty match"; let tr1 (b: branch) (pbs:R.pattern & list R.binding) : T.Tac (check_branches_aux_t pre post_hint sc_u sc_ty sc) = let e = b.e in let (p, bs) = pbs in - let (| p, e, c, d |) = check_branch (T.unseal b.norw) g pre pre_typing post_hint check sc_u sc_ty sc p e bs in - (| {pat=p; e; norw=b.norw}, c, d |) + let (| p, e, c |) = check_branch (T.unseal b.norw) g pre pre_typing post_hint check sc_u sc_ty sc p e bs in + (| {pat=p; e; norw=b.norw}, c |) in let r = zipWith tr1 brs0 bnds in - assume (samepats brs0 (L.map Mkdtuple3?._1 r)); + assume (samepats brs0 (L.map dfst r)); r let comp_observability (c:comp_st {C_STAtomic? c}) = @@ -332,7 +330,7 @@ let comp_observability (c:comp_st {C_STAtomic? c}) = let ctag_of_br (#g #pre #post_hint #sc_u #sc_ty #sc:_) (l:check_branches_aux_t #g pre post_hint sc_u sc_ty sc) : ctag -= let (|_, c, _|) = l in ctag_of_comp_st c += let (|_, c|) = l in ctag_of_comp_st c #push-options "--admit_smt_queries true" // Z3 crash let weaken_branch_observability @@ -346,16 +344,14 @@ let weaken_branch_observability comp_observability c == obs }) (checked_br : check_branches_aux_t #g pre post_hint sc_u sc_ty sc { ctag_of_br checked_br == STT_Atomic}) -: T.Tac (br:branch & br_typing_vis g sc_u sc_ty sc br.pat br.e c) -= let (| br, c0, typing |) = checked_br in +: T.Tac branch += let (| br, c0 |) = checked_br in match c0 with | C_STAtomic i obs' st -> if not (sub_observability obs' obs) then T.fail "Cannot weaken observability" - else ( - let d : br_typing_vis g sc_u sc_ty sc br.pat br.e c = () in - (| br, d |) - ) + else + br #pop-options let rec max_obs @@ -378,24 +374,24 @@ let join_branches (#g #pre #post_hint #sc_u #sc_ty #sc:_) (ct:ctag) (checked_brs : list (cbr:check_branches_aux_t #g pre post_hint sc_u sc_ty sc {ctag_of_br cbr == ct})) : T.Tac (c:comp_st { comp_pre c == pre /\ comp_post_matches_hint c (PostHint post_hint) } & - list (br:branch & br_typing_vis g sc_u sc_ty sc br.pat br.e c)) + list branch) = match checked_brs with | [] -> T.fail "Impossible: empty match" | checked_br::rest -> - let (| br, c, d |) = checked_br in + let (| br, c |) = checked_br in match c with | C_ST _ | C_STGhost _ _ -> let rest = List.Tot.map #(cbr:check_branches_aux_t #g pre post_hint sc_u sc_ty sc {ctag_of_br cbr==ct}) - #(br:branch & br_typing_vis g sc_u sc_ty sc br.pat br.e c) - (fun (| br, c', d |) -> (| br, d |)) + #branch + (fun (| br, c' |) -> br) rest in - (| c, ((| br, d |) :: rest) |) + (| c, (br :: rest) |) | C_STAtomic i obs stc -> - let max_obs = max_obs (List.Tot.map Mkdtuple3?._2 rest) obs in + let max_obs = max_obs (List.Tot.map dsnd rest) obs in let c = C_STAtomic i max_obs stc in let checked_brs = T.map (weaken_branch_observability max_obs c) checked_brs in (| c, checked_brs |) @@ -407,7 +403,7 @@ let rec least_tag (#g #pre #post_hint #sc_u #sc_ty #sc:_) = match checked_brs with | [] -> STT_Ghost | checked_br::rest -> - let (| _, c, _ |) = checked_br in + let (| _, c |) = checked_br in match c with | C_ST _ -> STT | C_STGhost _ _ -> least_tag rest @@ -421,7 +417,7 @@ let weaken_branch_tag_to (ct:ctag) (br :check_branches_aux_t #g pre post_hint sc_u sc_ty sc { EffectAnnotAtomicOrGhost? post_hint.effect_annot }) : T.Tac (cbr:check_branches_aux_t #g pre post_hint sc_u sc_ty sc { ctag_of_br cbr == ct }) -= let (| pe, c, d|) = br in += let (| pe, c |) = br in if ctag_of_comp_st c = ct then br else let r = pe.e.range in @@ -438,8 +434,7 @@ let weaken_branch_tag_to | STT_Atomic, C_STGhost _ _ -> ( let c' = Pulse.Typing.Combinators.st_ghost_as_atomic c in - let d : br_typing_vis g sc_u sc_ty sc pe.pat pe.e c' = () in - (| pe, c', d |) + (| pe, c' |) ) @@ -471,26 +466,6 @@ let maybe_weaken_branch_tags let checked_brs = T.map #_ #(cbr:check_branches_aux_t #g pre post_hint sc_u sc_ty sc {ctag_of_br cbr == ct}) (fun x -> x) checked_brs in (| ct, checked_brs |) #pop-options -let erase_br_typing #g #sc_u #sc_ty #sc #p #e #c (d: br_typing_vis g sc_u sc_ty sc p e c) - : br_typing g sc_u sc_ty sc p e c = - () - -(* Hoisting this makes the proof much faster and more stable. *) -let rec check_branches_aux2 - (g:env) - (sc_u:universe) - (sc_ty:typ) - (sc : term) - (c0 :comp_st) - (brs : list (br:branch & br_typing_vis g sc_u sc_ty sc br.pat br.e c0)) - : brs_typing g sc_u sc_ty sc (List.Tot.map dfst brs) c0 - = match brs with - | [] -> () - | (| br, d|)::rest -> - let { pat; e } = br in - let _ = erase_br_typing d in - let _ = check_branches_aux2 g sc_u sc_ty sc c0 rest in - () let check_branches (g:env) @@ -504,14 +479,12 @@ let check_branches (brs0:list branch) (bnds: list (R.pattern & list R.binding){L.length brs0 == L.length bnds}) : T.Tac (brs:list branch - & c:comp_st{comp_pre c == pre /\ comp_post_matches_hint c (PostHint post_hint)} - & brs_typing g sc_u sc_ty sc brs c) + & c:comp_st{comp_pre c == pre /\ comp_post_matches_hint c (PostHint post_hint)}) = let checked_brs = check_branches_aux g pre pre_typing post_hint check sc_u sc_ty sc brs0 bnds in let (| ct, checked_brs |) = maybe_weaken_branch_tags checked_brs in let (| c0, checked_brs |) = join_branches ct checked_brs in - let brs = List.Tot.map dfst checked_brs in - let d : brs_typing g sc_u sc_ty sc brs c0 = check_branches_aux2 g sc_u sc_ty sc c0 checked_brs in - (| brs, c0, d |) + let brs = checked_brs in + (| brs, c0 |) #push-options "--fuel 0 --ifuel 1 --z3rlimit_factor 4" let check (g:env) @@ -539,10 +512,9 @@ let check lemma_map_len elab_pat (L.map patof brs) ); - let (| elab_pats', bnds', complete_d |) + let (| elab_pats', bnds' |) : (pats : (list R.pattern){L.length pats == nbr} - & bnds : (list (list R.binding)){L.length bnds == nbr} - & pats_complete g sc sc_ty pats) + & bnds : (list (list R.binding)){L.length bnds == nbr}) = match T.check_match_complete (elab_env g) sc sc_ty elab_pats with | None, issues -> @@ -551,7 +523,7 @@ let check text "Could not verify that this match is exhaustive."; ] | Some (elab_pats', bnds), _ -> - (| elab_pats', bnds, () |) + (| elab_pats', bnds |) in let new_pats = map_opt readback_pat elab_pats' in if None? new_pats then @@ -571,7 +543,7 @@ let check assert (L.length elab_pats' == nbr); assert (L.length (zip elab_pats' bnds') == nbr); - let (| brs, c, brs_d |) = + let (| brs, c |) = check_branches g pre pre_typing post_hint check sc_u sc_ty sc brs (zip elab_pats' bnds') in (* Provable *) diff --git a/src/checker/Pulse.Checker.Prover.fst b/src/checker/Pulse.Checker.Prover.fst index 9803791fd..df9a21ba5 100644 --- a/src/checker/Pulse.Checker.Prover.fst +++ b/src/checker/Pulse.Checker.Prover.fst @@ -395,7 +395,7 @@ let prove_pure (g: env) (ctxt: list slprop_view) (skip_eq_uvar: bool) (goal: slp Some (| g, ctxt, [], [], fun g'' -> let p_typing: tot_typing g'' p tm_prop = () in // implied by t2_typing - let pv = check_prop_validity g'' p p_typing in + let pv = check_prop_validity g'' p in cont_elab_refl g ctxt ([] @ ctxt) (()), (fun frame -> let h1: slprop_equiv g'' (elab_slprops frame) (elab_slprops (frame @ [] @ [])) = () in @@ -414,7 +414,7 @@ let intro_with_pure (g: env) (frame: slprop) (p: term) (n: ppname) (v: term) : fun post t -> let g = push_context g "check_intro_with_pure" (RU.range_of_term p) in let p_typing: tot_typing g p tm_prop = () in // implied by t2_typing - let pv = check_prop_validity g p p_typing in + let pv = check_prop_validity g p in let frame_typ : tot_typing g frame tm_slprop = () in // implied by t2_typing let ty = mk_squash u0 p in let st = wtag (Some STT_Ghost) (Tm_ST { t = tm_unknown; args = [] }) in @@ -448,7 +448,7 @@ let intro_exists (g: env) (frame: slprop) (u: universe) (b: binder) (body: slpro let frame_typ : tot_typing g frame tm_slprop = () in // implied by t2_typing let binder_ty_typ : tot_typing g b.binder_ty (tm_type u) = () in // implied by t2_typing let tm_ex_typ : tot_typing g (tm_exists_sl u b body) tm_slprop = () in // implied by t2_typing - let e_typ = core_check_term' g e T.E_Ghost b.binder_ty (fun _ -> let open Pulse.PP in + let _ = core_check_term' g e T.E_Ghost b.binder_ty (fun _ -> let open Pulse.PP in [text "Cannot find witness for" ^/^ pp (tm_exists_sl u b body)]) in let h1: tot_typing g (tm_star frame (comp_pre (comp_intro_exists u b body e))) tm_slprop = () in let h2: slprop_equiv g (tm_star frame (comp_pre (comp_intro_exists u b body e))) (tm_star frame (open_term' body e 0)) = () in @@ -527,16 +527,16 @@ let elim_first (g: env) (ctxt0 goals: list slprop_view) | None -> None let unreachable_elim_typing (g: env) (u: universe) (res: term) (post: term) : - t:st_term & st_typing g t (C_STGhost tm_emp_inames { u; res; pre=tm_is_unreachable; post }) = + st_term = let c = C_STGhost tm_emp_inames { u; res; pre=tm_is_unreachable; post } in let st = wtag (Some STT_Ghost) (Tm_Unreachable { c }) in - let typing: st_typing g st c = () in - (| st, typing |) + st let unreachable_elim (g: env) (goals: list slprop_view) : cont_elab g [IsUnreachable] g goals = fun frame post t -> let frame_t = elab_slprops frame in let c = C_STGhost tm_emp_inames { u=u0; res=tm_unit; pre=tm_is_unreachable; post=frame_t } in - let (| st, typing |) = unreachable_elim_typing g u0 tm_unit frame_t in + let st = unreachable_elim_typing g u0 tm_unit frame_t in + let typing : st_typing g st c = () in let h: tot_typing g (tm_star frame_t tm_is_unreachable) tm_slprop = () in k_elab_equiv (elab_slprops (frame @ [IsUnreachable])) (elab_slprops (frame @ goals)) (continuation_elaborator_with_bind_nondep frame_t c st typing h) (()) (()) post t diff --git a/src/checker/Pulse.Checker.Pure.fst b/src/checker/Pulse.Checker.Pure.fst index 230c51589..f4cf9a97a 100644 --- a/src/checker/Pulse.Checker.Pure.fst +++ b/src/checker/Pulse.Checker.Pure.fst @@ -342,8 +342,7 @@ let compute_term_type (g:env) (t:term) = let aux () : T.Tac (t:term & eff:T.tot_or_ghost & - ty:term & - typing g t eff ty) + ty:term) = let rng, fg = elab_env_with_term_range g t in debug g (fun _ -> Printf.sprintf "check_tot : called on %s elaborated to %s" @@ -353,7 +352,7 @@ let compute_term_type (g:env) (t:term) match res with | None -> fail_doc_with_subissues g (Some rng) issues (ill_typed_term t None None) - | Some (| rt, eff, ty', tok |) -> (| rt, eff, ty', () |) + | Some (| rt, eff, ty', tok |) -> (| rt, eff, ty' |) in RU.record_stats "Pulse.compute_term_type" aux @@ -362,8 +361,7 @@ let compute_term_type_and_u (g:env) (t:term) : T.Tac (t:term & eff:T.tot_or_ghost & ty:term & - universe & - typing g t eff ty) + universe) = let rng, fg = elab_env_with_term_range g t in let res, issues = tc_meta_callback g fg t in match res with @@ -371,13 +369,13 @@ let compute_term_type_and_u (g:env) (t:term) fail_doc_with_subissues g (Some rng) issues (ill_typed_term t None None) | Some (| rt, eff, ty', tok |) -> let u = check_universe_aux g ty' true in //ty' is well-typed; we just need to find its universe - (| rt, eff, ty', u, () |) + (| rt, eff, ty', u |) in RU.record_stats "Pulse.compute_term_type_and_u" aux let check_term (g:env) (e:term) (eff:T.tot_or_ghost) (t:term) = let aux () - : T.Tac (e:term & typing g e eff t) + : T.Tac term = let e, _ = instantiate_term_implicits g e (Some t) (*inst_extra:*)true in let rng, fg = elab_env_with_term_range g e in @@ -389,13 +387,13 @@ let check_term (g:env) (e:term) (eff:T.tot_or_ghost) (t:term) match topt with | None -> fail_doc_with_subissues g (Some rng) issues (ill_typed_term e (Some t) None) - | Some tok -> (| e, () |) + | Some tok -> e in RU.record_stats "Pulse.check_term" aux let check_term_at_type (g:env) (e:term) (t:term) = let aux () - : T.Tac (e:term & eff:T.tot_or_ghost & typing g e eff t) + : T.Tac (e:term & eff:T.tot_or_ghost) = let e, _ = instantiate_term_implicits g e (Some t) true in let rng, fg = elab_env_with_term_range g e in @@ -408,7 +406,7 @@ let check_term_at_type (g:env) (e:term) (t:term) | None -> fail_doc_with_subissues g (Some rng) issues (ill_typed_term e (Some t) None) | Some eff -> - (| e, eff, () |) + (| e, eff |) in RU.record_stats "Pulse.check_term_at_type" aux @@ -464,19 +462,18 @@ let tc_type_phase1 (g: env) (t: term) : T.Tac (term & universe) = let core_compute_term_type (g:env) (t:term) = let aux () : T.Tac (eff:T.tot_or_ghost & - ty:term & - typing g t eff ty) + ty:term) = let _, fg = elab_env_with_term_range g t in let res, issues = tc_with_core (push_context g "core_check_term" (range_of_term t)) fg t in match res with | None -> fail_doc_with_subissues g (Some <| RU.range_of_term t) issues (ill_typed_term t None None) - | Some (| eff, ty', tok |) -> (| eff, ty', () |) + | Some (| eff, ty', tok |) -> (| eff, ty' |) in RU.record_stats "Pulse.core_compute_term_type" aux let core_check_term' g e eff t extra_msg -= let aux () : T.Tac (typing g e eff t) += let aux () : T.Tac unit = let _, fg = elab_env_with_term_range g e in let topt, issues = catch_all (fun _ -> @@ -495,7 +492,7 @@ let core_check_term g e eff t = core_check_term' g e eff t fun _ -> [] let core_check_term_at_type g e t -= let aux () : T.Tac (eff:T.tot_or_ghost & typing g e eff t) += let aux () : T.Tac T.tot_or_ghost = let _, fg = elab_env_with_term_range g e in let effopt, issues = catch_all (fun _ -> @@ -506,19 +503,19 @@ let core_check_term_at_type g e t | None -> fail_doc_with_subissues g (Some <| RU.range_of_term e) issues (ill_typed_term e (Some t) None) | Some eff -> - (| eff, () |) + eff in RU.record_stats "Pulse.core_check_term_at_type" aux let check_slprop (g:env) (t:term) -: T.Tac (t:term & tot_typing g t tm_slprop) +: T.Tac term = RU.record_stats "Pulse.check_slprop" <| fun _ -> check_term (push_context_no_range g "check_slprop") t T.E_Total tm_slprop let check_slprop_with_core (g:env) (t:term) -: T.Tac (tot_typing g t tm_slprop) = +: T.Tac unit = core_check_term (push_context_no_range g "check_slprop_with_core") t T.E_Total tm_slprop @@ -605,14 +602,14 @@ let try_get_non_informative_witness_aux (g:env) (u:universe) (ty:term) (ty_typin Some dict, issues ) -let try_get_non_informative_witness g u ty ty_typing = +let try_get_non_informative_witness g u ty = RU.record_stats "Pulse.try_get_noninformative_witness" <| fun _ -> - let ropt, _ = try_get_non_informative_witness_aux g u ty ty_typing in + let ropt, _ = try_get_non_informative_witness_aux g u ty () in ropt -let get_non_informative_witness g u t t_typing +let get_non_informative_witness g u t : T.Tac (non_informative_t g u t) - = match try_get_non_informative_witness_aux g u t t_typing with + = match try_get_non_informative_witness_aux g u t () with | None, issues -> let open Pulse.PP in fail_doc g (Some (RU.range_of_term t)) [ @@ -623,18 +620,18 @@ let get_non_informative_witness g u t t_typing | Some e, issues -> e -let try_check_prop_validity (g:env) (p:term) (pf:tot_typing g p tm_prop) +let try_check_prop_validity (g:env) (p:term) : T.Tac (option (Pulse.Typing.prop_validity g p)) = let _, f = elab_env_with_term_range g p in RU.record_stats "Pulse.try_check_prop_validity" fun _ -> - let t_opt, issues = rtb_check_prop_validity g true f p pf in + let t_opt, issues = rtb_check_prop_validity g true f p () in t_opt -let check_prop_validity (g:env) (p:term) (pf:tot_typing g p tm_prop) +let check_prop_validity (g:env) (p:term) : T.Tac (Pulse.Typing.prop_validity g p) = let _, f = elab_env_with_term_range g p in RU.record_stats "Pulse.check_prop_validity" fun _ -> - let t_opt, issues = rtb_check_prop_validity g true f p pf in + let t_opt, issues = rtb_check_prop_validity g true f p () in match t_opt with | None -> let open Pulse.PP in @@ -650,12 +647,12 @@ let fail_expected_tot_found_ghost (g:env) (t:term) = ] let compute_tot_term_type g t = - let (| t, eff, ty, t_typing |) = compute_term_type g t in + let (| t, eff, ty |) = compute_term_type g t in if eff = T.E_Total then (| t, ty |) else fail_expected_tot_found_ghost g t let compute_tot_term_type_and_u g t = - let (| t, eff, ty, u, t_typing |) = compute_term_type_and_u g t in + let (| t, eff, ty, u |) = compute_term_type_and_u g t in if eff = T.E_Total then (| t, u, ty |) else fail_expected_tot_found_ghost g t @@ -663,12 +660,12 @@ let check_tot_term g e t = check_term g e T.E_Total t let core_compute_tot_term_type g t = - let (| eff, ty, d |) = core_compute_term_type g t in - if eff = T.E_Total then (| ty, d |) + let (| eff, ty |) = core_compute_term_type g t in + if eff = T.E_Total then ty else fail_expected_tot_found_ghost g t let core_check_tot_term g e t = - core_check_term g e T.E_Total t + core_check_term g e T.E_Total t; () let is_non_informative g c = RU.record_stats "Pulse.is_non_informative" fun _ -> diff --git a/src/checker/Pulse.Checker.Pure.fsti b/src/checker/Pulse.Checker.Pure.fsti index db02a8bad..a0e1ea0aa 100644 --- a/src/checker/Pulse.Checker.Pure.fsti +++ b/src/checker/Pulse.Checker.Pure.fsti @@ -43,21 +43,19 @@ val check_universe (g:env) (t:term) val compute_term_type (g:env) (t:term) : T.Tac (t:term & eff:T.tot_or_ghost & - ty:term & - typing g t eff ty) + ty:term) val compute_term_type_and_u (g:env) (t:term) : T.Tac (t:term & eff:T.tot_or_ghost & ty:term & - universe & - typing g t eff ty) + universe) val check_term (g:env) (e:term) (eff:T.tot_or_ghost) (t:term) - : T.Tac (e:term & typing g e eff t) + : T.Tac term val check_term_at_type (g:env) (e:term) (t:term) - : T.Tac (e:term & eff:T.tot_or_ghost & typing g e eff t) + : T.Tac (e:term & eff:T.tot_or_ghost) val tc_term_phase1 (g:env) (t:term) : T.Tac (term & term & T.tot_or_ghost) val tc_term_phase1_with_type (g: env) (t:term) (expected_typ: term) : T.Tac (term & T.tot_or_ghost) @@ -65,39 +63,36 @@ val tc_type_phase1 (g: env) (t: term) : T.Tac (term & universe) val core_compute_term_type (g:env) (t:term) : T.Tac (eff:T.tot_or_ghost & - ty:term & - typing g t eff ty) + ty:term) val core_check_term' (g:env) (e:term) (eff:T.tot_or_ghost) (t:term) (extra_msg: unit -> T.Tac (list Pprint.document)) - : T.Tac (typing g e eff t) + : T.Tac unit val core_check_term (g:env) (e:term) (eff:T.tot_or_ghost) (t:term) - : T.Tac (typing g e eff t) + : T.Tac unit val core_check_term_at_type (g:env) (e:term) (t:term) - : T.Tac (eff:T.tot_or_ghost & typing g e eff t) + : T.Tac T.tot_or_ghost val check_slprop (g:env) (t:term) - : T.Tac (t:term & tot_typing g t tm_slprop) + : T.Tac term val check_slprop_with_core (g:env) (t:term) - : T.Tac (tot_typing g t tm_slprop) + : T.Tac unit val try_get_non_informative_witness (g:env) (u:universe) (t:term) - (t_typing:universe_of g t u) : T.Tac (option (non_informative_t g u t)) val get_non_informative_witness (g:env) (u:universe) (t:term) - (t_typing:universe_of g t u) : T.Tac (non_informative_t g u t) -val try_check_prop_validity (g:env) (p:term) (_:tot_typing g p tm_prop) +val try_check_prop_validity (g:env) (p:term) : T.Tac (option (Pulse.Typing.prop_validity g p)) -val check_prop_validity (g:env) (p:term) (_:tot_typing g p tm_prop) +val check_prop_validity (g:env) (p:term) : T.Tac (Pulse.Typing.prop_validity g p) val compute_tot_term_type (g:env) (t:term) @@ -109,15 +104,13 @@ val compute_tot_term_type_and_u (g:env) (t:term) ty:typ) val check_tot_term (g:env) (e:term) (t:term) - : T.Tac (e:term & - tot_typing g e t) + : T.Tac term val core_compute_tot_term_type (g:env) (t:term) - : T.Tac (ty:typ & - tot_typing g t ty) + : T.Tac typ val core_check_tot_term (g:env) (e:term) (t:typ) - : T.Tac (tot_typing g e t) + : T.Tac unit val is_non_informative (g:env) (c:comp) : T.Tac (option (T.non_informative_token (elab_env g) (elab_comp c))) diff --git a/src/checker/Pulse.Checker.Return.fst b/src/checker/Pulse.Checker.Return.fst index 16c352764..4231b80d2 100644 --- a/src/checker/Pulse.Checker.Return.fst +++ b/src/checker/Pulse.Checker.Return.fst @@ -27,29 +27,35 @@ module Metatheory = Pulse.Typing.Metatheory module RU = Pulse.RuntimeUtils let check_effect - (#g:env) (#e:term) (#eff:T.tot_or_ghost) (#t:term) - (d:typing g e eff t) + (g:env) (e:term) (eff:T.tot_or_ghost) (c:option ctag) -: T.Tac (c:ctag & e:term & typing g e (eff_of_ctag c) t) +: T.Tac (c:ctag & e:term) = match c, eff with | None, T.E_Total -> - (| STT_Atomic, e, d |) + (| STT_Atomic, e |) | None, T.E_Ghost -> - (| STT_Ghost, e, d |) + (| STT_Ghost, e |) | Some STT_Ghost, T.E_Total -> - (| STT_Atomic, e, d |) + (| STT_Atomic, e |) | Some STT_Ghost, T.E_Ghost -> - (| STT_Ghost, e, d |) + (| STT_Ghost, e |) | _, T.E_Total -> - (| STT_Atomic, e, d |) + (| STT_Atomic, e |) | _ -> fail g (Some (RU.range_of_term e)) "Expected a total term, but this term has Ghost effect" let check_tot_or_ghost_term (g:env) (e:term) (t:term) (c:option ctag) -: T.Tac (c:ctag & e:term & typing g e (eff_of_ctag c) t) -= let (| e, eff, d |) = check_term_at_type g e t in - check_effect d c +: T.Tac (c:ctag & e:term) += let (| e, eff |) = check_term_at_type g e t in + match c, eff with + | None, T.E_Total + | Some STT_Ghost, T.E_Total + | _, T.E_Total -> (| STT_Atomic, e |) + | None, T.E_Ghost + | Some STT_Ghost, T.E_Ghost -> (| STT_Ghost, e |) + | _ -> + fail g (Some (RU.range_of_term e)) "Expected a total term, but this term has Ghost effect" noeq type result_of_typing (g:env) = @@ -65,9 +71,9 @@ type result_of_typing (g:env) = let compute_tot_or_ghost_term_type_and_u (g:env) (e:term) (c:option ctag) : T.Tac (result_of_typing g) = RU.with_error_bound (RU.range_of_term e) fun () -> // stopgap, ideally remove - let (| t, eff, ty, u, d |) = compute_term_type_and_u g e in - let (| c, e, d |) = check_effect d c in - R c e u ty () d + let (| t, eff, ty, u |) = compute_term_type_and_u g e in + let (| c, e |) = check_effect g t eff c in + R c e u ty () () #push-options "--z3rlimit_factor 16 --fuel 0 --ifuel 1 --split_queries no" #restart-solver @@ -84,12 +90,12 @@ let check_core let g = push_context "check_return" st.range g in let Tm_Return {expected_type; insert_eq=use_eq; term=t} = st.term in let return_type - : option (ty:term & u:universe & universe_of g ty u) = + : option (ty:term & u:universe) = match post_hint with | PostHint post -> assert (g `env_extends` post.g); - let ty_typing : universe_of g post.ret_ty post.u = () in - Some (| post.ret_ty, post.u, ty_typing |) + + Some (| post.ret_ty, post.u |) | _ -> match inspect_term expected_type with | Tm_Unknown -> ( @@ -98,24 +104,24 @@ let check_core | TypeHint expected_type -> let ty, _ = Pulse.Checker.Pure.instantiate_term_implicits g expected_type None false in let u = check_universe g ty in - Some (| ty, u, () |) + Some (| ty, u |) ) | _ -> let ty, _ = Pulse.Checker.Pure.instantiate_term_implicits g expected_type None false in let u = check_universe g ty in - Some (| ty, u, () |) + Some (| ty, u |) in let R c t u ty uty d : result_of_typing g = match return_type with | None -> compute_tot_or_ghost_term_type_and_u g t ctag_ctxt - | Some (| ret_ty, u, ty_typing |) -> - let (| c, t, d |) = check_tot_or_ghost_term g t ret_ty ctag_ctxt in - R c t u ret_ty ty_typing d + | Some (| ret_ty, u |) -> + let (| c, t |) = check_tot_or_ghost_term g t ret_ty ctag_ctxt in + R c t u ret_ty () () in let x = fresh g in let px = res_ppname, x in - let (| post_opened, post_typing |) : t:term & tot_typing (push_binding g x (fst px) ty) t tm_slprop = + let post_opened : term = match post_hint with | PostHint post -> // we already checked for the return type @@ -126,10 +132,10 @@ let check_core please file a bug report") else let ty_rec = post_hint_typing g post x in - (| open_term_nv post.post px, ty_rec.post_typing |) + open_term_nv post.post px | _ -> - let (| t, ty |) = check_tot_term (push_binding g x (fst px) ty) tm_emp tm_slprop in - (| t, ty |) + let t = check_tot_term (push_binding g x (fst px) ty) tm_emp tm_slprop in + t in //if we're inferring a postcondition, then add an equality (if it is non-trivial) let use_eq = use_eq || (not (PostHint? post_hint) && not (T.term_eq ty (`unit))) in diff --git a/src/checker/Pulse.Checker.Rewrite.fst b/src/checker/Pulse.Checker.Rewrite.fst index fdbfff732..a9447fc24 100644 --- a/src/checker/Pulse.Checker.Rewrite.fst +++ b/src/checker/Pulse.Checker.Rewrite.fst @@ -122,7 +122,7 @@ let check else let ctxt = { ctxt_now = pre; ctxt_old = None } in purify_term g ctxt p, purify_term g ctxt q in - let (| p, p_typing |), (| q, q_typing |) = + let p, q = check_slprop g p, check_slprop g q in let equiv_p_q = diff --git a/src/checker/Pulse.Checker.ST.fst b/src/checker/Pulse.Checker.ST.fst index 500ac6e71..906514db8 100644 --- a/src/checker/Pulse.Checker.ST.fst +++ b/src/checker/Pulse.Checker.ST.fst @@ -58,7 +58,7 @@ let check | None -> fail g (Some range) (Printf.sprintf "readback of %s failed" (show ty)) | Some (C_Tot _) -> let h, a = T.collect_app_ln e in - let (| _, _, th, _ |) = Pulse.Checker.Pure.compute_term_type g h in + let (| _, _, th |) = Pulse.Checker.Pure.compute_term_type g h in let open Pulse.PP in fail_doc g (Some range) @@ -78,7 +78,7 @@ let check assume elab_comp c0 == ty; let Some c = Pulse.Readback.readback_comp ty in - let (| eff, typing |) = core_check_term_at_type g' e ty in + let eff = core_check_term_at_type g' e ty in let t = { t with term = Tm_ST { t=e; args=[] }; effect_tag = T.seal (Some (ctag_of_comp_st c)) } in let d : st_typing g' t c = if eff = T.E_Total diff --git a/src/checker/Pulse.Checker.While.fst b/src/checker/Pulse.Checker.While.fst index 5566076d0..4f9535599 100644 --- a/src/checker/Pulse.Checker.While.fst +++ b/src/checker/Pulse.Checker.While.fst @@ -38,17 +38,16 @@ let body_typing_ex #g #x #post (_:tot_typing (push_binding g x ppname_default tm let unit_typing g : universe_of g tm_unit u0 = admit() let inv_typing_weakening (#g:env) (#inv:slprop) (inv_typing:tot_typing g inv tm_slprop) -: (x:FStar.Ghost.erased var {fresh_wrt x g (freevars inv)} & tot_typing (push_binding g x ppname_default tm_unit) (open_term inv x) tm_slprop) +: (x:FStar.Ghost.erased var {fresh_wrt x g (freevars inv)}) = let x : (x:FStar.Ghost.erased var {fresh_wrt x g (freevars inv)}) = RU.magic () in - let tt : tot_typing (push_binding g x ppname_default tm_unit) (open_term inv x) tm_slprop = () in - (|x, tt|) + x let inv_as_post_hint (#g:env) (#inv:slprop) (inv_typing:tot_typing g inv tm_slprop) : T.Tac (ph:post_hint_for_env g { ph.post == inv /\ ph.ret_ty == tm_unit /\ ph.u == u0 /\ ph.effect_annot == EffectAnnotSTT }) -= let (| x, post_typing_src |) = inv_typing_weakening inv_typing in += let x = inv_typing_weakening inv_typing in { g; effect_annot=EffectAnnotSTT; effect_annot_typing=(); ret_ty=tm_unit; u=u0; ty_typing=unit_typing g; post=inv; - x; post_typing_src } + x; post_typing_src = () } let tm_l_true : term = FStar.Reflection.V2.Formula.(formula_as_term True_) let tm_l_or (a b: term) : term = FStar.Reflection.V2.Formula.(formula_as_term (Or a b)) @@ -161,7 +160,7 @@ let check_while | None -> u0, tm_unit, unit_const, false | Some meas -> let meas' = purify_term g { ctxt_now = pre; ctxt_old = Some pre } meas in - let (| _, _, ty, u, _ |) = compute_term_type_and_u g meas' in + let (| _, _, ty, u |) = compute_term_type_and_u g meas' in u, ty, meas, true in let inv_range = term_range inv in @@ -191,7 +190,7 @@ let check_while then T.fail "Expected while condition to return a bool"; assume freshv g1 breaklblx; - let (| break_pred, break_typ |) : t:term & tot_typing g0 t tm_slprop = + let break_pred : term = match loop_ensures with | Some loop_ensures -> let (| x_cond, g1', (_, _), cond_post, k |) = res_cond in @@ -202,7 +201,7 @@ let check_while let loop_ensures = purify_term g1' { ctxt_now = cond_post; ctxt_old = Some pre } loop_ensures in let loop_ensures = RU.beta_lax (elab_env g1') loop_ensures in let loop_ensures = RU.deep_compress_safe loop_ensures in - let (| loop_ensures, loop_ensures_typ |) = check_tot_term g1' loop_ensures tm_prop in + let loop_ensures = check_tot_term g1' loop_ensures tm_prop in let loop_ensures = cond_post `tm_star` tm_pure loop_ensures in let y = fresh g1' in let g1'' = push_binding g1' y ppname_default tm_unit in @@ -215,11 +214,10 @@ let check_while let loop_ensures = subst_loop_requires_marker_with_true loop_ensures.post in let loop_ensures = open_term' loop_ensures unit_const 0 in let loop_ensures_typ: tot_typing g0 loop_ensures tm_slprop = () in - (| loop_ensures, loop_ensures_typ |) + loop_ensures | None -> let t: term = tm_exists_sl u_meas (as_binder ty_meas) (close_term (open_term' post_cond.post tm_false 0) (snd x_meas)) in - let typ: tot_typing g0 t tm_slprop = () in - (| t, typ |) + t in let break_lbl_c = C_ST { u = u0; diff --git a/src/checker/Pulse.Checker.WithLocal.fst b/src/checker/Pulse.Checker.WithLocal.fst index 4d30138fb..8b94cf7b8 100644 --- a/src/checker/Pulse.Checker.WithLocal.fst +++ b/src/checker/Pulse.Checker.WithLocal.fst @@ -87,9 +87,8 @@ let check | PostHint post -> let g = push_context "check_withlocal" t.range g in let Tm_WithLocal {binder; initializer=init; body} = t.term in - let (| init, init_u, init_t, init_t_typing, init_typing |) : - (init: option term & u:universe & ty:term & universe_of g ty u & - (match init with Some init -> tot_typing g init ty | None -> unit)) + let (| init, init_u, init_t |) : + (init: option term & u:universe & ty:term) = (* Check against annotation if any *) let ty = binder.binder_ty in @@ -102,16 +101,13 @@ let check // will turn postconditions into refinements, and we don't want these // going into the type of the local variable. See issue #512. let init_t = unrefine init_t in - // The proofs of typing should follow from the ones above + inversion lemmas. - (| Some init, init_u, init_t, magic(), magic() |) + (| Some init, init_u, init_t |) | _, Some init -> let ty, _ = tc_type_phase1 g ty in let u = check_universe g ty in - let (| init, init_typing |) = check_term g init T.E_Total ty in - let ty_typing : universe_of g ty u = () in - let init_typing : typing g init T.E_Total ty = init_typing in - (| Some init, u, ty, ty_typing, init_typing |) + let init = check_term g init T.E_Total ty in + (| Some init, u, ty |) | Tm_Unknown, None -> fail g (Some <| head_range t) @@ -120,8 +116,7 @@ let check | _, None -> let ty, _ = tc_type_phase1 g ty in let u = check_universe g ty in - let ty_typing : universe_of g ty u = () in - (| None, u, ty, ty_typing, () |) + (| None, u, ty |) in if not (eq_univ init_u u0) then ( diff --git a/src/checker/Pulse.Checker.WithLocalArray.fst b/src/checker/Pulse.Checker.WithLocalArray.fst index fa5f84cd1..d85430911 100644 --- a/src/checker/Pulse.Checker.WithLocalArray.fst +++ b/src/checker/Pulse.Checker.WithLocalArray.fst @@ -112,9 +112,8 @@ let check let _ = Tactics.BreakVC.break_vc () in let g = push_context "check_withlocal_array" t.range g in let Tm_WithLocalArray {binder; initializer; length; body} = t.term in - let (| init, init_u, init_t, init_t_typing, init_typing |) - : (init:option term & u:universe & ty:term & universe_of g ty u & - (match init with Some t -> tot_typing g t ty | None -> unit)) = + let (| init, init_u, init_t |) + : (init:option term & u:universe & ty:term) = (* Check against annotation if any *) let ty = binder.binder_ty in match inspect_term ty with @@ -122,7 +121,7 @@ let check (match initializer with | Some initializer -> let (| init, init_u, init_t |) = compute_tot_term_type_and_u g initializer in - (| Some init, init_u, init_t, (), () |) + (| Some init, init_u, init_t |) | None -> fail g (Some <| head_range t) "allocating a local array: type must be specified when there is no initializer") @@ -135,16 +134,14 @@ let check (P.term_to_string ty)) | Some ty -> let u = check_universe g ty in - let ty_typing : universe_of g ty u = () in match initializer with | Some initializer -> - let (| init, init_typing |) = check_term g initializer T.E_Total ty in - let init_typing : typing g init T.E_Total ty = init_typing in - (| Some init, u, ty, ty_typing, init_typing |) + let init = check_term g initializer T.E_Total ty in + (| Some init, u, ty |) | None -> - (| None, u, ty, ty_typing, () |) + (| None, u, ty |) in - let (| len, len_typing |) = + let len = check_tot_term g length tm_szt in if not (eq_univ init_u u0) then ( @@ -161,7 +158,7 @@ let check let g_extended = extend_env g init_t x binder.binder_ppname init in let body_pre = comp_withlocal_array_body_pre pre init_t x_tm init len in let body_pre_typing = - with_local_array_pre_typing pre_typing init_t init len init_typing len_typing x binder.binder_ppname in + with_local_array_pre_typing pre_typing init_t init len () () x binder.binder_ppname in // elaborating this post here, // so that later we can check the computed post to be equal to this one let post : post_hint_for_env g = post in diff --git a/src/checker/Pulse.JoinComp.fst b/src/checker/Pulse.JoinComp.fst index ff9d22fa3..6cfd2018f 100644 --- a/src/checker/Pulse.JoinComp.fst +++ b/src/checker/Pulse.JoinComp.fst @@ -293,26 +293,23 @@ let join_slprop g b (ex1 ex2:list (universe & binder)) (p1 p2:slprop) list_as_slprop (remaining::pures1@pures2@matched) let rec join_effect_annot g (e1 e2:effect_annot) -: T.Tac (e:effect_annot & effect_annot_typing g e) +: T.Tac effect_annot = match e1, e2 with | _, EffectAnnotSTT - | EffectAnnotSTT, _ -> (| EffectAnnotSTT, () |) + | EffectAnnotSTT, _ -> EffectAnnotSTT | EffectAnnotGhost { opens=o1 }, EffectAnnotGhost { opens=o2 } -> let o = tm_join_inames o1 o2 in let ty = Pulse.Checker.Pure.core_check_term g o RT.E_Total tm_inames in - let e = EffectAnnotGhost { opens = o } in - (| e, ty |) + EffectAnnotGhost { opens = o } | EffectAnnotAtomic { opens=o1 }, EffectAnnotAtomic { opens=o2 } -> let o = tm_join_inames o1 o2 in let ty = Pulse.Checker.Pure.core_check_term g o RT.E_Total tm_inames in - let e = EffectAnnotAtomic { opens = o } in - (| e, ty |) + EffectAnnotAtomic { opens = o } | EffectAnnotAtomicOrGhost { opens=o1 }, EffectAnnotAtomicOrGhost { opens=o2 } -> let o = tm_join_inames o1 o2 in let ty = Pulse.Checker.Pure.core_check_term g o RT.E_Total tm_inames in - let e = EffectAnnotAtomicOrGhost { opens = o } in - (| e, ty |) + EffectAnnotAtomicOrGhost { opens = o } | EffectAnnotAtomicOrGhost { opens=o1 }, EffectAnnotGhost _ -> join_effect_annot g (EffectAnnotGhost {opens=o1}) e2 @@ -366,12 +363,12 @@ let join_post #g #hyp #b assume (fresh_wrt x g (freevars joined_post)); let u = Pulse.Checker.Pure.check_universe g p1.ret_ty in let joined_post' = open_term_nv joined_post (ppname_default, x) in - let post_typing_src = Pulse.Checker.Pure.check_slprop_with_core g' joined_post' in - let (| eff, eff_ty |) = join_effect_annot g p1.effect_annot p2.effect_annot in + let _ = Pulse.Checker.Pure.check_slprop_with_core g' joined_post' in + let eff = join_effect_annot g p1.effect_annot p2.effect_annot in let res : post_hint_for_env g = - {g; effect_annot=eff; effect_annot_typing=eff_ty; + {g; effect_annot=eff; effect_annot_typing=(); ret_ty=p1.ret_ty; u=u; ty_typing=(); x; - post=joined_post; post_typing_src} + post=joined_post; post_typing_src=()} in res diff --git a/src/checker/Pulse.Typing.Combinators.fst b/src/checker/Pulse.Typing.Combinators.fst index 68d002d7d..0ce90352d 100644 --- a/src/checker/Pulse.Typing.Combinators.fst +++ b/src/checker/Pulse.Typing.Combinators.fst @@ -115,17 +115,16 @@ let weaken_comp_inames (#g:env) (#e:st_term) (#c:comp_st) (d_e:st_typing g e c) = match c with | C_ST _ -> (| c, d_e |) | C_STGhost inames sc -> - let _ = check_prop_validity g _ (tm_inames_subset_typing g inames new_inames) in + let _ = check_prop_validity g (tm_inames_subset inames new_inames) in (| with_inames c new_inames, () |) | C_STAtomic inames obs sc -> - let _ = check_prop_validity g _ (tm_inames_subset_typing g inames new_inames) in + let _ = check_prop_validity g (tm_inames_subset inames new_inames) in (| with_inames c new_inames, () |) let try_lift_ghost_atomic (g:env) (e:st_term) (c:comp_st { C_STGhost? c }) (d:st_typing g e c) : T.Tac (option (st_typing g e (st_ghost_as_atomic c))) -= let comp_res_typing : universe_of g (comp_res c) (comp_u c) = () in - let w = try_get_non_informative_witness g (comp_u c) (comp_res c) comp_res_typing in += let w = try_get_non_informative_witness g (comp_u c) (comp_res c) in match w with | None -> None | Some w -> Some () @@ -161,15 +160,15 @@ let mk_bind_ghost_ghost : bind_t C_STGhost? C_STGhost? = end else if (PostHint? post_hint) then ( - let _ = check_prop_validity g _ (tm_inames_subset_typing g inames1 inames2) in + let _ = check_prop_validity g (tm_inames_subset inames1 inames2) in let c : comp_st = C_STGhost inames2 (st_comp_with_pre sc2 pre) in let t = wrst c (Tm_Bind {binder=b; head=e1; body=e2}) in (| t, c |) ) else begin let new_inames = tm_join_inames inames1 inames2 in - let _ = check_prop_validity g _ (tm_inames_subset_typing g inames1 new_inames) in - let _ = check_prop_validity g _ (tm_inames_subset_typing g inames2 new_inames) in + let _ = check_prop_validity g (tm_inames_subset inames1 new_inames) in + let _ = check_prop_validity g (tm_inames_subset inames2 new_inames) in let c : comp_st = C_STGhost new_inames (st_comp_with_pre sc2 pre) in let t = wrst c (Tm_Bind {binder=b; head=e1; body=e2}) in (| t, c |) @@ -192,15 +191,15 @@ let mk_bind_atomic_atomic end else if (PostHint? post_hint) then ( - let _ = check_prop_validity g _ (tm_inames_subset_typing g inames1 inames2) in + let _ = check_prop_validity g (tm_inames_subset inames1 inames2) in let c : comp_st = C_STAtomic inames2 (join_obs obs1 obs2) (st_comp_with_pre sc2 pre) in let t = wrst c (Tm_Bind {binder=b; head=e1; body=e2}) in (| t, c |) ) else begin let new_inames = tm_join_inames inames1 inames2 in - let _ = check_prop_validity g _ (tm_inames_subset_typing g inames1 new_inames) in - let _ = check_prop_validity g _ (tm_inames_subset_typing g inames2 new_inames) in + let _ = check_prop_validity g (tm_inames_subset inames1 new_inames) in + let _ = check_prop_validity g (tm_inames_subset inames2 new_inames) in let c : comp_st = C_STAtomic new_inames (join_obs obs1 obs2) (st_comp_with_pre sc2 pre) in let t = wrst c (Tm_Bind {binder=b; head=e1; body=e2}) in (| t, c |) @@ -346,7 +345,7 @@ let bind_res_and_post_typing g c2 x post_hint else ( let y = x in //fresh g in let s2_post_opened = open_term_nv s2.post (v_as_nv y) in - let post_typing = + let _ = check_slprop_with_core (push_binding g y ppname_default s2.res) s2_post_opened in () ) From 438d7e9564c49bd3e5c1ef0398f8c3eb7491c1a5 Mon Sep 17 00:00:00 2001 From: Gabriel Ebner Date: Fri, 27 Feb 2026 22:37:06 +0000 Subject: [PATCH 10/18] Remove Pulse.Typing.Metatheory modules All functions in these modules returned unit (or tuples of unit) since all typing token types are now unit. Inline the trivial returns at call sites and delete all 4 Metatheory files (384 lines). Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/checker/Pulse.Checker.Base.fst | 35 +---- src/checker/Pulse.Checker.Bind.fst | 4 +- src/checker/Pulse.Checker.Comp.fsti | 1 - src/checker/Pulse.Checker.Exists.fst | 4 +- src/checker/Pulse.Checker.If.fst | 9 +- src/checker/Pulse.Checker.IntroPure.fst | 2 +- src/checker/Pulse.Checker.Match.fst | 9 +- src/checker/Pulse.Checker.Prover.Substs.fst | 1 - src/checker/Pulse.Checker.Pure.fst | 1 - src/checker/Pulse.Checker.Return.fst | 1 - src/checker/Pulse.Checker.While.fst | 1 - src/checker/Pulse.Typing.Combinators.fst | 2 - src/checker/Pulse.Typing.Metatheory.Base.fst | 148 ------------------ src/checker/Pulse.Typing.Metatheory.Base.fsti | 138 ---------------- src/checker/Pulse.Typing.Metatheory.fst | 35 ----- src/checker/Pulse.Typing.Metatheory.fsti | 63 -------- 16 files changed, 14 insertions(+), 440 deletions(-) delete mode 100644 src/checker/Pulse.Typing.Metatheory.Base.fst delete mode 100644 src/checker/Pulse.Typing.Metatheory.Base.fsti delete mode 100644 src/checker/Pulse.Typing.Metatheory.fst delete mode 100644 src/checker/Pulse.Typing.Metatheory.fsti diff --git a/src/checker/Pulse.Checker.Base.fst b/src/checker/Pulse.Checker.Base.fst index c5a2483e8..843870677 100644 --- a/src/checker/Pulse.Checker.Base.fst +++ b/src/checker/Pulse.Checker.Base.fst @@ -19,7 +19,6 @@ module Pulse.Checker.Base module R = FStar.Reflection.V2 module T = FStar.Tactics.V2 module RT = FStar.Reflection.Typing -module Metatheory = Pulse.Typing.Metatheory module CP = Pulse.Checker.Pure module RU = Pulse.RuntimeUtils module FV = Pulse.Typing.FV @@ -27,8 +26,6 @@ open Pulse.Checker.Util open Pulse.Show open Pulse.Typing.Combinators -open Pulse.Typing.Metatheory - let debug (g:env) (f: unit -> T.Tac string) : T.Tac unit = if RU.debug_at_level (fstar_env g) "pulse.checker" then T.print (f()) @@ -138,18 +135,16 @@ let comp_typing_as_effect_annot_typing (#g:env) (#c:comp_st) (ct:comp_typing_u g let post_hint_from_comp_typing #g #c ct = - let st_comp_typing = fst <| Metatheory.comp_typing_inversion g c ct in let effect_annot_typing = comp_typing_as_effect_annot_typing ct in - let inv = Metatheory.st_comp_typing_inversion g (st_comp_of_comp c) st_comp_typing in let p : post_hint_t = { g; effect_annot=_; effect_annot_typing; ret_ty = comp_res c; u=comp_u c; - ty_typing=Mkdtuple4?._1 inv; + ty_typing=(); post=comp_post c; - x=Mkdtuple4?._3 inv; - post_typing_src=Mkdtuple4?._4 inv } + x=admit(); + post_typing_src=() } in p @@ -337,7 +332,6 @@ let continuation_elaborator_with_bind' (#g:env) (ctxt:term) let res1 = comp_res c1 in let post1 = comp_post c1 in let ctxt_typing = star_typing_inversion_l ctxt_pre1_typing in - // let p_prop = Metatheory.pure_typing_inversion pure_typing in let v_eq = () in let framing_token : frame_for_req_in_ctxt g (tm_star ctxt pre1) pre1 = ctxt @@ -348,8 +342,7 @@ let continuation_elaborator_with_bind' (#g:env) (ctxt:term) (show c1)); let c1 = apply_frame g e1 (tm_star ctxt pre1) ctxt_pre1_typing c1 e1_typing framing_token in - let (| u_of_1, pre_typing, _, _ |) = - Metatheory.(st_comp_typing_inversion g (st_comp_of_comp c1) (fst <| comp_typing_inversion g c1 (st_typing_correctness g e1 c1 ()))) in + let u_of_1 = () in let b = res1 in let ppname, x = x in let g' = push_binding g x ppname b in @@ -440,18 +433,7 @@ let st_comp_typing_with_post_hint = if x = Ghost.reveal ph.x then post_typing_src else - let open Pulse.Typing.Metatheory.Base in - let tt : - tot_typing - (push_binding ph.g x ppname_default ph.ret_ty) - (subst_term (open_term ph.post ph.x) (renaming ph.x x)) - (subst_term tm_slprop (renaming ph.x x)) = - tot_typing_renaming1 ph.g ph.x ph.ret_ty (open_term ph.post ph.x) tm_slprop post_typing_src x - in - assert (subst_term tm_slprop (renaming ph.x x) == tm_slprop); - assume (subst_term (open_term ph.post ph.x) (renaming ph.x x) == - open_term ph.post x); - coerce_eq tt () + () in let post_typing_src : tot_typing (push_binding g x ppname_default ph.ret_ty) @@ -484,7 +466,7 @@ let continuation_elaborator_with_bind_fn (#g:env) (ctxt:term) let e2_closed = close_st_term e2 x in assume (open_st_term (close_st_term e2 x) x == e2); let e = wrst c2 (Tm_Bind {binder=b; head=e1; body=e2_closed}) in - let u = Pulse.Typing.Metatheory.Base.st_typing_correctness_ctot g e1 c1 e1_typing in + let u : Ghost.erased universe = RU.magic () in let c2_typing : comp_typing g c2 (universe_of_comp c2) = () in (| e, c2 |) @@ -600,8 +582,7 @@ let checker_result_for_st_typing (#g:env) (#ctxt:slprop) (#post_hint:post_hint_o = let (| e1, c1 |) = d in let x = fresh g in assume (~ (x `Set.mem` freevars (comp_post c1))); - let u_of_1, pre_typing, post_typing = - Metatheory.(st_comp_typing_inversion_with_name g (st_comp_of_comp c1) (fst <| comp_typing_inversion g c1 (st_typing_correctness g e1 c1 ())) x) in + let u_of_1, pre_typing, post_typing = (), (), () in let g' = push_binding g x ppname (comp_res c1) in let ctxt' = open_term_nv (comp_post c1) (ppname, x) in let k @@ -788,7 +769,7 @@ let norm_st_typing_inverse then ( let t0_typing : Ghost.erased (RT.tot_typing (elab_env g) t0 (RT.tm_type u)) = - rt_equiv_typing #_ #_ #t0 related_t1_t1' d1 + admit() in let eq : Ghost.erased (RT.equiv (elab_env g) t0 t1) diff --git a/src/checker/Pulse.Checker.Bind.fst b/src/checker/Pulse.Checker.Bind.fst index e6201eead..b871d7349 100644 --- a/src/checker/Pulse.Checker.Bind.fst +++ b/src/checker/Pulse.Checker.Bind.fst @@ -27,7 +27,6 @@ open Pulse.Checker.Util module T = FStar.Tactics.V2 module P = Pulse.Syntax.Printer -module Metatheory = Pulse.Typing.Metatheory module Abs = Pulse.Checker.Abs module RU = Pulse.Reflection.Util @@ -53,8 +52,7 @@ let check_bind_fn let x = fresh g in let b = { binder with binder_ty = comp_res c } in let g' = push_binding g x (binder.binder_ppname) b.binder_ty in - let ctxt_typing' : tot_typing g' ctxt tm_slprop = - Metatheory.tot_typing_weakening_single g ctxt tm_slprop ctxt_typing x b.binder_ty in + let ctxt_typing' : tot_typing g' ctxt tm_slprop = () in let r = check g' _ ctxt_typing' post_hint res_ppname (open_st_term_nv body (binder.binder_ppname, x)) in let body_typing = apply_checker_result_k #_ #_ #(PostHint?.v post_hint) r res_ppname in let k = Pulse.Checker.Base.continuation_elaborator_with_bind_fn ctxt ctxt_typing t c b () (binder.binder_ppname, x) in diff --git a/src/checker/Pulse.Checker.Comp.fsti b/src/checker/Pulse.Checker.Comp.fsti index bfe7e286e..67fc9c1bf 100644 --- a/src/checker/Pulse.Checker.Comp.fsti +++ b/src/checker/Pulse.Checker.Comp.fsti @@ -20,7 +20,6 @@ module T = FStar.Tactics.V2 open Pulse.Syntax open Pulse.Typing -open Pulse.Typing.Metatheory.Base val check (g:env) (c:comp_st) diff --git a/src/checker/Pulse.Checker.Exists.fst b/src/checker/Pulse.Checker.Exists.fst index 919b5154d..85c348df5 100644 --- a/src/checker/Pulse.Checker.Exists.fst +++ b/src/checker/Pulse.Checker.Exists.fst @@ -28,8 +28,6 @@ module T = FStar.Tactics.V2 module P = Pulse.Syntax.Printer module FV = Pulse.Typing.FV -module Metatheory = Pulse.Typing.Metatheory - let slprop_as_list_typing (#g:env) (#p:term) (t:tot_typing g p tm_slprop) (x:term { List.Tot.memP x (slprop_as_list p) }) @@ -129,7 +127,7 @@ let check_intro_exists Pulse.Typing.FV.tot_typing_freevars g t tm_slprop (); let x = fresh g in - let ty_typing, _ = Metatheory.tm_exists_inversion g u b.binder_ty p () x in + let ty_typing, _ = (), () in let witness = check_term g witness T.E_Ghost b.binder_ty in let intro_st = wtag (Some STT_Ghost) (Tm_IntroExists { p = tm_exists_sl u b p; witnesses = [witness] }) in diff --git a/src/checker/Pulse.Checker.If.fst b/src/checker/Pulse.Checker.If.fst index c8ee6515c..69db87688 100644 --- a/src/checker/Pulse.Checker.If.fst +++ b/src/checker/Pulse.Checker.If.fst @@ -23,7 +23,6 @@ open Pulse.Checker.Pure open Pulse.Checker.Base module T = FStar.Tactics.V2 -module Metatheory = Pulse.Typing.Metatheory module J = Pulse.JoinComp module RW = Pulse.Checker.Prover.RewritesTo #set-options "--z3rlimit 40" @@ -65,13 +64,7 @@ let check let g_with_eq = g_with_eq g hyp b in let check_branch (eq_v:term) (br:st_term) (is_then:bool) : T.Tac (checker_result_t (g_with_eq eq_v) pre post_hint) - = let pre_typing = - Metatheory.tot_typing_weakening_single - g pre tm_slprop - pre_typing - hyp - (mk_sq_rewrites_to_p u0 tm_bool b eq_v) - in + = let pre_typing : tot_typing (g_with_eq eq_v) pre tm_slprop = () in let br = let t = diff --git a/src/checker/Pulse.Checker.IntroPure.fst b/src/checker/Pulse.Checker.IntroPure.fst index 26025ceee..81d888d99 100644 --- a/src/checker/Pulse.Checker.IntroPure.fst +++ b/src/checker/Pulse.Checker.IntroPure.fst @@ -31,7 +31,7 @@ let check_prop (g:env) (p:term) let p = Pulse.Checker.Pure.check_slprop g (tm_pure p) in match inspect_term p with | Tm_Pure pp -> - let prop_typing = Pulse.Typing.Metatheory.pure_typing_inversion g pp () in + let prop_typing = () in pp | _ -> fail g None diff --git a/src/checker/Pulse.Checker.Match.fst b/src/checker/Pulse.Checker.Match.fst index 3af5c5393..07d800751 100644 --- a/src/checker/Pulse.Checker.Match.fst +++ b/src/checker/Pulse.Checker.Match.fst @@ -184,12 +184,7 @@ val tot_typing_weakening_n (d:tot_typing g t ty) : Tot (tot_typing (push_bindings g bs) t ty) (decreases bs) -let rec tot_typing_weakening_n bs d = - match bs with - | [] -> d - | {x; ty} :: bs -> - let d = Pulse.Typing.Metatheory.tot_typing_weakening_single _ _ _ d x ty in - tot_typing_weakening_n bs d +let rec tot_typing_weakening_n #g #t #ty bs d = () let patof (b:branch) : pattern = b.pat let samepat (b1 b2 : branch) : prop = b1.pat == b2.pat @@ -276,7 +271,7 @@ let check_branch { t with effect_tag = e.effect_tag } in let pre_typing = tot_typing_weakening_n pulse_bs pre_typing in // weaken w/ binders - let pre_typing = Pulse.Typing.Metatheory.tot_typing_weakening_single _ _ _ pre_typing hyp_var eq_typ in // weaken w/ branch eq + let pre_typing : tot_typing _ _ _ = () in // weaken w/ branch eq let (| e, c |) = let ppname = mk_ppname_no_range "_br" in diff --git a/src/checker/Pulse.Checker.Prover.Substs.fst b/src/checker/Pulse.Checker.Prover.Substs.fst index d8866f1cd..92afd57f2 100644 --- a/src/checker/Pulse.Checker.Prover.Substs.fst +++ b/src/checker/Pulse.Checker.Prover.Substs.fst @@ -26,7 +26,6 @@ open Pulse.Checker.Pure module L = FStar.List.Tot module Env = Pulse.Typing.Env -module Metatheory = Pulse.Typing.Metatheory let coerce_eq (#a #b:Type) (x:a) (_:squash (a == b)) : y:b {y == x} = x diff --git a/src/checker/Pulse.Checker.Pure.fst b/src/checker/Pulse.Checker.Pure.fst index f4cf9a97a..3a82e8ee9 100644 --- a/src/checker/Pulse.Checker.Pure.fst +++ b/src/checker/Pulse.Checker.Pure.fst @@ -521,7 +521,6 @@ let check_slprop_with_core (g:env) (push_context_no_range g "check_slprop_with_core") t T.E_Total tm_slprop -module Metatheory = Pulse.Typing.Metatheory.Base let non_informative_class_typing (g:env) (u:universe) (ty:typ) (ty_typing : universe_of g ty u) diff --git a/src/checker/Pulse.Checker.Return.fst b/src/checker/Pulse.Checker.Return.fst index 4231b80d2..09bce0267 100644 --- a/src/checker/Pulse.Checker.Return.fst +++ b/src/checker/Pulse.Checker.Return.fst @@ -23,7 +23,6 @@ open Pulse.Checker.Base open Pulse.Checker.Prover module T = FStar.Tactics.V2 -module Metatheory = Pulse.Typing.Metatheory module RU = Pulse.RuntimeUtils let check_effect diff --git a/src/checker/Pulse.Checker.While.fst b/src/checker/Pulse.Checker.While.fst index 4f9535599..713749dbd 100644 --- a/src/checker/Pulse.Checker.While.fst +++ b/src/checker/Pulse.Checker.While.fst @@ -26,7 +26,6 @@ open Pulse.Checker.ImpureSpec module T = FStar.Tactics.V2 module R = FStar.Reflection.V2 module P = Pulse.Syntax.Printer -module Metatheory = Pulse.Typing.Metatheory module RU = Pulse.RuntimeUtils let empty_env g = mk_env (fstar_env g) diff --git a/src/checker/Pulse.Typing.Combinators.fst b/src/checker/Pulse.Typing.Combinators.fst index 0ce90352d..c17a2b5e8 100644 --- a/src/checker/Pulse.Typing.Combinators.fst +++ b/src/checker/Pulse.Typing.Combinators.fst @@ -22,8 +22,6 @@ module P = Pulse.Syntax.Printer module CU = Pulse.Checker.Util module RU = Pulse.RuntimeUtils -module Metatheory = Pulse.Typing.Metatheory.Base - open FStar.List.Tot open Pulse.Syntax open Pulse.Typing diff --git a/src/checker/Pulse.Typing.Metatheory.Base.fst b/src/checker/Pulse.Typing.Metatheory.Base.fst deleted file mode 100644 index 44059992b..000000000 --- a/src/checker/Pulse.Typing.Metatheory.Base.fst +++ /dev/null @@ -1,148 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Typing.Metatheory.Base -open Pulse.Syntax -open Pulse.Syntax.Naming -open Pulse.Typing -module RU = Pulse.RuntimeUtils -module RT = FStar.Reflection.Typing - -let admit_st_comp_typing (g:env) (st:st_comp) - : st_comp_typing g st - = () - -let admit_comp_typing (g:env) (c:comp_st) - : comp_typing_u g c - = () - -let st_typing_correctness_ctot (g:env) (t:st_term) (c:comp{C_Tot? c}) - (_:st_typing g t c) -: Ghost.erased universe -= let u : Ghost.erased universe = RU.magic () in - u - -let st_typing_correctness (g:env) (t:st_term) (c:comp_st) - (_:st_typing g t c) - : comp_typing_u g c - = () - -let add_frame_well_typed (g:env) (c:comp_st) (ct:comp_typing_u g c) - (f:term) (ft:tot_typing g f tm_slprop) - : Dv (comp_typing_u g (add_frame c f)) - = () - -let emp_inames_typing (g:env) : tot_typing g tm_emp_inames tm_inames = () - -let comp_typing_inversion g c ct = - ((), ()) - -let st_comp_typing_inversion_cofinite (g:env) (st:st_comp) (ct:st_comp_typing g st) = - (), (), (fun _ -> ()) - -let stc_x (g:env) (st:st_comp) (ct:st_comp_typing g st) : x:Ghost.erased var{fresh_wrt x g (freevars st.post)} = admit() - -let st_comp_typing_inversion (g:env) (st:st_comp) (ct:st_comp_typing g st) = - (| (), (), stc_x g st ct, () |) - -let st_comp_typing_inversion_with_name (g:env) (st:st_comp) (ct:st_comp_typing g st) (x:var{fresh_wrt x g (freevars st.post)}) -: (universe_of g st.res st.u & - tot_typing g st.pre tm_slprop & - tot_typing (push_binding g x ppname_default st.res) (open_term st.post x) tm_slprop) -= ((), (), ()) - -let tm_exists_inversion (g:env) (u:universe) (ty:term) (p:term) - (_:tot_typing g (tm_exists_sl u (as_binder ty) p) tm_slprop) - (x:var { fresh_wrt x g (freevars p) } ) - : universe_of g ty u & - tot_typing (push_binding g x ppname_default ty) p tm_slprop - = (), () - -let pure_typing_inversion (g:env) (p:term) (_:tot_typing g (tm_pure p) tm_slprop) - : tot_typing g p (wr FStar.Reflection.Typing.tm_prop Range.range_0) - = () - -let typing_correctness _ = admit() -let tot_typing_renaming1 _ _ _ _ _ _ = admit() -let tot_typing_weakening _ _ _ _ _ _ = admit () - -let non_informative_t_weakening (g g':env) (g1:env{ pairwise_disjoint g g1 g' }) - (u:universe) (t:term) - (d:non_informative_t (push_env g g') u t) - : non_informative_t (push_env (push_env g g1) g') u t = - d - -let non_informative_c_weakening (g g':env) (g1:env{ pairwise_disjoint g g1 g' }) - (c:comp_st) - (d:non_informative_c (push_env g g') c) - : non_informative_c (push_env (push_env g g1) g') c = - non_informative_t_weakening g g' g1 _ _ d - -let bind_comp_weakening (g:env) (g':env { disjoint g g' }) - (x:var) (c1 c2 c3:comp) (d:bind_comp (push_env g g') x c1 c2 c3) - (g1:env { pairwise_disjoint g g1 g' }) - : bind_comp (push_env (push_env g g1) g') x c1 c2 c3 - = () - -let lift_comp_weakening (g:env) (g':env { disjoint g g'}) - (c1 c2:comp) (d:lift_comp (push_env g g') c1 c2) - (g1:env { pairwise_disjoint g g1 g' }) - : lift_comp (push_env (push_env g g1) g') c1 c2 - = () - -// TODO: the proof for RT.Equiv is not correct here -let equiv_weakening (g:env) (g':env { disjoint g g' }) - #t1 #t2 (d:RT.equiv (elab_env (push_env g g')) t1 t2) - (g1:env { pairwise_disjoint g g1 g' }) - : RT.equiv (elab_env (push_env (push_env g g1) g')) t1 t2 = - admit (); - d - -let st_equiv_weakening (g:env) (g':env { disjoint g g' }) - (c1 c2:comp) (d:st_equiv (push_env g g') c1 c2) - (g1:env { pairwise_disjoint g g1 g' }) - : st_equiv (push_env (push_env g g1) g') c1 c2 = - () - -// TODO: add precondition that g1 extends g' -let prop_validity_token_weakening (#g:env) (#t:term) - (token:prop_validity g t) - (g1:env) - : prop_validity g1 t = - admit (); - token - -let st_sub_weakening (g:env) (g':env { disjoint g g' }) - (c1 c2:comp) (d:st_sub (push_env g g') c1 c2) - (g1:env { pairwise_disjoint g g1 g' }) - : st_sub (push_env (push_env g g1) g') c1 c2 - = () - -let st_comp_typing_weakening (g:env) (g':env { disjoint g g' }) - (s:st_comp) (d:st_comp_typing (push_env g g') s) - (g1:env { pairwise_disjoint g g1 g' }) - : st_comp_typing (push_env (push_env g g1) g') s = - () - -let comp_typing_weakening (g:env) (g':env { disjoint g g' }) - (c:comp) (u:universe) (d:comp_typing (push_env g g') c u) - (g1:env { pairwise_disjoint g g1 g' }) - : comp_typing (push_env (push_env g g1) g') c u = - () - -let st_typing_weakening g g' t c d g1 - : st_typing (push_env (push_env g g1) g') t c - = () \ No newline at end of file diff --git a/src/checker/Pulse.Typing.Metatheory.Base.fsti b/src/checker/Pulse.Typing.Metatheory.Base.fsti deleted file mode 100644 index 4683087f8..000000000 --- a/src/checker/Pulse.Typing.Metatheory.Base.fsti +++ /dev/null @@ -1,138 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Typing.Metatheory.Base -open Pulse.Syntax -open Pulse.Syntax.Naming -open Pulse.Typing - -module T = FStar.Tactics.V2 -module R = FStar.Reflection.V2 -module RT = FStar.Reflection.Typing -module C = FStar.Stubs.TypeChecker.Core - -module S = Pulse.Syntax -module RU = Pulse.RuntimeUtils - - -open FStar.Ghost - - -val admit_comp_typing (g:env) (c:comp_st) - : comp_typing_u g c - -let rt_equiv_typing (#g:_) (#t0 #t1:_) (d:RT.equiv g t0 t1) - (#k:_) - (d1:Ghost.erased (RT.tot_typing g t0 k)) - : Ghost.erased (RT.tot_typing g t1 k) - = admit() - -val st_typing_correctness_ctot (g:env) (t:st_term) (c:comp{C_Tot? c}) - (_:st_typing g t c) - : Ghost.erased universe - -let inames_of_comp_st (c:comp_st) = - match c with - | C_STAtomic _ _ _ - | C_STGhost _ _ -> comp_inames c - | _ -> tm_emp_inames - -let iname_typing (g:env) (c:comp_st) = tot_typing g (inames_of_comp_st c) tm_inames - -val st_typing_correctness (g:env) (t:st_term) (c:comp_st) - (d:st_typing g t c) - : comp_typing_u g c - -val comp_typing_inversion (g:env) (c:comp_st) (ct:comp_typing_u g c) - : erased (st_comp_typing g (st_comp_of_comp c) & iname_typing g c) - -val st_comp_typing_inversion_cofinite (g:env) (st:st_comp) (ct:st_comp_typing g st) - : ( - universe_of g st.res st.u & - tot_typing g st.pre tm_slprop & - (x:var{fresh_wrt x g (freevars st.post)} -> //this part is tricky, to get the quantification on x - tot_typing (push_binding g x ppname_default st.res) (open_term st.post x) tm_slprop)) - -val st_comp_typing_inversion (g:env) (st:st_comp) (ct:st_comp_typing g st) - : (universe_of g st.res st.u & - tot_typing g st.pre tm_slprop & - x:erased var{fresh_wrt x g (freevars st.post)} & - tot_typing (push_binding g x ppname_default st.res) (open_term st.post x) tm_slprop) - -val st_comp_typing_inversion_with_name (g:env) (st:st_comp) (ct:st_comp_typing g st) (x:var{fresh_wrt x g (freevars st.post)}) - : universe_of g st.res st.u & - tot_typing g st.pre tm_slprop & - tot_typing (push_binding g x ppname_default st.res) (open_term st.post x) tm_slprop - -val tm_exists_inversion (g:env) (u:universe) (ty:term) (p:term) - (_:tot_typing g (tm_exists_sl u (as_binder ty) p) tm_slprop) - (x:var { fresh_wrt x g (freevars p) } ) - : (universe_of g ty u & - tot_typing (push_binding g x ppname_default ty) p tm_slprop) - -val pure_typing_inversion (g:env) (p:term) (_:tot_typing g (tm_pure p) tm_slprop) - : tot_typing g p (S.wr FStar.Reflection.Typing.tm_prop Range.range_0) - -module RT = FStar.Reflection.Typing -val typing_correctness - (#g:R.env) - (#t:R.term) - (#ty:R.typ) - (#eff:_) - (_:erased (RT.typing g t (eff, ty))) - : erased (u:R.universe & RT.typing g ty (C.E_Total, RT.tm_type u)) - -let renaming x y = [RT.NT x (tm_var {nm_index=y; nm_ppname=ppname_default})] -val tot_typing_renaming1 - (g:env) (x:var {freshv g x}) (tx e ty:term) - (_:tot_typing (push_binding g x ppname_default tx) e ty) - (y:var { freshv g y /\ x <> y }) - : tot_typing (push_binding g y ppname_default tx) - (subst_term e (renaming x y)) - (subst_term ty (renaming x y)) - - -val tot_typing_weakening - (g:env) (g':env { disjoint g g' }) - (t:term) (ty:typ) (_:tot_typing (push_env g g') t ty) - (g1:env { pairwise_disjoint g g1 g' }) - : tot_typing (push_env (push_env g g1) g') t ty - -val st_typing_weakening - (g:env) (g':env { disjoint g g' }) - (t:st_term) (c:comp) (_:st_typing (push_env g g') t c) - (g1:env { pairwise_disjoint g g1 g' }) - : GTot (st_typing (push_env (push_env g g1) g') t c) - -let veq_weakening - (g:env) (g':env { disjoint g g' }) - (v1 v2:slprop) (_:slprop_equiv (push_env g g') v1 v2) - (g1:env { pairwise_disjoint g g1 g' }) - : slprop_equiv (push_env (push_env g g1) g') v1 v2 = () - -let nt (x:var) (t:term) = [ RT.NT x t ] - -let slprop_equiv_rename - (g:env) (t0 t1:term) - (x:var{freshv g x}) - (y:var{freshv g y}) tx ty (eq:RT.equiv (elab_env g) tx ty) - (v:slprop_equiv (push_binding g x ppname_default tx) (open_term t0 x) (open_term t1 x)) -: slprop_equiv (push_binding g y ppname_default ty) (open_term t0 y) (open_term t1 y) -= () - -let freevars_slprop_equiv (g:env) (t0 t1:term) (d:slprop_equiv g t0 t1) -: Lemma ((freevars t0 `Set.subset` dom g) /\ (freevars t1 `Set.subset` dom g)) -= admit() diff --git a/src/checker/Pulse.Typing.Metatheory.fst b/src/checker/Pulse.Typing.Metatheory.fst deleted file mode 100644 index 4ef626342..000000000 --- a/src/checker/Pulse.Typing.Metatheory.fst +++ /dev/null @@ -1,35 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Typing.Metatheory - -open Pulse.Syntax -open Pulse.Typing - - -let tot_typing_weakening_single g t ty d x x_t = () - -let tot_typing_weakening_standard g t ty d g2 = () - -let st_typing_weakening g g' t c d g1 = () - -let st_typing_weakening_standard g t c d g1 = () - -let st_typing_weakening_end g g' t c d g'' = () - -let veq_weakening g g' v1 v2 d g1 = () - -let veq_weakening_end g g' v1 v2 d g'' = () diff --git a/src/checker/Pulse.Typing.Metatheory.fsti b/src/checker/Pulse.Typing.Metatheory.fsti deleted file mode 100644 index 0bf82db2e..000000000 --- a/src/checker/Pulse.Typing.Metatheory.fsti +++ /dev/null @@ -1,63 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Typing.Metatheory -open Pulse.Syntax -open Pulse.Syntax.Naming -open Pulse.Typing - -include Pulse.Typing.Metatheory.Base - -val tot_typing_weakening_single (g:env) (t ty:term) - (d:tot_typing g t ty) - (x:var { ~ (x `Set.mem` dom g)}) - (x_t:typ) - - : tot_typing (push_binding g x ppname_default x_t) t ty - -val tot_typing_weakening_standard (g:env) - (t ty:term) (d:tot_typing g t ty) - (g1:env { g1 `env_extends` g }) - : tot_typing g1 t ty - -val st_typing_weakening - (g:env) (g':env { disjoint g g' }) - (t:st_term) (c:comp) (d:st_typing (push_env g g') t c) - (g1:env { g1 `env_extends` g /\ disjoint g1 g' }) - : GTot (st_typing (push_env g1 g') t c) - -val st_typing_weakening_standard - (g:env) (t:st_term) (c:comp) (d:st_typing g t c) - (g1:env { g1 `env_extends` g }) - : GTot (st_typing g1 t c) - -val st_typing_weakening_end - (g:env) (g':env { disjoint g g' }) - (t:st_term) (c:comp) (d:st_typing (push_env g g') t c) - (g'':env { g'' `env_extends` g' /\ disjoint g'' g }) - : GTot (st_typing (push_env g g'') t c) - -val veq_weakening - (g:env) (g':env { disjoint g g' }) - (v1 v2:slprop) (d:slprop_equiv (push_env g g') v1 v2) - (g1:env { g1 `env_extends` g /\ disjoint g1 g' }) - : slprop_equiv (push_env g1 g') v1 v2 - -val veq_weakening_end - (g:env) (g':env { disjoint g g' }) - (v1 v2:slprop) (d:slprop_equiv (push_env g g') v1 v2) - (g'':env { g'' `env_extends` g' /\ disjoint g'' g }) - : slprop_equiv (push_env g g'') v1 v2 From bd17edc87e2ea569c39c407372117d3ab32f6461 Mon Sep 17 00:00:00 2001 From: Gabriel Ebner Date: Sat, 28 Feb 2026 02:10:17 +0000 Subject: [PATCH 11/18] Remove x and post_typing_src fields from post_hint_t These fields existed to document that post has a free de Bruijn variable for the result. Now that all typing tokens are unit, they served no purpose. Added a comment on the post field instead. Also removed the now-unnecessary post_hint_typing_t type and post_hint_typing function. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/checker/Pulse.Checker.Base.fst | 65 ++++---------------- src/checker/Pulse.Checker.Goto.fst | 1 - src/checker/Pulse.Checker.Return.fst | 1 - src/checker/Pulse.Checker.While.fst | 10 +-- src/checker/Pulse.Checker.WithLocal.fst | 7 +-- src/checker/Pulse.Checker.WithLocalArray.fst | 7 +-- src/checker/Pulse.JoinComp.fst | 8 +-- src/checker/Pulse.Typing.Combinators.fst | 1 - src/checker/Pulse.Typing.fst | 22 +------ 9 files changed, 25 insertions(+), 97 deletions(-) diff --git a/src/checker/Pulse.Checker.Base.fst b/src/checker/Pulse.Checker.Base.fst index 843870677..0a000f01c 100644 --- a/src/checker/Pulse.Checker.Base.fst +++ b/src/checker/Pulse.Checker.Base.fst @@ -127,7 +127,7 @@ let intro_post_hint g effect_annot ret_ty_opt post = effect_annot_typing = (); ret_ty; u; ty_typing=(); post=post'; - x; post_typing_src=() } + } let comp_typing_as_effect_annot_typing (#g:env) (#c:comp_st) (ct:comp_typing_u g c) : effect_annot_typing g (effect_annot_of_comp c) @@ -142,9 +142,7 @@ let post_hint_from_comp_typing #g #c ct = effect_annot_typing; ret_ty = comp_res c; u=comp_u c; ty_typing=(); - post=comp_post c; - x=admit(); - post_typing_src=() } + post=comp_post c } in p @@ -158,45 +156,21 @@ let comp_typing_from_post_hint = let x = fresh g in if x `Set.mem` freevars p.post //exclude this then fail g None "Impossible: unexpected freevar in post, please file a bug-report" - else let post_typing = post_hint_typing g p x in - intro_comp_typing g c pre_typing - post_typing.effect_annot_typing - post_typing.ty_typing - x post_typing.post_typing + else intro_comp_typing g c pre_typing + () + () + x () let extend_post_hint g p x tx conjunct conjunct_typing = let g' = push_binding g x ppname_default tx in let y = fresh g' in let g'' = push_binding g' y ppname_default p.ret_ty in - let p_post_typing_src - : tot_typing (push_binding p.g p.x ppname_default p.ret_ty) - (open_term p.post p.x) tm_slprop - = p.post_typing_src - in - let p_post_typing_src'' - : tot_typing g'' (open_term p.post y) tm_slprop - = () //weaken, rename - in - let conjunct_typing' - : tot_typing g' conjunct tm_slprop - = conjunct_typing - in - let conjunct_typing'' - : tot_typing g'' (open_term conjunct y) tm_slprop - = () //weaken - in let new_post = tm_star p.post conjunct in - let new_post_typing - : tot_typing g'' (open_term new_post y) tm_slprop - = Pulse.Typing.star_typing p_post_typing_src'' conjunct_typing'' - in assume (fresh_wrt y g'' (freevars new_post)); { p with g=g'; - post=new_post; - x=y; - post_typing_src=new_post_typing } + post=new_post } let k_elab_unit (g:env) (ctxt:term) : continuation_elaborator g ctxt g ctxt @@ -419,27 +393,12 @@ let st_comp_typing_with_post_hint : st_comp_typing g (st_comp_of_comp c) = let st = st_comp_of_comp c in let PostHint ph = post_hint in - let post_typing_src - : tot_typing (push_binding ph.g ph.x ppname_default ph.ret_ty) - (open_term ph.post ph.x) tm_slprop - = ph.post_typing_src - in let x = RU.magic () in //fresh g in assume (fresh_wrt x g (freevars ph.post)); - assume (None? (lookup g ph.x)); - let post_typing_src - : tot_typing (push_binding ph.g x ppname_default ph.ret_ty) - (open_term ph.post x) tm_slprop - = if x = Ghost.reveal ph.x - then post_typing_src - else - () - in let post_typing_src : tot_typing (push_binding g x ppname_default ph.ret_ty) (open_term ph.post x) tm_slprop - = //weakening: TODO - () + = () in let ty_typing : universe_of ph.g st.res st.u = ph.ty_typing in let ty_typing : universe_of g st.res st.u = () in @@ -511,15 +470,15 @@ let return_in_ctxt (g:env) (y:var) (y_ppname:ppname) (u:universe) (ty:term) (ctx | C_STAtomic _ obs st, EffectAnnotAtomic { opens } | C_STAtomic _ obs st, EffectAnnotAtomicOrGhost { opens } -> assert (comp_inames c == tm_emp_inames); - let pht = post_hint_typing g post_hint x in - let validity = emp_inames_included g opens pht.effect_annot_typing in + let pht = () in + let validity = emp_inames_included g opens pht in let c' = C_STAtomic opens obs st in (| t, c' |) | C_STGhost _ st, EffectAnnotGhost { opens } | C_STGhost _ st, EffectAnnotAtomicOrGhost { opens } -> assert (comp_inames c == tm_emp_inames); - let pht = post_hint_typing g post_hint x in - let validity = emp_inames_included g opens pht.effect_annot_typing in + let pht = () in + let validity = emp_inames_included g opens pht in let c' = C_STGhost opens st in (| t, c' |) | _ -> diff --git a/src/checker/Pulse.Checker.Goto.fst b/src/checker/Pulse.Checker.Goto.fst index 1da5ea177..d6ed283b4 100644 --- a/src/checker/Pulse.Checker.Goto.fst +++ b/src/checker/Pulse.Checker.Goto.fst @@ -51,7 +51,6 @@ let check' let t = wtag (Some (ctag_of_comp_st c')) (Tm_Goto { lbl = term_of_nvar (lbln, v); arg }) in let typing: st_typing g t c' = let x' = fresh g in assume fresh_wrt x' g (freevars ph.post); - let pht = post_hint_typing g ph x' in () in let c' = match_comp_res_with_post_hint t c' typing post_hint in prove_post_hint #g diff --git a/src/checker/Pulse.Checker.Return.fst b/src/checker/Pulse.Checker.Return.fst index 09bce0267..225148869 100644 --- a/src/checker/Pulse.Checker.Return.fst +++ b/src/checker/Pulse.Checker.Return.fst @@ -130,7 +130,6 @@ let check_core ("check_return: unexpected variable clash in return post,\ please file a bug report") else - let ty_rec = post_hint_typing g post x in open_term_nv post.post px | _ -> let t = check_tot_term (push_binding g x (fst px) ty) tm_emp tm_slprop in diff --git a/src/checker/Pulse.Checker.While.fst b/src/checker/Pulse.Checker.While.fst index 713749dbd..77a89b108 100644 --- a/src/checker/Pulse.Checker.While.fst +++ b/src/checker/Pulse.Checker.While.fst @@ -45,8 +45,7 @@ let inv_as_post_hint (#g:env) (#inv:slprop) (inv_typing:tot_typing g inv tm_slpr : T.Tac (ph:post_hint_for_env g { ph.post == inv /\ ph.ret_ty == tm_unit /\ ph.u == u0 /\ ph.effect_annot == EffectAnnotSTT }) = let x = inv_typing_weakening inv_typing in { g; effect_annot=EffectAnnotSTT; effect_annot_typing=(); - ret_ty=tm_unit; u=u0; ty_typing=unit_typing g; post=inv; - x; post_typing_src = () } + ret_ty=tm_unit; u=u0; ty_typing=unit_typing g; post=inv } let tm_l_true : term = FStar.Reflection.V2.Formula.(formula_as_term True_) let tm_l_or (a b: term) : term = FStar.Reflection.V2.Formula.(formula_as_term (Or a b)) @@ -243,9 +242,8 @@ let check_while let body_ph : post_hint_for_env g2 = inv_as_post_hint body_post_typing in assert body_ph.ret_ty == tm_unit; let x = fresh g2 in - assume (x == Ghost.reveal post_cond.x); let body_open_pre_typing : tot_typing (push_binding g2 x ppname_default tm_bool) (open_term body_pre_open x) tm_slprop = - () in // post_cond.post_typing_src + () in let body_pre_typing = body_typing_subst_true body_open_pre_typing in let r_body = check @@ -281,9 +279,7 @@ let check_while ret_ty=RT.unit_ty; u=u_zero; ty_typing=RU.magic(); //unit typing - post=break_pred; - x; - post_typing_src=RU.magic() //from inv typing and body_open_pre_typing + post=break_pred } in let res = prove_post_hint res (PostHint post_hint_for_while) t.range in diff --git a/src/checker/Pulse.Checker.WithLocal.fst b/src/checker/Pulse.Checker.WithLocal.fst index 8b94cf7b8..fcd27a426 100644 --- a/src/checker/Pulse.Checker.WithLocal.fst +++ b/src/checker/Pulse.Checker.WithLocal.fst @@ -146,11 +146,10 @@ let check assume (open_st_term (close_st_term opened_body x) x == opened_body); let c = C_ST {u=comp_u c_body;res=comp_res c_body;pre;post=post.post} in let c_typing = - let post_typing_rec :post_hint_typing_t g post x = post_hint_typing g post x in intro_comp_typing g c pre_typing - post_typing_rec.effect_annot_typing - post_typing_rec.ty_typing - x post_typing_rec.post_typing + () + () + x () in assert (freshv g x); assert (~(Set.mem x (freevars_st body))); diff --git a/src/checker/Pulse.Checker.WithLocalArray.fst b/src/checker/Pulse.Checker.WithLocalArray.fst index d85430911..f86833e05 100644 --- a/src/checker/Pulse.Checker.WithLocalArray.fst +++ b/src/checker/Pulse.Checker.WithLocalArray.fst @@ -172,11 +172,10 @@ let check assume (open_st_term (close_st_term opened_body x) x == opened_body); let c = C_ST {u=comp_u c_body;res=comp_res c_body;pre;post=post.post} in let c_typing = - let post_typing_rec = post_hint_typing g post x in intro_comp_typing g c pre_typing - post_typing_rec.effect_annot_typing - post_typing_rec.ty_typing - x post_typing_rec.post_typing + () + () + x () in let st = wrst c (Tm_WithLocalArray { binder = mk_binder_ppname (mk_array init_t) binder.binder_ppname; initializer=init; length=len; body }) in checker_result_for_st_typing (| st, c |) res_ppname diff --git a/src/checker/Pulse.JoinComp.fst b/src/checker/Pulse.JoinComp.fst index 6cfd2018f..fb449ddcf 100644 --- a/src/checker/Pulse.JoinComp.fst +++ b/src/checker/Pulse.JoinComp.fst @@ -126,13 +126,11 @@ let infer_post' (g:env) (g':env { g' `env_extends` g }) let x = fresh g in let post' = open_term_nv post (ppname_default, x) in let g' = push_binding g x ppname_default t in - // we just constructed it; should ideally prove it well-typed rather then re-checking it - let post_typing_src : tot_typing g' post' tm_slprop = () in assume (fresh_wrt x g (freevars post)); { g; effect_annot=EffectAnnotSTT; effect_annot_typing=(); ret_ty=t; u; ty_typing=(); - post; x; post_typing_src + post } in let post = RU.beta_lax (elab_env g) post in // clean up spurious dependencies on variables @@ -367,8 +365,8 @@ let join_post #g #hyp #b let eff = join_effect_annot g p1.effect_annot p2.effect_annot in let res : post_hint_for_env g = {g; effect_annot=eff; effect_annot_typing=(); - ret_ty=p1.ret_ty; u=u; ty_typing=(); x; - post=joined_post; post_typing_src=()} + ret_ty=p1.ret_ty; u=u; ty_typing=(); + post=joined_post} in res diff --git a/src/checker/Pulse.Typing.Combinators.fst b/src/checker/Pulse.Typing.Combinators.fst index c17a2b5e8..f93b55ab1 100644 --- a/src/checker/Pulse.Typing.Combinators.fst +++ b/src/checker/Pulse.Typing.Combinators.fst @@ -349,7 +349,6 @@ let bind_res_and_post_typing g c2 x post_hint ) | PostHint post -> CU.debug g "pulse.main" (fun _ -> "bind_res_and_post_typing (with post_hint)\n"); - let pr = post_hint_typing g post x in () let add_frame (g:env) (t:st_term) (c:comp_st) (t_typing:st_typing g t c) diff --git a/src/checker/Pulse.Typing.fst b/src/checker/Pulse.Typing.fst index dba87a094..b2cdd38e6 100644 --- a/src/checker/Pulse.Typing.fst +++ b/src/checker/Pulse.Typing.fst @@ -652,9 +652,7 @@ type post_hint_t = { ret_ty:term; u:universe; ty_typing:universe_of g ret_ty u; - post:term; - x:(x:FStar.Ghost.erased var { fresh_wrt x g (freevars post) }); - post_typing_src:tot_typing (push_binding g x ppname_default ret_ty) (open_term post x) tm_slprop; + post:term; // post has a free de Bruijn variable 0 for the result of type ret_ty } let post_hint_for_env_p (g:env) (p:post_hint_t) = g `env_extends` p.g @@ -675,24 +673,6 @@ type post_hint_opt_t = let post_hint_opt (g:env) = p:post_hint_opt_t { PostHint? p ==> post_hint_for_env_p g (PostHint?.v p) } -noeq -type post_hint_typing_t (g:env) (p:post_hint_t) (x:var { ~ (Set.mem x (dom g)) }) = { - effect_annot_typing:effect_annot_typing g p.effect_annot; - ty_typing:universe_of g p.ret_ty p.u; - post_typing:tot_typing (push_binding g x ppname_default p.ret_ty) (open_term p.post x) tm_slprop -} - -irreducible -let post_hint_typing (g:env) - (p:post_hint_for_env g) - (x:var { fresh_wrt x g (freevars p.post) }) - : post_hint_typing_t g p x - = { - effect_annot_typing = (); - ty_typing = (); - post_typing = (); - } - let effect_annot_matches (c:comp_st) (effect_annot:effect_annot) : prop = match c, effect_annot with From c150ac84e19e29a1d0e9fe8f8bd530e21d25406d Mon Sep 17 00:00:00 2001 From: Gabriel Ebner Date: Sat, 28 Feb 2026 06:52:54 +0000 Subject: [PATCH 12/18] Remove unit-typed typing token definitions entirely Remove all 17 type definitions that were previously simplified to unit aliases (tot_typing, st_typing, comp_typing, slprop_equiv, universe_of, st_equiv, st_sub, lift_comp, st_comp_typing, bind_comp, non_informative, pats_complete, brs_typing, br_typing, effect_annot_typing, typing, ghost_typing) from Pulse.Typing.fst. Replace all uses across 54 files with 'unit'. Where implicit arguments were previously inferred from typing token parameters, make them explicit. Remove helper functions that only constructed unit values (star_typing*, emp_typing, etc.). Remove effect_annot_typing and ty_typing fields from post_hint_t record. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/checker/Pulse.Checker.Abs.fst | 21 +- src/checker/Pulse.Checker.Admit.fst | 6 +- src/checker/Pulse.Checker.Admit.fsti | 2 +- .../Pulse.Checker.AssertWithBinders.fst | 26 +- .../Pulse.Checker.AssertWithBinders.fsti | 2 +- src/checker/Pulse.Checker.Base.fst | 154 ++++++----- src/checker/Pulse.Checker.Base.fsti | 66 ++--- src/checker/Pulse.Checker.Bind.fst | 8 +- src/checker/Pulse.Checker.Bind.fsti | 4 +- src/checker/Pulse.Checker.Comp.fst | 6 +- src/checker/Pulse.Checker.Comp.fsti | 4 +- src/checker/Pulse.Checker.Exists.fst | 14 +- src/checker/Pulse.Checker.Exists.fsti | 6 +- .../Pulse.Checker.ForwardJumpLabel.fst | 6 +- .../Pulse.Checker.ForwardJumpLabel.fsti | 2 +- src/checker/Pulse.Checker.Goto.fst | 6 +- src/checker/Pulse.Checker.Goto.fsti | 2 +- src/checker/Pulse.Checker.If.fst | 8 +- src/checker/Pulse.Checker.If.fsti | 2 +- src/checker/Pulse.Checker.IntroPure.fst | 6 +- src/checker/Pulse.Checker.IntroPure.fsti | 2 +- src/checker/Pulse.Checker.Match.fst | 17 +- src/checker/Pulse.Checker.Match.fsti | 2 +- .../Pulse.Checker.Prover.Normalize.fst | 6 +- .../Pulse.Checker.Prover.Normalize.fsti | 2 +- src/checker/Pulse.Checker.Prover.fst | 248 ++++++++---------- src/checker/Pulse.Checker.Prover.fsti | 6 +- src/checker/Pulse.Checker.Pure.fst | 8 +- src/checker/Pulse.Checker.Return.fst | 10 +- src/checker/Pulse.Checker.Return.fsti | 2 +- src/checker/Pulse.Checker.Rewrite.fst | 10 +- src/checker/Pulse.Checker.Rewrite.fsti | 2 +- src/checker/Pulse.Checker.SLPropEquiv.fst | 78 +++--- src/checker/Pulse.Checker.SLPropEquiv.fsti | 50 ++-- src/checker/Pulse.Checker.ST.fst | 8 +- src/checker/Pulse.Checker.ST.fsti | 2 +- src/checker/Pulse.Checker.While.fst | 54 ++-- src/checker/Pulse.Checker.While.fsti | 2 +- src/checker/Pulse.Checker.WithLocal.fst | 10 +- src/checker/Pulse.Checker.WithLocal.fsti | 2 +- src/checker/Pulse.Checker.WithLocalArray.fst | 15 +- src/checker/Pulse.Checker.WithLocalArray.fsti | 2 +- src/checker/Pulse.Checker.fst | 4 +- src/checker/Pulse.Elaborate.Core.fst | 40 +-- src/checker/Pulse.JoinComp.fst | 30 +-- src/checker/Pulse.JoinComp.fsti | 14 +- src/checker/Pulse.Main.fst | 4 +- src/checker/Pulse.Typing.Combinators.fst | 76 +++--- src/checker/Pulse.Typing.Combinators.fsti | 36 ++- src/checker/Pulse.Typing.FV.fst | 34 +-- src/checker/Pulse.Typing.FV.fsti | 16 +- src/checker/Pulse.Typing.LN.fst | 26 +- src/checker/Pulse.Typing.LN.fsti | 12 +- src/checker/Pulse.Typing.fst | 85 +----- 54 files changed, 561 insertions(+), 705 deletions(-) diff --git a/src/checker/Pulse.Checker.Abs.fst b/src/checker/Pulse.Checker.Abs.fst index 2c52d4866..a377ea61f 100644 --- a/src/checker/Pulse.Checker.Abs.fst +++ b/src/checker/Pulse.Checker.Abs.fst @@ -372,7 +372,7 @@ let check_effect_annotation g r (asc:comp_ascription) (c_computed:comp) : T.Tac let Some tok = tok in - let d_sub : st_sub g c_computed c = + let d_sub : unit = match c_computed with | C_STAtomic _ obs _ -> () | C_STGhost _ _ -> () @@ -393,8 +393,8 @@ let check_effect_annotation g r (asc:comp_ascription) (c_computed:comp) : T.Tac (* Rewrite the comp c into the annotated one, if any, preserving the st_typing derivation d *) let maybe_rewrite_body_typing - (#g:_) (#e:st_term) (#c:comp) - (d:st_typing g e c) + (g:_) (e:st_term) (c:comp) + (d:unit) (asc:comp_ascription) : T.Tac comp = let open Pulse.PP in @@ -416,11 +416,11 @@ let maybe_rewrite_body_typing (show c) (show (C_Tot t))); let sq : squash (RT.equiv_token (elab_env g) t t') = () in - let t'_typing : universe_of g t' u = + let t'_typing : unit = (* t is equiv to t', and t has universe t. *) magic () in - let tok' : st_equiv g (C_Tot t') (C_Tot t) = + let tok' : unit = () in C_Tot t @@ -482,11 +482,10 @@ let rec check_abs_core (* Check if it matches annotation (if any, likely not), and adjust derivation if needed. Currently this only subtypes the invariants. *) let c_body = check_effect_annotation g' body.range asc c_body in - let body_typing : st_typing g' body c_body = () in - let c_body = maybe_rewrite_body_typing body_typing asc in + let body_typing : unit = () in + let c_body = maybe_rewrite_body_typing g' body c_body body_typing asc in - FV.st_typing_freevars g' body c_body body_typing; - let body_closed = close_st_term body x in + FV.st_typing_freevars g' body c_body body_typing; let body_closed = close_st_term body x in assume (open_st_term body_closed x == body); // instantiate implicits in the attributes @@ -588,9 +587,9 @@ let rec check_abs_core in let c_body = check_effect_annotation g' body.range c_opened c_body in - let body_typing : st_typing g' body c_body = () in + let body_typing : unit = () in - let c_body = maybe_rewrite_body_typing body_typing asc in + let c_body = maybe_rewrite_body_typing g' body c_body body_typing asc in FV.st_typing_freevars g' body c_body body_typing; let body_closed = close_st_term body x in diff --git a/src/checker/Pulse.Checker.Admit.fst b/src/checker/Pulse.Checker.Admit.fst index 069eb8025..051d73938 100644 --- a/src/checker/Pulse.Checker.Admit.fst +++ b/src/checker/Pulse.Checker.Admit.fst @@ -29,7 +29,7 @@ module P = Pulse.Syntax.Printer let check (g:env) (pre:term) - (pre_typing:tot_typing g pre tm_slprop) + (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_Admit? t.term }) @@ -65,7 +65,7 @@ let check let post = close_term post_opened x in let s : st_comp = {u;res=t;pre;post} in assume (open_term (close_term post_opened x) x == post_opened); - let d_s : st_comp_typing g s = () in + let d_s : unit = () in (match c with | STT -> C_ST s | STT_Ghost -> C_STGhost tm_emp_inames s @@ -79,7 +79,7 @@ let check u=comp_u c; typ=comp_res c; post=None }) in - let d : st_typing g admit_st c = () in + let d : unit = () in FStar.Tactics.BreakVC.break_vc (); // ^ This makes a big difference! Would be good to distill into // a smaller F*-only example and file an issue. diff --git a/src/checker/Pulse.Checker.Admit.fsti b/src/checker/Pulse.Checker.Admit.fsti index 4b5f85533..591b82698 100644 --- a/src/checker/Pulse.Checker.Admit.fsti +++ b/src/checker/Pulse.Checker.Admit.fsti @@ -25,7 +25,7 @@ open Pulse.Checker.Base val check (g:env) (pre:term) - (pre_typing:tot_typing g pre tm_slprop) + (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_Admit? t.term }) diff --git a/src/checker/Pulse.Checker.AssertWithBinders.fst b/src/checker/Pulse.Checker.AssertWithBinders.fst index 8fb6cdec2..ed47d93f0 100644 --- a/src/checker/Pulse.Checker.AssertWithBinders.fst +++ b/src/checker/Pulse.Checker.AssertWithBinders.fst @@ -318,7 +318,7 @@ let rec check_pairs (g:env) rng (ps: list (term & term)) (tac_opt:option term) : let check_renaming (g:env) (pre:term) - (pre_typing:tot_typing g pre tm_slprop) + (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (st:st_term { @@ -352,8 +352,8 @@ let check_renaming // if there is no goal, take the goal to be the full current pre let rhs, pairs = rewrite_all st.range (T.unseal st.source) g pairs pre pre elaborated tac_opt false in check_pairs g st.range pairs tac_opt; - let h2: slprop_equiv g rhs pre = () in - let h1: tot_typing g rhs tm_slprop = () in + let h2: unit = () in + let h1: unit = () in let (| x, g', ty, ctxt', k |) = check g rhs h1 post_hint res_ppname body in (| x, g', ty, ctxt', k_elab_equiv pre ctxt' k h2 () |) @@ -369,7 +369,7 @@ let check_renaming #restart-solver #push-options "--z3rlimit_factor 2 --fuel 0 --ifuel 1" let rec peel_binders k (ex: slprop) pre r - (g:env) frame (bs: list binder) (t:term) (t_typ: tot_typing g t tm_slprop) : + (g:env) frame (bs: list binder) (t:term) (t_typ: unit) : T.Tac (g':env {env_extends g' g} & t': slprop & xs: list (universe & typ & nvar) & continuation_elaborator g (frame `tm_star` t) @@ -383,7 +383,7 @@ let rec peel_binders k (ex: slprop) pre r let ty = mk_erased u b.binder_ty in let g' = push_binding g (snd x) (fst x) ty in let t' = open_term' body (mk_reveal u b.binder_ty (term_of_nvar x)) 0 in - let t'_typ : tot_typing g' t' tm_slprop = () in + let t'_typ : unit = () in let (|g'', t'', bs', k'|) = peel_binders k ex pre r g' frame bs t' t'_typ in (| g'', t'', (u,b.binder_ty,x)::bs', k_elab_trans (Pulse.Checker.Prover.elim_exists g frame u b body x g') k' |) | _ -> @@ -403,7 +403,7 @@ let open_st_term_with_reveals (t: st_term) (xs: list (universe & typ & nvar)) : let check_wild (g:env) (pre:term) - (pre_typing:tot_typing g pre tm_slprop) + (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (st:st_term { head_wild st }) @@ -433,10 +433,10 @@ let check_wild | [ex] -> let k = List.Tot.length bs in let frame = list_as_slprop rest in - let ex_typ : tot_typing g ex tm_slprop = () in + let ex_typ : unit = () in let (|g', ex', bs, k|) = peel_binders k ex pre st.range g frame bs ex ex_typ in let body = open_st_term_with_reveals body bs in - let pre_typ : tot_typing g' (tm_star frame ex') tm_slprop = () in + let pre_typ : unit = () in let (| x'', g'', t'', ctxt'', k' |) = check g' (frame `tm_star` ex') pre_typ post_hint res_ppname body in assume pre == (frame `tm_star` ex); @@ -462,7 +462,7 @@ let rec add_rem_uvs (g:env) (t:typ) (v:term) let check (g:env) (pre:term) - (pre_typing:tot_typing g pre tm_slprop) + (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (st:st_term { Tm_ProofHintWithBinders? st.term }) @@ -518,8 +518,8 @@ let check assume (v == v'); //sorry---ideally, we would retype everything proving that it is stable after normalization let v = v' in let body = body in // TODO compress - let h: tot_typing g1 v tm_slprop = PC.core_check_term g1 v T.E_Total tm_slprop in - let h: tot_typing g1 (tm_star v pre') tm_slprop = () in // TODO: propagate through prover + let h: unit = PC.core_check_term g1 v T.E_Total tm_slprop in + let h: unit = () in // TODO: propagate through prover let (| x, x_ty, pre'', g2, k |) = check g1 (tm_star v pre') h post_hint res_ppname body in (| x, x_ty, pre'', g2, k_elab_trans k_frame k |) @@ -555,8 +555,8 @@ let check let _ = PC.check_slprop_with_core g v' in - let h1: tot_typing g' (tm_star pre_remaining rhs') tm_slprop = () in - let h2: slprop_equiv g' (tm_star pre_remaining rhs') (tm_star lhs pre_remaining) = () in + let h1: unit = () in + let h2: unit = () in let (| x, g'', ty, ctxt', k' |) = check g' (tm_star pre_remaining rhs') h1 post_hint res_ppname body in diff --git a/src/checker/Pulse.Checker.AssertWithBinders.fsti b/src/checker/Pulse.Checker.AssertWithBinders.fsti index 5e9c0de10..db335ddd6 100644 --- a/src/checker/Pulse.Checker.AssertWithBinders.fsti +++ b/src/checker/Pulse.Checker.AssertWithBinders.fsti @@ -30,7 +30,7 @@ let head_wild (st:st_term) = val check (g:env) (pre:term) - (pre_typing:tot_typing g pre tm_slprop) + (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (st:st_term { Tm_ProofHintWithBinders? st.term }) diff --git a/src/checker/Pulse.Checker.Base.fst b/src/checker/Pulse.Checker.Base.fst index 0a000f01c..63a97f183 100644 --- a/src/checker/Pulse.Checker.Base.fst +++ b/src/checker/Pulse.Checker.Base.fst @@ -54,18 +54,18 @@ let mk_abs ty t = RT.(mk_abs ty T.Q_Explicit t) let intro_comp_typing (g:env) (c:comp_st) - (pre_typing:tot_typing g (comp_pre c) tm_slprop) - (i_typing:effect_annot_typing g (effect_annot_of_comp c)) - (res_typing:universe_of g (comp_res c) (comp_u c)) + (pre_typing:unit) + (i_typing:unit) + (res_typing:unit) (x:var { fresh_wrt x g (freevars (comp_post c)) }) - (post_typing:tot_typing (push_binding g x ppname_default (comp_res c)) (open_term (comp_post c) x) tm_slprop) - : T.Tac (comp_typing g c (universe_of_comp c)) + (post_typing:unit) + : T.Tac unit = () irreducible let post_typing_as_abstraction (g:env) (x:var) (ty:term) (t:term { fresh_wrt x g (freevars t) }) - (_:tot_typing (push_binding g x ppname_default ty) (open_term t x) tm_slprop) + (_:unit) : FStar.Ghost.erased (RT.tot_typing (elab_env g) (mk_abs ty t) (mk_arrow ty tm_slprop)) = admit() @@ -80,8 +80,8 @@ let fstar_equiv_preserves_typing let equiv_preserves_typing (g:env) (t1 : term) (typ : term) (t2 : term) (eq : squash (T.equiv_token (elab_env g) t1 t2)) - (t1_typing : typing g t1 T.E_Total typ) - : typing g t2 T.E_Total typ + (t1_typing : unit) + : unit = () let check_effect_annot (g:env) (e:effect_annot) @@ -124,24 +124,20 @@ let intro_post_hint g effect_annot ret_ty_opt post = assume (open_term post' x == post); { g; effect_annot; - effect_annot_typing = (); - ret_ty; u; ty_typing=(); + ret_ty; u; post=post'; } -let comp_typing_as_effect_annot_typing (#g:env) (#c:comp_st) (ct:comp_typing_u g c) -: effect_annot_typing g (effect_annot_of_comp c) +let comp_typing_as_effect_annot_typing (g:env) (c:comp_st) (ct:unit) +: unit = () -let post_hint_from_comp_typing #g #c ct = - let effect_annot_typing = comp_typing_as_effect_annot_typing ct in +let post_hint_from_comp_typing g c ct = let p : post_hint_t = { g; - effect_annot=_; - effect_annot_typing; + effect_annot = effect_annot_of_comp c; ret_ty = comp_res c; u=comp_u c; - ty_typing=(); post=comp_post c } in p @@ -150,9 +146,9 @@ let post_hint_from_comp_typing #g #c ct = let comp_typing_from_post_hint (#g: env) (c: comp_st) - (pre_typing: tot_typing g (comp_pre c) tm_slprop) + (pre_typing: unit) (p:post_hint_for_env g { comp_post_matches_hint c (PostHint p) }) -: T.Tac (comp_typing_u g c) +: T.Tac unit = let x = fresh g in if x `Set.mem` freevars p.post //exclude this then fail g None "Impossible: unexpected freevar in post, please file a bug-report" @@ -190,26 +186,24 @@ let comp_st_with_post (c:comp_st) (post:term) | C_STGhost i st -> C_STGhost i { st with post } | C_STAtomic i obs st -> C_STAtomic i obs {st with post} -let ve_unit_r g (p:term) : slprop_equiv g (tm_star p tm_emp) p = +let ve_unit_r g (p:term) : unit = () -let st_equiv_post (#g:env) (#t:st_term) (#c:comp_st) (d:st_typing g t c) +let st_equiv_post (#g:env) (t:st_term) (c:comp_st) (d:unit) (post:term { freevars post `Set.subset` freevars (comp_post c)}) (veq: (x:var { fresh_wrt x g (freevars (comp_post c)) } -> - slprop_equiv (push_binding g x ppname_default (comp_res c)) - (open_term (comp_post c) x) - (open_term post x))) - : Dv (st_typing g t (comp_st_with_post c post)) + unit)) + : Dv unit = if eq_tm post (comp_post c) then d else let c' = comp_st_with_post c post in - let st_equiv : st_equiv g c c' = () in + let st_equiv : unit = () in Pulse.Typing.Combinators.t_equiv g t c d c' st_equiv -let simplify_post (#g:env) (#t:st_term) (#c:comp_st) (d:st_typing g t c) +let simplify_post (g:env) (t:st_term) (c:comp_st) (d:unit) (post:term { comp_post c == tm_star post tm_emp}) - : Dv (st_typing g t (comp_st_with_post c post)) - = st_equiv_post d post (fun x -> ve_unit_r (push_binding g x ppname_default (comp_res c)) (open_term post x)) + : Dv unit + = st_equiv_post #g t c d post (fun x -> ve_unit_r (push_binding g x ppname_default (comp_res c)) (open_term post x)) let simplify_lemma (c:comp_st) (c':comp_st) (post_hint:post_hint_opt_t) : Lemma @@ -223,9 +217,9 @@ let simplify_lemma (c:comp_st) (c':comp_st) (post_hint:post_hint_opt_t) comp_pre (comp_st_with_post c' (comp_post c)) == comp_pre c') = () -let slprop_equiv_typing_bk (#g:env) (#ctxt:_) (ctxt_typing:tot_typing g ctxt tm_slprop) - (p:_) (d:slprop_equiv g p ctxt) - : tot_typing g p tm_slprop +let slprop_equiv_typing_bk (#g:env) (#ctxt:_) (ctxt_typing:unit) + (p:_) (d:unit) + : unit = let _, bk = slprop_equiv_typing g p ctxt d in bk ctxt_typing @@ -236,35 +230,35 @@ let comp_with_pre (c:comp_st) (pre:term) = | C_STAtomic i obs st -> C_STAtomic i obs {st with pre} #push-options "--fuel 0 --ifuel 0" -let st_equiv_pre (#g:env) (#t:st_term) (#c:comp_st) (d:st_typing g t c) +let st_equiv_pre (#g:env) (t:st_term) (c:comp_st) (d:unit) (pre:term) - (veq: slprop_equiv g (comp_pre c) pre) - : Dv (st_typing g t (comp_with_pre c pre)) + (veq: unit) + : Dv unit = if eq_tm pre (comp_pre c) then d else let c' = comp_with_pre c pre in - let st_equiv : st_equiv g c c' = () in + let st_equiv : unit = () in Pulse.Typing.Combinators.t_equiv g t c d c' st_equiv let k_elab_equiv_continuation (#g1:env) (#g2:env { g2 `env_extends` g1 }) (#ctxt #ctxt1:term) (ctxt2:term) (k:continuation_elaborator g1 ctxt g2 ctxt1) - (d:slprop_equiv g2 ctxt1 ctxt2) + (d:unit) : continuation_elaborator g1 ctxt g2 ctxt2 = fun post_hint res -> let (| st, c |) = res in assert (comp_pre c == ctxt2); k post_hint (| st, comp_with_pre c ctxt1 |) -let slprop_equiv_typing_fwd (#g:env) (#ctxt:_) (ctxt_typing:tot_typing g ctxt tm_slprop) - (p:_) (d:slprop_equiv g ctxt p) - : tot_typing g p tm_slprop +let slprop_equiv_typing_fwd (#g:env) (#ctxt:_) (ctxt_typing:unit) + (p:_) (d:unit) + : unit = let fwd, _ = slprop_equiv_typing g ctxt p d in fwd ctxt_typing let k_elab_equiv_prefix (#g1:env) (#g2:env { g2 `env_extends` g1 }) (#ctxt1 #ctxt:term) (ctxt2:term) (k:continuation_elaborator g1 ctxt1 g2 ctxt) - (d:slprop_equiv g1 ctxt1 ctxt2) + (d:unit) : continuation_elaborator g1 ctxt2 g2 ctxt = fun post_hint res -> let framing_token : frame_for_req_in_ctxt g1 ctxt2 ctxt1 = @@ -278,8 +272,8 @@ let k_elab_equiv_prefix let k_elab_equiv (#g1:env) (#g2:env { g2 `env_extends` g1 }) (#ctxt1 #ctxt2:term) (ctxt1' ctxt2':term) (k:continuation_elaborator g1 ctxt1 g2 ctxt2) - (d1:slprop_equiv g1 ctxt1 ctxt1') - (d2:slprop_equiv g2 ctxt2 ctxt2') + (d1:unit) + (d2:unit) : continuation_elaborator g1 ctxt1' g2 ctxt2' = let k : continuation_elaborator g1 ctxt1 g2 ctxt2' = @@ -293,8 +287,8 @@ open Pulse.PP let continuation_elaborator_with_bind' (#g:env) (ctxt:term) (c1:comp{stateful_comp c1}) (e1:st_term) - (e1_typing:st_typing g e1 c1) - (ctxt_pre1_typing:tot_typing g (tm_star ctxt (comp_pre c1)) tm_slprop) + (e1_typing:unit) + (ctxt_pre1_typing:unit) (x:nvar {freshv g (snd x)}) : T.Tac (continuation_elaborator g @@ -305,7 +299,7 @@ let continuation_elaborator_with_bind' (#g:env) (ctxt:term) let pre1 = comp_pre c1 in let res1 = comp_res c1 in let post1 = comp_post c1 in - let ctxt_typing = star_typing_inversion_l ctxt_pre1_typing in + let ctxt_typing = () in let v_eq = () in let framing_token : frame_for_req_in_ctxt g (tm_star ctxt pre1) pre1 = ctxt @@ -369,8 +363,8 @@ let continuation_elaborator_with_bind' (#g:env) (ctxt:term) let continuation_elaborator_with_bind (#g:env) (ctxt:term) (c1:comp{stateful_comp c1}) (e1:st_term) - (e1_typing:st_typing g e1 c1) - (ctxt_pre1_typing:tot_typing g (tm_star ctxt (comp_pre c1)) tm_slprop) + (e1_typing:unit) + (ctxt_pre1_typing:unit) (x:nvar { freshv g (snd x) }) : T.Tac (continuation_elaborator g @@ -387,32 +381,30 @@ let coerce_eq (#a #b:Type) (x:a) (_:squash (a == b)) : y:b{y == x} = x let st_comp_typing_with_post_hint (#g:env) (#ctxt:_) - (ctxt_typing:tot_typing g ctxt tm_slprop) + (ctxt_typing:unit) (post_hint:post_hint_opt g { PostHint? post_hint }) (c:comp_st { comp_pre c == ctxt /\ comp_post_matches_hint c post_hint }) -: st_comp_typing g (st_comp_of_comp c) +: unit = let st = st_comp_of_comp c in let PostHint ph = post_hint in let x = RU.magic () in //fresh g in assume (fresh_wrt x g (freevars ph.post)); let post_typing_src - : tot_typing (push_binding g x ppname_default ph.ret_ty) - (open_term ph.post x) tm_slprop + : unit = () in - let ty_typing : universe_of ph.g st.res st.u = ph.ty_typing in - let ty_typing : universe_of g st.res st.u = () in + let ty_typing : unit = () in assert (st.res == ph.ret_ty); assert (st.post == ph.post); () #pop-options let continuation_elaborator_with_bind_fn (#g:env) (ctxt:term) - (ctxt_typing:tot_typing g ctxt tm_slprop) + (ctxt_typing:unit) (e1:st_term) (c1:comp { C_Tot? c1 }) (b:binder{b.binder_ty == comp_res c1}) - (e1_typing:st_typing g e1 c1) + (e1_typing:unit) (x:nvar { freshv g (snd x) }) : T.Tac (continuation_elaborator g ctxt @@ -426,11 +418,11 @@ let continuation_elaborator_with_bind_fn (#g:env) (ctxt:term) assume (open_st_term (close_st_term e2 x) x == e2); let e = wrst c2 (Tm_Bind {binder=b; head=e1; body=e2_closed}) in let u : Ghost.erased universe = RU.magic () in - let c2_typing : comp_typing g c2 (universe_of_comp c2) = () in + let c2_typing : unit = () in (| e, c2 |) let rec check_equiv_emp (g:env) (vp:term) - : option (slprop_equiv g vp tm_emp) + : option unit = match inspect_term vp with | Tm_Emp -> Some () | Tm_Star vp1 vp2 -> @@ -440,13 +432,13 @@ let rec check_equiv_emp (g:env) (vp:term) | _, _ -> None) | _ -> None -let emp_inames_included (g:env) (i:term) (_:tot_typing g i tm_inames) +let emp_inames_included (g:env) (i:term) (_:unit) : prop_validity g (tm_inames_subset tm_emp_inames i) = RU.magic() #push-options "--ifuel 1" let return_in_ctxt (g:env) (y:var) (y_ppname:ppname) (u:universe) (ty:term) (ctxt:slprop) - (ty_typing:universe_of g ty u) + (ty_typing:unit) (post_hint0:post_hint_opt g { PostHint? post_hint0 /\ checker_res_matches_post_hint g post_hint0 y ty ctxt}) : Div (st_typing_in_ctxt g ctxt post_hint0) (requires lookup g y == Some ty) @@ -464,7 +456,7 @@ let return_in_ctxt (g:env) (y:var) (y_ppname:ppname) (u:universe) (ty:term) (ctx let y_tm = tm_var {nm_index=y;nm_ppname=y_ppname} in let t = wtag (Some ctag) (Tm_Return {expected_type=tm_unknown;insert_eq=false;term=y_tm}) in let c = comp_return ctag false u ty y_tm post_hint.post x in - let d : st_typing g t c = () in + let d : unit = () in assume (comp_u c == post_hint.u); // this u should follow from equality of t match c, post_hint.effect_annot with | C_STAtomic _ obs st, EffectAnnotAtomic { opens } @@ -487,7 +479,7 @@ let return_in_ctxt (g:env) (y:var) (y_ppname:ppname) (u:universe) (ty:term) (ctx #push-options "--z3rlimit_factor 4 --ifuel 1 --split_queries always" #restart-solver let match_comp_res_with_post_hint (#g:env) (t:st_term) (c:comp_st) - (d:st_typing g t c) + (d:unit) (post_hint:post_hint_opt g) : T.Tac (c':comp_st { comp_pre c' == comp_pre c }) = @@ -511,7 +503,7 @@ let match_comp_res_with_post_hint (#g:env) (t:st_term) (c:comp_st) RT.Rel_eq_token _ _ _ (FStar.Squash.return_squash tok) in let c' = with_st_comp c {(st_comp_of_comp c) with res = ret_ty } in - let d_stequiv : st_equiv g c c' = () in + let d_stequiv : unit = () in c' #pop-options @@ -573,7 +565,7 @@ let checker_result_for_st_typing (#g:env) (#ctxt:slprop) (#post_hint:post_hint_o | _ -> () in assert (g' `env_extends` g); - let u_of_1_g' : universe_of g' (comp_res c1) (comp_u c1) = () in + let u_of_1_g' : unit = () in assert (~ (x `Set.mem` freevars (comp_post c1))); (| x, g', (comp_u c1, comp_res c1), ctxt', k |) #pop-options @@ -648,7 +640,7 @@ let rec is_stateful_arrow (g:env) (c:option comp) (args:list T.argv) (out:list T let checker_result_t_equiv_ctxt (g:env) (ctxt ctxt' : slprop) (post_hint:post_hint_opt g) - (equiv : slprop_equiv g ctxt ctxt') + (equiv : unit) (r : checker_result_t g ctxt post_hint) : checker_result_t g ctxt' post_hint = let (| x, g1, t, ctxt_r, k |) = r in @@ -675,18 +667,18 @@ let is_stateful_application (g:env) (e:term) | _ -> None let apply_conversion - (#g:env) (#e:term) (#eff:_) (#t0:term) - (d:typing g e eff t0) + (#g:env) (#e:term) (#eff:FStar.Tactics.V2.tot_or_ghost) (#t0:term) + (d:unit) (#t1:term) (eq:Ghost.erased (RT.related (elab_env g) t0 RT.R_Eq t1)) - : typing g e eff t1 + : unit = () let norm_typing - (g:env) (e:term) (eff:_) (t0:term) - (d:typing g e eff t0) + (g:env) (e:term) (eff:FStar.Tactics.V2.tot_or_ghost) (t0:term) + (d:unit) (steps:list norm_step) - : T.Tac (t':term & typing g e eff t') + : T.Tac (t':term & unit) = let (| t', _, _ |) = CP.norm_well_typed_term_alt #(elab_env g) #e #eff #t0 (magic()) steps in @@ -694,13 +686,13 @@ let norm_typing module TermEq = FStar.Reflection.TermEq let norm_typing_inverse - (g:env) (e:term) (eff:_) (t0:term) - (d:typing g e eff t0) + (g:env) (e:term) (eff:FStar.Tactics.V2.tot_or_ghost) (t0:term) + (d:unit) (t1:term) - (#u:_) - (d1:tot_typing g t1 (tm_type u)) + (u:universe) + (d1:unit) (steps:list norm_step) - : T.Tac (option (typing g e eff t1)) + : T.Tac (option unit) = let (| t1', t1'_typing, related_t1_t1' |) = CP.norm_well_typed_term_alt #(elab_env g) #t1 #T.E_Total #(R.pack_ln (R.Tv_Type u)) (Ghost.hide (magic())) steps in @@ -711,12 +703,12 @@ let norm_typing_inverse let norm_st_typing_inverse (g:env) (e:st_term) (t0:term) - (d:st_typing g e (C_Tot t0)) - (#u:_) + (d:unit) + (u:universe) (t1:term) - (d1:tot_typing g t1 (tm_type u)) + (d1:unit) (steps:list norm_step) - : T.Tac (option (st_typing g e (C_Tot t1))) + : T.Tac (option unit) = let d1 : Ghost.erased (RT.tot_typing (elab_env g) t1 (RT.tm_type u)) = Ghost.hide (magic()) @@ -734,7 +726,7 @@ let norm_st_typing_inverse : Ghost.erased (RT.equiv (elab_env g) t0 t1) = Ghost.hide (RT.Rel_sym _ _ _ related_t1_t1') in - let steq : st_equiv g (C_Tot t0) (C_Tot t1) = () in + let steq : unit = () in Some (Pulse.Typing.Combinators.t_equiv g e (C_Tot t0) d (C_Tot t1) steq) ) else None diff --git a/src/checker/Pulse.Checker.Base.fsti b/src/checker/Pulse.Checker.Base.fsti index 4f14bcfc7..c8781bc3c 100644 --- a/src/checker/Pulse.Checker.Base.fsti +++ b/src/checker/Pulse.Checker.Base.fsti @@ -30,16 +30,16 @@ val format_failed_goal (g:env) (ctxt:list term) (goal:list term) : T.Tac string val intro_comp_typing (g:env) (c:comp_st) - (pre_typing:tot_typing g (comp_pre c) tm_slprop) - (iname_typing:effect_annot_typing g (effect_annot_of_comp c)) - (res_typing:universe_of g (comp_res c) (comp_u c)) + (pre_typing:unit) + (iname_typing:unit) + (res_typing:unit) (x:var { fresh_wrt x g (freevars (comp_post c)) }) - (post_typing:tot_typing (push_binding g x ppname_default (comp_res c)) (open_term (comp_post c) x) tm_slprop) - : T.Tac (comp_typing g c (universe_of_comp c)) + (post_typing:unit) + : T.Tac unit val post_typing_as_abstraction (g:env) (x:var) (ty:term) (t:term { fresh_wrt x g (freevars t) }) - (_:tot_typing (push_binding g x ppname_default ty) (open_term t x) tm_slprop) + (_:unit) : FStar.Ghost.erased (RT.tot_typing (elab_env g) (RT.mk_abs ty T.Q_Explicit t) (RT.mk_arrow ty T.Q_Explicit tm_slprop)) @@ -62,19 +62,19 @@ val intro_post_hint effect_annot_labels_match h.effect_annot effect_annot }) -val post_hint_from_comp_typing (#g:env) (#c:comp_st) (ct:comp_typing_u g c) +val post_hint_from_comp_typing (g:env) (c:comp_st) (ct:unit) : post_hint_for_env g val comp_typing_from_post_hint (#g: env) (c: comp_st) - (pre_typing: tot_typing g (comp_pre c) tm_slprop) + (pre_typing: unit) (p:post_hint_for_env g { comp_post_matches_hint c (PostHint p) }) -: T.Tac (comp_typing_u g c) +: T.Tac unit val extend_post_hint (g:env) (p:post_hint_for_env g) (x:var{freshv g x}) (tx:term) - (conjunct:term) (_:tot_typing (push_binding g x ppname_default tx) conjunct tm_slprop) + (conjunct:term) (_:unit) : T.Tac (q:post_hint_for_env (push_binding g x ppname_default tx) { q.post == tm_star p.post conjunct /\ q.ret_ty == p.ret_ty /\ @@ -102,14 +102,14 @@ val k_elab_trans val k_elab_equiv_continuation (#g1:env) (#g2:env { g2 `env_extends` g1 }) (#ctxt #ctxt1:term) (ctxt2:term) (k:continuation_elaborator g1 ctxt g2 ctxt1) - (d:slprop_equiv g2 ctxt1 ctxt2) + (d:unit) : continuation_elaborator g1 ctxt g2 ctxt2 val k_elab_equiv (#g1:env) (#g2:env { g2 `env_extends` g1 }) (#ctxt1 #ctxt2:term) (ctxt1' ctxt2':term) (k:continuation_elaborator g1 ctxt1 g2 ctxt2) - (d1:slprop_equiv g1 ctxt1 ctxt1') - (d2:slprop_equiv g2 ctxt2 ctxt2') + (d1:unit) + (d2:unit) : continuation_elaborator g1 ctxt1' g2 ctxt2' // @@ -118,8 +118,8 @@ val k_elab_equiv val continuation_elaborator_with_bind (#g:env) (ctxt:term) (c1:comp{stateful_comp c1}) (e1:st_term) - (e1_typing:st_typing g e1 c1) - (ctxt_pre1_typing:tot_typing g (tm_star ctxt (comp_pre c1)) tm_slprop) + (e1_typing:unit) + (ctxt_pre1_typing:unit) (x:nvar { freshv g (snd x) }) : T.Tac (continuation_elaborator g @@ -128,18 +128,18 @@ val continuation_elaborator_with_bind (#g:env) (ctxt:term) (tm_star (open_term (comp_post c1) (snd x)) ctxt)) val continuation_elaborator_with_bind_fn (#g:env) (ctxt:term) - (ctxt_typing:tot_typing g ctxt tm_slprop) + (ctxt_typing:unit) (e1:st_term) (c1:comp { C_Tot? c1 }) (b:binder{b.binder_ty == comp_res c1}) - (e1_typing:st_typing g e1 c1) + (e1_typing:unit) (x:nvar { freshv g (snd x) }) : T.Tac (continuation_elaborator g ctxt (push_binding g (snd x) ppname_default (comp_res c1)) ctxt) val check_equiv_emp (g:env) (vp:term) - : option (slprop_equiv g vp tm_emp) + : option unit let checker_res_matches_post_hint (g:env) @@ -185,14 +185,14 @@ let retype_checker_result (#g:env) (#ctxt:slprop) (#ph:post_hint_opt g) (ph':pos type check_t = g:env -> ctxt:slprop -> - ctxt_typing:tot_typing g ctxt tm_slprop -> + ctxt_typing:unit -> post_hint:post_hint_opt g -> res_ppname:ppname -> t:st_term -> T.Tac (checker_result_t g ctxt post_hint) val match_comp_res_with_post_hint (#g:env) (t:st_term) (c:comp_st) - (d:st_typing g t c) + (d:unit) (post_hint:post_hint_opt g) : T.Tac (c':comp_st { comp_pre c' == comp_pre c }) @@ -208,7 +208,7 @@ val checker_result_for_st_typing (#g:env) (#ctxt:slprop) (#post_hint:post_hint_o val checker_result_t_equiv_ctxt (g:env) (ctxt ctxt' : slprop) (post_hint:post_hint_opt g) - (equiv : slprop_equiv g ctxt ctxt') + (equiv : unit) (r : checker_result_t g ctxt post_hint) : checker_result_t g ctxt' post_hint @@ -216,28 +216,28 @@ val is_stateful_application (g:env) (e:term) : T.Tac (option st_term) val norm_typing - (g:env) (e:term) (eff:_) (t0:term) - (d:typing g e eff t0) + (g:env) (e:term) (eff:T.tot_or_ghost) (t0:term) + (d:unit) (steps:list norm_step) - : T.Tac (t':term & typing g e eff t') + : T.Tac (t':term & unit) val norm_typing_inverse - (g:env) (e:term) (eff:_) (t0:term) - (d:typing g e eff t0) + (g:env) (e:term) (eff:T.tot_or_ghost) (t0:term) + (d:unit) (t1:term) - (#u:_) - (d1:tot_typing g t1 (tm_type u)) + (u:universe) + (d1:unit) (steps:list norm_step) - : T.Tac (option (typing g e eff t1)) + : T.Tac (option unit) val norm_st_typing_inverse (g:env) (e:st_term) (t0:term) - (d:st_typing g e (C_Tot t0)) - (#u:_) + (d:unit) + (u:universe) (t1:term) - (d1:tot_typing g t1 (tm_type u)) + (d1:unit) (steps:list norm_step) - : T.Tac (option (st_typing g e (C_Tot t1))) + : T.Tac (option unit) val hoist (g:env) diff --git a/src/checker/Pulse.Checker.Bind.fst b/src/checker/Pulse.Checker.Bind.fst index b871d7349..31460814b 100644 --- a/src/checker/Pulse.Checker.Bind.fst +++ b/src/checker/Pulse.Checker.Bind.fst @@ -34,7 +34,7 @@ module RU = Pulse.Reflection.Util let check_bind_fn (g:env) (ctxt:slprop) - (ctxt_typing:tot_typing g ctxt tm_slprop) + (ctxt_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term {Tm_Bind? t.term}) @@ -52,7 +52,7 @@ let check_bind_fn let x = fresh g in let b = { binder with binder_ty = comp_res c } in let g' = push_binding g x (binder.binder_ppname) b.binder_ty in - let ctxt_typing' : tot_typing g' ctxt tm_slprop = () in + let ctxt_typing' : unit = () in let r = check g' _ ctxt_typing' post_hint res_ppname (open_st_term_nv body (binder.binder_ppname, x)) in let body_typing = apply_checker_result_k #_ #_ #(PostHint?.v post_hint) r res_ppname in let k = Pulse.Checker.Base.continuation_elaborator_with_bind_fn ctxt ctxt_typing t c b () (binder.binder_ppname, x) in @@ -120,7 +120,7 @@ let check_bind' (maybe_elaborate:bool) (g:env) (ctxt:slprop) - (ctxt_typing:tot_typing g ctxt tm_slprop) + (ctxt_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term {Tm_Bind? t.term}) @@ -196,7 +196,7 @@ let check_bind = check_bind' true let check_tot_bind (g:env) (pre:term) - (pre_typing:tot_typing g pre tm_slprop) + (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_TotBind? t.term }) diff --git a/src/checker/Pulse.Checker.Bind.fsti b/src/checker/Pulse.Checker.Bind.fsti index e0c9fdd5e..e2e9a3dff 100644 --- a/src/checker/Pulse.Checker.Bind.fsti +++ b/src/checker/Pulse.Checker.Bind.fsti @@ -25,7 +25,7 @@ open Pulse.Checker.Base val check_bind (g:env) (pre:term) - (pre_typing:tot_typing g pre tm_slprop) + (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term{Tm_Bind? t.term}) @@ -35,7 +35,7 @@ val check_bind val check_tot_bind (g:env) (pre:term) - (pre_typing:tot_typing g pre tm_slprop) + (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_TotBind? t.term }) diff --git a/src/checker/Pulse.Checker.Comp.fst b/src/checker/Pulse.Checker.Comp.fst index 9a8311a6b..666f8532a 100644 --- a/src/checker/Pulse.Checker.Comp.fst +++ b/src/checker/Pulse.Checker.Comp.fst @@ -25,15 +25,15 @@ module P = Pulse.Syntax.Printer let check (g:env) (c:comp_st) - (pre_typing:tot_typing g (comp_pre c) tm_slprop) - : T.Tac (comp_typing g c (universe_of_comp c)) + (pre_typing:unit) + : T.Tac (unit) = let g = Pulse.Typing.Env.push_context_no_range g "check_comp" in let check_st_comp (st:st_comp { comp_u c == st.u /\ comp_pre c == st.pre /\ comp_res c == st.res /\ comp_post c == st.post } ) - : T.Tac (st_comp_typing g st) + : T.Tac (unit) = let u = check_universe g st.res in if not (eq_univ u (comp_u c)) then fail g None diff --git a/src/checker/Pulse.Checker.Comp.fsti b/src/checker/Pulse.Checker.Comp.fsti index 67fc9c1bf..a23055e7c 100644 --- a/src/checker/Pulse.Checker.Comp.fsti +++ b/src/checker/Pulse.Checker.Comp.fsti @@ -23,5 +23,5 @@ open Pulse.Typing val check (g:env) (c:comp_st) - (pre_typing:tot_typing g (comp_pre c) tm_slprop) - : T.Tac (comp_typing g c (universe_of_comp c)) + (pre_typing:unit) + : T.Tac (unit) diff --git a/src/checker/Pulse.Checker.Exists.fst b/src/checker/Pulse.Checker.Exists.fst index 85c348df5..f8e98c46d 100644 --- a/src/checker/Pulse.Checker.Exists.fst +++ b/src/checker/Pulse.Checker.Exists.fst @@ -29,9 +29,9 @@ module P = Pulse.Syntax.Printer module FV = Pulse.Typing.FV let slprop_as_list_typing (#g:env) (#p:term) - (t:tot_typing g p tm_slprop) + (t:unit) (x:term { List.Tot.memP x (slprop_as_list p) }) - : tot_typing g x tm_slprop + : unit = assume false; t let terms_to_string (t:list term) @@ -43,7 +43,7 @@ let terms_to_string (t:list term) let check_elim_exists (g:env) (pre:term) - (pre_typing:tot_typing g pre tm_slprop) + (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term{Tm_ElimExists? t.term}) @@ -88,7 +88,7 @@ let check_elim_exists then let x = fresh g in let elim_st = wtag (Some STT_Ghost) (Tm_ElimExists { p = tm_exists_sl u (as_binder ty) p }) in let elim_c = comp_elim_exists u ty p (ppname_default, x) in - let d : st_typing g elim_st elim_c = () in + let d : unit = () in let c = match_comp_res_with_post_hint elim_st elim_c d post_hint in prove_post_hint (try_frame_pre false pre_typing (|elim_st,c|) res_ppname) post_hint t_rng else fail g (Some t_rng) @@ -101,11 +101,11 @@ let check_elim_exists let check_intro_exists (g:env) (pre:term) - (pre_typing:tot_typing g pre tm_slprop) + (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (st:st_term { intro_exists_witness_singleton st }) - (slprop_typing: option (tot_typing g (intro_exists_slprop st) tm_slprop)) + (slprop_typing: option (unit)) : T.Tac (checker_result_t g pre post_hint) = let g = Pulse.Typing.Env.push_context g "check_intro_exists_non_erased" st.range in @@ -132,7 +132,7 @@ let check_intro_exists check_term g witness T.E_Ghost b.binder_ty in let intro_st = wtag (Some STT_Ghost) (Tm_IntroExists { p = tm_exists_sl u b p; witnesses = [witness] }) in let intro_c = C_STGhost tm_emp_inames { u=u0; res=tm_unit; pre=open_term' p witness 0; post=tm_exists_sl u b p } in - let d : st_typing g intro_st intro_c = () in + let d : unit = () in let c = match_comp_res_with_post_hint intro_st intro_c d post_hint in prove_post_hint (try_frame_pre false pre_typing (|intro_st, c|) res_ppname) post_hint diff --git a/src/checker/Pulse.Checker.Exists.fsti b/src/checker/Pulse.Checker.Exists.fsti index bda34d5a6..633f69346 100644 --- a/src/checker/Pulse.Checker.Exists.fsti +++ b/src/checker/Pulse.Checker.Exists.fsti @@ -25,7 +25,7 @@ open Pulse.Checker.Base val check_elim_exists (g:env) (pre:term) - (pre_typing:tot_typing g pre tm_slprop) + (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term{Tm_ElimExists? t.term}) @@ -43,9 +43,9 @@ let intro_exists_slprop (st:st_term { Tm_IntroExists? st.term }) = val check_intro_exists (g:env) (pre:term) - (pre_typing:tot_typing g pre tm_slprop) + (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (st:st_term { intro_exists_witness_singleton st }) - (slprop_typing: option (tot_typing g (intro_exists_slprop st) tm_slprop)) + (slprop_typing: option (unit)) : T.Tac (checker_result_t g pre post_hint) diff --git a/src/checker/Pulse.Checker.ForwardJumpLabel.fst b/src/checker/Pulse.Checker.ForwardJumpLabel.fst index 3bdd8c8ba..1ce18be2b 100644 --- a/src/checker/Pulse.Checker.ForwardJumpLabel.fst +++ b/src/checker/Pulse.Checker.ForwardJumpLabel.fst @@ -35,7 +35,7 @@ let starts_with (a b: string) : bool = let check (g:env) (pre:term) - (pre_typing:tot_typing g pre tm_slprop) + (pre_typing:unit) (post_hint0:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_ForwardJumpLabel? t.term }) @@ -72,7 +72,7 @@ let check } in let lbl_x = fresh g in let g' = push_goto g lbl_x lbl lbl_c in - let pre_typing': tot_typing g' pre tm_slprop = () in + let pre_typing': unit = () in let post_hint' : post_hint_opt g' = assume post_hint_for_env_p g' post; PostHint post in @@ -92,7 +92,7 @@ let check post = body'_c; }) in assume open_st_term' body (term_of_nvar (lbl, lbl_x)) 0 == body'; - let typing: st_typing g t body'_c = () in + let typing: unit = () in if not has_explicit_post then ( assert post_hint0 == PostHint post; checker_result_for_st_typing (| t, body'_c |) res_ppname diff --git a/src/checker/Pulse.Checker.ForwardJumpLabel.fsti b/src/checker/Pulse.Checker.ForwardJumpLabel.fsti index 0f7266630..93e884884 100644 --- a/src/checker/Pulse.Checker.ForwardJumpLabel.fsti +++ b/src/checker/Pulse.Checker.ForwardJumpLabel.fsti @@ -27,7 +27,7 @@ open Pulse.Checker.Base val check (g:env) (pre:term) - (pre_typing:tot_typing g pre tm_slprop) + (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_ForwardJumpLabel? t.term }) diff --git a/src/checker/Pulse.Checker.Goto.fst b/src/checker/Pulse.Checker.Goto.fst index d6ed283b4..40dfbff50 100644 --- a/src/checker/Pulse.Checker.Goto.fst +++ b/src/checker/Pulse.Checker.Goto.fst @@ -28,7 +28,7 @@ open Pulse.Checker.Prover let check' (g:env) (pre:term) - (pre_typing:tot_typing g pre tm_slprop) + (pre_typing:unit) (post_hint:post_hint_opt g { PostHint? post_hint }) (res_ppname:ppname) (t:st_term { Tm_Goto? t.term }) @@ -49,7 +49,7 @@ let check' post = ph.post } in let t = wtag (Some (ctag_of_comp_st c')) (Tm_Goto { lbl = term_of_nvar (lbln, v); arg }) in - let typing: st_typing g t c' = + let typing: unit = let x' = fresh g in assume fresh_wrt x' g (freevars ph.post); () in let c' = match_comp_res_with_post_hint t c' typing post_hint in @@ -65,7 +65,7 @@ let check' let check (g:env) (pre:term) - (pre_typing:tot_typing g pre tm_slprop) + (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_Goto? t.term }) diff --git a/src/checker/Pulse.Checker.Goto.fsti b/src/checker/Pulse.Checker.Goto.fsti index 4e5ba98e7..8977ea774 100644 --- a/src/checker/Pulse.Checker.Goto.fsti +++ b/src/checker/Pulse.Checker.Goto.fsti @@ -27,7 +27,7 @@ open Pulse.Checker.Base val check (g:env) (pre:term) - (pre_typing:tot_typing g pre tm_slprop) + (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_Goto? t.term }) diff --git a/src/checker/Pulse.Checker.If.fst b/src/checker/Pulse.Checker.If.fst index 69db87688..0d766098b 100644 --- a/src/checker/Pulse.Checker.If.fst +++ b/src/checker/Pulse.Checker.If.fst @@ -46,7 +46,7 @@ let retype_checker_result (#g:env) (#ctxt:slprop) (#ph:post_hint_opt g) (ph':pos let check (g:env) (pre:term) - (pre_typing: tot_typing g pre tm_slprop) + (pre_typing: unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (b:term) @@ -64,7 +64,7 @@ let check let g_with_eq = g_with_eq g hyp b in let check_branch (eq_v:term) (br:st_term) (is_then:bool) : T.Tac (checker_result_t (g_with_eq eq_v) pre post_hint) - = let pre_typing : tot_typing (g_with_eq eq_v) pre tm_slprop = () in + = let pre_typing : unit = () in let br = let t = @@ -85,7 +85,7 @@ let check let infer_post_branch (#eq_v:term) (r: checker_result_t (g_with_eq eq_v) pre NoHint) : T.Tac (p:post_hint_for_env g {p.g == g /\ p.effect_annot==EffectAnnotSTT}) = let (| x, g', (u, t), post, k |) = r in - J.infer_post' g g' #u #t x () #post () + J.infer_post' g g' u t x () post () in let then_ = check_branch tm_true e1 true in @@ -112,7 +112,7 @@ let check let extract #g #pre (#ph:post_hint_for_env g) (r:checker_result_t g pre (PostHint ph)) (is_then:bool) : T.Tac (br:st_term { ~(hyp `Set.mem` freevars_st br) } & c:comp_st { comp_pre c == pre /\ comp_post_matches_hint c (PostHint ph)} & - st_typing g br c) + unit) = let (| br, c |) = let ppname = mk_ppname_no_range "_if_br" in apply_checker_result_k r ppname diff --git a/src/checker/Pulse.Checker.If.fsti b/src/checker/Pulse.Checker.If.fsti index d8099e86a..c363d7a83 100644 --- a/src/checker/Pulse.Checker.If.fsti +++ b/src/checker/Pulse.Checker.If.fsti @@ -25,7 +25,7 @@ open Pulse.Checker.Base val check (g:env) (pre:term) - (pre_typing: tot_typing g pre tm_slprop) + (pre_typing: unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (b:term) diff --git a/src/checker/Pulse.Checker.IntroPure.fst b/src/checker/Pulse.Checker.IntroPure.fst index 81d888d99..71d3e0321 100644 --- a/src/checker/Pulse.Checker.IntroPure.fst +++ b/src/checker/Pulse.Checker.IntroPure.fst @@ -46,7 +46,7 @@ let check_prop_validity (g:env) (p:term): T.Tac (prop_validity g p) = let check (g:env) (pre:term) - (pre_typing:tot_typing g pre tm_slprop) + (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_IntroPure? t.term }) @@ -57,10 +57,10 @@ let check let Tm_IntroPure { p } = t.term in let p = check_prop g p in - let p_typing : tot_typing g p tm_prop = () in + let p_typing : unit = () in let pv = check_prop_validity g p in let intro_st = wtag (Some STT_Ghost) (Tm_IntroPure { p }) in let intro_c = C_STGhost tm_emp_inames { u=u0; res=tm_unit; pre=tm_emp; post=tm_pure p } in - let st_typing : st_typing g intro_st intro_c = () in + let st_typing : unit = () in let c = match_comp_res_with_post_hint intro_st intro_c st_typing post_hint in prove_post_hint (try_frame_pre false pre_typing (|intro_st,c|) res_ppname) post_hint t.range diff --git a/src/checker/Pulse.Checker.IntroPure.fsti b/src/checker/Pulse.Checker.IntroPure.fsti index ccbfdfb5f..48565cef1 100644 --- a/src/checker/Pulse.Checker.IntroPure.fsti +++ b/src/checker/Pulse.Checker.IntroPure.fsti @@ -25,7 +25,7 @@ module T = FStar.Tactics.V2 val check (g:env) (pre:term) - (pre_typing:tot_typing g pre tm_slprop) + (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_IntroPure? t.term }) diff --git a/src/checker/Pulse.Checker.Match.fst b/src/checker/Pulse.Checker.Match.fst index 07d800751..7ecff787f 100644 --- a/src/checker/Pulse.Checker.Match.fst +++ b/src/checker/Pulse.Checker.Match.fst @@ -181,8 +181,8 @@ and elab_readback_subpat (pb : R.pattern & bool) val tot_typing_weakening_n (#g:env) (#t:term) (#ty:term) (bs:list var_binding {all_fresh g bs}) - (d:tot_typing g t ty) - : Tot (tot_typing (push_bindings g bs) t ty) + (d:unit) + : Tot (unit) (decreases bs) let rec tot_typing_weakening_n #g #t #ty bs d = () @@ -219,7 +219,7 @@ let check_branch (norw:bool) (g:env) (pre:term) - (pre_typing: tot_typing g pre tm_slprop) + (pre_typing: unit) (post_hint:post_hint_for_env g) (check:check_t) (sc_u : universe) @@ -270,8 +270,7 @@ let check_branch in { t with effect_tag = e.effect_tag } in - let pre_typing = tot_typing_weakening_n pulse_bs pre_typing in // weaken w/ binders - let pre_typing : tot_typing _ _ _ = () in // weaken w/ branch eq + let pre_typing : unit = () in // weakened w/ binders and branch eq let (| e, c |) = let ppname = mk_ppname_no_range "_br" in @@ -294,7 +293,7 @@ let check_branches_aux_t let check_branches_aux (g:env) (pre:term) - (pre_typing: tot_typing g pre tm_slprop) + (pre_typing: unit) (post_hint:post_hint_for_env g) (check:check_t) (sc_u : universe) @@ -465,7 +464,7 @@ let maybe_weaken_branch_tags let check_branches (g:env) (pre:term) - (pre_typing: tot_typing g pre tm_slprop) + (pre_typing: unit) (post_hint:post_hint_for_env g) (check:check_t) (sc_u : universe) @@ -484,7 +483,7 @@ let check_branches let check (g:env) (pre:term) - (pre_typing: tot_typing g pre tm_slprop) + (pre_typing: unit) (post_hint:post_hint_for_env g) (res_ppname:ppname) (sc:term) @@ -545,6 +544,6 @@ let check assume (L.map (fun br -> elab_pat br.pat) brs == elab_pats'); let c_typing = comp_typing_from_post_hint c pre_typing post_hint in let t = wtag (Some (ctag_of_comp_st c)) (Tm_Match {sc; returns_=None; brs}) in - let d : st_typing g t c = () in + let d : unit = () in checker_result_for_st_typing (| t, c |) res_ppname #pop-options \ No newline at end of file diff --git a/src/checker/Pulse.Checker.Match.fsti b/src/checker/Pulse.Checker.Match.fsti index cedfdb880..57942983e 100644 --- a/src/checker/Pulse.Checker.Match.fsti +++ b/src/checker/Pulse.Checker.Match.fsti @@ -29,7 +29,7 @@ let close_st_term_bs t bs = val check (g:env) (pre:term) - (pre_typing: tot_typing g pre tm_slprop) + (pre_typing: unit) (post_hint:post_hint_for_env g) (res_ppname:ppname) (sc:term) diff --git a/src/checker/Pulse.Checker.Prover.Normalize.fst b/src/checker/Pulse.Checker.Prover.Normalize.fst index 852aeb378..8931ad881 100644 --- a/src/checker/Pulse.Checker.Prover.Normalize.fst +++ b/src/checker/Pulse.Checker.Prover.Normalize.fst @@ -48,7 +48,7 @@ let __normalize_slprop let v' = PCP.norm_well_typed_term (elab_env g) steps v in let v' = Pulse.Simplify.simplify v' in (* NOTE: the simplify stage is unverified *) - let v_equiv_v' : slprop_equiv g v v' = () in + let v_equiv_v' : unit = () in v' let normalize_slprop @@ -60,7 +60,7 @@ let normalize_slprop if use_rewrites_to then let rwr = Pulse.Checker.Prover.RewritesTo.get_subst_from_env g in let v' = PS.ss_term v rwr in - let eq_v_v' : slprop_equiv g v v' = () in + let eq_v_v' : unit = () in let v'' = __normalize_slprop g v' in v'' else @@ -69,7 +69,7 @@ let normalize_slprop let normalize_slprop_welltyped (g:env) (v:slprop) - (v_typing:tot_typing g v tm_slprop) + (v_typing:unit) : T.Tac slprop = let v' = normalize_slprop g v true in diff --git a/src/checker/Pulse.Checker.Prover.Normalize.fsti b/src/checker/Pulse.Checker.Prover.Normalize.fsti index b857b1474..a16b408b1 100644 --- a/src/checker/Pulse.Checker.Prover.Normalize.fsti +++ b/src/checker/Pulse.Checker.Prover.Normalize.fsti @@ -35,5 +35,5 @@ val normalize_slprop val normalize_slprop_welltyped (g:env) (v:slprop) - (v_typing:tot_typing g v tm_slprop) + (v_typing:unit) : T.Tac slprop diff --git a/src/checker/Pulse.Checker.Prover.fst b/src/checker/Pulse.Checker.Prover.fst index df9a21ba5..c9fa9c73a 100644 --- a/src/checker/Pulse.Checker.Prover.fst +++ b/src/checker/Pulse.Checker.Prover.fst @@ -77,9 +77,9 @@ let rec elab_slprops (ps: list slprop_view) : slprop = | p::ps -> elab_slprop p `tm_star` elab_slprops ps let slprop_eqv (p q: slprop) : prop = - forall g. squash (slprop_equiv g p q) + True -let slprop_eqv_intro #p #q (h: (g:env -> slprop_equiv g p q)) : squash (slprop_eqv p q) = admit () +let slprop_eqv_intro #p #q (h: (g:env -> unit)) : squash (slprop_eqv p q) = () let slprop_eqv_refl (p: slprop) : squash (slprop_eqv p p) = slprop_eqv_intro fun g -> () let slprop_eqv_trans (p q r: slprop) : Lemma (requires slprop_eqv p q /\ slprop_eqv q r) (ensures slprop_eqv p r) = admit () let slprop_eqv_star p1 q1 p2 q2 : Lemma (requires slprop_eqv p1 p2 /\ slprop_eqv q1 q2) (ensures slprop_eqv (tm_star p1 q1) (tm_star p2 q2)) = admit () @@ -205,20 +205,20 @@ let build_plems (g: env) : T.Tac plems = let cont_elab g ps g' ps' = frame: list slprop_view -> continuation_elaborator g (elab_slprops (frame @ ps)) g' (elab_slprops (frame @ ps')) -let cont_elab_refl g ps ps' (h: slprop_equiv g (elab_slprops ps) (elab_slprops ps')) : cont_elab g ps g ps' = +let cont_elab_refl g ps ps' (h: unit) : cont_elab g ps g ps' = fun frame -> k_elab_equiv (elab_slprops (frame @ ps)) (elab_slprops (frame @ ps')) (k_elab_unit g (elab_slprops (frame @ ps))) (()) (()) let cont_elab_trans #g1 (#g2: env { g2 `env_extends` g1 }) (#g3: env { g3 `env_extends` g2 }) #ps1 #ps2 #ps2' #ps3 (k1: cont_elab g1 ps1 g2 ps2) (k2: cont_elab g2 ps2' g3 ps3) - (h: slprop_equiv g2 (elab_slprops ps2) (elab_slprops ps2')) : + (h: unit) : cont_elab g1 ps1 g3 ps3 = fun frame -> k_elab_trans (k1 frame) (k_elab_equiv (elab_slprops (frame @ ps2)) (elab_slprops (frame @ ps3)) (k2 frame) (()) (())) let cont_elab_equiv #g1 #ps1 #ps1' #g2 #ps2 #ps2' (k: cont_elab g1 ps1 g2 ps2) - (h1: slprop_equiv g1 (elab_slprops ps1) (elab_slprops ps1')) - (h2: slprop_equiv g2 (elab_slprops ps2) (elab_slprops ps2')) : + (h1: unit) + (h2: unit) : cont_elab g1 ps1' g2 ps2' = fun frame -> k_elab_equiv (elab_slprops (frame @ ps1')) (elab_slprops (frame @ ps2')) (k frame) (()) (()) @@ -248,12 +248,12 @@ let prover_result_join #g #ctxt #goals #g1 #ctxt1 #goals1 let before1, after1 = k1 g3 in let before2, after2 = k2 g3 in (fun frame -> - let h1: slprop_equiv g1 (elab_slprops ((frame @ solved1) @ ctxt1)) (elab_slprops (frame @ solved1 @ ctxt1)) = () in - let h2: slprop_equiv g2 (elab_slprops ((frame @ solved1) @ solved2 @ ctxt2)) (elab_slprops (frame @ (solved1 @ solved2) @ ctxt2)) = () in + let h1: unit = () in + let h2: unit = () in k_elab_trans (before1 frame) (k_elab_equiv (elab_slprops (frame @ solved1 @ ctxt1)) (elab_slprops (frame @ (solved1 @ solved2) @ ctxt2)) (before2 (frame @ solved1)) h1 h2)), (fun frame -> - let h1: slprop_equiv g3 (elab_slprops ((frame @ solved1) @ solved2 @ goals2)) (elab_slprops (frame @ (solved1 @ solved2) @ goals2)) = () in - let h2: slprop_equiv g3 (elab_slprops ((frame @ solved1) @ goals1)) (elab_slprops (frame @ solved1 @ goals1)) = () in + let h1: unit = () in + let h2: unit = () in k_elab_trans (k_elab_equiv (elab_slprops (frame @ (solved1 @ solved2) @ goals2)) (elab_slprops (frame @ solved1 @ goals1)) (after2 (frame @ solved1)) h1 h2) (after1 frame)) <: T.Tac _ |) @@ -272,12 +272,8 @@ let prove_first (g: env) (ctxt goals: list slprop_view) let before, after = res g'' in before, (fun frame -> - let h1 : slprop_equiv g'' - (elab_slprops ((frame @ List.Tot.Base.rev goals_left_rev @ goals) @ solved @ goals')) - (elab_slprops (frame @ solved @ List.Tot.Base.rev goals_left_rev @ goals' @ goals)) = () in - let h2 : slprop_equiv g'' - (elab_slprops ((frame @ List.Tot.Base.rev goals_left_rev @ goals) @ [goal])) - (elab_slprops (frame @ goals0)) = () in + let h1 : unit = () in + let h2 : unit = () in k_elab_equiv (elab_slprops (frame @ solved @ List.Tot.Base.rev goals_left_rev @ goals' @ goals)) (elab_slprops (frame @ goals0)) (after (frame @ List.rev goals_left_rev @ goals)) h1 h2) |) | None -> assert List.rev goals_left_rev @ (goal::goals) == goals0; @@ -294,8 +290,8 @@ let deep_compress_comp (c:comp {stateful_comp c}) : comp = let continuation_elaborator_with_bind_nondep (#g:env) (ctxt:term) (c1:comp{stateful_comp c1}) (e1:st_term) - (e1_typing:st_typing g e1 c1) - (ctxt_pre1_typing:tot_typing g (tm_star ctxt (comp_pre c1)) tm_slprop) + (e1_typing:unit) + (ctxt_pre1_typing:unit) : T.Tac (continuation_elaborator g (tm_star ctxt (comp_pre c1)) @@ -308,51 +304,46 @@ let continuation_elaborator_with_bind_nondep (#g:env) (ctxt:term) let continuation_elaborator_with_bind_nondep_unit (#g:env) (ctxt:term) (c1:comp_st{comp_res c1 == tm_unit }) (e1:st_term) - (e1_typing:st_typing g e1 c1) - (ctxt_pre1_typing:tot_typing g (tm_star ctxt (comp_pre c1)) tm_slprop) + (e1_typing:unit) + (ctxt_pre1_typing:unit) : T.Tac (continuation_elaborator g (tm_star ctxt (comp_pre c1)) g (tm_star (open_term' (comp_post c1) unit_const 0) ctxt)) = let c1 = with_st_comp c1 { st_comp_of_comp c1 with post = open_term' (comp_post c1) unit_const 0 } in - let e1_typing: st_typing g e1 c1 = () in + let e1_typing: unit = () in continuation_elaborator_with_bind_nondep #g ctxt c1 e1 e1_typing ctxt_pre1_typing let cont_elab_with_bind_nondep_unit (#g:env) (c1:comp_st{comp_res c1 == tm_unit }) (e1:st_term) - (e1_typing:st_typing g e1 c1) - (pre1_typing:tot_typing g (comp_pre c1) tm_slprop) + (e1_typing:unit) + (pre1_typing:unit) : T.Tac (cont_elab g [Unknown (comp_pre c1)] g [Unknown (open_term' (comp_post c1) unit_const 0)]) = fun frame posth t -> - let h1: tot_typing g (tm_star (elab_slprops frame) (comp_pre c1)) tm_slprop = () in - let h2: slprop_equiv g - (tm_star (elab_slprops frame) (comp_pre c1)) - (elab_slprops (frame @ [Unknown (comp_pre c1)])) = () in - let h3: slprop_equiv g - (tm_star (open_term' (comp_post c1) unit_const 0) (elab_slprops frame)) - (elab_slprops (frame @ - [Unknown (open_term' (comp_post c1) unit_const 0)])) = () in + let h1: unit = () in + let h2: unit = () in + let h3: unit = () in k_elab_equiv (elab_slprops (frame @ [Unknown (comp_pre c1)])) (elab_slprops (frame @ [Unknown (open_term' (comp_post c1) unit_const 0)])) (continuation_elaborator_with_bind_nondep_unit (elab_slprops frame) c1 e1 e1_typing h1) h2 h3 posth t -let tot_typing_tm_unit (g: env) : tot_typing g tm_unit (tm_type u0) = () +let tot_typing_tm_unit (g: env) : unit = () let intro_pure (g: env) (frame: slprop) (p: term) - (p_typing:tot_typing g p tm_prop) + (p_typing:unit) (pv:prop_validity g p): continuation_elaborator g frame g (frame `tm_star` tm_pure p) = fun post t -> - let frame_typ : tot_typing g frame tm_slprop = () in // implied by t2_typing - let h: tot_typing g (tm_star frame (comp_pre (comp_intro_pure p))) tm_slprop = () in + let frame_typ : unit = () in // implied by t2_typing + let h: unit = () in let st = wtag (Some STT_Ghost) (Tm_IntroPure { p }) in debug_prover g (fun _ -> Printf.sprintf "intro_pure p=%s\nframe=%s\n" (show p) (show frame)); k_elab_equiv frame (frame `tm_star` tm_pure p) (continuation_elaborator_with_bind_nondep frame (comp_intro_pure p) st () h) (()) (()) @@ -394,12 +385,12 @@ let prove_pure (g: env) (ctxt: list slprop_view) (skip_eq_uvar: bool) (goal: slp debug_prover g (fun _ -> Printf.sprintf "prove_pure p=%s success" (show p)); Some (| g, ctxt, [], [], fun g'' -> - let p_typing: tot_typing g'' p tm_prop = () in // implied by t2_typing + let p_typing: unit = () in // implied by t2_typing let pv = check_prop_validity g'' p in cont_elab_refl g ctxt ([] @ ctxt) (()), (fun frame -> - let h1: slprop_equiv g'' (elab_slprops frame) (elab_slprops (frame @ [] @ [])) = () in - let h2: slprop_equiv g'' (tm_star (elab_slprops frame) (tm_pure p)) (elab_slprops (frame @ [goal])) = () in + let h1: unit = () in + let h2: unit = () in k_elab_equiv (elab_slprops (frame @ [] @ [])) (elab_slprops (frame @ [goal])) @@ -413,14 +404,14 @@ let intro_with_pure (g: env) (frame: slprop) (p: term) (n: ppname) (v: term) : continuation_elaborator g (frame `tm_star` v) g (frame `tm_star` tm_with_pure p n v) = fun post t -> let g = push_context g "check_intro_with_pure" (RU.range_of_term p) in - let p_typing: tot_typing g p tm_prop = () in // implied by t2_typing + let p_typing: unit = () in // implied by t2_typing let pv = check_prop_validity g p in - let frame_typ : tot_typing g frame tm_slprop = () in // implied by t2_typing + let frame_typ : unit = () in // implied by t2_typing let ty = mk_squash u0 p in let st = wtag (Some STT_Ghost) (Tm_ST { t = tm_unknown; args = [] }) in let c = C_STGhost tm_emp_inames { u=u0; res=tm_unit; pre=v; post=tm_with_pure p n v } in - let typing: st_typing g st c = () in - let h: tot_typing g (tm_star frame (comp_pre c)) tm_slprop = () in + let typing: unit = () in + let h: unit = () in debug_prover g (fun _ -> Printf.sprintf "intro_pure p=%s\nframe=%s\n" (show p) (show frame)); k_elab_equiv (frame `tm_star` v) (frame `tm_star` tm_with_pure p n v) (continuation_elaborator_with_bind_nondep frame c st typing h) (()) (()) post t @@ -434,9 +425,8 @@ let prove_with_pure (g: env) (ctxt: list slprop_view) skip_eq_uvar (goal: slprop Some (| g, ctxt, [Unknown v], [], fun g'' -> cont_elab_refl g ctxt ([] @ ctxt) (()), (fun frame -> - let h1: slprop_equiv g'' (tm_star (elab_slprops frame) v) (elab_slprops (frame @ [Unknown v] @ [])) = () in - let h2: slprop_equiv g'' (tm_star (elab_slprops frame) (tm_with_pure p n v)) - (elab_slprops (frame @ [goal])) = () in + let h1: unit = () in + let h2: unit = () in k_elab_equiv (elab_slprops (frame @ [Unknown v] @ [])) (elab_slprops (frame @ [goal])) (intro_with_pure g'' (elab_slprops frame) p n v) h1 h2) <: T.Tac _ |) | _ -> None @@ -445,14 +435,14 @@ let intro_exists (g: env) (frame: slprop) (u: universe) (b: binder) (body: slpro continuation_elaborator g (frame `tm_star` open_term' body e 0) g (frame `tm_star` tm_exists_sl u b body) = fun post t -> let g = push_context g "check_intro_exists" (RU.range_of_term body) in - let frame_typ : tot_typing g frame tm_slprop = () in // implied by t2_typing - let binder_ty_typ : tot_typing g b.binder_ty (tm_type u) = () in // implied by t2_typing - let tm_ex_typ : tot_typing g (tm_exists_sl u b body) tm_slprop = () in // implied by t2_typing + let frame_typ : unit = () in // implied by t2_typing + let binder_ty_typ : unit = () in // implied by t2_typing + let tm_ex_typ : unit = () in // implied by t2_typing let _ = core_check_term' g e T.E_Ghost b.binder_ty (fun _ -> let open Pulse.PP in [text "Cannot find witness for" ^/^ pp (tm_exists_sl u b body)]) in - let h1: tot_typing g (tm_star frame (comp_pre (comp_intro_exists u b body e))) tm_slprop = () in - let h2: slprop_equiv g (tm_star frame (comp_pre (comp_intro_exists u b body e))) (tm_star frame (open_term' body e 0)) = () in - let h3: slprop_equiv g (tm_star (comp_post (comp_intro_exists u b body e)) frame) (tm_star frame (tm_exists_sl u b body)) = () in + let h1: unit = () in + let h2: unit = () in + let h3: unit = () in let st = wtag (Some STT_Ghost) (Tm_IntroExists { p = tm_exists_sl u b body; witnesses = [e] }) in debug_prover g (fun _ -> Printf.sprintf "intro_exists %s\nframe=%s\n" (show (tm_exists_sl u b body)) (show frame)); k_elab_equiv (frame `tm_star` open_term' body e 0) (frame `tm_star` tm_exists_sl u b body) (continuation_elaborator_with_bind_nondep frame (comp_intro_exists u b body e) st () h1) h2 h3 @@ -467,8 +457,8 @@ let prove_exists (g: env) (ctxt: list slprop_view) (goal: slprop_view) : Some (| g, ctxt, [Unknown (open_term' body e 0)], [], fun g'' -> cont_elab_refl g ctxt ([] @ ctxt) (()), (fun frame -> - let h1: slprop_equiv g'' (tm_star (elab_slprops frame) (open_term' body e 0)) (elab_slprops (frame @ [] @ [Unknown (open_term' body e 0)])) = () in - let h2: slprop_equiv g'' (tm_star (elab_slprops frame) (tm_exists_sl u b body)) (elab_slprops (frame @ [goal])) = () in + let h1: unit = () in + let h2: unit = () in k_elab_equiv (elab_slprops (frame @ [] @ [Unknown (open_term' body e 0)])) (elab_slprops (frame @ [goal])) (intro_exists g'' (elab_slprops frame) u b body e) h1 h2) <: T.Tac _ |) | _ -> None @@ -482,7 +472,7 @@ let unpack_and_norm_goal (g: env) (ctxt: list slprop_view) (goal: slprop_view) : (match goal'' with | [Unknown _] -> None | _ -> Some (| g, ctxt, goal'', [], fun g' -> - let h: slprop_equiv g' (elab_slprops ([] @ goal'')) (elab_slprops [Unknown goal]) = () in + let h: unit = () in cont_elab_refl _ _ _ (()), cont_elab_refl _ _ _ h <: T.Tac _ |)) | _ -> None @@ -506,11 +496,10 @@ let elim_first' (g: env) (ctxt0 goals: list slprop_view) assert goals' == []; Some (| g', List.rev ctxt_left_rev @ ctxt' @ ctxt, goals, solved, fun (g'': env { env_extends g'' g' }) -> let before, after = res g'' in - let h1: slprop_equiv g (elab_slprops ((List.Tot.Base.rev ctxt_left_rev @ ctxt) @ [c])) (elab_slprops ctxt0) = () in - let h2: slprop_equiv g' (elab_slprops ((List.Tot.Base.rev ctxt_left_rev @ ctxt) @ solved @ ctxt')) - (elab_slprops (solved @ List.Tot.Base.rev ctxt_left_rev @ ctxt' @ ctxt)) = () in - let h3: slprop_equiv g'' (elab_slprops (goals @ solved @ goals')) (elab_slprops (solved @ goals)) = () in - let h4: slprop_equiv g'' (elab_slprops (goals @ [])) (elab_slprops goals) = () in + let h1: unit = () in + let h2: unit = () in + let h3: unit = () in + let h4: unit = () in cont_elab_equiv (cont_elab_frame before (List.rev ctxt_left_rev @ ctxt)) h1 h2, cont_elab_equiv (cont_elab_frame after goals) h3 h4 |) | None -> @@ -536,8 +525,8 @@ let unreachable_elim (g: env) (goals: list slprop_view) : cont_elab g [IsUnreach let frame_t = elab_slprops frame in let c = C_STGhost tm_emp_inames { u=u0; res=tm_unit; pre=tm_is_unreachable; post=frame_t } in let st = unreachable_elim_typing g u0 tm_unit frame_t in - let typing : st_typing g st c = () in - let h: tot_typing g (tm_star frame_t tm_is_unreachable) tm_slprop = () in + let typing : unit = () in + let h: unit = () in k_elab_equiv (elab_slprops (frame @ [IsUnreachable])) (elab_slprops (frame @ goals)) (continuation_elaborator_with_bind_nondep frame_t c st typing h) (()) (()) post t @@ -545,7 +534,7 @@ let elim_is_unreachable (g: env) (ctxt goals: list slprop_view) : T.Tac (option (prover_result g ctxt goals)) = if not (List.existsb IsUnreachable? ctxt) then None else // TODO: maybe add `_: squash False` to the environment? - let h1 : slprop_equiv g (elab_slprops ctxt) (elab_slprops ([IsUnreachable] @ [IsUnreachable])) = () in + let h1 : unit = () in Some (| g, [IsUnreachable], [], [IsUnreachable], (fun g'' -> cont_elab_refl _ _ _ h1, unreachable_elim _ _ <: T.Tac _)|) let elim_is_unreachable' (g: env) (ctxt goals: list slprop_view) : @@ -556,8 +545,8 @@ let elim_is_unreachable' (g: env) (ctxt goals: list slprop_view) : if not (List.existsb IsUnreachable? ctxt) then None else // TODO: maybe add `_: squash False` to the environment? Some (| g, [IsUnreachable], goals, [IsUnreachable], (fun g'' -> - let h1 : slprop_equiv g (elab_slprops ctxt) (elab_slprops ([IsUnreachable] @ [IsUnreachable])) = () in - let h2: slprop_equiv g'' (elab_slprops [IsUnreachable]) (elab_slprops ([IsUnreachable] @ goals)) = () in + let h1 : unit = () in + let h2: unit = () in cont_elab_refl _ _ _ h1, cont_elab_equiv (unreachable_elim g'' goals) h2 (()) <: T.Tac _)|) @@ -571,7 +560,7 @@ let unpack_and_norm_ctxt (g: env) (ctxt: slprop_view) : (match ctxt'' with | [Unknown _] -> None | _ -> Some (| g, ctxt'', [], [], fun g' -> - let h: slprop_equiv g ctxt (elab_slprops ([] @ ctxt'')) = () in + let h: unit = () in cont_elab_refl _ _ _ h, cont_elab_refl _ _ _ (()) <: T.Tac _ |)) | _ -> None @@ -582,9 +571,9 @@ let elim_pure (g: env) (frame: slprop) (p: term) (x: nvar { ~(Set.mem (snd x) (d let ty = mk_squash u0 p in let st = wtag (Some STT_Ghost) (Tm_ST { t = tm_unknown; args = [] }) in let c = C_STGhost tm_emp_inames { u=u0; res=ty; pre=tm_pure p; post=tm_emp } in - let typing: st_typing g st c = () in - let h: tot_typing g (tm_star frame (comp_pre c)) tm_slprop = () in - let h2: slprop_equiv g' (tm_star (open_term_nv (comp_post c) x) frame) frame = () in + let typing: unit = () in + let h: unit = () in + let h2: unit = () in let k: continuation_elaborator g (tm_star frame (tm_pure p)) g' (tm_star tm_emp frame) = continuation_elaborator_with_bind frame c st typing h x in k_elab_equiv (frame `tm_star` tm_pure p) frame k () h2 post t @@ -598,8 +587,8 @@ let elim_pure_step (g: env) (ctxt: slprop_view) : let g' = push_binding g (snd x) (fst x) ty in Some (| g', [], [], [], fun g'' -> (fun frame -> - let h1: slprop_equiv g (tm_star (elab_slprops frame) (tm_pure p)) (elab_slprops (frame @ [ctxt])) = () in - let h2: slprop_equiv g' (elab_slprops frame) (elab_slprops (frame @ [] @ [])) = () in + let h1: unit = () in + let h2: unit = () in k_elab_equiv (elab_slprops (frame @ [ctxt])) (elab_slprops (frame @ [] @ [])) (elim_pure g (elab_slprops frame) p x g') h1 h2), cont_elab_refl _ _ _ (()) <: T.Tac _ |) @@ -613,9 +602,9 @@ let elim_with_pure (g: env) (frame: slprop) (p: term) (x: nvar { ~(Set.mem (snd let st = wtag (Some STT_Ghost) (Tm_ST { t = tm_unknown; args = [] }) in let c = C_STGhost tm_emp_inames { u=u0; res=ty; pre=tm_with_pure p (fst x) v; post=v } in assume open_term v (snd x) == v; // no loose bvars - let typing: st_typing g st c = () in - let h: tot_typing g (tm_star frame (comp_pre c)) tm_slprop = () in - let h2: slprop_equiv g' (tm_star (open_term_nv (comp_post c) x) frame) (tm_star frame v) = () in + let typing: unit = () in + let h: unit = () in + let h2: unit = () in let k: continuation_elaborator g (tm_star frame (tm_with_pure p (fst x) v)) g' (tm_star v frame) = continuation_elaborator_with_bind frame c st typing h x in k_elab_equiv (frame `tm_star` tm_with_pure p (fst x) v) (frame `tm_star` v) k () h2 post t @@ -629,8 +618,8 @@ let elim_with_pure_step (g: env) (ctxt: slprop_view) : let g' = push_binding g (snd x) (fst x) ty in Some (| g', [Unknown v], [], [], fun g'' -> (fun frame -> - let h1: slprop_equiv g (tm_star (elab_slprops frame) (tm_with_pure p (fst x) v)) (elab_slprops (frame @ [ctxt])) = () in - let h2: slprop_equiv g' (tm_star (elab_slprops frame) v) (elab_slprops (frame @ [Unknown v] @ [])) = () in + let h1: unit = () in + let h2: unit = () in k_elab_equiv (elab_slprops (frame @ [ctxt])) (elab_slprops (frame @ [Unknown v] @ [])) (elim_with_pure g (elab_slprops frame) p x v g') h1 h2), cont_elab_refl _ _ _ (()) <: T.Tac _ |) @@ -642,14 +631,14 @@ let elim_exists (g: env) (frame: slprop) u b body (x: nvar { ~(Set.mem (snd x) ( continuation_elaborator g (frame `tm_star` tm_exists_sl u b body) g' (frame `tm_star` open_term' body (mk_reveal u b.binder_ty (term_of_nvar x)) 0) = fun post t -> let c = comp_elim_exists u b.binder_ty body x in - let h1: tot_typing g b.binder_ty (tm_type u) = () in - let h2: tot_typing g (tm_exists_sl u (as_binder b.binder_ty) body) tm_slprop = () in + let h1: unit = () in + let h2: unit = () in let st : st_term = wtag (Some STT_Ghost) (Tm_ElimExists { p = tm_exists_sl u (as_binder b.binder_ty) body }) in - let typing: st_typing g st c = () in - let h: tot_typing g (tm_star frame (comp_pre c)) tm_slprop = () in + let typing: unit = () in + let h: unit = () in let c_post_x = open_term' body (mk_reveal u b.binder_ty (term_of_nvar x)) 0 in assume open_term (comp_post c) (snd x) == c_post_x; - let h2: slprop_equiv g' (tm_star c_post_x frame) (tm_star frame c_post_x) = () in + let h2: unit = () in let k: continuation_elaborator g (tm_star frame (tm_exists_sl u b body)) g' (tm_star c_post_x frame) = continuation_elaborator_with_bind frame c st typing h x in k_elab_equiv (frame `tm_star` tm_exists_sl u b body) (frame `tm_star` c_post_x) k () h2 post t @@ -666,8 +655,8 @@ let elim_exists_step (g: env) (ctxt: slprop_view) : let result = open_term' body (mk_reveal u b.binder_ty (term_of_nvar x)) 0 in Some (| g', [Unknown result], [], [], fun g'' -> (fun frame -> - let h1: slprop_equiv g (tm_star (elab_slprops frame) (tm_exists_sl u b body)) (elab_slprops (frame @ [ctxt])) = () in - let h2: slprop_equiv g' (tm_star (elab_slprops frame) result) (elab_slprops (frame @ [] @ [Unknown result])) = () in + let h1: unit = () in + let h2: unit = () in k_elab_equiv (elab_slprops (frame @ [ctxt])) (elab_slprops (frame @ [] @ [Unknown result])) (elim_exists g (elab_slprops frame) u b body x g') h1 h2), cont_elab_refl _ _ _ (()) <: T.Tac _ |) @@ -689,7 +678,7 @@ open Pulse.PP module RT = FStar.Reflection.Typing let check_slprop_equiv_ext r (g:env) (p q:slprop) -: T.Tac (slprop_equiv g p q) +: T.Tac (unit) = let p = RU.deep_compress_safe p in let q = RU.deep_compress_safe q in @@ -928,9 +917,9 @@ let prove_atom_unamb (g: env) (ctxt: list slprop_view) (goal: slprop_view) : debug_prover g (fun _ -> Printf.sprintf "prove_atom_unamb: result of unify %s and %s is %s\n" (show (elab_slprop cand)) (show goal) (show ok)); let rest_ctxt = List.Tot.filter (fun (j, _) -> j <> i) ictxt |> List.Tot.map snd in Some (| g, rest_ctxt, [], [cand], fun g' -> - let h2: slprop_equiv g' (elab_slprop cand) goal = check_slprop_equiv_ext (RU.range_of_term goal) _ _ _ in - let h1: slprop_equiv g (elab_slprops ctxt) (elab_slprops ([cand] @ rest_ctxt)) = () in - let h2: slprop_equiv g' (elab_slprops ([cand] @ [])) goal = h2 in + let h2: unit = check_slprop_equiv_ext (RU.range_of_term goal) g (elab_slprop cand) goal in + let h1: unit = () in + let h2: unit = h2 in cont_elab_refl _ _ _ h1, cont_elab_refl _ _ _ h2 <: T.Tac _ |) @@ -957,9 +946,9 @@ let prove_atom (g: env) (ctxt: list slprop_view) (allow_amb: bool) (goal: slprop debug_prover g (fun _ -> Printf.sprintf "prove_atom: unified %s and %s, result is %s\n" (show (elab_slprop cand)) (show goal) (show ok)); let rest_ctxt = List.Tot.filter (fun (j, _) -> j <> i) ictxt |> List.Tot.map snd in Some (| g, rest_ctxt, [], [cand], fun g' -> - let h2: slprop_equiv g' (elab_slprop cand) goal = check_slprop_equiv_ext (RU.range_of_term goal) _ _ _ in - let h1: slprop_equiv g (elab_slprops ctxt) (elab_slprops ([cand] @ rest_ctxt)) = () in - let h2: slprop_equiv g' (elab_slprops ([cand] @ [])) goal = h2 in + let h2: unit = check_slprop_equiv_ext (RU.range_of_term goal) g (elab_slprop cand) goal in + let h1: unit = () in + let h2: unit = h2 in cont_elab_refl _ _ _ h1, cont_elab_refl _ _ _ h2 <: T.Tac _ @@ -1032,13 +1021,12 @@ let try_apply_elim_lemma (g: env) (lid: R.name) (i: nat) (ctxt: slprop_view) : Some (| g, [Unknown post'], [], [], fun g'' -> let typing = core_check_term g t T.E_Ghost ty in let t' = wtag (Some STT_Ghost) (Tm_ST { t; args=[] }) in - let ni: non_informative g c = () in - let typing: st_typing g t' c = () in - let h1: tot_typing g (comp_pre c) tm_slprop = () in - let h2: slprop_equiv g (elab_slprops [Unknown (comp_pre c)]) (elab_slprops [ctxt]) = + let ni: unit = () in + let typing: unit = () in + let h1: unit = () in + let h2: unit = assume elab_slprop ctxt == pre; () in - let h3: slprop_equiv g (elab_slprops [Unknown (open_term' (comp_post c) unit_const 0)]) - (elab_slprops ([] @ [Unknown post'])) = () in + let h3: unit = () in let k_t = cont_elab_with_bind_nondep_unit c t' typing h1 in cont_elab_equiv k_t h2 h3, cont_elab_refl g'' ([] @ []) [] (()) |) @@ -1076,11 +1064,11 @@ let try_apply_eager_intro_lemma (g: env) (lid: R.name) (i: nat) ctxt (goal: slpr Some (| g, ctxt, [Unknown pre], [], fun g'' -> let typing = core_check_term g'' t T.E_Ghost ty in let t' = wtag (Some STT_Ghost) (Tm_ST { t; args=[] }) in - let ni: non_informative g'' c = () in - let typing: st_typing g'' t' c = () in - let h1: tot_typing g'' (comp_pre c) tm_slprop = () in - let h2: slprop_equiv g'' (elab_slprops [Unknown (comp_pre c)]) (elab_slprops ([] @ [Unknown pre])) = () in - let h3: slprop_equiv g'' (elab_slprops [Unknown (open_term' (comp_post c) unit_const 0)]) (elab_slprops [goal]) = () in + let ni: unit = () in + let typing: unit = () in + let h1: unit = () in + let h2: unit = () in + let h3: unit = () in let k_typing = cont_elab_with_bind_nondep_unit c t' typing h1 in cont_elab_refl g ctxt ([] @ ctxt) (()), cont_elab_equiv k_typing h2 h3 @@ -1137,7 +1125,7 @@ let prover_result_solved_unpack #g #ctxt #goals (res: prover_result_solved g ctx let (| g', ctxt', goals', solved, k |) = res in (| g', ctxt', cont_elab_thunk fun _ -> let k1, k2 = k g' in - let h: slprop_equiv g' (elab_slprops (solved @ ctxt')) (elab_slprops (ctxt' @ solved @ goals')) = () in + let h: unit = () in cont_elab_trans k1 (cont_elab_frame k2 ctxt') h |) #restart-solver @@ -1180,14 +1168,12 @@ let try_apply_intro_lemma (g: env) (lid: R.name) (i: nat) ctxt (goal: slprop_vie let c = C_STGhost inames { pre; post; res; u } in let typing = core_check_term g' t T.E_Ghost ty in let t' = wtag (Some STT_Ghost) (Tm_ST { t; args=[] }) in - let ni: non_informative g' c = () in - let typing: st_typing g' t' c = () in - let h1: tot_typing g' (comp_pre c) tm_slprop = () in - let h2: slprop_equiv g' (elab_slprops (ctxt' @ [Unknown (comp_pre c)])) (elab_slprops (ctxt' @ [Unknown pre])) = + let ni: unit = () in + let typing: unit = () in + let h1: unit = () in + let h2: unit = () in - let h3: slprop_equiv g' - (elab_slprops (ctxt' @ [Unknown (open_term' (comp_post c) unit_const 0)])) - (elab_slprops ([goal] @ ctxt' @ post''_rest)) = () in + let h3: unit = () in let k_typing = cont_elab_with_bind_nondep_unit c t' typing h1 in let k_typing = cont_elab_frame k_typing ctxt' in let k_typing: cont_elab g' (ctxt' @ [Unknown pre]) g' ([goal] @ ctxt' @ post''_rest) = @@ -1338,8 +1324,8 @@ let try_prove (g: env) (ctxt goals: slprop) allow_amb : T.Tac (prover_result g [ let (| g1, ctxt1, goals1, solved1, k1 |) = try_prove_core pg [Unknown ctxt'] [Unknown goals'] in (| g1, ctxt1, goals1, solved1, fun (g2: env { env_extends g2 g1 }) -> let before, after = k1 g2 in - let h1: slprop_equiv g ctxt' ctxt = () in - let h2: slprop_equiv g2 goals' goals = () in + let h1: unit = () in + let h2: unit = () in cont_elab_equiv before h1 (()), cont_elab_equiv after (()) h2 |) @@ -1361,9 +1347,7 @@ let prove rng (g: env) (ctxt goals: slprop) allow_amb : (Some rng) else let (| g', ctxt', k |) = prover_result_solved_unpack res in - let h: slprop_equiv g' - (elab_slprops ([] @ ctxt' @ [Unknown goals])) - (tm_star goals (RU.deep_compress_safe (elab_slprops ctxt'))) = () in + let h: unit = () in (| g', RU.deep_compress_safe (elab_slprops ctxt'), k_elab_equiv ctxt (tm_star goals (RU.deep_compress_safe (elab_slprops ctxt'))) (k []) () h |) let rec try_elim_core (pg: penv) (ctxt: list slprop_view) : @@ -1387,37 +1371,37 @@ let rec try_elim_core (pg: penv) (ctxt: list slprop_view) : | None -> noop () let elim_exists_and_pure (#g:env) (#ctxt:slprop) - (ctxt_typing:tot_typing g ctxt tm_slprop) + (ctxt_typing:unit) : T.Tac (g':env { env_extends g' g } & ctxt':term & - tot_typing g' ctxt' tm_slprop & + unit & continuation_elaborator g ctxt g' ctxt') = let ss = Pulse.Checker.Prover.RewritesTo.get_subst_from_env g in let ctxt' = Pulse.Checker.Prover.Substs.ss_term ctxt ss in let pg = mk_penv g false in let (| g', ctxt'', goals'', solved, k |) = try_elim_core pg [Unknown ctxt'] in - let h: tot_typing g' (elab_slprops ctxt'') tm_slprop = () in // TODO thread through prover + let h: unit = () in // TODO thread through prover (| g', elab_slprops ctxt'', h, fun post_hint post_hint_typ -> - let h1: slprop_equiv g (elab_slprops ([] @ [Unknown ctxt'])) ctxt = (RU.magic() <: slprop_equiv g ctxt' ctxt) in - let h2: slprop_equiv g' (elab_slprops (ctxt'' @ solved @ goals'')) (elab_slprops ([] @ solved @ ctxt'')) = () in - let h3: slprop_equiv g' (elab_slprops (ctxt'' @ [])) (elab_slprops ctxt'') = () in + let h1: unit = (RU.magic() <: unit) in + let h2: unit = () in + let h3: unit = () in let before, after = k g' in k_elab_trans (k_elab_equiv ctxt (elab_slprops ([] @ solved @ ctxt'')) (before []) h1 (())) (k_elab_equiv (elab_slprops ([] @ solved @ ctxt'')) (elab_slprops ctxt'') (after ctxt'') h2 h3) post_hint post_hint_typ |) let k_unreach (g: env) (x: nvar { freshv g (snd x) }) (post_hint: post_hint_t { g `env_extends` post_hint.g }) : T.Tac (continuation_elaborator g tm_is_unreachable (push_binding g (snd x) (fst x) post_hint.ret_ty) (open_term_nv post_hint.post x)) = - let h: tot_typing g tm_is_unreachable tm_slprop = () in + let h: unit = () in let c = Pulse.Typing.Combinators.comp_for_post_hint g tm_is_unreachable h post_hint (snd x) in let st = wtag (Some (ctag_of_comp_st c)) (Tm_Unreachable { c }) in - let typ : st_typing g st c = () in + let typ : unit = () in let g' = push_binding g (snd x) (fst x) post_hint.ret_ty in let post_opened = open_term_nv post_hint.post x in let k_elim: continuation_elaborator g (tm_star tm_emp tm_is_unreachable) g' (tm_star post_opened tm_emp) = - let h3: tot_typing g (tm_star tm_emp tm_is_unreachable) tm_slprop = () in + let h3: unit = () in continuation_elaborator_with_bind #g tm_emp c st typ h3 x in - let h4: slprop_equiv g (tm_star tm_emp tm_is_unreachable) tm_is_unreachable = () in - let h5: slprop_equiv g' (tm_star post_opened tm_emp) post_opened = () in + let h4: unit = () in + let h5: unit = () in k_elab_equiv tm_is_unreachable post_opened k_elim h4 h5 #restart-solver @@ -1445,8 +1429,8 @@ let prove_post_hint (#g:env) (#ctxt:slprop) (r:checker_result_t g ctxt NoHint) ( let ppname = mk_ppname_no_range "_posth" in let post_hint_opened = open_term_nv post_hint.post (ppname, y) in let g4 = push_binding g3 y ppname post_hint.ret_ty in - let h1: universe_of g4 post_hint.ret_ty post_hint.u = () in - let h2: tot_typing g4 post_hint_opened tm_slprop = () in + let h1: unit = () in + let h2: unit = () in let k_unreach: continuation_elaborator g3 ctxt3 g4 post_hint_opened = k_unreach g3 (ppname, y) post_hint in (| y, g4, (post_hint.u, post_hint.ret_ty), post_hint_opened, @@ -1477,22 +1461,22 @@ let prove_post_hint (#g:env) (#ctxt:slprop) (r:checker_result_t g ctxt NoHint) ( else text "Did you forget to free this resource?"); ] else - let h3: slprop_equiv g3 (tm_star post_hint_opened remaining_ctxt) post_hint_opened = () in + let h3: unit = () in // for the typing of ty in g3, we have typing of ty in g2 above, and g3 `env_extends` g2 - let h1: universe_of g3 ty u_ty = () in + let h1: unit = () in // for the typing of post_hint_opened, again post_hint is well-typed in g, and g3 `env_extends` g - let h2: tot_typing g3 post_hint_opened tm_slprop = () in + let h2: unit = () in (| x, g3, (u_ty, ty), post_hint_opened, k_elab_trans k (k_elab_equiv ctxt' post_hint_opened k_post () h3) |) #pop-options let try_frame_pre (allow_ambiguous : bool) (#g:env) - (#ctxt:slprop) (ctxt_typing:tot_typing g ctxt tm_slprop) + (#ctxt:slprop) (ctxt_typing:unit) (d:(t:st_term & c:comp_st)) (res_ppname:ppname) : T.Tac (checker_result_t g ctxt NoHint) = let (| t, c |) = d in let (| g', ctxt', k |) = prove t.range g ctxt (comp_pre c) allow_ambiguous in - let d: st_typing g' t c = () in // weakening from g to g' - let h1: tot_typing g' ctxt' tm_slprop = () in // weakening from to g' + let d: unit = () in // weakening from g to g' + let h1: unit = () in // weakening from to g' checker_result_for_st_typing (k _ (| t, add_frame c ctxt' |)) res_ppname \ No newline at end of file diff --git a/src/checker/Pulse.Checker.Prover.fsti b/src/checker/Pulse.Checker.Prover.fsti index d76be2d15..fa43e8e75 100644 --- a/src/checker/Pulse.Checker.Prover.fsti +++ b/src/checker/Pulse.Checker.Prover.fsti @@ -32,17 +32,17 @@ val prove (rng: range) (g: env) (ctxt goals: slprop) (allow_amb: bool) : continuation_elaborator g ctxt g' (goals `tm_star` ctxt')) val elim_exists_and_pure (#g:env) (#ctxt:slprop) - (ctxt_typing:tot_typing g ctxt tm_slprop) + (ctxt_typing:unit) : T.Tac (g':env { env_extends g' g } & ctxt':term & - tot_typing g' ctxt' tm_slprop & + unit & continuation_elaborator g ctxt g' ctxt') val prove_post_hint (#g:env) (#ctxt:slprop) (r:checker_result_t g ctxt NoHint) (post_hint:post_hint_opt g) (rng:range) : T.Tac (checker_result_t g ctxt post_hint) val try_frame_pre (allow_ambiguous : bool) (#g:env) - (#ctxt:slprop) (ctxt_typing:tot_typing g ctxt tm_slprop) + (#ctxt:slprop) (ctxt_typing:unit) (d:(t:st_term & c:comp_st)) (res_ppname:ppname) : T.Tac (checker_result_t g ctxt NoHint) \ No newline at end of file diff --git a/src/checker/Pulse.Checker.Pure.fst b/src/checker/Pulse.Checker.Pure.fst index 3a82e8ee9..e196023f7 100644 --- a/src/checker/Pulse.Checker.Pure.fst +++ b/src/checker/Pulse.Checker.Pure.fst @@ -145,7 +145,7 @@ let squash_prop_validity_token f p (t:prop_validity_token f (mk_squash0 p)) : prop_validity_token f p = admit(); t -let rtb_check_prop_validity (g:env) (sync:bool) (f:_{f == elab_env g }) (p:_) (pf:tot_typing g p tm_prop) = +let rtb_check_prop_validity (g:env) (sync:bool) (f:_{f == elab_env g }) (p:_) (pf:unit) = let _ : squash (typing_token f p (E_Total, tm_prop)) = magic () in @@ -523,7 +523,7 @@ let check_slprop_with_core (g:env) let non_informative_class_typing - (g:env) (u:universe) (ty:typ) (ty_typing : universe_of g ty u) + (g:env) (u:universe) (ty:typ) (ty_typing : unit) : my_erased (typing_token (elab_env g) (non_informative_class u ty) (E_Total, R.pack_ln (R.Tv_Type u))) = E (magic()) @@ -551,7 +551,7 @@ let non_info_squash_tm (u:universe) (t:term) : term = To do so, we simply create that constraint (and prove it's well-typed), and then call the tcresolve typeclass resolution tactic on it to obtain a dictionary and a proof of typing for the dictionary. *) -let try_get_non_informative_witness_aux (g:env) (u:universe) (ty:term) (ty_typing:universe_of g ty u) +let try_get_non_informative_witness_aux (g:env) (u:universe) (ty:term) (ty_typing:unit) : T.Tac (option (non_informative_t g u ty) & issues) = let goal = non_informative_class u ty in let r_env = elab_env g in @@ -597,7 +597,7 @@ let try_get_non_informative_witness_aux (g:env) (u:universe) (ty:term) (ty_typin let dict = wr r_dict (RU.range_of_term ty) in let r_dict_typing_token : squash (typing_token r_env r_dict (E_Total, goal)) = () in let r_dict_typing : RT.typing r_env r_dict (E_Total, goal) = RT.T_Token _ _ _ () in - let dict_typing : tot_typing g dict (non_informative_class u ty) = () in + let dict_typing : unit = () in Some dict, issues ) diff --git a/src/checker/Pulse.Checker.Return.fst b/src/checker/Pulse.Checker.Return.fst index 225148869..1c6cd14ef 100644 --- a/src/checker/Pulse.Checker.Return.fst +++ b/src/checker/Pulse.Checker.Return.fst @@ -63,8 +63,8 @@ type result_of_typing (g:env) = t:term -> u:universe -> ty:term -> - universe_of g ty u -> - typing g t (eff_of_ctag c) ty -> + unit -> + unit -> result_of_typing g let compute_tot_or_ghost_term_type_and_u (g:env) (e:term) (c:option ctag) @@ -79,7 +79,7 @@ let compute_tot_or_ghost_term_type_and_u (g:env) (e:term) (c:option ctag) let check_core (g:env) (ctxt:term) - (ctxt_typing:tot_typing g ctxt tm_slprop) + (ctxt_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (st:st_term { Tm_Return? st.term }) @@ -141,7 +141,7 @@ let check_core let post = close_term post_opened x in let ret_st = wtag (Some c) (Tm_Return {expected_type=tm_unknown; insert_eq=use_eq; term=t}) in let ret_c = comp_return c use_eq u ty t post x in - let d : st_typing g ret_st ret_c = () in + let d : unit = () in let c' = match_comp_res_with_post_hint ret_st ret_c d post_hint in Pulse.Checker.Util.debug g "pulse.return" (fun _ -> Printf.sprintf "Return comp is: %s" @@ -155,7 +155,7 @@ let check_core let check (g:env) (ctxt:term) - (ctxt_typing:tot_typing g ctxt tm_slprop) + (ctxt_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (st:st_term { Tm_Return? st.term }) diff --git a/src/checker/Pulse.Checker.Return.fsti b/src/checker/Pulse.Checker.Return.fsti index dcb931d6a..d435bb78a 100644 --- a/src/checker/Pulse.Checker.Return.fsti +++ b/src/checker/Pulse.Checker.Return.fsti @@ -25,7 +25,7 @@ module T = FStar.Tactics.V2 val check (g:env) (ctxt:term) - (ctxt_typing:tot_typing g ctxt tm_slprop) + (ctxt_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (st:st_term { Tm_Return? st.term }) diff --git a/src/checker/Pulse.Checker.Rewrite.fst b/src/checker/Pulse.Checker.Rewrite.fst index a9447fc24..146cac261 100644 --- a/src/checker/Pulse.Checker.Rewrite.fst +++ b/src/checker/Pulse.Checker.Rewrite.fst @@ -29,7 +29,7 @@ module RT = FStar.Reflection.Typing module RU = Pulse.RuntimeUtils let check_slprop_equiv_ext r (g:env) (p q:slprop) -: T.Tac (slprop_equiv g p q) +: T.Tac (unit) = let res, issues = Pulse.Typing.Util.check_equiv_now (elab_env g) p q in match res with | None -> @@ -42,7 +42,7 @@ let check_slprop_equiv_ext r (g:env) (p q:slprop) () let check_slprop_equiv_tac r (g:env) (p q:slprop) (tac_tm : term) -: T.Tac (slprop_equiv g p q) +: T.Tac (unit) = let open FStar.Reflection.Typing in let open FStar.Stubs.TypeChecker.Core in begin match T.inspect tac_tm with @@ -78,7 +78,7 @@ let check_slprop_equiv_tac r (g:env) (p q:slprop) (tac_tm : term) () let rec check_slprop_equiv r (g:env) (p q:slprop) -: T.Tac (slprop_equiv g p q) +: T.Tac (unit) = if eq_tm p q then () else ( @@ -107,7 +107,7 @@ let rec check_slprop_equiv r (g:env) (p q:slprop) let check (g:env) (pre:term) - (pre_typing:tot_typing g pre tm_slprop) + (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term{Tm_Rewrite? t.term}) @@ -139,6 +139,6 @@ let check in let rew_st = wtag (Some STT_Ghost) (Tm_Rewrite { t1=p; t2=q; tac_opt=None; elaborated=true }) in let rew_c = C_STGhost tm_emp_inames { u=u0; res=tm_unit; pre=p; post=q } in - let d : st_typing g rew_st rew_c = () in + let d : unit = () in let c = match_comp_res_with_post_hint rew_st rew_c d post_hint in prove_post_hint (try_frame_pre false pre_typing (| rew_st,c |) res_ppname) post_hint t.range diff --git a/src/checker/Pulse.Checker.Rewrite.fsti b/src/checker/Pulse.Checker.Rewrite.fsti index 29a07071f..ee639251e 100644 --- a/src/checker/Pulse.Checker.Rewrite.fsti +++ b/src/checker/Pulse.Checker.Rewrite.fsti @@ -25,7 +25,7 @@ module T = FStar.Tactics.V2 val check (g:env) (pre:term) - (pre_typing:tot_typing g pre tm_slprop) + (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_Rewrite? t.term }) diff --git a/src/checker/Pulse.Checker.SLPropEquiv.fst b/src/checker/Pulse.Checker.SLPropEquiv.fst index 1f853be08..73cb8faf5 100644 --- a/src/checker/Pulse.Checker.SLPropEquiv.fst +++ b/src/checker/Pulse.Checker.SLPropEquiv.fst @@ -19,18 +19,15 @@ open Pulse.Syntax open Pulse.Typing open FStar.List.Tot -let ve_unit_r g (p:term) : slprop_equiv g (tm_star p tm_emp) p = +let ve_unit_r g (p:term) : unit = () let rec list_as_slprop_append g (vp0 vp1:list term) - : GTot (slprop_equiv g (list_as_slprop (vp0 @ vp1)) - (tm_star (list_as_slprop vp0) - (list_as_slprop vp1))) + : GTot (unit) (decreases vp0) = match vp0 with | [] -> - let v : slprop_equiv g (list_as_slprop vp1) - (tm_star tm_emp (list_as_slprop vp1)) = () + let v : unit = () in v | [hd] -> @@ -41,33 +38,29 @@ let rec list_as_slprop_append g (vp0 vp1:list term) end | hd::tl -> let tl_vp1 = list_as_slprop_append g tl vp1 in - let d : slprop_equiv g (list_as_slprop (vp0 @ vp1)) - (tm_star hd (tm_star (list_as_slprop tl) (list_as_slprop vp1))) + let d : unit = () in - let d : slprop_equiv g (list_as_slprop (vp0 @ vp1)) - (tm_star (tm_star hd (list_as_slprop tl)) (list_as_slprop vp1)) + let d : unit = () in d let list_as_slprop_comm g (vp0 vp1:list term) - : GTot (slprop_equiv g (list_as_slprop (vp0 @ vp1)) - (list_as_slprop (vp1 @ vp0))) + : GTot (unit) = let d1 : _ = list_as_slprop_append g vp0 vp1 in let d2 : _ = list_as_slprop_append g vp1 vp0 in () let list_as_slprop_assoc g (vp0 vp1 vp2:list term) - : GTot (slprop_equiv g (list_as_slprop (vp0 @ (vp1 @ vp2))) - (list_as_slprop ((vp0 @ vp1) @ vp2))) + : GTot (unit) = List.Tot.append_assoc vp0 vp1 vp2; () let list_as_slprop_ctx g (vp0 vp0' vp1 vp1':list term) - (d0:slprop_equiv g (list_as_slprop vp0) (list_as_slprop vp0')) - (d1:slprop_equiv g (list_as_slprop vp1) (list_as_slprop vp1')) - : GTot (slprop_equiv g (list_as_slprop (vp0 @ vp1)) (list_as_slprop (vp0' @ vp1'))) + (d0:unit) + (d1:unit) + : GTot (unit) = let split_app = list_as_slprop_append g vp0 vp1 in let split_app' = list_as_slprop_append g vp0' vp1' in @@ -75,13 +68,13 @@ let list_as_slprop_ctx g (vp0 vp0' vp1 vp1':list term) let list_as_slprop_singleton g (p q:term) - (d:slprop_equiv g p q) - : GTot (slprop_equiv g (list_as_slprop [p]) (list_as_slprop [q])) + (d:unit) + : GTot (unit) = d let rec slprop_list_equiv (g:env) (vp:term) - : GTot (slprop_equiv g vp (canon_slprop vp)) + : GTot (unit) (decreases vp) = match inspect_term vp with | Tm_Emp -> () @@ -89,60 +82,49 @@ let rec slprop_list_equiv (g:env) let eq0 = slprop_list_equiv g vp0 in let eq1 = slprop_list_equiv g vp1 in let app_eq - : slprop_equiv g (canon_slprop vp) (tm_star (canon_slprop vp0) (canon_slprop vp1)) + : unit = list_as_slprop_append g (slprop_as_list vp0) (slprop_as_list vp1) in () | _ -> () -let slprop_equiv_swap_equiv (g:_) +let slprop_equiv_swap_equiv (g:env) (l0 l2:list term) - (p q:term) (d_p_q:slprop_equiv g p q) - : slprop_equiv g (list_as_slprop ((l0 @ [q]) @ l2)) - (list_as_slprop ([p] @ (l0 @ l2))) - = let d : slprop_equiv g (list_as_slprop ((l0 @ [q]) @ l2)) - (list_as_slprop (([q] @ l0) @ l2)) + (p q:term) (d_p_q:unit) + : unit + = let d : unit = () in - let d' : slprop_equiv g (list_as_slprop (([q] @ l0) @ l2)) - (list_as_slprop ([q] @ (l0 @ l2))) + let d' : unit = List.Tot.append_assoc [q] l0 l2; () in - let d : slprop_equiv g (list_as_slprop ((l0 @ [q]) @ l2)) - (list_as_slprop ([q] @ (l0 @ l2))) + let d : unit = () in let d_q_p = d_p_q in - let d' : slprop_equiv g (list_as_slprop [q]) (list_as_slprop [p]) = d_q_p in - let d' : slprop_equiv g (list_as_slprop ([q] @ (l0 @ l2))) - (list_as_slprop ([p] @ (l0 @ l2))) + let d' : unit = d_q_p in + let d' : unit = () in () -let slprop_equiv_split_frame (g:_) (ctxt req:term) (frame:list term) - (veq:slprop_equiv g (list_as_slprop (slprop_as_list req @ frame)) - (list_as_slprop (slprop_as_list ctxt))) - : slprop_equiv g (tm_star req (list_as_slprop frame)) ctxt +let slprop_equiv_split_frame (g:env) (ctxt req:term) (frame:list term) + (veq:unit) + : unit = let ctxt_l = slprop_as_list ctxt in let req_l = slprop_as_list req in - let veq : slprop_equiv g (list_as_slprop (req_l @ frame)) - (list_as_slprop ctxt_l) = veq in + let veq : unit = veq in let d1 - : slprop_equiv g (tm_star (canon_slprop req) (list_as_slprop frame)) - (list_as_slprop (req_l @ frame)) + : unit = () in let d1 - : slprop_equiv g (tm_star req (list_as_slprop frame)) - (list_as_slprop (req_l @ frame)) + : unit = () in - let d : slprop_equiv g (tm_star req (list_as_slprop frame)) - (canon_slprop ctxt) = + let d : unit = () in - let d : slprop_equiv g (tm_star req (list_as_slprop frame)) - ctxt = + let d : unit = () in d diff --git a/src/checker/Pulse.Checker.SLPropEquiv.fsti b/src/checker/Pulse.Checker.SLPropEquiv.fsti index c797da3f9..1c7f3cd02 100644 --- a/src/checker/Pulse.Checker.SLPropEquiv.fsti +++ b/src/checker/Pulse.Checker.SLPropEquiv.fsti @@ -27,52 +27,46 @@ let canon_slprop (vp:term) : term = list_as_slprop (slprop_as_list vp) -val ve_unit_r (g:env) (p:term) : slprop_equiv g (tm_star p tm_emp) p +val ve_unit_r (g:env) (p:term) : unit val list_as_slprop_append (g:env) (vp0 vp1:list term) - : GTot (slprop_equiv g (list_as_slprop (vp0 @ vp1)) - (tm_star (list_as_slprop vp0) - (list_as_slprop vp1))) + : GTot (unit) val list_as_slprop_comm (g:env) (vp0 vp1:list term) - : GTot (slprop_equiv g (list_as_slprop (vp0 @ vp1)) - (list_as_slprop (vp1 @ vp0))) + : GTot (unit) val list_as_slprop_assoc (g:env) (vp0 vp1 vp2:list term) - : GTot (slprop_equiv g (list_as_slprop (vp0 @ (vp1 @ vp2))) - (list_as_slprop ((vp0 @ vp1) @ vp2))) + : GTot (unit) val list_as_slprop_ctx (g:env) (vp0 vp0' vp1 vp1':list term) - (_:slprop_equiv g (list_as_slprop vp0) (list_as_slprop vp0')) - (_:slprop_equiv g (list_as_slprop vp1) (list_as_slprop vp1')) - : GTot (slprop_equiv g (list_as_slprop (vp0 @ vp1)) (list_as_slprop (vp0' @ vp1'))) + (_:unit) + (_:unit) + : GTot (unit) -val list_as_slprop_singleton (g:env) (p q:term) (d:slprop_equiv g p q) - : GTot (slprop_equiv g (list_as_slprop [p]) (list_as_slprop [q])) +val list_as_slprop_singleton (g:env) (p q:term) (d:unit) + : GTot (unit) val slprop_list_equiv (g:env) (vp:term) - : GTot (slprop_equiv g vp (canon_slprop vp)) + : GTot (unit) -val slprop_equiv_swap_equiv (g:_) (l0 l2:list term) - (p q:term) (d_p_q:slprop_equiv g p q) - : GTot (slprop_equiv g (list_as_slprop ((l0 @ [q]) @ l2)) - (list_as_slprop ([p] @ (l0 @ l2)))) +val slprop_equiv_swap_equiv (g:env) (l0 l2:list term) + (p q:term) (d_p_q:unit) + : GTot (unit) -val slprop_equiv_split_frame (g:_) (ctxt req:term) (frame:list term) - (d:slprop_equiv g (list_as_slprop (slprop_as_list req @ frame)) - (list_as_slprop (slprop_as_list ctxt))) - : slprop_equiv g (tm_star req (list_as_slprop frame)) ctxt +val slprop_equiv_split_frame (g:env) (ctxt req:term) (frame:list term) + (d:unit) + : unit -let slprop_equiv_typing_fwd (#g:env) (#ctxt:_) (ctxt_typing:tot_typing g ctxt tm_slprop) - (p:_) (d:slprop_equiv g ctxt p) - : tot_typing g p tm_slprop +let slprop_equiv_typing_fwd (#g:env) (#ctxt:term) (ctxt_typing:unit) + (p:term) (d:unit) + : unit = let fwd, _ = slprop_equiv_typing g ctxt p d in fwd ctxt_typing -let slprop_equiv_typing_bk (#g:env) (#ctxt:_) (ctxt_typing:tot_typing g ctxt tm_slprop) - (p:_) (d:slprop_equiv g p ctxt) - : tot_typing g p tm_slprop +let slprop_equiv_typing_bk (#g:env) (#ctxt:term) (ctxt_typing:unit) + (p:term) (d:unit) + : unit = let _, bk = slprop_equiv_typing g p ctxt d in bk ctxt_typing diff --git a/src/checker/Pulse.Checker.ST.fst b/src/checker/Pulse.Checker.ST.fst index 906514db8..5c514cb0b 100644 --- a/src/checker/Pulse.Checker.ST.fst +++ b/src/checker/Pulse.Checker.ST.fst @@ -38,7 +38,7 @@ open Pulse.PP let check (g:env) (ctxt:slprop) - (ctxt_typing:tot_typing g ctxt tm_slprop) + (ctxt_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_ST? t.term }) @@ -80,7 +80,7 @@ let check let eff = core_check_term_at_type g' e ty in let t = { t with term = Tm_ST { t=e; args=[] }; effect_tag = T.seal (Some (ctag_of_comp_st c)) } in - let d : st_typing g' t c = + let d : unit = if eff = T.E_Total then () else ( @@ -93,7 +93,7 @@ let check text "has computation type"; pp c] | C_STGhost .. -> - let d_non_info : non_informative g' c = + let d_non_info : unit = let token = is_non_informative g' c in match token with | None -> @@ -105,7 +105,7 @@ let check () ) in - let h: tot_typing g' ctxt' tm_slprop = () in // TODO: thread through prover + let h: unit = () in // TODO: thread through prover if comp_post c `eq_tm` tm_is_unreachable then let framed = checker_result_for_st_typing (k _ (| t, add_frame c ctxt' |)) res_ppname in RU.record_stats "prove_post_hint" fun _ -> prove_post_hint framed post_hint range diff --git a/src/checker/Pulse.Checker.ST.fsti b/src/checker/Pulse.Checker.ST.fsti index e038f602f..0b071829f 100644 --- a/src/checker/Pulse.Checker.ST.fsti +++ b/src/checker/Pulse.Checker.ST.fsti @@ -25,7 +25,7 @@ open Pulse.Checker.Base val check (g:env) (pre:term) - (pre_typing:tot_typing g pre tm_slprop) + (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term{Tm_ST? t.term}) diff --git a/src/checker/Pulse.Checker.While.fst b/src/checker/Pulse.Checker.While.fst index 39b8ada24..e6da684c8 100644 --- a/src/checker/Pulse.Checker.While.fst +++ b/src/checker/Pulse.Checker.While.fst @@ -30,22 +30,22 @@ module RU = Pulse.RuntimeUtils let empty_env g = mk_env (fstar_env g) let push_empty_env_idem (g:env) : Lemma (push_env g (empty_env g) == g)[SMTPat (push_env g (empty_env g))] = admit() -let body_typing_subst_true #g #x #post (_:tot_typing (push_binding g x ppname_default tm_bool) (open_term post x) tm_slprop) -: tot_typing g (open_term' post tm_true 0) tm_slprop = admit() -let body_typing_ex #g #x #post (_:tot_typing (push_binding g x ppname_default tm_bool) (open_term post x) tm_slprop) -: tot_typing g (tm_exists_sl u0 (as_binder tm_bool) post) tm_slprop = admit() -let unit_typing g : universe_of g tm_unit u0 = admit() +let body_typing_subst_true #g #x #post (_:unit) +: unit = admit() +let body_typing_ex #g #x #post (_:unit) +: unit = admit() +let unit_typing g : unit = admit() -let inv_typing_weakening (#g:env) (#inv:slprop) (inv_typing:tot_typing g inv tm_slprop) +let inv_typing_weakening (g:env) (inv:slprop) (inv_typing:unit) : (x:FStar.Ghost.erased var {fresh_wrt x g (freevars inv)}) = let x : (x:FStar.Ghost.erased var {fresh_wrt x g (freevars inv)}) = RU.magic () in x -let inv_as_post_hint (#g:env) (#inv:slprop) (inv_typing:tot_typing g inv tm_slprop) +let inv_as_post_hint (g:env) (inv:slprop) (inv_typing:unit) : T.Tac (ph:post_hint_for_env g { ph.post == inv /\ ph.ret_ty == tm_unit /\ ph.u == u0 /\ ph.effect_annot == EffectAnnotSTT }) -= let x = inv_typing_weakening inv_typing in - { g; effect_annot=EffectAnnotSTT; effect_annot_typing=(); - ret_ty=tm_unit; u=u0; ty_typing=unit_typing g; post=inv } += let x = inv_typing_weakening g inv inv_typing in + { g; effect_annot=EffectAnnotSTT; + ret_ty=tm_unit; u=u0; post=inv } let tm_l_true : term = FStar.Reflection.V2.Formula.(formula_as_term True_) let tm_l_or (a b: term) : term = FStar.Reflection.V2.Formula.(formula_as_term (Or a b)) @@ -147,7 +147,7 @@ let rec build_tuple_info (infos: list (term & term & universe)) let check_while (g:env) (pre:term) - (pre_typing:tot_typing g pre tm_slprop) + (pre_typing:unit) (post_hint:post_hint_opt g {~ (PostHint? post_hint) }) (res_ppname:ppname) (t:st_term{Tm_While? t.term}) @@ -213,7 +213,7 @@ let check_while assume freshv g0 (snd x_meas); let g1 = push_binding g0 (snd x_meas) (fst x_meas) ty_meas in let inv = tm_star (RU.deep_compress_safe inv) remaining in - let inv_typing : tot_typing g1 inv tm_slprop = () in + let inv_typing : unit = () in let res_cond : checker_result_t g1 inv (TypeHint tm_bool) = check (push_context "check_while_condition" cond.range g1) inv inv_typing (TypeHint tm_bool) ppname_default cond in let (| post_cond, r_cond |) : (ph:post_hint_for_env g1 & Pulse.Typing.Combinators.st_typing_in_ctxt g1 inv (PostHint ph)) = @@ -246,12 +246,12 @@ let check_while assert g1 `env_extends` g0; assert g1' `env_extends` g1; assert g1'' `env_extends` g1'; - let loop_ensures_typ: tot_typing g1'' loop_ensures tm_slprop = () in - let unit_typ: universe_of g1'' tm_unit u0 = () in - let loop_ensures = Pulse.JoinComp.infer_post' g0 g1'' y unit_typ loop_ensures_typ in + let loop_ensures_typ: unit = () in + let unit_typ: unit = () in + let loop_ensures = Pulse.JoinComp.infer_post' g0 g1'' u0 tm_unit y () loop_ensures () in let loop_ensures = subst_loop_requires_marker_with_true loop_ensures.post in let loop_ensures = open_term' loop_ensures unit_const 0 in - let loop_ensures_typ: tot_typing g0 loop_ensures tm_slprop = () in + let loop_ensures_typ: unit = () in loop_ensures | None -> let t: term = tm_exists_sl u_meas (as_binder ty_meas) (close_term (open_term' post_cond.post tm_false 0) (snd x_meas)) in @@ -274,17 +274,17 @@ let check_while let post_cond : post_hint_for_env g2 = assume post_hint_for_env_p g2 post_cond; post_cond in let r_cond : Pulse.Typing.Combinators.st_typing_in_ctxt g2 inv (PostHint post_cond) = let (| t, c |) = r_cond in - let typ : st_typing g2 t c = () in + let typ : unit = () in (| t, c |) in let body_pre_open = post_cond.post in - let body_post_typing : tot_typing g2 (comp_post (comp_while_body u_meas ty_meas is_tot dec_formula x_meas inv body_pre_open)) tm_slprop = () in - let body_ph : post_hint_for_env g2 = inv_as_post_hint body_post_typing in + let body_post_typing : unit = () in + let body_ph : post_hint_for_env g2 = inv_as_post_hint g2 (comp_post (comp_while_body u_meas ty_meas is_tot dec_formula x_meas inv body_pre_open)) body_post_typing in assert body_ph.ret_ty == tm_unit; let x = fresh g2 in - let body_open_pre_typing : tot_typing (push_binding g2 x ppname_default tm_bool) (open_term body_pre_open x) tm_slprop = + let body_open_pre_typing : unit = () in - let body_pre_typing = body_typing_subst_true body_open_pre_typing in + let body_pre_typing = () in let r_body = check (push_context "check_while_body" body.range g2) @@ -298,13 +298,13 @@ let check_while assert (comp_u comp_body == comp_u (comp_while_body u_meas ty_meas is_tot dec_formula x_meas inv body_pre_open)); assert (comp_res comp_body == comp_res (comp_while_body u_meas ty_meas is_tot dec_formula x_meas inv body_pre_open)); assert (comp_body == comp_while_body u_meas ty_meas is_tot dec_formula x_meas inv body_pre_open); - let inv_typing2 : tot_typing g2 inv tm_slprop = () in + let inv_typing2 : unit = () in let while = wtag (Some STT) (Tm_While { invariant = inv; loop_requires = tm_unknown; meas = []; condition = cond; body }) in - let typ_meas: universe_of g1' ty_meas u_meas = () in + let typ_meas: unit = () in assume ~(snd x_meas `Set.mem` freevars_st cond); assume ~(snd x_meas `Set.mem` freevars_st body); - let d: st_typing g1' while (comp_while u_meas ty_meas x_meas inv body_pre_open) = + let d: unit = () in let C_ST cst = comp_while u_meas ty_meas x_meas inv body_pre_open in let loop_pre = tm_exists_sl u_meas (as_binder ty_meas) (close_term inv (snd x_meas)) in @@ -315,10 +315,8 @@ let check_while let post_hint_for_while : post_hint_for_env g0 = { g=g0; effect_annot=EffectAnnotSTT; - effect_annot_typing=(); ret_ty=RT.unit_ty; u=u_zero; - ty_typing=RU.magic(); //unit typing post=break_pred } in @@ -337,14 +335,14 @@ let check_while (Tm_ForwardJumpLabel { lbl = breaklbln; body = close_st_term while breaklblx; post = while_comp }) in admit (); assert break_lbl_c == goto_comp_of_block_comp while_comp; - let fjl_d: st_typing g0 fjl while_comp = + let fjl_d: unit = () in let d_st: Pulse.Typing.Combinators.st_typing_in_ctxt g0 loop_pre (TypeHint tm_unit) = (| fjl, while_comp |) in let d_st: Pulse.Typing.Combinators.st_typing_in_ctxt g0 loop_pre0 (TypeHint tm_unit) = let (| t, c |) = d_st in let c = with_st_comp c { st_comp_of_comp c with pre = loop_pre0 } in - let typ : st_typing g0 t c = () in + let typ : unit = () in (| t, c |) in let d_st : Pulse.Typing.Combinators.st_typing_in_ctxt g pre NoHint = k NoHint d_st in diff --git a/src/checker/Pulse.Checker.While.fsti b/src/checker/Pulse.Checker.While.fsti index 12070d4f0..af026c0dc 100644 --- a/src/checker/Pulse.Checker.While.fsti +++ b/src/checker/Pulse.Checker.While.fsti @@ -25,7 +25,7 @@ module T = FStar.Tactics.V2 val check_while (g:env) (pre:term) - (pre_typing:tot_typing g pre tm_slprop) + (pre_typing:unit) (post_hint:post_hint_opt g { ~ (PostHint? post_hint) }) (res_ppname:ppname) (t:st_term{Tm_While? t.term}) diff --git a/src/checker/Pulse.Checker.WithLocal.fst b/src/checker/Pulse.Checker.WithLocal.fst index fcd27a426..679daa310 100644 --- a/src/checker/Pulse.Checker.WithLocal.fst +++ b/src/checker/Pulse.Checker.WithLocal.fst @@ -42,11 +42,9 @@ let extend_post_hint_for_local (g:env) (p:post_hint_for_env g) let res = Pulse.Checker.Base.extend_post_hint g p x (mk_ref init_t) conjunct c_typing in res -let with_local_pre_typing (#g:env) (#pre:term) (pre_typing:tot_typing g pre tm_slprop) +let with_local_pre_typing (#g:env) (#pre:term) (pre_typing:unit) (init_t:term) (x:var { ~ (Set.mem x (dom g)) }) n (i:option term) - : tot_typing (extend_env g x n init_t) - (comp_withlocal_body_pre pre init_t (term_of_nvar (n, x)) i) - tm_slprop + : unit = admit() #push-options "--z3rlimit_factor 10 --fuel 0 --ifuel 0" @@ -66,7 +64,7 @@ let head_range (t:st_term {Tm_WithLocal? t.term}) : range = let check (g:env) (pre:term) - (pre_typing:tot_typing g pre tm_slprop) + (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_WithLocal? t.term }) @@ -132,7 +130,7 @@ let check let x_tm = term_of_nvar px in let g_extended = extend_env g x binder.binder_ppname init_t in let body_pre = comp_withlocal_body_pre pre init_t x_tm init in - let body_pre_typing = with_local_pre_typing pre_typing init_t x binder.binder_ppname init in + let body_pre_typing = () in // elaborating this post here, // so that later we can check the computed post to be equal to this one let post : post_hint_for_env g = post in diff --git a/src/checker/Pulse.Checker.WithLocal.fsti b/src/checker/Pulse.Checker.WithLocal.fsti index f397731b6..9880c294b 100644 --- a/src/checker/Pulse.Checker.WithLocal.fsti +++ b/src/checker/Pulse.Checker.WithLocal.fsti @@ -25,7 +25,7 @@ open Pulse.Checker.Base val check (g:env) (pre:term) - (pre_typing:tot_typing g pre tm_slprop) + (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_WithLocal? t.term }) diff --git a/src/checker/Pulse.Checker.WithLocalArray.fst b/src/checker/Pulse.Checker.WithLocalArray.fst index f86833e05..c2a6819a7 100644 --- a/src/checker/Pulse.Checker.WithLocalArray.fst +++ b/src/checker/Pulse.Checker.WithLocalArray.fst @@ -54,17 +54,15 @@ let extend_post_hint let with_local_array_pre_typing (#g:env) (#pre:term) - (pre_typing:tot_typing g pre tm_slprop) + (pre_typing:unit) (init_t:term) (init:option term) (len:term) - (init_typing:(match init with Some init -> tot_typing g init init_t | _ -> unit)) - (len_typing:tot_typing g len tm_szt) + (init_typing:(match init with Some init -> unit | _ -> unit)) + (len_typing:unit) (x:var { ~ (Set.mem x (dom g)) }) (n: ppname) - : tot_typing (extend_env g init_t x n init) - (comp_withlocal_array_body_pre pre init_t (term_of_nvar (n, x)) init len) - tm_slprop + : unit = admit() let is_annotated_type_array (t:term) : option term = @@ -91,7 +89,7 @@ let head_range (t:st_term {Tm_WithLocalArray? t.term}) : range = let check (g:env) (pre:term) - (pre_typing:tot_typing g pre tm_slprop) + (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_WithLocalArray? t.term }) @@ -157,8 +155,7 @@ let check let x_tm = term_of_nvar px in let g_extended = extend_env g init_t x binder.binder_ppname init in let body_pre = comp_withlocal_array_body_pre pre init_t x_tm init len in - let body_pre_typing = - with_local_array_pre_typing pre_typing init_t init len () () x binder.binder_ppname in + let body_pre_typing = () in // elaborating this post here, // so that later we can check the computed post to be equal to this one let post : post_hint_for_env g = post in diff --git a/src/checker/Pulse.Checker.WithLocalArray.fsti b/src/checker/Pulse.Checker.WithLocalArray.fsti index 2d57694e3..789df72d1 100644 --- a/src/checker/Pulse.Checker.WithLocalArray.fsti +++ b/src/checker/Pulse.Checker.WithLocalArray.fsti @@ -25,7 +25,7 @@ open Pulse.Checker.Base val check (g:env) (pre:term) - (pre_typing:tot_typing g pre tm_slprop) + (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_WithLocalArray? t.term }) diff --git a/src/checker/Pulse.Checker.fst b/src/checker/Pulse.Checker.fst index 1f9235190..63f3768d3 100644 --- a/src/checker/Pulse.Checker.fst +++ b/src/checker/Pulse.Checker.fst @@ -261,7 +261,7 @@ let rec do_not_elim_state (t:st_term) : Dv bool = let rec check (g0:env) (pre0:term) - (pre0_typing: tot_typing g0 pre0 tm_slprop) + (pre0_typing: unit) (post_hint:post_hint_opt g0) (res_ppname:ppname) (t:st_term) @@ -292,7 +292,7 @@ let rec check let (| g, pre, pre_typing, k_elim_pure |) : (g':env { env_extends g' g0 } & ctxt':term & - tot_typing g' ctxt' tm_slprop & + unit & continuation_elaborator g0 pre0 g' ctxt') = if do_not_elim_state t then (| g0, pre0, pre0_typing, k_elab_unit _ _ |) diff --git a/src/checker/Pulse.Elaborate.Core.fst b/src/checker/Pulse.Elaborate.Core.fst index 51d650715..243a06185 100644 --- a/src/checker/Pulse.Elaborate.Core.fst +++ b/src/checker/Pulse.Elaborate.Core.fst @@ -56,13 +56,13 @@ let elab_sub (c1 c2:comp_st) (e:R.term) = else mk_sub_stt_ghost u ty pre1 pre2 post1 post2 e -let elab_bind #g #x #c1 #c2 #c - (bc:bind_comp g x c1 c2 c) +let elab_bind (g:env) (x:var) (c1:comp) (c2:comp) (c:comp) + (bc:unit) (e1 e2:R.term) : GTot R.term = RU.magic () -let elab_lift #g #c1 #c2 (d:lift_comp g c1 c2) (e:R.term) +let elab_lift (g:env) (c1:comp) (c2:comp) (d:unit) (e:R.term) : GTot R.term = RU.magic () @@ -86,32 +86,32 @@ let simple_arr (t1 t2 : R.term) : R.term = attrs = [] } in R.pack_ln (R.Tv_Arrow b (R.pack_comp (R.C_Total t2))) -let elab_st_sub (#g:env) (#c1 #c2 : comp) - (d_sub : st_sub g c1 c2) +let elab_st_sub (g:env) (c1:comp) (c2:comp) + (d_sub : unit) : Tot (t:R.term & RT.tot_typing (elab_env g) t (simple_arr (elab_comp c1) (elab_comp c2))) = RU.magic_s "elab_st_sub" -let rec elab_st_typing (#g:env) - (#t:st_term) - (#c:comp) - (d:st_typing g t c) +let rec elab_st_typing (g:env) + (t:st_term) + (c:comp) + (d:unit) : GTot R.term (decreases d) = RU.magic () -and elab_br (#g:env) - (#c:comp_st) - (#sc_u:universe) (#sc_ty:typ) (#sc:term) - (#p:pattern) - (#e:st_term) - (d : br_typing g sc_u sc_ty sc p e c) +and elab_br (g:env) + (c:comp_st) + (sc_u:universe) (sc_ty:typ) (sc:term) + (p:pattern) + (e:st_term) + (d : unit) : GTot R.branch (decreases d) = RU.magic () -and elab_branches (#g:env) - (#c:comp_st) - (#sc_u:universe) (#sc_ty:typ) (#sc:term) - (#brs:list branch) - (d : brs_typing g sc_u sc_ty sc brs c) +and elab_branches (g:env) + (c:comp_st) + (sc_u:universe) (sc_ty:typ) (sc:term) + (brs:list branch) + (d : unit) : GTot (list R.branch) (decreases d) = RU.magic () diff --git a/src/checker/Pulse.JoinComp.fst b/src/checker/Pulse.JoinComp.fst index fb449ddcf..e51119e0d 100644 --- a/src/checker/Pulse.JoinComp.fst +++ b/src/checker/Pulse.JoinComp.fst @@ -104,11 +104,11 @@ let rec bindings_var_dom : env_bindings -> Set.set var = function let var_dom (g: env) : Set.set var = bindings_var_dom (bindings g) let infer_post' (g:env) (g':env { g' `env_extends` g }) - #u #t (x: var { lookup g' x == Some t }) (t_typ: universe_of g' t u) - #post (post_typing: tot_typing g' post tm_slprop) + (u:universe) (t:typ) (x: var { lookup g' x == Some t }) (t_typ: unit) + (post:term) (post_typing: unit) = // simplify post by applying elimination rules (particularly `frame ** is_unreachable ~~> is_unreachable`) - let (| g1, post, _, _ |) = Pulse.Checker.Prover.elim_exists_and_pure post_typing in + let (| g1, post, _, _ |) = Pulse.Checker.Prover.elim_exists_and_pure #g' #post post_typing in let bs0 = bindings g in let dom_g = var_dom g in let fvs_t = freevars t in @@ -128,8 +128,8 @@ let infer_post' (g:env) (g':env { g' `env_extends` g }) let g' = push_binding g x ppname_default t in assume (fresh_wrt x g (freevars post)); { - g; effect_annot=EffectAnnotSTT; effect_annot_typing=(); - ret_ty=t; u; ty_typing=(); + g; effect_annot=EffectAnnotSTT; + ret_ty=t; u; post } in @@ -364,8 +364,8 @@ let join_post #g #hyp #b let _ = Pulse.Checker.Pure.check_slprop_with_core g' joined_post' in let eff = join_effect_annot g p1.effect_annot p2.effect_annot in let res : post_hint_for_env g = - {g; effect_annot=eff; effect_annot_typing=(); - ret_ty=p1.ret_ty; u=u; ty_typing=(); + {g; effect_annot=eff; + ret_ty=p1.ret_ty; u=u; post=joined_post} in res @@ -388,15 +388,15 @@ let rec join_comps (g_then:env) (e_then:st_term) (c_then:comp_st) - (e_then_typing:st_typing g_then e_then c_then) + (e_then_typing:unit) (g_else:env) (e_else:st_term) (c_else:comp_st) - (e_else_typing:st_typing g_else e_else c_else) + (e_else_typing:unit) (post:post_hint_t) : T.TacH (c:comp_st & - st_typing g_then e_then c & - st_typing g_else e_else c) + unit & + unit) (requires comp_post_matches_hint c_then (PostHint post) /\ comp_post_matches_hint c_else (PostHint post) /\ @@ -410,8 +410,8 @@ let rec join_comps | C_STAtomic inames obs1 st, C_STAtomic _ obs2 _ -> let obs = join_obs obs1 obs2 in let c = C_STAtomic inames obs st in - let e_then_typing : st_typing g_then e_then c = () in - let e_else_typing : st_typing g_else e_else c = () in + let e_then_typing : unit = () in + let e_else_typing : unit = () in (| c, e_then_typing, e_else_typing |) | C_STGhost _ _, C_STGhost _ _ | C_ST _, C_ST _ -> (| c_then, e_then_typing, e_else_typing |) @@ -420,13 +420,13 @@ let rec join_comps assert (EffectAnnotAtomicOrGhost? post.effect_annot); match c_then, c_else with | C_STGhost _ _, C_STAtomic _ _ _ -> - let d : st_typing g_then e_then (st_ghost_as_atomic c_then) = + let d : unit = () in st_ghost_as_atomic_matches_post_hint c_then post; join_comps g_then e_then (st_ghost_as_atomic c_then) d g_else e_else c_else e_else_typing post | C_STAtomic _ _ _, C_STGhost _ _ -> - let d : st_typing g_else e_else (st_ghost_as_atomic c_else) = () in + let d : unit = () in st_ghost_as_atomic_matches_post_hint c_else post; join_comps g_then e_then c_then e_then_typing g_else e_else (st_ghost_as_atomic c_else) d post #pop-options diff --git a/src/checker/Pulse.JoinComp.fsti b/src/checker/Pulse.JoinComp.fsti index b8557b312..d37d5e4a3 100644 --- a/src/checker/Pulse.JoinComp.fsti +++ b/src/checker/Pulse.JoinComp.fsti @@ -22,14 +22,14 @@ open Pulse.Checker.Base module T = FStar.Tactics.V2 val infer_post' (g:env) (g':env { g' `env_extends` g }) - #u #t (x: var { lookup g' x == Some t }) (t_typ: universe_of g' t u) - #post (post_typing: tot_typing g' post tm_slprop) + (u:universe) (t:typ) (x: var { lookup g' x == Some t }) (t_typ: unit) + (post:term) (post_typing: unit) : T.Tac (p:post_hint_for_env g {p.g == g /\ p.effect_annot==EffectAnnotSTT}) let infer_post #g #ctxt (r:checker_result_t g ctxt NoHint) : T.Tac (p:post_hint_for_env g {p.g == g /\ p.effect_annot==EffectAnnotSTT}) = let (| x, g', (u, t), post, k |) = r in - infer_post' g g' #u #t x () #post () + infer_post' g g' u t x () post () val join_post #g #hyp #b (p1:post_hint_for_env (g_with_eq g hyp b tm_true)) @@ -40,15 +40,15 @@ val join_comps (g_then:env) (e_then:st_term) (c_then:comp_st) - (e_then_typing:st_typing g_then e_then c_then) + (e_then_typing:unit) (g_else:env) (e_else:st_term) (c_else:comp_st) - (e_else_typing:st_typing g_else e_else c_else) + (e_else_typing:unit) (post:post_hint_t) : T.TacH (c:comp_st & - st_typing g_then e_then c & - st_typing g_else e_else c) + unit & + unit) (requires comp_post_matches_hint c_then (PostHint post) /\ comp_post_matches_hint c_else (PostHint post) /\ diff --git a/src/checker/Pulse.Main.fst b/src/checker/Pulse.Main.fst index ae4038a39..a0871a25d 100644 --- a/src/checker/Pulse.Main.fst +++ b/src/checker/Pulse.Main.fst @@ -46,7 +46,7 @@ let check_fndefn (g : stt_env{bindings g == []}) (expected_t : option term) (* Both of these unused: *) - (pre : term) (pre_typing : tot_typing g pre tm_slprop) + (pre : term) (pre_typing : unit) : T.Tac (RT.dsl_tac_result_t (fstar_env g) expected_t) = let g = let FnDefn {us} = d.d in push_univ_vars g us in @@ -221,7 +221,7 @@ let main' (d:decl) (pre:term) (g:RT.fstar_top_env) (expected_t:option term) let (| pre, ty |) = Pulse.Checker.Pure.compute_tot_term_type g pre in if not (eq_tm ty tm_slprop) then fail g (Some (Pulse.RuntimeUtils.range_of_term pre)) "pulse main: cannot typecheck pre at type slprop"; //fix range - let pre_typing : tot_typing g pre tm_slprop = () in + let pre_typing : unit = () in match d.d with | FnDefn {} -> check_fndefn d g expected_t pre pre_typing | FnDecl {} -> diff --git a/src/checker/Pulse.Typing.Combinators.fst b/src/checker/Pulse.Typing.Combinators.fst index f93b55ab1..aa1f86bde 100644 --- a/src/checker/Pulse.Typing.Combinators.fst +++ b/src/checker/Pulse.Typing.Combinators.fst @@ -29,33 +29,33 @@ open Pulse.Checker.Pure assume val invert_forall_typing - (#g #u #b #body:_) - (d:tot_typing g (tm_forall_sl u b body) tm_slprop) + (g:env) (u:universe) (b:binder) (body:term) + (d:unit) (x:var { freshv g x /\ ~ (x `Set.mem` freevars body) }) : GTot ( - tot_typing g b.binder_ty (tm_type u) & - tot_typing (push_binding g x ppname_default b.binder_ty) (open_term body x) tm_slprop + unit & + unit ) assume val construct_forall_typing - (#g #u #b #body:_) + (g:env) (u:universe) (b:binder) (body:term) (x:var { freshv g x /\ ~ (x `Set.mem` freevars body) }) - (dt:tot_typing g b.binder_ty (tm_type u)) - (db:tot_typing (push_binding g x ppname_default b.binder_ty) (open_term body x) tm_slprop) - : GTot (tot_typing g (tm_forall_sl u b body) tm_slprop) + (dt:unit) + (db:unit) + : GTot (unit) -let st_equiv_trans (#g:env) (#c0 #c1 #c2:comp) (d01:st_equiv g c0 c1) (d12:st_equiv g c1 c2) - : st_equiv g c0 c2 +let st_equiv_trans (g:env) (c0 c1 c2:comp) (d01:unit) (d12:unit) + : unit = () -let t_equiv (g:env) (st:st_term) (c:comp) (d:st_typing g st c) (c':comp) (eq:st_equiv g c c') - : st_typing g st c' +let t_equiv (g:env) (st:st_term) (c:comp) (d:unit) (c':comp) (eq:unit) + : unit = () -let slprop_equiv_typing (g:env) (t0 t1:term) (v:slprop_equiv g t0 t1) - : GTot ((tot_typing g t0 tm_slprop -> tot_typing g t1 tm_slprop) & - (tot_typing g t1 tm_slprop -> tot_typing g t0 tm_slprop)) +let slprop_equiv_typing (g:env) (t0 t1:term) (v:unit) + : GTot ((unit -> unit) & + (unit -> unit)) = (fun _ -> ()), (fun _ -> ()) let bind_t (case_c1 case_c2:comp_st -> bool) = @@ -66,13 +66,11 @@ let bind_t (case_c1 case_c2:comp_st -> bool) = (c1:comp_st{ case_c1 c1 }) -> (c2:comp_st{ case_c2 c2 }) -> (px:nvar { ~ (Set.mem (snd px) (dom g)) }) -> - (d_e1:st_typing g e1 c1) -> - (d_c1res:tot_typing g (comp_res c1) (tm_type (comp_u c1))) -> - (d_e2:st_typing (push_binding g (snd px) (fst px) (comp_res c1)) (open_st_term_nv e2 px) c2) -> - (res_typing:universe_of g (comp_res c2) (comp_u c2)) -> - (post_typing:tot_typing (push_binding g (snd px) (fst px) (comp_res c2)) - (open_term_nv (comp_post c2) px) - tm_slprop) -> + (d_e1:unit) -> + (d_c1res:unit) -> + (d_e2:unit) -> + (res_typing:unit) -> + (post_typing:unit) -> (post_hint:post_hint_opt g { comp_post_matches_hint c2 post_hint }) -> T.TacH (t:st_term & c:comp_st { st_comp_of_comp c == st_comp_with_pre (st_comp_of_comp c2) pre /\ @@ -107,9 +105,9 @@ let with_inames (c:comp_st) (i:term) = | C_STGhost _ sc -> C_STGhost i sc | C_STAtomic _ obs sc -> C_STAtomic i obs sc -let weaken_comp_inames (#g:env) (#e:st_term) (#c:comp_st) (d_e:st_typing g e c) (new_inames:term) +let weaken_comp_inames (g:env) (e:st_term) (c:comp_st) (d_e:unit) (new_inames:term) : T.Tac (c':comp_st { with_inames c new_inames == c' } & - st_typing g e c') + unit) = match c with | C_ST _ -> (| c, d_e |) | C_STGhost inames sc -> @@ -120,15 +118,15 @@ let weaken_comp_inames (#g:env) (#e:st_term) (#c:comp_st) (d_e:st_typing g e c) let _ = check_prop_validity g (tm_inames_subset inames new_inames) in (| with_inames c new_inames, () |) -let try_lift_ghost_atomic (g:env) (e:st_term) (c:comp_st { C_STGhost? c }) (d:st_typing g e c) -: T.Tac (option (st_typing g e (st_ghost_as_atomic c))) +let try_lift_ghost_atomic (g:env) (e:st_term) (c:comp_st { C_STGhost? c }) (d:unit) +: T.Tac (option (unit)) = let w = try_get_non_informative_witness g (comp_u c) (comp_res c) in match w with | None -> None | Some w -> Some () -let lift_ghost_atomic (g:env) (e:st_term) (c:comp_st { C_STGhost? c }) (d:st_typing g e c) -: T.Tac (st_typing g e (st_ghost_as_atomic c)) +let lift_ghost_atomic (g:env) (e:st_term) (c:comp_st { C_STGhost? c }) (d:unit) +: T.Tac (unit) = let w = try_lift_ghost_atomic g e c d in match w with | None -> @@ -217,13 +215,11 @@ let rec mk_bind (g:env) (c1:comp_st) (c2:comp_st) (px:nvar { ~ (Set.mem (snd px) (dom g)) }) - (d_e1:st_typing g e1 c1) - (d_c1res:tot_typing g (comp_res c1) (tm_type (comp_u c1))) - (d_e2:st_typing (push_binding g (snd px) (fst px) (comp_res c1)) (open_st_term_nv e2 px) c2) - (res_typing:universe_of g (comp_res c2) (comp_u c2)) - (post_typing:tot_typing (push_binding g (snd px) (fst px) (comp_res c2)) - (open_term_nv (comp_post c2) px) - tm_slprop) + (d_e1:unit) + (d_c1res:unit) + (d_e2:unit) + (res_typing:unit) + (post_typing:unit) (post_hint:post_hint_opt g { comp_post_matches_hint c2 post_hint }) : T.TacH (t:st_term & c:comp_st { @@ -351,9 +347,9 @@ let bind_res_and_post_typing g c2 x post_hint CU.debug g "pulse.main" (fun _ -> "bind_res_and_post_typing (with post_hint)\n"); () -let add_frame (g:env) (t:st_term) (c:comp_st) (t_typing:st_typing g t c) +let add_frame (g:env) (t:st_term) (c:comp_st) (t_typing:unit) (frame:slprop) - (frame_typing:tot_typing g frame tm_slprop) + (frame_typing:unit) : t':st_term & c':comp_st { c' == add_frame c frame } = @@ -363,9 +359,9 @@ let add_frame (g:env) (t:st_term) (c:comp_st) (t_typing:st_typing g t c) let apply_frame (g:env) (t:st_term) (ctxt:term) - (ctxt_typing: tot_typing g ctxt tm_slprop) + (ctxt_typing: unit) (c:comp { stateful_comp c }) - (t_typing: st_typing g t c) + (t_typing: unit) (frame_t:frame_for_req_in_ctxt g ctxt (comp_pre c)) : Dv (c':comp_st { comp_pre c' == ctxt /\ comp_res c' == comp_res c /\ @@ -382,7 +378,7 @@ let apply_frame (g:env) #pop-options #push-options "--z3rlimit_factor 2" -let comp_for_post_hint (g:env) (pre:slprop) (pre_typing:tot_typing g pre tm_slprop) +let comp_for_post_hint (g:env) (pre:slprop) (pre_typing:unit) (post:post_hint_t { g `env_extends` post.g }) (x:var { freshv g x }) : T.Tac (c:comp_st { comp_pre c == pre /\ comp_post_matches_hint c (PostHint post) }) = diff --git a/src/checker/Pulse.Typing.Combinators.fsti b/src/checker/Pulse.Typing.Combinators.fsti index ed235cf83..53e6b71d0 100644 --- a/src/checker/Pulse.Typing.Combinators.fsti +++ b/src/checker/Pulse.Typing.Combinators.fsti @@ -26,18 +26,18 @@ let st_comp_with_pre (st:st_comp) (pre:term) : st_comp = { st with pre } let nvar_as_binder (x:nvar) (t:term) : binder = mk_binder_ppname t (fst x) -val t_equiv (g:env) (st:st_term) (c:comp) (d:st_typing g st c) (c':comp) (eq:st_equiv g c c') - : st_typing g st c' +val t_equiv (g:env) (st:st_term) (c:comp) (d:unit) (c':comp) (eq:unit) + : unit -val slprop_equiv_typing (g:env) (t0 t1:term) (v:slprop_equiv g t0 t1) - : GTot ((tot_typing g t0 tm_slprop -> tot_typing g t1 tm_slprop) & - (tot_typing g t1 tm_slprop -> tot_typing g t0 tm_slprop)) +val slprop_equiv_typing (g:env) (t0 t1:term) (v:unit) + : GTot ((unit -> unit) & + (unit -> unit)) let st_ghost_as_atomic (c:comp_st { C_STGhost? c }) = C_STAtomic (comp_inames c) Neutral (st_comp_of_comp c) -val lift_ghost_atomic (g:env) (e:st_term) (c:comp_st { C_STGhost? c }) (d:st_typing g e c) -: T.Tac (st_typing g e (st_ghost_as_atomic c)) +val lift_ghost_atomic (g:env) (e:st_term) (c:comp_st { C_STGhost? c }) (d:unit) +: T.Tac (unit) val mk_bind (g:env) (pre:term) @@ -46,13 +46,11 @@ val mk_bind (g:env) (c1:comp_st) (c2:comp_st) (px:nvar { ~ (Set.mem (snd px) (dom g)) }) - (d_e1:st_typing g e1 c1) - (d_c1res:tot_typing g (comp_res c1) (tm_type (comp_u c1))) - (d_e2:st_typing (push_binding g (snd px) (fst px) (comp_res c1)) (open_st_term_nv e2 px) c2) - (res_typing:universe_of g (comp_res c2) (comp_u c2)) - (post_typing:tot_typing (push_binding g (snd px) (fst px) (comp_res c2)) - (open_term_nv (comp_post c2) px) - tm_slprop) + (d_e1:unit) + (d_c1res:unit) + (d_e2:unit) + (res_typing:unit) + (post_typing:unit) (post_hint:post_hint_opt g { comp_post_matches_hint c2 post_hint }) : T.TacH (t:st_term & c:comp_st { st_comp_of_comp c == st_comp_with_pre (st_comp_of_comp c2) pre /\ @@ -71,9 +69,9 @@ val bind_res_and_post_typing (g:env) (s2:comp_st) (x:var { fresh_wrt x g (freeva (post_hint:post_hint_opt g { comp_post_matches_hint s2 post_hint }) : T.Tac unit -val add_frame (g:env) (t:st_term) (c:comp_st) (t_typing:st_typing g t c) +val add_frame (g:env) (t:st_term) (c:comp_st) (t_typing:unit) (frame:slprop) - (frame_typing:tot_typing g frame tm_slprop) + (frame_typing:unit) : t':st_term & c':comp_st { c' == add_frame c frame } @@ -85,9 +83,9 @@ let frame_of #g #ctxt #req (f:frame_for_req_in_ctxt g ctxt req) = f val apply_frame (g:env) (t:st_term) (ctxt:term) - (ctxt_typing: tot_typing g ctxt tm_slprop) + (ctxt_typing: unit) (c:comp { stateful_comp c }) - (t_typing: st_typing g t c) + (t_typing: unit) (frame_t:frame_for_req_in_ctxt g ctxt (comp_pre c)) : Dv (c':comp_st { comp_pre c' == ctxt /\ comp_res c' == comp_res c /\ @@ -98,7 +96,7 @@ type st_typing_in_ctxt (g:env) (ctxt:slprop) (post_hint:post_hint_opt g) = t:st_term & c:comp_st { comp_pre c == ctxt /\ comp_post_matches_hint c post_hint } -val comp_for_post_hint (g:env) (pre:slprop) (pre_typing:tot_typing g pre tm_slprop) +val comp_for_post_hint (g:env) (pre:slprop) (pre_typing:unit) (post:post_hint_t { g `env_extends` post.g }) (x:var { freshv g x }) : T.Tac (c:comp_st { comp_pre c == pre /\ comp_post_matches_hint c (PostHint post) }) \ No newline at end of file diff --git a/src/checker/Pulse.Typing.FV.fst b/src/checker/Pulse.Typing.FV.fst index 928289f87..b736b2246 100644 --- a/src/checker/Pulse.Typing.FV.fst +++ b/src/checker/Pulse.Typing.FV.fst @@ -281,38 +281,38 @@ val freevars_open_comp (c:comp) (x:term) (i:index) #push-options "--fuel 2 --ifuel 2" let tot_or_ghost_typing_freevars - (#g:_) (#t:_) (#ty:_) (#eff:_) - (d:typing g t eff ty) + (g:env) (t:term) (ty:term) (eff:FStar.Tactics.V2.tot_or_ghost) + (d:unit) : Lemma (ensures freevars t `Set.subset` vars_of_env g /\ freevars ty `Set.subset` vars_of_env g) = admit () let tot_typing_freevars - (g:_) (t:_) (ty:_) - (d:tot_typing g t ty) + (g:env) (t:term) (ty:term) + (d:unit) : Lemma (ensures freevars t `Set.subset` vars_of_env g /\ freevars ty `Set.subset` vars_of_env g) = admit () -let bind_comp_freevars (g:_) (x:_) (c1:_) (c2:_) (c:_) - (d:bind_comp g x c1 c2 c) +let bind_comp_freevars (g:env) (x:var) (c1:comp) (c2:comp) (c:comp) + (d:unit) : Lemma (requires freevars_comp c1 `Set.subset` vars_of_env g /\ freevars_comp c2 `Set.subset` (Set.union (vars_of_env g) (Set.singleton x))) (ensures freevars_comp c `Set.subset` vars_of_env g) = admit () -let slprop_equiv_freevars (g:_) (t0:_) (t1:_) (v:slprop_equiv g t0 t1) +let slprop_equiv_freevars (g:env) (t0:term) (t1:term) (v:unit) : Lemma (ensures (freevars t0 `Set.subset` vars_of_env g) <==> (freevars t1 `Set.subset` vars_of_env g)) = admit () -let st_equiv_freevars (g:_) (c1:_) (c2:_) - (d:st_equiv g c1 c2) +let st_equiv_freevars (g:env) (c1:comp) (c2:comp) + (d:unit) : Lemma (requires freevars_comp c1 `Set.subset` vars_of_env g) (ensures freevars_comp c2 `Set.subset` vars_of_env g) @@ -324,26 +324,26 @@ let prop_validity_fv (g:env) (p:term) (ensures freevars p `Set.subset` vars_of_env g) = admit() -let st_sub_freevars (g:_) (c1:_) (c2:_) - (d:st_sub g c1 c2) +let st_sub_freevars (g:env) (c1:comp) (c2:comp) + (d:unit) : Lemma (requires freevars_comp c1 `Set.subset` vars_of_env g) (ensures freevars_comp c2 `Set.subset` vars_of_env g) = admit () let src_typing_freevars_t (d':'a) = - (g:_) -> (t:_) -> (c:_) -> (d:st_typing g t c { d << d' }) -> + (g:env) -> (t:st_term) -> (c:comp) -> (d:unit) -> Lemma (ensures freevars_st t `Set.subset` vars_of_env g /\ freevars_comp c `Set.subset` vars_of_env g) -let st_comp_typing_freevars (g:_) (st:_) (d:st_comp_typing g st) +let st_comp_typing_freevars (g:env) (st:st_comp) (d:unit) : Lemma (ensures freevars_st_comp st `Set.subset` vars_of_env g) = admit () -let comp_typing_freevars (g:_) (c:_) (u:_) - (d:comp_typing g c u) +let comp_typing_freevars (g:env) (c:comp) (u:universe) + (d:unit) : Lemma (ensures freevars_comp c `Set.subset` vars_of_env g) = admit () @@ -418,8 +418,8 @@ let freevars_array (t:term) (** Big lemma follows. We have to split it to make it digestible to SMT. *) let st_typing_freevars - (g:_) (t:_) (c:_) - (d:st_typing g t c) + (g:env) (t:st_term) (c:comp) + (d:unit) : Lemma (ensures freevars_st t `Set.subset` vars_of_env g /\ freevars_comp c `Set.subset` vars_of_env g) diff --git a/src/checker/Pulse.Typing.FV.fsti b/src/checker/Pulse.Typing.FV.fsti index ce742eab8..8011c4c80 100644 --- a/src/checker/Pulse.Typing.FV.fsti +++ b/src/checker/Pulse.Typing.FV.fsti @@ -48,26 +48,26 @@ val freevars_close_st_term (e:st_term) (x:var) (i:index) freevars_st e `set_minus` x) [SMTPat (freevars_st (close_st_term' e x i))] -val tot_typing_freevars (g:_) (t:_) (ty:_) - (d:tot_typing g t ty) +val tot_typing_freevars (g:env) (t:term) (ty:term) + (d:unit) : Lemma (ensures freevars t `Set.subset` vars_of_env g /\ freevars ty `Set.subset` vars_of_env g) -val comp_typing_freevars (g:_) (c:_) (u:_) - (d:comp_typing g c u) +val comp_typing_freevars (g:env) (c:comp) (u:universe) + (d:unit) : Lemma (ensures freevars_comp c `Set.subset` vars_of_env g) -val st_typing_freevars (g:_) (t:_) (c:_) - (d:st_typing g t c) +val st_typing_freevars (g:env) (t:st_term) (c:comp) + (d:unit) : Lemma (ensures freevars_st t `Set.subset` vars_of_env g /\ freevars_comp c `Set.subset` vars_of_env g) -let st_typing_freevars_inv (g:_) (t:_) (c:_) - (d:st_typing g t c) +let st_typing_freevars_inv (g:env) (t:st_term) (c:comp) + (d:unit) (x:var) : Lemma (requires freshv g x) diff --git a/src/checker/Pulse.Typing.LN.fst b/src/checker/Pulse.Typing.LN.fst index 5bdcc6ec9..d05a60834 100644 --- a/src/checker/Pulse.Typing.LN.fst +++ b/src/checker/Pulse.Typing.LN.fst @@ -923,32 +923,32 @@ let close_comp_ln (c:comp) (v:var) #push-options "--ifuel 2 --z3rlimit_factor 4 --z3cliopt 'smt.qi.eager_threshold=100'" -let lift_comp_ln #g #c1 #c2 (d:lift_comp g c1 c2) +let lift_comp_ln (g:env) (c1:comp) (c2:comp) (d:unit) : Lemma (requires ln_c c1) (ensures ln_c c2) = admit () let tot_or_ghost_typing_ln - (#g:_) (#e:_) (#t:_) (#eff:_) - (d:typing g e eff t) + (g:env) (e:term) (t:term) (eff:FStar.Tactics.V2.tot_or_ghost) + (d:unit) : Lemma (ensures ln e /\ ln t) = admit () let tot_typing_ln - (#g:_) (#e:_) (#t:_) - (d:tot_typing g e t) + (g:env) (e:term) (t:term) + (d:unit) : Lemma (ensures ln e /\ ln t) = admit () #push-options "--fuel 4 --ifuel 4" -let slprop_equiv_ln (#g:_) (#t0 #t1:_) (v:slprop_equiv g t0 t1) +let slprop_equiv_ln (g:env) (t0:term) (t1:term) (v:unit) : Lemma (ensures ln t0 <==> ln t1) = admit () #pop-options -let st_equiv_ln #g #c1 #c2 (d:st_equiv g c1 c2) +let st_equiv_ln (g:env) (c1:comp) (c2:comp) (d:unit) : Lemma (requires ln_c c1) (ensures ln_c c2) @@ -958,23 +958,23 @@ let prop_valid_must_be_ln (g:env) (t:term) (d:prop_validity g t) : Lemma (ensures ln t) = admit() -let st_sub_ln #g #c1 #c2 (d:st_sub g c1 c2) +let st_sub_ln (g:env) (c1:comp) (c2:comp) (d:unit) : Lemma (requires ln_c c1) (ensures ln_c c2) = admit () -let bind_comp_ln #g #x #c1 #c2 #c (d:bind_comp g x c1 c2 c) +let bind_comp_ln (g:env) (x:var) (c1:comp) (c2:comp) (c:comp) (d:unit) : Lemma (requires ln_c c1 /\ ln_c c2) (ensures ln_c c) = admit () -let st_comp_typing_ln (#g:_) (#st:_) (d:st_comp_typing g st) +let st_comp_typing_ln (g:env) (st:st_comp) (d:unit) : Lemma (ensures ln_st_comp st (-1)) = admit () -let comp_typing_ln (#g:_) (#c:_) (#u:_) (d:comp_typing g c u) +let comp_typing_ln (g:env) (c:comp) (u:universe) (d:unit) : Lemma (ensures ln_c c) = admit () #pop-options @@ -1038,8 +1038,8 @@ let comp_par_ln (cL : comp{C_ST? cL}) (cR : comp{C_ST? cR}) (x : var) // Note the use of break_vc in every case below. #push-options "--z3rlimit_factor 15 --fuel 4 --ifuel 1 --split_queries no --z3cliopt 'smt.qi.eager_threshold=100'" -let st_typing_ln (#g:_) (#t:_) (#c:_) - (d:st_typing g t c) +let st_typing_ln (g:env) (t:st_term) (c:comp) + (d:unit) : Lemma (ensures ln_st t /\ ln_c c) = admit () diff --git a/src/checker/Pulse.Typing.LN.fsti b/src/checker/Pulse.Typing.LN.fsti index d63b3e858..6e0e6ccdb 100644 --- a/src/checker/Pulse.Typing.LN.fsti +++ b/src/checker/Pulse.Typing.LN.fsti @@ -20,14 +20,14 @@ open Pulse.Syntax open Pulse.Syntax.Naming open Pulse.Typing -val tot_typing_ln (#g:_) (#e:_) (#t:_) - (d:tot_typing g e t) +val tot_typing_ln (g:env) (e:term) (t:term) + (d:unit) : Lemma (ln e /\ ln t) -val comp_typing_ln (#g:_) (#c:_) (#u:_) - (d:comp_typing g c u) +val comp_typing_ln (g:env) (c:comp) (u:universe) + (d:unit) : Lemma (ln_c c) -val st_typing_ln (#g:_) (#t:_) (#c:_) - (st:st_typing g t c) +val st_typing_ln (g:env) (t:st_term) (c:comp) + (st:unit) : Lemma (ln_st t /\ ln_c c) diff --git a/src/checker/Pulse.Typing.fst b/src/checker/Pulse.Typing.fst index 1d49e41fa..22c00c2ce 100644 --- a/src/checker/Pulse.Typing.fst +++ b/src/checker/Pulse.Typing.fst @@ -139,8 +139,6 @@ let elab_push_binding (g:env) (x:var { ~ (Set.mem x (dom g)) }) (t:typ) : Lemma (elab_env (push_binding g x ppname_default t) == RT.extend_env (elab_env g) x t) = () -[@@ erasable; no_auto_projectors] -let slprop_equiv (g:env) (t1:term) (t2:term) = unit let add_frame (s:comp_st) (frame:term) @@ -473,17 +471,6 @@ let comp_rewrite (p q:slprop) : comp = noeq type my_erased (a:Type) = | E of a -let typing (g:env) (e:term) (eff:T.tot_or_ghost) (t:term) = unit - -let tot_typing (g:env) (e:term) (t:term) = unit - -let ghost_typing (g:env) (e:term) (t:typ) = unit - -let lift_typing_to_ghost_typing (#g:env) (#e:term) (#eff:T.tot_or_ghost) (#t:term) - (d:typing g e eff t) - : ghost_typing g e t = () - -let universe_of (g:env) (t:term) (u:universe) = unit let non_informative_t (g:env) (u:universe) (t:term) = term @@ -508,23 +495,16 @@ let tm_inames_subset (inames1 inames2 : term) : term = wr (R.mk_e_app join [inames1; inames2]) (T.range_of_term inames1) -let tm_inames_subset_typing (g:env) (inames1 inames2 : term) : tot_typing g (tm_inames_subset inames1 inames2) tm_prop = - (* Need to add the typing hypothesis for `inames_subset` to - the env and a precondition that the inames have type Pulse.Lib.Core.inames in g, - which the caller should get from an inversion lemma *) - RU.magic() +let tm_inames_subset_typing (g:env) (inames1 inames2 : term) : unit = + () let prop_validity (g:env) (t:term) = FTB.prop_validity_token (elab_env g) t -[@@ erasable; no_auto_projectors] -let st_equiv (g:env) (c1:comp) (c2:comp) = unit let sub_observability (o1 o2:observability) = o1 = Neutral || o1 = o2 || o2 = Observable -let st_sub (g:env) (c1:comp) (c2:comp) = unit -let lift_comp (g:env) (c1:comp) (c2:comp) = unit let wrst (ct:comp_st) (t:st_term') : st_term = { term = t; @@ -541,10 +521,8 @@ let wtag (ct:option ctag) (t:st_term') : st_term = seq_lhs = Sealed.seal false; } -let st_comp_typing (g:env) (st:st_comp) = unit -let bind_comp (g:env) (x:var) (c1:comp) (c2:comp) (c:comp) = unit let tr_binding (vt : var & typ) : Tot R.binding = let v, t = vt in @@ -556,9 +534,7 @@ let tr_binding (vt : var & typ) : Tot R.binding = let tr_bindings = L.map tr_binding -let comp_typing (g:env) (c:comp) (u:universe) = unit -let comp_typing_u (e:env) (c:comp_st) = comp_typing e c (universe_of_comp c) let subtyping_token g t1 t2 = T.subtyping_token (elab_env g) t1 t2 @@ -566,7 +542,6 @@ let subtyping_token g t1 t2 = val readback_binding : R.binding -> var_binding let readback_binding b = { n = { name = b.ppname; range = Range.range_0 }; x = b.uniq; ty = b.sort } -let non_informative (g:env) (c:comp) = unit let inv_disjointness (inames i:term) = let g = Pulse.Reflection.Util.inv_disjointness_goal inames i in @@ -587,77 +562,21 @@ let goto_comp_of_block_comp (c: comp_st) : comp_st = post = tm_is_unreachable; } -[@@ erasable; no_auto_projectors] -let st_typing (g:env) (t:st_term) (c:comp) = unit - -let pats_complete (g:env) (sc:term) (sc_ty:typ) (pats:list R.pattern) = unit - -let brs_typing (g:env) (sc_u:universe) (sc_ty:typ) (sc:term) (brs:list branch) (c:comp_st) = unit - -let br_typing (g:env) (sc_u:universe) (sc_ty:typ) (sc:term) (p:pattern) (e:st_term) (c:comp_st) = unit -(* this requires some metatheory on FStar.Reflection.Typing - G |- fv e : t - G(fv) = t0 -> t1 - - G |- e : t0 - G |- t1 <: t - - - - G |- e0 e1 : t ==> - - exists t0 t1. - G |- e0 : t0 -> t1 /\ - G |- e1 : t0 - -*) -let star_typing_inversion_l (#g:_) (#t0 #t1:term) (d:tot_typing g (tm_star t0 t1) tm_slprop) - : tot_typing g t0 tm_slprop - = () - -let star_typing_inversion_r (#g:_) (#t0 #t1:term) (d:tot_typing g (tm_star t0 t1) tm_slprop) - : tot_typing g t1 tm_slprop - = () - -let star_typing_inversion (#g:_) (#t0 #t1:term) (d:tot_typing g (tm_star t0 t1) tm_slprop) - : GTot (tot_typing g t0 tm_slprop & tot_typing g t1 tm_slprop) - = ((), ()) - -let slprop_eq_typing_inversion g (t0 t1:term) - (token:RT.equiv (elab_env g) - t0 - t1) - : GTot (tot_typing g t0 tm_slprop & - tot_typing g t1 tm_slprop) - = ((), ()) - -let star_typing (#g:_) (#t0 #t1:term) - (d0:tot_typing g t0 tm_slprop) - (d1:tot_typing g t1 tm_slprop) - : tot_typing g (tm_star t0 t1) tm_slprop - = () - -let emp_typing (#g:_) - : tot_typing g tm_emp tm_slprop - = () let fresh_wrt (x:var) (g:env) (vars:_) = freshv g x /\ ~(x `Set.mem` vars) -let effect_annot_typing (g:env) (e:effect_annot) = unit noeq type post_hint_t = { g:env; effect_annot:effect_annot; - effect_annot_typing:effect_annot_typing g effect_annot; ret_ty:term; u:universe; - ty_typing:universe_of g ret_ty u; post:term; // post has a free de Bruijn variable 0 for the result of type ret_ty } From e07bf0571186cfe9fa2f53f6a276d95daaec6398 Mon Sep 17 00:00:00 2001 From: Gabriel Ebner Date: Sat, 28 Feb 2026 20:00:26 +0000 Subject: [PATCH 13/18] Remove trivial let-bindings of unit values Remove 147 let-bindings of the form 'let x : unit = () in' across 19 files, replacing their use sites with (). These bindings were remnants of the typing token removal and served no purpose. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/checker/Pulse.Checker.Abs.fst | 12 +- src/checker/Pulse.Checker.Admit.fst | 4 +- .../Pulse.Checker.AssertWithBinders.fst | 28 +- src/checker/Pulse.Checker.Base.fst | 25 +- src/checker/Pulse.Checker.Exists.fst | 8 +- .../Pulse.Checker.ForwardJumpLabel.fst | 4 +- src/checker/Pulse.Checker.IntroPure.fst | 6 +- src/checker/Pulse.Checker.Match.fst | 6 +- src/checker/Pulse.Checker.Prover.fst | 281 +++++++++--------- src/checker/Pulse.Checker.Pure.fst | 2 +- src/checker/Pulse.Checker.Return.fst | 4 +- src/checker/Pulse.Checker.Rewrite.fst | 4 +- src/checker/Pulse.Checker.SLPropEquiv.fst | 37 +-- src/checker/Pulse.Checker.ST.fst | 2 +- src/checker/Pulse.Checker.While.fst | 31 +- src/checker/Pulse.JoinComp.fst | 17 +- src/checker/Pulse.Main.fst | 4 +- 17 files changed, 226 insertions(+), 249 deletions(-) diff --git a/src/checker/Pulse.Checker.Abs.fst b/src/checker/Pulse.Checker.Abs.fst index a377ea61f..8292d029b 100644 --- a/src/checker/Pulse.Checker.Abs.fst +++ b/src/checker/Pulse.Checker.Abs.fst @@ -482,10 +482,10 @@ let rec check_abs_core (* Check if it matches annotation (if any, likely not), and adjust derivation if needed. Currently this only subtypes the invariants. *) let c_body = check_effect_annotation g' body.range asc c_body in - let body_typing : unit = () in - let c_body = maybe_rewrite_body_typing g' body c_body body_typing asc in - FV.st_typing_freevars g' body c_body body_typing; let body_closed = close_st_term body x in + let c_body = maybe_rewrite_body_typing g' body c_body () asc in + + FV.st_typing_freevars g' body c_body (); let body_closed = close_st_term body x in assume (open_st_term body_closed x == body); // instantiate implicits in the attributes @@ -587,11 +587,11 @@ let rec check_abs_core in let c_body = check_effect_annotation g' body.range c_opened c_body in - let body_typing : unit = () in - let c_body = maybe_rewrite_body_typing g' body c_body body_typing asc in - FV.st_typing_freevars g' body c_body body_typing; + let c_body = maybe_rewrite_body_typing g' body c_body () asc in + + FV.st_typing_freevars g' body c_body (); let body_closed = close_st_term body x in assume (open_st_term body_closed x == body); let b = {binder_ty=t;binder_ppname=ppname;binder_attrs} in diff --git a/src/checker/Pulse.Checker.Admit.fst b/src/checker/Pulse.Checker.Admit.fst index 051d73938..ea0a6718b 100644 --- a/src/checker/Pulse.Checker.Admit.fst +++ b/src/checker/Pulse.Checker.Admit.fst @@ -65,7 +65,7 @@ let check let post = close_term post_opened x in let s : st_comp = {u;res=t;pre;post} in assume (open_term (close_term post_opened x) x == post_opened); - let d_s : unit = () in + (match c with | STT -> C_ST s | STT_Ghost -> C_STGhost tm_emp_inames s @@ -79,7 +79,7 @@ let check u=comp_u c; typ=comp_res c; post=None }) in - let d : unit = () in + FStar.Tactics.BreakVC.break_vc (); // ^ This makes a big difference! Would be good to distill into // a smaller F*-only example and file an issue. diff --git a/src/checker/Pulse.Checker.AssertWithBinders.fst b/src/checker/Pulse.Checker.AssertWithBinders.fst index ed47d93f0..93be8e045 100644 --- a/src/checker/Pulse.Checker.AssertWithBinders.fst +++ b/src/checker/Pulse.Checker.AssertWithBinders.fst @@ -352,10 +352,10 @@ let check_renaming // if there is no goal, take the goal to be the full current pre let rhs, pairs = rewrite_all st.range (T.unseal st.source) g pairs pre pre elaborated tac_opt false in check_pairs g st.range pairs tac_opt; - let h2: unit = () in - let h1: unit = () in - let (| x, g', ty, ctxt', k |) = check g rhs h1 post_hint res_ppname body in - (| x, g', ty, ctxt', k_elab_equiv pre ctxt' k h2 () |) + + + let (| x, g', ty, ctxt', k |) = check g rhs () post_hint res_ppname body in + (| x, g', ty, ctxt', k_elab_equiv pre ctxt' k () () |) | [], Some goal -> ( let rhs, _ = rewrite_all st.range (T.unseal st.source) g pairs goal pre elaborated tac_opt true in @@ -433,12 +433,12 @@ let check_wild | [ex] -> let k = List.Tot.length bs in let frame = list_as_slprop rest in - let ex_typ : unit = () in - let (|g', ex', bs, k|) = peel_binders k ex pre st.range g frame bs ex ex_typ in + + let (|g', ex', bs, k|) = peel_binders k ex pre st.range g frame bs ex () in let body = open_st_term_with_reveals body bs in - let pre_typ : unit = () in + let (| x'', g'', t'', ctxt'', k' |) = - check g' (frame `tm_star` ex') pre_typ post_hint res_ppname body in + check g' (frame `tm_star` ex') () post_hint res_ppname body in assume pre == (frame `tm_star` ex); (| x'', g'', t'', ctxt'', k_elab_trans k k' |) #pop-options @@ -519,9 +519,9 @@ let check let v = v' in let body = body in // TODO compress let h: unit = PC.core_check_term g1 v T.E_Total tm_slprop in - let h: unit = () in // TODO: propagate through prover + // TODO: propagate through prover let (| x, x_ty, pre'', g2, k |) = - check g1 (tm_star v pre') h post_hint res_ppname body in + check g1 (tm_star v pre') () post_hint res_ppname body in (| x, x_ty, pre'', g2, k_elab_trans k_frame k |) @@ -555,9 +555,9 @@ let check let _ = PC.check_slprop_with_core g v' in - let h1: unit = () in - let h2: unit = () in + + let (| x, g'', ty, ctxt', k' |) = - check g' (tm_star pre_remaining rhs') h1 post_hint res_ppname body in - (| x, g'', ty, ctxt', k_elab_trans k (k_elab_equiv (tm_star lhs pre_remaining) ctxt' k' h2 ()) |) + check g' (tm_star pre_remaining rhs') () post_hint res_ppname body in + (| x, g'', ty, ctxt', k_elab_trans k (k_elab_equiv (tm_star lhs pre_remaining) ctxt' k' () ()) |) diff --git a/src/checker/Pulse.Checker.Base.fst b/src/checker/Pulse.Checker.Base.fst index 63a97f183..ed3b53587 100644 --- a/src/checker/Pulse.Checker.Base.fst +++ b/src/checker/Pulse.Checker.Base.fst @@ -197,8 +197,8 @@ let st_equiv_post (#g:env) (t:st_term) (c:comp_st) (d:unit) = if eq_tm post (comp_post c) then d else let c' = comp_st_with_post c post in - let st_equiv : unit = () in - Pulse.Typing.Combinators.t_equiv g t c d c' st_equiv + + Pulse.Typing.Combinators.t_equiv g t c d c' () let simplify_post (g:env) (t:st_term) (c:comp_st) (d:unit) (post:term { comp_post c == tm_star post tm_emp}) @@ -237,8 +237,8 @@ let st_equiv_pre (#g:env) (t:st_term) (c:comp_st) (d:unit) = if eq_tm pre (comp_pre c) then d else let c' = comp_with_pre c pre in - let st_equiv : unit = () in - Pulse.Typing.Combinators.t_equiv g t c d c' st_equiv + + Pulse.Typing.Combinators.t_equiv g t c d c' () let k_elab_equiv_continuation (#g1:env) (#g2:env { g2 `env_extends` g1 }) (#ctxt #ctxt1:term) (ctxt2:term) (k:continuation_elaborator g1 ctxt g2 ctxt1) @@ -389,11 +389,8 @@ let st_comp_typing_with_post_hint let PostHint ph = post_hint in let x = RU.magic () in //fresh g in assume (fresh_wrt x g (freevars ph.post)); - let post_typing_src - : unit - = () - in - let ty_typing : unit = () in + + assert (st.res == ph.ret_ty); assert (st.post == ph.post); () @@ -418,7 +415,7 @@ let continuation_elaborator_with_bind_fn (#g:env) (ctxt:term) assume (open_st_term (close_st_term e2 x) x == e2); let e = wrst c2 (Tm_Bind {binder=b; head=e1; body=e2_closed}) in let u : Ghost.erased universe = RU.magic () in - let c2_typing : unit = () in + (| e, c2 |) let rec check_equiv_emp (g:env) (vp:term) @@ -456,7 +453,7 @@ let return_in_ctxt (g:env) (y:var) (y_ppname:ppname) (u:universe) (ty:term) (ctx let y_tm = tm_var {nm_index=y;nm_ppname=y_ppname} in let t = wtag (Some ctag) (Tm_Return {expected_type=tm_unknown;insert_eq=false;term=y_tm}) in let c = comp_return ctag false u ty y_tm post_hint.post x in - let d : unit = () in + assume (comp_u c == post_hint.u); // this u should follow from equality of t match c, post_hint.effect_annot with | C_STAtomic _ obs st, EffectAnnotAtomic { opens } @@ -503,7 +500,7 @@ let match_comp_res_with_post_hint (#g:env) (t:st_term) (c:comp_st) RT.Rel_eq_token _ _ _ (FStar.Squash.return_squash tok) in let c' = with_st_comp c {(st_comp_of_comp c) with res = ret_ty } in - let d_stequiv : unit = () in + c' #pop-options @@ -726,8 +723,8 @@ let norm_st_typing_inverse : Ghost.erased (RT.equiv (elab_env g) t0 t1) = Ghost.hide (RT.Rel_sym _ _ _ related_t1_t1') in - let steq : unit = () in - Some (Pulse.Typing.Combinators.t_equiv g e (C_Tot t0) d (C_Tot t1) steq) + + Some (Pulse.Typing.Combinators.t_equiv g e (C_Tot t0) d (C_Tot t1) ()) ) else None diff --git a/src/checker/Pulse.Checker.Exists.fst b/src/checker/Pulse.Checker.Exists.fst index f8e98c46d..2bac24b86 100644 --- a/src/checker/Pulse.Checker.Exists.fst +++ b/src/checker/Pulse.Checker.Exists.fst @@ -88,8 +88,8 @@ let check_elim_exists then let x = fresh g in let elim_st = wtag (Some STT_Ghost) (Tm_ElimExists { p = tm_exists_sl u (as_binder ty) p }) in let elim_c = comp_elim_exists u ty p (ppname_default, x) in - let d : unit = () in - let c = match_comp_res_with_post_hint elim_st elim_c d post_hint in + + let c = match_comp_res_with_post_hint elim_st elim_c () post_hint in prove_post_hint (try_frame_pre false pre_typing (|elim_st,c|) res_ppname) post_hint t_rng else fail g (Some t_rng) (Printf.sprintf "check_elim_exists: universe checking failed, computed %s, expected %s" @@ -132,8 +132,8 @@ let check_intro_exists check_term g witness T.E_Ghost b.binder_ty in let intro_st = wtag (Some STT_Ghost) (Tm_IntroExists { p = tm_exists_sl u b p; witnesses = [witness] }) in let intro_c = C_STGhost tm_emp_inames { u=u0; res=tm_unit; pre=open_term' p witness 0; post=tm_exists_sl u b p } in - let d : unit = () in - let c = match_comp_res_with_post_hint intro_st intro_c d post_hint in + + let c = match_comp_res_with_post_hint intro_st intro_c () post_hint in prove_post_hint (try_frame_pre false pre_typing (|intro_st, c|) res_ppname) post_hint (Pulse.RuntimeUtils.range_of_term t) diff --git a/src/checker/Pulse.Checker.ForwardJumpLabel.fst b/src/checker/Pulse.Checker.ForwardJumpLabel.fst index 1ce18be2b..298c6602d 100644 --- a/src/checker/Pulse.Checker.ForwardJumpLabel.fst +++ b/src/checker/Pulse.Checker.ForwardJumpLabel.fst @@ -92,12 +92,12 @@ let check post = body'_c; }) in assume open_st_term' body (term_of_nvar (lbl, lbl_x)) 0 == body'; - let typing: unit = () in + if not has_explicit_post then ( assert post_hint0 == PostHint post; checker_result_for_st_typing (| t, body'_c |) res_ppname ) else ( - let c'' = match_comp_res_with_post_hint t body'_c typing post_hint0 in + let c'' = match_comp_res_with_post_hint t body'_c () post_hint0 in prove_post_hint #g (try_frame_pre false #g pre_typing (|t,c''|) res_ppname) post_hint0 diff --git a/src/checker/Pulse.Checker.IntroPure.fst b/src/checker/Pulse.Checker.IntroPure.fst index 71d3e0321..b69fe8c1f 100644 --- a/src/checker/Pulse.Checker.IntroPure.fst +++ b/src/checker/Pulse.Checker.IntroPure.fst @@ -57,10 +57,10 @@ let check let Tm_IntroPure { p } = t.term in let p = check_prop g p in - let p_typing : unit = () in + let pv = check_prop_validity g p in let intro_st = wtag (Some STT_Ghost) (Tm_IntroPure { p }) in let intro_c = C_STGhost tm_emp_inames { u=u0; res=tm_unit; pre=tm_emp; post=tm_pure p } in - let st_typing : unit = () in - let c = match_comp_res_with_post_hint intro_st intro_c st_typing post_hint in + + let c = match_comp_res_with_post_hint intro_st intro_c () post_hint in prove_post_hint (try_frame_pre false pre_typing (|intro_st,c|) res_ppname) post_hint t.range diff --git a/src/checker/Pulse.Checker.Match.fst b/src/checker/Pulse.Checker.Match.fst index 7ecff787f..48b7218f9 100644 --- a/src/checker/Pulse.Checker.Match.fst +++ b/src/checker/Pulse.Checker.Match.fst @@ -270,11 +270,11 @@ let check_branch in { t with effect_tag = e.effect_tag } in - let pre_typing : unit = () in // weakened w/ binders and branch eq + // weakened w/ binders and branch eq let (| e, c |) = let ppname = mk_ppname_no_range "_br" in - let r = check g' pre pre_typing (PostHint post_hint) ppname e in + let r = check g' pre () (PostHint post_hint) ppname e in apply_checker_result_k r ppname in (| p, close_st_term_n e (L.map (fun (b: var_binding) -> b.x) pulse_bs), c |) @@ -544,6 +544,6 @@ let check assume (L.map (fun br -> elab_pat br.pat) brs == elab_pats'); let c_typing = comp_typing_from_post_hint c pre_typing post_hint in let t = wtag (Some (ctag_of_comp_st c)) (Tm_Match {sc; returns_=None; brs}) in - let d : unit = () in + checker_result_for_st_typing (| t, c |) res_ppname #pop-options \ No newline at end of file diff --git a/src/checker/Pulse.Checker.Prover.fst b/src/checker/Pulse.Checker.Prover.fst index c9fa9c73a..c8a44d7ea 100644 --- a/src/checker/Pulse.Checker.Prover.fst +++ b/src/checker/Pulse.Checker.Prover.fst @@ -248,13 +248,13 @@ let prover_result_join #g #ctxt #goals #g1 #ctxt1 #goals1 let before1, after1 = k1 g3 in let before2, after2 = k2 g3 in (fun frame -> - let h1: unit = () in - let h2: unit = () in - k_elab_trans (before1 frame) (k_elab_equiv (elab_slprops (frame @ solved1 @ ctxt1)) (elab_slprops (frame @ (solved1 @ solved2) @ ctxt2)) (before2 (frame @ solved1)) h1 h2)), + + + k_elab_trans (before1 frame) (k_elab_equiv (elab_slprops (frame @ solved1 @ ctxt1)) (elab_slprops (frame @ (solved1 @ solved2) @ ctxt2)) (before2 (frame @ solved1)) () ())), (fun frame -> - let h1: unit = () in - let h2: unit = () in - k_elab_trans (k_elab_equiv (elab_slprops (frame @ (solved1 @ solved2) @ goals2)) (elab_slprops (frame @ solved1 @ goals1)) (after2 (frame @ solved1)) h1 h2) (after1 frame)) + + + k_elab_trans (k_elab_equiv (elab_slprops (frame @ (solved1 @ solved2) @ goals2)) (elab_slprops (frame @ solved1 @ goals1)) (after2 (frame @ solved1)) () ()) (after1 frame)) <: T.Tac _ |) let prove_first (g: env) (ctxt goals: list slprop_view) @@ -272,9 +272,9 @@ let prove_first (g: env) (ctxt goals: list slprop_view) let before, after = res g'' in before, (fun frame -> - let h1 : unit = () in - let h2 : unit = () in - k_elab_equiv (elab_slprops (frame @ solved @ List.Tot.Base.rev goals_left_rev @ goals' @ goals)) (elab_slprops (frame @ goals0)) (after (frame @ List.rev goals_left_rev @ goals)) h1 h2) |) + + + k_elab_equiv (elab_slprops (frame @ solved @ List.Tot.Base.rev goals_left_rev @ goals' @ goals)) (elab_slprops (frame @ goals0)) (after (frame @ List.rev goals_left_rev @ goals)) () ()) |) | None -> assert List.rev goals_left_rev @ (goal::goals) == goals0; assume List.rev (goal::goals_left_rev) @ goals == goals0; @@ -312,8 +312,8 @@ let continuation_elaborator_with_bind_nondep_unit (#g:env) (ctxt:term) g (tm_star (open_term' (comp_post c1) unit_const 0) ctxt)) = let c1 = with_st_comp c1 { st_comp_of_comp c1 with post = open_term' (comp_post c1) unit_const 0 } in - let e1_typing: unit = () in - continuation_elaborator_with_bind_nondep #g ctxt c1 e1 e1_typing ctxt_pre1_typing + + continuation_elaborator_with_bind_nondep #g ctxt c1 e1 () ctxt_pre1_typing let cont_elab_with_bind_nondep_unit (#g:env) (c1:comp_st{comp_res c1 == tm_unit }) @@ -326,14 +326,14 @@ let cont_elab_with_bind_nondep_unit (#g:env) g [Unknown (open_term' (comp_post c1) unit_const 0)]) = fun frame posth t -> - let h1: unit = () in - let h2: unit = () in - let h3: unit = () in + + + k_elab_equiv (elab_slprops (frame @ [Unknown (comp_pre c1)])) (elab_slprops (frame @ [Unknown (open_term' (comp_post c1) unit_const 0)])) - (continuation_elaborator_with_bind_nondep_unit (elab_slprops frame) c1 e1 e1_typing h1) - h2 h3 posth t + (continuation_elaborator_with_bind_nondep_unit (elab_slprops frame) c1 e1 e1_typing ()) + () () posth t let tot_typing_tm_unit (g: env) : unit = () @@ -342,11 +342,11 @@ let intro_pure (g: env) (frame: slprop) (p: term) (pv:prop_validity g p): continuation_elaborator g frame g (frame `tm_star` tm_pure p) = fun post t -> - let frame_typ : unit = () in // implied by t2_typing - let h: unit = () in + // implied by t2_typing + let st = wtag (Some STT_Ghost) (Tm_IntroPure { p }) in debug_prover g (fun _ -> Printf.sprintf "intro_pure p=%s\nframe=%s\n" (show p) (show frame)); - k_elab_equiv frame (frame `tm_star` tm_pure p) (continuation_elaborator_with_bind_nondep frame (comp_intro_pure p) st () h) (()) (()) + k_elab_equiv frame (frame `tm_star` tm_pure p) (continuation_elaborator_with_bind_nondep frame (comp_intro_pure p) st () ()) (()) (()) post t let is_uvar (t:term) : bool = @@ -385,17 +385,17 @@ let prove_pure (g: env) (ctxt: list slprop_view) (skip_eq_uvar: bool) (goal: slp debug_prover g (fun _ -> Printf.sprintf "prove_pure p=%s success" (show p)); Some (| g, ctxt, [], [], fun g'' -> - let p_typing: unit = () in // implied by t2_typing + // implied by t2_typing let pv = check_prop_validity g'' p in cont_elab_refl g ctxt ([] @ ctxt) (()), (fun frame -> - let h1: unit = () in - let h2: unit = () in + + k_elab_equiv (elab_slprops (frame @ [] @ [])) (elab_slprops (frame @ [goal])) - (intro_pure g'' (elab_slprops frame) p p_typing pv) - h1 h2) + (intro_pure g'' (elab_slprops frame) p () pv) + () ()) <: T.Tac _ |) end | _ -> None @@ -404,16 +404,16 @@ let intro_with_pure (g: env) (frame: slprop) (p: term) (n: ppname) (v: term) : continuation_elaborator g (frame `tm_star` v) g (frame `tm_star` tm_with_pure p n v) = fun post t -> let g = push_context g "check_intro_with_pure" (RU.range_of_term p) in - let p_typing: unit = () in // implied by t2_typing + // implied by t2_typing let pv = check_prop_validity g p in - let frame_typ : unit = () in // implied by t2_typing + // implied by t2_typing let ty = mk_squash u0 p in let st = wtag (Some STT_Ghost) (Tm_ST { t = tm_unknown; args = [] }) in let c = C_STGhost tm_emp_inames { u=u0; res=tm_unit; pre=v; post=tm_with_pure p n v } in - let typing: unit = () in - let h: unit = () in + + debug_prover g (fun _ -> Printf.sprintf "intro_pure p=%s\nframe=%s\n" (show p) (show frame)); - k_elab_equiv (frame `tm_star` v) (frame `tm_star` tm_with_pure p n v) (continuation_elaborator_with_bind_nondep frame c st typing h) (()) (()) + k_elab_equiv (frame `tm_star` v) (frame `tm_star` tm_with_pure p n v) (continuation_elaborator_with_bind_nondep frame c st () ()) (()) (()) post t let prove_with_pure (g: env) (ctxt: list slprop_view) skip_eq_uvar (goal: slprop_view) : @@ -425,9 +425,9 @@ let prove_with_pure (g: env) (ctxt: list slprop_view) skip_eq_uvar (goal: slprop Some (| g, ctxt, [Unknown v], [], fun g'' -> cont_elab_refl g ctxt ([] @ ctxt) (()), (fun frame -> - let h1: unit = () in - let h2: unit = () in - k_elab_equiv (elab_slprops (frame @ [Unknown v] @ [])) (elab_slprops (frame @ [goal])) (intro_with_pure g'' (elab_slprops frame) p n v) h1 h2) + + + k_elab_equiv (elab_slprops (frame @ [Unknown v] @ [])) (elab_slprops (frame @ [goal])) (intro_with_pure g'' (elab_slprops frame) p n v) () ()) <: T.Tac _ |) | _ -> None @@ -435,17 +435,17 @@ let intro_exists (g: env) (frame: slprop) (u: universe) (b: binder) (body: slpro continuation_elaborator g (frame `tm_star` open_term' body e 0) g (frame `tm_star` tm_exists_sl u b body) = fun post t -> let g = push_context g "check_intro_exists" (RU.range_of_term body) in - let frame_typ : unit = () in // implied by t2_typing - let binder_ty_typ : unit = () in // implied by t2_typing - let tm_ex_typ : unit = () in // implied by t2_typing + // implied by t2_typing + // implied by t2_typing + // implied by t2_typing let _ = core_check_term' g e T.E_Ghost b.binder_ty (fun _ -> let open Pulse.PP in [text "Cannot find witness for" ^/^ pp (tm_exists_sl u b body)]) in - let h1: unit = () in - let h2: unit = () in - let h3: unit = () in + + + let st = wtag (Some STT_Ghost) (Tm_IntroExists { p = tm_exists_sl u b body; witnesses = [e] }) in debug_prover g (fun _ -> Printf.sprintf "intro_exists %s\nframe=%s\n" (show (tm_exists_sl u b body)) (show frame)); - k_elab_equiv (frame `tm_star` open_term' body e 0) (frame `tm_star` tm_exists_sl u b body) (continuation_elaborator_with_bind_nondep frame (comp_intro_exists u b body e) st () h1) h2 h3 + k_elab_equiv (frame `tm_star` open_term' body e 0) (frame `tm_star` tm_exists_sl u b body) (continuation_elaborator_with_bind_nondep frame (comp_intro_exists u b body e) st () ()) () () post t let prove_exists (g: env) (ctxt: list slprop_view) (goal: slprop_view) : @@ -457,9 +457,9 @@ let prove_exists (g: env) (ctxt: list slprop_view) (goal: slprop_view) : Some (| g, ctxt, [Unknown (open_term' body e 0)], [], fun g'' -> cont_elab_refl g ctxt ([] @ ctxt) (()), (fun frame -> - let h1: unit = () in - let h2: unit = () in - k_elab_equiv (elab_slprops (frame @ [] @ [Unknown (open_term' body e 0)])) (elab_slprops (frame @ [goal])) (intro_exists g'' (elab_slprops frame) u b body e) h1 h2) + + + k_elab_equiv (elab_slprops (frame @ [] @ [Unknown (open_term' body e 0)])) (elab_slprops (frame @ [goal])) (intro_exists g'' (elab_slprops frame) u b body e) () ()) <: T.Tac _ |) | _ -> None @@ -472,8 +472,8 @@ let unpack_and_norm_goal (g: env) (ctxt: list slprop_view) (goal: slprop_view) : (match goal'' with | [Unknown _] -> None | _ -> Some (| g, ctxt, goal'', [], fun g' -> - let h: unit = () in - cont_elab_refl _ _ _ (()), cont_elab_refl _ _ _ h + + cont_elab_refl _ _ _ (()), cont_elab_refl _ _ _ () <: T.Tac _ |)) | _ -> None @@ -496,12 +496,12 @@ let elim_first' (g: env) (ctxt0 goals: list slprop_view) assert goals' == []; Some (| g', List.rev ctxt_left_rev @ ctxt' @ ctxt, goals, solved, fun (g'': env { env_extends g'' g' }) -> let before, after = res g'' in - let h1: unit = () in - let h2: unit = () in - let h3: unit = () in - let h4: unit = () in - cont_elab_equiv (cont_elab_frame before (List.rev ctxt_left_rev @ ctxt)) h1 h2, - cont_elab_equiv (cont_elab_frame after goals) h3 h4 |) + + + + + cont_elab_equiv (cont_elab_frame before (List.rev ctxt_left_rev @ ctxt)) () (), + cont_elab_equiv (cont_elab_frame after goals) () () |) | None -> assert List.rev ctxt_left_rev @ (c::ctxt) == ctxt0; assume List.rev (c::ctxt_left_rev) @ ctxt == ctxt0; @@ -525,17 +525,17 @@ let unreachable_elim (g: env) (goals: list slprop_view) : cont_elab g [IsUnreach let frame_t = elab_slprops frame in let c = C_STGhost tm_emp_inames { u=u0; res=tm_unit; pre=tm_is_unreachable; post=frame_t } in let st = unreachable_elim_typing g u0 tm_unit frame_t in - let typing : unit = () in - let h: unit = () in - k_elab_equiv (elab_slprops (frame @ [IsUnreachable])) (elab_slprops (frame @ goals)) (continuation_elaborator_with_bind_nondep frame_t c st typing h) (()) (()) + + + k_elab_equiv (elab_slprops (frame @ [IsUnreachable])) (elab_slprops (frame @ goals)) (continuation_elaborator_with_bind_nondep frame_t c st () ()) (()) (()) post t let elim_is_unreachable (g: env) (ctxt goals: list slprop_view) : T.Tac (option (prover_result g ctxt goals)) = if not (List.existsb IsUnreachable? ctxt) then None else // TODO: maybe add `_: squash False` to the environment? - let h1 : unit = () in - Some (| g, [IsUnreachable], [], [IsUnreachable], (fun g'' -> cont_elab_refl _ _ _ h1, unreachable_elim _ _ <: T.Tac _)|) + + Some (| g, [IsUnreachable], [], [IsUnreachable], (fun g'' -> cont_elab_refl _ _ _ (), unreachable_elim _ _ <: T.Tac _)|) let elim_is_unreachable' (g: env) (ctxt goals: list slprop_view) : T.Tac (option (prover_result_samegoals g ctxt goals)) = @@ -545,10 +545,10 @@ let elim_is_unreachable' (g: env) (ctxt goals: list slprop_view) : if not (List.existsb IsUnreachable? ctxt) then None else // TODO: maybe add `_: squash False` to the environment? Some (| g, [IsUnreachable], goals, [IsUnreachable], (fun g'' -> - let h1 : unit = () in - let h2: unit = () in - cont_elab_refl _ _ _ h1, - cont_elab_equiv (unreachable_elim g'' goals) h2 (()) + + + cont_elab_refl _ _ _ (), + cont_elab_equiv (unreachable_elim g'' goals) () (()) <: T.Tac _)|) let unpack_and_norm_ctxt (g: env) (ctxt: slprop_view) : @@ -560,8 +560,8 @@ let unpack_and_norm_ctxt (g: env) (ctxt: slprop_view) : (match ctxt'' with | [Unknown _] -> None | _ -> Some (| g, ctxt'', [], [], fun g' -> - let h: unit = () in - cont_elab_refl _ _ _ h, cont_elab_refl _ _ _ (()) + + cont_elab_refl _ _ _ (), cont_elab_refl _ _ _ (()) <: T.Tac _ |)) | _ -> None @@ -571,12 +571,12 @@ let elim_pure (g: env) (frame: slprop) (p: term) (x: nvar { ~(Set.mem (snd x) (d let ty = mk_squash u0 p in let st = wtag (Some STT_Ghost) (Tm_ST { t = tm_unknown; args = [] }) in let c = C_STGhost tm_emp_inames { u=u0; res=ty; pre=tm_pure p; post=tm_emp } in - let typing: unit = () in - let h: unit = () in - let h2: unit = () in + + + let k: continuation_elaborator g (tm_star frame (tm_pure p)) g' (tm_star tm_emp frame) = - continuation_elaborator_with_bind frame c st typing h x in - k_elab_equiv (frame `tm_star` tm_pure p) frame k () h2 post t + continuation_elaborator_with_bind frame c st () () x in + k_elab_equiv (frame `tm_star` tm_pure p) frame k () () post t let elim_pure_step (g: env) (ctxt: slprop_view) : T.Tac (option (prover_result_nogoals g [ctxt])) = @@ -587,9 +587,9 @@ let elim_pure_step (g: env) (ctxt: slprop_view) : let g' = push_binding g (snd x) (fst x) ty in Some (| g', [], [], [], fun g'' -> (fun frame -> - let h1: unit = () in - let h2: unit = () in - k_elab_equiv (elab_slprops (frame @ [ctxt])) (elab_slprops (frame @ [] @ [])) (elim_pure g (elab_slprops frame) p x g') h1 h2), + + + k_elab_equiv (elab_slprops (frame @ [ctxt])) (elab_slprops (frame @ [] @ [])) (elim_pure g (elab_slprops frame) p x g') () ()), cont_elab_refl _ _ _ (()) <: T.Tac _ |) | _ -> None @@ -602,12 +602,12 @@ let elim_with_pure (g: env) (frame: slprop) (p: term) (x: nvar { ~(Set.mem (snd let st = wtag (Some STT_Ghost) (Tm_ST { t = tm_unknown; args = [] }) in let c = C_STGhost tm_emp_inames { u=u0; res=ty; pre=tm_with_pure p (fst x) v; post=v } in assume open_term v (snd x) == v; // no loose bvars - let typing: unit = () in - let h: unit = () in - let h2: unit = () in + + + let k: continuation_elaborator g (tm_star frame (tm_with_pure p (fst x) v)) g' (tm_star v frame) = - continuation_elaborator_with_bind frame c st typing h x in - k_elab_equiv (frame `tm_star` tm_with_pure p (fst x) v) (frame `tm_star` v) k () h2 post t + continuation_elaborator_with_bind frame c st () () x in + k_elab_equiv (frame `tm_star` tm_with_pure p (fst x) v) (frame `tm_star` v) k () () post t let elim_with_pure_step (g: env) (ctxt: slprop_view) : T.Tac (option (prover_result_nogoals g [ctxt])) = @@ -618,9 +618,9 @@ let elim_with_pure_step (g: env) (ctxt: slprop_view) : let g' = push_binding g (snd x) (fst x) ty in Some (| g', [Unknown v], [], [], fun g'' -> (fun frame -> - let h1: unit = () in - let h2: unit = () in - k_elab_equiv (elab_slprops (frame @ [ctxt])) (elab_slprops (frame @ [Unknown v] @ [])) (elim_with_pure g (elab_slprops frame) p x v g') h1 h2), + + + k_elab_equiv (elab_slprops (frame @ [ctxt])) (elab_slprops (frame @ [Unknown v] @ [])) (elim_with_pure g (elab_slprops frame) p x v g') () ()), cont_elab_refl _ _ _ (()) <: T.Tac _ |) | _ -> None @@ -631,17 +631,17 @@ let elim_exists (g: env) (frame: slprop) u b body (x: nvar { ~(Set.mem (snd x) ( continuation_elaborator g (frame `tm_star` tm_exists_sl u b body) g' (frame `tm_star` open_term' body (mk_reveal u b.binder_ty (term_of_nvar x)) 0) = fun post t -> let c = comp_elim_exists u b.binder_ty body x in - let h1: unit = () in - let h2: unit = () in + + let st : st_term = wtag (Some STT_Ghost) (Tm_ElimExists { p = tm_exists_sl u (as_binder b.binder_ty) body }) in - let typing: unit = () in - let h: unit = () in + + let c_post_x = open_term' body (mk_reveal u b.binder_ty (term_of_nvar x)) 0 in assume open_term (comp_post c) (snd x) == c_post_x; - let h2: unit = () in + let k: continuation_elaborator g (tm_star frame (tm_exists_sl u b body)) g' (tm_star c_post_x frame) = - continuation_elaborator_with_bind frame c st typing h x in - k_elab_equiv (frame `tm_star` tm_exists_sl u b body) (frame `tm_star` c_post_x) k () h2 post t + continuation_elaborator_with_bind frame c st () () x in + k_elab_equiv (frame `tm_star` tm_exists_sl u b body) (frame `tm_star` c_post_x) k () () post t let elim_exists_step (g: env) (ctxt: slprop_view) : T.Tac (option (prover_result_nogoals g [ctxt])) = @@ -655,9 +655,9 @@ let elim_exists_step (g: env) (ctxt: slprop_view) : let result = open_term' body (mk_reveal u b.binder_ty (term_of_nvar x)) 0 in Some (| g', [Unknown result], [], [], fun g'' -> (fun frame -> - let h1: unit = () in - let h2: unit = () in - k_elab_equiv (elab_slprops (frame @ [ctxt])) (elab_slprops (frame @ [] @ [Unknown result])) (elim_exists g (elab_slprops frame) u b body x g') h1 h2), + + + k_elab_equiv (elab_slprops (frame @ [ctxt])) (elab_slprops (frame @ [] @ [Unknown result])) (elim_exists g (elab_slprops frame) u b body x g') () ()), cont_elab_refl _ _ _ (()) <: T.Tac _ |) | _ -> None @@ -918,9 +918,9 @@ let prove_atom_unamb (g: env) (ctxt: list slprop_view) (goal: slprop_view) : let rest_ctxt = List.Tot.filter (fun (j, _) -> j <> i) ictxt |> List.Tot.map snd in Some (| g, rest_ctxt, [], [cand], fun g' -> let h2: unit = check_slprop_equiv_ext (RU.range_of_term goal) g (elab_slprop cand) goal in - let h1: unit = () in + let h2: unit = h2 in - cont_elab_refl _ _ _ h1, + cont_elab_refl _ _ _ (), cont_elab_refl _ _ _ h2 <: T.Tac _ |) | _ -> None @@ -947,9 +947,9 @@ let prove_atom (g: env) (ctxt: list slprop_view) (allow_amb: bool) (goal: slprop let rest_ctxt = List.Tot.filter (fun (j, _) -> j <> i) ictxt |> List.Tot.map snd in Some (| g, rest_ctxt, [], [cand], fun g' -> let h2: unit = check_slprop_equiv_ext (RU.range_of_term goal) g (elab_slprop cand) goal in - let h1: unit = () in + let h2: unit = h2 in - cont_elab_refl _ _ _ h1, + cont_elab_refl _ _ _ (), cont_elab_refl _ _ _ h2 <: T.Tac _ |) @@ -1021,14 +1021,14 @@ let try_apply_elim_lemma (g: env) (lid: R.name) (i: nat) (ctxt: slprop_view) : Some (| g, [Unknown post'], [], [], fun g'' -> let typing = core_check_term g t T.E_Ghost ty in let t' = wtag (Some STT_Ghost) (Tm_ST { t; args=[] }) in - let ni: unit = () in - let typing: unit = () in - let h1: unit = () in + + + let h2: unit = assume elab_slprop ctxt == pre; () in - let h3: unit = () in - let k_t = cont_elab_with_bind_nondep_unit c t' typing h1 in - cont_elab_equiv k_t h2 h3, + + let k_t = cont_elab_with_bind_nondep_unit c t' () () in + cont_elab_equiv k_t h2 (), cont_elab_refl g'' ([] @ []) [] (()) |) ) else None @@ -1064,14 +1064,14 @@ let try_apply_eager_intro_lemma (g: env) (lid: R.name) (i: nat) ctxt (goal: slpr Some (| g, ctxt, [Unknown pre], [], fun g'' -> let typing = core_check_term g'' t T.E_Ghost ty in let t' = wtag (Some STT_Ghost) (Tm_ST { t; args=[] }) in - let ni: unit = () in - let typing: unit = () in - let h1: unit = () in - let h2: unit = () in - let h3: unit = () in - let k_typing = cont_elab_with_bind_nondep_unit c t' typing h1 in + + + + + + let k_typing = cont_elab_with_bind_nondep_unit c t' () () in cont_elab_refl g ctxt ([] @ ctxt) (()), - cont_elab_equiv k_typing h2 h3 + cont_elab_equiv k_typing () () |) ) else None @@ -1125,8 +1125,8 @@ let prover_result_solved_unpack #g #ctxt #goals (res: prover_result_solved g ctx let (| g', ctxt', goals', solved, k |) = res in (| g', ctxt', cont_elab_thunk fun _ -> let k1, k2 = k g' in - let h: unit = () in - cont_elab_trans k1 (cont_elab_frame k2 ctxt') h |) + + cont_elab_trans k1 (cont_elab_frame k2 ctxt') () |) #restart-solver #push-options "--split_queries always --z3rlimit 15" @@ -1168,16 +1168,15 @@ let try_apply_intro_lemma (g: env) (lid: R.name) (i: nat) ctxt (goal: slprop_vie let c = C_STGhost inames { pre; post; res; u } in let typing = core_check_term g' t T.E_Ghost ty in let t' = wtag (Some STT_Ghost) (Tm_ST { t; args=[] }) in - let ni: unit = () in - let typing: unit = () in - let h1: unit = () in - let h2: unit = - () in - let h3: unit = () in - let k_typing = cont_elab_with_bind_nondep_unit c t' typing h1 in + + + + + + let k_typing = cont_elab_with_bind_nondep_unit c t' () () in let k_typing = cont_elab_frame k_typing ctxt' in let k_typing: cont_elab g' (ctxt' @ [Unknown pre]) g' ([goal] @ ctxt' @ post''_rest) = - cont_elab_equiv k_typing h2 h3 in + cont_elab_equiv k_typing () () in cont_elab_trans k k_typing (()), cont_elab_refl g'' ([goal] @ []) [goal] (()) <: cont_elab g ctxt g' ([goal] @ ctxt' @ post''_rest) & cont_elab g'' ([goal] @ []) g'' [goal] @@ -1324,10 +1323,10 @@ let try_prove (g: env) (ctxt goals: slprop) allow_amb : T.Tac (prover_result g [ let (| g1, ctxt1, goals1, solved1, k1 |) = try_prove_core pg [Unknown ctxt'] [Unknown goals'] in (| g1, ctxt1, goals1, solved1, fun (g2: env { env_extends g2 g1 }) -> let before, after = k1 g2 in - let h1: unit = () in - let h2: unit = () in - cont_elab_equiv before h1 (()), - cont_elab_equiv after (()) h2 |) + + + cont_elab_equiv before () (()), + cont_elab_equiv after (()) () |) let prove rng (g: env) (ctxt goals: slprop) allow_amb : T.Tac (g':env { env_extends g' g } & @@ -1347,8 +1346,8 @@ let prove rng (g: env) (ctxt goals: slprop) allow_amb : (Some rng) else let (| g', ctxt', k |) = prover_result_solved_unpack res in - let h: unit = () in - (| g', RU.deep_compress_safe (elab_slprops ctxt'), k_elab_equiv ctxt (tm_star goals (RU.deep_compress_safe (elab_slprops ctxt'))) (k []) () h |) + + (| g', RU.deep_compress_safe (elab_slprops ctxt'), k_elab_equiv ctxt (tm_star goals (RU.deep_compress_safe (elab_slprops ctxt'))) (k []) () () |) let rec try_elim_core (pg: penv) (ctxt: list slprop_view) : T.Tac (prover_result_nogoals pg.penv_env ctxt) = @@ -1380,29 +1379,29 @@ let elim_exists_and_pure (#g:env) (#ctxt:slprop) let ctxt' = Pulse.Checker.Prover.Substs.ss_term ctxt ss in let pg = mk_penv g false in let (| g', ctxt'', goals'', solved, k |) = try_elim_core pg [Unknown ctxt'] in - let h: unit = () in // TODO thread through prover - (| g', elab_slprops ctxt'', h, fun post_hint post_hint_typ -> + // TODO thread through prover + (| g', elab_slprops ctxt'', (), fun post_hint post_hint_typ -> let h1: unit = (RU.magic() <: unit) in - let h2: unit = () in - let h3: unit = () in + + let before, after = k g' in k_elab_trans (k_elab_equiv ctxt (elab_slprops ([] @ solved @ ctxt'')) (before []) h1 (())) - (k_elab_equiv (elab_slprops ([] @ solved @ ctxt'')) (elab_slprops ctxt'') (after ctxt'') h2 h3) post_hint post_hint_typ |) + (k_elab_equiv (elab_slprops ([] @ solved @ ctxt'')) (elab_slprops ctxt'') (after ctxt'') () ()) post_hint post_hint_typ |) let k_unreach (g: env) (x: nvar { freshv g (snd x) }) (post_hint: post_hint_t { g `env_extends` post_hint.g }) : T.Tac (continuation_elaborator g tm_is_unreachable (push_binding g (snd x) (fst x) post_hint.ret_ty) (open_term_nv post_hint.post x)) = - let h: unit = () in - let c = Pulse.Typing.Combinators.comp_for_post_hint g tm_is_unreachable h post_hint (snd x) in + + let c = Pulse.Typing.Combinators.comp_for_post_hint g tm_is_unreachable () post_hint (snd x) in let st = wtag (Some (ctag_of_comp_st c)) (Tm_Unreachable { c }) in - let typ : unit = () in + let g' = push_binding g (snd x) (fst x) post_hint.ret_ty in let post_opened = open_term_nv post_hint.post x in let k_elim: continuation_elaborator g (tm_star tm_emp tm_is_unreachable) g' (tm_star post_opened tm_emp) = - let h3: unit = () in - continuation_elaborator_with_bind #g tm_emp c st typ h3 x in - let h4: unit = () in - let h5: unit = () in - k_elab_equiv tm_is_unreachable post_opened k_elim h4 h5 + + continuation_elaborator_with_bind #g tm_emp c st () () x in + + + k_elab_equiv tm_is_unreachable post_opened k_elim () () #restart-solver #push-options "--z3rlimit_factor 2 --split_queries always" @@ -1429,8 +1428,8 @@ let prove_post_hint (#g:env) (#ctxt:slprop) (r:checker_result_t g ctxt NoHint) ( let ppname = mk_ppname_no_range "_posth" in let post_hint_opened = open_term_nv post_hint.post (ppname, y) in let g4 = push_binding g3 y ppname post_hint.ret_ty in - let h1: unit = () in - let h2: unit = () in + + let k_unreach: continuation_elaborator g3 ctxt3 g4 post_hint_opened = k_unreach g3 (ppname, y) post_hint in (| y, g4, (post_hint.u, post_hint.ret_ty), post_hint_opened, @@ -1461,13 +1460,13 @@ let prove_post_hint (#g:env) (#ctxt:slprop) (r:checker_result_t g ctxt NoHint) ( else text "Did you forget to free this resource?"); ] else - let h3: unit = () in + // for the typing of ty in g3, we have typing of ty in g2 above, and g3 `env_extends` g2 - let h1: unit = () in + // for the typing of post_hint_opened, again post_hint is well-typed in g, and g3 `env_extends` g - let h2: unit = () in + (| x, g3, (u_ty, ty), post_hint_opened, - k_elab_trans k (k_elab_equiv ctxt' post_hint_opened k_post () h3) |) + k_elab_trans k (k_elab_equiv ctxt' post_hint_opened k_post () ()) |) #pop-options let try_frame_pre (allow_ambiguous : bool) (#g:env) @@ -1477,6 +1476,6 @@ let try_frame_pre (allow_ambiguous : bool) (#g:env) T.Tac (checker_result_t g ctxt NoHint) = let (| t, c |) = d in let (| g', ctxt', k |) = prove t.range g ctxt (comp_pre c) allow_ambiguous in - let d: unit = () in // weakening from g to g' - let h1: unit = () in // weakening from to g' + // weakening from g to g' + // weakening from to g' checker_result_for_st_typing (k _ (| t, add_frame c ctxt' |)) res_ppname \ No newline at end of file diff --git a/src/checker/Pulse.Checker.Pure.fst b/src/checker/Pulse.Checker.Pure.fst index e196023f7..7621e2f3d 100644 --- a/src/checker/Pulse.Checker.Pure.fst +++ b/src/checker/Pulse.Checker.Pure.fst @@ -597,7 +597,7 @@ let try_get_non_informative_witness_aux (g:env) (u:universe) (ty:term) (ty_typin let dict = wr r_dict (RU.range_of_term ty) in let r_dict_typing_token : squash (typing_token r_env r_dict (E_Total, goal)) = () in let r_dict_typing : RT.typing r_env r_dict (E_Total, goal) = RT.T_Token _ _ _ () in - let dict_typing : unit = () in + Some dict, issues ) diff --git a/src/checker/Pulse.Checker.Return.fst b/src/checker/Pulse.Checker.Return.fst index 1c6cd14ef..ad7bf464f 100644 --- a/src/checker/Pulse.Checker.Return.fst +++ b/src/checker/Pulse.Checker.Return.fst @@ -141,8 +141,8 @@ let check_core let post = close_term post_opened x in let ret_st = wtag (Some c) (Tm_Return {expected_type=tm_unknown; insert_eq=use_eq; term=t}) in let ret_c = comp_return c use_eq u ty t post x in - let d : unit = () in - let c' = match_comp_res_with_post_hint ret_st ret_c d post_hint in + + let c' = match_comp_res_with_post_hint ret_st ret_c () post_hint in Pulse.Checker.Util.debug g "pulse.return" (fun _ -> Printf.sprintf "Return comp is: %s" (Pulse.Syntax.Printer.comp_to_string c')); diff --git a/src/checker/Pulse.Checker.Rewrite.fst b/src/checker/Pulse.Checker.Rewrite.fst index 146cac261..cff9c0573 100644 --- a/src/checker/Pulse.Checker.Rewrite.fst +++ b/src/checker/Pulse.Checker.Rewrite.fst @@ -139,6 +139,6 @@ let check in let rew_st = wtag (Some STT_Ghost) (Tm_Rewrite { t1=p; t2=q; tac_opt=None; elaborated=true }) in let rew_c = C_STGhost tm_emp_inames { u=u0; res=tm_unit; pre=p; post=q } in - let d : unit = () in - let c = match_comp_res_with_post_hint rew_st rew_c d post_hint in + + let c = match_comp_res_with_post_hint rew_st rew_c () post_hint in prove_post_hint (try_frame_pre false pre_typing (| rew_st,c |) res_ppname) post_hint t.range diff --git a/src/checker/Pulse.Checker.SLPropEquiv.fst b/src/checker/Pulse.Checker.SLPropEquiv.fst index 73cb8faf5..921671a9a 100644 --- a/src/checker/Pulse.Checker.SLPropEquiv.fst +++ b/src/checker/Pulse.Checker.SLPropEquiv.fst @@ -27,9 +27,8 @@ let rec list_as_slprop_append g (vp0 vp1:list term) (decreases vp0) = match vp0 with | [] -> - let v : unit = () - in - v + + () | [hd] -> (* Need to check vp1 too in this case *) begin match vp1 with @@ -38,12 +37,9 @@ let rec list_as_slprop_append g (vp0 vp1:list term) end | hd::tl -> let tl_vp1 = list_as_slprop_append g tl vp1 in - let d : unit - = () - in - let d : unit - = () in - d + + + () let list_as_slprop_comm g (vp0 vp1:list term) @@ -98,8 +94,7 @@ let slprop_equiv_swap_equiv (g:env) let d' : unit = List.Tot.append_assoc [q] l0 l2; () in - let d : unit - = () in + let d_q_p = d_p_q in let d' : unit = d_q_p in let d' : unit @@ -113,18 +108,8 @@ let slprop_equiv_split_frame (g:env) (ctxt req:term) (frame:list term) = let ctxt_l = slprop_as_list ctxt in let req_l = slprop_as_list req in let veq : unit = veq in - let d1 - : unit - = () - in - let d1 - : unit - = () - in - let d : unit = - () - in - let d : unit = - () - in - d + + + + + () diff --git a/src/checker/Pulse.Checker.ST.fst b/src/checker/Pulse.Checker.ST.fst index 5c514cb0b..6030f618a 100644 --- a/src/checker/Pulse.Checker.ST.fst +++ b/src/checker/Pulse.Checker.ST.fst @@ -105,7 +105,7 @@ let check () ) in - let h: unit = () in // TODO: thread through prover + // TODO: thread through prover if comp_post c `eq_tm` tm_is_unreachable then let framed = checker_result_for_st_typing (k _ (| t, add_frame c ctxt' |)) res_ppname in RU.record_stats "prove_post_hint" fun _ -> prove_post_hint framed post_hint range diff --git a/src/checker/Pulse.Checker.While.fst b/src/checker/Pulse.Checker.While.fst index e6da684c8..a6e0c9baa 100644 --- a/src/checker/Pulse.Checker.While.fst +++ b/src/checker/Pulse.Checker.While.fst @@ -213,9 +213,9 @@ let check_while assume freshv g0 (snd x_meas); let g1 = push_binding g0 (snd x_meas) (fst x_meas) ty_meas in let inv = tm_star (RU.deep_compress_safe inv) remaining in - let inv_typing : unit = () in + let res_cond : checker_result_t g1 inv (TypeHint tm_bool) = - check (push_context "check_while_condition" cond.range g1) inv inv_typing (TypeHint tm_bool) ppname_default cond in + check (push_context "check_while_condition" cond.range g1) inv () (TypeHint tm_bool) ppname_default cond in let (| post_cond, r_cond |) : (ph:post_hint_for_env g1 & Pulse.Typing.Combinators.st_typing_in_ctxt g1 inv (PostHint ph)) = let res_cond = retype_checker_result NoHint res_cond in let ph = Pulse.JoinComp.infer_post res_cond in @@ -246,12 +246,12 @@ let check_while assert g1 `env_extends` g0; assert g1' `env_extends` g1; assert g1'' `env_extends` g1'; - let loop_ensures_typ: unit = () in - let unit_typ: unit = () in + + let loop_ensures = Pulse.JoinComp.infer_post' g0 g1'' u0 tm_unit y () loop_ensures () in let loop_ensures = subst_loop_requires_marker_with_true loop_ensures.post in let loop_ensures = open_term' loop_ensures unit_const 0 in - let loop_ensures_typ: unit = () in + loop_ensures | None -> let t: term = tm_exists_sl u_meas (as_binder ty_meas) (close_term (open_term' post_cond.post tm_false 0) (snd x_meas)) in @@ -274,16 +274,15 @@ let check_while let post_cond : post_hint_for_env g2 = assume post_hint_for_env_p g2 post_cond; post_cond in let r_cond : Pulse.Typing.Combinators.st_typing_in_ctxt g2 inv (PostHint post_cond) = let (| t, c |) = r_cond in - let typ : unit = () in + (| t, c |) in let body_pre_open = post_cond.post in - let body_post_typing : unit = () in - let body_ph : post_hint_for_env g2 = inv_as_post_hint g2 (comp_post (comp_while_body u_meas ty_meas is_tot dec_formula x_meas inv body_pre_open)) body_post_typing in + + let body_ph : post_hint_for_env g2 = inv_as_post_hint g2 (comp_post (comp_while_body u_meas ty_meas is_tot dec_formula x_meas inv body_pre_open)) () in assert body_ph.ret_ty == tm_unit; let x = fresh g2 in - let body_open_pre_typing : unit = - () in + let body_pre_typing = () in let r_body = check @@ -298,14 +297,13 @@ let check_while assert (comp_u comp_body == comp_u (comp_while_body u_meas ty_meas is_tot dec_formula x_meas inv body_pre_open)); assert (comp_res comp_body == comp_res (comp_while_body u_meas ty_meas is_tot dec_formula x_meas inv body_pre_open)); assert (comp_body == comp_while_body u_meas ty_meas is_tot dec_formula x_meas inv body_pre_open); - let inv_typing2 : unit = () in + let while = wtag (Some STT) (Tm_While { invariant = inv; loop_requires = tm_unknown; meas = []; condition = cond; body }) in - let typ_meas: unit = () in + assume ~(snd x_meas `Set.mem` freevars_st cond); assume ~(snd x_meas `Set.mem` freevars_st body); - let d: unit = - () in + let C_ST cst = comp_while u_meas ty_meas x_meas inv body_pre_open in let loop_pre = tm_exists_sl u_meas (as_binder ty_meas) (close_term inv (snd x_meas)) in assert comp_pre (comp_while u_meas ty_meas x_meas inv body_pre_open) == loop_pre; @@ -335,14 +333,13 @@ let check_while (Tm_ForwardJumpLabel { lbl = breaklbln; body = close_st_term while breaklblx; post = while_comp }) in admit (); assert break_lbl_c == goto_comp_of_block_comp while_comp; - let fjl_d: unit = - () in + let d_st: Pulse.Typing.Combinators.st_typing_in_ctxt g0 loop_pre (TypeHint tm_unit) = (| fjl, while_comp |) in let d_st: Pulse.Typing.Combinators.st_typing_in_ctxt g0 loop_pre0 (TypeHint tm_unit) = let (| t, c |) = d_st in let c = with_st_comp c { st_comp_of_comp c with pre = loop_pre0 } in - let typ : unit = () in + (| t, c |) in let d_st : Pulse.Typing.Combinators.st_typing_in_ctxt g pre NoHint = k NoHint d_st in diff --git a/src/checker/Pulse.JoinComp.fst b/src/checker/Pulse.JoinComp.fst index e51119e0d..c9f66f756 100644 --- a/src/checker/Pulse.JoinComp.fst +++ b/src/checker/Pulse.JoinComp.fst @@ -410,23 +410,22 @@ let rec join_comps | C_STAtomic inames obs1 st, C_STAtomic _ obs2 _ -> let obs = join_obs obs1 obs2 in let c = C_STAtomic inames obs st in - let e_then_typing : unit = () in - let e_else_typing : unit = () in - (| c, e_then_typing, e_else_typing |) + + + (| c, (), () |) | C_STGhost _ _, C_STGhost _ _ - | C_ST _, C_ST _ -> (| c_then, e_then_typing, e_else_typing |) + | C_ST _, C_ST _ -> (| c_then, (), () |) | _ -> assert (EffectAnnotAtomicOrGhost? post.effect_annot); match c_then, c_else with | C_STGhost _ _, C_STAtomic _ _ _ -> - let d : unit = - () in + st_ghost_as_atomic_matches_post_hint c_then post; - join_comps g_then e_then (st_ghost_as_atomic c_then) d g_else e_else c_else e_else_typing post + join_comps g_then e_then (st_ghost_as_atomic c_then) () g_else e_else c_else () post | C_STAtomic _ _ _, C_STGhost _ _ -> - let d : unit = () in + st_ghost_as_atomic_matches_post_hint c_else post; - join_comps g_then e_then c_then e_then_typing g_else e_else (st_ghost_as_atomic c_else) d post + join_comps g_then e_then c_then () g_else e_else (st_ghost_as_atomic c_else) () post #pop-options diff --git a/src/checker/Pulse.Main.fst b/src/checker/Pulse.Main.fst index a0871a25d..c389a5cf4 100644 --- a/src/checker/Pulse.Main.fst +++ b/src/checker/Pulse.Main.fst @@ -221,9 +221,9 @@ let main' (d:decl) (pre:term) (g:RT.fstar_top_env) (expected_t:option term) let (| pre, ty |) = Pulse.Checker.Pure.compute_tot_term_type g pre in if not (eq_tm ty tm_slprop) then fail g (Some (Pulse.RuntimeUtils.range_of_term pre)) "pulse main: cannot typecheck pre at type slprop"; //fix range - let pre_typing : unit = () in + match d.d with - | FnDefn {} -> check_fndefn d g expected_t pre pre_typing + | FnDefn {} -> check_fndefn d g expected_t pre () | FnDecl {} -> if None? expected_t then check_fndecl d g From 408abd9f131ae743d2ec8c30df84427b59a1d254 Mon Sep 17 00:00:00 2001 From: Gabriel Ebner Date: Sat, 28 Feb 2026 20:14:46 +0000 Subject: [PATCH 14/18] Remove pre_typing/ctxt_typing unit parameters from checker functions Remove the (pre_typing:unit) parameter from all checker check functions and their call sites, and (ctxt_typing:unit) from Return.check. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/checker/Pulse.Checker.Admit.fst | 3 +- src/checker/Pulse.Checker.Admit.fsti | 1 - .../Pulse.Checker.AssertWithBinders.fst | 15 ++--- .../Pulse.Checker.AssertWithBinders.fsti | 1 - src/checker/Pulse.Checker.Bind.fst | 19 +++---- src/checker/Pulse.Checker.Bind.fsti | 2 - src/checker/Pulse.Checker.Exists.fst | 6 +- src/checker/Pulse.Checker.Exists.fsti | 2 - .../Pulse.Checker.ForwardJumpLabel.fst | 5 +- .../Pulse.Checker.ForwardJumpLabel.fsti | 1 - src/checker/Pulse.Checker.Goto.fst | 10 ++-- src/checker/Pulse.Checker.Goto.fsti | 1 - src/checker/Pulse.Checker.If.fst | 8 +-- src/checker/Pulse.Checker.If.fsti | 1 - src/checker/Pulse.Checker.IntroPure.fst | 3 +- src/checker/Pulse.Checker.IntroPure.fsti | 1 - src/checker/Pulse.Checker.Match.fst | 12 ++-- src/checker/Pulse.Checker.Match.fsti | 1 - src/checker/Pulse.Checker.Return.fst | 10 ++-- src/checker/Pulse.Checker.Return.fsti | 1 - src/checker/Pulse.Checker.Rewrite.fst | 3 +- src/checker/Pulse.Checker.Rewrite.fsti | 1 - src/checker/Pulse.Checker.ST.fst | 1 - src/checker/Pulse.Checker.ST.fsti | 1 - src/checker/Pulse.Checker.While.fst | 1 - src/checker/Pulse.Checker.While.fsti | 1 - src/checker/Pulse.Checker.WithLocal.fst | 5 +- src/checker/Pulse.Checker.WithLocal.fsti | 1 - src/checker/Pulse.Checker.WithLocalArray.fst | 5 +- src/checker/Pulse.Checker.WithLocalArray.fsti | 1 - src/checker/Pulse.Checker.fst | 56 +++++++++---------- src/checker/Pulse.Main.fst | 2 +- 32 files changed, 69 insertions(+), 112 deletions(-) diff --git a/src/checker/Pulse.Checker.Admit.fst b/src/checker/Pulse.Checker.Admit.fst index ea0a6718b..6a9168c8a 100644 --- a/src/checker/Pulse.Checker.Admit.fst +++ b/src/checker/Pulse.Checker.Admit.fst @@ -29,7 +29,6 @@ module P = Pulse.Syntax.Printer let check (g:env) (pre:term) - (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_Admit? t.term }) @@ -71,7 +70,7 @@ let check | STT_Ghost -> C_STGhost tm_emp_inames s | STT_Atomic -> C_STAtomic tm_emp_inames Neutral s) - | _, PostHint post -> Pulse.Typing.Combinators.comp_for_post_hint g pre pre_typing post x + | _, PostHint post -> Pulse.Typing.Combinators.comp_for_post_hint g pre () post x in let c = res in let admit_st = wtag (Some (ctag_of_comp_st c)) diff --git a/src/checker/Pulse.Checker.Admit.fsti b/src/checker/Pulse.Checker.Admit.fsti index 591b82698..8814e3b34 100644 --- a/src/checker/Pulse.Checker.Admit.fsti +++ b/src/checker/Pulse.Checker.Admit.fsti @@ -25,7 +25,6 @@ open Pulse.Checker.Base val check (g:env) (pre:term) - (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_Admit? t.term }) diff --git a/src/checker/Pulse.Checker.AssertWithBinders.fst b/src/checker/Pulse.Checker.AssertWithBinders.fst index 93be8e045..1276f3f44 100644 --- a/src/checker/Pulse.Checker.AssertWithBinders.fst +++ b/src/checker/Pulse.Checker.AssertWithBinders.fst @@ -318,7 +318,6 @@ let rec check_pairs (g:env) rng (ps: list (term & term)) (tac_opt:option term) : let check_renaming (g:env) (pre:term) - (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (st:st_term { @@ -342,7 +341,7 @@ let check_renaming // ... let body = {st with term = Tm_ProofHintWithBinders { ht with binders = [] }; source = Sealed.seal false; } in - check g pre pre_typing post_hint res_ppname + check g pre () post_hint res_ppname { st with term = Tm_ProofHintWithBinders { hint_type=ASSERT { p = goal; elaborated = true }; binders=bs; t=body }; source = Sealed.seal false; @@ -361,7 +360,7 @@ let check_renaming let rhs, _ = rewrite_all st.range (T.unseal st.source) g pairs goal pre elaborated tac_opt true in let t = { st with term = Tm_Rewrite { t1 = goal; t2 = rhs; tac_opt; elaborated = true }; source = Sealed.seal false; } in - check g pre pre_typing post_hint res_ppname + check g pre () post_hint res_ppname { st with term = Tm_Bind { binder = as_binder tm_unit; head = t; body }; source = Sealed.seal false; } @@ -403,7 +402,6 @@ let open_st_term_with_reveals (t: st_term) (xs: list (universe & typ & nvar)) : let check_wild (g:env) (pre:term) - (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (st:st_term { head_wild st }) @@ -462,7 +460,6 @@ let rec add_rem_uvs (g:env) (t:typ) (v:term) let check (g:env) (pre:term) - (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (st:st_term { Tm_ProofHintWithBinders? st.term }) @@ -476,7 +473,7 @@ let check allow_invert hint_type; match hint_type with | WILD -> - check_wild g pre pre_typing post_hint res_ppname st check + check_wild g pre post_hint res_ppname st check | SHOW_PROOF_STATE r -> let open FStar.Pprint in @@ -488,19 +485,19 @@ let check fail_doc_env true g (Some r) msg | RENAME {} -> - check_renaming g pre pre_typing post_hint res_ppname st check + check_renaming g pre post_hint res_ppname st check | REWRITE { t1; t2; tac_opt; elaborated } -> ( match bs with | [] -> let t = { st with term = Tm_Rewrite { t1; t2; tac_opt; elaborated } } in - check g pre pre_typing post_hint res_ppname + check g pre () post_hint res_ppname { st with term = Tm_Bind { binder = as_binder tm_unit; head = t; body } } | _ -> let t = { st with term = Tm_Rewrite { t1; t2; tac_opt; elaborated } } in let body = { st with term = Tm_Bind { binder = as_binder tm_unit; head = t; body } } in let st = { st with term = Tm_ProofHintWithBinders { hint_type = ASSERT { p = t1; elaborated }; binders = bs; t = body } } in - check g pre pre_typing post_hint res_ppname st + check g pre () post_hint res_ppname st ) | ASSERT { p = v; elaborated } -> diff --git a/src/checker/Pulse.Checker.AssertWithBinders.fsti b/src/checker/Pulse.Checker.AssertWithBinders.fsti index db335ddd6..3ffda9671 100644 --- a/src/checker/Pulse.Checker.AssertWithBinders.fsti +++ b/src/checker/Pulse.Checker.AssertWithBinders.fsti @@ -30,7 +30,6 @@ let head_wild (st:st_term) = val check (g:env) (pre:term) - (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (st:st_term { Tm_ProofHintWithBinders? st.term }) diff --git a/src/checker/Pulse.Checker.Bind.fst b/src/checker/Pulse.Checker.Bind.fst index 31460814b..5f1b0ff29 100644 --- a/src/checker/Pulse.Checker.Bind.fst +++ b/src/checker/Pulse.Checker.Bind.fst @@ -34,7 +34,6 @@ module RU = Pulse.Reflection.Util let check_bind_fn (g:env) (ctxt:slprop) - (ctxt_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term {Tm_Bind? t.term}) @@ -55,7 +54,7 @@ let check_bind_fn let ctxt_typing' : unit = () in let r = check g' _ ctxt_typing' post_hint res_ppname (open_st_term_nv body (binder.binder_ppname, x)) in let body_typing = apply_checker_result_k #_ #_ #(PostHint?.v post_hint) r res_ppname in - let k = Pulse.Checker.Base.continuation_elaborator_with_bind_fn ctxt ctxt_typing t c b () (binder.binder_ppname, x) in + let k = Pulse.Checker.Base.continuation_elaborator_with_bind_fn ctxt () t c b () (binder.binder_ppname, x) in let d = k post_hint body_typing in checker_result_for_st_typing d res_ppname ) @@ -120,7 +119,6 @@ let check_bind' (maybe_elaborate:bool) (g:env) (ctxt:slprop) - (ctxt_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term {Tm_Bind? t.term}) @@ -134,11 +132,11 @@ let check_bind' let Tm_Bind { binder; head=e1; body=e2 } = t.term in if Tm_Admit? e1.term then ( //Discard the continuation if the head is an admit - check g ctxt ctxt_typing post_hint res_ppname e1 + check g ctxt () post_hint res_ppname e1 ) else if Tm_Abs? e1.term then ( - check_bind_fn g ctxt ctxt_typing post_hint res_ppname t check + check_bind_fn g ctxt post_hint res_ppname t check ) else ( let dflt () = @@ -148,7 +146,7 @@ let check_bind' { binder with binder_ppname = ppname_default } else binder in - let r0 = check g ctxt ctxt_typing NoHint binder.binder_ppname e1 in + let r0 = check g ctxt () NoHint binder.binder_ppname e1 in check_if_seq_lhs g ctxt _ r0 e1; check_binder_typ g ctxt _ r0 binder e1; let (| x, g1, _, ctxt', k1 |) = r0 in @@ -171,7 +169,7 @@ let check_bind' match Pulse.Checker.Base.hoist g (Inl tm) false rebuild with | Some t -> //something was elaborated, go back to the top checking loop Util.debug g "pulse.hoist" (fun _ -> Printf.sprintf "Bind was elaborated to %s\n" (show t)); - check g ctxt ctxt_typing post_hint res_ppname t + check g ctxt () post_hint res_ppname t | None -> Util.debug g "pulse.hoist" (fun _ -> Printf.sprintf "No elaboration in check_bind, proceeding to check head\n"); dflt() @@ -184,7 +182,7 @@ let check_bind' match Pulse.Checker.Base.hoist g (Inr e1) false rebuild with | Some t -> //something was elaborated, go back to the top checking loop debug_prover g (fun _ -> Printf.sprintf "Bind was elaborated to %s\n" (show t)); - check g ctxt ctxt_typing post_hint res_ppname t + check g ctxt () post_hint res_ppname t | None -> debug_prover g (fun _ -> "No elaboration in check_bind, proceeding to check head\n"); dflt() @@ -196,7 +194,6 @@ let check_bind = check_bind' true let check_tot_bind (g:env) (pre:term) - (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_TotBind? t.term }) @@ -219,11 +216,11 @@ let check_tot_bind let t = rebuild (Inl e1) in Pulse.Checker.Util.debug g "pulse.hoist" (fun _ -> Printf.sprintf "No elaboration in check_tot_bind, proceeding to check\n%s\n" (show t)); - check_bind' false g pre pre_typing post_hint res_ppname t check + check_bind' false g pre post_hint res_ppname t check | Some t' -> Pulse.Checker.Util.debug g "pulse.hoist" (fun _ -> Printf.sprintf "Elaborated and proceeding back to top-level\n%s\nto\n%s\n" (show t) (show t')); - check g pre pre_typing post_hint res_ppname t' + check g pre () post_hint res_ppname t' #pop-options \ No newline at end of file diff --git a/src/checker/Pulse.Checker.Bind.fsti b/src/checker/Pulse.Checker.Bind.fsti index e2e9a3dff..36e2bc8e9 100644 --- a/src/checker/Pulse.Checker.Bind.fsti +++ b/src/checker/Pulse.Checker.Bind.fsti @@ -25,7 +25,6 @@ open Pulse.Checker.Base val check_bind (g:env) (pre:term) - (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term{Tm_Bind? t.term}) @@ -35,7 +34,6 @@ val check_bind val check_tot_bind (g:env) (pre:term) - (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_TotBind? t.term }) diff --git a/src/checker/Pulse.Checker.Exists.fst b/src/checker/Pulse.Checker.Exists.fst index 2bac24b86..a528f842a 100644 --- a/src/checker/Pulse.Checker.Exists.fst +++ b/src/checker/Pulse.Checker.Exists.fst @@ -43,7 +43,6 @@ let terms_to_string (t:list term) let check_elim_exists (g:env) (pre:term) - (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term{Tm_ElimExists? t.term}) @@ -90,7 +89,7 @@ let check_elim_exists let elim_c = comp_elim_exists u ty p (ppname_default, x) in let c = match_comp_res_with_post_hint elim_st elim_c () post_hint in - prove_post_hint (try_frame_pre false pre_typing (|elim_st,c|) res_ppname) post_hint t_rng + prove_post_hint (try_frame_pre false () (|elim_st,c|) res_ppname) post_hint t_rng else fail g (Some t_rng) (Printf.sprintf "check_elim_exists: universe checking failed, computed %s, expected %s" (P.univ_to_string u') (P.univ_to_string u)) @@ -101,7 +100,6 @@ let check_elim_exists let check_intro_exists (g:env) (pre:term) - (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (st:st_term { intro_exists_witness_singleton st }) @@ -134,7 +132,7 @@ let check_intro_exists let intro_c = C_STGhost tm_emp_inames { u=u0; res=tm_unit; pre=open_term' p witness 0; post=tm_exists_sl u b p } in let c = match_comp_res_with_post_hint intro_st intro_c () post_hint in - prove_post_hint (try_frame_pre false pre_typing (|intro_st, c|) res_ppname) + prove_post_hint (try_frame_pre false () (|intro_st, c|) res_ppname) post_hint (Pulse.RuntimeUtils.range_of_term t) #pop-options diff --git a/src/checker/Pulse.Checker.Exists.fsti b/src/checker/Pulse.Checker.Exists.fsti index 633f69346..73f81b31a 100644 --- a/src/checker/Pulse.Checker.Exists.fsti +++ b/src/checker/Pulse.Checker.Exists.fsti @@ -25,7 +25,6 @@ open Pulse.Checker.Base val check_elim_exists (g:env) (pre:term) - (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term{Tm_ElimExists? t.term}) @@ -43,7 +42,6 @@ let intro_exists_slprop (st:st_term { Tm_IntroExists? st.term }) = val check_intro_exists (g:env) (pre:term) - (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (st:st_term { intro_exists_witness_singleton st }) diff --git a/src/checker/Pulse.Checker.ForwardJumpLabel.fst b/src/checker/Pulse.Checker.ForwardJumpLabel.fst index 298c6602d..7a4967b49 100644 --- a/src/checker/Pulse.Checker.ForwardJumpLabel.fst +++ b/src/checker/Pulse.Checker.ForwardJumpLabel.fst @@ -35,7 +35,6 @@ let starts_with (a b: string) : bool = let check (g:env) (pre:term) - (pre_typing:unit) (post_hint0:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_ForwardJumpLabel? t.term }) @@ -60,7 +59,7 @@ let check // TODO: just ignore early return/continue labels in atomic/ghost contexts for now let lbl_x = fresh g in let body = open_st_term_nv body (lbl, lbl_x) in - check _ _ pre_typing _ res_ppname body + check _ _ () _ res_ppname body else fail g (Some rng) "Labels require stt" else @@ -99,7 +98,7 @@ let check ) else ( let c'' = match_comp_res_with_post_hint t body'_c () post_hint0 in prove_post_hint #g - (try_frame_pre false #g pre_typing (|t,c''|) res_ppname) + (try_frame_pre false #g () (|t,c''|) res_ppname) post_hint0 rng ) diff --git a/src/checker/Pulse.Checker.ForwardJumpLabel.fsti b/src/checker/Pulse.Checker.ForwardJumpLabel.fsti index 93e884884..f61722737 100644 --- a/src/checker/Pulse.Checker.ForwardJumpLabel.fsti +++ b/src/checker/Pulse.Checker.ForwardJumpLabel.fsti @@ -27,7 +27,6 @@ open Pulse.Checker.Base val check (g:env) (pre:term) - (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_ForwardJumpLabel? t.term }) diff --git a/src/checker/Pulse.Checker.Goto.fst b/src/checker/Pulse.Checker.Goto.fst index 40dfbff50..d905022ba 100644 --- a/src/checker/Pulse.Checker.Goto.fst +++ b/src/checker/Pulse.Checker.Goto.fst @@ -28,7 +28,6 @@ open Pulse.Checker.Prover let check' (g:env) (pre:term) - (pre_typing:unit) (post_hint:post_hint_opt g { PostHint? post_hint }) (res_ppname:ppname) (t:st_term { Tm_Goto? t.term }) @@ -54,7 +53,7 @@ let check' () in let c' = match_comp_res_with_post_hint t c' typing post_hint in prove_post_hint #g - (try_frame_pre false #g pre_typing (|t,c'|) res_ppname) + (try_frame_pre false #g () (|t,c'|) res_ppname) post_hint rng | None -> @@ -65,7 +64,6 @@ let check' let check (g:env) (pre:term) - (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_Goto? t.term }) @@ -73,11 +71,11 @@ let check = match post_hint with | NoHint -> let post_hint' = intro_post_hint g EffectAnnotSTT None tm_is_unreachable in - let res = check' g pre pre_typing (PostHint post_hint') res_ppname t in + let res = check' g pre (PostHint post_hint') res_ppname t in retype_checker_result _ res | TypeHint ty -> let post_hint' = intro_post_hint g EffectAnnotSTT (Some ty) tm_is_unreachable in - let res = check' g pre pre_typing (PostHint post_hint') res_ppname t in + let res = check' g pre (PostHint post_hint') res_ppname t in retype_checker_result _ res | PostHint post -> - check' g pre pre_typing post_hint res_ppname t + check' g pre post_hint res_ppname t diff --git a/src/checker/Pulse.Checker.Goto.fsti b/src/checker/Pulse.Checker.Goto.fsti index 8977ea774..553c2c382 100644 --- a/src/checker/Pulse.Checker.Goto.fsti +++ b/src/checker/Pulse.Checker.Goto.fsti @@ -27,7 +27,6 @@ open Pulse.Checker.Base val check (g:env) (pre:term) - (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_Goto? t.term }) diff --git a/src/checker/Pulse.Checker.If.fst b/src/checker/Pulse.Checker.If.fst index 0d766098b..08099989a 100644 --- a/src/checker/Pulse.Checker.If.fst +++ b/src/checker/Pulse.Checker.If.fst @@ -46,7 +46,6 @@ let retype_checker_result (#g:env) (#ctxt:slprop) (#ph:post_hint_opt g) (ph':pos let check (g:env) (pre:term) - (pre_typing: unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (b:term) @@ -64,8 +63,7 @@ let check let g_with_eq = g_with_eq g hyp b in let check_branch (eq_v:term) (br:st_term) (is_then:bool) : T.Tac (checker_result_t (g_with_eq eq_v) pre post_hint) - = let pre_typing : unit = () in - + = let br = let t = mk_term (Tm_ProofHintWithBinders { @@ -78,7 +76,7 @@ let check in let ppname = mk_ppname_no_range "_if_br" in - let r = check (g_with_eq eq_v) pre pre_typing post_hint ppname br in + let r = check (g_with_eq eq_v) pre () post_hint ppname br in r in @@ -130,7 +128,7 @@ let check let (| c, e1_typing, e2_typing |) = J.join_comps (g_with_eq tm_true) e1 c1 e1_typing (g_with_eq tm_false) e2 c2 e2_typing post_hint' in - let c_typing = comp_typing_from_post_hint c pre_typing post_hint' in + let c_typing = comp_typing_from_post_hint c () post_hint' in let if_st = wrst c (Tm_If { b; then_=e1; else_=e2; post=None }) in let d : st_typing_in_ctxt g pre (PostHint post_hint') = diff --git a/src/checker/Pulse.Checker.If.fsti b/src/checker/Pulse.Checker.If.fsti index c363d7a83..986e63be4 100644 --- a/src/checker/Pulse.Checker.If.fsti +++ b/src/checker/Pulse.Checker.If.fsti @@ -25,7 +25,6 @@ open Pulse.Checker.Base val check (g:env) (pre:term) - (pre_typing: unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (b:term) diff --git a/src/checker/Pulse.Checker.IntroPure.fst b/src/checker/Pulse.Checker.IntroPure.fst index b69fe8c1f..d2a9040d0 100644 --- a/src/checker/Pulse.Checker.IntroPure.fst +++ b/src/checker/Pulse.Checker.IntroPure.fst @@ -46,7 +46,6 @@ let check_prop_validity (g:env) (p:term): T.Tac (prop_validity g p) = let check (g:env) (pre:term) - (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_IntroPure? t.term }) @@ -63,4 +62,4 @@ let check let intro_c = C_STGhost tm_emp_inames { u=u0; res=tm_unit; pre=tm_emp; post=tm_pure p } in let c = match_comp_res_with_post_hint intro_st intro_c () post_hint in - prove_post_hint (try_frame_pre false pre_typing (|intro_st,c|) res_ppname) post_hint t.range + prove_post_hint (try_frame_pre false () (|intro_st,c|) res_ppname) post_hint t.range diff --git a/src/checker/Pulse.Checker.IntroPure.fsti b/src/checker/Pulse.Checker.IntroPure.fsti index 48565cef1..ad391b338 100644 --- a/src/checker/Pulse.Checker.IntroPure.fsti +++ b/src/checker/Pulse.Checker.IntroPure.fsti @@ -25,7 +25,6 @@ module T = FStar.Tactics.V2 val check (g:env) (pre:term) - (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_IntroPure? t.term }) diff --git a/src/checker/Pulse.Checker.Match.fst b/src/checker/Pulse.Checker.Match.fst index 48b7218f9..733ab517d 100644 --- a/src/checker/Pulse.Checker.Match.fst +++ b/src/checker/Pulse.Checker.Match.fst @@ -219,7 +219,6 @@ let check_branch (norw:bool) (g:env) (pre:term) - (pre_typing: unit) (post_hint:post_hint_for_env g) (check:check_t) (sc_u : universe) @@ -293,7 +292,6 @@ let check_branches_aux_t let check_branches_aux (g:env) (pre:term) - (pre_typing: unit) (post_hint:post_hint_for_env g) (check:check_t) (sc_u : universe) @@ -310,7 +308,7 @@ let check_branches_aux : T.Tac (check_branches_aux_t pre post_hint sc_u sc_ty sc) = let e = b.e in let (p, bs) = pbs in - let (| p, e, c |) = check_branch (T.unseal b.norw) g pre pre_typing post_hint check sc_u sc_ty sc p e bs in + let (| p, e, c |) = check_branch (T.unseal b.norw) g pre post_hint check sc_u sc_ty sc p e bs in (| {pat=p; e; norw=b.norw}, c |) in let r = zipWith tr1 brs0 bnds in @@ -464,7 +462,6 @@ let maybe_weaken_branch_tags let check_branches (g:env) (pre:term) - (pre_typing: unit) (post_hint:post_hint_for_env g) (check:check_t) (sc_u : universe) @@ -474,7 +471,7 @@ let check_branches (bnds: list (R.pattern & list R.binding){L.length brs0 == L.length bnds}) : T.Tac (brs:list branch & c:comp_st{comp_pre c == pre /\ comp_post_matches_hint c (PostHint post_hint)}) -= let checked_brs = check_branches_aux g pre pre_typing post_hint check sc_u sc_ty sc brs0 bnds in += let checked_brs = check_branches_aux g pre post_hint check sc_u sc_ty sc brs0 bnds in let (| ct, checked_brs |) = maybe_weaken_branch_tags checked_brs in let (| c0, checked_brs |) = join_branches ct checked_brs in let brs = checked_brs in @@ -483,7 +480,6 @@ let check_branches let check (g:env) (pre:term) - (pre_typing: unit) (post_hint:post_hint_for_env g) (res_ppname:ppname) (sc:term) @@ -538,11 +534,11 @@ let check assert (L.length (zip elab_pats' bnds') == nbr); let (| brs, c |) = - check_branches g pre pre_typing post_hint check sc_u sc_ty sc brs (zip elab_pats' bnds') in + check_branches g pre post_hint check sc_u sc_ty sc brs (zip elab_pats' bnds') in (* Provable *) assume (L.map (fun br -> elab_pat br.pat) brs == elab_pats'); - let c_typing = comp_typing_from_post_hint c pre_typing post_hint in + let c_typing = comp_typing_from_post_hint c () post_hint in let t = wtag (Some (ctag_of_comp_st c)) (Tm_Match {sc; returns_=None; brs}) in checker_result_for_st_typing (| t, c |) res_ppname diff --git a/src/checker/Pulse.Checker.Match.fsti b/src/checker/Pulse.Checker.Match.fsti index 57942983e..a3a25136c 100644 --- a/src/checker/Pulse.Checker.Match.fsti +++ b/src/checker/Pulse.Checker.Match.fsti @@ -29,7 +29,6 @@ let close_st_term_bs t bs = val check (g:env) (pre:term) - (pre_typing: unit) (post_hint:post_hint_for_env g) (res_ppname:ppname) (sc:term) diff --git a/src/checker/Pulse.Checker.Return.fst b/src/checker/Pulse.Checker.Return.fst index ad7bf464f..dbf1cf04f 100644 --- a/src/checker/Pulse.Checker.Return.fst +++ b/src/checker/Pulse.Checker.Return.fst @@ -79,7 +79,6 @@ let compute_tot_or_ghost_term_type_and_u (g:env) (e:term) (c:option ctag) let check_core (g:env) (ctxt:term) - (ctxt_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (st:st_term { Tm_Return? st.term }) @@ -147,7 +146,7 @@ let check_core Printf.sprintf "Return comp is: %s" (Pulse.Syntax.Printer.comp_to_string c')); prove_post_hint #g - (try_frame_pre false #g ctxt_typing (|ret_st,c'|) res_ppname) + (try_frame_pre false #g () (|ret_st,c'|) res_ppname) post_hint st.range #pop-options @@ -155,7 +154,6 @@ let check_core let check (g:env) (ctxt:term) - (ctxt_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (st:st_term { Tm_Return? st.term }) @@ -172,7 +170,7 @@ let check Pulse.Checker.Util.debug g "pulse.hoist" (fun _ -> Printf.sprintf "Hoisted term: %s" (Pulse.Syntax.Printer.st_term_to_string tt) ); - check g ctxt ctxt_typing post_hint res_ppname tt + check g ctxt () post_hint res_ppname tt | None -> ( match post_hint with | PostHint p -> ( @@ -180,8 +178,8 @@ let check match ctag_of_effect_annot p.effect_annot with | Some c -> c | None -> STT_Atomic in - check_core g ctxt ctxt_typing post_hint res_ppname st (Some ctag) + check_core g ctxt post_hint res_ppname st (Some ctag) ) - | _ -> check_core g ctxt ctxt_typing post_hint res_ppname st None + | _ -> check_core g ctxt post_hint res_ppname st None ) diff --git a/src/checker/Pulse.Checker.Return.fsti b/src/checker/Pulse.Checker.Return.fsti index d435bb78a..82ce1d1f6 100644 --- a/src/checker/Pulse.Checker.Return.fsti +++ b/src/checker/Pulse.Checker.Return.fsti @@ -25,7 +25,6 @@ module T = FStar.Tactics.V2 val check (g:env) (ctxt:term) - (ctxt_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (st:st_term { Tm_Return? st.term }) diff --git a/src/checker/Pulse.Checker.Rewrite.fst b/src/checker/Pulse.Checker.Rewrite.fst index cff9c0573..0c6db6805 100644 --- a/src/checker/Pulse.Checker.Rewrite.fst +++ b/src/checker/Pulse.Checker.Rewrite.fst @@ -107,7 +107,6 @@ let rec check_slprop_equiv r (g:env) (p q:slprop) let check (g:env) (pre:term) - (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term{Tm_Rewrite? t.term}) @@ -141,4 +140,4 @@ let check let rew_c = C_STGhost tm_emp_inames { u=u0; res=tm_unit; pre=p; post=q } in let c = match_comp_res_with_post_hint rew_st rew_c () post_hint in - prove_post_hint (try_frame_pre false pre_typing (| rew_st,c |) res_ppname) post_hint t.range + prove_post_hint (try_frame_pre false () (| rew_st,c |) res_ppname) post_hint t.range diff --git a/src/checker/Pulse.Checker.Rewrite.fsti b/src/checker/Pulse.Checker.Rewrite.fsti index ee639251e..7eef78790 100644 --- a/src/checker/Pulse.Checker.Rewrite.fsti +++ b/src/checker/Pulse.Checker.Rewrite.fsti @@ -25,7 +25,6 @@ module T = FStar.Tactics.V2 val check (g:env) (pre:term) - (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_Rewrite? t.term }) diff --git a/src/checker/Pulse.Checker.ST.fst b/src/checker/Pulse.Checker.ST.fst index 6030f618a..0df19fac6 100644 --- a/src/checker/Pulse.Checker.ST.fst +++ b/src/checker/Pulse.Checker.ST.fst @@ -38,7 +38,6 @@ open Pulse.PP let check (g:env) (ctxt:slprop) - (ctxt_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_ST? t.term }) diff --git a/src/checker/Pulse.Checker.ST.fsti b/src/checker/Pulse.Checker.ST.fsti index 0b071829f..17e721ddd 100644 --- a/src/checker/Pulse.Checker.ST.fsti +++ b/src/checker/Pulse.Checker.ST.fsti @@ -25,7 +25,6 @@ open Pulse.Checker.Base val check (g:env) (pre:term) - (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term{Tm_ST? t.term}) diff --git a/src/checker/Pulse.Checker.While.fst b/src/checker/Pulse.Checker.While.fst index a6e0c9baa..920ded6cb 100644 --- a/src/checker/Pulse.Checker.While.fst +++ b/src/checker/Pulse.Checker.While.fst @@ -147,7 +147,6 @@ let rec build_tuple_info (infos: list (term & term & universe)) let check_while (g:env) (pre:term) - (pre_typing:unit) (post_hint:post_hint_opt g {~ (PostHint? post_hint) }) (res_ppname:ppname) (t:st_term{Tm_While? t.term}) diff --git a/src/checker/Pulse.Checker.While.fsti b/src/checker/Pulse.Checker.While.fsti index af026c0dc..f56c3f6a7 100644 --- a/src/checker/Pulse.Checker.While.fsti +++ b/src/checker/Pulse.Checker.While.fsti @@ -25,7 +25,6 @@ module T = FStar.Tactics.V2 val check_while (g:env) (pre:term) - (pre_typing:unit) (post_hint:post_hint_opt g { ~ (PostHint? post_hint) }) (res_ppname:ppname) (t:st_term{Tm_While? t.term}) diff --git a/src/checker/Pulse.Checker.WithLocal.fst b/src/checker/Pulse.Checker.WithLocal.fst index 679daa310..ac343a9a1 100644 --- a/src/checker/Pulse.Checker.WithLocal.fst +++ b/src/checker/Pulse.Checker.WithLocal.fst @@ -42,7 +42,7 @@ let extend_post_hint_for_local (g:env) (p:post_hint_for_env g) let res = Pulse.Checker.Base.extend_post_hint g p x (mk_ref init_t) conjunct c_typing in res -let with_local_pre_typing (#g:env) (#pre:term) (pre_typing:unit) +let with_local_pre_typing (#g:env) (#pre:term) (_pre_typing:unit) (init_t:term) (x:var { ~ (Set.mem x (dom g)) }) n (i:option term) : unit = admit() @@ -64,7 +64,6 @@ let head_range (t:st_term {Tm_WithLocal? t.term}) : range = let check (g:env) (pre:term) - (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_WithLocal? t.term }) @@ -144,7 +143,7 @@ let check assume (open_st_term (close_st_term opened_body x) x == opened_body); let c = C_ST {u=comp_u c_body;res=comp_res c_body;pre;post=post.post} in let c_typing = - intro_comp_typing g c pre_typing + intro_comp_typing g c () () () x () diff --git a/src/checker/Pulse.Checker.WithLocal.fsti b/src/checker/Pulse.Checker.WithLocal.fsti index 9880c294b..c25575f52 100644 --- a/src/checker/Pulse.Checker.WithLocal.fsti +++ b/src/checker/Pulse.Checker.WithLocal.fsti @@ -25,7 +25,6 @@ open Pulse.Checker.Base val check (g:env) (pre:term) - (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_WithLocal? t.term }) diff --git a/src/checker/Pulse.Checker.WithLocalArray.fst b/src/checker/Pulse.Checker.WithLocalArray.fst index c2a6819a7..3e13ec1ef 100644 --- a/src/checker/Pulse.Checker.WithLocalArray.fst +++ b/src/checker/Pulse.Checker.WithLocalArray.fst @@ -54,7 +54,7 @@ let extend_post_hint let with_local_array_pre_typing (#g:env) (#pre:term) - (pre_typing:unit) + (_pre_typing:unit) (init_t:term) (init:option term) (len:term) @@ -89,7 +89,6 @@ let head_range (t:st_term {Tm_WithLocalArray? t.term}) : range = let check (g:env) (pre:term) - (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_WithLocalArray? t.term }) @@ -169,7 +168,7 @@ let check assume (open_st_term (close_st_term opened_body x) x == opened_body); let c = C_ST {u=comp_u c_body;res=comp_res c_body;pre;post=post.post} in let c_typing = - intro_comp_typing g c pre_typing + intro_comp_typing g c () () () x () diff --git a/src/checker/Pulse.Checker.WithLocalArray.fsti b/src/checker/Pulse.Checker.WithLocalArray.fsti index 789df72d1..363b98347 100644 --- a/src/checker/Pulse.Checker.WithLocalArray.fsti +++ b/src/checker/Pulse.Checker.WithLocalArray.fsti @@ -25,7 +25,6 @@ open Pulse.Checker.Base val check (g:env) (pre:term) - (pre_typing:unit) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_WithLocalArray? t.term }) diff --git a/src/checker/Pulse.Checker.fst b/src/checker/Pulse.Checker.fst index 63f3768d3..aaca16d56 100644 --- a/src/checker/Pulse.Checker.fst +++ b/src/checker/Pulse.Checker.fst @@ -287,33 +287,33 @@ let rec check match maybe_elaborate_stateful_head g0 t with | Some t -> - check g0 pre0 pre0_typing post_hint res_ppname t + check g0 pre0 () post_hint res_ppname t | None -> - let (| g, pre, pre_typing, k_elim_pure |) : + let (| g, pre, _, k_elim_pure |) : (g':env { env_extends g' g0 } & ctxt':term & unit & continuation_elaborator g0 pre0 g' ctxt') = if do_not_elim_state t then - (| g0, pre0, pre0_typing, k_elab_unit _ _ |) + (| g0, pre0, (), k_elab_unit _ _ |) else - Pulse.Checker.Prover.elim_exists_and_pure pre0_typing + Pulse.Checker.Prover.elim_exists_and_pure () in let r : checker_result_t g pre post_hint = let g = push_context (P.tag_of_st_term t) t.range g in match t.term with | Tm_Return _ -> - Return.check g pre pre_typing post_hint res_ppname t check + Return.check g pre post_hint res_ppname t check | Tm_Abs _ -> T.fail "Tm_Abs check should not have been called in the checker" | Tm_ST _ -> RU.record_stats "check_st" (fun _ -> - Pulse.Checker.ST.check g pre pre_typing post_hint res_ppname t) + Pulse.Checker.ST.check g pre post_hint res_ppname t) | Tm_ElimExists _ -> - Exists.check_elim_exists g pre pre_typing post_hint res_ppname t + Exists.check_elim_exists g pre post_hint res_ppname t | Tm_IntroExists _ -> ( (* First of all, elaborate *) @@ -328,22 +328,22 @@ let rec check match instantiate_unknown_witnesses g t with | Some t -> - check g pre pre_typing post_hint res_ppname t + check g pre () post_hint res_ppname t | None -> match witnesses with | [] -> fail g (Some t.range) "intro exists with empty witnesses" | [_] -> - Exists.check_intro_exists g pre pre_typing post_hint res_ppname t None + Exists.check_intro_exists g pre post_hint res_ppname t None | _ -> let t = transform_to_unary_intro_exists g p witnesses in - check g pre pre_typing post_hint res_ppname t + check g pre () post_hint res_ppname t ) | Tm_Bind _ -> - Bind.check_bind g pre pre_typing post_hint res_ppname t check + Bind.check_bind g pre post_hint res_ppname t check | Tm_TotBind _ -> - Bind.check_tot_bind g pre pre_typing post_hint res_ppname t check + Bind.check_tot_bind g pre post_hint res_ppname t check | Tm_If { b; then_=e1; else_=e2; post=post_if } -> ( let post : post_hint_opt g = @@ -367,14 +367,14 @@ let rec check NoHint in let (| x, t, pre', g1, k |) : checker_result_t g pre post = - If.check g pre pre_typing post res_ppname b e1 e2 check in + If.check g pre post res_ppname b e1 e2 check in (| x, t, pre', g1, k |) ) | Tm_While .. -> ( match post_hint with - | PostHint _ -> Bind.check_bind g pre pre_typing post_hint res_ppname (seq_with_unit t) check - | _ -> While.check_while g pre pre_typing post_hint res_ppname t (fresh g) None check + | PostHint _ -> Bind.check_bind g pre post_hint res_ppname (seq_with_unit t) check + | _ -> While.check_while g pre post_hint res_ppname t (fresh g) None check ) // SUPER HACKY, we pass break invariants from the frontend by annotating a @@ -383,7 +383,7 @@ let rec check if T.unseal lbl.name = "_break" then match post_hint with | PostHint _ -> - Bind.check_bind g pre pre_typing post_hint res_ppname (seq_with_unit t) check + Bind.check_bind g pre post_hint res_ppname (seq_with_unit t) check | _ -> let lblx = fresh g in let Tm_ForwardJumpLabel {body} = t.term in @@ -393,9 +393,9 @@ let rec check let loop_ensures = match inspect_term (comp_post post) with | Tm_Pure p -> Some p | _ -> None in - While.check_while g pre pre_typing post_hint res_ppname body lblx loop_ensures check + While.check_while g pre post_hint res_ppname body lblx loop_ensures check else - ForwardJumpLabel.check g pre pre_typing post_hint res_ppname t check + ForwardJumpLabel.check g pre post_hint res_ppname t check | Tm_Match {sc;returns_=post_match;brs} -> // TODO : dedup @@ -421,42 +421,42 @@ let rec check Either annotate this `if` with `returns` clause; or rewrite your code to use a tail conditional") in let (| x, ty, pre', g1, k |) = - Match.check g pre pre_typing post res_ppname sc brs check in + Match.check g pre post res_ppname sc brs check in (| x, ty, pre', g1, k |) | Tm_ProofHintWithBinders _ -> - Pulse.Checker.AssertWithBinders.check g pre pre_typing post_hint res_ppname t check + Pulse.Checker.AssertWithBinders.check g pre post_hint res_ppname t check | Tm_WithLocal _ -> - WithLocal.check g pre pre_typing post_hint res_ppname t check + WithLocal.check g pre post_hint res_ppname t check | Tm_WithLocalArray _ -> - WithLocalArray.check g pre pre_typing post_hint res_ppname t check + WithLocalArray.check g pre post_hint res_ppname t check | Tm_IntroPure _ -> - Pulse.Checker.IntroPure.check g pre pre_typing post_hint res_ppname t + Pulse.Checker.IntroPure.check g pre post_hint res_ppname t | Tm_Admit _ -> - Admit.check g pre pre_typing post_hint res_ppname t + Admit.check g pre post_hint res_ppname t | Tm_Unreachable _ -> T.fail "Tm_Unreachable check should not have been called in the checker" | Tm_Rewrite _ -> - Rewrite.check g pre pre_typing post_hint res_ppname t + Rewrite.check g pre post_hint res_ppname t | Tm_PragmaWithOptions { options; body } -> RU.push_options(); RU.set_options options; - let r = check g pre pre_typing post_hint res_ppname body in + let r = check g pre () post_hint res_ppname body in RU.pop_options (); r | Tm_ForwardJumpLabel _ -> - ForwardJumpLabel.check g pre pre_typing post_hint res_ppname t check + ForwardJumpLabel.check g pre post_hint res_ppname t check | Tm_Goto _ -> - Goto.check g pre pre_typing post_hint res_ppname t + Goto.check g pre post_hint res_ppname t in let (| x, g1, t, pre', k |) = r in diff --git a/src/checker/Pulse.Main.fst b/src/checker/Pulse.Main.fst index c389a5cf4..7939a6696 100644 --- a/src/checker/Pulse.Main.fst +++ b/src/checker/Pulse.Main.fst @@ -46,7 +46,7 @@ let check_fndefn (g : stt_env{bindings g == []}) (expected_t : option term) (* Both of these unused: *) - (pre : term) (pre_typing : unit) + (pre : term) (_pre_typing : unit) : T.Tac (RT.dsl_tac_result_t (fstar_env g) expected_t) = let g = let FnDefn {us} = d.d in push_univ_vars g us in From 41f29dd85811a54e05dd034a6c1343533b1c4d0e Mon Sep 17 00:00:00 2001 From: Gabriel Ebner Date: Sat, 28 Feb 2026 21:49:55 +0000 Subject: [PATCH 15/18] Remove extra unit function parameters across checker modules Remove unit-typed parameters (pre_typing, ctxt_typing, d, typing, etc.) from function signatures in LN, FV, Elaborate.Core, Combinators, Base, Prover, SLPropEquiv, While, JoinComp, Comp, WithLocal, WithLocalArray, Abs, Exists, Match, Normalize, Pure, and their callers. Also clean up remaining let-bindings of unit values. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/checker/Pulse.Checker.Abs.fst | 16 +- src/checker/Pulse.Checker.Admit.fst | 2 +- .../Pulse.Checker.AssertWithBinders.fst | 22 +-- src/checker/Pulse.Checker.Base.fst | 99 +++------- src/checker/Pulse.Checker.Base.fsti | 25 +-- src/checker/Pulse.Checker.Bind.fst | 17 +- src/checker/Pulse.Checker.Comp.fst | 1 - src/checker/Pulse.Checker.Comp.fsti | 1 - src/checker/Pulse.Checker.Exists.fst | 13 +- .../Pulse.Checker.ForwardJumpLabel.fst | 8 +- src/checker/Pulse.Checker.Goto.fst | 7 +- src/checker/Pulse.Checker.If.fst | 6 +- src/checker/Pulse.Checker.IntroPure.fst | 4 +- src/checker/Pulse.Checker.Match.fst | 7 +- .../Pulse.Checker.Prover.Normalize.fst | 1 - .../Pulse.Checker.Prover.Normalize.fsti | 1 - src/checker/Pulse.Checker.Prover.fst | 177 ++++++++---------- src/checker/Pulse.Checker.Prover.fsti | 4 +- src/checker/Pulse.Checker.Pure.fst | 14 +- src/checker/Pulse.Checker.Return.fst | 6 +- src/checker/Pulse.Checker.Rewrite.fst | 4 +- src/checker/Pulse.Checker.SLPropEquiv.fst | 11 +- src/checker/Pulse.Checker.SLPropEquiv.fsti | 15 +- src/checker/Pulse.Checker.ST.fst | 44 ++--- src/checker/Pulse.Checker.While.fst | 16 +- src/checker/Pulse.Checker.WithLocal.fst | 12 +- src/checker/Pulse.Checker.WithLocalArray.fst | 12 +- src/checker/Pulse.Checker.fst | 16 +- src/checker/Pulse.Elaborate.Core.fst | 12 +- src/checker/Pulse.JoinComp.fst | 8 +- src/checker/Pulse.JoinComp.fsti | 2 - src/checker/Pulse.Typing.Combinators.fst | 78 +++----- src/checker/Pulse.Typing.Combinators.fsti | 18 +- src/checker/Pulse.Typing.FV.fst | 13 +- src/checker/Pulse.Typing.FV.fsti | 6 +- src/checker/Pulse.Typing.LN.fst | 17 +- src/checker/Pulse.Typing.LN.fsti | 3 - 37 files changed, 272 insertions(+), 446 deletions(-) diff --git a/src/checker/Pulse.Checker.Abs.fst b/src/checker/Pulse.Checker.Abs.fst index 8292d029b..1e45e9a58 100644 --- a/src/checker/Pulse.Checker.Abs.fst +++ b/src/checker/Pulse.Checker.Abs.fst @@ -372,11 +372,6 @@ let check_effect_annotation g r (asc:comp_ascription) (c_computed:comp) : T.Tac let Some tok = tok in - let d_sub : unit = - match c_computed with - | C_STAtomic _ obs _ -> () - | C_STGhost _ _ -> () - in c | _, _ -> @@ -394,7 +389,6 @@ let check_effect_annotation g r (asc:comp_ascription) (c_computed:comp) : T.Tac preserving the st_typing derivation d *) let maybe_rewrite_body_typing (g:_) (e:st_term) (c:comp) - (d:unit) (asc:comp_ascription) : T.Tac comp = let open Pulse.PP in @@ -483,9 +477,9 @@ let rec check_abs_core if needed. Currently this only subtypes the invariants. *) let c_body = check_effect_annotation g' body.range asc c_body in - let c_body = maybe_rewrite_body_typing g' body c_body () asc in + let c_body = maybe_rewrite_body_typing g' body c_body asc in - FV.st_typing_freevars g' body c_body (); let body_closed = close_st_term body x in + FV.st_typing_freevars g' body c_body; let body_closed = close_st_term body x in assume (open_st_term body_closed x == body); // instantiate implicits in the attributes @@ -561,7 +555,7 @@ let rec check_abs_core in let ppname_ret = mk_ppname_no_range "_fret" in - let r = check g' pre_opened () post ppname_ret body_opened in + let r = check g' pre_opened post ppname_ret body_opened in let (| post, r |) : (ph:post_hint_opt g' & checker_result_t g' pre_opened ph) = match post with | PostHint _ -> (| post, r |) @@ -589,9 +583,9 @@ let rec check_abs_core let c_body = check_effect_annotation g' body.range c_opened c_body in - let c_body = maybe_rewrite_body_typing g' body c_body () asc in + let c_body = maybe_rewrite_body_typing g' body c_body asc in - FV.st_typing_freevars g' body c_body (); + FV.st_typing_freevars g' body c_body; let body_closed = close_st_term body x in assume (open_st_term body_closed x == body); let b = {binder_ty=t;binder_ppname=ppname;binder_attrs} in diff --git a/src/checker/Pulse.Checker.Admit.fst b/src/checker/Pulse.Checker.Admit.fst index 6a9168c8a..9a62025a2 100644 --- a/src/checker/Pulse.Checker.Admit.fst +++ b/src/checker/Pulse.Checker.Admit.fst @@ -70,7 +70,7 @@ let check | STT_Ghost -> C_STGhost tm_emp_inames s | STT_Atomic -> C_STAtomic tm_emp_inames Neutral s) - | _, PostHint post -> Pulse.Typing.Combinators.comp_for_post_hint g pre () post x + | _, PostHint post -> Pulse.Typing.Combinators.comp_for_post_hint g pre post x in let c = res in let admit_st = wtag (Some (ctag_of_comp_st c)) diff --git a/src/checker/Pulse.Checker.AssertWithBinders.fst b/src/checker/Pulse.Checker.AssertWithBinders.fst index 1276f3f44..ed2f81661 100644 --- a/src/checker/Pulse.Checker.AssertWithBinders.fst +++ b/src/checker/Pulse.Checker.AssertWithBinders.fst @@ -341,7 +341,7 @@ let check_renaming // ... let body = {st with term = Tm_ProofHintWithBinders { ht with binders = [] }; source = Sealed.seal false; } in - check g pre () post_hint res_ppname + check g pre post_hint res_ppname { st with term = Tm_ProofHintWithBinders { hint_type=ASSERT { p = goal; elaborated = true }; binders=bs; t=body }; source = Sealed.seal false; @@ -353,14 +353,14 @@ let check_renaming check_pairs g st.range pairs tac_opt; - let (| x, g', ty, ctxt', k |) = check g rhs () post_hint res_ppname body in - (| x, g', ty, ctxt', k_elab_equiv pre ctxt' k () () |) + let (| x, g', ty, ctxt', k |) = check g rhs post_hint res_ppname body in + (| x, g', ty, ctxt', k_elab_equiv pre ctxt' k |) | [], Some goal -> ( let rhs, _ = rewrite_all st.range (T.unseal st.source) g pairs goal pre elaborated tac_opt true in let t = { st with term = Tm_Rewrite { t1 = goal; t2 = rhs; tac_opt; elaborated = true }; source = Sealed.seal false; } in - check g pre () post_hint res_ppname + check g pre post_hint res_ppname { st with term = Tm_Bind { binder = as_binder tm_unit; head = t; body }; source = Sealed.seal false; } @@ -436,7 +436,7 @@ let check_wild let body = open_st_term_with_reveals body bs in let (| x'', g'', t'', ctxt'', k' |) = - check g' (frame `tm_star` ex') () post_hint res_ppname body in + check g' (frame `tm_star` ex') post_hint res_ppname body in assume pre == (frame `tm_star` ex); (| x'', g'', t'', ctxt'', k_elab_trans k k' |) #pop-options @@ -491,13 +491,13 @@ let check match bs with | [] -> let t = { st with term = Tm_Rewrite { t1; t2; tac_opt; elaborated } } in - check g pre () post_hint res_ppname + check g pre post_hint res_ppname { st with term = Tm_Bind { binder = as_binder tm_unit; head = t; body } } | _ -> let t = { st with term = Tm_Rewrite { t1; t2; tac_opt; elaborated } } in let body = { st with term = Tm_Bind { binder = as_binder tm_unit; head = t; body } } in let st = { st with term = Tm_ProofHintWithBinders { hint_type = ASSERT { p = t1; elaborated }; binders = bs; t = body } } in - check g pre () post_hint res_ppname st + check g pre post_hint res_ppname st ) | ASSERT { p = v; elaborated } -> @@ -515,10 +515,10 @@ let check assume (v == v'); //sorry---ideally, we would retype everything proving that it is stable after normalization let v = v' in let body = body in // TODO compress - let h: unit = PC.core_check_term g1 v T.E_Total tm_slprop in + let _ = PC.core_check_term g1 v T.E_Total tm_slprop in // TODO: propagate through prover let (| x, x_ty, pre'', g2, k |) = - check g1 (tm_star v pre') () post_hint res_ppname body in + check g1 (tm_star v pre') post_hint res_ppname body in (| x, x_ty, pre'', g2, k_elab_trans k_frame k |) @@ -556,5 +556,5 @@ let check let (| x, g'', ty, ctxt', k' |) = - check g' (tm_star pre_remaining rhs') () post_hint res_ppname body in - (| x, g'', ty, ctxt', k_elab_trans k (k_elab_equiv (tm_star lhs pre_remaining) ctxt' k' () ()) |) + check g' (tm_star pre_remaining rhs') post_hint res_ppname body in + (| x, g'', ty, ctxt', k_elab_trans k (k_elab_equiv (tm_star lhs pre_remaining) ctxt' k') |) diff --git a/src/checker/Pulse.Checker.Base.fst b/src/checker/Pulse.Checker.Base.fst index ed3b53587..7ba07deff 100644 --- a/src/checker/Pulse.Checker.Base.fst +++ b/src/checker/Pulse.Checker.Base.fst @@ -54,18 +54,13 @@ let mk_abs ty t = RT.(mk_abs ty T.Q_Explicit t) let intro_comp_typing (g:env) (c:comp_st) - (pre_typing:unit) - (i_typing:unit) - (res_typing:unit) (x:var { fresh_wrt x g (freevars (comp_post c)) }) - (post_typing:unit) : T.Tac unit = () irreducible let post_typing_as_abstraction (g:env) (x:var) (ty:term) (t:term { fresh_wrt x g (freevars t) }) - (_:unit) : FStar.Ghost.erased (RT.tot_typing (elab_env g) (mk_abs ty t) (mk_arrow ty tm_slprop)) = admit() @@ -80,7 +75,6 @@ let fstar_equiv_preserves_typing let equiv_preserves_typing (g:env) (t1 : term) (typ : term) (t2 : term) (eq : squash (T.equiv_token (elab_env g) t1 t2)) - (t1_typing : unit) : unit = () @@ -128,12 +122,12 @@ let intro_post_hint g effect_annot ret_ty_opt post = post=post'; } -let comp_typing_as_effect_annot_typing (g:env) (c:comp_st) (ct:unit) +let comp_typing_as_effect_annot_typing (g:env) (c:comp_st) : unit = () -let post_hint_from_comp_typing g c ct = +let post_hint_from_comp_typing g c = let p : post_hint_t = { g; effect_annot = effect_annot_of_comp c; @@ -146,19 +140,16 @@ let post_hint_from_comp_typing g c ct = let comp_typing_from_post_hint (#g: env) (c: comp_st) - (pre_typing: unit) (p:post_hint_for_env g { comp_post_matches_hint c (PostHint p) }) : T.Tac unit = let x = fresh g in if x `Set.mem` freevars p.post //exclude this then fail g None "Impossible: unexpected freevar in post, please file a bug-report" - else intro_comp_typing g c pre_typing - () - () - x () + else intro_comp_typing g c + x -let extend_post_hint g p x tx conjunct conjunct_typing = +let extend_post_hint g p x tx conjunct = let g' = push_binding g x ppname_default tx in let y = fresh g' in let g'' = push_binding g' y ppname_default p.ret_ty in @@ -189,21 +180,21 @@ let comp_st_with_post (c:comp_st) (post:term) let ve_unit_r g (p:term) : unit = () -let st_equiv_post (#g:env) (t:st_term) (c:comp_st) (d:unit) +let st_equiv_post (#g:env) (t:st_term) (c:comp_st) (post:term { freevars post `Set.subset` freevars (comp_post c)}) (veq: (x:var { fresh_wrt x g (freevars (comp_post c)) } -> unit)) : Dv unit - = if eq_tm post (comp_post c) then d + = if eq_tm post (comp_post c) then () else let c' = comp_st_with_post c post in - Pulse.Typing.Combinators.t_equiv g t c d c' () + Pulse.Typing.Combinators.t_equiv g t c c' -let simplify_post (g:env) (t:st_term) (c:comp_st) (d:unit) +let simplify_post (g:env) (t:st_term) (c:comp_st) (post:term { comp_post c == tm_star post tm_emp}) : Dv unit - = st_equiv_post #g t c d post (fun x -> ve_unit_r (push_binding g x ppname_default (comp_res c)) (open_term post x)) + = st_equiv_post #g t c post (fun x -> ve_unit_r (push_binding g x ppname_default (comp_res c)) (open_term post x)) let simplify_lemma (c:comp_st) (c':comp_st) (post_hint:post_hint_opt_t) : Lemma @@ -217,11 +208,11 @@ let simplify_lemma (c:comp_st) (c':comp_st) (post_hint:post_hint_opt_t) comp_pre (comp_st_with_post c' (comp_post c)) == comp_pre c') = () -let slprop_equiv_typing_bk (#g:env) (#ctxt:_) (ctxt_typing:unit) - (p:_) (d:unit) +let slprop_equiv_typing_bk (#g:env) (#ctxt:_) + (p:_) : unit - = let _, bk = slprop_equiv_typing g p ctxt d in - bk ctxt_typing + = let _, bk = slprop_equiv_typing g p ctxt in + bk () let comp_with_pre (c:comp_st) (pre:term) = match c with @@ -230,35 +221,33 @@ let comp_with_pre (c:comp_st) (pre:term) = | C_STAtomic i obs st -> C_STAtomic i obs {st with pre} #push-options "--fuel 0 --ifuel 0" -let st_equiv_pre (#g:env) (t:st_term) (c:comp_st) (d:unit) +let st_equiv_pre (#g:env) (t:st_term) (c:comp_st) (pre:term) (veq: unit) : Dv unit - = if eq_tm pre (comp_pre c) then d + = if eq_tm pre (comp_pre c) then () else let c' = comp_with_pre c pre in - Pulse.Typing.Combinators.t_equiv g t c d c' () + Pulse.Typing.Combinators.t_equiv g t c c' let k_elab_equiv_continuation (#g1:env) (#g2:env { g2 `env_extends` g1 }) (#ctxt #ctxt1:term) (ctxt2:term) (k:continuation_elaborator g1 ctxt g2 ctxt1) - (d:unit) : continuation_elaborator g1 ctxt g2 ctxt2 = fun post_hint res -> let (| st, c |) = res in assert (comp_pre c == ctxt2); k post_hint (| st, comp_with_pre c ctxt1 |) -let slprop_equiv_typing_fwd (#g:env) (#ctxt:_) (ctxt_typing:unit) - (p:_) (d:unit) +let slprop_equiv_typing_fwd (#g:env) (#ctxt:_) + (p:_) : unit - = let fwd, _ = slprop_equiv_typing g ctxt p d in - fwd ctxt_typing + = let fwd, _ = slprop_equiv_typing g ctxt p in + fwd () let k_elab_equiv_prefix (#g1:env) (#g2:env { g2 `env_extends` g1 }) (#ctxt1 #ctxt:term) (ctxt2:term) (k:continuation_elaborator g1 ctxt1 g2 ctxt) - (d:unit) : continuation_elaborator g1 ctxt2 g2 ctxt = fun post_hint res -> let framing_token : frame_for_req_in_ctxt g1 ctxt2 ctxt1 = @@ -272,14 +261,12 @@ let k_elab_equiv_prefix let k_elab_equiv (#g1:env) (#g2:env { g2 `env_extends` g1 }) (#ctxt1 #ctxt2:term) (ctxt1' ctxt2':term) (k:continuation_elaborator g1 ctxt1 g2 ctxt2) - (d1:unit) - (d2:unit) : continuation_elaborator g1 ctxt1' g2 ctxt2' = let k : continuation_elaborator g1 ctxt1 g2 ctxt2' = - k_elab_equiv_continuation ctxt2' k d2 in + k_elab_equiv_continuation ctxt2' k in let k : continuation_elaborator g1 ctxt1' g2 ctxt2' = - k_elab_equiv_prefix ctxt1' k d1 in + k_elab_equiv_prefix ctxt1' k in k #push-options "--fuel 3 --ifuel 1 --split_queries no --z3rlimit_factor 20" @@ -287,8 +274,6 @@ open Pulse.PP let continuation_elaborator_with_bind' (#g:env) (ctxt:term) (c1:comp{stateful_comp c1}) (e1:st_term) - (e1_typing:unit) - (ctxt_pre1_typing:unit) (x:nvar {freshv g (snd x)}) : T.Tac (continuation_elaborator g @@ -309,7 +294,7 @@ let continuation_elaborator_with_bind' (#g:env) (ctxt:term) (show ctxt) (show c1)); let c1 = - apply_frame g e1 (tm_star ctxt pre1) ctxt_pre1_typing c1 e1_typing framing_token in + apply_frame g e1 (tm_star ctxt pre1) c1 framing_token in let u_of_1 = () in let b = res1 in let ppname, x = x in @@ -347,11 +332,7 @@ let continuation_elaborator_with_bind' (#g:env) (ctxt:term) let (| e, c |) = Pulse.Typing.Combinators.mk_bind g (tm_star ctxt pre1) - e1 e2_closed c1 c2 (ppname, x) e1_typing - u_of_1 - () - () - () + e1 e2_closed c1 c2 (ppname, x) post_hint in (| e, c |) @@ -363,8 +344,6 @@ let continuation_elaborator_with_bind' (#g:env) (ctxt:term) let continuation_elaborator_with_bind (#g:env) (ctxt:term) (c1:comp{stateful_comp c1}) (e1:st_term) - (e1_typing:unit) - (ctxt_pre1_typing:unit) (x:nvar { freshv g (snd x) }) : T.Tac (continuation_elaborator g @@ -372,7 +351,7 @@ let continuation_elaborator_with_bind (#g:env) (ctxt:term) (push_binding g (snd x) (fst x) (comp_res c1)) (tm_star (open_term (comp_post c1) (snd x)) ctxt)) = RU.record_stats "continuation_elaborator_with_bind" fun _ -> - continuation_elaborator_with_bind' ctxt c1 e1 e1_typing ctxt_pre1_typing x + continuation_elaborator_with_bind' ctxt c1 e1 x let coerce_eq (#a #b:Type) (x:a) (_:squash (a == b)) : y:b{y == x} = x @@ -381,7 +360,6 @@ let coerce_eq (#a #b:Type) (x:a) (_:squash (a == b)) : y:b{y == x} = x let st_comp_typing_with_post_hint (#g:env) (#ctxt:_) - (ctxt_typing:unit) (post_hint:post_hint_opt g { PostHint? post_hint }) (c:comp_st { comp_pre c == ctxt /\ comp_post_matches_hint c post_hint }) : unit @@ -397,11 +375,9 @@ let st_comp_typing_with_post_hint #pop-options let continuation_elaborator_with_bind_fn (#g:env) (ctxt:term) - (ctxt_typing:unit) (e1:st_term) (c1:comp { C_Tot? c1 }) (b:binder{b.binder_ty == comp_res c1}) - (e1_typing:unit) (x:nvar { freshv g (snd x) }) : T.Tac (continuation_elaborator g ctxt @@ -429,7 +405,7 @@ let rec check_equiv_emp (g:env) (vp:term) | _, _ -> None) | _ -> None -let emp_inames_included (g:env) (i:term) (_:unit) +let emp_inames_included (g:env) (i:term) : prop_validity g (tm_inames_subset tm_emp_inames i) = RU.magic() @@ -459,15 +435,13 @@ let return_in_ctxt (g:env) (y:var) (y_ppname:ppname) (u:universe) (ty:term) (ctx | C_STAtomic _ obs st, EffectAnnotAtomic { opens } | C_STAtomic _ obs st, EffectAnnotAtomicOrGhost { opens } -> assert (comp_inames c == tm_emp_inames); - let pht = () in - let validity = emp_inames_included g opens pht in + let validity = emp_inames_included g opens in let c' = C_STAtomic opens obs st in (| t, c' |) | C_STGhost _ st, EffectAnnotGhost { opens } | C_STGhost _ st, EffectAnnotAtomicOrGhost { opens } -> assert (comp_inames c == tm_emp_inames); - let pht = () in - let validity = emp_inames_included g opens pht in + let validity = emp_inames_included g opens in let c' = C_STGhost opens st in (| t, c' |) | _ -> @@ -476,7 +450,6 @@ let return_in_ctxt (g:env) (y:var) (y_ppname:ppname) (u:universe) (ty:term) (ctx #push-options "--z3rlimit_factor 4 --ifuel 1 --split_queries always" #restart-solver let match_comp_res_with_post_hint (#g:env) (t:st_term) (c:comp_st) - (d:unit) (post_hint:post_hint_opt g) : T.Tac (c':comp_st { comp_pre c' == comp_pre c }) = @@ -548,9 +521,6 @@ let checker_result_for_st_typing (#g:env) (#ctxt:slprop) (#post_hint:post_hint_o Pulse.Typing.Combinators.mk_bind g (comp_pre c1) e1 e2_closed c1 c2 (ppname, x) - () u_of_1 - () () - () post_hint in (| ee, cc |) @@ -637,11 +607,10 @@ let rec is_stateful_arrow (g:env) (c:option comp) (args:list T.argv) (out:list T let checker_result_t_equiv_ctxt (g:env) (ctxt ctxt' : slprop) (post_hint:post_hint_opt g) - (equiv : unit) (r : checker_result_t g ctxt post_hint) : checker_result_t g ctxt' post_hint = let (| x, g1, t, ctxt_r, k |) = r in - (| x, g1, t, ctxt_r, k_elab_equiv ctxt' ctxt_r k equiv () |) + (| x, g1, t, ctxt_r, k_elab_equiv ctxt' ctxt_r k |) module RU = Pulse.RuntimeUtils let as_stateful_application (e:term) (head:term) (args:list T.argv { Cons? args }) @@ -665,7 +634,6 @@ let is_stateful_application (g:env) (e:term) let apply_conversion (#g:env) (#e:term) (#eff:FStar.Tactics.V2.tot_or_ghost) (#t0:term) - (d:unit) (#t1:term) (eq:Ghost.erased (RT.related (elab_env g) t0 RT.R_Eq t1)) : unit @@ -673,7 +641,6 @@ let apply_conversion let norm_typing (g:env) (e:term) (eff:FStar.Tactics.V2.tot_or_ghost) (t0:term) - (d:unit) (steps:list norm_step) : T.Tac (t':term & unit) = let (| t', _, _ |) = @@ -684,10 +651,8 @@ let norm_typing module TermEq = FStar.Reflection.TermEq let norm_typing_inverse (g:env) (e:term) (eff:FStar.Tactics.V2.tot_or_ghost) (t0:term) - (d:unit) (t1:term) (u:universe) - (d1:unit) (steps:list norm_step) : T.Tac (option unit) = let (| t1', t1'_typing, related_t1_t1' |) = @@ -700,10 +665,8 @@ let norm_typing_inverse let norm_st_typing_inverse (g:env) (e:st_term) (t0:term) - (d:unit) (u:universe) (t1:term) - (d1:unit) (steps:list norm_step) : T.Tac (option unit) = let d1 @@ -724,7 +687,7 @@ let norm_st_typing_inverse = Ghost.hide (RT.Rel_sym _ _ _ related_t1_t1') in - Some (Pulse.Typing.Combinators.t_equiv g e (C_Tot t0) d (C_Tot t1) ()) + Some (Pulse.Typing.Combinators.t_equiv g e (C_Tot t0) (C_Tot t1)) ) else None diff --git a/src/checker/Pulse.Checker.Base.fsti b/src/checker/Pulse.Checker.Base.fsti index c8781bc3c..b3ad8d1f3 100644 --- a/src/checker/Pulse.Checker.Base.fsti +++ b/src/checker/Pulse.Checker.Base.fsti @@ -30,16 +30,11 @@ val format_failed_goal (g:env) (ctxt:list term) (goal:list term) : T.Tac string val intro_comp_typing (g:env) (c:comp_st) - (pre_typing:unit) - (iname_typing:unit) - (res_typing:unit) (x:var { fresh_wrt x g (freevars (comp_post c)) }) - (post_typing:unit) : T.Tac unit val post_typing_as_abstraction (g:env) (x:var) (ty:term) (t:term { fresh_wrt x g (freevars t) }) - (_:unit) : FStar.Ghost.erased (RT.tot_typing (elab_env g) (RT.mk_abs ty T.Q_Explicit t) (RT.mk_arrow ty T.Q_Explicit tm_slprop)) @@ -62,19 +57,18 @@ val intro_post_hint effect_annot_labels_match h.effect_annot effect_annot }) -val post_hint_from_comp_typing (g:env) (c:comp_st) (ct:unit) +val post_hint_from_comp_typing (g:env) (c:comp_st) : post_hint_for_env g val comp_typing_from_post_hint (#g: env) (c: comp_st) - (pre_typing: unit) (p:post_hint_for_env g { comp_post_matches_hint c (PostHint p) }) : T.Tac unit val extend_post_hint (g:env) (p:post_hint_for_env g) (x:var{freshv g x}) (tx:term) - (conjunct:term) (_:unit) + (conjunct:term) : T.Tac (q:post_hint_for_env (push_binding g x ppname_default tx) { q.post == tm_star p.post conjunct /\ q.ret_ty == p.ret_ty /\ @@ -102,14 +96,11 @@ val k_elab_trans val k_elab_equiv_continuation (#g1:env) (#g2:env { g2 `env_extends` g1 }) (#ctxt #ctxt1:term) (ctxt2:term) (k:continuation_elaborator g1 ctxt g2 ctxt1) - (d:unit) : continuation_elaborator g1 ctxt g2 ctxt2 val k_elab_equiv (#g1:env) (#g2:env { g2 `env_extends` g1 }) (#ctxt1 #ctxt2:term) (ctxt1' ctxt2':term) (k:continuation_elaborator g1 ctxt1 g2 ctxt2) - (d1:unit) - (d2:unit) : continuation_elaborator g1 ctxt1' g2 ctxt2' // @@ -118,8 +109,6 @@ val k_elab_equiv val continuation_elaborator_with_bind (#g:env) (ctxt:term) (c1:comp{stateful_comp c1}) (e1:st_term) - (e1_typing:unit) - (ctxt_pre1_typing:unit) (x:nvar { freshv g (snd x) }) : T.Tac (continuation_elaborator g @@ -128,11 +117,9 @@ val continuation_elaborator_with_bind (#g:env) (ctxt:term) (tm_star (open_term (comp_post c1) (snd x)) ctxt)) val continuation_elaborator_with_bind_fn (#g:env) (ctxt:term) - (ctxt_typing:unit) (e1:st_term) (c1:comp { C_Tot? c1 }) (b:binder{b.binder_ty == comp_res c1}) - (e1_typing:unit) (x:nvar { freshv g (snd x) }) : T.Tac (continuation_elaborator g ctxt @@ -185,14 +172,12 @@ let retype_checker_result (#g:env) (#ctxt:slprop) (#ph:post_hint_opt g) (ph':pos type check_t = g:env -> ctxt:slprop -> - ctxt_typing:unit -> post_hint:post_hint_opt g -> res_ppname:ppname -> t:st_term -> T.Tac (checker_result_t g ctxt post_hint) val match_comp_res_with_post_hint (#g:env) (t:st_term) (c:comp_st) - (d:unit) (post_hint:post_hint_opt g) : T.Tac (c':comp_st { comp_pre c' == comp_pre c }) @@ -208,7 +193,6 @@ val checker_result_for_st_typing (#g:env) (#ctxt:slprop) (#post_hint:post_hint_o val checker_result_t_equiv_ctxt (g:env) (ctxt ctxt' : slprop) (post_hint:post_hint_opt g) - (equiv : unit) (r : checker_result_t g ctxt post_hint) : checker_result_t g ctxt' post_hint @@ -217,25 +201,20 @@ val is_stateful_application (g:env) (e:term) val norm_typing (g:env) (e:term) (eff:T.tot_or_ghost) (t0:term) - (d:unit) (steps:list norm_step) : T.Tac (t':term & unit) val norm_typing_inverse (g:env) (e:term) (eff:T.tot_or_ghost) (t0:term) - (d:unit) (t1:term) (u:universe) - (d1:unit) (steps:list norm_step) : T.Tac (option unit) val norm_st_typing_inverse (g:env) (e:st_term) (t0:term) - (d:unit) (u:universe) (t1:term) - (d1:unit) (steps:list norm_step) : T.Tac (option unit) diff --git a/src/checker/Pulse.Checker.Bind.fst b/src/checker/Pulse.Checker.Bind.fst index 5f1b0ff29..9ae23dc37 100644 --- a/src/checker/Pulse.Checker.Bind.fst +++ b/src/checker/Pulse.Checker.Bind.fst @@ -51,10 +51,9 @@ let check_bind_fn let x = fresh g in let b = { binder with binder_ty = comp_res c } in let g' = push_binding g x (binder.binder_ppname) b.binder_ty in - let ctxt_typing' : unit = () in - let r = check g' _ ctxt_typing' post_hint res_ppname (open_st_term_nv body (binder.binder_ppname, x)) in + let r = check g' _ post_hint res_ppname (open_st_term_nv body (binder.binder_ppname, x)) in let body_typing = apply_checker_result_k #_ #_ #(PostHint?.v post_hint) r res_ppname in - let k = Pulse.Checker.Base.continuation_elaborator_with_bind_fn ctxt () t c b () (binder.binder_ppname, x) in + let k = Pulse.Checker.Base.continuation_elaborator_with_bind_fn ctxt t c b (binder.binder_ppname, x) in let d = k post_hint body_typing in checker_result_for_st_typing d res_ppname ) @@ -132,7 +131,7 @@ let check_bind' let Tm_Bind { binder; head=e1; body=e2 } = t.term in if Tm_Admit? e1.term then ( //Discard the continuation if the head is an admit - check g ctxt () post_hint res_ppname e1 + check g ctxt post_hint res_ppname e1 ) else if Tm_Abs? e1.term then ( @@ -146,12 +145,12 @@ let check_bind' { binder with binder_ppname = ppname_default } else binder in - let r0 = check g ctxt () NoHint binder.binder_ppname e1 in + let r0 = check g ctxt NoHint binder.binder_ppname e1 in check_if_seq_lhs g ctxt _ r0 e1; check_binder_typ g ctxt _ r0 binder e1; let (| x, g1, _, ctxt', k1 |) = r0 in let g1 = reset_context g1 g in - let r1 = check g1 ctxt' () post_hint ppname_default (open_st_term_nv e2 (binder.binder_ppname, x)) in + let r1 = check g1 ctxt' post_hint ppname_default (open_st_term_nv e2 (binder.binder_ppname, x)) in Pulse.Checker.Base.compose_checker_result_t r0 r1 in if not maybe_elaborate then dflt() @@ -169,7 +168,7 @@ let check_bind' match Pulse.Checker.Base.hoist g (Inl tm) false rebuild with | Some t -> //something was elaborated, go back to the top checking loop Util.debug g "pulse.hoist" (fun _ -> Printf.sprintf "Bind was elaborated to %s\n" (show t)); - check g ctxt () post_hint res_ppname t + check g ctxt post_hint res_ppname t | None -> Util.debug g "pulse.hoist" (fun _ -> Printf.sprintf "No elaboration in check_bind, proceeding to check head\n"); dflt() @@ -182,7 +181,7 @@ let check_bind' match Pulse.Checker.Base.hoist g (Inr e1) false rebuild with | Some t -> //something was elaborated, go back to the top checking loop debug_prover g (fun _ -> Printf.sprintf "Bind was elaborated to %s\n" (show t)); - check g ctxt () post_hint res_ppname t + check g ctxt post_hint res_ppname t | None -> debug_prover g (fun _ -> "No elaboration in check_bind, proceeding to check head\n"); dflt() @@ -222,5 +221,5 @@ let check_tot_bind Printf.sprintf "Elaborated and proceeding back to top-level\n%s\nto\n%s\n" (show t) (show t')); - check g pre () post_hint res_ppname t' + check g pre post_hint res_ppname t' #pop-options \ No newline at end of file diff --git a/src/checker/Pulse.Checker.Comp.fst b/src/checker/Pulse.Checker.Comp.fst index 666f8532a..1243b659e 100644 --- a/src/checker/Pulse.Checker.Comp.fst +++ b/src/checker/Pulse.Checker.Comp.fst @@ -25,7 +25,6 @@ module P = Pulse.Syntax.Printer let check (g:env) (c:comp_st) - (pre_typing:unit) : T.Tac (unit) = let g = Pulse.Typing.Env.push_context_no_range g "check_comp" in diff --git a/src/checker/Pulse.Checker.Comp.fsti b/src/checker/Pulse.Checker.Comp.fsti index a23055e7c..14d50dd0d 100644 --- a/src/checker/Pulse.Checker.Comp.fsti +++ b/src/checker/Pulse.Checker.Comp.fsti @@ -23,5 +23,4 @@ open Pulse.Typing val check (g:env) (c:comp_st) - (pre_typing:unit) : T.Tac (unit) diff --git a/src/checker/Pulse.Checker.Exists.fst b/src/checker/Pulse.Checker.Exists.fst index a528f842a..d067c27c7 100644 --- a/src/checker/Pulse.Checker.Exists.fst +++ b/src/checker/Pulse.Checker.Exists.fst @@ -29,10 +29,9 @@ module P = Pulse.Syntax.Printer module FV = Pulse.Typing.FV let slprop_as_list_typing (#g:env) (#p:term) - (t:unit) (x:term { List.Tot.memP x (slprop_as_list p) }) : unit - = assume false; t + = assume false; () let terms_to_string (t:list term) : T.Tac string @@ -88,8 +87,8 @@ let check_elim_exists let elim_st = wtag (Some STT_Ghost) (Tm_ElimExists { p = tm_exists_sl u (as_binder ty) p }) in let elim_c = comp_elim_exists u ty p (ppname_default, x) in - let c = match_comp_res_with_post_hint elim_st elim_c () post_hint in - prove_post_hint (try_frame_pre false () (|elim_st,c|) res_ppname) post_hint t_rng + let c = match_comp_res_with_post_hint elim_st elim_c post_hint in + prove_post_hint (try_frame_pre false (|elim_st,c|) res_ppname) post_hint t_rng else fail g (Some t_rng) (Printf.sprintf "check_elim_exists: universe checking failed, computed %s, expected %s" (P.univ_to_string u') (P.univ_to_string u)) @@ -123,7 +122,7 @@ let check_intro_exists let Tm_ExistsSL u b p = tv in - Pulse.Typing.FV.tot_typing_freevars g t tm_slprop (); + Pulse.Typing.FV.tot_typing_freevars g t tm_slprop; let x = fresh g in let ty_typing, _ = (), () in let witness = @@ -131,8 +130,8 @@ let check_intro_exists let intro_st = wtag (Some STT_Ghost) (Tm_IntroExists { p = tm_exists_sl u b p; witnesses = [witness] }) in let intro_c = C_STGhost tm_emp_inames { u=u0; res=tm_unit; pre=open_term' p witness 0; post=tm_exists_sl u b p } in - let c = match_comp_res_with_post_hint intro_st intro_c () post_hint in - prove_post_hint (try_frame_pre false () (|intro_st, c|) res_ppname) + let c = match_comp_res_with_post_hint intro_st intro_c post_hint in + prove_post_hint (try_frame_pre false (|intro_st, c|) res_ppname) post_hint (Pulse.RuntimeUtils.range_of_term t) #pop-options diff --git a/src/checker/Pulse.Checker.ForwardJumpLabel.fst b/src/checker/Pulse.Checker.ForwardJumpLabel.fst index 7a4967b49..d6c28e565 100644 --- a/src/checker/Pulse.Checker.ForwardJumpLabel.fst +++ b/src/checker/Pulse.Checker.ForwardJumpLabel.fst @@ -59,7 +59,7 @@ let check // TODO: just ignore early return/continue labels in atomic/ghost contexts for now let lbl_x = fresh g in let body = open_st_term_nv body (lbl, lbl_x) in - check _ _ () _ res_ppname body + check _ _ _ res_ppname body else fail g (Some rng) "Labels require stt" else @@ -76,7 +76,7 @@ let check assume post_hint_for_env_p g' post; PostHint post in let body = open_st_term_nv body (lbl, lbl_x) in - let body' = check g' pre pre_typing' post_hint' res_ppname body in + let body' = check g' pre post_hint' res_ppname body in let (| body', body'_c |) = apply_checker_result_k #g' #pre #post body' res_ppname in assert comp_u body'_c == comp_u lbl_c; assert comp_res body'_c == comp_res lbl_c; @@ -96,9 +96,9 @@ let check assert post_hint0 == PostHint post; checker_result_for_st_typing (| t, body'_c |) res_ppname ) else ( - let c'' = match_comp_res_with_post_hint t body'_c () post_hint0 in + let c'' = match_comp_res_with_post_hint t body'_c post_hint0 in prove_post_hint #g - (try_frame_pre false #g () (|t,c''|) res_ppname) + (try_frame_pre false #g (|t,c''|) res_ppname) post_hint0 rng ) diff --git a/src/checker/Pulse.Checker.Goto.fst b/src/checker/Pulse.Checker.Goto.fst index d905022ba..c288a12c4 100644 --- a/src/checker/Pulse.Checker.Goto.fst +++ b/src/checker/Pulse.Checker.Goto.fst @@ -48,12 +48,9 @@ let check' post = ph.post } in let t = wtag (Some (ctag_of_comp_st c')) (Tm_Goto { lbl = term_of_nvar (lbln, v); arg }) in - let typing: unit = - let x' = fresh g in assume fresh_wrt x' g (freevars ph.post); - () in - let c' = match_comp_res_with_post_hint t c' typing post_hint in + let c' = match_comp_res_with_post_hint t c' post_hint in prove_post_hint #g - (try_frame_pre false #g () (|t,c'|) res_ppname) + (try_frame_pre false #g (|t,c'|) res_ppname) post_hint rng | None -> diff --git a/src/checker/Pulse.Checker.If.fst b/src/checker/Pulse.Checker.If.fst index 08099989a..2a68865c3 100644 --- a/src/checker/Pulse.Checker.If.fst +++ b/src/checker/Pulse.Checker.If.fst @@ -76,7 +76,7 @@ let check in let ppname = mk_ppname_no_range "_if_br" in - let r = check (g_with_eq eq_v) pre () post_hint ppname br in + let r = check (g_with_eq eq_v) pre post_hint ppname br in r in @@ -126,9 +126,9 @@ let check let (| e1, c1, e1_typing |) = extract then_ true in let (| e2, c2, e2_typing |) = extract else_ false in let (| c, e1_typing, e2_typing |) = - J.join_comps (g_with_eq tm_true) e1 c1 e1_typing (g_with_eq tm_false) e2 c2 e2_typing post_hint' in + J.join_comps (g_with_eq tm_true) e1 c1 (g_with_eq tm_false) e2 c2 post_hint' in - let c_typing = comp_typing_from_post_hint c () post_hint' in + let c_typing = comp_typing_from_post_hint c post_hint' in let if_st = wrst c (Tm_If { b; then_=e1; else_=e2; post=None }) in let d : st_typing_in_ctxt g pre (PostHint post_hint') = diff --git a/src/checker/Pulse.Checker.IntroPure.fst b/src/checker/Pulse.Checker.IntroPure.fst index d2a9040d0..8b51018bf 100644 --- a/src/checker/Pulse.Checker.IntroPure.fst +++ b/src/checker/Pulse.Checker.IntroPure.fst @@ -61,5 +61,5 @@ let check let intro_st = wtag (Some STT_Ghost) (Tm_IntroPure { p }) in let intro_c = C_STGhost tm_emp_inames { u=u0; res=tm_unit; pre=tm_emp; post=tm_pure p } in - let c = match_comp_res_with_post_hint intro_st intro_c () post_hint in - prove_post_hint (try_frame_pre false () (|intro_st,c|) res_ppname) post_hint t.range + let c = match_comp_res_with_post_hint intro_st intro_c post_hint in + prove_post_hint (try_frame_pre false (|intro_st,c|) res_ppname) post_hint t.range diff --git a/src/checker/Pulse.Checker.Match.fst b/src/checker/Pulse.Checker.Match.fst index 733ab517d..3cd33a997 100644 --- a/src/checker/Pulse.Checker.Match.fst +++ b/src/checker/Pulse.Checker.Match.fst @@ -181,10 +181,9 @@ and elab_readback_subpat (pb : R.pattern & bool) val tot_typing_weakening_n (#g:env) (#t:term) (#ty:term) (bs:list var_binding {all_fresh g bs}) - (d:unit) : Tot (unit) (decreases bs) -let rec tot_typing_weakening_n #g #t #ty bs d = () +let rec tot_typing_weakening_n #g #t #ty bs = () let patof (b:branch) : pattern = b.pat let samepat (b1 b2 : branch) : prop = b1.pat == b2.pat @@ -273,7 +272,7 @@ let check_branch let (| e, c |) = let ppname = mk_ppname_no_range "_br" in - let r = check g' pre () (PostHint post_hint) ppname e in + let r = check g' pre (PostHint post_hint) ppname e in apply_checker_result_k r ppname in (| p, close_st_term_n e (L.map (fun (b: var_binding) -> b.x) pulse_bs), c |) @@ -538,7 +537,7 @@ let check (* Provable *) assume (L.map (fun br -> elab_pat br.pat) brs == elab_pats'); - let c_typing = comp_typing_from_post_hint c () post_hint in + let c_typing = comp_typing_from_post_hint c post_hint in let t = wtag (Some (ctag_of_comp_st c)) (Tm_Match {sc; returns_=None; brs}) in checker_result_for_st_typing (| t, c |) res_ppname diff --git a/src/checker/Pulse.Checker.Prover.Normalize.fst b/src/checker/Pulse.Checker.Prover.Normalize.fst index 8931ad881..69a022481 100644 --- a/src/checker/Pulse.Checker.Prover.Normalize.fst +++ b/src/checker/Pulse.Checker.Prover.Normalize.fst @@ -69,7 +69,6 @@ let normalize_slprop let normalize_slprop_welltyped (g:env) (v:slprop) - (v_typing:unit) : T.Tac slprop = let v' = normalize_slprop g v true in diff --git a/src/checker/Pulse.Checker.Prover.Normalize.fsti b/src/checker/Pulse.Checker.Prover.Normalize.fsti index a16b408b1..ced5d0308 100644 --- a/src/checker/Pulse.Checker.Prover.Normalize.fsti +++ b/src/checker/Pulse.Checker.Prover.Normalize.fsti @@ -35,5 +35,4 @@ val normalize_slprop val normalize_slprop_welltyped (g:env) (v:slprop) - (v_typing:unit) : T.Tac slprop diff --git a/src/checker/Pulse.Checker.Prover.fst b/src/checker/Pulse.Checker.Prover.fst index c8a44d7ea..7e9db2a0b 100644 --- a/src/checker/Pulse.Checker.Prover.fst +++ b/src/checker/Pulse.Checker.Prover.fst @@ -205,26 +205,23 @@ let build_plems (g: env) : T.Tac plems = let cont_elab g ps g' ps' = frame: list slprop_view -> continuation_elaborator g (elab_slprops (frame @ ps)) g' (elab_slprops (frame @ ps')) -let cont_elab_refl g ps ps' (h: unit) : cont_elab g ps g ps' = - fun frame -> k_elab_equiv (elab_slprops (frame @ ps)) (elab_slprops (frame @ ps')) (k_elab_unit g (elab_slprops (frame @ ps))) (()) (()) +let cont_elab_refl g ps ps' : cont_elab g ps g ps' = + fun frame -> k_elab_equiv (elab_slprops (frame @ ps)) (elab_slprops (frame @ ps')) (k_elab_unit g (elab_slprops (frame @ ps))) let cont_elab_trans #g1 (#g2: env { g2 `env_extends` g1 }) (#g3: env { g3 `env_extends` g2 }) #ps1 #ps2 #ps2' #ps3 (k1: cont_elab g1 ps1 g2 ps2) - (k2: cont_elab g2 ps2' g3 ps3) - (h: unit) : + (k2: cont_elab g2 ps2' g3 ps3) : cont_elab g1 ps1 g3 ps3 = - fun frame -> k_elab_trans (k1 frame) (k_elab_equiv (elab_slprops (frame @ ps2)) (elab_slprops (frame @ ps3)) (k2 frame) (()) (())) + fun frame -> k_elab_trans (k1 frame) (k_elab_equiv (elab_slprops (frame @ ps2)) (elab_slprops (frame @ ps3)) (k2 frame)) let cont_elab_equiv #g1 #ps1 #ps1' #g2 #ps2 #ps2' - (k: cont_elab g1 ps1 g2 ps2) - (h1: unit) - (h2: unit) : + (k: cont_elab g1 ps1 g2 ps2) : cont_elab g1 ps1' g2 ps2' = - fun frame -> k_elab_equiv (elab_slprops (frame @ ps1')) (elab_slprops (frame @ ps2')) (k frame) (()) (()) + fun frame -> k_elab_equiv (elab_slprops (frame @ ps1')) (elab_slprops (frame @ ps2')) (k frame) let cont_elab_frame #g #ps #g' #ps' (k: cont_elab g ps g' ps') frame : cont_elab g (frame @ ps) g' (frame @ ps') = - fun frame' -> k_elab_equiv (elab_slprops (frame' @ (frame @ ps))) (elab_slprops (frame' @ (frame @ ps'))) (k (frame' @ frame)) (RU.magic()) (RU.magic()) + fun frame' -> k_elab_equiv (elab_slprops (frame' @ (frame @ ps))) (elab_slprops (frame' @ (frame @ ps'))) (k (frame' @ frame)) let cont_elab_thunk #g #ps #g' #ps' (k: unit -> T.Tac (cont_elab g ps g' ps')) : cont_elab g ps g' ps' = fun frame posth typing -> k () frame posth typing @@ -250,11 +247,11 @@ let prover_result_join #g #ctxt #goals #g1 #ctxt1 #goals1 (fun frame -> - k_elab_trans (before1 frame) (k_elab_equiv (elab_slprops (frame @ solved1 @ ctxt1)) (elab_slprops (frame @ (solved1 @ solved2) @ ctxt2)) (before2 (frame @ solved1)) () ())), + k_elab_trans (before1 frame) (k_elab_equiv (elab_slprops (frame @ solved1 @ ctxt1)) (elab_slprops (frame @ (solved1 @ solved2) @ ctxt2)) (before2 (frame @ solved1)))), (fun frame -> - k_elab_trans (k_elab_equiv (elab_slprops (frame @ (solved1 @ solved2) @ goals2)) (elab_slprops (frame @ solved1 @ goals1)) (after2 (frame @ solved1)) () ()) (after1 frame)) + k_elab_trans (k_elab_equiv (elab_slprops (frame @ (solved1 @ solved2) @ goals2)) (elab_slprops (frame @ solved1 @ goals1)) (after2 (frame @ solved1))) (after1 frame)) <: T.Tac _ |) let prove_first (g: env) (ctxt goals: list slprop_view) @@ -274,7 +271,7 @@ let prove_first (g: env) (ctxt goals: list slprop_view) (fun frame -> - k_elab_equiv (elab_slprops (frame @ solved @ List.Tot.Base.rev goals_left_rev @ goals' @ goals)) (elab_slprops (frame @ goals0)) (after (frame @ List.rev goals_left_rev @ goals)) () ()) |) + k_elab_equiv (elab_slprops (frame @ solved @ List.Tot.Base.rev goals_left_rev @ goals' @ goals)) (elab_slprops (frame @ goals0)) (after (frame @ List.rev goals_left_rev @ goals))) |) | None -> assert List.rev goals_left_rev @ (goal::goals) == goals0; assume List.rev (goal::goals_left_rev) @ goals == goals0; @@ -290,8 +287,6 @@ let deep_compress_comp (c:comp {stateful_comp c}) : comp = let continuation_elaborator_with_bind_nondep (#g:env) (ctxt:term) (c1:comp{stateful_comp c1}) (e1:st_term) - (e1_typing:unit) - (ctxt_pre1_typing:unit) : T.Tac (continuation_elaborator g (tm_star ctxt (comp_pre c1)) @@ -299,13 +294,11 @@ let continuation_elaborator_with_bind_nondep (#g:env) (ctxt:term) (tm_star (comp_post c1) ctxt)) = let x = fresh g in admit (); - continuation_elaborator_with_bind (RU.deep_compress_safe ctxt) (deep_compress_comp c1) e1 e1_typing ctxt_pre1_typing (ppname_default, x) + continuation_elaborator_with_bind (RU.deep_compress_safe ctxt) (deep_compress_comp c1) e1 (ppname_default, x) let continuation_elaborator_with_bind_nondep_unit (#g:env) (ctxt:term) (c1:comp_st{comp_res c1 == tm_unit }) (e1:st_term) - (e1_typing:unit) - (ctxt_pre1_typing:unit) : T.Tac (continuation_elaborator g (tm_star ctxt (comp_pre c1)) @@ -313,13 +306,11 @@ let continuation_elaborator_with_bind_nondep_unit (#g:env) (ctxt:term) (tm_star (open_term' (comp_post c1) unit_const 0) ctxt)) = let c1 = with_st_comp c1 { st_comp_of_comp c1 with post = open_term' (comp_post c1) unit_const 0 } in - continuation_elaborator_with_bind_nondep #g ctxt c1 e1 () ctxt_pre1_typing + continuation_elaborator_with_bind_nondep #g ctxt c1 e1 let cont_elab_with_bind_nondep_unit (#g:env) (c1:comp_st{comp_res c1 == tm_unit }) (e1:st_term) - (e1_typing:unit) - (pre1_typing:unit) : T.Tac (cont_elab g [Unknown (comp_pre c1)] @@ -332,13 +323,10 @@ let cont_elab_with_bind_nondep_unit (#g:env) k_elab_equiv (elab_slprops (frame @ [Unknown (comp_pre c1)])) (elab_slprops (frame @ [Unknown (open_term' (comp_post c1) unit_const 0)])) - (continuation_elaborator_with_bind_nondep_unit (elab_slprops frame) c1 e1 e1_typing ()) - () () posth t - -let tot_typing_tm_unit (g: env) : unit = () + (continuation_elaborator_with_bind_nondep_unit (elab_slprops frame) c1 e1) + posth t let intro_pure (g: env) (frame: slprop) (p: term) - (p_typing:unit) (pv:prop_validity g p): continuation_elaborator g frame g (frame `tm_star` tm_pure p) = fun post t -> @@ -346,7 +334,7 @@ let intro_pure (g: env) (frame: slprop) (p: term) let st = wtag (Some STT_Ghost) (Tm_IntroPure { p }) in debug_prover g (fun _ -> Printf.sprintf "intro_pure p=%s\nframe=%s\n" (show p) (show frame)); - k_elab_equiv frame (frame `tm_star` tm_pure p) (continuation_elaborator_with_bind_nondep frame (comp_intro_pure p) st () ()) (()) (()) + k_elab_equiv frame (frame `tm_star` tm_pure p) (continuation_elaborator_with_bind_nondep frame (comp_intro_pure p) st) post t let is_uvar (t:term) : bool = @@ -387,15 +375,14 @@ let prove_pure (g: env) (ctxt: list slprop_view) (skip_eq_uvar: bool) (goal: slp Some (| g, ctxt, [], [], fun g'' -> // implied by t2_typing let pv = check_prop_validity g'' p in - cont_elab_refl g ctxt ([] @ ctxt) (()), + cont_elab_refl g ctxt ([] @ ctxt), (fun frame -> k_elab_equiv (elab_slprops (frame @ [] @ [])) (elab_slprops (frame @ [goal])) - (intro_pure g'' (elab_slprops frame) p () pv) - () ()) + (intro_pure g'' (elab_slprops frame) p pv)) <: T.Tac _ |) end | _ -> None @@ -413,7 +400,7 @@ let intro_with_pure (g: env) (frame: slprop) (p: term) (n: ppname) (v: term) : debug_prover g (fun _ -> Printf.sprintf "intro_pure p=%s\nframe=%s\n" (show p) (show frame)); - k_elab_equiv (frame `tm_star` v) (frame `tm_star` tm_with_pure p n v) (continuation_elaborator_with_bind_nondep frame c st () ()) (()) (()) + k_elab_equiv (frame `tm_star` v) (frame `tm_star` tm_with_pure p n v) (continuation_elaborator_with_bind_nondep frame c st) post t let prove_with_pure (g: env) (ctxt: list slprop_view) skip_eq_uvar (goal: slprop_view) : @@ -423,11 +410,11 @@ let prove_with_pure (g: env) (ctxt: list slprop_view) skip_eq_uvar (goal: slprop if pure_eq_unif g p skip_eq_uvar then None else Some (| g, ctxt, [Unknown v], [], fun g'' -> - cont_elab_refl g ctxt ([] @ ctxt) (()), + cont_elab_refl g ctxt ([] @ ctxt), (fun frame -> - k_elab_equiv (elab_slprops (frame @ [Unknown v] @ [])) (elab_slprops (frame @ [goal])) (intro_with_pure g'' (elab_slprops frame) p n v) () ()) + k_elab_equiv (elab_slprops (frame @ [Unknown v] @ [])) (elab_slprops (frame @ [goal])) (intro_with_pure g'' (elab_slprops frame) p n v)) <: T.Tac _ |) | _ -> None @@ -445,7 +432,7 @@ let intro_exists (g: env) (frame: slprop) (u: universe) (b: binder) (body: slpro let st = wtag (Some STT_Ghost) (Tm_IntroExists { p = tm_exists_sl u b body; witnesses = [e] }) in debug_prover g (fun _ -> Printf.sprintf "intro_exists %s\nframe=%s\n" (show (tm_exists_sl u b body)) (show frame)); - k_elab_equiv (frame `tm_star` open_term' body e 0) (frame `tm_star` tm_exists_sl u b body) (continuation_elaborator_with_bind_nondep frame (comp_intro_exists u b body e) st () ()) () () + k_elab_equiv (frame `tm_star` open_term' body e 0) (frame `tm_star` tm_exists_sl u b body) (continuation_elaborator_with_bind_nondep frame (comp_intro_exists u b body e) st) post t let prove_exists (g: env) (ctxt: list slprop_view) (goal: slprop_view) : @@ -455,11 +442,11 @@ let prove_exists (g: env) (ctxt: list slprop_view) (goal: slprop_view) : // unnecessarily restrictive environment for uvar let e = RU.new_implicit_var "witness for exists*" (RU.range_of_term body) (elab_env g) b.binder_ty false in Some (| g, ctxt, [Unknown (open_term' body e 0)], [], fun g'' -> - cont_elab_refl g ctxt ([] @ ctxt) (()), + cont_elab_refl g ctxt ([] @ ctxt), (fun frame -> - k_elab_equiv (elab_slprops (frame @ [] @ [Unknown (open_term' body e 0)])) (elab_slprops (frame @ [goal])) (intro_exists g'' (elab_slprops frame) u b body e) () ()) + k_elab_equiv (elab_slprops (frame @ [] @ [Unknown (open_term' body e 0)])) (elab_slprops (frame @ [goal])) (intro_exists g'' (elab_slprops frame) u b body e)) <: T.Tac _ |) | _ -> None @@ -473,7 +460,7 @@ let unpack_and_norm_goal (g: env) (ctxt: list slprop_view) (goal: slprop_view) : | [Unknown _] -> None | _ -> Some (| g, ctxt, goal'', [], fun g' -> - cont_elab_refl _ _ _ (()), cont_elab_refl _ _ _ () + cont_elab_refl _ _ _, cont_elab_refl _ _ _ <: T.Tac _ |)) | _ -> None @@ -500,8 +487,8 @@ let elim_first' (g: env) (ctxt0 goals: list slprop_view) - cont_elab_equiv (cont_elab_frame before (List.rev ctxt_left_rev @ ctxt)) () (), - cont_elab_equiv (cont_elab_frame after goals) () () |) + cont_elab_equiv (cont_elab_frame before (List.rev ctxt_left_rev @ ctxt)), + cont_elab_equiv (cont_elab_frame after goals) |) | None -> assert List.rev ctxt_left_rev @ (c::ctxt) == ctxt0; assume List.rev (c::ctxt_left_rev) @ ctxt == ctxt0; @@ -527,7 +514,7 @@ let unreachable_elim (g: env) (goals: list slprop_view) : cont_elab g [IsUnreach let st = unreachable_elim_typing g u0 tm_unit frame_t in - k_elab_equiv (elab_slprops (frame @ [IsUnreachable])) (elab_slprops (frame @ goals)) (continuation_elaborator_with_bind_nondep frame_t c st () ()) (()) (()) + k_elab_equiv (elab_slprops (frame @ [IsUnreachable])) (elab_slprops (frame @ goals)) (continuation_elaborator_with_bind_nondep frame_t c st) post t let elim_is_unreachable (g: env) (ctxt goals: list slprop_view) : @@ -535,7 +522,7 @@ let elim_is_unreachable (g: env) (ctxt goals: list slprop_view) : if not (List.existsb IsUnreachable? ctxt) then None else // TODO: maybe add `_: squash False` to the environment? - Some (| g, [IsUnreachable], [], [IsUnreachable], (fun g'' -> cont_elab_refl _ _ _ (), unreachable_elim _ _ <: T.Tac _)|) + Some (| g, [IsUnreachable], [], [IsUnreachable], (fun g'' -> cont_elab_refl _ _ _, unreachable_elim _ _ <: T.Tac _)|) let elim_is_unreachable' (g: env) (ctxt goals: list slprop_view) : T.Tac (option (prover_result_samegoals g ctxt goals)) = @@ -547,8 +534,8 @@ let elim_is_unreachable' (g: env) (ctxt goals: list slprop_view) : Some (| g, [IsUnreachable], goals, [IsUnreachable], (fun g'' -> - cont_elab_refl _ _ _ (), - cont_elab_equiv (unreachable_elim g'' goals) () (()) + cont_elab_refl _ _ _, + cont_elab_equiv (unreachable_elim g'' goals) <: T.Tac _)|) let unpack_and_norm_ctxt (g: env) (ctxt: slprop_view) : @@ -561,7 +548,7 @@ let unpack_and_norm_ctxt (g: env) (ctxt: slprop_view) : | [Unknown _] -> None | _ -> Some (| g, ctxt'', [], [], fun g' -> - cont_elab_refl _ _ _ (), cont_elab_refl _ _ _ (()) + cont_elab_refl _ _ _, cont_elab_refl _ _ _ <: T.Tac _ |)) | _ -> None @@ -575,8 +562,8 @@ let elim_pure (g: env) (frame: slprop) (p: term) (x: nvar { ~(Set.mem (snd x) (d let k: continuation_elaborator g (tm_star frame (tm_pure p)) g' (tm_star tm_emp frame) = - continuation_elaborator_with_bind frame c st () () x in - k_elab_equiv (frame `tm_star` tm_pure p) frame k () () post t + continuation_elaborator_with_bind frame c st x in + k_elab_equiv (frame `tm_star` tm_pure p) frame k post t let elim_pure_step (g: env) (ctxt: slprop_view) : T.Tac (option (prover_result_nogoals g [ctxt])) = @@ -589,8 +576,8 @@ let elim_pure_step (g: env) (ctxt: slprop_view) : (fun frame -> - k_elab_equiv (elab_slprops (frame @ [ctxt])) (elab_slprops (frame @ [] @ [])) (elim_pure g (elab_slprops frame) p x g') () ()), - cont_elab_refl _ _ _ (()) + k_elab_equiv (elab_slprops (frame @ [ctxt])) (elab_slprops (frame @ [] @ [])) (elim_pure g (elab_slprops frame) p x g')), + cont_elab_refl _ _ _ <: T.Tac _ |) | _ -> None @@ -606,8 +593,8 @@ let elim_with_pure (g: env) (frame: slprop) (p: term) (x: nvar { ~(Set.mem (snd let k: continuation_elaborator g (tm_star frame (tm_with_pure p (fst x) v)) g' (tm_star v frame) = - continuation_elaborator_with_bind frame c st () () x in - k_elab_equiv (frame `tm_star` tm_with_pure p (fst x) v) (frame `tm_star` v) k () () post t + continuation_elaborator_with_bind frame c st x in + k_elab_equiv (frame `tm_star` tm_with_pure p (fst x) v) (frame `tm_star` v) k post t let elim_with_pure_step (g: env) (ctxt: slprop_view) : T.Tac (option (prover_result_nogoals g [ctxt])) = @@ -620,8 +607,8 @@ let elim_with_pure_step (g: env) (ctxt: slprop_view) : (fun frame -> - k_elab_equiv (elab_slprops (frame @ [ctxt])) (elab_slprops (frame @ [Unknown v] @ [])) (elim_with_pure g (elab_slprops frame) p x v g') () ()), - cont_elab_refl _ _ _ (()) + k_elab_equiv (elab_slprops (frame @ [ctxt])) (elab_slprops (frame @ [Unknown v] @ [])) (elim_with_pure g (elab_slprops frame) p x v g')), + cont_elab_refl _ _ _ <: T.Tac _ |) | _ -> None @@ -640,8 +627,8 @@ let elim_exists (g: env) (frame: slprop) u b body (x: nvar { ~(Set.mem (snd x) ( assume open_term (comp_post c) (snd x) == c_post_x; let k: continuation_elaborator g (tm_star frame (tm_exists_sl u b body)) g' (tm_star c_post_x frame) = - continuation_elaborator_with_bind frame c st () () x in - k_elab_equiv (frame `tm_star` tm_exists_sl u b body) (frame `tm_star` c_post_x) k () () post t + continuation_elaborator_with_bind frame c st x in + k_elab_equiv (frame `tm_star` tm_exists_sl u b body) (frame `tm_star` c_post_x) k post t let elim_exists_step (g: env) (ctxt: slprop_view) : T.Tac (option (prover_result_nogoals g [ctxt])) = @@ -657,8 +644,8 @@ let elim_exists_step (g: env) (ctxt: slprop_view) : (fun frame -> - k_elab_equiv (elab_slprops (frame @ [ctxt])) (elab_slprops (frame @ [] @ [Unknown result])) (elim_exists g (elab_slprops frame) u b body x g') () ()), - cont_elab_refl _ _ _ (()) + k_elab_equiv (elab_slprops (frame @ [ctxt])) (elab_slprops (frame @ [] @ [Unknown result])) (elim_exists g (elab_slprops frame) u b body x g')), + cont_elab_refl _ _ _ <: T.Tac _ |) | _ -> None @@ -917,11 +904,9 @@ let prove_atom_unamb (g: env) (ctxt: list slprop_view) (goal: slprop_view) : debug_prover g (fun _ -> Printf.sprintf "prove_atom_unamb: result of unify %s and %s is %s\n" (show (elab_slprop cand)) (show goal) (show ok)); let rest_ctxt = List.Tot.filter (fun (j, _) -> j <> i) ictxt |> List.Tot.map snd in Some (| g, rest_ctxt, [], [cand], fun g' -> - let h2: unit = check_slprop_equiv_ext (RU.range_of_term goal) g (elab_slprop cand) goal in - - let h2: unit = h2 in - cont_elab_refl _ _ _ (), - cont_elab_refl _ _ _ h2 + let _ = check_slprop_equiv_ext (RU.range_of_term goal) g (elab_slprop cand) goal in + cont_elab_refl _ _ _, + cont_elab_refl _ _ _ <: T.Tac _ |) | _ -> None @@ -946,11 +931,9 @@ let prove_atom (g: env) (ctxt: list slprop_view) (allow_amb: bool) (goal: slprop debug_prover g (fun _ -> Printf.sprintf "prove_atom: unified %s and %s, result is %s\n" (show (elab_slprop cand)) (show goal) (show ok)); let rest_ctxt = List.Tot.filter (fun (j, _) -> j <> i) ictxt |> List.Tot.map snd in Some (| g, rest_ctxt, [], [cand], fun g' -> - let h2: unit = check_slprop_equiv_ext (RU.range_of_term goal) g (elab_slprop cand) goal in - - let h2: unit = h2 in - cont_elab_refl _ _ _ (), - cont_elab_refl _ _ _ h2 + let _ = check_slprop_equiv_ext (RU.range_of_term goal) g (elab_slprop cand) goal in + cont_elab_refl _ _ _, + cont_elab_refl _ _ _ <: T.Tac _ |) | _ -> None @@ -1024,12 +1007,10 @@ let try_apply_elim_lemma (g: env) (lid: R.name) (i: nat) (ctxt: slprop_view) : - let h2: unit = - assume elab_slprop ctxt == pre; () in - - let k_t = cont_elab_with_bind_nondep_unit c t' () () in - cont_elab_equiv k_t h2 (), - cont_elab_refl g'' ([] @ []) [] (()) |) + assume (elab_slprop ctxt == pre); + let k_t = cont_elab_with_bind_nondep_unit c t' in + cont_elab_equiv k_t, + cont_elab_refl g'' ([] @ []) [] |) ) else None | _ -> None) @@ -1069,9 +1050,9 @@ let try_apply_eager_intro_lemma (g: env) (lid: R.name) (i: nat) ctxt (goal: slpr - let k_typing = cont_elab_with_bind_nondep_unit c t' () () in - cont_elab_refl g ctxt ([] @ ctxt) (()), - cont_elab_equiv k_typing () () + let k_typing = cont_elab_with_bind_nondep_unit c t' in + cont_elab_refl g ctxt ([] @ ctxt), + cont_elab_equiv k_typing |) ) else None @@ -1126,7 +1107,7 @@ let prover_result_solved_unpack #g #ctxt #goals (res: prover_result_solved g ctx (| g', ctxt', cont_elab_thunk fun _ -> let k1, k2 = k g' in - cont_elab_trans k1 (cont_elab_frame k2 ctxt') () |) + cont_elab_trans k1 (cont_elab_frame k2 ctxt') |) #restart-solver #push-options "--split_queries always --z3rlimit 15" @@ -1173,12 +1154,12 @@ let try_apply_intro_lemma (g: env) (lid: R.name) (i: nat) ctxt (goal: slprop_vie - let k_typing = cont_elab_with_bind_nondep_unit c t' () () in + let k_typing = cont_elab_with_bind_nondep_unit c t' in let k_typing = cont_elab_frame k_typing ctxt' in let k_typing: cont_elab g' (ctxt' @ [Unknown pre]) g' ([goal] @ ctxt' @ post''_rest) = - cont_elab_equiv k_typing () () in - cont_elab_trans k k_typing (()), - cont_elab_refl g'' ([goal] @ []) [goal] (()) + cont_elab_equiv k_typing in + cont_elab_trans k k_typing, + cont_elab_refl g'' ([goal] @ []) [goal] <: cont_elab g ctxt g' ([goal] @ ctxt' @ post''_rest) & cont_elab g'' ([goal] @ []) g'' [goal] |) <: T.Tac (prover_result g ctxt [goal]) @@ -1309,8 +1290,8 @@ let rec try_prove_core (pg: penv) (ctxt goals: list slprop_view) : T.Tac (prover prover_result_join step step2 | None -> (| g, ctxt, goals, [], fun g'' -> - cont_elab_refl g _ _ (()), - cont_elab_refl g'' ([] @ goals) goals (()) + cont_elab_refl g _ _, + cont_elab_refl g'' ([] @ goals) goals <: T.Tac _ |) let try_prove (g: env) (ctxt goals: slprop) allow_amb : T.Tac (prover_result g [Unknown ctxt] [Unknown goals]) = @@ -1325,8 +1306,8 @@ let try_prove (g: env) (ctxt goals: slprop) allow_amb : T.Tac (prover_result g [ let before, after = k1 g2 in - cont_elab_equiv before () (()), - cont_elab_equiv after (()) () |) + cont_elab_equiv before, + cont_elab_equiv after |) let prove rng (g: env) (ctxt goals: slprop) allow_amb : T.Tac (g':env { env_extends g' g } & @@ -1347,7 +1328,7 @@ let prove rng (g: env) (ctxt goals: slprop) allow_amb : else let (| g', ctxt', k |) = prover_result_solved_unpack res in - (| g', RU.deep_compress_safe (elab_slprops ctxt'), k_elab_equiv ctxt (tm_star goals (RU.deep_compress_safe (elab_slprops ctxt'))) (k []) () () |) + (| g', RU.deep_compress_safe (elab_slprops ctxt'), k_elab_equiv ctxt (tm_star goals (RU.deep_compress_safe (elab_slprops ctxt'))) (k []) |) let rec try_elim_core (pg: penv) (ctxt: list slprop_view) : T.Tac (prover_result_nogoals pg.penv_env ctxt) = @@ -1355,8 +1336,8 @@ let rec try_elim_core (pg: penv) (ctxt: list slprop_view) : let g = pg.penv_env in let noop () : prover_result g ctxt [] = (| g, ctxt, [], [], fun g'' -> - cont_elab_refl g _ _ (()), - cont_elab_refl g'' [] [] (()) + cont_elab_refl g _ _, + cont_elab_refl g'' [] [] <: T.Tac _ |) in debug_prover g (fun _ -> Printf.sprintf "eliminating\n%s\n" (show_slprops ctxt)); let step : option (prover_result_nogoals g ctxt) = @@ -1370,38 +1351,34 @@ let rec try_elim_core (pg: penv) (ctxt: list slprop_view) : | None -> noop () let elim_exists_and_pure (#g:env) (#ctxt:slprop) - (ctxt_typing:unit) : T.Tac (g':env { env_extends g' g } & ctxt':term & - unit & continuation_elaborator g ctxt g' ctxt') = let ss = Pulse.Checker.Prover.RewritesTo.get_subst_from_env g in let ctxt' = Pulse.Checker.Prover.Substs.ss_term ctxt ss in let pg = mk_penv g false in let (| g', ctxt'', goals'', solved, k |) = try_elim_core pg [Unknown ctxt'] in // TODO thread through prover - (| g', elab_slprops ctxt'', (), fun post_hint post_hint_typ -> - let h1: unit = (RU.magic() <: unit) in - + (| g', elab_slprops ctxt'', fun post_hint post_hint_typ -> let before, after = k g' in - k_elab_trans (k_elab_equiv ctxt (elab_slprops ([] @ solved @ ctxt'')) (before []) h1 (())) - (k_elab_equiv (elab_slprops ([] @ solved @ ctxt'')) (elab_slprops ctxt'') (after ctxt'') () ()) post_hint post_hint_typ |) + k_elab_trans (k_elab_equiv ctxt (elab_slprops ([] @ solved @ ctxt'')) (before [])) + (k_elab_equiv (elab_slprops ([] @ solved @ ctxt'')) (elab_slprops ctxt'') (after ctxt'')) post_hint post_hint_typ |) let k_unreach (g: env) (x: nvar { freshv g (snd x) }) (post_hint: post_hint_t { g `env_extends` post_hint.g }) : T.Tac (continuation_elaborator g tm_is_unreachable (push_binding g (snd x) (fst x) post_hint.ret_ty) (open_term_nv post_hint.post x)) = - let c = Pulse.Typing.Combinators.comp_for_post_hint g tm_is_unreachable () post_hint (snd x) in + let c = Pulse.Typing.Combinators.comp_for_post_hint g tm_is_unreachable post_hint (snd x) in let st = wtag (Some (ctag_of_comp_st c)) (Tm_Unreachable { c }) in let g' = push_binding g (snd x) (fst x) post_hint.ret_ty in let post_opened = open_term_nv post_hint.post x in let k_elim: continuation_elaborator g (tm_star tm_emp tm_is_unreachable) g' (tm_star post_opened tm_emp) = - continuation_elaborator_with_bind #g tm_emp c st () () x in + continuation_elaborator_with_bind #g tm_emp c st x in - k_elab_equiv tm_is_unreachable post_opened k_elim () () + k_elab_equiv tm_is_unreachable post_opened k_elim #restart-solver #push-options "--z3rlimit_factor 2 --split_queries always" @@ -1420,7 +1397,7 @@ let prove_post_hint (#g:env) (#ctxt:slprop) (r:checker_result_t g ctxt NoHint) ( // TODO: subtyping if not (eq_tm (RU.deep_compress_safe ty) (RU.deep_compress_safe post_hint.ret_ty)) then ( - let (| g3, ctxt3, ctxt3_typing, k3 |) = elim_exists_and_pure #g2 #ctxt' () in + let (| g3, ctxt3, k3 |) = elim_exists_and_pure #g2 #ctxt' in let k3: continuation_elaborator g2 ctxt' g3 ctxt3 = k3 in if ctxt3 `eq_tm` tm_is_unreachable then ( @@ -1466,11 +1443,11 @@ let prove_post_hint (#g:env) (#ctxt:slprop) (r:checker_result_t g ctxt NoHint) ( // for the typing of post_hint_opened, again post_hint is well-typed in g, and g3 `env_extends` g (| x, g3, (u_ty, ty), post_hint_opened, - k_elab_trans k (k_elab_equiv ctxt' post_hint_opened k_post () ()) |) + k_elab_trans k (k_elab_equiv ctxt' post_hint_opened k_post) |) #pop-options let try_frame_pre (allow_ambiguous : bool) (#g:env) - (#ctxt:slprop) (ctxt_typing:unit) + (#ctxt:slprop) (d:(t:st_term & c:comp_st)) (res_ppname:ppname) : T.Tac (checker_result_t g ctxt NoHint) = diff --git a/src/checker/Pulse.Checker.Prover.fsti b/src/checker/Pulse.Checker.Prover.fsti index fa43e8e75..5668f343f 100644 --- a/src/checker/Pulse.Checker.Prover.fsti +++ b/src/checker/Pulse.Checker.Prover.fsti @@ -32,17 +32,15 @@ val prove (rng: range) (g: env) (ctxt goals: slprop) (allow_amb: bool) : continuation_elaborator g ctxt g' (goals `tm_star` ctxt')) val elim_exists_and_pure (#g:env) (#ctxt:slprop) - (ctxt_typing:unit) : T.Tac (g':env { env_extends g' g } & ctxt':term & - unit & continuation_elaborator g ctxt g' ctxt') val prove_post_hint (#g:env) (#ctxt:slprop) (r:checker_result_t g ctxt NoHint) (post_hint:post_hint_opt g) (rng:range) : T.Tac (checker_result_t g ctxt post_hint) val try_frame_pre (allow_ambiguous : bool) (#g:env) - (#ctxt:slprop) (ctxt_typing:unit) + (#ctxt:slprop) (d:(t:st_term & c:comp_st)) (res_ppname:ppname) : T.Tac (checker_result_t g ctxt NoHint) \ No newline at end of file diff --git a/src/checker/Pulse.Checker.Pure.fst b/src/checker/Pulse.Checker.Pure.fst index 7621e2f3d..cd23ea6c3 100644 --- a/src/checker/Pulse.Checker.Pure.fst +++ b/src/checker/Pulse.Checker.Pure.fst @@ -145,7 +145,7 @@ let squash_prop_validity_token f p (t:prop_validity_token f (mk_squash0 p)) : prop_validity_token f p = admit(); t -let rtb_check_prop_validity (g:env) (sync:bool) (f:_{f == elab_env g }) (p:_) (pf:unit) = +let rtb_check_prop_validity (g:env) (sync:bool) (f:_{f == elab_env g }) (p:_) = let _ : squash (typing_token f p (E_Total, tm_prop)) = magic () in @@ -551,11 +551,11 @@ let non_info_squash_tm (u:universe) (t:term) : term = To do so, we simply create that constraint (and prove it's well-typed), and then call the tcresolve typeclass resolution tactic on it to obtain a dictionary and a proof of typing for the dictionary. *) -let try_get_non_informative_witness_aux (g:env) (u:universe) (ty:term) (ty_typing:unit) +let try_get_non_informative_witness_aux (g:env) (u:universe) (ty:term) : T.Tac (option (non_informative_t g u ty) & issues) = let goal = non_informative_class u ty in let r_env = elab_env g in - let constraint_typing = non_informative_class_typing g u ty ty_typing in + let constraint_typing = non_informative_class_typing g u ty () in let goal_typing_tok : squash (typing_token r_env goal (E_Total, R.pack_ln (R.Tv_Type u))) = match constraint_typing with | E tok -> Squash.return_squash tok in @@ -603,12 +603,12 @@ let try_get_non_informative_witness_aux (g:env) (u:universe) (ty:term) (ty_typin let try_get_non_informative_witness g u ty = RU.record_stats "Pulse.try_get_noninformative_witness" <| fun _ -> - let ropt, _ = try_get_non_informative_witness_aux g u ty () in + let ropt, _ = try_get_non_informative_witness_aux g u ty in ropt let get_non_informative_witness g u t : T.Tac (non_informative_t g u t) - = match try_get_non_informative_witness_aux g u t () with + = match try_get_non_informative_witness_aux g u t with | None, issues -> let open Pulse.PP in fail_doc g (Some (RU.range_of_term t)) [ @@ -623,14 +623,14 @@ let try_check_prop_validity (g:env) (p:term) : T.Tac (option (Pulse.Typing.prop_validity g p)) = let _, f = elab_env_with_term_range g p in RU.record_stats "Pulse.try_check_prop_validity" fun _ -> - let t_opt, issues = rtb_check_prop_validity g true f p () in + let t_opt, issues = rtb_check_prop_validity g true f p in t_opt let check_prop_validity (g:env) (p:term) : T.Tac (Pulse.Typing.prop_validity g p) = let _, f = elab_env_with_term_range g p in RU.record_stats "Pulse.check_prop_validity" fun _ -> - let t_opt, issues = rtb_check_prop_validity g true f p () in + let t_opt, issues = rtb_check_prop_validity g true f p in match t_opt with | None -> let open Pulse.PP in diff --git a/src/checker/Pulse.Checker.Return.fst b/src/checker/Pulse.Checker.Return.fst index dbf1cf04f..e86f5b132 100644 --- a/src/checker/Pulse.Checker.Return.fst +++ b/src/checker/Pulse.Checker.Return.fst @@ -141,12 +141,12 @@ let check_core let ret_st = wtag (Some c) (Tm_Return {expected_type=tm_unknown; insert_eq=use_eq; term=t}) in let ret_c = comp_return c use_eq u ty t post x in - let c' = match_comp_res_with_post_hint ret_st ret_c () post_hint in + let c' = match_comp_res_with_post_hint ret_st ret_c post_hint in Pulse.Checker.Util.debug g "pulse.return" (fun _ -> Printf.sprintf "Return comp is: %s" (Pulse.Syntax.Printer.comp_to_string c')); prove_post_hint #g - (try_frame_pre false #g () (|ret_st,c'|) res_ppname) + (try_frame_pre false #g (|ret_st,c'|) res_ppname) post_hint st.range #pop-options @@ -170,7 +170,7 @@ let check Pulse.Checker.Util.debug g "pulse.hoist" (fun _ -> Printf.sprintf "Hoisted term: %s" (Pulse.Syntax.Printer.st_term_to_string tt) ); - check g ctxt () post_hint res_ppname tt + check g ctxt post_hint res_ppname tt | None -> ( match post_hint with | PostHint p -> ( diff --git a/src/checker/Pulse.Checker.Rewrite.fst b/src/checker/Pulse.Checker.Rewrite.fst index 0c6db6805..d703ab91c 100644 --- a/src/checker/Pulse.Checker.Rewrite.fst +++ b/src/checker/Pulse.Checker.Rewrite.fst @@ -139,5 +139,5 @@ let check let rew_st = wtag (Some STT_Ghost) (Tm_Rewrite { t1=p; t2=q; tac_opt=None; elaborated=true }) in let rew_c = C_STGhost tm_emp_inames { u=u0; res=tm_unit; pre=p; post=q } in - let c = match_comp_res_with_post_hint rew_st rew_c () post_hint in - prove_post_hint (try_frame_pre false () (| rew_st,c |) res_ppname) post_hint t.range + let c = match_comp_res_with_post_hint rew_st rew_c post_hint in + prove_post_hint (try_frame_pre false (| rew_st,c |) res_ppname) post_hint t.range diff --git a/src/checker/Pulse.Checker.SLPropEquiv.fst b/src/checker/Pulse.Checker.SLPropEquiv.fst index 921671a9a..4c2f53276 100644 --- a/src/checker/Pulse.Checker.SLPropEquiv.fst +++ b/src/checker/Pulse.Checker.SLPropEquiv.fst @@ -54,8 +54,6 @@ let list_as_slprop_assoc g (vp0 vp1 vp2:list term) () let list_as_slprop_ctx g (vp0 vp0' vp1 vp1':list term) - (d0:unit) - (d1:unit) : GTot (unit) = let split_app = list_as_slprop_append g vp0 vp1 in @@ -64,9 +62,8 @@ let list_as_slprop_ctx g (vp0 vp0' vp1 vp1':list term) let list_as_slprop_singleton g (p q:term) - (d:unit) : GTot (unit) - = d + = () let rec slprop_list_equiv (g:env) (vp:term) @@ -87,7 +84,7 @@ let rec slprop_list_equiv (g:env) let slprop_equiv_swap_equiv (g:env) (l0 l2:list term) - (p q:term) (d_p_q:unit) + (p q:term) : unit = let d : unit = () in @@ -95,7 +92,7 @@ let slprop_equiv_swap_equiv (g:env) = List.Tot.append_assoc [q] l0 l2; () in - let d_q_p = d_p_q in + let d_q_p = () in let d' : unit = d_q_p in let d' : unit = () in @@ -103,11 +100,9 @@ let slprop_equiv_swap_equiv (g:env) let slprop_equiv_split_frame (g:env) (ctxt req:term) (frame:list term) - (veq:unit) : unit = let ctxt_l = slprop_as_list ctxt in let req_l = slprop_as_list req in - let veq : unit = veq in diff --git a/src/checker/Pulse.Checker.SLPropEquiv.fsti b/src/checker/Pulse.Checker.SLPropEquiv.fsti index 1c7f3cd02..20531bf35 100644 --- a/src/checker/Pulse.Checker.SLPropEquiv.fsti +++ b/src/checker/Pulse.Checker.SLPropEquiv.fsti @@ -39,34 +39,31 @@ val list_as_slprop_assoc (g:env) (vp0 vp1 vp2:list term) : GTot (unit) val list_as_slprop_ctx (g:env) (vp0 vp0' vp1 vp1':list term) - (_:unit) - (_:unit) : GTot (unit) -val list_as_slprop_singleton (g:env) (p q:term) (d:unit) +val list_as_slprop_singleton (g:env) (p q:term) : GTot (unit) val slprop_list_equiv (g:env) (vp:term) : GTot (unit) val slprop_equiv_swap_equiv (g:env) (l0 l2:list term) - (p q:term) (d_p_q:unit) + (p q:term) : GTot (unit) val slprop_equiv_split_frame (g:env) (ctxt req:term) (frame:list term) - (d:unit) : unit let slprop_equiv_typing_fwd (#g:env) (#ctxt:term) (ctxt_typing:unit) - (p:term) (d:unit) + (p:term) : unit - = let fwd, _ = slprop_equiv_typing g ctxt p d in + = let fwd, _ = slprop_equiv_typing g ctxt p in fwd ctxt_typing let slprop_equiv_typing_bk (#g:env) (#ctxt:term) (ctxt_typing:unit) - (p:term) (d:unit) + (p:term) : unit - = let _, bk = slprop_equiv_typing g p ctxt d in + = let _, bk = slprop_equiv_typing g p ctxt in bk ctxt_typing diff --git a/src/checker/Pulse.Checker.ST.fst b/src/checker/Pulse.Checker.ST.fst index 0df19fac6..41e30c0cb 100644 --- a/src/checker/Pulse.Checker.ST.fst +++ b/src/checker/Pulse.Checker.ST.fst @@ -79,38 +79,30 @@ let check let eff = core_check_term_at_type g' e ty in let t = { t with term = Tm_ST { t=e; args=[] }; effect_tag = T.seal (Some (ctag_of_comp_st c)) } in - let d : unit = - if eff = T.E_Total - then () - else ( - match c with - | C_ST _ | C_STAtomic .. -> - let open Pulse.PP in - fail_doc g (Some range) - [text "Application of a stateful or atomic computation cannot have a ghost effect"; - pp t; - text "has computation type"; - pp c] - | C_STGhost .. -> - let d_non_info : unit = - let token = is_non_informative g' c in - match token with - | None -> - fail g' (Some range) - (Printf.sprintf "Unexpected informative result for %s" (P.comp_to_string c)) - | Some token -> - () - in - () - ) - in + if not (eff = T.E_Total) then ( + match c with + | C_ST _ | C_STAtomic .. -> + let open Pulse.PP in + fail_doc g (Some range) + [text "Application of a stateful or atomic computation cannot have a ghost effect"; + pp t; + text "has computation type"; + pp c] + | C_STGhost .. -> + let token = is_non_informative g' c in + (match token with + | None -> + fail g' (Some range) + (Printf.sprintf "Unexpected informative result for %s" (P.comp_to_string c)) + | Some _ -> ()) + ); // TODO: thread through prover if comp_post c `eq_tm` tm_is_unreachable then let framed = checker_result_for_st_typing (k _ (| t, add_frame c ctxt' |)) res_ppname in RU.record_stats "prove_post_hint" fun _ -> prove_post_hint framed post_hint range else // TODO: not sure why we need the type equality check below.. - let c = match_comp_res_with_post_hint t c d post_hint in + let c = match_comp_res_with_post_hint t c post_hint in let framed = checker_result_for_st_typing (k _ (| t, add_frame c ctxt' |)) res_ppname in RU.record_stats "prove_post_hint" fun _ -> prove_post_hint framed post_hint range ) diff --git a/src/checker/Pulse.Checker.While.fst b/src/checker/Pulse.Checker.While.fst index 920ded6cb..a39c36e87 100644 --- a/src/checker/Pulse.Checker.While.fst +++ b/src/checker/Pulse.Checker.While.fst @@ -30,20 +30,20 @@ module RU = Pulse.RuntimeUtils let empty_env g = mk_env (fstar_env g) let push_empty_env_idem (g:env) : Lemma (push_env g (empty_env g) == g)[SMTPat (push_env g (empty_env g))] = admit() -let body_typing_subst_true #g #x #post (_:unit) +let body_typing_subst_true #g #x #post : unit = admit() -let body_typing_ex #g #x #post (_:unit) +let body_typing_ex #g #x #post : unit = admit() let unit_typing g : unit = admit() -let inv_typing_weakening (g:env) (inv:slprop) (inv_typing:unit) +let inv_typing_weakening (g:env) (inv:slprop) : (x:FStar.Ghost.erased var {fresh_wrt x g (freevars inv)}) = let x : (x:FStar.Ghost.erased var {fresh_wrt x g (freevars inv)}) = RU.magic () in x -let inv_as_post_hint (g:env) (inv:slprop) (inv_typing:unit) +let inv_as_post_hint (g:env) (inv:slprop) : T.Tac (ph:post_hint_for_env g { ph.post == inv /\ ph.ret_ty == tm_unit /\ ph.u == u0 /\ ph.effect_annot == EffectAnnotSTT }) -= let x = inv_typing_weakening g inv inv_typing in += let x = inv_typing_weakening g inv in { g; effect_annot=EffectAnnotSTT; ret_ty=tm_unit; u=u0; post=inv } @@ -214,7 +214,7 @@ let check_while let inv = tm_star (RU.deep_compress_safe inv) remaining in let res_cond : checker_result_t g1 inv (TypeHint tm_bool) = - check (push_context "check_while_condition" cond.range g1) inv () (TypeHint tm_bool) ppname_default cond in + check (push_context "check_while_condition" cond.range g1) inv (TypeHint tm_bool) ppname_default cond in let (| post_cond, r_cond |) : (ph:post_hint_for_env g1 & Pulse.Typing.Combinators.st_typing_in_ctxt g1 inv (PostHint ph)) = let res_cond = retype_checker_result NoHint res_cond in let ph = Pulse.JoinComp.infer_post res_cond in @@ -278,7 +278,7 @@ let check_while let body_pre_open = post_cond.post in - let body_ph : post_hint_for_env g2 = inv_as_post_hint g2 (comp_post (comp_while_body u_meas ty_meas is_tot dec_formula x_meas inv body_pre_open)) () in + let body_ph : post_hint_for_env g2 = inv_as_post_hint g2 (comp_post (comp_while_body u_meas ty_meas is_tot dec_formula x_meas inv body_pre_open)) in assert body_ph.ret_ty == tm_unit; let x = fresh g2 in @@ -286,7 +286,7 @@ let check_while let r_body = check (push_context "check_while_body" body.range g2) - (open_term' body_pre_open tm_true 0) body_pre_typing (PostHint body_ph) ppname_default body + (open_term' body_pre_open tm_true 0) (PostHint body_ph) ppname_default body in let (| cond, comp_cond |) = r_cond in let (| body, comp_body |) = apply_checker_result_k r_body ppname_default in diff --git a/src/checker/Pulse.Checker.WithLocal.fst b/src/checker/Pulse.Checker.WithLocal.fst index ac343a9a1..2b3bf3cfe 100644 --- a/src/checker/Pulse.Checker.WithLocal.fst +++ b/src/checker/Pulse.Checker.WithLocal.fst @@ -39,10 +39,10 @@ let extend_post_hint_for_local (g:env) (p:post_hint_for_env g) = let conjunct = withlocal_post init_t (term_of_nvar (n, x)) in let g' = extend_env g x n init_t in let c_typing = Pulse.Checker.Pure.core_check_term (push_binding g x n (mk_ref init_t)) conjunct T.E_Total tm_slprop in - let res = Pulse.Checker.Base.extend_post_hint g p x (mk_ref init_t) conjunct c_typing in + let res = Pulse.Checker.Base.extend_post_hint g p x (mk_ref init_t) conjunct in res -let with_local_pre_typing (#g:env) (#pre:term) (_pre_typing:unit) +let with_local_pre_typing (#g:env) (#pre:term) (init_t:term) (x:var { ~ (Set.mem x (dom g)) }) n (i:option term) : unit = admit() @@ -136,17 +136,15 @@ let check assume not (x `Set.mem` freevars post.post); let open Pulse.Typing.Combinators in let body_post : post_hint_for_env g_extended = extend_post_hint_for_local g post init_t x binder.binder_ppname in - let r = check g_extended body_pre body_pre_typing (PostHint body_post) binder.binder_ppname (open_st_term_nv body px) in + let r = check g_extended body_pre (PostHint body_post) binder.binder_ppname (open_st_term_nv body px) in let r: checker_result_t g_extended body_pre (PostHint body_post) = r in let (| opened_body, c_body |) = apply_checker_result_k #g_extended #body_pre #body_post r binder.binder_ppname in let body = close_st_term opened_body x in assume (open_st_term (close_st_term opened_body x) x == opened_body); let c = C_ST {u=comp_u c_body;res=comp_res c_body;pre;post=post.post} in let c_typing = - intro_comp_typing g c () - () - () - x () + intro_comp_typing g c + x in assert (freshv g x); assert (~(Set.mem x (freevars_st body))); diff --git a/src/checker/Pulse.Checker.WithLocalArray.fst b/src/checker/Pulse.Checker.WithLocalArray.fst index 3e13ec1ef..78d3230a9 100644 --- a/src/checker/Pulse.Checker.WithLocalArray.fst +++ b/src/checker/Pulse.Checker.WithLocalArray.fst @@ -49,17 +49,15 @@ let extend_post_hint | None -> mk_array_pts_to_uninit_post init_t arr) in let g' = push_binding g x n (mk_array init_t) in let c_typing = Pulse.Checker.Pure.core_check_term g' conjunct T.E_Total tm_slprop in - let res = Pulse.Checker.Base.extend_post_hint g p x (mk_array init_t) conjunct c_typing in + let res = Pulse.Checker.Base.extend_post_hint g p x (mk_array init_t) conjunct in res let with_local_array_pre_typing (#g:env) (#pre:term) - (_pre_typing:unit) (init_t:term) (init:option term) (len:term) (init_typing:(match init with Some init -> unit | _ -> unit)) - (len_typing:unit) (x:var { ~ (Set.mem x (dom g)) }) (n: ppname) : unit @@ -162,16 +160,14 @@ let check let body_post = extend_post_hint g post init_t init x binder.binder_ppname in let (| opened_body, c_body |) = let r = - check g_extended body_pre body_pre_typing (PostHint body_post) binder.binder_ppname (open_st_term_nv body px) in + check g_extended body_pre (PostHint body_post) binder.binder_ppname (open_st_term_nv body px) in apply_checker_result_k r binder.binder_ppname in let body = close_st_term opened_body x in assume (open_st_term (close_st_term opened_body x) x == opened_body); let c = C_ST {u=comp_u c_body;res=comp_res c_body;pre;post=post.post} in let c_typing = - intro_comp_typing g c () - () - () - x () + intro_comp_typing g c + x in let st = wrst c (Tm_WithLocalArray { binder = mk_binder_ppname (mk_array init_t) binder.binder_ppname; initializer=init; length=len; body }) in checker_result_for_st_typing (| st, c |) res_ppname diff --git a/src/checker/Pulse.Checker.fst b/src/checker/Pulse.Checker.fst index aaca16d56..ae0f5843c 100644 --- a/src/checker/Pulse.Checker.fst +++ b/src/checker/Pulse.Checker.fst @@ -261,7 +261,6 @@ let rec do_not_elim_state (t:st_term) : Dv bool = let rec check (g0:env) (pre0:term) - (pre0_typing: unit) (post_hint:post_hint_opt g0) (res_ppname:ppname) (t:st_term) @@ -287,17 +286,16 @@ let rec check match maybe_elaborate_stateful_head g0 t with | Some t -> - check g0 pre0 () post_hint res_ppname t + check g0 pre0 post_hint res_ppname t | None -> - let (| g, pre, _, k_elim_pure |) : + let (| g, pre, k_elim_pure |) : (g':env { env_extends g' g0 } & ctxt':term & - unit & continuation_elaborator g0 pre0 g' ctxt') = if do_not_elim_state t then - (| g0, pre0, (), k_elab_unit _ _ |) + (| g0, pre0, k_elab_unit _ _ |) else - Pulse.Checker.Prover.elim_exists_and_pure () + Pulse.Checker.Prover.elim_exists_and_pure #g0 #pre0 in let r : checker_result_t g pre post_hint = let g = push_context (P.tag_of_st_term t) t.range g in @@ -328,7 +326,7 @@ let rec check match instantiate_unknown_witnesses g t with | Some t -> - check g pre () post_hint res_ppname t + check g pre post_hint res_ppname t | None -> match witnesses with | [] -> fail g (Some t.range) "intro exists with empty witnesses" @@ -336,7 +334,7 @@ let rec check Exists.check_intro_exists g pre post_hint res_ppname t None | _ -> let t = transform_to_unary_intro_exists g p witnesses in - check g pre () post_hint res_ppname t + check g pre post_hint res_ppname t ) | Tm_Bind _ -> @@ -448,7 +446,7 @@ let rec check | Tm_PragmaWithOptions { options; body } -> RU.push_options(); RU.set_options options; - let r = check g pre () post_hint res_ppname body in + let r = check g pre post_hint res_ppname body in RU.pop_options (); r diff --git a/src/checker/Pulse.Elaborate.Core.fst b/src/checker/Pulse.Elaborate.Core.fst index 243a06185..53c6c61d7 100644 --- a/src/checker/Pulse.Elaborate.Core.fst +++ b/src/checker/Pulse.Elaborate.Core.fst @@ -57,12 +57,11 @@ let elab_sub (c1 c2:comp_st) (e:R.term) = let elab_bind (g:env) (x:var) (c1:comp) (c2:comp) (c:comp) - (bc:unit) (e1 e2:R.term) : GTot R.term = RU.magic () -let elab_lift (g:env) (c1:comp) (c2:comp) (d:unit) (e:R.term) +let elab_lift (g:env) (c1:comp) (c2:comp) (e:R.term) : GTot R.term = RU.magic () @@ -87,7 +86,6 @@ let simple_arr (t1 t2 : R.term) : R.term = R.pack_ln (R.Tv_Arrow b (R.pack_comp (R.C_Total t2))) let elab_st_sub (g:env) (c1:comp) (c2:comp) - (d_sub : unit) : Tot (t:R.term & RT.tot_typing (elab_env g) t (simple_arr (elab_comp c1) (elab_comp c2))) = RU.magic_s "elab_st_sub" @@ -95,8 +93,7 @@ let elab_st_sub (g:env) (c1:comp) (c2:comp) let rec elab_st_typing (g:env) (t:st_term) (c:comp) - (d:unit) - : GTot R.term (decreases d) + : GTot R.term = RU.magic () and elab_br (g:env) @@ -104,14 +101,11 @@ and elab_br (g:env) (sc_u:universe) (sc_ty:typ) (sc:term) (p:pattern) (e:st_term) - (d : unit) - : GTot R.branch (decreases d) + : GTot R.branch = RU.magic () and elab_branches (g:env) (c:comp_st) (sc_u:universe) (sc_ty:typ) (sc:term) (brs:list branch) - (d : unit) : GTot (list R.branch) - (decreases d) = RU.magic () diff --git a/src/checker/Pulse.JoinComp.fst b/src/checker/Pulse.JoinComp.fst index c9f66f756..5ec75045a 100644 --- a/src/checker/Pulse.JoinComp.fst +++ b/src/checker/Pulse.JoinComp.fst @@ -108,7 +108,7 @@ let infer_post' (g:env) (g':env { g' `env_extends` g }) (post:term) (post_typing: unit) = // simplify post by applying elimination rules (particularly `frame ** is_unreachable ~~> is_unreachable`) - let (| g1, post, _, _ |) = Pulse.Checker.Prover.elim_exists_and_pure #g' #post post_typing in + let (| g1, post, _ |) = Pulse.Checker.Prover.elim_exists_and_pure #g' #post in let bs0 = bindings g in let dom_g = var_dom g in let fvs_t = freevars t in @@ -388,11 +388,9 @@ let rec join_comps (g_then:env) (e_then:st_term) (c_then:comp_st) - (e_then_typing:unit) (g_else:env) (e_else:st_term) (c_else:comp_st) - (e_else_typing:unit) (post:post_hint_t) : T.TacH (c:comp_st & unit & @@ -422,10 +420,10 @@ let rec join_comps | C_STGhost _ _, C_STAtomic _ _ _ -> st_ghost_as_atomic_matches_post_hint c_then post; - join_comps g_then e_then (st_ghost_as_atomic c_then) () g_else e_else c_else () post + join_comps g_then e_then (st_ghost_as_atomic c_then) g_else e_else c_else post | C_STAtomic _ _ _, C_STGhost _ _ -> st_ghost_as_atomic_matches_post_hint c_else post; - join_comps g_then e_then c_then () g_else e_else (st_ghost_as_atomic c_else) () post + join_comps g_then e_then c_then g_else e_else (st_ghost_as_atomic c_else) post #pop-options diff --git a/src/checker/Pulse.JoinComp.fsti b/src/checker/Pulse.JoinComp.fsti index d37d5e4a3..0388658b8 100644 --- a/src/checker/Pulse.JoinComp.fsti +++ b/src/checker/Pulse.JoinComp.fsti @@ -40,11 +40,9 @@ val join_comps (g_then:env) (e_then:st_term) (c_then:comp_st) - (e_then_typing:unit) (g_else:env) (e_else:st_term) (c_else:comp_st) - (e_else_typing:unit) (post:post_hint_t) : T.TacH (c:comp_st & unit & diff --git a/src/checker/Pulse.Typing.Combinators.fst b/src/checker/Pulse.Typing.Combinators.fst index aa1f86bde..561d9b17a 100644 --- a/src/checker/Pulse.Typing.Combinators.fst +++ b/src/checker/Pulse.Typing.Combinators.fst @@ -30,7 +30,6 @@ open Pulse.Checker.Pure assume val invert_forall_typing (g:env) (u:universe) (b:binder) (body:term) - (d:unit) (x:var { freshv g x /\ ~ (x `Set.mem` freevars body) }) : GTot ( unit & @@ -41,19 +40,17 @@ assume val construct_forall_typing (g:env) (u:universe) (b:binder) (body:term) (x:var { freshv g x /\ ~ (x `Set.mem` freevars body) }) - (dt:unit) - (db:unit) - : GTot (unit) + : GTot (unit) -let st_equiv_trans (g:env) (c0 c1 c2:comp) (d01:unit) (d12:unit) +let st_equiv_trans (g:env) (c0 c1 c2:comp) : unit = () -let t_equiv (g:env) (st:st_term) (c:comp) (d:unit) (c':comp) (eq:unit) +let t_equiv (g:env) (st:st_term) (c:comp) (c':comp) : unit = () -let slprop_equiv_typing (g:env) (t0 t1:term) (v:unit) +let slprop_equiv_typing (g:env) (t0 t1:term) : GTot ((unit -> unit) & (unit -> unit)) = (fun _ -> ()), (fun _ -> ()) @@ -66,11 +63,6 @@ let bind_t (case_c1 case_c2:comp_st -> bool) = (c1:comp_st{ case_c1 c1 }) -> (c2:comp_st{ case_c2 c2 }) -> (px:nvar { ~ (Set.mem (snd px) (dom g)) }) -> - (d_e1:unit) -> - (d_c1res:unit) -> - (d_e2:unit) -> - (res_typing:unit) -> - (post_typing:unit) -> (post_hint:post_hint_opt g { comp_post_matches_hint c2 post_hint }) -> T.TacH (t:st_term & c:comp_st { st_comp_of_comp c == st_comp_with_pre (st_comp_of_comp c2) pre /\ @@ -86,7 +78,7 @@ let bind_t (case_c1 case_c2:comp_st -> bool) = #push-options "--fuel 0 --ifuel 0" let mk_bind_st_st : bind_t C_ST? C_ST? - = fun g pre e1 e2 c1 c2 px d_e1 d_c1res d_e2 res_typing post_typing _ -> + = fun g pre e1 e2 c1 c2 px _ -> let _, x = px in let b = nvar_as_binder px (comp_res c1) in let c : comp_st = C_ST (st_comp_with_pre (st_comp_of_comp c2) pre) in @@ -105,11 +97,11 @@ let with_inames (c:comp_st) (i:term) = | C_STGhost _ sc -> C_STGhost i sc | C_STAtomic _ obs sc -> C_STAtomic i obs sc -let weaken_comp_inames (g:env) (e:st_term) (c:comp_st) (d_e:unit) (new_inames:term) +let weaken_comp_inames (g:env) (e:st_term) (c:comp_st) (new_inames:term) : T.Tac (c':comp_st { with_inames c new_inames == c' } & unit) = match c with - | C_ST _ -> (| c, d_e |) + | C_ST _ -> (| c, () |) | C_STGhost inames sc -> let _ = check_prop_validity g (tm_inames_subset inames new_inames) in (| with_inames c new_inames, () |) @@ -118,16 +110,16 @@ let weaken_comp_inames (g:env) (e:st_term) (c:comp_st) (d_e:unit) (new_inames:te let _ = check_prop_validity g (tm_inames_subset inames new_inames) in (| with_inames c new_inames, () |) -let try_lift_ghost_atomic (g:env) (e:st_term) (c:comp_st { C_STGhost? c }) (d:unit) +let try_lift_ghost_atomic (g:env) (e:st_term) (c:comp_st { C_STGhost? c }) : T.Tac (option (unit)) = let w = try_get_non_informative_witness g (comp_u c) (comp_res c) in match w with | None -> None | Some w -> Some () -let lift_ghost_atomic (g:env) (e:st_term) (c:comp_st { C_STGhost? c }) (d:unit) +let lift_ghost_atomic (g:env) (e:st_term) (c:comp_st { C_STGhost? c }) : T.Tac (unit) -= let w = try_lift_ghost_atomic g e c d in += let w = try_lift_ghost_atomic g e c in match w with | None -> let open Pulse.PP in @@ -143,7 +135,7 @@ let lift_ghost_atomic (g:env) (e:st_term) (c:comp_st { C_STGhost? c }) (d:unit) #push-options "--z3rlimit_factor 2 --ifuel 0 --fuel 0 --split_queries no" #restart-solver let mk_bind_ghost_ghost : bind_t C_STGhost? C_STGhost? = - fun g pre e1 e2 c1 c2 px d_e1 d_c1res d_e2 res_typing post_typing post_hint -> + fun g pre e1 e2 c1 c2 px post_hint -> let _, x = px in let b = nvar_as_binder px (comp_res c1) in let C_STGhost inames1 sc1 = c1 in @@ -172,7 +164,7 @@ let mk_bind_ghost_ghost : bind_t C_STGhost? C_STGhost? = let mk_bind_atomic_atomic : bind_t C_STAtomic? C_STAtomic? - = fun g pre e1 e2 c1 c2 px d_e1 d_c1res d_e2 res_typing post_typing post_hint -> + = fun g pre e1 e2 c1 c2 px post_hint -> let _, x = px in let b = nvar_as_binder px (comp_res c1) in let C_STAtomic inames1 obs1 sc1 = c1 in @@ -215,11 +207,6 @@ let rec mk_bind (g:env) (c1:comp_st) (c2:comp_st) (px:nvar { ~ (Set.mem (snd px) (dom g)) }) - (d_e1:unit) - (d_c1res:unit) - (d_e2:unit) - (res_typing:unit) - (post_typing:unit) (post_hint:post_hint_opt g { comp_post_matches_hint c2 post_hint }) : T.TacH (t:st_term & c:comp_st { @@ -245,45 +232,45 @@ let rec mk_bind (g:env) in match c1, c2 with | C_ST _, C_ST _ -> - mk_bind_st_st g pre e1 e2 c1 c2 px d_e1 d_c1res d_e2 res_typing post_typing post_hint + mk_bind_st_st g pre e1 e2 c1 c2 px post_hint | C_STGhost _ _, C_STGhost _ _ -> - mk_bind_ghost_ghost g pre e1 e2 c1 c2 px d_e1 d_c1res d_e2 res_typing post_typing post_hint + mk_bind_ghost_ghost g pre e1 e2 c1 c2 px post_hint | C_STAtomic inames1 obs1 sc1, C_STAtomic inames2 obs2 sc2 -> if at_most_one_observable obs1 obs2 then ( - mk_bind_atomic_atomic g pre e1 e2 c1 c2 px d_e1 d_c1res d_e2 res_typing post_typing post_hint + mk_bind_atomic_atomic g pre e1 e2 c1 c2 px post_hint ) else if (PostHint? post_hint) then fail_bias "atomic" else ( - mk_bind g pre e1 e2 (C_ST (st_comp_of_comp c1)) c2 px () d_c1res d_e2 res_typing post_typing post_hint + mk_bind g pre e1 e2 (C_ST (st_comp_of_comp c1)) c2 px post_hint ) | C_STAtomic inames _ _, C_ST _ -> - mk_bind g pre e1 e2 (C_ST (st_comp_of_comp c1)) c2 px () d_c1res d_e2 res_typing post_typing post_hint + mk_bind g pre e1 e2 (C_ST (st_comp_of_comp c1)) c2 px post_hint | C_ST _, C_STAtomic inames _ _ -> if (PostHint? post_hint) then fail_bias "atomic" else ( let c2_lifted = C_ST (st_comp_of_comp c2) in - let (| t, c |) = mk_bind g pre e1 e2 c1 c2_lifted px () d_c1res () res_typing post_typing post_hint in + let (| t, c |) = mk_bind g pre e1 e2 c1 c2_lifted px post_hint in (| t, c |) ) | C_STGhost _ _, C_STAtomic _ Neutral _ -> ( - match try_lift_ghost_atomic g e1 c1 d_e1 with + match try_lift_ghost_atomic g e1 c1 with | Some _ -> - mk_bind g pre e1 e2 (st_ghost_as_atomic c1) c2 px () d_c1res d_e2 res_typing post_typing post_hint + mk_bind g pre e1 e2 (st_ghost_as_atomic c1) c2 px post_hint | None -> match post_hint with | TypeHint _ | NoHint | PostHint { effect_annot = EffectAnnotAtomicOrGhost _ } -> let c2_lifted = C_STGhost (comp_inames c2) (st_comp_of_comp c2) in - let (| t, c |) = mk_bind g pre e1 e2 c1 c2_lifted px () d_c1res () res_typing post_typing post_hint in + let (| t, c |) = mk_bind g pre e1 e2 c1 c2_lifted px post_hint in (| t, c |) | _ -> fail_bias "atomic" ) @@ -294,32 +281,32 @@ let rec mk_bind (g:env) | NoHint | PostHint { effect_annot = EffectAnnotGhost _ } -> let c1_lifted = C_STGhost (comp_inames c1) (st_comp_of_comp c1) in - mk_bind g pre e1 e2 c1_lifted c2 px () d_c1res d_e2 res_typing post_typing post_hint + mk_bind g pre e1 e2 c1_lifted c2 px post_hint | _ -> - match try_lift_ghost_atomic (push_binding g (snd px) (fst px) (comp_res c1)) (open_st_term_nv e2 px) c2 d_e2 with + match try_lift_ghost_atomic (push_binding g (snd px) (fst px) (comp_res c1)) (open_st_term_nv e2 px) c2 with | Some _ -> let c2_lifted = st_ghost_as_atomic c2 in - let (| t, c |) = mk_bind g pre e1 e2 c1 c2_lifted px () d_c1res () res_typing post_typing post_hint in + let (| t, c |) = mk_bind g pre e1 e2 c1 c2_lifted px post_hint in (| t, c |) | None -> let c1_lifted = C_STGhost (comp_inames c1) (st_comp_of_comp c1) in - mk_bind g pre e1 e2 c1_lifted c2 px () d_c1res d_e2 res_typing post_typing post_hint + mk_bind g pre e1 e2 c1_lifted c2 px post_hint ) | C_STGhost _ _, C_ST _ | C_STGhost _ _, C_STAtomic _ _ _ -> - let _ = lift_ghost_atomic g e1 c1 d_e1 in - mk_bind g pre e1 e2 (st_ghost_as_atomic c1) c2 px () d_c1res d_e2 res_typing post_typing post_hint + let _ = lift_ghost_atomic g e1 c1 in + mk_bind g pre e1 e2 (st_ghost_as_atomic c1) c2 px post_hint | C_ST _, C_STGhost _ _ | C_STAtomic _ _ _, C_STGhost _ _ -> if (PostHint? post_hint) then fail_bias "ghost" else ( - let _ = lift_ghost_atomic (push_binding g (snd px) (fst px) (comp_res c1)) (open_st_term_nv e2 px) c2 d_e2 in + let _ = lift_ghost_atomic (push_binding g (snd px) (fst px) (comp_res c1)) (open_st_term_nv e2 px) c2 in let c2_lifted = st_ghost_as_atomic c2 in - let (| t, c |) = mk_bind g pre e1 e2 c1 c2_lifted px () d_c1res () res_typing post_typing post_hint in + let (| t, c |) = mk_bind g pre e1 e2 c1 c2_lifted px post_hint in (| t, c |) ) | _ -> T.fail "Impossible: unexpected combination of effects" @@ -347,9 +334,8 @@ let bind_res_and_post_typing g c2 x post_hint CU.debug g "pulse.main" (fun _ -> "bind_res_and_post_typing (with post_hint)\n"); () -let add_frame (g:env) (t:st_term) (c:comp_st) (t_typing:unit) +let add_frame (g:env) (t:st_term) (c:comp_st) (frame:slprop) - (frame_typing:unit) : t':st_term & c':comp_st { c' == add_frame c frame } = @@ -359,9 +345,7 @@ let add_frame (g:env) (t:st_term) (c:comp_st) (t_typing:unit) let apply_frame (g:env) (t:st_term) (ctxt:term) - (ctxt_typing: unit) (c:comp { stateful_comp c }) - (t_typing: unit) (frame_t:frame_for_req_in_ctxt g ctxt (comp_pre c)) : Dv (c':comp_st { comp_pre c' == ctxt /\ comp_res c' == comp_res c /\ @@ -378,7 +362,7 @@ let apply_frame (g:env) #pop-options #push-options "--z3rlimit_factor 2" -let comp_for_post_hint (g:env) (pre:slprop) (pre_typing:unit) +let comp_for_post_hint (g:env) (pre:slprop) (post:post_hint_t { g `env_extends` post.g }) (x:var { freshv g x }) : T.Tac (c:comp_st { comp_pre c == pre /\ comp_post_matches_hint c (PostHint post) }) = diff --git a/src/checker/Pulse.Typing.Combinators.fsti b/src/checker/Pulse.Typing.Combinators.fsti index 53e6b71d0..72baec351 100644 --- a/src/checker/Pulse.Typing.Combinators.fsti +++ b/src/checker/Pulse.Typing.Combinators.fsti @@ -26,17 +26,17 @@ let st_comp_with_pre (st:st_comp) (pre:term) : st_comp = { st with pre } let nvar_as_binder (x:nvar) (t:term) : binder = mk_binder_ppname t (fst x) -val t_equiv (g:env) (st:st_term) (c:comp) (d:unit) (c':comp) (eq:unit) +val t_equiv (g:env) (st:st_term) (c:comp) (c':comp) : unit -val slprop_equiv_typing (g:env) (t0 t1:term) (v:unit) +val slprop_equiv_typing (g:env) (t0 t1:term) : GTot ((unit -> unit) & (unit -> unit)) let st_ghost_as_atomic (c:comp_st { C_STGhost? c }) = C_STAtomic (comp_inames c) Neutral (st_comp_of_comp c) -val lift_ghost_atomic (g:env) (e:st_term) (c:comp_st { C_STGhost? c }) (d:unit) +val lift_ghost_atomic (g:env) (e:st_term) (c:comp_st { C_STGhost? c }) : T.Tac (unit) val mk_bind (g:env) @@ -46,11 +46,6 @@ val mk_bind (g:env) (c1:comp_st) (c2:comp_st) (px:nvar { ~ (Set.mem (snd px) (dom g)) }) - (d_e1:unit) - (d_c1res:unit) - (d_e2:unit) - (res_typing:unit) - (post_typing:unit) (post_hint:post_hint_opt g { comp_post_matches_hint c2 post_hint }) : T.TacH (t:st_term & c:comp_st { st_comp_of_comp c == st_comp_with_pre (st_comp_of_comp c2) pre /\ @@ -69,9 +64,8 @@ val bind_res_and_post_typing (g:env) (s2:comp_st) (x:var { fresh_wrt x g (freeva (post_hint:post_hint_opt g { comp_post_matches_hint s2 post_hint }) : T.Tac unit -val add_frame (g:env) (t:st_term) (c:comp_st) (t_typing:unit) +val add_frame (g:env) (t:st_term) (c:comp_st) (frame:slprop) - (frame_typing:unit) : t':st_term & c':comp_st { c' == add_frame c frame } @@ -83,9 +77,7 @@ let frame_of #g #ctxt #req (f:frame_for_req_in_ctxt g ctxt req) = f val apply_frame (g:env) (t:st_term) (ctxt:term) - (ctxt_typing: unit) (c:comp { stateful_comp c }) - (t_typing: unit) (frame_t:frame_for_req_in_ctxt g ctxt (comp_pre c)) : Dv (c':comp_st { comp_pre c' == ctxt /\ comp_res c' == comp_res c /\ @@ -96,7 +88,7 @@ type st_typing_in_ctxt (g:env) (ctxt:slprop) (post_hint:post_hint_opt g) = t:st_term & c:comp_st { comp_pre c == ctxt /\ comp_post_matches_hint c post_hint } -val comp_for_post_hint (g:env) (pre:slprop) (pre_typing:unit) +val comp_for_post_hint (g:env) (pre:slprop) (post:post_hint_t { g `env_extends` post.g }) (x:var { freshv g x }) : T.Tac (c:comp_st { comp_pre c == pre /\ comp_post_matches_hint c (PostHint post) }) \ No newline at end of file diff --git a/src/checker/Pulse.Typing.FV.fst b/src/checker/Pulse.Typing.FV.fst index b736b2246..2bf0b1169 100644 --- a/src/checker/Pulse.Typing.FV.fst +++ b/src/checker/Pulse.Typing.FV.fst @@ -282,7 +282,6 @@ val freevars_open_comp (c:comp) (x:term) (i:index) #push-options "--fuel 2 --ifuel 2" let tot_or_ghost_typing_freevars (g:env) (t:term) (ty:term) (eff:FStar.Tactics.V2.tot_or_ghost) - (d:unit) : Lemma (ensures freevars t `Set.subset` vars_of_env g /\ freevars ty `Set.subset` vars_of_env g) @@ -290,21 +289,19 @@ let tot_or_ghost_typing_freevars let tot_typing_freevars (g:env) (t:term) (ty:term) - (d:unit) : Lemma (ensures freevars t `Set.subset` vars_of_env g /\ freevars ty `Set.subset` vars_of_env g) = admit () let bind_comp_freevars (g:env) (x:var) (c1:comp) (c2:comp) (c:comp) - (d:unit) : Lemma (requires freevars_comp c1 `Set.subset` vars_of_env g /\ freevars_comp c2 `Set.subset` (Set.union (vars_of_env g) (Set.singleton x))) (ensures freevars_comp c `Set.subset` vars_of_env g) = admit () -let slprop_equiv_freevars (g:env) (t0:term) (t1:term) (v:unit) +let slprop_equiv_freevars (g:env) (t0:term) (t1:term) : Lemma (ensures (freevars t0 `Set.subset` vars_of_env g) <==> (freevars t1 `Set.subset` vars_of_env g)) = admit () @@ -312,7 +309,6 @@ let slprop_equiv_freevars (g:env) (t0:term) (t1:term) (v:unit) let st_equiv_freevars (g:env) (c1:comp) (c2:comp) - (d:unit) : Lemma (requires freevars_comp c1 `Set.subset` vars_of_env g) (ensures freevars_comp c2 `Set.subset` vars_of_env g) @@ -325,25 +321,23 @@ let prop_validity_fv (g:env) (p:term) = admit() let st_sub_freevars (g:env) (c1:comp) (c2:comp) - (d:unit) : Lemma (requires freevars_comp c1 `Set.subset` vars_of_env g) (ensures freevars_comp c2 `Set.subset` vars_of_env g) = admit () let src_typing_freevars_t (d':'a) = - (g:env) -> (t:st_term) -> (c:comp) -> (d:unit) -> + (g:env) -> (t:st_term) -> (c:comp) -> Lemma (ensures freevars_st t `Set.subset` vars_of_env g /\ freevars_comp c `Set.subset` vars_of_env g) -let st_comp_typing_freevars (g:env) (st:st_comp) (d:unit) +let st_comp_typing_freevars (g:env) (st:st_comp) : Lemma (ensures freevars_st_comp st `Set.subset` vars_of_env g) = admit () let comp_typing_freevars (g:env) (c:comp) (u:universe) - (d:unit) : Lemma (ensures freevars_comp c `Set.subset` vars_of_env g) = admit () @@ -419,7 +413,6 @@ let freevars_array (t:term) let st_typing_freevars (g:env) (t:st_term) (c:comp) - (d:unit) : Lemma (ensures freevars_st t `Set.subset` vars_of_env g /\ freevars_comp c `Set.subset` vars_of_env g) diff --git a/src/checker/Pulse.Typing.FV.fsti b/src/checker/Pulse.Typing.FV.fsti index 8011c4c80..80cf02674 100644 --- a/src/checker/Pulse.Typing.FV.fsti +++ b/src/checker/Pulse.Typing.FV.fsti @@ -49,28 +49,24 @@ val freevars_close_st_term (e:st_term) (x:var) (i:index) [SMTPat (freevars_st (close_st_term' e x i))] val tot_typing_freevars (g:env) (t:term) (ty:term) - (d:unit) : Lemma (ensures freevars t `Set.subset` vars_of_env g /\ freevars ty `Set.subset` vars_of_env g) val comp_typing_freevars (g:env) (c:comp) (u:universe) - (d:unit) : Lemma (ensures freevars_comp c `Set.subset` vars_of_env g) val st_typing_freevars (g:env) (t:st_term) (c:comp) - (d:unit) : Lemma (ensures freevars_st t `Set.subset` vars_of_env g /\ freevars_comp c `Set.subset` vars_of_env g) let st_typing_freevars_inv (g:env) (t:st_term) (c:comp) - (d:unit) (x:var) : Lemma (requires freshv g x) (ensures ~(x `Set.mem` freevars_st t) /\ ~(x `Set.mem` freevars_comp c)) - = st_typing_freevars g t c d \ No newline at end of file + = st_typing_freevars g t c diff --git a/src/checker/Pulse.Typing.LN.fst b/src/checker/Pulse.Typing.LN.fst index d05a60834..a1f59b98f 100644 --- a/src/checker/Pulse.Typing.LN.fst +++ b/src/checker/Pulse.Typing.LN.fst @@ -923,7 +923,7 @@ let close_comp_ln (c:comp) (v:var) #push-options "--ifuel 2 --z3rlimit_factor 4 --z3cliopt 'smt.qi.eager_threshold=100'" -let lift_comp_ln (g:env) (c1:comp) (c2:comp) (d:unit) +let lift_comp_ln (g:env) (c1:comp) (c2:comp) : Lemma (requires ln_c c1) (ensures ln_c c2) @@ -931,24 +931,22 @@ let lift_comp_ln (g:env) (c1:comp) (c2:comp) (d:unit) let tot_or_ghost_typing_ln (g:env) (e:term) (t:term) (eff:FStar.Tactics.V2.tot_or_ghost) - (d:unit) : Lemma (ensures ln e /\ ln t) = admit () let tot_typing_ln (g:env) (e:term) (t:term) - (d:unit) : Lemma (ensures ln e /\ ln t) = admit () #push-options "--fuel 4 --ifuel 4" -let slprop_equiv_ln (g:env) (t0:term) (t1:term) (v:unit) +let slprop_equiv_ln (g:env) (t0:term) (t1:term) : Lemma (ensures ln t0 <==> ln t1) = admit () #pop-options -let st_equiv_ln (g:env) (c1:comp) (c2:comp) (d:unit) +let st_equiv_ln (g:env) (c1:comp) (c2:comp) : Lemma (requires ln_c c1) (ensures ln_c c2) @@ -958,23 +956,23 @@ let prop_valid_must_be_ln (g:env) (t:term) (d:prop_validity g t) : Lemma (ensures ln t) = admit() -let st_sub_ln (g:env) (c1:comp) (c2:comp) (d:unit) +let st_sub_ln (g:env) (c1:comp) (c2:comp) : Lemma (requires ln_c c1) (ensures ln_c c2) = admit () -let bind_comp_ln (g:env) (x:var) (c1:comp) (c2:comp) (c:comp) (d:unit) +let bind_comp_ln (g:env) (x:var) (c1:comp) (c2:comp) (c:comp) : Lemma (requires ln_c c1 /\ ln_c c2) (ensures ln_c c) = admit () -let st_comp_typing_ln (g:env) (st:st_comp) (d:unit) +let st_comp_typing_ln (g:env) (st:st_comp) : Lemma (ensures ln_st_comp st (-1)) = admit () -let comp_typing_ln (g:env) (c:comp) (u:universe) (d:unit) +let comp_typing_ln (g:env) (c:comp) (u:universe) : Lemma (ensures ln_c c) = admit () #pop-options @@ -1039,7 +1037,6 @@ let comp_par_ln (cL : comp{C_ST? cL}) (cR : comp{C_ST? cR}) (x : var) #push-options "--z3rlimit_factor 15 --fuel 4 --ifuel 1 --split_queries no --z3cliopt 'smt.qi.eager_threshold=100'" let st_typing_ln (g:env) (t:st_term) (c:comp) - (d:unit) : Lemma (ensures ln_st t /\ ln_c c) = admit () diff --git a/src/checker/Pulse.Typing.LN.fsti b/src/checker/Pulse.Typing.LN.fsti index 6e0e6ccdb..2be8a8b0b 100644 --- a/src/checker/Pulse.Typing.LN.fsti +++ b/src/checker/Pulse.Typing.LN.fsti @@ -21,13 +21,10 @@ open Pulse.Syntax.Naming open Pulse.Typing val tot_typing_ln (g:env) (e:term) (t:term) - (d:unit) : Lemma (ln e /\ ln t) val comp_typing_ln (g:env) (c:comp) (u:universe) - (d:unit) : Lemma (ln_c c) val st_typing_ln (g:env) (t:st_term) (c:comp) - (st:unit) : Lemma (ln_st t /\ ln_c c) From ac4f9c11a944eb072399e2674e8ed87a2a65cad6 Mon Sep 17 00:00:00 2001 From: Gabriel Ebner Date: Mon, 2 Mar 2026 19:18:13 +0000 Subject: [PATCH 16/18] Remove Pulse.Typing.LN module and unused unit-returning functions Delete the entirely unused Pulse.Typing.LN module (1074 lines). Remove unused GTot/unit-returning functions from: - Pulse.Checker.SLPropEquiv (11 functions) - Pulse.Checker.Base (10 internal functions + 3 exported vals) - Pulse.Typing.Combinators (t_equiv, slprop_equiv_typing, st_equiv_trans) Remove dead FV.st_typing_freevars calls from Abs.fst and Exists.fst. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/checker/Pulse.Checker.Abs.fst | 5 +- src/checker/Pulse.Checker.Base.fst | 113 --- src/checker/Pulse.Checker.Base.fsti | 19 - src/checker/Pulse.Checker.Exists.fst | 2 - src/checker/Pulse.Checker.SLPropEquiv.fst | 90 -- src/checker/Pulse.Checker.SLPropEquiv.fsti | 43 - src/checker/Pulse.Typing.Combinators.fst | 13 - src/checker/Pulse.Typing.Combinators.fsti | 7 - src/checker/Pulse.Typing.LN.fst | 1044 -------------------- src/checker/Pulse.Typing.LN.fsti | 30 - 10 files changed, 2 insertions(+), 1364 deletions(-) delete mode 100644 src/checker/Pulse.Typing.LN.fst delete mode 100644 src/checker/Pulse.Typing.LN.fsti diff --git a/src/checker/Pulse.Checker.Abs.fst b/src/checker/Pulse.Checker.Abs.fst index 1e45e9a58..e79b4c50c 100644 --- a/src/checker/Pulse.Checker.Abs.fst +++ b/src/checker/Pulse.Checker.Abs.fst @@ -28,7 +28,7 @@ open FStar.List.Tot module RT = FStar.Reflection.Typing module P = Pulse.Syntax.Printer module PSB = Pulse.Syntax.Builder -module FV = Pulse.Typing.FV + module T = FStar.Tactics.V2 module R = FStar.Reflection.V2 module RU = Pulse.RuntimeUtils @@ -479,7 +479,7 @@ let rec check_abs_core let c_body = maybe_rewrite_body_typing g' body c_body asc in - FV.st_typing_freevars g' body c_body; let body_closed = close_st_term body x in + let body_closed = close_st_term body x in assume (open_st_term body_closed x == body); // instantiate implicits in the attributes @@ -585,7 +585,6 @@ let rec check_abs_core let c_body = maybe_rewrite_body_typing g' body c_body asc in - FV.st_typing_freevars g' body c_body; let body_closed = close_st_term body x in assume (open_st_term body_closed x == body); let b = {binder_ty=t;binder_ppname=ppname;binder_attrs} in diff --git a/src/checker/Pulse.Checker.Base.fst b/src/checker/Pulse.Checker.Base.fst index 7ba07deff..0ed6ccd27 100644 --- a/src/checker/Pulse.Checker.Base.fst +++ b/src/checker/Pulse.Checker.Base.fst @@ -21,7 +21,6 @@ module T = FStar.Tactics.V2 module RT = FStar.Reflection.Typing module CP = Pulse.Checker.Pure module RU = Pulse.RuntimeUtils -module FV = Pulse.Typing.FV open Pulse.Checker.Util open Pulse.Show @@ -113,7 +112,6 @@ let intro_post_hint g effect_annot ret_ty_opt post = let u = CP.check_universe g ret_ty in let post = CP.check_slprop (push_binding g x ppname_default ret_ty) (open_term_nv post (v_as_nv x)) in let post' = close_term post x in - Pulse.Typing.FV.freevars_close_term post x 0; let effect_annot = check_effect_annot g effect_annot in assume (open_term post' x == post); { g; @@ -122,11 +120,6 @@ let intro_post_hint g effect_annot ret_ty_opt post = post=post'; } -let comp_typing_as_effect_annot_typing (g:env) (c:comp_st) -: unit -= () - - let post_hint_from_comp_typing g c = let p : post_hint_t = { g; @@ -177,60 +170,12 @@ let comp_st_with_post (c:comp_st) (post:term) | C_STGhost i st -> C_STGhost i { st with post } | C_STAtomic i obs st -> C_STAtomic i obs {st with post} -let ve_unit_r g (p:term) : unit = - () - -let st_equiv_post (#g:env) (t:st_term) (c:comp_st) - (post:term { freevars post `Set.subset` freevars (comp_post c)}) - (veq: (x:var { fresh_wrt x g (freevars (comp_post c)) } -> - unit)) - : Dv unit - = if eq_tm post (comp_post c) then () - else - let c' = comp_st_with_post c post in - - Pulse.Typing.Combinators.t_equiv g t c c' - -let simplify_post (g:env) (t:st_term) (c:comp_st) - (post:term { comp_post c == tm_star post tm_emp}) - : Dv unit - = st_equiv_post #g t c post (fun x -> ve_unit_r (push_binding g x ppname_default (comp_res c)) (open_term post x)) - -let simplify_lemma (c:comp_st) (c':comp_st) (post_hint:post_hint_opt_t) - : Lemma - (requires - comp_post_matches_hint c post_hint /\ - effect_annot_of_comp c == effect_annot_of_comp c' /\ - comp_res c' == comp_res c /\ - comp_u c' == comp_u c /\ - comp_post c' == tm_star (comp_post c) tm_emp) - (ensures comp_post_matches_hint (comp_st_with_post c' (comp_post c)) post_hint /\ - comp_pre (comp_st_with_post c' (comp_post c)) == comp_pre c') - = () - -let slprop_equiv_typing_bk (#g:env) (#ctxt:_) - (p:_) - : unit - = let _, bk = slprop_equiv_typing g p ctxt in - bk () - let comp_with_pre (c:comp_st) (pre:term) = match c with | C_ST st -> C_ST { st with pre } | C_STGhost i st -> C_STGhost i { st with pre } | C_STAtomic i obs st -> C_STAtomic i obs {st with pre} -#push-options "--fuel 0 --ifuel 0" -let st_equiv_pre (#g:env) (t:st_term) (c:comp_st) - (pre:term) - (veq: unit) - : Dv unit - = if eq_tm pre (comp_pre c) then () - else - let c' = comp_with_pre c pre in - - Pulse.Typing.Combinators.t_equiv g t c c' - let k_elab_equiv_continuation (#g1:env) (#g2:env { g2 `env_extends` g1 }) (#ctxt #ctxt1:term) (ctxt2:term) (k:continuation_elaborator g1 ctxt g2 ctxt1) : continuation_elaborator g1 ctxt g2 ctxt2 = @@ -239,12 +184,6 @@ let k_elab_equiv_continuation (#g1:env) (#g2:env { g2 `env_extends` g1 }) (#ctxt assert (comp_pre c == ctxt2); k post_hint (| st, comp_with_pre c ctxt1 |) -let slprop_equiv_typing_fwd (#g:env) (#ctxt:_) - (p:_) - : unit - = let fwd, _ = slprop_equiv_typing g ctxt p in - fwd () - let k_elab_equiv_prefix (#g1:env) (#g2:env { g2 `env_extends` g1 }) (#ctxt1 #ctxt:term) (ctxt2:term) (k:continuation_elaborator g1 ctxt1 g2 ctxt) @@ -639,58 +578,6 @@ let apply_conversion : unit = () -let norm_typing - (g:env) (e:term) (eff:FStar.Tactics.V2.tot_or_ghost) (t0:term) - (steps:list norm_step) - : T.Tac (t':term & unit) - = let (| t', _, _ |) = - CP.norm_well_typed_term_alt #(elab_env g) #e #eff #t0 (magic()) steps - in - (| t', () |) - -module TermEq = FStar.Reflection.TermEq -let norm_typing_inverse - (g:env) (e:term) (eff:FStar.Tactics.V2.tot_or_ghost) (t0:term) - (t1:term) - (u:universe) - (steps:list norm_step) - : T.Tac (option unit) - = let (| t1', t1'_typing, related_t1_t1' |) = - CP.norm_well_typed_term_alt #(elab_env g) #t1 #T.E_Total #(R.pack_ln (R.Tv_Type u)) (Ghost.hide (magic())) steps - in - if TermEq.term_eq t0 t1' - then Some () - else None - - -let norm_st_typing_inverse - (g:env) (e:st_term) (t0:term) - (u:universe) - (t1:term) - (steps:list norm_step) - : T.Tac (option unit) - = let d1 - : Ghost.erased (RT.tot_typing (elab_env g) t1 (RT.tm_type u)) - = Ghost.hide (magic()) - in - let (| t1', t1'_typing, related_t1_t1' |) = - CP.norm_well_typed_term_alt d1 steps - in - if TermEq.term_eq t0 t1' - then ( - let t0_typing - : Ghost.erased (RT.tot_typing (elab_env g) t0 (RT.tm_type u)) = - admit() - in - let eq - : Ghost.erased (RT.equiv (elab_env g) t0 t1) - = Ghost.hide (RT.Rel_sym _ _ _ related_t1_t1') - in - - Some (Pulse.Typing.Combinators.t_equiv g e (C_Tot t0) (C_Tot t1)) - ) - else None - open FStar.List.Tot module RT = FStar.Reflection.Typing #push-options "--ifuel 1" diff --git a/src/checker/Pulse.Checker.Base.fsti b/src/checker/Pulse.Checker.Base.fsti index b3ad8d1f3..3ef3737e2 100644 --- a/src/checker/Pulse.Checker.Base.fsti +++ b/src/checker/Pulse.Checker.Base.fsti @@ -199,25 +199,6 @@ val checker_result_t_equiv_ctxt (g:env) (ctxt ctxt' : slprop) val is_stateful_application (g:env) (e:term) : T.Tac (option st_term) -val norm_typing - (g:env) (e:term) (eff:T.tot_or_ghost) (t0:term) - (steps:list norm_step) - : T.Tac (t':term & unit) - -val norm_typing_inverse - (g:env) (e:term) (eff:T.tot_or_ghost) (t0:term) - (t1:term) - (u:universe) - (steps:list norm_step) - : T.Tac (option unit) - -val norm_st_typing_inverse - (g:env) (e:st_term) (t0:term) - (u:universe) - (t1:term) - (steps:list norm_step) - : T.Tac (option unit) - val hoist (g:env) (tt:either term st_term) diff --git a/src/checker/Pulse.Checker.Exists.fst b/src/checker/Pulse.Checker.Exists.fst index d067c27c7..1003ccb6a 100644 --- a/src/checker/Pulse.Checker.Exists.fst +++ b/src/checker/Pulse.Checker.Exists.fst @@ -26,7 +26,6 @@ open Pulse.Checker.Prover module T = FStar.Tactics.V2 module P = Pulse.Syntax.Printer -module FV = Pulse.Typing.FV let slprop_as_list_typing (#g:env) (#p:term) (x:term { List.Tot.memP x (slprop_as_list p) }) @@ -122,7 +121,6 @@ let check_intro_exists let Tm_ExistsSL u b p = tv in - Pulse.Typing.FV.tot_typing_freevars g t tm_slprop; let x = fresh g in let ty_typing, _ = (), () in let witness = diff --git a/src/checker/Pulse.Checker.SLPropEquiv.fst b/src/checker/Pulse.Checker.SLPropEquiv.fst index 4c2f53276..5a7803d37 100644 --- a/src/checker/Pulse.Checker.SLPropEquiv.fst +++ b/src/checker/Pulse.Checker.SLPropEquiv.fst @@ -18,93 +18,3 @@ module Pulse.Checker.SLPropEquiv open Pulse.Syntax open Pulse.Typing open FStar.List.Tot - -let ve_unit_r g (p:term) : unit = - () - -let rec list_as_slprop_append g (vp0 vp1:list term) - : GTot (unit) - (decreases vp0) - = match vp0 with - | [] -> - - () - | [hd] -> - (* Need to check vp1 too in this case *) - begin match vp1 with - | [] -> () - | _::_ -> () - end - | hd::tl -> - let tl_vp1 = list_as_slprop_append g tl vp1 in - - - () - - -let list_as_slprop_comm g (vp0 vp1:list term) - : GTot (unit) - = let d1 : _ = list_as_slprop_append g vp0 vp1 in - let d2 : _ = list_as_slprop_append g vp1 vp0 in - () - -let list_as_slprop_assoc g (vp0 vp1 vp2:list term) - : GTot (unit) - = List.Tot.append_assoc vp0 vp1 vp2; - () - -let list_as_slprop_ctx g (vp0 vp0' vp1 vp1':list term) - : GTot (unit) - - = let split_app = list_as_slprop_append g vp0 vp1 in - let split_app' = list_as_slprop_append g vp0' vp1' in - () - -let list_as_slprop_singleton g - (p q:term) - : GTot (unit) - = () - -let rec slprop_list_equiv (g:env) - (vp:term) - : GTot (unit) - (decreases vp) - = match inspect_term vp with - | Tm_Emp -> () - | Tm_Star vp0 vp1 -> - let eq0 = slprop_list_equiv g vp0 in - let eq1 = slprop_list_equiv g vp1 in - let app_eq - : unit - = list_as_slprop_append g (slprop_as_list vp0) (slprop_as_list vp1) - in - () - - | _ -> () - -let slprop_equiv_swap_equiv (g:env) - (l0 l2:list term) - (p q:term) - : unit - = let d : unit - = () in - let d' : unit - = List.Tot.append_assoc [q] l0 l2; - () in - - let d_q_p = () in - let d' : unit = d_q_p in - let d' : unit - = () in - () - - -let slprop_equiv_split_frame (g:env) (ctxt req:term) (frame:list term) - : unit - = let ctxt_l = slprop_as_list ctxt in - let req_l = slprop_as_list req in - - - - - () diff --git a/src/checker/Pulse.Checker.SLPropEquiv.fsti b/src/checker/Pulse.Checker.SLPropEquiv.fsti index 20531bf35..1f7fdc6a0 100644 --- a/src/checker/Pulse.Checker.SLPropEquiv.fsti +++ b/src/checker/Pulse.Checker.SLPropEquiv.fsti @@ -20,50 +20,7 @@ open FStar.List.Tot open Pulse.Syntax open Pulse.Typing -open Pulse.Typing.Combinators -open Pulse.Checker.Base let canon_slprop (vp:term) : term = list_as_slprop (slprop_as_list vp) - -val ve_unit_r (g:env) (p:term) : unit - -val list_as_slprop_append (g:env) (vp0 vp1:list term) - : GTot (unit) - -val list_as_slprop_comm (g:env) (vp0 vp1:list term) - : GTot (unit) - -val list_as_slprop_assoc (g:env) (vp0 vp1 vp2:list term) - : GTot (unit) - -val list_as_slprop_ctx (g:env) (vp0 vp0' vp1 vp1':list term) - : GTot (unit) - -val list_as_slprop_singleton (g:env) (p q:term) - : GTot (unit) - -val slprop_list_equiv (g:env) (vp:term) - : GTot (unit) - -val slprop_equiv_swap_equiv (g:env) (l0 l2:list term) - (p q:term) - : GTot (unit) - -val slprop_equiv_split_frame (g:env) (ctxt req:term) (frame:list term) - : unit - - -let slprop_equiv_typing_fwd (#g:env) (#ctxt:term) (ctxt_typing:unit) - (p:term) - : unit - = let fwd, _ = slprop_equiv_typing g ctxt p in - fwd ctxt_typing - - -let slprop_equiv_typing_bk (#g:env) (#ctxt:term) (ctxt_typing:unit) - (p:term) - : unit - = let _, bk = slprop_equiv_typing g p ctxt in - bk ctxt_typing diff --git a/src/checker/Pulse.Typing.Combinators.fst b/src/checker/Pulse.Typing.Combinators.fst index 561d9b17a..febf6e054 100644 --- a/src/checker/Pulse.Typing.Combinators.fst +++ b/src/checker/Pulse.Typing.Combinators.fst @@ -42,19 +42,6 @@ val construct_forall_typing (x:var { freshv g x /\ ~ (x `Set.mem` freevars body) }) : GTot (unit) -let st_equiv_trans (g:env) (c0 c1 c2:comp) - : unit - = () - -let t_equiv (g:env) (st:st_term) (c:comp) (c':comp) - : unit - = () - -let slprop_equiv_typing (g:env) (t0 t1:term) - : GTot ((unit -> unit) & - (unit -> unit)) - = (fun _ -> ()), (fun _ -> ()) - let bind_t (case_c1 case_c2:comp_st -> bool) = (g:env) -> (pre:term) -> diff --git a/src/checker/Pulse.Typing.Combinators.fsti b/src/checker/Pulse.Typing.Combinators.fsti index 72baec351..629e4b314 100644 --- a/src/checker/Pulse.Typing.Combinators.fsti +++ b/src/checker/Pulse.Typing.Combinators.fsti @@ -26,13 +26,6 @@ let st_comp_with_pre (st:st_comp) (pre:term) : st_comp = { st with pre } let nvar_as_binder (x:nvar) (t:term) : binder = mk_binder_ppname t (fst x) -val t_equiv (g:env) (st:st_term) (c:comp) (c':comp) - : unit - -val slprop_equiv_typing (g:env) (t0 t1:term) - : GTot ((unit -> unit) & - (unit -> unit)) - let st_ghost_as_atomic (c:comp_st { C_STGhost? c }) = C_STAtomic (comp_inames c) Neutral (st_comp_of_comp c) diff --git a/src/checker/Pulse.Typing.LN.fst b/src/checker/Pulse.Typing.LN.fst deleted file mode 100644 index a1f59b98f..000000000 --- a/src/checker/Pulse.Typing.LN.fst +++ /dev/null @@ -1,1044 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Typing.LN -module RT = FStar.Reflection.Typing -module R = FStar.Reflection.V2 -module L = FStar.List.Tot -open FStar.List.Tot -open Pulse.Syntax -open Pulse.Typing - -// -// TODO: this is needed only for the E_Total flag, -// may be the flag should move to reflection -// - -let well_typed_terms_are_ln (g:R.env) (e:R.term) (t:R.term) (#eff:_) (d:RT.typing g e (eff, t)) - : Lemma (ensures RT.ln e /\ RT.ln t) = - - RT.well_typed_terms_are_ln g e (eff, t) d - -let rt_equiv_ln (g:R.env) (e1 e2:R.term) (d:RT.equiv g e1 e2) - : Lemma (RT.ln e1 /\ RT.ln e2) = admit () - -assume -val open_term_ln_host' (t:term) (x:R.term) (i:index) - : Lemma - (requires RT.ln' (RT.subst_term t [ RT.DT i x ]) (i - 1)) - (ensures RT.ln' t i) - -let open_term_ln' (e:term) - (x:term) - (i:index) - : Lemma - (requires ln' (open_term' e x i) (i - 1)) - (ensures ln' e i) - (decreases e) - = open_term_ln_host' e x i - -#push-options "--fuel 2 --ifuel 1 --z3rlimit_factor 4" -let open_comp_ln' (c:comp) - (x:term) - (i:index) - : Lemma - (requires ln_c' (open_comp' c x i) (i - 1)) - (ensures ln_c' c i) - = allow_invert c; - match c with - | C_Tot t -> - open_term_ln' t x i - | C_ST s -> - open_term_ln' s.res x i; - open_term_ln' s.pre x i; - open_term_ln' s.post x (i + 1) - | C_STGhost n s - | C_STAtomic n _ s -> - open_term_ln' n x i; - open_term_ln' s.res x i; - open_term_ln' s.pre x i; - open_term_ln' s.post x (i + 1) - -let open_term_ln_opt' (t:option term) (x:term) (i:index) - : Lemma - (requires ln_opt' ln' (open_term_opt' t x i) (i - 1)) - (ensures ln_opt' ln' t i) - (decreases t) - = match t with - | None -> () - | Some t -> open_term_ln' t x i - -// aux -let __brs_of (t:st_term{Tm_Match? t.term}) : list branch = - let Tm_Match {brs} = t.term in - brs - -let rec open_term_ln_list' (t:list term) (x:term) (i:index) - : Lemma - (requires ln_list' (open_term_list' t x i) (i - 1)) - (ensures ln_list' t i) - (decreases t) - = match t with - | [] -> () - | hd::tl -> - open_term_ln' hd x i; - open_term_ln_list' tl x i - -let open_term_pairs' (t:list (term & term)) (v:term) (i:index) - : Tot (list (term & term)) - = subst_term_pairs t [ RT.DT i v ] - -let rec open_term_ln_pairs (t:list (term & term)) (x:term) (i:index) - : Lemma - (requires ln_terms' (open_term_pairs' t x i) (i - 1)) - (ensures ln_terms' t i) - (decreases t) - = match t with - | [] -> () - | (l, r)::tl -> - open_term_ln' l x i; - open_term_ln' r x i; - open_term_ln_pairs tl x i - -let open_proof_hint_ln (t:proof_hint_type) (x:term) (i:index) - : Lemma - (requires ln_proof_hint' (open_proof_hint' t x i) (i - 1)) - (ensures ln_proof_hint' t i) - = match t with - | ASSERT { p } - | FOLD { p } - | UNFOLD { p } -> - open_term_ln' p x i - | RENAME { pairs; goal } -> - open_term_ln_pairs pairs x i; - open_term_ln_opt' goal x i - | REWRITE { t1; t2 } -> - open_term_ln' t1 x i; - open_term_ln' t2 x i - | WILD - | SHOW_PROOF_STATE _ -> () - -let open_pattern' (p:pattern) (v:term) (i:index) = - subst_pat p [RT.DT i v] -let close_pattern' (p:pattern) (x:var) (i:index) = - subst_pat p [RT.ND x i] -let open_pattern_args' (ps:list (pattern & bool)) (v:term) (i:index) = - subst_pat_args ps [RT.DT i v] -let close_pattern_args' (ps:list (pattern & bool)) (x:var) (i:index) = - subst_pat_args ps [RT.ND x i] - -#push-options "--ifuel 2" -let rec pattern_shift_subst_invariant (p:pattern) (s:subst) - : Lemma - (ensures pattern_shift_n p == pattern_shift_n (subst_pat p s)) - (decreases p) - [SMTPat (pattern_shift_n (subst_pat p s))] - = match p with - | Pat_Cons _ subpats -> admit() - | _ -> () -and pattern_args_shift_subst_invariant (ps:list (pattern & bool)) (s:subst) - : Lemma - (ensures pattern_args_shift_n ps == pattern_args_shift_n (subst_pat_args ps s)) - (decreases ps) - = allow_invert ps; - match ps with - | [] -> () - | (hd, _)::tl -> - pattern_shift_subst_invariant hd s; - pattern_args_shift_subst_invariant tl (shift_subst_n (pattern_shift_n hd) s) - -let rec open_pattern_ln (p:pattern) (x:term) (i:index) - : Lemma - (requires ln_pattern' (open_pattern' p x i) (i - 1)) - (ensures ln_pattern' p i) - (decreases p) - = match p with - | Pat_Constant _ - | Pat_Var _ _ - | Pat_Dot_Term None -> () - | Pat_Dot_Term (Some e) -> - open_term_ln' e x i - | Pat_Cons _ subpats -> - open_pattern_args_ln subpats x i - -and open_pattern_args_ln (pats:list (pattern & bool)) (x:term) (i:index) - : Lemma - (requires ln_pattern_args' (open_pattern_args' pats x i) (i - 1)) - (ensures ln_pattern_args' pats i) - (decreases pats) - = match pats with - | [] -> () - | (hd, b)::tl -> - open_pattern_ln hd x i; - open_pattern_args_ln tl x (i + pattern_shift_n hd) - -let map_opt_lemma_2 ($f: (x:'a -> y:'b -> z:'c -> Lemma (requires 'p x y z) (ensures 'q x y z))) - (x:option 'a) - (y:'b) - (z:'c) - : Lemma (requires Some? x ==> 'p (Some?.v x) y z) - (ensures Some? x ==> 'q (Some?.v x) y z) - = match x with - | None -> () - | Some x -> f x y z - -#push-options "--z3rlimit 20" -let rec open_st_term_ln' (e:st_term) - (x:term) - (i:index) - : Lemma - (requires ln_st' (open_st_term' e x i) (i - 1)) - (ensures ln_st' e i) - (decreases e) - = match e.term with - | Tm_Return { expected_type; term = e } -> - open_term_ln' expected_type x i; - open_term_ln' e x i - - | Tm_ST { t; args } -> - open_term_ln' t x i; - admit () // same as match - - | Tm_Abs { b; ascription=c; body } -> - open_term_ln' b.binder_ty x i; - map_opt_lemma_2 open_comp_ln' c.annotated x (i + 1); - map_opt_lemma_2 open_comp_ln' c.elaborated x (i + 1); - open_st_term_ln' body x (i + 1) - - | Tm_Bind { binder; head; body } -> - open_term_ln' binder.binder_ty x i; - open_st_term_ln' head x i; - open_st_term_ln' body x (i + 1) - - | Tm_TotBind { binder; head; body } -> - open_term_ln' binder.binder_ty x i; - open_term_ln' head x i; - open_st_term_ln' body x (i + 1) - - | Tm_If { b; then_; else_; post } -> - open_term_ln' b x i; - open_st_term_ln' then_ x i; - open_st_term_ln' else_ x i; - open_term_ln_opt' post x (i + 1) - - | Tm_Match {sc;returns_;brs} -> - open_term_ln' sc x i; - open_term_ln_opt' returns_ x i; - assert (__brs_of e == brs); - open_branches_ln' e brs x i; - () - - | Tm_IntroPure { p } - | Tm_ElimExists { p } -> - open_term_ln' p x i - - | Tm_IntroExists { p; witnesses } -> - open_term_ln' p x i; - open_term_ln_list' witnesses x i - - | Tm_While { invariant; loop_requires; meas; condition; body } -> - open_term_ln' invariant x i; - open_term_ln' loop_requires x i; - open_term_ln_list' meas x i; - open_st_term_ln' condition x i; - open_st_term_ln' body x i - - | Tm_Rewrite { t1; t2 } -> - open_term_ln' t1 x i; - open_term_ln' t2 x i - (* Note: we don't say anything about the tactic. We do not - use it for elaboration, so it does not really matter. *) - - | Tm_WithLocal { binder; initializer; body } -> - open_term_ln' binder.binder_ty x i; - open_term_ln_opt' initializer x i; - open_st_term_ln' body x (i + 1) - - | Tm_WithLocalArray { binder; initializer; length; body } -> - open_term_ln' binder.binder_ty x i; - open_term_ln_opt' initializer x i; - open_term_ln' length x i; - open_st_term_ln' body x (i + 1) - - | Tm_Admit { typ; post } -> - open_term_ln' typ x i; - open_term_ln_opt' post x (i + 1) - - | Tm_Unreachable { c } -> - open_comp_ln' c x i - - | Tm_ProofHintWithBinders { binders; hint_type; t } -> - let n = L.length binders in - open_proof_hint_ln hint_type x (i + n); - open_st_term_ln' t x (i + n) - - | Tm_PragmaWithOptions { body } -> - open_st_term_ln' body x i - - | Tm_ForwardJumpLabel { lbl; body; post } -> - open_comp_ln' post x i; - open_st_term_ln' body x (i+1) - - | Tm_Goto { lbl; arg } -> - open_term_ln' lbl x i; - open_term_ln' arg x i - -// The Tm_Match? and __brs_of conditions are to prove that the ln_branches' below -// satisfies the termination refinment. -and open_branches_ln' (t:st_term{Tm_Match? t.term}) - (brs:list branch{brs << t /\ __brs_of t == brs}) - (x:term) - (i:index) - : Lemma - (requires ( - assert (subst_branches t [RT.DT i x] brs == __brs_of (subst_st_term t [RT.DT i x])); // hint - ln_branches' (open_st_term' t x i) (subst_branches t [RT.DT i x] brs) (i - 1))) - (ensures ln_branches' t brs i) - (decreases brs) - = match brs with - | [] -> () - | br::brs -> - assume (ln_branch' (subst_branch [RT.DT i x] br) (i - 1)); // Should be immediate. Unfold - open_branch_ln' br x i; - admit () - -and open_branch_ln' (br : branch) (x:term) (i:index) - : Lemma - (requires ln_branch' (subst_branch [RT.DT i x] br) (i - 1)) - (ensures ln_branch' br i) - = let {pat; e} = br in - open_pattern_ln pat x i; - open_st_term_ln' e x (i + pattern_shift_n pat) - -let open_term_ln (e:term) (v:var) - : Lemma - (requires ln (open_term e v)) - (ensures ln' e 0) - = open_term_ln' e (term_of_no_name_var v) 0 - - -let open_st_term_ln (e:st_term) (v:var) - : Lemma - (requires ln_st (open_st_term e v)) - (ensures ln_st' e 0) - = open_st_term_ln' e (term_of_no_name_var v) 0 - -assume -val r_ln_weakening (e:R.term) (i j:int) - : Lemma - (requires RT.ln' e i /\ i <= j) - (ensures RT.ln' e j) - -let ln_weakening (e:term) (i j:int) - : Lemma - (requires ln' e i /\ i <= j) - (ensures ln' e j) - (decreases e) - [SMTPat (ln' e j); - SMTPat (ln' e i)] - = r_ln_weakening e i j -#pop-options - -let ln_weakening_comp (c:comp) (i j:int) - : Lemma - (requires ln_c' c i /\ i <= j) - (ensures ln_c' c j) - = match c with - | C_Tot t -> - ln_weakening t i j - | C_ST s -> - ln_weakening s.res i j; - ln_weakening s.pre i j; - ln_weakening s.post (i + 1) (j + 1) - | C_STGhost n s - | C_STAtomic n _ s -> - ln_weakening n i j; - ln_weakening s.res i j; - ln_weakening s.pre i j; - ln_weakening s.post (i + 1) (j + 1) - -let ln_weakening_opt (t:option term) (i j:int) - : Lemma - (requires ln_opt' ln' t i /\ i <= j) - (ensures ln_opt' ln' t j) - (decreases t) - = match t with - | None -> () - | Some t -> ln_weakening t i j - - -let rec ln_weakening_list (t:list term) (i j:int) - : Lemma - (requires ln_list' t i /\ i <= j) - (ensures ln_list' t j) - (decreases t) - = match t with - | [] -> () - | hd::tl -> - ln_weakening hd i j; - ln_weakening_list tl i j - -let rec ln_weakening_pairs (t:list (term & term)) (i j:int) - : Lemma - (requires ln_terms' t i /\ i <= j) - (ensures ln_terms' t j) - (decreases t) - = match t with - | [] -> () - | (l, r)::tl -> - ln_weakening l i j; - ln_weakening r i j; - ln_weakening_pairs tl i j - -let ln_weakening_proof_hint (t:proof_hint_type) (i j:int) - : Lemma - (requires ln_proof_hint' t i /\ i <= j) - (ensures ln_proof_hint' t j) - = match t with - | ASSERT { p } - | FOLD { p } - | UNFOLD { p } -> - ln_weakening p i j - | RENAME { pairs; goal } -> - ln_weakening_pairs pairs i j; - ln_weakening_opt goal i j - | REWRITE { t1; t2 } -> - ln_weakening t1 i j; - ln_weakening t2 i j - | WILD - | SHOW_PROOF_STATE _ -> () - -let rec ln_weakening_st (t:st_term) (i j:int) - : Lemma - (requires ln_st' t i /\ i <= j) - (ensures ln_st' t j) - (decreases t) - = match t.term with - | Tm_Return { expected_type; term } -> - ln_weakening expected_type i j; - ln_weakening term i j - - | Tm_IntroPure { p } - | Tm_ElimExists { p } -> - ln_weakening p i j - - | Tm_IntroExists { p; witnesses } -> - ln_weakening p i j; - ln_weakening_list witnesses i j - - | Tm_While { invariant; loop_requires; meas; condition; body } -> - ln_weakening invariant i j; - ln_weakening loop_requires i j; - admit(); // list lemma for meas - ln_weakening_st condition i j; - ln_weakening_st body i j - - | Tm_If { b; then_; else_; post } -> - ln_weakening b i j; - ln_weakening_st then_ i j; - ln_weakening_st else_ i j; - ln_weakening_opt post (i + 1) (j + 1) - - | Tm_Match _ -> - admit () - - | Tm_ST { t } -> - ln_weakening t i j; - admit () // same as match - - | Tm_Bind { binder; head; body } -> - ln_weakening binder.binder_ty i j; - ln_weakening_st head i j; - ln_weakening_st body (i + 1) (j + 1) - - | Tm_TotBind { binder; head; body } -> - ln_weakening binder.binder_ty i j; - ln_weakening head i j; - ln_weakening_st body (i + 1) (j + 1) - - | Tm_Abs { b; ascription=c; body } -> - ln_weakening b.binder_ty i j; - map_opt_lemma_2 ln_weakening_comp c.annotated (i + 1) (j + 1); - map_opt_lemma_2 ln_weakening_comp c.elaborated (i + 1) (j + 1); - ln_weakening_st body (i + 1) (j + 1) - - | Tm_Rewrite { t1; t2 } -> - ln_weakening t1 i j; - ln_weakening t2 i j - - | Tm_WithLocal { initializer; body } -> - ln_weakening_opt initializer i j; - ln_weakening_st body (i + 1) (j + 1) - - | Tm_WithLocalArray { initializer; length; body } -> - ln_weakening_opt initializer i j; - ln_weakening length i j; - ln_weakening_st body (i + 1) (j + 1) - - | Tm_Admit { typ; post } -> - ln_weakening typ i j; - ln_weakening_opt post (i + 1) (j + 1) - - | Tm_Unreachable { c } -> - ln_weakening_comp c i j - - | Tm_ProofHintWithBinders { binders; hint_type; t } -> - let n = L.length binders in - ln_weakening_proof_hint hint_type (i + n) (j + n); - ln_weakening_st t (i + n) (j + n) - - | Tm_PragmaWithOptions { body } -> - ln_weakening_st body i j - - | Tm_ForwardJumpLabel { body; post } -> - ln_weakening_st body (i + 1) (j + 1); - ln_weakening_comp post i j - - | Tm_Goto { lbl; arg } -> - ln_weakening lbl i j; - ln_weakening arg i j - -assume -val r_open_term_ln_inv' (e:R.term) (x:R.term { RT.ln x }) (i:index) - : Lemma - (requires RT.ln' e i) - (ensures RT.ln' (RT.subst_term e [ RT.DT i x ]) (i - 1)) - -let open_term_ln_inv' (e:term) - (x:term { ln x }) - (i:index) - : Lemma - (requires ln' e i) - (ensures ln' (open_term' e x i) (i - 1)) - (decreases e) - = r_open_term_ln_inv' e x i -#restart-solver -#push-options "--z3rlimit_factor 2 --split_queries no" -let open_comp_ln_inv' (c:comp) - (x:term { ln x }) - (i:index) - : Lemma - (requires ln_c' c i) - (ensures ln_c' (open_comp' c x i) (i - 1)) - = match c with - | C_Tot t -> - open_term_ln_inv' t x i - | C_ST s -> - open_term_ln_inv' s.res x i; - open_term_ln_inv' s.pre x i; - open_term_ln_inv' s.post x (i + 1) - | C_STGhost n s - | C_STAtomic n _ s -> - open_term_ln_inv' n x i; - open_term_ln_inv' s.res x i; - open_term_ln_inv' s.pre x i; - open_term_ln_inv' s.post x (i + 1) -#pop-options - -let open_term_ln_inv_opt' (t:option term) - (x:term { ln x }) - (i:index) - : Lemma - (requires ln_opt' ln' t i) - (ensures ln_opt' ln' (open_term_opt' t x i) (i - 1)) - (decreases t) - = match t with - | None -> () - | Some t -> open_term_ln_inv' t x i - -let rec open_term_ln_inv_list' (t:list term) - (x:term { ln x }) - (i:index) - : Lemma - (requires ln_list' t i) - (ensures ln_list' (open_term_list' t x i) (i - 1)) - (decreases t) - = match t with - | [] -> () - | hd::tl -> - open_term_ln_inv' hd x i; - open_term_ln_inv_list' tl x i - -let rec open_term_ln_inv_pairs (t:list (term & term)) - (x:term { ln x }) - (i:index) - : Lemma - (requires ln_terms' t i) - (ensures ln_terms' (open_term_pairs' t x i) (i - 1)) - (decreases t) - = match t with - | [] -> () - | (l, r)::tl -> - open_term_ln_inv' l x i; - open_term_ln_inv' r x i; - open_term_ln_inv_pairs tl x i - -let open_proof_hint_ln_inv (ht:proof_hint_type) (x:term { ln x }) (i:index) - : Lemma - (requires ln_proof_hint' ht i) - (ensures ln_proof_hint' (open_proof_hint' ht x i) (i - 1)) - = match ht with - | ASSERT { p } - | FOLD { p } - | UNFOLD { p } -> - open_term_ln_inv' p x i - | RENAME { pairs; goal } -> - open_term_ln_inv_pairs pairs x i; - open_term_ln_inv_opt' goal x i - | REWRITE { t1; t2 } -> - open_term_ln_inv' t1 x i; - open_term_ln_inv' t2 x i - | WILD - | SHOW_PROOF_STATE _ -> () - -#push-options "--z3rlimit_factor 4 --fuel 2 --ifuel 2 --split_queries no" -let rec open_term_ln_inv_st' (t:st_term) - (x:term { ln x }) - (i:index) - : Lemma - (requires ln_st' t i) - (ensures ln_st' (open_st_term' t x i) (i - 1)) - (decreases t) - = match t.term with - | Tm_Return { expected_type; term } -> - FStar.Pure.BreakVC.break_vc(); - open_term_ln_inv' expected_type x i; - open_term_ln_inv' term x i - - | Tm_IntroPure { p } - | Tm_ElimExists { p } -> - FStar.Pure.BreakVC.break_vc(); - open_term_ln_inv' p x i - - | Tm_IntroExists { p; witnesses } -> - FStar.Pure.BreakVC.break_vc(); - open_term_ln_inv' p x i; - open_term_ln_inv_list' witnesses x i - - | Tm_While { invariant; loop_requires; meas; condition; body } -> - FStar.Pure.BreakVC.break_vc(); - open_term_ln_inv' invariant x i; - open_term_ln_inv' loop_requires x i; - admit(); // list lemma for meas - open_term_ln_inv_st' condition x i; - open_term_ln_inv_st' body x i - - | Tm_If { b; then_; else_; post } -> - FStar.Pure.BreakVC.break_vc(); - open_term_ln_inv' b x i; - open_term_ln_inv_st' then_ x i; - open_term_ln_inv_st' else_ x i; - open_term_ln_inv_opt' post x (i + 1) - - | Tm_Match _ -> - admit () - - | Tm_Bind { binder; head; body } -> - FStar.Pure.BreakVC.break_vc(); - open_term_ln_inv' binder.binder_ty x i; - open_term_ln_inv_st' head x i; - open_term_ln_inv_st' body x (i + 1) - - | Tm_TotBind { binder; head; body } -> - FStar.Pure.BreakVC.break_vc(); - open_term_ln_inv' binder.binder_ty x i; - open_term_ln_inv' head x i; - open_term_ln_inv_st' body x (i + 1) - - | Tm_ST { t } -> - FStar.Pure.BreakVC.break_vc(); - open_term_ln_inv' t x i; - admit () - - | Tm_Abs { b; ascription=c; body } -> - FStar.Pure.BreakVC.break_vc(); - open_term_ln_inv' b.binder_ty x i; - map_opt_lemma_2 open_comp_ln_inv' c.annotated x (i + 1); - map_opt_lemma_2 open_comp_ln_inv' c.elaborated x (i + 1); - open_term_ln_inv_st' body x (i + 1) - - | Tm_Rewrite { t1; t2 } -> - FStar.Pure.BreakVC.break_vc(); - open_term_ln_inv' t1 x i; - open_term_ln_inv' t2 x i - - | Tm_WithLocal { binder; initializer; body } -> - FStar.Pure.BreakVC.break_vc(); - open_term_ln_inv' binder.binder_ty x i; - open_term_ln_inv_opt' initializer x i; - open_term_ln_inv_st' body x (i + 1) - - | Tm_WithLocalArray { binder; initializer; length; body } -> - FStar.Pure.BreakVC.break_vc(); - open_term_ln_inv' binder.binder_ty x i; - open_term_ln_inv_opt' initializer x i; - open_term_ln_inv' length x i; - open_term_ln_inv_st' body x (i + 1) - - | Tm_Admit { typ; post } -> - FStar.Pure.BreakVC.break_vc(); - open_term_ln_inv' typ x i; - open_term_ln_inv_opt' post x (i + 1) - - | Tm_Unreachable { c } -> - FStar.Pure.BreakVC.break_vc(); - open_comp_ln_inv' c x i - - | Tm_ProofHintWithBinders { binders; hint_type; t } -> - FStar.Pure.BreakVC.break_vc(); - let n = L.length binders in - open_proof_hint_ln_inv hint_type x (i + n); - open_term_ln_inv_st' t x (i + n) - - | Tm_PragmaWithOptions { body } -> - open_term_ln_inv_st' body x i - - | Tm_ForwardJumpLabel { body; post } -> - open_term_ln_inv_st' body x (i + 1); - open_comp_ln_inv' post x i - - | Tm_Goto { lbl; arg } -> - open_term_ln_inv' lbl x i; - open_term_ln_inv' arg x i - -#pop-options - -assume -val r_close_term_ln' (e:R.term) (x:var) (i:index) - : Lemma - (requires RT.ln' e (i - 1)) - (ensures RT.ln' (RT.subst_term e [ RT.ND x i ]) i) - -let close_term_ln' (e:term) - (x:var) - (i:index) - : Lemma - (requires ln' e (i - 1)) - (ensures ln' (close_term' e x i) i) - (decreases e) - = r_close_term_ln' e x i - -let close_comp_ln' (c:comp) - (x:var) - (i:index) - : Lemma - (requires ln_c' c (i - 1)) - (ensures ln_c' (close_comp' c x i) i) - = match c with - | C_Tot t -> - close_term_ln' t x i - - | C_ST s -> - close_term_ln' s.res x i; - close_term_ln' s.pre x i; - close_term_ln' s.post x (i + 1) - | C_STGhost n s - | C_STAtomic n _ s -> - close_term_ln' n x i; - close_term_ln' s.res x i; - close_term_ln' s.pre x i; - close_term_ln' s.post x (i + 1) - -let close_term_ln_opt' (t:option term) (x:var) (i:index) - : Lemma - (requires ln_opt' ln' t (i - 1)) - (ensures ln_opt' ln' (close_term_opt' t x i) i) - (decreases t) - = match t with - | None -> () - | Some t -> close_term_ln' t x i - -let rec close_term_ln_list' (t:list term) (x:var) (i:index) - : Lemma - (requires ln_list' t (i - 1)) - (ensures ln_list' (close_term_list' t x i) i) - (decreases t) - = match t with - | [] -> () - | hd::tl -> - close_term_ln' hd x i; - close_term_ln_list' tl x i - -let close_term_pairs' (t:list (term & term)) (v:var) (i:index) - : Tot (list (term & term)) - = subst_term_pairs t [ RT.ND v i ] - -let rec close_term_ln_pairs (t:list (term & term)) (x:var) (i:index) - : Lemma - (requires ln_terms' t (i - 1)) - (ensures ln_terms' (close_term_pairs' t x i) i) - (decreases t) - = match t with - | [] -> () - | (l, r)::tl -> - close_term_ln' l x i; - close_term_ln' r x i; - close_term_ln_pairs tl x i - -let close_proof_hint_ln (ht:proof_hint_type) (v:var) (i:index) - : Lemma - (requires ln_proof_hint' ht (i - 1)) - (ensures ln_proof_hint' (close_proof_hint' ht v i) i) - = match ht with - | ASSERT { p } - | FOLD { p } - | UNFOLD { p } -> - close_term_ln' p v i - | RENAME { pairs; goal } -> - close_term_ln_pairs pairs v i; - close_term_ln_opt' goal v i - | REWRITE { t1; t2 } -> - close_term_ln' t1 v i; - close_term_ln' t2 v i - | WILD - | SHOW_PROOF_STATE _ -> () - -#push-options "--fuel 2 --ifuel 2 --z3rlimit_factor 10 --split_queries no" -let rec close_st_term_ln' (t:st_term) (x:var) (i:index) - : Lemma - (requires ln_st' t (i - 1)) - (ensures ln_st' (close_st_term' t x i) i) - (decreases t) - = match t.term with - | Tm_Return { expected_type; term } -> - FStar.Pure.BreakVC.break_vc(); - close_term_ln' expected_type x i; - close_term_ln' term x i - - | Tm_IntroPure { p } - | Tm_ElimExists { p } -> - FStar.Pure.BreakVC.break_vc(); - close_term_ln' p x i - - | Tm_IntroExists { p; witnesses } -> - FStar.Pure.BreakVC.break_vc(); - close_term_ln' p x i; - close_term_ln_list' witnesses x i - - | Tm_While { invariant; loop_requires; meas; condition; body } -> - FStar.Pure.BreakVC.break_vc(); - close_term_ln' invariant x i; - close_term_ln' loop_requires x i; - admit(); // list lemma for meas - close_st_term_ln' condition x i; - close_st_term_ln' body x i - - | Tm_If { b; then_; else_; post } -> - FStar.Pure.BreakVC.break_vc(); - close_term_ln' b x i; - close_st_term_ln' then_ x i; - close_st_term_ln' else_ x i; - close_term_ln_opt' post x (i + 1) - - | Tm_Match _ -> - admit () - - | Tm_Bind { binder; head; body } -> - FStar.Pure.BreakVC.break_vc(); - close_term_ln' binder.binder_ty x i; - close_st_term_ln' head x i; - close_st_term_ln' body x (i + 1) - - | Tm_TotBind { binder; head; body } -> - FStar.Pure.BreakVC.break_vc(); - close_term_ln' binder.binder_ty x i; - close_term_ln' head x i; - close_st_term_ln' body x (i + 1) - - | Tm_ST { t } -> - FStar.Pure.BreakVC.break_vc(); - close_term_ln' t x i; - admit () - - | Tm_Abs { b; ascription=c; body } -> - FStar.Pure.BreakVC.break_vc(); - close_term_ln' b.binder_ty x i; - map_opt_lemma_2 close_comp_ln' c.annotated x (i + 1); - map_opt_lemma_2 close_comp_ln' c.elaborated x (i + 1); - close_st_term_ln' body x (i + 1) - - | Tm_Rewrite { t1; t2 } -> - FStar.Pure.BreakVC.break_vc(); - close_term_ln' t1 x i; - close_term_ln' t2 x i - - | Tm_WithLocal { binder; initializer; body } -> - FStar.Pure.BreakVC.break_vc(); - close_term_ln' binder.binder_ty x i; - close_term_ln_opt' initializer x i; - close_st_term_ln' body x (i + 1) - - | Tm_WithLocalArray { binder; initializer; length; body } -> - FStar.Pure.BreakVC.break_vc(); - close_term_ln' binder.binder_ty x i; - close_term_ln_opt' initializer x i; - close_term_ln' length x i; - close_st_term_ln' body x (i + 1) - - | Tm_Admit { typ; post } -> - FStar.Pure.BreakVC.break_vc(); - close_term_ln' typ x i; - close_term_ln_opt' post x (i + 1) - - | Tm_Unreachable { c } -> - FStar.Pure.BreakVC.break_vc(); - close_comp_ln' c x i - - | Tm_ProofHintWithBinders { binders; hint_type; t } -> - FStar.Pure.BreakVC.break_vc(); - let n = L.length binders in - close_proof_hint_ln hint_type x (i + n); - close_st_term_ln' t x (i + n) - - | Tm_PragmaWithOptions { body } -> - close_st_term_ln' body x i - - | Tm_ForwardJumpLabel { body; post } -> - close_st_term_ln' body x (i + 1); - close_comp_ln' post x i - - | Tm_Goto { lbl; arg } -> - close_term_ln' lbl x i; - close_term_ln' arg x i - -#pop-options -let close_comp_ln (c:comp) (v:var) - : Lemma - (requires ln_c c) - (ensures ln_c' (close_comp c v) 0) - = close_comp_ln' c v 0 - -#push-options "--ifuel 2 --z3rlimit_factor 4 --z3cliopt 'smt.qi.eager_threshold=100'" - -let lift_comp_ln (g:env) (c1:comp) (c2:comp) - : Lemma - (requires ln_c c1) - (ensures ln_c c2) - = admit () - -let tot_or_ghost_typing_ln - (g:env) (e:term) (t:term) (eff:FStar.Tactics.V2.tot_or_ghost) - : Lemma - (ensures ln e /\ ln t) - = admit () - -let tot_typing_ln - (g:env) (e:term) (t:term) - : Lemma - (ensures ln e /\ ln t) - = admit () -#push-options "--fuel 4 --ifuel 4" -let slprop_equiv_ln (g:env) (t0:term) (t1:term) - : Lemma (ensures ln t0 <==> ln t1) - = admit () -#pop-options - -let st_equiv_ln (g:env) (c1:comp) (c2:comp) - : Lemma - (requires ln_c c1) - (ensures ln_c c2) - = admit () - -let prop_valid_must_be_ln (g:env) (t:term) (d:prop_validity g t) - : Lemma (ensures ln t) = - admit() - -let st_sub_ln (g:env) (c1:comp) (c2:comp) - : Lemma - (requires ln_c c1) - (ensures ln_c c2) - = admit () - -let bind_comp_ln (g:env) (x:var) (c1:comp) (c2:comp) (c:comp) - : Lemma - (requires ln_c c1 /\ ln_c c2) - (ensures ln_c c) - = admit () - -let st_comp_typing_ln (g:env) (st:st_comp) - : Lemma (ensures ln_st_comp st (-1)) = - admit () - -let comp_typing_ln (g:env) (c:comp) (u:universe) - : Lemma (ensures ln_c c) = - admit () -#pop-options - -let ln_mk_reveal (u:universe) (t:term) (e:term) (n:int) - : Lemma - (requires ln' t n /\ ln' e n) - (ensures ln' (mk_reveal u t e) n) = - admit () - -let ln_mk_fst (u:universe) (aL aR e:term) (n:int) - : Lemma - (requires ln' aL n /\ ln' aR n /\ ln' e n) - (ensures ln' (mk_fst u u aL aR e) n) = - admit () - -let ln_mk_snd (u:universe) (aL aR e:term) (n:int) - : Lemma - (requires ln' aL n /\ ln' aR n /\ ln' e n) - (ensures ln' (mk_snd u u aL aR e) n) = - admit () - -let ln_mk_ref (t:term) (n:int) - : Lemma - (requires ln' t n) - (ensures ln' (mk_ref t) n) = - admit () - -let ln_mk_array (t:term) (n:int) - : Lemma - (requires ln' t n) - (ensures ln' (mk_array t) n) = - admit () - -let par_post_ln (uL uR aL aR postL postR x : _) - : Lemma - (requires ln' postL 0 /\ ln' postR 0) - (ensures ln' (par_post uL uR aL aR postL postR x) 0) -= - admit () - -#push-options "--fuel 4 --ifuel 4" -let comp_par_ln (cL : comp{C_ST? cL}) (cR : comp{C_ST? cR}) (x : var) - : Lemma - (requires ln_c cL /\ ln_c cR) - (ensures ln_c (comp_par cL cR x)) -= let res = mk_tuple2 (comp_u cL) (comp_u cR) (comp_res cL) (comp_res cR) in - assert (ln res); - let pre = tm_star (comp_pre cL) (comp_pre cR) in - assert (ln pre); - assert (ln_c cL); - assert (ln' (comp_post cL) 1); - assert (ln' (comp_post cR) 1); - let post = par_post (comp_u cL) (comp_u cR) (comp_res cL) (comp_res cR) (comp_post cL) (comp_post cR) x in - par_post_ln (comp_u cL) (comp_u cR) (comp_res cL) (comp_res cR) (comp_post cL) (comp_post cR) x; - assert (ln' post 0); - assert (ln_c (comp_par cL cR x)); - () -#pop-options - -// Note the use of break_vc in every case below. - -#push-options "--z3rlimit_factor 15 --fuel 4 --ifuel 1 --split_queries no --z3cliopt 'smt.qi.eager_threshold=100'" -let st_typing_ln (g:env) (t:st_term) (c:comp) - : Lemma - (ensures ln_st t /\ ln_c c) - = admit () - -#pop-options \ No newline at end of file diff --git a/src/checker/Pulse.Typing.LN.fsti b/src/checker/Pulse.Typing.LN.fsti deleted file mode 100644 index 2be8a8b0b..000000000 --- a/src/checker/Pulse.Typing.LN.fsti +++ /dev/null @@ -1,30 +0,0 @@ -(* - Copyright 2023 Microsoft Research - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. -*) - -module Pulse.Typing.LN -open FStar.List.Tot -open Pulse.Syntax -open Pulse.Syntax.Naming -open Pulse.Typing - -val tot_typing_ln (g:env) (e:term) (t:term) - : Lemma (ln e /\ ln t) - -val comp_typing_ln (g:env) (c:comp) (u:universe) - : Lemma (ln_c c) - -val st_typing_ln (g:env) (t:st_term) (c:comp) - : Lemma (ln_st t /\ ln_c c) From 9229b52daad9b1f09084e2f02e4f9544a57d3dc3 Mon Sep 17 00:00:00 2001 From: Gabriel Ebner Date: Mon, 2 Mar 2026 19:35:34 +0000 Subject: [PATCH 17/18] Remove unused non-SMTPat functions from Pulse.Typing.FV Remove functions without SMTPat triggers that are never called externally: tot_typing_freevars, comp_typing_freevars, st_typing_freevars, st_typing_freevars_inv, freevars_open_term_both, and 15 internal helpers (tot_or_ghost_typing_freevars, bind_comp_freevars, slprop_equiv_freevars, st_equiv_freevars, prop_validity_fv, st_sub_freevars, st_comp_typing_freevars, freevars_tm_arrow, freevars_mk_*, freevars_ref, freevars_array, etc.) Keep only the SMTPat-triggered lemmas needed by downstream modules. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/checker/Pulse.Typing.FV.fst | 150 +------------------------------ src/checker/Pulse.Typing.FV.fsti | 27 ------ 2 files changed, 1 insertion(+), 176 deletions(-) diff --git a/src/checker/Pulse.Typing.FV.fst b/src/checker/Pulse.Typing.FV.fst index 2bf0b1169..7e1cacfeb 100644 --- a/src/checker/Pulse.Typing.FV.fst +++ b/src/checker/Pulse.Typing.FV.fst @@ -246,31 +246,8 @@ val freevars_open_term (e:term) (x:term) (i:index) (freevars e `Set.union` freevars x)) [SMTPat (freevars (open_term' e x i))] -let freevars_open_term_both (x:var) (t:term) -: Lemma (freevars (open_term t x) `Set.subset` (freevars t `Set.union` Set.singleton x) /\ - freevars t `Set.subset` freevars (open_term t x)) -= admit() - let freevars_close_st_term e x i = freevars_close_st_term' e x i -let contains_r (g:R.env) (x:var) = Some? (RT.lookup_bvar g x) -assume val vars_of_env_r (g:R.env) : - s:Set.set var { forall x. Set.mem x s <==> contains_r g x } // = Set.intension (contains_r g) - -assume -val refl_typing_freevars (#g:R.env) (#e:R.term) (#t:R.term) (#eff:_) - (_:RT.typing g e (eff, t)) - : Lemma - (ensures RT.freevars e `Set.subset` (vars_of_env_r g) /\ - RT.freevars t `Set.subset` (vars_of_env_r g)) - -assume -val refl_equiv_freevars (#g:R.env) (#e1 #e2:R.term) (d:RT.equiv g e1 e2) - : Lemma (RT.freevars e1 `Set.subset` (vars_of_env_r g) /\ - RT.freevars e2 `Set.subset` (vars_of_env_r g)) - - - assume val freevars_open_comp (c:comp) (x:term) (i:index) : Lemma @@ -279,69 +256,6 @@ val freevars_open_comp (c:comp) (x:term) (i:index) (freevars_comp c `Set.union` freevars x)) [SMTPat (freevars_comp (open_comp' c x i))] -#push-options "--fuel 2 --ifuel 2" -let tot_or_ghost_typing_freevars - (g:env) (t:term) (ty:term) (eff:FStar.Tactics.V2.tot_or_ghost) - : Lemma - (ensures freevars t `Set.subset` vars_of_env g /\ - freevars ty `Set.subset` vars_of_env g) - = admit () - -let tot_typing_freevars - (g:env) (t:term) (ty:term) - : Lemma - (ensures freevars t `Set.subset` vars_of_env g /\ - freevars ty `Set.subset` vars_of_env g) - = admit () - -let bind_comp_freevars (g:env) (x:var) (c1:comp) (c2:comp) (c:comp) - : Lemma - (requires freevars_comp c1 `Set.subset` vars_of_env g /\ - freevars_comp c2 `Set.subset` (Set.union (vars_of_env g) (Set.singleton x))) - (ensures freevars_comp c `Set.subset` vars_of_env g) - = admit () - -let slprop_equiv_freevars (g:env) (t0:term) (t1:term) - : Lemma (ensures (freevars t0 `Set.subset` vars_of_env g) <==> - (freevars t1 `Set.subset` vars_of_env g)) - = admit () - - - -let st_equiv_freevars (g:env) (c1:comp) (c2:comp) - : Lemma - (requires freevars_comp c1 `Set.subset` vars_of_env g) - (ensures freevars_comp c2 `Set.subset` vars_of_env g) - = admit () - -let prop_validity_fv (g:env) (p:term) - : Lemma - (requires prop_validity g p) - (ensures freevars p `Set.subset` vars_of_env g) - = admit() - -let st_sub_freevars (g:env) (c1:comp) (c2:comp) - : Lemma - (requires freevars_comp c1 `Set.subset` vars_of_env g) - (ensures freevars_comp c2 `Set.subset` vars_of_env g) - = admit () - -let src_typing_freevars_t (d':'a) = - (g:env) -> (t:st_term) -> (c:comp) -> - Lemma - (ensures freevars_st t `Set.subset` vars_of_env g /\ - freevars_comp c `Set.subset` vars_of_env g) - -let st_comp_typing_freevars (g:env) (st:st_comp) - : Lemma - (ensures freevars_st_comp st `Set.subset` vars_of_env g) - = admit () - -let comp_typing_freevars (g:env) (c:comp) (u:universe) - : Lemma - (ensures freevars_comp c `Set.subset` vars_of_env g) - = admit () - let freevars_open_st_term_inv (e:st_term) (x:var {~ (x `Set.mem` freevars_st e) }) : Lemma @@ -354,66 +268,4 @@ let freevars_open_st_term_inv (e:st_term) (==) { freevars_close_st_term' (open_st_term e x) x 0 } freevars_st (open_st_term e x) `set_minus` x; } -#pop-options -#pop-options - -let freevars_tm_arrow (b:binder) (q:option qualifier) (c:comp) - : Lemma (freevars (tm_arrow b q c) == - Set.union (freevars b.binder_ty) - (freevars_comp c)) = - admit () - -let freevars_mk_eq2 (u:universe) (t e0 e1:term) - : Lemma (freevars (mk_eq2 u t e0 e1) == - Set.union (freevars t) - (Set.union (freevars e0) - (freevars e1))) = - admit() - -let freevars_mk_reveal (u:universe) (t x_tm:term) - : Lemma (freevars (Pulse.Typing.mk_reveal u t x_tm) == - Set.union (freevars t) (freevars x_tm)) = - admit () - -let freevars_mk_erased (u:universe) (t:term) - : Lemma (freevars (mk_erased u t) == freevars t) = - admit () - -let freevars_mk_fst (uL uR:universe) (aL aR x_tm:term) - : Lemma (freevars (Pulse.Typing.mk_fst uL uR aL aR x_tm) == - Set.union (freevars aL) - (Set.union (freevars aR) - (freevars x_tm))) = - admit () - -let freevars_mk_snd (uL uR:universe) (aL aR x_tm:term) - : Lemma (freevars (Pulse.Typing.mk_snd uL uR aL aR x_tm) == - Set.union (freevars aL) - (Set.union (freevars aR) - (freevars x_tm))) = - admit () - -let freevars_mk_tuple2 (uL uR:universe) (aL aR:term) - : Lemma (freevars (mk_tuple2 uL uR aL aR) == - Set.union (freevars aL) (freevars aR)) = - admit () - -let freevars_ref (t:term) - : Lemma (freevars (mk_ref t) == freevars t) - = admit() - -let freevars_array (t:term) - : Lemma (freevars (mk_array t) == freevars t) - = admit() - - -(*****************************************************************************) - -(** Big lemma follows. We have to split it to make it digestible to SMT. *) - -let st_typing_freevars - (g:env) (t:st_term) (c:comp) -: Lemma - (ensures freevars_st t `Set.subset` vars_of_env g /\ - freevars_comp c `Set.subset` vars_of_env g) -= admit () \ No newline at end of file +#pop-options \ No newline at end of file diff --git a/src/checker/Pulse.Typing.FV.fsti b/src/checker/Pulse.Typing.FV.fsti index 80cf02674..d65ae5363 100644 --- a/src/checker/Pulse.Typing.FV.fsti +++ b/src/checker/Pulse.Typing.FV.fsti @@ -38,35 +38,8 @@ val freevars_close_term (e:term) (x:var) (i:index) freevars e `set_minus` x) [SMTPat (freevars (close_term' e x i))] -val freevars_open_term_both (x:var) (t:term) -: Lemma (freevars (open_term t x) `Set.subset` (freevars t `Set.union` Set.singleton x) /\ - freevars t `Set.subset` freevars (open_term t x)) - val freevars_close_st_term (e:st_term) (x:var) (i:index) : Lemma (ensures freevars_st (close_st_term' e x i) == freevars_st e `set_minus` x) [SMTPat (freevars_st (close_st_term' e x i))] - -val tot_typing_freevars (g:env) (t:term) (ty:term) - : Lemma - (ensures freevars t `Set.subset` vars_of_env g /\ - freevars ty `Set.subset` vars_of_env g) - -val comp_typing_freevars (g:env) (c:comp) (u:universe) - : Lemma - (ensures freevars_comp c `Set.subset` vars_of_env g) - -val st_typing_freevars (g:env) (t:st_term) (c:comp) - : Lemma - (ensures freevars_st t `Set.subset` vars_of_env g /\ - freevars_comp c `Set.subset` vars_of_env g) - - -let st_typing_freevars_inv (g:env) (t:st_term) (c:comp) - (x:var) - : Lemma - (requires freshv g x) - (ensures ~(x `Set.mem` freevars_st t) /\ - ~(x `Set.mem` freevars_comp c)) - = st_typing_freevars g t c From 45e8ab6799b6e8b1edfe55dea8f50e9dd0abf629 Mon Sep 17 00:00:00 2001 From: Gabriel Ebner Date: Mon, 2 Mar 2026 22:45:46 +0000 Subject: [PATCH 18/18] Clean up remaining unit & tuples, unit bindings, and unit parameters - Simplify join_comps return type from (comp_st & unit & unit) to comp_st - Simplify invert_forall_typing return from (unit & unit) to unit - Remove unit params: infer_post' (t_typ, post_typing), peel_binders (t_typ), check_fndefn (_pre_typing), non_informative_class_typing (ty_typing) - Remove unused unit functions: slprop_as_list_typing, with_local_pre_typing, with_local_array_pre_typing, body_typing_subst_true, body_typing_ex, unit_typing, equiv_preserves_typing, st_comp_typing_with_post_hint, apply_conversion, tm_inames_subset_typing - Remove stray let-bindings: u_of_1_g', v_equiv_v', eq_v_v', t'_typing, tok', pre_typing' Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/checker/Pulse.Checker.Abs.fst | 7 ---- .../Pulse.Checker.AssertWithBinders.fst | 7 ++-- src/checker/Pulse.Checker.Base.fst | 40 ------------------- src/checker/Pulse.Checker.Exists.fst | 5 --- .../Pulse.Checker.ForwardJumpLabel.fst | 1 - src/checker/Pulse.Checker.If.fst | 13 +++--- .../Pulse.Checker.Prover.Normalize.fst | 2 - src/checker/Pulse.Checker.Pure.fst | 4 +- src/checker/Pulse.Checker.While.fst | 8 +--- src/checker/Pulse.Checker.WithLocal.fst | 6 --- src/checker/Pulse.Checker.WithLocalArray.fst | 11 ----- src/checker/Pulse.JoinComp.fst | 14 +++---- src/checker/Pulse.JoinComp.fsti | 12 +++--- src/checker/Pulse.Main.fst | 6 +-- src/checker/Pulse.Typing.Combinators.fst | 7 +--- src/checker/Pulse.Typing.fst | 3 -- 16 files changed, 28 insertions(+), 118 deletions(-) diff --git a/src/checker/Pulse.Checker.Abs.fst b/src/checker/Pulse.Checker.Abs.fst index e79b4c50c..d13d4f9a0 100644 --- a/src/checker/Pulse.Checker.Abs.fst +++ b/src/checker/Pulse.Checker.Abs.fst @@ -410,13 +410,6 @@ let maybe_rewrite_body_typing (show c) (show (C_Tot t))); let sq : squash (RT.equiv_token (elab_env g) t t') = () in - let t'_typing : unit = - (* t is equiv to t', and t has universe t. *) - magic () - in - let tok' : unit = - () - in C_Tot t ) diff --git a/src/checker/Pulse.Checker.AssertWithBinders.fst b/src/checker/Pulse.Checker.AssertWithBinders.fst index ed2f81661..7004e0292 100644 --- a/src/checker/Pulse.Checker.AssertWithBinders.fst +++ b/src/checker/Pulse.Checker.AssertWithBinders.fst @@ -368,7 +368,7 @@ let check_renaming #restart-solver #push-options "--z3rlimit_factor 2 --fuel 0 --ifuel 1" let rec peel_binders k (ex: slprop) pre r - (g:env) frame (bs: list binder) (t:term) (t_typ: unit) : + (g:env) frame (bs: list binder) (t:term) : T.Tac (g':env {env_extends g' g} & t': slprop & xs: list (universe & typ & nvar) & continuation_elaborator g (frame `tm_star` t) @@ -382,8 +382,7 @@ let rec peel_binders k (ex: slprop) pre r let ty = mk_erased u b.binder_ty in let g' = push_binding g (snd x) (fst x) ty in let t' = open_term' body (mk_reveal u b.binder_ty (term_of_nvar x)) 0 in - let t'_typ : unit = () in - let (|g'', t'', bs', k'|) = peel_binders k ex pre r g' frame bs t' t'_typ in + let (|g'', t'', bs', k'|) = peel_binders k ex pre r g' frame bs t' in (| g'', t'', (u,b.binder_ty,x)::bs', k_elab_trans (Pulse.Checker.Prover.elim_exists g frame u b body x g') k' |) | _ -> fail_doc g (Some r) [ @@ -432,7 +431,7 @@ let check_wild let k = List.Tot.length bs in let frame = list_as_slprop rest in - let (|g', ex', bs, k|) = peel_binders k ex pre st.range g frame bs ex () in + let (|g', ex', bs, k|) = peel_binders k ex pre st.range g frame bs ex in let body = open_st_term_with_reveals body bs in let (| x'', g'', t'', ctxt'', k' |) = diff --git a/src/checker/Pulse.Checker.Base.fst b/src/checker/Pulse.Checker.Base.fst index 0ed6ccd27..89051013c 100644 --- a/src/checker/Pulse.Checker.Base.fst +++ b/src/checker/Pulse.Checker.Base.fst @@ -63,20 +63,6 @@ let post_typing_as_abstraction : FStar.Ghost.erased (RT.tot_typing (elab_env g) (mk_abs ty t) (mk_arrow ty tm_slprop)) = admit() -(* This should be in reflection typing *) -let fstar_equiv_preserves_typing - (g:R.env) (t1 : R.term) (typ : R.term) (t2 : R.term) - (eq : squash (T.equiv_token g t1 t2)) - (t1_typing : RT.tot_typing g t1 typ) - : RT.tot_typing g t2 typ - = admit() - -let equiv_preserves_typing - (g:env) (t1 : term) (typ : term) (t2 : term) - (eq : squash (T.equiv_token (elab_env g) t1 t2)) - : unit - = () - let check_effect_annot (g:env) (e:effect_annot) : T.Tac (e':effect_annot { effect_annot_labels_match e e' }) = let check_opens opens : T.Tac term = @@ -295,24 +281,6 @@ let continuation_elaborator_with_bind (#g:env) (ctxt:term) let coerce_eq (#a #b:Type) (x:a) (_:squash (a == b)) : y:b{y == x} = x -#push-options "--z3rlimit_factor 8 --fuel 1 --ifuel 1" - -let st_comp_typing_with_post_hint - (#g:env) (#ctxt:_) - (post_hint:post_hint_opt g { PostHint? post_hint }) - (c:comp_st { comp_pre c == ctxt /\ comp_post_matches_hint c post_hint }) -: unit -= let st = st_comp_of_comp c in - let PostHint ph = post_hint in - let x = RU.magic () in //fresh g in - assume (fresh_wrt x g (freevars ph.post)); - - - assert (st.res == ph.ret_ty); - assert (st.post == ph.post); - () -#pop-options - let continuation_elaborator_with_bind_fn (#g:env) (ctxt:term) (e1:st_term) (c1:comp { C_Tot? c1 }) @@ -471,7 +439,6 @@ let checker_result_for_st_typing (#g:env) (#ctxt:slprop) (#post_hint:post_hint_o | _ -> () in assert (g' `env_extends` g); - let u_of_1_g' : unit = () in assert (~ (x `Set.mem` freevars (comp_post c1))); (| x, g', (comp_u c1, comp_res c1), ctxt', k |) #pop-options @@ -571,13 +538,6 @@ let is_stateful_application (g:env) (e:term) ) | _ -> None -let apply_conversion - (#g:env) (#e:term) (#eff:FStar.Tactics.V2.tot_or_ghost) (#t0:term) - (#t1:term) - (eq:Ghost.erased (RT.related (elab_env g) t0 RT.R_Eq t1)) - : unit - = () - open FStar.List.Tot module RT = FStar.Reflection.Typing #push-options "--ifuel 1" diff --git a/src/checker/Pulse.Checker.Exists.fst b/src/checker/Pulse.Checker.Exists.fst index 1003ccb6a..0530b9d0a 100644 --- a/src/checker/Pulse.Checker.Exists.fst +++ b/src/checker/Pulse.Checker.Exists.fst @@ -27,11 +27,6 @@ open Pulse.Checker.Prover module T = FStar.Tactics.V2 module P = Pulse.Syntax.Printer -let slprop_as_list_typing (#g:env) (#p:term) - (x:term { List.Tot.memP x (slprop_as_list p) }) - : unit - = assume false; () - let terms_to_string (t:list term) : T.Tac string = String.concat "\n" (T.map Pulse.Syntax.Printer.term_to_string t) diff --git a/src/checker/Pulse.Checker.ForwardJumpLabel.fst b/src/checker/Pulse.Checker.ForwardJumpLabel.fst index d6c28e565..463c7ab2c 100644 --- a/src/checker/Pulse.Checker.ForwardJumpLabel.fst +++ b/src/checker/Pulse.Checker.ForwardJumpLabel.fst @@ -71,7 +71,6 @@ let check } in let lbl_x = fresh g in let g' = push_goto g lbl_x lbl lbl_c in - let pre_typing': unit = () in let post_hint' : post_hint_opt g' = assume post_hint_for_env_p g' post; PostHint post in diff --git a/src/checker/Pulse.Checker.If.fst b/src/checker/Pulse.Checker.If.fst index 2a68865c3..a593129ee 100644 --- a/src/checker/Pulse.Checker.If.fst +++ b/src/checker/Pulse.Checker.If.fst @@ -83,7 +83,7 @@ let check let infer_post_branch (#eq_v:term) (r: checker_result_t (g_with_eq eq_v) pre NoHint) : T.Tac (p:post_hint_for_env g {p.g == g /\ p.effect_annot==EffectAnnotSTT}) = let (| x, g', (u, t), post, k |) = r in - J.infer_post' g g' u t x () post () + J.infer_post' g g' u t x post in let then_ = check_branch tm_true e1 true in @@ -109,8 +109,7 @@ let check let extract #g #pre (#ph:post_hint_for_env g) (r:checker_result_t g pre (PostHint ph)) (is_then:bool) : T.Tac (br:st_term { ~(hyp `Set.mem` freevars_st br) } & - c:comp_st { comp_pre c == pre /\ comp_post_matches_hint c (PostHint ph)} & - unit) + c:comp_st { comp_pre c == pre /\ comp_post_matches_hint c (PostHint ph)}) = let (| br, c |) = let ppname = mk_ppname_no_range "_if_br" in apply_checker_result_k r ppname @@ -121,11 +120,11 @@ let check // (Printf.sprintf "check_if: branch hypothesis is in freevars of checked %s branch" br_name) // else assume not (hyp `Set.mem` freevars_st br); - (| br, c, () |) + (| br, c |) in - let (| e1, c1, e1_typing |) = extract then_ true in - let (| e2, c2, e2_typing |) = extract else_ false in - let (| c, e1_typing, e2_typing |) = + let (| e1, c1 |) = extract then_ true in + let (| e2, c2 |) = extract else_ false in + let c = J.join_comps (g_with_eq tm_true) e1 c1 (g_with_eq tm_false) e2 c2 post_hint' in let c_typing = comp_typing_from_post_hint c post_hint' in diff --git a/src/checker/Pulse.Checker.Prover.Normalize.fst b/src/checker/Pulse.Checker.Prover.Normalize.fst index 69a022481..2d8a57e85 100644 --- a/src/checker/Pulse.Checker.Prover.Normalize.fst +++ b/src/checker/Pulse.Checker.Prover.Normalize.fst @@ -48,7 +48,6 @@ let __normalize_slprop let v' = PCP.norm_well_typed_term (elab_env g) steps v in let v' = Pulse.Simplify.simplify v' in (* NOTE: the simplify stage is unverified *) - let v_equiv_v' : unit = () in v' let normalize_slprop @@ -60,7 +59,6 @@ let normalize_slprop if use_rewrites_to then let rwr = Pulse.Checker.Prover.RewritesTo.get_subst_from_env g in let v' = PS.ss_term v rwr in - let eq_v_v' : unit = () in let v'' = __normalize_slprop g v' in v'' else diff --git a/src/checker/Pulse.Checker.Pure.fst b/src/checker/Pulse.Checker.Pure.fst index cd23ea6c3..672daeb6a 100644 --- a/src/checker/Pulse.Checker.Pure.fst +++ b/src/checker/Pulse.Checker.Pure.fst @@ -523,7 +523,7 @@ let check_slprop_with_core (g:env) let non_informative_class_typing - (g:env) (u:universe) (ty:typ) (ty_typing : unit) + (g:env) (u:universe) (ty:typ) : my_erased (typing_token (elab_env g) (non_informative_class u ty) (E_Total, R.pack_ln (R.Tv_Type u))) = E (magic()) @@ -555,7 +555,7 @@ let try_get_non_informative_witness_aux (g:env) (u:universe) (ty:term) : T.Tac (option (non_informative_t g u ty) & issues) = let goal = non_informative_class u ty in let r_env = elab_env g in - let constraint_typing = non_informative_class_typing g u ty () in + let constraint_typing = non_informative_class_typing g u ty in let goal_typing_tok : squash (typing_token r_env goal (E_Total, R.pack_ln (R.Tv_Type u))) = match constraint_typing with | E tok -> Squash.return_squash tok in diff --git a/src/checker/Pulse.Checker.While.fst b/src/checker/Pulse.Checker.While.fst index a39c36e87..30bc10b88 100644 --- a/src/checker/Pulse.Checker.While.fst +++ b/src/checker/Pulse.Checker.While.fst @@ -30,11 +30,6 @@ module RU = Pulse.RuntimeUtils let empty_env g = mk_env (fstar_env g) let push_empty_env_idem (g:env) : Lemma (push_env g (empty_env g) == g)[SMTPat (push_env g (empty_env g))] = admit() -let body_typing_subst_true #g #x #post -: unit = admit() -let body_typing_ex #g #x #post -: unit = admit() -let unit_typing g : unit = admit() let inv_typing_weakening (g:env) (inv:slprop) : (x:FStar.Ghost.erased var {fresh_wrt x g (freevars inv)}) @@ -247,7 +242,7 @@ let check_while assert g1'' `env_extends` g1'; - let loop_ensures = Pulse.JoinComp.infer_post' g0 g1'' u0 tm_unit y () loop_ensures () in + let loop_ensures = Pulse.JoinComp.infer_post' g0 g1'' u0 tm_unit y loop_ensures in let loop_ensures = subst_loop_requires_marker_with_true loop_ensures.post in let loop_ensures = open_term' loop_ensures unit_const 0 in @@ -282,7 +277,6 @@ let check_while assert body_ph.ret_ty == tm_unit; let x = fresh g2 in - let body_pre_typing = () in let r_body = check (push_context "check_while_body" body.range g2) diff --git a/src/checker/Pulse.Checker.WithLocal.fst b/src/checker/Pulse.Checker.WithLocal.fst index 2b3bf3cfe..196bff1cc 100644 --- a/src/checker/Pulse.Checker.WithLocal.fst +++ b/src/checker/Pulse.Checker.WithLocal.fst @@ -42,11 +42,6 @@ let extend_post_hint_for_local (g:env) (p:post_hint_for_env g) let res = Pulse.Checker.Base.extend_post_hint g p x (mk_ref init_t) conjunct in res -let with_local_pre_typing (#g:env) (#pre:term) - (init_t:term) (x:var { ~ (Set.mem x (dom g)) }) n (i:option term) - : unit - = admit() - #push-options "--z3rlimit_factor 10 --fuel 0 --ifuel 0" let rec unrefine t : T.Tac term = @@ -129,7 +124,6 @@ let check let x_tm = term_of_nvar px in let g_extended = extend_env g x binder.binder_ppname init_t in let body_pre = comp_withlocal_body_pre pre init_t x_tm init in - let body_pre_typing = () in // elaborating this post here, // so that later we can check the computed post to be equal to this one let post : post_hint_for_env g = post in diff --git a/src/checker/Pulse.Checker.WithLocalArray.fst b/src/checker/Pulse.Checker.WithLocalArray.fst index 78d3230a9..3b3d80921 100644 --- a/src/checker/Pulse.Checker.WithLocalArray.fst +++ b/src/checker/Pulse.Checker.WithLocalArray.fst @@ -53,16 +53,6 @@ let extend_post_hint res -let with_local_array_pre_typing (#g:env) (#pre:term) - (init_t:term) - (init:option term) - (len:term) - (init_typing:(match init with Some init -> unit | _ -> unit)) - (x:var { ~ (Set.mem x (dom g)) }) - (n: ppname) - : unit - = admit() - let is_annotated_type_array (t:term) : option term = match is_pure_app t with | Some (head, None, a) -> @@ -152,7 +142,6 @@ let check let x_tm = term_of_nvar px in let g_extended = extend_env g init_t x binder.binder_ppname init in let body_pre = comp_withlocal_array_body_pre pre init_t x_tm init len in - let body_pre_typing = () in // elaborating this post here, // so that later we can check the computed post to be equal to this one let post : post_hint_for_env g = post in diff --git a/src/checker/Pulse.JoinComp.fst b/src/checker/Pulse.JoinComp.fst index 5ec75045a..e1aa8700a 100644 --- a/src/checker/Pulse.JoinComp.fst +++ b/src/checker/Pulse.JoinComp.fst @@ -104,8 +104,8 @@ let rec bindings_var_dom : env_bindings -> Set.set var = function let var_dom (g: env) : Set.set var = bindings_var_dom (bindings g) let infer_post' (g:env) (g':env { g' `env_extends` g }) - (u:universe) (t:typ) (x: var { lookup g' x == Some t }) (t_typ: unit) - (post:term) (post_typing: unit) + (u:universe) (t:typ) (x: var { lookup g' x == Some t }) + (post:term) = // simplify post by applying elimination rules (particularly `frame ** is_unreachable ~~> is_unreachable`) let (| g1, post, _ |) = Pulse.Checker.Prover.elim_exists_and_pure #g' #post in @@ -392,14 +392,12 @@ let rec join_comps (e_else:st_term) (c_else:comp_st) (post:post_hint_t) - : T.TacH (c:comp_st & - unit & - unit) + : T.TacH comp_st (requires comp_post_matches_hint c_then (PostHint post) /\ comp_post_matches_hint c_else (PostHint post) /\ comp_pre c_then == comp_pre c_else) - (ensures fun (| c, _, _ |) -> + (ensures fun c -> st_comp_of_comp c == st_comp_of_comp c_then /\ comp_post_matches_hint c (PostHint post)) = let g = g_then in @@ -410,9 +408,9 @@ let rec join_comps let c = C_STAtomic inames obs st in - (| c, (), () |) + c | C_STGhost _ _, C_STGhost _ _ - | C_ST _, C_ST _ -> (| c_then, (), () |) + | C_ST _, C_ST _ -> c_then | _ -> assert (EffectAnnotAtomicOrGhost? post.effect_annot); diff --git a/src/checker/Pulse.JoinComp.fsti b/src/checker/Pulse.JoinComp.fsti index 0388658b8..53d96dbb1 100644 --- a/src/checker/Pulse.JoinComp.fsti +++ b/src/checker/Pulse.JoinComp.fsti @@ -22,14 +22,14 @@ open Pulse.Checker.Base module T = FStar.Tactics.V2 val infer_post' (g:env) (g':env { g' `env_extends` g }) - (u:universe) (t:typ) (x: var { lookup g' x == Some t }) (t_typ: unit) - (post:term) (post_typing: unit) + (u:universe) (t:typ) (x: var { lookup g' x == Some t }) + (post:term) : T.Tac (p:post_hint_for_env g {p.g == g /\ p.effect_annot==EffectAnnotSTT}) let infer_post #g #ctxt (r:checker_result_t g ctxt NoHint) : T.Tac (p:post_hint_for_env g {p.g == g /\ p.effect_annot==EffectAnnotSTT}) = let (| x, g', (u, t), post, k |) = r in - infer_post' g g' u t x () post () + infer_post' g g' u t x post val join_post #g #hyp #b (p1:post_hint_for_env (g_with_eq g hyp b tm_true)) @@ -44,13 +44,11 @@ val join_comps (e_else:st_term) (c_else:comp_st) (post:post_hint_t) -: T.TacH (c:comp_st & - unit & - unit) +: T.TacH comp_st (requires comp_post_matches_hint c_then (PostHint post) /\ comp_post_matches_hint c_else (PostHint post) /\ comp_pre c_then == comp_pre c_else) - (ensures fun (| c, _, _ |) -> + (ensures fun c -> st_comp_of_comp c == st_comp_of_comp c_then /\ comp_post_matches_hint c (PostHint post)) diff --git a/src/checker/Pulse.Main.fst b/src/checker/Pulse.Main.fst index 7939a6696..2c75041b3 100644 --- a/src/checker/Pulse.Main.fst +++ b/src/checker/Pulse.Main.fst @@ -45,8 +45,8 @@ let check_fndefn (d : decl{FnDefn? d.d}) (g : stt_env{bindings g == []}) (expected_t : option term) - (* Both of these unused: *) - (pre : term) (_pre_typing : unit) + (* pre is unused: *) + (pre : term) : T.Tac (RT.dsl_tac_result_t (fstar_env g) expected_t) = let g = let FnDefn {us} = d.d in push_univ_vars g us in @@ -223,7 +223,7 @@ let main' (d:decl) (pre:term) (g:RT.fstar_top_env) (expected_t:option term) fail g (Some (Pulse.RuntimeUtils.range_of_term pre)) "pulse main: cannot typecheck pre at type slprop"; //fix range match d.d with - | FnDefn {} -> check_fndefn d g expected_t pre () + | FnDefn {} -> check_fndefn d g expected_t pre | FnDecl {} -> if None? expected_t then check_fndecl d g diff --git a/src/checker/Pulse.Typing.Combinators.fst b/src/checker/Pulse.Typing.Combinators.fst index febf6e054..a9f0a7d90 100644 --- a/src/checker/Pulse.Typing.Combinators.fst +++ b/src/checker/Pulse.Typing.Combinators.fst @@ -31,16 +31,13 @@ assume val invert_forall_typing (g:env) (u:universe) (b:binder) (body:term) (x:var { freshv g x /\ ~ (x `Set.mem` freevars body) }) - : GTot ( - unit & - unit - ) + : GTot unit assume val construct_forall_typing (g:env) (u:universe) (b:binder) (body:term) (x:var { freshv g x /\ ~ (x `Set.mem` freevars body) }) - : GTot (unit) + : GTot unit let bind_t (case_c1 case_c2:comp_st -> bool) = (g:env) -> diff --git a/src/checker/Pulse.Typing.fst b/src/checker/Pulse.Typing.fst index 22c00c2ce..4d30b68a1 100644 --- a/src/checker/Pulse.Typing.fst +++ b/src/checker/Pulse.Typing.fst @@ -495,9 +495,6 @@ let tm_inames_subset (inames1 inames2 : term) : term = wr (R.mk_e_app join [inames1; inames2]) (T.range_of_term inames1) -let tm_inames_subset_typing (g:env) (inames1 inames2 : term) : unit = - () - let prop_validity (g:env) (t:term) = FTB.prop_validity_token (elab_env g) t