new vm now supprts continuations

parent dd8384e2
......@@ -48,11 +48,12 @@ constant = #(nlocals nstack constants code)
(<global> SCM *gp-not-n* (<scm> #f))
(<global> SCM *gp-is-delayed?* (<scm> #f))
(<declare-s> SCM gp_get_state_token ())
(<declare-s> SCM scm_gr_p ((SCM x) (SCM y)))
(<declare-s> SCM scm_less_p ((SCM x) (SCM y)))
(<declare-s> SCM scm_geq_p ((SCM x) (SCM y)))
(<declare-s> SCM scm_leq_p ((SCM x) (SCM y)))
(<declare-s> gp_copy_vector (((SCM **) vector) (int nvar)))
(<declare-s> SCM scm_sum ((SCM x) (SCM y)))
(<declare-s> SCM scm_product ((SCM x) (SCM y)))
(<declare-s> SCM scm_divide ((SCM x) (SCM y)))
......@@ -115,6 +116,13 @@ constant = #(nlocals nstack constants code)
(SCM d)))
(<declare-s> remove_me_t gp_make_vm_model ())
(define-syntax-rule (MAYBE-ADJUST-VECTOR
pinned? variables varables-scm nvar)
(<if> (TRUE pinned?)
(<begin>
(<=> varibles-scm (<call> gp_copy_vector (<addr> variables) nvar))
(<=> pinned? (<scm> #f)))))
(define-syntax-rule (GET-TOKEN) (<call> gp_get_state_token))
(define-syntax-rule (SET x y s) (<call> gp_set x y s))
(define-syntax-rule (CAR x) (<call> SCM_CAR x))
(define-syntax-rule (CDR x) (<call> SCM_CDR x))
......@@ -313,12 +321,14 @@ constant = #(nlocals nstack constants code)
(define-syntax-rule (SVAR-REF fp nstack i)
(<ref> fp (<-> (<+> nstack i))))
(define-syntax-rule (UNPACK-VAR x i code1 code2)
(define-syntax-rule (UNPACK-VAR var? x i code1 code2)
(<if> (PAIR? x)
(<let> ((int i (scm->int (CAR x))))
code1)
code1)
(<let> ((int i (scm->int x)))
code2)))
(<if> var? (MAYBE-ADJUST-VECTOR
pinned? variables varables-scm nvar))
code2)))
(define-syntax CLEAR
(syntax-rules ()
......@@ -524,12 +534,12 @@ constant = #(nlocals nstack constants code)
(<=> inst-pt (<+> inst-pt (<c> 3)))
(<if> (<==> k (<scm> #f))
(<begin>
(UNPACK-VAR n i
(UNPACK-VAR 1 n i
(<=> (SVAR-REF fp nstack i) (ARG -1 sp))
(<=> (<ref> variables i) (ARG -1 sp)))
(CLEAR 1 sp)
(NEXT inst-pt))
(<let*> ((SCM x (UNPACK-VAR n i
(<let*> ((SCM x (UNPACK-VAR 0 n i
(SVAR-REF fp nstack i)
(<ref> variables i)))
(SCM y (ARG -1 sp))
......@@ -560,11 +570,11 @@ constant = #(nlocals nstack constants code)
(<=> inst-pt (<+> inst-pt (<c> 4)))
(<if> (<==> k (<scm> #f))
(<begin>
(UNPACK-VAR n ii
(UNPACK-VAR 1 n ii
(<=> (SVAR-REF fp nstack ii) q)
(<=> (<ref> variables ii) q))
(NEXT inst-pt))
(<let*> ((SCM x (UNPACK-VAR n ii
(<let*> ((SCM x (UNPACK-VAR 0 n ii
(SVAR-REF fp nstack ii)
(<ref> variables ii)))
(SCM y q)
......@@ -598,30 +608,30 @@ constant = #(nlocals nstack constants code)
(<if> (<==> k1 (<scm> #f))
(<begin>
(<if> (EQ k2 (<scm> #f))
(UNPACK-VAR n2 i2
(UNPACK-VAR 1 n2 i2
(<=> (SVAR-REF fp nstack i2) (MKVAR s))
(<=> (<ref> variables i2) (MKVAR s))))
(<let> ((rhs (UNPACK-VAR n2 i2
(<let> ((rhs (UNPACK-VAR 0 n2 i2
(SVAR-REF fp nstack i2)
(<ref> variables i2))))
(UNPACK-VAR n1 i1
(UNPACK-VAR 1 n1 i1
(<=> (SVAR-REF fp nstack i1) rhs)
(<=> (<ref> variables i1) rhs)))
(NEXT inst-pt))
(<if> (<==> k2 (<scm> #f))
(<let> ((rhs (UNPACK-VAR n1 i2
(<let> ((rhs (UNPACK-VAR 0 n1 i2
(SVAR-REF fp nstack i2)
(<ref> variables i2))))
(UNPACK-VAR n2 i1
(UNPACK-VAR 1 n2 i1
(<=> (SVAR-REF fp nstack i1) rhs)
(<=> (<ref> variables i1) rhs))
(NEXT inst-pt))
(<let*> ((SCM x (UNPACK-VAR n1 i1
(<let*> ((SCM x (UNPACK-VAR 0 n1 i1
(SVAR-REF fp nstack i1)
(<ref> variables i1)))
(SCM y (UNPACK-VAR n2 i2
(SCM y (UNPACK-VAR 0 n2 i2
(SVAR-REF fp nstack i2)
(<ref> variables i2)))
......@@ -652,6 +662,13 @@ constant = #(nlocals nstack constants code)
*delayers*))
p)))
stack)))
(define-syntax-rule (STORE-STATE-SOFT tag p stack)
(<let> ((np (<if> (NUMBER? p) p (<scm> 0))))
(CONS (CONS tag
(CONS (<scm> #f)
p))
stack)))
(define-syntax-rule (CLEAR-SP-XP sp xp)
(<recur> lp ()
......@@ -700,6 +717,20 @@ constant = #(nlocals nstack constants code)
(<begin>
(<=> stack (CDR stack))
(<next> lp))))))
(define-syntax-rule (RESTORE-STATE-SOFT p tag stack)
(<recur> lp ()
(<let> ((x (CAR stack)))
(<if> (EQ x tag)
(<let*> ((x1 (CDR x))
(x2 (CDR x1)))
(<=> stack (CDR stack))
(<if> (PAIR? x2)
(<=> p (CAR x2))
(<=> p x2)))
(<begin>
(<=> stack (CDR stack))
(<next> lp))))))
(define-syntax-rule (NEXT inst-pt)
......@@ -727,6 +758,7 @@ constant = #(nlocals nstack constants code)
(define-syntax-rule (MAKE-REGS sp)
(<begin>
(REGISTER store-state)
(REGISTER softie)
(REGISTER newframe)
(REGISTER unwind)
(REGISTER unwind-tail)
......@@ -932,11 +964,13 @@ constant = #(nlocals nstack constants code)
(scm->int (INSTR-REF free))))
(define-syntax-rule (GET-VARIABLES s nvar variables
middle session cnst tvars)
middle session cnst tvars pinned?)
(<begin>
(PRINTF "get-variables\n")
(<if> (TRUE variables)
(scm->vector variables)
(<let> ((vv (scm->vector variables)))
(<=> pinned? (VARIABLE-REF (<ref> vv (<c> 2))))
vv)
(<let*> ((int n nvar)
(SCM v (<call> scm_c_make_vector n (<scm> #f)))
((SCM *) vv (scm->vector v)))
......@@ -948,6 +982,7 @@ constant = #(nlocals nstack constants code)
(<if> var?
(<=> (<ref> vv i) (<call> gp_mkvar s)))
(<next> lp (<+> i (<c> 1))))))
(<=> (<ref> vv (<c> 2)) (GET-TOKEN))
vv))))
(define-syntax-rule (DO-CONS s sp)
......@@ -961,7 +996,7 @@ constant = #(nlocals nstack constants code)
(define-syntax-rule (PRE-UNIFY variables nstack inst-pt fp)
(<let> ((SCM n (<*> inst-pt)))
(<=> inst-pt (<+> inst-pt (<c> 1)))
(UNPACK-VAR n i2
(UNPACK-VAR 1 n i2
(<=> (SVAR-REF fp nstack i2) (<call> scm_fluid_ref *delayers*))
(<=> (<ref> variables i2) (<call> scm_fluid_ref *delayers*)))))
......@@ -969,10 +1004,10 @@ constant = #(nlocals nstack constants code)
(define-syntax-rule (POST-UNIFY variables inst-pt sp-stack nstack sp fp)
(<let*> ((SCM n (<*> inst-pt))
(int nsloc (scm->int (<ref> inst-pt (<c> 1))))
(SCM old (UNPACK-VAR n i2
(SCM old (UNPACK-VAR 0 n i2
(SVAR-REF fp nstack i2)
(<ref> variables i2))))
(UNPACK-VAR n i2
(UNPACK-VAR 1 n i2
(<=> (SVAR-REF fp nstack i2) (<scm> #f))
(<=> (<ref> variables i2) (<scm> #f)))
......@@ -989,11 +1024,11 @@ constant = #(nlocals nstack constants code)
(define-syntax-rule (POST-UNIFY-TAIL variables inst-pt sp-stack nstack sp fp)
(<let*> ((SCM n (<*> inst-pt))
(SCM old (UNPACK-VAR n i2
(SCM old (UNPACK-VAR 0 n i2
(SVAR-REF fp nstack i2)
(<ref> variables i2))))
(UNPACK-VAR n i2
(UNPACK-VAR 1 n i2
(<=> (SVAR-REF fp nstack i2) (<scm> #f))
(<=> (<ref> variables i2) (<scm> #f)))
......@@ -1225,7 +1260,8 @@ constant = #(nlocals nstack constants code)
(<--> sp)
(<if> register?
(MAKE-REGS sp)
(<let> ((int call? (<c> 1))
(<let> ((SCM pinned? (<scm> #f))
(int call? (<c> 1))
(int narg (<c> 0))
(int nlocals (<c> 0))
(SCM always (<scm> #f))
......@@ -1399,11 +1435,8 @@ constant = #(nlocals nstack constants code)
(LABEL store-state)
(PRSTACK sp fp)
(<let> ((SCM np (<ref> inst-pt (<c> 0)))
(int tp (scm->int (<ref> inst-pt (<c> 1))))
(SCM ss (NEWFRAME s)))
(<=> inst-pt (<+> inst-pt (<c> 2)))
(<=> s ss)
(<=> ctrl-stack (STORE-STATE tp np s p ctrl-stack))
(<=> inst-pt (<+> inst-pt (<c> 1)))
(<=> ctrl-stack (STORE-STATE-SOFT np p ctrl-stack))
(NEXT inst-pt))
(LABEL newframe)
......@@ -1479,6 +1512,13 @@ constant = #(nlocals nstack constants code)
(UNWIND-TAIL s)
(NEXT inst-pt))
(LABEL softie)
(PRSTACK sp fp)
(<let> ((SCM tag (<*> inst-pt)))
(<=> inst-pt (<+> inst-pt (<c> 1)))
(RESTORE-STATE-SOFT p tag ctrl-stack)
(NEXT inst-pt))
(LABEL unwind)
(PRSTACK sp fp)
......@@ -1554,7 +1594,7 @@ constant = #(nlocals nstack constants code)
(<let*> ((SCM n (<ref> inst-pt (<c> 0)))
(ss
(SET
(UNPACK-VAR n i
(UNPACK-VAR 0 n i
(SVAR-REF fp nstack i)
(<ref> variables i))
(ARG -1 sp) s)))
......@@ -1648,7 +1688,7 @@ constant = #(nlocals nstack constants code)
(<++> inst-pt)
(<if> (<call> scm_is_false x)
(<=> (<*> sp) (<call> gp_mkvar s))
(UNPACK-VAR x i
(UNPACK-VAR 0 x i
(<=> (<*> sp) (SVAR-REF fp nstack i))
(<=> (<*> sp) (<ref> variables i))))
(INCR 1 sp)
......@@ -1668,11 +1708,11 @@ constant = #(nlocals nstack constants code)
(int new? (scm->int (<ref> inst-pt (<c> 1))))
(SCM v (<if> new?
(<let> ((v (MKVAR s)))
(UNPACK-VAR x i
(UNPACK-VAR 1 x i
(<=> (SVAR-REF fp nstack i) v)
(<=> (<ref> variables i) v))
v)
(UNPACK-VAR x i
(UNPACK-VAR 0 x i
(SVAR-REF fp nstack i)
(<ref> variables i)))))
......@@ -1685,7 +1725,7 @@ constant = #(nlocals nstack constants code)
(PRSTACK sp fp)
(<let*> ((SCM x (<*> inst-pt))
(SCM v (<call> gp_gp_lookup
(UNPACK-VAR x i
(UNPACK-VAR 0 x i
(SVAR-REF fp nstack i)
(<ref> variables i))
s)))
......
......@@ -46,13 +46,27 @@ compile_conj0([!|Gs],Tail,V,[L,LL]) :- !,
(
E==#t ->
(Tail==#t -> L=[[cut],[cc]|LL] ; L=[[cut]|LL]);
throw(c)
throw(c)
)
),
(
L=[[cut]|L1]
)).
compile_conj0([softie(A)|Gs],Tail,V,[L,LL]) :- !,
ifc(compile_conj0(Gs,Tail,V,[L1,LL]),E,
(
tfc(E),
(
E==#t ->
(Tail==#t -> L=[[softie,A],[cc]|LL] ; L=[[softie,A]|LL]);
throw(softie(A))
)
),
(
L=[[softie,A]|L1]
)).
compile_conj0([(fail;false)|Gs],Tail,V,[L,LL]) :- !,
L=[[fail]|LL].
......@@ -75,7 +89,11 @@ compile_conj0([G|Gs],Tail,V,L) :- !,
(
E2==#t ->
(Tail==#t -> L2=[[[cc]|U],U] ; L2=[U,U]);
throw(E2)
E2==c ->
L2=[[[cut],[fail]|U],U] ;
E2=softie(A) ->
L2=[[[softie,A],[fail]|U],U] ;
throw(E2)
)
))
)).
......
......@@ -47,7 +47,7 @@ head_at_true(#f,#t,A,C,Lab,Lab2,L1,LLX) :-
tr('unwind-tail',UnwindTail),
L1=[[label,Lab,U],[UnwindTail,A]|LLX].
compile_disjunction
compile_disjunction0
([X],First,Aq,Ae,Out,Lab,A,Tail,S0,[U],V,[L,LL]) :- !,
(First=#t -> compile_goal(X,First,V,[L,LL]) ;
catch((
......@@ -55,7 +55,8 @@ compile_disjunction
get_CES(V,[C|_],E,S),
set_AES(V,Aq,0,S0),
(
compile_goal(X,Tail,V,[LX,LL]),
(X=[G1->G2] -> XX=[G1,softie(A),G2] ; XX=X)
compile_goal(XX,Tail,V,[LX,LL]),
get_ACES(V,Aq1,[C1|_],E1,S1),
(C == C1 -> true ; throw(bug_c_state_error)),
(
......@@ -77,8 +78,9 @@ compile_disjunction
throw(#t) ;
head_at_true(#f,#t,A,C,Lab,Lab2,L,LL)
);
Er == #f -> throw(#f);
Er == c -> throw(#f)
Er == c ->
throw(c) ;
throw(#f)
)
))).
......@@ -86,7 +88,8 @@ goal(X,Y,First,Lab,Tail,Out,A,Ae,Aq,S0,[U|UU],V,L,LL,LG,LLX) :-
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]),
(X=[G1->G2] -> XX=[G1,softie(A),G2] ; XX=X)
compile_goal(XX,Tail,V,[LX,LG]),
get_ACES(V,A1q,[C1|_],E1,S1),
(C == C1 -> true ; throw(bug_c_state_error)),
S2 is max(S,S1),
......@@ -104,21 +107,23 @@ goal(X,Y,First,Lab,Tail,Out,A,Ae,Aq,S0,[U|UU],V,L,LL,LG,LLX) :-
throw(all_disjuction_goals_needs_the_same_begin_level))
)
),
ifc(compile_disjunction(Y,#f,Aq,Ae,Out,Lab2,A,Tail,S0,UU,V,[LLX,LL]),Err,
ifc(compile_disjunction0(Y,#f,Aq,Ae,Out,Lab2,A,Tail,S0,UU,V,[LLX,LL]),Err,
(
(
Err=#t ->
Err==#t ->
throw(bug_true_not_be_send_in_non_first_disjunction);
(
head_at_true(First,#t,A,C,Lab,Lab2,L,LX),
LLX=LL
)
head_at_true(First,Tail,A,C,Lab,Lab2,L,LX),
Err==c ->
LLX=[[cut],[fail]|LL];
LLX=LL
);
)
),
head_at_true(First,#f,A,C,Lab,Lab2,L,LX)
head_at_true(First,Tail,A,C,Lab,Lab2,L,LX)
).
compile_disjunction([X|Y],First,Aq,Ae,Out, Lab,A,Tail,S0,U,V,[L,LL]) :- !,
compile_disjunction0([X|Y],First,Aq,Ae,Out, Lab,A,Tail,S0,U,V,[L,LL]) :- !,
tr('goto-inst',Goto),
(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,LLX), Er,
......@@ -126,11 +131,12 @@ compile_disjunction([X|Y],First,Aq,Ae,Out, Lab,A,Tail,S0,U,V,[L,LL]) :- !,
tfc(Er),
(Tail==#t -> LLG = [[cc]|LG] ; LLG=LG),
(
Er==c -> throw(#f) ;
Er==c ->
throw(c) ;
Er==#t ->
(
U = [E1,_],
ifc(compile_disjunction
ifc(compile_disjunction0
(Y,#f,Aq,Aq,Out,Lab2,A,Tail,S0,UU,V,[LLX,LL]),Er2,
(
tfc(Er2),
......@@ -153,7 +159,17 @@ compile_disjunction([X|Y],First,Aq,Ae,Out, Lab,A,Tail,S0,U,V,[L,LL]) :- !,
throw(syntax_error_begin_en_missmatch))),
head_at_true(First,#f,A,C,Lab,Lab2,L,LG)
)));
compile_disjunction(Y,First,Aq,Ae,Out,Lab,A,Tail,S0,U,V,[L,LL])
compile_disjunction0(Y,First,Aq,Ae,Out,Lab,A,Tail,S0,U,V,[L,LL])
)
)).
compile_disjunction(Y,First,Aq,Ae,Out,Lab,A,Tail,S0,U,V,[L,LL]) :-
catch(compile_disjunction0(Y,First,Aq,Ae,Out,Lab,A,Tail,S0,U,V,[L,LL]),Er,
(
tfc(Er),
(
Er=softie(_) -> throw(#f) ; throw(Er)
)
)).
")
......@@ -72,6 +72,10 @@ compile_goal(!,Tail,V,[LL,L]) :- !,
check_tail(Tail),
(Tail==#t -> L=[[cut],[cc]|LL] ; L=[[cut]|LL]).
compile_goal(softie(A),Tail,V,[LL,L]) :- !,
check_tail(Tail),
(Tail==#t -> L=[[softie,A],[cc]|LL] ; L=[[softie,A]|LL]).
compile_goal(begin_att,Tail,V,[L,LL]) :- !,
check_tail(Tail),
tail(Tail,LL,LLL),
......@@ -203,9 +207,9 @@ compile_goal(set(V,X),Tail,V,[L,LL]) :- !,
compile_goal(once(G),Tail,V,[L,LL]) :- !,
compile_goal(G,#f,V,[LX,LLX]),
tr('store-state',Newframe),
tr('unwind-tail',UnwindTail),
tr('softie' ,UnwindTail),
(zero(V) -> Tp is 0 ; Tp is 2),
L=[[Newframe,A,Tp]|LX],
L=[[Newframe,A]|LX],
(
Tail=#t ->
LLX=[[label,A],[UnwindTail,A],[cc]|LL];
......
......@@ -32,7 +32,7 @@ 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';'unwind-tail'),N]),
handle((X,[('goto-inst';'store-state';'unwind-tail';softie),N]),
I,II,L,LL) :- !,
II is I + 2,
L=[X|LL].
......
......@@ -171,6 +171,7 @@ t('store-state').
t(newframe).
t(unwind).
t('unwind-tail').
t(softie).
t('newframe-negation').
t('unwind-negation').
......
......@@ -204,7 +204,7 @@ ifc(G,E,X,Y) :-
(var(E) -> Y ; true).
tf(E) :- (E==#t;E==#f) -> true ; throw(E).
tfc(E) :- (E==#t;E==#f;E==c) -> true ; throw(E).
tfc(E) :- (E==#t;E==#f;E==c;E=softie(_)) -> true ; throw(E).
tt(E) :- E==#t -> true ; throw(E).
ff(E) :-
(E == #t -> throw(bug_should_not_throw_true) ; throw(E)).
......
......@@ -12,6 +12,19 @@
#include "dynstack.c"
SCM gp_state_token = SCM_BOOL_F;
inline SCM gp_get_state_token()
{
return scm_fluid_ref(gp_state_token);
}
inline void gp_new_state_token()
{
SCM x = scm_fluid_ref(gp_state_token);
scm_variable_set_x(x,SCM_BOOL_T);
scm_fluid_set_x(gp_state_token,scm_make_variable(SCM_BOOL_F));
}
SCM inline get_cs(SCM v)
{
......@@ -881,6 +894,8 @@ SCM_DEFINE(gp_gp_store_state, "gp-store-state", 1, 0, 0, (SCM s),
vlist_incref(l);
}
gp_new_state_token()
ret = scm_cons(gp_store_state(get_gp()),
scm_cons(scm_fluid_ref(gp_current_stack) , s));
......
......@@ -3752,6 +3752,21 @@ SCM_DEFINE(gp_custom_fkn, "gp-custom-fkn",3,0,0,
#include "guile-2.2.c"
#define AREF(a,i) ((a)[i])
SCM gp_copy_vector(SCM s, SCM **vector, int nvar)
{
SCM newvec = scm_c_make_vector(nvar,SCM_BOOL_F);
SCM *newp = SCM_I_VECTOR_WELTS(newvec);
SCM *vecp = *vector;
for(int i = 0; i < nvar; i++)
{
newp[i] = vector[i];
}
newp[2] = gp_get_state_token();
*vector = newp;
return newvec;
}
#include "prolog-vm.c"
......@@ -3817,7 +3832,9 @@ void gp_init()
gp_cons_sym = scm_string_to_symbol (gp_cons_str);
gp_type = scm_make_smob_type("unify-variable",0);
gp_state_token = scm_make_fluid(scm_make_variable(SCM_BOOOL_F));
scm_set_smob_print(gp_type, gp_printer);
{
......
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