Just a spurious error remains

parent c56b1b6a
......@@ -338,8 +338,39 @@ static void gp_double_cons_stack(struct gp_stack *gp)
}
*/
static SCM gp_stack_mark(SCM obj)
{
inline int gp_at_newframe(SCM *pt)
{
SCM val = *pt;
retry:
if(SCM_I_INUMP(val) && SCM_I_INUMP(*(pt - 1)) && SCM_I_INUMP(*(pt - 2)))
{
return 1;
}
if(SCM_CONSP(val))
{
SCM tag = SCM_CAR(val);
if(SCM_I_INUMP(tag))
{
if(SCM_UNPACK(tag) == gp_save_tag)
{
val = SCM_CDR(val);
}
else
{
val = SCM_CDDR(val);
}
goto retry;
}
}
return 0;
}
static SCM gp_stack_mark0(SCM obj, int unlocked)
{
struct gp_stack *gp = (struct gp_stack *) SCM_SMOB_DATA(obj);
int i;
......@@ -349,11 +380,47 @@ static SCM gp_stack_mark(SCM obj)
scm_gc_mark(GP_UNREF(gp->gp_stack));
scm_gc_mark(GP_UNREF(gp->gp_cons_stack));
scm_gc_mark(gp->gp_cstack[0]);
scm_gc_mark(gp->gp_cstack[1]);
scm_gc_mark(gp->gp_cstack[2]);
scm_gc_mark(gp->gp_cstack[3]);
for(i=0;i < gp->gp_ci - gp->gp_cstack; i++)
{
SCM *pt = gp->gp_cstack + i;
if(*pt && SCM_CONSP(*pt))
scm_gc_mark(*pt);
if(*pt)
{
if(GP(*pt))
{
if(unlocked && i >= 4)
{
scm_t_bits head = SCM_UNPACK(GP_GETREF(*pt)[0]);
GP_GC_CAND(head);
GP_GETREF(*pt)[0] = SCM_PACK(head);
gp_gc_mark_no_touch(*pt);
}
else
scm_gc_mark(*pt);
}
else if(gp_at_newframe(pt))
{
SCM *f = get_ci_f(pt + 1);
scm_t_bits head = SCM_UNPACK(f[0]);
if(unlocked && i >= 4)
{
GP_GC_CAND(head);
f[0] = SCM_PACK(head);
gp_gc_mark_no_touch(GP_UNREF(f));
}
else
scm_gc_mark(GP_UNREF(f));
if(SCM_CONSP(*pt))
scm_gc_mark(*pt);
}
else
scm_gc_mark(*pt);
}
}
for(i=0;i < gp->gp_si - gp->gp_stack; i++)
......@@ -361,10 +428,15 @@ static SCM gp_stack_mark(SCM obj)
SCM *pt = gp->gp_stack + i;
if(GP(*pt))
{
scm_t_bits head = SCM_UNPACK(GP_GETREF(*pt)[0]);
GP_GC_CAND(head);
GP_GETREF(*pt)[0] = SCM_PACK(head);
gp_gc_mark_no_touch(*pt);
if(unlocked)
{
scm_t_bits head = SCM_UNPACK(GP_GETREF(*pt)[0]);
GP_GC_CAND(head);
GP_GETREF(*pt)[0] = SCM_PACK(head);
gp_gc_mark_no_touch(*pt);
}
else
scm_gc_mark(*pt);
}
}
......@@ -393,13 +465,6 @@ static int gp_stack_printer(SCM x, SCM port, scm_print_state *spec)
return 0;
}
static void gp_module_stack_init()
{
gp_stack_type = scm_make_smob_type("unify-stacks",0);
scm_set_smob_mark(gp_stack_type, gp_stack_mark);
scm_set_smob_print(gp_stack_type,gp_stack_printer);
}
static inline void gp_alloc_cons(struct gp_stack *gp, int n)
{
int i;
......@@ -494,38 +559,10 @@ SCM_DEFINE(gp_make_stack, "gp-make-stack", 5, 0, 0,
}
#undef FUNC_NAME
inline int gp_at_newframe(SCM *pt)
{
SCM val = *pt;
retry:
if(SCM_I_INUMP(val) && SCM_I_INUMP(*(pt - 1)) && SCM_I_INUMP(*(pt - 2)))
{
return 1;
}
if(SCM_CONSP(val))
{
SCM tag = SCM_CAR(val);
if(SCM_I_INUMP(tag))
{
if(SCM_UNPACK(tag) == gp_save_tag)
{
val = SCM_CDR(val);
}
else
{
val = SCM_CDDR(val);
}
goto retry;
}
}
return 0;
}
static inline int is_advanced_tag(SCM *pt);
void gp_sweep_handle(SCM in)
{
struct gp_stack *gp = (struct gp_stack *) SCM_SMOB_DATA(in);
......@@ -561,16 +598,12 @@ void gp_sweep_handle(SCM in)
// Stop when we find the first newframe mark in the control stack
if(gp_at_newframe(pt))
{
{
SCM *f = get_ci_f(pt + 1);
scm_t_bits head = SCM_UNPACK(f[0]);
n += 3;
if(SCM_CONSP(pt[-1]) ||
SCM_CONSP(pt[-2]) ||
SCM_CONSP(pt[-3]))
printf("Got a stupid cons\n");
if(SCM_I_INUMP(*pt) &&
if(SCM_I_INUMP(*pt) && SCM_I_INUMP(pt[-1]) &&
!GP_GC_ISMARKED(head) && GP_GC_ISCAND(head))
{
nrem += 4;
......@@ -589,52 +622,28 @@ void gp_sweep_handle(SCM in)
int vn = 0;
int vrem = 0;
for(pt = gp->gp_stack; pt < gp->gp_si; pt++)
{
vn++;
if(GP(*pt))
{
SCM *f = GP_GETREF(*pt);
scm_t_bits head = SCM_UNPACK(f[0]);
if(!GP_GC_ISMARKED(head) && GP_GC_ISCAND(head))
{
vrem++;
f[0] = SCM_PACK(GP_MK_FRAME_UNBD(gp_type)
| GPI_SCM_C | GPI_SCM_Q);
f[1] = SCM_UNBOUND;
}
else
{
GP_GC_CLEAR(head);
GP_GC_CLEARCAND(head);
f[0] = SCM_PACK(head);
}
}
}
//Trigger cleanup code
if(vn > 100 && vrem*2 - vn > nrem * 2 - n)
{
nrem = vrem;
n = vn;
}
if(!(n > 100 && nrem*2 - n > 0))
{
printf("clear marks\n");
for(pt = gp->gp_stack; pt < gp->gp_nns; pt++)
vn++;
if(GP(*pt))
{
if(GP(*pt))
SCM *f = GP_GETREF(*pt);
scm_t_bits head = SCM_UNPACK(f[0]);
if(!(!GP_GC_ISMARKED(head) && GP_GC_ISCAND(head)))
{
SCM *f = GP_GETREF(*pt);
scm_t_bits head = SCM_UNPACK(f[0]);
GP_GC_CLEAR(head);
GP_GC_CLEARCAND(head);
f[0] = SCM_PACK(head);
}
}
}
//Trigger cleanup code
if(vn > 100 && vrem*2 - vn > nrem * 2 - n)
{
nrem = vrem;
n = vn;
}
printf("sweep2 %d %d\n",vn,vrem);
}
......@@ -658,6 +667,37 @@ void gp_sweep_handle(SCM in)
#include "gc.c"
static SCM gp_stack_mark(SCM obj)
{
SCM pt = scm_fluid_ref(gp_stacks);
SCM ret = SCM_BOOL_F;
pthread_mutex_lock(&gp_gc_lock);
if(gp_gc_p)
{
ret = gp_stack_mark0(obj,0);
pthread_mutex_unlock(&gp_gc_lock);
return ret;
}
while(SCM_CONSP(pt))
{
ret = gp_stack_mark0(obj,1);
pt = SCM_CDR(pt);
}
pthread_mutex_unlock(&gp_gc_lock);
return ret;
}
static void gp_module_stack_init()
{
gp_stack_type = scm_make_smob_type("unify-stacks",0);
scm_set_smob_mark(gp_stack_type, gp_stack_mark);
scm_set_smob_print(gp_stack_type,gp_stack_printer);
}
void gp_init_stacks()
{
gp_stacks = scm_make_fluid_with_default(SCM_EOL);
......@@ -673,8 +713,7 @@ SCM_DEFINE(gp_gc, "gp-gc", 0, 0, 0, (), "clean up the stack")
int mute = 0;
struct gp_stack *gp = get_gp();
gp_no_gc();
if(gp->n > 100 && gp->nrem*2 > gp->n)
if(gp->n > 100 && gp->nrem*4 > gp->n)
{
printf("gc: %d %d\n",gp->n, gp->nrem);
SCM *pt1,*pt2, *pt1_insert, *pt2_insert, *last_redo = gp->gp_cstack,
......@@ -776,7 +815,7 @@ SCM_DEFINE(gp_gc, "gp-gc", 0, 0, 0, (), "clean up the stack")
#define macro \
while(pt2 < si) \
{ \
if(scm_is_false(*pt2)) \
if(!mute && scm_is_false(*pt2)) \
{ \
pt2++; \
continue; \
......@@ -788,8 +827,16 @@ SCM_DEFINE(gp_gc, "gp-gc", 0, 0, 0, (), "clean up the stack")
scm_t_bits head = SCM_UNPACK(f[0]); \
if(!GP_GC_ISMARKED(head) && GP_GC_ISCAND(head)) \
{ \
pt2++; \
continue; \
if(mute) \
{ \
*pt2 = SCM_BOOL_F; \
} \
else \
{ \
f[1] = SCM_UNBOUND; \
pt2++; \
continue; \
} \
} \
} \
\
......
......@@ -271,13 +271,13 @@ static inline void gp_unwind0(SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp)
DB(printf("unwind> %x %x\n",ci - gp->gp_cstack, gp->gp_ci - gp->gp_cstack);fflush(stdout));
if(gp->gp_ci < ci || gp->gp_si < si)
if(gp->gp_ci < ci)
{
scm_misc_error("gp_unwind","wrong unwind forward in time",SCM_EOL);
}
ci_old = gp->gp_ci;
//si_old = gp->gp_si;
if(si > gp->gp_si) si = gp->gp_si;
#define MASK_OFF() \
if(state) \
......@@ -332,9 +332,17 @@ static inline void gp_unwind0(SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp)
{
if(state == gp_redo)
old = SCM_CDR(old);
if(state == gp_store)
{
SCM val = scm_cons(SCM_BOOL_F, SCM_EOL);
if(SCM_CONSP(old))
SCM_SETCDR(old,val);
old = val;
}
continue;
}
if(!GP(*i))
{
// ------------------- Code for stack pointers -----------------
......@@ -346,7 +354,9 @@ static inline void gp_unwind0(SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp)
{
gp_debug0("unwind 2 ints\n");
SCM *cs2 = get_cs_only(i, gp);
SCM *cs2, *si2;
get_cs_si(i + 1, &cs2, &si2, gp);
if(si2 < si) si = si2;
if(cs2 < cs) cs = cs2;
MASK_OFF();
......@@ -481,11 +491,6 @@ static inline void gp_unwind0(SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp)
if(scm_is_eq(*i,SCM_BOOL_T))
{
*i = SCM_BOOL_F;
if(!si_store)
{
if(si > gp->gp_stack)
si --;
}
si_store = 1;
continue;
}
......@@ -493,38 +498,14 @@ static inline void gp_unwind0(SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp)
}
gp_debug1("finishing si %x\n",gp->gp_si - si);
if(si < gp->gp_si)
if(si_store)
{
if(scm_is_eq(*i,SCM_BOOL_T))
{
*i = SCM_BOOL_F;
si_store = 1;
}
if(si_store)
{
// mark the stack (#t) as storing and save new stack position
if(si > gp->gp_stack && si[-1] == SCM_BOOL_T)
gp->gp_si = si;
else
{
if(GP(*si))
{
SCM *v = GP_GETREF(*si);
scm_t_bits head = SCM_UNPACK(v[0]);
GP_GC_CLEARQAND(head);
v[0] = SCM_PACK(head);
}
*si = SCM_BOOL_F;
gp->gp_si = si + 1;
}
}
else
gp->gp_si = si;
*si = SCM_BOOL_T;
gp->gp_si = si + 1;
}
else
gp->gp_si = si;
//cs part
int cs_store = 0;
......@@ -846,7 +827,7 @@ SCM_DEFINE(gp_gp_store_state, "gp-store-state", 1, 0, 0, (SCM s),
}
#undef FUNC_NAME
#define DB(X) X
//#define DB(X) X
static inline SCM * gp_get_branch(SCM *p, SCM *ci, struct gp_stack *gp)
{
......@@ -1066,6 +1047,13 @@ static int gp_rewind(SCM pp, SCM pend, struct gp_stack *gp)
sp--;
}
else if(scm_is_eq(q, SCM_BOOL_F))
{
gp->gp_ci[0] = q;
gp->gp_ci ++;
sp--;
}
else
{
gp_debug0("stack ref\n");
......@@ -1143,23 +1131,6 @@ static void gp_restore_state(SCM data, struct gp_stack *gp, SCM K)
scm_t_bits nfini = n;
gp_debug0("prepare si state\n");
if(si > gp->gp_si)
{
SCM *s;
for(s = gp->gp_si; s < si; s += 1)
{
if(scm_is_true(*s))
{
SCM *x = GP_GETREF(*s);
x[0] = gp_unbd;
x[1] = SCM_UNBOUND;
}
}
gp->gp_si = si;
}
gp_debug0("make paths equal length\n");
ci_x = gp->gp_ci - 1;
pp_x = path;
......@@ -1213,7 +1184,9 @@ static void gp_restore_state(SCM data, struct gp_stack *gp, SCM K)
pp_x = SCM_CDR(pp_x);
else
scm_misc_error("gp-restore-state",
"encountered a non cons as a pp_x",SCM_EOL);
"encountered a non cons as a pp_x ~a ~a > ~a"
,scm_list_3(pp_x,
SCM_I_MAKINUM(n), SCM_I_MAKINUM(m)));
}
}
......@@ -1250,7 +1223,7 @@ static void gp_restore_state(SCM data, struct gp_stack *gp, SCM K)
fail = 5;
}
else
if(SCM_CAR(pp_x) != *ci)
if(0 && SCM_CAR(pp_x) != *ci)
fail = 3;
if(fail)
......@@ -1293,7 +1266,7 @@ static void gp_restore_state(SCM data, struct gp_stack *gp, SCM K)
gp_debug0("leave reinstate\n");
}
#define DB(X)
//#define DB(X)
SCM_DEFINE(gp_gp_restore_state, "gp-restore-state", 2, 0, 0, (SCM cont, SCM K),
"restore a continuation point")
......
......@@ -1473,8 +1473,7 @@
(<run> 34 (t)
(<var> (x y r)
(*o x y r)
(<=> (x y r) t)
(<pp> t)))
(<=> (x y r) t)))
'((() v0 ())
((v0 . v1) () ())
((1) (v0 . v1) (v0 . v1))
......
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