simple shortcut simplifier implemented

parent 957d2f44
......@@ -11,6 +11,19 @@
#:export (compile_disj compile_disjunction collect_disj))
(compile-prolog-string "
cat(F,G) :-
catch(F,Er,
(
tf(Er),
(Er==#t -> throw(bug_should_not_throw_true ; G)
).
caf(F) :-
catch(F,Er,
(
ff(Er)
).
collect_disj([],U,U).
collect_disj([X|L],U,UU) :-
collect_disjunction(X,U,U1),
......@@ -24,50 +37,68 @@ collect_disjunction(X,[X|UU],UU).
compile_disjunction
([X],First,Out,Lab,A,Tail,S0,[U],V,[L,LL]) :- !,
get_ACES(V,Aq,C,E,S),
set_ES(V,0,S0),
compile_goal(X,Tail,V,[LX,LL]),
get_ACES(Aq1,C1,E1,S1),
(C == C1 -> true ; throw(bug_c_state_error)),
(
Aq == Aq1 -> AAq=Aq ;
throw(all_disjuction_goals_needs_the_same_begin_level)
),
SS is max(S,S1),
EE is E \\/ E1,
set_AES(Aq,EE,SS),
U = [E1,_],
tr('unwind-tail',UnwindTail),
L=[[label,Lab,U],[UnwindTail,A,C] | LX].
First=#t -> compile_goal(X,Tail,V,[L,LL]) ;
caf(
get_ACES(V,Aq,C,E,S),
set_ES(V,0,S0),
(
compile_goal(X,Tail,V,[LX,LL]),
get_ACES(Aq1,C1,E1,S1),
(C == C1 -> true ; throw(bug_c_state_error)),
(
Aq == Aq1 -> AAq=Aq ;
throw(all_disjuction_goals_needs_the_same_begin_level)
),
SS is max(S,S1),
EE is E \\/ E1,
set_AES(Aq,EE,SS),
U = [E1,_],
tr('unwind-tail',UnwindTail),
L=[[label,Lab,U],[UnwindTail,A,C] | LX]
)).
compile_disjunction([X|Y],First,Out, Lab,A,Tail,S0,[U|UU],V,[L,LL]) :- !,
tr('goto-inst',Goto),
get_ACES(Aq,C,V,E,S),
(Tail==#t -> LG=LLX ; LG = [[Goto,Out]|LLX]),
set_ES(V,0,S0),
compile_goal(X,Tail,V,[LX,LG]),
get_ACES(V,A1q,C1,E1,S1),
(C == C1 -> true ; throw(bug_c_state_error)),
S2 is max(S,S1),
E2 is E \\/ E1,
U = [E1,_],
set_AES(V,A2q,E2,S2),
LQ =[LLX,LL],
(First == #t ->
(
A2q=A1q,
L = [[label,_,U]|LX],
compile_disjunction(Y,#f,Out,Lab,A,Tail,S0,UU,V,LQ)
) ;
(
catch(
(
compile_goal(X,Tail,V,[LX,LG]),
get_ACES(V,A1q,C1,E1,S1),
(C == C1 -> true ; throw(bug_c_state_error)),
S2 is max(S,S1),
E2 is E \\/ E1,
U = [E1,_],
set_AES(V,A2q,E2,S2),
LQ =[LLX,LL],
(First == #t ->
(
Aq == A1q -> A1q=A2q ;
throw(all_disjuction_goals_needs_the_same_begin_level)
),
label(Lab2),tr(unwind,Unwind),
L = [[label,Lab,U],[unwind,A,Lab2,0,C]|LX],
compile_disjunction(Y,#f,Out,Lab2,A,Tail,S0,UU,V,LQ)
)
).
A2q=A1q,
L = [[label,_,U]|LX],
cat(compile_disjunction(Y,#f,Out,Lab,A,Tail,S0,UU,V,[LLX,LL]),
LLX=LL)
) ;
(
(
Aq == A1q -> A1q=A2q ;
throw(all_disjuction_goals_needs_the_same_begin_level)
),
label(Lab2),tr(unwind,Unwind),
L = [[label,Lab,U],[unwind,A,Lab2,0,C]|LX],
cat(compile_disjunction(Y,#f,Out,Lab2,A,Tail,S0,UU,V,[LLX,LL]),
) LLX=LL)
)
),Er,
(
tf(Er),
Er==#t ->
(
label(Lab2),tr(unwind,Unwind),
L = [[label,Lab,U],[unwind,A,Lab2,0,C]|LG],
cat(compile_disjunction(Y,#f,Out,Lab2,A,Tail,S0,UU,V,[LLX,LL]),
LLX=LL)
);
caf(compile_disjunction(Y,First,Out,Lab,A,Tail,S0,[U|UU],V,[L,LL]))
)).
")
......@@ -44,7 +44,11 @@ compile_goal(Code,Iout,StackSize,Narg,Constants,Pretty) :- !,
(var(Constants) -> init_const ; true),
b_setval(pretty,#t),
make_state([[0,_,_]],0,0,0,0,0,[HC,HV],V),
compile_goal(Code,#t,V,[L,[]]),!,
catch(compile_goal(Code,#t,V,[L,[]]),E
(
tf(E),
(E==#t -> L=LL ; L=[[fail])
)),!,
get_M(V,StackSize),
handle_all(L,LL),
(var(Constants)->Constants=scm[(get-consts)];true),
......@@ -110,8 +114,13 @@ compile_goal((F :- Goal),Tail,V,L) :- !,
compile_goal((X,Y),Tail,V,L) :- !,
link_l(L,L1,L2),
compile_goal(X,#f,V,L1),
compile_goal(Y,Tail,V,L2).
ifc(
compile_goal(X,#f,V,L1),
#t,
compile_goal(Y,Tail,V,L),
compile_goal(Y,Tail,V,L2)
).
compile_goal(';'(|X),Tail,V,[L,LL]) :- !,
collect_disj(X,XX,[]),
......@@ -125,7 +134,7 @@ compile_goal(';'(|X),Tail,V,[L,LL]) :- !,
label(Lab),label(Out),tr(newframe,Newframe),
L = [[Newframe,Lab,0] | LX],
LM = [LX, [[label,Out] | LL]],
compile_disjunction(XX,#t,Out,Lab,Lab,Tail,S2,U,V,LM),
compile_disjunction(XX,#t,Out,Lab,Lab,Tail,S2,U,V,LM,Er),
get_E(B,Ed),
add_missing_variables(H,U,Ed,Ed,EEd),
EE is E \\/ EEd
......@@ -173,29 +182,33 @@ compile_goal(\\+X,Tail,V,[L,LL]) :- !,
compile_goal((m_and(Op,m_or(<,>,=<,>=,=:=,=\\=,@<,@=<,@>,@>=)))(X,Y),
Tail,V,[L,LL]) :- !,
tail(Tail,LL,LLL),
catch(compile_scm(X,V,L,LX,EX),EX,
ifc(compile_scm(X,V,L,LX),EX,
(
catch(compile_scm(Y,V,L,LY,EY),EY,
ifc(compile_scm(Y,V,L,LY),EY,
(
call(Op(EX,EY)) -> L=LL ; L=[[false]LL]
));
push_v(-1,V),
reverse_op(Op,Or),
binop1L(Or,O),
tr(O,OO),
LY=[[OO,EX]|LLL]
)),
catch(compile_scm(Y,V,LX,LY,EY),EY,
(
push_v(-1,V),
binop1L(Op,O),
tr(O,OO),
LX=[[OO,EY]|LLL]
)),
push_v(-2,V),
tr(Op,OOp),
binop(OOp,O).
call(Op(EX,EY)) -> throw(#t) ; throw(#f)
),
(
push_v(-1,V),
reverse_op(Op,Or),
binop1L(Or,O),
tr(O,OO),
LY=[[OO,EX]|LLL]
))
),
ifc(compile_scm(Y,V,LX,LY),EY,
(
push_v(-1,V),
binop1L(Op,O),
tr(O,OO),
LX=[[OO,EY]|LLL]
),
(
push_v(-2,V),
tr(Op,OOp),
binop(OOp,O)
))).
compile_goal(X is Y,Tail,V,[L,LL]) :- !,
tail(Tail,LL,LLL),
......@@ -203,35 +216,35 @@ compile_goal(X is Y,Tail,V,[L,LL]) :- !,
instruction(Y) ->
(
instruction(X) ->
(
X==Y -> L=LLL ;
L=[[fail]|LL]
);
(
X==Y -> throw(#t) ; throw(#f)
);
(
tr('unify-instruction-2',Unify),
add_var(X,V,Tag),
L=[[Unify,Tag,Y,#t]|LLL]
)
);
(
catch(compile_scm(Y,V,L,LX,EY),EY,compile_goal(X is EY, Tail, V, [L,LL])),
var(X) ->
(
ifc(compile_scm(Y,V,L,LX),EY,compile_goal(X is EY, Tail, V, [L,LL]),
(
var(X) ->
(
add_var(X,V,Tag),
push_v(-1,V),
tr(unify,Unify),
LX=[[unify,Tag,#t]|LLL]
);
(
(
constant(X) ->
tr('equal-constant',Equal) ;
tr('equal-instruction',Equal)
),
push_v(-1,V),
LX=[[Equal,X]|LLL]
)
).
);
(
(
constant(X) ->
tr('equal-constant',Equal) ;
tr('equal-instruction',Equal)
),
push_v(-1,V),
LX=[[Equal,X]|LLL]
)
)).
compile_goal(unify_with_occurs_check(X,Y),Tail,V,L) :- !,
zero(V) ->
......
......@@ -12,7 +12,7 @@
(compile-prolog-string
"
-extended.
compile_scm(X,V,L,LL,E) :-
compile_scm(X,V,L,LL) :-
var(X) ->
( !,
add_var(X,V,Tag),tr('push-variable-scm',Push),
......@@ -24,30 +24,44 @@ compile_scm(X,V,L,LL,E) :-
instruction(X) -> (!,tr('push-instruction',Atomic), L=[[Atomic,X]|LL],
E=X,push_v(1,V)).
compile_scm((Op,(+ ; - ; * ; /))(X,Y),V,L,LL,E) :- !,
catch(compile_scm(X,V,L,LX,EX),EX,
(
catch(compile_scm(Y,V,L,LY,EY),EY,(call(E is Op(EX,EY)),throw(E))),
binop1L(Op,O),
LY=[[Op,EX]|LL]
)),
catch(compile_scm(Y,V,LX,LY,EY),EY,
compile_scm((Op,(+ ; - ; * ; /))(X,Y),V,L,LL) :- !,
ifc(compile_scm(X,V,L,LX,EX),EX,
ifc(compile_scm(Y,V,L,LY),EY,
(
call(E is Op(EX,EY)),
throw(E)
),
(
binop1L(Op,O),
LY=[[Op,EX]|LL]
)),
ifc(compile_scm(Y,V,LX,LY),EY,
(
binop1R(Op,O),
LX=[[O,EY]|LL]
)),
push_v(-1,V),
binop(Op,O),
LY=[[O]|LL].
),
(
push_v(-1,V),
binop(Op,O),
LY=[[O]|LL].
))).
compile_scm((Op,(+ ; -))(X),V,L,LL,E) :- !,
catch(compile_scm(X,V,L,LX,EX),EX,(call(E is Op(EX)),throw(E))),
Op=='+' -> LX=LL ;
(
(
Op=='-' -> unop('op1_-',O) ;
unop(Op,O)
),
LX=[[O]|LL]
).
ifc(compile_scm(X,V,L,LX),EX,
(
call(E is Op(EX)),
throw(E)
),
(
Op=='+' -> LX=LL ;
(
(
Op=='-' -> unop('op1_-',O) ;
unop(Op,O)
),
LX=[[O]|LL]
)
)).
")
......@@ -13,7 +13,7 @@
(compile-prolog-string "
compile_unify(X,Y,V,[L,LL],M) :-
X==Y -> (!,L=LL);
X==Y -> (!,throw(#t));
var(X) ->
(
!,
......@@ -33,10 +33,12 @@ compile_unify(X,Y,V,[L,LL],M) :-
);
var(Y) ->
(
(
get_H(H),
tr('unify-2',Unify),
add_var(X,V,Tag1),
add_var(Y,V,Tag2),
((isFirst(Tag1),isFirst(Tag2),M=#f) -> throw(#f) ; true)
L = [[Unify,Tag1,Tag2,M]|LL]
);
(
......@@ -52,18 +54,24 @@ compile_unify(X,Y,V,[L,LL],M) :-
compile_unify([X|LX],[Y|LY],V,L,M) :- !,
link_l(L,L1,L2),
compile_unify(X, Y ,V,L1,M),
compile_unify(LX,LY,V,L2,M).
catch(compile_unify(X, Y ,V,L1,M),E,
(
tt(E),L1=[Q,Q].
)),
compile_unify(LX,LY,V,L2,M)
compile_unify(X(|LX),Y(|LY),V,L,M) :- !,
link_l(L,L1,L2),
compile_unify(X , Y,V,L1,M),
catch(compile_unify(X, Y ,V,L1,M),E,
(
tt(E),L1=[Q,Q]
)),
compile_unify(LX,LY,V,L2,M).
compile_unify({X},{Y},V,L,M) :- !,
compile_unify(X,Y,V,L,M).
compile_unify(X,Y,V,[[[False]|LL],LL],M) :-
tr(false,False).
throw(#f).
")
......@@ -144,6 +144,11 @@
(compile-prolog-string
"
tf(E) :- (E==#t;E==#f) -> true ; throw(E).
tt(E) :- E==#t -> true ; throw(E).
ff(E) :-
(E == #t -> throw(bug_should_not_throw_true) ; throw(E)).
reference([HC,HV],[_,V,_,X,E]) :-
(var(V) -> set(V,1) ;
(
......@@ -154,7 +159,9 @@ reference([HC,HV],[_,V,_,X,E]) :-
set(Etags,Enew)
).
first([_,_,#t|_]).
first ([_,_,#t|_]).
isFirst([_,_,X |_]) :- X==#t.
force_variable([[#t|_]|_]).
new_tag([HC,HV],X,XX,Tag,Etag) :-
......
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