restore / store works acceptable for paralell and pzip

parent 46ed87f3
......@@ -134,6 +134,7 @@ PSSOURCES = \
logic/guile-log/guile-prolog/vm/vm-unify.scm \
logic/guile-log/guile-prolog/vm/vm-goal.scm \
logic/guile-log/guile-prolog/vm-compiler.scm \
logic/guile-log/guile-prolog/paralell.scm \
logic/guile-log/examples/kanren/type-inference.scm \
logic/guile-log/imatch.scm \
language/prolog/install.scm \
......
......@@ -114,6 +114,7 @@
(<code>
(usr-set! 'stall-ret '())
(fluid-set! *usr-state* S)
(fluid-set! (@ (logic guile-log umatch) *current-stack*) S)
(set! lold (<state-ref>)))
(<stall>))
......@@ -127,6 +128,7 @@
(add_env (car n.x) (cdr n.x))
(<code>
(fluid-set! *usr-state* S)
(fluid-set! (@ (logic guile-log umatch) *current-stack*) S)
(set! lold (<state-ref>)))
(<stall>)))))
......@@ -287,11 +289,18 @@
((@ (guile) if) #f #f)))
(load
`((@ (guile) begin)
((@ (logic guile-log) <state-set!>)
((@ (guile) hash-ref) (@@ (logic guile-log guile-prolog interpreter)
`((@ (guile) let*)
((x
((@ (guile) hash-ref)
(@@ (logic guile-log guile-prolog interpreter)
*states*)
',load))
(state ((@ (guile) car) x))
(s ((@ (guile) cdr) x)))
((@ (logic guile-log) <state-set!>) state)
((@ (guile) fluid-set!)
(@ (logic guile-log umatch) *current-stack*)
s)
((@ (guile) if) #f #f)))
(save
......@@ -299,7 +308,10 @@
((@ (guile) hash-set!)
(@@ (logic guile-log guile-prolog interpreter) *states*)
',save
((@ (logic guile-log) <state-ref>)))
((@ (guile) cons)
((@ (logic guile-log) <state-ref>))
((@ (guile) fluid-ref)
(@@ (logic guile-log guile-prolog interpreter) *usr-state*))))
((@ (guile) if) #f #f)))
(cont
......
(define-module (logic guile-log guile-prolog paralell)
#:use-module (logic guile-log)
#:use-module (logic guile-log prolog goal-functors)
#:use-module (logic guile-log umatch)
#:use-module (logic guile-log paralell)
#:export (paralell pzip))
(define paralell
(<case-lambda>
(() <fail>)
((x) (goal-eval x))
((x y)
(<pand>
(p1 s1 (gp-make-engine 100) (goal-eval x))
(p2 s2 (gp-make-engine 100) (goal-eval y))))
((x y u)
(<pand>
(p1 s1 (gp-make-engine 100) (goal-eval x))
(p2 s2 (gp-make-engine 100) (goal-eval y))
(p3 s3 (gp-make-engine 100) (goal-eval u))))
((x y u v)
(<pand>
(p1 s1 (gp-make-engine 100) (goal-eval x))
(p2 s2 (gp-make-engine 100) (goal-eval y))
(p3 s3 (gp-make-engine 100) (goal-eval u))
(p4 s4 (gp-make-engine 100) (goal-eval v))))
(l
(let ((l-u (let lp ((l l) (u '()) (n (/ (length l) 2)))
(if (= n 0)
(cons l u)
(lp (cdr l) (cons (car l) u) (- n 1))))))
(<pand>
(p1 s1 (gp-make-engine 100) (<apply> paralell (car l-u)))
(p3 s3 (gp-make-engine 100) (<apply> paralell (cdr l-u))))))))
(define pzip
(<case-lambda>
(() <fail>)
((x) (goal-eval x))
((x y)
(<pzip>
(p1 s1 q1 (goal-eval x))
(p2 s2 q2 (goal-eval y))))
((x y u)
(<pzip>
(p1 s1 q1 (goal-eval x))
(p2 s2 q2 (goal-eval y))
(p3 s3 q3 (goal-eval u))))
((x y u v)
(<pzip>
(p1 s1 q1 (goal-eval x))
(p2 s2 q2 (goal-eval y))
(p3 s3 q3 (goal-eval u))
(p4 s4 q4 (goal-eval v))))
(l
(let ((l-u (let lp ((l l) (u '()) (n (/ (length l) 2)))
(if (= n 0)
(cons l u)
(lp (cdr l) (cons (car l) u) (- n 1))))))
(<pzip>
(p2 s2 q2 (<apply> pzip (car l-u)))
(p3 s3 q3 (<apply> pzip (cdr l-u))))))))
......@@ -257,7 +257,7 @@
#{\\=}# #{\\==}# @< @> @>= @=< is op2:
op2+ op2- op1+ op1- #{\\}# op2* op2/ // rem mod div
** << >> #{/\\}# #{\\/}# op2< op2> op2>= op2=< =:= #{=\\=}#
#{;}# #{;;}# --> ? $ ?-
#{;}# #{;;}# --> ? $ ?- ← → =>
eval_when
*prolog-ops*
......
(define-module (logic guile-log paralell)
#:use-module (logic guile-log)
#:use-module (logic guile-log code-load)
#:use-module (logic guile-log dynamic-features)
#:use-module (logic guile-log umatch)
#:export (<pand> <pzip> f test1 test2 test3 test4))
......@@ -13,6 +14,8 @@
(<with-cc> (lambda (s p) (cc-internal s p))
code ...)))
(define *cc* (@@ (logic guile-log run) *cc*))
(<define-guile-log-rule> (<pand> (v se engine code ...) ...)
(<var> (v ...)
(<let> ((data (list v ...))
......@@ -31,6 +34,7 @@
(<with-fail> p
(<with-s> (gp-push-engine frame engine)
(<code> (gp-combine-push data))
(state-guard-dynamic-object *cc*)
(<code> (gp-var-set v (gp-peek-engine) S))
code ...
(<code> (set! se S))
......
......@@ -54,7 +54,7 @@
#{\\=}# #{\\==}# #{\\=@=}# @< @> @>= @=< is op2<=
op2+ op2- op1- op1+ #{\\}# op2* op2/ // rem mod div
** << >> #{/\\}# #{\\/}# op2< op2> op2>= op2=< =:= #{=\\=}#
=.. --> ? $ ?-
=.. --> ? $ ?- =>
gop2+ gop2- gop1+ gop1-
#{g\\}# gop2* gop2/ g// gop2rem gop2mod
......@@ -536,7 +536,24 @@ We could make all variable references through a stack frame e.g.
(<values> x (goal-eval goal))
(<=> x data)))))
(<define> (<=>> data goal)
(<<match>> (#:mode -) (data)
(#((f . l))
(<and>
(<values> x (let ((cc CC))
(<and>
(<=> f ,(mk-lam cc))
(goal-eval goal))))
(<=> x l)))
(_
(<and>
(<values> x (goal-eval goal))
(<=> x data)))))
(mk-prolog-biop 'xfx "<=" <=-tr op2<= <<=> a a)
(mk-prolog-biop 'xfx "←" -tr <<=> a a)
(mk-prolog-biop 'xfx "=>" =>-tr op2=> <=>> a a)
(mk-prolog-biop 'xfx "←" -tr <=>> a a)
(define-syntax-rule (shr x y) (ash x (- y)))
(mk-scheme-dual 'yfx "|" tr-| | consx s s)
......
......@@ -201,7 +201,8 @@
(fy 900 "\\+")
,@(map (lambda (x) `(xfx 700 ,x))
'(<=
< = =.. =@= =:= =< == "=\\=" > >= @< @=< @> @>= "\\=" "\\==" is
< = =.. =@= =:= =< == <= =>
"=\\=" > >= @< @=< @> @>= "\\=" "\\==" is
))
(xfy 400 :)
,@(map (lambda (x) `(yfx 500 ,x)) '(+ - "/\\" "\\/" xor))
......@@ -233,7 +234,7 @@
(xfx 990 ":=")
(fy 900 "\\+")
,@(map (lambda (x) `(xfx 700 ,x))
'(< = =.. =@= "\\=@=" <=
'(< = =.. =@= "\\=@=" <= =>
=:= =< == "=\\=" > >= @< @=< @> @>= "\\=" "\\==" as is
))
(xfy 600 :)
......
......@@ -1562,7 +1562,9 @@ SCM_DEFINE(gp_pop_engine, "gp-pop-engine", 0, 0, 0, (),
gp_paths = scm_cons(gp_engine_path, gp_store_path);
scm_fluid_set_x(gp_current_stack, SCM_CDR(SCM_CAR(gp_engine_path)));
SCM e = SCM_CDR(SCM_CAR(gp_engine_path));
scm_fluid_set_x(gp_current_stack, e);
if(!SCM_CONSP(gp_engine_path))
scm_misc_error("gp-pop-engine","poped to an empty list",SCM_EOL);
......
......@@ -901,6 +901,7 @@ void vector_state(int state, SCM *old, SCM l, SCM vec)
SCM olde = scm_fluid_ref(gp_current_stack);
scm_fluid_set_x(gp_current_stack, e);
gp_newframe(s);
SCM r = scm_cons(gp_store_state(get_gp()),
scm_cons(e , s));
scm_fluid_set_x(gp_current_stack, olde);
......@@ -912,8 +913,8 @@ void vector_state(int state, SCM *old, SCM l, SCM vec)
scm_list_1(x));
}
scm_c_vector_set_x(xx,0 ,vec);
scm_c_vector_set_x(xx,1 ,u );
scm_c_vector_set_x(xx, 0, vec);
scm_c_vector_set_x(xx, 1, u );
SCM val = scm_cons(xx,SCM_EOL);
if(SCM_CONSP(*old))
SCM_SETCDR(*old,val);
......@@ -955,6 +956,8 @@ void unwind_in_new_branch(SCM p, SCM l, SCM path, SCM lpath)
{
SCM engine = SCM_CDR(p);
//printf("in new engine unwind: e = %p\n", (void *) SCM_UNPACK(engine));
scm_fluid_set_x(gp_current_stack, engine);
gp_unwind_(SCM_CAR(p), 0, 0, 0, path, lpath);
......@@ -993,27 +996,54 @@ static inline void gp_unwind_(SCM s , int ncons, int nvar, int nci,
if(SCM_CONSP(path))
{
SCM l = gp_engine_path;
SCM a = scm_reverse(l);
SCM b = scm_reverse(path);
SCM aa = a;
while(SCM_CONSP(a) && SCM_CONSP(b) && scm_is_eq(SCM_CAR(a),SCM_CAR(b)))
SCM b = SCM_EOL;
int na = scm_to_int(scm_length(l));
int nb = scm_to_int(scm_length(path));
while(na > nb)
{
if(SCM_CONSP(gp_store_path))
{
aa = a;
a = SCM_CDR(a);
b = SCM_CDR(b);
SCM ls = SCM_CAR(gp_store_path);
unwind_all_in_branch(ls);
gp_store_path = SCM_CDR(gp_store_path);
l = SCM_CDR(l);
na--;
}
else
scm_misc_error("gp-unwind","gp_store_path of wrong length",
SCM_EOL);
}
SCM a0 = SCM_CAR(aa);
SCM a = scm_reverse(l);
while(SCM_CONSP(l) && !scm_is_eq(SCM_CAR(l), a0))
while(nb > na)
{
SCM engine = SCM_CDAR(l);
gp_clear(SCM_BOOL_F);
scm_fluid_set_x(gp_current_stack, engine);
gp_engine_path = SCM_CDR(gp_engine_path);
b = scm_cons(SCM_CAR(path), b);
path = SCM_CDR(path);
nb--;
}
while(SCM_CONSP(l) && !scm_is_eq(SCM_CAR(l), SCM_CAR(path)))
{
if(SCM_CONSP(gp_store_path))
{
SCM ls = SCM_CAR(gp_store_path);
unwind_all_in_branch(ls);
gp_store_path = SCM_CDR(gp_store_path);
l = SCM_CDR(l);
na--;
}
else
scm_misc_error("gp-unwind","gp_store_path of wrong length",
SCM_EOL);
b = scm_cons(SCM_CAR(path), b);
path = SCM_CDR(path);
}
gp_engine_path = l;
scm_fluid_set_x(gp_current_stack, SCM_CDAR(l));
path = b;
......@@ -1462,25 +1492,20 @@ SCM_DEFINE(gp_gp_store_state, "gp-store-state", 1, 0, 0, (SCM s),
SCM k = gp_engine_path;
int first = 1;
printf("1\n");
while(SCM_CONSP(lpath))
for(;SCM_CONSP(lpath); lpath=SCM_CDR(lpath))
{
SCM l = SCM_CAR(lpath);
SCM ll = SCM_EOL;
SCM tag = SCM_CAR(k);
printf("a lpath\n");
k = SCM_CDR(k);
while(SCM_CONSP(l))
for(;SCM_CONSP(l);l = SCM_CDR(l))
{
SCM x = SCM_CAR(l);
printf("a state in lpath\n");
if(GP(x) && GP_UNBOUND(GP_GETREF(x)))
ll = scm_cons(SCM_BOOL_F, ll);
else
......@@ -1498,6 +1523,7 @@ SCM_DEFINE(gp_gp_store_state, "gp-store-state", 1, 0, 0, (SCM s),
SCM s = SCM_CAR(xx);
SCM olde = scm_fluid_ref(gp_current_stack);
scm_fluid_set_x(gp_current_stack, e);
gp_newframe(s);
SCM r = scm_cons(gp_store_state(get_gp()),
scm_cons(e , s));
scm_fluid_set_x(gp_current_stack, olde);
......@@ -1512,6 +1538,7 @@ SCM_DEFINE(gp_gp_store_state, "gp-store-state", 1, 0, 0, (SCM s),
gp_do_gc();
return scm_cons(gp_paths,
scm_cons(ret, llpath));
}
......@@ -1720,23 +1747,21 @@ static int gp_rewind(SCM pp, SCM pend, struct gp_stack *gp, SCM K)
gp->gp_ci[0] = scm_c_vector_ref(q,0);
gp->gp_ci ++;
sp--;
printf("1\n");
SCM l = scm_c_vector_ref(q,1);
for(;SCM_CONSP(l);l = SCM_CDR(l))
{
printf("11\n");
SCM dcont = SCM_CAR(l);
if(scm_is_false(dcont))
continue;
SCM olde = scm_fluid_ref(gp_current_stack);
printf("*\n");
scm_fluid_set_x(gp_current_stack, SCM_CADR(dcont));
struct gp_stack *gp2 = get_gp();
gp_restore_state(SCM_CAR(dcont), gp2, K);
scm_fluid_set_x(gp_current_stack, olde);
}
printf("2\n");
}
else
scm_misc_error("restore-state/ci rewinding",
"Got unhandle object ci -> ~%~a",
scm_list_1(q));
......@@ -2142,8 +2167,6 @@ SCM_DEFINE(gp_gp_restore_state, "gp-restore-state", 2, 0, 0, (SCM cont, SCM K),
{
gp_no_gc();
printf("restore 1\n");fflush(stdout);
// Unpack level 1
SCM paths = SCM_CAR(cont);
SCM pathsl = SCM_CDR(cont);
......@@ -2151,9 +2174,10 @@ SCM_DEFINE(gp_gp_restore_state, "gp-restore-state", 2, 0, 0, (SCM cont, SCM K),
SCM epath = SCM_CAR(paths);
SCM lpath = SCM_CDR(pathsl);
cont = SCM_CAR(pathsl);
printf("restore 2\n");fflush(stdout);
//First we clear the head of the states
/*
int ncur = scm_to_int(scm_length(gp_engine_path));
int nnew = scm_to_int(scm_length(epath));
printf("restore 3 %d %d\n",ncur,nnew);fflush(stdout);
......@@ -2200,18 +2224,19 @@ SCM_DEFINE(gp_gp_restore_state, "gp-restore-state", 2, 0, 0, (SCM cont, SCM K),
printf("restore 6 %d %d\n", ncur, scm_to_int(scm_length(lpath)));
fflush(stdout);
*/
printf("restore 7\n");fflush(stdout);
while(SCM_CONSP(lpath))
for(;SCM_CONSP(lpath); lpath = SCM_CDR(lpath))
{
SCM ll = SCM_CAR(lpath);
while(SCM_CONSP(ll))
for(;SCM_CONSP(ll); ll = SCM_CDR(ll))
{
SCM dcont = SCM_CAR(ll);
if(scm_is_false(dcont))
continue;
if(scm_is_eq(dcont, cont))
continue;
else
......@@ -2221,27 +2246,20 @@ SCM_DEFINE(gp_gp_restore_state, "gp-restore-state", 2, 0, 0, (SCM cont, SCM K),
gp_restore_state(SCM_CAR(dcont), gp, K);
}
}
lpath = SCM_CDR(lpath);
}
{
scm_fluid_set_x(gp_current_stack, SCM_CADR(cont));
struct gp_stack *gp = get_gp();
gp_restore_state(SCM_CAR(cont), gp, K);
struct gp_stack *gp2 = get_gp();
gp_restore_state(SCM_CAR(cont), gp2, K);
}
printf("restore 8\n");fflush(stdout);
gp_engine_path = epath;
gp_store_path = spath;
gp_paths = paths;
gp_do_gc();
printf("restore 9\n");fflush(stdout);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
......
......@@ -1268,7 +1268,7 @@ static inline SCM gp_newframe(SCM s)
}
if(scm_is_eq(l, SCM_UNBOUND))
l = SCM_EOL;
l = scm_cons(SCM_EOL, gp_paths);
{
SCM ret;
......@@ -1331,7 +1331,7 @@ static inline SCM gp_newframe_choice(SCM s)
}
if(scm_is_eq(l, SCM_UNBOUND))
l = scm_cons(SCM_EOL,gp_engine_path);
l = scm_cons(SCM_EOL,gp_paths);
{
SCM ret;
......
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