missing tr in kanren implemented + GL mem fixes

parent 6794ff0b
......@@ -50,6 +50,31 @@
(define sfail fail)
(define var? gp-logical-var?)
(define (tr a b s)
(define m (make-hash-table))
(define i 0)
(let lp ((x (gp->scm b s)))
(cond
((pair? x)
(cons (lp (car x)) (lp (cdr x))))
((vector? x)
(list->vector
(lp (vector->list x))))
((gp-var? x s)
(let ((v (hash-ref m x #f)))
(if v
v
(let ((v (string->symbol
(format #f "~a~a" a i))))
(hash-set! m x v)
(set! i (+ i 1))
v))))
(else
x))))
(define reify (lambda (x)
(tr 'v. x (fluid-ref *current-stack*))))
......
......@@ -40,6 +40,7 @@ struct gp_stack
int n;
int nrem;
};
#define GP_TEST_CSTACK if(gp->gp_ci > gp->gp_nnc) scm_out_of_range(NULL, SCM_I_MAKINUM(gp->gp_nc))
#define GP_TEST_STACK if(gp->gp_si > gp->gp_nns) scm_out_of_range(NULL, SCM_I_MAKINUM(gp->gp_ns))
......@@ -564,7 +565,13 @@ void gp_sweep_handle(SCM in)
SCM *f = get_ci_f(pt + 1);
scm_t_bits head = SCM_UNPACK(f[0]);
n += 3;
if(SCM_I_INUMP(*pt) && !GP_GC_ISMARKED(head) && GP_GC_ISCAND(head))
if(SCM_CONSP(pt[-1]) ||
SCM_CONSP(pt[-2]) ||
SCM_CONSP(pt[-3]))
printf("Got a stupid cons\n");
if(SCM_I_INUMP(*pt) &&
!GP_GC_ISMARKED(head) && GP_GC_ISCAND(head))
{
nrem += 4;
pt[0] = SCM_BOOL_F;
......@@ -649,6 +656,8 @@ void gp_sweep_handle(SCM in)
gp->nrem = nrem;
}
#include "gc.c"
void gp_init_stacks()
{
gp_stacks = scm_make_fluid_with_default(SCM_EOL);
......@@ -657,8 +666,6 @@ void gp_init_stacks()
}
#include "gc.c"
SCM_DEFINE(gp_gc, "gp-gc", 0, 0, 0, (), "clean up the stack")
#define FUNC_NAME s_gp_gc
{
......@@ -670,7 +677,9 @@ SCM_DEFINE(gp_gc, "gp-gc", 0, 0, 0, (), "clean up the stack")
if(gp->n > 100 && gp->nrem*2 > gp->n)
{
printf("gc: %d %d\n",gp->n, gp->nrem);
SCM *pt1,*pt2, *pt1_insert, *pt2_insert, *last_redo = gp->gp_cstack;
SCM *pt1,*pt2, *pt1_insert, *pt2_insert, *last_redo = gp->gp_cstack,
*last_save = gp->gp_cstack;
for(pt1 = gp->gp_ci - 1; pt1 >= gp->gp_cstack; pt1--)
{
......@@ -685,6 +694,20 @@ SCM_DEFINE(gp_gc, "gp-gc", 0, 0, 0, (), "clean up the stack")
}
}
for(pt1 = gp->gp_ci - 1; pt1 >= gp->gp_cstack; pt1--)
{
if(SCM_CONSP(*pt1))
{
SCM tag = SCM_CAR(*pt1);
if(SCM_I_INUMP(tag) && SCM_UNPACK(tag) == gp_save_tag)
{
last_save = pt1;
break;
}
}
}
pt1 = gp->gp_cstack + 4;
pt2 = gp->gp_stack;
pt1_insert = pt1;
......@@ -692,6 +715,7 @@ SCM_DEFINE(gp_gc, "gp-gc", 0, 0, 0, (), "clean up the stack")
while(pt1 < gp->gp_ci)
{
/*
if(SCM_CONSP(*pt1))
{
SCM tag = SCM_CAR(*pt1);
......@@ -713,7 +737,12 @@ SCM_DEFINE(gp_gc, "gp-gc", 0, 0, 0, (), "clean up the stack")
}
}
}
*/
if(pt1 < last_save || pt1 < last_redo)
mute = 1;
else
mute = 0;
//Sections that start with a save tag and ends with
if(!mute)
if(scm_is_false(*pt1))
......
......@@ -903,7 +903,7 @@ static inline SCM * gp_get_branch(SCM *p, SCM *ci, struct gp_stack *gp)
}
else
{
scm_misc_error ("gp_get_branch", "not a pair or '() pp ~a n ~a",
scm_misc_error ("gp_get_branch", "(1) not a pair or '() pp ~a n ~a",
scm_list_2 (pp, SCM_I_MAKINUM(i)));
}
......@@ -956,7 +956,7 @@ static inline SCM * gp_get_branch(SCM *p, SCM *ci, struct gp_stack *gp)
}
else
{
scm_misc_error ("gp_get_branch", "pp not a pair or '() pp ~a n ~a",
scm_misc_error ("gp_get_branch", "(2) pp not a pair or '() pp ~a n ~a",
scm_list_2 (pp, SCM_I_MAKINUM(i)));
}
......@@ -1043,12 +1043,7 @@ static int gp_rewind(SCM pp, SCM pend, struct gp_stack *gp)
gp_debug0("gp\n");
id = GP_GETREF(SCM_CAR(q));
q = SCM_CDR(q);
if(id[1] != SCM_UNBOUND &&
id >= gp->gp_stack &&
id < gp->gp_stack + 100000)
scm_misc_error("gp_rewind","non cleared mem",SCM_EOL);
gp_store_var_2(id,1,gp);
id[0] = SCM_PACK(SCM_I_INUM(SCM_CAR(q)));
......@@ -1258,8 +1253,13 @@ static void gp_restore_state(SCM data, struct gp_stack *gp, SCM K)
fail = 3;
if(fail)
scm_misc_error("gp_restore_state","branch point is wrong ~a ci ~a ~a ~a",
scm_list_4(SCM_I_MAKINUM(fail), *ci, pp_x, path));
{
#define DB(X) X
gp_format1("pp_x: ~a",pp_x);
#define DB(X)
scm_misc_error("gp_restore_state","branch point is wrong ~a ci ~a ~a ~a",
scm_list_4(SCM_I_MAKINUM(fail), *ci, pp_x, path));
}
// We search for the nearest stack information
......
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