disjunction works

parent af5a5ce2
......@@ -142,6 +142,10 @@ variables is the most difficult part to maintain
(lp (cdr l) (+ i 1)))))
v))
(define (pp x y)
(format #t "~a ~a~%" x y)
y)
(define pack-start (@@ (logic guile-log code-load) pack-start))
(define (name-it x) (set-procedure-property! x 'name 'anonymous) x)
(<define> (compile_to_fkn code f)
......@@ -154,13 +158,14 @@ variables is the most difficult part to maintain
(<<match>> (#:mode -) (l)
((x . l) (lp l ((@ (guile) append) ((@ (guile) reverse) x) o)))
(()
(let ((instructions ((@ (guile) reverse) o))
(nvar (<lookup> nvar))
(tvar (<lookup> tvar))
(nsvar (<lookup> nsvar))
(narg (<lookup> narg))
(stackSize (<lookup> stackSize))
(constants (map car (<scm> constants))))
(let ((instructions (pp 'instructions: ((@ (guile) reverse) o)))
(nvar (pp 'nvar: (<lookup> nvar)))
(tvar (pp 'tvar: (<lookup> tvar)))
(nsvar (pp 'nsvar: (<lookup> nsvar)))
(narg (pp 'narg: (<lookup> narg)))
(stackSize (pp 'size: (<lookup> stackSize)))
(constants (pp 'constants: (map car (<scm> constants)))))
<cut>
(<=> f
,(name-it
(make-vm-function
......@@ -168,7 +173,7 @@ variables is the most difficult part to maintain
(pack-start nvar
stackSize
(mk-instructions instructions)
constants
(list->vector constants)
tvar))))))))))
......@@ -26,8 +26,9 @@ constant = #(nlocals nstack constants code)
(auto-defs)
(eval-when (compile eval load)
(define debug #t))
(define debug #t)
(define-syntax DB
(lambda (x)
(syntax-case x ()
......@@ -127,6 +128,7 @@ constant = #(nlocals nstack constants code)
(<=> middle (CONS (<scm> '()) session))
(<=> pinned? (<scm> #f)))))
(define-syntax-rule (1- x) (int->scm (<-> (scm->int x) (<c> 1))))
(define-syntax-rule (GET-TOKEN) (<call> gp_get_state_token))
(define-syntax-rule (SET x y s) (<call> gp_set x y s))
(define-syntax-rule (CAR x) (<call> SCM_CAR x))
......@@ -206,14 +208,14 @@ constant = #(nlocals nstack constants code)
(<=> (<ref> vp (<c> 3)) w)
v))
((_ x y z w v)
(<let*> ((v (<call> scm_c_make_vector (<c> 5) (<scm> #f)))
((SCM *) vp (scm->vector v)))
(<let*> ((vv (<call> scm_c_make_vector (<c> 5) (<scm> #f)))
((SCM *) vp (scm->vector vv)))
(<=> (<ref> vp (<c> 0)) x)
(<=> (<ref> vp (<c> 1)) y)
(<=> (<ref> vp (<c> 2)) z)
(<=> (<ref> vp (<c> 3)) w)
(<=> (<ref> vp (<c> 3)) v)
v))))
(<=> (<ref> vp (<c> 4)) v)
vv))))
(define-syntax-rule (PRINTF a ...)
(DB (<icall> 'printf (<c> a) ...)))
......@@ -274,6 +276,7 @@ constant = #(nlocals nstack constants code)
(<label> s)
(PRINTF "%s : %d\n" (symbol->string 's) (hash-ref *map* 's 0)))))
#;
(define-syntax-rule (LABEL s)
(begin
(TOUCH s 1)
......@@ -686,22 +689,19 @@ constant = #(nlocals nstack constants code)
(define-syntax-rule (STORE-STATE tp tag s p stack)
(<let> ((np (<if> (NUMBER? p) p (<scm> 0))))
(CONS (CONS tag
(CONS s
(<if> tp
(CONS p
(<call> scm_fluid_ref
*delayers*))
p)))
stack)))
(CONS (CONS tag
(CONS s
(<if> tp
(CONS p
(<call> scm_fluid_ref *delayers*))
p)))
stack))
(define-syntax-rule (STORE-STATE-SOFT tag p stack)
(<let> ((np (<if> (NUMBER? p) p (<scm> 0))))
(CONS (CONS tag
(CONS (<scm> #f)
p))
stack)))
(CONS (CONS tag
(CONS (<scm> #f)
p))
stack))
(define-syntax-rule (CLEAR-SP-XP sp xp)
(<recur> lp ()
......@@ -720,7 +720,7 @@ constant = #(nlocals nstack constants code)
(define-syntax-rule (RESTORE-STATE s tag stack)
(<recur> lp ()
(<let> ((x (CAR stack)))
(<if> (EQ x tag)
(<if> (EQ (CAR x) tag)
(<let*> ((x1 (CDR x))
(ss (CAR x1))
(x2 (CDR x1)))
......@@ -735,26 +735,26 @@ constant = #(nlocals nstack constants code)
(define-syntax-rule (RESTORE-STATE-TAIL s p tag stack)
(<recur> lp ()
(<let> ((x (CAR stack)))
(<if> (EQ x tag)
(<let*> ((x1 (CDR x))
(ss (CAR x1))
(x2 (CDR x1)))
(<=> stack (CDR stack))
(<=> s ss)
(<if> (PAIR? x2)
(<begin>
(<=> p (CAR x2))
(<call> scm_fluid_set_x *delayers*
(CDR x2)))
(<=> p x2)))
(<begin>
(<=> stack (CDR stack))
(<next> lp))))))
(<if> (EQ (CAR x) tag)
(<let*> ((x1 (CDR x))
(ss (CAR x1))
(x2 (CDR x1)))
(<=> stack (CDR stack))
(<=> s ss)
(<if> (PAIR? x2)
(<begin>
(<=> p (CAR x2))
(<call> scm_fluid_set_x *delayers*
(CDR x2)))
(<=> p x2)))
(<begin>
(<=> stack (CDR stack))
(<next> lp))))))
(define-syntax-rule (RESTORE-STATE-SOFT p tag stack)
(<recur> lp ()
(<let> ((x (CAR stack)))
(<if> (EQ x tag)
(<if> (EQ (CAR x) tag)
(<let*> ((x1 (CDR x))
(x2 (CDR x1)))
(<=> stack (CDR stack))
......@@ -825,7 +825,8 @@ constant = #(nlocals nstack constants code)
(REGISTER icurly!)
(REGISTER ifkn!)
(REGISTER icons!)
(REGISTER fail)
(REGISTER cc)
(REGISTER tail-cc)
(REGISTER call)
......@@ -883,12 +884,12 @@ constant = #(nlocals nstack constants code)
(<=> const (CDR session))))
(define-syntax-rule (UNPACK-ALWAYS always p? ninst ctrl-stack pp)
(<let*> ((SCM x1 (CAR always))
(int ninst (scm->int (CAR x1)))
(<let*> ((SCM x1 (CAR always))
(SCM x2 (CDR x1)))
(<=> ninst (scm->int (CAR x1)))
(<if> p?
(UNPACK-ALWAYS-P x2 ctrl-stack pp)
(<if> (<==> ninst (<c> 1))
(<if> (<==> ninst (<c> 0))
(UNPACK-ALWAYS-START x2 ctrl-stack pp)
(UNPACK-ALWAYS-CC x2 ctrl-stack pp)))))
......@@ -905,7 +906,7 @@ constant = #(nlocals nstack constants code)
(define-syntax-rule (UNPACK-ALWAYS-P x ctrl-stack pp)
(<begin>
(<=> ctrl-stack x)
(<=> pp (<scm> #f))))
(<=> pp (<scm> #f))))
(define-syntax-rule (UNPACK-MIDDLE middle sp-stack)
(<=> sp-stack (CAR middle)))
......@@ -916,11 +917,11 @@ constant = #(nlocals nstack constants code)
(define-syntax-rule
(UNPACK-CONST const nvar nstack instructions constants tvars)
(<let> (((SCM *) r (scm->vector const)))
(<=> nvar (scm->int (<ref> r (<c> 0))))
(<=> nstack (scm->int (<ref> r (<c> 1))))
(<=> constants (<ref> r (<c> 2)))
(<=> instructions (<ref> r (<c> 3)))
(<=> tvars (<ref> r (<c> 4)))))
(<=> nvar (scm->int (<ref> r (<c> 0))))
(<=> nstack (scm->int (<ref> r (<c> 1))))
(<=> constants (<ref> r (<c> 2)))
(<=> instructions (<ref> r (<c> 3)))
(<=> tvars (<ref> r (<c> 4)))))
(define-syntax-rule (PACK-CONST nvar nstack instructions constants tvars)
(VECTOR nvar nstack constants instructions tvars))
......@@ -1349,7 +1350,7 @@ constant = #(nlocals nstack constants code)
(SCM cut (<scm> 0)))
(UNPACK-ENV free narg nlocals)
(UNPACK-1 free always middle session cnst)
(PRSTACK sp fp)
......@@ -1357,14 +1358,16 @@ constant = #(nlocals nstack constants code)
(<if> (<or> p? (<==> ninst (<c> 0)))
(<=> call? (<c> 0)))
(<if> p? (<=> sp fp))
(UNPACK-CONST
cnst nvar nstack instructions-scm constants-scm tvars-scm)
(<=> instructions (scm->vector instructions-scm))
(<=> constants (scm->vector constants-scm))
(<=> tvars (scm->vector tvars-scm))
(UNPACK-SESSION session variables-scm)
(<=> variables
......@@ -1373,15 +1376,16 @@ constant = #(nlocals nstack constants code)
tvars pinned?))
(UNPACK-ALWAYS always p? ninst ctrl-stack pp)
(<=> inst-pt (<+> instructions ninst))
(<if> (<and> (PAIR? pp) (EQ (CDR pp) p))
(<=> p (CAR pp)))
(SET-CC ninst variables fp)
(UNPACK-MIDDLE middle sp-stack)
(<=> inst-pt (<+> instructions ninst))
(NEXT inst-pt)
(LABEL pre-unify)
......@@ -1518,7 +1522,7 @@ constant = #(nlocals nstack constants code)
(LABEL newframe-negation)
(PRSTACK sp fp)
(<let> ((SCM np (<ref> inst-pt (<c> 0)))
(<let> ((SCM np (<ref> inst-pt (<c> 0)))
(int tp (scm->int (<ref> inst-pt (<c> 1))))
(SCM ss (NEWFRAME s)))
(<=> inst-pt (<+> inst-pt (<c> 2)))
......@@ -1534,6 +1538,7 @@ constant = #(nlocals nstack constants code)
s))
(<=> s (<call> gp_set *gp-is-delayed?* (<scm> #f) s))
(<=> ctrl-stack (STORE-STATE tp np ss p ctrl-stack))
(<=> p np)
(<=> cut np)
(NEXT inst-pt))
......@@ -1549,7 +1554,7 @@ constant = #(nlocals nstack constants code)
;; [.y.]
;; [label c] [unwind-tail a]
;; [.z.]
(LABEL unwind-negation)
(LABEL post-negation)
(PRSTACK sp fp)
(<let> ((SCM np (<ref> inst-pt (<c> 0)))
(int out (scm->int (<ref> inst-pt (<c> 1)))))
......@@ -1558,7 +1563,7 @@ constant = #(nlocals nstack constants code)
(RESTORE-STATE-TAIL s p np ctrl-stack)
(<let> ((int n (scm->int (<call> gp_gp_lookup *gp-not-n* s)))
(SCM d (<call> gp_gp_lookup *gp-is-delayed?* s)))
(UNWIND s)
(UNWIND-TAIL s)
(<if> (<and> (q> n (<c> 1))
(<call> scm_is_true d))
(<begin>
......@@ -1596,7 +1601,7 @@ constant = #(nlocals nstack constants code)
(NEXT inst-pt))
(LABEL post-negation)
(LABEL unwind-negation)
(PRSTACK sp fp)
(<let> ((SCM n (<*> inst-pt)))
(<=> cut (<ref> inst-pt (<c> 1)))
......@@ -1604,7 +1609,7 @@ constant = #(nlocals nstack constants code)
(RESTORE-STATE-TAIL s p n ctrl-stack)
(UNWIND-TAIL s)
(<call> gp_fluid_force_bang *gp-is-delayed?* (<scm> #f) s)
(NEXT inst-pt))
(BACKTRACK p instructions inst-pt fp sp))
(LABEL false)
(PRSTACK sp fp)
......@@ -1649,6 +1654,10 @@ constant = #(nlocals nstack constants code)
(NEXT inst-pt))))
(LABEL fail)
(<if> (EQ p (<scm> 0)) (<=> p (GET-P variables)))
(BACKTRACK p instructions inst-pt fp sp)
(LABEL cut)
(PRSTACK sp fp)
(<if> (<==> cut (<c> 0))
......@@ -1852,7 +1861,7 @@ constant = #(nlocals nstack constants code)
(<=> (ARG 0 sp) (ARG -1 sp))
(INCR 1 sp)
(NEXT inst-pt)
(LABEL mk-cons)
(PRSTACK sp fp)
(DO-CONS s sp)
......
......@@ -55,7 +55,7 @@ compile_disjunction0
get_CES(V,[C|_],E,S),
set_AES(V,Aq,0,S0),
(
(X=[G1->G2] -> XX=[G1,softie(A),G2] ; XX=X)
((nonvar(X),X=(G1->G2)) -> XX=[G1,softie(A),G2] ; XX=X),
compile_goal(XX,Tail,V,[LX,LL]),
get_ACES(V,Aq1,[C1|_],E1,S1),
(C == C1 -> true ; throw(bug_c_state_error)),
......@@ -88,7 +88,7 @@ goal(X,Y,First,Lab,Tail,Out,A,Ae,Aq,S0,[U|UU],V,L,LL,LG,LLX) :-
get_CES(V,[C|_],E,S),
set_AES(V,Aq,0,S0),
(First==#t -> true ; set_F(V,scm[(gensym \"tag\")])),
(X=[G1->G2] -> XX=[G1,softie(A),G2] ; XX=X)
((nonvar(X),X=(G1->G2)) -> XX=[G1,softie(A),G2] ; XX=X),
compile_goal(XX,Tail,V,[LX,LG]),
get_ACES(V,A1q,[C1|_],E1,S1),
(C == C1 -> true ; throw(bug_c_state_error)),
......@@ -113,14 +113,14 @@ goal(X,Y,First,Lab,Tail,Out,A,Ae,Aq,S0,[U|UU],V,L,LL,LG,LLX) :-
Err==#t ->
throw(bug_true_not_be_send_in_non_first_disjunction);
(
head_at_true(First,Tail,A,C,Lab,Lab2,L,LX),
head_at_true(First,#f,A,C,Lab,Lab2,L,LX),
Err==c ->
LLX=[[cut],[fail]|LL];
LLX=LL
);
)
)
),
head_at_true(First,Tail,A,C,Lab,Lab2,L,LX)
head_at_true(First,#f,A,C,Lab,Lab2,L,LX)
).
compile_disjunction0([X|Y],First,Aq,Ae,Out, Lab,A,Tail,S0,U,V,[L,LL]) :- !,
......
......@@ -175,7 +175,7 @@ compile_goal(';'(|X),Tail,V,[L,LL]) :- !,
XX=[] -> L=[[false]|LL] ;
XX=[Z] -> compile_goal(Z,Tail,V,[L,LL]) ;
(
get_ESM(V,E,S,M),
get_AESM(V,Aq,E,S,M),
S2 is S + 2,
M2 is max(M,S2),
set_ESM(V,0,S2,M2),
......
......@@ -21,7 +21,7 @@ newv([_|L]) :- newv(L).
handle_all(L,Lout) :-
newv(L),
handle_all(L,3,II,Lout,[]).
handle_all(L,-1,II,Lout,[]).
handle_all([],I,I,L,L).
handle_all([X|Y],I,II,L,LL) :-
......
......@@ -29,8 +29,9 @@
(<define> (get_varn x) (<=> x ,(fluid-ref *varn*)))
(<define> (get_vart x) (<=> x ,(list->vector
(cons 0 ((@ (guile) reverse)
(fluid-ref *var-to-type*))))))
(cons* 0 0 0
((@ (guile) reverse)
(fluid-ref *var-to-type*))))))
(<define> (new_tag x)
(let ((tag (fluid-ref *tag*)))
......@@ -50,11 +51,10 @@
(<define> (max_svarns x)
(<=> x ,(vhash-fold (lambda (k v s)
(max s v))
0
(fluid-ref *svarn*))))
(<=> x ,(let lp ((s 0) (l (vhash->assoc (fluid-ref *svarn*))))
(if (pair? l)
(lp (max s (cdar l)) (cdr l))
s))))
(define (get-varn)
(let ((i (fluid-ref *varn*)))
......@@ -212,6 +212,7 @@ t('post-unify-tail').
t('clear-sp').
t(false).
t(fail).
t(cc).
t('tail-cc').
t('call').
......
......@@ -53,6 +53,13 @@
(<=> s ,(<lookup> (vector-ref v ns)))
(<=> m ,(<lookup> (vector-ref v nm)))))
(<define> (get_AESM v a e s m)
(<let> ((v (<lookup> v)))
(<=> a ,(<lookup> (vector-ref v na)))
(<=> e ,(<lookup> (vector-ref v ne)))
(<=> s ,(<lookup> (vector-ref v ns)))
(<=> m ,(<lookup> (vector-ref v nm)))))
(<define> (get_AES v a e s)
(<let> ((v (<lookup> v)))
(<=> s ,(<lookup> (vector-ref v ns)))
......
This diff is collapsed.
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