added multiple satck support, basic umatch tests successes

parent de409e5d
(define-module (logic guile-log collects)
#:use-module (logic guile-log)
#:use-module (logic guile-log umatch)
#:export (<collect> <collect-set!>))
(define (free-execute g)
(lambda (s p cc innerv)
(letg ((fail p)
(been '())
(w #f)
(ccc (lambda (ss pp inner-next)
(let ((val (freeze v)))
(if (member val been) (pp))
(set! v val)
(set! ccc (lambda (ss pp _)
(<=> w v)
(cc ss pp next)))
(set! next
(let ((s (gp-store-state)))
(lambda x
(gp-restore-state-wind s)
(gset! v (cons w been) #t inner-next next)
(pp))))))
(cc ss pp next)
(g s fail ccc)
......@@ -322,6 +322,4 @@ and-interleave
......@@ -301,63 +301,3 @@
%append
%member
;; Here is the zip function, zipping two functions together
(define (zip f (x g) (y h))
(define (make-cont p)
(let ((s (gp-store-state)))
(lambda ()
(gp-restore-state-wind s)
(p))))
(lambda (s p cc)
(glet ((g-cont #f) (h-cont h))
(with-logical
(let ((fr (gp-newframe fr)))
(g ss p
(lambda (ssg ppg)
(let ((cont #f))
(set! g-cont (lambda () (cont)))
(set! cont (make-cont ppg)))
(let ((xx (gp->scm x ssg)))
(gp-unwind fr)
(h-cont ss p
(lambda (ssh pph)
(let ((cont #f))
(set! h-cont (lambda (x y z) (cont)))
(set! cont (make-cont pph)))
(let ((yy (gp->scm y ssh)))
(gp-unwind fr)
(leave-logical
(<with-guile-log> (s g-cont cc)
(<and> (<=> x xx)
(<=> y yy)))))))))))))))
;; kanren zip
;; kanren bag-of including free variables
;; this can lead to an increase in computational complexity
;; any other kinds of tricks to accomplish anything cool?
;; a zip with wone function is especially call in that one can make
;; a problem is that applications are statedful , but we can store the
;; state and program as usuall
;; When we have multiple stacks we can do some trickety in order to stay
;; functional this means that we can implement copying functions and still
;; i'm 1, and i'm setting 2, let's hash it as an interpretation in stead
;; this way we can mix different stacks and actually keep them separate
;; without a need to store them, this means fast zipping so yeah multiple
;; stacks are pretty cool
;; One efficient hack is to make use of functional trees in order to reduce
;; lookup cost, to do this efficiently it would be nice to be able to store
;; the data in a functional lookup structure. it would be nice if all variables
;; had a hash value located on them. hmm, could be cool to use some kind of
;; 16 extra bit's on the smob! hmm it could also be a hash-key! cool!
;; We could find the base adress of the memory pool and use that as a reference
;; and be able to deduce if we are on different pools. then the extra smob bits
;; can be used as a hash structure.
;; hmm this is a really cool zipper, and is potentially very fast this also
;; can lead to efficient algorithms for multithreading applications.
\ No newline at end of file
......@@ -2,9 +2,9 @@ LIBS = `pkg-config --libs guile-2.0`
CFLAGS = `pkg-config --cflags guile-2.0`
libguile-unify.so : unify.h unify.c unify-undo-redo.c logical.c unify.x
libguile-unify.so : unify.h unify.c unify-undo-redo.c logical.c unify.x state.c functional-tree.c
gcc $(LIBS) $(CFLAGS) -shared -o libguile-unify.so -fPIC unify.c
unify.x : unify.h unify.c unify-undo-redo.c logical.c
unify.x : unify.h unify.c unify-undo-redo.c logical.c state.c functional-tree.c
guile-snarf -o unify.x $(CFLAGS) unify.c
......@@ -5,18 +5,17 @@ This define the logical variables
#include <stdlib.h>
#include "functional-tree.c"
int _logical_ = 0;
inline SCM get_gp_key(SCM *id)
{
if(GP_STAR(id))
return SCM_PACK(((SCM_UNPACK(id[0]) >> 20) & ~0x11) | 0x10);
return SCM_PACK(((SCM_UNPACK(id[0]) >> 4*9) & 0xfffc) | 0x10);
scm_misc_error("get_gp_key","not a gp variables as input",SCM_EOL);
return 0;
}
inline SCM make_logical()
SCM make_logical()
{
SCM ret,*id;
ret = SCM_NEWSMOB(ret,GP_MK_FRAME_UNBD(gp_type),
......@@ -24,7 +23,8 @@ inline SCM make_logical()
id = GP_GETREF(ret);
long k = random() << 20;
long k = random() << 9*4;
*(id + 0) = SCM_PACK(GP_MK_FRAME_UNBD(gp_type) | k);
*(id + 1) = SCM_UNBOUND;
return ret;
......@@ -151,28 +151,33 @@ SCM logical_add(SCM x, SCM v, SCM s)
return scm_cons(SCM_CAR(s),gp_tree_add(ss,hash,x,v));
}
*/
SCM ss = s;
s = SCM_CDR(s);
if(SCM_CONSP(s))
return scm_cons(SCM_CAR(s),scm_cons(scm_cons(x,v),SCM_CDR(s)));
return scm_cons(SCM_CAR(ss),
scm_cons(SCM_CAR(s),scm_cons(scm_cons(x,v),SCM_CDR(s))));
else
scm_misc_error("logical_add","malformed s",SCM_EOL);
return SCM_BOOL_F;
}
SCM_DEFINE(gp_logical_incr, "gp-logical++", 0, 0, 0, (),
SCM_DEFINE(gp_logical_incr, "gp-logical++", 1, 0, 0, (SCM s),
"increase logic indicator")
#define FUNC_NAME s_gp_logical_incr
{
_logical_ ++;
struct gp_stack *gp = get_gp(s);
gp->_logical_ ++;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE(gp_logical_decr, "gp-logical--", 0, 0, 0, (),
SCM_DEFINE(gp_logical_decr, "gp-logical--", 1, 0, 0, (SCM s),
"increase logic indicator")
#define FUNC_NAME s_gp_logical_incr
{
_logical_ --;
struct gp_stack *gp = get_gp(s);
gp->_logical_ --;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
#define gp_N2 100000
#define gp_N3 100000
scm_t_bits gp_stack_type;
#define GP_STACKP(scm) (SCM_NIMP(scm) && SCM_SMOB_PREDICATE(gp_stack_type,scm))
struct gp_stack
{
int id;
int thread_id;
int _logical_;
int gp_nc;
SCM *gp_cstack;
int gp_ns;
SCM *gp_stack;
SCM* gp_si;
SCM* gp_ci;
SCM *gp_nnc;
SCM *gp_nns;
SCM *gp_ci_h;
SCM *gp_ci_q;
};
static inline struct gp_stack *get_gp(SCM s)
{
if(SCM_CONSP(s))
{
SCM gp = SCM_CAR(s);
if(GP_STACKP(gp))
return (struct gp_stack *) SCM_SMOB_DATA(gp);
}
scm_misc_error("get_gp","could not find stacks",SCM_EOL);
return (struct gp_stack *)0;
}
static inline SCM *make_gp_stack(int id, int nthread, int nc, int ns, struct gp_stack **ggp)
{
*ggp =
(struct gp_stack *) scm_gc_malloc_pointerless(sizeof(struct gp_stack),"struct gp_stack");
struct gp_stack *gp = *ggp;
if(!gp) goto error1;
gp->gp_cstack =
(SCM *) scm_gc_malloc_pointerless(sizeof(SCM) * nc,"gp->gp_cstack");
if(!gp->gp_cstack) goto error2;
gp->gp_stack =
(SCM *) scm_gc_malloc_pointerless(sizeof(SCM) * ns,"gp->gp_stack");
if(!gp->gp_stack) goto error3;
gp->gp_nc = nc;
gp->gp_ns = ns;
gp->gp_si = gp->gp_stack;
gp->gp_ci = gp->gp_cstack + 1;
gp->gp_nns = gp->gp_stack + gp->gp_ns - 10;
gp->gp_nnc = gp->gp_cstack + gp->gp_nc - 10;
gp->_logical_ = 0;
gp->gp_ci_h = (SCM *) 0;
gp->id = id;
gp->thread_id = nthread;
SCM ret;
SCM_NEWSMOB(ret, gp_stack_type, (void*)0);
GP_GETREF(ret)[1] = GP_UNREF((SCM *) gp);
return GP_GETREF(ret);
error3:
error2:
error1:
return (SCM *)0;
}
static SCM gp_stack_mark(SCM obj)
{
struct gp_stack *gp = (struct gp_stack *) SCM_SMOB_DATA(obj);
int i;
scm_gc_mark(GP_UNREF(gp->gp_cstack));
scm_gc_mark(GP_UNREF(gp->gp_stack));
for(i=0;i < gp->gp_ci - gp->gp_cstack; i++)
{
scm_gc_mark(gp->gp_cstack[i]);
}
for(i=0;i < gp->gp_si - gp->gp_stack; i+=2)
{
if(GP_VAL(&(gp->gp_stack[i])))
scm_gc_mark(gp->gp_stack[i+1]);
}
return SCM_BOOL_T;
}
static int gp_stack_printer(SCM x, SCM port, scm_print_state *spec)
{
scm_simple_format(port,scm_from_locale_string("<gp-stack>"),SCM_EOL);
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);
}
......@@ -163,7 +163,7 @@ static inline int gp_do_cons(SCM item, int state, SCM *old)
}
static inline void gp_unwind0(SCM *ci, SCM *si)
static inline void gp_unwind0(SCM *ci, SCM *si, struct gp_stack *gp)
{
SCM val, old = SCM_EOL;
SCM *i, *ci_old, *id;
......@@ -171,22 +171,12 @@ static inline void gp_unwind0(SCM *ci, SCM *si)
DB(printf("unwind>\n");fflush(stdout));
/*
if(ci > gp_ci || si > gp_si)
{
if(ci > gp_ci && si > gp_si)
return;
printf("ERROR in unwind, ci and si not larger at the same time\n");
return;
}
*/
ci_old = gp_ci;
gp_ci = ci;
gp_si = si;
ci_old = gp->gp_ci;
gp->gp_ci = ci;
gp->gp_si = si;
if (ci_old-1 >= gp_ci)
for(i = ci_old-1; i >= gp_ci; i-=1)
if (ci_old-1 >= gp->gp_ci)
for(i = ci_old-1; i >= gp->gp_ci; i-=1)
{
if(SCM_CONSP(*i))
{
......@@ -223,62 +213,64 @@ static inline void gp_unwind0(SCM *ci, SCM *si)
switch(state)
{
case gp_store:
if(gp_ci == gp_cstack)
if(gp->gp_ci == gp->gp_cstack)
{
SCM_SETCDR(old,SCM_EOL);
return;
}
if(SCM_CONSP(gp_ci[-1]))
if(SCM_CONSP(gp->gp_ci[-1]))
{
SCM q = SCM_CAR(gp_ci[-1]);
SCM q = SCM_CAR(gp->gp_ci[-1]);
if(SCM_I_INUMP(q))
{
switch(SCM_UNPACK(q))
{
case gp_save_tag:
SCM_SETCDR(old,gp_ci[-1]);
SCM_SETCDR(old,gp->gp_ci[-1]);
return;
case gp_redo_tag:
SCM_SETCDR(old,SCM_CADR(gp_ci[-1]));
SCM_SETCDR(old,SCM_CADR(gp->gp_ci[-1]));
return;
}
}
}
gp_ci[-1] = scm_cons(SCM_PACK(gp_save_tag),gp_ci[-1]);
SCM_SETCDR(old,gp_ci[-1]);
gp->gp_ci[-1] = scm_cons(SCM_PACK(gp_save_tag),gp->gp_ci[-1]);
SCM_SETCDR(old,gp->gp_ci[-1]);
return;
case gp_redo:
if(gp_ci == gp_cstack)
if(gp->gp_ci == gp->gp_cstack)
return;
if(SCM_CONSP(gp_ci[-1]))
if(SCM_CONSP(gp->gp_ci[-1]))
{
SCM q = SCM_CAR(gp_ci[-1]);
SCM q = SCM_CAR(gp->gp_ci[-1]);
if(SCM_I_INUMP(q))
{
switch(SCM_UNPACK(q))
{
case gp_save_tag:
SCM_SETCDR(old,gp_ci[-1]);
SCM_SETCDR(old,gp->gp_ci[-1]);
return;
case gp_redo_tag:
SCM_SETCDR(old,SCM_CADR(gp_ci[-1]));
SCM_SETCDR(old,SCM_CADR(gp->gp_ci[-1]));
return;
}
}
}
gp_ci[-1] = scm_cons(SCM_PACK(gp_redo_tag),
scm_cons(SCM_CDR(old), gp_ci[-1]));
gp->gp_ci[-1] = scm_cons(SCM_PACK(gp_redo_tag),
scm_cons(SCM_CDR(old), gp->gp_ci[-1]));
}
}
static inline void gp_unwind(SCM fr)
{
fr = SCM_CAR(fr);
struct gp_stack *gp = get_gp(fr);
fr = SCM_CADR(fr);
SCM *ci,*si;
if(SCM_CONSP(fr))
......@@ -288,12 +280,12 @@ static inline void gp_unwind(SCM fr)
}
else
{
ci = gp_ci - SCM_I_INUM(fr);
if(ci < gp_cstack)
ci = gp_cstack;
si = gp_si;
ci = gp->gp_ci - SCM_I_INUM(fr);
if(ci < gp->gp_cstack)
ci = gp->gp_cstack;
si = gp->gp_si;
}
gp_unwind0(ci,si);
gp_unwind0(ci,si,gp);
}
......@@ -306,13 +298,14 @@ SCM_DEFINE(gp_gp_unwind, "gp-unwind", 1, 0, 0, (SCM fr),
}
#undef FUNC_NAME
SCM_DEFINE(gp_get_stack, "gp-get-stack", 0, 0, 0, (),
SCM_DEFINE(gp_get_stack, "gp-get-stack", 1, 0, 0, (SCM s),
"yields the stack as a list")
#define FUNC_NAME s_gp_get_stack
{
struct gp_stack *gp = get_gp(s);
SCM* i;
SCM ret = SCM_EOL;
for(i = gp_cstack; i < gp_ci; i++)
for(i = gp->gp_cstack; i < gp->gp_ci; i++)
{
ret = scm_cons(*i,ret);
}
......@@ -320,18 +313,18 @@ SCM_DEFINE(gp_get_stack, "gp-get-stack", 0, 0, 0, (),
}
#undef FUNC_NAME
static inline SCM gp_store_state()
static inline SCM gp_store_state(struct gp_stack *gp)
{
SCM head, data;
if(gp_ci == gp_cstack)
if(gp->gp_ci == gp->gp_cstack)
{
return scm_cons(SCM_I_MAKINUM(_logical_),
scm_cons(PTR2NUM(gp_si),
return scm_cons(SCM_I_MAKINUM(gp->_logical_),
scm_cons(PTR2NUM(gp->gp_si),
scm_cons(SCM_I_MAKINUM(0), SCM_EOL)));
}
data = gp_ci[-1];
data = gp->gp_ci[-1];
head = SCM_EOL;
if(SCM_CONSP(data) && SCM_I_INUMP(SCM_CAR(data)))
......@@ -350,27 +343,27 @@ static inline SCM gp_store_state()
else
{
head = scm_cons(SCM_PACK(gp_save_tag),data);
gp_ci[-1] = head;
gp->gp_ci[-1] = head;
}
return scm_cons(SCM_I_MAKINUM(_logical_),
scm_cons(PTR2NUM(gp_si),
scm_cons(SCM_I_MAKINUM(gp_ci - gp_cstack)
return scm_cons(SCM_I_MAKINUM(gp->_logical_),
scm_cons(PTR2NUM(gp->gp_si),
scm_cons(SCM_I_MAKINUM(gp->gp_ci - gp->gp_cstack)
, head)));
}
SCM_DEFINE(gp_gp_store_state, "gp-store-state", 0, 0, 0, (),
SCM_DEFINE(gp_gp_store_state, "gp-store-state", 1, 0, 0, (SCM s),
"sore a continuation point at the current state")
#define FUNC_NAME s_gp_gp_store_state
{
return gp_store_state();
return scm_cons(gp_store_state(get_gp(s)),s);
}
#undef FUNC_NAME
//#define DB(X) X
static inline SCM * gp_get_branch(SCM *p, SCM *ci)
static inline SCM * gp_get_branch(SCM *p, SCM *ci, struct gp_stack *gp)
{
SCM d;
SCM pp = *p;
......@@ -378,7 +371,7 @@ static inline SCM * gp_get_branch(SCM *p, SCM *ci)
retry:
i++;
if(pp == SCM_EOL)
return gp_cstack;
return gp->gp_cstack;
if(pp == *ci)
{
......@@ -421,7 +414,7 @@ static inline SCM * gp_get_branch(SCM *p, SCM *ci)
cdrcdr:
i++;
if(pp == SCM_EOL)
return gp_cstack;
return gp->gp_cstack;
if(SCM_CONSP(pp) && SCM_CDR(pp) == d)
{
......@@ -470,7 +463,7 @@ static inline SCM * gp_get_branch(SCM *p, SCM *ci)
goto cdrcdr;
}
static int gp_rewind(SCM pp, SCM pend, SCM *ci)
static int gp_rewind(SCM pp, SCM pend, SCM *ci, struct gp_stack *gp)
{
SCM *id,q,stack[50];
int sp;
......@@ -487,7 +480,7 @@ static int gp_rewind(SCM pp, SCM pend, SCM *ci)
stack[sp++] = pp;
if(sp == 50)
{
gp_rewind(SCM_CDR(pp), pend, ci);
gp_rewind(SCM_CDR(pp), pend, ci, gp);
break;
}
pp = SCM_CDR(pp);
......@@ -504,7 +497,7 @@ static int gp_rewind(SCM pp, SCM pend, SCM *ci)
id = GP_GETREF(SCM_CAR(q));
q = SCM_CDR(q);
gp_store_var_2(id,0);
gp_store_var_2(id,0,gp);
id[0] = SCM_PACK(SCM_I_INUM(SCM_CAR(q)));
id[1] = SCM_CDR(q);
......@@ -516,8 +509,8 @@ static int gp_rewind(SCM pp, SCM pend, SCM *ci)
scm_call_1(SCM_CAR(q),SCM_BOOL_T);
else
scm_call_0(SCM_CAR(q));
gp_ci[0] = q;
gp_ci ++;
gp->gp_ci[0] = q;
gp->gp_ci ++;
}
sp--;
}
......@@ -525,7 +518,7 @@ static int gp_rewind(SCM pp, SCM pend, SCM *ci)
return 1;
}
static void gp_restore_state(SCM data)
static void gp_restore_state(SCM data, struct gp_stack *gp)
{
SCM *si, q, path;
int n, m;
......@@ -534,8 +527,8 @@ static void gp_restore_state(SCM data)
gp_debug0("to restore\n");
_logical_ = SCM_I_INUM(SCM_CAR(data));
gp_ci_h = (SCM *) 0;
gp->_logical_ = SCM_I_INUM(SCM_CAR(data));
gp->gp_ci_h = (SCM *) 0;
data = SCM_CDR(data);
if(SCM_CONSP(data))
......@@ -546,7 +539,7 @@ static void gp_restore_state(SCM data)
{
n = SCM_I_INUM(SCM_CAR(q));
path = SCM_CDR(q);
m = gp_ci - gp_cstack;
m = gp->gp_ci - gp->gp_cstack;
}
else
{
......@@ -564,26 +557,26 @@ static void gp_restore_state(SCM data)
}
gp_debug0("prepare si state\n");
if(si > gp_si)
if(si > gp->gp_si)
{
SCM *s;
for(s = gp_si; s < si; s++)
for(s = gp->gp_si; s < si; s++)
{
s[0] = gp_unbd;
s[1] = SCM_UNBOUND;
}
gp_si = si;
gp->gp_si = si;
}
gp_debug0("make paths equal length\n");
ci_x = gp_ci - 1;
ci_x = gp->gp_ci - 1;
pp_x = path;
if(m > n)
{
gp_debug0("m > n\n");
ci_x = gp_ci - (m - n) - 1;
gp_unwind0(ci_x + 1, si);
ci_x = gp->gp_ci - (m - n) - 1;
gp_unwind0(ci_x + 1, si,gp);
}
if(n > m)
......@@ -597,19 +590,19 @@ static void gp_restore_state(SCM data)
}
gp_debug0("get-branch\n");
ci = gp_get_branch(&pp_x, ci_x);
ci = gp_get_branch(&pp_x, ci_x, gp);
gp_debug0("unwind\n");
gp_unwind0(ci + 1, si);
gp_unwind0(ci + 1, si, gp);
gp_debug0("rewind\n");
restored = gp_rewind(path,pp_x,ci);
restored = gp_rewind(path,pp_x,ci, gp);
gp_debug0("check restored\n");
if(restored)
gp_ci[-1] = scm_cons(SCM_PACK(gp_redo_tag),
scm_cons(path, gp_ci[-1]));
gp->gp_ci[-1] = scm_cons(SCM_PACK(gp_redo_tag),
scm_cons(path, gp->gp_ci[-1]));
}
//#define DB(X)
......@@ -618,7 +611,11 @@ SCM_DEFINE(gp_gp_restore_state, "gp-restore-state", 1, 0, 0, (SCM cont),
"restore a continuation point")
#define FUNC_NAME s_gp_gp_restore_state
{
gp_restore_state(cont);
if(SCM_CONSP(cont))
{
struct gp_stack *gp = get_gp(SCM_CDR(cont));
gp_restore_state(SCM_CAR(cont),gp);
}
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
......
This diff is collapsed.
......@@ -30,10 +30,6 @@
#define i_load Q(9)
#define i_arbr Q(10)
SCM_API SCM gp_swap_a();
SCM_API SCM gp_swap_b();
SCM_API SCM gp_gp(SCM scm);
SCM_API SCM gp_varp(SCM x, SCM s);
......@@ -42,14 +38,14 @@ SCM_API SCM gp_consp(SCM x);
SCM_API SCM gp_set(SCM var, SCM val, SCM s);
SCM_API SCM gp_ref_set(SCM var, SCM val, SCM s);
SCM_API SCM gp_clear();
SCM_API SCM gp_clear(SCM s);
SCM_API SCM gp_gp_newframe(SCM s);
SCM_API SCM gp_mkvar();
SCM_API SCM gp_mkvar(SCM s);
SCM_API SCM smob2scm(SCM scm, SCM s);
SCM_API SCM gp_gp_unify(SCM scm1, SCM scm2, SCM s);
SCM_API SCM gp_gp_lookup(SCM scm, SCM s);
SCM_API SCM gp_var_number(SCM x);
SCM_API SCM gp_var_number(SCM x, SCM s);
SCM_API SCM gp_soft_init();
SCM_API SCM gp_cons_bang(SCM car, SCM cdr, SCM s);
......@@ -62,18 +58,20 @@ SCM_API SCM gp_gp_cdr(SCM x);
SCM_API SCM gp_car(SCM x);
SCM_API SCM gp_gp_unwind(SCM fr);
SCM_API SCM gp_gp_store_state();
SCM_API SCM gp_gp_store_state(SCM s);
SCM_API SCM gp_gp_restore_state(SCM cont);
SCM_API SCM gp_make_fluid();
SCM_API SCM gp_fluid_set_bang(SCM f, SCM v);
SCM_API SCM gp_make_fluid(SCM s);
SCM_API SCM gp_fluid_set_bang(SCM f, SCM v, SCM s);
SCM_API SCM gp_dynwind(SCM in, SCM out);
SCM_API SCM gp_dynwind(SCM in, SCM out, SCM s);
//SCM_API SCM gp_copy(SCM x);
SCM_API SCM gp_jumpframe_start();
SCM_API SCM gp_jumpframe_end();
SCM_API SCM gp_logical_incr();