subtle memore gc problem fixed + various other fixes

parent 9d72e7c9
......@@ -772,7 +772,8 @@
(gp-dynwind
redo
(lambda () (parse<> (cut s p cc) <cc>))
undo))))
undo
s))))
(log-code-macro '<dynwind>)
......
......@@ -52,17 +52,19 @@ static inline SCM *make_gp_stack(int id, int nthread, int nc, int ns, struct gp_
(SCM *) scm_gc_malloc_pointerless(sizeof(SCM) * nc,"gp->gp_cstack");
if(!gp->gp_cstack) goto error2;
scm_gc_protect_object(GP_UNREF(gp->gp_cstack));
gp->gp_stack =
(SCM *) scm_gc_malloc_pointerless(sizeof(SCM) * ns,"gp->gp_stack");
if(!gp->gp_stack) goto error3;
scm_gc_protect_object(GP_UNREF(gp->gp_stack));
gp->gp_nc = nc;
gp->gp_ns = ns;
gp->gp_si = gp->gp_stack;
gp->gp_ci = gp->gp_cstack + 1;
gp->gp_cstack[0] = GP_UNREF(gp->gp_stack);
gp->gp_ci = gp->gp_cstack;
gp->gp_nns = gp->gp_stack + gp->gp_ns - 10;
gp->gp_nnc = gp->gp_cstack + gp->gp_nc - 10;
......@@ -75,15 +77,17 @@ static inline SCM *make_gp_stack(int id, int nthread, int nc, int ns, struct gp_
SCM ret;
SCM_NEWSMOB(ret, gp_stack_type, (void*)0);
GP_GETREF(ret)[1] = GP_UNREF((SCM *) gp);
scm_gc_unprotect_object(GP_UNREF(gp->gp_cstack));
scm_gc_unprotect_object(GP_UNREF(gp->gp_stack));
return GP_GETREF(ret);
error3:
scm_gc_unprotect_object(GP_UNREF(gp->gp_cstack));
error2:
error1:
return (SCM *)0;
return (SCM *)0;
}
......
......@@ -99,9 +99,12 @@ item
static inline int gp_do_cons(SCM item, int state, SCM *old)
{
SCM q,a,b,*id,tag = SCM_CAR(item);
SCM q,a,b,*id,tag;
gp_debug0("do_cons\n");
tag = SCM_CAR(item);
if(SCM_I_INUMP(tag))
return gp_advanced(item,state,old);
......@@ -180,14 +183,21 @@ static inline void gp_unwind0(SCM *ci, SCM *si, struct gp_stack *gp)
if (ci_old-1 >= gp->gp_ci)
for(i = ci_old-1; i >= gp->gp_ci; i-=1)
{
gp_debug1("iter %x\n",i - gp->gp_cstack);
if(SCM_CONSP(*i))
{
state = gp_do_cons(*i, state, &old);
continue;
}
if(!GP(*i))
{
gp_debug1("adress> %x\n",SCM_UNPACK(*i));
scm_misc_error("in unwinding","should have a GP value or CONS in unwinding of cstack",SCM_EOL);
}
id = GP_GETREF(*i);
if(state)
{
switch(state)
......@@ -299,8 +309,8 @@ static inline void gp_unwind(SCM fr)
else
{
ci = gp->gp_ci - SCM_I_INUM(fr);
if(ci < gp->gp_cstack)
ci = gp->gp_cstack;
if(ci < gp->gp_cstack + 1)
ci = gp->gp_cstack + 1;
si = gp->gp_si;
}
gp_unwind0(ci,si,gp);
......
......@@ -41,8 +41,8 @@ scm_simple_format(SCM_BOOL_T, \
#define DB(X)
#define DS(X)
#define DB(X)
#define DS(X)
#define gp_debug0(s) DB(printf(s) ; fflush(stdout))
#define gp_debug1(s,a) DB(printf(s,a) ; fflush(stdout))
#define gp_debug2(s,a,b) DB(printf(s,a,b) ; fflush(stdout))
......@@ -130,7 +130,7 @@ scm_t_bits gp_smob_t;
#define GP_EQ(ref) ( SCM_UNPACK(GP_FLAGS(ref)) & GPI_EQ)
#define GP_ATTR(ref) ( SCM_UNPACK(GP_FLAGS(ref)) & GPI_ATTR)
#define GP_THREAD(x) (SCM_UNPACK(x) | GPI_THREAD)
#define GP_THREAD(x) (SCM_UNPACK(x) & GPI_THREAD)
#define GP_MK_FRAME_VAL(fr) ((fr) | GPI_VAL)
#define GP_MK_FRAME_PTR(fr) ((fr) | GPI_PTR)
......@@ -184,17 +184,21 @@ SCM gp_cons_str;
static inline void gp_store_var_2(SCM *id, int simple, struct gp_stack *gp)
{
GP_TEST_CSTACK;
if(!GP(GP_UNREF(id)))
scm_misc_error("gp_store_var_2"," got non gp variable to set",SCM_EOL);
if(simple || GP_UNBOUND(id))
{
*gp->gp_ci = GP_UNREF(id);
*(gp->gp_ci) = GP_UNREF(id);
}
else
{
*gp->gp_ci = scm_cons(GP_UNREF(id), scm_cons(SCM_I_MAKINUM(id[0]),
id[1]));
*(gp->gp_ci) = scm_cons(GP_UNREF(id), scm_cons(SCM_I_MAKINUM(id[0]),
id[1]));
}
gp_debug1("stored> %x\n",SCM_UNPACK(gp->gp_ci[0]));
gp->gp_ci += 1;
}
......@@ -211,19 +215,29 @@ static inline SCM handle(SCM *id, SCM flags, SCM v, SCM s, int k, int bang)
struct gp_stack *gp = get_gp(s);
if(!GP(GP_UNREF(id)))
scm_misc_error("unify.c: handle"," got non gp variable to set",SCM_EOL);
if(gp->_logical_) return logical_add(GP_UNREF(id),v,s);
if(GP_THREAD(SCM_PACK(id)))
if(GP_THREAD(id[0]))
{
gp_debug1("id0 = %x\n",SCM_UNPACK(id[0]));
gp_debug0("got a thraed variable to set!\n");
id = id + gp->thread_id * 2;
}
if(GP_ID(*id) != gp->id)
return logical_add(GP_UNREF(id),v,s);
{
gp_debug0("logical add\n");
return logical_add(GP_UNREF(id),v,s);
}
store:
gp_debug1("set var... bang!(%d)",bang);
if(!bang) gp_store_var_2(id,k,gp);
mask_on(gp->id,id,flags);
......@@ -960,7 +974,7 @@ SCM_DEFINE(gp_clear, "gp-clear", 1, 0, 0, (SCM s),
gp_debug0("clear\n");
gp->_logical_ = 0;
gp->gp_ci_h = (SCM *) 0;
gp_unwind0(gp->gp_cstack + 1,gp->gp_stack, gp);
gp_unwind0(gp->gp_cstack + 1,gp->gp_stack + 2, gp);
return SCM_BOOL_T;
}
#undef FUNC_NAME
......@@ -1046,7 +1060,7 @@ SCM_DEFINE(gp_set_stack, "gp-stack-set!", 3, 0, 0, (SCM var, SCM val, SCM s),
gp->_logical_ = 0;
ggp_set(var,val,s);
gp->_logical_ = old;
return SCM_UNDEFINED;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
......@@ -1065,6 +1079,27 @@ SCM_DEFINE(gp_print, "gp-print", 1, 0, 0, (SCM pr),
}
#undef FUNC_NAME
SCM_DEFINE(gp_print_stack, "gp-print-stack", 1, 0, 0, (SCM s),
"print info about supplied gp stack")
#define FUNC_NAME s_gp_print
{
SCM *i;
struct gp_stack *gp = get_gp(s);
printf("\nci: %d\nsi: %d\nlogical: %d\n",gp->gp_ci - gp->gp_cstack
,gp->gp_si - gp->gp_stack,gp->_logical_);
for(i = gp->gp_cstack; i < gp->gp_ci; i++)
{
printf("%d c %x\n",i - gp->gp_cstack,SCM_UNPACK(*i));
}
for(i = gp->gp_stack; i < gp->gp_si; i++)
{
printf("%d v %x\n",i - gp->gp_stack,SCM_UNPACK(*i));
}
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE(gp_ref_set, "gp-ref-set!", 3, 0, 0, (SCM var, SCM val, SCM s),
"set gp var reference to val")
#define FUNC_NAME s_gp_ref_set
......@@ -1396,8 +1431,8 @@ SCM_DEFINE(gp_dynwind, "gp-dynwind", 3, 0, 0, (SCM in, SCM out, SCM s),
#define FUNC_NAME s_gp_dynwind
{
SCM *id;
gp_debug0("dynwind...");
struct gp_stack *gp = get_gp(s);
gp->gp_ci[0] = scm_cons(in,out);
gp->gp_ci ++;
return SCM_UNSPECIFIED;
......@@ -1409,6 +1444,7 @@ SCM_DEFINE(gp_make_stack, "gp-make-stack", 4, 0, 0,
"make logical stack for id, thread_id, and sizes nc, ns")
#define FUNC_NAME s_gp_make_stack
{
SCM s;
struct gp_stack *gp;
if(!SCM_I_INUMP(id)) goto error2;
if(!SCM_I_INUMP(thread_id)) goto error2;
......@@ -1423,11 +1459,19 @@ SCM_DEFINE(gp_make_stack, "gp-make-stack", 4, 0, 0,
SCM* sgp = make_gp_stack(i_id,i_thread_id, i_nc, i_ns, &gp);
if(!sgp) goto error;
return scm_cons(GP_UNREF(sgp),
scm_cons(scm_cons(PTR2NUM(gp->gp_ci),
PTR2NUM(gp->gp_si))
,SCM_EOL));
s = scm_cons(GP_UNREF(sgp),
scm_cons(scm_cons(PTR2NUM(gp->gp_ci),
PTR2NUM(gp->gp_si))
,SCM_EOL));
SCM v = GP_IT(gp_mk_var(s));
gp_set(v,SCM_BOOL_F,s);
return s;
error:
scm_misc_error("gp-make-stack","could not allocate stacks",SCM_EOL);
return SCM_UNSPECIFIED;
......
......@@ -30,7 +30,7 @@
gp-budy gp-swap-to-a gp-swap-to-b gp-m-unify!
gp-lookup
gp-var? gp-cons! gp-set!
gp-printer gp-var-number
gp-printer gp-var-number gp-print-stack
gp-car gp-cdr gp-pair?
gp-store-state gp-restore-state gp-restore-wind
gp-make-fluid gp-fluid-set! gp-fluid-ref with-gp-fluids
......
......@@ -25,7 +25,7 @@
(syntax-rules ()
((_ title x y)
(begin
(gp-clear)
(gp-clear *current-stack*)
(with-test-prefix "start"
(pass-if (format #f "~a" 'x)
(equal? x y)))))))
......
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