Commit 66e8ca94 authored by Stefan Israelsson Tampe's avatar Stefan Israelsson Tampe

a

Merge branch 'master' of gitorious.org:gule-log/guile-log
parents 73418491 99d45596
......@@ -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*))))
......
#include <pthread.h>
int gp_gc_p = 0;
pthread_mutex_t gp_gc_lock = PTHREAD_MUTEX_INITIALIZER;
void gp_no_gc()
{
pthread_mutex_lock(&gp_gc_lock);
gp_gc_p ++;
pthread_mutex_unlock(&gp_gc_lock);
}
void gp_do_gc()
{
pthread_mutex_lock(&gp_gc_lock);
gp_gc_p --;
pthread_mutex_unlock(&gp_gc_lock);
}
void *gp_after_mark_hook(void *hook_data, void *fn_data, void *data)
{
SCM pt = scm_fluid_ref(gp_stacks);
pthread_mutex_lock(&gp_gc_lock);
if(gp_gc_p)
{
pthread_mutex_unlock(&gp_gc_lock);
return (void *)0;
}
while(SCM_CONSP(pt))
{
gp_sweep_handle(SCM_CAR(pt));
pt = SCM_CDR(pt);
}
pthread_mutex_unlock(&gp_gc_lock);
return (void *)0;
}
void init_gpgc()
{
const int appendp = 0;
void *data = (void *) 0;
scm_c_hook_add(&scm_after_gc_c_hook, gp_after_mark_hook, data, appendp);
}
This diff is collapsed.
......@@ -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;
......@@ -903,7 +884,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)));
}
......@@ -936,6 +917,7 @@ static inline SCM * gp_get_branch(SCM *p, SCM *ci, struct gp_stack *gp)
if(pp == d)
{
gp_debug0("found it\n");
*p = pp;
return ci;
}
......@@ -952,17 +934,17 @@ static inline SCM * gp_get_branch(SCM *p, SCM *ci, struct gp_stack *gp)
if(SCM_CONSP(pp))
{
gp_debug0("next\n");
pp = SCM_CDR(pp);
}
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)));
}
if(SCM_CONSP(d))
{
{
d = SCM_CDR(d);
}
else
......@@ -1043,12 +1025,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)));
......@@ -1070,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");
......@@ -1147,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;
......@@ -1217,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)));
}
}
......@@ -1237,7 +1206,7 @@ static void gp_restore_state(SCM data, struct gp_stack *gp, SCM K)
{
if(SCM_UNPACK(SCM_CAR(*ci)) == gp_save_tag)
{
if(pp_x != *ci)
if(pp_x != *ci)
fail = 1;
}
else if(SCM_UNPACK(SCM_CAR(*ci)) == gp_redo_tag)
......@@ -1254,12 +1223,14 @@ 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)
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));
{
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
......
......@@ -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