improving calling vm compilation

parent ddffe08e
...@@ -149,7 +149,7 @@ caller(F,Args,Tail,V,[L,LL]) :- ...@@ -149,7 +149,7 @@ caller(F,Args,Tail,V,[L,LL]) :-
set_S(V,0), set_S(V,0),
push_v(3,V), push_v(3,V),
argkind(F,K), argkind(F,K),
push_args_args(K,Args,V,L3,LL2,LW,LL), push_args_args(K,Args,V,L2,LL2,LW,LL),
touch_A(V), touch_A(V),
gen_f(Fsym), gen_f(Fsym),
set_FS(V,Fsym,S), set_FS(V,Fsym,S),
......
...@@ -20,6 +20,13 @@ reverse_op(=:=,=:=). ...@@ -20,6 +20,13 @@ reverse_op(=:=,=:=).
reverse_op(=\\=,=\\=). reverse_op(=\\=,=\\=).
rev(X,Y) :-
rev(X,[],Y).
rev([],X,X).
rev([A|X],Y,Z) :-
YY = [A|Y],
rev(X,YY,Z).
zero(V) :- get_A(V,A),A=[[0|_]]. zero(V) :- get_A(V,A),A=[[0|_]].
...@@ -146,7 +153,8 @@ compile_goal((Args <= Goal),Tail,V,L) :- !, ...@@ -146,7 +153,8 @@ compile_goal((Args <= Goal),Tail,V,L) :- !,
push_v(NN,V), push_v(NN,V),
compile_goal((begin_att,Impr,pop(3),end_att),Tail,V,L3). compile_goal((begin_att,Impr,pop(3),end_att),Tail,V,L3).
compile_goal((F(|Args) :- Goal),Tail,V,L) :- !, compile_goal((F(|ASrgs) :- Goal),Tail,V,L) :- !,
rev(ASrgs,Args),
(listp(Args) -> true ; throw(not_proper_head(F(|Args)))), (listp(Args) -> true ; throw(not_proper_head(F(|Args)))),
reverse(Args,AArgs), reverse(Args,AArgs),
mg(F(|Args),AArgs,Impr,0,N), mg(F(|Args),AArgs,Impr,0,N),
...@@ -166,8 +174,8 @@ compile_goal(newtag_F(F),Tail,V,[L,L]) :- ...@@ -166,8 +174,8 @@ compile_goal(newtag_F(F),Tail,V,[L,L]) :-
compile_goal(extended_off,Tail,V,[L,L]) :- !, compile_goal(extended_off,Tail,V,[L,L]) :- !,
set_extended(#f). set_extended(#f).
compile_goal(move_args(N,N),Tail,V,[L,L]) :- !, compile_goal(move_args(N,N),Tail,V,[L,LL]) :- !,
true. L=[['handle-spcc',N]|LL].
compile_goal(move_args(K,N),Tail,V,[L,LL]) :- !, compile_goal(move_args(K,N),Tail,V,[L,LL]) :- !,
L=[push_at(K)|L1], L=[push_at(K)|L1],
...@@ -648,10 +656,10 @@ compile_goal(imprint(X,M),Tail,V,[L,LL]) :- !, ...@@ -648,10 +656,10 @@ compile_goal(imprint(X,M),Tail,V,[L,LL]) :- !,
tail(Tail,LL,LLL), tail(Tail,LL,LLL),
compile_imprint(X,V,L,LLL,M). compile_imprint(X,V,L,LLL,M).
compile_goal(m_and(X,F(|Args)),Tail,V,L) :- !, compile_goal(m_and(X,F(|AArgs)),Tail,V,L) :- !,
( (
(var_p(F) ; isApply(Args)) -> compile_goal(call(X),Tail,V,L) ; (var_p(F) ; isApply(AArgs)) -> compile_goal(call(X),Tail,V,L) ;
caller(F,Args,Tail,V,L) (rev(AArgs,Args), caller(F,Args,Tail,V,L))
). ).
compile_goal(F,Tail,V,L) :- compile_goal(F,Tail,V,L) :-
......
...@@ -40,6 +40,9 @@ handle([\"label\",C],I,II,L,LL) :- ...@@ -40,6 +40,9 @@ handle([\"label\",C],I,II,L,LL) :-
handle(['clear-sp'],I,0,L,LL) :- !, handle(['clear-sp'],I,0,L,LL) :- !,
'clear-sp'(I,0,L,LL). 'clear-sp'(I,0,L,LL).
handle(['handle-spcc',C],I,II,L,LL) :- !,
'handle-spcc'(C,I,II,L,LL).
handle([\"call\",N],I,II,L,LL) :- !, handle([\"call\",N],I,II,L,LL) :- !,
'in-call'(N,I,II,L,LL). 'in-call'(N,I,II,L,LL).
......
...@@ -15,11 +15,19 @@ ...@@ -15,11 +15,19 @@
#:use-module (logic guile-log vm utils) #:use-module (logic guile-log vm utils)
#:use-module (logic guile-log vm fkn) #:use-module (logic guile-log vm fkn)
#:export (in-call cc-call in-tailcall in-post-call post-unicall #:export (in-call cc-call in-tailcall in-post-call post-unicall
push-3 pushtail-3)) push-3 pushtail-3 handle-spcc))
(compile-prolog-string (compile-prolog-string
" "
-trace. 'handle-spcc'(C,I,I,L,LL) :-
NCC is C,
NP is C + 1,
NS is C + 2,
gset(cc,svar(NCC),I,L,L2),
gset(p,svar(NP),I,L2,L3),
gset(s,svar(NS),I,L3,L4),
gset(vec,lvec,I,L4,LL).
'push-3'(C,I,II,L,LL) :- 'push-3'(C,I,II,L,LL) :-
args([cc(C),pp,s],I,II,L,LL). args([cc(C),pp,s],I,II,L,LL).
...@@ -29,21 +37,19 @@ ...@@ -29,21 +37,19 @@
'cc-call'(I,0,L,LL) :- 'cc-call'(I,0,L,LL) :-
scmtailcall(cc,[s,pp],0,_,L,LL). scmtailcall(cc,[s,pp],0,_,L,LL).
-trace.
move_block(0,I,I,L,L). move_block(0,I,I,L,L).
move_block(N,I,II,L,LL) :- move_block(N,I,II,L,LL) :-
I2 is I - 1, I2 is I - 1,
move(base+I2,N,L,L2),
NN is N - 1, NN is N - 1,
move(NN,base+I2,L,L2),
move_block(NN,I2,II,L2,LL). move_block(NN,I2,II,L2,LL).
move_block_rev(N,N,I,L,L). move_block_rev(N,N,I,L,L).
move_block_rev(N,I,II,L,LL) :- move_block_rev(N,I,II,L,LL) :-
move(I,base+I,N,L,L2), move(N,base+I,L,L2),
NN is N + 1, NN is N + 1,
move_block_rev(NN,I2,II,L2,LL). move_block_rev(NN,I2,II,L2,LL).
-trace.
'in-call'(N,I,II,L,LL) :- 'in-call'(N,I,II,L,LL) :-
NN is N + 4, NN is N + 4,
M is I - NN - 1, M is I - NN - 1,
...@@ -56,13 +62,10 @@ ...@@ -56,13 +62,10 @@
move_block(NN,I,II,L,L2), move_block(NN,I,II,L,L2),
tailstub(NN,L2,LL). tailstub(NN,L2,LL).
-trace.
'in-post-call'(I,II,L,LL) :- 'in-post-call'(I,II,L,LL) :-
gset(s,svar(2),0,L,LL), gset(vec,lvec,I,L,LL),
II = 0. II = 0.
'post-unicall'(I,II,L,LL) :- 'post-unicall'(I,II,L,LL) :-
'goto-stackstart'(II), 'goto-stackstart'(II),
'install-stack'(I1,II,L,LL). 'install-stack'(I1,II,L,LL).
......
...@@ -14,23 +14,23 @@ ...@@ -14,23 +14,23 @@
'icons!'(I,II,L,LL) :- 'icons!'(I,II,L,LL) :-
pltest_s('gp-pair!?',[sp(I-1),s],I,L,L2), pltest_s('gp-pair!?',[sp(I-1),s],I,L,L2),
scmcall('gp-cdr',[sp(I-1),s],I,I2,L2,L3), scmcall('gp-cdr',[sp(I-1),s],I,I2,L2,L3),
scmcall('gp-car',[sp(I-1),s],I2,I3,L4), scmcall('gp-car',[sp(I-1),s],I2,I3,L4),
move(I2-1,I-1,L4,L5), movex(I-1,I2-1,L4,L5),
move(I3-1,I,L5,L6), movex(I,I3-1,L5,L6),
II is I + 1, II is I + 1,
reset(II,L6,LL). reset(II,L6,LL).
'ifkn!'(I,L,LL) :- 'ifkn!'(I,L,LL) :-
pltest_s('fkn!?',[sp[I - 1],s],I,L,L1), pltest_s('fkn!?',[sp[I - 1],s],I,L,L1),
scmcall('vector-ref',[sp[I - 1],c(0)],I,I2,L1,L2), scmcall('vector-ref',[sp[I - 1],c(0)],I,I2,L1,L2),
move(I2-1,I-1,L2,L3), movex(I-1,I2-1,L2,L3),
reset(I,L3,LL). reset(I,L3,LL).
'icurly!'(I,L,LL) :- 'icurly!'(I,L,LL) :-
pltest_s('curly!?',[sp[I - 1],s],I,L,L1), pltest_s('curly!?',[sp[I - 1],s],I,L,L1),
scmcall('vector-ref',[sp[I - 1],c(1)],I,I1,L1,L2), scmcall('vector-ref',[sp[I - 1],c(1)],I,I1,L1,L2),
move(I1-1,I-1,L2,L3), movex(I-1,I1-1,L2,L3),
reset(I,L3,LL). reset(I,L3,LL).
...@@ -38,7 +38,7 @@ ...@@ -38,7 +38,7 @@
'mk-cons'(I,II,L,LL) :- 'mk-cons'(I,II,L,LL) :-
scmcall('gp-cons',[sp(I-2),sp(I-1),s],I,I1,L,L1), scmcall('gp-cons',[sp(I-2),sp(I-1),s],I,I1,L,L1),
move(I1-1,I-2,L1,L2), movex(I-2,I1-1,L1,L2),
II is I - 1, II is I - 1,
reset(II,L2,LL). reset(II,L2,LL).
...@@ -52,13 +52,13 @@ ...@@ -52,13 +52,13 @@
do_n_cons(N,I,II,L1), do_n_cons(N,I,II,L1),
scmcall(scm_make_vector,[c(1),c(#f)],I1,I2,L1,L2), scmcall(scm_make_vector,[c(1),c(#f)],I1,I2,L1,L2),
scmcall('vector-set!',[sp(I2-1),c(0),sp(II-1)],I2,_,L2,L3), scmcall('vector-set!',[sp(I2-1),c(0),sp(II-1)],I2,_,L2,L3),
move(I2-1,II-1,L3,L4), movex(II-1,I2-1,L3,L4),
reset(II,L4,LL). reset(II,L4,LL).
'mk-curly'(I,L,LL) :- 'mk-curly'(I,L,LL) :-
scmcall('make-vector',[c(2),c(#:brace)],I,I2,L,L1), scmcall('make-vector',[c(2),c(#:brace)],I,I2,L,L1),
scmcall('vector-set!',[sp(I2-1),c(1),sp(I-1)],I2,_,L1,L2), scmcall('vector-set!',[sp(I2-1),c(1),sp(I-1)],I2,_,L1,L2),
move(sp(I2-1),sp(I-1),L2,L3), movex(I-1,I2-1,L2,L3),
reset(I,L3,LL). reset(I,L3,LL).
...@@ -68,21 +68,21 @@ ...@@ -68,21 +68,21 @@
pltest('gp-pair?',[sp[-1],s],I,_,L,L1), pltest('gp-pair?',[sp[-1],s],I,_,L,L1),
scmcall('gp-cdr',[sp[-1],s],I,I2,L1,L2), scmcall('gp-cdr',[sp[-1],s],I,I2,L1,L2),
scmcall('gp-car',[sp[-1],s],I2,I3,L2,L3), scmcall('gp-car',[sp[-1],s],I2,I3,L2,L3),
move(sp(I2-1),I-1,L3,L4), movex(I-1,I2-1,L3,L4),
move(sp(I3-1),I,L4,L5), movex(I,I3-1,L4,L5),
II is I + 1, II is I + 1,
reset(II,L5,LL). reset(II,L5,LL).
ifkn(I,L,LL) :- ifkn(I,L,LL) :-
pltest('fkn?',[sp(I-1)],I,_,L,L1), pltest('fkn?',[sp(I-1)],I,_,L,L1),
scmcall('vector-ref',[sp(I-1),c(0)],I,L1,L2), scmcall('vector-ref',[sp(I-1),c(0)],I,L1,L2),
move(I+3,I-1,L2,L3), movex(I-1,I+3,L2,L3),
reset(I,L3,LL). reset(I,L3,LL).
icurly(I,L,LL) :- icurly(I,L,LL) :-
pltest('curly?',[sp(I-1)],I,_,L,L1), pltest('curly?',[sp(I-1)],I,_,L,L1),
scmcall('vector-ref',[sp(I-1),c(1)],I,I2,L1,L2), scmcall('vector-ref',[sp(I-1),c(1)],I,I2,L1,L2),
move(I2-1,I-1,L2,L3), movex(I-1,I2-1,L2,L3),
reset(I,L3,LL). reset(I,L3,LL).
") ")
...@@ -80,7 +80,7 @@ ...@@ -80,7 +80,7 @@
reset(II,L,LL). reset(II,L,LL).
dup(I,II,L,LL) :- dup(I,II,L,LL) :-
move(I,I-1,L,L1), movex(I,I-1,L,L1),
II is I + 1, II is I + 1,
reset(II,L1,LL). reset(II,L1,LL).
......
(define-module (logic guile-log vm utils) (define-module (logic guile-log vm utils)
#:use-module (logic guile-log iso-prolog) #:use-module (logic guile-log iso-prolog)
#:use-module ((logic guile-log umatch) #:select (gp-make-var)) #:use-module ((logic guile-log umatch) #:select (gp-make-var))
#:export (reset gset gref move scmcall make_p make_cc j je jne #:export (reset gset gref move movex scmcall make_p make_cc j je jne
scmtailcall scmtailcall2 scmcall1 generate scmtailcall scmtailcall2 scmcall1 generate
label gfalse gtrue isTrue pltest lookup2 svar args label gfalse gtrue isTrue pltest lookup2 svar args
test sp cc s c vec cut stack call? scut pp pltest_s base test sp cc p s c vec lvec cut stack call? scut pp pltest_s base
tailstub stub inlabel)) tailstub stub inlabel))
(define base (gp-make-var)) (define base (gp-make-var))
...@@ -13,15 +13,17 @@ ...@@ -13,15 +13,17 @@
" "
generate(Tok,[Tok|LL],LL). generate(Tok,[Tok|LL],LL).
id(s ,svar(0)). id(s ,svar(1)).
id(p ,svar(1)). id(p ,svar(0)).
id(vec ,svar(2)).
id(cut ,var(0)). id(cut ,var(0)).
id(scut ,var(1)). id(scut ,var(1)).
id(vec ,var(2)).
id(stack ,var(3)). id(stack ,var(3)).
id(cc ,var(4)). id(cc ,var(4)).
id('call?' ,var(5)). id('call?' ,var(5)).
id(self ,var(6)). id(self ,var(6)).
id(lvec ,cl(0)).
id(ret ,cl(1)).
sp(6). sp(6).
pp(I,II,L,LL) :- pp(I,II,L,LL) :-
...@@ -30,7 +32,7 @@ ...@@ -30,7 +32,7 @@
isProcedure(sp(I),Lab,II,L1,L2), isProcedure(sp(I),Lab,II,L1,L2),
scmcall1('gp-make-p',[self],I,I1,L2,L3), scmcall1('gp-make-p',[self],I,I1,L2,L3),
J is I1 - 1, J is I1 - 1,
move(base+J,base+I,L3,L4), move(base+I,base+J,L3,L4),
label(Lab,L4,LL). label(Lab,L4,LL).
cc(C,I,II,L,LL) :- cc(C,I,II,L,LL) :-
...@@ -66,7 +68,16 @@ ...@@ -66,7 +68,16 @@
generate(constant(I,C),L,LL). generate(constant(I,C),L,LL).
move(I,J,L,LL) :- move(I,J,L,LL) :-
generate(move(J,I),L,LL). generate(move(I,J),L,LL).
movex(I,J,L,LL) :-
call(II is I),
call(JJ is J),
generate(move(base+II,base+JJ),L,LL).
gref(cl(X),I,L,LL) :- !,
call(II is I),
generate(closure(base+II,X),L,LL).
gref(c(X),I,L,LL) :- !, gref(c(X),I,L,LL) :- !,
call(II is I), call(II is I),
...@@ -79,12 +90,12 @@ ...@@ -79,12 +90,12 @@
gref(sp(X),I,L,LL) :- !, gref(sp(X),I,L,LL) :- !,
call(XX is X), call(XX is X),
call(II is I), call(II is I),
move(XX,base + II,L,LL). move(base+II,base + XX,L,LL).
gref(svar(X),I,L,LL) :- !, gref(svar(X),I,L,LL) :- !,
call(XX is X), call(XX is X),
call(II is I), call(II is I),
move(XX,base + II,L,LL). move(base + II,XX,L,LL).
gref(l(X),I,L,LL) :- !, gref(l(X),I,L,LL) :- !,
generate('label-ref'(base+I,X),L,LL). generate('label-ref'(base+I,X),L,LL).
...@@ -105,7 +116,7 @@ ...@@ -105,7 +116,7 @@
varset(J,I,L2,LL). varset(J,I,L2,LL).
vset(J,svar(X),I,L,LL) :- !, vset(J,svar(X),I,L,LL) :- !,
varset_s(J,X,L2,LL). varset_s(J,X,L,LL).
vset(J,c(X),I,L,LL) :- !, vset(J,c(X),I,L,LL) :- !,
gref(c(X),I,L,L2), gref(c(X),I,L,L2),
...@@ -116,16 +127,18 @@ ...@@ -116,16 +127,18 @@
vset(J,XX,I,L,LL). vset(J,XX,I,L,LL).
sset(K,sp(J),I,L,LL) :- !, sset(K,sp(J),I,L,LL) :- !,
move(base+J,base+K,L,LL). call(KK is K),
call(JJ is J),
move(base+KK,base+JJ,L,LL).
sset(K,svar(J),I,L,LL) :- !, sset(K,svar(J),I,L,LL) :- !,
call(KK is K), call(KK is K),
move(J,base+KK,L,LL). move(base+KK,J,L,LL).
sset(J,var(X),I,L,LL) :- !, sset(J,var(X),I,L,LL) :- !,
gref(var(X),I,L,L2), gref(var(X),I,L,L2),
call(JJ is J), call(JJ is J),
move(base+I,base+JJ,L2,LL). move(base+JJ,base+I,L2,LL).
sset(J,c(X),I,L,LL) :- !, sset(J,c(X),I,L,LL) :- !,
call(JJ is J), call(JJ is J),
...@@ -136,21 +149,25 @@ ...@@ -136,21 +149,25 @@
sset(J,XX,I,L,LL). sset(J,XX,I,L,LL).
cset(K,sp(J),I,L,LL) :- !, cset(K,sp(J),I,L,LL) :- !,
move(base+J,K,L,LL). move(K,base+J,L,LL).
cset(K,svar(J),I,L,LL) :- !, cset(K,svar(J),I,L,LL) :- !,
call(KK is K), call(KK is K),
move(J,KK,L,LL). move(KK,J,L,LL).
cset(J,var(X),I,L,LL) :- !, cset(J,var(X),I,L,LL) :- !,
gref(var(X),I,L,L2), gref(var(X),I,L,L2),
call(JJ is J), call(JJ is J),
move(base + I,JJ,L2,LL). move(JJ,base + I,L2,LL).
cset(J,cl(X),I,L,LL) :- !,
call(JJ is J),
gref(cl(X),JJ,L,LL).
cset(J,c(X),I,L,LL) :- !, cset(J,c(X),I,L,LL) :- !,
gref(c(X),I,L,L2), gref(c(X),I,L,L2),
call(JJ is J), call(JJ is J),
move(base+I,JJ,L2,LL). move(JJ,base+I,L2,LL).
cset(J,X,I,L,LL) :- cset(J,X,I,L,LL) :-
id(X,XX), id(X,XX),
...@@ -260,10 +277,13 @@ ...@@ -260,10 +277,13 @@
gset(s,sp(II-1),II,L2,LL). gset(s,sp(II-1),II,L2,LL).
lookup2(I,L,LL) :- lookup2(I,L,LL) :-
scmcall('gp-lookup',[sp(I-2),s],I,L,L1), scmcall('gp-lookup',[sp(I-2),s],I,II,L,L1),
move(I+3,I-2,L1,L2), III is II - 1,
scmcall('gp-lookup',[sp(I-1),s],I,L2,L3), K is I - 2,
move(I+3,I-1,L3,LL). move(base+K,base + III,L1,L2),
scmcall('gp-lookup',[sp(I-1),s],I,II,L2,L3),
KK is I - 1,
move(base+KK,base+III,L3,LL).
test(Op,A,B,Label,I,L,LL) :- test(Op,A,B,Label,I,L,LL) :-
generate(test2(Op,A,B,Label),L,LL). generate(test2(Op,A,B,Label),L,LL).
......
...@@ -18,7 +18,7 @@ ...@@ -18,7 +18,7 @@
;; call ;; call
in-call cc-call in-tailcall in-post-call post-unicall in-call cc-call in-tailcall in-post-call post-unicall
push-3 pushtail-3 push-3 pushtail-3 handle-spcc
;; newframe ;; newframe
newframe-ps newframe-pst newframe-light newframe newframe-ps newframe-pst newframe-light newframe
......
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