diff --git a/src/checker/Pulse.Checker.Abs.fst b/src/checker/Pulse.Checker.Abs.fst index 9e8495049..d13d4f9a0 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 @@ -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_Neutral_Ghost g c_computed 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_Observability g c_computed o2 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, STS_Refl _ _ |) 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)) [ @@ -375,12 +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 = - 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 - in - (| c, d_sub |) + c | _, _ -> let open Pulse.PP in @@ -396,16 +388,15 @@ 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) (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) [ @@ -419,15 +410,7 @@ 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 = - (* t is equiv to t', and t has universe t. *) - magic () - in - let tok' : st_equiv g (C_Tot t') (C_Tot t) = - ST_TotEquiv _ t' t u t'_typing - (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 *) @@ -456,15 +439,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 @@ -474,27 +457,21 @@ 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 = T_Lift _ _ _ _ body_typing lift in - (| c_body, body_typing |) + | None -> 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 body_typing = T_Sub _ _ _ _ body_typing d_sub 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 - - FV.st_typing_freevars body_typing; + 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 body_closed = close_st_term body x in assume (open_st_term body_closed x == body); @@ -506,9 +483,9 @@ 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 tres = tm_arrow {binder_ty=t;binder_ppname=ppname;binder_attrs} qual (close_comp c_body x) in - (| _, C_Tot tres, tt |) + let abs_st = wtag None (Tm_Abs { b; q=qual; body=body_closed; ascription=empty_ascription}) in + (| abs_st, C_Tot tres |) | _ -> let elab_c, pre_opened, inames_opened, ret_ty, post_hint_body = match asc.elaborated with @@ -547,7 +524,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. *) @@ -571,7 +548,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 |) @@ -583,37 +560,34 @@ 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 = T_Lift _ _ _ _ body_typing lift in - (| c_body, body_typing |) + | None -> 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 body_typing = T_Sub _ _ _ _ body_typing d_sub in + let c_body = check_effect_annotation g' body.range c_opened c_body in + - let (| c_body, body_typing |) = maybe_rewrite_body_typing body_typing asc in + let c_body = maybe_rewrite_body_typing g' body c_body asc in - FV.st_typing_freevars 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 = T_Abs g x qual b u body_closed c_body t_typing body_typing 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 - (| _, 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 ff332d273..9a62025a2 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:tot_typing g pre tm_slprop) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_Admit? t.term }) @@ -44,8 +43,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,24 +56,29 @@ 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 |) = + 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 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 + (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 -> 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 pre_typing post x + | _, PostHint post -> Pulse.Typing.Combinators.comp_for_post_hint g pre post x in - let (| c, d_c |) = res in - let d = T_Admit _ _ d_c 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; + typ=comp_res c; + post=None }) 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 +95,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 (| admit_st, c |) res_ppname diff --git a/src/checker/Pulse.Checker.Admit.fsti b/src/checker/Pulse.Checker.Admit.fsti index 4b5f85533..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:tot_typing g pre tm_slprop) (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 78ff876c0..7004e0292 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 @@ -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 -> @@ -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:tot_typing g pre tm_slprop) (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; @@ -352,16 +351,16 @@ 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 (| 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 _ _) |) + + + 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 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; } @@ -369,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: tot_typing g t tm_slprop) : + (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) @@ -383,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 : tot_typing g' t' tm_slprop = RU.magic () 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) [ @@ -403,7 +401,6 @@ 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) (post_hint:post_hint_opt g) (res_ppname:ppname) (st:st_term { head_wild st }) @@ -433,12 +430,12 @@ 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 (|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 : tot_typing g' (tm_star frame ex') tm_slprop = RU.magic () 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 @@ -462,7 +459,6 @@ 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) (post_hint:post_hint_opt g) (res_ppname:ppname) (st:st_term { Tm_ProofHintWithBinders? st.term }) @@ -476,7 +472,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 +484,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 } -> @@ -518,10 +514,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: tot_typing g1 v tm_slprop = PC.core_check_term _ _ _ _ in - let h: tot_typing g1 (tm_star v pre') tm_slprop = RU.magic () in // TODO: propagate through prover + 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') 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 |) @@ -553,11 +549,11 @@ 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 = RU.magic () in - let h2: slprop_equiv g' (tm_star pre_remaining rhs') (tm_star lhs pre_remaining) = RU.magic () 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 k' h2 (VE_Refl _ _)) |) + 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.AssertWithBinders.fsti b/src/checker/Pulse.Checker.AssertWithBinders.fsti index 5e9c0de10..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:tot_typing g pre tm_slprop) (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 05380724f..89051013c 100644 --- a/src/checker/Pulse.Checker.Base.fst +++ b/src/checker/Pulse.Checker.Base.fst @@ -19,16 +19,12 @@ 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 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()) @@ -57,76 +53,39 @@ 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)) (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 res_typing pre_typing post_typing - 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 _ i_typing stc - | C_STGhost i st -> - let stc = intro_st_comp_typing st in - CT_STGhost _ i _ i_typing stc + : 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) + (g:env) (x:var) (ty:term) (t:term { fresh_wrt x g (freevars t) }) : 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)) - (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') = - 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 @@ -136,43 +95,23 @@ 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 (| post, post_typing |) = CP.check_slprop (push_binding g x ppname_default ret_ty) (open_term_nv post (v_as_nv x)) in + 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, 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; - ret_ty; u; ty_typing; + ret_ty; u; post=post'; - x; post_typing_src=post_typing; - post_typing=post_typing_as_abstraction #_ #_ #_ #post' 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) -= 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 effect_annot_typing = comp_typing_as_effect_annot_typing ct in - let inv = Metatheory.st_comp_typing_inversion st_comp_typing in +let post_hint_from_comp_typing g c = 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=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=comp_post c } in p @@ -180,56 +119,24 @@ 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) (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" - 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 + 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 - 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 - = RU.magic () //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 - = RU.magic () //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)); - 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=new_post } let k_elab_unit (g:env) (ctxt:term) : continuation_elaborator g ctxt g ctxt @@ -249,122 +156,49 @@ 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 = - 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)}) - (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)) - = 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 pre_typing u_of post_typing (RT.Rel_refl _ _ _) (VE_Refl _ _) veq - in - t_equiv d 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}) - : 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)) - -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:_) (ctxt_typing:tot_typing g ctxt tm_slprop) - (#p:_) (d:slprop_equiv g p ctxt) - : tot_typing g p tm_slprop - = let _, bk = slprop_equiv_typing d in - bk ctxt_typing - 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) (d:st_typing g t c) - (pre:term) - (veq: slprop_equiv g (comp_pre c) pre) - : Dv (st_typing g t (comp_with_pre c pre)) - = 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 pre_typing u_of post_typing (RT.Rel_refl _ _ _) veq (VE_Refl _ _) - in - t_equiv d 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 = 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 _ (VE_Sym _ _ _ d) in - k post_hint (| st, _, 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) - : tot_typing g p tm_slprop - = let fwd, _ = slprop_equiv_typing d in - fwd ctxt_typing + k post_hint (| st, comp_with_pre c ctxt1 |) 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 - (| 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_equiv_pre st_d _ d |) + (| st, comp_with_pre c ctxt2 |) 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 in let k : continuation_elaborator g1 ctxt1' g2 ctxt2' = - k_elab_equiv_prefix k d1 in + k_elab_equiv_prefix ctxt1' k 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) - (e1_typing:st_typing g e1 c1) - (ctxt_pre1_typing:tot_typing g (tm_star ctxt (comp_pre c1)) tm_slprop) + (c1:comp{stateful_comp c1}) + (e1:st_term) (x:nvar {freshv g (snd x)}) : T.Tac (continuation_elaborator g @@ -375,20 +209,18 @@ 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 p_prop = Metatheory.pure_typing_inversion pure_typing in - let v_eq = VE_Comm g ctxt pre1 in + let ctxt_typing = () 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 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 - let (| u_of_1, pre_typing, _, _ |) = - Metatheory.(st_comp_typing_inversion (fst <| comp_typing_inversion (st_typing_correctness e1_typing))) in + let c1 = + 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 let g' = push_binding g x ppname b in @@ -396,9 +228,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)); @@ -413,7 +244,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 @@ -423,27 +254,21 @@ 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 + e1 e2_closed c1 c2 (ppname, x) post_hint in - (| e, c, e_typing |) + (| e, c |) ) in k #pop-options 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) + (c1:comp{stateful_comp c1}) + (e1:st_term) (x:nvar { freshv g (snd x) }) : T.Tac (continuation_elaborator g @@ -451,125 +276,49 @@ 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 x 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:_) - (ctxt_typing:tot_typing g ctxt tm_slprop) - (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) -= 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 - 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) - (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 = - Pulse.Typing.Metatheory.tot_typing_weakening_standard ph.g ty_typing g - in - assert (st.res == ph.ret_ty); - assert (st.post == ph.post); - STC g st x ty_typing ctxt_typing post_typing_src -#pop-options - -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 }) +let continuation_elaborator_with_bind_fn (#g:env) (ctxt:term) + (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) }) : T.Tac (continuation_elaborator g ctxt (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, c1_typing |) = 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 - let i_typing = CP.core_check_term g i T.E_Total tm_inames in - CT_STAtomic _ _ obs _ i_typing 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 - 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 - in - (| e, c2, d |) + let u : Ghost.erased universe = RU.magic () 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 (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 -let emp_inames_included (g:env) (i:term) (_:tot_typing g i tm_inames) +let emp_inames_included (g:env) (i:term) : 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) @@ -585,47 +334,39 @@ 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 - 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 + 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 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 = 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 validity = emp_inames_included g opens in + let c' = C_STGhost opens st in + (| 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) +let match_comp_res_with_post_hint (#g:env) (t:st_term) (c:comp_st) (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 @@ -639,13 +380,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' _ cpre_typing cres_typing cpost_typing d_equiv (VE_Refl _ _) (VE_Refl _ _) - in - (| c', Pulse.Typing.Combinators.t_equiv d d_stequiv |) + + c' #pop-options #pop-options @@ -655,12 +392,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 @@ -670,34 +407,30 @@ 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 (fst <| comp_typing_inversion (st_typing_correctness d1)) 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 : 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 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') = @@ -706,9 +439,8 @@ 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 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), ctxt', k |) #pop-options let readback_comp_res_as_comp (c:T.comp) : option comp = @@ -781,11 +513,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 : 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' ctxt_r k |) module RU = Pulse.RuntimeUtils let as_stateful_application (e:term) (head:term) (args:list T.argv { Cons? args }) @@ -807,87 +538,6 @@ 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) - (#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 - 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 |) - -module TermEq = FStar.Reflection.TermEq -let norm_typing_inverse - (g:env) (e:term) (eff:_) (t0:term) - (d:typing g e eff t0) - (t1:term) - (#u:_) - (d1:tot_typing g t1 (tm_type u)) - (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 - 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) - ) - else None - - -let norm_st_typing_inverse - (#g:env) (#e:st_term) (#t0:term) - (d:st_typing g e (C_Tot t0)) - (#u:_) - (t1:term) - (d1:tot_typing g t1 (tm_type u)) - (steps:list norm_step) - : 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 ()) - 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)) = - rt_equiv_typing #_ #_ #t0 related_t1_t1' d1 - in - let eq - : 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 (E (coerce_eq (Ghost.reveal t0_typing) ())) eq - in - Some (Pulse.Typing.Combinators.t_equiv d steq) - ) - else None - open FStar.List.Tot module RT = FStar.Reflection.Typing #push-options "--ifuel 1" @@ -1117,7 +767,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 4a085b6c8..3ef3737e2 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: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)) (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)) + : 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) + (g:env) (x:var) (ty:term) (t:term { fresh_wrt x g (freevars t) }) : 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:comp_typing_u g c) +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: tot_typing g (comp_pre c) tm_slprop) (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) : 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 /\ @@ -100,26 +94,21 @@ 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') : continuation_elaborator g1 ctxt1' g2 ctxt2' // // A canonical continuation elaborator for Bind // 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) + (c1:comp{stateful_comp c1}) + (e1:st_term) (x:nvar { freshv g (snd x) }) : T.Tac (continuation_elaborator g @@ -127,19 +116,17 @@ 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) - (ctxt_typing:tot_typing g ctxt tm_slprop) - (#e1:st_term) - (#c1:comp { C_Tot? c1 }) +val continuation_elaborator_with_bind_fn (#g:env) (ctxt:term) + (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) }) : 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) @@ -155,11 +142,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 +156,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' } @@ -186,17 +172,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 -> 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) +val match_comp_res_with_post_hint (#g:env) (t:st_term) (c:comp_st) (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)) @@ -210,37 +193,12 @@ 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') (r : checker_result_t g ctxt post_hint) : checker_result_t g ctxt' post_hint 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) - (steps:list norm_step) - : T.Tac (t':term & typing g e eff t') - -val norm_typing_inverse - (g:env) (e:term) (eff:_) (t0:term) - (d:typing g e eff t0) - (t1:term) - (#u:_) - (d1:tot_typing g t1 (tm_type u)) - (steps:list norm_step) - : T.Tac (option (typing g e eff t1)) - -val norm_st_typing_inverse - (#g:env) (#e:st_term) (#t0:term) - (d:st_typing g e (C_Tot t0)) - (#u:_) - (t1:term) - (d1:tot_typing g t1 (tm_type u)) - (steps:list norm_step) - : T.Tac (option (st_typing g e (C_Tot t1))) - val hoist (g:env) (tt:either term st_term) @@ -259,7 +217,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 3145e79c6..9ae23dc37 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 @@ -35,7 +34,6 @@ module RU = Pulse.Reflection.Util let check_bind_fn (g:env) (ctxt:slprop) - (ctxt_typing:tot_typing g ctxt tm_slprop) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term {Tm_Bind? t.term}) @@ -44,7 +42,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) @@ -53,11 +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' : tot_typing g' ctxt tm_slprop = - Metatheory.tot_typing_weakening_single 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 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_typing b head_typing (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 ) @@ -69,7 +65,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 +73,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 +93,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 ... @@ -122,7 +118,6 @@ let check_bind' (maybe_elaborate:bool) (g:env) (ctxt:slprop) - (ctxt_typing:tot_typing g ctxt tm_slprop) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term {Tm_Bind? t.term}) @@ -136,11 +131,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 () = @@ -150,12 +145,12 @@ 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', 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() @@ -173,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 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() @@ -186,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 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() @@ -198,7 +193,6 @@ let check_bind = check_bind' true let check_tot_bind (g:env) (pre:term) - (pre_typing:tot_typing g pre tm_slprop) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_TotBind? t.term }) @@ -221,11 +215,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 e0c9fdd5e..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:tot_typing g pre tm_slprop) (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:tot_typing g pre tm_slprop) (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 2a14d6844..1243b659e 100644 --- a/src/checker/Pulse.Checker.Comp.fst +++ b/src/checker/Pulse.Checker.Comp.fst @@ -25,16 +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)) + : 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) - = let (| u, t_u |) = check_universe g st.res in + : T.Tac (unit) + = 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" @@ -47,34 +46,34 @@ 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))) else ( assert (ty == tm_slprop); - STC g st x t_u pre_typing post_typing + () ) ) 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 + 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 CT_STAtomic _ _ obs _ i_typing stc + 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" (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 + () diff --git a/src/checker/Pulse.Checker.Comp.fsti b/src/checker/Pulse.Checker.Comp.fsti index bfe7e286e..14d50dd0d 100644 --- a/src/checker/Pulse.Checker.Comp.fsti +++ b/src/checker/Pulse.Checker.Comp.fsti @@ -20,9 +20,7 @@ module T = FStar.Tactics.V2 open Pulse.Syntax open Pulse.Typing -open Pulse.Typing.Metatheory.Base 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)) + : T.Tac (unit) diff --git a/src/checker/Pulse.Checker.Exists.fst b/src/checker/Pulse.Checker.Exists.fst index 983ffee75..0530b9d0a 100644 --- a/src/checker/Pulse.Checker.Exists.fst +++ b/src/checker/Pulse.Checker.Exists.fst @@ -26,15 +26,6 @@ open Pulse.Checker.Prover 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) }) - : tot_typing g x tm_slprop - = assume false; t let terms_to_string (t:list term) : T.Tac string @@ -45,7 +36,6 @@ let terms_to_string (t:list term) let check_elim_exists (g:env) (pre:term) - (pre_typing:tot_typing g pre tm_slprop) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term{Tm_ElimExists? t.term}) @@ -55,7 +45,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 +56,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" @@ -85,12 +75,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 d = T_ElimExists g u ty p x ty_typing t_typing 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 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)) @@ -101,19 +93,18 @@ let check_elim_exists let check_intro_exists (g:env) (pre:term) - (pre_typing:tot_typing g pre tm_slprop) (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 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 @@ -125,15 +116,15 @@ let check_intro_exists let Tm_ExistsSL u b p = tv in - Pulse.Typing.FV.tot_typing_freevars 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 (| witness, witness_typing |) = + let ty_typing, _ = (), () in + let witness = 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 (| 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 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) 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 bda34d5a6..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:tot_typing g pre tm_slprop) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term{Tm_ElimExists? t.term}) @@ -43,9 +42,8 @@ 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) (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 677e61b99..463c7ab2c 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:tot_typing g pre tm_slprop) (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 @@ -72,13 +71,12 @@ 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 post_hint' : post_hint_opt g' = 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', body'_c, body'_typing |) = apply_checker_result_k #g' #pre #post body' res_ppname 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; assert comp_pre body'_c == pre; @@ -92,15 +90,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 + 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 |) res_ppname ) else ( - let (| c'', typing'' |) = match_comp_res_with_post_hint 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 (|_,c'',typing''|) 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 0f7266630..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:tot_typing g pre tm_slprop) (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 884f3a70c..c288a12c4 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:tot_typing g pre tm_slprop) (post_hint:post_hint_opt g { PostHint? post_hint }) (res_ppname:ppname) (t:st_term { Tm_Goto? t.term }) @@ -41,7 +40,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; @@ -49,13 +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: 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 - let (| c'', typing'' |) = match_comp_res_with_post_hint 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 pre_typing (|_,c'',typing''|) res_ppname) + (try_frame_pre false #g (|t,c'|) res_ppname) post_hint rng | None -> @@ -66,7 +61,6 @@ let check' let check (g:env) (pre:term) - (pre_typing:tot_typing g pre tm_slprop) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_Goto? t.term }) @@ -74,11 +68,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 4e5ba98e7..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:tot_typing g pre tm_slprop) (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 c6b1955db..a593129ee 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" @@ -47,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: tot_typing g pre tm_slprop) (post_hint:post_hint_opt g) (res_ppname:ppname) (b:term) @@ -57,7 +55,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 @@ -65,13 +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 = - Metatheory.tot_typing_weakening_single - pre_typing - hyp - (mk_sq_rewrites_to_p u0 tm_bool b eq_v) - in - + = let br = let t = mk_term (Tm_ProofHintWithBinders { @@ -84,14 +76,14 @@ 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 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 @@ -117,9 +109,8 @@ 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) - = let (| br, c, d |) = + 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 in @@ -129,17 +120,18 @@ 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 - let (| c, e1_typing, e2_typing |) = - J.join_comps _ _ _ e1_typing _ _ _ e2_typing post_hint' in + 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 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') = - (| _, c, T_If g b e1 e2 c hyp b_typing e1_typing e2_typing (E c_typing) |) 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.If.fsti b/src/checker/Pulse.Checker.If.fsti index d8099e86a..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: tot_typing g pre tm_slprop) (post_hint:post_hint_opt g) (res_ppname:ppname) (b:term) diff --git a/src/checker/Pulse.Checker.ImpureSpec.fst b/src/checker/Pulse.Checker.ImpureSpec.fst index fa375b641..413c44b4f 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 @@ -217,7 +217,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 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 2337efd15..8b51018bf 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 = () in + pp | _ -> fail g None (Printf.sprintf "Impossible: check_intro_pure: checking a pure slprop %s returned a non-pure slprop %s,\ @@ -40,13 +40,12 @@ 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) (pre:term) - (pre_typing:tot_typing g pre tm_slprop) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_IntroPure? t.term }) @@ -56,8 +55,11 @@ 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 st_typing = T_IntroPure _ _ p_typing 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 + let p = check_prop g p 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 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.IntroPure.fsti b/src/checker/Pulse.Checker.IntroPure.fsti index ccbfdfb5f..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:tot_typing g pre tm_slprop) (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 6c4ea982b..3cd33a997 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 @@ -202,15 +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:tot_typing g t ty) - : Tot (tot_typing (push_bindings g bs) t ty) + : Tot (unit) (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 = () let patof (b:branch) : pattern = b.pat let samepat (b1 b2 : branch) : prop = b1.pat == b2.pat @@ -245,7 +218,6 @@ let check_branch (norw:bool) (g:env) (pre:term) - (pre_typing: tot_typing g pre tm_slprop) (post_hint:post_hint_for_env g) (check:check_t) (sc_u : universe) @@ -254,15 +226,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); @@ -296,15 +268,13 @@ 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 = Pulse.Typing.Metatheory.tot_typing_weakening_single pre_typing hyp_var eq_typ in // weaken w/ branch eq + // weakened w/ binders and 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 + let r = check g' pre (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 - (| 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 @@ -316,13 +286,11 @@ 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) (pre:term) - (pre_typing: tot_typing g pre tm_slprop) (post_hint:post_hint_for_env g) (check:check_t) (sc_u : universe) @@ -332,18 +300,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 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}) = @@ -353,7 +321,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 @@ -367,21 +335,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 = - 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 d = TBRV g sc_u sc_ty sc _ p e bs p1 p2 p3 hyp st_typing in - d - in - (| br, d |) - ) + else + br #pop-options let rec max_obs @@ -404,24 +365,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 |) @@ -433,7 +394,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 @@ -447,7 +408,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 @@ -463,10 +424,8 @@ 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 = Pulse.Typing.Combinators.lift_ghost_atomic d 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 + (| pe, c' |) ) @@ -498,30 +457,10 @@ 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 = - 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 - (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 - | [] -> 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 check_branches (g:env) (pre:term) - (pre_typing: tot_typing g pre tm_slprop) (post_hint:post_hint_for_env g) (check:check_t) (sc_u : universe) @@ -530,19 +469,16 @@ 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) -= let checked_brs = check_branches_aux g pre pre_typing post_hint check sc_u sc_ty sc brs0 bnds in + & c:comp_st{comp_pre c == pre /\ comp_post_matches_hint c (PostHint post_hint)}) += 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 = 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) (pre:term) - (pre_typing: tot_typing g pre tm_slprop) (post_hint:post_hint_for_env g) (res_ppname:ppname) (sc:term) @@ -557,7 +493,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 () -> @@ -565,10 +501,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 -> @@ -577,7 +512,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 @@ -597,12 +532,13 @@ let check assert (L.length elab_pats' == nbr); assert (L.length (zip elab_pats' bnds') == nbr); - let (| brs, c, brs_d |) = - check_branches g pre pre_typing post_hint check sc_u sc_ty sc brs (zip elab_pats' bnds') in + let (| brs, c |) = + 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 d = T_Match g sc_u sc_ty sc sc_ty_typing sc_typing c (E c_typing) brs brs_d complete_d in - checker_result_for_st_typing (| _, _, d |) res_ppname + 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 #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..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: tot_typing g pre tm_slprop) (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 ed08e5109..2d8a57e85 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 @@ -48,30 +48,27 @@ 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 - (| 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' = VE_Ext _ _ _ (RU.magic ()) in - let (| v'', eq_v'_v'' |) = __normalize_slprop g v' in - (| v'', VE_Trans _ _ _ _ eq_v_v' eq_v'_v'' |) + let v'' = __normalize_slprop g v' in + v'' else __normalize_slprop g v 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', E (magic()) |) \ 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..ced5d0308 100644 --- a/src/checker/Pulse.Checker.Prover.Normalize.fsti +++ b/src/checker/Pulse.Checker.Prover.Normalize.fsti @@ -24,16 +24,15 @@ 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.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.Prover.fst b/src/checker/Pulse.Checker.Prover.fst index 8412aa78c..7e9db2a0b 100644 --- a/src/checker/Pulse.Checker.Prover.fst +++ b/src/checker/Pulse.Checker.Prover.fst @@ -77,10 +77,10 @@ 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_refl (p: slprop) : squash (slprop_eqv p p) = slprop_eqv_intro fun g -> VE_Refl g p +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 () let elab_slprops_append ps qs : squash (elab_slprops (ps@qs) `slprop_eqv` (elab_slprops ps `tm_star` elab_slprops qs)) = admit () @@ -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: 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 ()) +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: slprop_equiv g2 (elab_slprops ps2) (elab_slprops ps2')) : + (k2: cont_elab g2 ps2' g3 ps3) : 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 (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')) : + (k: cont_elab g1 ps1 g2 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) 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)) 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 @@ -248,13 +245,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: 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)))), (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))) (after1 frame)) <: T.Tac _ |) let prove_first (g: env) (ctxt goals: list slprop_view) @@ -272,13 +269,9 @@ 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)) = RU.magic () 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 - 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))) |) | None -> assert List.rev goals_left_rev @ (goal::goals) == goals0; assume List.rev (goal::goals_left_rev) @ goals == goals0; @@ -292,10 +285,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) - (e1_typing:st_typing g e1 c1) - (ctxt_pre1_typing:tot_typing g (tm_star ctxt (comp_pre c1)) tm_slprop) + (c1:comp{stateful_comp c1}) + (e1:st_term) : T.Tac (continuation_elaborator g (tm_star ctxt (comp_pre c1)) @@ -303,55 +294,47 @@ 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 (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:st_typing g e1 c1) - (ctxt_pre1_typing:tot_typing g (tm_star ctxt (comp_pre c1)) tm_slprop) + (c1:comp_st{comp_res c1 == tm_unit }) + (e1:st_term) : 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 = 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 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) + (c1:comp_st{comp_res c1 == tm_unit }) + (e1:st_term) : 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 = RU.magic () in - let h2: slprop_equiv g - (tm_star (elab_slprops frame) (comp_pre c1)) - (elab_slprops (frame @ [Unknown (comp_pre c1)])) = RU.magic () 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 - k_elab_equiv (continuation_elaborator_with_bind_nondep_unit (elab_slprops frame) e1_typing h1) - h2 h3 posth t - -let tot_typing_tm_unit (g: env) : tot_typing g tm_unit (tm_type u0) = RU.magic () + + + + 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) + posth t 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 + // 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 (continuation_elaborator_with_bind_nondep frame (T_IntroPure g p p_typing pv) 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) post t let is_uvar (t:term) : bool = @@ -390,15 +373,16 @@ 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 pv = check_prop_validity g'' p p_typing in - cont_elab_refl g ctxt ([] @ ctxt) (VE_Refl _ _), + // 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 @ [] @ [])) = 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 - (intro_pure g'' (elab_slprops frame) p p_typing pv) - h1 h2) + + + k_elab_equiv + (elab_slprops (frame @ [] @ [])) + (elab_slprops (frame @ [goal])) + (intro_pure g'' (elab_slprops frame) p pv)) <: T.Tac _ |) end | _ -> None @@ -407,16 +391,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 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 + // implied by t2_typing + let pv = check_prop_validity g p 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 + + 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) post t let prove_with_pure (g: env) (ctxt: list slprop_view) skip_eq_uvar (goal: slprop_view) : @@ -426,12 +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) (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)) - (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)) <: T.Tac _ |) | _ -> None @@ -439,16 +422,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 : 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 e_typ = core_check_term' g e T.E_Ghost b.binder_ty (fun _ -> let open Pulse.PP in + // 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: 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_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 (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 (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) : @@ -458,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) (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 - 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)) <: T.Tac _ |) | _ -> None @@ -470,13 +454,13 @@ 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 | _ -> 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 _ _ _ <: T.Tac _ |)) | _ -> None @@ -499,13 +483,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: slprop_equiv g (elab_slprops ((List.Tot.Base.rev ctxt_left_rev @ ctxt) @ [c])) (elab_slprops ctxt0) = RU.magic () 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 - 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; @@ -520,25 +503,26 @@ 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 }) = - let st = wtag (Some STT_Ghost) (Tm_ST { t = tm_unknown; args = [] }) in + st_term = let c = C_STGhost tm_emp_inames { u; res; pre=tm_is_unreachable; post } in - let typing: st_typing g st c = RU.magic () in - (| st, typing |) + let st = wtag (Some STT_Ghost) (Tm_Unreachable { c }) in + st 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 = 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) 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 - 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)) = @@ -548,23 +532,23 @@ 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 - cont_elab_refl _ _ _ h1, - cont_elab_equiv (unreachable_elim g'' goals) h2 (VE_Refl _ _) + + + cont_elab_refl _ _ _, + cont_elab_equiv (unreachable_elim g'' goals) <: T.Tac _)|) 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 | _ -> 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 _ _ _, cont_elab_refl _ _ _ <: T.Tac _ |)) | _ -> None @@ -574,12 +558,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: 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 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 + 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])) = @@ -590,10 +574,10 @@ 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 - k_elab_equiv (elim_pure g (elab_slprops frame) p x g') h1 h2), - cont_elab_refl _ _ _ (VE_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 @@ -605,12 +589,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: 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 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 + 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])) = @@ -621,10 +605,10 @@ 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 - k_elab_equiv (elim_with_pure g (elab_slprops frame) p x v g') h1 h2), - cont_elab_refl _ _ _ (VE_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 @@ -634,16 +618,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: 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 h: tot_typing g (tm_star frame (comp_pre c)) tm_slprop = RU.magic () in + + + let st : st_term = wtag (Some STT_Ghost) (Tm_ElimExists { p = tm_exists_sl u (as_binder b.binder_ty) body }) 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 + 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,10 +642,10 @@ 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 - k_elab_equiv (elim_exists g (elab_slprops frame) u b body x g') h1 h2), - cont_elab_refl _ _ _ (VE_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 @@ -680,7 +665,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 @@ -693,8 +678,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 _ _ _ ()) - + () 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 @@ -920,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: 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 h2: slprop_equiv g' (elab_slprops ([cand] @ [])) goal = h2 in - cont_elab_refl _ _ _ h1, - 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 @@ -949,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: 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 h2: slprop_equiv g' (elab_slprops ([cand] @ [])) goal = h2 in - cont_elab_refl _ _ _ h1, - 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,16 +1004,13 @@ 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 typing: st_typing g t' c = T_STGhost g t c typing ni 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 - let h3: slprop_equiv g (elab_slprops [Unknown (open_term' (comp_post c) unit_const 0)]) - (elab_slprops ([] @ [Unknown post'])) = VE_Refl _ _ 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 _ _) |) + + + + 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) @@ -1068,14 +1045,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: non_informative g'' c = RU.magic () in - let typing: st_typing g'' t' c = T_STGhost g'' t c typing ni 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 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_equiv k_typing h2 h3 + + + + + + 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 @@ -1129,8 +1106,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: slprop_equiv g' (elab_slprops (solved @ ctxt')) (elab_slprops (ctxt' @ solved @ goals')) = RU.magic () 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" @@ -1172,20 +1149,17 @@ 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 typing: st_typing g' t' c = T_STGhost g' t c typing ni 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 - 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' 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_trans k k_typing (VE_Refl _ _), - cont_elab_refl g'' ([goal] @ []) [goal] (VE_Refl _ _) + 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]) @@ -1316,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 _ _ (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]) = @@ -1330,10 +1304,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: 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, + cont_elab_equiv after |) let prove rng (g: env) (ctxt goals: slprop) allow_amb : T.Tac (g':env { env_extends g' g } & @@ -1353,10 +1327,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: 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 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) = @@ -1364,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 _ _ (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) = @@ -1379,37 +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:tot_typing g ctxt tm_slprop) : T.Tac (g':env { env_extends g' g } & ctxt':term & - tot_typing g' ctxt' tm_slprop & 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 = RU.magic () 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 + // TODO thread through prover + (| g', elab_slprops ctxt'', fun post_hint post_hint_typ -> + let before, after = k g' in - k_elab_trans (k_elab_equiv (before []) h1 (VE_Refl _ _)) - (k_elab_equiv (after ctxt'') h2 h3) 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 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 = 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) = - 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 - 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 + + 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" @@ -1422,13 +1391,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, 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 ( @@ -1436,11 +1405,11 @@ 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 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) [ @@ -1452,7 +1421,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 @@ -1468,22 +1437,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 = RU.magic () 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 + // 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) |) + + (| x, g3, (u_ty, ty), post_hint_opened, + 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:tot_typing g ctxt tm_slprop) - (d:(t:st_term & c:comp_st & st_typing g t c)) + (#ctxt:slprop) + (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 = 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 + // 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.Prover.fsti b/src/checker/Pulse.Checker.Prover.fsti index 0a75a1804..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:tot_typing g ctxt tm_slprop) : T.Tac (g':env { env_extends g' g } & ctxt':term & - tot_typing g' ctxt' tm_slprop & 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) - (d:(t:st_term & c:comp_st & st_typing g t c)) + (#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 530bb0e6f..672daeb6a 100644 --- a/src/checker/Pulse.Checker.Pure.fst +++ b/src/checker/Pulse.Checker.Pure.fst @@ -145,9 +145,9 @@ 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:_) = 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" @@ -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, E proof |) + ru in RU.record_stats "check_universe" aux @@ -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', E tok |) + | Some (| rt, eff, ty', tok |) -> (| rt, eff, ty' |) in RU.record_stats "Pulse.compute_term_type" aux @@ -362,22 +361,21 @@ 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) & - 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 | 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 |), E 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 |) 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, E (RT.T_Token _ _ _ (FStar.Squash.return_squash tok)) |) + | 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 (RT.T_Token _ _ _ (FStar.Squash.get_proof _)) |) + (| 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', E tok |) + | 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 _ -> @@ -486,7 +483,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 @@ -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,28 +503,27 @@ 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 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 -module Metatheory = Pulse.Typing.Metatheory.Base let non_informative_class_typing - (g:env) (u:universe) (ty:typ) (ty_typing : universe_of g ty u) + (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,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:universe_of g ty u) +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 @@ -601,18 +597,18 @@ 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 - Some (| dict, dict_typing |), issues + + 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 +619,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,25 +646,25 @@ 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 |) + 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, 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 |) = 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 = 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 a08f55872..a0e1ea0aa 100644 --- a/src/checker/Pulse.Checker.Pure.fsti +++ b/src/checker/Pulse.Checker.Pure.fsti @@ -35,29 +35,27 @@ 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 & 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 & - (u:universe & universe_of g ty u) & - 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,61 +63,54 @@ 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) - : 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 & - 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 ef10c914e..e86f5b132 100644 --- a/src/checker/Pulse.Checker.Return.fst +++ b/src/checker/Pulse.Checker.Return.fst @@ -23,33 +23,38 @@ 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 - (#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) = @@ -58,23 +63,22 @@ 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) : 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 (| c, e, d |) = check_effect d c in - R c e u ty ud 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 let check_core (g:env) (ctxt:term) - (ctxt_typing:tot_typing g ctxt tm_slprop) (post_hint:post_hint_opt g) (res_ppname:ppname) (st:st_term { Tm_Return? st.term }) @@ -84,13 +88,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 = - Metatheory.tot_typing_weakening_standard post.g post.ty_typing g in - Some (| post.ret_ty, post.u, ty_typing |) + + Some (| post.ret_ty, post.u |) | _ -> match inspect_term expected_type with | Tm_Unknown -> ( @@ -98,25 +101,25 @@ 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 | 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,23 +129,24 @@ 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, 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 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 (|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 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 ctxt_typing (|_,c',d'|) res_ppname) + (try_frame_pre false #g (|ret_st,c'|) res_ppname) post_hint st.range #pop-options @@ -150,7 +154,6 @@ let check_core let check (g:env) (ctxt:term) - (ctxt_typing:tot_typing g ctxt tm_slprop) (post_hint:post_hint_opt g) (res_ppname:ppname) (st:st_term { Tm_Return? st.term }) @@ -167,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 -> ( @@ -175,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 dcb931d6a..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:tot_typing g ctxt tm_slprop) (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 3e9b04964..d703ab91c 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 -> @@ -39,10 +39,10 @@ let check_slprop_equiv_ext r (g:env) (p q:slprop) pp q; ] | Some token -> - VE_Ext g p q (RT.Rel_eq_token _ _ _ ()) + () 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 @@ -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 ()) + () 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 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 ) @@ -110,7 +107,6 @@ 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) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term{Tm_Rewrite? t.term}) @@ -125,7 +121,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 = @@ -140,6 +136,8 @@ 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 (| 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 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.Rewrite.fsti b/src/checker/Pulse.Checker.Rewrite.fsti index 29a07071f..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:tot_typing g pre tm_slprop) (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 905ab61d5..5a7803d37 100644 --- a/src/checker/Pulse.Checker.SLPropEquiv.fst +++ b/src/checker/Pulse.Checker.SLPropEquiv.fst @@ -18,142 +18,3 @@ module Pulse.Checker.SLPropEquiv 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 = - 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)) - (tm_star (list_as_slprop vp0) - (list_as_slprop vp1))) - (decreases vp0) - = match vp0 with - | [] -> - let v : slprop_equiv g (list_as_slprop vp1) - (tm_star tm_emp (list_as_slprop vp1)) = VE_Sym _ _ _ (VE_Unit _ _) - 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 - 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))) - = 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 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')) - (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 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) - (d:slprop_equiv g p q) - : GTot (slprop_equiv g (list_as_slprop [p]) (list_as_slprop [q])) - = d - -let rec slprop_list_equiv (g:env) - (vp:term) - : GTot (slprop_equiv g vp (canon_slprop vp)) - (decreases vp) - = match inspect_term vp with - | Tm_Emp -> VE_Refl _ _ - | Tm_Star vp0 vp1 -> - 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)) - = 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) - (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)) - = list_as_slprop_ctx g (l0 @ [q]) ([q] @ l0) l2 l2 - (list_as_slprop_comm g l0 [q]) - (VE_Refl _ _) 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 - 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 - 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' - - -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 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 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.SLPropEquiv.fsti b/src/checker/Pulse.Checker.SLPropEquiv.fsti index b8051aa91..1f7fdc6a0 100644 --- a/src/checker/Pulse.Checker.SLPropEquiv.fsti +++ b/src/checker/Pulse.Checker.SLPropEquiv.fsti @@ -20,59 +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) : slprop_equiv g (tm_star p tm_emp) p - -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))) - -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))) - -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))) - -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'))) - -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 slprop_list_equiv (g:env) (vp:term) - : GTot (slprop_equiv g vp (canon_slprop vp)) - -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_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 - - -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 fwd, _ = slprop_equiv_typing 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 _, bk = slprop_equiv_typing d in - bk ctxt_typing diff --git a/src/checker/Pulse.Checker.ST.fst b/src/checker/Pulse.Checker.ST.fst index d3514f44a..41e30c0cb 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:tot_typing g ctxt tm_slprop) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_ST? t.term }) @@ -58,7 +57,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,41 +77,33 @@ 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 - then T_ST g' e c typing - 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 : non_informative g' c = - 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 -> - 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 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', T_Frame _ _ _ ctxt' h 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' h d |)) res_ppname 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 ) #pop-options \ No newline at end of file diff --git a/src/checker/Pulse.Checker.ST.fsti b/src/checker/Pulse.Checker.ST.fsti index e038f602f..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:tot_typing g pre tm_slprop) (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 f71f9b1be..30bc10b88 100644 --- a/src/checker/Pulse.Checker.While.fst +++ b/src/checker/Pulse.Checker.While.fst @@ -26,29 +26,21 @@ 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) 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 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 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 - let tt : tot_typing (push_binding g x ppname_default tm_unit) (open_term inv x) tm_slprop = RU.magic () in - (|x, tt|) + 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) : 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 - { 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() } += let x = inv_typing_weakening g inv 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)) @@ -122,7 +114,7 @@ let rec compute_meas_infos (g:env) (pre:term) (ms: list term) | [] -> [] | m :: rest -> let m' = purify_term g { ctxt_now = pre; ctxt_old = Some pre } m in - let (| _, _, ty, (| u, _ |), _ |) = compute_term_type_and_u g m' in + let (| _, _, ty, u |) = compute_term_type_and_u g m' in (m, ty, u) :: compute_meas_infos g pre rest let rec build_tuple_info (infos: list (term & term & universe)) @@ -150,7 +142,6 @@ 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) (post_hint:post_hint_opt g {~ (PostHint? post_hint) }) (res_ppname:ppname) (t:st_term{Tm_While? t.term}) @@ -194,19 +185,19 @@ let check_while | [] -> u0, tm_unit, unit_const, false, mk_precedes u0 tm_unit | [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, mk_precedes u ty | _ -> let meas_infos = compute_meas_infos g pre meas in let (meas_val, _ty_approx, _u_approx, mk_dec) = build_tuple_info meas_infos in let meas_val' = purify_term g { ctxt_now = pre; ctxt_old = Some pre } meas_val in - let (| _, _, ty, (| u, _ |), _ |) = compute_term_type_and_u g meas_val' in + let (| _, _, ty, u |) = compute_term_type_and_u g meas_val' in u, ty, meas_val, true, mk_dec in let dec_formula = mk_dec (tm_bvar {bv_index=0;bv_ppname=fst x_meas}) (term_of_nvar x_meas) 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_val)) @@ -216,25 +207,25 @@ 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 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 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"; 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', (| _, _, 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) @@ -242,24 +233,23 @@ 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 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 = Pulse.JoinComp.infer_post' g0 g1'' y unit_typ loop_ensures_typ 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 = RU.magic () 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 = RU.magic () in - (| t, typ |) + t in let break_lbl_c = C_ST { u = u0; @@ -277,66 +267,52 @@ 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 typ : st_typing g2 t c = RU.magic () in - (| t, c, typ |) in + let (| t, c |) = r_cond 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 = RU.magic () in - let body_ph : post_hint_for_env g2 = inv_as_post_hint 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 - 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 - let body_pre_typing = body_typing_subst_true body_open_pre_typing in + 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) (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 dec_formula x_meas inv body_pre_open)); assert (comp_pre comp_body == comp_pre (comp_while_body u_meas ty_meas is_tot dec_formula x_meas inv body_pre_open)); 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 = RU.magic () 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 = RU.magic () 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 h = RU.magic () in - T_While g1' inv body_pre_open cond body - u_meas ty_meas typ_meas is_tot dec_formula - x_meas g2 - inv_typing2 h 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 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 |) 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 = { 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; - x; - post_typing_src=RU.magic(); //from inv typing and body_open_pre_typing - post_typing=RU.magic() + post=break_pred } 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; @@ -350,15 +326,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 = - T_ForwardJumpLabel g0 (breaklbln, breaklblx) (close_st_term while breaklblx) while_comp while_d 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 |) 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 = RU.magic () 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.While.fsti b/src/checker/Pulse.Checker.While.fsti index 12070d4f0..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:tot_typing g pre tm_slprop) (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 38596fb63..196bff1cc 100644 --- a/src/checker/Pulse.Checker.WithLocal.fst +++ b/src/checker/Pulse.Checker.WithLocal.fst @@ -39,16 +39,9 @@ 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 in res -let with_local_pre_typing (#g:env) (#pre:term) (pre_typing:tot_typing g pre tm_slprop) - (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 - = admit() - #push-options "--z3rlimit_factor 10 --fuel 0 --ifuel 0" let rec unrefine t : T.Tac term = @@ -66,7 +59,6 @@ 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) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_WithLocal? t.term }) @@ -87,31 +79,27 @@ 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 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 // 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, ty_typing |) = 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 init_typing : typing g init T.E_Total ty = init_typing in - (| Some init, u, ty, ty_typing, init_typing |) + let u = check_universe g ty in + let init = check_term g init T.E_Total ty in + (| Some init, u, ty |) | Tm_Unknown, None -> fail g (Some <| head_range t) @@ -119,9 +107,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 - (| None, u, ty, ty_typing, () |) + let u = check_universe g ty in + (| None, u, ty |) in if not (eq_univ init_u u0) then ( @@ -137,40 +124,24 @@ 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 // 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 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, 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 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 + intro_comp_typing g c + x 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 - 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 + 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.WithLocal.fsti b/src/checker/Pulse.Checker.WithLocal.fsti index f397731b6..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:tot_typing g pre tm_slprop) (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 348799338..3b3d80921 100644 --- a/src/checker/Pulse.Checker.WithLocalArray.fst +++ b/src/checker/Pulse.Checker.WithLocalArray.fst @@ -49,24 +49,10 @@ 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 in res -let with_local_array_pre_typing (#g:env) (#pre:term) - (pre_typing:tot_typing g pre tm_slprop) - (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) - (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 - = admit() - let is_annotated_type_array (t:term) : option term = match is_pure_app t with | Some (head, None, a) -> @@ -91,7 +77,6 @@ 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) (post_hint:post_hint_opt g) (res_ppname:ppname) (t:st_term { Tm_WithLocalArray? t.term }) @@ -112,17 +97,16 @@ 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 | 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,17 +118,15 @@ 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 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 ( @@ -160,41 +142,22 @@ 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 init_typing len_typing 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 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 + 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 = - 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 + intro_comp_typing g c + x in - 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 + 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.Checker.WithLocalArray.fsti b/src/checker/Pulse.Checker.WithLocalArray.fsti index 2d57694e3..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:tot_typing g pre tm_slprop) (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..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: tot_typing g0 pre0 tm_slprop) (post_hint:post_hint_opt g0) (res_ppname:ppname) (t:st_term) @@ -287,33 +286,32 @@ 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 & - tot_typing g' ctxt' tm_slprop & 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 #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 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 +326,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 +365,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 +381,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 +391,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 +419,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.Elaborate.Core.fst b/src/checker/Pulse.Elaborate.Core.fst index 4eaa01235..53c6c61d7 100644 --- a/src/checker/Pulse.Elaborate.Core.fst +++ b/src/checker/Pulse.Elaborate.Core.fst @@ -56,88 +56,14 @@ 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) (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) +let elab_lift (g:env) (c1:comp) (c2:comp) (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 @@ -159,162 +85,27 @@ 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) : 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) - : 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") - -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) - : GTot R.branch (decreases d) - = let TBR _ _ _ _ _ _ _ _ bs _ _ _ ed = d in - let e = elab_st_typing ed in - (elab_pat p, e) -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) +let rec elab_st_typing (g:env) + (t:st_term) + (c:comp) + : GTot R.term + = RU.magic () + +and elab_br (g:env) + (c:comp_st) + (sc_u:universe) (sc_ty:typ) (sc:term) + (p:pattern) + (e:st_term) + : GTot R.branch + = RU.magic () +and elab_branches (g:env) + (c:comp_st) + (sc_u:universe) (sc_ty:typ) (sc:term) + (brs:list branch) : 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..e1aa8700a 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 @@ -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 }) + (post:term) = // 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 in let bs0 = bindings g in let dom_g = var_dom g in let fvs_t = freevars t in @@ -122,17 +122,15 @@ 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 - // 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 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_typing=RU.magic() + g; effect_annot=EffectAnnotSTT; + ret_ty=t; u; + post } in let post = RU.beta_lax (elab_env g) post in // clean up spurious dependencies on variables @@ -293,26 +291,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 @@ -354,9 +349,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,14 +359,14 @@ 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 _ = 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; - ret_ty=p1.ret_ty; u=u; ty_typing; x; - post=joined_post; post_typing_src; post_typing=RU.magic()} + {g; effect_annot=eff; + ret_ty=p1.ret_ty; u=u; + post=joined_post} in res @@ -393,44 +388,40 @@ 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) (g_else:env) (e_else:st_term) (c_else:comp_st) - (e_else_typing:st_typing g_else e_else c_else) (post:post_hint_t) - : T.TacH (c:comp_st & - st_typing g_then e_then c & - st_typing g_else e_else c) + : 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 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 = 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 - (| _, e_then_typing, e_else_typing |) + let c = C_STAtomic inames obs st in + + + c | C_STGhost _ _, C_STGhost _ _ - | C_ST _, C_ST _ -> (| _, 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 : st_typing g_then e_then (st_ghost_as_atomic c_then) = - lift_ghost_atomic e_then_typing 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) g_else e_else c_else post | C_STAtomic _ _ _, C_STGhost _ _ -> - let d = lift_ghost_atomic e_else_typing 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 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 b61e79789..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 #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 }) + (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, 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)) @@ -40,19 +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) (g_else:env) (e_else:st_term) (c_else:comp_st) - (e_else_typing:st_typing g_else e_else c_else) (post:post_hint_t) -: T.TacH (c:comp_st & - st_typing g_then e_then c & - st_typing g_else e_else c) +: 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 3783a7fb7..2c75041b3 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,10 +43,10 @@ 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) + (* 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 @@ -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 |) = 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 |) = (* 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,17 +213,17 @@ 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 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 + 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 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 cce455894..5bce52b48 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..a9f0a7d90 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 @@ -31,144 +29,16 @@ 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) (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 - ) + : GTot 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) - -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 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 - 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 - (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 - let eq'' = Ghost.hide (RT.Rel_trans _ _ _ _ _ eq eq') in - ST_TotEquiv g t1 t3 u typing 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' - = 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) - : 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) - + : GTot unit + let bind_t (case_c1 case_c2:comp_st -> bool) = (g:env) -> (pre:term) -> @@ -177,18 +47,10 @@ 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) -> (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 /\ @@ -200,11 +62,12 @@ 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 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 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 @@ -218,40 +81,29 @@ 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) (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_ST _ -> (| c, () |) | 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 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 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 w = try_get_non_informative_witness g (comp_u c) (comp_res c) comp_res_typing 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 }) +: 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 -> - 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) -: T.Tac (st_typing g e (st_ghost_as_atomic c)) -= let w = try_lift_ghost_atomic d in +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 in match w with | None -> let open Pulse.PP in @@ -267,39 +119,36 @@ let lift_ghost_atomic (#g:env) (#e:st_term) (#c:comp_st { C_STGhost? c }) (d:st_ #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 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 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 res_typing x post_typing in - (| _, _, T_Bind _ e1 e2 _ _ b _ _ d_e1 d_c1res d_e2 bc |) + 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 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 res_typing x post_typing in - (| _, _, T_Bind _ e1 e2 _ _ b _ _ d_e1 d_c1res d_e2 bc |) + 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 |) end 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 @@ -308,27 +157,24 @@ 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 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 res_typing x post_typing in - (| _, _, T_Bind _ e1 e2 _ _ b _ _ d_e1 d_c1res d_e2 bc |) + 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 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 res_typing x post_typing in - (| _, _, T_Bind _ e1 e2 _ _ b _ _ d_e1 d_c1res d_e2 bc |) + 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 |) end ) else ( @@ -345,19 +191,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) (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 /\ @@ -378,48 +216,46 @@ 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 ( - 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 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 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 - (| t, c, d |) + let c2_lifted = C_ST (st_comp_of_comp c2) 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 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 with + | Some _ -> + 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 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 - (| t, c, d |) + 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 post_hint in + (| t, c |) | _ -> fail_bias "atomic" ) @@ -428,32 +264,34 @@ 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 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 - (| t, c, d |) + 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 post_hint in + (| t, c |) | 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 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 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 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 - (| t, c, d |) + 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 post_hint in + (| t, c |) ) | _ -> T.fail "Impossible: unexpected combination of effects" #pop-options @@ -464,7 +302,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) @@ -472,86 +310,57 @@ 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 - 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) +let add_frame (g:env) (t:st_term) (c:comp_st) + (frame: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_Frame _ _ _ _ frame_typing t_typing |) + (| t, add_frame c frame |) #push-options "--fuel 0 --ifuel 0" -let apply_frame (#g:env) - (#t:st_term) - (#ctxt:term) - (ctxt_typing: tot_typing g ctxt tm_slprop) - (#c:comp { stateful_comp c }) - (t_typing: st_typing g t c) +let apply_frame (g:env) + (t:st_term) + (ctxt:term) + (c:comp { stateful_comp c }) (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 /\ 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 t_typing - : st_typing g t (Pulse.Typing.add_frame c frame) - = T_Frame g t c frame frame_typing t_typing in + let frame = frame_t 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 (| 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 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) (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 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 post_typing_rec.ty_typing pre_typing post_typing_rec.post_typing in - match post.effect_annot with - | EffectAnnotSTT -> (| _, CT_ST _ _ d_s |) + | EffectAnnotSTT -> C_ST 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 |) + C_STGhost opens 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 |) + 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..629e4b314 100644 --- a/src/checker/Pulse.Typing.Combinators.fsti +++ b/src/checker/Pulse.Typing.Combinators.fsti @@ -26,18 +26,11 @@ 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') - : st_typing g st c' - -val slprop_equiv_typing (#g:_) (#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) -: 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 }) +: T.Tac (unit) val mk_bind (g:env) (pre:term) @@ -46,18 +39,10 @@ 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) (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,44 +55,33 @@ 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) +val add_frame (g:env) (t:st_term) (c:comp_st) + (frame: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) - -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) - (ctxt_typing: tot_typing g ctxt tm_slprop) - (#c:comp { stateful_comp c }) - (t_typing: st_typing g t c) + = term + +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) + (c:comp { stateful_comp c }) (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 /\ 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 (#pre:slprop) (pre_typing:tot_typing g pre tm_slprop) +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) } & - 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.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 bde9adf7c..7e1cacfeb 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)) @@ -247,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 @@ -280,137 +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:_) (#t:_) (#ty:_) (#eff:_) - (d:typing g t eff ty) - : 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)) - -let 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) - = tot_or_ghost_typing_freevars d - -#push-options "--z3rlimit 10" -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 _ _ _ _ dt _ _ -> tot_or_ghost_typing_freevars dt -#pop-options - -let rec 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 -> - let d0, d1 = slprop_eq_typing_inversion _ _ _ token in - tot_or_ghost_typing_freevars d0; - tot_or_ghost_typing_freevars d1 - | VE_Fa g x u b t0 t1 d -> - slprop_equiv_freevars d; - close_open_inverse t0 x - - - -let st_equiv_freevars #g (#c1 #c2:_) - (d:st_equiv 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)) - -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 rec 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) - -let src_typing_freevars_t (d':'a) = - (#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) - : 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 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 - let freevars_open_st_term_inv (e:st_term) (x:var {~ (x `Set.mem` freevars_st e) }) : Lemma @@ -423,328 +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_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 -> - 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) - -#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 -#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 - -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 - -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 -#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 -#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 - -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); - } - -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 - -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 - -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 - -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 - -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 - -let rec 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 prop_typing _ -> - tot_or_ghost_typing_freevars prop_typing - | T_ElimExists _ u t p x dt dv -> - st_typing_freevars_elimexists d st_typing_freevars - | T_IntroExists _ u b p w dt dv dw -> - 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 +#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 7c9b5327e..d65ae5363 100644 --- a/src/checker/Pulse.Typing.FV.fsti +++ b/src/checker/Pulse.Typing.FV.fsti @@ -38,39 +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:_) (#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:_) - (d:comp_typing g c u) - : Lemma - (ensures freevars_comp c `Set.subset` vars_of_env g) - -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:_) - (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 diff --git a/src/checker/Pulse.Typing.LN.fst b/src/checker/Pulse.Typing.LN.fst deleted file mode 100644 index f1a867e7a..000000000 --- a/src/checker/Pulse.Typing.LN.fst +++ /dev/null @@ -1,1269 +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 #c1 #c2 (d:lift_comp g c1 c2) - : Lemma - (requires ln_c c1) - (ensures ln_c c2) - = () - -let tot_or_ghost_typing_ln - (#g:_) (#e:_) (#t:_) (#eff:_) - (d:typing g e eff t) - : Lemma - (ensures ln e /\ ln t) - = let E dt = d in - well_typed_terms_are_ln _ _ _ dt - -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 -#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) - (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 -> - let d0, d1 = slprop_eq_typing_inversion _ _ _ token in - tot_or_ghost_typing_ln d0; - tot_or_ghost_typing_ln d1 - | 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 - ) -#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 (E dpre) _dres _dpost 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)) - -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) - : 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) - -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) - = () - -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 - -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 -#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 rec 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 df 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) - - | T_IntroPure _ p t _ -> - FStar.Pure.BreakVC.break_vc (); - tot_or_ghost_typing_ln t; - assert (ln p); - assert (ln' p 0); - assert (ln' (tm_pure p) 0) - - | 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_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 t_typing e_typing post_typing -> - 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 -> - 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 -> - 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 _ -> - FStar.Pure.BreakVC.break_vc (); - tot_or_ghost_typing_ln tb; - st_typing_ln d1; - st_typing_ln d2 - - | T_Match _ _ _ sc _ scd c _ _ _ _ -> - FStar.Pure.BreakVC.break_vc (); - tot_or_ghost_typing_ln scd; - admit () - - | T_ElimExists _ u t p x dt dv -> - 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 - - - | T_IntroExists _ u t p e dt dv dw -> - 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 - - | 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 _ _ _ p_typing equiv_p_q -> - FStar.Pure.BreakVC.break_vc (); - tot_or_ghost_typing_ln p_typing; - slprop_equiv_ln equiv_p_q - - | 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_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_WithLocalArrayUninit .. -> - admit() - - | 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 - - | 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 () - -#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 d63b3e858..000000000 --- a/src/checker/Pulse.Typing.LN.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.Typing.LN -open FStar.List.Tot -open Pulse.Syntax -open Pulse.Syntax.Naming -open Pulse.Typing - -val tot_typing_ln (#g:_) (#e:_) (#t:_) - (d:tot_typing g e t) - : Lemma (ln e /\ ln t) - -val comp_typing_ln (#g:_) (#c:_) (#u:_) - (d:comp_typing g c u) - : Lemma (ln_c c) - -val st_typing_ln (#g:_) (#t:_) (#c:_) - (st:st_typing g t c) - : Lemma (ln_st t /\ ln_c c) diff --git a/src/checker/Pulse.Typing.Metatheory.Base.fst b/src/checker/Pulse.Typing.Metatheory.Base.fst deleted file mode 100644 index d5583428b..000000000 --- a/src/checker/Pulse.Typing.Metatheory.Base.fst +++ /dev/null @@ -1,208 +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 - = 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()) (admit_st_comp_typing g st) - | C_STGhost inames st -> - CT_STGhost g inames st (admit ()) (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) -: (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) - (_: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) - : 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 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 - -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_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_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 |) - -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)}) -: (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) - (_: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) - : tot_typing g p (wr FStar.Reflection.Typing.tm_prop Range.range_0) - = admit () - -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 = - let (| w, _ |) = d in - (| w, RU.magic #(tot_typing _ _ _) () |) - -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 - = admit() - -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' }) - : 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 - -// 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 = - 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 (RU.magic ()) (RU.magic ()) (RU.magic ()) - (equiv_weakening _ _ hequiv _) (RU.magic ()) (RU.magic ()) - | ST_TotEquiv _ t1 t2 u _ _ -> - ST_TotEquiv _ t1 t2 u (RU.magic ()) (RU.magic ()) - -// 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 rec 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 - -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 = - match d with - | STC _ st x _ _ _ -> - assume (~ (x `Set.mem` dom g')); - assume (~ (x `Set.mem` dom g1)); - STC _ st x (RU.magic ()) (RU.magic ()) (RU.magic ()) - -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_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) - -#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 diff --git a/src/checker/Pulse.Typing.Metatheory.Base.fsti b/src/checker/Pulse.Typing.Metatheory.Base.fsti deleted file mode 100644 index ffded3287..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) - : (u:Ghost.erased universe & universe_of g (comp_res c) u) - -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:_) (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) - : (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)}) - : 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 = RU.magic () - -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) -= 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)) -= admit() diff --git a/src/checker/Pulse.Typing.Metatheory.fst b/src/checker/Pulse.Typing.Metatheory.fst deleted file mode 100644 index 3527adab0..000000000 --- a/src/checker/Pulse.Typing.Metatheory.fst +++ /dev/null @@ -1,107 +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 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_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 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 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: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 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 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 diff --git a/src/checker/Pulse.Typing.Metatheory.fsti b/src/checker/Pulse.Typing.Metatheory.fsti deleted file mode 100644 index a87eba66c..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 diff --git a/src/checker/Pulse.Typing.fst b/src/checker/Pulse.Typing.fst index de5e347be..4d30b68a1 100644 --- a/src/checker/Pulse.Typing.fst +++ b/src/checker/Pulse.Typing.fst @@ -139,83 +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] -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 add_frame (s:comp_st) (frame:term) @@ -548,28 +471,9 @@ 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 tot_typing (g:env) (e:term) (t:term) = - typing g e T.E_Total t - -let ghost_typing (g:env) (e:term) (t:typ) = - typing g e T.E_Ghost t - -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 _ _)) - -let universe_of (g:env) (t:term) (u:universe) = - tot_typing g t (tm_type u) 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) @@ -591,107 +495,13 @@ 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 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)) } -> - 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)) - (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_of g t1 u -> - Ghost.erased (RT.equiv (elab_env g) t1 t2) -> - st_equiv g (C_Tot t1) (C_Tot t2) 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) - -[@@ 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 wrst (ct:comp_st) (t:st_term') : st_term = { term = t; @@ -708,32 +518,8 @@ 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) } -> - 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) - 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 = let v, t = vt in @@ -745,40 +531,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 -> - universe_of g t u -> - 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 -> - 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)) - - | CT_STGhost : - 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)) - -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 @@ -786,8 +539,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) = - my_erased (RT.non_informative (elab_env g) (elab_comp c)) let inv_disjointness (inames i:term) = let g = Pulse.Reflection.Util.inv_disjointness_goal inames i in @@ -808,444 +559,22 @@ let goto_comp_of_block_comp (c: comp_st) : comp_st = post = tm_is_unreachable; } -[@@ 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 -> - 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))) - - | 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) } -> - 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) - - | 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 -> - 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 - - | 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 -> - 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 - - | T_If: - g:env -> - b:term -> - 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) -> - 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 -> - 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 -> - 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 -> - tot_typing g frame tm_slprop -> - 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 -> - tot_typing g p tm_prop -> - 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 } -> - 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)) - - | T_IntroExists: - g:env -> - u:universe -> - 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) - - | T_While: - g:env -> - inv:term -> - post_cond:term -> - cond:st_term -> - body:st_term -> - u_meas: universe -> ty_meas: term -> universe_of g ty_meas u_meas -> - is_tot: bool -> - dec_formula: term -> - 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 dec_formula x inv post_cond) -> - st_typing g (wtag (Some STT) (Tm_While { invariant = inv; - loop_requires = tm_unknown; - meas = []; - 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) } -> - 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)) - (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) } -> - 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)) - (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) } -> - 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)) - (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) } -> - 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)) - (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 -> - 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) - - | 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) } -> - 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 -> - 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 - -(* 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 - = 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) - t0 - 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 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; - 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)) + 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 @@ -1266,33 +595,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 - = 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 (); - } - let effect_annot_matches (c:comp_st) (effect_annot:effect_annot) : prop = match c, effect_annot with