conjunction work

parent 98b9d274
......@@ -122,7 +122,8 @@ caller(cc,Args,label(G,N),V,[L,LL]) :- !,
get_S(V,S),
set_S(V,0),
push_v(2,V),
L2=[[push-3]|L4],
get_P(V,P0).
L2=[[push-3,P0,_]|L4],
push_args_args(#f,Args,V,L4,LL2,_,_),
LL2 = [['goto-inst',G]|LL].
......
......@@ -21,6 +21,7 @@ collect_conj((X,Y),L,LL) :- !,
collect_conj(Y,L1,LL).
collect_conj(X,[X|LL],LL).
-trace.
-extended.
compile_conj0([],Tail,V,L) :- throw(#t).
......@@ -31,18 +32,25 @@ compile_conj0([X|Gs],Tail,V,L) :- var(X),!,
compile_conj0([call(X)|Gs],Tail,V,L).
compile_conj0([!|Gs],Tail,V,[L,LL]) :- !,
get_C(V,[[_,#t]|_]),
get_C(V,C),
(C=[[[P0,TagC2],_]|_];(get_P(V,P0),TagC2=false)),!,
write(aa(C)),nl,
set_P(V,P0),
C=[[_,#t]|_],
ifc(compile_conj0(Gs,Tail,V,[L1,LL]),E,
(
tfc(E),
(
E==#t ->
(Tail==#t -> L=[[cut],[cc]|LL] ; L=[[cut]|LL]);
(
Cut=[cut,P0,TagC2],
(Tail==#t -> L=[Cut,[cc,TagC2]|LL] ; L=[Cut|LL])
);
throw(c)
)
),
(
L=[[cut]|L1]
L=[[cut,P0,TagC2]|L1]
)).
compile_conj0([softie(A)|Gs],Tail,V,[L,LL]) :- !,
......@@ -56,7 +64,10 @@ compile_conj0([softie(A)|Gs],Tail,V,[L,LL]) :- !,
push_Q(3,V,Q),
(
Tail==#t ->
L=[[softie,A],[cc]|LL] ;
(
get_P(V,P0),
L=[[softie,A],[cc,P0]|LL]
);
L=[[softie,A]|LL]
)
);
......@@ -71,7 +82,8 @@ compile_conj0([softie(A)|Gs],Tail,V,[L,LL]) :- !,
)).
compile_conj0([(fail;false)|Gs],Tail,V,[L,LL]) :- !,
L=[[fail]|LL].
get_P(V,P0),
L=[[fail,P0]|LL].
compile_conj0([G|Gs],Tail,V,L) :- !,
link_l(L,L1,L2),
......@@ -90,11 +102,25 @@ compile_conj0([G|Gs],Tail,V,L) :- !,
tfc(E2),
(
E2==#t ->
(Tail==#t -> L2=[[[cc]|U],U] ; L2=[U,U]);
(
Tail==#t ->
(
get_P(V,P0),
L2=[[[cc,P0]|U],U]
);
L2=[U,U]
);
E2==c ->
L2=[[[cut],[fail]|U],U] ;
(
get_C(V,[[[P0,TagC2],_]|_]),
set_P(V,P0),
L2=[[[cut,P0,TagC2],[fail,TagC2]|U],U]
);
E2=softie(A) ->
L2=[[[softie,A],[fail]|U],U] ;
(
get_P(V,P0),
L2=[[[softie,A],[fail,P0]|U],U]
);
throw(E2)
)
))
......
......@@ -86,7 +86,7 @@ goal(X,Y,First,Lab,Tail,Out,A,Ae,Aq,S0,[U|UU],V,L,LL,LG,B2,LLX,P0,PP0,Q,QQ)
(
(nonvar(X),X=(G1->G2)) ->
(W=#t,XX=(call(G1),softie(A),collect_F(FF),G2)) ;
(W=#f,,XX=(X,newtag_F(FF),set_p(Q)))
(W=#f,XX=(X,newtag_F(FF),set_p(Q)))
),
set_P(V,ground(Lab)),
push_Q(3,V,Q),
......@@ -123,11 +123,17 @@ goal(X,Y,First,Lab,Tail,Out,A,Ae,Aq,S0,[U|UU],V,L,LL,LG,B2,LLX,P0,PP0,Q,QQ)
%pop_Q(1,V,_),
head_at_true(Qit,First,#f,A,C,Lab,Lab2,L,LX),
UU=[[0,_]],
get_C(V,[[[P0,TagC2],_]|_]),
(
Err==c ->
LLX=[[cut],[fail]|LL];
(
set_P(V,P0),
LLX=[[cut,P0,TagC2],[fail,TagC2]|LL]
);
LLX=LL
)
)
)
),
head_at_true(Qit,First,#f,A,C,Lab,Lab2,L,LX)
).
......
......@@ -32,14 +32,26 @@ zero(V) :- get_A(V,A),A=[[0|_]].
print([]).
print([X|L]) :- write(X),nl,print(L).
wrap(Code,[L,LL]) :-
wrap(Code,V,[L,LL]) :-
catch(Code,E,
(
tfc(E),
(
E==#t -> L=[[[cc]|LL],LL];
E==c -> L=[[[cut],[fail]|LL],LL];
L=[[[fail]|LL],LL]
E==#t ->
(
get_P(P0),
L=[[[cc,P0]|LL],LL]
);
E==c ->
(
get_C(V,[[[P0,TagC2],_]|_]),
set_P(V,P0),
L=[[[cut,P0,TagC2],[fail,TagC2]|LL],LL]
);
(
get_P(V,P0),
L=[[[fail,P0]|LL],LL]
)
)
)).
......@@ -60,7 +72,7 @@ compile_goal(Code,Iout,StackSize,Narg,Constants,Pretty) :- !,
(var(Constants) -> init_const ; true),
b_setval(pretty,#t),
make_state(0,[[0,_,_]],[],[[0,_]],0,0,0,0,0,[HC,HV],[],V),
wrap(compile_goal(Code,#t,V,[L,[]]),[L,[]]),!,
wrap(compile_goal(Code,#t,V,[L,[]]),V,[L,[]]),!,
print(L),nl,!,
get_M(V,StackSize),
handle_all(L,LL),
......@@ -81,8 +93,10 @@ compile_goal(set_p(Q),Tail,V,[L,LL]) :- !,
compile_goal(!,Tail,V,[L,LL]) :- !,
check_tail(Tail),
(Tail==#t -> L=[[cut],[cc]|LL] ; L=[[cut]|LL]).
get_C(V,[[[P0,TagC2],_]|_]),
set_P(V,P0),
(Tail==#t -> L=[[cut,P0,TagC2],[cc,TagC2]|LL] ; L=[[cut,P0,TagC2]|LL])
.
compile_goal(softie(A),Tail,V,[L,LLL]) :- !,
check_tail(Tail),
tail(Tail,V,LL,LLL),
......@@ -169,12 +183,12 @@ compile_goal((F(|ASrgs) :- Goal),Tail,V,L) :- !,
push_v(N,V),
get_A(V,[[0|_]|_]) ->
wrap(compile_goal((move_args(0,N),begin_att,Impr,end_att,Goal),
Tail,V,L),L);
wrap(compile_goal((move_args(0,N),begin_att,Impr,Goal),Tail,V,L),L).
Tail,V,L),V,L);
wrap(compile_goal((move_args(0,N),begin_att,Impr,Goal),Tail,V,L),V,L).
compile_goal((F :- Goal),Tail,V,L) :- !,
push_v(4,V),
wrap(compile_goal((pop(4),Goal),Tail,V,L),L).
wrap(compile_goal((pop(4),Goal),Tail,V,L),V,L).
compile_goal(newtag_F(F),Tail,V,[L,LL]) :- !,
check_tail(Tail),
......@@ -332,7 +346,7 @@ compile_goal(call_(X,A0,Al,C0,Pre,Post,LP),Tail,V,[L,LL]) :- !,
set_AA(V,A),
LLX = Post,
set_C(V,C),
(Tail=#t -> LP=[[cc]|LL] ; LP=LL).
LP=LL.
compile_goal((X =.. Y),Tail,V, L, LL) :- !,
(var_p(X);constant(X)) ->
......@@ -410,45 +424,42 @@ compile_goal(\\+\\+\\+X,Tail,V,[L,LL]) :- !,
compile_goal(\\+X,Tail,V,[L,LL]).
compile_goal(\\+\\+X,Tail,V,[L,LLL]) :- !,
get_P(V,P0),
(P0=ground(_) -> PP=1 ; PP=0),
A0 = [P0,TagC2],
tail(Tail,V,LL,LLL),
L=LX,
get_QAESBB2(V,Q,AA,E,S,B,B2),
set_QAE(V,[],[[0|_]],0),
var_p(VP),
var_p(VS),
var_p(VT),
(PP=0 -> var_p(VP) ; true),
get_F(V,F),
add_var_f(VP,V,F,TagP1),
add_var_f(VS,V,F,TagS1),
add_var_f(VT,V,F,TagT1),
(PP=0 -> add_var_f(VP,V,F,TagC1) ; true),
compile_goal(call_(X,A,Ad,[C0|_],Pre,Post,LP),#f,V,[LX,LLX]),
set_P(V,P0),
add_var_f(VP,V,F,TagP2),
add_var_f(VS,V,F,TagS2),
add_var_f(VT,V,F,TagT2),
(PP=0 -> add_var_f(VP,V,F,TagC2) ; true),
set_QAESBB2(V,Q,AA,E,S,B,B2),
(A=[[0|_]|_] -> Tp is 0 ; Tp is 1),
Ad=[A0,Cut_p],
(
A==#t ->
(
Cut_p == #t ->
(
Tp == 0 ->
PP == 0 ->
(
Pre = ['newframe-ps', A0, TagP1, TagS1],
Post = [['goto-inst' , Out],
[label , A0],
['fail-psc' , TagP2, TagS2, C0],
[label , Out],
['unwind-psc', TagP2, TagS2, C0]|LP]
Pre = ['newframe-ps', TagP1, TagS1],
Post = [['unwind-ps', TagP2, TagS2]|LP]
) ;
(
Pre = ['newframe-pst', A0, TagP1, TagS1, TagT1],
Post = [['goto-inst' , Out],
[label , A0],
['fail-psc' , TagP2, TagS2, C0],
[label , Out],
['unwind-psct', TagP2, TagS2, TagT2, C0]|LP]
Pre = ['newframe-psc', TagP1, TagS1, TagC1],
Post = [['unwind-ps', TagP2, TagS2]|LP]
)
) ;
(
......@@ -458,20 +469,23 @@ compile_goal(\\+\\+X,Tail,V,[L,LLL]) :- !,
Post = [['unwind-ps' , TagP2, TagS2]|LP]
) ;
(
Pre = ['newframe-pst', A0, TagP1, TagS1, TagT1],
Post = [['unwind-pst' , A0, TagP2, TagS2, TagT2]|LP]
Pre = ['newframe-ps', TagP1, TagS1],
Post = [['unwind-ps' , TagP2, TagS2]|LP]
)
)
);
(
Cut_p == #t ->
(
Pre = ['store-p' , A0, TagP1],
Post = [['goto-inst', Out ],
[label , A0 ],
['fail-pc' , TagP2, C ],
[label , Out ],
['restore-c', C0 ]|LP]
PP=0 ->
(
Pre = ['newframe-pc', TagP1, TagC1],
Post = ['unwind-p', TagP1]
);
(
Pre = ['newframe-p', TagP1],
Post = ['unwind-p', TagP1]
)
) ;
(
Pre = [true],
......
......@@ -32,6 +32,26 @@ chech_push(F) :-
-extended.
handle([true],I,I,L,L) :- !.
handle([cut,P,[[S1,V1,Q1],N1,F1|_]],I,II,L,LL) :- !,
(
P=ground(_) ->
true;
(
new_var(V1,Q1,S),
(V1=[VC1|_] -> E1=var(VC1) ; E1=svar(V1)),
cut(P,E1,I,II,L,LL)
)
).
handle([cut,P,false],I,II,L,LL) :- !,
(
P=ground(_) ->
true;
(
cut(P,false,I,II,L,LL)
)
).
handle(['cc',P],I,II,L,LL) :- !,
'cc-call'(P,I,II,L,LL).
......@@ -175,13 +195,45 @@ handle(['unwind-light-tail',(U,[[[S,V,Q],N,F|_],_]),QQ],I,II,L,LL) :- !,
handle([(X,('goto-inst';'store-state';'post-q')),N],I,II,L,LL) :- !,
X(N,I,II,L,LL).
handle([(X,('unwind-tail')),[[[S1,V1,Q1],N1,F1|_],[[S2,V2,Q2],N2,F2|_]]],I,II,L,LL) :- !,
handle([(X,('unwind-tail')),
[[[S1,V1,Q1],N1,F1|_],
[[S2,V2,Q2],N2,F2|_]]],I,II,L,LL) :- !,
new_var(V1,Q1,S1),
(V1=[VC1|_] -> E1=var(VC1) ; E1=svar(V1)),
new_var(V2,Q2,S2),
(V2=[VC2|_] -> E2=var(VC2) ; E2=svar(V2)),
X(E1,E2,I,II,L,LL).
handle([(X,('unwind-p')),
[[S1,V1,Q1],N1,F1|_]] ,I,II,L,LL) :- !,
new_var(V1,Q1,S1),
(V1=[VC1|_] -> E1=var(VC1) ; E1=svar(V1)),
X(E1,I,II,L,LL).
handle([(X,('newframe-ps';'newframe-pc';
'unwind-ps';'unwind-pc')),
[[S1,V1,Q1],N1,F1|_],
[[S2,V2,Q2],N2,F2|_]] ,I,II,L,LL) :- !,
new_var(V1,Q1,S1),
(V1=[VC1|_] -> E1=var(VC1) ; E1=svar(V1)),
new_var(V2,Q2,S2),
(V2=[VC2|_] -> E2=var(VC2) ; E2=svar(V2)),
X(E1,E2,I,II,L,LL).
handle([(X,('newframe-psc')),
[[S1,V1,Q1],N1,F1|_],
[[S2,V2,Q2],N2,F2|_],
[[S3,V3,Q3],N3,F3|_]] ,I,II,L,LL) :- !,
new_var(V1,Q1,S1),
(V1=[VC1|_] -> E1=var(VC1) ; E1=svar(V1)),
new_var(V2,Q2,S2),
(V2=[VC2|_] -> E2=var(VC2) ; E2=svar(V2)),
new_var(V3,Q3,S3),
(V3=[VC3|_] -> E3=var(VC3) ; E3=svar(V3)),
X(E1,E2,E3,I,II,L,LL).
handle([(F,(newframe ; 'newframe-negation' ; 'post-negation'
; 'unwind' ; 'unwind-negation'
......@@ -195,27 +247,14 @@ handle([(F,(newframe ; 'newframe-negation' ; 'post-negation'
F(E1,E2,B,I,II,L,LL).
handle([(F,('newframe-ps';'unwind-ps';'unwind-psc';'store-ps';'fail-psc'))
,A0,[[S1,V1,Q1],N1,F1|_],[[S2,V2,Q2],N2,F2|_]],I,II,L,LL) :-
handle([(F,('store-ps';'fail-psc')),
A,[[S1,V1,Q1],N1,F1|_],[[S2,V2,Q2],N2,F2|_]],I,II,L,LL) :-
!,
new_var(V1,Q1,S1),
new_var(V2,Q2,S2),
(V1=[V1C|_] -> E1=var(V1C) ; E1=svar(V1)),
(V2=[V2C|_] -> E2=var(V2C) ; E2=svar(V2)),
F(A0,E1,E2,I,II,L,LL).
handle([(F,('newframe-pst';'unwind-psct';'unwind-pst'))
,A0,[[S1,V1,Q1],N1,F1|_],
[[S2,V2,Q2],N2,F2|_],
[[S2,V2,Q2],N2,F2|_]],I,II,L,LL) :-
!,
new_var(V1,Q1,S1),
new_var(V2,Q2,S2),
new_var(V3,Q3,S3),
(V1=[V1C|_] -> E1=var(V1C) ; E1=svar(V1)),
(V2=[V2C|_] -> E2=var(V2C) ; E2=svar(V2)),
(V3=[V3C|_] -> E3=var(V3C) ; E3=svar(V3)),
F(A0,E1,E2,E3,I,II,L,LL).
F(E1,E2,I,II,L,LL).
handle(['store-p',A0,[[S1,V1,Q1],N1,F1|_]],I,II,L,LL) :-
!,
......
......@@ -63,7 +63,7 @@
<cc>))))
(<define> (touch_Q e v)
(<pp> `(touch ,e))
; (<pp> `(touch ,e))
(<recur> lp ((l (<lookup> (vector-ref (<lookup> v) nq))))
(if (pk 'touch (pair? l))
(<and>
......
......@@ -15,20 +15,24 @@
#:use-module (logic guile-log vm utils)
#:use-module (logic guile-log vm fkn)
#:export (in-call cc-call in-tailcall in-post-call post-unicall
push-3 pushtail-3 handle-spcc))
push-3 pushtail-3 handle-spcc cut))
(compile-prolog-string
"
'handle-spcc'(C,I,I,L,LL) :-
NCC is C,
NP is C + 1,
NS is C + 2,
NVEC is C + 3,
gset(vec,svar(NVEC),I,L,L2),
gset(cc,svar(NCC),I,L2,L3),
gset(p,svar(NP),I,L3,L4),
gset(s,svar(NS),I,L4,LL).
NCUT is C,
NCC is C + 1,
NP is C + 2,
NS is C + 3,
NVEC is C + 4,
id(cut,var(ICUT)),
id(cc,var(cc)),
generate('scm-ref/immediate'(NVEC,ICUT,NCUT),L,L1),
generate('scm-ref/immediate'(NVEC,ICC,NCC),L1,L2),
gset(p,svar(NP),I,L2,L3),
gset(s,svar(NS),I,L3,L4),
gset(vec,svar(NVEC),I,L4,L5),
gset(const,vconst,I,L5,LL).
'push-3'(P,C,I,II,L,LL) :-
args([cc(C),pp(P),s],I,II,L,LL).
......@@ -65,11 +69,18 @@
tailstub(NN,L2,LL).
'in-post-call'(I,II,L,LL) :-
generate('assert-narg-ee/locals'(3,nvec),L,LL),
generate('assert-narg-ee/locals'(3,nvec),L,L1),
gset(const,vconst,I,L1,LL),
II = 0.
'post-unicall'(I,II,L,LL) :-
'goto-stackstart'(II),
'install-stack'(I1,II,L,LL).
cut(ground(_),V,I,I,L,L) :- !.
cut(_,false,I,I,L,L) :- !,
gset(p,cut,I,L,LL).
cut(_,V,I,I,L,LL) :-
gset(p,V,I,L,LL).
")
......@@ -8,8 +8,8 @@
((eq? s 'reset) 'pl-reset)
(else s))))
#:export (newframe-ps newframe-pst newframe-light newframe
newframe-negation
#:export (newframe-ps newframe-psc newframe-light newframe
newframe-negation newframe-pc
store-state store-ps store-p))
(compile-prolog-string
......@@ -46,18 +46,23 @@
gset(cstack,sp(I),L3,L4),
reset(I,L4,LL).
'newframe-ps'(A,P,S,I,L,LL) :-
scmcall('gp-newframe',[s],I,I1,L,L1),
gset(P,p,I1,L1,L2),
gset(S,s,I1,L2,L3),
gset(p,l(A),I1,L3,L4),
gset(s,sp(I1-1),I1,L4,L5),
reset(I,L5,LL).
'newframe-ps'(P,S,I,I,L,LL) :-
write(1),
generate(newframe,L,L1),
write(2),
gset(S,s,I,L1,L2),
gset(P,p,I,L2,LL).
'newframe-pc'(P,C,I,I,L,LL) :-
gset(P,p,I,L,L1),
gset(C,p,I,L1,L2).
'newframe-pst'(A,P,S,T,I,I,L,LL) :-
'newframe-psc'(P,S,C,I,I,L,LL) :-
generate(newframe,L,L1),
gset(P,p,I,L1,L2),
gset(S,s,I,L2,LL).
gset(S,s,I,L1,L2),
gset(P,p,I,L2,L3),
gset(C,p,I,L3,LL).
-trace.
'newframe-light'(P,NP,I,I,L,LL) :-
......
......@@ -2,7 +2,7 @@
#:use-module (logic guile-log vm utils)
#:use-module (logic guile-log iso-prolog)
#:export (unwind-light-tail unwind-light unwind unwind-negation
unwind-tail unwind-ps unwind-psc unwind-psct unwind-pst
unwind-tail unwind-ps unwind-p
post-negation post-s post-q post-c post-sc restore-c restore-pc
softie softie-light softie-ps softie-pc softie-psc
fail-psc fail-pc))
......@@ -39,16 +39,13 @@
'unwind-light-tail'(Tag,I,I,L,LL) :-
gset(p,Tag,I,L,LL).
'unwind-ps'(P,S,I,L,LL) :-
scmcall('gp-unwind',[S],I,I1,L,L1),
gset(s,sp(I1-1),I,L1,L2).
gset(p,P,I,2,L3),
'unwind-ps'(P,S,I,I,L,LL) :-
gset(s,S,I,L,L1),
generate('unwind-tail',L1,L2),
gset(p,P,I,L2,LL).
'unwind-psc'(P,S,C,I,L,LL) :-
scmcall('gp-unwind',[S],I,I1,L,L1),
gset(s,sp(I1-1),I,L1,L2),
gset(p,P,I,L2,L3),
gset(cut,C,I,L3,LL).
'unwind-p'(P,I,I,L,LL) :-
gset(p,P,I,L,LL).
'unwind-psct'(P,S,C,T,I,L,LL) :-
scmcall('gp-unwind',[S],I,I1,L,L1),
......
......@@ -5,9 +5,11 @@
#:export (reset gset gref move movex scmcall make_p make_cc j je jne
scmtailcall scmtailcall2 scmcall1 generate
label gfalse gtrue isTrue pltest lookup2 svar args
test sp cc p s c l vec lvec cut stack call? scut pp pltest_s
base init-proc
tailstub stub inlabel))
test sp cc p s c l vec lvec stack call? scut pp pltest_s
base init-proc id vconst
tailstub stub inlabel)
#:replace (const))
(define il 0)
......@@ -24,7 +26,6 @@
(set! i 0)
(set! constants (make-hash-table))))
(<define> (getconst n c l ll)
(let ((c (<lookup> c)))
(cond
......@@ -49,12 +50,10 @@
id(p ,svar(0)).
id(vec ,svar(2)).
id(const ,svar(3)).
id(cut ,var(0)).
id(scut ,var(1)).
id(stack ,var(3)).
id(cc ,var(4)).
id('call?' ,var(5)).
id(self ,var(6)).
id(self ,var(0)).
id(vconst ,var(1)).
id(\"cut\" ,var(2)).
id(cc ,var(3)).
id(lvec ,cl(0)).
id(ret ,cl(1)).
sp(6).
......@@ -66,7 +65,6 @@
generate('scm-ref/immediate'(II,I,2),L2,L3),
generate('scm-ref/immediate'(I,I,1),L3,LL).
-trace.
pp(complex,I,II,L,LL) :- !,
II is I + 1,
gset(sp(I),p,II,L,L1),
......@@ -112,7 +110,6 @@
call(II is I),
generate('reset-frame'(base+II),L,LL).
-trace.
varref(Pos,sp(I),II,L,LL) :-
id(vec,svar(IVEC)),
PPos is Pos + 1,
......@@ -290,7 +287,6 @@
id(X,XX),
gset(XX,Val,I,L,LL).
-trace.
'init-proc'(Nargs,Nvec,L,LL) :-
N is Nargs + 3 + 1,
NJ is N + 1,
......
......@@ -11,17 +11,17 @@
;; unwind
unwind-light-tail unwind-light unwind unwind-negation
unwind-tail
unwind-ps unwind-psc unwind-psct unwind-pst
unwind-ps unwind-p
post-negation post-s post-q post-c
softie-light softie-ps softie-pc post-sc softie-psc
restore-c restore-pc fail-psc fail-pc
;; call
in-call cc-call in-tailcall in-post-call post-unicall
push-3 pushtail-3 handle-spcc
push-3 pushtail-3 handle-spcc cut
;; newframe
newframe-ps newframe-pst newframe-light newframe
newframe-ps newframe-pc newframe-psc newframe-light newframe
newframe-negation store-state store-ps store-p
;; utils
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment