Skip to content

Commit 113fded

Browse files
committed
feat(phl): support backward ecall on bdHoare/phoare goals
Extend backward `ecall` to bdHoare statement goals, so a bdHoare/phoare contract can be applied to the last call of a phoare goal — mirroring the existing hoare backward `ecall`. - ecPhlExists.ml: add `t_ecall_bdhoare_bwd` / `process_ecall_bdhoare`, and dispatch `FbdHoareS` in `process_ecall` (phoare added to the no-xhl error kinds). Program-variable contract arguments are handled via the existing ecall abstraction machinery; a trivial probability split routes the suffix call through `t_bdhoare_seq`, lifting the hoare prefix subgoal via `t_hoareS_conseq_bdhoare`. - ecPhlConseq.mli: expose `t_hoareS_conseq_bdhoare` / `t_hoareF_conseq_bdhoare`.
1 parent 76bf9e9 commit 113fded

2 files changed

Lines changed: 153 additions & 1 deletion

File tree

src/phl/ecPhlConseq.mli

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -23,6 +23,9 @@ val t_bdHoareF_conseq_bd : hoarecmp -> ss_inv -> FApi.backward
2323

2424
val t_hoareS_conseq_conj : ss_inv -> hs_inv -> ss_inv -> hs_inv -> FApi.backward
2525

26+
val t_hoareS_conseq_bdhoare : FApi.backward
27+
val t_hoareF_conseq_bdhoare : FApi.backward
28+
2629
(* -------------------------------------------------------------------- *)
2730
val t_equivF_conseq_nm : ts_inv -> ts_inv -> FApi.backward
2831
val t_equivS_conseq_nm : ts_inv -> ts_inv -> FApi.backward

src/phl/ecPhlExists.ml

Lines changed: 150 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -447,6 +447,150 @@ let t_ecall_hoare_bwd ((cttpt, _) : proofterm * form) (tc : tcenv1) =
447447
EcPhlAuto.t_auto ?conv:None; (* Kill the conseq from the call rule *)
448448
] tc
449449

