operaters start working

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