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/CHR/chr/chrcmp.pl
2006-05-24 02:35:39 +00:00

1496 lines
38 KiB
Prolog

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Constraint Handling Rules version 2.2 %
% %
% (c) Copyright 1996-98 %
% LMU, Muenchen %
% %
% File: chrcmp.pl %
% Author: Christian Holzbaur christian@ai.univie.ac.at %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
/*
NOTES
-----
+) Environment trimming?
No because the merrits are small and revive needs vars trimmed away ...
+) Full macro expansion (decouple compiler from runtime system)
-) Group rules with identical outer match prefix?
Problem with total rule order.
*/
:- module( chrcmp,
[
options/0,
cc/1
]).
%vsc
% debug
:- ['operator'].
:- use_module(getval).
:- ['matching'].
:- use_module(concat, [concat_name/2]).
:- use_module( library(terms),
[
term_variables/2,
variant/2
]).
:- use_module( library(lists),
[
is_list/1,
member/2,
append/3,
reverse/2,
same_length/2
]).
:- use_module( library(ordsets),
[
list_to_ord_set/2,
ord_intersection/3,
ord_member/2,
ord_union/3
]).
%
% name, [default | values]
%
compiler_option( check_guard_bindings, [on,off]).
compiler_option( already_in_store, [off,on]).
compiler_option( already_in_heads, [off,on]).
compiler_option( debug_compile, [off,on]).
%
% internal
%
compiler_option( flatten, [on,off]).
compiler_option( rule_ordering, [canonical,heuristic]).
compiler_option( simpagation_scheme, [single,multi]).
compiler_option( revive_scheme, [new,old]).
compiler_option( dead_code_elimination, [on,off]).
options :-
compiler_option( Name, _),
getval( Name, Value),
print( option(Name,Value)), put(0'.), nl,
fail.
options.
:- dynamic constraint/2.
:- dynamic rule/7.
:- dynamic aih_functor/3.
%
% Default compiler options, etc.
%
init( _) :-
compiler_option( Name, [Default|_]),
setval( Name, Default),
fail.
init( Name) :-
setval( rulenum, 0),
setval( rules, _),
setval( handler, Name),
retractall( rule(Name,_,_,_,_,_,_)),
retractall( constraint(Name,_)),
retractall( aih_functor(Name,_,_)).
:- initialization
init(_).
:- multifile
user:portray_message/2,
user:term_expansion/2,
user:goal_expansion/3.
:- dynamic
user:portray_message/2,
user:term_expansion/2,
user:goal_expansion/3.
user:goal_expansion( dbg(E), chr, Exp) :-
( getval( debug_compile, on) ->
Exp = debug_event(E)
;
Exp = true
).
user:goal_expansion( '__remove_some'(L), _, Exp) :-
remove_some( L, Exp).
remove_some( [], true).
remove_some( [H#T|Ts], Exp) :-
functor( H, F, A),
flat( 'F'(n(detach,F/A), Vars, T), Call),
Exp = (
chr:dbg( remove(T)),
chr:remove_constraint_internal( T, Vars),
Call,
Exps
),
remove_some( Ts, Exps).
user:portray_message( informational, compiler(What)) :-
info_message( What).
user:portray_message( error, compiler(What)) :-
error_message( What, '{CHR Compiler ERROR: ', '}').
info_message( start(F,A)) :- !,
format( user_error, '{CHR compiling constraint ~p/~p}~n', [F,A]).
info_message( dce(H,R)) :- !,
format( user_error, '{CHR eliminated code for head ~p in ~p}~n', [H,R]).
info_message( What) :-
print_message( force(informational), What).
error_message( syntax(Term,N), P, S) :- !,
prolog_flag( toplevel_print_options, Opt),
format( user_error, '~asyntax rule ~p: ~@~a~n', [P,N,write_term(Term,Opt),S]).
%
error_message( wild_head(Rule), P, S) :- !,
format( user_error, '~atoo many general heads in ~p~a~n', [P,Rule,S]).
%
error_message( pragma(Prag,Rule), P, S) :- !,
format( user_error, '~abad pragma ~p in ~p~a~n', [P,Prag,Rule,S]).
%
error_message( undefined_constraint(F,A,Rule,Poss), P, S) :- !,
format( user_error, '~afound head ~p in ~p, expected one of: ~p~a~n',
[P,F/A,Rule,Poss,S]).
%
error_message( bad_ids(R), Prefix, Suffix) :- !,
prolog_flag( toplevel_print_options, Opt),
format( user_error, '~ahead identifiers in ~@ are not unique variables~a~n',
[Prefix,write_term(R,Opt),Suffix]).
%
error_message( handler_undefined, Prefix, Suffix) :- !,
format( user_error,'~ano handler defined~a~n', [Prefix,Suffix]).
%
error_message( failed, Prefix, Suffix) :- !,
format( user_error,'~acompilation failed~a~n', [Prefix,Suffix]).
%
error_message( What, _, _) :-
print_message( force(error), What).
% ------------------------------------------------------------------
record_constr( C, _) :- var( C), !,
raise_exception( instantiation_error(constraints(C),1)).
record_constr( (C,Cs), H) :- !,
record_constr( C, H),
record_constr( Cs, H).
record_constr( C, H) :-
C = F/A,
atom( F),
integer( A),
A >= 0,
!,
( constraint( H, C) ->
true
;
assert( constraint( H, C))
).
record_constr( C, _) :-
raise_exception( domain_error(constraints(C),1,'Functor/Arity',C)).
handler( Name) :-
getval( handler, Name),
nonvar( Name),
!.
handler( _) :-
raise_exception( compiler(handler_undefined)).
user:term_expansion( (handler Name), []) :-
( var( Name) ->
raise_exception( instantiation_error(handler(Name),1))
; atom( Name) ->
init( Name)
;
raise_exception( type_error(handler(Name),1,atom,Name))
).
user:term_expansion( option(N,V), []) :-
( compiler_option( N, Pval) ->
( member( V, Pval) ->
setval(N,V)
;
raise_exception( domain_error(option(N,V),2,one_of(Pval),V))
)
;
findall( O, compiler_option(O,_), Opts),
raise_exception( domain_error(option(N,V),1,one_of(Opts),N))
).
user:term_expansion( (rules Rs), []) :-
setval( rules, Rs).
user:term_expansion( (constraints C), []) :-
handler( Name),
record_constr( C, Name).
%
% Motivation for operator/3: compiler local operators
%
user:term_expansion( operator(A,B,C), (:-op(A,B,C))) :- op(A,B,C).
%
user:term_expansion( Term, []) :- Term = (_ @ _), !, parse_rule( Term).
user:term_expansion( Term, []) :- Term = (_ pragma _), !, parse_rule( Term).
user:term_expansion( Term, []) :- Term = (_ <=> _), !, parse_rule( Term).
user:term_expansion( Term, []) :- Term = (_ ==> _), !, parse_rule( Term).
%
user:term_expansion( end_of_file, Exp) :-
prolog_load_context( module, Module),
Module \== chrcmp, % leave us alone
getval( handler, Name),
nonvar( Name),
!,
setval( handler, _), % spill once only
%
% the system is unhappy when the expansion
% of end_of_file rises an exception ...
%
on_exception( Error, spill(Name,Module,Exp), report(Error)).
report( Error) :-
print_message( error, Error),
fail.
spill( Handler, Module, Exp3) :-
findall( Key, constraint(Handler,Key), Keys),
findall( C, (constraint(Handler,F/A),functor(C,F,A)), Cs),
comp_support( Keys, Handler, Module, Exp0,Exp1),
comp_constraints( Cs, Handler, Module, Exp1,[]),
expansion( Exp0, Exp3, []),
% show( Exp3),
!.
spill( _, _, _) :-
raise_exception( compiler(failed)).
show( Cls) :-
member( C, Cls),
portray_clause( C),
fail.
show( _).
expansion( []) --> [end_of_file].
expansion( [C|Cs]) -->
( {
flat( C, F),
expand_term( F, E)
} ->
copy( E)
;
{raise_exception( compiler(expansion_failed(C)))}
),
expansion( Cs).
copy( X) --> {var(X)}, !, [ X ].
copy( []) --> !.
copy( [X|Xs]) --> !, [ X ], copy( Xs).
copy( X) --> [ X ].
comp_support( Keys, Handler, Module) -->
{
keys2atts( Keys, Atts, AttSpec)
},
[
(:- chr:register_handler(Handler,Keys,Atts)),
(:- use_module(library(atts))),
(:- attribute(AttSpec)),
(verify_attributes( X, Y, Later) :-
get_atts( X, Sx),
Sx = [_|_],
!,
sort( Sx, Sxs),
( var(Y) ->
Later = [ chr:run_suspensions(Sz) ],
get_atts( Y, Sy),
sort( Sy, Sys),
chr:merge_attributes( Sxs, Sys, Sz),
call( put_atts( Y, Sz))
;
Later = [ chr:run_suspensions(Sx) ],
( compound(Y) -> % optimization
chr:term_variables( Y, NewVars),
attach_increment( NewVars, Sxs)
;
true
)
)),
(verify_attributes( _, _, [])),
(attach_increment( [], _)),
(attach_increment( [V|Vs], Attl) :-
chr:not_locked( V),
get_atts( V, All), % maybe []
sort( All, Alls),
chr:merge_attributes( Alls, Attl, AttsNew),
call( put_atts( V, AttsNew)),
attach_increment( Vs, Attl)),
(get_suspensions( X, Susp) :- get_atts( X, Susp)),
(put_suspensions( X, Susp) :- call(put_atts( X, Susp))),
(attribute_goal( X, Goal) :-
chr:global_term_ref_1( G),
X == G, % succeed once per module
get_atts( G, Gatts),
chr:attribute_goals( Gatts, Goal, Module))
],
gen_attach( Keys),
gen_detach( Keys),
gen_detach_case( Keys),
gen_insert( Keys, Module).
keys2atts( [], [], nil).
keys2atts( [FA], [Att], Name/1) :- !,
key2att( FA, Att, Name).
keys2atts( [FA|Keys], [Att|Atts], (Name/1,Specs)) :-
key2att( FA, Att, Name),
keys2atts( Keys, Atts, Specs).
key2att( FA, Attribute, Name) :-
concat_name( FA, Name),
functor( Attribute, Name, 1).
gen_attach( []) --> [].
gen_attach( [F/A|Fs]) -->
{
concat_name( F/A, AttName),
Att1 =.. [AttName,Val1],
Att2 =.. [AttName,Val2],
Att3 =.. [AttName,Val3]
},
[
'F'(n(attach,F/A),[], _),
('F'(n(attach,F/A),[X|Xs],S) :-
( get_atts( X, Att1) ->
chr:sbag_add_element( Val1, S, Val2),
put_atts( X, Att2)
;
chr:list_to_sbag( [S], Val3),
put_atts( X, Att3)
),
'F'(n(attach,F/A),Xs,S))
],
gen_attach( Fs).
gen_detach( []) --> [].
gen_detach( [F/A|Fs]) -->
{
concat_name( F/A, AttName),
Att1 =.. [AttName,Val1],
Att2 =.. [AttName,Val2]
},
[
'F'(n(detach,F/A),[], _),
('F'(n(detach,F/A),[X|Xs],S) :-
get_atts( X, Att1),
chr:sbag_del_element( Val1, S, Val2),
( chr:sbag_empty( Val2) ->
put_atts( X, -Att2)
;
put_atts( X, Att2)
),
'F'(n(detach,F/A),Xs,S))
],
gen_detach( Fs).
gen_detach_case( []) --> [].
gen_detach_case( [F/A|Fs]) -->
[
(detach(F/A,Susp,Vars) :- 'F'(n(detach,F/A),Vars,Susp))
],
gen_detach_case( Fs).
gen_insert( Keys, Module) -->
[
(insert_constraint(C,T) :- var(C), !,
raise_exception( instantiation_error( insert_constraint(C,T),1)))
],
gen_insert_2( Keys, Module),
[
(insert_constraint(C,T) :-
raise_exception( type_error(insert_constraint(C,T),1,'a constraint term',C)))
],
%
[
(insert_constraint(C,T,Vs) :- var(C), !,
raise_exception( instantiation_error( insert_constraint(C,T,Vs),1)))
],
gen_insert_3( Keys, Module),
[
(insert_constraint(C,T,Vs) :-
raise_exception( type_error(insert_constraint(C,T,Vs),1,'a constraint term',C)))
].
gen_insert_2( [], _) --> [].
gen_insert_2( [F/A|Keys], Module) -->
{
length( Args, A),
C =.. [F|Args],
flat( 'F'( n(F/A,1), a(Args), h(Self)), Closure)
},
[(
insert_constraint( C, Self) :- !,
chr:insert_constraint_internal( Vs, Self, Module:Closure, F, Args),
chr:dbg( insert(C#Self)),
'F'(n(attach,F/A), Vs, Self)
)],
gen_insert_2( Keys, Module).
gen_insert_3( [], _) --> [].
gen_insert_3( [F/A|Keys], Module) -->
{
length( Args, A),
C =.. [F|Args],
flat( 'F'( n(F/A,1), a(Args), h(Self)), Closure)
},
[(
insert_constraint( C, Self, Term) :- !,
chr:insert_constraint_internal( Vs, Self, Term, Module:Closure, F, Args),
chr:dbg( insert(C#Self)),
'F'(n(attach,F/A), Vs, Self)
)],
gen_insert_3( Keys, Module).
% -------------------------------------------------------------------------
comp_constraints( [], _, _) --> [].
comp_constraints( [C|Cs], Handler, Module) -->
comp_constraint( C, Handler, Module),
comp_constraints( Cs, Handler, Module).
comp_constraint( C, Handler, Module) -->
{
functor( C, F, A),
print_message( informational, compiler(start(F,A))),
getval( rules, Active),
findall( rule(H,Ps,G,B,n(Handler,Na,F/A,N,Pos),Hs,Prag),
(
rule(Handler,N,Na,Hs,G,B,Prag),
active_rule( Active, Na),
choose( Hs, H, Ps, 1, Pos),
arg( 1, H, C)
), Rs),
sort_rules( Rs, Rsss),
C =.. [_|Args],
flat( 'F'( n(F/A,1), a(Args), h(Self)), Closure),
Alloc = Ad:Closure/Self/Args,
( getval( debug_compile, on) ->
Ad = early,
EntryPoint = % byrd box
(
chr:allocate_constraint( Module:Closure, Self, F, Args),
( chr:dbg( call(Self)), Closure
; chr:dbg( fail(Self)), !, fail
),
( chr:dbg( exit(Self))
; chr:dbg( redo(Self)), fail
)
)
;
EntryPoint = Closure
)
},
[(
C :-
EntryPoint % user entry point
)],
{ comp_rules_first( Rsss, M, Alloc, Module, RL, RLT) },
%
% Code for rules generated, pragmas seen
%
already_in_store( Handler, C, F, A),
already_in_heads( Handler, C, F, A),
splice( RL, RLT), % insert rule code
{
(var(Ad) -> % compile time
Allocate =
( var(Self) -> % runtime
chr:insert_constraint_internal( LinkVars, Self, Module:Closure, F, Args)
;
chr:activate_constraint( LinkVars, Self, _)
)
;
Allocate = chr:activate_constraint( LinkVars, Self, _)
)
},
[( 'F'( n(F/A,M), a(Args), h(Self)) :-
Allocate,
chr:dbg( insert(C#Self)),
'F'(n(attach,F/A), LinkVars, Self)
)].
comp_rules_first( Rs, M, Alloc, Module, L, Lt) :-
( getval(dead_code_elimination,on),
dead_code_elimination( Rs, Rse) ->
phrase( comp_rules( Rse, 1,M, Alloc, Module), L, Lt)
;
phrase( comp_rules( Rs, 1,M, Alloc, Module), L, Lt)
).
%
% Assumes knowledge about DCG expansion
%
splice( RL, LT, RL, LT).
alloc( X:_, _, _, _, _, true) :- nonvar( X), !.
alloc( done:Closure/Self/Args, Self, Args, F/_, Module, Code) :-
Code = ( var(Self) ->
chr:allocate_constraint( Module:Closure, Self, F, Args)
;
true
).
choose( [X|Xs], X, Xs, N0,N0).
choose( [X|Xs], Y, [X|Xt], N0,N2) :-
N1 is N0+1,
choose( Xs, Y, Xt, N1,N2).
active_rule( Active, _) :- var( Active), !.
active_rule( (A,B), N) :- !,
( active_rule( A, N) ->
true
;
active_rule( B, N)
).
active_rule( R, N) :-
variant( R, N).
%
% Heuristic ordering compatible with the Eclipse version:
%
% single headed < double headed
% propagation last
% kill < revive
%
% Within a single rule we put clauses for active k(H,_) first
%
sort_rules( Rs, Rss) :-
getval( rule_ordering, O),
augment( Rs, O, Rsa),
keysort( Rsa, Rsas), % stable sort
strip( Rsas, Rss).
augment( [], _, []).
augment( [R|Rs], O, [K-R|Rsa]) :-
weight( O, R, K),
augment( Rs, O, Rsa).
strip( [], []).
strip( [_-R|Rs], [R|Rss]) :-
strip( Rs, Rss).
weight( canonical, rule(H,_,_,_,n(_,_,_,N,_),_,_), w(N,Nh)) :-
functor( H, Nh, _). % k < r
weight( heuristic, rule(H,Ps,_,_,_,_,_), w(Lw,Pw,Nh)) :-
length( Ps, Lw),
functor( H, Nh, _),
( member( k(_,_), Ps) -> Pw=1 ; Pw=2 ).
%
% k(_) rules after the current one that are variants
% up to and including the guard can be dropped (cut semantics)
%
% In the presence of already_in_heads we give up to
% get the continuation(s) right.
%
% constraints e/4.
%
% write @ e(A,B,C,D) ==> write(e(A,B,C,D)),nl.
% id1 @ e(A,B,C,D) <=> write(id1),nl, e(B,A,C,D).
% id2 @ e(A,B,C,D) <=> write(id2),nl, e(C,D,A,B).
%
%| ?- e(1,2,a,b).
%
% The check for a passive/1 pragma is to get some code
% generated after all for the following rule:
%
% (X leq Y)#Id , Y leq X <=> X=Y pragma passive(Id).
%
dead_code_elimination( Rs, Rse) :-
getval( already_in_heads, on),
!,
Rse = Rs.
dead_code_elimination( Rs, Rse) :-
member( rule(_,_,_,_,_,_,Pragma), Rs),
( member( already_in_heads, Pragma) -> true
; member( already_in_head(_), Pragma) -> true
; member( passive(_), Pragma) -> true
),
!,
Rse = Rs.
dead_code_elimination( Rs, Rse) :-
reverse( Rs, Rr),
dc_loop( Rr, Rkr),
reverse( Rkr, Rse).
dc_loop( [], []).
dc_loop( [R|Rs], Res) :-
R = rule(Active,Ps,G,_,n(_,Rnam,_,_,Hn),_,_),
( Active=k(_,_),
member( rule(Ap,Pp,Gp,_,_,_,_), Rs),
variant( Active/Ps/G, Ap/Pp/Gp) ->
print_message( informational, compiler(dce(Hn,Rnam))),
Res = Rest
;
Res = [R|Rest]
),
dc_loop( Rs, Rest).
%
% Currently for all constraints. Could be specific.
%
already_in_store( Handler, C, F, A) -->
{
getval( already_in_store, on),
!,
C =.. [_|Args],
same_length( Args, Actual),
same_length( Args, Actual2),
vars( C, V0),
key2att( F/A, Att, _)
},
[( 'F'( n(F/A,1), a(Actual), h(T1)) :-
chr:inline_matching( Args, Actual),
chr:via( V0, Via),
nd_init_iteration( Via, Handler, F/A, Att, T2),
chr:load_args( T2, active, Actual2),
chr:inline_matching( V0-Args, V0-Actual2),
!,
chr:dbg( apply(Handler,already_in_store,2,[r(C,T2),k(C,T1)],true,true))
)].
already_in_store( _, _, _, _) --> [].
comp_rules( [], N0,N0, _, _) --> [].
comp_rules( [rule(H,Ps,G,B,Name,Hs,Prag)|Rs], N0,N2, Alloc, Module) -->
( {
N1 = N0,
arg( 2, H, Tid),
member( X, Prag),
X == passive(Tid)
} ->
[]
;
{split( Ps, Kill, Revive)},
comp_rule( H, Kill, Revive, G,B, N0,N1, Name, Hs, Alloc, Module, Prag)
),
comp_rules( Rs, N1,N2, Alloc, Module).
split( [], [], []).
split( [P|Ps], K, R) :-
( P=k(H,T) -> K=[H#T|Ks], R=Rs
; P=r(H,T) -> R=[H#T|Rs], K=Ks
),
split( Ps, Ks, Rs).
%
% Current constraint of type k(_,_), i.e. to be removed (easy, not yet allocated)
%
% H ?- Exists p1,p2,p3, G | kill(some pi) B
%
comp_rule( k(H,Tid), Kill, Revive, G, Body, N0,N1, n(Hi,Ni,F/A,_,Hx), Hs, _, Module, Pragma) -->
{
H =.. [_|Args],
same_length( Args, Actual),
vars( H, V0),
ndmpc( Kill, Hi, MatchKill, Pragma, V0,V1, [],Ks),
ndmpc( Revive, Hi, MatchRevive, Pragma, V1,V2, Ks,_),
aih_expose( active(H,Tid), Hi, N0,N1, Kill, Body, Pragma, Continuation, FinalBody),
check_guard( V2, G, GuardCode)
},
[( 'F'( n(F/A,N0), a(Actual), h(Tid)) :-
chr:inline_matching( Args, Actual),
MatchKill,
MatchRevive,
chr:dbg( try(Hi,Ni,Hx,Hs,G,Body)),
GuardCode,
!,
chr:dbg( apply(Hi,Ni,Hx,Hs,G,Body)),
'__remove_some'( Ks),
(var(Tid)->true;'__remove_some'( [H#Tid])),
FinalBody
)],
( {N0=:=N1} -> []
;
{
Continuation = Module:Cgoal,
flat( 'F'( n(F/A,N1), a(Actual), h(Tid)), Cgoal)
},
[('F'( n(F/A,N0), a(Actual), h(Tid)) :- Continuation )]
).
comp_rule( r(H,Self), [], [], G, Body, N0,N1, n(Hi,Ni,F/A,Ri,Hx), Hs, Alloc, Module, _Prag) --> !,
{
N1 is N0+1,
H =.. [_|Args],
same_length( Args, Actual),
vars( H, V0),
revive( 'F'( n(F/A,N1), a(Actual), h(Self)),
Body, Proceed, H#Self, Self),
alloc( Alloc, Self, Actual, F/A, Module, Allocate),
check_guard( V0, G, GuardCode)
},
[
( 'F'( n(F/A,N0), a(Actual), h(Self)) :-
chr:inline_matching( Args, Actual),
Allocate,
Tuple = t(Ri,Self),
chr:novel_production( Self, Tuple),
chr:dbg( try(Hi,Ni,Hx,Hs,G,Body)),
GuardCode,
!,
chr:dbg( apply(Hi,Ni,Hx,Hs,G,Body)),
chr:extend_history( Self, Tuple),
Proceed
),
( 'F'( n(F/A,N0), a(Actual), h(Self)) :-
Allocate,
'F'( n(F/A,N1), a(Actual), h(Self))
)
].
comp_rule( r(H,Tid), [], [R|Rs], G, B, N0,N1, Name, Hs, Alloc, Module, Pragma) --> !,
{
N1 is N0+1,
Name = n(_,_,F/A,_,_),
H =.. [_|Args],
same_length( Args, Actual),
vars( H, V0),
matching:code( Args, Actual, Code)
},
fwd_first( Code, Actual, R, N0, V0, Name, Alloc, Module, Pragma),
fwd_rest( Rs, R, H#Tid, N0, 0, V0, G, B, Name, Hs,
propagation, [s(n(F/A,N1),a(Args))], Pragma).
%
comp_rule( r(H,Tid), [K|Ks], Rs, G, B, N0,N1, Name, Hs, Alloc, Module, Pragma) -->
{
N1 is N0+1,
Name = n(_,_,F/A,_,_),
H =.. [_|Args],
same_length( Args, Actual),
vars( H, V0),
matching:code( Args, Actual, Code)
},
fwd_first( Code, Actual, K, N0, V0, Name, Alloc, Module, Pragma),
( {getval( simpagation_scheme, single)} ->
%
% Single forward loop for an arbitrary partner to
% be killed,
% remaining partners are found nondet. inside the
% loop.
%
fwd_rest( [], K, H#Tid, N0, 0, V0, G, B, Name, Hs,
simpagation(Ks,Rs), [s(n(F/A,N1),a(Args))], Pragma)
;
%
% One forward loop for every partner to be killed,
% remaining partners are found nondet. inside the
% loops.
%
fwd_rest( Ks, K, H#Tid, N0, 0, V0, G, B, Name, Hs,
simpagation([],Rs), [s(n(F/A,N1),a(Args))], Pragma)
).
fwd_first( HeadMatch, Actual, Next#_, N, V0, n(Handler,_,F/A,_,_), Alloc, Module, Pragma) -->
{
N1 is N+1,
functor( Next, Fn, An),
vars( Next, Vn),
compute_via( V0, Vn, Vias, Pragma),
alloc( Alloc, Self, Actual, F/A, Module, Allocate),
key2att( Fn/An, Att, _)
},
[
('F'( n(F/A,N), a(Actual), h(Self)) :-
HeadMatch,
chr:via( Vias, Via),
init_iteration( Via, Handler, Fn/An, Att, Ds),
!,
Allocate,
'F'( n(F/A,N,0), state(Ds), h(Self), c([]), k([]), g(V0))),
('F'( n(F/A,N), a(Actual), h(Self)) :-
Allocate,
'F'( n(F/A,N1), a(Actual), h(Self)))
].
%
% The issure here is to let the body see the actual constraint
% when executing. The continuation inserts the constraint.
% Thus, if we run the body ahead of the continuation, we explicitly
% insert the constraint, run the body, remove the constraint again
% and run the continuation (which inserts the constraint again).
%
revive( Continuation, Body, Code, _, _) :-
getval( revive_scheme, old),
!,
Code = ( Continuation, Body ).
revive( Continuation, Body, Code, Term#_, Self) :-
( bening( Body) -> % optimization
Code = (Body, Continuation)
;
functor( Term, F, A),
Code = (
chr:activate_constraint( LinkVars, Self, Generation),
'F'(n(attach,F/A), LinkVars, Self),
Body,
chr:constraint_generation( Self, State, Gen),
( State == active, Gen == Generation ->
chr:change_state( Self, inactive),
Continuation
;
true
))
).
fwd_rest( [], Q#Tid, Active, N,M, V0, Guard, Body, n(Hi,Ni,F/A,Ri,Hx), Hs,
propagation, Stack, _Pragma) --> !,
{
Myname = n(F/A,N,M),
Active = _#Self,
length( Cs, M),
length( Ks, M),
vars( Q, Vq),
ord_union( V0, Vq, V1),
nextsol( Stack, M, Self, Cs, Ks, NextSol),
tids( Ks, KsT),
revive( 'F'(Myname,state(Dss),h(Self),c(Cs),k(KsT),g(V0)),
Body, Proceed, Active, Self),
tuple( Hs, Ri, Tv, Tuple, Checks),
decompose( Q, _, _, Args, Actual),
alldiffs( Ks, Tid, Diffs),
check_guard( V1, Guard, GuardCode)
},
[
( 'F'( Myname, state(St), h(Self), c(Cs), k(KsT), g(V0)) :-
chr:iter_last( St),
NextSol),
( 'F'( Myname, state(St), h(Self), c(Cs), k(KsT), g(V0)) :-
chr:iter_next( St, Tid, Dss),
( chr:load_args( Tid, active, Actual),
Diffs,
chr:inline_matching( V0-Args, V0-Actual),
chr:(Tv=Tuple),
Checks,
chr:dbg( try(Hi,Ni,Hx,Hs,Guard,Body)),
GuardCode ->
chr:dbg( apply(Hi,Ni,Hx,Hs,Guard,Body)),
chr:extend_history( Self, Tv),
Proceed
;
'F'( Myname, state(Dss), h(Self), c(Cs), k(KsT), g(V0))
))
].
%
% Kill early to let the continuation (new scheme) see the effect.
%
fwd_rest( [], Q#Tid, Active, N,M, V0, Guard, Body, Name, Hs,
simpagation(Kss,Rs), Stack, Pragma) -->
{
Name = n(Hi,Ni,F/A,_,Hx),
Myname = n(F/A,N,M),
Active = _#Self,
length( Cs, M),
length( Ks, M),
vars( Q, Vq),
ord_union( V0, Vq, V1),
nextsol( Stack, M, Self, Cs, Ks, NextSol),
M1 is M+1,
append( _, [First,_], [s(Myname,g(V0),k([Q#Tid|Ks]))|Stack]),
nextsol( [First], M1, Self, [Dss|Cs], [Q#Tid|Ks], RevCon),
%
ndmpc( Kss, Hi, MatchCode1, Pragma, V1,V2, [Q#Tid|Ks],K1),
ndmpc( Rs, Hi, MatchCode2, Pragma, V2,V3, K1, _),
append( [Q#Tid|Ks], Kss, Allkills),
decompose( Q, _, _, Args, Actual),
alldiffs( Ks, Tid, Diffs),
aih_expose( passive, Hi, 0,0, [Q#Tid|Kss], Body, Pragma, _, RevBody),
revive( RevCon, RevBody, Proceed, Active, Self),
check_guard( V3, Guard, GuardCode),
tids( Ks, KsT)
},
[
( 'F'( Myname, state(St), h(Self), c(Cs), k(KsT), g(V0)) :-
chr:iter_last( St),
NextSol ),
( 'F'( Myname, state(St), h(Self), c(Cs), k(KsT), g(V0)) :-
chr:iter_next( St, Tid, Dss),
( chr:load_args( Tid, active, Actual),
Diffs,
chr:inline_matching( V0-Args, V0-Actual),
MatchCode1,
MatchCode2,
chr:dbg( try(Hi,Ni,Hx,Hs,Guard,Body)),
GuardCode ->
chr:dbg( apply(Hi,Ni,Hx,Hs,Guard,Body)),
'__remove_some'( Allkills),
Proceed
;
'F'( Myname, state(Dss), h(Self), c(Cs), k(KsT), g(V0))
))
].
fwd_rest( [P#TidP|Ps], Q#Tid, Active, N,M, V0, G, B, Name, Hs,
RuleType, Stack, Pragma) -->
{
Myname = n(F/A,N,M),
Name = n(Handler,_,F/A,_,_),
L is M+1,
length( Cs, M),
length( Ks, M),
vars( Q, Vq),
ord_union( V0, Vq, V1),
vars( P, Vp),
compute_via( V1, Vp, Vias, Pragma),
nextsol( Stack, M, H, Cs, Ks, NextSol),
decompose( Q, _, _, Args, Actual),
decompose( P, Pf, Pa, _, _),
alldiffs( Ks, Tid, Diffs),
key2att( Pf/Pa, Att, _),
tids( Ks, KsT)
},
[
( 'F'( Myname, state(St), h(H), c(Cs), k(KsT), g(V0)) :-
chr:iter_last( St),
NextSol ),
( 'F'( Myname, state(St), h(H), c(Cs), k(KsT), g(V0)) :-
chr:iter_next( St, Tid, Dss),
( chr:load_args( Tid, active, Actual),
Diffs,
chr:inline_matching( V0-Args, V0-Actual),
chr:via( Vias, Via),
init_iteration( Via, Handler, Pf/Pa, Att, Ds) ->
'F'( n(F/A,N,L), state(Ds), h(H), c([Dss|Cs]), k([Tid|KsT]), g(V1))
;
'F'( Myname, state(Dss), h(H), c(Cs), k(KsT), g(V0))
))
],
fwd_rest( Ps, P#TidP, Active, N,L, V1, G, B, Name, Hs,
RuleType, [s(Myname,g(V0),k([P#Tid|Ks]))|Stack], Pragma).
nextsol( [s(Name,a(Args))|_], _, H, _, _, 'F'(Name,a(Args),h(H))).
nextsol( [s(Name,g(V),k(Km))|_], L, H, Css, Kss, 'F'(Name,state(C),h(H),c(Cs),k(Ks),g(V))) :-
Name = n(_,_,M),
N is L-M,
skip( N, Css, C, Cs),
tids( Km, [_|Ks]),
( Km=Kss -> true ; true ).
skip( N, [X|Xs], X, Xs) :- N =< 1, !.
skip( N, [_|Xs], X, Xt) :-
M is N-1,
skip( M, Xs, X, Xt).
tuple( Heads, Ri, Tv, Tuple, Checks) :-
tuple( Heads, Tv, Checks, Tids),
Tuple =.. [t,Ri|Tids].
tuple( [], _, true, []).
tuple( [H|Hs], Tv, (chr:novel_production(C,Tv),Co), [C|Cs]) :-
arg( 2, H, C),
tuple( Hs, Tv, Co, Cs).
vars( Term, Set) :-
term_variables( Term, Vs),
list_to_ord_set( Vs, Set).
%
%
% Trick:
%
% Instead of match( Pattern, Datum) we say
% match( Gv-Pattern, Gv-Datum)
%
% where Gv are the global variables from
% matches further to the left of the current head.
%
ndmpc( [], _, true, _, S0,S0, C0,C0).
ndmpc( [H#Tid|Ps], Handler, Mc, Pragma, S0,S2, C0,C2) :-
vars( H, Hv),
compute_via( S0, Hv, Vias, Pragma),
ord_union( S0, Hv, S1),
decompose( H, F, A, Args, Actual),
alldiffs( C0, Tid, Diffs),
key2att( F/A, Att, _),
Mc = (
chr:via( Vias, Via),
nd_init_iteration( Via, Handler, F/A, Att, Tid),
chr:load_args( Tid, active, Actual),
Diffs,
chr:inline_matching( S0-Args, S0-Actual),
Mcc
),
ndmpc( Ps, Handler, Mcc, Pragma, S1,S2, [H#Tid|C0],C2).
compute_via( Sofar, Local, Vias, Pragma) :-
ord_intersection( Sofar, Local, Common),
compute_via_( Pragma, Sofar, Local, ViaPragma),
list_to_ord_set( ViaPragma, Vp),
ord_union( Common, Vp, Vias).
compute_via_( [], _, _, []).
compute_via_( [P|Ps], Sofar, Local, Vias) :-
( P = sharing(A,B) ->
( ord_member( A, Sofar),
ord_member( B, Local) ->
Vias = [A|Rest]
; ord_member( B, Sofar),
ord_member( A, Local) ->
Vias = [B|Rest]
;
Vias = Rest
)
;
Vias = Rest
),
compute_via_( Ps, Sofar, Local, Rest).
%
% This could be more precise to consider only
% pairs of heads that unify, but \==/2 is cheap and our
% chains are short.
%
alldiffs( [], _, true).
alldiffs( [_#T|Ts], S, (S\==T,Diffs)) :-
alldiffs( Ts, S, Diffs).
decompose( Term, F, A, Args, Actual) :-
functor( Term, F, A),
Term =.. [F|Args],
same_length( Args, Actual).
tids( [], []).
tids( [_#Tid|Ts], [Tid|Tids]) :-
tids( Ts, Tids).
% ------------------------ already_in_heads support ---------------------
%
% A killed, exposed constraint can be passive in the exposing rule
% or active. When it is passive, the state of the constraint is
% changed to active. Otherwise the associated continuation is called.
%
already_in_heads( Handler, C, F, A) -->
{
aih_functor( Handler, F, A),
!,
C =.. [_|Args]
},
[( 'F'( n(F/A,1), a(Args), h(T1)) :-
chr:is_exposed( C, T2, Continuation),
!,
chr:dbg( apply(Handler,already_in_heads,2,[r(C,T2),k(C,T1)],true,true)),
( Continuation==true -> % passive
chr:dbg( insert(C#T2)),
chr:activate_constraint( LinkVars, T2, keep),
'F'(n(attach,F/A), LinkVars, T2)
;
call( Continuation)
)
)].
already_in_heads( _, _, _, _) --> [].
%
% If aih applies, we may need a continuation (N1=N0+1),
% or not, but it is computed by the caller.
%
aih_expose( Type, Hi, N0,N1, Kill, Body, Pragma, Continuation, FinalBody) :-
( getval( already_in_heads, on) ->
aih_expose( Type, Hi, N0,N1, Kill, Continuation, Handle, ExposeCall)
; member( already_in_heads, Pragma) ->
aih_expose( Type, Hi, N0,N1, Kill, Continuation, Handle, ExposeCall)
; Type=active(H,Tid),
aih_collect( Pragma, [H#Tid|Kill], Expose),
Expose=[_#I|Es] -> % at least one
( I==Tid ->
aih_expose( Type, Hi, N0,N1, Es, Continuation, Handle, ExposeCall)
;
aih_expose( passive, Hi, N0,N1, Expose, Continuation, Handle, ExposeCall)
)
; Type=passive,
aih_collect( Pragma, Kill, Expose),
Expose = [_|_] -> % at least one
aih_expose( Type, Hi, N0,N1, Expose, Continuation, Handle, ExposeCall)
),
\+ bening( Body), % optimization
!,
FinalBody = ( ExposeCall, Body, chr:de_expose( Handle) ).
aih_expose( _, _, N0,N0, _, Body, _, _, Body).
aih_expose( passive, Hi, N0,N0, K, _, Handle, chr:expose_passive(Handle,K)) :-
aih_record( K, Hi).
aih_expose( active(H,Tid), Hi, N0,N1, K, C, Handle, chr:expose_active(Handle,H,Tid,K,C)) :-
N1 is N0+1,
aih_record( [H#Tid|K], Hi).
aih_collect( [], _, []).
aih_collect( [P|Ps], Kills, Expose) :-
( P=already_in_head(Id),
member( K, Kills),
K = _#I,
I == Id ->
Expose = [K|Exps],
aih_collect( Ps, Kills, Exps)
;
aih_collect( Ps, Kills, Expose)
).
aih_record( Heads, Handler) :-
member( Head#_, Heads),
functor( Head, F, A),
( aih_functor( Handler, F, A) ->
true
;
assert( aih_functor(Handler,F,A))
),
fail.
aih_record( _, _).
% -------------------------- guard evaluation -------------------------
check_guard( Global, Guard, Code) :-
split_guard( Guard, Ask, Tell),
( Ask==true ->
Code = Tell
;
Code = ( Wrap, Tell ),
wrap_guard( Ask, Global, Wrap)
).
split_guard( (Ask & Tell), A, T) ?- !, Ask=A, Tell=T.
split_guard( Guard, true, Guard) :- getval( check_guard_bindings, off), !.
split_guard( Guard, Guard, true).
%
% Conservative guard analysis to avoid lock/unlock/on_exception
% for simple tests.
%
wrap_guard( Goal, Global, Expansion) :-
( bening( Goal) -> % no need to lock
( simple_guard( Goal, Term) ->
term_variables( Term, Vars),
ensure_ground( Vars, Goal, Expansion)
;
Expansion = on_exception( instantiation_error(_,_),Goal,fail)
)
;
vars( Goal, Va),
ord_intersection( Global, Va, Lock),
Expansion =
(
chr:lock_some( Lock),
on_exception( instantiation_error(_,_),Goal,fail),
chr:unlock_some( Lock)
)
).
%
% Goal is guaranteed not to bind any variable
% Careful: ground(Body) may still
% call a constraint
%
bening( Goal) :- var( Goal), !, fail.
bening( _:Goal) :- bening( Goal). % ignore module prefix
bening( true).
bening( fail).
bening( \+ G) :- bening( G). % don't want G to trigger anything
bening( (A,B)) :-
bening( A),
bening( B).
bening( (A;B)) :-
bening( A),
bening( B).
bening( (A->B)) :-
bening( A),
bening( B).
%
bening( G) :- type_check( G).
bening( G) :- arith_compare( G).
bening( G) :- term_compare( G).
type_check( var(_)).
type_check( nonvar(_)).
type_check( integer(_)).
type_check( float(_)).
type_check( number(_)).
type_check( atom(_)).
type_check( atomic(_)).
type_check( simple(_)).
type_check( compound(_)).
type_check( callable(_)).
type_check( ground(_)).
arith_compare( _ =:= _).
arith_compare( _ =\= _).
arith_compare( _ < _).
arith_compare( _ > _).
arith_compare( _ =< _).
arith_compare( _ >= _).
term_compare( _ == _).
term_compare( _ \== _).
term_compare( _ @< _).
term_compare( _ @=< _).
term_compare( _ @> _).
term_compare( _ @>= _).
%
% avoid on_exception/3 if trivial
%
simple_guard( G, _) :- var( G), !, fail.
simple_guard( Goal, []) :- ground( Goal), !. % incl. true,fail,...
simple_guard( (A,B), Ta+Tb) :-
simple_guard( A, Ta),
simple_guard( B, Tb).
%
simple_guard( G, []) :- type_check( G).
simple_guard( G, []) :- term_compare( G).
simple_guard( G, G) :- arith_compare( G).
ensure_ground( [], Guard, Guard).
ensure_ground( [V|Vs], Guard, (ground(V),Exp)) :-
ensure_ground( Vs, Guard, Exp).
% --------------------- flatten --------------------
flat( (H:-B), (Hf:-Bf)) :- !,
flat_g( H, Hf),
flat_body( B, Bf).
flat( (H-->B), (Hf-->Bf)) :- !,
flat_g( H, Hf),
flat_body( B, Bf).
flat( Fact, FFact) :-
flat_g( Fact, FFact).
%
% Here we will reorder and flatten the wrapped arguments.
% Considerations: 1st argument indexing, register motion, ...
%
% The magic functor in the templates is 'F'/N
%
flat_g( Goal, Flat) :-
nonvar( Goal),
Goal =.. ['F',Nm|Args],
Nm =.. [n|NmL],
concat_name( NmL, Name),
!,
( getval( flatten, on) ->
flat_args( Args, FlatArgs, [])
;
FlatArgs = Args
),
Flat =.. [Name|FlatArgs].
flat_g( Goal, Goal).
flat_args( []) --> [].
flat_args( [A|As]) -->
flat_arg( A),
flat_args( As).
flat_arg( A) --> {var(A)}, !, [A].
flat_arg( state(S)) --> !, [S].
flat_arg( h(H)) --> !, [H].
flat_arg( a(L)) --> !, flat_list( L).
flat_arg( g(L)) --> !, flat_list( L).
flat_arg( c(L)) --> !, flat_list( L).
flat_arg( k(L)) --> !, flat_list( L).
flat_arg( A) --> [A].
flat_list( []) --> [].
flat_list( [X|Xs]) --> [X], flat_list( Xs).
flat_body( (true,B), Bf) ?- !, flat_body( B, Bf).
flat_body( (B,true), Bf) ?- !, flat_body( B, Bf).
flat_body( (A,B), Res) ?- !,
flat_body( A, Af),
flat_body( B, Bf),
( Af==true -> Res=Bf
; Bf==true -> Res=Af
; Res=(Af,Bf)
).
flat_body( (A->B), Res) ?- !,
Res=(Af->Bf),
flat_body( A, Af),
flat_body( B, Bf).
flat_body( (A;B), Res) ?- !,
Res=(Af;Bf),
flat_body( A, Af),
flat_body( B, Bf).
%
flat_body( B, Bf) :- flat_g( B, Bf).
% --------------------------- parsing ---------------------------
parse_rule( Term) :-
handler( Handler),
incval( rulenum, N),
proper_rule( Term, Handler, N, Name, Heads, Guard, Body, Pragma),
assert( rule( Handler, N, Name, Heads, Guard, Body, Pragma)).
proper_rule( Term, Handler, N, Name, Heads, Guard, Body, Pragma) :-
is_rule( Term, Name, Heads, Guard, Body, Pragma),
!,
proper_name( Name, Handler, N),
proper_heads( Heads, Name, Handler),
proper_pragma( Pragma, Name).
proper_rule( Term, _, N, _, _, _, _, _) :-
raise_exception( compiler(syntax(Term,N))).
% --------------------------- syntax -----------------------------
%
% fail means syntax error
%
is_rule( (Name @ Rule), Name, Heads, Guard, Body, Pragma) :- !,
nonvar( Rule),
is_rule( Rule, Heads, Guard, Body, Pragma).
is_rule( Rule, _, Heads, Guard, Body, Pragma) :-
is_rule( Rule, Heads, Guard, Body, Pragma).
is_rule( (Rule pragma Pragma), Heads, Guard, Body, Prag) :- !,
nonvar( Rule),
is_rule( Rule, Heads, Guard, Body),
is_pragma( Pragma, Prag, []).
is_rule( Rule, Heads, Guard, Body, []) :- % no pragma
is_rule( Rule, Heads, Guard, Body).
is_rule( (Head <=> Rhs), Heads, Guard, Body) :-
is_simpagation( Head, Heads, []),
is_rhs( Rhs, Guard, Body).
is_rule( (Head ==> Rhs), Heads, Guard, Body) :-
is_propagation( Head, Heads, []),
is_rhs( Rhs, Guard, Body).
is_simpagation( Kill) --> {var(Kill)}, !, is_head( Kill, k).
is_simpagation( (Keep \ Kill)) --> !,
is_head( Keep, r),
is_head( Kill, k).
is_simpagation( Kill) -->
is_head( Kill, k).
is_propagation( Head) --> {var(Head)}, !, is_head( Head, r).
is_propagation( (_ \ _)) --> !, {fail}.
is_propagation( Head) --> is_head( Head, r).
is_head( Head, Type) --> {var(Head)}, !, is_head( Head, Type, _).
is_head( (A,B), Type) --> !, is_head( A, Type), is_head( B,Type).
is_head( (Head # Id), Type) --> !, is_head( Head, Type, Id).
is_head( Head, Type) --> is_head( Head, Type, _).
is_head( H, Type, Id) -->
{
Term =.. [Type,H,Id]
},
[ Term ].
is_pragma( P) --> {var(P)}, !, [ P ].
is_pragma( (P,Ps)) --> !,
is_pragma( P),
is_pragma( Ps).
is_pragma( P) --> [ P ].
is_rhs( Body, _, _) :- var( Body), !, fail.
is_rhs( (Guard | Body), Guard, Body) :- !.
is_rhs( Body, true, Body).
% ---------------------- statical semantics ----------------------
proper_name( Name, _, N) :- var( Name), !, Name = rule(N).
proper_name( _, _, _).
proper_heads( Heads, Rname, Handler) :-
proper_heads_( Heads, Rname, Handler),
proper_ids( Heads, Rname, Hts),
sort( Hts, Htss), % var < anything
( Htss=[] -> true
; Htss=[V], var(V) -> true
; Htss=[T|_], nonvar(T) -> true
;
raise_exception( compiler(wild_head(Rname)))
).
proper_heads_( [], _, _).
proper_heads_( [H|Hs], Rname, Handler) :-
proper_head( H, Rname, Handler),
proper_heads_( Hs, Rname, Handler).
proper_head( Head, Rname, Handler) :-
arg( 1, Head, Term),
( var( Term) ->
true
; functor( Term, F, A),
constraint( Handler, F/A) ->
true
;
functor( Term, F, A),
findall( C, constraint(Handler,C), L),
raise_exception( compiler(undefined_constraint(F,A,Rname,L)))
).
proper_ids( Heads, _, Hs) :-
proper_ids_( Heads, Tids, Hs),
list_to_ord_set( Tids, Ts),
same_length( Tids, Ts),
vars( Hs, Vhs),
ord_intersection( Ts, Vhs, []),
!.
proper_ids( _, Rname, _) :-
raise_exception( compiler(bad_ids(Rname))).
proper_ids_( [], [], []).
proper_ids_( [X|Xs], [T|Ts], [H|Hs]) :-
arg( 1, X, H),
arg( 2, X, T),
var( T),
proper_ids_( Xs, Ts, Hs).
proper_pragma( [], _).
proper_pragma( [P|Ps], Rname) :-
( var( P) ->
raise_exception( compiler(pragma(P,Rname)))
;
proper_pragma( Ps, Rname)
).
% --------------------------- development ---------------------
cc( F/A) ?- !, integer(A), functor( C, F, A), cc( C).
cc( C) :-
comp_constraint( C, _, user, Cls, []),
member( Cl, Cls), % nl,nl,portray_clause(Cl),
macro_exp( Cl, Cll),
expansion( [Cll], [Cle|_], []),
portray_clause( Cle),
fail.
%
% No need to do this. Just for the looks.
%
macro_exp( (H0:-B), (H0:-B1)) :-
prolog:get_module(H0, H, Module),
nonvar(H),
functor(H, F, _),
atom(F),
prolog:exp_vars(H, HV, Module, assert),
prolog:wellformed_body(B, []/*undef layout*/, +, B1, _, HV, Module, Module, assert),
!.
macro_exp( Clause, Clause).
end_of_file.