Skip to content

Commit 330ad7b

Browse files
FissoreDFissoreD
committed
[TC] refactor of build-eta-llam-links
1 parent e5c3f66 commit 330ad7b

File tree

4 files changed

+54
-76
lines changed

4 files changed

+54
-76
lines changed

‎apps/tc/elpi/compile_goal.elpi‎

Lines changed: 3 additions & 39 deletions
Original file line numberDiff line numberDiff line change
@@ -35,11 +35,6 @@ namespace tc {
3535
pred maybe-eta i:term.
3636
maybe-eta (fun _ _ B) :- pi x\ maybe-eta-aux (B x) [x].
3737

38-
pred split-pf i:list term, i:list term, o:list term, o:list term.
39-
split-pf [] _ [] [] :- !.
40-
split-pf [X|Xs] Old [X|Ys] L :- name X, not (std.mem! Old X), !, split-pf Xs [X|Old] Ys L.
41-
split-pf Xs _ [] Xs.
42-
4338
pred used i:term, i:term.
4439
used X (uvar _ S) :- std.mem! S X, !.
4540
used X (fun _ _ Bo) :- pi x\ used X (Bo x).
@@ -86,41 +81,10 @@ namespace tc {
8681
compile-full-aux Ty L Ty' LTy,
8782
compile-full-aux-close Bo Ty LTy Bo' L'.
8883

89-
% NOTE: when compiling t = (app [X, x, y]) and [x,y] are distinct_names,
90-
% then the coq variable has not [x,y] in scope, it is applied to
91-
% them. Note also that t is a problematic term that cannot be
92-
% exposed to the else unification algorithm.
93-
% The solution is to build the following links:
94-
% X =η (λa.Y a)
95-
% a |- Y a =η (λb.Z a b)
96-
% and expose a variable W at toplevel having Z has head and [x, y]
97-
% as scope
98-
99-
% NOTE: when compiling t = (app [X, a, x]) where a is a constant and x a
100-
% name, we build a llam link.
101-
% The link will be: T x =L X a x
102-
% the exposed variable in the term will be T x
103-
104-
% NOTE: here a combination of eta and llam:
105-
% let t = (app [X x y, z, c, w, d]) where X is a coq var with x and
106-
% y in scope, z and w are names and c, d are constants.
107-
% In this case, the links should be:
108-
% X x y =η (λa.Y x y a)
109-
% a |- Z x y a w =L (app[Y x y a, c w d])
110-
% The returned variable is Z x y a w
111-
112-
% Link for beta-redex (Uvar in PF)
113-
% BUILD CHAIN OF LINKS-ETA from X to V...
11484
% TODO: to avoid too many chain for the same var, maybe pass a list into the fold
115-
compile-full-aux (app [(uvar _ Scope as V) | S] as T) L G' L'' :- !,
116-
% By construction the scope of a uvar is a list of distinct name
117-
std.fold-map S L compile-full-aux S' L', % LS = Links built for S
118-
coq.typecheck V Ty ok,
119-
split-pf S' Scope PF NPF,
120-
free-names T Names,
121-
tc.link.build-eta-llam-links V Scope Ty Names PF NPF L' G'' L'',
122-
prune G' Names,
123-
var G' G'' Names.
85+
compile-full-aux (app [(uvar _ _ as V) | S]) L G' L'' :- !,
86+
std.fold-map S L compile-full-aux S' L', % L' = Links built for S
87+
tc.link.build-eta-llam-links (app [V|S']) L' G' L''.
12488

12589
compile-full-aux (app L) A (app L1) A1 :- !, std.fold-map L A compile-full-aux L1 A1.
12690

‎apps/tc/elpi/compile_instance.elpi‎

Lines changed: 6 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -119,7 +119,7 @@ namespace tc {
119119
(pi x\ is-name x => precompile-aux is_neg_fix (B x) N' (B' x) M).
120120

121121
precompile-aux _ (app [X|XS]) N (tc.maybe-llam-tm (app [app[X | PF] | NPF1]) Scope) (s M) :-
122-
if (is-uvar X) (Sc = []) (var X _ Sc), split-pf XS Sc PF NPF,
122+
is-uvar X, split-pf XS [] PF NPF,
123123
not (NPF = []), !, % else XS is a list of distinct names, i.e. `app [X|XS]` is in PF
124124
free-var Scope,
125125
std.fold-map NPF N (precompile-aux is_neg_fix) NPF1 M.
@@ -237,27 +237,11 @@ namespace tc {
237237
std.fold-map NPF (pr XS L1) decompile-term-aux Tl (pr XS' L2),
238238
NL = tc.link.llam Y (app [Hd|Tl]).
239239

240-
% Maybe-llam when H is a hole appearing in the shelved goals
241-
% This happens when the instance to be compiled comes from the context
242-
% Example: Goal exists (X : T1 -> T2), forall a, c (X a) -> ...
243-
% intros; eexists. (* In the context we have the instance `H: c (?X a)` *)
244-
decompile-term-aux (tc.maybe-llam-tm (app[app[V | PF] | NPF] as T) S_) L G'' (pr XS' L'') :- !,
245-
var V _ Scope, !,
246-
std.fold-map NPF L decompile-term-aux NPF' (pr XS' L'),
247-
free-names T Names,
248-
coq.typecheck V Ty ok,
249-
tc.link.build-eta-llam-links V Scope Ty Names PF NPF' L' G' L'',
250-
prune G'' Names,
251-
var G'' G' Names.
252-
253-
% HO var when H is a hole appearing in the shelved goals
254-
decompile-term-aux (app [V|PF] as T) (pr XS' L') G'' (pr XS' L'') :-
255-
var V _ Scope, !,
256-
free-names T Names,
257-
coq.typecheck V Ty ok,
258-
tc.link.build-eta-llam-links V Scope Ty Names PF [] L' G' L'',
259-
prune G'' Names,
260-
var G'' G' Names.
240+
% Here we have a coq evar applied to some terms. In this case, we build
241+
% eta-llam links after the decompilation of S.
242+
decompile-term-aux (app [(uvar _ _ as V)|S]) PR H (pr XS L') :- !,
243+
std.fold-map S PR decompile-term-aux S' (pr XS L),
244+
tc.link.build-eta-llam-links (app [V|S']) L H L'.
261245

262246
decompile-term-aux (fun Name Ty Bo) (pr XS L) (fun Name Ty' Bo') (pr XS2 L3) :- !,
263247
(pi x\ is-name x => decompile-term-aux (Bo x) (pr XS []) (Bo' x) (pr XS1 (L1x x))),

‎apps/tc/elpi/link.elpi‎

Lines changed: 44 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -9,28 +9,58 @@ namespace tc {
99
(pi X H L Ign\ fold-map X L X [H|L] :- var X H Ign, !) =>
1010
fold-map T [] _ R.
1111

12-
% [build-eta-llam-links LHS Scope Ty Names PF NPF OldLinks NewVar NewLinks]
13-
% Builds the eta/llam links at runtime for a term having the shape
14-
% `app[(uvar X Scope as V) | L]`.
15-
% LHS should be V, Scope the scope of V, TODO: finish to document this...
12+
pred split-pf i:list term, i:list term, o:list term, o:list term.
13+
split-pf [] _ [] [] :- !.
14+
split-pf [X|Xs] Old [X|Ys] L :- name X, not (std.mem! Old X), !, split-pf Xs [X|Old] Ys L.
15+
split-pf Xs _ [] Xs.
16+
17+
% [build-eta-llam-links.aux LHS Scope Ty Names PF NPF OldLinks NewVar NewLinks]
1618
:index(_ _ _ _ 3)
17-
% TODO: the argument Ty is unused, i.e. the binders of the eta links have no type...
18-
% LHS Scope Ty Names PF NPF OldLinks NewVar
19-
pred build-eta-llam-links i:term, i:list term, o:term, i:list term, i:list term, i:list term, i:list prop, o:term, o:list prop.
20-
build-eta-llam-links LHS _ _ Names [] NPF OL HD [tc.link.llam T (app [LHS | NPF]) | OL] :- !,
19+
pred build-eta-llam-links.aux i:term, i:list term, o:term, i:list term, i:list term, i:list term, i:list prop, o:term, o:list prop.
20+
build-eta-llam-links.aux LHS _ _ Names [] NPF OL HD [llam T (app [LHS | NPF]) | OL] :- !,
2121
std.assert! (not (NPF = [])) "[TC] NPF List should not be empty",
2222
prune T Names,
2323
var T HD _.
24-
build-eta-llam-links LHS SC (prod _ Ty _) _ [X] [] OL HD [tc.link.eta LHS (fun `_` Ty (x\ V x)) | OL] :- !,
24+
build-eta-llam-links.aux LHS SC (prod _ Ty _) _ [X] [] OL HD [eta LHS (fun `_` Ty (x\ V x)) | OL] :- !,
2525
prune V SC, var (V X) HD _.
26-
build-eta-llam-links LHS SC (prod _ Ty Bo) Names [X|XS] NPF OL HD [tc.link.eta LHS (fun `_` Ty (x\ LHS' x)) | L] :- !,
26+
build-eta-llam-links.aux LHS SC (prod _ Ty Bo) Names [X|XS] NPF OL HD [eta LHS (fun `_` Ty (x\ LHS' x)) | L] :- !,
2727
% TODO: unfold Ty if needed...
2828
std.append SC [X] SC',
29-
prune LHS' SC, build-eta-llam-links (LHS' X) SC' (Bo X) Names XS NPF OL HD L.
30-
build-eta-llam-links LHS SC Ty Names ([_|_] as PF) NPF OL HD L :-
29+
prune LHS' SC, build-eta-llam-links.aux (LHS' X) SC' (Bo X) Names XS NPF OL HD L.
30+
build-eta-llam-links.aux LHS SC Ty Names ([_|_] as PF) NPF OL HD L :-
3131
Ty' = prod _ _ _, coq.unify-eq Ty Ty' ok, !,
32-
build-eta-llam-links LHS SC Ty' Names PF NPF OL HD L.
33-
32+
build-eta-llam-links.aux LHS SC Ty' Names PF NPF OL HD L.
33+
34+
% [build-eta-llam-links T OldLinks X NewLinks]
35+
% T = app[(uvar _ Scope) | S] this term is problematic and asks for the
36+
% creation of eta- and/or llam-links. Below some examples:
37+
38+
% eta: when compiling t = (app [X, x, y]) and [x,y] are distinct_names, then
39+
% the coq variable has not [x,y] in scope: it is applied to them.
40+
% The solution is to build the following links:
41+
% NewLinks = [X =η (λa.Y a), a |- Y a =η (λb.Z a b)]
42+
% and the exposed variable is G, given by `var G Z [x, y]`
43+
44+
% llam: when compiling t = (app [X, a, x]) where a is a constant and x a
45+
% name, we build a llam link.
46+
% The link will be: NewLinks ] = [T x =L X a x]
47+
% and the exposed variable is G, given by `var G T [x]`
48+
49+
% eta-llam: here a combination of eta and llam:
50+
% let t = (app [X x y, z, c, w, d]) where X is a coq var with x and y
51+
% in scope, z and w are names and c, d are constants.
52+
% In this case, the links should be:
53+
% NewLinks = [X x y =η (λa.Y x y a), a |- Z x y a w =L (app[Y x y a, c w d])]
54+
% and the exposed variable is G, given by `var Z T [x, y, z, w]`
55+
pred build-eta-llam-links i:term, i:list prop, o:term, o:list prop.
56+
build-eta-llam-links (app[(uvar _ Scope as V) | S] as T) Links G NewLinks :- !,
57+
coq.typecheck V Ty ok,
58+
split-pf S Scope PF NPF,
59+
free-names T Names,
60+
build-eta-llam-links.aux V Scope Ty Names PF NPF Links LhsHd NewLinks,
61+
prune G Names,
62+
var G LhsHd Names.
63+
build-eta-llam-links T _ _ _ :- coq.error "[TC] invalid call to build-eta-llam-links:" T.
3464

3565
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3666
% ETA LINK %

‎apps/tc/tests/test.v‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -596,7 +596,7 @@ Module CoqUvar4.
596596
tc.precomp.instance {{c1 (fun x y => lp:X (lp:A x y) y)}} C _ _ _,
597597
Expected = app [{{c1}}, tc.maybe-eta-tm (fun _ _ Body1) _],
598598
Body1 = (x\ tc.maybe-eta-tm (fun _ _ (Body2 x)) [x]),
599-
Body2 = (x\y\ tc.maybe-llam-tm (app [app [X], (Y x y), y]) [y,x]),
599+
Body2 = (x\y\ app [X, (Y x y), y]),
600600
std.assert! (C = Expected) "[TC] invalid compilation".
601601
}}.
602602

0 commit comments

Comments
 (0)