vm stuff

parent 4d3eb903
......@@ -20,6 +20,7 @@
make-vm-function
compile_to_fkn
instr define-prolog
generate-prolog-assembler
mockalambda))
#|
......
......@@ -89,6 +89,7 @@ variables is the most difficult part to maintain
bv))
;; Setting up the vm engine meta information
#;
(define vm-model
((@@ (logic guile-log code-load) gp-make-vm-model) vm-bytevector))
......@@ -160,15 +161,8 @@ variables is the most difficult part to maintain
(stackSize (pp 'size: (<lookup> stackSize)))
(constants (pp 'constants: (map car (<scm> constants)))))
<cut>
(<=> f
,(name-it
(make-vm-function
(cons (+ narg 4) (+ stackSize nsvar))
(pack-start nvar
stackSize
(mk-instructions instructions)
(list->vector constants)
tvar))))))))))
(<=> f ,(list instructions nvar tvar nsvar narg stackSize constants))))))))
(define (get-mod c)
(let ((a (procedure-property c 'module)))
......@@ -264,6 +258,11 @@ generate_stx(STX,X,F) :-
)).
")
(define (generate-prolog-assembler code-string)
(prolog-run 1 (f)
(generate_lambda code-string f)))
(define-syntax-rule (define-prolog-fkn n code-string)
(define n (letrec ((n
(let ((g (prolog-run 1 (f)
......
......@@ -8,6 +8,7 @@
#:use-module (system vm assembler)
#:use-module (logic guile-log guile-prolog vm vm-pre)
#:use-module (logic guile-log guile-prolog vm vm-var)
#:use-module (logic guile-log vm vm)
#:export (compile_conj collect_conj))
(include-from-path "logic/guile-log/guile-prolog/vm/vm-conj-model.scm")
......@@ -9,6 +9,7 @@
#: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)
#:use-module (logic guile-log vm vm)
#:export (compile_disj compile_disjunction collect_disj))
(include-from-path "logic/guile-log/guile-prolog/vm/vm-disj-model.scm")
......@@ -376,7 +376,7 @@ compile_goal(\\+\\+\\+X,Tail,V,[L,LL]) :- !,
compile_goal(\\+X,Tail,V,[L,LL]).
compile_goal(\\+\\+X,Tail,V,[L,LL]) :- !,
L=[['newframe-negation',Al,0]|LX],
L=LX,
get_QAESBB2(V,Q,AA,E,S,B,B2),
set_QAE(V,[],[[0|_]],0),
new_var(VP,V,TagP1),
......
......@@ -15,6 +15,7 @@
#:use-module (logic guile-log guile-prolog vm vm-conj)
#:use-module (logic guile-log guile-prolog vm vm-handle)
#:use-module (system vm assembler)
#:use-module (logic guile-log vm vm)
#:export (begin_att end_att recur verbatim_call with_cut pr
extended_off extended_on))
......
......@@ -7,6 +7,7 @@
#:use-module (compat racket misc)
#:use-module (logic guile-log guile-prolog vm vm-pre)
#:use-module (logic guile-log guile-prolog vm vm-var)
#:use-module (logic guile-log vm vm)
#:use-module (system vm assembler)
#:export (handle_all))
......
......@@ -8,6 +8,7 @@
#:use-module (system vm assembler)
#:use-module (logic guile-log guile-prolog vm vm-pre)
#:use-module (logic guile-log guile-prolog vm vm-var)
#:use-module (logic guile-log vm vm)
#:export (compile_imprint))
(include-from-path "logic/guile-log/guile-prolog/vm/vm-imprint-model.scm")
......@@ -7,6 +7,7 @@
#:use-module (logic guile-log vlist)
#:use-module (compat racket misc)
#:use-module (system vm assembler)
#:use-module (logic guile-log vm vm)
#:replace (tr)
#:export ())
......
......@@ -9,6 +9,7 @@
#:use-module (logic guile-log guile-prolog vm vm-pre)
#:use-module (logic guile-log guile-prolog vm vm-var)
#:use-module (logic guile-log guile-prolog vm vm-imprint)
#:use-module (logic guile-log vm vm)
#:export (compile_unify))
(include-from-path "logic/guile-log/guile-prolog/vm/vm-unify-model.scm")
(define-module (logic guile-log vm call)
#:use-module ((logic guile-log iso-prolog)
#:renamer
(lambda (x) (if (eq? x 'reset)
'reset_iso
x)))
(lambda (x)
(cond
((eq? x 'reset)
'reset_iso)
((eq? x 'cc)
'cc_iso)
((eq? x 'pp)
'pp_iso)
(else
x))))
#:use-module (logic guile-log vm utils)
#:use-module (logic guile-log vm fkn)
#:export (call cc-call tail-call post-call post-unicall
restore-c fail-psc fail-pc))
#:export (in-call cc-call tail-call post-call post-unicall))
(compile-prolog-string
"
......@@ -19,94 +26,36 @@
).
gset('stack',sp(0),1,L1,L2).
cc(A,I,0,L,LL) :-
'cc-call'(A,I,0,L,LL) :-
scm_tailcall(cc,[s,pp|A],0,_,L,LL).
call(F,A,P,CC,I,0,L,LL) :-
store_stack(I,II,L,l1),
scm_tailcall(F,[s,pp,CC|A],0,_,L1,LL).
'in-call'(F,A,P,CC,I,II,L,LL) :-
store_stack(I,I1,L,L1),
scm_tailcall(F,[s,pp,CC|A],I1,II,L1,LL).
'in-tailcall'(F,A,P,CC,I,II,L,LL) :-
scm_tailcall(F,[s,pp,CC|A],I,II,L,LL).
pp(I,II,L,LL) :-
gset(sp(I),p,L,L1),
II is I + 1,
isProcedure(sp(I),Lab,II,L,L1),
scmcall1('gp-make-p',[self],I,I1,L,L1),
isProcedure(p,Lab,II,L1,L2),
scmcall1('gp-make-p',[self],I,I1,L2,L3),
move(I1-1,I,L1,LL),
label(Lab,L3,L4).
'cc-call'(C,I,II,L,LL) :-
scmcall('gp-make-cc',[self,stack,l(C),cut],I,I1,L,L1),
scmcall('gp-make-cc',[self,l(C)],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).
'post-call'(NARG,I,II,L,LL) :-
I0 is NARG + 2,
'goto-stackstart'(I0,I1),
'install-stack'(I1,II,L,LL).
'restore-c'.
'fail-psc'.
'fail-pc'.
'post-unicall'(I,II,L,LL) :-
'goto-stackstart'(II),
'install-stack'(I1,II,L,LL).
")
(define (gp-make-p p self)
(make-closure self self.vec p.ip p.stack p.cut p.scut))
(define (gp-make-cc self stack next-ip cut scut)
(make-closure self.proc self.vec ip stack cut scut))
(define-module (logic guile-log vm newframe)
#:use-module (logic guile-log vm utils)
#:use-module (logic guile-log iso-prolog)
#:use-module ((logic guile-log iso-prolog)
#:renamer
(lambda (s)
(cond
((eq? s 'cc) 'pl-cc)
((eq? s 'reset) 'pl-reset)
(else s))))
#:export (newframe-ps newframe-pst newframe-light newframe
newframe-negation
store-state store-ps store-p))
(compile-prolog-string
"
'store-ps'.
'store-p'.
'store-ps'(P,S,I,L,LL) :-
gset(P,p,I,L,LL),
gset(S,s,I,L,LL).
'store-p'(P,I,L,LL) :-
gset(P,p,I,L,LL).
% Probably not used
......@@ -17,11 +27,11 @@
mkconses2([A|U],I,L,LL) :-
gset(sp(I),A,I,L,L1),
II is I + 1,
'mk-cons(II,L1,L2),
'mk-cons'(II,L1,L2),
mkconses(U,I,L2,LL).
mkconses([A|U],I,L,LL) :-
reset(I+2,L,L1)
reset(I+2,L,L1),
gset(sp(I),A,I,L1,L2),
II is I + 1,
mkconses2(U,II,L2,L3),
......@@ -37,17 +47,21 @@
reset(I,L4,LL).
'newframe-ps'(A,P,S,I,L,LL) :-
gset(P,p,I,L,L1),
gset(S,s,I,L1,L2),
gset(p,l(A),I,L2,L3),
reset(I,L3,LL).
scmcall('gp-newframe',[s],I,I1,L,L1),
gset(P,p,I1,L1,L2),
gset(S,s,I1,L2,L3),
gset(p,l(A),I1,L3,L4),
gset(s,sp(I1-1),I1,L4,L5),
reset(I,L5,LL).
'newframe-pst'(A,P,S,T,I,L,LL) :-
gset(P,p,I,L,L1),
gset(S,s,I,L1,L2).
gset(T,delayers,I,L2,L3),
gset(p,l(A),I,L3,L4).
reset(I,L4,LL).
scmcall('gp-newframe',[s],I,I1,L,L1),
gset(P,p,I1,L1,L2),
gset(S,s,I1,L2,L3).
gset(T,delayers,I1,L3,L4),
gset(p,l(A),I1,L4,L5).
gset(s,sp(I1-1),I1,L5,L6),
reset(I,L6,LL).
'newframe-light'(P,NP,I,L,LL) :-
sset(P,p,I,L,L1),
......@@ -65,7 +79,7 @@
'newframe-negation'(NP,TP,I,L,LL) :-
I1 is I + 1,
gset(sp(I),l(NP),I,L1,L2),
'store-state'([sp(I),c(TP),scut,p,newframe,],II,L1,L2),
'store-state'([sp(I),c(TP),scut,p,newframe],II,L1,L2),
III is II + 1,
gset(cstack,sp(II),III,L2,L3),
scmcall('gp-newframe-negation',[s],II,I2,L2,L3),
......
(define-module (logic guile-log vm op)
#:use-module (logic guile-log vm utils)
#:use-module (logic guile-log iso-prolog)
#:export (plus minus band bor xor modulo mul shift-l shift-r
#:use-module ((logic guile-log iso-prolog)
#:renamer
(lambda (s)
(if (eq? s 'reset)
'pl-reset
s)))
#:replace (plus minus band bor xor modulo mul shift-l shift-r
divide
gt lt le eq neq))
......@@ -50,7 +54,7 @@
band(I,II,L,LL) :- binop(band,I,II,L,LL).
bor(I,II,L,LL) :- binop(bor,I,II,L,LL).
xor(I,II,L,LL) :- binop(xor,I,II,L,LL).
modulo(I,II,L,LL) :- binop(modulo,I,II,L,LL).
modulo(I,II,L,LL ) :- binop(modulo,I,II,L,LL).
mul(I,II,L,LL) :- binop(mul,I,II,L,LL).
'shift-l'(I,II,L,LL) :- binop('shift-l',I,II,L,LL).
'shift-r'(I,II,L,LL) :- binop('shift-r',I,II,L,LL).
......
......@@ -5,7 +5,7 @@
'reset_iso
x)))
#:use-module (logic guile-log vm utils)
#:export (cutter goto-inst sp-move equal-instruction
#:replace (cutter goto-inst sp-move equal-instruction
push-instruction pushv push-variable
pop-variable pop seek dup clear-sp))
......
(define-module (logic guile-log vm unify)
#:use-module (logic guile-log vm utils)
#:use-module (logic guile-log iso-prolog)
#:use-module ((logic guile-log iso-prolog)
#:renamer
(lambda (s)
(cond
((eq? s 'cc) 'pl-cc)
((eq? s 'reset) 'pl-reset)
(else s))))
#:export (ggset unify unify-2 unify-constant-2
unify-instruction pre-unify post-unify-tail
post-unify
......@@ -14,44 +21,10 @@
scmcall('gp-set',[V,sp(-1),s],I,I1,L,L1),
reset(I,L1,LL).
/*
(UNPACK-VAR 1 n i2 pinned? variables variables-scm nvar
cnst session middle
(<=> (SVAR-REF fp nstack i2) (<call> scm_fluid_ref *delayers*))
(<=> (<ref> variables i2) (<call> scm_fluid_ref *delayers*)))))
*/
'pre-unify'(V,I,L,LL) :-
vset('call?',c(0),I,L,L1),
gset(V,top(delayers),I,L,L1).
/*
(define-syntax-rule (POST-UNIFY inst-pt sp-stack nstack sp fp
pinned? variables variables-scm nvar
cnst session middle)
(<let*> ((SCM n (<*> inst-pt))
(int nsloc (scm->int (<ref> inst-pt (<c> 1))))
(SCM old (UNPACK-VAR 0 n i2 pinned? variables variables-scm nvar
cnst session middle
(SVAR-REF fp nstack i2)
(<ref> variables i2))))
(UNPACK-VAR 1 n i2 pinned? variables variables-scm nvar
cnst session middle
(<=> (SVAR-REF fp nstack i2) (<scm> #f))
(<=> (<ref> variables i2) (<scm> #f)))
(<=> inst-pt (<+> inst-pt (<c> 2)))
(<if> (<not> (EQ (<call> scm_fluid_ref *delayers*) old))
(<begin>
(<=> sp-stack (GET-STACK fp sp))
(<if> (q> nsloc (<c> 0))
(LINK-SVARS fp nstack nsloc sp-stack))
(<=> (FARG 0 fp) *dls*)
(<=> (FARG 4 fp) old)
(<=> sp (PFARG 5 fp))
(<goto> call)))))
*/
'post-unify'(V,Nsloc,I,L,LL) :-
gref(V,I,L,L1),
II is I + 1,
......@@ -62,31 +35,6 @@
generate('delay-call'(Nsloc),L6,LL),
label(E,LL).
/*
(define-syntax-rule (POST-UNIFY-TAIL inst-pt sp-stack nstack
sp fp pinned? variables variables-scm
nvar cnst session middle)
(<let*> ((SCM n (<*> inst-pt))
(SCM old (UNPACK-VAR 0 n i2 pinned? variables variables-scm nvar
cnst session middle
(SVAR-REF fp nstack i2)
(<ref> variables i2))))
(UNPACK-VAR 1 n i2 pinned? variables variables-scm nvar
cnst session middle
(<=> (SVAR-REF fp nstack i2) (<scm> #f))
(<=> (<ref> variables i2) (<scm> #f)))
(<=> inst-pt (<+> inst-pt (<c> 1)))
(<if> (<not> (EQ (<call> scm_fluid_ref *delayers*) old))
(<begin>
(<=> sp-stack (GET-STACK fp sp))
(<=> (FARG 0 fp) *dls*)
(<=> (FARG 4 fp) old)
(<=> sp (PFARG 5 fp))
(<goto> tail-call))
(<goto> cc))))
*/
'post-unify-tail'(V,Nsloc,I,L,LL) :-
gref(V,I,L,L1),
......@@ -96,20 +44,20 @@
generate(eq(I,II),L4,L5),
generate(je(E),L5,L6),
generate('delay-call'(Nsloc),L6,L7),
label(E,LL).
cc(L7,LL)
label(E,LL),
cc(L7,LL).
unify(Code,V,I,II,L,LL) :-
M is Code & 3,
A is Code & 4 >> 2,
K is Code & 24 >> 3,
M is (Code /\\ 3),
A is (Code /\\ 4) >> 2,
K is (Code /\\ 24) >> 3,
(
M==2 ->
pltest(gp_m_unify [V,sp(I-1),s],I,_,L,L1);
pltest('gp-m-unify',[V,sp(I-1),s],I,_,L,L1);
(M==3 ; K==3) ->
pltest_s(gp_gp_unify_raw [V,sp(I-1),s],I,L,L1);
pltest_s(gp_gp_unify [V,sp(I-1),s],I,L,L1)
pltest_s('gp-unify-raw',[V,sp(I-1),s],I,L,L1);
pltest_s('gp-unify',[V,sp(I-1),s],I,L,L1)
),
II is I - 1,
reset(II,L1,LL).
......@@ -117,13 +65,13 @@
'unify-2'(Code,V1,V2,I,L,LL) :-
M is Code & 3,
M is Code /\\ 3,
Code2 is Code >> 2,
A1 is Code2 & 1,
K1 is Code2 & 6 >> 1,
A1 is Code2 /\\ 1,
K1 is (Code2 /\\ 6) >> 1,
Code3 is Code2 >> 24,
A2 is Code3 & 1,
K2 is is Code3 & 6 >> 1,
A2 is Code3 /\\ 1,
K2 is (Code3 /\\ 6) >> 1,
(
K1 == 2 ->
......@@ -154,7 +102,7 @@
(
(M==3;K1==3;K2==3) ->
pltest_s('gp-unify-raw',[V1,V2,s],I,L,L1);
pltest_S(gp_gp_unify,[V1,V2,s],I,L,L1)
pltest_S('gp-unify',[V1,V2,s],I,L,L1)
),
reset(I,L1,LL)
)
......@@ -163,24 +111,25 @@
).
'unify-constant-2'(Code,V,I,L,LL) :-
M is Code & 3,
A is Code & 4 >> 2,
K is Code & 24 >> 3,
M is Code /\\ 3,
A is (Code /\\ 4) >> 2,
K is (Code /\\ 24) >> 3,
(
K == #f ->
gset(V,c(C),I,L,LL);
(
M == #f
M == #f ->
(
pltest(gp_m_unify,[V,c(C),s],I,_,L,L2),
pltest('gp-m-unify',[V,c(C),s],I,_,L,L2),
reset(I,L2,LL)
)
);
(
(
(M=#t;K=#t) ->
pltest_s('gp-unify-raw',[V,c(C),s],I,L,L1);
pltest_s('gp_unify',[V,c(C),s],I,L,L1)
pltest_s('gp-unify',[V,c(C),s],I,L,L1)
),
reset(I,L1,LL)
)
......
......@@ -3,180 +3,106 @@
#: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)
post-negation post-s post-q post-c post-sc restore-c restore-pc
softie softie-light softie-ps softie-pc softie-psc
fail-psc fail-pc))
(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),
gfail(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'.
'post-c'(C,I,L,LL) :-
gset(cut,C,I,L,LL).
/*
(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)))
*/
'post-sc'(S,C,I,L,LL) :-
gset(s,S,I,L,L1),
gset(cut,C,I,L1,LL).
'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))))))
*/
'unwind-ps'(P,S,I,L,LL) :-
scmcall('gp-unwind',[S],I,I1,L,L1),
gset(s,sp(I1-1),I,L1,L2).
gset(p,P,I,2,L3),
'unwind-psc'(P,S,C,I,L,LL) :-
scmcall('gp-unwind',[S],I,I1,L,L1),
gset(s,sp(I1-1),I,L1,L2),
gset(p,P,I,L2,L3),
gset(cut,C,I,L3,LL).
'unwind-psct'(P,S,C,T,I,L,LL) :-
scmcall('gp-unwind',[S],I,I1,L,L1),
gset(s,sp(I1-1),I,L1,L2),
gset(p,P,I,L2,L3),
gset(cut,C,I,L3,L4),
gset(delayers,T,I,L4,LL).
'unwind-pst'(P,S,T,I,L,LL) :-
scmcall('gp-unwind',[S],I,I1,L,L1),
gset(s,sp(I1-1),I,L1,L2),
gset(p,P,I,L2,L3),
gset(s,S,I,L3,L4),
gset(delayers,T,I,L4,LL).
'restore-c'(C,I,L,LL) :-
gset(cut,C,I,L,LL).
'restore-pc'(P,C,I,L,LL) :-
gset(p,P,I,L,L1),
gset(cut,C,I,L1,LL).
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).
'softie-ps'(P,S,I,L,LL) :-
get(p,P,I,L,L1),
get(s,S,I,L1,LL).
'softie-pc'(P,C,I,L,LL) :-
get(p,P,I,L,L1),
get(cut,C,I,L1,LL).
/*