calls starts to compile

parent 256de528
......@@ -122,7 +122,7 @@ caller(cc,Args,label(G,N),V,[L,LL]) :- !,
get_S(V,S),
set_S(V,0),
push_v(2,V),
L2=[[seek,3]|L4],
L2=[[push-3]|L4],
push_args_args(#f,Args,V,L4,LL2,_,_),
LL2 = [['goto-inst',G]|LL].
......@@ -134,36 +134,39 @@ caller(cc,Args,Tail,V,[L,LL]) :- !,
set_S(V,0),
push_args(F,V,L2,L3),
push_v(2,V),
L3=[[seek,2]|L4],
L3=[[push-2]|L4],
push_args_args(#f,Args,V,L4,LL2,_,_),
set_FS(V,F,S),
LL2 = [['tail-cc']|LW].
caller(F,Args,Tail,V,[L,LL]) :-
length(Args,Nargs),
touch_Q(3,V),
(get_recur(F,A,N) -> rec(F,A,N,Args,Tail,V,[L,LL]) ;
(
L=[['clear-sp']|L2],
get_CS(V,[C|_],S),
set_S(V,0),
push_args(F,V,L2,L3),
push_v(3,V),
L3=[[seek,3]|L4],
argkind(F,K),
push_args_args(K,Args,V,L4,LL2,LW,LL),
push_args_args(K,Args,V,L3,LL2,LW,LL),
touch_A(V),
gen_f(Fsym),
set_FS(V,Fsym,S),
(Tail == #t ->
(
LL2 = [['tail-call']|LW]
LL2 = [['pushtail-3']|LL3],
push_args(F,V,LL3,LL4),
LL4=[['tail-call',Nargs]|LW]
);
Tail = label(G,N) ->
(
LL2 = [['call-n',N],['goto-inst',G]|LW]
LL2 = [[seek,3],['call-n',N],['goto-inst',G]|LW]
);
(
LL2=[['call']|LLL],
LL2=[['push-3',Label]|LL3],
push_args(F,V,LL3,LL4),
LL4=[['call',Nargs],[label,Label]|LLL],
get_post(S,C,#f,Tail,LLL,LW)
)
))).
......
......@@ -149,12 +149,12 @@ compile_goal((Args <= Goal),Tail,V,L) :- !,
compile_goal((F(|Args) :- Goal),Tail,V,L) :- !,
(listp(Args) -> true ; throw(not_proper_head(F(|Args)))),
reverse(Args,AArgs),
mg(F(|Args),AArgs,Impr,0,N),
NN is N + 4,
push_v(NN,V),
mg(F(|Args),AArgs,Impr,0,N),
push_v(N,V),
get_A(V,[[0|_]|_]) ->
wrap(compile_goal((move_args(NN),begin_att,Impr,end_att,Goal),Tail,V,L),L);
wrap(compile_goal((move_args(NN),begin_att,Impr,Goal),Tail,V,L),L).
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).
compile_goal((F :- Goal),Tail,V,L) :- !,
push_v(4,V),
......@@ -166,13 +166,13 @@ compile_goal(newtag_F(F),Tail,V,[L,L]) :-
compile_goal(extended_off,Tail,V,[L,L]) :- !,
set_extended(#f).
compile_goal(move_args(4),Tail,V,[L,L]) :- !,
compile_goal(move_args(N,N),Tail,V,[L,L]) :- !,
true.
compile_goal(move_args(N),Tail,V,[L,LL]) :- !,
L=[push_at(N)|L1],
NN is N - 1,
compile_goal(move_args(NN),Tail,V,[L1,LL]).
compile_goal(move_args(K,N),Tail,V,[L,LL]) :- !,
L=[push_at(K)|L1],
KK is K + 1,
compile_goal(move_args(KK,N),Tail,V,[L1,LL]).
compile_goal(extended_on(|L),Tail,V,[L,L]) :- !,
set_extended(L).
......
......@@ -33,9 +33,25 @@ handle([label,N],[I,L],[II,LL]) :- !,
handle(['cc'],I,II,L,LL) :-
'cc-call'(I,II,L,LL).
handle([\"label\",C],I,II,L,LL) :-
I=II,
inlabel(C,L,LL).
handle(['clear-sp'],I,0,L,LL) :- !,
'clear-sp'(I,0,L,LL).
handle([\"call\",N],I,II,L,LL) :- !,
'in-call'(N,I,II,L,LL).
handle([\"tail-call\",N],I,II,L,LL) :- !,
'in-tailcall'(N,I,II,L,LL).
handle(['push-3',N],I,II,L,LL) :- !,
'push-3'(N,I,II,L,LL).
handle(['pushtail-3'],I,II,L,LL) :- !,
'pushtail-3'(I,II,L,LL).
handle([seek,N],I,II,L,LL) :- !,
seek(N,I,II,L,LL).
......@@ -135,8 +151,8 @@ handle([label,N,[_,Tags]],I,II,L,LL) :- !,
L=[N|_],
addvs(Tags,L,LL).
handle((X,['post-call',A,P]),I,II,L,LL) :- !,
II is I + 2, L=[X|LL].
handle([\"post-call\",A,P],I,II,L,LL) :- !,
'in-post-call'(I,II,L,LL).
handle((X,['post-unicall',A,P]),I,II,L,LL) :- !,
get_nsvars(P,N),
......@@ -194,7 +210,7 @@ handle(['push-variable',[[S,V,Q],N,F|_]],I,II,L,LL) :- !,
F==#t -> (new_var(V,Q,S), pushv(V,L,LL));
(
new_var(V,Q,S),
(V=[VC|_] -> QQ=svar(VC) ; QQ=V),
(V=[VC|_] -> QQ=svar(VC) ; QQ=var(V)),
'push-variable'(QQ,I,II,L,LL)
)
).
......
......@@ -214,8 +214,6 @@ the_tr(un(X) , [unop(X,N),tr(X,N)]) :- inc(N).
(compile-prolog-string
"
label(X).
print_error_if_fail :-
b_getval(pretty,#t),!,
write(tr_error(X)),nl,fail.
......@@ -295,7 +293,6 @@ t('tail-call').
t('goto-inst').
t('cut').
t('post-call').
t('post-unicall').
t('push-constant').
......
......@@ -14,32 +14,54 @@
#:use-module (logic guile-log vm utils)
#:use-module (logic guile-log vm fkn)
#:export (in-call cc-call in-tailcall post-call post-unicall))
#:export (in-call cc-call in-tailcall in-post-call post-unicall
push-3 pushtail-3))
(compile-prolog-string
"
store_stack(I,0,L,LL) :-
(
I > 0 ->
do_n_cons(I,I,_,L,L1);
gset(sp(0),c([]),L,L1)
).
gset('stack',sp(0),1,L1,L2).
-trace.
'push-3'(C,I,II,L,LL) :-
args([cc(C),pp,s],I,II,L,LL).
'pushtail-3'(I,II,L,LL) :-
args([cc,pp,s],I,II,L,LL).
'cc-call'(I,0,L,LL) :-
scmtailcall(cc,[s,pp],0,_,L,LL).
'in-call'(F,A,P,CC,I,II,L,LL) :-
store_stack(I,I1,L,L1),
scm_tailcall(F,[s,pp,CC|A],I1,II,L1,LL).
'in-tailcall'(F,A,P,CC,I,II,L,LL) :-
scm_tailcall(F,[s,pp,CC|A],I,II,L,LL).
-trace.
move_block(0,I,I,L,L).
move_block(N,I,II,L,LL) :-
I2 is I - 1,
move(base+I2,N,L,L2),
NN is N - 1,
move_block(NN,I2,II,L2,LL).
move_block_rev(N,N,I,L,L).
move_block_rev(N,I,II,L,LL) :-
move(I,base+I,N,L,L2),
NN is N + 1,
move_block_rev(NN,I2,II,L2,LL).
-trace.
'in-call'(N,I,II,L,LL) :-
NN is N + 4,
M is I - NN - 1,
move_block(NN,I,II,L,L2),
tailstub(NN,L2,LL).
'in-tailcall'(N,I,II,L,LL) :-
NN is N + 4,
M is I - NN - 1,
move_block(NN,I,II,L,L2),
tailstub(NN,L2,LL).
'post-call'(NARG,I,II,L,LL) :-
I0 is NARG + 2,
'goto-stackstart'(I0,I1),
'install-stack'(I1,II,L,LL).
-trace.
'in-post-call'(I,II,L,LL) :-
gset(s,svar(2),0,L,LL),
II = 0.
'post-unicall'(I,II,L,LL) :-
'goto-stackstart'(II),
......
......@@ -49,9 +49,9 @@
-trace.
'push-instruction'(C,I,II,L,LL) :-
gset(sp(I),c(C),I,L,L1),
gset(sp(I),c(C),I,L,L2),
II is I + 1,
reset(II,L1,LL).
reset(II,L2,LL).
pushv(X,I,II,L,LL) :-
scmcall('gp-var!',[s],I,I2,L,L1),
......@@ -61,9 +61,9 @@
-trace.
'push-variable'(V,I,II,L,LL) :-
gset(sp(I),V,I,L,L1),
gset(sp(I),V,I,L,L2),
II is I + 1,
reset(II,L1,LL).
reset(II,L2,LL).
'pop-variable'(V,I,II,L,LL) :-
gset(V,sp(I-1),L,L1),
......
......@@ -3,8 +3,9 @@
#:use-module ((logic guile-log umatch) #:select (gp-make-var))
#:export (reset gset gref move scmcall make_p make_cc j je jne
scmtailcall scmtailcall2 scmcall1 generate
label gfalse gtrue isTrue pltest lookup2 svar
test sp cc s c vec cut stack call? scut pp pltest_s base))
label gfalse gtrue isTrue pltest lookup2 svar args
test sp cc s c vec cut stack call? scut pp pltest_s base
tailstub stub inlabel))
(define base (gp-make-var))
......@@ -28,12 +29,26 @@
gset(sp(I),p,II,L,L1),
isProcedure(sp(I),Lab,II,L1,L2),
scmcall1('gp-make-p',[self],I,I1,L2,L3),
move(I1-1,I,L3,L4),
J is I1 - 1,
move(base+J,base+I,L3,L4),
label(Lab,L4,LL).
cc(C,I,II,L,LL) :-
scmcall('make-cc',[l(C),self],I,I1,L,L1),
J is I1 - 1,
move(base+I,base+J,L1,LL),
II is I + 1.
e(cc(C),I,II,L,LL) :- cc(C,I,II,L,LL).
e(pp,I,II,L,LL) :- pp(I,II,L,LL).
tailstub(I,L,LL) :-
generate(tailcall(I),L,LL).
stub(N,I,L,LL) :-
generate(call(N,I),L,LL).
reset(I,L,LL) :-
call(II is I),
generate(reset(base+II),L,LL).
......@@ -53,7 +68,6 @@
move(I,J,L,LL) :-
generate(move(J,I),L,LL).
-trace.
gref(c(X),I,L,LL) :- !,
call(II is I),
constant(X,base+II,L,LL).
......@@ -100,8 +114,7 @@
vset(J,X,I,L,LL) :-
id(X,XX),
vset(J,XX,I,L,LL).
-trace.
sset(K,sp(J),I,L,LL) :- !,
move(base+J,base+K,L,LL).
......@@ -116,7 +129,7 @@
sset(J,c(X),I,L,LL) :- !,
call(JJ is J),
gref(c(X),JJ,L,LLL).
gref(c(X),JJ,L,LL).
sset(J,X,I,L,LL) :-
id(X,XX),
......@@ -143,6 +156,7 @@
id(X,XX),
cset(J,XX,I,L,LL).
-trace.
gset(var(V),Val,I,L,LL) :- !,
vset(V,Val,I,L,LL).
......@@ -164,7 +178,6 @@
I = N,
generate('pl-setup-frame',L4,LL).
-trace.
args([],I,I,L,L).
args([X|A],I,II,L,LL) :-
......@@ -189,7 +202,6 @@
scmcall(F,Args,I,II,L,LL) :- scmcalln(0,F,Args,I,II,L,LL).
scmcall1(F,Args,I,II,L,LL) :- scmcalln(1,F,Args,I,II,L,LL).
-trace.
scmtailcalln(K,F,Args,I,II,L,LL) :-
length(Args,N),
NN is N + 1 + K,
......@@ -215,6 +227,9 @@
label(Label,L,LL) :-
generate(label(Label),L,LL).
inlabel(Label,L,LL) :-
generate(label(Label),L,LL).
gfalse(I,II,L,LL) :-
gref(p,I,L,L2),
......
......@@ -17,14 +17,15 @@
restore-c restore-pc fail-psc fail-pc
;; call
in-call cc-call in-tailcall post-call post-unicall
in-call cc-call in-tailcall in-post-call post-unicall
push-3 pushtail-3
;; newframe
newframe-ps newframe-pst newframe-light newframe
newframe-negation store-state store-ps store-p
;; utils
gfalse gtrue sp svar
gfalse gtrue sp svar inlabel
;; push
cutter goto-inst sp-move equal-instruction
......
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