improved undu compilation

parent 6e977722
......@@ -141,6 +141,7 @@ caller(cc,Args,Tail,V,[L,LL]) :- !,
caller(F,Args,Tail,V,[L,LL]) :-
length(Args,Nargs),
get_P(V,P0),
touch_Q(3,V),
(get_recur(F,A,N) -> rec(F,A,N,Args,Tail,V,[L,LL]) ;
(
......@@ -155,7 +156,7 @@ caller(F,Args,Tail,V,[L,LL]) :-
set_FS(V,Fsym,S),
(Tail == #t ->
(
LL2 = [['pushtail-3']|LL3],
LL2 = [['pushtail-3',P0]|LL3],
push_args(F,V,LL3,LL4),
LL4=[['tail-call',Nargs]|LW]
);
......@@ -164,7 +165,7 @@ caller(F,Args,Tail,V,[L,LL]) :-
LL2 = [[seek,3],['call-n',N],['goto-inst',G]|LW]
);
(
LL2=[['push-3',Label]|LL3],
LL2=[['push-3',P0,Label]|LL3],
push_args(F,V,LL3,LL4),
LL4=[['call',Nargs],[label,Label]|LLL],
get_post(S,C,#f,Tail,LLL,LW)
......
......@@ -43,9 +43,20 @@ head_at_true(Q,#f,#t,A,C,Lab,Lab2,L1,LLX) :-
(var(Lab) -> true ; throw(error_head)),
L1=[[label,Lab,U],[Unwind,A]|LLX].
compile_goaler(X,First,V,LX,PP0) :-
compile_goal(X,First,V,LX),
get_P(V,P0),
(
P0=PP0 ->
set_P(V,P0);
set_P(V,\"complex\")
).
compile_disjunction0
([X],First,Aq,Ae,Out,Lab,A,Tail,S0,[U],B2,V,[L,LL]) :- !,
(First=#t -> compile_goal(X,First,V,[L,LL]) ;
([X],First,Aq,Ae,Out,Lab,A,Tail,S0,[U],B2,V,[L,LL],P0,PP0) :- !,
set_P(V,P0),
(First=#t -> compile_goaler(X,First,V,[L,LL],PP0) ;
catch((
read_Q(0,V,Qit),
pop_Q(0,V,_),
......@@ -86,14 +97,19 @@ compile_disjunction0
)
))).
goal(X,Y,First,Lab,Tail,Out,A,Ae,Aq,S0,[U|UU],V,L,LL,LG,B2,LLX) :-
goal(X,Y,First,Lab,Tail,Out,A,Ae,Aq,S0,[U|UU],V,L,LL,LG,B2,LLX,P0,PP0) :-
read_Q(1,V,Qit),
get_CES(V,[C|_],E,S),
set_AB2ES(V,Aq,B2,0,S0),
((nonvar(X),X=(G1->G2)) ->
XX=(call(G1),softie(A),collect_F(FF),G2) ;
(XX=(X,newtag_F(FF)))),
set_P(V,ground(Lab)),
compile_goal(XX,Tail,V,[LX,LG]),
get_P(V,P1),
(
PP0 = P1 -> PP1 = P1 ; PP1 = \"complex\"
),
(var(FF) -> true ; set_F(V,FF)),
get_ACES(V,A1q,[C1|_],E1,S1),
(C == C1 -> true ; throw(bug_c_state_error)),
......@@ -114,7 +130,7 @@ goal(X,Y,First,Lab,Tail,Out,A,Ae,Aq,S0,[U|UU],V,L,LL,LG,B2,LLX) :-
)
),
ifc(compile_disjunction0(Y,#f,Aq,Ae,Out,Lab2,A,Tail,S0,UU,B2,
V,[LLX,LL]),Err,
V,[LLX,LL],P0,PP1),Err,
(
(
Err==#t ->
......@@ -132,11 +148,11 @@ goal(X,Y,First,Lab,Tail,Out,A,Ae,Aq,S0,[U|UU],V,L,LL,LG,B2,LLX) :-
head_at_true(Qit,First,#f,A,C,Lab,Lab2,L,LX)
).
compile_disjunction0([X|Y],First,Aq,Ae,Out, Lab,A,Tail,S0,U,B2,V,[L,LL]) :- !,
compile_disjunction0([X|Y],First,Aq,Ae,Out, Lab,A,Tail,S0,U,B2,V,[L,LL],P0,PP0) :- !,
tr('goto-inst',Goto),
read_Q(2,V,Qit),
(Tail==#t -> LG=LLX ; LG = [[Goto,Out]|LLX]),
catch(goal(X,Y,First,Lab,Tail,Out,A,Ae,Aq,S0,U,V,L,LL,LG,B2,LLX), Er,
catch(goal(X,Y,First,Lab,Tail,Out,A,Ae,Aq,S0,U,V,L,LL,LG,B2,LLX,P0,PP0), Er,
(
tfc(Er),
(Tail==#t -> LLG = [[cc]|LG] ; LLG=LG),
......@@ -175,7 +191,8 @@ compile_disjunction0([X|Y],First,Aq,Ae,Out, Lab,A,Tail,S0,U,B2,V,[L,LL]) :- !,
)).
compile_disjunction(Y,First,Aq,Ae,Out,Lab,A,Tail,S0,U,B2,V,[L,LL]) :-
catch(compile_disjunction0(Y,First,Aq,Ae,Out,Lab,A,Tail,S0,U,B2,V,[L,LL]),Er,
get_P(V,P0),
catch(compile_disjunction0(Y,First,Aq,Ae,Out,Lab,A,Tail,S0,U,B2,V,[L,LL],P0,PP0),Er,
(
tfc(Er),
(
......
......@@ -209,8 +209,10 @@ compile_goal((X,Y),Tail,V,L) :- !,
collect_conj((X,Y),Gs,[]),
compile_conj(Gs,Tail,V,L).
compile_goal(m_or(fail,false),#t,V,[[[fail],[cc] |L], L]).
compile_goal(m_or(fail,false),#f,V,[[[fail] |L], L]).
compile_goal(m_or(fail,false),#t,V,[[[fail,P],[cc] |L], L]) :-
get_P(V,P).
compile_goal(m_or(fail,false),#f,V,[[[fail,P] |L], L]) :-
get_P(V,P).
compile_goal(true,_,_,_) :- throw(#t).
compile_goal(';'(|X),Tail,V,[L,LL]) :- !,
collect_disj(X,XX,[]),
......@@ -659,7 +661,8 @@ compile_goal(imprint(X,M),Tail,V,[L,LL]) :- !,
compile_goal(m_and(X,F(|AArgs)),Tail,V,L) :- !,
(
(var_p(F) ; isApply(AArgs)) -> compile_goal(call(X),Tail,V,L) ;
(rev(AArgs,Args), caller(F,Args,Tail,V,L))
(rev(AArgs,Args), caller(F,Args,Tail,V,L)),
set_P(V,\"procedure\")
).
compile_goal(F,Tail,V,L) :-
......
......@@ -49,11 +49,11 @@ handle([\"call\",N],I,II,L,LL) :- !,
handle([\"tail-call\",N],I,II,L,LL) :- !,
'in-tailcall'(N,I,II,L,LL).
handle(['push-3',N],I,II,L,LL) :- !,
'push-3'(N,I,II,L,LL).
handle(['push-3',P,N],I,II,L,LL) :- !,
'push-3'(P,N,I,II,L,LL).
handle(['pushtail-3'],I,II,L,LL) :- !,
'pushtail-3'(I,II,L,LL).
handle(['pushtail-3',P],I,II,L,LL) :- !,
'pushtail-3'(P,I,II,L,LL).
handle([seek,N],I,II,L,LL) :- !,
seek(N,I,II,L,LL).
......
(<define> (make_state f a aa c e m s b b2 h q x)
(<var> (F A AA C E M S B B2 H Q)
(<=> (F A AA C E M S B B2 H Q)
(f a aa c e m s b b2 h q))
(<=> x ,(vector F A AA C E M S B B2 H Q))))
(<var> (F A AA C E M S B B2 H Q P)
(<=> (F A AA C E M S B B2 H Q P)
(f a aa c e m s b b2 h q "procedure"))
(<=> x ,(vector F A AA C E M S B B2 H Q P))))
(define nf 0)
(define na 1)
......@@ -16,6 +16,7 @@
(define nb2 8)
(define nh 9)
(define nq 10)
(define np 11)
(<define> (push_Q e v u)
;(<pp> `(push ,e))
......@@ -43,10 +44,14 @@
(<=> q ,(car (<lookup> (vector-ref v nq))))))
(<define> (copy_state v1 v2)
(<var> (L F A AA C E M S B H Q)
(<=> v2 ,(vector L F A AA C E M S B H Q))
(<var> (L F A AA C E M S B H Q P)
(<=> v2 ,(vector L F A AA C E M S B H Q P))
(<=> v2 v1)))
(<define> (get_P v p)
(let ((v (<lookup> v)))
(<=> p ,(<lookup> (vector-ref v np)))))
(<define> (get_EB v e b)
(<let> ((v (<lookup> v)))
(<=> e ,(<lookup> (vector-ref v ne)))
......@@ -182,6 +187,10 @@
(<=> a ,(<lookup> (vector-ref v na)))
(<=> f ,(<lookup> (vector-ref v nf)))))
(<define> (set_P v p)
(<let> ((v (<lookup> v)))
(<set> (vector-ref v np) p)))
(<define> (set_EB v e b)
(let ((v (<lookup> v)))
(<set> (vector-ref v ne) (<lookup> e))
......
......@@ -30,11 +30,11 @@
gset(s,svar(NS),I,L4,LL).
'push-3'(C,I,II,L,LL) :-
args([cc(C),pp,s],I,II,L,LL).
'push-3'(P,C,I,II,L,LL) :-
args([cc(C),pp(P),s],I,II,L,LL).
'pushtail-3'(I,II,L,LL) :-
args([cc,pp,s],I,II,L,LL).
'pushtail-3'(P,I,II,L,LL) :-
args([cc,pp(P),s],I,II,L,LL).
'cc-call'(I,0,L,LL) :-
scmtailcall(cc,[s,pp],0,_,L,LL).
......
......@@ -16,8 +16,7 @@
cutter(V,VC,I,L,LL) :-
gset(cut,V,I,L,L1),
gset(scut,VC,I,L1,L2),
reset(I,L2,LL).
gset(scut,VC,I,L1,LL).
'goto-inst'(Inst,I,L,LL) :-
gref(I,c(Inst),I,L,L1),
......@@ -29,8 +28,7 @@
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).
scmcall('gp-prune',[scut],I,_,L7,LL).
push_at(K,I,II,L,LL) :-
......@@ -39,50 +37,41 @@
'sp-move'(_,V,I,II,L,LL) :-
II is I - 1,
gset(V,sp(II),I,L,L1),
reset(II,L1,LL).
gset(V,sp(II),I,L,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).
pltest('equal?',[sp(I-1),c(C)],I,L,LL),
II is I - 1.
-trace.
'push-instruction'(C,I,II,L,LL) :-
gset(sp(I),c(C),I,L,L2),
II is I + 1,
reset(II,L2,LL).
gset(sp(I),c(C),I,L,LL),
II is I + 1.
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).
gset(sp[I],svar(I2-1),I2,L1,LL),
II is I + 1.
-trace.
'push-variable'(V,I,II,L,LL) :-
gset(sp(I),V,I,L,L2),
II is I + 1,
reset(II,L2,LL).
gset(sp(I),V,I,L,LL),
II is I + 1.
'pop-variable'(V,I,II,L,LL) :-
gset(V,sp(I-1),L,L1),
II is I - 1,
reset(II,L1,LL).
gset(V,sp(I-1),L,LL),
II is I - 1.
pop(N,I,II,L,LL) :-
II is I - N,
reset(II,L,LL).
pop(N,I,II,L,L) :-
II is I - N.
seek(N,I,II,L,LL) :-
II is I + N,
reset(II,L,LL).
seek(N,I,II,L,L) :-
II is I + N.
dup(I,II,L,LL) :-
movex(I,I-1,L,L1),
II is I + 1,
reset(II,L1,LL).
movex(I,I-1,L,L),
II is I + 1.
")
......
......@@ -34,7 +34,7 @@
generate('scm-ref/immediate'(II,I,2),L2,L3),
generate('scm-ref/immediate'(I,I,1),L3,LL).
pp(I,II,L,LL) :-
pp(complex,I,II,L,LL) :-
II is I + 1,
gset(sp(I),p,II,L,L1),
isProcedure(sp(I),Lab,II,L1,L2),
......@@ -43,6 +43,16 @@
move(base+I,base+J,L3,L4),
label(Lab,L4,LL).
pp(ground(Lab),I,II,L,LL) :-
II is I + 1,
gset(sp(I),l(Lab),I,L,L1),
scmcall1('gp-make-p',[self],II,I1,L1,L2),
gset(sp(I),sp(I1-1),II,L2,L3).
pp(procedure,I,II,L,LL) :-
II is I + 1,
gset(sp(I),p,I,L,LL).
cc(C,I,II,L,LL) :-
scmcall('make-cc',[l(C),self],I,I1,L,L1),
J is I1 - 1,
......@@ -51,7 +61,7 @@
e(cc(C),I,II,L,LL) :- cc(C,I,II,L,LL).
e(pp,I,II,L,LL) :- pp(I,II,L,LL).
e(pp(C),I,II,L,LL) :- pp(C,I,II,L,LL).
tailstub(I,L,LL) :-
generate(tailcall(I),L,LL).
......@@ -62,6 +72,19 @@
reset(I,L,LL) :-
call(II is I),
generate('reset-frame'(base+II),L,LL).
-trace.
varref(Pos,sp(I),II,L,LL) :-
id(vec,svar(IVEC)),
PPos is Pos + 1,
generate('scm-ref/immediate'(base+I,IVEC,PPos),L,LL),
II is I + 1.
varref(Pos,svar(I),II,L,LL) :-
id(vec,svar(IVEC)),
PPos is Pos + 1,
generate('scm-ref/immediate'(I,IVEC,PPos),L,LL),
II is I + 1.
varref(Pos,I,II,L,LL) :-
id(vec,svar(IVEC)),
......@@ -90,17 +113,31 @@
call(JJ is J),
generate(mov(base+II,base+JJ),L,LL).
-trace.
gref(cl(X),I,L,LL) :- !,
call(II is I),
generate(closure(base+II,X),L,LL).
gref(c(X),I,L,LL) :- !,
gref(c(X),sp(I),L,LL) :- !,
call(II is I),
constant(X,base+II,L,LL).
gref(var(X),I,L,LL) :- !,
gref(c(X),svar(I),L,LL) :- !,
call(II is I),
varref(X,II,_,L,LL).
constant(X,II,L,LL).
gref(c(X),I,L,LL) :- !,
call(II is I),
constant(X,base+II,L,LL).
gref(var(X),sp(I),L,LL) :-
varref(X,sp(I),_,L,LL).
gref(var(X),svar(I),L,LL) :-
varref(X,svar(I),_,L,LL).
gref(var(X),I,L,LL) :-
varref(X,sp(I),_,L,LL).
gref(sp(X),I,L,LL) :- !,
call(XX is X),
......@@ -151,17 +188,16 @@
move(base+KK,J,L,LL).
sset(J,var(X),I,L,LL) :- !,
gref(var(X),I,L,L2),
call(JJ is J),
move(base+JJ,base+I,L2,LL).
gref(var(X),sp(JJ),L,LL).
sset(J,c(X),I,L,LL) :- !,
call(JJ is J),
gref(c(X),JJ,L,LL).
sset(J,X,I,L,LL) :-
id(X,XX),
sset(J,XX,I,L,LL).
sset(J,XX,sp(I),L,LL).
cset(K,sp(J),I,L,LL) :- !,
move(K,base+J,L,LL).
......@@ -171,13 +207,12 @@
move(KK,J,L,LL).
cset(J,var(X),I,L,LL) :- !,
gref(var(X),I,L,L2),
call(JJ is J),
move(JJ,base + I,L2,LL).
gref(var(X),svar(JJ),L,LL).
cset(J,cl(X),I,L,LL) :- !,
call(JJ is J),
gref(cl(X),JJ,L,LL).
gref(cl(X),svar(JJ),L,LL).
cset(J,c(X),I,L,LL) :- !,
gref(c(X),I,L,L2),
......@@ -188,7 +223,6 @@
id(X,XX),
cset(J,XX,I,L,LL).
-trace.
gset(var(V),Val,I,L,LL) :- !,
vset(V,Val,I,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