%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % 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(library('chr/getval')). :- ['matching']. :- use_module( library('chr/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.