bug fix, gc of test cases passes

parent eb48b4fa
......@@ -202,7 +202,8 @@ rec(F,A,N,Args,Tail,V,[L,LL]) :-
set_S(V,0),
push_args_args(#f,Args,V,L2,LL2,_,_),
touch_A(V),
set_FS(V,F,S),
%set_FS(V,F,S),
set_S(V,S),
(
tr('goto-inst',Goto),
LL2 = [[Goto,A]|LL]
......
......@@ -59,7 +59,6 @@ compile_disjunction0
catch((
read_Q(V,Qit),
pop_Q(V,_),
set_F(V,scm[(gensym \"tag\")]),
get_CES(V,[C|_],E,S),
set_AES(V,Aq,0,S0),
(
......@@ -96,9 +95,11 @@ goal(X,Y,First,Lab,Tail,Out,A,Ae,Aq,S0,[U|UU],V,L,LL,LG,LLX) :-
read_Q(V,Qit),
get_CES(V,[C|_],E,S),
set_AES(V,Aq,0,S0),
(First==#t -> true ; set_F(V,scm[(gensym \"tag\")])),
((nonvar(X),X=(G1->G2)) -> XX=(G1,softie(A),G2) ; XX=X),
compile_goal(XX,Tail,V,[LX,LG]),
((nonvar(X),X=(G1->G2)) ->
XX=(G1,softie(A),collect_F(FF),G2) ;
(XX=(X,newtag(FF)))),
compile_goal(XX,Tail,V,[LX,LG]),
(var(FF) -> true ; set_F(V,FF)),
get_ACES(V,A1q,[C1|_],E1,S1),
(C == C1 -> true ; throw(bug_c_state_error)),
S2 is max(S,S1),
......
......@@ -156,6 +156,11 @@ compile_goal((F :- Goal),Tail,V,L) :- !,
push_v(4,V),
wrap(compile_goal((pop(4),Goal),Tail,V,L),L).
compile_goal(newtag_F(F),Tail,V,[L,L]) :-
F=scm[(gensym \"disj\")].
compile_goal(collect_F(F),Tail,V,[L,L]) :-
get_F(V,F).
compile_goal(Op(\"recur\",Args),Tail,V,[L,LL]) :-
Args = F(|U),
......@@ -167,7 +172,7 @@ compile_goal(Op(\"recur\",Args),Tail,V,[L,LL]) :-
push_args_args(#f,Xin,V,L,L1,_,_),
touch_A(V),
touch_Q(V),
set_F(V,scm[(gensym \"Rec\")]),
%set_F(V,scm[(gensym \"Rec\")]),
L1=[[label,A]|L2],
compile_goal((begin_att,Impr,end_att),Tail,V,[L2,LL]).
......
......@@ -288,7 +288,7 @@ isFirst([_,_,X |_]) :- X==#t.
force_variable([[#t|_]|_]).
new_tag([HC,HV],X,XX,Tag,Etag) :-
new_tag2([HC,HV],X,XX,Tag,Etag) :-
new_e(Etag),
Tag=[XX,_,_,X,Etag],
vhashq_cons (HV,Tag,Etag),
......@@ -306,7 +306,7 @@ get_e_tag(X,[HC,HV],F,Ex,Tag,Etags) :-
vhashql_cons(HC,E,X)
)
),
new_tag([HC,HV],X,XX,Tag,Etag),
new_tag2([HC,HV],X,XX,Tag,Etag),
EE is Etags \\/ Etag,
Ex is E \\/ Etag,
set(Etags,EE).
......@@ -352,7 +352,7 @@ find_all_vars(H,Es,L) :-
add_miss(_,[],[],E,E).
add_miss(H,[V|Xs],Ys,E,EE) :-
new_tag(H,V,_,Tag,Etag),
new_tag2(H,V,_,Tag,Etag),
first(Tag),
reference(H,Tag),
E1 is E \\/ Etag,
......@@ -417,6 +417,9 @@ get_line([A|U],[A|X],[_|Xin],I,N) :- !,
get_line(U,X,Xin,II,N).
get_line(_,[],[],I,I).
collect_F.
newtag_F.
")
......
......@@ -2,7 +2,7 @@
(use-modules (logic guile-log guile-prolog ops))
(use-modules (logic guile-log guile-prolog vm-compiler))
#;
(define-prolog f1 "
f1(N,I,J,S) :-
I < N ->
......@@ -28,7 +28,7 @@
).
")
#;
(compile-prolog-string "
f3(N,I,J,S) :-
I < N ->
......@@ -40,7 +40,7 @@
S=J
")
#;
(define-prolog memb "
memb(X,L) :-
recur * lp((LL,L)),
......
......@@ -74,7 +74,8 @@
(<and>
(existence_error "undefined_global_variable" atom)
(lp))
(<=> val ,(gp-lookup-1 r S))))))
(<and>
(<=> val ,(gp-lookup-1 r S)))))))
((string? atom)
(<let> ((mod (current-module))
(sym (string->symbol atom)))
......
......@@ -59,7 +59,7 @@ SCM_DEFINE(gp_mk_att_data, "gp-make-attribute-from-data", 2, 0, 0, (SCM model, S
datapt = scm_cons(scm_cons(car,h),datapt);
data = SCM_CDR(data);
}
data = datapt;
{
......@@ -371,11 +371,11 @@ SCM_DEFINE(gp_del_attr, "gp-del-attr", 3, 0, 0, (SCM x, SCM lam, SCM s),
if(GP(x))
{
SCM *ref = GP_GETREF(x);
gp_debug0("a gp~%");
gp_debug0("a gp\n");
if(GP_ATTR(ref))
{
SCM it = SCM_CDR(ref[1]);
gp_debug0("a an attr~%");
gp_debug0("a an attr\n");
if(GP_UNBOUND(ref))
{
return s;
......@@ -437,11 +437,11 @@ SCM_DEFINE(gp_del_attr_x, "gp-del-attr!", 3, 0, 0, (SCM x, SCM lam, SCM s),
if(GP(x))
{
SCM *ref = GP_GETREF(x);
gp_debug0("a gp~%");
gp_debug0("a gp\n");
if(GP_ATTR(ref))
{
SCM it = SCM_CDR(ref[1]);
gp_debug0("a an attr~%");
gp_debug0("a an attr\n");
if(GP_UNBOUND(ref))
{
return s;
......
......@@ -7,12 +7,17 @@ int gp_gc_p = 0;
int gp_gc_counter = 0;
inline void gp_gc_inc(struct gp_stack *gp)
{
unsigned long
ns = gp->gp_nns - gp->gp_si,
unsigned long
ns = gp->gp_nns - gp->gp_si,
nc = gp->gp_nncs - gp->gp_cs,
n = gp->gp_nnc - gp->gp_ci;
nf = gp->gp_nnfr - gp->gp_fr,
n = gp->gp_nnc - gp->gp_ci;
n = (nf > n) ? ((nc > n) ? (n > ns ? ns : n)
: (nc > ns ? ns : nc))
: ((nc > nf) ? (nf > ns ? ns : nf)
: (nc > ns ? ns : nc));
n = (nc > n) ? (n > ns ? ns : n) : (nc > ns ? ns : nc);
gp_gc_counter++;
if(n > 10000)
......
This diff is collapsed.
#define DB(X)
//#define DB(X)
#define STATE_LOGICAL 0
#define STATE_DYNSTACK 1
......@@ -1239,8 +1239,8 @@ static inline SCM * gp_get_branch(SCM *p, SCM *fr, struct gp_stack *gp)
else
{
scm_misc_error("gp-unwind/get_branch",
"reched eol prematurely 1 ~a",
scm_list_1(scm_from_int(i)));
"reched eol prematurely 1 ~a ~a ~a",
scm_list_3(scm_from_int(i),fr[0],fr[1]));
return fr;
}
}
......@@ -1606,7 +1606,7 @@ SCM scm_length2(SCM pt)
}
//#define DB(X) X
// #define DB(X) X
static void gp_restore_state(SCM data, struct gp_stack *gp, SCM K)
{
SCM *si, path, pathfr;
......@@ -1682,6 +1682,9 @@ static void gp_restore_state(SCM data, struct gp_stack *gp, SCM K)
gp_debug0("get-branch\n");
fr = gp_get_branch(&pp_x, fr_x, gp) + 1;
if(SCM_CONSP(fr[-1]))
gp_format0("fr has a tag\n");
gp_format2("pp_x ~a dfr ~a~%",
scm_length2(pp_x),
scm_from_long(fr_x-fr));
......@@ -1697,9 +1700,13 @@ static void gp_restore_state(SCM data, struct gp_stack *gp, SCM K)
cs = gp->gp_cons_stack + GP_GET_CONS (fr);
ci = gp->gp_cstack + GP_GET_VAL_VAL (fr) + 1;
if(!SCM_CONSP(*(ci - 1)) && !scm_is_eq(*(ci - 1),GP_GET_VAL(fr)))
scm_misc_error("restore-state","ci self entry is not the same~%~a"
, scm_list_1(*ci));
if(!SCM_CONSP(ci[-1]))
if(SCM_UNPACK(ci[-1]) != SCM_UNPACK(GP_GET_VAL(fr)))
scm_misc_error("restore-state",
"ci self entry is not the same~%~a ~a ~a ~a",
scm_list_4(ci[-2],ci[-1],ci[0],
GP_GET_VAL(fr)));
if(si > gp->gp_si) si = gp->gp_si;
if(cs > gp->gp_cs) cs = gp->gp_cs;
......
......@@ -4009,12 +4009,11 @@ SCM gp_copy_vector(SCM **vector, int nvar)
SCM inline gp_cons_simple(SCM x, SCM y, SCM s)
{
struct gp_stack *gp = get_gp();
SCM cons = get_gp_cons_pure(gp);
SCM *f = GP_GETREF(cons);
SCM *f = get_gp_cons_pure(gp);
f[1] = x;
f[2] = y;
return cons;
return GP_UNREF(f);
}
#include "prolog-vm.c"
......
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