Old functionality untouched by engines

parent f7f826f3
...@@ -141,6 +141,11 @@ ...@@ -141,6 +141,11 @@
gp-make-struct gp-make-struct
gp-set-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 ;; Tos silence the compiler, those are fetched from the .so file
......
...@@ -16,13 +16,14 @@ ...@@ -16,13 +16,14 @@
(frame (<newframe>)) (frame (<newframe>))
(p P) (p P)
(cc CC)) (cc CC))
(<code> (gp-combine-engines data)
(<pit> cc (<pit> cc
(<with-p> p (<with-p> p
(<with-s> (gp-push-engine frame engine) (<with-s> (gp-push-engine frame engine)
code code
(<=> v ,(gp-pop-engine))))) (<=> v ,(gp-pop-engine)))))
... ...
(<with-fail> p (<code> (gp-combine-engines data)))))) (<with-fail> p <cc>)))))
......
...@@ -43,7 +43,7 @@ SCM make_logical() ...@@ -43,7 +43,7 @@ SCM make_logical()
return ret; return ret;
} }
inline get_l(SCM l) inline SCM get_l(SCM l)
{ {
return SCM_CAR(l); return SCM_CAR(l);
} }
...@@ -184,7 +184,7 @@ inline SCM logical_lookup3(SCM x, SCM l) ...@@ -184,7 +184,7 @@ 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)); l = GP_GETREF(get_l(*l));
gp_debug0("logiacl l lookup\n"); gp_debug0("logiacl l lookup\n");
if(!GP(x)) if(!GP(x))
......
...@@ -1533,25 +1533,8 @@ SCM_DEFINE(gp_clear_frame, "gp-clear-frame", 0, 0, 0, (), ...@@ -1533,25 +1533,8 @@ 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
#undef FUNC_NAME
SCM_DEFINE(gp_pop_engine, "gp-pop-engine", 0, 0, 0, (), SCM_DEFINE(gp_pop_engine, "gp-pop-engine", 0, 0, 0, (),
"") "")
#define FUNC_NAME s_gp_pop_engine #define FUNC_NAME s_gp_pop_engine
...@@ -1567,11 +1550,10 @@ SCM_DEFINE(gp_pop_engine, "gp-pop-engine", 0, 0, 0, (), ...@@ -1567,11 +1550,10 @@ SCM_DEFINE(gp_pop_engine, "gp-pop-engine", 0, 0, 0, (),
gp_engine_path = SCM_CDR(gp_engine_path); gp_engine_path = SCM_CDR(gp_engine_path);
return s_stack; return SCM_CAR(s_stack);
} }
#undef FUNC_NAME #undef FUNC_NAME
#undef FUNC_NAME
SCM_DEFINE(gp_peek_engine, "gp-peek-engine", 0, 0, 0, (), SCM_DEFINE(gp_peek_engine, "gp-peek-engine", 0, 0, 0, (),
"") "")
#define FUNC_NAME s_gp_peek_engine #define FUNC_NAME s_gp_peek_engine
...@@ -1587,9 +1569,36 @@ SCM_DEFINE(gp_peek_engine, "gp-peek-engine", 0, 0, 0, (), ...@@ -1587,9 +1569,36 @@ SCM_DEFINE(gp_peek_engine, "gp-peek-engine", 0, 0, 0, (),
} }
#undef FUNC_NAME #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); SCM vec = scm_c_make_vector (1,l);
struct gp_stack * gp = get_gp(); struct gp_stack * gp = get_gp();
...@@ -1599,6 +1608,6 @@ SCM_DEFINE(gp_combine_engines, "gp-combine-engines", 0, 0, 0, (SCM l), ...@@ -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[0] = vec;
gp->gp_ci++; gp->gp_ci++;
return ret; return SCM_UNSPECIFIED;
} }
#undef FUNC_NAME #undef FUNC_NAME
...@@ -575,32 +575,35 @@ static void gp_unwind0(SCM *fr, SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp, ...@@ -575,32 +575,35 @@ static void gp_unwind0(SCM *fr, SCM *ci, SCM *si, SCM *cs, struct gp_stack *gp,
if(scm_is_false(*i)) if(scm_is_false(*i))
continue; 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)) if(SCM_I_IS_VECTOR(*i))
{ {
SCM l = SCM_SIMPLE_VECTOR_REF(*i,0); 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)) if(scm_is_false(p))
{ {
unwind_all_in_branch(l); unwind_all_in_branch(l);
} }
else else
{ {
int found = 0; int found = 0;
for(;SCM_CONSP(l);l=SCM_CDR(l)) 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; 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); if(!found) unwind_all_in_branch(l);
}
}
while(SCM_CONSP(l))
{
SCM item = SCM_CAR(l);
} }
} }
...@@ -854,18 +857,25 @@ void unwind_all_in_branch(SCM l) ...@@ -854,18 +857,25 @@ void unwind_all_in_branch(SCM l)
for(; SCM_CONSP(l); l = SCM_CDR(l)) for(; SCM_CONSP(l); l = SCM_CDR(l))
{ {
SCM new_engine = SCM_CDAR(l); SCM x = gp_variable_ref(SCM_CAR(l));
scm_fluid_set_x(gp_current_stack, new_engine); if(SCM_CONSP(x))
gp_clear(); {
SCM new_engine = SCM_CDR(x);
scm_fluid_set_x(gp_current_stack, new_engine);
gp_clear(SCM_BOOL_F);
}
} }
scm_fluid_set_x(gp_current_stack, old_engine); 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) void unwind_in_new_branch(SCM p, SCM path, SCM lpath)
{ {
SCM engine = SCM_CDR(p); 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); scm_fluid_set_x(gp_current_stack, engine);
if(SCM_CONSP(path)) if(SCM_CONSP(path))
...@@ -874,31 +884,85 @@ void unwind_in_new_branch(SCM p, SCM path, SCM lpath) ...@@ -874,31 +884,85 @@ void unwind_in_new_branch(SCM p, SCM path, SCM lpath)
} }
else 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, /*
SCM path, SCM lpath) 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); lt = gp_gp_cdr(s,s);
if(SCM_CONSP(lt)) if(SCM_CONSP(lt))
path = SCM_CDR(lt); path = SCM_CDR(lt);
else 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_CONSP(path))
{ {
if(scm_bool_false(lpath))
lpath = scm_list_4(s,(SCM) ncons, (SCM) nvar, (SCM) nci);
s = SCM_CAAR(path); 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(); struct gp_stack *gp = get_gp();
SCM *fr, *ci,*si,*cs,lt; SCM *fr, *ci,*si,*cs;
scm_t_bits dyn_n; scm_t_bits dyn_n;
SCM ha, tag = SCM_EOL; SCM ha, tag = SCM_EOL;
...@@ -996,6 +1060,7 @@ void inline falsify_entries(SCM *ci,struct gp_stack *gp) ...@@ -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 // Use this functionto prune the control stack and also perhaps clear
// The stacks completely. // 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) static inline void gp_prune(SCM s, int tailp)
{ {
struct gp_stack *gp = get_gp(); struct gp_stack *gp = get_gp();
...@@ -1006,6 +1071,14 @@ static inline void gp_prune(SCM s, int tailp) ...@@ -1006,6 +1071,14 @@ static inline void gp_prune(SCM s, int tailp)
{ {
tag = gp_car(gp_car(s, s),s); tag = gp_car(gp_car(s, s),s);
lt = gp_gp_cdr(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); fr = gp->gp_frstack + GP_GET_SELF_TAG(tag);
if(vlist_p(lt)) if(vlist_p(lt))
{ {
...@@ -1064,7 +1137,8 @@ static inline void gp_prune(SCM s, int tailp) ...@@ -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_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) ...@@ -1086,7 +1160,7 @@ static inline void gp_unwind_ncons(SCM fr, int ncons)
static inline void gp_unwind_tail(SCM fr) 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);); //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) ...@@ -1806,7 +1880,7 @@ static void gp_restore_state(SCM data, struct gp_stack *gp, SCM K)
gp->gp_si - si, gp->gp_si - si,
gp->gp_cs - cs); 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"); gp_debug0("scan ci stack\n");
......
...@@ -122,3 +122,8 @@ void init_variables() ...@@ -122,3 +122,8 @@ void init_variables()
#endif #endif
} }
SCM gp_variable_ref(SCM x)
{
return GP_GETREF(x)[1];
}
...@@ -105,6 +105,11 @@ ...@@ -105,6 +105,11 @@
code-to-int code-to-int
gp-make-null-procedure gp-make-null-procedure
gp-push-engine
gp-peek-engine
gp-pop-engine
gp-combine-engines
) )
...@@ -147,7 +152,8 @@ ...@@ -147,7 +152,8 @@
ref-attribute-constructors ref-attribute-constructors
do-attribute-constructors do-attribute-constructors
set-attribute-cstor! set-attribute-cstor!
attribute-cstor-repr attribute-cstor-repr
gp-make-engine
#;gp-unwind)) #;gp-unwind))
(define old (@ (logic guile-log code-load) gp-make-var)) (define old (@ (logic guile-log code-load) gp-make-var))
...@@ -307,14 +313,18 @@ ...@@ -307,14 +313,18 @@
(define *states* #t) (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)) (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 '())) (define *current-stack* (make-fluid '()))
((@@(logic guile-log code-load) gp-set-current-stack) *current-stack*) ((@@(logic guile-log code-load) gp-set-current-stack) *current-stack*)
(gp-clear 1) (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) (define (gp-var-set! v val)
((@ (logic guile-log code-load) gp-var-set!) ((@ (logic guile-log code-load) gp-var-set!)
......
...@@ -70,6 +70,11 @@ ...@@ -70,6 +70,11 @@
(() (()
(cont))))) (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 ...) (define-syntax-rule (fresh (v ...) f ...)
(let ((v (make-variable #f)) ...) (let ((v (make-variable #f)) ...)
(all f ...))) (all f ...)))
...@@ -214,23 +219,24 @@ ...@@ -214,23 +219,24 @@
(define false (lambda (s p cc) (p))) (define false (lambda (s p cc) (p)))
(define (== x y) (define (== x y)
(match (cons x y) (let-lookup (x y)
(((x1 . y1) . (x2 . y2)) (match (cons x y)
(all (((x1 . y1) . (x2 . y2))
(== x1 x2) (all
(== y1 y2))) (== x1 x2)
(== y1 y2)))
((#(a ...) . #(b ...))
(== a b)) ((#(a ...) . #(b ...))
(== a b))
(_
(if (variable? x) (_
(bind x y) (if (variable? x)
(if (variable? y) (bind x y)
(bind y x) (if (variable? y)
(if (eqv? x y) (bind y x)
true (if (eqv? x y)
false)))))) true
false)))))))
(define-syntax-rule (wrap f) (lambda (s p cc) (f s p cc))) (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