vm stuff

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