unwind

parent e7539c41
......@@ -6,7 +6,8 @@
x)))
#:use-module (logic guile-log vm utils)
#:use-module (logic guile-log vm fkn)
#:export ())
#:export (call cc-call tail-call post-call post-unicall
restore-c fail-psc fail-pc))
(compile-prolog-string
"
......@@ -33,11 +34,74 @@
move(I1-1,I,L1,LL),
label(Lab,L3,L4).
cc(C,I,II,L,LL) :-
'cc-call'(C,I,II,L,LL) :-
scmcall('gp-make-cc',[self,stack,l(C),cut],I,I1,L,L1),
move(I1-1,I,L1,LL),
II is I + 1.
/*
(LABEL post-call)
(PRSTACK sp fp)
(<let> ((SCM c (<ref> inst-pt (<c> 0)))
(SCM pop? (<ref> inst-pt (<c> 1))))
(<=> inst-pt (<+> inst-pt (<c> 2)))
(<if> call?
(<begin>
(<=> call? (<c> 0))
(<if> (TRUE pop?)
(DECR 3 sp))
(<=> cut c)
(<if> (PAIR? sp-stack)
(INSTALL-STACK fp sp nstack (<c> 0) sp-stack))
(NEXT inst-pt))))
*/
'post-call(C,POP,I,L,LL) :-
gref(I,call?),
isTrue(I),
generate(ne(Label),L,L2),
gset(call?,const(0),L2,L3),
(
POP=#t ->
arith(sp,sp - const(3),L3,L4);
L4 = L3
),
gset(cut,label(C),I,L4,L5),
gref(I,sp-stack,II,L5,L6),
conspTest(I,L6,L7),
generate(ne(Label2),L7,L8)),
call('install-stack',[vec],I,L8,L9),
generate(label(Label2),L9,LL).
/*
(LABEL post-unicall)
(PRSTACK sp fp)
(<let> ((SCM c (<ref> inst-pt (<c> 0)))
(int nsloc (scm->int (<ref> inst-pt (<c> 1)))))
(<=> inst-pt (<+> inst-pt (<c> 2)))
(<if> call?
(<begin>
(<=> call? (<c> 0))
(DECR 3 sp)
(<=> cut c)
(<if> (PAIR? sp-stack)
(INSTALL-STACK fp sp nstack nsloc sp-stack))))
(NEXT inst-pt))
*/
'post-unicall'(C,NSLOC,I,L,LL) :-
gset(call?,const(0),I,L,L2),
arith(sp,sp - const(3),I,L2,L3),
gset(cut,label(C),I,L3,L4),
gref(I,sp-stack,II,L5,L6),
conspTest(I,L6,L7),
generate(ne(Label2),L7,L8)),
call('install-stack',[vec],I,L8,L9),
generate(label(Label2),L9,LL).
'restore-c'.
'fail-psc'.
'fail-pc'.
")
(define (gp-make-p p self)
......
......@@ -2,11 +2,33 @@
#:use-module (logic guile-log vm utils)
#:use-module (logic guile-log iso-prolog)
#:export (newframe-ps newframe-pst newframe-light newframe
newframe-negation))
newframe-negation
store-state store-ps store-p))
(compile-prolog-string
"
'store-ps'.
'store-p'.
/*
(LABEL store-state)
(PRSTACK sp fp)
(<let> ((SCM tag (<ref> inst-pt (<c> 0)))
(SCM np (<ref> inst-pt (<c> 1))))
(<=> inst-pt (<+> inst-pt (<c> 2)))
(STORE-STATE-SOFT s tag p fp nstack)
(<call> INTERUPT)
(NEXT inst-pt))
(define-syntax-rule (STORE-STATE-SOFT s tag p fp nstack)
(<let> ((int v (scm->int tag)))
(<=> (SVAR-REF fp nstack v) p)))
*/
'store-state'(Tag,NP,I,L,LL) :-
sset(Tag,p,I,L,LL)
'newframe-ps'(PP,SS,I,L,LL) :-
gset(PP,p,I,L,L1),
gset(SS,s,I,L1,L2),
......
(define-module (logic guile-log vm unwind)
#:use-module (logic guile-log vm utils)
#:use-module (logic guile-log iso-prolog)
#:export (unwind-light-tail unwind-light unwind unwind-negation
unwind-tail unwind-ps unwind-psc unwind-psct unwind-pst
post-negation post-s post-q post-c post-sc
softie softie-light softie-ps softie-pc softie-psc)
(compile-prolog-string
"
/*
(LABEL post-negation)
(PRSTACK sp fp)
(<let> ((SCM np (<ref> inst-pt (<c> 0))))
(<=> cut (<ref> inst-pt (<c> 1)))
(<=> inst-pt (<+> inst-pt (<c> 2)))
(<let> ((SCM fr (RESTORE-STATE-TAIL-NEG s scut p np ctrl-stack))
(int n (scm->int (<call> gp_gp_lookup *gp-not-n* s)))
(SCM d (<call> gp_gp_lookup *gp-is-delayed?* s)))
(UNWIND-TAIL fr)
(<if> (<and> (q> n (<c> 1))
(<call> scm_is_true d))
(<begin>
(<call> gp_fluid_force_bang
*gp-is-delayed?* (<scm> #t) s)
(BACKTRACK p instructions inst-pt fp sp))
(NEXT inst-pt))))
*/
'post-negation'(NP,CUT,I,L,LL) :-
scm_call('gp-post-negation',[vec,c(NP),c(CUT)],I,L,L1),
generate('immediate-tag=?'(I,3839,4),L1,L2),
generate(je(A),L2,L3),
fail(I,L3,L4),
label(A,L4).
/*
(LABEL post-s)
(PRSTACK sp fp)
(<let> ((SCM np (<ref> inst-pt (<c> 0))))
(<=> cut (<ref> inst-pt (<c> 1)))
(<=> inst-pt (<+> inst-pt (<c> 2)))
(<let> ((fr (RESTORE-STATE-TAIL-NEG s scut p np ctrl-stack)))
(UNWIND-TAIL fr)
(NEXT inst-pt)))
*/
'post-s'(NP,CUT,I,L,LL) :-
scmcall('gp-post-s',[vec,c(NP),c(CUT)],I,L,LL).
/*
(LABEL post-q)
(PRSTACK sp fp)
(<=> cut (<ref> inst-pt (<c> 0)))
(<=> inst-pt (<+> inst-pt (<c> 1)))
(NEXT inst-pt)
*/
'post-q'(CUT,I,L,LL) :-
gset(cut,c(CUT),I,L,LL).
'post-c'.
'post-sc'.
/*
(LABEL unwind-tail)
(PRSTACK sp fp)
(<let> ((SCM tag (<*> inst-pt)))
(<=> inst-pt (<+> inst-pt (<c> 1)))
(<let> ((ss (RESTORE-STATE-TAIL s p tag ctrl-stack)))
(UNWIND-TAIL ss)
(NEXT inst-pt)))
*/
'unwind-tail'(Tag,I,L,LL) :-
scmcall('restore-state-tail',[vec,c(Tag)],I,L,LL).
/*
(LABEL unwind-light-tail)
(PRSTACK sp fp)
(<let> ((SCM tag (<*> inst-pt)))
(<=> inst-pt (<+> inst-pt (<c> 1)))
(RESTORE-STATE-SOFT s p tag fp nstack)
(NEXT inst-pt))
(define-syntax-rule (RESTORE-STATE-SOFT s p tag fp nstack)
(<let> ((int v (scm->int tag)))
(<=> p (SVAR-REF fp nstack v))))
*/
'unwind-light-tail'(Tag,I,L,LL) :-
gset(p,svar(Tag),I,L,LL).
'unwind-ps'.
'unwind-psc'.
'unwind-psct'.
'unwind-pst'.
/*
(LABEL softie)
(PRSTACK sp fp)
(<let> ((SCM tag (<*> inst-pt)))
(<=> inst-pt (<+> inst-pt (<c> 1)))
(RESTORE-STATE-TAIL-P p tag ctrl-stack)
(NEXT inst-pt))
(define-syntax-rule (RESTORE-STATE-TAIL-P p tag stack)
(<recur> lp ()
(<let> ((x (GGPCAR stack)))
(FORMAT "RESTORE-P x : ~a tag : ~a~%" x tag)
(<if> (EQ (GGPCAR x) tag)
(<let*> ((x1 (GGPCDR x)))
(<=> p (GGPCAR x1))
(<=> stack (GGPCDR stack))
(PRUNE-TAIL (GGPCDR (GGPCAR (GGPCDR x1)))))
(<begin>
(<=> stack (GGPCDR stack))
(<next> lp))))))
*/
softie(Tag,I,L,LL) :-
scmcall('restore-state-tail-p',[vec,c[Tag]],I,L,LL).
/*
(LABEL softie-light)
(PRSTACK sp fp)
(<let> ((SCM tag (<*> inst-pt)))
(<=> inst-pt (<+> inst-pt (<c> 1)))
(RESTORE-STATE-SOFT s p tag fp nstack)
(NEXT inst-pt))
*/
'softie-light'(Tag,I,L,LL) :-
gset(p,svar(Tag),I,L,LL).
'softie-ps'.
'softie-pc'.
'softie-psc'.
/*
(LABEL unwind)
(<let> ((SCM tag (<ref> inst-pt (<c> 0))))
(<=> p (<ref> inst-pt (<c> 1)))
(<=> inst-pt (<+> inst-pt (<c> 2)))
(<let> ((int ncons (RESTORE-STATE s tag ctrl-stack)))
(UNWIND s ncons)
(NEXT inst-pt)))
*/
unwind(Tag,P,I,L,LL) :-
scmcall('gp-unwind-it',[vec,c(Tag),c(P)],I,L,LL).
/*
(LABEL unwind-light)
(PRSTACK sp fp)
(<=> p (<ref> inst-pt (<c> 1)))
(<=> inst-pt (<+> inst-pt (<c> 1)))
(NEXT inst-pt)
*/
'unwind-light'(P,I,L,LL) :-
gset(p,c(P),I,L,LL).
/*
(LABEL unwind-negation)
(PRSTACK sp fp)
(<let> ((SCM n (<*> inst-pt)))
(<=> cut (<ref> inst-pt (<c> 1)))
(RESTORE-STATE-TAIL-NEG-0 scut p n ctrl-stack)
(<call> gp_fluid_force_bang *gp-is-delayed?* (<scm> #f) s)
(BACKTRACK p instructions inst-pt fp sp))
*/
'unwind-negation'(N,CUT,I,L,LL) :-
scmcall('gp-unwind-negation',[vec,c(N),c(CUT)],I,L,LL).
")
This diff is collapsed.
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