using a more robust prolog-run-rewind

parent e9af6e54
......@@ -260,7 +260,7 @@ generate_stx(STX,X,F) :-
(syntax-case x ()
((_ n code-string)
#`(define n (let ((g (lambda ()
#,(let ((g (prolog-run 1 (meta)
#,(let ((g (prolog-run-rewind 1 (meta)
(generate_stx x
(syntax->datum
#'code-string)
......
......@@ -144,6 +144,10 @@
(<let> ((v (<lookup> v)))
(<=> e ,(<lookup> (vector-ref v ne)))))
(<define> (get_F v f)
(<let> ((v (<lookup> v)))
(<=> f ,(<lookup> (vector-ref v nf)))))
(<define> (get_M v m)
(<let> ((v (<lookup> v)))
(<=> m ,(<lookup> (vector-ref v nm)))))
......
......@@ -14,6 +14,16 @@
S=J
")
(define-prolog f0 "
f1(N,I,J,S) :-
I > N -> S=J ;
(
II is I + 1,
JJ is J + I,
f1(N,II,JJ,S)
).
")
(define-prolog f2 "
f2(N,S) :-
recur * lp((I,0),(J,0)),
......@@ -28,7 +38,6 @@
).
")
(compile-prolog-string "
f3(N,I,J,S) :-
I < N ->
......@@ -40,7 +49,6 @@
S=J
")
(define-prolog memb "
memb(X,L) :-
recur * lp((LL,L)),
......@@ -52,3 +60,5 @@
")
......@@ -161,6 +161,7 @@
;; Scheme functions
compile-prolog-string compile-prolog-file
save-operator-table prolog-run
prolog-run-rewind
load-prolog clear-directives
save-char-conversion-table
reset-char-conversion
......
......@@ -7,7 +7,8 @@
#:use-module ((logic guile-log umatch)
#:select (gp-newframe gp-unwind gp-unwind-tail *current-stack*))
#:use-module (logic guile-log prompts)
#:export (prolog-run prolog-run-* proog-run-0 var->code))
#:export (prolog-run prolog-run-* proog-run-0 var->code
prolog-run-rewind))
(define (var->code x)
(define (get-fkn a)
......@@ -46,6 +47,25 @@
(<format> #t "DYNAMIC ERROR:~%=> ~a~%~%" (var->code (<scm> l)))
(<ret> (<scm> l))))))))
(define-syntax-rule (prolog-run-rewind n v code ...)
(let* ((fr1 ((@ (logic guile-log umatch) gp-newframe)
(fluid-ref (@ (logic guile-log umatch) *current-stack*))))
(fr2 ((@ (logic guile-log umatch) gp-newframe)
fr1)))
(with-fluids ((*current-stack* fr2))
(let ((ret
(scheme-wrapper
(lambda ()
(<run> n v
(<catch> 'prolog #f
(<lambda> () (init-machines) code ...)
(<lambda> (tag next l)
(<format> #t "DYNAMIC ERROR:~%=> ~a~%~%"
(var->code (<scm> l)))
(<ret> (<scm> l)))))))))
((@ (logic guile-log umatch) gp-unwind-tail) fr1)
ret))))
(define-syntax-rule (prolog-run-* code ...)
(let* ((fr1 ((@ (logic guile-log umatch) gp-newframe)
(fluid-ref (@ (logic guile-log umatch) *current-stack*))))
......
......@@ -1027,7 +1027,7 @@ void gp_sweep_handle(SCM in)
SCM *pt;
//printf("sweep %d\n",gp_gc_p);
printf("sweep %d\n",gp_gc_p);
// Search for the first newframe stored
......@@ -1072,7 +1072,7 @@ void gp_sweep_handle(SCM in)
}
//printf("sweep1 %d %d\n",n,nrem);
printf("sweep1 %d %d\n",n,nrem);
{
int vn = 0;
......@@ -1136,7 +1136,7 @@ void gp_sweep_handle(SCM in)
}
}
}
//printf("sweep2 %d %d\n",n,nrem);
printf("sweep2 %d %d\n",n,nrem);
for(pt = gp->gp_stack; pt < gp->gp_si; pt++)
{
......@@ -1206,7 +1206,7 @@ void gp_sweep_handle(SCM in)
}
//printf("sweep2 vn1 %d vn2 %d vrem1 %d vrem %d\n",vn,vn,vrem,vrem);
printf("sweep2 vn1 %d vn2 %d vrem1 %d vrem %d\n",vn,vn,vrem,vrem);
}
gp_clean_pairs(gp);
......@@ -1272,19 +1272,19 @@ SCM_DEFINE(gp_gc, "gp-gc", 0, 0, 0, (), "clean up the stack")
int mute = 0;
int doit = 0;
struct gp_stack *gp = get_gp();
pthread_mutex_lock(&gp_gc_lock);
scan_weak_lists();
if(!gp_gc_p)
{
/*
if(gp->n > 100000)
printf("gc0: %d %d\n",gp->n, gp->nrem);
*/
if(gp->n > 100 && gp->nrem*20 > gp->n)
{
pthread_mutex_lock(&gp_gc_lock);
if(!gp_gc_p)
{
//printf("gc: %d %d\n",gp->n, gp->nrem);
if(gp->n > 100000) doit = 1;
SCM *pt1,*pt2, *pt3, *pt4,
......@@ -1504,13 +1504,14 @@ SCM_DEFINE(gp_gc, "gp-gc", 0, 0, 0, (), "clean up the stack")
gp->gp_ci = pt4_insert;
//printf("end gc\n");fflush(stdout);
}
}
gp->n = 0;
gp->nrem = 0;
gp->n = 0;
gp->nrem = 0;
pthread_mutex_unlock(&gp_gc_lock);
}
}
pthread_mutex_unlock(&gp_gc_lock);
if(0 && doit)
scm_gc();
#endif
......
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