swi engines now store and restore state even better

parent dd97a5b0
...@@ -16,13 +16,11 @@ ...@@ -16,13 +16,11 @@
engine_fetch engine_fetch
is_engine is_engine
engine_self engine_self
current_engine)) current_engine
stub))
(<define> (engine_yield term) (<ret> (list #:yield S P CC term))) (<define> (engine_yield term) (<ret> (list #:yield S P CC term)))
(<define> (stub-scm goal box engine)
(goal box engine))
(define postbox (make-fluid #f)) (define postbox (make-fluid #f))
(<wrap> add-fluid-dynamics postbox) (<wrap> add-fluid-dynamics postbox)
(define (<postbox-ref>) (fluid-ref postbox)) (define (<postbox-ref>) (fluid-ref postbox))
...@@ -33,8 +31,10 @@ ...@@ -33,8 +31,10 @@
(define (generate-engine s size name goal) (define (generate-engine s size name goal)
(let ((engine (gp-make-engine size))) (let ((engine (gp-make-engine size)))
(letrec ((state #f) (letrec ((state #f)
(first #t)
(guards #f) (guards #f)
(path #f) (inhibit #f)
(path (cons (list (cons s engine)) '()))
(postbox (make-variable #f)) (postbox (make-variable #f))
(on-result (on-result
(lambda () (lambda ()
...@@ -50,13 +50,6 @@ ...@@ -50,13 +50,6 @@
(begin (begin
(set! state (set! state
(list #:stalled (list #:stalled
(let ((e engine)
(g guards)
(p path))
(lambda ()
(set! engine e)
(set! guards g)
(set! path p)))
(cons (cons
(@@ (logic (@@ (logic
guile-log guile-log
...@@ -77,34 +70,37 @@ ...@@ -77,34 +70,37 @@
(g #f)) (g #f))
(dynamic-wind (dynamic-wind
(lambda () (lambda ()
(set! inhibit #t)
(set! g (gp-store-engine-guards)) (set! g (gp-store-engine-guards))
(if path (if (not first)
(set! pth (begin
(gp-set-engine path)) (set! first #f)
(set! pth
(gp-set-engine path)))
(let ((s2.p (gp-new-engine engine))) (let ((s2.p (gp-new-engine engine)))
(set! s2 (car s2.p)) (set! s2 (car s2.p))
(set! pth (cdr s2.p)))) (set! pth (cdr s2.p))))
(if guards (if guards
(gp-restore-engine-guards guards))) (gp-restore-engine-guards guards)))
(lambda () (lambda ()
(set! state (set! state
(stub-scm (goal
s2 s2
(lambda () (lambda ()
(set! engine #f) (set! engine #f)
#:exit) #:exit)
(lambda (s p x) (lambda (s p x)
(list #:finish s p)) (list #:finish s p))
goal
postbox postbox
(lambda () ret))) (lambda () ret)))
(on-result)) (on-result))
(lambda () (lambda ()
(set! guards (gp-store-engine-guards)) (set! guards (gp-store-engine-guards))
(set! path (gp-set-engine pth)) (set! path (gp-set-engine pth))
(gp-restore-engine-guards g))))) (gp-restore-engine-guards g)
(set! inhibit #f)))))
#:exit))) #:exit)))
(next (next
...@@ -112,7 +108,8 @@ ...@@ -112,7 +108,8 @@
(let ((pth #f) (let ((pth #f)
(g #f)) (g #f))
(dynamic-wind (dynamic-wind
(lambda () (lambda ()
(set! inhibit #t)
(set! g (gp-store-engine-guards)) (set! g (gp-store-engine-guards))
(set! pth (gp-set-engine path)) (set! pth (gp-set-engine path))
(gp-restore-engine-guards guards)) (gp-restore-engine-guards guards))
...@@ -126,9 +123,7 @@ ...@@ -126,9 +123,7 @@
((#:throw e) ((#:throw e)
state) state)
((#:stalled thunk cc) ((#:stalled cc)
(thunk)
(<state-set!> (car cc))
(set! state (continue (cdr cc))) (set! state (continue (cdr cc)))
(on-result)) (on-result))
...@@ -143,27 +138,36 @@ ...@@ -143,27 +138,36 @@
(x x)) (x x))
#:exit)) #:exit))
(lambda () (lambda ()
(set! guards (gp-store-engine-guards)) (set! guards (gp-store-engine-guards))
(set! path (gp-set-engine pth)) (set! path (gp-set-engine pth))
(gp-restore-engine-guards g)))))) (gp-restore-engine-guards g)
(set! inhibit #f))))))
(ret (ret
(case-lambda (case-lambda
(() (()
(let* ((pth (gp-set-engine path)) (when (not inhibit)
(s (<state-ref>))) (let* ((pth (gp-set-engine path))
(gp-set-engine pth) (s (<state-ref>)))
(list s state path guards engine (variable-ref postbox)))) (gp-set-engine pth)
(list first start-f
s state path guards engine (variable-ref postbox)))))
((l) ((l)
(match l (when (not inhibit)
((s state_ path_ guards_ engine_ post_) (match l
(set! state s) ((first_ start-f_ s state_ path_ guards_ engine_ post_)
(set! path path_) (set! start-f start-f_)
(set! guards guards_) (set! first first_)
(set! engine engine_) (set! state state_)
(variable-set! postbox post_) (set! path path_)
(<state-set> s)))) (set! guards guards_)
(set! engine engine_)
(variable-set! postbox post_)
(let ((pth (gp-set-engine path)))
(<state-set!> s)
(gp-set-engine pth))))))
((kind s . term) ((kind s . term)
(match kind (match kind
...@@ -182,6 +186,7 @@ ...@@ -182,6 +186,7 @@
(#:exit #f) (#:exit #f)
(_ #t))))))))) (_ #t)))))))))
(<wrap> add-parameter-dynamics ret)
(set-procedure-property! ret 'engine #t) (set-procedure-property! ret 'engine #t)
(set-procedure-property! (set-procedure-property!
ret 'name (string->symbol (format #f "e<~a>" (name-it name)))) ret 'name (string->symbol (format #f "e<~a>" (name-it name))))
...@@ -210,15 +215,14 @@ ...@@ -210,15 +215,14 @@
((#:yield s p cc x) ((#:yield s p cc x)
(<=> x term)) (<=> x term))
((#:stalled _ _) ((#:stalled _)
(<and> (<and>
(nl)
(write "stalled engine > ") (write "stalled engine > ")
(write engine) (write engine)
(nl) (nl)
(let ((state res)) (stall)
(stall) (lp (engine #:run S))))
(<code> (engine #:set-state state))
(lp (engine #:run S)))))
(x (<ret> x)))))) (x (<ret> x))))))
...@@ -241,7 +245,7 @@ ...@@ -241,7 +245,7 @@
((#:yield s p cc x) ((#:yield s p cc x)
(<=> ,(vector (list "the" x)) term)) (<=> ,(vector (list "the" x)) term))
((#:stalled _ _) ((#:stalled _)
(<and> (<and>
(write "stalled engine > ") (write "stalled engine > ")
(write engine) (write engine)
...@@ -280,14 +284,19 @@ ...@@ -280,14 +284,19 @@
(<define> (create-engine-scm t g name size engine) (<define> (create-engine-scm t g name size engine)
(let ((e (generate-engine S (<lookup> size) (<lookup> name) (let ((e (generate-engine S (<lookup> size) (<lookup> name)
(<lambda> (a b) (mk t g))))
(stub t g a b)))))
(<=> engine e))) (<=> engine e)))
(<define> (ret_e e) (<ret> (list #:throw e))) (<define> (ret_e e) (<ret> (list #:throw e)))
(<define> (ret_g t) (<ret> (list #:finish S P t))) (<define> (ret_g t) (<ret> (list #:finish S P t)))
(define mod (current-module))
(define (mk t g)
(lambda (s p cc a b)
(stub s p cc t g a b)))
(compile-prolog-string " (compile-prolog-string "
g(Term,Goal,A,B) :- g(Term,Goal,A,B) :-
......
...@@ -1674,9 +1674,14 @@ SCM_DEFINE(gp_set_engine, "gp-set-engine", 1, 0, 0, (SCM paths), ...@@ -1674,9 +1674,14 @@ SCM_DEFINE(gp_set_engine, "gp-set-engine", 1, 0, 0, (SCM paths),
{ {
SCM e = SCM_CDR(SCM_CAR(SCM_CAR(paths))); SCM e = SCM_CDR(SCM_CAR(SCM_CAR(paths)));
SCM pathout = gp_paths; SCM pathout = gp_paths;
gp_engine_path = SCM_CAR(paths); if(SCM_CONSP(paths))
gp_store_path = SCM_CDR(paths); {
gp_engine_path = SCM_CAR(paths);
gp_store_path = SCM_CDR(paths);
}
else
scm_misc_error("gp-set-engine","paths not a cons ~a",scm_list_1(paths));
gp_paths = paths; gp_paths = paths;
......
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