-
Notifications
You must be signed in to change notification settings - Fork 232
New issue
Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.
By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.
Already on GitHub? Sign in to your account
Inlining of typeclass methods #2986
base: master
Are you sure you want to change the base?
Conversation
70b24f0
to
9cd9d31
Compare
I've updated this PR quite a bit.
would work,as the
|
The normalizer change leads to several regressions in Vale. They mostly seem related to the Also Pulse needs a slight patch: diff --git a/lib/steel/pulse/Pulse.Class.BoundedIntegers.fst b/lib/steel/pulse/Pulse.Class.BoundedIntegers.fst
index 700d4229..c2e760d6 100644
--- a/lib/steel/pulse/Pulse.Class.BoundedIntegers.fst
+++ b/lib/steel/pulse/Pulse.Class.BoundedIntegers.fst
@@ -63,6 +63,7 @@ let safe_add (#t:eqtype) {| c: bounded_unsigned t |} (x y : t)
else (
if x <= max_bound
then (
+ assert (fits #t (v (max_bound #t) - v x));
if (y <= max_bound - x)
then Some (x + y)
else None
@@ -78,7 +79,10 @@ let safe_mod (#t:eqtype) {| c: bounded_unsigned t |} (x : t) (y : t)
then Some (x % y)
else (
if y <= max_bound
- then Some (x % y)
+ then (
+ assert (fits #t (v x % v y));
+ Some (x % y)
+ )
else None
) |
c6bed58
to
03394e2
Compare
03394e2
to
be43411
Compare
Finally got an everest green with this PR. I added a switch for the unifier to be able to unfold strict definitions during unification, otherwise with something like: [@@strict_on_arguments [0]]
let f (x:t) = match x with | Mk y -> y
let g (x:t) = match x with | Mk y -> y it would fail to unify This did require a patch in hacl-star to not mark
Patch is: diff --git a/providers/evercrypt/fst/EverCrypt.Hash.fst b/providers/evercrypt/fst/EverCrypt.Hash.fst
index 4aa69da94c..1fe022c26b 100644
--- a/providers/evercrypt/fst/EverCrypt.Hash.fst
+++ b/providers/evercrypt/fst/EverCrypt.Hash.fst
@@ -217,7 +217,7 @@ let frame_invariant #a l s h0 h1 =
assert (repr_eq (repr s h0) (repr s h1))
inline_for_extraction noextract
-[@@strict_on_arguments [0]]
let alloca a =
let s: state_s a =
match a with I'm not sure this is correct.. but I don't see any calls to After that, this PR also causes a dist-diff in hacl-star. The diffstat (just for gcc-compatible) is
Full diff can be seen here: http://sprunge.us/YGc4At . To me it seems like an improvement since there's less duplicated code... but not really sure. |
Another thing: I find the logic in let head_matches_delta env smt_ok t1 t2 : (match_result & option (typ&typ)) =
let maybe_inline t =
let head = U.head_of (unrefine env t) in
if Env.debug env <| Options.Other "RelDelta" then
BU.print2 "Head of %s is %s\n" (Print.term_to_string t) (Print.term_to_string head);
match (U.un_uinst head).n with
| Tm_fvar fv ->
begin
match Env.lookup_definition
[Env.Unfold delta_constant;
Env.Eager_unfolding_only]
env
fv.fv_name.v
with
| None ->
if Env.debug env <| Options.Other "RelDelta" then
BU.print1 "No definition found for %s\n" (Print.term_to_string head);
None
| Some _ ->
let basic_steps =
[Env.UnfoldUntil delta_constant;
Env.Weak;
Env.HNF;
Env.Primops;
Env.Beta;
Env.Eager_unfolding;
Env.Iota]
in
let steps =
if smt_ok then basic_steps
else Env.Exclude Env.Zeta::basic_steps
//NS: added this to prevent unifier looping
//see bug606.fst
//should we always disable Zeta here?
in
let t' = norm_with_steps "FStar.TypeChecker.Rel.norm_with_steps.1" steps env t in
if U.eq_tm t t' = U.Equal //if we didn't inline anything
then None
else let _ = if Env.debug env <| Options.Other "RelDelta"
then BU.print2 "Inlined %s to %s\n"
(Print.term_to_string t)
(Print.term_to_string t') in
Some t'
end
| _ -> None
in
let success d r t1 t2 = (r, (if d>0 then Some(t1, t2) else None)) in
let fail d r t1 t2 = (r, (if d>0 then Some(t1, t2) else None)) in
(*
* AR: When we delta-unfold the terms below, it may happen that application of an fv with
* delta depth say 1 doesn't unfold because it is marked with strict_on_arguments
* To prevent looping in that case, we make sure that we have made progress
* in an unfolding call to the normalizer
* This made_progress function is checking that we have made progress in unfolding t to t'
* See #2184
*)
let made_progress t t' =
let head, head' = U.head_and_args t |> fst, U.head_and_args t' |> fst in
not (U.eq_tm head head' = U.Equal) in
let rec aux retry n_delta t1 t2 =
let r = head_matches env t1 t2 in
if Env.debug env <| Options.Other "RelDelta" then
BU.print3 "head_matches (%s, %s) = %s\n"
(Print.term_to_string t1)
(Print.term_to_string t2)
(string_of_match_result r);
let reduce_one_and_try_again (d1:delta_depth) (d2:delta_depth) =
let d1_greater_than_d2 = Common.delta_depth_greater_than d1 d2 in
let t1, t2, made_progress =
if d1_greater_than_d2
then let t1' = normalize_refinement [Env.UnfoldUntil d2; Env.Weak; Env.HNF] env t1 in
t1', t2, made_progress t1 t1'
else let t2' = normalize_refinement [Env.UnfoldUntil d1; Env.Weak; Env.HNF] env t2 in
t1, t2', made_progress t2 t2' in
if made_progress
then aux retry (n_delta + 1) t1 t2
else fail n_delta r t1 t2
in
let reduce_both_and_try_again (d:delta_depth) (r:match_result) =
match Common.decr_delta_depth d with
| None -> fail n_delta r t1 t2
| Some d ->
let t1' = normalize_refinement [Env.UnfoldUntil d; Env.Weak; Env.HNF] env t1 in
let t2' = normalize_refinement [Env.UnfoldUntil d; Env.Weak; Env.HNF] env t2 in
if made_progress t1 t1' &&
made_progress t2 t2'
then aux retry (n_delta + 1) t1' t2'
else fail n_delta r t1 t2
in
match r with
| MisMatch (Some (Delta_equational_at_level i), Some (Delta_equational_at_level j)) when (i > 0 || j > 0) && i <> j ->
reduce_one_and_try_again (Delta_equational_at_level i) (Delta_equational_at_level j)
| MisMatch(Some (Delta_equational_at_level _), _)
| MisMatch(_, Some (Delta_equational_at_level _)) ->
if not retry then fail n_delta r t1 t2
else begin match maybe_inline t1, maybe_inline t2 with
| None, None -> fail n_delta r t1 t2
| Some t1, None -> aux false (n_delta + 1) t1 t2
| None, Some t2 -> aux false (n_delta + 1) t1 t2
| Some t1, Some t2 -> aux false (n_delta + 1) t1 t2
end
| MisMatch(Some d1, Some d2) when (d1=d2) -> //incompatible
reduce_both_and_try_again d1 r
| MisMatch(Some d1, Some d2) -> //these may be related after some delta steps
reduce_one_and_try_again d1 d2
| MisMatch _ ->
fail n_delta r t1 t2
| _ ->
success n_delta r t1 t2 in
let r = aux true 0 t1 t2 in
if Env.debug env <| Options.Other "RelDelta" then
BU.print4 "head_matches_delta (%s, %s) = %s (%s)\n"
(Print.term_to_string t1)
(Print.term_to_string t2)
(string_of_match_result (fst r))
(if Option.isNone (snd r)
then "None"
else snd r
|> must
|> (fun (t1, t2) ->
Print.term_to_string t1
^ "; "
^ Print.term_to_string t2));
r My main confusions are: |
be43411
to
4a55315
Compare
This adds some attributes and normalization tweaks to unfold more of the indirections introduced by typeclasses. The idea is to try to unfold methods when their dictionary is concrete, but some work remains to be done:
1- We should only unfold an instance in that case, currently (with this patch) they would be unfolded (exploded into a record) unconditionally
2- Perhaps the way to achieve that is by tweaking the
strict_on_arguments
attribute to fully normalize the relevant argument, triggering unfolding, and drop the tcnorm attr from the instances.Not merging this yet, just posting to keep track of it.
@nikswamy