guile-log gts refined newfram/unwind/prune logic added

parent 72678813
......@@ -4,7 +4,9 @@
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:export (gp-clear gp-unify!- gp-unify-raw!- gp-newframe
#:export (gp-clear gp-unify!- gp-unify-raw!-
gp-newframe
gp-newframe-choice
gp->scm gp-print gp-heap-var!
gp-c-system
gp-make-var
......@@ -29,14 +31,16 @@
gp-module-init
gp-thread-safe-set!
-gp-member -gp-right-of -next-to -einstein
gp-deterministic?
gp-current-stack-ref
gp-undo-safe-variable-guard
gp-undo-safe-variable-rguard
gp-undo-safe-variable-lguard
gp-prompt gp-abort
gp-fluid-set
gp-prune
gp-prune-tail
gp-handlers-ref
gp-handlers-set!
gp-cont-ids-ref
......
......@@ -1178,7 +1178,7 @@ add/run * vlist *
truncate! ref++ ref-- walk-lr-ii)
(define g
(lambda (s p cc . a)
(let ((fr (gp-newframe s))
(let ((fr (gp-newframe-choice s))
(del (fluid-ref delayers)))
(walk-lr s p a
(lambda (p cut a vec last?)
......@@ -1188,10 +1188,12 @@ add/run * vlist *
(fluid-set! delayers del)
(p))))
((get-f vec) s p cc cut a))
((get-f vec) s p cc cut a)))))))
(begin
(gp-unwind-tail fr)
((get-f vec) s p cc cut a))))))))
(define k
(lambda (s p cc . a)
(let ((fr (gp-newframe s))
(let ((fr (gp-newframe-choice s))
(del (fluid-ref delayers)))
(walk-lr-ii s p a
(lambda (p cut a vec last?)
......@@ -1201,7 +1203,9 @@ add/run * vlist *
(fluid-set! delayers del)
(p))))
((get-f vec) s p cc cut a))
((get-f vec) s p cc cut a)))))))
(begin
(gp-unwind-tail fr)
((get-f vec) s p cc cut a))))))))
(define gg (lambda x (apply g x)))
(define kk (lambda x (apply k x)))
......@@ -1649,7 +1653,7 @@ add/run * vlist *
(lambda (data)
(let ((fr (<newframe>)))
(let* ((s (gp-unify! (get-c data) y S)))
(<unwind> fr)
(<unwind-tail> fr)
(if s #t #f))))
#t)))
......@@ -1659,7 +1663,7 @@ add/run * vlist *
(lambda (data)
(let ((fr (<newframe>)))
(let ((s (gp-unify! (get-c data) y S)))
(<unwind> fr)
(<unwind-tail> fr)
(if s #t #f))))
#f)))
......@@ -1668,7 +1672,7 @@ add/run * vlist *
(s2 (gp-newframe s1)))
(with-fluids ((*current-stack* s2))
(let ((ret (code s1)))
(gp-unwind s1)
(gp-unwind-tail s1)
ret))))
(define (wapu ff mk-dyn . lams)
......
......@@ -178,13 +178,15 @@
(define walk-lr (vector-ref data 10))
(define g
(lambda (s p cc . a)
(let ((fr (gp-newframe s)))
(let ((fr (gp-newframe-choice s)))
(walk-lr s p a
(lambda (p cut a vec last?)
(if (not last?)
(let ((p (lambda () (gp-unwind fr) (p))))
((get-f vec) s p cc cut a))
((get-f vec) s p cc cut a)))))))
(begin
(gp-unwind-tail fr)
((get-f vec) s p cc cut a))))))))
(setter g)
(set-object-property! g 'dynamic-data data)
(set-procedure-property! g 'name f)))
......
......@@ -48,7 +48,7 @@
(define (f-interleave sin p cc as)
(let-with-lr-guard sin wind lguard rguard ((l '()) (r '()))
(lguard sin
(let ((sin (gp-newframe sin)))
(let ((sin (gp-newframe-choice sin)))
(define fail
(lambda ()
(let ((sin (gp-unwind sin)))
......@@ -83,7 +83,7 @@
(define (f-interleave-union sin p cc as)
(let-with-lr-guard sin wind lguard rguard ((l '()) (r '()) (gs '()) (gr '()))
(lguard sin
(let ((s (gp-newframe sin)))
(let ((s (gp-newframe-choice sin)))
(define fail
(lambda ()
(let ((s (gp-unwind s)))
......@@ -186,7 +186,7 @@ and-interleave
(set! r (cons (mk-cont p2 ss) r))
(g2 ss fail
(lambda (sss p3)
(let ((fr (gp-newframe sss)))
(let ((fr (gp-newframe-choice sss)))
(set! r (cons (mk-cont p3 sss) r))
(rg sss (cc sss (lambda ()
(gp-unwind fr)
......@@ -239,7 +239,7 @@ and-interleave
(let-with-lr-guard s wind lguard rguard
((gg #f) (ggs gs) ... (vv #f) ... (vvs #f) ... ...)
(lguard s
(let ((fr (gp-newframe s)))
(let ((fr (gp-newframe-choice s)))
(g s p
(lambda (ss pp)
(cont-set! gg pp ss wind)
......@@ -271,7 +271,7 @@ and-interleave
(define (call s p cc lam x l)
#;(use-logical s)
(let ((s (gp-newframe s))
(let ((s (gp-newframe-choice s))
(wind (gp-windlevel-ref s)))
((gp-lookup lam s)
s p (lambda (ss pp)
......@@ -293,32 +293,35 @@ and-interleave
(call (</.> code ...) (list x ...) (list l ...))))))
(<define> (<gc-call> X L Lam)
(<let> ((pr (<newframe>)))
(<let> ((p P)
(pr (<newframe>)))
(Lam)
(<let> ((res (<cp> X L)))
(<code> (<unwind> pr))
(<=> X res))))
(<code> (<unwind-tail> pr))
(<with-fail> p (<=> X res)))))
(<define> (<gc-scm-call> X Lam)
(<let> ((pr (<newframe>)))
(<let> ((p P)
(pr (<newframe>)))
(Lam)
(<let> ((res (<scm> X)))
(<code> (<unwind> pr))
(<=> X res))))
(<code> (<unwind-tail> pr))
(<with-fail> p (<=> X res)))))
(<define> (<gc-list-call> X Lam)
(<let> ((pr (<newframe>)))
(<let> ((p P)
(pr (<newframe>)))
(Lam)
(<let> ((res (->list S X)))
(<pp> (length res))
(<code> (<unwind> pr))
(<=> X res))))
(<code> (<unwind-tail> pr))
(<with-fail> p (<=> X res)))))
(define-syntax-rule (fcall-m nm)
(define (nm s p cc lam x l f)
(let-with-lr-guard s wind lguard rguard ((cc cc))
(lguard s
(let ((s (gp-newframe s)))
(let ((s (gp-newframe-choice s)))
((gp-lookup lam s)
s p (lambda (ss pp)
(let ((state (gp-store-state ss)))
......
......@@ -33,7 +33,8 @@
<syntax-parameterize>
<car> <cdr> <logical++> <logical-->
define-guile-log-parser-tool
<newframe> <unwind> <unwind-tail>
<newframe> <newframe-choice>
<unwind> <unwind-tail> <prune> <prune-tail>
<define-guile-log-rule>
<get-fixed> <get-idfixed> <cp> <lookup> <wrap> <wrap-s>
<with-bind>
......@@ -106,7 +107,13 @@
(define-syntax-rule (<cdr> x) (gp-cdr (gp-lookup x S) S))
(define-syntax-rule (<lookup> x) (gp-lookup x S))
(define-syntax-rule (<newframe>) (gp-newframe S))
(define-syntax <newframe-choice>
(syntax-rules ()
((_) (gp-newframe-choice S))
((_ s) (gp-newframe-choice s))))
(define-syntax-rule (<unwind> p) (gp-unwind p))
(define-syntax-rule (<prune> p) (gp-prune p))
(define-syntax-rule (<prune-tail> p) (gp-prune-tail p))
(define-syntax-rule (<unwind-tail> p) (gp-unwind-tail p))
(define-syntax-rule (<cp> x ...) (gp-cp x ... S))
(define-syntax-rule (<cons?> x) (gp-pair- (gp-lookup x S) S))
......@@ -169,7 +176,7 @@
((_ meta e1) (parse<> meta e1))
((_ (cut s pr cc) . l)
(let ((s (gp-newframe s)))
(let ((s (gp-newframe-choice s)))
(or-aux (cut s pr cc) . l)))))
(define-syntax or-aux
......@@ -302,7 +309,6 @@
(cc-let (ccc)
(parse<> (cut s pr ccc) e1))))))))))
;;This is inspired from kanren
;; (<and!> a ... ) gives exactly one answer from (and a ....)
;; (<and!!> a ... ) is the same as (and (and! a) ...)
......@@ -311,8 +317,10 @@
(syntax-rules ()
((_ w) (parse<> w <cc>))
((_ (cut s p cc) a ...)
(let ((ccc (lambda (ss pp . l) (apply cc ss p l))))
(parse<> (cut s p ccc) (<and> a ...))))))
(let ((ccc (lambda (ss pp . l)
(<prune> s)
(apply cc ss p l))))
(parse<> (cut s p ccc) (<and> a ... ))))))
(define-guile-log <and!!>
(lambda (x)
......@@ -355,7 +363,7 @@
(syntax-rules ()
((_ (cut s p cc) g ...)
(let* ((s (gp-newframe s))
(ccc (lambda (ss pp) (gp-unwind s) (cc s p))))
(ccc (lambda (ss pp) (gp-unwind-tail s) (cc s p))))
(parse<> (cut s p ccc) (<and> g ...))))))
......@@ -398,15 +406,21 @@
(define-guile-log <if>
(syntax-rules ()
((_ meta p a)
(parse<> meta (<and> (<and!> p) a)))
(parse<> meta
(let ((s S))
(<and!> p)
a)))
((_ (cut s p cc) pred a b)
(<or> (cut s p cc)
(<let> ((ss S))
(<and> (<and!> pred)
(<with-fail> p
(<code> (gp-clear-frame! ss))
a)))
b))))
(let* ((fr (<newframe-choice> s))
(pp (lambda ()
(<unwind-tail> fr)
(parse<> (cut s p cc) b))))
(parse<> (cut fr pp cc)
(<and>
pred
(<with-fail> p
(<code> (<prune-tail> fr))
a)))))))
(define-guile-log <scm-if>
(syntax-rules ()
......@@ -432,7 +446,6 @@
(let ((cc2 (lambda (s3 p3)
(parse<> (cut s3 p cc) a))))
(parse<> (cut s p2f cc2) pred))))))
(define-guile-log <if-some>
......@@ -522,7 +535,7 @@ For tabling, negations are tricky. the reason is that when a recursive applicati
(ss2 (gp-set! gp-not-n (+ (gp-lookup gp-not-n s) 1) ss))
(ss3 (gp-set! gp-is-delayed? #f ss2))
(ccc (lambda (s pp . x)
(gp-unwind ss)
(gp-unwind-tail ss)
(gp-var-set! gp-is-delayed? #f)
(p)))
(ppp (lambda ()
......@@ -1086,7 +1099,6 @@ For tabling, negations are tricky. the reason is that when a recursive applicati
((_ code ...) (<lambda> () code ...))))
(define (<funcall> S P CC F . L)
(apply (gp-lookup F S) S P CC L))
......@@ -1285,8 +1297,7 @@ MAKE SURE TO REVISIT THIS IDEA LATER
#'(<let> w ((id I) ...)
(<syntax-parameterize> ((X (lambda x #'id)) ...)
(<and> code ...))))))))
(define-syntax-rule (<define-guile-log-rule> (f a ...) code ...)
(define-guile-log f
(syntax-rules ()
......@@ -1337,14 +1348,12 @@ MAKE SURE TO REVISIT THIS IDEA LATER
(doit_off)
(<r=> v ,(gp-lookup-1 ret S))
(doit_on))))
(<define> (<del-attr!> x m) (<code> (gp-del-attr! x m S)))
(<define> (<del-attr> x m)
(<define> (<del-attr> x m)
(<let> ((s (gp-del-attr x m S)))
(if s (<with-s> s <cc>) <cc>)))
(<define> (<del-attr!> x m) (<code> (gp-del-attr! x m S)))
(if s (<with-s> s <cc>) <cc>)))
(define (tr-meta f fnew)
(define (sieve l)
(let lp ((l l))
......@@ -1363,7 +1372,8 @@ MAKE SURE TO REVISIT THIS IDEA LATER
(fu f))
(let ((res (tr-meta fu (<lambda> x (<apply> goal fu l ... x)))))
res)))
(define-syntax-rule (adaptable_vars f)
(fluid-let-syntax ((<var> (syntax-rules ()
((_ . l) (<modvar> . l)))))
......@@ -1463,9 +1473,6 @@ MAKE SURE TO REVISIT THIS IDEA LATER
(<=> var val)
(<==> val var)))))
(variable-set! (@@ (logic guile-log code-load) attributeU) attributeU)
(define-syntax-rule (<with-log-in-code> code ...)
......
......@@ -6,7 +6,7 @@
#:use-module ((logic guile-log umatch) #:select
(gp-unifier gp-raw-unifier gp-m-unifier gp? gp-pair?
gp-attvar-raw? gp-att-raw-var gp-att-data
gp-newframe gp-unwind
gp-newframe gp-unwind gp-unwind-tail
attribute-cstor-ref))
#:use-module (logic guile-log canonacalize)
#:use-module (logic guile-log dynamic-features)
......@@ -574,7 +574,7 @@ Also it is possible to solve inifinite recursion.
x)))
(let ((ret
(canon-it++ gp->scm-rec analyze (cdr sy) (car sy))))
(gp-unwind fr)
(gp-unwind-tail fr)
ret))))
......
......@@ -3,6 +3,7 @@
#:use-module (logic guile-log vlist)
#:use-module ((logic guile-log umatch)
#:select (gp-attvar-raw? set-attribute-cstor! gp-lookup
gp-newframe-choice
gp-make-var
gp-attvar?))
#:use-module (logic guile-log run)
......@@ -628,7 +629,7 @@
(<code> (set! true #t)))))
<cc>)))
(if true
(<code> (<unwind> fr))
(<code> (<unwind-tail> fr))
(when var))))
(define-syntax-rule (=/= x y)
......
......@@ -391,7 +391,7 @@
(p (<newframe>)))
(<with-s> p
(.. (c) (f c))
(<code> (<unwind> p))
(<code> (<unwind-tail> p))
(<with-fail> op
(<p-cc> c))))))
......@@ -440,23 +440,23 @@
(<and!>
(<let> ((val (hash-ref (fluid-ref *freeze-map*)
(cons* N M tok) #f))
(fr (<newframe>)))
(fr (<newframe-choice>)))
(if (not val)
(<let> ((n N) (m M))
(<let> ((n N) (m M))
(<or>
(<and>
(.. (cc) (f c))
(<let> ((val2 (mk S c cc)))
(<let> ((val2 (mk S c cc)))
(<code>
(<unwind> fr)
(<unwind-tail> fr)
(hash-set! (fluid-ref *freeze-map*)
(cons* n m tok) (list X XL N M XX ... val2)))
(<p-cc> val2)))
(<let> ((val2 'fail))
(<code>
(<unwind> fr)
(hash-set! (fluid-ref *freeze-map*)
(cons* n m tok) val2))
(<unwind-tail> fr)
(hash-set! (fluid-ref *freeze-map*)
(cons* n m tok) val2))
<fail>)))
(if (pair? val)
(<apply> f-true val)
......
......@@ -162,7 +162,7 @@
(<eval> (v)
(<and> code ...)
(lambda x
(gp-unwind fr1)
(gp-unwind-tail fr1)
(reverse ret))
(lambda (s p)
(let ((res (gp-var! s)))
......@@ -182,7 +182,7 @@
(lambda x
(let ((r ret))
(set! ret '())
(gp-unwind fr1)
(gp-unwind-tail fr1)
(reverse r)))
(lambda (s p)
(set! ret (cons (tr (gp->scm (list v ...) s) s #f) ret))
......@@ -205,7 +205,7 @@
(let ((r ret))
(set! n 0)
(set! ret '())
(gp-unwind fr1)
(gp-unwind-tail fr1)
(reverse r)))
(lambda (s p)
(if (= n 0)
......@@ -242,7 +242,7 @@
(let ((r ret))
(set! n 0)
(set! ret '())
(gp-unwind fr1)
(gp-unwind-tail fr1)
(reverse r)))
(lambda (s p)
(if (= n 0)
......
(define-module (logic guile-log soft-cut)
#:use-module (logic guile-log)
#:use-module ((logic guile-log umatch) #:select
(gp-deterministic?))
#:use-module (logic guile-log interleave)
#:export (<soft-if>
soft-if-f
......@@ -25,7 +27,7 @@ and rgard removes it from the list going backwards reverses the actions.
(s0 S)
(cut1 CUT)
(cc CC)
(fr (<newframe>)))
(fr (<newframe-choice>)))
(<let-with-lr-guard> wind lguard rguard
((rp (lambda ()
(<unwind-tail> fr)
......@@ -37,8 +39,8 @@ and rgard removes it from the list going backwards reverses the actions.
(<with-cut> cut1
a
(<code>
(if (gp-deterministic? fr S)
(<unwind-tail> fr)))
(if (gp-deterministic? fr)
(<prune-tail> fr)))
(<code> (set! rp p0))
(<let> ((cut2 CUT))
(rguard
......@@ -51,14 +53,10 @@ and rgard removes it from the list going backwards reverses the actions.
(define-guile-log <setup-call-cleanup-once>
(syntax-rules ()
((_ w pre action cleanup)
(<let> w ((p0 P)
(s0 S)
(cut1 CUT)
(cc CC)
(fr (<newframe>)))
(<let-with-lr-guard> wind lguard rguard
((done? #f))
(lguard
(let w ((s0 S))
(<let-with-lr-guard> wind lguard rguard
((done? #f))
(lguard
(</.>
pre
(<dynwind>
......
......@@ -554,7 +554,7 @@ gp_stack_mark0(SCM obj, int unlocked,
GP_GC_CAND(head);
GP_GETREF(val)[0] = SCM_PACK(head);
//printf("NTMARK(%p)\n",SCM_UNPACK(val));
#ifdef HAS_GP_GC
#ifdef HAS_GP_GC
GC_MARK_NT(val);
#else
GC_MARK(val);
......
#define DB(X) X
#define DB(X)
#define STATE_LOGICAL 0
#define STATE_DYNSTACK 1
......@@ -787,6 +787,90 @@ static inline void gp_unwind_(SCM s, int ncons, int nvar, int nfr)
gp_debug0("leaving unwind\n");
}
void inline falsify_entires(SCM *ci,struct gp_stack *gp)
{
SCM *i = gp->gp_ci - 1;
int action = 1;
for(;i >= ci; i--)
{
if(GP_FRAME_VAR(*i) && action)
*i = SCM_BOOL_F;
if(SCM_CONSP(*i))
{
SCM tag = SCM_CAR(*i);
if(SCM_I_INUMP(*i) && SCM_UNPACK(tag) == gp_redo_tag)
{
action = 1;
}
else
action = 0;
}
}
}
// Use this functionto prune the control stack and also perhaps clear
// The stacks completely.
static inline void gp_prune(SCM s, int tailp)
{
struct gp_stack *gp = get_gp();
SCM *fr, *ci,*si,*cs,lt;
SCM tag = SCM_EOL;
if((GP(s) && GP_CONSP(s)) || SCM_CONSP(s))
{
tag = gp_car(gp_car(s, s),s);
lt = gp_gp_cdr(s,s);
fr = gp->gp_frstack + GP_GET_SELF_TAG(tag);
if(vlist_p(lt))
{
vhash_truncate_x(lt);
}
}
else
{
return;
}
ci = gp->gp_cstack + GP_GET_VAL_VAL(fr);
si = gp->gp_stack + GP_GET_VAR(fr);
cs = gp->gp_cons_stack + GP_GET_CONS(fr);
int vp = 0;
if(ci == gp->gp_ci && tailp)
{
ci--;
vp = 1;
}
else
{
falsify_entires(ci,gp);
ci = gp->gp_ci;
}
if(si == gp->gp_si && vp && tailp)
{
si-=2;
}
else
{
si = gp->gp_si;
}
if(cs == gp->gp_cs && tailp)
{
cs -= 2;
}
else
cs = gp->gp_cs;
gp_debug2("er> %x %x %x\n",cs - gp->gp_stack,cs - gp->gp_cons_stack);
gp_debug2("er> %x %x %x\n",si - gp->gp_stack,si - gp->gp_cons_stack);
gp_unwind0(fr - (tailp?GP_FRAMESIZE:0),ci, si, cs, gp);
}
static inline void gp_unwind(SCM fr)
{
gp_unwind_(fr,0,0,0);
......@@ -820,6 +904,28 @@ SCM_DEFINE(gp_gp_unwind, "gp-unwind", 1, 0, 0, (SCM fr),
}
#undef FUNC_NAME
SCM_DEFINE(gp_gp_prune, "gp-prune", 1, 0, 0, (SCM fr),
"unwinds the prolog stack till frame refered by the argument")
#define FUNC_NAME s_gp_gp_unwind
{
gp_no_gc();
gp_prune(fr, 0);
gp_do_gc();
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE(gp_gp_prune_tail, "gp-prune-tail", 1, 0, 0, (SCM fr),
"unwinds the prolog stack till frame refered by the argument")
#define FUNC_NAME s_gp_gp_unwind
{
gp_no_gc();
gp_prune(fr, 1);
gp_do_gc();
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE(gp_gp_unwind_tail, "gp-unwind-tail", 1, 0, 0, (SCM fr),
"unwinds the prolog stack till frame refered by the argument")
#define FUNC_NAME s_gp_gp_unwind_tail
......@@ -1038,7 +1144,7 @@ static inline SCM * gp_get_branch(SCM *p, SCM *fr, struct gp_stack *gp)
}
}
return SCM_EOL;
return (SCM *)0;
}
//#define DB(X) X
......
......@@ -122,8 +122,8 @@ SCM gp_procedure_name(SCM f)
}
#define DB(X) X
#define DS(X) X
#define DB(X)
#define DS(X)
#define gp_debug0(s) DB(printf(s) ; fflush(stdout))
#define gp_debug1(s,a) DB(printf(s,a) ; fflush(stdout))
#define gp_debug2(s,a,b) DB(printf(s,a,b) ; fflush(stdout))
......@@ -268,7 +268,7 @@ scm_t_bits gp_smob_t;
#define SET_FRAME(x) ((x) = (x) | GPI_FRAME)
#define FRAMEP(x) ((x) & GPI_FRAME)
#define GP_CONSP(x) GP_CONS(GP_GETREF(x))
#define GP_CONSP(x) (x && GP(x) && GP_CONS(GP_GETREF(x)))
inline int GP_FRAME_VAR(SCM x)
{
if(GP(x))
......@@ -338,7 +338,7 @@ static inline SCM gp_make_closure_heap(int n, SCM **closure)
a = scm_fluid_ref(gp_current_stack); \
if(!GP_STACKP(a)) \
scm_misc_error("unpack_s2",err,SCM_EOL); \
gp = GET_GP(a); \
gp = GET_GP(a); \
gp_debug0(err); \
if(!GP_CONSP(s)) \
{ \
......@@ -1208,11 +1208,16 @@ static inline SCM gp_newframe(SCM s)
{
SCM l;
struct gp_stack *gp = get_gp();
gp_debug0("newframe\n");
if(SCM_CONSP(s))
{
l = SCM_CDR(s);
}
else if (GP_CONSP(s))
{
l = GP_GETREF(s)[2];
}
else
{
s = SCM_PACK(0);
......@@ -1223,7 +1228,7 @@ static inline SCM gp_newframe(SCM s)
SCM ret;
SCM *f1, *f2, *cons1, *cons2;
SCM *fr;
gp_debug0("newframe\n");
GP_TEST_CSTACK;
gp_gc_inc(gp);
......@@ -1251,7 +1256,7 @@ static inline SCM gp_newframe(SCM s)
cons1[2] = l;