Optimization for non unifying choices added

parent 24a49db9
......@@ -10,7 +10,7 @@
#:use-module (logic guile-log guile-prolog vm vm-goal)
#:use-module (system vm assembler)
#:re-export (compile_goal begin_att end_att cc)
#:export (compilable_scm collect_data
#:export (compilable_scm collect_data define-prolog-fkn
make-vm-function
compile_to_fkn
instr define-prolog))
......@@ -175,7 +175,13 @@ variables is the most difficult part to maintain
(mk-instructions instructions)
(list->vector constants)
tvar))))))))))
#;
(define (get-mod c)
(let ((a (procedure-property c 'module)))
(if a
a
(module-name (current-module)))))
(<define> (compile_to_meta stx code meta)
(<var> (stackSize constants l nvar nsvar tvar narg)
(compile_goal code l stackSize narg constants #f)
......@@ -196,17 +202,22 @@ variables is the most difficult part to maintain
(constants-r (map (lambda (c)
(let ((c (<lookup> c)))
#`(@@
#,(precedure-property c 'mod)
#,(precedure-property c 'name))))
#,(map
(lambda (x)
(datum->syntax stx x))
(get-mod c))
#,(datum->syntax
stx
(procedure-name c)))))
constants)))
<cut>
(<=> meta
#`(make-vm-function
,#`(make-vm-function
'(#,(+ narg 4) . #,(+ stackSize nsvar))
`#,(pack-start nvar
stackSize
(mk-instructions instructions)
,(vector #,@constants-r)
#`,(vector #,@constants-r)
tvar)))))))))
(define readline_term_str (@@ (logic guile-log guile-prolog interpreter)
......@@ -218,7 +229,20 @@ generate_lambda(X,F) :-
compile_to_fkn(T,F).
")
(define-syntax-rule (define-prolog n code-string)
(compile-prolog-string "
generate_stx(STX,X,F) :-
catch(
(
readline_term_str(X,T,[variables(V),variable_names(N)]),
compile_to_meta(STX,T,F)
),E,
(
write(error(E)),nl,F=1
)).
")
(define-syntax-rule (define-prolog-fkn n code-string)
(define n (letrec ((n
(let ((g (prolog-run 1 (f)
(generate_lambda code-string f))))
......@@ -226,3 +250,30 @@ generate_lambda(X,F) :-
(error "failed compile")
(car g)))))
n)))
(define (cur x)
(map (lambda (s) (datum->syntax x s))
(module-name (current-module))))
(define-syntax define-prolog
(lambda (x)
(syntax-case x ()
((_ n code-string)
#`(define n (let ((g (lambda ()
#,(let ((g (prolog-run 1 (meta)
(generate_stx x
(syntax->datum
#'code-string)
meta))))
(if (null? g)
(lambda x (error "not implemented"))
(if (not (eq? (car g) 1))
(car g)
(lambda x
(error "not implemented"))))))))
(letrec ((n (lambda x
(let ((gg (g)))
(module-set! (resolve-module '#,(cur x))
'n gg)
(apply gg x)))))
n)))))))
......@@ -50,6 +50,7 @@ constant = #(nlocals nstack constants code)
(<global> SCM *gp-is-delayed?* (<scm> #f))
(<declare-s> SCM gp_get_state_token ())
(<declare-s> SCM gp_cons_bang ((SCM x) (SCM y) (SCM s)))
(<declare-s> SCM scm_gr_p ((SCM x) (SCM y)))
(<declare-s> SCM scm_less_p ((SCM x) (SCM y)))
(<declare-s> SCM scm_geq_p ((SCM x) (SCM y)))
......@@ -91,8 +92,10 @@ constant = #(nlocals nstack constants code)
(<declare-s> SCM gp_gp_cdr ((SCM x) (SCM s)))
(<declare-s> SCM gp_with_fluid ((SCM x) (SCM y)))
(<declare-s> SCM gp_gp_newframe ((SCM s)))
(<declare-s> SCM gp_gp_unwind ((SCM s)))
(<declare-s> SCM gp_gp_unwind_ncons ((SCM s) (int ncons)))
(<declare-s> SCM gp_gp_unwind_soft ((int ncons)))
(<declare-s> SCM gp_gp_unwind_tail ((SCM s)))
(<declare-s> SCM gp_gp_unwind ((SCM s)))
(<declare-s> SCM gp_set ((SCM a) (SCM b) (SCM s)))
(<declare-s> int scm_is_true ((SCM x)))
(<declare-s> int scm_is_false ((SCM x)))
......@@ -115,6 +118,8 @@ constant = #(nlocals nstack constants code)
(<declare-s> SCM scm_make_variable ((SCM s)))
(<declare-s> int SCM_VARIABLEP ((SCM s)))
(<declare-s> int gp_varp ((SCM x) (SCM s)))
(<declare-s> int gp_pair ((SCM x) (SCM s)))
(<declare-s> SCM gp_custom_fkn ((SCM model) (SCM a) (SCM b) (SCM c)
(SCM d)))
(<declare-s> remove_me_t gp_make_vm_model ())
......@@ -130,6 +135,10 @@ constant = #(nlocals nstack constants code)
(<=> middle (CONS (<scm> '()) session))
(<=> pinned? (<scm> #f)))))
(define-syntax-rule (GPPAIR? x s) (TRUE (<call> gp_pair x s)))
(define-syntax-rule (GPCAR x s) (LOOKUP (<call> gp_car x s) s))
(define-syntax-rule (GPCDR x s) (LOOKUP (<call> gp_gp_cdr x s) s))
(define-syntax-rule (GPCONS x y s) (<call> gp_cons_bang x y s))
(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))
......@@ -732,19 +741,18 @@ constant = #(nlocals nstack constants code)
(define-syntax-rule (STORE-STATE tp tag s p stack)
(CONS (CONS tag
(CONS s
(GPCONS (GPCONS tag
(GPCONS p
(<if> tp
(CONS p
(<call> scm_fluid_ref *delayers*))
p)))
stack))
(define-syntax-rule (STORE-STATE-SOFT tag p stack)
(CONS (CONS tag
(CONS (<scm> #f)
p))
stack))
(GPCONS s (<call> scm_fluid_ref *delayers*) s)
s)
s)
s)
stack s))
(define-syntax-rule (STORE-STATE-SOFT s tag p stack)
(GPCONS (GPCONS tag p s)
stack s))
(define-syntax-rule (CLEAR-SP-XP sp xp)
(<recur> lp ()
......@@ -762,53 +770,60 @@ constant = #(nlocals nstack constants code)
(define-syntax-rule (RESTORE-STATE s tag stack)
(<recur> lp ()
(<let> ((x (CAR stack)))
(<if> (EQ (CAR x) tag)
(<let*> ((x1 (CDR x))
(ss (CAR x1))
(x2 (CDR x1)))
(<=> s ss)
(<if> (PAIR? x2)
(<let> ((x (GPCAR stack s)))
(<if> (EQ (GPCAR x s) tag)
(<let*> ((x1 (GPCDR x s))
(x2 (GPCDR x1 s)))
(<if> (GPPAIR? x2 s)
(<begin>
(<call> scm_fluid_set_x *delayers*
(CDR x2))))
(GPCDR x2 s))
(<=> s (GPCAR x2 s))
(<c> 4))
(<begin>
(<=> s x2)
(<c> 3))))
(<begin>
(<=> stack (CDR stack))
(<=> stack (GPCDR stack s))
(<next> lp))))))
(define-syntax-rule (RESTORE-STATE-TAIL s p tag stack)
(<recur> lp ()
(<let> ((x (CAR stack)))
(<if> (EQ (CAR x) tag)
(<let*> ((x1 (CDR x))
(ss (CAR x1))
(x2 (CDR x1)))
(<=> stack (CDR stack))
(<=> s ss)
(<let> ((x (GPCAR stack s)))
(<if> (EQ (GPCAR x s) tag)
(<let*> ((x1 (GPCDR x s))
(x2 (GPCDR x1 s)))
(<=> p (GPCAR x1 s))
(<=> stack (GPCDR stack s))
(<if> (PAIR? x2)
(<begin>
(<=> p (CAR x2))
(<let> ((ss (GPCAR x2 s)))
(<call> scm_fluid_set_x *delayers*
(CDR x2)))
(<=> p x2)))
(GPCDR x2 s))
(<=> s ss))
(<=> s x2)))
(<begin>
(<=> stack (CDR stack))
(<=> stack (GPCDR stack s))
(<next> lp))))))
(define-syntax-rule (RESTORE-STATE-SOFT p tag stack)
(define-syntax-rule (RESTORE-STATE-SOFT s p tag stack)
(<recur> lp ()
(<let> ((x (CAR stack)))
(<if> (EQ (CAR x) tag)
(<let*> ((x1 (CDR x))
(x2 (CDR x1)))
(<=> stack (CDR stack))
(<if> (PAIR? x2)
(<=> p (CAR x2))
(<=> p x2)))
(<let> ((x (GPCAR stack s)))
(<if> (EQ (GPCAR x s) tag)
(<let*> ((x1 (GPCDR x s)))
(<=> stack (GPCDR stack s))
(<if> (GPPAIR? x1 s)
(<begin>
(<=> p (GPCAR x1 s))
(<if> (GPPAIR? (GPCDR x1 s) s)
(<c> 4)
(<c> 3)))
(<begin>
(<=> p x1)
(<c> 2))))
(<begin>
(<=> stack (CDR stack))
(<=> stack (GPCDR stack s))
(<next> lp))))))
(define-syntax-rule (NEXT inst-pt)
(<let> (((void *) jmp (<ref> *operations*
(scm->int (<*> inst-pt)))))
......@@ -835,9 +850,13 @@ constant = #(nlocals nstack constants code)
(<begin>
(REGISTER store-state)
(REGISTER softie)
(REGISTER softie-light)
(REGISTER newframe)
(REGISTER newframe-light)
(REGISTER unwind)
(REGISTER unwind-tail)
(REGISTER unwind-light)
(REGISTER unwind-light-tail)
(REGISTER newframe-negation)
(REGISTER unwind-negation)
......@@ -1302,11 +1321,13 @@ constant = #(nlocals nstack constants code)
(<next> lp (CDR l)))))
(<call> gp_gp_newframe s)))
(define-syntax-rule (mk-unw UNWIND gp_gp_unwind)
(define-syntax-rule (UNWIND s)
(define-syntax-rule (UNWIND-SOFT ncons)
(<call> gp_gp_unwind_soft ncons))
(define-syntax-rule (UNWIND s ncons)
(<begin>
(<call> scm_fluid_set_x *unwind-hooks* (<scm> '()))
(<call> gp_gp_unwind s)
(<call> gp_gp_unwind_ncons s ncons)
(<recur> lp ((SCM l (CDR (<call> scm_fluid_ref *unwind-parameters*))))
(<if> (PAIR? l)
(<let> ((SCM f (CAR l)))
......@@ -1317,11 +1338,30 @@ constant = #(nlocals nstack constants code)
(<if> (PAIR? l)
(<begin>
(CALL (CAR l) s *false* *true*)
(<call> gp_gp_unwind s)
(<next> lp (CDR l))))))))
(<call> gp_gp_unwind_ncons s ncons)
(<next> lp (CDR l)))))))
(mk-unw UNWIND gp_gp_unwind)
(mk-unw UNWIND-TAIL gp_gp_unwind_tail)
(define-syntax-rule (UNWIND-TAIL s)
(<begin>
(<call> scm_fluid_set_x *unwind-hooks* (<scm> '()))
(<recur> lp ((SCM l (CDR (<call> scm_fluid_ref *unwind-parameters*))))
(<if> (PAIR? l)
(<let> ((SCM f (CAR l)))
(CALL (CAR f) (CDR f))
(<next> lp (CDR l)))))
(<let> ((SCM l (<call> scm_reverse
(<call> scm_fluid_ref *unwind-hooks*))))
(<if> (PAIR? l)
(<begin>
(<call> gp_gp_unwind s)
(<recur> lp ((SCM l l))
(<if> (PAIR? l)
(<begin>
(CALL (CAR l) s *false* *true*)
(<call> gp_gp_unwind s)
(<next> lp (CDR l)))))
(<call> gp_gp_unwind_tail s))
(<call> gp_gp_unwind_tail s)))))
(<define> SCM gp_c_vector_x ((SCM x) (int n) (SCM s))
(<let> ((x (<call> gp_gp_lookup x s)))
......@@ -1599,7 +1639,15 @@ constant = #(nlocals nstack constants code)
(PRSTACK sp fp)
(<let> ((SCM np (<ref> inst-pt (<c> 0))))
(<=> inst-pt (<+> inst-pt (<c> 1)))
(<=> ctrl-stack (STORE-STATE-SOFT np p ctrl-stack))
(<=> ctrl-stack (STORE-STATE-SOFT s np p ctrl-stack))
(NEXT inst-pt))
(LABEL newframe-light)
(PRSTACK sp fp)
(<let> ((SCM np (<ref> inst-pt (<c> 0))))
(<=> inst-pt (<+> inst-pt (<c> 1)))
(<=> ctrl-stack (STORE-STATE-SOFT s np p ctrl-stack))
(<=> p np)
(NEXT inst-pt))
(LABEL newframe)
......@@ -1688,22 +1736,43 @@ constant = #(nlocals nstack constants code)
(UNWIND-TAIL s)
(NEXT inst-pt))
(LABEL unwind-light-tail)
(PRSTACK sp fp)
(<let> ((SCM tag (<*> inst-pt)))
(<=> inst-pt (<+> inst-pt (<c> 1)))
(<let> ((int ncons (RESTORE-STATE-SOFT s p tag ctrl-stack)))
(UNWIND-SOFT ncons)
(NEXT inst-pt)))
(LABEL softie)
(PRSTACK sp fp)
(<let> ((SCM tag (<*> inst-pt)))
(<=> inst-pt (<+> inst-pt (<c> 1)))
(RESTORE-STATE-SOFT p tag ctrl-stack)
(NEXT inst-pt))
(<let> ((int ncons (RESTORE-STATE-SOFT s p tag ctrl-stack)))
(NEXT inst-pt)))
(LABEL softie-light)
(PRSTACK sp fp)
(<let> ((SCM tag (<*> inst-pt)))
(<=> inst-pt (<+> inst-pt (<c> 1)))
(<let> ((int ncons (RESTORE-STATE-SOFT s p tag ctrl-stack)))
(UNWIND-SOFT ncons)
(NEXT inst-pt)))
(LABEL unwind)
(PRSTACK sp fp)
(<let> ((SCM tag (<ref> inst-pt (<c> 0))))
(<=> p (<ref> inst-pt (<c> 1)))
(<=> inst-pt (<+> inst-pt (<c> 2)))
(RESTORE-STATE s tag ctrl-stack)
(UNWIND s)
(NEXT inst-pt))
(<let> ((int ncons (RESTORE-STATE s tag ctrl-stack)))
(UNWIND s ncons)
(NEXT inst-pt)))
(LABEL unwind-light)
(PRSTACK sp fp)
(<=> p (<ref> inst-pt (<c> 1)))
(<=> inst-pt (<+> inst-pt (<c> 2)))
(NEXT inst-pt)
(LABEL unwind-negation)
......@@ -1715,6 +1784,7 @@ constant = #(nlocals nstack constants code)
(<call> gp_fluid_force_bang *gp-is-delayed?* (<scm> #f) s)
(BACKTRACK p instructions inst-pt fp sp))
(LABEL false)
(PRSTACK sp fp)
(BACKTRACK p instructions inst-pt fp sp)
......
......@@ -93,6 +93,7 @@ get_post(S,C,Cplx,Tail,X,XX) :-
).
caller(cc,Args,label(G,N),V,[L,LL]) :- !,
touch_Q(V),
narg(Args,0,MM),
M is MM + 3,
(M==N -> true ; throw(cc_does_not_match_caller)),
......@@ -108,6 +109,7 @@ caller(cc,Args,label(G,N),V,[L,LL]) :- !,
LL2 = [[Goto,G]|LL].
caller(cc,Args,Tail,V,[L,LL]) :- !,
touch_Q(V),
(Tail=#f -> throw(cc_not_in_tail_context) ; true),
tr('clear-sp' , Clear),
L=[[Clear]|L2],
......@@ -123,6 +125,7 @@ caller(cc,Args,Tail,V,[L,LL]) :- !,
LL2 = [[Call]|LL].
caller(F,Args,Tail,V,[L,LL]) :-
touch_Q(V),
get_recur(F,A,N) -> rec(F,A,N,Args,Tail,V,[L,LL]) ;
(
tr('clear-sp' , Clear),
......
......@@ -39,6 +39,9 @@ compile_conj0([],Tail,V,L) :- throw(#t).
compile_conj0([X],Tail,V,L) :- !,
compile_goal(X,Tail,V,L).
compile_conj0([X|Gs],Tail,V,L) :- var(X),!,
compile_conj0([call(X)|Gs],Tail,V,L).
compile_conj0([!|Gs],Tail,V,[L,LL]) :- !,
ifc(compile_conj0(Gs,Tail,V,[L1,LL]),E,
(
......@@ -54,6 +57,7 @@ compile_conj0([!|Gs],Tail,V,[L,LL]) :- !,
)).
compile_conj0([softie(A)|Gs],Tail,V,[L,LL]) :- !,
pop_Q(V,Q),
ifc(compile_conj0(Gs,Tail,V,[L1,LL]),E,
(
tfc(E),
......@@ -66,7 +70,12 @@ compile_conj0([softie(A)|Gs],Tail,V,[L,LL]) :- !,
)
),
(
(
var(Q) ->
L=[['softie-light',A]|L1];
L=[[softie,A]|L1]
),
push_Q(V,Q)
)).
compile_conj0([(fail;false)|Gs],Tail,V,[L,LL]) :- !,
......
......@@ -34,23 +34,23 @@ collect_disjunction(';'(|L),U,UU) :- !,
collect_disjunction(X,[X|UU],UU).
%head_at_true(First,Last,A,C,Lab,Lab2,L1,LLX)
head_at_true(#t,_,A,C,Lab,Lab2,L1,LLX) :- L1=LLX, Lab2=Lab.
head_at_true(#t,_,A,C,Lab,Lab2,L1,LLX) :- L1=LLX, Lab2=Lab.
head_at_true(Q,#t,_,A,C,Lab,Lab2,L1,LLX) :- L1=LLX, Lab2=Lab.
head_at_true(Q,#t,_,A,C,Lab,Lab2,L1,LLX) :- L1=LLX, Lab2=Lab.
head_at_true(#f,#f,A,C,Lab,Lab2,L1,LLX) :-
tr(unwind,Unwind),
label(Lab2),
head_at_true(Q,#f,#f,A,C,Lab,Lab2,L1,LLX) :-
(var(Q) -> tr('unwind-light',Unwind) ; tr(unwind,Unwind)),
L1=[[label,Lab,U],[Unwind,A,Lab2]|LLX].
head_at_true(#f,#t,A,C,Lab,Lab2,L1,LLX) :-
label(Lab2),
tr('unwind-tail',UnwindTail),
L1=[[label,Lab,U],[UnwindTail,A]|LLX].
head_at_true(Q,#f,#t,A,C,Lab,Lab2,L1,LLX) :-
(var(Q) -> tr('unwind-light-tail',Unwind) ; tr('unwind-tail',Unwind)),
L1=[[label,Lab,U],[Unwind,A]|LLX].
compile_disjunction0
([X],First,Aq,Ae,Out,Lab,A,Tail,S0,[U],V,[L,LL]) :- !,
(First=#t -> compile_goal(X,First,V,[L,LL]) ;
catch((
read_Q(V,Qit),
pop_Q(V,_),
set_F(V,scm[(gensym \"tag\")]),
get_CES(V,[C|_],E,S),
set_AES(V,Aq,0,S0),
......@@ -67,7 +67,7 @@ compile_disjunction0
EE is E \\/ E1,
set_AES(V,Aq,EE,SS),
U = [E1,_],
head_at_true(First,#t,A,C,Lab,Lab2,L,LX)
head_at_true(Qit,First,#t,A,C,Lab,Lab2,L,LX)
)),Er,
(
tfc(Er),
......@@ -76,7 +76,7 @@ compile_disjunction0
(
First==#t ->
throw(#t) ;
head_at_true(#f,#t,A,C,Lab,Lab2,L,LL)
head_at_true(Qit,#f,#t,A,C,Lab,Lab2,L,LL)
);
Er == c ->
throw(c) ;
......@@ -85,6 +85,7 @@ compile_disjunction0
))).
goal(X,Y,First,Lab,Tail,Out,A,Ae,Aq,S0,[U|UU],V,L,LL,LG,LLX) :-
read_Q(V,Qit),
get_CES(V,[C|_],E,S),
set_AES(V,Aq,0,S0),
(First==#t -> true ; set_F(V,scm[(gensym \"tag\")])),
......@@ -113,18 +114,20 @@ 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,#f,A,C,Lab,Lab2,L,LX),
pop_Q(V,_),
head_at_true(Qit,First,#f,A,C,Lab,Lab2,L,LX),
Err==c ->
LLX=[[cut],[fail]|LL];
LLX=LL
)
)
),
head_at_true(First,#f,A,C,Lab,Lab2,L,LX)
head_at_true(Qit,First,#f,A,C,Lab,Lab2,L,LX)
).
compile_disjunction0([X|Y],First,Aq,Ae,Out, Lab,A,Tail,S0,U,V,[L,LL]) :- !,
tr('goto-inst',Goto),
read_Q(V,Qit),
(Tail==#t -> LG=LLX ; LG = [[Goto,Out]|LLX]),
catch(goal(X,Y,First,Lab,Tail,Out,A,Ae,Aq,S0,U,V,L,LL,LG,LLX), Er,
(
......@@ -146,7 +149,7 @@ compile_disjunction0([X|Y],First,Aq,Ae,Out, Lab,A,Tail,S0,U,V,[L,LL]) :- !,
First = #t ->
throw(#t);
(
head_at_true(#f,#t,A,C,Lab,Lab2,L,LLG),
head_at_true(Qit,#f,#t,A,C,Lab,Lab2,L,LLG),
LLX=LL
)
);
......@@ -157,7 +160,7 @@ compile_disjunction0([X|Y],First,Aq,Ae,Out, Lab,A,Tail,S0,U,V,[L,LL]) :- !,
(First==#t -> true ;
(Aq==Ae -> true ;
throw(syntax_error_begin_en_missmatch))),
head_at_true(First,#f,A,C,Lab,Lab2,L,LG)
head_at_true(Qit,First,#f,A,C,Lab,Lab2,L,LG)
)));
compile_disjunction0(Y,First,Aq,Ae,Out,Lab,A,Tail,S0,U,V,[L,LL])
)
......
......@@ -31,7 +31,7 @@ reverse_op(=\\=,=\\=).
zero(V) :- get_A(V,A),A=[[0|_]].
wrap(Code,L) :-
wrap(Code,[L,LL]) :-
catch(Code,E,
(
tfc(E),
......@@ -57,7 +57,7 @@ compile_goal(Code,Iout,StackSize,Narg,Constants,Pretty) :- !,
init_vars,init_e,
(var(Constants) -> init_const ; true),
b_setval(pretty,#t),
make_state(0,[[0,_,_]],[0],0,0,0,0,[HC,HV],V),
make_state(0,[[0,_,_]],[0],0,0,0,0,[HC,HV],[],V),
wrap(compile_goal(Code,#t,V,[L,[]]),[L,[]]),
get_M(V,StackSize),
handle_all(L,LL),
......@@ -166,6 +166,7 @@ compile_goal(Op(\"recur\",Args),Tail,V,[L,LL]) :-
add_recur(F,A,N),
push_args_args(Xin,V,L,L1),
touch_A(V),
touch_Q(V),
set_F(V,scm[(gensym \"Rec\")]),
L1=[[label,A]|L2],
compile_goal((begin_att,Impr,end_att),Tail,V,[L2,LL]).
......@@ -186,10 +187,15 @@ compile_goal(';'(|X),Tail,V,[L,LL]) :- !,
XX=[Z] -> compile_goal(Z,Tail,V,[L,LL]) ;
(
get_AESM(V,Aq,E,S,M),
label(Lab),label(Out),tr(newframe,Newframe),
label(Lab),label(Out),
push_Q(V,Q),
compile_disjunction(XX,#t,Aq,Ae,Out,Lab,Lab,Tail,S,U,V,LM),!,
(zero(V) -> Tp is 0 ; Tp is 1),
L = [[Newframe,Lab,Tp] | LX],
(
var(Q) ->
L = [['newframe-light',Lab ] | LX];
L = [[newframe ,Lab,Tp] | LX]
),
LM = [LX, [[label,Out] | LL]],
get_EBH(V,Ed,B,H),
add_missing_variables(H,U,Ed,Ed,EEd),!,
......@@ -247,6 +253,7 @@ compile_goal((X =.. Y),Tail,V, L, LL) :- !,
compile_goal(set(V,X),Tail,V,[L,LL]) :- !,
touch_Q(V),
tr(set,Set),
(var_p(X) -> true ; throw(no_var_in_set)),
add_var(X,V,Tag),
......@@ -279,12 +286,12 @@ compile_goal(\\+\\+\\+X,Tail,V,[L,LL]) :- !,
compile_goal(\\+\\+X,Tail,V,[L,LL]) :- !,
L=[['newframe-negation',Al,0]|LX],
get_ACESB(V,A,C,E,S,B),
get_QACESB(V,Q,A,C,E,S,B),
C = [C0|_],
CC = [Al|C],
set_ACE(V,[[0|_]],CC,0),
set_QACE(V,[],[[0|_]],CC,0),
compile_goal(X,#f,V,[LX,LLX]),
set_ACESB(V,A,C,E,S,B),
set_QACESB(V,Q,A,C,E,S,B),
(Tail=#t -> LG=[[cc]|LL] ; LG=LL),
LLX = [['goto-inst' ,Bl ],
[label ,Al ],
......@@ -300,12 +307,12 @@ compile_goal(\\+X,Tail,V,[L,LL]) :- !,
tr('post-negation' , Post ),
tr(notend,Notend),
tail(Tail,LL,LLL),
get_ACESB(V,A,C,E,S,B),
get_QACESB(V,Q,A,C,E,S,B),
C = [C0|_],
CC = [Al|C],
ifc(
(
set_ACE(V,[[0|_]],CC,0),
set_QACE(V,[],[[0|_]],CC,0),
compile_goal(X,#f,V,[LX,LLX])
),Er,
(
......@@ -315,8 +322,7 @@ compile_goal(\\+X,Tail,V,[L,LL]) :- !,
(
get_A(V,A1),
(A==A1 -> true ; throw(mismatching_begin_end_in_negation)),
set_ACESB(V,A,C,E,S,B),
label(Al),label(Bl),
set_QACESB(V,Q,A,C,E,S,B),
(A=[[0|_]|_] -> Tp is 0 ; Tp is 1),
L = [ [Newframe,Al,Tp] |LX ],
LLX = [ [Unwind,Al,C0],[label,Al],[Post,Al,C0] | LLL]
......@@ -383,6 +389,7 @@ compile_goal(iss(X,Y),Tail,V,[L,LL]) :- !,
var_p(X) ->
(
add_var(X,V,Tag),
(isFirst(Tag) -> true ; touch_Q(V)),
push_v(-1,V),
tr(unify,Unify),
LX=[[unify,Tag,#t]|LLL]
......@@ -400,6 +407,7 @@ compile_goal(iss(X,Y),Tail,V,[L,LL]) :- !,
compile_goal(unify_with_occurs_check(X,Y),Tail,V,L) :- !,
touch_Q(V),
(
X==Y -> throw(#t) ;
zero(V) ->
......@@ -414,6 +422,7 @@ compile_goal(uni_0(X,Y),Tail,V,[L,LL]) :- !,
compile_goal(X = Y,Tail,V,L) :- !,
touch_Q(V),
(
X==Y -> throw(#t) ;
zero(V) ->
......
......@@ -32,14 +32,15 @@ handle_all([X|Y],I,II,L,LL) :-
handle([label,N],I,II,L,LL) :- !,
N=I,I=II,LL=L.
handle((X,[('goto-inst';'store-state';'unwind-tail';softie;'post-q'),N]),
handle((X,[('goto-inst';'store-state' ;'unwind-tail';softie;'softie-light';
'post-q' ;'newframe-light';'unwind-light-tail'),N]),
I,II,L,LL) :- !,
II is I + 2,
L=[X|LL].
handle((X,[(newframe;'newframe-negation';'post-negation'
;'unwind' ;'unwind-negation'
;'post-s' ),A,B]),
;'post-s' ;'unwind-light'),A,B]),
I,II,L,LL) :- !,
II is I + 3,
L=[X|LL].
......
......@@ -66,7 +66,7 @@
(i (vhashq-ref h q 0)))
(let ()
(fluid-set! *svarn* (vhash-consq q (+ i 1) h))
(cons i q))))
(cons i 0))))
(<define> (new_var v q s)
......@@ -188,9 +188,13 @@ t(X,X) :- b_getval(pretty,#t),!.
t('store-state').
t(newframe).
t('newframe-light').
t(unwind).
t('unwind-light').
t('unwind-tail').
t('unwind-light-tail').
t(softie).
t('softie-light').
t('post-s').
t('post-q').
......
......@@ -11,11 +11,11 @@
#:replace (first)
#:export ())
(<define> (make_state f a c e m s b h x)
(<var> (F A C E M S B H)
(<=> (F A C E M S B H)
(f a c e m s b h))
(<=> x ,(vector F A C E M S B H))))
(<define> (make_state f a c e m s b h q x)
(<var> (F A C E M S B H Q)
(<=> (F A C E M S B H Q)
(f a c e m s b h q))
(<=> x ,(vector F A C E M S B H Q))))
(define nf 0)
(define na 1)
......@@ -25,10 +25,30 @@
(define ns 5)