improving calling vm compilation

parent ddffe08e
......@@ -149,7 +149,7 @@ caller(F,Args,Tail,V,[L,LL]) :-
set_S(V,0),
push_v(3,V),
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),
gen_f(Fsym),
set_FS(V,Fsym,S),
......
......@@ -20,6 +20,13 @@ 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|_]].
......@@ -146,7 +153,8 @@ compile_goal((Args <= Goal),Tail,V,L) :- !,
push_v(NN,V),
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)))),
reverse(Args,AArgs),
mg(F(|Args),AArgs,Impr,0,N),
......@@ -166,8 +174,8 @@ compile_goal(newtag_F(F),Tail,V,[L,L]) :-
compile_goal(extended_off,Tail,V,[L,L]) :- !,
set_extended(#f).
compile_goal(move_args(N,N),Tail,V,[L,L]) :- !,
true.
compile_goal(move_args(N,N),Tail,V,[L,LL]) :- !,
L=[['handle-spcc',N]|LL].
compile_goal(move_args(K,N),Tail,V,[L,LL]) :- !,
L=[push_at(K)|L1],
......@@ -648,10 +656,10 @@ compile_goal(imprint(X,M),Tail,V,[L,LL]) :- !,
tail(Tail,LL,LLL),
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) ;
caller(F,Args,Tail,V,L)
(var_p(F) ; isApply(AArgs)) -> compile_goal(call(X),Tail,V,L) ;
(rev(AArgs,Args), caller(F,Args,Tail,V,L))
).
compile_goal(F,Tail,V,L) :-
......
......@@ -40,6 +40,9 @@ handle([\"label\",C],I,II,L,LL) :-
handle(['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) :- !,
'in-call'(N,I,II,L,LL).
......
......@@ -15,11 +15,19 @@
#: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))
push-3 pushtail-3 handle-spcc))
(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) :-
args([cc(C),pp,s],I,II,L,LL).
......@@ -29,21 +37,19 @@
'cc-call'(I,0,L,LL) :-
scmtailcall(cc,[s,pp],0,_,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(NN,base+I2,L,L2),
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),
move(N,base+I,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,
......@@ -56,13 +62,10 @@
move_block(NN,I,II,L,L2),
tailstub(NN,L2,LL).
-trace.
'in-post-call'(I,II,L,LL) :-
gset(s,svar(2),0,L,LL),
gset(vec,lvec,I,L,LL),
II = 0.
'post-unicall'(I,II,L,LL) :-
'goto-stackstart'(II),
'install-stack'(I1,II,L,LL).
......
......@@ -15,22 +15,22 @@
pltest_s('gp-pair!?',[sp(I-1),s],I,L,L2),
scmcall('gp-cdr',[sp(I-1),s],I,I2,L2,L3),
scmcall('gp-car',[sp(I-1),s],I2,I3,L4),
move(I2-1,I-1,L4,L5),
move(I3-1,I,L5,L6),
movex(I-1,I2-1,L4,L5),
movex(I,I3-1,L5,L6),
II is I + 1,
reset(II,L6,LL).
'ifkn!'(I,L,LL) :-
pltest_s('fkn!?',[sp[I - 1],s],I,L,L1),
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).
'icurly!'(I,L,LL) :-
pltest_s('curly!?',[sp[I - 1],s],I,L,L1),
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).
......@@ -38,7 +38,7 @@
'mk-cons'(I,II,L,LL) :-
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,
reset(II,L2,LL).
......@@ -52,13 +52,13 @@
do_n_cons(N,I,II,L1),
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),
move(I2-1,II-1,L3,L4),
movex(II-1,I2-1,L3,L4),
reset(II,L4,LL).
'mk-curly'(I,L,LL) :-
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),
move(sp(I2-1),sp(I-1),L2,L3),
movex(I-1,I2-1,L2,L3),
reset(I,L3,LL).
......@@ -68,21 +68,21 @@
pltest('gp-pair?',[sp[-1],s],I,_,L,L1),
scmcall('gp-cdr',[sp[-1],s],I,I2,L1,L2),
scmcall('gp-car',[sp[-1],s],I2,I3,L2,L3),
move(sp(I2-1),I-1,L3,L4),
move(sp(I3-1),I,L4,L5),
movex(I-1,I2-1,L3,L4),
movex(I,I3-1,L4,L5),
II is I + 1,
reset(II,L5,LL).
ifkn(I,L,LL) :-
pltest('fkn?',[sp(I-1)],I,_,L,L1),
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).
icurly(I,L,LL) :-
pltest('curly?',[sp(I-1)],I,_,L,L1),
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).
")
......@@ -80,7 +80,7 @@
reset(II,L,LL).
dup(I,II,L,LL) :-
move(I,I-1,L,L1),
movex(I,I-1,L,L1),
II is I + 1,
reset(II,L1,LL).
......
(define-module (logic guile-log vm utils)
#:use-module (logic guile-log iso-prolog)
#: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
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))
(define base (gp-make-var))
......@@ -13,15 +13,17 @@
"
generate(Tok,[Tok|LL],LL).
id(s ,svar(0)).
id(p ,svar(1)).
id(s ,svar(1)).
id(p ,svar(0)).
id(vec ,svar(2)).
id(cut ,var(0)).
id(scut ,var(1)).
id(vec ,var(2)).
id(stack ,var(3)).
id(cc ,var(4)).
id('call?' ,var(5)).
id(self ,var(6)).
id(lvec ,cl(0)).
id(ret ,cl(1)).
sp(6).
pp(I,II,L,LL) :-
......@@ -30,7 +32,7 @@
isProcedure(sp(I),Lab,II,L1,L2),
scmcall1('gp-make-p',[self],I,I1,L2,L3),
J is I1 - 1,
move(base+J,base+I,L3,L4),
move(base+I,base+J,L3,L4),
label(Lab,L4,LL).
cc(C,I,II,L,LL) :-
......@@ -66,7 +68,16 @@
generate(constant(I,C),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) :- !,
call(II is I),
......@@ -79,12 +90,12 @@
gref(sp(X),I,L,LL) :- !,
call(XX is X),
call(II is I),
move(XX,base + II,L,LL).
move(base+II,base + XX,L,LL).
gref(svar(X),I,L,LL) :- !,
call(XX is X),
call(II is I),
move(XX,base + II,L,LL).
move(base + II,XX,L,LL).
gref(l(X),I,L,LL) :- !,
generate('label-ref'(base+I,X),L,LL).
......@@ -105,7 +116,7 @@
varset(J,I,L2,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) :- !,
gref(c(X),I,L,L2),
......@@ -116,16 +127,18 @@
vset(J,XX,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) :- !,
call(KK is K),
move(J,base+KK,L,LL).
move(base+KK,J,L,LL).
sset(J,var(X),I,L,LL) :- !,
gref(var(X),I,L,L2),
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) :- !,
call(JJ is J),
......@@ -136,21 +149,25 @@
sset(J,XX,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) :- !,
call(KK is K),
move(J,KK,L,LL).
move(KK,J,L,LL).
cset(J,var(X),I,L,LL) :- !,
gref(var(X),I,L,L2),
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) :- !,
gref(c(X),I,L,L2),
call(JJ is J),
move(base+I,JJ,L2,LL).
move(JJ,base+I,L2,LL).
cset(J,X,I,L,LL) :-
id(X,XX),
......@@ -260,10 +277,13 @@
gset(s,sp(II-1),II,L2,LL).
lookup2(I,L,LL) :-
scmcall('gp-lookup',[sp(I-2),s],I,L,L1),
move(I+3,I-2,L1,L2),
scmcall('gp-lookup',[sp(I-1),s],I,L2,L3),
move(I+3,I-1,L3,LL).
scmcall('gp-lookup',[sp(I-2),s],I,II,L,L1),
III is II - 1,
K is I - 2,
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) :-
generate(test2(Op,A,B,Label),L,LL).
......
......@@ -18,7 +18,7 @@
;; call
in-call cc-call in-tailcall in-post-call post-unicall
push-3 pushtail-3
push-3 pushtail-3 handle-spcc
;; 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