poping and pushing engines and paralell and

parent 91974c50
(define-module (logic guile-log parallel)
#:use-module (logic guile-log)
#:export (<pand>))
(<define-guile-log-rule> (<pit> cc code ...)
(<let> ((cc-internal
(lambda (s p)
(set! cc-internal cc)
(CC s p))))
(<with-cc> cc-internal code ...)))
(<define-guile-log-rule> (<pand> (v engine code ...) ...)
(<var> (v ...)
(<let> ((data (list v ...))
(frame (<newframe>))
(p P)
(cc CC))
(<pit> cc
(<with-p> p
(<with-s> (gp-push-engine frame engine)
code
(<=> v ,(gp-pop-engine)))))
...
(<with-fail> p (<code> (gp-combine-engines data))))))
...@@ -43,9 +43,14 @@ SCM make_logical() ...@@ -43,9 +43,14 @@ SCM make_logical()
return ret; return ret;
} }
inline get_l(SCM l)
{
return SCM_CAR(l);
}
inline SCM logical_lookup(SCM x, SCM l) inline SCM logical_lookup(SCM x, SCM l)
{ {
SCM s = l; SCM s = get_l(l);
/* /*
{ {
//new tree code here //new tree code here
...@@ -108,7 +113,7 @@ inline SCM logical_lookup2(SCM x, SCM l) ...@@ -108,7 +113,7 @@ inline SCM logical_lookup2(SCM x, SCM l)
goto retry_tree; goto retry_tree;
} }
*/ */
SCM s = l; SCM s = get_l(l);
retry: retry:
if(!GP(x)) if(!GP(x))
...@@ -143,6 +148,8 @@ retry: ...@@ -143,6 +148,8 @@ retry:
inline SCM logical_lookup3(SCM x, SCM l) inline SCM logical_lookup3(SCM x, SCM l)
{ {
l = get_l(l);
if(!GP(x)) if(!GP(x))
return x; return x;
...@@ -177,6 +184,8 @@ inline SCM logical_lookup3(SCM x, SCM l) ...@@ -177,6 +184,8 @@ inline SCM logical_lookup3(SCM x, SCM l)
inline SCM logical_lookup_l(SCM x, SCM *l) inline SCM logical_lookup_l(SCM x, SCM *l)
{ {
l = &(get_l(*l));
gp_debug0("logiacl l lookup\n"); gp_debug0("logiacl l lookup\n");
if(!GP(x)) if(!GP(x))
return x; return x;
...@@ -213,6 +222,8 @@ inline SCM logical_lookup_l(SCM x, SCM *l) ...@@ -213,6 +222,8 @@ inline SCM logical_lookup_l(SCM x, SCM *l)
inline SCM logical_lookup4(SCM x, SCM l) inline SCM logical_lookup4(SCM x, SCM l)
{ {
l = get_l(l);
if(!GP(x)) if(!GP(x))
return x; return x;
...@@ -239,8 +250,9 @@ inline SCM logical_lookup4(SCM x, SCM l) ...@@ -239,8 +250,9 @@ inline SCM logical_lookup4(SCM x, SCM l)
return x; return x;
} }
SCM inline logical_add(SCM x, SCM v, SCM l) SCM inline logical_add(SCM x, SCM v, SCM ll)
{ {
SCM l = get_l(ll);
/* /*
{ {
//new tree code comes in here //new tree code comes in here
...@@ -252,14 +264,16 @@ SCM inline logical_add(SCM x, SCM v, SCM l) ...@@ -252,14 +264,16 @@ SCM inline logical_add(SCM x, SCM v, SCM l)
} }
*/ */
return scm_cons(scm_cons(x,v),l); return scm_cons(scm_cons(scm_cons(x,v),l),SCM_CDR(ll));
} }
SCM inline logical_add2(SCM x, SCM v, SCM l) SCM inline logical_add2(SCM x, SCM v, SCM ll)
{ {
if(scm_is_eq(x,v)) if(scm_is_eq(x,v))
return l; return ll;
SCM l = SCM_CAR(ll);
if(SCM_CONSP(l) || SCM_NULLP(l)) if(SCM_CONSP(l) || SCM_NULLP(l))
{ {
int n;SCM pt; int n;SCM pt;
...@@ -279,20 +293,22 @@ SCM inline logical_add2(SCM x, SCM v, SCM l) ...@@ -279,20 +293,22 @@ SCM inline logical_add2(SCM x, SCM v, SCM l)
scm_fluid_set_x(init_block_size, val); scm_fluid_set_x(init_block_size, val);
return l; return scm_cons(l, SCM_CDR(ll));
} }
else else
return scm_cons(scm_cons(x,v),l); return scm_cons(scm_cons(scm_cons(x,v),l),SCM_CDR(ll));
} }
return vhash_consq_unify(x, v, l); return scm_cons(vhash_consq_unify(x, v, l), SCM_CDR(ll));
} }
SCM inline logical_add2_l(SCM x, SCM v, SCM *l) SCM inline logical_add2_l(SCM x, SCM v, SCM *ll)
{ {
if(scm_is_eq(x,v)) if(scm_is_eq(x,v))
return SCM_BOOL_T; return SCM_BOOL_T;
SCM *l = &(SCM_CAR(*ll));
if(SCM_CONSP(*l) || SCM_NULLP(*l)) if(SCM_CONSP(*l) || SCM_NULLP(*l))
{ {
int n;SCM pt; int n;SCM pt;
......
...@@ -1533,5 +1533,72 @@ SCM_DEFINE(gp_clear_frame, "gp-clear-frame", 0, 0, 0, (), ...@@ -1533,5 +1533,72 @@ SCM_DEFINE(gp_clear_frame, "gp-clear-frame", 0, 0, 0, (),
gp_do_gc(); gp_do_gc();
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }
#undef FUNC_NAME
SCM_DEFINE(gp_push_engine, "gp-push-engine", 0, 0, 0, (SCM frame, SCM new_engine),
"")
#define FUNC_NAME s_gp_push_engine
{
SCM old_engine = scm_fluid_ref(gp_current_stack);
SCM p = scm_cons(frame, old_engine);
gp_engine_path = scm_cons(p, gp_engine_path);
scm_fluid_set_x(gp_current_stack, new_engine);
return scm_cons(SCM_EOL, scm_cons(SCM_EOL, p));
}
#undef FUNC_NAME
#undef FUNC_NAME
SCM_DEFINE(gp_pop_engine, "gp-pop-engine", 0, 0, 0, (),
"")
#define FUNC_NAME s_gp_pop_engine
{
if(!SCM_CONSP(gp_engine_path))
{
return SCM_BOOL_F;
}
SCM s_stack = SCM_CAR(gp_engine_path);
scm_fluid_set_x(gp_current_stack, SCM_CDR(s_stack));
gp_engine_path = SCM_CDR(gp_engine_path);
return s_stack;
}
#undef FUNC_NAME
#undef FUNC_NAME
SCM_DEFINE(gp_peek_engine, "gp-peek-engine", 0, 0, 0, (),
"")
#define FUNC_NAME s_gp_peek_engine
{
if(!SCM_CONSP(gp_engine_path))
{
return SCM_BOOL_F;
}
SCM ret = SCM_CAR(gp_engine_path);
return ret;
}
#undef FUNC_NAME #undef FUNC_NAME
SCM_DEFINE(gp_combine_engines, "gp-combine-engines", 0, 0, 0, (SCM l),
"")
#define FUNC_NAME s_gp_peek_engine
{
SCM vec = scm_c_make_vector (1,l);
struct gp_stack * gp = get_gp();
GP_TEST_CSTACK;
gp->gp_ci[0] = vec;
gp->gp_ci++;
return ret;
}
#undef FUNC_NAME
...@@ -389,9 +389,12 @@ static inline int gp_do_cons(SCM item, int state, SCM *old, SCM gp_unbd) ...@@ -389,9 +389,12 @@ static inline int gp_do_cons(SCM item, int state, SCM *old, SCM gp_unbd)
} \ } \
} }
void unwind_all_in_branch(SCM l);
void unwind_in_new_branch(SCM p,SCM path, SCM lpath);
SCM unwind_hooks = SCM_BOOL_F; SCM unwind_hooks = SCM_BOOL_F;
//#define DB(X) X //#define DB(X) X
static void gp_unwind0(SCM *fr, SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp) static void gp_unwind0(SCM *fr, SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp, SCM path, SCM lpath)
{ {
SCM val, old = SCM_EOL; SCM val, old = SCM_EOL;
SCM *i, *fr_old, *ci_old, *id; SCM *i, *fr_old, *ci_old, *id;
...@@ -567,14 +570,42 @@ static void gp_unwind0(SCM *fr, SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp) ...@@ -567,14 +570,42 @@ static void gp_unwind0(SCM *fr, SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp)
MASK_OFF_CI(); MASK_OFF_CI();
*i = SCM_BOOL_F; *i = SCM_BOOL_F;
continue; continue;
} }
if(scm_is_false(*i)) if(scm_is_false(*i))
continue; continue;
if(SCM_I_IS_VECTOR(*i))
{
SCM l = SCM_SIMPLE_VECTOR_REF(*i,0);
SCM p = SCM_EOL(path) ? SCM_BOOL_F : SCM_CAR(path);
if(scm_is_false(p))
{
unwind_all_in_branch(l);
}
else
{
int found = 0;
for(;SCM_CONSP(l);l=SCM_CDR(l))
{
if(scm_is_eq(SCM_CAR(l), p))
{
found = 1;
unwind_in_new_branch(p,SCM_CDR(path), lpath);
}
}
if(!found) unwind_all_in_branch(l);
}
}
while(SCM_CONSP(l))
{
SCM item = SCM_CAR(l);
}
}
if(!GP(*i)) if(!GP(*i))
{ {
// ------------- Rest case, just keep (handlers) sloppy version // ------------- Rest case, just keep (handlers) sloppy version
// //
...@@ -817,8 +848,55 @@ static void gp_unwind0(SCM *fr, SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp) ...@@ -817,8 +848,55 @@ static void gp_unwind0(SCM *fr, SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp)
} }
//#define DB(X) //#define DB(X)
static inline void gp_unwind_(SCM s, int ncons, int nvar, int nci) void unwind_all_in_branch(SCM l)
{
SCM old_engine = scm_fluid_ref(gp_current_stack);
for(; SCM_CONSP(l); l = SCM_CDR(l))
{
SCM new_engine = SCM_CDAR(l);
scm_fluid_set_x(gp_current_stack, new_engine);
gp_clear();
}
scm_fluid_set_x(gp_current_stack, old_engine);
}
void unwind_in_new_branch(SCM p, SCM path, SCM lpath)
{
SCM engine = SCM_CDR(p);
SCM gp_engine_path = scm_cons(p, gp_engine_path);
scm_fluid_set_x(gp_current_stack, engine);
if(SCM_CONSP(path))
{
gp_unwind_(SCM_CAR(p), 0, 0, 0, path, lpath);
}
else
{
gp_unwind_(SCM_CAR(p, 0, 0, 0, path, lpath);
}
}
static inline void gp_unwind_(SCM s , int ncons, int nvar, int nci,
SCM path, SCM lpath)
{ {
if(scm_is_false(path))
{
lt = gp_gp_cdr(s,s);
if(SCM_CONSP(lt))
path = SCM_CDR(lt);
else
path = SCM_EOL;
}
if(SCM_CONSP(path))
{
if(scm_bool_false(lpath))
lpath = scm_list_4(s,(SCM) ncons, (SCM) nvar, (SCM) nci);
s = SCM_CAAR(path);
}
struct gp_stack *gp = get_gp(); struct gp_stack *gp = get_gp();
SCM *fr, *ci,*si,*cs,lt; SCM *fr, *ci,*si,*cs,lt;
scm_t_bits dyn_n; scm_t_bits dyn_n;
...@@ -826,13 +904,24 @@ static inline void gp_unwind_(SCM s, int ncons, int nvar, int nci) ...@@ -826,13 +904,24 @@ static inline void gp_unwind_(SCM s, int ncons, int nvar, int nci)
if(GP_CONSP(s) || SCM_CONSP(s)) if(GP_CONSP(s) || SCM_CONSP(s))
{ {
tag = gp_car(gp_car(s, s),s); SCM cars = gp_car(s, s);
lt = gp_gp_cdr(s,s); if(GP_CONSP(cars) || SCM_CONSP(cars))
fr = gp->gp_frstack + GP_GET_SELF_TAG(tag); {
if(vlist_p(lt)) tag = gp_car(cars,s);
{ lt = gp_gp_cdr(s,s);
vhash_truncate_x(lt); if(SCM_CONSP(lt))
} lt = SCM_CAR(lt);
fr = gp->gp_frstack + GP_GET_SELF_TAG(tag);
if(vlist_p(lt))
{
vhash_truncate_x(lt);
}
}
else
{
fr = gp->gp_fr;
}
} }
else else
{ {
...@@ -868,18 +957,18 @@ static inline void gp_unwind_(SCM s, int ncons, int nvar, int nci) ...@@ -868,18 +957,18 @@ static inline void gp_unwind_(SCM s, int ncons, int nvar, int nci)
si = gp->gp_stack + GP_GET_VAR(fr) - nvar; si = gp->gp_stack + GP_GET_VAR(fr) - nvar;
cs = gp->gp_cons_stack + GP_GET_CONS(fr) - ncons; cs = gp->gp_cons_stack + GP_GET_CONS(fr) - ncons;
gp_debug2("cs> %x %x\n",cs - gp->gp_stack,cs - gp->gp_cons_stack); gp_debug2("cs> %x %x\n",cs - gp->gp_stack,cs - gp->gp_cons_stack);
gp_debug2("si> %x %x\n",si - gp->gp_stack,si - gp->gp_cons_stack); gp_debug2("si> %x %x\n",si - gp->gp_stack,si - gp->gp_cons_stack);
gp->handlers = ha; gp->handlers = ha;
gp_unwind0(fr - GP_FRAMESIZE*nci,ci, si, cs, gp);
gp_unwind_dynstack(gp, dyn_n); gp_unwind_dynstack(gp, dyn_n);
gp_unwind0(fr - GP_FRAMESIZE*nci,ci, si, cs, gp, path, lpath);
gp->handlers = ha; gp->handlers = ha;
gp_debug0("leaving unwind\n"); gp_debug0("leaving unwind\n");
} }
...@@ -981,7 +1070,7 @@ static inline void gp_prune(SCM s, int tailp) ...@@ -981,7 +1070,7 @@ static inline void gp_prune(SCM s, int tailp)
static inline void gp_unwind(SCM fr) static inline void gp_unwind(SCM fr)
{ {
gp_unwind_(fr,0,0,0); gp_unwind_(fr,0,0,0, SCM_EOL, SCM_BOOL_F);
} }
static inline void gp_unwind_soft(int ncons) static inline void gp_unwind_soft(int ncons)
...@@ -992,13 +1081,13 @@ static inline void gp_unwind_soft(int ncons) ...@@ -992,13 +1081,13 @@ static inline void gp_unwind_soft(int ncons)
static inline void gp_unwind_ncons(SCM fr, int ncons) static inline void gp_unwind_ncons(SCM fr, int ncons)
{ {
gp_unwind_(fr,-ncons,0,0); gp_unwind_(fr,-ncons,0,0, SCM_EOL, SCM_BOOL_F);
} }
static inline void gp_unwind_tail(SCM fr) static inline void gp_unwind_tail(SCM fr)
{ {
gp_unwind_(fr,2,2,1); gp_unwind_(fr,2,2,1, SCM_EOL, SCM_BOOL_F););
//gp_unwind_(fr,0,0,0); //gp_unwind_(fr,0,0,0, SCM_EOL, SCM_BOOL_F););
} }
SCM_DEFINE(gp_gp_unwind, "gp-unwind", 1, 0, 0, (SCM fr), SCM_DEFINE(gp_gp_unwind, "gp-unwind", 1, 0, 0, (SCM fr),
......
...@@ -30,6 +30,8 @@ SCM tester = SCM_BOOL_F; ...@@ -30,6 +30,8 @@ SCM tester = SCM_BOOL_F;
SCM inline get_cs(SCM v); SCM inline get_cs(SCM v);
SCM gp_engine_path = SCM_EOL;
SCM gp_current_stack = SCM_BOOL_F; SCM gp_current_stack = SCM_BOOL_F;
int do_gp_mark = 1; int do_gp_mark = 1;
......
...@@ -161,6 +161,10 @@ SCM_API SCM gp_code_to_int(SCM x); ...@@ -161,6 +161,10 @@ SCM_API SCM gp_code_to_int(SCM x);
SCM_API SCM gp_make_null_procedure(SCM n, SCM def); SCM_API SCM gp_make_null_procedure(SCM n, SCM def);
SCM_API SCM gp_fill_null_procedure(SCM proc, SCM addr, SCM l); SCM_API SCM gp_fill_null_procedure(SCM proc, SCM addr, SCM l);
SCM_API SCM gp_push_engine(SCM s, SCM engine);
SCM_API SCM gp_pop_engine();
SCM_API SCM gp_peek_engine();
SCM_API SCM gp_combine_engines(SCM l);
SCM_API SCM gp_set_struct(SCM a, SCM b); SCM_API SCM gp_set_struct(SCM a, SCM b);
SCM_API SCM gp_make_struct(SCM a, SCM b); SCM_API SCM gp_make_struct(SCM a, SCM b);
SCM_API SCM gp_custom_fkn(SCM custom_vm_fkn, SCM a, SCM b); SCM_API SCM gp_custom_fkn(SCM custom_vm_fkn, SCM a, SCM b);
......
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