Cons fixed attributed variables is strated to be coded

parent 1d79f358
......@@ -257,7 +257,7 @@ mandir = ${datarootdir}/man
mkdir_p = /bin/mkdir -p
oldincludedir = /usr/include
pdfdir = ${docdir}
prefix = /usr/local
prefix = /usr
program_transform_name = s,x,x,
psdir = ${docdir}
sbindir = ${exec_prefix}/sbin
......
......@@ -50,6 +50,8 @@ struct gp_stack
#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_CCSTACK if(gp->gp_cs > gp->gp_nncs) scm_out_of_range(NULL, SCM_I_MAKINUM(gp->gp_ncs))
#define GP_TEST_STACK if(gp->gp_si > gp->gp_nns) scm_out_of_range(NULL, SCM_I_MAKINUM(gp->gp_ns))
#define GET_GP(scm) ((struct gp_stack *) GP_GETREF(scm)[1])
......@@ -66,7 +68,7 @@ static inline struct gp_stack *get_gp()
static inline void init_gp_var(SCM *cand)
{
cand[0] = SCM_PACK(GP_MK_FRAME_EQ(gp_type));
cand[0] = SCM_PACK(GP_MK_FRAME_UNBD(gp_type));
cand[1] = SCM_UNBOUND;
}
......@@ -85,34 +87,44 @@ static inline SCM *get_gp_var(struct gp_stack *gp)
return GP_GETREF(cand);
}
static inline init_gp_cons(SCM *cand, struct gp_stack *gp)
static inline void init_gp_cons(SCM *cand)
{
gp_debug0("init_gp_cons\n");
if(!GP_CONS(cand))
cand[0] = SCM_PACK(GP_MK_FRAME_CONS(gp_type));
{
gp_debug0("get_gp_cons no cons\n");
cand[0] = SCM_PACK(GP_MK_FRAME_CONS(gp_type));
}
SCM car = cand[1];
if(GP(car))
{
if(!(GP_VAR(car)))
gp_debug0("get_gp_cons gp(car)\n");
if(!(GP_UNBOUND(GP_GETREF(car))))
{
gp_debug0("get_gp_cons car not unbound\n");
init_gp_var(GP_GETREF(car));
}
}
else
{
gp_debug0("get_gp_cons car bound\n");
cand[1] = gp_make_variable();
}
SCM cdr = cand[2];
if(GP(cdr))
{
if(!(GP_VAR(cdr)))
gp_debug0("get_gp_cons GP(cdr)\n");
if(!(GP_UNBOUND(GP_GETREF(cdr))))
{
gp_debug0("get_gp_cons cdr not unbound\n");
init_gp_var(GP_GETREF(cdr));
}
}
else
{
gp_debug0("get_gp_cons cdr unbound\n");
cand[2] = gp_make_variable();
}
}
......@@ -120,7 +132,8 @@ static inline init_gp_cons(SCM *cand, struct gp_stack *gp)
static inline SCM *get_gp_cons(struct gp_stack *gp)
{
SCM cand;
GP_TEST_STACK;
gp_debug0("get_gp_cons\n");
GP_TEST_CCSTACK;
cand = *(gp->gp_cs);
if(scm_is_false(cand) || scm_is_eq(cand, SCM_BOOL_T))
{
......@@ -306,16 +319,13 @@ static inline SCM *make_gp_stack(int id, int nthread, int nc, int ns, int ncs, s
gp->n = 0;
SCM ret;
#ifdef HAS_GP_GC
ret = PTR2SCM (GC_generic_malloc (2 * sizeof (scm_t_cell),
gp_variable_gc_kind));
#else
ret = scm_new_smob(gp_stack_type, (scm_t_bits)0);
#endif
GP_GETREF(ret)[0] = SCM_PACK(gp_stack_type);
GP_GETREF(ret)[1] = GP_UNREF((SCM *) gp);
for(i = 0; i < gp->gp_ncs; i++)
{
gp->gp_cs[i] = SCM_BOOL_F;
......@@ -323,7 +333,18 @@ static inline SCM *make_gp_stack(int id, int nthread, int nc, int ns, int ncs, s
for(i = 0; i < gp->gp_ncs && i < 10000; i++)
{
gp->gp_cs[i] = scm_cons(SCM_BOOL_F,SCM_BOOL_F);
gp->gp_cs[i] = gp_make_cons(gp);
}
for(i = 0; i < gp->gp_ns; i++)
{
gp->gp_si[i] = SCM_BOOL_F;
}
for(i = 0; i < gp->gp_ns && i < 10000; i++)
{
gp->gp_si[i] = gp_make_variable(gp);
}
scm_gc_unprotect_object(GP_UNREF(gp->gp_cstack));
......@@ -696,7 +717,7 @@ void gp_clear_marks(SCM in, int isBefore)
struct gp_stack *gp = GET_GP(in);
SCM *pt;
//printf("clear\n");
// printf("clear\n");
// Search for the first newframe stored
for(pt = gp->gp_ci - 1; pt >= gp->gp_cstack + 4; pt--)
{
......@@ -878,12 +899,22 @@ void gp_sweep_handle(SCM in)
}
}
}
if(vn > 100 && vrem*2 - vn > nrem * 2 - n)
{
nrem = vrem;
n = vn;
}
vn = 0;
vrem = 0;
for(pt = gp->gp_cons_stack; pt < gp->gp_cs; pt++)
{
vn++;
if(GP(*pt))
{
SCM tc = SCM_PACK(GP_MK_FRAME_CONS(gp_type));
SCM *f = GP_GETREF(*pt);
scm_t_bits head = SCM_UNPACK(f[0]);
if(!GP_GC_ISMARKED(head) && GP_GC_ISCAND(head))
......@@ -899,13 +930,13 @@ void gp_sweep_handle(SCM in)
}
}
//Trigger cleanup code
if(vn > 100 && vrem*2 - vn > nrem * 2 - n)
{
nrem = vrem;
n = vn;
}
//printf("sweep2 %d %d\n",vn,vrem);
}
......@@ -923,17 +954,24 @@ struct GC_ms_entry *gp_stack_mark(SCM pt,
{
struct GC_ms_entry * ret;
pthread_mutex_lock(&gp_gc_lock);
if(gp_gc_p)
#ifdef HAS_GP_GC
{
ret = gp_stack_mark0(pt,0,ptr,limit);
pthread_mutex_lock(&gp_gc_lock);
if(gp_gc_p)
{
ret = gp_stack_mark0(pt,0,ptr,limit);
pthread_mutex_unlock(&gp_gc_lock);
return ret;
}
ret = gp_stack_mark0(pt,1,ptr,limit);
pthread_mutex_unlock(&gp_gc_lock);
return ret;
}
ret = gp_stack_mark0(pt,1,ptr,limit);
pthread_mutex_unlock(&gp_gc_lock);
#else
ret = gp_stack_mark0(pt,0,ptr,limit);
return ret;
#endif
}
static void gp_module_stack_init()
......@@ -955,7 +993,9 @@ SCM_DEFINE(gp_gc, "gp-gc", 0, 0, 0, (), "clean up the stack")
#ifdef HAS_GP_GC
int mute = 0;
struct gp_stack *gp = get_gp();
gp_no_gc();
pthread_mutex_lock(&gp_gc_lock);
if(!gp_gc_p)
{
//printf("gc0: %d %d\n",gp->n, gp->nrem);
if(gp->n > 100 && gp->nrem*4 > gp->n)
{
......@@ -1094,7 +1134,7 @@ SCM_DEFINE(gp_gc, "gp-gc", 0, 0, 0, (), "clean up the stack")
} \
\
} \
while(pt3 < si) \
while(pt3 < cs) \
{ \
if(!mute && scm_is_false(*pt3)) \
{ \
......@@ -1146,6 +1186,7 @@ SCM_DEFINE(gp_gc, "gp-gc", 0, 0, 0, (), "clean up the stack")
{
SCM *si=gp->gp_si;
SCM *cs=gp->gp_cs;
macro;
gp->gp_si = pt2_insert;
gp->gp_cs = pt3_insert;
......@@ -1157,7 +1198,8 @@ SCM_DEFINE(gp_gc, "gp-gc", 0, 0, 0, (), "clean up the stack")
gp->n = 0;
gp->nrem = 0;
gp_do_gc();
}
pthread_mutex_unlock(&gp_gc_lock);
#endif
return SCM_UNSPECIFIED;
......
......@@ -558,8 +558,8 @@ static inline void gp_unwind0(SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp)
else
gp->gp_cs = cs;
//*s part
int cs_store = 0;
/*s part
cs_store = 0;
gp_debug0("cs handling\n");
for(i = gp->gp_cs - 1; i >= cs; i--)
......
......@@ -20,7 +20,7 @@
#include<stdio.h>
#include "../../../config.h"
#include "unify.h"
#include "libguile/smob.h"
#define VECTOR_HEADER_SIZE 2
SCM tester = SCM_BOOL_F;
......@@ -218,8 +218,8 @@ scm_t_bits gp_smob_t;
#define PTR2NUM(x) SCM_PACK((((scm_t_bits) x) | 2))
#define NUM2PTR(x) ((SCM *) (SCM_UNPACK(x) & ~2))
#define GP_CAR(id) ((id) + 1)
#define GP_CDR(id) ((id) + 2)
#define GP_CAR(id) GP_GETREF((*((id) + 1)))
#define GP_CDR(id) GP_GETREF((*((id) + 2)))
#define GP_GETREF(x) ((SCM *) (x))
......@@ -825,8 +825,11 @@ static inline SCM gp_newframe(SCM s)
l = scm_is_false(l) ? SCM_EOL : l;
ci[-4] = gp->handlers;
ci[-3] = SCM_PACK (gp->dynstack_length);
gp_debug0("newframe 2\n");
f = set_ci(ci,gp);
gp_debug0("newframe 3\n");
set_cs_si(ci, gp);
gp_debug0("newframe4\n");
ret = scm_cons(GP_UNREF(f), l);
gp->gp_ci = ci;
gp_debug0("return\n");
......@@ -895,10 +898,9 @@ static inline SCM* gp_mk_var(SCM s)
static inline SCM gp_mk_cons(SCM s)
{
SCM *ret;
scm_t_bits fi;
struct gp_stack *gp;
gp = get_gp();
gp_debug0("gp_mk_cons\n");
if(gp->_logical_)
{
SCM x = make_logical();
......@@ -1362,6 +1364,54 @@ static SCM gp_unify(SCM *id1, SCM *id2, int raw, int gp_plus_unify, SCM *l, stru
// u11 Has unbounded variables
gp_debug0("unify> looked up with u11\n");
if(GP_ATTR(id1) && SCM_CONSP(id1[1]))
{
retry_attr:
{
SCM scm_raw, scm_plus;
if(raw)
scm_raw = SCM_BOOL_T;
else
scm_raw = SCM_BOOL_F;
if(gp_plus_unify)
scm_plus = SCM_BOOL_T;
else
scm_plus = SCM_BOOL_F;
SCM s = gp_make_s(ci,l);
SCM l = id1[1];
while(SCM_CONSP(l))
{
s =
scm_call_5(SCM_CAAR(l), SCM_CDAR(l),*id2, scmraw, scm_plus, s);
l = SCM_CDR(l);
}
if(scm_is_false(s))
return (SCM) 0;
{
SCM ll = SCM_CDR(s);
if(vlist_p(ll))
{
l[1] = GP_UNREF((SCM_I_VECTOR_WELTS(S(ll,0))));
l[2] = SCM_PACK(my_scm_to_int(S(ll,1)));
}
else
l[0] = ll;
}
}
}
else if (GP_ATTR(id2) && SCM_CONSP(id2[1]))
{
SCM *temp = id1;
id1 = id2;
id2 = temp;
goto retry_attr;
}
if(GP_UNBOUND(id1))
{
if(id1 == id2)
......@@ -2352,6 +2402,10 @@ SCM_DEFINE(gp_print_stack, "gp-print-stack", 1, 0, 0, (SCM s),
{
printf("%ld v %lx\n",i - gp->gp_stack,SCM_UNPACK(*i));
}
for(i = gp->gp_cons_stack; i < gp->gp_cs; i++)
{
printf("%ld v %lx\n",i - gp->gp_cons_stack,SCM_UNPACK(*i));
}
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
......@@ -2467,6 +2521,7 @@ SCM_DEFINE(gp_pair_bang, "gp-pair!?", 2, 0, 0, (SCM x, SCM s),
if(GP_UNBOUND(y))
{
SCM *cons = GP_GETREF(gp_mk_cons(s));
gp_debus0("gp-pair!?> unbd mk cons\n");
ret = gp_set_ref(y,GP_UNREF(cons),l,gp);
PACK_ALL(ci,l,ret,ggp,s);
return s;
......@@ -2891,31 +2946,6 @@ SCM gp_save_mark_sym;
#include "unify-undo-redo.c"
#ifndef GP_USE_GC_MOCK
static size_t gp_type_free(SCM obj)
{
SCM *v = GP_GETREF(obj);
scm_t_bits head = SCM_UNPACK(v[0]);
if(!GP_GC_ISQAND(head))
{
scm_gc_free(GP_GETREF(obj), 2*sizeof(SCM), "gp-variable-free");
}
return 0;
}
#endif
static SCM gp_type_mark(SCM obj)
{
SCM *v = GP_GETREF(obj);
scm_t_bits head = SCM_UNPACK(v[0]);
GP_GC_MARK(head);
v[0] = SCM_PACK(head);
scm_gc_mark(v[1]);
return SCM_BOOL_T;
}
SCM unify_env_smob;
scm_t_bits unify_env_smob_t;
......@@ -2946,10 +2976,10 @@ SCM_DEFINE(gp_make_fluid, "gp-make-var", 0, 0, 0, (),
{
SCM ret,l=SCM_BOOL_F;
struct gp_stack *gp = get_gp();
int old = gp->_logical_;
gp->_logical_ = 0;
ret = gp_make_variable();
//printf("%p %p\n", (SCM_UNPACK(*(GP_GETREF(ret)))), gp_type);fflush(stdout);
gp_set_unbound_bang(GP_GETREF(ret), l, gp);
gp->_logical_ = old;
return ret;
......@@ -3192,10 +3222,7 @@ void gp_init()
gp_type = scm_make_smob_type("unify-variable",0);
scm_set_smob_print(gp_type, gp_printer);
scm_set_smob_mark(gp_type, gp_type_mark);
#ifndef GP_USE_GC_MOCK
scm_set_smob_free(gp_type, gp_type_free);
#endif
gp_current_stack = scm_make_fluid();
gp_module_stack_init();
......
......@@ -3,7 +3,7 @@
/*
We need a special variable
*/
#ifdef HAS_GP_GC
static int gp_variable_gc_kind;
static struct GC_ms_entry *
......@@ -26,6 +26,7 @@ gp_mark_variable (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
else
{
SCM x = SCM_CELL_OBJECT_1 (cell);
#ifdef HAS_GP_GC
if(GP_GC_ISMARKED(SCM_UNPACK(SCM_CELL_OBJECT_0 (cell))));
{
mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (x),
......@@ -40,16 +41,28 @@ gp_mark_variable (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
}
}
}
#else
mark_stack_ptr = GC_MARK_AND_PUSH (SCM2PTR (x),
mark_stack_ptr,
mark_stack_limit, NULL);
if(GP_CONS(GP_GETREF(cell)))
{
mark_stack_ptr =
GC_MARK_AND_PUSH (SCM2PTR (SCM_CELL_OBJECT_2 (cell)),
mark_stack_ptr,
mark_stack_limit, NULL);
}
#endif
}
return mark_stack_ptr;
}
#endif
SCM gp_make_variable()
{
#ifdef HAS_GP_GC
gp_debug0("make variable\n");
SCM ret = PTR2SCM (GC_generic_malloc (2 * sizeof (scm_t_cell),
gp_variable_gc_kind));
SCM tc = SCM_PACK(GP_MK_FRAME_UNBD(gp_type));
......@@ -57,51 +70,36 @@ SCM gp_make_variable()
SCM_SET_CELL_WORD_0 (ret, tc);
return ret;
#else
SCM ret = scm_new_smob(gp_type, (scm_t_bits)0);
SCM *v = GP_GETREF(ret);
v[0] = SCM_PACK(GP_MK_FRAME_UNBD(gp_type));
v[1] = SCM_UNBOUND;
return ret;
#endif
}
SCM gp_make_cons()
{
gp_debug0("make cons\n");
SCM x1 = gp_make_variable();
SCM x2 = gp_make_variable();
#ifdef HAS_GP_GC
SCM ret = PTR2SCM (GC_generic_malloc (3 * sizeof (scm_t_cell),
gp_variable_gc_kind));
SCM tc = SCM_PACK(GP_MK_FRAME_CONS(gp_type));
SCM_SET_CELL_WORD_2 (ret, x1);
SCM_SET_CELL_WORD_1 (ret, x2);
SCM_SET_CELL_WORD_2 (ret, x2);
SCM_SET_CELL_WORD_1 (ret, x1);
SCM_SET_CELL_WORD_0 (ret, tc);
return ret;
#else
SCM ret = scm_new_double_smob(gp_type,
(scm_t_bits)0,
(scm_t_bits)0,
(scm_t_bits)0);
SCM *v = GP_GETREF(ret);
v[0] = SCM_PACK(GP_MK_FRAME_CONS(gp_type));
v[1] = x1;
v[2] = x2;
v[3] = SCM_UNBOUND;
return ret;
#endif
}
void init_variables()
{
#ifdef HAS_GP_GC
gp_variable_gc_kind
= GC_new_kind_adv (GC_new_free_list (),
GC_MAKE_PROC (GC_new_proc (gp_mark_variable), 0),
0,1,(GC_word) GPI_SCM_M);
#else
gp_variable_gc_kind
= GC_new_kind(GC_new_free_list (),
GC_MAKE_PROC (GC_new_proc (gp_mark_variable), 0),
0,1);
#endif
}
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