diogo/yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

improve code for disjunctions by trying to avoid permanent variables.

Browse Source
This commit is contained in:
Vitor Santos Costa 2009-03-10 16:24:26 +00:00
parent e4d6b529c7
commit fc2e01f320
7 changed files with 115 additions and 608 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
C/compiler.c
View File

@ -1383,18 +1383,6 @@ IsTrueGoal(Term t) {
return(t == MkAtomTerm(AtomTrue)); return(t == MkAtomTerm(AtomTrue));
} }
static void
c_p_put(Term Goal, op_numbers op_var, op_numbers op_val, compiler_struct * cglobs)
{
Term t = Deref(ArgOfTerm(2, Goal));
int new = check_var(t, 1, 0, cglobs);
t = Deref(t);
Yap_emit((new ?
(++cglobs->nvars,op_var) : op_val), t, IntegerOfTerm(ArgOfTerm(1, Goal)), &cglobs->cint);
tag_var(t, new, cglobs);
}
static void static void
emit_special_label(Term Goal, compiler_struct *cglobs) emit_special_label(Term Goal, compiler_struct *cglobs)
{ {
@ -1814,6 +1802,12 @@ c_goal(Term Goal, int mod, compiler_struct *cglobs)
} }
return; return;
} }
else if (f == FunctorSafe) {
Ventry *v = (Ventry *)ArgOfTerm(1, Goal);
/* This variable must be known before */
v->FlagsOfVE |= SafeVar;
return;
}
else if (p->PredFlags & AsmPredFlag) { else if (p->PredFlags & AsmPredFlag) {
int op = p->PredFlags & 0x7f; int op = p->PredFlags & 0x7f;

2
H/iatoms.h
View File

@ -212,6 +212,7 @@
AtomRestoreRegs = Yap_FullLookupAtom("$restore_regs"); AtomRestoreRegs = Yap_FullLookupAtom("$restore_regs");
AtomRetryCounter = Yap_LookupAtom("retry_counter"); AtomRetryCounter = Yap_LookupAtom("retry_counter");
AtomRTree = Yap_LookupAtom("rtree"); AtomRTree = Yap_LookupAtom("rtree");
AtomSafe = Yap_FullLookupAtom("$safe");
AtomSame = Yap_LookupAtom("=="); AtomSame = Yap_LookupAtom("==");
AtomSemic = Yap_LookupAtom(";"); AtomSemic = Yap_LookupAtom(";");
AtomShiftCountOverflow = Yap_LookupAtom("shift_count_overflow"); AtomShiftCountOverflow = Yap_LookupAtom("shift_count_overflow");
@ -361,6 +362,7 @@
FunctorResourceError = Yap_MkFunctor(AtomResourceError,1); FunctorResourceError = Yap_MkFunctor(AtomResourceError,1);
FunctorRestoreRegs = Yap_MkFunctor(AtomRestoreRegs,2); FunctorRestoreRegs = Yap_MkFunctor(AtomRestoreRegs,2);
FunctorRestoreRegs1 = Yap_MkFunctor(AtomRestoreRegs,1); FunctorRestoreRegs1 = Yap_MkFunctor(AtomRestoreRegs,1);
FunctorSafe = Yap_MkFunctor(AtomSafe,1);
FunctorSame = Yap_MkFunctor(AtomSame,2); FunctorSame = Yap_MkFunctor(AtomSame,2);
FunctorSlash = Yap_MkFunctor(AtomSlash,2); FunctorSlash = Yap_MkFunctor(AtomSlash,2);
FunctorStaticClause = Yap_MkFunctor(AtomStaticClause,1); FunctorStaticClause = Yap_MkFunctor(AtomStaticClause,1);

2
H/ratoms.h
View File

@ -214,6 +214,7 @@
AtomRestoreRegs = AtomAdjust(AtomRestoreRegs); AtomRestoreRegs = AtomAdjust(AtomRestoreRegs);
AtomRetryCounter = AtomAdjust(AtomRetryCounter); AtomRetryCounter = AtomAdjust(AtomRetryCounter);
AtomRTree = AtomAdjust(AtomRTree); AtomRTree = AtomAdjust(AtomRTree);
AtomSafe = AtomAdjust(AtomSafe);
AtomSame = AtomAdjust(AtomSame); AtomSame = AtomAdjust(AtomSame);
AtomSemic = AtomAdjust(AtomSemic); AtomSemic = AtomAdjust(AtomSemic);
AtomShiftCountOverflow = AtomAdjust(AtomShiftCountOverflow); AtomShiftCountOverflow = AtomAdjust(AtomShiftCountOverflow);
@ -363,6 +364,7 @@
FunctorResourceError = FuncAdjust(FunctorResourceError); FunctorResourceError = FuncAdjust(FunctorResourceError);
FunctorRestoreRegs = FuncAdjust(FunctorRestoreRegs); FunctorRestoreRegs = FuncAdjust(FunctorRestoreRegs);
FunctorRestoreRegs1 = FuncAdjust(FunctorRestoreRegs1); FunctorRestoreRegs1 = FuncAdjust(FunctorRestoreRegs1);
FunctorSafe = FuncAdjust(FunctorSafe);
FunctorSame = FuncAdjust(FunctorSame); FunctorSame = FuncAdjust(FunctorSame);
FunctorSlash = FuncAdjust(FunctorSlash); FunctorSlash = FuncAdjust(FunctorSlash);
FunctorStaticClause = FuncAdjust(FunctorStaticClause); FunctorStaticClause = FuncAdjust(FunctorStaticClause);

4
H/tatoms.h
View File

@ -430,6 +430,8 @@
#define AtomRetryCounter Yap_heap_regs->AtomRetryCounter_ #define AtomRetryCounter Yap_heap_regs->AtomRetryCounter_
Atom AtomRTree_; Atom AtomRTree_;
#define AtomRTree Yap_heap_regs->AtomRTree_ #define AtomRTree Yap_heap_regs->AtomRTree_
Atom AtomSafe_;
#define AtomSafe Yap_heap_regs->AtomSafe_
Atom AtomSame_; Atom AtomSame_;
#define AtomSame Yap_heap_regs->AtomSame_ #define AtomSame Yap_heap_regs->AtomSame_
Atom AtomSemic_; Atom AtomSemic_;
@ -728,6 +730,8 @@
#define FunctorRestoreRegs Yap_heap_regs->FunctorRestoreRegs_ #define FunctorRestoreRegs Yap_heap_regs->FunctorRestoreRegs_
Functor FunctorRestoreRegs1_; Functor FunctorRestoreRegs1_;
#define FunctorRestoreRegs1 Yap_heap_regs->FunctorRestoreRegs1_ #define FunctorRestoreRegs1 Yap_heap_regs->FunctorRestoreRegs1_
Functor FunctorSafe_;
#define FunctorSafe Yap_heap_regs->FunctorSafe_
Functor FunctorSame_; Functor FunctorSame_;
#define FunctorSame Yap_heap_regs->FunctorSame_ #define FunctorSame Yap_heap_regs->FunctorSame_
Functor FunctorSlash_; Functor FunctorSlash_;

2
misc/ATOMS
View File

@ -223,6 +223,7 @@ A ResourceError N "resource_error"
A RestoreRegs F "$restore_regs" A RestoreRegs F "$restore_regs"
A RetryCounter N "retry_counter" A RetryCounter N "retry_counter"
A RTree N "rtree" A RTree N "rtree"
A Safe F "$safe"
A Same N "==" A Same N "=="
A Semic N ";" A Semic N ";"
A ShiftCountOverflow N "shift_count_overflow" A ShiftCountOverflow N "shift_count_overflow"
@ -372,6 +373,7 @@ F RepresentationError RepresentationError 1
F ResourceError ResourceError 1 F ResourceError ResourceError 1
F RestoreRegs RestoreRegs 2 F RestoreRegs RestoreRegs 2
F RestoreRegs1 RestoreRegs 1 F RestoreRegs1 RestoreRegs 1
F Safe Safe 1
F Same Same 2 F Same Same 2
F Slash Slash 2 F Slash Slash 2
F StaticClause StaticClause 1 F StaticClause StaticClause 1

686
pl/eval.yap
View File

@ -11,611 +11,109 @@
* File: eval.yap * * File: eval.yap *
* Last rev: * * Last rev: *
* mods: * * mods: *
* comments: arithmetical optimization * * comments: optimise disjunction handling *
* * * *
*************************************************************************/ *************************************************************************/
%, portray_clause((H:-BF))
'$full_clause_optimisation'(H, M, B0, BF) :-
'$localise_vars_opt'(H, M, B0, BF), !.
:- module('$eval', % the idea here is to make global variables in disjunctions
['$compile_arithmetic'/2]). % local.
'$localise_vars_opt'(H, M, (B1;B2), (NB1;NB2)) :-
'$variables_in_term'(H, [], LV),
'$localise_vars'(B1, M, NB1, LV, LV, []),
'$localise_disj_vars'(B2, M, NB2, LV, LV, []).
'$compile_arithmetic'((Head :- Body), (Head :- NBody)) :- '$localise_disj_vars'((B;B2), M, (NB ; NB2), LV, LV0, LEqs) :- !,
term_variables(Head, LVs), '$localise_vars'(B, M, NB, LV, LV0, LEqs),
process_body(Body, LVs, NBody), !. '$localise_disj_vars'(B2, M, NB2, LV, LV0, LEqs).
'$compile_arithmetic'(G, G). '$localise_disj_vars'(B2, M, NB, LV, LV0, LEqs) :-
'$localise_vars'(B2, M, NB, LV, LV0, LEqs).
process_body((G,Body), InputVs, NewBody) :- '$localise_vars'((A->B), M, (A->NB), LV, LV0, LEqs) :-
arithmetic_exp(G), !, '$safe_guard'(A, M), !,
term_variables(G, UnsortedExpVs), '$variables_in_term'(A, LV, LV1),
'$sort'(UnsortedExpVs, ExpVs), '$localise_vars'(B, M, NB, LV1, LV0, LEqs).
fetch_more(Body, ExpVs, LGs, Gs, _, RBody), '$localise_vars'((A;B), M, (NA;NB), LV1, LV0, LEqs) :- !,
term_variables(RBody, ExtraVs), '$localise_vars'(A, M, NA, LV1, LV0, LEqs),
compile_arith([G|LGs], InputVs, ExtraVs, (G,Gs), ArithComp), '$localise_disj_vars'(B, M, NB, LV1, LV0, LEqs).
( '$localise_vars'(((A,B),C), M, NG, LV, LV0, LEqs) :- !,
RBody = true '$flatten_bd'((A,B),C,NB),
-> '$localise_vars'(NB, M, NG, LV, LV0, LEqs).
NewBody = ArithComp '$localise_vars'((!,B), M, (!,NB), LV, LV0, LEqs) :- !,
; '$localise_vars'(B, M, NB, LV, LV0, LEqs).
NewBody = (ArithComp,MBody), '$localise_vars'((X=Y,B), M, (X=Y,NB1), LV, LV0, LEqs) :-
term_variables(InputVs+G, NewInputVs), var(X), var(Y), !,
process_body(RBody, NewInputVs, MBody) '$localise_vars'(B, M, NB1, LV, LV0, [X,Y|LEqs]).
). '$localise_vars'((G,B), M, (G,NB1), LV, LV0, LEqs) :-
process_body((G,Body), InputVs, (G,NewBody)) :- !, '$safe_builtin'(G, M), !,
term_variables(InputVs+G, NewInputVs), '$variables_in_term'(G, LV, LV1),
process_body(Body, NewInputVs, NewBody). '$add_extra_safe'(G, NLV0, LV0),
process_body(G, InputVs, NewBody) :- '$localise_vars'(B, M, NB1, LV1, NLV0, LEqs).
arithmetic_exp(G), !, '$localise_vars'((G1,B1), _, O, LV, LV0, LEqs) :- !,
term_variables(G, _), terms:variables_within_term(LV, B1, Commons),
compile_arith([G], InputVs, [], G, ArithComp), terms:new_variables_in_term(LV, B1, New),
NewBody = (ArithComp,true). copy_term(Commons+New+LEqs+B1, NCommons+NNew+NLEqs+NB1),
process_body(G, _, G). NNew = New,
NLEqs = LEqs,
'$gen_equals'(Commons, NCommons, LV0, (G1,NB1), O).
'$localise_vars'(G, _, G, _, _, _).
fetch_more((G,Gs), ExpVs, [G|LGs], (G,AGs), AllExpVs, RGs) :- '$gen_equals'([], [], _, O, O).
arithmetic_exp(G), '$gen_equals'([V|Commons],[NV|NCommons], LV0, O, NO) :- V == NV, !,
term_variables(G,Vs), '$gen_equals'(Commons,NCommons, LV0, O, NO).
'$sort'(Vs, SVs), '$gen_equals'([V|Commons],[NV|NCommons], LV0, O, OO) :-
intersect_vars(SVs,ExpVs), !, '$vmember'(V,LV0),
join_vars(ExpVs,SVs,MoreExpVs), OO = (V=NV,'$safe'(NV),NO),
fetch_more(Gs, MoreExpVs, LGs, AGs, AllExpVs, RGs). '$gen_equals'(Commons,NCommons, LV0, O, NO).
fetch_more((G,Gs), ExpVs, [], true, ExpVs, (G,Gs)) :- !. '$gen_equals'([V|Commons],[NV|NCommons], LV0, O, OO) :-
fetch_more(G, ExpVs, [G], (G), MoreExpVs, true) :- OO = (V=NV,NO),
arithmetic_exp(G), '$gen_equals'(Commons,NCommons, LV0, O, NO).
term_variables(G,Vs),
'$sort'(Vs,SVs),
intersect_vars(SVs,ExpVs), !,
join_vars(ExpVs,SVs,MoreExpVs).
fetch_more(G, ExpVs, [], true, ExpVs, G).
arithmetic_exp((_ is _)). '$safe_guard'((A,B), M) :- !,
arithmetic_exp((_ =:= _)). '$safe_guard'(A, M),
arithmetic_exp((_ < _)). '$safe_guard'(B, M).
arithmetic_exp((_ > _)). '$safe_guard'((A;B), M) :- !,
arithmetic_exp((_ >= _)). '$safe_guard'(A, M),
arithmetic_exp((_ =< _)). '$safe_guard'(B, M).
'$safe_guard'(A, M) :- !,
'$safe_builtin'(A, M).
intersect_vars([V1|R1],[V2|R2]) :- '$safe_builtin'(G, Mod) :-
( '$flags'(G, Mod, Fl, Fl),
V1 == V2 Fl /\ 0x00008880 =\= 0.
->
true
;
V1 @< V2
->
intersect_vars(R1,[V2|R2])
;
intersect_vars([V1|R1],R2)
).
join_vars([],[],[]). '$vmember'(V,[V1|_]) :- V == V1, !.
join_vars([],[V2|R2],[V2|R2]). '$vmember'(V,[_|LV0]) :-
join_vars([V1|R1],[],[V1|R1]). '$vmember'(V,LV0).
join_vars([V1|R1],[V2|R2],O) :-
(
V1 == V2
->
O = [V1|RO],
join_vars(R1, R2, RO)
;
V1 @< V2
->
O = [V1|RO],
join_vars(R1,[V2|R2], RO)
;
O = [V2|RO],
join_vars([V1|R1],R2, RO)
).
compile_arith(LGs, InputVs, ExtraVs, Gs, ArithComp) :- '$flatten_bd'((A,B),R,NB) :- !,
add_type_slots(InputVs,TypedVs), '$flatten_bd'(B,R,R1),
'$sort'(InputVs,S1), '$flatten_bd'(A,R1,NB).
'$sort'(ExtraVs,S2), '$flatten_bd'(A,R,(A,R)).
join_vars(S1, S2, S),
visit(LGs, TypedVs, NewTypedVs, S, FlatExps, []),
FlatExps = [_,_|_],
alloc_regs(NewTypedVs,0,Regs),
Regs < 32,
compile_ops([init_label(exception_label),init_label(success_label)|FlatExps], Gs, ArithComp), !.
compile_arith(_, _, _, Gs, Gs).
add_type_slots([],[]). '$add_extra_safe'('$plus'(_,_,V)) --> !, [V].
add_type_slots([V|ExpVs],[t(V,_,_)|TypesVs]) :- '$add_extra_safe'('$minus'(_,_,V)) --> !, [V].
add_type_slots(ExpVs,TypesVs). '$add_extra_safe'('$times'(_,_,V)) --> !, [V].
'$add_extra_safe'('$div'(_,_,V)) --> !, [V].
visit([], TypedVs, TypedVs, _) --> []. '$add_extra_safe'('$and'(_,_,V)) --> !, [V].
visit([Exp|Exps], TypedVs, NewTypedVs, ExtraVs) --> '$add_extra_safe'('$or'(_,_,V)) --> !, [V].
visit_pred(Exp, TypedVs, ITypedVs, ExtraVs), '$add_extra_safe'('$sll'(_,_,V)) --> !, [V].
add_success_label(Exps), '$add_extra_safe'('$slr'(_,_,V)) --> !, [V].
visit(Exps, ITypedVs, NewTypedVs, ExtraVs). '$add_extra_safe'(C=D,A,B) :-
!,
add_success_label([]) --> []. ( compound(C) ->
add_success_label([_|_]) --> [set_label(success_label)]. '$variables_in_term'(C,E,A)
;
visit_pred((X is _), _, _, _) --> E=A
{ nonvar(X) }, !, ),
{ fail }. ( compound(D) ->
visit_pred((_ is T), _, _, _) --> '$variables_in_term'(D,B,E)
{ var(T) }, !, ;
fail. B=E
visit_pred((X is T), TypedVs, ExtraTypedVs, LeftBodyVars) --> ).
% check the expression '$add_extra_safe'(_) --> [].
visit_exp(T, TypedVs, NewTypedVs, TMP, Type),
({ tmember(X, TypedVs, Type, TMP) }
->
{ NewTypedVs = ExtraTypedVs }
;
{ ExtraTypedVs = [t(X,Type,TMP)|NewTypedVs] }
),
% final code
( { vmember(X, LeftBodyVars) } ->
[init_label(success_label), export(TMP,X,Type)]
;
[]
).
visit_pred((X =:= T), TypedVs, NewTypedVs, _) -->
% check the expression
visit_exp(X, TypedVs, ITypedVs, TMP1, Type),
visit_exp(T, ITypedVs, NewTypedVs, TMP2, Type),
% assign the type to X, if any
% final code
[init_label(success_label), eq(TMP1,TMP2)].
visit_pred((X < T), TypedVs, NewTypedVs, _) -->
% check the expression
visit_exp(X, TypedVs, ITypedVs, TMP1, _),
visit_exp(T, ITypedVs, NewTypedVs, TMP2, _),
% assign the type to X, if any
% final code
[init_label(success_label), lt(TMP1,TMP2)].
visit_pred((X > T), TypedVs, NewTypedVs, _) -->
% check the expression
visit_exp(X, TypedVs, ITypedVs, TMP1, _),
visit_exp(T, ITypedVs, NewTypedVs, TMP2, _),
% assign the type to X, if any
% final code
[init_label(success_label), lt(TMP2,TMP1)].
visit_exp(V, TypedVs, TypedVs, TMP, Type) -->
{
var(V), !,
tmember(V, TypedVs, Type, TMP)
% must have been defined before
},
(
{ var(TMP) } ->
{ TMP = x(_) },
[get(TMP,V,Type)]
;
[]
).
visit_exp(V, TypedVs, TypedVs, V, Type) -->
{
float(V)
}, !,
{ Type = float }.
visit_exp(V, TypedVs, TypedVs, V, Type) -->
{
integer(V)
}, !,
{ Type = int }.
visit_exp(V, TypedVs, NewTypedVs, TMP, Type) -->
{
ground(V),
noatoms(V),
!,
NV is V
},
visit_exp(NV, TypedVs, NewTypedVs, TMP, Type).
visit_exp(X, TypedVs, TypedVs, TMP, Type) -->
{
atom(X), !,
add_type(X,Type)
},
[zerop(TMP,X)].
visit_exp(X+Y, TypedVs, [t(_,Type,TMP)|NewTypedVs], TMP, Type) -->
!,
visit_exp(X, TypedVs, ITypedVs, V1, T1),
visit_exp(Y, ITypedVs, NewTypedVs, V2, T2),
{ forward_type(T1, T2, Type) },
{ TMP = x(_) },
[add(TMP,V1,V2)].
visit_exp(X-Y, TypedVs, [t(_,Type,TMP)|NewTypedVs], TMP, Type) -->
!,
visit_exp(X, TypedVs, ITypedVs, V1, T1),
visit_exp(Y, ITypedVs, NewTypedVs, V2, T2),
{ forward_type(T1, T2, Type) },
{ TMP = x(_) },
[sub(TMP,V1,V2)].
visit_exp(X*Y, TypedVs, [t(_,Type,TMP)|NewTypedVs], TMP, Type) -->
!,
visit_exp(X, TypedVs, ITypedVs, V1, T1),
visit_exp(Y, ITypedVs, NewTypedVs, V2, T2),
{ forward_type(T1, T2, Type) },
{ TMP = x(_) },
[mul(TMP,V1,V2)].
visit_exp(X/Y, TypedVs, [t(_,float,TMP)|NewTypedVs], TMP, float) -->
!,
visit_exp(X, TypedVs, ITypedVs, V1, _),
visit_exp(Y, ITypedVs, NewTypedVs, V2, _),
[fdiv(TMP,V1,V2)].
visit_exp(X//Y, TypedVs, [t(_,int,TMP)|NewTypedVs], TMP, int) -->
{ Y\== 0},
!,
visit_exp(X, TypedVs, ITypedVs, V1, int),
visit_exp(Y, ITypedVs, NewTypedVs, V2, int),
{ TMP = x(_) },
[idiv(TMP,V1,V2)].
visit_exp(X mod Y, TypedVs, [t(_,int,TMP)|NewTypedVs], TMP, int) -->
{ Y\== 0},
!,
visit_exp(X, TypedVs, ITypedVs, V1, int),
visit_exp(Y, ITypedVs, NewTypedVs, V2, int),
{ TMP = x(_) },
[mod(TMP,V1,V2)].
visit_exp(X rem Y, TypedVs, [t(_,int,TMP)|NewTypedVs], TMP, int) -->
{ Y\== 0},
!,
visit_exp(X, TypedVs, ITypedVs, V1, int),
visit_exp(Y, ITypedVs, NewTypedVs, V2, int),
{ TMP = x(_) },
[rem(TMP,V1,V2)].
visit_exp(X /\ Y, TypedVs, [t(_,int,TMP)|NewTypedVs], TMP, int) -->
!,
visit_exp(X, TypedVs, ITypedVs, V1, int),
visit_exp(Y, ITypedVs, NewTypedVs, V2, int),
{ TMP = x(_) },
[and(TMP,V1,V2)].
visit_exp(X \/ Y, TypedVs, [t(_,int,TMP)|NewTypedVs], TMP, int) -->
!,
visit_exp(X, TypedVs, ITypedVs, V1, int),
visit_exp(Y, ITypedVs, NewTypedVs, V2, int),
{ TMP = x(_) },
[or(TMP,V1,V2)].
visit_exp(X # Y, TypedVs, [t(_,int,TMP)|NewTypedVs], TMP, int) -->
!,
visit_exp(X, TypedVs, ITypedVs, V1, int),
visit_exp(Y, ITypedVs, NewTypedVs, V2, int),
{ TMP = x(_) },
[xor(TMP,V1,V2)].
visit_exp(X << Y, TypedVs, [t(_,int,TMP)|NewTypedVs], TMP, int) -->
!,
visit_exp(X, TypedVs, ITypedVs, V1, int),
visit_exp(Y, ITypedVs, NewTypedVs, V2, int),
{ TMP = x(_) },
[sl(TMP,V1,V2)].
visit_exp(X >> Y, TypedVs, [t(_,int,TMP)|NewTypedVs], TMP, int) -->
!,
visit_exp(X, TypedVs, ITypedVs, V1, int),
visit_exp(Y, ITypedVs, NewTypedVs, V2, int),
{ TMP = x(_) },
[sr(TMP,V1,V2)].
visit_exp(X ^ Y, TypedVs, [t(_,int,TMP)|NewTypedVs], TMP, float) -->
!,
visit_exp(X, TypedVs, ITypedVs, V1, _),
visit_exp(Y, ITypedVs, NewTypedVs, V2, _),
{ TMP = x(_) },
[exp(TMP,V1,V2)].
visit_exp(X ** Y, TypedVs, [t(_,int,TMP)|NewTypedVs], TMP, float) -->
!,
visit_exp(X, TypedVs, ITypedVs, V1, _),
visit_exp(Y, ITypedVs, NewTypedVs, V2, _),
[exp(TMP,V1,V2)].
visit_exp(exp(X,Y), TypedVs, [t(_,int,TMP)|NewTypedVs], TMP, float) -->
!,
visit_exp(X, TypedVs, ITypedVs, V1, _),
visit_exp(Y, ITypedVs, NewTypedVs, V2, _),
{ TMP = x(_) },
[exp(TMP,V1,V2)].
visit_exp(max(X,Y), TypedVs, [t(_,int,TMP)|NewTypedVs], TMP, float) -->
!,
visit_exp(X, TypedVs, ITypedVs, V1, _),
visit_exp(Y, ITypedVs, NewTypedVs, V2, _),
[max(TMP,V1,V2)].
visit_exp(min(X,Y), TypedVs, [t(_,int,TMP)|NewTypedVs], TMP, float) -->
!,
visit_exp(X, TypedVs, ITypedVs, V1, _),
visit_exp(Y, ITypedVs, NewTypedVs, V2, _),
{ TMP = x(_) },
[min(TMP,V1,V2)].
visit_exp(gcd(X,Y), TypedVs, [t(_,int,TMP)|NewTypedVs], TMP, float) -->
!,
visit_exp(X, TypedVs, ITypedVs, V1, _),
visit_exp(Y, ITypedVs, NewTypedVs, V2, _),
[gcd(TMP,V1,V2)].
visit_exp(+X, TypedVs, NewTypedVs, TMP, T) -->
visit_exp(X, TypedVs, NewTypedVs, TMP, T).
visit_exp(-X, TypedVs, [t(_,T,TMP)|NewTypedVs], TMP, T) -->
visit_exp(X, TypedVs, NewTypedVs, TMP1, T),
{ TMP = x(_) },
[uminus(TMP,TMP1)].
visit_exp(\(X), TypedVs, [t(_,int,TMP)|NewTypedVs], TMP, int) -->
visit_exp(X, TypedVs, NewTypedVs, TMP1, int),
{ TMP = x(_) },
[unot(TMP,TMP1)].
visit_exp(exp(X), TypedVs, [t(_,float,TMP)|NewTypedVs], TMP, float) -->
visit_exp(X, TypedVs, NewTypedVs, TMP1, _),
{ TMP = x(_) },
[exp1(TMP,TMP1)].
visit_exp(log(X), TypedVs, [t(_,float,TMP)|NewTypedVs], TMP, float) -->
visit_exp(X, TypedVs, NewTypedVs, TMP1, _),
{ TMP = x(_) },
[log(TMP,TMP1)].
visit_exp(log10(X), TypedVs, [t(_,float,TMP)|NewTypedVs], TMP, float) -->
visit_exp(X, TypedVs, NewTypedVs, TMP1, _),
{ TMP = x(_) },
[log10(TMP,TMP1)].
visit_exp(sqrt(X), TypedVs, [t(_,float,TMP)|NewTypedVs], TMP, float) -->
visit_exp(X, TypedVs, NewTypedVs, TMP1, _),
{ TMP = x(_) },
[sqrt(TMP,TMP1)].
visit_exp(sin(X), TypedVs, [t(_,float,TMP)|NewTypedVs], TMP, float) -->
visit_exp(X, TypedVs, NewTypedVs, TMP1, _),
{ TMP = x(_) },
[sin(TMP,TMP1)].
visit_exp(cos(X), TypedVs, [t(_,float,TMP)|NewTypedVs], TMP, float) -->
visit_exp(X, TypedVs, NewTypedVs, TMP1, _),
{ TMP = x(_) },
[cos(TMP,TMP1)].
visit_exp(tan(X), TypedVs, [t(_,float,TMP)|NewTypedVs], TMP, float) -->
visit_exp(X, TypedVs, NewTypedVs, TMP1, _),
{ TMP = x(_) },
[tan(TMP,TMP1)].
visit_exp(asin(X), TypedVs, [t(_,float,TMP)|NewTypedVs], TMP, float) -->
visit_exp(X, TypedVs, NewTypedVs, TMP1, _),
{ TMP = x(_) },
[asin(TMP,TMP1)].
visit_exp(atan(X), TypedVs, [t(_,float,TMP)|NewTypedVs], TMP, float) -->
visit_exp(X, TypedVs, NewTypedVs, TMP1, _),
{ TMP = x(_) },
[atan(TMP,TMP1)].
visit_exp(atan2(X), TypedVs, [t(_,float,TMP)|NewTypedVs], TMP, float) -->
visit_exp(X, TypedVs, NewTypedVs, TMP1, _),
{ TMP = x(_) },
[atan2(TMP,TMP1)].
visit_exp(acos(X), TypedVs, [t(_,float,TMP)|NewTypedVs], TMP, float) -->
visit_exp(X, TypedVs, NewTypedVs, TMP1, _),
{ TMP = x(_) },
[acos(TMP,TMP1)].
visit_exp(sinh(X), TypedVs, [t(_,float,TMP)|NewTypedVs], TMP, float) -->
visit_exp(X, TypedVs, NewTypedVs, TMP1, _),
{ TMP = x(_) },
[sinh(TMP,TMP1)].
visit_exp(cosh(X), TypedVs, [t(_,float,TMP)|NewTypedVs], TMP, float) -->
visit_exp(X, TypedVs, NewTypedVs, TMP1, _),
{ TMP = x(_) },
[cosh(TMP,TMP1)].
visit_exp(tanh(X), TypedVs, [t(_,float,TMP)|NewTypedVs], TMP, float) -->
visit_exp(X, TypedVs, NewTypedVs, TMP1, _),
{ TMP = x(_) },
[tanh(TMP,TMP1)].
visit_exp(asinh(X), TypedVs, [t(_,float,TMP)|NewTypedVs], TMP, float) -->
visit_exp(X, TypedVs, NewTypedVs, TMP1, _),
{ TMP = x(_) },
[asinh(TMP,TMP1)].
visit_exp(acosh(X), TypedVs, [t(_,float,TMP)|NewTypedVs], TMP, float) -->
visit_exp(X, TypedVs, NewTypedVs, TMP1, _),
{ TMP = x(_) },
[acosh(TMP,TMP1)].
visit_exp(atanh(X), TypedVs, [t(_,float,TMP)|NewTypedVs], TMP, float) -->
visit_exp(X, TypedVs, NewTypedVs, TMP1, _),
{ TMP = x(_) },
[atanh(TMP,TMP1)].
visit_exp(floor(X), TypedVs, [t(_,float,TMP)|NewTypedVs], TMP, float) -->
visit_exp(X, TypedVs, NewTypedVs, TMP1, _),
{ TMP = x(_) },
[floor(TMP,TMP1)].
visit_exp(abs(X), TypedVs, [t(_,T,TMP)|NewTypedVs], TMP, T) -->
visit_exp(X, TypedVs, NewTypedVs, TMP1, T),
{ TMP = x(_) },
[abs(TMP,TMP1)].
visit_exp(integer(X), TypedVs, [t(_,int,TMP)|NewTypedVs], TMP, int) -->
visit_exp(X, TypedVs, NewTypedVs, TMP1, _),
{ TMP = x(_) },
[integer(TMP,TMP1)].
visit_exp(truncate(X), TypedVs, [t(_,float,TMP)|NewTypedVs], TMP, float) -->
visit_exp(X, TypedVs, NewTypedVs, TMP1, _),
{ TMP = x(_) },
[truncate(TMP,TMP1)].
visit_exp(round(X), TypedVs, [t(_,float,TMP)|NewTypedVs], TMP, float) -->
visit_exp(X, TypedVs, NewTypedVs, TMP1, _),
{ TMP = x(_) },
[round(TMP,TMP1)].
visit_exp(ceiling(X), TypedVs, [t(_,float,TMP)|NewTypedVs], TMP, float) -->
visit_exp(X, TypedVs, NewTypedVs, TMP1, _),
{ TMP = x(_) },
[ceiling(TMP,TMP1)].
visit_exp(msb(X), TypedVs, [t(_,int,TMP)|NewTypedVs], TMP, int) -->
visit_exp(X, TypedVs, NewTypedVs, TMP1, int),
{ TMP = x(_) },
[msb(TMP,TMP1)].
visit_exp(random(X), TypedVs, [t(_,int,TMP)|NewTypedVs], TMP, int) -->
visit_exp(X, TypedVs, NewTypedVs, TMP1, int),
{ TMP = x(_) },
[random(TMP,TMP1)].
visit_exp(lgamma(X), TypedVs, [t(_,float,TMP)|NewTypedVs], TMP, float) -->
visit_exp(X, TypedVs, NewTypedVs, TMP1, _),
{ TMP = x(_) },
[lgamma(TMP,TMP1)].
forward_type(T1, _, Type) :- T1 == float, !, Type = float.
forward_type(_, T2, Type) :- T2 == float, !, Type = float.
forward_type(T1, T2, Type) :- T1 == int, T2 == int, !, Type = int.
forward_type(_, _, _).
tmember(X, [t(X1,Type,Tmp)|_], Type, Tmp) :-
X == X1, !.
tmember(X, [_|TypesVs], Type, Tmp) :-
tmember(X, TypesVs, Type, Tmp).
stmember(X, [t(X,Type,Tmp1)|_], Type, Tmp) :-
Tmp == Tmp1, !.
stmember(X, [_|TypesVs], Type, Tmp) :-
stmember(X, TypesVs, Type, Tmp).
vmember(X, [X1|_]) :-
X == X1, !.
vmember(X, [_|Vs]) :-
vmember(X, Vs).
add_type(random, float).
add_type(pi, float).
add_type(inf, float).
add_type(nan, float).
add_type(random, float).
add_type(cputime, float).
add_type(heapused, int).
add_type(local_sp, int).
add_type(global_sp, int).
add_type(stackfree, int).
noatoms(N) :-
N =.. [_|Ns],
noatom_in_list(Ns).
noatom_in_list([]).
noatom_in_list([El|Els]) :-
\+ atom(El),
El =.. [_|LEl],
noatom_in_list(LEl),
noatom_in_list(Els).
alloc_regs([],R,R).
alloc_regs([t(_,_,no)|NewTypedVs], R0, RF) :- !,
alloc_regs(NewTypedVs, R0, RF).
alloc_regs([t(_,_,x(R0))|NewTypedVs], R0, RF) :- !,
R1 is R0+1,
alloc_regs(NewTypedVs, R1, RF).
alloc_regs([t(_,_,x(_))|NewTypedVs], R0, RF) :-
alloc_regs(NewTypedVs, R0, RF).
compile_ops([], Gs, Tail) :-
compile_tail(Gs, Tail).
compile_ops([Op|Exps], Gs, (COp,More)) :-
compile_op(Op , COp),
compile_ops(Exps, Gs, More).
compile_tail(Gs,(E1,Gs,E2,E3,E4)) :-
compile_op(set_label(exception_label),E1),
compile_op(set_label(success_label),E2),
compile_op(clear_label(exception_label),E3),
compile_op(clear_label(success_label),E4).
compile_op(init_label(exception_label), '$label_ctl'(0,2)).
compile_op(init_label(fail_label), '$label_ctl'(0,1)).
compile_op(init_label(success_label), '$label_ctl'(0,0)).
compile_op(set_label(exception_label), '$label_ctl'(1,2)).
compile_op(set_label(fail_label), '$label_ctl'(1,1)).
compile_op(set_label(success_label), '$label_ctl'(1,0)).
compile_op(clear_label(exception_label), '$label_ctl'(2,2)).
compile_op(clear_label(fail_label), '$label_ctl'(2,1)).
compile_op(clear_label(success_label), '$label_ctl'(2,0)).
compile_op(export(x(A),V,any), '$put_fi'(A,V)) :- !.
compile_op(export(x(A),V,int), '$put_i'(A,V)).
compile_op(export(x(A),V,float), '$put_f'(A,V)).
compile_op(eq(x(A),F), '$a_eq_float'(A,F)) :- float(F), !.
compile_op(eq(x(A),I), '$a_eq_int'(A,I)) :- integer(I), !, \+ '$bignum'(I).
compile_op(eq(x(A),x(B)), '$a_eq'(A,B)).
compile_op(lt(x(A),F), '$ltc_float'(A,F)) :- float(F), !.
compile_op(lt(x(A),I), '$ltc_int'(A,I)) :- integer(I), !, \+ '$bignum'(I).
compile_op(lt(F,x(A)), '$gtc_float'(A,F)) :- float(F), !.
compile_op(lt(I,x(A)), '$gtc_int'(A,I)) :- integer(I), !, \+ '$bignum'(I).
compile_op(lt(x(A),x(B)), '$lt'(A,B)).
compile_op(get(x(A),V,any), '$get_fi'(A,V)) :- !.
compile_op(get(x(A),V,int), '$get_i'(A,V)) :- !.
compile_op(get(x(A),V,float), '$get_f'(A,V)).
compile_op(add(x(A),F,x(B)), '$add_float_c'(A,B,F)) :- float(F), !.
compile_op(add(x(A),I,x(B)), '$add_int_c'(A,B,I)) :- integer(I), !, \+ '$bignum'(I).
compile_op(add(x(A),x(B),F), '$add_float_c'(A,B,F)) :- float(F), !.
compile_op(add(x(A),x(B),I), '$add_int_c'(A,B,I)) :- integer(I), !, \+ '$bignum'(I).
compile_op(add(x(A),x(B),x(C)), '$add'(A,B,C)).
compile_op(sub(x(A),F,x(B)), '$sub_float_c'(A,B,F)) :- float(F), !.
compile_op(sub(x(A),I,x(B)), '$sub_int_c'(A,B,I)) :- integer(I), !, \+ '$bignum'(I).
compile_op(sub(x(A),x(B),F), '$add_float_c'(A,B,F1)) :- float(F), !, F1 is -F.
compile_op(sub(x(A),x(B),I), '$add_int_c'(A,B,I1)) :- integer(I), !, I1 is -I, \+ '$bignum'(I1).
compile_op(sub(x(A),x(B),x(C)), '$sub'(A,B,C)).
compile_op(mul(x(A),F,x(B)), '$mul_float_c'(A,B,F)) :- float(F), !.
compile_op(mul(x(A),I,x(B)), '$mul_int_c'(A,B,I)) :- integer(I), !, \+ '$bignum'(I).
compile_op(mul(x(A),x(B),F), '$mul_float_c'(A,B,F)) :- float(F), !.
compile_op(mul(x(A),x(B),I), '$mul_int_c'(A,B,I)) :- integer(I), !, \+ '$bignum'(I).
compile_op(mul(x(A),x(B),x(C)), '$mul'(A,B,C)).
compile_op(fdiv(x(A),F,x(B)), '$fdiv_c1'(A,B,F)) :- float(F), !.
compile_op(fdiv(x(A),I,x(B)), '$fdiv_c1'(A,B,F)) :- integer(I), !, \+ '$bignum'(I), F is truncate(I).
compile_op(fdiv(x(A),x(B),F), '$fdiv_c2'(A,B,F)) :- float(F), !.
compile_op(fdiv(x(A),x(B),I), '$fdiv_c2'(A,B,F)) :- integer(I), !, \+ '$bignum'(I), F is truncate(I).
compile_op(fdiv(x(A),x(B),x(C)), '$fdiv'(A,B,C)).
compile_op(idiv(x(A),I,x(B)), '$idiv_c1'(A,B,I)) :- integer(I), !, \+ '$bignum'(I).
compile_op(idiv(x(A),x(B),I), '$idiv_c2'(A,B,I)) :- integer(I), !, \+ '$bignum'(I).
compile_op(idiv(x(A),x(B),x(C)), '$idiv'(A,B,C)).
compile_op(mod(x(A),I,x(B)), '$mod_c1'(A,B,I)) :- integer(I), !, \+ '$bignum'(I).
compile_op(mod(x(A),x(B),I), '$mod_c2'(A,B,I)) :- integer(I), !, \+ '$bignum'(I).
compile_op(mod(x(A),x(B),x(C)), '$mod'(A,B,C)).
compile_op(rem(x(A),I,x(B)), '$rem_c1'(A,B,I)) :- integer(I), !, \+ '$bignum'(I).
compile_op(rem(x(A),x(B),I), '$rem_c2'(A,B,I)) :- integer(I), !, \+ '$bignum'(I).
compile_op(rem(x(A),x(B),x(C)), '$rem'(A,B,C)).
compile_op(and(x(A),I,x(B)), '$land_c'(A,B,I)) :- integer(I), !, \+ '$bignum'(I).
compile_op(and(x(A),x(B),I), '$land_c'(A,B,I)) :- integer(I), !, \+ '$bignum'(I).
compile_op(and(x(A),x(B),x(C)), '$land'(A,B,C)).
compile_op(or(x(A),I,x(B)), '$lor_c'(A,B,I)) :- integer(I), !, \+ '$bignum'(I).
compile_op(or(x(A),x(B),I), '$lor_c'(A,B,I)) :- integer(I), !, \+ '$bignum'(I).
compile_op(or(x(A),x(B),x(C)), '$lor'(A,B,C)).
compile_op(xor(x(A),I,x(B)), '$xor_c'(A,B,I)) :- integer(I), !, \+ '$bignum'(I).
compile_op(xor(x(A),x(B),I), '$xor_c'(A,B,I)) :- integer(I), !, \+ '$bignum'(I).
compile_op(xor(x(A),x(B),x(C)), '$xor'(A,B,C)).
compile_op(uminus(x(A),x(B)), '$uminus'(A,B)).
compile_op(sr(x(A),I,x(B)), '$sr_c1'(A,B,I)) :- integer(I), !, \+ '$bignum'(I).
compile_op(sr(x(A),x(B),I), '$sr_c2'(A,B,I)) :- integer(I), I >=0, !, \+ '$bignum'(I).
compile_op(sr(x(A),x(B),I), '$sl_c2'(A,B,NI)) :- integer(I), !, NI is -I, \+ '$bignum'(NI).
compile_op(sr(x(A),x(B),x(C)), '$sr'(A,B,C)).
compile_op(sl(x(A),I,x(B)), '$sl_c1'(A,B,I)) :- integer(I), !, \+ '$bignum'(I).
compile_op(sl(x(A),x(B),I), '$sl_c2'(A,B,I)) :- integer(I), I >= 0, !, \+ '$bignum'(I).
compile_op(sl(x(A),x(B),I), '$sr_c2'(A,B,NI)) :- integer(I), !, NI is -I, \+ '$bignum'(NI).
compile_op(sl(x(A),x(B),x(C)), '$sl'(A,B,C)).
/*
compile_op(zerop(x(A),Op), '$zerop'(A,Op)).
compile_op(exp(x(A),F,x(B)), exp_c(A,B,F)) :- float(F), !.
compile_op(exp(x(A),I,x(B)), exp_c(A,B,F)) :- integer(I), !, \+ '$bignum'(I), F is truncate(I).
compile_op(exp(x(A),x(B),F), exp_c(A,B,F)) :- float(F), !.
compile_op(exp(x(A),x(B),I), exp_c(A,B,F)) :- integer(I), !, \+ '$bignum'(I), F is truncate(I).
compile_op(exp(x(A),x(B),x(C)), exp(A,B,C)).
compile_op(max(x(A),F,x(B)), max_float_c(A,B,F)) :- float(F), !.
compile_op(max(x(A),I,x(B)), max_int_c(A,B,I)) :- integer(I), !, \+ '$bignum'(I).
compile_op(max(x(A),x(B),F), max_float_c(A,B,F)) :- float(F), !.
compile_op(max(x(A),x(B),I), max_int_c(A,B,I)) :- integer(I), !, \+ '$bignum'(I).
compile_op(max(x(A),x(B),x(C)), max(A,B,C)).
compile_op(min(x(A),F,x(B)), min_float_c(A,B,F)) :- float(F), !.
compile_op(min(x(A),I,x(B)), min_int_c(A,B,I)) :- integer(I), !, \+ '$bignum'(I).
compile_op(min(x(A),x(B),F), min_float_c(A,B,F)) :- float(F), !.
compile_op(min(x(A),x(B),I), min_int_c(A,B,I)) :- integer(I), !, \+ '$bignum'(I).
compile_op(min(x(A),x(B),x(C)), min(A,B,C)).
compile_op(gcd(x(A),I,x(B)), gcd_c(A,B,I)) :- integer(I), !, \+ '$bignum'(I).
compile_op(gcd(x(A),x(B),I), gcd_c(A,B,I)) :- integer(I), !, \+ '$bignum'(I).
compile_op(gcd(x(A),x(B),x(C)), gcd(A,B,C)).
compile_op(unot(x(A),x(B)), unot(A,B)).
compile_op(exp1(x(A),x(B)), exp1(A,B)).
compile_op(log(x(A),x(B)), log(A,B)).
compile_op(log10(x(A),x(B)), log10(A,B)).
compile_op(sqrt(x(A),x(B)), sqrt(A,B)).
compile_op(sin(x(A),x(B)), sin(A,B)).
compile_op(cos(x(A),x(B)), cos(A,B)).
compile_op(tan(x(A),x(B)), tan(A,B)).
compile_op(asin(x(A),x(B)), asin(A,B)).
compile_op(acos(x(A),x(B)), acos(A,B)).
compile_op(atan(x(A),x(B)), atan(A,B)).
compile_op(atan2(x(A),x(B)), atan2(A,B)).
compile_op(sinh(x(A),x(B)), sinh(A,B)).
compile_op(cosh(x(A),x(B)), cosh(A,B)).
compile_op(tanh(x(A),x(B)), tanh(A,B)).
compile_op(asinh(x(A),x(B)), asinh(A,B)).
compile_op(acosh(x(A),x(B)), acosh(A,B)).
compile_op(atanh(x(A),x(B)), atanh(A,B)).
compile_op(floor(x(A),x(B)), floor(A,B)).
compile_op(abs(x(A),x(B)), abs(A,B)).
compile_op(integer(x(A),x(B)), integer(A,B)).
compile_op(truncate(x(A),x(B)), truncate(A,B)).
compile_op(round(x(A),x(B)), round(A,B)).
compile_op(ceiling(x(A),x(B)), ceiling(A,B)).
compile_op(msb(x(A),x(B)), msb(A,B)).
compile_op(random(x(A),x(B)), random(A,B)).
compile_op(lgamma(x(A),x(B)), lgamma(A,B)).
*/

9
pl/modules.yap
View File

@ -194,11 +194,16 @@ module(N) :-
% A6: head module (this is the one used in compiling and accessing). % A6: head module (this is the one used in compiling and accessing).
% %
% %
'$module_expansion'((H:-B),(H:-B1),(H:-BO),M,HM) :- !, '$module_expansion'((H:-B),(H:-B1),(H:-BOO),M,HM) :- !,
'$is_mt'(M, H, B, IB, MM), '$is_mt'(M, H, B, IB, MM),
'$module_u_vars'(H,UVars,M), % collect head variables in '$module_u_vars'(H,UVars,M), % collect head variables in
% expanded positions % expanded positions
'$module_expansion'(IB,B1,BO,M,MM,HM,UVars). '$module_expansion'(IB,B1,BO,M,MM,HM,UVars),
('$full_clause_optimisation'(H, M, BO, BOO) ->
true
;
BO = BOO
).
% do not expand bodyless clauses. % do not expand bodyless clauses.
'$module_expansion'(H,H,H,_,_). '$module_expansion'(H,H,H,_,_).