subtle memore gc problem fixed + various other fixes

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