refactorisation

parent 8a15c84d
(define-module (logic guile-log vm call)
#:use-module ((logic guile-log iso-prolog)
#:renamer
(lambda (x) (if (eq? x 'reset)
'reset_iso
x)))
#:use-module (logic guile-log vm utils)
#:use-module (logic guile-log vm fkn)
#:export ())
(compile-prolog-string
"
store_stack(I,0,L,LL) :-
(
I > 0 ->
do_n_cons(I,I,_,L,L1);
gset(sp(0),c([]),L,L1)
).
gset('stack',sp(0),1,L1,L2).
cc(A,I,0,L,LL) :-
scm_tailcall(cc,[s,pp|A],0,_,L,LL).
call(F,A,P,CC,I,0,L,LL) :-
store_stack(I,II,L,l1),
scm_tailcall(F,[s,pp,CC|A],0,_,L1,LL).
pp(I,II,L,LL) :-
gset(sp(I),p,L,L1),
II is I + 1,
isProcedure(sp(I),Lab,II,L,L1),
scmcall1('gp-make-p',[self],I,I1,L,L1),
move(I1-1,I,L1,LL),
label(Lab,L3,L4).
cc(C,I,II,L,LL) :-
scmcall('gp-make-cc',[self,stack,l(C),cut],I,I1,L,L1),
move(I1-1,I,L1,LL),
II is I + 1.
")
(define (gp-make-p p self)
(make-closure self self.vec p.ip p.stack p.cut p.scut))
(define (gp-make-cc self stack next-ip cut scut)
(make-closure self.proc self.vec ip stack cut scut))
......@@ -7,7 +7,7 @@
#:use-module (logic guile-log vm utils)
#:export (icons! ifkn! icurly!
mk-cons mk-fkn mk-curly
icons ifkn icurly))
icons ifkn icurly do_n_cons))
(compile-prolog-string
"
......
(define-module (logic guile-log vm push)
#: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 (cutter goto-inst sp-move equal-instruction
push-instruction pushv push-variable
pop-variable pop seek dup clear-sp))
(compile-prolog-string
"
'clear-sp'(I,0,L,LL) :-
reset(0,L,LL).
cutter(V,VC,I,L,LL) :-
gset(cut,V,I,L,L1),
gset(scut,VC,I,L1,L2),
reset(I,L2,LL).
'goto-inst'(Inst,I,L,LL) :-
gref(I,c(Inst),I,L,L1),
generate(goto(I),L1,LL).
cut(I,L,LL) :-
isZero(cut,I,L,L2),
jne(Lab,L2,L3),
gset(p,vcut,I,L3,L4),
j(Lab2,L4,L5),
gset(p,cut,I,L6,L7).
scmcall('gp-prune',[scut],I,_,L7,L8),
reset(I,L8,LL).
'sp-move'(V,I,II,L,LL) :-
II is I - 1,
gset(V,svar(II),I,L,LL),
reset(II,L1,LL).
'equal-instruction'(C,I,II,L,LL) :-
pltest('equal?',[sp(I-1),c(C)],I,L,L2),
II is I - 1,
reset(II,L2,LL).
'push-instruction'(C,I,II,L,LL) :-
gset(sp(I),c(C),I,L,L1),
II is I + 1,
reset(II,L1,LL).
pushv(X,I,II,L,LL) :-
scmcall('gp-var!',[s],I,I2,L,L1),
gset(sp[I],svar(I2-1),I2,L1,L2),
II is I + 1,
reset(II,L2,LL).
'push-variable'(V,I,II,L,LL) :-
gset(sp(I),V,I,L,L1),
II is I + 1,
reset(II,L1,LL).
'pop-variable'(V,I,II,L,LL) :-
gset(V,sp(I-1),L,L1),
II is I - 1,
reset(II,L1,LL).
pop(N,I,II,L,LL) :-
II is I - N,
reset(II,L,LL).
seek(N,I,II,L,LL) :-
II is I + N,
reset(II,L,LL).
dup(I,II,L,LL) :-
move(I,I-1,L,L1),
II is I + 1,
reset(II,L1,LL).
")
......@@ -2,16 +2,23 @@
#:use-module (logic guile-log iso-prolog)
#:export (reset gset gref move scmcall make_p make_cc j je jne
label gfalse isTrue pltest lookup2
test))
test sp cc vec cut scut pp))
(compile-prolog-string
"
generate(Tok,[Tok|LL],LL).
id(s , sp(0)).
id(p , sp(1)).
id(cc , sp(2)).
id(vec, sp(3)).
id(s ,sp(0)).
id(p ,sp(1)).
id(cut ,sp(2)).
id(scut ,sp(3))
id(vec ,sp(4)).
id(stack,sp(5)),
id(cc ,var(0)).
sp(6).
e(cc(C),I,II,L,LL) :- cc(C,I,II,L,LL).
e(pp,I,II,L,LL) :- pp(I,II,L,LL).
reset(I,L,LL) :-
call(II is I),
......@@ -38,6 +45,9 @@
gref(var(X),I,L,LL) :-
var_ref(X,I,L,LL).
gref(l(X),I,L,LL) :- !,
generate('label-ref'(I,X),L,LL).
gref(sp(X),I,L,LL) :-
move(X,I,L,LL).
......@@ -110,14 +120,6 @@
II is I2 + 1,
reset(II,L4,LL).
make_p(I,L,LL) :-
scmcall('gp-make-p',[self,p],I,L,L1),
move(I+3,I,L1,L2).
make_cc(I,L,LL) :-
scmcall('gp-make-cc',[self,cc],I,L,L1),
move(I+3,I,L1,L2).
j(Label,L,LL) :-
generate(j(Label),L,LL).
......
......@@ -4,6 +4,7 @@
#:use-module (logic guile-log vm op)
#:use-module (logic guile-log vm fkn)
#:use-module (logic guile-log vm utils)
#:use-module (logic guile-log vm push)
#:re-export (softie newframe-light unwind-light-tail unwind-light
goto-inst store-state unwind-tail post-q
newframe newframe-negation
......@@ -25,152 +26,6 @@
(compile-prolog-string
"
generate(Tok,[I,[Tok|LL]],[II,LL]) :- II is I + 1.
id(s ,0).
id(p ,1).
id(cc,2).
git(addr,0)
vareref(Pos,I,L,LL) :-
varsid(V),
vector_ref(V,Pos,I)
args([],I,I,L,L).
init(Nargs,Nvec,I,L,LL) :-
N is Nargs + 3;
generate('pljump',L,L2),
generate('assert-narg-ee/locals'(Nargs,0),L2,L3),
generate('handle-interrupts',L3,L4)
I = N,
generate('pl-setup-frame',L4,LL).
make_p(I,L,LL) :-
copy_self(I,L,L1),
generate(setp(I),L1,LL).
make_cc(I,L,LL) :-
copy_self(I,L,L1),
generate(setcc(I),L1,LL).
args([var(P)|A],I,II,L,LL) :-
varref(P,I,L,L1),
I2 is I + 1,
args(A,I2,II,L1,LL).
args([s|A],I,II,L,LL) :-
id(s,S),
move(S,I,L,LL),
I2 is I + 1,
args(A,I2,II,L1,LL).
args([p|A],I,II,L,LL) :-
make_p(p,I,L,L1)
I2 is I + 1,
args(A,I2,II,L1,LL).
args([p(C)|A],I,II,L,LL) :-
make_p(C,I,L,L1)
I2 is I + 1,
args(A,I2,II,L1,LL).
args([cc|A],I,II,L,LL) :-
make_cc(I,L,L1)
I2 is I + 1,
args(A,I2,II,L1,LL).
args([cc_tail|A],I,II,L,LL) :-
id(cc,CC),
generate(move(CC,I),L,L1),
I2 is I + 1,
args(A,I2,II,L1,LL).
scmcall(var(F),Args,N,I,L,LL) :-
args(Args,N,I,L,L1)
varref(F,I,L,L1),
II is I + 1,
handle_interupts(L1,L2),
generate(call(I,N),L2,LL).
tailcall(var(F),Args,N,I,L,LL) :-
args(Args,N,I,L,L1)
varref(F,I,L,L1),
II is I + 1,
handle_interupts(L1,L2),
generate(tail_call,I,N,L2,LL).
pl_call(F,Args,I,II,L,LL) :-
AArgs=[s,p,cc|Args],
args(AArgs,I,I2,L,L1),
handle_interupts(I2,I3,L1,L2),
generate(next_address,I3,I4,L2,L3).
generate(tail_call,I4,II,L3,LL).
pl_tail_call(F,Args,I,II,L,LL) :-
AArgs=[s,p,cc_tail|Args],
args(AArgs,I,I2,L,L1),
handle_interupts(I2,I3,L1,L2),
generate(tail_call,I4,II,L3,LL).
pl_tail_call_cc(C,F,Args,I,II,L,LL) :-
AArgs=[s,p(C),cc_tail|Args],
args(AArgs,I,I2,L,L1),
handle_interupts(I2,I3,L1,L2),
generate(tail_call,I4,II,L3,LL).
gref(c(X),I,L,LL) :-
make_const(X,I,L,LL).
gref(top(X),I,L,LL) :-
generate('toplevel-ref'(X,I),L,LL).
gref(var(X),I,L,LL) :-
var_ref(X,I,L,LL).
gref(svar(X),I,L,LL) :-
generate(move(X,I),L,LL).
vset(V,svar(Val),I,L,LL) :- !;
vid(V,N),
var_set(V,Val,L2,LL).
vset(V,Val,I,L,LL) :-
vid(V,N),
g_ref(Val,I,L,L1),
var_set(V,I,L2,LL).
tset(V,svar(Val),I,L,LL) :- !;
generate('toplevel-set'(V,Val),L,LL).
tset(V,Val,I,L,LL) :-
g_ref(Val,I,L,L1),
tset(V,svar(I),L2,LL).
sset(V,svar(Val),I,L,LL) :- !,
id(V,VV).
generate(move(Val,VV),L,LL),
sset(V,Val,I,L,LL) :-
id(V,VV),
gref(Val,VV,L,LL).
sset(V,Val,I,L,LL) :-
vid(V,N),
g_ref(Val,I,L,L1),
var_set(V,I,L2,LL).
gset(var(V),Val,I,L,LL).
vset(V,Val,I,L,LL).
gset(svar(V),Val,I,L,LL).
sset(V,Val,I,L,LL).
gset(top(V),Val,I,L,LL).
tset(V,Val,I,L,LL).
/*
......@@ -291,29 +146,6 @@
generate('get-stack',L,L2),
tail_call(cc,[s,p],I,L2,L3).
/*
(LABEL cutter)
(<let*> ((ulong v (scm->ulong (<*> inst-pt)))
(ulong vc (<bit-and> v (<c> #xffff)))
(ulong vcs (<bit-and> (q>> v (<c> 16)) (<c> #xffff)))
(ulong q (q>> v (<c> 32)))
(SCM xs (<if> (<bit-and> q (<c> 1))
(<ref> variables vc)
(SVAR-REF fp nstack vc)))
(SCM xcs (<if> (<bit-and> q (<c> 2))
(<ref> variables vcs)
(SVAR-REF fp nstack vcs))))
(<=> inst-pt (<+> inst-pt (<c> 1)))
(<=> cut xs)
(<=> scut xcs)
(<=> (GET-CUT variables) xs)
(NEXT inst-pt))
*/
cutter(V,VC,I,L,LL) :-
gset(cut,V,I,L,L1),
gset(scut,VC,I,L1,LL).
/*
(LABEL call)
(PRSTACK sp fp)
......@@ -699,41 +531,6 @@
'unwind-negation'(N,CUT,I,L,LL) :-
scmcall('gp-unwind-negation',[vec,c(N),c(CUT)],I,L,LL).
/*
(LABEL false)
(PRSTACK sp fp)
(BACKTRACK p instructions inst-pt fp sp)
(define-syntax-rule (BACKTRACK p instructions inst-pt fp sp)
(<if> (NUMBER? p)
(<begin>
(<=> inst-pt (<+> instructions (scm->int p)))
(NEXT inst-pt))
(CALL-P p fp sp)))
*/
gfalse(I,L,LL) :-
II is I + 1,
gref(I,p,II,L,L2),
generate('immediate-tag?='(I,7,0),L2,L3),
generate(je(A),L3,L4),
generate(goto(I),L4,L5),
label(A,L5),
'scm-tail-call'(I,[],II,L5,LL).
/*
(LABEL goto-inst)
(PRSTACK sp fp)
(<call> INTERUPT)
(GC iter)
(<let> ((int ni (scm->int (<*> inst-pt))))
(<=> inst-pt (<+> instructions ni))
(NEXT inst-pt))
*/
'goto-inst'(Inst,I,L,LL) :-
gref(I,c(Inst),I,L,L1),
generate(goto(I),L1,LL).
/*
......@@ -798,24 +595,6 @@
fail(I,L,LL) :- gfalse(I,L,LL).
/*
(LABEL cut)
(PRSTACK sp fp)
(<if> (EQ cut (<scm> 0))
(<=> p (GET-CUT variables))
(<=> p cut))
(PRUNE scut)
(NEXT inst-pt)
(define-syntax-rule (PRUNE s) (<call> gp_gp_prune s))
*/
cut(I,L,LL) :-
isZero(cut,L,L2),
jne(Lab,L2,L3),
gset(p,vcut),
j(Lab2,L3,L4),
gset(p,cut,I,L5,L6).
scmcall(gp_gp_prune,[scut],I,L6,LL).
/*
(LABEL set)
......@@ -832,37 +611,11 @@
(DECR 1 sp)
(define-syntax-rule (SET x y s) (<call> gp_set x y s))
*/
gset(N,I,L,LL) :-
scmcall(gp_set,[N,sp(-1),s],I,L,LL).
/*
(define-syntax-rule (mk-scm-move op q s p variables variables-scm
nvar pinned? cnst session middle nstack
instructions vars inst-pt sp fp)
(<begin>
(LABEL op)
(PRSTACK sp fp)
(<let*> ((ulong v (scm->ulong (<ref> inst-pt (<c> 0)))))
(<=> inst-pt (<+> inst-pt (<c> 1)))
(UNPACK-VAR-A q 1 pinned? variables variables-scm nvar
cnst session middle
(<=> (SVAR-REF fp nstack v) (ARG -1 sp))
(<=> (<ref> variables v) (ARG -1 sp)))
(CLEAR 1 sp)
(NEXT inst-pt))))
(mk-scm-move sp-move (<c> 0) s p variables variables-scm
nvar pinned? cnst session middle nstack
instructions variables inst-pt sp fp)
*/
'sp-move'(V,I,II,L,LL) :-
II is I - 1,
gset(V,svar(II),II,L,LL),
gset(svar(II),const(#f)).
/*
(mk-scm-unify unify s p variables variables-scm
nvar pinned? cnst session middle nstack
......@@ -1147,185 +900,6 @@
II is I - 1.
/*
(mk-equal-i equal-instruction s p constants
instructions variables inst-pt sp fp)
(define-syntax-rule (mk-eql-i-c mk-scm-equal constants i q)
(define-syntax-rule (mk-scm-equal op s p constants
instructions vars inst-pt sp fp)
(<begin>
(LABEL op)
(PRSTACK sp fp)
(<let*> ((SCM i (<ref> inst-pt (<c> 0)))
(SCM x q)
(SCM y (ARG -1 sp)))
(CLEAR 1 sp)
(<if> (<call> scm_is_true (<call> scm_equal_p x y))
(NEXT inst-pt)
(BACKTRACK p instructions inst-pt fp sp))))))
(mk-eql-i-c mk-equal-i constants i i)
(mk-eql-i-c mk-equal-c constants i (<ref> constants (scm->int i)))
*/
'equal-instruction'(C,I,II,L,LL) :-
pltest(scm_equal_p,[sp(-1),const(C)],I,L,L2),
II is I - 1,
reset(II,L2,LL).
/*
(LABEL icons!)
(PRSTACK sp fp)
(<let*> ((x (ARG -1 sp))
(ss (<call> gp_pair_bang x s)))
(<if> (<call> scm_is_true ss)
(<begin>
(INCR 1 sp)
(<=> s ss)
(<=> (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_bang,[sp(I-1)],I,L,L2),
scmcall(gp_gp_cdr,[sp(I-1),s],I,L2,L3),
scmcall(gp_gp_car,[sp(I-1),s],I+4,L3,L4)
move(I+3,I-1,L4,L5),
move(I+7,I,L5,L6),
reset(I+1,L6,L7),
II is I + 1.
'ifkn!'(I,L,LL) :-
pltest('vector!?',[sp[I - 1]], I , L , L1),
scmcall('vector-ref',[sp[I - 1],const(0)],I,L1,L2),
move(I+3,I-1,L2,L3),
reset(I,L3,LL).
/*
(LABEL push-instruction)
(PRSTACK sp fp)
(<let> ((SCM x (<*> inst-pt)))
(<++> inst-pt)
(<=> (<*> sp) x)
(INCR 1 sp))
(NEXT inst-pt)
*/
'push-instruction'(C,I,II,L,LL) :-
gset(sp(I),const(C),I,L,L1),
II is I + 1,
reset(II,L1,LL).
/*
(LABEL pushv)
(PRSTACK sp fp)
(<let> ((SCM x (<*> inst-pt)))
(<++> inst-pt)
(<if> (<call> scm_is_false x)
(<=> (<*> sp) (<call> gp_mkvar s))
(UNPACK-VAR 0 x i pinned? variables variables-scm nvar
cnst session middle
(<=> (<*> sp) (SVAR-REF fp nstack i))
(<=> (<*> sp) (<ref> variables i))))
(INCR 1 sp)
(NEXT inst-pt))
*/
pushv(X,I,II,L,LL) :-
scmcall(gp_mkvar,[s],I,L,L1),
gset(sp[I],svar(I+2),I+3,L1,L2),
II is I + 1,
reset(II,L2,LL).
/*
(LABEL push-variable-s)
(PRSTACK sp fp)
(<let*> ((int i (scm->int (<*> inst-pt)))
(SCM v (UNPACK-VAR-A (<c> 1)
0 pinned? variables
variables-scm nvar
cnst session middle
(SVAR-REF fp nstack i)
(<ref> variables i))))
(<=> inst-pt (<+> inst-pt (<c> 1)))
(FORMAT "push ~a~%" v)
(<=> (ARG 0 sp) v)
(INCR 1 sp))
(NEXT inst-pt)
*/
'push-variable'(V,I,II,L,LL) :-
gset(sp(I),V,I,L,L1),
II is I + 1,
reset(II,L1,LL).
/*
(LABEL pop-variable)
(PRSTACK sp fp)
(<let> ((int n (scm->int (<*> inst-pt))))
(<++> inst-pt)
(<=> (<ref> variables n) (ARG -1 sp))
(DECR 1 sp))
(NEXT inst-pt)
*/
'pop-variable'(V,I,II,L,LL) :-
gset(V,sp(I-1),L,L1),
II is I - 1,
reset(II,L1,LL).
/*
(LABEL pop)
(PRSTACK sp fp)
(<let> ((int n (scm->int (<*> inst-pt))))
(<recur> lp ((int m n))
(<if> (<not> (<==> m (<c> 0)))
(<begin>
(DECR 1 sp)
(<=> (ARG 0 sp) (<scm> #f))
(<next> lp (<-> m (<c> 1))))))
(<++> inst-pt)
(PRSTACK sp fp)
(NEXT inst-pt))
*/
pop(N,I,II,L,LL) :-
II is I - N,
reset(II,L,LL).
/*
(LABEL seek)
(PRSTACK sp fp)
(<let> ((int n (scm->int (<*> inst-pt))))
(<++> inst-pt)
(INCR n sp)
(NEXT inst-pt))
*/
seek(N,I,II,L,LL) :-
II is I + N,
reset(II,L,LL).
/*
(LABEL dup)
(PRSTACK sp fp)
(<=> (ARG 0 sp) (ARG -1 sp))
(INCR 1 sp)
(NEXT inst-pt)
*/
dup(I,II,L,LL) :-
gset(sp[I],sp[I-1],I,L,L1),
II is I + 1,
reset(II,L1,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