soft cut support and support for closure creation in the

parent 1300577c
......@@ -10,6 +10,21 @@
#:use-module (system vm assembler)
#:export (caller push_args_args2 push_args_args push_args))
#|
By setting a procedure as 'with-cut we can pass under the radar
|#
(<define> (argkind f k)
(let ((f (<lookup> f)))
(if (procedure? f)
(case (procedure-property (<lookup> f) 'argkind)
((with-cut)
(<=> k with_cut))
((without-cut)
(<=> k without_cut))
(else
(<=> k #f)))
(<=> k #f))))
(compile-prolog-string "
narg(X,N,N) :- var_p(X),!.
narg([X|L],I,N) :-
......@@ -17,14 +32,32 @@ narg([X|L],I,N) :-
narg(L,II,N).
narg(_,I,I).
push_args_args(X,V,L,LL) :- var_p(X),!,
push_code_with_cut(X,Label,V,L,LL) :-
L=[[label,Label],[clean-sp],LX],
compile_goal(X,#t,V,[LX,LL]).
push_code_without_cut(X,Label,V,L,LL) :-
L=[[label,Label],[clean-sp],LX],
compile_goal(call(X),#t,V,[LX,LL]).
push_args_args(K,X,V,L,LL,LW,LW) :- var_p(X),!,K==#f,
push_args(X,V,L,LL).
push_args_args([X|Y],V,L,LL) :- !,
push_args_args(#f,[X|Y],V,L,LL,_,_) :- !,
push_args(X,V,L,L1),
push_args_args(Y,V,L1,LL).
push_args_args([],V,L,L) :- !.
push_args_args(with_cut,[X|Y],V,L,LL,LW,LLW) :- !,
L=[['push-closure',Label]|LL]
push_code_with_cut(X,Label,V,LW,LLW),
push_args_args(Y,V,L1,LL).
push_args_args(without_cut,[X|Y],V,L,LL,LW,LLW) :- !,
L=[['push-closure',Label]|LL]
push_code_without_cut(X,Label,V,L,L1),
push_args_args(Y,V,L1,LL).
push_args_args(_,[],V,L,L,LW,LW) :- !.
push_args_args2(X,V,L,LL) :- var_p(X),!,
push_args(X,V,L,LL).
......@@ -104,7 +137,7 @@ caller(cc,Args,label(G,N),V,[L,LL]) :- !,
push_v(2,V),
tr(seek,Seek),
L2=[[Seek,3]|L4],
push_args_args(Args,V,L4,LL2),
push_args_args(#f,Args,V,L4,LL2,_,_),
tr('goto-inst', Goto),
LL2 = [[Goto,G]|LL].
......@@ -119,10 +152,10 @@ caller(cc,Args,Tail,V,[L,LL]) :- !,
push_v(2,V),
tr(seek,Seek),
L3=[[Seek,2]|L4],
push_args_args(Args,V,L4,LL2),
push_args_args(#f,Args,V,L4,LL2,_,_),
set_FS(V,F,S),
tr('tail-cc', Call),
LL2 = [[Call]|LL].
LL2 = [[Call]|LW].
caller(F,Args,Tail,V,[L,LL]) :-
touch_Q(V),
......@@ -136,24 +169,25 @@ caller(F,Args,Tail,V,[L,LL]) :-
push_v(3,V),
tr(seek,Seek),
L3=[[Seek,3]|L4],
push_args_args(Args,V,L4,LL2),
argkind(F,K)
push_args_args(K,Args,V,L4,LL2,LW,LL),
touch_A(V),
set_FS(V,scm[(gensym \"F\")],S),
(Tail == #t ->
(
tr('tail-call', Call),
LL2 = [[Call]|LL]
LL2 = [[Call]|LW]
);
Tail = label(G,N) ->
(
tr(goto-inst,Goto),
tr('call-n',Call),
LL2 = [[Call,N],[Goto,G]|LL]
LL2 = [[Call,N],[Goto,G]|LW]
);
(
tr('call', Call),
LL2=[[Call]|LLL],
get_post(S,C,#f,Tail,LLL,LL)
get_post(S,C,#f,Tail,LLL,LW)
)
)).
......@@ -163,7 +197,7 @@ rec(F,A,N,Args,Tail,V,[L,LL]) :-
L=[[Clear]|L2],
get_CS(V,[C|_],S),
set_S(V,0),
push_args_args(Args,V,L2,LL2),
push_args_args(#f,Args,V,L2,LL2,_,_),
touch_A(V),
set_FS(V,F,S),
(
......
......@@ -6,6 +6,7 @@
#:use-module (logic guile-log prolog swi)
#:use-module (compat racket misc)
#:use-module (system vm assembler)
#:use-module (logic guile-log soft-cut)
#:use-module (logic guile-log guile-prolog vm vm-pre)
#:use-module (logic guile-log guile-prolog vm vm-var)
#:export (compile_disj compile_disjunction collect_disj))
......@@ -23,6 +24,13 @@ cat(F,G) :-
)).
collect_disj([],U,U).
collect_disj([A *-> B]|L],U,UU) :-
U=[['soft-if-f',A,B,';'(|L)]|UU].
collect_disj([A -i> B]|L],U,UU) :-
U=[['interleaving-if-f',A,B,';'(|L)]|UU].
collect_disj([X|L],U,UU) :-
collect_disjunction(X,U,U1),
collect_disj(L,U1,UU).
......
(define-module (logic guile-log soft-cut)
#:use-module (logic guile-log)
#:use-module (logic guile-log interleave)
#:export (<soft-if>))
#:export (<soft-if>
soft-if-f
<setup-call-cleanup-once>))
#|
swi uses A *-> B ; C as a soft cut,
......@@ -17,25 +19,66 @@ and rgard removes it from the list going backwards reverses the actions.
(define-guile-log <soft-if>
(syntax-rules ()
((_ w a b) (<and> w a b))
((_ w a b c)
(<let> w ((p0 P)
(s0 S)
(cut1 CUT)
(cc CC)
(fr (<newframe>)))
(<let-with-lr-guard> wind lguard rguard
((rp (lambda ()
(<unwind-tail> fr)
(parse<> (cut1 s0 p0 cc) c))))
((_ w a b) (<and> w a b))
((_ w a b c)
(<let> w ((p0 P)
(s0 S)
(cut1 CUT)
(cc CC)
(fr (<newframe>)))
(<let-with-lr-guard> wind lguard rguard
((rp (lambda ()
(<unwind-tail> fr)
(parse<> (cut1 s0 p0 cc) c))))
(lguard
(</.>
(<with-fail> (lambda () (rp))
(<with-cut> cut1
a
(<code> (set! rp p0))
(<let> ((cut2 CUT))
(rguard
(lguard
(</.>
(<with-fail> (lambda () (rp))
(<with-cut> cut1
a
(<code>
(if (gp-deterministic? fr S)
(<unwind-tail> fr)))
(<code> (set! rp p0))
(<let> ((cut2 CUT))
(rguard
(</.>
(<with-cut> cut2 b)))))))))))))
(<define> (soft-if-f a b c) (<soft-if> (a) (b) (c)))
(set-procedure-property soft-if-f 'argkind 'with-cut)
(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
(</.>
pre
(<dynwind>
(lambda ()
(error "<setup-call-cleanup> is not reentrable"))
(lambda (x)
(if (not done?)
(set! done #t)
(<wrap-s> S cleanup))))
(<dynwind>
(<lambda> ())
(<lambda> ()))
(<let> ((s0 S))
action
(if (gp-deterministic? s0 S)
(<and>
(<code> (set! done? #t))
clenup
<cut>
<fail>)
<cc>)
(rguard
(</.> <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