450+
(* -------------------------------------------------------------------- *)
451+
(* Backward ecall on bdHoare/phoare goals (ecall without ->>).
452+
*
453+
* Mirrors t_ecall_hoare_bwd but for a bdHoare goal and a bdHoare/phoare
454+
* contract. We abstract program-variable arguments of the contract pterm
455+
* into fresh local idents, dispatch to [t_call None ctt] (which routes
456+
* via [t_call]'s (FbdHoareF, FbdHoareS) arm to [t_bdhoare_call]), then
457+
* re-generalize over the abstracted idents in the residual goals.
458+
*
459+
* Unlike the hoare bwd variant, we do not elaborate a [t_hoare_seq]
460+
* splitting the prefix from the call: the bdhoare seq variant requires
461+
* an additional probability split which we cannot infer here. As a
462+
* result the user gets the same shape of subgoals that plain
463+
* [call (lemma)] would produce, but with program-variable arguments
464+
* handled by ecall's abstraction machinery.
465+
*)
466+
let t_ecall_bdhoare_bwd ((cttpt, _) : proofterm * form) (tc : tcenv1) =
467+
let hyps = FApi.tc1_hyps tc in
468+
let env = EcEnv.LDecl.toenv hyps in
469+
let concl = destr_bdHoareS (FApi.tc1_goal tc) in
470+
let m = fst (concl.bhs_m) in
471+
let call, _ = pf_last_call !!tc concl.bhs_s in
472+
473+
let pvs = PT.collect_pvars_from_pt cttpt in
474+
let ids, _, pvs_as_inv, subst = abstract_pvs hyps [m] pvs in
475+
476+
let cttpt =
477+
let pt_head, pt_args =
478+
match cttpt with
479+
| PTApply { pt_head; pt_args } -> (pt_head, pt_args)
480+
| _ -> assert false in
481+
let pt_args = List.map (PT.subst_pv_pt_arg env subst) pt_args in
482+
PTApply { pt_head; pt_args } in
483+
484+
let cttpt, ctt = EcLowGoal.LowApply.check `Elim cttpt (`Hyps (hyps, !!tc)) in
485+
486+
let ctt =
487+
EcReduction.h_red_opt EcReduction.full_red hyps ctt
488+
|> odfl ctt in
489+
490+
let ids_subst =
491+
List.fold_left2
492+
(fun s (id, _) pv -> EcSubst.add_flocal s id (inv_of_inv pv))
493+
EcSubst.empty ids pvs_as_inv in
494+
495+
let fpre, fpost =
496+
let hf = destr_bdHoareF ctt in
497+
(ss_inv_rebind (bhf_pr hf) m).inv, (ss_inv_rebind (bhf_po hf) m).inv
498+
in
499+
500+
let post =
501+
EcPhlCall.compute_hoare_call_post
502+
hyps m (fpre, POE.empty fpost) call
503+
(POE.empty (bhs_po concl).inv) in
504+
let post = EcSubst.subst_form ids_subst post in
505+
506+
(* Trivial probability split for FHeq with bound 1%r (lossless body):
507+
pR = true, f1=f2=1%r, g1=g2=0%r. Yields:
508+
- cond_phi : f_hoareS pre s1 post (user-level prefix, as hoare)
509+
- condf1 : pre s1 true 1%r (lossless prefix, trivial for det. code)
510+
- condf2 : phi s2 bhs_po 1%r (suffix bdhoare, target of t_call)
511+
- condg1 : pre s1 false 0%r (trivial)
512+
- condbd : 1*1+0*0 = bd (trivial when bd=1%r)
513+
- condnm : forall r1 r2 ... (trivial) *)
514+
let seq_info =
515+
let phi = { m; inv = post } in
516+
let pR = { m; inv = f_true } in
517+
let f1 = { m; inv = f_r1 } in
518+
let f2 = { m; inv = f_r1 } in
519+
let g1 = { m; inv = f_r0 } in
520+
let g2 = { m; inv = f_r0 } in
521+
(phi, pR, f1, f2, g1, g2)
522+
in
523+
524+
let tc = EcPhlSeq.t_bdhoare_seq (GapBefore cpos1_last) seq_info tc in
525+
(* Subgoal order from t_bdhoare_seq (with f1≠0, f2≠0, g1=0):
526+
[cond_phi; condf1; condf2; condg1; condbd; condnm]
527+
We apply the exists+intros+t_call pipeline to condf2 (the suffix).
528+
The intros chain leaves a single bdhoare goal on which t_call produces
529+
two subgoals (contract obligation + conseq); we then dispatch via
530+
t_seqsub. *)
531+
let condf2_tactic =
532+
FApi.t_seqs [
533+
t_hr_exists_intro_r pvs_as_inv;
534+
t_hr_exists_elim_r ~bound:(List.length ids);
535+
t_intros_i (List.fst ids);
536+
FApi.t_seqsub
537+
(EcPhlCall.t_call None ctt)
538+
[ EcLowGoal.Apply.t_apply_bwd_hi ~dpe:true cttpt;
539+
EcPhlAuto.t_auto ?conv:None; ];
540+
]
541+
in
542+
543+
(* t_bdhoare_seq_r auto-closes condnm via t_try, so the count is 5 (or 6 if
544+
that auto fails). Use t_onalli with an index-based dispatcher to be
545+
robust to either count. Order (0-indexed):
546+
0 -> cond_phi (HOARE prefix): lift to BDHOARE [pre ==> phi] FHeq 1%r
547+
via t_hoareS_conseq_bdhoare. This is sound under losslessness of
548+
the prefix — which the user proves as part of the residual goal.
549+
Subsequent ecalls then dispatch through our bdhoare arm and accept
550+
phoare contracts.
551+
2 -> condf2 (suffix call dance)
552+
others -> auto (trivial bound conditions). *)
553+
let tc =
554+
FApi.t_onalli
555+
(fun i ->
556+
if i = 0 then EcPhlConseq.t_hoareS_conseq_bdhoare
557+
else if i = 2 then condf2_tactic
558+
else EcPhlAuto.t_auto ?conv:None)
559+
tc
560+
in
561+
562+
tc
563+
564+
(* -------------------------------------------------------------------- *)
565+
let process_ecall_bdhoare
566+
(dir : APT.pdirection)
567+
(pterm : APT.pecall)
568+
(tc : tcenv1)
569+
=
570+
if dir <> `Backward then
571+
tc_error !!tc "forward ecall on bdHoare/phoare goals is not supported";
572+
573+
let (ctt_path, ctt_tvi, ctt_args) = pterm in
574+
let hyps = FApi.tc1_hyps tc in
575+
let concl = destr_bdHoareS (FApi.tc1_goal tc) in
576+
577+
(* Type-check contract (lemma) - apply it fully to find the bdHoare contract *)
578+
let ptenv = PT.ptenv_of_penv (LDecl.push_active_ss concl.bhs_m hyps) !!tc in
579+
let contract = PT.process_pterm ptenv (APT.FPNamed (ctt_path, ctt_tvi)) in
580+
let contract, _ = PT.process_pterm_args_app contract ctt_args in
581+
let contract = PT.apply_pterm_to_max_holes hyps contract in
582+
583+
assert (PT.can_concretize contract.PT.ptev_env);
584+
let contract = PT.concretize contract in
585+
586+
let call, _ = pf_last_call !!tc concl.bhs_s in
587+
588+
check_contract_type
589+
~phoare:true ~noexn:false ~loc:(L.loc ctt_path) ~name:(L.unloc ctt_path)
590+
!!tc hyps (`Single call) (snd contract);
591+
592+
t_ecall_bdhoare_bwd contract tc
593+
450594
(* -------------------------------------------------------------------- *)
451595
let process_ecall_hoare
452596
(dir : APT.pdirection)
@@ -624,7 +768,12 @@ let process_ecall
624768
tc_error !!tc "cannot provide a side for Hoare goals";
625769
process_ecall_hoare dir pterm tc
626770

771+
| FbdHoareS _ ->
772+
if Option.is_some oside then
773+
tc_error !!tc "cannot provide a side for bdHoare/phoare goals";
774+
process_ecall_bdhoare dir pterm tc
775+
627776
| FequivS _ ->
628777
process_ecall_equiv dir oside pterm tc
629778

630-
| _ -> tc_error_noXhl ~kinds:[`Hoare `Stmt; `Equiv `Stmt] !!tc
779+
| _ -> tc_error_noXhl ~kinds:[`Hoare `Stmt; `PHoare `Stmt; `Equiv `Stmt] !!tc

0 commit comments

Comments
 (0)