Old functionality untouched by engines

parent f7f826f3
......@@ -141,6 +141,11 @@
gp-make-struct
gp-set-struct
gp-pop-engine
gp-push-engine
gp-peek-engine
gp-combine-engines
))
;; Tos silence the compiler, those are fetched from the .so file
......
......@@ -16,13 +16,14 @@
(frame (<newframe>))
(p P)
(cc CC))
(<code> (gp-combine-engines data)
(<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))))))
(<with-fail> p <cc>)))))
......
......@@ -43,7 +43,7 @@ SCM make_logical()
return ret;
}
inline get_l(SCM l)
inline SCM get_l(SCM l)
{
return SCM_CAR(l);
}
......@@ -184,7 +184,7 @@ inline SCM logical_lookup3(SCM x, SCM l)
inline SCM logical_lookup_l(SCM x, SCM *l)
{
l = &(get_l(*l));
l = GP_GETREF(get_l(*l));
gp_debug0("logiacl l lookup\n");
if(!GP(x))
......
......@@ -1533,25 +1533,8 @@ SCM_DEFINE(gp_clear_frame, "gp-clear-frame", 0, 0, 0, (),
gp_do_gc();
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
......@@ -1567,11 +1550,10 @@ SCM_DEFINE(gp_pop_engine, "gp-pop-engine", 0, 0, 0, (),
gp_engine_path = SCM_CDR(gp_engine_path);
return s_stack;
return SCM_CAR(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
......@@ -1587,9 +1569,36 @@ SCM_DEFINE(gp_peek_engine, "gp-peek-engine", 0, 0, 0, (),
}
#undef FUNC_NAME
SCM_DEFINE(gp_combine_engines, "gp-combine-engines", 0, 0, 0, (SCM l),
SCM_DEFINE(gp_push_engine, "gp-push-engine", 2, 0, 0, (SCM s, SCM e),
"")
#define FUNC_NAME s_gp_peek_engine
#define FUNC_NAME s_gp_push_engine
{
SCM x = scm_cons(SCM_BOOL_F,e);
SCM car;
SCM cdr;
if(SCM_CONSP(s) || GP_CONSP(s))
{
car = gp_car(s,s);
cdr = gp_gp_cdr(s,s);
}
else
{
car = SCM_BOOL_F;
cdr = scm_cons(SCM_EOL,SCM_EOL);
}
SCM ss;
gp_engine_path = scm_cons(x , gp_engine_path);
ss = scm_cons(car, scm_cons(SCM_CAR(cdr), gp_engine_path));
SCM_SETCAR(x, ss);
return ss;
}
#undef FUNC_NAME
SCM_DEFINE(gp_combine_engines, "gp-combine-engines", 1, 0, 0, (SCM l),
"")
#define FUNC_NAME s_gp_combine_engine
{
SCM vec = scm_c_make_vector (1,l);
struct gp_stack * gp = get_gp();
......@@ -1599,6 +1608,6 @@ SCM_DEFINE(gp_combine_engines, "gp-combine-engines", 0, 0, 0, (SCM l),
gp->gp_ci[0] = vec;
gp->gp_ci++;
return ret;
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
......@@ -575,10 +575,16 @@ static void gp_unwind0(SCM *fr, SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp,
if(scm_is_false(*i))
continue;
/*
current_path => '((sk . ek) ... (s1 . ek))
path => '((s1' . ek) ... (sk* . ek*))
We assume that we cons unwind path onto current path
*/
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);
SCM p = SCM_CAR(path);
if(scm_is_false(p))
{
unwind_all_in_branch(l);
......@@ -588,22 +594,19 @@ static void gp_unwind0(SCM *fr, SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp,
int found = 0;
for(;SCM_CONSP(l);l=SCM_CDR(l))
{
if(scm_is_eq(SCM_CAR(l), p))
SCM x = gp_variable_ref(SCM_CAR(l));
if(scm_is_eq(x, p))
{
found = 1;
unwind_in_new_branch(p,SCM_CDR(path), lpath);
unwind_in_new_branch(p, SCM_CDR(path), lpath);
ci = i + 1;
break;
}
}
if(!found) unwind_all_in_branch(l);
}
}
while(SCM_CONSP(l))
{
SCM item = SCM_CAR(l);
}
}
if(!GP(*i))
{
// ------------- Rest case, just keep (handlers) sloppy version
......@@ -854,18 +857,25 @@ void unwind_all_in_branch(SCM l)
for(; SCM_CONSP(l); l = SCM_CDR(l))
{
SCM new_engine = SCM_CDAR(l);
SCM x = gp_variable_ref(SCM_CAR(l));
if(SCM_CONSP(x))
{
SCM new_engine = SCM_CDR(x);
scm_fluid_set_x(gp_current_stack, new_engine);
gp_clear();
gp_clear(SCM_BOOL_F);
}
}
scm_fluid_set_x(gp_current_stack, old_engine);
}
static inline void gp_unwind_(SCM s , int ncons, int nvar, int nci,
SCM path, SCM lpath);
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);
gp_engine_path = scm_cons(p, gp_engine_path);
scm_fluid_set_x(gp_current_stack, engine);
if(SCM_CONSP(path))
......@@ -874,31 +884,85 @@ void unwind_in_new_branch(SCM p, SCM path, SCM lpath)
}
else
{
gp_unwind_(SCM_CAR(p, 0, 0, 0, path, lpath);
gp_unwind_(SCM_CAR(p), 0, 0, 0, path, lpath);
}
}
static inline void gp_unwind_(SCM s , int ncons, int nvar, int nci,
/*
path = [bk, ..., a0, x, ...]
l = [ak, ..., a0, x, ...]
*/
static inline void gp_unwind_(SCM s , int ncons, int nvar, int nci,
SCM path, SCM lpath)
{
if(scm_is_false(path))
SCM lt = SCM_EOL;
if(scm_is_false(lpath))
{
lt = gp_gp_cdr(s,s);
if(SCM_CONSP(lt))
path = SCM_CDR(lt);
else
path = SCM_EOL;
path = gp_engine_path;
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)))
{
aa = a;
a = SCM_CDR(a);
b = SCM_CDR(b);
}
SCM a0 = SCM_CAR(aa);
while(SCM_CONSP(l) && !scm_is_eq(SCM_CAR(l), a0))
{
SCM engine = SCM_CDAR(l);
scm_fluid_set_x(gp_current_stack, engine);
gp_clear(SCM_BOOL_F);
l = SCM_CDR(l);
}
scm_fluid_set_x(gp_current_stack, SCM_CDAR(l));
path = b;
}
}
if(SCM_CONSP(path))
{
if(scm_bool_false(lpath))
lpath = scm_list_4(s,(SCM) ncons, (SCM) nvar, (SCM) nci);
s = SCM_CAAR(path);
if(scm_is_false(lpath))
lpath = scm_list_4(s,SCM_PACK((scm_t_bits) ncons),
SCM_PACK((scm_t_bits) nvar),
SCM_PACK((scm_t_bits) nci));
ncons = 0;
nvar = 0;
nci = 0;
}
else
{
if(scm_is_true(lpath))
{
s = SCM_CAR(lpath);
lpath = SCM_CDR(lpath);
ncons = (int) SCM_UNPACK(SCM_CAR(lpath));
lpath = SCM_CDR(lpath);
nvar = (int) SCM_UNPACK(SCM_CAR(lpath));
lpath = SCM_CDR(lpath);
nci = (int) SCM_UNPACK(SCM_CAR(lpath));
}
}
struct gp_stack *gp = get_gp();
SCM *fr, *ci,*si,*cs,lt;
SCM *fr, *ci,*si,*cs;
scm_t_bits dyn_n;
SCM ha, tag = SCM_EOL;
......@@ -996,6 +1060,7 @@ void inline falsify_entries(SCM *ci,struct gp_stack *gp)
// Use this functionto prune the control stack and also perhaps clear
// The stacks completely.
// Todo make this work for sub engines currently we do nothing between engines
static inline void gp_prune(SCM s, int tailp)
{
struct gp_stack *gp = get_gp();
......@@ -1006,6 +1071,14 @@ static inline void gp_prune(SCM s, int tailp)
{
tag = gp_car(gp_car(s, s),s);
lt = gp_gp_cdr(s,s);
if(SCM_CONSP(lt))
{
SCM pth = SCM_CDR(lt);
lt = SCM_CAR(lt);
if(!(SCM_CONSP(gp_engine_path) && SCM_CONSP(pth) &&
scm_is_eq(SCM_CAR(pth), SCM_CAR(gp_engine_path))))
return; // Between engines we do nothing
}
fr = gp->gp_frstack + GP_GET_SELF_TAG(tag);
if(vlist_p(lt))
{
......@@ -1064,7 +1137,8 @@ static inline void gp_prune(SCM s, int tailp)
gp_debug2("2 si> %x %x\n",si - gp->gp_stack,si - gp->gp_cons_stack);
gp_unwind0(fr - (tailp?GP_FRAMESIZE:0),ci, si, cs, gp);
gp_unwind0(fr - (tailp?GP_FRAMESIZE:0),ci, si, cs, gp,
SCM_BOOL_F, SCM_BOOL_F);
}
......@@ -1086,7 +1160,7 @@ static inline void gp_unwind_ncons(SCM fr, int ncons)
static inline void gp_unwind_tail(SCM fr)
{
gp_unwind_(fr,2,2,1, SCM_EOL, SCM_BOOL_F););
gp_unwind_(fr,2,2,1, SCM_EOL, SCM_BOOL_F);
//gp_unwind_(fr,0,0,0, SCM_EOL, SCM_BOOL_F););
}
......@@ -1806,7 +1880,7 @@ static void gp_restore_state(SCM data, struct gp_stack *gp, SCM K)
gp->gp_si - si,
gp->gp_cs - cs);
gp_unwind0(fr, ci, si, cs, gp);
gp_unwind0(fr, ci, si, cs, gp, SCM_BOOL_F, SCM_BOOL_F);
gp_debug0("scan ci stack\n");
......
......@@ -122,3 +122,8 @@ void init_variables()
#endif
}
SCM gp_variable_ref(SCM x)
{
return GP_GETREF(x)[1];
}
......@@ -105,6 +105,11 @@
code-to-int
gp-make-null-procedure
gp-push-engine
gp-peek-engine
gp-pop-engine
gp-combine-engines
)
......@@ -148,6 +153,7 @@
do-attribute-constructors
set-attribute-cstor!
attribute-cstor-repr
gp-make-engine
#;gp-unwind))
(define old (@ (logic guile-log code-load) gp-make-var))
......@@ -307,14 +313,18 @@
(define *states* #t)
(define (gp-make-engine n) (gp-make-stack 0 0 n n n n))
(define-named-object *gp* (gp-current-stack-ref))
(fluid-set! *gp* (gp-make-stack 0 0 5000000 5000000 5000000 1000000))
(define root-engine (gp-make-stack 0 0 5000000 5000000 5000000 1000000))
(fluid-set! *gp* root-engine)
(define *current-stack* (make-fluid '()))
((@@(logic guile-log code-load) gp-set-current-stack) *current-stack*)
(gp-clear 1)
(fluid-set! *current-stack* (gp-push-engine (fluid-ref *current-stack*)
root-engine))
;(fluid-set! *current-stack*
(define (gp-var-set! v val)
((@ (logic guile-log code-load) gp-var-set!)
......
......@@ -70,6 +70,11 @@
(()
(cont)))))
(define-syntax-rule (let-lookup (a ...) code ...)
(lambda (s p cc)
(let ((a (lookup s a)) ...)
((all code ...) s p cc))))
(define-syntax-rule (fresh (v ...) f ...)
(let ((v (make-variable #f)) ...)
(all f ...)))
......@@ -214,6 +219,7 @@
(define false (lambda (s p cc) (p)))
(define (== x y)
(let-lookup (x y)
(match (cons x y)
(((x1 . y1) . (x2 . y2))
(all
......@@ -230,7 +236,7 @@
(bind y x)
(if (eqv? x y)
true
false))))))
false)))))))
(define-syntax-rule (wrap f) (lambda (s p cc) (f s p cc)))
......
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