added another stack to be able to allocate closures from the stack and still...

added another stack to be able to allocate closures from the stack and still be able to store the state e.g. push the closures to the heap, einstein example works
parent ea18d8fd
......@@ -4,6 +4,7 @@
(define-module (ice-9 match-phd-lookup)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
#:export (match-define match-let* match-let match-letrec match-lambda*
match-lambda match make-phd-matcher))
......@@ -291,14 +292,13 @@
(define-syntax match-three*
(syntax-rules (_ ___ *** quote quasiquote ? $ = and or not set! get!)
((match-two (abs ((car cdr pair? null? id) rr)) s v (p) g+s sk fk i)
(let ((s (pair? v s)))
(let-values (((w cd s) (pair? v s)))
(if s
(let ((s (null? (cdr v s) s)))
(let ((s (null? cd s)))
(if s
(let ((w (car v s)))
(match-one (abs ((car cdr pair? null? id) rr)) s w p
((car w)
(set-car! w)) sk fk i))
(match-one (abs ((car cdr pair? null? id) rr)) s w p
((car w)
(set-car! w)) sk fk i)
(insert-abs (abs ((car cdr pair? null? equal? id) pp)) fk)))
(insert-abs (abs ((car cdr pair? null? equal? id) pp)) fk))))
......@@ -310,14 +310,13 @@
((match-two (abs ((car cdr pair? null? equal? id) pp)) s v (p . q)
g+s sk fk i)
(let ((s (pair? v s)))
(let-values (((w x s) (pair? v s)))
(if s
(let ((w (car v s)) (x (cdr v s)))
(match-one (abs ((car cdr pair? null? equal? id) pp)) s w p
((car ww) (set-car! ww))
(match-one s x q ((cdr ww) (set-cdr! ww)) sk fk)
fk
i))
(match-one (abs ((car cdr pair? null? equal? id) pp)) s w p
((car ww) (set-car! ww))
(match-one s x q ((cdr ww) (set-cdr! ww)) sk fk)
fk
i)
(insert-abs (abs ((car cdr pair? null? equal? id) pp)) fk))))
((match-two abs s v #(p ...) g+s . x)
......
......@@ -17,7 +17,8 @@
gp-make-stack
gp-pair!? gp-null!? gp-null?
gp-jumpframe-start gp-jumpframe-end gp?
gp-module-init))
gp-module-init
-gp-member -gp-right-of))
......@@ -46,6 +47,13 @@
(define-inlinable (gp-m-unify! x y s)
(fast-call-3 2 x y s))
#|
(fast-call-set! -gp-member 3 3)
(define --gp-member -gp-member)
(define-inlinable (-gp-member x l s)
(fast-call-3 3 x l s))
|#
;; fast call 1 arg
(fast-call-set! gp-jumpframe-start 1 2)
(define-inlinable (gp-jumpframe-start s)
......@@ -63,6 +71,10 @@
(define-inlinable (gp-newframe s)
(fast-call-1 5 s))
(fast-call-set! gp-var! 1 6)
(define-inlinable (gp-var! s)
(fast-call-1 6 s))
;; fast call 2 arg
(fast-call-set! gp-lookup 2 0)
......@@ -89,10 +101,25 @@
(define-inlinable (gp-car x s)
(fast-call-2 5 x s))
(fast-call-set! gp-cdr 2 6)
(define-inlinable (gp-cdr x s)
(fast-call-2 6 x s))
(fast-call-set! gp->scm 2 7)
(define-inlinable (gp->scm x s)
(fast-call-2 7 x s))
;; fast call 4 args
#|
(fast-call-set! -gp-right-of 4 0)
(define-inlinable (-gp-right-of x y l s)
(fast-call-4 0 x y l s))
|#
(let ((tag (cons 'the 'closure-tag)))
(set-c-closure-tag tag)
(gp-set-closure-tag tag))
(define -gp-member (gp-make-member))
(define -gp-right-of (gp-make-right-of))
(define-module (logic guile-log examples einstein)
#:use-module (srfi srfi-11)
#:use-module (logic guile-log)
#:use-module (logic guile-log umatch)
#:use-module (ice-9 pretty-print)
......@@ -6,11 +7,22 @@
;(use-modules (language prolog kanren))
(<define> (memb x l)
(<match> () (l)
((,x . l) <cc>)
((_ . l) (<cut> (memb x l)))
(_ <fail>)))
(define memb gp-member)
#;(define (memb s p cc x l)
(let ((f (gp-newframe s)))
(letrec ((next (lambda (l)
(let loop ((l l))
(gp-unwind f)
(let-values (((a as s) (gp-fpair!? l s)))
(if s
(let ((s (gp-unify-raw! a x s)))
(if s
(cc s (lambda () (next as)))
(loop as)))
(p)))))))
(next l))))
#;
(<define> (on-right i j l)
......@@ -21,26 +33,43 @@
(_ <fail>)))
(define (on-right s p cc i j l)
(define on-right gp-right-of)
#;(define (on-right s p cc i j l)
(let ((f (gp-newframe s)))
(let loop ((l l))
(gp-unwind f)
(let ((s (gp-pair!? l f)))
(if s
(let ((ii (gp-car l s))
(ll (gp-cdr l s)))
(let ((s (gp-pair!? ll s)))
(if s
(let ((jj (gp-car ll s)))
(let ((s (gp-unify-raw! ii i s)))
(if s
(let ((s (gp-unify-raw! jj j s)))
(if s
(cc s (lambda () (loop ll)))
(loop ll)))
(loop ll))))
(p))))
(p))))))
(letrec ((next (lambda (l)
(let loop ((l l))
(gp-unwind f)
(let-values (((ii ll s) (gp-fpair!? l f)))
(if s
(let-values (((jj kk s) (gp-fpair!? ll s)))
(if s
(let ((s (gp-unify-raw! ii i s)))
(if s
(let ((s (gp-unify-raw! jj j s)))
(if s
(cc s (lambda () (next ll)))
(loop ll)))
(loop ll)))
(p)))
(p))))))
(loop (lambda (l)
(gp-unwind f)
(let-values (((ii ll s) (gp-fpair!? l f)))
(if s
(let-values (((jj kk s) (gp-fpair!? ll s)))
(if s
(let ((s (gp-unify-raw! ii i s)))
(if s
(let ((s (gp-unify-raw! jj j s)))
(if s
(cc s (lambda () (next ll)))
(loop ll)))
(loop ll)))
(p)))
(p))))))
(loop l))))
(<define> (next-to item1 item2 rest)
......@@ -54,24 +83,66 @@
((x . l) #'((gp-var! *current-stack*) . l))
(_ #'(gp-var! *current-stack*)))))
(define a1 #f)
(define a2 #f)
(define a3 #f)
(define a4a #f)
(define a4b #f)
(define a5 #f)
(define a6 #f)
(define a7 #f)
(define a8a #f)
(define a8b #f)
(define a9 #f)
(define a10a #f)
(define a10b #f)
(define a11a #f)
(define a11b #f)
(define a12 #f)
(define a13 #f)
(define a14a #f)
(define a14b #f)
(define a15 #f)
(<define> (einstein h)
(<code>
(set! a1 `(brit ,__ ,__ ,__ red))
(set! a2 `(swede dog ,__ ,__ ,__ ))
(set! a3 `(dane ,__ ,__ tea ,__ ))
(set! a4a `(,__ ,__ ,__ ,__ green))
(set! a4b `(,__ ,__ ,__ ,__ white))
(set! a5 `(,__ ,__ ,__ cofee green))
(set! a6 `(,__ bird pallmall ,__ ,__))
(set! a7 `(,__ ,__ dunhill ,__ yellow))
(set! a8a `(,__ ,__ dunhill ,__ ,__))
(set! a8b `(,__ horse ,__ ,__ ,__))
(set! a9 `(,__ ,__ ,__ milk ,__))
(set! a10a `(,__ ,__ marlboro ,__ ,__))
(set! a10b `(,__ cat ,__ ,__ ,__))
(set! a11a `(,__ ,__ marlboro ,__ ,__))
(set! a11b `(,__ ,__ ,__ water ,__))
(set! a12 `(,__ ,__ winfield beer ,__))
(set! a13 `(german ,__ rothmans ,__ ,__))
(set! a14a `(norwegian ,__ ,__ ,__ ,__))
(set! a14b `(,__ ,__ ,__ ,__ blue))
(set! a15 `(,__ fish ,__ ,__ ,__)))
(<and>
(<=> h ,`((norwegian ,__ ,__ ,__ ,__) ,__ (,__ ,__ ,__ milk ,__) ,__ ,__))
(memb `(brit ,__ ,__ ,__ red) h)
(memb `(swede dog ,__ ,__ ,__ ) h)
(memb `(dane ,__ ,__ tea ,__ ) h)
(on-right `(,__ ,__ ,__ ,__ green) `(,__ ,__ ,__ ,__ white) h)
(memb `(,__ ,__ ,__ cofee green) h)
(memb `(,__ bird pallmall ,__ ,__) h)
(memb `(,__ ,__ dunhill ,__ yellow) h)
(next-to `(,__ ,__ dunhill ,__ ,__) `(,__ horse ,__ ,__ ,__) h)
(memb `(,__ ,__ ,__ milk ,__) h)
(next-to `(,__ ,__ marlboro ,__ ,__) `(,__ cat ,__ ,__ ,__) h)
(next-to `(,__ ,__ marlboro ,__ ,__) `(,__ ,__ ,__ water ,__) h)
(memb `(,__ ,__ winfield beer ,__) h)
(memb `(german ,__ rothmans ,__ ,__) h)
(next-to `(norwegian ,__ ,__ ,__ ,__) `(,__ ,__ ,__ ,__ blue) h)
(memb `(,__ fish ,__ ,__ ,__) h)
(memb a1 h)
(memb a2 h)
(memb a3 h)
(on-right a4a a4b h)
(memb a5 h)
(memb a6 h)
(memb a7 h)
(next-to a8a a8b h)
(memb a9 h)
(next-to a10a a10b h)
(next-to a11a a11b h)
(memb a12 h)
(memb a13 h)
(next-to a14a a14b h)
(memb a15 h)
))
......
(define-module (logic guile-log examples queens)
#:use-module (logic guile-log)
#:use-module (logic guile-log umatch)
#:use-module (srfi srfi-11)
#:export (run))
(<define> (queens N Qs)
(<var> (Ns)
(<and> (range-list 1 N Ns)
(queens3 Ns '() Qs))))
(<define> (queens3 UnplacedQs SafeQs Qs)
(<match> () (UnplacedQs)
( _ (<var> (Q UnplacedQs1)
(<and> (selectq Q UnplacedQs UnplacedQs1)
(<not> (attack Q SafeQs))
(queens3 UnplacedQs1 (<cons> Q SafeQs) Qs))))
('() (<=> SafeQs Qs))
( _ <fail>)))
(<define> (attack X Xs) (attack3 X 1 Xs))
(define (attack3 s p cc x n v)
(let-values (((ca cd s) (gp-fpair!? v s)))
(if s
(let ((x (gp->scm x s))
(y (gp->scm ca s)))
(let ((f (gp-newframe s)))
(if (or (eq? x (+ y n)) (eq? x (- y n)))
(cc f (lambda ()
(gp-unwind f)
(attack3 f p cc x (+ n 1) cd)))
(attack3 f p cc x (+ n 1) cd))))
(p))))
#;
(<define> (attack3 X N V)
(<match> () (V)
((Y . _) (<when> (or (eq? (<scm> X) (+ (<scm> Y) N))
(eq? (<scm> X) (- (<scm> Y) N)))))
((_ . Y) (attack3 X (+ N 1) Y))
(_ <fail>)))
(<define> (range-list M N U)
(<match> () (U)
((,M) (<when> (>= M N) <cut>))
((,M . L) (range-list (+ M 1) N L))
(_ <fail>)))
(<define> (selectq X U Xs)
(<match> () (U Xs)
((,X . ,Xs) _ <cc>)
(( Y . Ys) ( Y . Zs) (selectq X Ys Zs))
(_ _ <fail>)))
(define (f)
(<run> * (Q)
(queens 10 Q)))
(define (run n)
(if (= n 0)
#t
(begin
(f)
(run (- n 1)))))
......@@ -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 state.c functional-tree.c
gcc $(LIBS) $(CFLAGS) -shared -o libguile-unify.so -fPIC unify.c
libguile-unify.so : unify.h unify.c unify-undo-redo.c logical.c unify.x state.c functional-tree.c util.c
gcc $(LIBS) $(CFLAGS) -O3 -shared -o libguile-unify.so -fPIC unify.c
unify.x : unify.h unify.c unify-undo-redo.c logical.c state.c functional-tree.c
unify.x : unify.h unify.c unify-undo-redo.c logical.c state.c functional-tree.c util.c
guile-snarf -o unify.x $(CFLAGS) unify.c
......@@ -11,17 +11,23 @@ struct gp_stack
int _logical_;
int gp_ncs;
SCM *gp_cons_stack;
int gp_nc;
SCM *gp_cstack;
int gp_ns;
SCM *gp_stack;
SCM* gp_cs;
SCM* gp_si;
SCM* gp_ci;
SCM *gp_nnc;
SCM *gp_nns;
SCM *gp_nncs;
SCM *gp_ci_h;
SCM *gp_ci_q;
};
......@@ -39,8 +45,10 @@ static inline struct gp_stack *get_gp(SCM s)
return (struct gp_stack *)0;
}
static inline SCM *make_gp_stack(int id, int nthread, int nc, int ns, struct gp_stack **ggp)
static inline SCM *make_gp_stack(int id, int nthread, int nc, int ns, int ncs, struct gp_stack **ggp)
{
int i,ii;
*ggp =
(struct gp_stack *) scm_gc_malloc_pointerless(sizeof(struct gp_stack),"struct gp_stack");
......@@ -60,14 +68,24 @@ static inline SCM *make_gp_stack(int id, int nthread, int nc, int ns, struct gp_
scm_gc_protect_object(GP_UNREF(gp->gp_stack));
gp->gp_nc = nc;
gp->gp_ns = ns;
gp->gp_cons_stack =
(SCM *) scm_gc_malloc(sizeof(SCM) * ncs,"gp->gp_stack");
if(!gp->gp_cons_stack) goto error4;
scm_gc_protect_object(GP_UNREF(gp->gp_cons_stack));
gp->gp_nc = nc;
gp->gp_ns = ns;
gp->gp_ncs = ncs;
gp->gp_si = gp->gp_stack;
gp->gp_ci = gp->gp_cstack;
gp->gp_cs = gp->gp_cons_stack;
gp->gp_nns = gp->gp_stack + gp->gp_ns - 10;
gp->gp_nnc = gp->gp_cstack + gp->gp_nc - 10;
gp->gp_nns = gp->gp_stack + gp->gp_ns - 10;
gp->gp_nnc = gp->gp_cstack + gp->gp_nc - 10;
gp->gp_nncs = gp->gp_cons_stack + gp->gp_ncs - 10;
gp->_logical_ = 0;
gp->gp_ci_h = (SCM *) 0;
......@@ -77,11 +95,25 @@ static inline SCM *make_gp_stack(int id, int nthread, int nc, int ns, struct gp_
SCM ret;
SCM_NEWSMOB(ret, gp_stack_type, (void*)0);
GP_GETREF(ret)[1] = GP_UNREF((SCM *) gp);
for(i = 0; i < gp->gp_ncs; i++)
{
gp->gp_cs[i] = SCM_BOOL_F;
}
for(i = 0; i < gp->gp_ncs && i < 10000; i++)
{
gp->gp_cs[i] = scm_cons(SCM_BOOL_F,SCM_BOOL_F);
}
scm_gc_unprotect_object(GP_UNREF(gp->gp_cstack));
scm_gc_unprotect_object(GP_UNREF(gp->gp_stack));
scm_gc_unprotect_object(GP_UNREF(gp->gp_cons_stack));
return GP_GETREF(ret);
error4:
scm_gc_unprotect_object(GP_UNREF(gp->gp_stack));
error3:
scm_gc_unprotect_object(GP_UNREF(gp->gp_cstack));
......@@ -96,18 +128,26 @@ static SCM gp_stack_mark(SCM obj)
struct gp_stack *gp = (struct gp_stack *) SCM_SMOB_DATA(obj);
int i;
printf("stack mark\n");
scm_gc_mark(GP_UNREF(gp->gp_cstack));
scm_gc_mark(GP_UNREF(gp->gp_stack));
scm_gc_mark(GP_UNREF(gp->gp_cons_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)
for(i=0;i < gp->gp_nncs - gp->gp_cons_stack; i++)
{
scm_gc_mark(gp->gp_cons_stack[i]);
}
for(i=0;i < gp->gp_si - gp->gp_stack; i++)
{
if(GP_VAL(&(gp->gp_stack[i])))
scm_gc_mark(gp->gp_stack[i+1]);
// if(GP_VAL(&(gp->gp_stack[i])))
scm_gc_mark(gp->gp_stack[i+1]);
}
return SCM_BOOL_T;
......@@ -126,3 +166,67 @@ static void gp_module_stack_init()
scm_set_smob_mark(gp_stack_type, gp_stack_mark);
scm_set_smob_print(gp_stack_type,gp_stack_printer);
}
static inline void gp_alloc_cons(struct gp_stack *gp, int n)
{
int i;
if(!(gp->gp_cs + n <= gp->gp_nncs)) goto error;
if(!SCM_CONSP(gp->gp_cs[n-1])) goto allocate;
return;
allocate:
for(i=0;i < 10000 && gp->gp_cs+i < gp->gp_nncs;i++)
{
if(!SCM_CONSP(gp->gp_cs[i]))
gp->gp_cs[i] = scm_cons(SCM_BOOL_F,SCM_BOOL_F);
}
return;
error:
scm_misc_error("gp_alloc_cons","cons stack is full",SCM_EOL);
return;
}
static inline SCM gpa_cons(SCM x, SCM y, struct gp_stack *gp)
{
SCM r = gp->gp_cs[0];
gp->gp_cs++;
SCM_SETCAR(r,x);
SCM_SETCDR(r,y);
return r;
}
static inline SCM* gp_alloc_data(int n, struct gp_stack *gp)
{
int i;
if(!(gp->gp_si + n <= gp->gp_nns)) goto error;
SCM * ret = gp->gp_si;
gp->gp_si += n;
return ret;
error:
scm_misc_error("gp_alloc_data","data stack is full",SCM_EOL);
return;
}
static inline SCM gp_make_vector(int n, struct gp_stack *gp)
{
SCM *vec = gp_alloc_data(n + SCM_I_VECTOR_HEADER_SIZE,gp);
((scm_t_bits *) vec)[0] = (n << 8) | scm_tc7_vector;
((scm_t_bits *) vec)[1] = 0;
return PTR2SCM(vec);
}
static inline SCM gp_make_closure(int n, SCM **closure, SCM s)
{
struct gp_stack *gp = get_gp(s);
SCM vec = gp_make_vector(n,gp);
*closure = SCM_I_VECTOR_WELTS(vec);
gp_alloc_cons(gp,1);
return gpa_cons(closure_tag, vec, gp);
}
......@@ -41,7 +41,7 @@ static inline SCM gp_handle(SCM item, int ret, SCM gp_unbd)
scm_call_0(SCM_CDR(item));
return item;
}
else
else if(GP(item))
{
id = GP_GETREF(item);
if(ret)
......@@ -51,6 +51,13 @@ static inline SCM gp_handle(SCM item, int ret, SCM gp_unbd)
id[1] = SCM_UNBOUND;
return x;
}
else if (2 & SCM_UNPACK(item))
{
return item;
}
else
scm_misc_error("gp_handle","scheme object that is not a number on gp_cstack"
,SCM_EOL);
}
static inline int gp_advanced(SCM item, int state, SCM *old, SCM gp_unbd)
......@@ -167,13 +174,14 @@ static inline int gp_do_cons(SCM item, int state, SCM *old, SCM gp_unbd)
}
static inline void gp_unwind0(SCM *ci, SCM *si, struct gp_stack *gp)
static inline void gp_unwind0(SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp)
{
SCM val, old = SCM_EOL;
SCM *i, *ci_old,*si_old, *id;
int state = 0;
SCM gp_unbd;
mask_on(gp->id,&gp_unbd,SCM_PACK(GP_MK_FRAME_UNBD(gp_type)));
DB(printf("unwind> %x %x\n",ci - gp->gp_cstack, gp->gp_ci - gp->gp_cstack);fflush(stdout));
......@@ -201,6 +209,49 @@ static inline void gp_unwind0(SCM *ci, SCM *si, struct gp_stack *gp)
if(!GP(*i))
{
// ------------------- Code for stack pointers -----------------
if(2 & SCM_UNPACK(*i))
{
SCM *cs2 = NUM2PTR(*i);
if(cs2 < cs) cs = cs2;
if(state)
{
switch(state)
{
case gp_store:
{
val = scm_cons(*i,SCM_EOL);
if(SCM_CONSP(old))
SCM_SETCDR(old,val);
old = val;
break;
}
case gp_redo:
old = SCM_CDR(old);
}
}
i--;
if(state)
{
switch(state)
{
case gp_store:
{
val = scm_cons(*i,SCM_EOL);
if(SCM_CONSP(old))
SCM_SETCDR(old,val);
old = val;
break;
}
case gp_redo:
old = SCM_CDR(old);
}
}
continue;
}
//--------------------------------------------------
gp_debug1("adress> %x\n",SCM_UNPACK(*i));
scm_misc_error("in unwinding","should have a GP value or CONS in unwinding of cstack",SCM_EOL);
}
......@@ -230,6 +281,60 @@ static inline void gp_unwind0(SCM *ci, SCM *si, struct gp_stack *gp)
id[1] = SCM_UNBOUND;
}
//cs part
int cs_store = 0;
for(i = gp->gp_cs - 1; i >= cs; i--)
{
if(cs_store)
{
if(SCM_CONSP(*i))
{
if(scm_is_eq(SCM_CAR(*i),closure_tag))
{
//We must copy the closure to the heap
//Eg the cons cell removed from the stack
//And the cdr is setted to the heap closure
SCM vec = SCM_CDR(*i);
int n = SCM_I_VECTOR_LENGTH(vec);
const SCM *from = SCM_I_VECTOR_ELTS(vec);
SCM vec_to = scm_c_make_vector(n,SCM_BOOL_F);
SCM *to = SCM_I_VECTOR_WELTS(vec_to);
int ii;
for(ii=0; ii<n; ii++)
to[ii] = from[ii];
SCM_SETCDR(*i, vec_to);
}
*i = SCM_BOOL_F;
}
}
else
{
if(scm_is_eq(*i,SCM_BOOL_T))
{
*i = SCM_BOOL_F;
cs_store = 1;
continue;
}
if(SCM_CONSP(*i))
{
SCM_SETCDR(*i, SCM_BOOL_F);
SCM_SETCAR(*i, SCM_BOOL_F);
}
}
}
if(cs_store)
{
// mark the stack (#t) as storing and save new stack position
cs[0] = SCM_BOOL_T;
gp->gp_cs = cs + 1;
}
else
gp->gp_cs = cs;
// ----------------------------- End cs part
if(0)
{ //Check the si stack that everything is unbounded
int found = 0;
......@@ -323,6 +428,7 @@ static inline void gp_unwind0(SCM *ci, SCM *si, struct gp_stack *gp)