operaters start working

parent acf5b1ea
...@@ -222,7 +222,6 @@ compile_goal(';'(|X),Tail,V,[L,LL]) :- !, ...@@ -222,7 +222,6 @@ compile_goal(';'(|X),Tail,V,[L,LL]) :- !,
( (
get_AB2ESM(V,Aq,B2,E,S,M), get_AB2ESM(V,Aq,B2,E,S,M),
get_F(V,F), get_F(V,F),
label(Lab),label(Out),
push_Q(0,V,Q), push_Q(0,V,Q),
compile_disjunction(XX,#t,Aq,Ae,Out,Lab,LabA,Tail,S,U,B2,V,LM),!, compile_disjunction(XX,#t,Aq,Ae,Out,Lab,LabA,Tail,S,U,B2,V,LM),!,
(zero(V) -> Tp is 0 ; Tp is 1), (zero(V) -> Tp is 0 ; Tp is 1),
...@@ -539,6 +538,7 @@ compile_goal((m_and(Op,m_or(<,>,=<,>=,=:=,=\\=,@<,@=<,@>,@>=)))(X,Y), ...@@ -539,6 +538,7 @@ compile_goal((m_and(Op,m_or(<,>,=<,>=,=:=,=\\=,@<,@=<,@>,@>=)))(X,Y),
Tail,V,[L,LL]) :- !, Tail,V,[L,LL]) :- !,
check_tail(Tail), check_tail(Tail),
tail(Tail,LL,LLL), tail(Tail,LL,LLL),
get_P(V,P),
ifc(compile_scm(X,V,L,LX),EX, ifc(compile_scm(X,V,L,LX),EX,
( (
ifc(compile_scm(Y,V,L,LY),EY, ifc(compile_scm(Y,V,L,LY),EY,
...@@ -551,7 +551,7 @@ compile_goal((m_and(Op,m_or(<,>,=<,>=,=:=,=\\=,@<,@=<,@>,@>=)))(X,Y), ...@@ -551,7 +551,7 @@ compile_goal((m_and(Op,m_or(<,>,=<,>=,=:=,=\\=,@<,@=<,@>,@>=)))(X,Y),
binop1L(Or,O), binop1L(Or,O),
tr(O,OO), tr(O,OO),
LY=[[OO,EX]|LLL] LY=[[OO,P,EX]|LLL]
)) ))
), ),
ifc(compile_scm(Y,V,LX,LY),EY, ifc(compile_scm(Y,V,LX,LY),EY,
...@@ -559,13 +559,13 @@ compile_goal((m_and(Op,m_or(<,>,=<,>=,=:=,=\\=,@<,@=<,@>,@>=)))(X,Y), ...@@ -559,13 +559,13 @@ compile_goal((m_and(Op,m_or(<,>,=<,>=,=:=,=\\=,@<,@=<,@>,@>=)))(X,Y),
push_v(-1,V), push_v(-1,V),
binop1L(Op,O), binop1L(Op,O),
tr(O,OO), tr(O,OO),
LX=[[OO,EY]|LLL] LX=[[OO,P,EY]|LLL]
), ),
( (
push_v(-2,V), push_v(-2,V),
tr(Op,OOp), tr(Op,OOp),
binop(OOp,O), binop(OOp,O),
LY=[[Op]|LLL] LY=[[Op,P]|LLL]
))). ))).
compile_goal(X is Y,Tail,V,L) :- !, compile_goal(X is Y,Tail,V,L) :- !,
...@@ -644,7 +644,7 @@ compile_goal(X == Y,Tail,V,L) :- !, ...@@ -644,7 +644,7 @@ compile_goal(X == Y,Tail,V,L) :- !,
( (
X==Y -> throw(#t) ; X==Y -> throw(#t) ;
zero(V) -> zero(V) ->
compile_goal((begin_att,uni(X,Y),end_att),Tail,V,L); compile_goal((begin_att,unim(X,Y),end_att),Tail,V,L);
compile_goal(uni(X,Y),Tail,V,L) compile_goal(uni(X,Y),Tail,V,L)
). ).
...@@ -653,6 +653,11 @@ compile_goal(uni(X,Y),Tail,V,[L,LL]) :- !, ...@@ -653,6 +653,11 @@ compile_goal(uni(X,Y),Tail,V,[L,LL]) :- !,
tail(Tail,LL,LLL), tail(Tail,LL,LLL),
compile_unify(X,Y,V,[L,LLL],#t). compile_unify(X,Y,V,[L,LLL],#t).
compile_goal(unim(X,Y),Tail,V,[L,LL]) :- !,
check_tail(Tail),
tail(Tail,LL,LLL),
compile_unify(X,Y,V,[L,LLL],#f).
compile_goal(imprint(X,M),Tail,V,[L,LL]) :- !, compile_goal(imprint(X,M),Tail,V,[L,LL]) :- !,
check_tail(Tail), check_tail(Tail),
tail(Tail,LL,LLL), tail(Tail,LL,LLL),
......
...@@ -33,6 +33,9 @@ handle([label,N],[I,L],[II,LL]) :- !, ...@@ -33,6 +33,9 @@ handle([label,N],[I,L],[II,LL]) :- !,
handle(['cc'],I,II,L,LL) :- handle(['cc'],I,II,L,LL) :-
'cc-call'(I,II,L,LL). 'cc-call'(I,II,L,LL).
handle([('unify-constant';'unify-instruction'),C,M],I,II,L,LL) :-
'unify-instruction'(C,M,I,II,L,LL).
handle([\"label\",C],I,II,L,LL) :- handle([\"label\",C],I,II,L,LL) :-
I=II, I=II,
inlabel(C,L,LL). inlabel(C,L,LL).
...@@ -58,6 +61,60 @@ handle(['pushtail-3',P],I,II,L,LL) :- !, ...@@ -58,6 +61,60 @@ handle(['pushtail-3',P],I,II,L,LL) :- !,
handle([seek,N],I,II,L,LL) :- !, handle([seek,N],I,II,L,LL) :- !,
seek(N,I,II,L,LL). seek(N,I,II,L,LL).
handle(['mk-cons'],I,II,L,LL) :- !,
'mk-cons'(I,II,L,LL).
handle(['mk-fkn',N],I,II,L,LL) :- !,
'mk-fkn'(N,I,II,L,LL).
handle(['mk-curly'],I,I,L,LL) :- !,
'mk-curly'(I,L,LL).
handle(['icons!'],I,II,L,LL) :-
'icons!'(I,II,L,LL).
handle(['ifkn!'],I,I,L,LL) :-
'ifkn!'(I,L,LL).
handle(['icurly!'],I,I,L,LL) :-
'icurly!'(I,L,LL).
handle(['icons'],I,II,L,LL) :-
'icons'(I,II,L,LL).
handle(['ifkn'],I,I,L,LL) :-
'ifkn'(I,L,LL).
handle(['icurly'],I,I,L,LL) :-
'icurly'(I,L,LL).
handle([<,P],I,II,L,LL) :-
lt(P,I,II,L,LL).
handle([>,P],I,II,L,LL) :-
gt(P,I,II,L,LL).
handle([=<,P],I,II,L,LL) :-
le(P,I,II,L,LL).
handle([>=,P],I,II,L,LL) :-
ge(P,I,II,L,LL).
handle(['op2+'],I,II,L,LL) :-
plus(I,II,L,LL).
handle(['op2-'],I,II,L,LL) :-
minus(I,II,L,LL).
handle(['op1_-'],I,II,L,LL) :-
minus1(I,II,L,LL).
handle([*],I,II,L,LL) :-
mul(I,II,L,LL).
handle([/],I,II,L,LL) :-
divide(I,II,L,LL).
handle([softie,A],I,II,L,LL) :- !, handle([softie,A],I,II,L,LL) :- !,
( (
(var(A) ; number(A)) -> (var(A) ; number(A)) ->
...@@ -73,11 +130,11 @@ handle([softie,A],I,II,L,LL) :- !, ...@@ -73,11 +130,11 @@ handle([softie,A],I,II,L,LL) :- !,
handle(push_at(K),I,II,L,LL) :- !, handle(push_at(K),I,II,L,LL) :- !,
push_at(K,I,II,L,LL). push_at(K,I,II,L,LL).
handle([(F,('newframe-light';'unwind-light-tail';'unwind-light')), handle([(FF,('newframe-light';'unwind-light-tail';'unwind-light')),
[[S,V,Q],N,F|_],A],I,II,L,LL) :- [[S,V,Q],N,F|_],A],I,II,L,LL) :-
new_var(V,Q,S), new_var(V,Q,S),
V=[VC|_], (V=[VC|_] -> E=var(VC) ; E=svar(V)),
'newframe-light'(VC,A,I,II,L,LL). FF(E,A,I,II,L,LL).
handle((X,[('goto-inst';'store-state';'unwind-tail'; handle((X,[('goto-inst';'store-state';'unwind-tail';
...@@ -196,7 +253,8 @@ handle(['post-unify',[[S,V,Q],N,F|_]],I,II,L,LL) :- ...@@ -196,7 +253,8 @@ handle(['post-unify',[[S,V,Q],N,F|_]],I,II,L,LL) :-
( (
(get_nsvars(Q,M) -> true ; M=0), (get_nsvars(Q,M) -> true ; M=0),
new_var(V,Q,S), new_var(V,Q,S),
'post-unify'(V,M,I,II,L,LL) (V=[VC|_] -> E=var(VC) ; E=svar(V)),
'post-unify'(E,M,I,II,L,LL)
) )
). ).
...@@ -486,20 +544,17 @@ code([unify,M,V,K],Code,Q,Action) :- !, ...@@ -486,20 +544,17 @@ code([unify,M,V,K],Code,Q,Action) :- !,
) ; ) ;
( (
Action=unify, Action=unify,
write(1),
( (
M = #f -> MC=2 ; M = #f -> MC=2 ;
M = #t -> MC=3 ; M = #t -> MC=3 ;
MC=M MC=M
), ),
write(3),
(V=[VC|_] -> (A=1,Q=svar(VC)) ; (Q=var(V), A=0)), (V=[VC|_] -> (A=1,Q=svar(VC)) ; (Q=var(V), A=0)),
( (
K = #f -> KC=2 ; K = #f -> KC=2 ;
K = #t -> KC=3 ; K = #t -> KC=3 ;
KC=K KC=K
), ),
write(four(A,KC,VC,MC)),
U is A + KC << 1 + VC << 3, U is A + KC << 1 + VC << 3,
Code is MC + U << 2 Code is MC + U << 2
) )
......
(define-module (logic guile-log guile-prolog vm vm-handle) (define-module (logic guile-log guile-prolog vm vm-handle)
#:use-module (logic guile-log) #:use-module (logic guile-log)
#:use-module (logic guile-log iso-prolog) #:use-module ((logic guile-log iso-prolog)
#:renamer
(lambda (x)
(if (eq? x 'plus)
'swi:plus
x)))
#:use-module (logic guile-log guile-prolog hash) #:use-module (logic guile-log guile-prolog hash)
#:use-module (logic guile-log guile-prolog ops) #:use-module (logic guile-log guile-prolog ops)
#:use-module (logic guile-log prolog swi) #:use-module ((logic guile-log prolog swi)
#:renamer
(lambda (x)
(if (eq? x 'plus)
'swi:plus
x)))
#:use-module (compat racket misc) #:use-module (compat racket misc)
#:use-module (logic guile-log guile-prolog vm vm-pre) #: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 guile-prolog vm vm-var)
......
...@@ -214,6 +214,8 @@ the_tr(un(X) , [unop(X,N),tr(X,N)]) :- inc(N). ...@@ -214,6 +214,8 @@ the_tr(un(X) , [unop(X,N),tr(X,N)]) :- inc(N).
(compile-prolog-string (compile-prolog-string
" "
tr(X,X) :- !.
print_error_if_fail :- print_error_if_fail :-
b_getval(pretty,#t),!, b_getval(pretty,#t),!,
write(tr_error(X)),nl,fail. write(tr_error(X)),nl,fail.
...@@ -443,6 +445,9 @@ constant(X) :- atom(X), \\+instruction(X). ...@@ -443,6 +445,9 @@ constant(X) :- atom(X), \\+instruction(X).
link_l([L,LL],[L,L1],[L1,LL]). link_l([L,LL],[L,L1],[L1,LL]).
link_l([L,LL],[L,L1],[L1,L2],[L2,LL]). link_l([L,LL],[L,L1],[L1,L2],[L2,LL]).
ff :- asserta((tr(X,X) :- !)).
") ")
(<wrap> ff)
(all-defined-out) (all-defined-out)
...@@ -37,7 +37,7 @@ ...@@ -37,7 +37,7 @@
args([cc,pp(P),s],I,II,L,LL). args([cc,pp(P),s],I,II,L,LL).
'cc-call'(I,0,L,LL) :- 'cc-call'(I,0,L,LL) :-
scmtailcall(cc,[s,pp],0,_,L,LL). scmtailcall(cc,[s,p],0,_,L,LL).
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) :-
......
...@@ -9,80 +9,45 @@ ...@@ -9,80 +9,45 @@
mk-cons mk-fkn mk-curly mk-cons mk-fkn mk-curly
icons ifkn icurly do_n_cons)) icons ifkn icurly do_n_cons))
(define fkn!? (lambda (x) x))
(compile-prolog-string (compile-prolog-string
" "
'icons!'(I,II,L,LL) :- 'icons!'(I,II,L,LL) :-
pltest_s('gp-pair!?',[sp(I-1),s],I,L,L2), J is I - 1,
scmcall('gp-cdr',[sp(I-1),s],I,I2,L2,L3), generate('icons!'(base+J),L,LL),
scmcall('gp-car',[sp(I-1),s],I2,I3,L4), II is I + 1.
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),
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),
movex(I-1,I1-1,L2,L3),
reset(I,L3,LL).
'ifkn!'(I,L,LL) :-
J is I - 1,
generate('ifkn!'(base+J),L,LL).
'icurly!'(I,L,LL) :-
J is I - 1,
generate('icurly!'(base+J),L,LL).
'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), generate('mk-cons'(base+I),L,LL),
movex(I-2,I1-1,L1,L2), II is I - 1.
II is I - 1,
reset(II,L2,LL).
do_n_cons(0,I,I,L,L) :- !.
do_n_cons(N,I,II,L,LL) :-
'mk-cons'(I,I2,L,L2),
do_n_cons(I2,II,L2,LL).
'mk-fkn'(N,I,II,L,LL) :- 'mk-fkn'(N,I,II,L,LL) :-
do_n_cons(N,I,II,L1), generate('mk-fkn'(N,base+I),L,LL),
scmcall(scm_make_vector,[c(1),c(#f)],I1,I2,L1,L2), II is I - N + 1.
scmcall('vector-set!',[sp(I2-1),c(0),sp(II-1)],I2,_,L2,L3),
movex(II-1,I2-1,L3,L4),
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), generate('mk-curly'(base+I),L,LL).
scmcall('vector-set!',[sp(I2-1),c(1),sp(I-1)],I2,_,L1,L2),
movex(I-1,I2-1,L2,L3),
reset(I,L3,LL).
icons(I,II,L,LL) :- icons(I,II,L,LL) :-
pltest('gp-pair?',[sp[-1],s],I,_,L,L1), J is I - 1,
scmcall('gp-cdr',[sp[-1],s],I,I2,L1,L2), generate(icons(base+J),L,LL),
scmcall('gp-car',[sp[-1],s],I2,I3,L2,L3), II is I + 1.
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) :- ifkn(I,L,LL) :-
pltest('fkn?',[sp(I-1)],I,_,L,L1), J is I - 1,
scmcall('vector-ref',[sp(I-1),c(0)],I,L1,L2), generate(ifkn(base+J),L,LL).
movex(I-1,I+3,L2,L3),
reset(I,L3,LL).
icurly(I,L,LL) :- icurly(I,L,LL) :-
pltest('curly?',[sp(I-1)],I,_,L,L1), J is I - 1,
scmcall('vector-ref',[sp(I-1),c(1)],I,I2,L1,L2), generate(icurly(base+J),L,LL).
movex(I-1,I2-1,L2,L3),
reset(I,L3,LL).
") ")
...@@ -62,11 +62,10 @@ ...@@ -62,11 +62,10 @@
gset(p,l(A),I1,L4,L5). gset(p,l(A),I1,L4,L5).
gset(s,sp(I1-1),I1,L5,L6), gset(s,sp(I1-1),I1,L5,L6),
reset(I,L6,LL). reset(I,L6,LL).
'newframe-light'(P,NP,I,L,LL) :- -trace.
sset(P,p,I,L,L1), 'newframe-light'(P,NP,I,I,L,LL) :-
gset(p,l(NP),I,L1,L2), gset(P,p,I,L,LL).
reset(I,L2,LL).
newframe(NP,TP,I,L,LL) :- newframe(NP,TP,I,L,LL) :-
gset(sp(I),l(NP),I,L,L1), gset(sp(I),l(NP),I,L,L1),
......
(define-module (logic guile-log vm op) (define-module (logic guile-log vm op)
#:use-module (logic guile-log vm utils) #:use-module (logic guile-log vm utils)
#:use-module (logic guile-log guile-prolog ops)
#:use-module ((logic guile-log iso-prolog) #:use-module ((logic guile-log iso-prolog)
#:renamer #:renamer
(lambda (s) (lambda (s)
...@@ -14,20 +15,32 @@ ...@@ -14,20 +15,32 @@
(compile-prolog-string (compile-prolog-string
" "
cmp(Op,I,II,L,LL) :- ggfalse(procedure,L,LL) :-
generate(tailcall(0),L,LL).
ggfalse(ground(P),L,LL) :-
generate(goto(P),L,LL).
ggfalse(complex,L,LL) :-
gfalse(L,LL).
ggfalse(\"\",L,LL) :-
generate(tailcall(0),L,LL).
cmp(Op,P,I,II,L,LL) :-
lookup2(I,L,L1), lookup2(I,L,L1),
II is I - 2, II is I - 2,
test(Op,sp[I-2],sp[I-1],Label,I,L1,L2), III is I - 1,
gfalse(II,L2,L3), generate(Op(base+II,base+III),L1,L2),
label(Label,L3,L4), generate(je(Label),L2,L3),
reset(II,L4,LL). ggfalse(P,L3,L4),
label(Label,L4,L5),
gt(I,II,L,LL) :- cmp(gt,I,II,L,LL). reset(II,L5,LL).
lt(I,II,L,LL) :- cmp(lt,I,II,L,LL).
ge(I,II,L,LL) :- cmp(ge,I,II,L,LL). gt(P,I,II,L,LL) :- cmp(gt,P,I,II,L,LL).
le(I,II,L,LL) :- cmp(le,I,II,L,LL). lt(P,I,II,L,LL) :- cmp(lt,P,I,II,L,LL).
eq(I,II,L,LL) :- cmp(eq,I,II,L,LL). ge(P,I,II,L,LL) :- cmp(ge,P,I,II,L,LL).
neq(I,II,L,LL) :- cmp(neq,I,II,L,LL). le(P,I,II,L,LL) :- cmp(le,P,I,II,L,LL).
eq(P,I,II,L,LL) :- cmp(eq,P,I,II,L,LL).
neq(P,I,II,L,LL) :- cmp(neq,P,I,II,L,LL).
trbpo(plus , plus). trbpo(plus , plus).
trbpo(minus , minus). trbpo(minus , minus).
...@@ -44,9 +57,11 @@ ...@@ -44,9 +57,11 @@
binop(Bop,I,II,L,LL) :- binop(Bop,I,II,L,LL) :-
lookup2(I,L,L1), lookup2(I,L,L1),
trbop(Bop,Nm), trbop(Bop,Nm),
generate(Bop(I-2,I-1,I-2),L3,L4), I1 is I - 2,
I2 is I - 1,
generate(Bop(base + I1, base + I2, base + I1),L1,L2),
II is I - 1, II is I - 1,
reset(II,L4,LL). reset(II,L2,LL).
plus(I,II,L,LL) :- binop(plus,I,II,L,LL). plus(I,II,L,LL) :- binop(plus,I,II,L,LL).
......
...@@ -64,6 +64,9 @@ ...@@ -64,6 +64,9 @@
pop(N,I,II,L,L) :- pop(N,I,II,L,L) :-
II is I - N. II is I - N.
pop(I,II,L,L) :-
II is I - 1.
seek(N,I,II,L,L) :- seek(N,I,II,L,L) :-
......
...@@ -26,15 +26,9 @@ ...@@ -26,15 +26,9 @@
gset('call?',c(0),I,L,L1), gset('call?',c(0),I,L,L1),
gset(V,c(delayers),I,L1,LL). gset(V,c(delayers),I,L1,LL).
'post-unify'(V,Nsloc,I,L,LL) :- 'post-unify'(V,Nsloc,I,I,L,LL) :-
gref(V,I,L,L1), gref(V,I,L,L2),
II is I + 1, generate('post-unify'(base+I),L2,LL).
gset(V,c(#f),II,L2,L3),
gref(c(delayers),II,L3,L4),
generate(eq(I,II),L4,L5),
generate(je(E),L5,L6),
generate('delay-call'(Nsloc),L6,LL),
label(E,LL).
'post-unify-tail'(V,I,0,L,LL) :- 'post-unify-tail'(V,I,0,L,LL) :-
gref(V,I,L,L1), gref(V,I,L,L1),
...@@ -47,19 +41,21 @@ ...@@ -47,19 +41,21 @@
label(E,L8,L9), label(E,L8,L9),
'cc-call'(I,_,L9,LL). 'cc-call'(I,_,L9,LL).
-trace.
unify(Code,V,I,II,L,LL) :- unify(Code,V,I,II,L,LL) :-
M is (Code /\\ 3), M is (Code /\\ 3),
A is (Code /\\ 4) >> 2, A is (Code /\\ 4) >> 2,
K is (Code /\\ 24) >> 3, K is (Code /\\ 24) >> 3,
gset(sp(I),V,I,L,L1),
( (
M==2 -> M==2 ->
pltest('gp-m-unify',[V,sp(I-1),s],I,_,L,L1); generate('gp-m-unify',L1,L2);
(M==3 ; K==3) -> (M==3 ; K==3) ->
pltest_s('gp-unify-raw',[V,sp(I-1),s],I,L,L1); generate('gp-unify-raw',L1,L2);
pltest_s('gp-unify',[V,sp(I-1),s],I,L,L1) generate('gp-unify',L1,L2)
), ),
II is I - 1, II is I - 1,
reset(II,L1,LL). reset(II,L2,LL).
...@@ -118,25 +114,30 @@ ...@@ -118,25 +114,30 @@
( (
M == #f -> M == #f ->
( (
pltest('gp-m-unify',[V,c(C),s],I,_,L,L2), gset(sp(I),V,L,L1),
gset(sp(I+1),c(C),L,L1),
generate('gp-m-unify',L1,L2),
reset(I,L2,LL) reset(I,L2,LL)
); );
( (
gset(sp(I),V,L,L1),
gset(sp(I+1),c(C),L,L1),
( (
(M=#t;K=#t) -> (M=#t;K=#t) ->
pltest_s('gp-unify-raw',[V,c(C),s],I,L,L1); generate('gp-unify-raw',L1,L2);
pltest_s('gp-unify',[V,c(C),s],I,L,L1) generate('gp-unify',L1,L2)
), ),
reset(I,L1,LL) reset(I,L2,LL)
) )
) )
). ).
'unify-instruction'(C,M,I,II,L,LL) :- 'unify-instruction'(C,M,I,II,L,LL) :-
gref(c(C),I,L,L1),
( (
M == #f -> M == #f ->
pltest('gp_m_unify',[sp(I-1),c(C),s],I,_,L,L2); generate('gp_m_unify',L1,L2);
pltest_S('gp-unify-raw',[sp(I-1),c(C),s],I,L,L2) generate('gp-unify-raw',L1,L2)
), ),
II is I - 1, II is I - 1,
reset(II,L2,LL) reset(II,L2,LL)
......
(define-module (logic guile-log vm utils) (define-module (logic guile-log vm utils)
#:use-module (logic guile-log)
#: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 movex scmcall make_p make_cc j je jne #:export (reset gset gref move movex scmcall make_p make_cc j je jne
...@@ -10,6 +11,28 @@ ...@@ -10,6 +11,28 @@
(define base (gp-make-var)) (define base (gp-make-var))
(define i 0)
(define constants (make-hash-table))
(define init-constants
(lambda ()
(set! i 0)
(set! constants (make-hash-table))))
(<define> (getconst n c l ll)
(let ((c (<lookup> c)))
(cond
((or (string? c) (number? c) (boolean? c) (symbol? c) (keyword? c))
(<=> l (("get-constant" n c) . ll)))
(else
(let ((it (hashq-ref constants c)))
(if it
(ssset n it l ll)
(let ((it i))
(<code>
(hashq-set! constants c i)
(set! i (+ i 1)))
(ssset n it l ll))))))))
(compile-prolog-string (compile-prolog-string
" "
generate(Tok,[Tok|LL],LL). generate(Tok,[Tok|LL],LL).
...@@ -17,6 +40,7 @@ ...@@ -17,6 +40,7 @@
id(s ,svar(1)). id(s ,svar(1)).
id(p ,svar(0)). id(p ,svar(0)).
id(vec ,svar(2)). id(vec ,svar(2)).
id(const ,svar(3)).
id(cut ,var(0)). id(cut ,var(0)).
id(scut ,var(1)). id(scut ,var(1)).
id(stack ,var(3)). id(stack ,var(3)).
...@@ -102,9 +126,6 @@ ...@@ -102,9 +126,6 @@
Pos is I + 1, Pos is I + 1,
generate('scm-set!/immediate'(IVEC,Pos,J),L,LL). generate('scm-set!/immediate'(IVEC,Pos,J),L,LL).
constant(C,I,L,LL) :-
generate(constant(I,C),L,LL).
move(I,J,L,LL) :- move(I,J,L,LL) :-
generate(mov(I,J),L,LL). generate(mov(I,J),L,LL).
...@@ -120,15 +141,20 @@ ...@@ -120,15 +141,20 @@
gref(c(X),sp(I),L,LL) :- !, gref(c(X),sp(I),L,LL) :- !,
call(II is I), call(II is I),
constant(X,base+II,L,LL). getconst(base+II,X,L,LL).
gref(c(X),svar(I),L,LL) :- !, gref(c(X),svar(I),L,LL) :- !,
call(II is I), call(II is I),
constant(X,II,L,LL). getconst(II,X,L,LL).
gref(c(X),I,L,LL) :- !, gref(c(X),I,L,LL) :- !,
call(II is I), call(II is I),
constant(X,base+II,L,LL). getconst(II,X,L,LL).
gref(const(X),svar(I),L,LL) :- !,
call(II is I),
id(const,svar(S)),
generate('scm-ref/immediate'(II,S,X),L,LL).
gref(var(X),sp(I),L,LL) :- gref(var(X),sp(I),L,LL) :-
varref(X,sp(I),_,L,LL). varref(X,sp(I),_,L,LL).
...@@ -195,6 +221,10 @@ ...@@ -195,6 +221,10 @@
call(JJ is J), call(JJ is J),
gref(c(X),JJ,L,LL). gref(c(X),JJ,L,LL).
ssset(J,X,L,LL) :- !,
id(const,svar(S)),
generate('scm-ref/immediate'(J,S,X),L,LL).