This repository has been archived on 2023-08-20. You can view files and clone it, but cannot push or open issues or pull requests.
yap-6.3/pl/arith.yap

379 lines
11 KiB
Plaintext
Raw Normal View History

2015-09-25 14:31:58 +01:00
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: arith.yap *
* Last rev: *
* mods: *
* comments: arithmetical optimization *
* *
*************************************************************************/
2014-04-09 12:39:29 +01:00
% the default mode is on
2014-04-06 17:05:17 +01:00
2014-04-09 12:39:29 +01:00
:- system_module( '$_arith', [compile_expressions/0,
expand_exprs/2,
plus/3,
succ/2], ['$c_built_in'/3]).
2014-04-06 17:05:17 +01:00
2014-04-09 12:39:29 +01:00
:- private( [do_c_built_in/3,
do_c_built_metacall/3,
expand_expr/3,
expand_expr/5,
expand_expr/6] ).
2015-09-21 23:05:36 +01:00
2014-04-09 12:39:29 +01:00
:- use_system_module( '$_errors', ['$do_error'/2]).
:- use_system_module( '$_modules', ['$clean_cuts'/2]).
/** @defgroup CompilerAnalysis Internal Clause Rewriting
@ingroup YAPCompilerSettings
2014-12-24 15:32:29 +00:00
YAP supports several clause optimisation mechanisms, that
are designed to improve execution of arithmetic
and term construction built-ins. In other words, during the
compilation process a clause is rewritten twice:
2014-12-24 15:32:29 +00:00
1. first, perform user-defined goal_expansion as described
in the predicates goal_expansion/1 and goal_expansion/2.
2014-12-24 15:32:29 +00:00
2. Perform expansion of some built-ins like:
2014-12-24 15:32:29 +00:00
+ pruning operators, like ->/2 and *->/2
2014-12-24 15:32:29 +00:00
+ arithmetic, including early evaluation of constant expressions
2014-12-24 15:32:29 +00:00
+ specialise versions for some built-ins, if we are aware of the
run-time execution mode
The user has some control over this process, through some
built-ins and through execution flsgs.
*/
2015-01-04 23:58:23 +00:00
%% @{
2015-09-21 23:05:36 +01:00
/** @pred expand_exprs(- _O_,+ _N_)
Control term expansion during compilation.
Enables low-level optimizations. It reports the current state by
unifying _O_ with the previous state. It then puts YAP in state _N_
(`on` or `off`)/ _On_ is equivalent to compile_expressions/0 and `off`
is equivalent to do_not_compile_expressions/0.
This predicate is useful when debugging, to ensure execution close to the original source.
2015-09-21 23:05:36 +01:00
*/
expand_exprs(Old,New) :-
(get_value('$c_arith',true) ->
Old = on ;
Old = off ),
'$set_arith_expan'(New).
'$set_arith_expan'(on) :- set_value('$c_arith',true).
'$set_arith_expan'(off) :- set_value('$c_arith',[]).
/** @pred compile_expressions
After a call to this predicate, arithmetical expressions will be compiled.
(see example below). This is the default behavior.
*/
2014-10-02 14:39:45 +01:00
compile_expressions :- set_value('$c_arith',true).
/** @pred do_not_compile_expressions
After a call to this predicate, arithmetical expressions will not be compiled.
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
?- source, do_not_compile_expressions.
yes
?- [user].
| p(X) :- X is 2 * (3 + 8).
| :- end_of_file.
?- compile_expressions.
yes
?- [user].
| q(X) :- X is 2 * (3 + 8).
| :- end_of_file.
:- listing.
p(A):-
A is 2 * (3 + 8).
q(A):-
A is 22.
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2015-09-29 23:49:03 +01:00
w*/
do_not_compile_expressions :- set_value('$c_arith',[]).
2015-09-25 10:57:26 +01:00
'$c_built_in'(IN, M, H, OUT) :-
get_value('$c_arith',true), !,
2015-09-25 10:57:26 +01:00
do_c_built_in(IN, M, H, OUT).
'$c_built_in'(IN, _, _H, IN).
2015-09-25 10:57:26 +01:00
do_c_built_in(G, M, H, OUT) :- var(G), !,
do_c_built_metacall(G, M, H, OUT).
do_c_built_in(Mod:G, _, H, OUT) :-
'$yap_strip_module'(Mod:G, M1, G1),
2014-10-11 12:45:54 +01:00
var(G1), !,
2015-09-25 10:57:26 +01:00
do_c_built_metacall(G1, M1, H, OUT).
do_c_built_in('C'(A,B,C), _, _, (A=[B|C])) :- !.
2015-09-29 23:49:03 +01:00
do_c_built_in('$do_error'( Error, Goal), M, Head,
(clause_location(Call, Caller),
strip_module(M:Goal,M1,NGoal),
throw(error(Error, [[g|g(M1:NGoal)],[p|Call],[e|Caller],[h|g(Head)]]))
2015-09-25 14:31:58 +01:00
)
2015-09-29 23:49:03 +01:00
) :- !.
2015-09-25 14:31:58 +01:00
do_c_built_in(X is Y, M, H, P) :-
2009-09-10 00:13:12 +01:00
primitive(X), !,
2015-09-25 14:31:58 +01:00
do_c_built_in(X =:= Y, M, H, P).
do_c_built_in(X is Y, M, H, (P,A=X)) :-
nonvar(X), !,
2015-09-25 14:31:58 +01:00
do_c_built_in(A is Y, M, H, P).
2015-09-25 10:57:26 +01:00
do_c_built_in(X is Y, _, _, P) :-
nonvar(Y), % Don't rewrite variables
!,
(
number(Y) ->
P = ( X = Y); % This case reduces to an unification
2014-04-06 17:05:17 +01:00
expand_expr(Y, P0, X0),
'$drop_is'(X0, X, P0, P)
).
2015-09-25 14:31:58 +01:00
do_c_built_in(phrase(NT,Xs), Mod, H, NTXsNil) :-
'$_arith':do_c_built_in(phrase(NT,Xs,[]), Mod, H, NTXsNil).
2015-09-25 10:57:26 +01:00
do_c_built_in(phrase(NT,Xs0,Xs), Mod, _, NewGoal) :-
'$goal_expansion_allowed'(phrase(NT,Xs0,Xs), Mod),
Goal = phrase(NT,Xs0,Xs),
callable(NT),
2015-09-29 23:49:03 +01:00
catch(prolog:'$translate_rule'((pseudo_nt --> NT), Rule),
error(Pat,ImplDep),
2015-09-21 23:05:36 +01:00
( \+ '$harmless_dcgexception'(Pat),
throw(error(Pat,ImplDep))
)
),
Rule = (pseudo_nt(Xs0c,Xsc) :- NewGoal0),
Goal \== NewGoal0,
% apply translation only if we are safe
\+ '$contains_illegal_dcgnt'(NT), !,
( var(Xsc), Xsc \== Xs0c
-> Xs = Xsc, NewGoal1 = NewGoal0
; NewGoal1 = (NewGoal0, Xsc = Xs)
),
( var(Xs0c)
-> Xs0 = Xs0c,
NewGoal = NewGoal1
; ( Xs0 = Xs0c, NewGoal1 ) = NewGoal
).
2015-09-25 10:57:26 +01:00
do_c_built_in(Comp0, _, _, R) :- % now, do it for comparisons
'$compop'(Comp0, Op, E, F),
!,
'$compop'(Comp, Op, U, V),
2014-04-06 17:05:17 +01:00
expand_expr(E, P, U),
expand_expr(F, Q, V),
'$do_and'(P, Q, R0),
'$do_and'(R0, Comp, R).
2015-09-25 10:57:26 +01:00
do_c_built_in(P, _M, _H, P).
2015-09-25 14:31:58 +01:00
do_c_built_metacall(G1, Mod, _, '$execute_wo_mod'(G1,Mod)) :-
2014-10-11 12:45:54 +01:00
var(Mod), !.
2015-09-25 14:31:58 +01:00
do_c_built_metacall(G1, Mod, _, '$execute_in_mod'(G1,Mod)) :-
2014-10-11 12:45:54 +01:00
atom(Mod), !.
2015-09-25 14:31:58 +01:00
do_c_built_metacall(G1, Mod, _, call(Mod:G1)).
'$do_and'(true, P, P) :- !.
'$do_and'(P, true, P) :- !.
'$do_and'(P, Q, (P,Q)).
% V is the result of the simplification,
% X the result of the initial expression
% and the last argument is how we are writing this result
2015-09-21 23:05:36 +01:00
'$drop_is'(V, V1, P0, G) :-
var(V),
!, % usual case
V = V1,
P0 = G.
'$drop_is'(V, X, P0, P) :- % atoms
'$do_and'(P0, X is V, P).
% Table of arithmetic comparisons
'$compop'(X < Y, < , X, Y).
'$compop'(X > Y, > , X, Y).
'$compop'(X=< Y,=< , X, Y).
'$compop'(X >=Y, >=, X, Y).
'$compop'(X=:=Y,=:=, X, Y).
'$compop'(X=\=Y,=\=, X, Y).
'$composed_built_in'(V) :- var(V), !,
fail.
2015-11-05 17:26:04 +00:00
'$composed_built_in'(('$current_choice_point'(_),NG,'$$cut_by'(_))) :- !,
'$composed_built_in'(NG).
'$composed_built_in'((_,_)).
'$composed_built_in'((_;_)).
'$composed_built_in'((_|_)).
'$composed_built_in'((_->_)).
'$composed_built_in'(_:G) :-
'$composed_built_in'(G).
'$composed_built_in'(\+G) :-
'$composed_built_in'(G).
'$composed_built_in'(not(G)) :-
'$composed_built_in'(G).
2015-09-21 23:05:36 +01:00
% expanding an expression:
% first argument is the expression not expanded,
% second argument the expanded expression
% third argument unifies with the result from the expression
2014-04-06 17:05:17 +01:00
expand_expr(V, true, V) :-
var(V), !.
2014-04-06 17:05:17 +01:00
expand_expr([T], E, V) :- !,
expand_expr(T, E, V).
expand_expr(String, _E, V) :-
2014-03-16 18:59:54 +00:00
string( String ), !,
string_codes(String, [V]).
2014-04-06 17:05:17 +01:00
expand_expr(A, true, A) :-
atomic(A), !.
2014-04-06 17:05:17 +01:00
expand_expr(T, E, V) :-
T =.. [O, A], !,
2014-04-06 17:05:17 +01:00
expand_expr(A, Q, X),
expand_expr(O, X, V, Q, E).
expand_expr(T, E, V) :-
T =.. [O, A, B], !,
2014-04-06 17:05:17 +01:00
expand_expr(A, Q, X),
expand_expr(B, R, Y),
expand_expr(O, X, Y, V, Q, S),
'$do_and'(R, S, E).
% expanding an expression of the form:
% O is Op(X),
% after having expanded into Q
% and giving as result P (the last argument)
2014-04-06 17:05:17 +01:00
expand_expr(Op, X, O, Q, Q) :-
2015-10-05 10:40:58 +01:00
number(X),
catch(is( O, Op, X),_,fail), !. % do not do error handling at compile time
2014-04-06 17:05:17 +01:00
expand_expr(Op, X, O, Q, P) :-
'$unary_op_as_integer'(Op,IOp),
'$do_and'(Q, is( O, IOp, X), P).
% expanding an expression of the form:
% O is Op(X,Y),
% after having expanded into Q
% and giving as result P (the last argument)
% included is some optimization for:
% incrementing and decrementing,
% the elementar arithmetic operations [+,-,*,//]
2014-04-06 17:05:17 +01:00
expand_expr(Op, X, Y, O, Q, Q) :-
2015-10-05 10:40:58 +01:00
number(X), number(Y),
catch(is( O, Op, X, Y),_,fail), !.
2014-04-06 17:05:17 +01:00
expand_expr(+, X, Y, O, Q, P) :- !,
'$preprocess_args_for_commutative'(X, Y, X1, Y1, E),
'$do_and'(E, '$plus'(X1,Y1,O), F),
'$do_and'(Q, F, P).
2014-04-06 17:05:17 +01:00
expand_expr(-, X, Y, O, Q, P) :-
2009-02-16 09:55:31 +00:00
var(X), number(Y),
Z is -Y, !,
2014-04-06 17:05:17 +01:00
expand_expr(+, Z, X, O, Q, P).
expand_expr(-, X, Y, O, Q, P) :- !,
'$preprocess_args_for_non_commutative'(X, Y, X1, Y1, E),
'$do_and'(E, '$minus'(X1,Y1,O), F),
'$do_and'(Q, F, P).
2014-04-06 17:05:17 +01:00
expand_expr(*, X, Y, O, Q, P) :- !,
'$preprocess_args_for_commutative'(X, Y, X1, Y1, E),
'$do_and'(E, '$times'(X1,Y1,O), F),
'$do_and'(Q, F, P).
2014-04-06 17:05:17 +01:00
expand_expr(//, X, Y, O, Q, P) :-
2009-02-16 09:55:31 +00:00
nonvar(Y), Y == 0, !,
'$binary_op_as_integer'(//,IOp),
'$do_and'(Q, is(O,IOp,X,Y), P).
2014-04-06 17:05:17 +01:00
expand_expr(//, X, Y, O, Q, P) :- !,
'$preprocess_args_for_non_commutative'(X, Y, X1, Y1, E),
'$do_and'(E, '$div'(X1,Y1,O), F),
'$do_and'(Q, F, P).
2014-04-06 17:05:17 +01:00
expand_expr(/\, X, Y, O, Q, P) :- !,
'$preprocess_args_for_commutative'(X, Y, X1, Y1, E),
'$do_and'(E, '$and'(X1,Y1,O), F),
'$do_and'(Q, F, P).
2014-04-06 17:05:17 +01:00
expand_expr(\/, X, Y, O, Q, P) :- !,
'$preprocess_args_for_commutative'(X, Y, X1, Y1, E),
'$do_and'(E, '$or'(X1,Y1,O), F),
'$do_and'(Q, F, P).
2014-04-06 17:05:17 +01:00
expand_expr(<<, X, Y, O, Q, P) :-
2009-02-16 09:55:31 +00:00
var(X), number(Y), Y < 0,
Z is -Y, !,
2014-04-06 17:05:17 +01:00
expand_expr(>>, X, Z, O, Q, P).
expand_expr(<<, X, Y, O, Q, P) :- !,
'$preprocess_args_for_non_commutative'(X, Y, X1, Y1, E),
'$do_and'(E, '$sll'(X1,Y1,O), F),
'$do_and'(Q, F, P).
2014-04-06 17:05:17 +01:00
expand_expr(>>, X, Y, O, Q, P) :-
2009-02-16 09:55:31 +00:00
var(X), number(Y), Y < 0,
Z is -Y, !,
2014-04-06 17:05:17 +01:00
expand_expr(<<, X, Z, O, Q, P).
expand_expr(>>, X, Y, O, Q, P) :- !,
'$preprocess_args_for_non_commutative'(X, Y, X1, Y1, E),
'$do_and'(E, '$slr'(X1,Y1,O), F),
'$do_and'(Q, F, P).
2014-04-06 17:05:17 +01:00
expand_expr(Op, X, Y, O, Q, P) :-
'$binary_op_as_integer'(Op,IOp),
'$do_and'(Q, is(O,IOp,X,Y), P).
'$preprocess_args_for_commutative'(X, Y, X, Y, true) :-
var(X), var(Y), !.
'$preprocess_args_for_commutative'(X, Y, X, Y, true) :-
var(X), integer(Y), \+ '$bignum'(Y), !.
'$preprocess_args_for_commutative'(X, Y, X, Z, Z = Y) :-
var(X), !.
'$preprocess_args_for_commutative'(X, Y, Y, X, true) :-
integer(X), \+ '$bignum'(X), var(Y), !.
'$preprocess_args_for_commutative'(X, Y, Z, X, Z = Y) :-
integer(X), \+ '$bignum'(X), !.
'$preprocess_args_for_commutative'(X, Y, Z, W, E) :-
'$do_and'(Z = X, Y = W, E).
'$preprocess_args_for_non_commutative'(X, Y, X, Y, true) :-
var(X), var(Y), !.
'$preprocess_args_for_non_commutative'(X, Y, X, Y, true) :-
var(X), integer(Y), \+ '$bignum'(Y), !.
'$preprocess_args_for_non_commutative'(X, Y, X, Z, Z = Y) :-
var(X), !.
'$preprocess_args_for_non_commutative'(X, Y, X, Y, true) :-
integer(X), \+ '$bignum'(X), var(Y), !.
'$preprocess_args_for_non_commutative'(X, Y, X, Z, Z = Y) :-
2009-02-16 09:55:31 +00:00
integer(X), \+ '$bignum'(X), !.
'$preprocess_args_for_non_commutative'(X, Y, Z, W, E) :-
'$do_and'(Z = X, Y = W, E).
2010-05-04 16:33:35 +01:00
2014-10-02 14:39:45 +01:00
'$goal_expansion_allowed'(phrase(_NT,_Xs0,_Xs), _Mod).
%% contains_illegal_dcgnt(+Term) is semidet.
%
% True if Term contains a non-terminal we cannot deal with using
% goal-expansion. The test is too general approximation, but safe.
'$contains_illegal_dcgnt'(NT) :-
functor(NT, _, A),
between(1, A, I),
2014-10-07 10:13:31 +01:00
arg(I, NT, AI),
nonvar(AI),
( AI = ! ; AI = phrase(_,_,_) ), !.
2014-10-02 14:39:45 +01:00
% write(contains_illegal_nt(NT)), % JW: we do not want to write
% nl.
'$harmless_dcgexception'(instantiation_error). % ex: phrase(([1],x:X,[3]),L)
'$harmless_dcgexception'(type_error(callable,_)). % ex: phrase(27,L)
2015-09-29 23:49:03 +01:00
:- set_value('$c_arith',true).
2015-09-21 23:05:36 +01:00
/**
@}
*/