refactorisation

parent ed78e265
(define-module (logic guile-log vm fkn)
#:use-module ((logic guile-log iso-prolog)
#:renamer
(lambda (x) (if (eq? x 'reset)
'reset_iso
x)))
#:use-module (logic guile-log vm utils)
#:export (icons! ifkn! icurly!
mk-cons mk-fkn mk-curly
icons ifkn icurly))
(compile-prolog-string
"
'icons!'(I,II,L,LL) :-
pltest('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),
II is I + 1,
reset(II,L6,LL).
'ifkn!'(I,L,LL) :-
pltest('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),
reset(I,L3,LL).
'icurly!'(I,L,LL) :-
pltest('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),
reset(I,L3,LL).
'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),
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) :-
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),
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),
reset(I,L3,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),
move(sp(I2-1),I-1,L3,L4),
move(sp(I3-1),I,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),
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),
reset(I,L3,LL).
")
(define-module (logic guile-log vm op)
#:use-module (logic guile-log vm utils)
#:use-module (logic guile-log iso-prolog)
#:export (plus minus band bor xor modulo mul shift-l shift-r
divide
gt lt le eq neq))
(compile-prolog-string
"
cmp(Op,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).
trbpo(plus , plus).
trbpo(minus , minus).
trbop(band , band).
trbop(bor , bor).
trbop(xor , xor).
trbop(modulo , modulo).
trbop(mul , mul).
trbop('shift-l', lshift).
trbop('shift-r', rshift).
trbop(divide , divide).
binop(Bop,I,II,L,LL) :-
lookup2(I,L,L1),
trbop(Bop,Nm),
generate(Bop(I-2,I-1,I-2),L3,L4),
II is I - 1,
reset(II,L4,LL).
plus(I,II,L,LL) :- binop(plus,I,II,L,LL).
minus(I,II,L,LL) :- binop(minus,I,II,L,LL).
band(I,II,L,LL) :- binop(band,I,II,L,LL).
bor(I,II,L,LL) :- binop(bor,I,II,L,LL).
xor(I,II,L,LL) :- binop(xor,I,II,L,LL).
modulo(I,II,L,LL) :- binop(modulo,I,II,L,LL).
mul(I,II,L,LL) :- binop(mul,I,II,L,LL).
'shift-l'(I,II,L,LL) :- binop('shift-l',I,II,L,LL).
'shift-r'(I,II,L,LL) :- binop('shift-r',I,II,L,LL).
divide(I,II,L,LL) :- binop(divide,I,II,L,LL).
")
(define-module (logic guile-log vm utils)
#:use-module (logic guile-log iso-prolog)
#:export (reset gset gref move scmcall make_p make_cc j je jne label
gfalse isTrue pltest))
#:export (reset gset gref move scmcall make_p make_cc j je jne
label gfalse isTrue pltest lookup2
test))
(compile-prolog-string
"
......@@ -17,14 +18,14 @@
generate(reset(II),L,LL).
vareref(Pos,I,II,L,LL) :-
generate('vector-ref'(I,0,Pos),L,LL)
II is I + 1,
generate('vector-ref'(I,0,Pos),L,LL),
II is I + 1.
varset(I,J,L,LL) :-
generate('vector-set!'(3,I,J),L,LL).
const(C,I,L,LL) :-
generate(const(I,C),L,LL).
constant(C,I,L,LL) :-
generate(constant(I,C),L,LL).
move(I,J,L,LL) :-
call(II is I),
......@@ -32,7 +33,7 @@
generate(move(II,JJ),L,LL) .
gref(c(X),I,L,LL) :-
const(X,I,L,LL).
constant(X,I,L,LL).
gref(var(X),I,L,LL) :-
var_ref(X,I,L,LL).
......@@ -44,15 +45,15 @@
id(A,X),
gref(X,I,L,LL).
vset(I,sp(J),I,L,LL) :- !;
vset(I,sp(J),I,L,LL) :- !,
call(JJ is J),
varset(I,JJ,L2,LL).
vset(J,var(X),I,L,LL) :-
vset(J,var(X),I,L,LL) :- !,
gref(var(X),I,L,L1),
varset(J,I,L2,LL).
vset(J,c(X),I,L,LL) :-
vset(J,c(X),I,L,LL) :- !,
gref(c(X),I,L,L1),
varset(J,I,L2,LL).
......@@ -60,17 +61,21 @@
id(X,XX),
vset(J,XX,I,L,LL).
sset(I,sp(J),I,L,LL) :-
sset(I,sp(J),I,L,LL) :- !,
move(J,I,L,LL).
sset(J,X,I,L,LL) :-
gref(X,I,L,L1),
sset(J,var(X),I,L,LL) :- !,
gref(var(X),I,L,L1),
move(I,J,L1,LL).
sset(J,c(X),I,L,LL) :- !,
gref(c(X),I,L,L1),
move(I,J,L1,LL).
gset(var(V),Val,I,L,LL) :-
vset(V,Val,I,L,LL).
gset(sp(V),Val,I,L,LL) :-
gset(sp(V),Val,I,L,LL) :- !,
sset(V,Val,I,L,LL).
gset(X,Val,I,L,LL) :-
......@@ -78,10 +83,10 @@
gset(XX,Val,I,L,LL).
init(Nargs,Nvec,I,L,LL) :-
N is Nargs + 3;
N is Nargs + 3,
generate('pljump',L,L2),
generate('assert-narg-ee/locals'(Nargs,0),L2,L3),
generate('handle-interrupts',L3,L4)
generate('handle-interrupts',L3,L4),
I = N,
generate('pl-setup-frame',L4,LL).
......@@ -99,9 +104,11 @@
reset(NNN,L,L1),
args(Args,I,I1,L1,L2),
gref(F,I1,L2,L3),
II is I1 + 1,
I2 is I1 + 1,
generate(handle_interupts,L3,L4),
generate(call(II,NN),L3,LL).
generate(call(I2,NN),L3,L4),
II is I2 + 1,
reset(II,L4,LL).
make_p(I,L,LL) :-
scmcall('gp-make-p',[self,p],I,L,L1),
......@@ -134,14 +141,23 @@
isTrue(sp(I),Label,I,L,LL) :-
call(II is I),
generate(test(true,II,Label),L,LL).
generate(test1(true,II,Label),L,LL).
pltest(F,A,I,L,LL) :-
scmcall(F,A,I,II,L,L1),
III is II + 2,
isTrue(sp(II + 1),III,Label,L1,L2),
false(L2,L3),
gfalse(L2,L3),
label(Label,L3,L4),
gset(s,sp(II + 1),III,L4,L5),
reset(I,L5,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).
test(Op,A,B,Label,I,L,LL) :-
generate(test2(Op,A,B,Label),L,LL).
")
(define-module (logic guile-log vm vm.scm)
(define-module (logic guile-log vm vm)
#:use-module (logic guile-log iso-prolog)
#:use-module (system vm assembler)
#:export (softie newframe-light unwind-light-tail unwind-light
#:use-module (logic guile-log vm op)
#:use-module (logic guile-log vm fkn)
#:use-module (logic guile-log vm utils)
#:re-export (softie newframe-light unwind-light-tail unwind-light
goto-inst store-state unwind-tail post-q
newframe newframe-negation
post-negation unwind unwind-negation post-s
......@@ -1196,18 +1199,6 @@
/*
(LABEL ifkn!)
(PRSTACK sp fp)
(<let*> ((x (LOOKUP (ARG -1 sp) s))
(ss (<call> gp_c_vector_x x (<c> 1) s)))
(<if> (TRUE ss)
(<let*> ((xb (<call> scm_c_vector_ref x (<c> 0))))
(<=> s ss)
(<=> (ARG -1 sp) xb)
(NEXT inst-pt))
(BACKTRACK p instructions inst-pt fp sp)))
*/
'ifkn!'(I,L,LL) :-
pltest('vector!?',[sp[I - 1]], I , L , L1),
......@@ -1215,32 +1206,7 @@
move(I+3,I-1,L2,L3),
reset(I,L3,LL).
/*
(LABEL icurly!)
(PRSTACK sp fp)
(<let*> ((x (LOOKUP (ARG -1 sp) s))
(q (<call> gp_c_vector_x x (<c> 2) s)))
(<if> (TRUE q)
(<let*> ((SCM q (<call> gp_gp_unify
(<scm> #:brace)
(<call> scm_c_vector_ref
x (<c> 0))
q)))
(<if> q
(<begin>
(<=> s q)
(<=> (ARG -1 sp)
(<call> scm_c_vector_ref x (<c> 1)))
(NEXT inst-pt))
(BACKTRACK p instructions inst-pt fp sp)))
(BACKTRACK p instructions inst-pt fp sp)))
*/
'icurly!'(I,L,LL)
pltest('curly!?',[sp[I - 1]], I , L , L1),
scmcall('curly-ref',[sp[I - 1],const(0)],I,L1,L2),
move(I+3,I-1,L2,L3),
reset(I,L3,LL).
/*
(LABEL push-instruction)
......@@ -1360,201 +1326,6 @@
II is I + 1,
reset(II,L1,LL).
/*
(LABEL mk-cons)
(PRSTACK sp fp)
(DO-CONS s sp)
(NEXT inst-pt)
(define-syntax-rule (DO-CONS s sp)
(<let> ((c (<call> gp_cons_bang
(ARG -2 sp)
(ARG -1 sp)
s)))
(<=> (ARG -2 sp) c)
(CLEAR 1 sp)))
*/
'mk-cons'(I,II,L,LL) :-
scmcall(gp_cons_bang,[sp(I-2),sp(I-1),s],I,L,L1) :-
move(I+4,I-2,L1,L2),
II is I - 1,
reset(II).
/*
(LABEL mk-fkn)
(PRSTACK sp fp)
(<let*> ((int n (scm->int (<*> inst-pt))))
(<++> inst-pt)
(<recur> lp ((int i n))
(<if> (q<= i (<c> 0))
(<let> ((SCM v (<call> scm_c_make_vector
(<c> 1) (<scm> #f))))
(<call> scm_c_vector_set_x v (<c> 0) (ARG -1 sp))
(<=> (ARG -1 sp) v))
(<begin>
(DO-CONS s sp)
(<next> lp (<-> i (<c> 1)))))))
(NEXT inst-pt)
*/
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) :-
do_n_cons(N,I,II,L1),
scmcall(scm_make_vector,[const(1),const(#f)],II,L1,L2),
scmcall('vector-set!',[sp(II+3),const(0),sp(II-1)],L2,L3),
move(II+3,II-1),
reset(II,L3,LL).
/*
(LABEL mk-curly)
(PRSTACK sp fp)
(<let> ((SCM v (<call> scm_c_make_vector (<c> 2) (<scm> #f))))
(<call> scm_c_vector_set_x v (<c> 0) (<scm> #:brace))
(<call> scm_c_vector_set_x v (<c> 1) (ARG -1 sp))
(<=> (ARG -1 sp) v))
(NEXT inst-pt)
*/
'mk-curly'(I,L,LL) :-
scmcall('make-vector',[const(2),const(#:brace)],I,L,L1),
scmcall('vector-set!',[sp(I+3),const(1),sp(I-1)],I+4,L1,L2),
move(sp(I+3),sp(I-1),L2,L3),
reset(I,L3,LL).
/*
(LABEL icons)
(PRSTACK sp fp)
(<let*> ((SCM x (ARG -1 sp))
(SCM ss (<call> gp_pair x s)))
(<if> (TRUE ss)
(<begin>
(INCR 1 sp)
(<=> (ARG -2 sp) (<call> gp_gp_cdr x s))
(<=> (ARG -1 sp) (<call> gp_car x s))
(NEXT inst-pt))
(BACKTRACK p instructions inst-pt fp sp)))
*/
icons(I,II,L,LL) :-
pltest('gp-pair?',[sp[-1],s],I,L,L1),
scmcall('gp-cdr',[sp[-1],s],I,L,L2),
scmcall('gp-car',[sp[-1],s],I+4,L,L2),
move(sp(I+3,I-1,L2,L3),
move(sp(I+7,I,L3,L4),
II is I + 1,
reset(II,L3,LL).
/*
(LABEL ifkn)
(PRSTACK sp fp)
(<let*> ((x (<call> gp_gp_lookup (ARG -1 sp) s))
(ss (<call> gp_c_vector x (<c> 1) s)))
(<if> ss
(<let> ((xa (<call> scm_c_vector_ref x (<c> 0))))
(<=> (ARG -1 sp) xa)
(NEXT inst-pt))
(BACKTRACK p instructions inst-pt fp sp)))
*/
ifkn(I,L,LL) :-
pltest('vector?',[sp(I-1)],I,L,L1),
scmcall('vector-length',[sp(I-1)],I,L1,L2),
isEq(sp(I+2),const(1),I+3,Label,L2,L3),
false(L3,L4),
label(Label,L4,L5),
scmcall('vector-ref',[sp(I-1),const(0)],I,L5,L6),
move(I+3,I-1,L6,L7),
reset(I,L7,LL).
/*
(LABEL icurly)
(PRSTACK sp fp)
(<let*> ((x (<call> gp_gp_lookup (ARG -1 sp) s))
(ss (<call> gp_c_vector x (<c> 2) s)))
(<if> ss
(<if> (<==> (<scm> #:brace)
(<call> gp_gp_lookup
(<call> scm_c_vector_ref x (<c> 0))
s))
(<begin>
(<=> (ARG -1 sp)
(<call> scm_c_vector_ref x (<c> 1)))
(NEXT inst-pt))
(BACKTRACK p instructions inst-pt fp sp))
(BACKTRACK p instructions inst-pt fp sp)))
*/
ifcurly(I,L,LL) :-
pltest('vector?',[sp(I-1)],I,L,L1),
scmcall('vector-length',[sp(I-1)],I,L1,L2),
isEq(sp(I+2),const(2),I+3,Label,L2,L3),
false(L3,L4),
label(Label,L4,L5),
scmcall('vector-ref',[sp(I-1),const(0)],I,L5,L6),
isEq(sp(I+3),const(#:brace),Label2,L6,L7)
false(L7,L8),
scmcall('vector-ref',[sp(I-1),const(1)],I,L8,L9),
move(I+3,I-1,L6,L7),
reset(I,L9,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).
binop(Bop,I,II,L,LL) :-
lookup2(I,L,L1)
do_binop(Bop,I,II,L2,L3),
trbop(Bop,Nm)
generate(Bop(I-1,I-1,I-2),L3,L4),
II is I - 1,
reset(II,L4,LL).
plus(I,II,L,LL) :- binop(+,I,II,L,LL).
minus(I,II,L,LL) :- binop(-,I,II,L,LL).
band(I,II,L,LL) :- binop(&,I,II,L,LL).
bor(I,II,L,LL) :- binop(|,I,II,L,LL).
xor(I,II,L,LL) :- binop(^,I,II,L,LL).
modulo(I,II,L,LL) :- binop(%,I,II,L,LL).
mul(I,II,L,LL) :- binop(*,I,II,L,LL).
'shift-l'(I,II,L,LL) :- binop(<<,I,II,L,LL).
'shift-r'(I,II,L,LL) :- binop(>>,I,II,L,LL).
divide(I,II,L,LL) :- binop(/,I,II,L,LL).
/*
(define-syntax-rule (CMP op schmop p instructions inst-pt fp sp)
(<let> ((x (ARG -2 sp))
(y (ARG -1 sp)))
(CLEAR 2 sp)
(FORMAT "~a ~a ~a~%\n" x (<scm> 'schmop) y)
(<if> (<and> (<call> SCM_I_INUMP x) (<call> SCM_I_INUMP y))
(<if> (<not> (op x y))
(BACKTRACK p instructions inst-pt fp sp))
(<if> (<call> scm_is_false (<call> schmop x y))
(BACKTRACK p instructions inst-pt fp sp)))))
*/
cmp(Op,I,II,L,LL) :-
lookup(I,L,L1),
generate(test(Op,sp[I-2],sp[I-1],Label),L1,L2),
false(L2,L3),
label(Label,L3,L4),
II is I - 1,
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).
assemble(L,Asm) :-
Asm is 'make-assembler'(),
assemble0(L,Asm).
......
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