...

parent 13b3c171
......@@ -63,34 +63,30 @@ push_args_args2([],V,L,LL) :-
push_args(X,V,L,LL) :- var_p(X),!,
add_var(X,V,Tag),
push_v(1,V),
tr('push-variable',Push),
L=[[Push,Tag]|LL].
L=[['push-variable',Tag]|LL].
push_args([X|Y],V,L,LL) :- !,
tr('mk-cons',Cons),
push_args(X,V,L,L1),
push_args(Y,V,L1,L2),
push_v(-1,V),
L2=[[Cons]|LL].
L2=[['mk-cons']|LL].
push_args(X(|Y),V,L,LL) :- !,
tr('mk-fkn',Fkn),
narg(Y,0,NN),N is NN + 1,
push_args_args2([X|Y],V,L,L1),
M is -N, push_v(M,V),
L1=[[Fkn,N]|LL].
L1=[['mk-fkn',N]|LL].
push_args({X},V,L,LL) :- !,
tr('mk-curly',MK),
push_args(X,V,L,L1),
L1=[[MK]|LL].
L1=[['mk-curly']|LL].
push_args(X,V,L,LL) :-
push_v(1,V),
(
constant(X) ->
(tr('push-constant',Push),regconst(X,XX),L=[[Push,XX]|LL]) ;
(tr('push-instruction',Push),L=[[Push,X]|LL])
(L=[['push-instruction', X]|LL]) ;
(L=[['push-instruction', X]|LL])
).
get_post(S,C,Cplx,Tail,X,XX) :-
......@@ -122,21 +118,18 @@ caller(cc,Args,label(G,N),V,[L,LL]) :- !,
narg(Args,0,MM),
M is MM + 3,
(M==N -> true ; throw(cc_does_not_match_caller)),
tr('clear-sp' , Clear),
L=[[Clear]|L2],
L=[['clear-sp']|L2],
get_S(V,S),
set_S(V,0),
push_v(2,V),
L2=[[seek,3]|L4],
push_args_args(#f,Args,V,L4,LL2,_,_),
tr('goto-inst', Goto),
LL2 = [[Goto,G]|LL].
LL2 = [['goto-inst',G]|LL].
caller(cc,Args,Tail,V,[L,LL]) :- !,
touch_Q(2,V),
(Tail=#f -> throw(cc_not_in_tail_context) ; true),
tr('clear-sp' , Clear),
L=[[Clear]|L2],
L=[['clear-sp']|L2],
get_S(V,S),
set_S(V,0),
push_args(F,V,L2,L3),
......@@ -144,15 +137,13 @@ caller(cc,Args,Tail,V,[L,LL]) :- !,
L3=[[seek,2]|L4],
push_args_args(#f,Args,V,L4,LL2,_,_),
set_FS(V,F,S),
tr('tail-cc', Call),
LL2 = [[Call]|LW].
LL2 = [['tail-cc']|LW].
caller(F,Args,Tail,V,[L,LL]) :-
touch_Q(3,V),
(get_recur(F,A,N) -> rec(F,A,N,Args,Tail,V,[L,LL]) ;
(
tr('clear-sp' , Clear),
L=[[Clear]|L2],
L=[['clear-sp']|L2],
get_CS(V,[C|_],S),
set_S(V,0),
push_args(F,V,L2,L3),
......@@ -165,18 +156,14 @@ caller(F,Args,Tail,V,[L,LL]) :-
set_FS(V,Fsym,S),
(Tail == #t ->
(
tr('tail-call', Call),
LL2 = [[Call]|LW]
LL2 = [['tail-call']|LW]
);
Tail = label(G,N) ->
(
tr(goto-inst,Goto),
tr('call-n',Call),
LL2 = [[Call,N],[Goto,G]|LW]
LL2 = [['call-n',N],['goto-inst',G]|LW]
);
(
tr('call', Call),
LL2=[[Call]|LLL],
LL2=[['call']|LLL],
get_post(S,C,#f,Tail,LLL,LW)
)
))).
......
......@@ -6,6 +6,7 @@
#:use-module (logic guile-log prolog swi)
#:use-module (logic guile-log guile-prolog vm vm-pre)
#:use-module (logic guile-log guile-prolog vm vm-var)
#:use-module (logic guile-log vm vm)
#:use-module (compat racket misc)
#:use-module (system vm assembler)
#:export (caller push_args_args2 push_args_args push_args))
......
......@@ -153,8 +153,8 @@ compile_goal((F(|Args) :- Goal),Tail,V,L) :- !,
NN is N + 4,
push_v(NN,V),
get_A(V,[[0|_]|_]) ->
wrap(compile_goal((begin_att,Impr,pop(4),end_att,Goal),Tail,V,L),L);
wrap(compile_goal((begin_att,Impr,pop(4),Goal),Tail,V,L),L).
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).
compile_goal((F :- Goal),Tail,V,L) :- !,
push_v(4,V),
......@@ -166,6 +166,14 @@ 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]) :- !,
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(extended_on(|L),Tail,V,[L,L]) :- !,
set_extended(L).
......
......@@ -30,6 +30,15 @@ chech_push(F) :-
handle([label,N],[I,L],[II,LL]) :- !,
N=I,I=II,LL=L.
handle(['cc'],I,II,L,LL) :-
'cc-call'(I,II,L,LL).
handle(['clear-sp'],I,0,L,LL) :- !,
'clear-sp'(I,0,L,LL).
handle([seek,N],I,II,L,LL) :- !,
seek(N,I,II,L,LL).
handle([softie,A],I,II,L,LL) :- !,
(
(var(A) ; number(A)) ->
......@@ -42,6 +51,9 @@ handle([softie,A],I,II,L,LL) :- !,
)
).
handle(push_at(K),I,II,L,LL) :- !,
push_at(K,I,II,L,LL).
handle([(F,('newframe-light';'unwind-light-tail';'unwind-light')),
[[S,V,Q],N,F|_],A],I,II,L,LL) :-
new_var(V,Q,S),
......@@ -116,6 +128,9 @@ handle([pop,N],I,II,L,LL) :-
handle(['post-c',C],I,II,L,LL) :- !,
'post-c'(C,I,II,L,LL).
handle(['push-instruction',C],I,II,L,LL) :- !,
'push-instruction'(C,I,II,L,LL).
handle([label,N,[_,Tags]],I,II,L,LL) :- !,
L=[N|_],
addvs(Tags,L,LL).
......@@ -138,7 +153,7 @@ handle(['pre-unify',At,Vx],I,II,L,LL) :- !,
isCplx(At) ->
(
new_var(V,Q,S),
(V=[VC|_] -> E=var(VC) ; E=sp(V)),
(V=[VC|_] -> E=var(VC) ; E=svar(V)),
'pre-unify'(E,I,II,L,LL)
) ;
(L=LL,I=II)
......@@ -150,7 +165,7 @@ handle(['post-unify-tail',[[S,V,Q],N,F|_]],I,II,L,LL) :-
F==#t -> throw(end_with_no_begin) ;
(
new_var(V,Q,S),
(V=[VC|_] -> E=var(VC) ; E=sp(V)),
(V=[VC|_] -> E=var(VC) ; E=svar(V)),
'post-unify-tail'(E,I,II,L,LL)
)
).
......@@ -176,11 +191,11 @@ handle([set,(W,[[S,V,Q],N,F|_])],I,II,L,LL) :- !,
handle(['push-variable',[[S,V,Q],N,F|_]],I,II,L,LL) :- !,
(
(F==#t,N==1) -> pushv(#f,L,LL);
F==#t -> (new_var(V,Q,S), pushv(V,L,LL));
F==#t -> (new_var(V,Q,S), pushv(V,L,LL));
(
new_var(V,Q,S),
(V=[VC|_] -> Q=sp(VC) ; Q=V),
'push-variable-s'(Q,I,II,L,LL)
(V=[VC|_] -> QQ=svar(VC) ; QQ=V),
'push-variable'(QQ,I,II,L,LL)
)
).
......@@ -188,7 +203,11 @@ handle(['push-variable-scm',[[S,V,Q],N,F|_]],I,II,L,LL) :- !,
(
F==#t ->
throw(first_variable_in_scheme_context);
'push-variable-scm'(V,I,II,L,LL)
(
new_var(V,Q,S),
(V=[VC|_] -> QQ=svar(VC) ; QQ=V),
'push-variable'(QQ,I,II,L,LL)
)
).
handle([comp,CMP,[[S1,V1,Q1],N1,F1|_],
......@@ -295,9 +314,7 @@ handle([unify,[[S,V,Q],N,F|_],M],I,II,L,LL) :- !,
M=#f -> gfalse(I,II,L,LL);
(
new_var(V,Q,S),
write(thecase),nl,
code([unify,M,V,#f],K,VV,Unify),
write(got(Unify,K,VV)),nl,
Unify(K,VV,I,II,L,LL)
)
);
......@@ -321,24 +338,24 @@ handle([U,[[S,V,Q],N,F|_],A,M],I,II,L,LL) :- !,
(F==#t,S==#t) ->
(
new_var(V,Q,S),
(V=[VC|_] -> E=sp(VC) ; E=var(V)),
(V=[VC|_] -> E=svar(VC) ; E=var(V)),
U(M,XX,E,#t,I,II,L,LL)
);
F==#t ->
(
new_var(V,Q,S),
(V=[VC|_] -> E=sp(VC) ; E=var(V)),
(V=[VC|_] -> E=svar(VC) ; E=var(V)),
U(M,XX,E,#f,I,II,L,LL)
) ;
N==1 ->
(
new_var(V,Q,S),
(V=[VC|_] -> E=sp(VC) ; E=var(V)),
(V=[VC|_] -> E=svar(VC) ; E=var(V)),
U(M,XX,E,1,I,II,L,LL)
) ;
(
new_var(V,Q,S),
(V=[VC|_] -> E=sp(VC) ; E=var(V)),
(V=[VC|_] -> E=svar(VC) ; E=var(V)),
U(M,XX,E,0,I,II,L,LL)
)
)
......@@ -445,7 +462,7 @@ code([unify,M,V,K],Code,Q,Action) :- !,
(M\\=#f,K=#f) ->
(
V=[U|_] ->
(Action = 'sp-move', Q = sp(U));
(Action = 'sp-move', Q = svar(U));
(Action = 'sp-move', Q = var(V))
) ;
(
......@@ -457,7 +474,7 @@ code([unify,M,V,K],Code,Q,Action) :- !,
MC=M
),
write(3),
(V=[VC|_] -> (A=1,Q=sp(VC)) ; (Q=var(V), A=0)),
(V=[VC|_] -> (A=1,Q=svar(VC)) ; (Q=var(V), A=0)),
(
K = #f -> KC=2 ;
K = #t -> KC=3 ;
......@@ -475,8 +492,8 @@ code(['unify-2',M,V1,K1,V2,K2],Code,Q1,Q2) :- !,
M = #t -> MC=3 ;
MC=M
),
(V1=[V1C|_] -> (A1=1,Q1=sp(V1C)) ; (V1=V1C, A1=0, Q1=var(V1))),
(V2=[V2C|_] -> (A2=1,Q2=sp(V2C)) ; (V2=V2C, A2=0, Q2=var(V2))),
(V1=[V1C|_] -> (A1=1,Q1=svar(V1C)) ; (V1=V1C, A1=0, Q1=var(V1))),
(V2=[V2C|_] -> (A2=1,Q2=svar(V2C)) ; (V2=V2C, A2=0, Q2=var(V2))),
(
K1 = #f -> K1C=2 ;
K1 = #t -> K1C=3 ;
......
......@@ -83,7 +83,7 @@
(define (get-svarn s q)
(let* ((h (fluid-ref *svarn*))
(i (vhashq-ref h q 0)))
(i (vhashq-ref h q 2)))
(let ()
(fluid-set! *svarn* (vhash-consq q (+ i 1) h))
(cons i 0))))
......
......@@ -14,7 +14,7 @@
#:use-module (logic guile-log vm utils)
#:use-module (logic guile-log vm fkn)
#:export (in-call cc-call tail-call post-call post-unicall))
#:export (in-call cc-call in-tailcall post-call post-unicall))
(compile-prolog-string
"
......
......@@ -7,7 +7,7 @@
#:use-module (logic guile-log vm utils)
#:replace (cutter goto-inst sp-move equal-instruction
push-instruction pushv push-variable
pop-variable pop seek dup clear-sp))
pop-variable pop seek dup clear-sp push_at))
(compile-prolog-string
"
......@@ -32,7 +32,11 @@
scmcall('gp-prune',[scut],I,_,L7,L8),
reset(I,L8,LL).
-trace.
push_at(K,I,II,L,LL) :-
gset(sp(I),svar(K),I,L,LL),
II is I + 1.
'sp-move'(_,V,I,II,L,LL) :-
II is I - 1,
gset(V,sp(II),I,L,L1),
......@@ -42,7 +46,8 @@
pltest('equal?',[sp(I-1),c(C)],I,L,L2),
II is I - 1,
reset(II,L2,LL).
-trace.
'push-instruction'(C,I,II,L,LL) :-
gset(sp(I),c(C),I,L,L1),
II is I + 1,
......@@ -54,6 +59,7 @@
II is I + 1,
reset(II,L2,LL).
-trace.
'push-variable'(V,I,II,L,LL) :-
gset(sp(I),V,I,L,L1),
II is I + 1,
......
......@@ -39,7 +39,7 @@
'post-unify-tail'(V,I,0,L,LL) :-
gref(V,I,L,L1),
II is I + 1,
gref(c(delayers),II,L3,L4),
gref(c(delayers),II,L1,L4),
generate(eq(I,II),L4,L5),
generate(je(E),L5,L6),
III is II + 1,
......@@ -110,12 +110,12 @@
).
'unify-instruction-2'(M,C,V,K,I,II,L,LL) :- 'unify-constant-2'(M,C,V,K,I,II,L,LL).
-trace.
'unify-constant-2'(M,C,V,K,I,I,L,LL) :-
(
K == #f ->
gset(V,c(C),I,L,LL);
(
(
M == #f ->
(
pltest('gp-m-unify',[V,c(C),s],I,_,L,L2),
......@@ -129,7 +129,7 @@
),
reset(I,L1,LL)
)
)
)
).
'unify-instruction'(C,M,I,II,L,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
scmtailcall scmtailcall2 scmcall1 generate
label gfalse gtrue isTrue pltest lookup2
test sp cc s c vec cut stack call? scut pp pltest_s))
label gfalse gtrue isTrue pltest lookup2 svar
test sp cc s c vec cut stack call? scut pp pltest_s base))
(define base (gp-make-var))
(compile-prolog-string
"
generate(Tok,[Tok|LL],LL).
id(s ,sp(0)).
id(p ,sp(1)).
id(s ,svar(0)).
id(p ,svar(1)).
id(cut ,var(0)).
id(scut ,var(1)).
id(vec ,var(2)).
......@@ -33,34 +36,44 @@
reset(I,L,LL) :-
call(II is I),
generate(reset(II),L,LL).
generate(reset(base+II),L,LL).
varref(Pos,I,II,L,LL) :-
generate('vector-ref'(I,0,Pos),L,LL),
generate('vector-ref'(base+I,0,Pos),L,LL),
II is I + 1.
varset(I,J,L,LL) :-
generate('vector-set!'(3,I,base+J),L,LL).
varset_s(I,J,L,LL) :-
generate('vector-set!'(3,I,J),L,LL).
constant(C,I,L,LL) :-
generate(constant(I,C),L,LL).
move(I,J,L,LL) :-
call(II is I),
call(JJ is J),
generate(move(JJ,II),L,LL).
generate(move(J,I),L,LL).
-trace.
gref(c(X),I,L,LL) :- !,
constant(X,I,L,LL).
call(II is I),
constant(X,base+II,L,LL).
gref(var(X),I,L,LL) :- !,
varref(X,I,_,L,LL).
call(II is I),
varref(X,II,_,L,LL).
gref(sp(X),I,L,LL) :- !,
move(X,I,L,LL).
call(XX is X),
call(II is I),
move(XX,base + II,L,LL).
gref(svar(X),I,L,LL) :- !,
call(XX is X),
call(II is I),
move(XX,base + II,L,LL).
gref(l(X),I,L,LL) :- !,
generate('label-ref'(I,X),L,LL).
generate('label-ref'(base+I,X),L,LL).
gref(A,I,L,LL) :-
id(A,X),!,
......@@ -69,14 +82,17 @@
gref(A,I,L,LL) :-
e(A,I,_,L,LL).
vset(I,sp(J),I,L,LL) :- !,
vset(K,sp(J),I,L,LL) :- !,
call(JJ is J),
varset(I,JJ,L,LL).
varset(K,JJ,L,LL).
vset(J,var(X),I,L,LL) :- !,
gref(var(X),I,L,L2),
varset(J,I,L2,LL).
vset(J,svar(X),I,L,LL) :- !,
varset_s(J,X,L2,LL).
vset(J,c(X),I,L,LL) :- !,
gref(c(X),I,L,L2),
varset(J,I,L2,LL).
......@@ -85,27 +101,57 @@
id(X,XX),
vset(J,XX,I,L,LL).
-trace.
sset(K,sp(J),I,L,LL) :- !,
move(J,K,L,LL).
move(base+J,base+K,L,LL).
sset(K,svar(J),I,L,LL) :- !,
call(KK is K),
move(J,base+KK,L,LL).
sset(J,var(X),I,L,LL) :- !,
gref(var(X),I,L,L2),
move(I,J,L2,LL).
call(JJ is J),
move(base+I,base+JJ,L2,LL).
sset(J,c(X),I,L,LL) :- !,
gref(c(X),I,L,L2),
move(I,J,L2,LL).
call(JJ is J),
gref(c(X),JJ,L,LLL).
sset(J,X,I,L,LL) :-
id(X,XX),
sset(J,XX,I,L,LL).
cset(K,sp(J),I,L,LL) :- !,
move(base+J,K,L,LL).
cset(K,svar(J),I,L,LL) :- !,
call(KK is K),
move(J,KK,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).
cset(J,c(X),I,L,LL) :- !,
gref(c(X),I,L,L2),
call(JJ is J),
move(base+I,JJ,L2,LL).
cset(J,X,I,L,LL) :-
id(X,XX),
cset(J,XX,I,L,LL).
gset(var(V),Val,I,L,LL) :- !,
vset(V,Val,I,L,LL).
gset(sp(V),Val,I,L,LL) :- !,
sset(V,Val,I,L,LL).
gset(svar(V),Val,I,L,LL) :- !,
cset(V,Val,I,L,LL).
gset(X,Val,I,L,LL) :-
id(X,XX),
gset(XX,Val,I,L,LL).
......@@ -118,30 +164,18 @@
I = N,
generate('pl-setup-frame',L4,LL).
-trace.
args([],I,I,L,L).
args([X|A],I,II,L,LL) :-
gref(X,I,L,L1),
I1 is I + 1,
args(A,I1,II,L1,LL).
scmcall(F,Args,I,II,L,LL) :-
length(Args,N),
NN is N + 1,
NNN is I + NN,
reset(NNN,L,L1),
args(Args,I,I1,L1,L2),
gref(c(F),I1,L2,L3),
I2 is I1 + 1,
generate(handle_interupts,L3,L4),
generate(call(I2,NN),L4,L5),
II is I2 + 1,
reset(II,L5,LL).
scmcall1(F,Args,I,II,L,LL) :-
scmcalln(K,F,Args,I,II,L,LL) :-
length(Args,N),
NN is N + 2,
NNN is I + NN - 1,
NN is N + 1 + K,
NNN is I + NN - K,
reset(NNN,L,L1),
args(Args,I,I1,L1,L2),
gref(c(F),I1,L2,L3),
......@@ -150,11 +184,16 @@
generate(call(I2,NN),L4,L5),
II is I2 + 1,
reset(II,L5,LL).
scmtailcall(F,Args,I,II,L,LL) :-
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,
NNN is I + NN,
NN is N + 1 + K,
NNN is I + NN - K,
reset(NNN,L,L1),
args(Args,I,I1,L1,L2),
gref(c(F),I1,L2,L3),
......@@ -162,16 +201,8 @@
generate(handle_interupts,L3,L4),
generate(tailcall(I2,NN),L4,L5).
scmtailcall2(F,Args,I,II,L,LL) :-
length(Args,N),
NN is N + 1 + 2,
NNN is I + NN - 2,
reset(NNN,L,L1),
args(Args,I,I1,L1,L2),
gref(c(F),I1,L2,L3),
I2 is I1 + 1,
generate(handle_interupts,L3,L4),
generate(tailcall(I2,NN),L4,L5).
scmtailcall(F,Args,I,II,L,LL) :- scmtailcalln(0,F,Args,I,II,L,LL).
scmtailcall2(F,Args,I,II,L,LL) :- scmtailcalln(2,F,Args,I,II,L,LL).
j(Label,L,LL) :-
generate(j(Label),L,LL).
......@@ -184,8 +215,8 @@
label(Label,L,LL) :-
generate(label(Label),L,LL).
gfalse(P,I,L,LL) :-
gfalse(I,II,L,LL) :-
gref(p,I,L,L2),
generate('immediate-tag?='(I,7,0),L2,L3),
generate(je(Lab),L3,L4),
......@@ -194,18 +225,18 @@
generate(tailcall(I,0),L6,LL).
gtrue(I,L,L).
isTrue(sp(I),I,Label,L,LL) :-
call(II is I),
generate(test1(true,II,Label),L,LL).
isTrue(sp(J),Label,L,LL) :-
call(JJ is J),
generate(test1(true,JJ,Label),L,LL).
isProcedure(sp(J),Label,I,L,LL) :-
call(JJ is J),
generate(test1(isProcedure,JJ,Label),L,LL).
pltest(F,A,I,II,L,LL) :-
scmcall(F,A,I,II,L,L1),
isTrue(sp(II-1),II,Label,L1,L2),
isTrue(sp(II-1),Label,L1,L2),
gfalse(II,_,L2,L3),
label(Label,L3,LL).
......
......@@ -17,19 +17,19 @@
restore-c restore-pc fail-psc fail-pc
;; call
in-call cc-call tail-call post-call post-unicall
in-call cc-call in-tailcall post-call post-unicall
;; newframe
newframe-ps newframe-pst newframe-light newframe
newframe-negation store-state store-ps store-p
;; utils
gfalse gtrue sp
gfalse gtrue sp svar
;; push
cutter goto-inst sp-move equal-instruction
push-instruction pushv push-variable
pop-variable pop seek dup clear-sp
pop-variable pop seek dup clear-sp push_at
;; unify
ggset unify unify-2 unify-constant-2
......
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