compiling set, reworked cut logic

parent 95a5fb83
......@@ -637,23 +637,15 @@ constant = #(nlocals nstack constants code)
(BACKTRACK p instructions inst-pt fp sp))))))))
(define-syntax-rule (STORE-STATE tp tag s p cut stack)
(define-syntax-rule (STORE-STATE tp tag s p stack)
(<let> ((np (<if> (NUMBER? p) p (<scm> 0))))
(CONS (CONS tag
(CONS s
(<if> (q> tp (<c> 0))
(CONS np
(<if> (<==> tp 1)
cut
(<if> (<==> tp 2)
(MAKE-VARIABLE
(<call> scm_fluid_ref
*delayers*))
(CONS cut
(<call>
scm_fluid_set_x
*delayers*)))))
np)))
(<if> (<==> tp 1)
(CONS p
(<call> scm_fluid_ref
*delayers*))
p)))
stack)))
(define-syntax-rule (CLEAR-SP-XP sp xp)
......@@ -670,7 +662,7 @@ constant = #(nlocals nstack constants code)
(<=> (<*> sp) (<scm> #f))
(<next> lp))))))
(define-syntax-rule (RESTORE-STATE s cut tag stack)
(define-syntax-rule (RESTORE-STATE s tag stack)
(<recur> lp ()
(<let> ((x (CAR stack)))
(<if> (EQ x tag)
......@@ -679,22 +671,13 @@ constant = #(nlocals nstack constants code)
(x2 (CDR x1)))
(<=> s ss)
(<if> (PAIR? x2)
(<let> ((x3 (CDR x2)))
(<if> (PAIR? x3)
(<begin>
(<=> cut (CAR x3))
(<call> scm_fluid_set_x *delayers*
(CDR x3)))
(<if> (VARIABLE? x3)
(<call> scm_fluid_set_x *delayers*
(VARIABLE-REF x3))
(<=> cut x3))))))
(<call> scm_fluid_set_x *delayers*
(CDR x2))))
(<begin>
(<=> stack (CDR stack))
(<next> lp))))))
(define-syntax-rule (RESTORE-STATE-TAIL s p cut tag stack)
(define-syntax-rule (RESTORE-STATE-TAIL s p tag stack)
(<recur> lp ()
(<let> ((x (CAR stack)))
(<if> (EQ x tag)
......@@ -706,16 +689,8 @@ constant = #(nlocals nstack constants code)
(<if> (PAIR? x2)
(<begin>
(<=> p (CAR x2))
(<let*> ((x3 (CDR x3)))
(<if> (PAIR? x3)
(<begin>
(<=> cut (CAR x3))
(<call> scm_fluid_set_x *delayers*
(CDR x3)))
(<if> (VARIABLE? x3)
(<call> scm_fluid_set_x *delayers*
(VARIABLE-REF x3))
(<=> cut x3)))))
(<call> scm_fluid_set_x *delayers*
(CDR x2)))
(<=> p x2)))
(<begin>
(<=> stack (CDR stack))
......@@ -1367,7 +1342,7 @@ constant = #(nlocals nstack constants code)
(SCM ss (NEWFRAME s)))
(<=> inst-pt (<+> inst-pt (<c> 2)))
(<=> s ss)
(<=> ctrl-stack (STORE-STATE tp np s p cut ctrl-stack))
(<=> ctrl-stack (STORE-STATE tp np s p ctrl-stack))
(<=> p np)
(NEXT inst-pt))
......@@ -1388,7 +1363,7 @@ constant = #(nlocals nstack constants code)
*gp-not-n* s))))
s))
(<=> s (<call> gp_set *gp-is-delayed?* (<scm> #f) s))
(<=> ctrl-stack (STORE-STATE tp np ss p cut ctrl-stack))
(<=> ctrl-stack (STORE-STATE tp np ss p ctrl-stack))
(<=> cut np)
(NEXT inst-pt))
......@@ -1408,8 +1383,9 @@ constant = #(nlocals nstack constants code)
(PRSTACK sp fp)
(<let> ((int np (scm->int (<ref> inst-pt (<c> 0))))
(int out (scm->int (<ref> inst-pt (<c> 1)))))
(<=> inst-pt (<+> inst-pt (<c> 2)))
(RESTORE-STATE-TAIL s p cut np ctrl-stack)
(<=> cut (<ref> inst-pt (<c> 2)))
(<=> inst-pt (<+> inst-pt (<c> 3)))
(RESTORE-STATE-TAIL s p np ctrl-stack)
(<let> ((int n (scm->int (<call> gp_gp_lookup *gp-not-n* s)))
(SCM d (<call> gp_gp_lookup *gp-is-delayed?* s)))
(UNWIND s)
......@@ -1428,7 +1404,7 @@ constant = #(nlocals nstack constants code)
(PRSTACK sp fp)
(<let> ((SCM tag (<*> inst-pt)))
(<=> inst-pt (<+> inst-pt (<c> 1)))
(RESTORE-STATE-TAIL s p cut tag ctrl-stack)
(RESTORE-STATE-TAIL s p tag ctrl-stack)
(UNWIND-TAIL s)
(NEXT inst-pt))
......@@ -1438,7 +1414,7 @@ constant = #(nlocals nstack constants code)
(<let> ((SCM tag (<ref> inst-pt (<c> 0))))
(<=> p (<ref> inst-pt (<c> 1))))
(<=> inst-pt (<+> inst-pt (<c> 2)))
(RESTORE-STATE s cut tag ctrl-stack)
(RESTORE-STATE s tag ctrl-stack)
(UNWIND s)
(NEXT inst-pt))
......@@ -1446,8 +1422,9 @@ constant = #(nlocals nstack constants code)
(LABEL post-negation)
(PRSTACK sp fp)
(<let> ((SCM n (<*> inst-pt))
(<=> inst-pt (<+> inst-pt (<c> 1)))
(RESTORE-STATE-TAIL s p cut n ctrl-stack)
(<=> cut (<ref> inst-pt (<c> 1)))
(<=> inst-pt (<+> inst-pt (<c> 2)))
(RESTORE-STATE-TAIL s p n ctrl-stack)
(UNWIND-TAIL s)
(<call> gp_fluid_force_bang *gp-is-delayed?* (<scm> #f) s)
(NEXT inst-pt))
......
......@@ -81,14 +81,14 @@ get_post(S,C,Cplx,Tail,X,XX) :-
) ;
X=XX
);
cplx==#f ->
Cplx==#f ->
(
tr(post_call,Post),
X=[[post-call,C,#t]|XX]
tr('post-call',Post),
X=[Post,C,#t]|XX]
);
(
tr(post_call,Post),
X=[[post-call,C,#f]|XX]
tr('post-call',Post),
X=[[Post,C,#f]|XX]
)
).
......@@ -98,7 +98,7 @@ caller(cc,Args,label(G,N),V,[L,LL]) :- !,
(M==N -> true ; throw(cc_does_not_match_caller)),
tr('clear-sp' , Clear),
L=[[Clear]|L2],
get_CS(V,C,S),
get_S(V,S),
set_S(V,0),
push_v(2,V),
tr(seek,Seek),
......@@ -111,7 +111,7 @@ caller(cc,Args,Tail,V,[L,LL]) :- !,
(Tail=#f -> throw(cc_not_in_tail_context) ; true),
tr('clear-sp' , Clear),
L=[[Clear]|L2],
get_CS(V,C,S),
get_S(V,S),
set_S(V,0),
push_args(F,V,L2,L3),
push_v(2,V),
......@@ -126,7 +126,7 @@ caller(F,Args,Tail,V,[L,LL]) :-
tr('clear-sp' , Clear),
L=[[Clear]|L2],
touch_A(V),
get_CS(V,C,S),
get_CS(V,[C|_],S),
set_S(V,0),
push_args(F,V,L2,L3),
push_v(3,V),
......
......@@ -52,11 +52,11 @@ compile_disjunction
(First=#t -> compile_goal(X,First,V,[L,LL]) ;
catch((
set_F(V,scm[(gensym \"tag\")]),
get_CES(V,C,E,S),
get_CES(V,[C|_],E,S),
set_AES(V,Aq,0,S0),
(
compile_goal(X,Tail,V,[LX,LL]),
get_ACES(V,Aq1,C1,E1,S1),
get_ACES(V,Aq1,[C1|_],E1,S1),
(C == C1 -> true ; throw(bug_c_state_error)),
(
eql_a(Ae,Aq1) -> true ;
......@@ -83,11 +83,11 @@ compile_disjunction
))).
goal(X,Y,First,Lab,Tail,Out,A,Ae,Aq,S0,[U|UU],V,L,LL,LG,LLX) :-
get_CES(V,C,E,S),
get_CES(V,[C|_],E,S),
set_AES(V,Aq,0,S0),
(First==#t -> true ; set_F(V,scm[(gensym \"tag\")])),
compile_goal(X,Tail,V,[LX,LG]),
get_ACES(V,A1q,C1,E1,S1),
get_ACES(V,A1q,[C1|_],E1,S1),
(C == C1 -> true ; throw(bug_c_state_error)),
S2 is max(S,S1),
E2 is E \\/ E1,
......
......@@ -57,7 +57,7 @@ compile_goal(Code,Iout,StackSize,Narg,Constants,Pretty) :- !,
init_vars,init_e,
(var(Constants) -> init_const ; true),
b_setval(pretty,#t),
make_state(0,[[0,_,_]],0,0,0,0,0,[HC,HV],V),
make_state(0,[[0,_,_]],[0],0,0,0,0,[HC,HV],V),
wrap(compile_goal(Code,#t,V,[L,[]]),[L,[]]),
get_M(V,StackSize),
handle_all(L,LL),
......@@ -100,7 +100,11 @@ compile_goal(end_att,Tail,V,[L,LL]) :- !,
Tail==#t -> LLL=LL ;
(
At==#t ->
(tr('post-unicall',PostCall),get_C(V,C),LLL=[[PostCall,C,F]|LL]) ;
(
tr('post-unicall',PostCall),
get_C(V,[C|_]),
LLL=[[PostCall,C,F]|LL]
) ;
LLL=LL
)
),
......@@ -183,13 +187,33 @@ compile_goal((X =.. Y),Tail,V, L, LL) :- !,
).
compile_goal((X->Y),Tail,V) :- !,
compile_goal(X,#f ,V,[LX,LLX]),
compile_goal(Y,Tail,V,[LY,LL ]),
compile_goal(set(V,X),Tail,[L,LL]) :-
tr(set,Set),
(var(X) -> true ; throw(no_var_in_set)),
add_var(X,V,Tag),
(isFirst(Tag) -> true ; force_variable(Tag)),
push_args(X,V,L,LX),
push_v(-1,V),
(
Tail=#t ->
LX=[[Set,Tag],[cc]|LL];
LX=[[Set,Tag] |LL]
).
compile_goal(once(G),Tail,[L,LL]) :-
compile_goal(G,#f,V,[LX,LLX]),
tr('store-state',Newframe),
tr('unwind-tail',UnwindTail),
L=[[Newframe,A]|LX],
LLX=[[UnwindTail,A,0]|LY].
(zero(V) -> Tp is 0 ; Tp is 2),
L=[[Newframe,A,Tp]|LX],
(
Tail=#t ->
LLX=[[UnwindTail,A],[cc]|LL];
LLX=[[UnwindTail,A] |LL]
).
compile_goal((X->Y),Tail,V,L) :- !,
compile_goal((once(X),Y),Tail,V,L).
compile_goal(\\+X,Tail,V,[L,LL]) :- !,
check_tail(Tail),
......@@ -200,7 +224,8 @@ compile_goal(\\+X,Tail,V,[L,LL]) :- !,
tr(notend,Notend),
tail(Tail,LL,LLL),
get_ACESB(V,A,C,E,S,B),
CC is C + 1,
C = [C0|_],
CC = [Al|C],
set_CE(V,CC,0),
ifc(compile_goal(X,#f,V,[LX,LLX]),Er,
(
......@@ -212,9 +237,9 @@ compile_goal(\\+X,Tail,V,[L,LL]) :- !,
(A==A1 -> true ; throw(mismatching_begin_end_in_negation)),
set_ACESB(V,A,C,E,S,B),
label(Al),label(Bl),
(A=[[0|_]|_] -> Tp is 1 ; Tp is 3),
(A=[[0|_]|_] -> Tp is 0 ; Tp is 1),
L = [ [Newframe,Al,Tp] |LX ],
LLX = [ [Unwind,Al,Bl],[label,Al],[Post,Al],[label,Bl] | LLL]
LLX = [ [Unwind,Al,Bl,C0],[label,Al],[Post,Al,C0],[label,Bl] | LLL]
)).
......
......@@ -32,16 +32,20 @@ handle_all([X|Y],I,II,L,LL) :-
handle([label,N],I,II,L,LL) :- !,
N=I,I=II,LL=L.
handle((X,[('goto-inst';'store-state';'post-negation';'unwind-tail'),N]),
handle((X,[('goto-inst';'store-state';'unwind-tail'),N]),
I,II,L,LL) :- !,
II is I + 2,
L=[X|LL].
handle((X,[(newframe;'newframe-negation';'unwind-negation';'unwind'),A,B]),
handle((X,[(newframe;'newframe-negation';'post-negation';'unwind'),A,B]),
I,II,L,LL) :- !,
II is I + 3,
L=[X|LL].
handle((X,['unwind-negation',A,B,C]),I,II,L,LL) :- !,
II is I + 4,
L = [X|LL].
handle([label,N,[_,Tags]],I,II,L,LL) :- !,
N=I,
addvs(Tags,I,II,L,LL).
......@@ -83,6 +87,13 @@ handle([(Op,('post-unify' ; 'post-unify-tail')),[[S,V,Q],N,F|_]],I,II,L,LL) :-
)
).
handle([set,(W,[[S,V,Q],N,F|_])],I,II,L,LL) :- !,
(
(F=#t,N=1) -> (L=LL, I=II) ;
S=#t -> (new_var(V,Q,S),L=[[set,V]|LL],II is I + 2) ;
handle([unify,W,#t],I,II,L,LL)
).
handle(['push-variable',[[S,V,Q],N,F|_]],I,II,L,LL) :- !,
(
(F==#t,N==1) -> (L=[[pushv,#f]|LL] , II is I + 2);
......
......@@ -176,7 +176,7 @@ t('newframe-negation').
t('unwind-negation').
t('post-negation').
t('set').
t('unify-variable').
t('unify-constant').
t('unify-instruction').
......
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