Skip to content

G
Guile Log
Commit 07610add authored by Stefan Israelsson Tampe's avatar Stefan Israelsson Tampe
Browse files
Options

Cons fixed attributed variables is strated to be coded

parent 1d79f358
Hide whitespace changes
Inline Side-by-side
Showing with 159 additions and 92 deletions
logic/guile-log/src/Makefile
View file @ 07610add
......@@ -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
......
logic/guile-log/src/state.c
View file @ 07610add
......@@ -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;
......
logic/guile-log/src/unify-undo-redo.c
View file @ 07610add
......@@ -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--)
......
logic/guile-log/src/unify.c
View file @ 07610add
......@@ -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();
......
logic/guile-log/src/variable.c
View file @ 07610add
......@@ -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