added support for fast und/redo safe variables and parameters

parent a72f0bf7
......@@ -73,8 +73,8 @@
(define (gp-pair* x s)
(if (pair? x)
(values (car x s)
(cdr x s)
(values (car x)
(cdr x)
s)
(values #f #f #f)))
......
......@@ -28,6 +28,156 @@ SCM inline get_cs(SCM v)
return v;
}
SCM safe_fluid_fluid = SCM_BOOL_F;
SCM safe_variable_fluid = SCM_BOOL_F;
SCM_DEFINE(gp_safe_fluid_fluid_ref, "gp-safe-fluid-fluid-ref", 0, 0, 0, ()
,"")
#define FUNC_NAME s_gp_safe_fluid_fluid-ref
{
return safe_fluid_fluid;
}
#undef FUNC_NAME
SCM_DEFINE(gp_safe_variable_fluid_ref, "gp-safe-variable-fluid-ref", 0, 0, 0, ()
,"")
#define FUNC_NAME s_gp_safe_variable_fluid-ref
{
return safe_variable_fluid;
}
#undef FUNC_NAME
int redo_safe_fluid_guard(SCM kind)
{
SCM x;
if(scm_is_eq(kind, SCM_BOOL_T)) return 1;
if(scm_is_eq(kind, SCM_BOOL_F)) return 0;
x = scm_fluid_ref(safe_fluid_fluid);
if(scm_is_eq(x, SCM_BOOL_T)) return 1;
if(scm_is_eq(x, SCM_BOOL_F)) return 0;
if(SCM_I_INUMP(x) && SCM_I_NUMP(kind))
return SCM_I_INUM(x) < SCM_I_INUM(kind);
return scm_is_true (scm_call_1(x, kind));
}
int redo_safe_variable_guard(SCM kind)
{
SCM x;
if(scm_is_eq(kind, SCM_BOOL_T)) return 1;
if(scm_is_eq(kind, SCM_BOOL_F)) return 0;
x = scm_fluid_ref(safe_variable_fluid);
if(scm_is_eq(x, SCM_BOOL_T)) return 1;
if(scm_is_eq(x, SCM_BOOL_F)) return 0;
if(SCM_I_INUMP(x))
{
if(SCM_I_NUMP(kind))
return SCM_I_INUM(x) < SCM_I_INUM(kind);
else
return 0;
}
return scm_is_true (scm_call_1(x, kind));
}
SCM_DEFINE(undo_safe_parameter_guard, "gp-undo-safe-parameter-guard", 4, 0, 0,
(SCM var, SCM val, SCM kind, SCM s),
"")
#define FUNC_NAME s_safe_parameter_guard
{
SCM *id,l,uw,ret,ggp;
struct gp_stack *gp;
UNPACK_ALL(uw,l,ggp,gp,s,"failed to unpack s in ggp_set");
if(GP(var))
{
SCM* id = GP_GETREF(var);
SCM v1 = SCM_I_MAKINUM(id[0]);
SCM v2 = id[1];
SCM* ci = gp->gp_ci;
ggp_set(var, val, s);
gp->gp_ci = ci;
SCM q = SCM_CONS(kind,
SCM_CONS(var,
SCM_CONS(v1,
SCM_CONS(v2,
SCM_CONS(SCM_I_MAKINUM(id[0]), id[1])))));
gp->gp_ci[0] = q;
gp->gp_ci ++;
return q;
}
scm_misc_error("undo_safe_parameter_guard", "argument 1 must be a gp var, got ~a", scm_list_1(var));
return SCM_BOOL_F;
}
#undef FUNC_NAME
SCM_DEFINE(undo_safe_variable_guard, "gp-undo-safe-variable-guard", 3, 0, 0,
(SCM var, SCM kind, SCM s),
"")
#define FUNC_NAME s_safe_variable_guard
{
SCM *id,l,uw,ret,ggp;
struct gp_stack *gp;
UNPACK_ALL(uw,l,ggp,gp,s,"failed to unpack s in undo_safe_variable_guard");
if(SCM_VARIABLE_P (var))
{
SCM q = SCM_CONS(kind, SCM_CONS(var, SCM_VARIABLE_REF(var)));
gp->gp_ci[0] = q;
gp->gp_ci ++;
return q;
}
scm_misc_error("undo_safe_variable_guard", "argument 1 must be a variable, got ~a", scm_list_1(var));
return SCM_BOOL_F;
}
#undef FUNC_NAME
static SCM inline do_nongp(int state, SCM item)
{
SCM cdr = SCM_CDR(item);
if(SCM_CONSP(cdr))
{
SCM p = SCM_CAR(cdr);
if(GP(p))
{
SCM cdr1 = SCM_CDR(cdr);
SCM v1 = SCM_CAR(cdr);
SCM cdr2 = SCM_CDR(cdr1);
SCM v2 = SCM_CAR(cdr2);
SCM *id = GP_GETREF(p);
// A swap
SCM_SETCAR(cdr1, SCM_I_MAKINUM(id[0]));
SCM_SETCAR(cdr2, id[1]);
id[0] = SCM_PACK(SCM_I_INUM(v1));
id[1] = v2;
}
} else
{
gp_debug0("a call tag\n");
if(scm_is_false(SCM_CDR(item)))
scm_call_1(SCM_CAR(item),SCM_BOOL_F);
else
scm_call_1(SCM_CDR(item),(state == gp_store)
? SCM_BOOL_T : SCM_BOOL_F);
gp_debug0("called\n");
}
return item;
}
static inline SCM gp_handle(SCM item, int ret, SCM gp_unbd, int state)
{
SCM x = SCM_BOOL_F,q,a,b,*id;
......@@ -59,11 +209,7 @@ static inline SCM gp_handle(SCM item, int ret, SCM gp_unbd, int state)
}
gp_debug0("non GP car\n");
if(scm_is_false(SCM_CDR(item)))
scm_call_1(SCM_CAR(item),SCM_BOOL_F);
else
scm_call_1(SCM_CDR(item),(state == gp_store) ? SCM_BOOL_T : SCM_BOOL_F);
return item;
return do_nongp(state, item);
}
else if(GP(item))
{
......@@ -85,6 +231,7 @@ static inline SCM gp_handle(SCM item, int ret, SCM gp_unbd, int state)
,SCM_EOL);
}
static inline int gp_advanced(SCM item, int state, SCM *old, SCM gp_unbd)
{
SCM redo;
......@@ -142,7 +289,10 @@ static inline int gp_do_cons(SCM item, int state, SCM *old, SCM gp_unbd)
gp_debug0("not inum tag\n");
if(!GP(tag))
{
{ // (DYNWIND #f)
// (WIND UNWIND)
// (Kind GP Val INIT)
// (Kind Var INIT)
gp_debug0("not a GP tag\n");
if(state)
switch(state)
......@@ -157,12 +307,9 @@ static inline int gp_do_cons(SCM item, int state, SCM *old, SCM gp_unbd)
case gp_redo:
*old = SCM_CDR(*old);
}
gp_debug0("a call tag\n");
if(scm_is_false(SCM_CDR(item)))
scm_call_1(SCM_CAR(item),SCM_BOOL_F);
else
scm_call_0(SCM_CDR(item));
gp_debug0("called\n");
do_nongp(state, item);
return state;
}
......@@ -861,12 +1008,53 @@ static int gp_rewind(SCM pp, SCM pend, SCM *ci, struct gp_stack *gp)
else
{
gp_debug0("call\n");
if(scm_is_false(SCM_CDR(q)))
scm_call_1(SCM_CAR(q),SCM_BOOL_T);
else
scm_call_0(SCM_CAR(q));
gp->gp_ci[0] = q;
gp->gp_ci ++;
SCM cdr = SCM_CDR(q);
if (SCM_CONSP(cdr))
{
SCM kind = SCM_CAR(q);
SCM p = SCM_CAR(cdr);
if(GP(p))
{
SCM cdr1 = SCM_CDR(cdr);
SCM v1 = SCM_CAR(cdr);
SCM cdr2 = SCM_CDR(cdr1);
SCM v2 = SCM_CAR(cdr);
id = GP_GETREF(p);
SCM cdr3 = SCM_CDR(cdr2);
q = SCM_CONS(kind,
SCM_CONS(p,
SCM_CONS(SCM_I_MAKINUM(id[0]),
SCM_CONS(id[1], cdr3))));
gp_store_var_2(id,0,gp);
if(redo_safe_fluid_guard(kind))
{
id[0] = SCM_PACK(SCM_I_INUM(SCM_CAR(cdr3)));
id[1] = SCM_CDR(cdr3);
}
else
{
id[0] = SCM_PACK(SCM_I_INUM(v1));
id[1] = SCM_CDR(v2);
}
}
else
{
SCM init = SCM_CDR(cdr);
if(redo_safe_variable_guard(kind))
SCM_VARIABLE_SET(p, init);
}
}
else
{
if(scm_is_false(SCM_CDR(q)))
scm_call_1(SCM_CAR(q),SCM_BOOL_T);
else
scm_call_0(SCM_CAR(q));
}
gp->gp_ci[0] = q;
gp->gp_ci ++;
}
sp--;
}
......
......@@ -1434,19 +1434,19 @@ SCM_DEFINE(gp_print_stack, "gp-print-stack", 1, 0, 0, (SCM s),
{
SCM *i;
struct gp_stack *gp = get_gp(s);
printf("\nci: %d\nsi: %d\ncs: %d\nlogical: %d\n"
printf("\nci: %ld\nsi: %ld\ncs: %ld\nlogical: %d\n"
,gp->gp_ci - gp->gp_cstack
,gp->gp_si - gp->gp_stack
,gp->gp_cs - gp->gp_cons_stack
,gp->_logical_);
for(i = gp->gp_cstack; i < gp->gp_ci; i++)
{
printf("%d c %x\n",i - gp->gp_cstack,SCM_UNPACK(*i));
printf("%ld c %lx\n",i - gp->gp_cstack,SCM_UNPACK(*i));
}
for(i = gp->gp_stack; i < gp->gp_si; i++)
{
printf("%d v %x\n",i - gp->gp_stack,SCM_UNPACK(*i));
printf("%ld v %lx\n",i - gp->gp_stack,SCM_UNPACK(*i));
}
return SCM_UNSPECIFIED;
}
......@@ -2189,6 +2189,9 @@ void gp_init()
scm_set_smob_mark(gp_type,gp_type_mark);
gp_module_stack_init();
safe_fluid_fluid = scm_make_fluid_with_default (SCM_BOOL_F);
safe_variable_fluid = scm_make_fluid_with_default (SCM_BOOL_F);
}
......
......@@ -92,3 +92,6 @@ SCM_API SCM gp_setup_set(SCM s, SCM v);
SCM_API SCM gp_wind_ref(SCM s);
SCM_API SCM gp_setup_ref(SCM s);
SCM_API SCM gp_set_thread_safe(SCM s, SCM bool);
SCM_API SCM gp_safe_fluid_fluid_ref();
SCM_API SCM gp_safe_variable_fluid_ref();
......@@ -141,9 +141,10 @@
(let ((ss s) ...)
(lambda ()
(set! done #f)
(if fr
(guard ss ...)
(begin (set! s ss) ...)))))))
(when (not (and (eq? s ss) ...))
(if fr
(guard ss ...)
(begin (set! s ss) ...))))))))
(set! s ss) ...)
(begin
(if (and (gp-wind-ref p) (not done))
......@@ -153,9 +154,10 @@
(let ((ss s) ...)
(lambda ()
(set! done #f)
(if fr
(guard ss ...)
(begin (set! s ss) ...)))))))
(when (not (and (eq? s ss) ...))
(if fr
(guard ss ...)
(begin (set! s ss) ...))))))))
(set! s so) ...))))
;;The second argument is not used here
#f
......@@ -175,7 +177,7 @@
*current-stack*
(lambda ()
(set! done #f))))
(lambda () (set! fr #f))
(lambda (x) (set! fr #f))
*current-stack*)
(let () code ...)))))))
......@@ -261,16 +263,16 @@
((_ x s) x)
((_ x) x)))
(define-inlinable (ppair? x s)
(define-syntax-rule (ppair? x s)
(if (pair? x) s #f))
(define-inlinable (nnull? x s)
(define-syntax-rule (nnull? x s)
(if (null? x) s #f))
(define-inlinable (eequal? x y s)
(define-syntax-rule (eequal? x y s)
(if (equal? x y) s #f))
(define-inlinable (ccar x s) (car x))
(define-inlinable (ccdr x s) (cdr x))
(define-syntax-rule (ccar x s) (car x))
(define-syntax-rule (ccdr x s) (cdr x))
(make-phd-matcher umatch0
( (gp-car gp-cdr gp-pair+ gp-null!? gp-unify! id-12345)
......
......@@ -2,7 +2,7 @@
:use-module (logic guile-log umatch)
:use-module (test-suite lib) )
;;This umatch does not support anything but tail call position yet, soo.
(define (f1) (umatch () (1) (X X)))
(define (f2) (umatch () ('(1 a)) ((X _) X)))
(define (f3) (umatch () ('(1 1)) ((X X) X)))
......@@ -15,7 +15,7 @@
(define (f10) (umatch () (#\g) (#\g #t)))
(define (f11) (umatch () ('(a b c)) ('(a b c) #t)))
(with-test-prefix "basic mode *, 1 arg, umatch usage *"
(with-test-prefix "basic mode +, 1 arg, umatch usage +"
(pass-if "(X X)"
(equal? 1 (f1)))
......@@ -52,7 +52,7 @@
(define (g2) (umatch () ('(3 a) -2) ((X _) Y (+ X Y))))
(define (g3) (umatch () ('(3 3) -2) ((X X) Y (+ X Y))))
(with-test-prefix "basic mode *, 2 arg, umatch usage *"
(with-test-prefix "basic mode +, 2 arg, umatch usage +"
(pass-if "(X X)"
(equal? 1 (g1)))
......@@ -64,19 +64,19 @@
(define (f1) (umatch (#:mode +) (1) (X X)))
(define (f2) (umatch (#:mode +) ('(1 a)) ((X _) X)))
(define (f3) (umatch (#:mode +) ('(1 1)) ((X X) X)))
(define (f4) (umatch (#:mode +) ('(a b)) ((X X) X) (_ 1)))
(define (f5) (umatch (#:mode +) ('(a a)) ((and X (Y Y)) X)))
(define (f6) (umatch (#:mode +) ("hello") (_ #t)))
(define (f7) (umatch (#:mode +) ('foo) ('foo #t)))
(define (f8) (umatch (#:mode +) ("bar") ("bar" #t)))
(define (f9) (umatch (#:mode +) (777) (777 #t)))
(define (f10) (umatch (#:mode +) (#\g) (#\g #t)))
(define (f11) (umatch (#:mode +) ('(a b c)) ('(a b c) #t)))
(with-test-prefix "basic mode +, 1 arg, umatch usage *"
(define (f1) (umatch (#:mode *) (1) (X X)))
(define (f2) (umatch (#:mode *) ('(1 a)) ((X _) X)))
(define (f3) (umatch (#:mode *) ('(1 1)) ((X X) X)))
(define (f4) (umatch (#:mode *) ('(a b)) ((X X) X) (_ 1)))
(define (f5) (umatch (#:mode *) ('(a a)) ((and X (Y Y)) X)))
(define (f6) (umatch (#:mode *) ("hello") (_ #t)))
(define (f7) (umatch (#:mode *) ('foo) ('foo #t)))
(define (f8) (umatch (#:mode *) ("bar") ("bar" #t)))
(define (f9) (umatch (#:mode *) (777) (777 #t)))
(define (f10) (umatch (#:mode *) (#\g) (#\g #t)))
(define (f11) (umatch (#:mode *) ('(a b c)) ('(a b c) #t)))
(with-test-prefix "basic mode * 2, 1 arg, umatch usage *"
(pass-if "(X X)"
(equal? 1 (f1)))
......@@ -121,7 +121,7 @@
(define (f10) (umatch (#:mode -) (#\g) (#\g #t)))
(define (f11) (umatch (#:mode -) ('(a b c)) ('(a b c) #t)))
(with-test-prefix "basic mode -, 1 arg, umatch usage *"
(with-test-prefix "basic mode -, 1 arg, umatch usage -"
(pass-if "(X X)"
(equal? 1 (f1)))
......
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