3671 lines
107 KiB
Plaintext
3671 lines
107 KiB
Plaintext
|
/* $Id$
|
||
|
|
|
||
|
|
Part of CHR (Constraint Handling Rules)
|
||
|
|
|
||
|
|
Author: Tom Schrijvers
|
||
|
|
E-mail: Tom.Schrijvers@cs.kuleuven.be
|
||
|
|
WWW: http://www.swi-prolog.org
|
||
|
|
Copyright (C): 2003-2004, K.U. Leuven
|
||
|
|
|
||
|
|
This program is free software; you can redistribute it and/or
|
||
|
|
modify it under the terms of the GNU General Public License
|
||
|
|
as published by the Free Software Foundation; either version 2
|
||
|
|
of the License, or (at your option) any later version.
|
||
|
|
|
||
|
|
This program is distributed in the hope that it will be useful,
|
||
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
|
|
GNU General Public License for more details.
|
||
|
|
|
||
|
|
You should have received a copy of the GNU Lesser General Public
|
||
|
|
License along with this library; if not, write to the Free Software
|
||
|
|
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||
|
|
|
||
|
|
As a special exception, if you link this library with other files,
|
||
|
|
compiled with a Free Software compiler, to produce an executable, this
|
||
|
|
library does not by itself cause the resulting executable to be covered
|
||
|
|
by the GNU General Public License. This exception does not however
|
||
|
|
invalidate any other reasons why the executable file might be covered by
|
||
|
|
the GNU General Public License.
|
||
|
|
*/
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
%%
|
||
|
|
%% ____ _ _ ____ ____ _ _
|
||
|
|
%% / ___| | | | _ \ / ___|___ _ __ ___ _ __ (_) | ___ _ __
|
||
|
|
%% | | | |_| | |_) | | | / _ \| '_ ` _ \| '_ \| | |/ _ \ '__|
|
||
|
|
%% | |___| _ | _ < | |__| (_) | | | | | | |_) | | | __/ |
|
||
|
|
%% \____|_| |_|_| \_\ \____\___/|_| |_| |_| .__/|_|_|\___|_|
|
||
|
|
%% |_|
|
||
|
|
%%
|
||
|
|
%% hProlog CHR compiler:
|
||
|
|
%%
|
||
|
|
%% * by Tom Schrijvers, K.U. Leuven, Tom.Schrijvers@cs.kuleuven.be
|
||
|
|
%%
|
||
|
|
%% * based on the SICStus CHR compilation by Christian Holzbaur
|
||
|
|
%%
|
||
|
|
%% First working version: 6 June 2003
|
||
|
|
%%
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
%%
|
||
|
|
%% URGENTLY TODO
|
||
|
|
%%
|
||
|
|
%% * fine-tune automatic selection of constraint stores
|
||
|
|
%%
|
||
|
|
%% To Do
|
||
|
|
%%
|
||
|
|
%% * further specialize runtime predicates for special cases where
|
||
|
|
%% - none of the constraints contain any indexing variables, ...
|
||
|
|
%% - just one constraint requires some runtime predicate
|
||
|
|
%% * analysis for attachment delaying (see primes for case)
|
||
|
|
%% * internal constraints declaration + analyses?
|
||
|
|
%% * Do not store in global variable store if not necessary
|
||
|
|
%% NOTE: affects show_store/1
|
||
|
|
%% * multi-level store: variable - ground
|
||
|
|
%% * Do not maintain/check unnecessary propagation history
|
||
|
|
%% for rules that cannot be applied more than once
|
||
|
|
%% e.g. due to groundness
|
||
|
|
%% * Strengthen attachment analysis:
|
||
|
|
%% reason about bodies of rules only containing constraints
|
||
|
|
%%
|
||
|
|
%% * SICStus compatibility
|
||
|
|
%% - rules/1 declaration
|
||
|
|
%% - options
|
||
|
|
%% - pragmas
|
||
|
|
%% - tell guard
|
||
|
|
%% * instantiation declarations
|
||
|
|
%% POTENTIAL GAIN:
|
||
|
|
%% GROUND
|
||
|
|
%% - cheaper matching code?
|
||
|
|
%% VARIABLE (never bound)
|
||
|
|
%%
|
||
|
|
%% * make difference between cheap guards for reordering
|
||
|
|
%% and non-binding guards for lock removal
|
||
|
|
%% * unqiue -> once/[] transformation for propagation
|
||
|
|
%% * cheap guards interleaved with head retrieval + faster
|
||
|
|
%% via-retrieval + non-empty checking for propagation rules
|
||
|
|
%% redo for simpagation_head2 prelude
|
||
|
|
%% * intelligent backtracking for simplification/simpagation rule
|
||
|
|
%% generator_1(X),'_$savecp'(CP_1),
|
||
|
|
%% ...
|
||
|
|
%% if( (
|
||
|
|
%% generator_n(Y),
|
||
|
|
%% test(X,Y)
|
||
|
|
%% ),
|
||
|
|
%% true,
|
||
|
|
%% ('_$cutto'(CP_1), fail)
|
||
|
|
%% ),
|
||
|
|
%% ...
|
||
|
|
%%
|
||
|
|
%% or recently developped cascading-supported approach
|
||
|
|
%%
|
||
|
|
%% * intelligent backtracking for propagation rule
|
||
|
|
%% use additional boolean argument for each possible smart backtracking
|
||
|
|
%% when boolean at end of list true -> no smart backtracking
|
||
|
|
%% false -> smart backtracking
|
||
|
|
%% only works for rules with at least 3 constraints in the head
|
||
|
|
%%
|
||
|
|
%% * mutually exclusive rules
|
||
|
|
%% * (set semantics + functional dependency) declaration + resolution
|
||
|
|
%%
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
:- module(chr_translate,
|
||
|
|
[ chr_translate/2 % +Decls, -TranslatedDecls
|
||
|
|
]).
|
||
|
|
%% SWI begin
|
||
|
|
:- use_module(library(lists),[append/3,member/2,delete/3,reverse/2,permutation/2]).
|
||
|
|
:- use_module(library(ordsets)).
|
||
|
|
%% SWI end
|
||
|
|
|
||
|
|
:- use_module(library(dialect/hprolog)).
|
||
|
|
:- use_module(pairlist).
|
||
|
|
:- use_module(a_star).
|
||
|
|
:- use_module(clean_code).
|
||
|
|
:- use_module(builtins).
|
||
|
|
:- use_module(find).
|
||
|
|
:- include(chr_op2).
|
||
|
|
|
||
|
|
:- chr_option(debug,off).
|
||
|
|
:- chr_option(optimize,full).
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
:- chr_constraint
|
||
|
|
|
||
|
|
constraint/2, % constraint(F/A,ConstraintIndex)
|
||
|
|
get_constraint/2,
|
||
|
|
|
||
|
|
constraint_count/1, % constraint_count(MaxConstraintIndex)
|
||
|
|
get_constraint_count/1,
|
||
|
|
|
||
|
|
constraint_index/2, % constraint_index(F/A,DefaultStoreAndAttachedIndex)
|
||
|
|
get_constraint_index/2,
|
||
|
|
|
||
|
|
max_constraint_index/1, % max_constraint_index(MaxDefaultStoreAndAttachedIndex)
|
||
|
|
get_max_constraint_index/1,
|
||
|
|
|
||
|
|
target_module/1, % target_module(Module)
|
||
|
|
get_target_module/1,
|
||
|
|
|
||
|
|
attached/2, % attached(F/A,yes/no/maybe)
|
||
|
|
is_attached/1,
|
||
|
|
|
||
|
|
indexed_argument/2, % argument instantiation may enable applicability of rule
|
||
|
|
is_indexed_argument/2,
|
||
|
|
|
||
|
|
constraint_mode/2,
|
||
|
|
get_constraint_mode/2,
|
||
|
|
|
||
|
|
may_trigger/1,
|
||
|
|
|
||
|
|
has_nonground_indexed_argument/3,
|
||
|
|
|
||
|
|
store_type/2,
|
||
|
|
get_store_type/2,
|
||
|
|
update_store_type/2,
|
||
|
|
actual_store_types/2,
|
||
|
|
assumed_store_type/2,
|
||
|
|
validate_store_type_assumption/1,
|
||
|
|
|
||
|
|
rule_count/1,
|
||
|
|
inc_rule_count/1,
|
||
|
|
get_rule_count/1,
|
||
|
|
|
||
|
|
passive/2,
|
||
|
|
is_passive/2,
|
||
|
|
any_passive_head/1,
|
||
|
|
|
||
|
|
pragma_unique/3,
|
||
|
|
get_pragma_unique/3,
|
||
|
|
|
||
|
|
occurrence/4,
|
||
|
|
get_occurrence/4,
|
||
|
|
|
||
|
|
max_occurrence/2,
|
||
|
|
get_max_occurrence/2,
|
||
|
|
|
||
|
|
allocation_occurrence/2,
|
||
|
|
get_allocation_occurrence/2,
|
||
|
|
rule/2,
|
||
|
|
get_rule/2
|
||
|
|
.
|
||
|
|
|
||
|
|
:- chr_option(mode,constraint(+,+)).
|
||
|
|
:- chr_option(mode,constraint_count(+)).
|
||
|
|
:- chr_option(mode,constraint_index(+,+)).
|
||
|
|
:- chr_option(mode,max_constraint_index(+)).
|
||
|
|
:- chr_option(mode,target_module(+)).
|
||
|
|
:- chr_option(mode,attached(+,+)).
|
||
|
|
:- chr_option(mode,indexed_argument(+,+)).
|
||
|
|
:- chr_option(mode,constraint_mode(+,+)).
|
||
|
|
:- chr_option(mode,may_trigger(+)).
|
||
|
|
:- chr_option(mode,store_type(+,+)).
|
||
|
|
:- chr_option(mode,actual_store_types(+,+)).
|
||
|
|
:- chr_option(mode,assumed_store_type(+,+)).
|
||
|
|
:- chr_option(mode,rule_count(+)).
|
||
|
|
:- chr_option(mode,passive(+,+)).
|
||
|
|
:- chr_option(mode,pragma_unique(+,+,?)).
|
||
|
|
:- chr_option(mode,occurrence(+,+,+,+)).
|
||
|
|
:- chr_option(mode,max_occurrence(+,+)).
|
||
|
|
:- chr_option(mode,allocation_occurrence(+,+)).
|
||
|
|
:- chr_option(mode,rule(+,+)).
|
||
|
|
|
||
|
|
constraint(FA,Index) \ get_constraint(Query,Index)
|
||
|
|
<=> Query = FA.
|
||
|
|
get_constraint(_,_)
|
||
|
|
<=> fail.
|
||
|
|
|
||
|
|
constraint_count(Index) \ get_constraint_count(Query)
|
||
|
|
<=> Query = Index.
|
||
|
|
get_constraint_count(Query)
|
||
|
|
<=> Query = 0.
|
||
|
|
|
||
|
|
target_module(Mod) \ get_target_module(Query)
|
||
|
|
<=> Query = Mod .
|
||
|
|
get_target_module(Query)
|
||
|
|
<=> Query = user.
|
||
|
|
|
||
|
|
constraint_index(C,Index) \ get_constraint_index(C,Query)
|
||
|
|
<=> Query = Index.
|
||
|
|
get_constraint_index(_,_)
|
||
|
|
<=> fail.
|
||
|
|
|
||
|
|
max_constraint_index(Index) \ get_max_constraint_index(Query)
|
||
|
|
<=> Query = Index.
|
||
|
|
get_max_constraint_index(Query)
|
||
|
|
<=> Query = 0.
|
||
|
|
|
||
|
|
attached(Constr,yes) \ attached(Constr,_) <=> true.
|
||
|
|
attached(Constr,no) \ attached(Constr,_) <=> true.
|
||
|
|
attached(Constr,maybe) \ attached(Constr,maybe) <=> true.
|
||
|
|
|
||
|
|
attached(Constr,Type) \ is_attached(Constr)
|
||
|
|
<=> Type \== no.
|
||
|
|
is_attached(_) <=> true.
|
||
|
|
|
||
|
|
indexed_argument(FA,I) \ indexed_argument(FA,I) <=> true.
|
||
|
|
indexed_argument(FA,I) \ is_indexed_argument(FA,I) <=> true.
|
||
|
|
is_indexed_argument(_,_) <=> fail.
|
||
|
|
|
||
|
|
constraint_mode(FA,Mode) \ get_constraint_mode(FA,Query)
|
||
|
|
<=> Query = Mode.
|
||
|
|
get_constraint_mode(FA,Query)
|
||
|
|
<=> FA = _/A, length(Query,A), set_elems(Query,?).
|
||
|
|
|
||
|
|
may_trigger(FA) <=>
|
||
|
|
is_attached(FA),
|
||
|
|
get_constraint_mode(FA,Mode),
|
||
|
|
has_nonground_indexed_argument(FA,1,Mode).
|
||
|
|
|
||
|
|
has_nonground_indexed_argument(FA,I,[Mode|Modes])
|
||
|
|
<=>
|
||
|
|
true
|
||
|
|
|
|
||
|
|
( is_indexed_argument(FA,I),
|
||
|
|
Mode \== (+) ->
|
||
|
|
true
|
||
|
|
;
|
||
|
|
J is I + 1,
|
||
|
|
has_nonground_indexed_argument(FA,J,Modes)
|
||
|
|
).
|
||
|
|
has_nonground_indexed_argument(_,_,_)
|
||
|
|
<=> fail.
|
||
|
|
|
||
|
|
store_type(FA,atom_hash(Index)) <=> store_type(FA,multi_hash([Index])).
|
||
|
|
store_type(FA,Store) \ get_store_type(FA,Query)
|
||
|
|
<=> Query = Store.
|
||
|
|
assumed_store_type(FA,Store) \ get_store_type(FA,Query)
|
||
|
|
<=> Query = Store.
|
||
|
|
get_store_type(_,Query)
|
||
|
|
<=> Query = default.
|
||
|
|
|
||
|
|
actual_store_types(C,STs) \ update_store_type(C,ST)
|
||
|
|
<=> member(ST,STs) | true.
|
||
|
|
update_store_type(C,ST), actual_store_types(C,STs)
|
||
|
|
<=>
|
||
|
|
actual_store_types(C,[ST|STs]).
|
||
|
|
update_store_type(C,ST)
|
||
|
|
<=>
|
||
|
|
actual_store_types(C,[ST]).
|
||
|
|
|
||
|
|
% refine store type assumption
|
||
|
|
validate_store_type_assumption(C), actual_store_types(C,STs), assumed_store_type(C,_) % automatic assumption
|
||
|
|
<=>
|
||
|
|
store_type(C,multi_store(STs)).
|
||
|
|
validate_store_type_assumption(C), actual_store_types(C,STs), store_type(C,_) % user assumption
|
||
|
|
<=>
|
||
|
|
store_type(C,multi_store(STs)).
|
||
|
|
validate_store_type_assumption(_)
|
||
|
|
<=> true.
|
||
|
|
|
||
|
|
rule_count(C), inc_rule_count(NC)
|
||
|
|
<=> NC is C + 1, rule_count(NC).
|
||
|
|
inc_rule_count(NC)
|
||
|
|
<=> NC = 1, rule_count(NC).
|
||
|
|
|
||
|
|
rule_count(C) \ get_rule_count(Q)
|
||
|
|
<=> Q = C.
|
||
|
|
get_rule_count(Q)
|
||
|
|
<=> Q = 0.
|
||
|
|
|
||
|
|
passive(RuleNb,ID) \ is_passive(RuleNb,ID)
|
||
|
|
<=> true.
|
||
|
|
is_passive(_,_)
|
||
|
|
<=> fail.
|
||
|
|
passive(RuleNb,_) \ any_passive_head(RuleNb)
|
||
|
|
<=> true.
|
||
|
|
any_passive_head(_)
|
||
|
|
<=> fail.
|
||
|
|
|
||
|
|
pragma_unique(RuleNb,ID,Vars) \ get_pragma_unique(RuleNb,ID,Query)
|
||
|
|
<=> Query = Vars.
|
||
|
|
get_pragma_unique(_,_,_)
|
||
|
|
<=> true.
|
||
|
|
|
||
|
|
occurrence(C,ON,Rule,ID) \ get_occurrence(C,ON,QRule,QID)
|
||
|
|
<=> Rule = QRule, ID = QID.
|
||
|
|
get_occurrence(_,_,_,_)
|
||
|
|
<=> fail.
|
||
|
|
|
||
|
|
occurrence(C,ON,_,_) ==> max_occurrence(C,ON).
|
||
|
|
max_occurrence(C,N) \ max_occurrence(C,M)
|
||
|
|
<=> N >= M | true.
|
||
|
|
max_occurrence(C,MON) \ get_max_occurrence(C,Q)
|
||
|
|
<=> Q = MON.
|
||
|
|
get_max_occurrence(_,Q)
|
||
|
|
<=> Q = 0.
|
||
|
|
|
||
|
|
% need not store constraint that is removed
|
||
|
|
rule(RuleNb,Rule), occurrence(C,O,RuleNb,ID) \ allocation_occurrence(C,O)
|
||
|
|
<=> Rule = pragma(_,ids(IDs1,_),_,_,_), member(ID,IDs)
|
||
|
|
| NO is O + 1, allocation_occurrence(C,NO).
|
||
|
|
% need not store constraint when body is true
|
||
|
|
rule(RuleNb,Rule), occurrence(C,O,RuleNb,_) \ allocation_occurrence(C,O)
|
||
|
|
<=> Rule = pragma(rule(_,_,_,true),_,_,_,_)
|
||
|
|
| NO is O + 1, allocation_occurrence(C,NO).
|
||
|
|
% cannot store constraint at passive occurrence
|
||
|
|
occurrence(C,O,RuleNb,ID), passive(RuleNb,ID) \ allocation_occurrence(C,O)
|
||
|
|
<=> NO is O + 1, allocation_occurrence(C,NO).
|
||
|
|
allocation_occurrence(C,O) \ get_allocation_occurrence(C,Q)
|
||
|
|
<=> Q = O.
|
||
|
|
get_allocation_occurrence(_,_)
|
||
|
|
<=> fail.
|
||
|
|
|
||
|
|
rule(RuleNb,Rule) \ get_rule(RuleNb,Q)
|
||
|
|
<=> Q = Rule.
|
||
|
|
get_rule(_,_)
|
||
|
|
<=> fail.
|
||
|
|
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
%%
|
||
|
|
%% Translation
|
||
|
|
|
||
|
|
chr_translate(Declarations,NewDeclarations) :-
|
||
|
|
init_chr_pp_flags,
|
||
|
|
partition_clauses(Declarations,Constraints,Rules,OtherClauses),
|
||
|
|
( Constraints == [] ->
|
||
|
|
insert_declarations(OtherClauses, NewDeclarations)
|
||
|
|
;
|
||
|
|
% start analysis
|
||
|
|
add_rules(Rules),
|
||
|
|
check_rules(Rules,Constraints),
|
||
|
|
add_occurrences(Rules),
|
||
|
|
late_allocation(Constraints),
|
||
|
|
unique_analyse_optimise(Rules,NRules),
|
||
|
|
check_attachments(Constraints),
|
||
|
|
assume_constraint_stores(Constraints),
|
||
|
|
set_constraint_indices(Constraints,1),
|
||
|
|
% end analysis
|
||
|
|
constraints_code(Constraints,NRules,ConstraintClauses),
|
||
|
|
validate_store_type_assumptions(Constraints),
|
||
|
|
store_management_preds(Constraints,StoreClauses), % depends on actual code used
|
||
|
|
insert_declarations(OtherClauses, Clauses0),
|
||
|
|
chr_module_declaration(CHRModuleDeclaration),
|
||
|
|
append([Clauses0,
|
||
|
|
StoreClauses,
|
||
|
|
ConstraintClauses,
|
||
|
|
CHRModuleDeclaration
|
||
|
|
],
|
||
|
|
NewDeclarations)
|
||
|
|
).
|
||
|
|
|
||
|
|
store_management_preds(Constraints,Clauses) :-
|
||
|
|
generate_attach_detach_a_constraint_all(Constraints,AttachAConstraintClauses),
|
||
|
|
generate_indexed_variables_clauses(Constraints,IndexedClauses),
|
||
|
|
generate_attach_increment(AttachIncrementClauses),
|
||
|
|
generate_attr_unify_hook(AttrUnifyHookClauses),
|
||
|
|
generate_extra_clauses(Constraints,ExtraClauses),
|
||
|
|
generate_insert_delete_constraints(Constraints,DeleteClauses),
|
||
|
|
generate_store_code(Constraints,StoreClauses),
|
||
|
|
append([AttachAConstraintClauses
|
||
|
|
,IndexedClauses
|
||
|
|
,AttachIncrementClauses
|
||
|
|
,AttrUnifyHookClauses
|
||
|
|
,ExtraClauses
|
||
|
|
,DeleteClauses
|
||
|
|
,StoreClauses]
|
||
|
|
,Clauses).
|
||
|
|
|
||
|
|
|
||
|
|
%% SWI begin
|
||
|
|
specific_declarations([(:- use_module('chr_runtime'))
|
||
|
|
,(:- use_module('chr_hashtable_store'))
|
||
|
|
,(:- style_check(-discontiguous))
|
||
|
|
|Tail],Tail).
|
||
|
|
%% SWI end
|
||
|
|
|
||
|
|
%% SICStus begin
|
||
|
|
%% specific_declarations([(:- use_module('chr_runtime')),
|
||
|
|
%% (:- use_module('chr_hashtable_store')),
|
||
|
|
%% (:- set_prolog_flag(discontiguous_warnings,off)),
|
||
|
|
%% (:- set_prolog_flag(single_var_warnings,off))
|
||
|
|
%% |Tail],Tail).
|
||
|
|
%% SICStus end
|
||
|
|
|
||
|
|
|
||
|
|
insert_declarations(Clauses0, Clauses) :-
|
||
|
|
specific_declarations(Decls,Tail),
|
||
|
|
( Clauses0 = [ (:- module(M,E))|FileBody] ->
|
||
|
|
Clauses = [ (:- module(M,E))|Decls],
|
||
|
|
Tail = FileBody
|
||
|
|
;
|
||
|
|
Clauses = Decls,
|
||
|
|
Tail = Clauses0
|
||
|
|
).
|
||
|
|
|
||
|
|
|
||
|
|
chr_module_declaration(CHRModuleDeclaration) :-
|
||
|
|
get_target_module(Mod),
|
||
|
|
( Mod \== chr_translate ->
|
||
|
|
CHRModuleDeclaration = [
|
||
|
|
(:- multifile chr:'$chr_module'/1),
|
||
|
|
chr:'$chr_module'(Mod)
|
||
|
|
]
|
||
|
|
;
|
||
|
|
CHRModuleDeclaration = []
|
||
|
|
).
|
||
|
|
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
%%
|
||
|
|
%% Partitioning of clauses into constraint declarations, chr rules and other
|
||
|
|
%% clauses
|
||
|
|
|
||
|
|
partition_clauses([],[],[],[]).
|
||
|
|
partition_clauses([C|Cs],Ds,Rs,OCs) :-
|
||
|
|
( parse_rule(C,R) ->
|
||
|
|
Ds = RDs,
|
||
|
|
Rs = [R | RRs],
|
||
|
|
OCs = ROCs
|
||
|
|
; is_declaration(C,D) ->
|
||
|
|
append(D,RDs,Ds),
|
||
|
|
Rs = RRs,
|
||
|
|
OCs = ROCs
|
||
|
|
; is_module_declaration(C,Mod) ->
|
||
|
|
target_module(Mod),
|
||
|
|
Ds = RDs,
|
||
|
|
Rs = RRs,
|
||
|
|
OCs = [C|ROCs]
|
||
|
|
; C = (handler _) ->
|
||
|
|
format('CHR compiler WARNING: ~w.\n',[C]),
|
||
|
|
format(' `--> SICStus compatibility: ignoring handler/1 declaration.\n',[]),
|
||
|
|
Ds = RDs,
|
||
|
|
Rs = RRs,
|
||
|
|
OCs = ROCs
|
||
|
|
; C = (rules _) ->
|
||
|
|
format('CHR compiler WARNING: ~w.\n',[C]),
|
||
|
|
format(' `--> SICStus compatibility: ignoring rules/1 declaration.\n',[]),
|
||
|
|
Ds = RDs,
|
||
|
|
Rs = RRs,
|
||
|
|
OCs = ROCs
|
||
|
|
; C = (:- chr_option(OptionName,OptionValue)) ->
|
||
|
|
handle_option(OptionName,OptionValue),
|
||
|
|
Ds = RDs,
|
||
|
|
Rs = RRs,
|
||
|
|
OCs = ROCs
|
||
|
|
; C = (:- chr_type _) ->
|
||
|
|
Ds = RDs,
|
||
|
|
Rs = RRs,
|
||
|
|
OCs = ROCs
|
||
|
|
; Ds = RDs,
|
||
|
|
Rs = RRs,
|
||
|
|
OCs = [C|ROCs]
|
||
|
|
),
|
||
|
|
partition_clauses(Cs,RDs,RRs,ROCs).
|
||
|
|
|
||
|
|
is_declaration(D, Constraints) :- %% constraint declaration
|
||
|
|
D = (:- Decl),
|
||
|
|
( Decl =.. [chr_constraint,Cs] ; Decl =.. [chr_constraint,Cs]),
|
||
|
|
conj2list(Cs,Constraints).
|
||
|
|
|
||
|
|
%% Data Declaration
|
||
|
|
%%
|
||
|
|
%% pragma_rule
|
||
|
|
%% -> pragma(
|
||
|
|
%% rule,
|
||
|
|
%% ids,
|
||
|
|
%% list(pragma),
|
||
|
|
%% yesno(string), :: maybe rule nane
|
||
|
|
%% int :: rule number
|
||
|
|
%% )
|
||
|
|
%%
|
||
|
|
%% ids -> ids(
|
||
|
|
%% list(int),
|
||
|
|
%% list(int)
|
||
|
|
%% )
|
||
|
|
%%
|
||
|
|
%% rule -> rule(
|
||
|
|
%% list(constraint), :: constraints to be removed
|
||
|
|
%% list(constraint), :: surviving constraints
|
||
|
|
%% goal, :: guard
|
||
|
|
%% goal :: body
|
||
|
|
%% )
|
||
|
|
|
||
|
|
parse_rule(RI,R) :- %% name @ rule
|
||
|
|
RI = (Name @ RI2), !,
|
||
|
|
rule(RI2,yes(Name),R).
|
||
|
|
parse_rule(RI,R) :-
|
||
|
|
rule(RI,no,R).
|
||
|
|
|
||
|
|
rule(RI,Name,R) :-
|
||
|
|
RI = (RI2 pragma P), !, %% pragmas
|
||
|
|
is_rule(RI2,R1,IDs),
|
||
|
|
conj2list(P,Ps),
|
||
|
|
inc_rule_count(RuleCount),
|
||
|
|
R = pragma(R1,IDs,Ps,Name,RuleCount).
|
||
|
|
rule(RI,Name,R) :-
|
||
|
|
is_rule(RI,R1,IDs),
|
||
|
|
inc_rule_count(RuleCount),
|
||
|
|
R = pragma(R1,IDs,[],Name,RuleCount).
|
||
|
|
|
||
|
|
is_rule(RI,R,IDs) :- %% propagation rule
|
||
|
|
RI = (H ==> B), !,
|
||
|
|
conj2list(H,Head2i),
|
||
|
|
get_ids(Head2i,IDs2,Head2),
|
||
|
|
IDs = ids([],IDs2),
|
||
|
|
( B = (G | RB) ->
|
||
|
|
R = rule([],Head2,G,RB)
|
||
|
|
;
|
||
|
|
R = rule([],Head2,true,B)
|
||
|
|
).
|
||
|
|
is_rule(RI,R,IDs) :- %% simplification/simpagation rule
|
||
|
|
RI = (H <=> B), !,
|
||
|
|
( B = (G | RB) ->
|
||
|
|
Guard = G,
|
||
|
|
Body = RB
|
||
|
|
; Guard = true,
|
||
|
|
Body = B
|
||
|
|
),
|
||
|
|
( H = (H1 \ H2) ->
|
||
|
|
conj2list(H1,Head2i),
|
||
|
|
conj2list(H2,Head1i),
|
||
|
|
get_ids(Head2i,IDs2,Head2,0,N),
|
||
|
|
get_ids(Head1i,IDs1,Head1,N,_),
|
||
|
|
IDs = ids(IDs1,IDs2)
|
||
|
|
; conj2list(H,Head1i),
|
||
|
|
Head2 = [],
|
||
|
|
get_ids(Head1i,IDs1,Head1),
|
||
|
|
IDs = ids(IDs1,[])
|
||
|
|
),
|
||
|
|
R = rule(Head1,Head2,Guard,Body).
|
||
|
|
|
||
|
|
get_ids(Cs,IDs,NCs) :-
|
||
|
|
get_ids(Cs,IDs,NCs,0,_).
|
||
|
|
|
||
|
|
get_ids([],[],[],N,N).
|
||
|
|
get_ids([C|Cs],[N|IDs],[NC|NCs],N,NN) :-
|
||
|
|
( C = (NC # N) ->
|
||
|
|
true
|
||
|
|
;
|
||
|
|
NC = C
|
||
|
|
),
|
||
|
|
M is N + 1,
|
||
|
|
get_ids(Cs,IDs,NCs, M,NN).
|
||
|
|
|
||
|
|
is_module_declaration((:- module(Mod)),Mod).
|
||
|
|
is_module_declaration((:- module(Mod,_)),Mod).
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
% Add rules
|
||
|
|
add_rules([]).
|
||
|
|
add_rules([Rule|Rules]) :-
|
||
|
|
Rule = pragma(_,_,_,_,RuleNb),
|
||
|
|
rule(RuleNb,Rule),
|
||
|
|
add_rules(Rules).
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
%% Some input verification:
|
||
|
|
%% - all constraints in heads are declared constraints
|
||
|
|
%% - all passive pragmas refer to actual head constraints
|
||
|
|
|
||
|
|
check_rules([],_).
|
||
|
|
check_rules([PragmaRule|Rest],Decls) :-
|
||
|
|
check_rule(PragmaRule,Decls),
|
||
|
|
check_rules(Rest,Decls).
|
||
|
|
|
||
|
|
check_rule(PragmaRule,Decls) :-
|
||
|
|
check_rule_indexing(PragmaRule),
|
||
|
|
PragmaRule = pragma(Rule,_IDs,Pragmas,_Name,_N),
|
||
|
|
Rule = rule(H1,H2,_,_),
|
||
|
|
append(H1,H2,HeadConstraints),
|
||
|
|
check_head_constraints(HeadConstraints,Decls,PragmaRule),
|
||
|
|
check_pragmas(Pragmas,PragmaRule).
|
||
|
|
|
||
|
|
check_head_constraints([],_,_).
|
||
|
|
check_head_constraints([Constr|Rest],Decls,PragmaRule) :-
|
||
|
|
functor(Constr,F,A),
|
||
|
|
( member(F/A,Decls) ->
|
||
|
|
check_head_constraints(Rest,Decls,PragmaRule)
|
||
|
|
;
|
||
|
|
format('CHR compiler ERROR: Undeclared constraint ~w in head of ~@.\n',
|
||
|
|
[F/A,format_rule(PragmaRule)]),
|
||
|
|
format(' `--> Constraint should be one of ~w.\n',[Decls]),
|
||
|
|
fail
|
||
|
|
).
|
||
|
|
|
||
|
|
check_pragmas([],_).
|
||
|
|
check_pragmas([Pragma|Pragmas],PragmaRule) :-
|
||
|
|
check_pragma(Pragma,PragmaRule),
|
||
|
|
check_pragmas(Pragmas,PragmaRule).
|
||
|
|
|
||
|
|
check_pragma(Pragma,PragmaRule) :-
|
||
|
|
var(Pragma), !,
|
||
|
|
format('CHR compiler ERROR: invalid pragma ~w in ~@.\n',
|
||
|
|
[Pragma,format_rule(PragmaRule)]),
|
||
|
|
format(' `--> Pragma should not be a variable!\n',[]),
|
||
|
|
fail.
|
||
|
|
check_pragma(passive(ID), PragmaRule) :-
|
||
|
|
!,
|
||
|
|
PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb),
|
||
|
|
( memberchk_eq(ID,IDs1) ->
|
||
|
|
true
|
||
|
|
; memberchk_eq(ID,IDs2) ->
|
||
|
|
true
|
||
|
|
;
|
||
|
|
format('CHR compiler ERROR: invalid identifier ~w in pragma passive in ~@.\n',
|
||
|
|
[ID,format_rule(PragmaRule)]),
|
||
|
|
fail
|
||
|
|
),
|
||
|
|
passive(RuleNb,ID).
|
||
|
|
|
||
|
|
check_pragma(Pragma, PragmaRule) :-
|
||
|
|
Pragma = unique(ID,Vars),
|
||
|
|
!,
|
||
|
|
PragmaRule = pragma(_,_,_,_,RuleNb),
|
||
|
|
pragma_unique(RuleNb,ID,Vars),
|
||
|
|
format('CHR compiler WARNING: undocumented pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule)]),
|
||
|
|
format(' `--> Only use this pragma if you know what you are doing.\n',[]).
|
||
|
|
|
||
|
|
check_pragma(Pragma, PragmaRule) :-
|
||
|
|
Pragma = already_in_heads,
|
||
|
|
!,
|
||
|
|
format('CHR compiler WARNING: currently unsupported pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule)]),
|
||
|
|
format(' `--> Pragma is ignored. Termination and correctness may be affected \n',[]).
|
||
|
|
|
||
|
|
check_pragma(Pragma, PragmaRule) :-
|
||
|
|
Pragma = already_in_head(_),
|
||
|
|
!,
|
||
|
|
format('CHR compiler WARNING: currently unsupported pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule)]),
|
||
|
|
format(' `--> Pragma is ignored. Termination and correctness may be affected \n',[]).
|
||
|
|
|
||
|
|
check_pragma(Pragma,PragmaRule) :-
|
||
|
|
format('CHR compiler ERROR: invalid pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule)]),
|
||
|
|
format(' `--> Pragma should be one of passive/1!\n',[]),
|
||
|
|
fail.
|
||
|
|
|
||
|
|
format_rule(PragmaRule) :-
|
||
|
|
PragmaRule = pragma(_,_,_,MaybeName,N),
|
||
|
|
( MaybeName = yes(Name) ->
|
||
|
|
write('rule '), write(Name)
|
||
|
|
;
|
||
|
|
write('rule number '), write(N)
|
||
|
|
).
|
||
|
|
|
||
|
|
check_rule_indexing(PragmaRule) :-
|
||
|
|
PragmaRule = pragma(Rule,_,_,_,_),
|
||
|
|
Rule = rule(H1,H2,G,_),
|
||
|
|
term_variables(H1-H2,HeadVars),
|
||
|
|
remove_anti_monotonic_guards(G,HeadVars,NG),
|
||
|
|
check_indexing(H1,NG-H2),
|
||
|
|
check_indexing(H2,NG-H1).
|
||
|
|
|
||
|
|
remove_anti_monotonic_guards(G,Vars,NG) :-
|
||
|
|
conj2list(G,GL),
|
||
|
|
remove_anti_monotonic_guard_list(GL,Vars,NGL),
|
||
|
|
list2conj(NGL,NG).
|
||
|
|
|
||
|
|
remove_anti_monotonic_guard_list([],_,[]).
|
||
|
|
remove_anti_monotonic_guard_list([G|Gs],Vars,NGs) :-
|
||
|
|
( G = var(X),
|
||
|
|
memberchk_eq(X,Vars) ->
|
||
|
|
NGs = RGs
|
||
|
|
;
|
||
|
|
NGs = [G|RGs]
|
||
|
|
),
|
||
|
|
remove_anti_monotonic_guard_list(Gs,Vars,RGs).
|
||
|
|
|
||
|
|
check_indexing([],_).
|
||
|
|
check_indexing([Head|Heads],Other) :-
|
||
|
|
functor(Head,F,A),
|
||
|
|
Head =.. [_|Args],
|
||
|
|
term_variables(Heads-Other,OtherVars),
|
||
|
|
check_indexing(Args,1,F/A,OtherVars),
|
||
|
|
check_indexing(Heads,[Head|Other]).
|
||
|
|
|
||
|
|
check_indexing([],_,_,_).
|
||
|
|
check_indexing([Arg|Args],I,FA,OtherVars) :-
|
||
|
|
( is_indexed_argument(FA,I) ->
|
||
|
|
true
|
||
|
|
; nonvar(Arg) ->
|
||
|
|
indexed_argument(FA,I)
|
||
|
|
; % var(Arg) ->
|
||
|
|
term_variables(Args,ArgsVars),
|
||
|
|
append(ArgsVars,OtherVars,RestVars),
|
||
|
|
( memberchk_eq(Arg,RestVars) ->
|
||
|
|
indexed_argument(FA,I)
|
||
|
|
;
|
||
|
|
true
|
||
|
|
)
|
||
|
|
),
|
||
|
|
J is I + 1,
|
||
|
|
term_variables(Arg,NVars),
|
||
|
|
append(NVars,OtherVars,NOtherVars),
|
||
|
|
check_indexing(Args,J,FA,NOtherVars).
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
% Occurrences
|
||
|
|
|
||
|
|
add_occurrences([]).
|
||
|
|
add_occurrences([Rule|Rules]) :-
|
||
|
|
Rule = pragma(rule(H1,H2,_,_),ids(IDs1,IDs2),_,_,Nb),
|
||
|
|
add_occurrences(H1,IDs1,Nb),
|
||
|
|
add_occurrences(H2,IDs2,Nb),
|
||
|
|
add_occurrences(Rules).
|
||
|
|
|
||
|
|
add_occurrences([],[],_).
|
||
|
|
add_occurrences([H|Hs],[ID|IDs],RuleNb) :-
|
||
|
|
functor(H,F,A),
|
||
|
|
FA = F/A,
|
||
|
|
get_max_occurrence(FA,MO),
|
||
|
|
O is MO + 1,
|
||
|
|
occurrence(FA,O,RuleNb,ID),
|
||
|
|
add_occurrences(Hs,IDs,RuleNb).
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
% Late allocation
|
||
|
|
|
||
|
|
late_allocation([]).
|
||
|
|
late_allocation([C|Cs]) :-
|
||
|
|
allocation_occurrence(C,1),
|
||
|
|
late_allocation(Cs).
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
% Global Options
|
||
|
|
%
|
||
|
|
|
||
|
|
handle_option(Var,Value) :-
|
||
|
|
var(Var), !,
|
||
|
|
format('CHR compiler ERROR: ~w.\n',[option(Var,Value)]),
|
||
|
|
format(' `--> First argument should be an atom, not a variable.\n',[]),
|
||
|
|
fail.
|
||
|
|
|
||
|
|
handle_option(Name,Value) :-
|
||
|
|
var(Value), !,
|
||
|
|
format('CHR compiler ERROR: ~w.\n',[option(Name,Value)]),
|
||
|
|
format(' `--> Second argument should be a nonvariable.\n',[]),
|
||
|
|
fail.
|
||
|
|
|
||
|
|
handle_option(Name,Value) :-
|
||
|
|
option_definition(Name,Value,Flags),
|
||
|
|
!,
|
||
|
|
set_chr_pp_flags(Flags).
|
||
|
|
|
||
|
|
handle_option(Name,Value) :-
|
||
|
|
\+ option_definition(Name,_,_), !,
|
||
|
|
% setof(N,_V ^ _F ^ (option_definition(N,_V,_F)),Ns),
|
||
|
|
format('CHR compiler WARNING: ~w.\n',[option(Name,Value)]),
|
||
|
|
format(' `--> Invalid option name \n',[]). %~w: should be one of ~w.\n',[Name,Ns]).
|
||
|
|
|
||
|
|
handle_option(Name,Value) :-
|
||
|
|
findall(V,option_definition(Name,V,_),Vs),
|
||
|
|
format('CHR compiler ERROR: ~w.\n',[option(Name,Value)]),
|
||
|
|
format(' `--> Invalid value ~w: should be one of ~w.\n',[Value,Vs]),
|
||
|
|
fail.
|
||
|
|
|
||
|
|
option_definition(optimize,experimental,Flags) :-
|
||
|
|
Flags = [ unique_analyse_optimise - on,
|
||
|
|
check_unnecessary_active - full,
|
||
|
|
reorder_heads - on,
|
||
|
|
set_semantics_rule - on,
|
||
|
|
check_attachments - on,
|
||
|
|
guard_via_reschedule - on
|
||
|
|
].
|
||
|
|
option_definition(optimize,full,Flags) :-
|
||
|
|
Flags = [ unique_analyse_optimise - off,
|
||
|
|
check_unnecessary_active - full,
|
||
|
|
reorder_heads - on,
|
||
|
|
set_semantics_rule - on,
|
||
|
|
check_attachments - on,
|
||
|
|
guard_via_reschedule - on
|
||
|
|
].
|
||
|
|
|
||
|
|
option_definition(optimize,sicstus,Flags) :-
|
||
|
|
Flags = [ unique_analyse_optimise - off,
|
||
|
|
check_unnecessary_active - simplification,
|
||
|
|
reorder_heads - off,
|
||
|
|
set_semantics_rule - off,
|
||
|
|
check_attachments - off,
|
||
|
|
guard_via_reschedule - off
|
||
|
|
].
|
||
|
|
|
||
|
|
option_definition(optimize,off,Flags) :-
|
||
|
|
Flags = [ unique_analyse_optimise - off,
|
||
|
|
check_unnecessary_active - off,
|
||
|
|
reorder_heads - off,
|
||
|
|
set_semantics_rule - off,
|
||
|
|
check_attachments - off,
|
||
|
|
guard_via_reschedule - off
|
||
|
|
].
|
||
|
|
|
||
|
|
option_definition(check_guard_bindings,on,Flags) :-
|
||
|
|
Flags = [ guard_locks - on ].
|
||
|
|
|
||
|
|
option_definition(check_guard_bindings,off,Flags) :-
|
||
|
|
Flags = [ guard_locks - off ].
|
||
|
|
|
||
|
|
option_definition(reduced_indexing,on,Flags) :-
|
||
|
|
Flags = [ reduced_indexing - on ].
|
||
|
|
|
||
|
|
option_definition(reduced_indexing,off,Flags) :-
|
||
|
|
Flags = [ reduced_indexing - off ].
|
||
|
|
|
||
|
|
option_definition(mode,ModeDecl,[]) :-
|
||
|
|
(nonvar(ModeDecl) ->
|
||
|
|
functor(ModeDecl,F,A),
|
||
|
|
ModeDecl =.. [_|ArgModes],
|
||
|
|
constraint_mode(F/A,ArgModes)
|
||
|
|
;
|
||
|
|
true
|
||
|
|
).
|
||
|
|
option_definition(store,FA-Store,[]) :-
|
||
|
|
store_type(FA,Store).
|
||
|
|
|
||
|
|
option_definition(debug,on,Flags) :-
|
||
|
|
Flags = [ debugable - on ].
|
||
|
|
option_definition(debug,off,Flags) :-
|
||
|
|
Flags = [ debugable - off ].
|
||
|
|
option_definition(type_definition, _, []). % JW: ignored by bootstrap compiler
|
||
|
|
option_definition(type_declaration, _, []). % JW: ignored by bootstrap compiler
|
||
|
|
option_definition(verbosity,_,[]).
|
||
|
|
|
||
|
|
init_chr_pp_flags :-
|
||
|
|
chr_pp_flag_definition(Name,[DefaultValue|_]),
|
||
|
|
set_chr_pp_flag(Name,DefaultValue),
|
||
|
|
fail.
|
||
|
|
init_chr_pp_flags.
|
||
|
|
|
||
|
|
set_chr_pp_flags([]).
|
||
|
|
set_chr_pp_flags([Name-Value|Flags]) :-
|
||
|
|
set_chr_pp_flag(Name,Value),
|
||
|
|
set_chr_pp_flags(Flags).
|
||
|
|
|
||
|
|
set_chr_pp_flag(Name,Value) :-
|
||
|
|
atom_concat('$chr_pp_',Name,GlobalVar),
|
||
|
|
nb_setval(GlobalVar,Value).
|
||
|
|
|
||
|
|
chr_pp_flag_definition(unique_analyse_optimise,[on,off]).
|
||
|
|
chr_pp_flag_definition(check_unnecessary_active,[full,simplification,off]).
|
||
|
|
chr_pp_flag_definition(reorder_heads,[on,off]).
|
||
|
|
chr_pp_flag_definition(set_semantics_rule,[on,off]).
|
||
|
|
chr_pp_flag_definition(guard_via_reschedule,[on,off]).
|
||
|
|
chr_pp_flag_definition(guard_locks,[on,off]).
|
||
|
|
chr_pp_flag_definition(check_attachments,[on,off]).
|
||
|
|
chr_pp_flag_definition(debugable,[off,on]).
|
||
|
|
chr_pp_flag_definition(reduced_indexing,[on,off]).
|
||
|
|
|
||
|
|
chr_pp_flag(Name,Value) :-
|
||
|
|
atom_concat('$chr_pp_',Name,GlobalVar),
|
||
|
|
nb_getval(GlobalVar,V),
|
||
|
|
( V == [] ->
|
||
|
|
chr_pp_flag_definition(Name,[Value|_])
|
||
|
|
;
|
||
|
|
V = Value
|
||
|
|
).
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
%%
|
||
|
|
%% Generated predicates
|
||
|
|
%% attach_$CONSTRAINT
|
||
|
|
%% attach_increment
|
||
|
|
%% detach_$CONSTRAINT
|
||
|
|
%% attr_unify_hook
|
||
|
|
|
||
|
|
%% attach_$CONSTRAINT
|
||
|
|
generate_attach_detach_a_constraint_all([],[]).
|
||
|
|
generate_attach_detach_a_constraint_all([Constraint|Constraints],Clauses) :-
|
||
|
|
( may_trigger(Constraint) ->
|
||
|
|
generate_attach_a_constraint(Constraint,Clauses1),
|
||
|
|
generate_detach_a_constraint(Constraint,Clauses2)
|
||
|
|
;
|
||
|
|
Clauses1 = [],
|
||
|
|
Clauses2 = []
|
||
|
|
),
|
||
|
|
generate_attach_detach_a_constraint_all(Constraints,Clauses3),
|
||
|
|
append([Clauses1,Clauses2,Clauses3],Clauses).
|
||
|
|
|
||
|
|
generate_attach_a_constraint(Constraint,[Clause1,Clause2]) :-
|
||
|
|
generate_attach_a_constraint_empty_list(Constraint,Clause1),
|
||
|
|
get_max_constraint_index(N),
|
||
|
|
( N == 1 ->
|
||
|
|
generate_attach_a_constraint_1_1(Constraint,Clause2)
|
||
|
|
;
|
||
|
|
generate_attach_a_constraint_t_p(Constraint,Clause2)
|
||
|
|
).
|
||
|
|
|
||
|
|
generate_attach_a_constraint_skeleton(FA,Args,Body,Clause) :-
|
||
|
|
make_name('attach_',FA,Fct),
|
||
|
|
Head =.. [Fct | Args],
|
||
|
|
Clause = ( Head :- Body).
|
||
|
|
|
||
|
|
generate_attach_a_constraint_empty_list(FA,Clause) :-
|
||
|
|
generate_attach_a_constraint_skeleton(FA,[[],_],true,Clause).
|
||
|
|
|
||
|
|
generate_attach_a_constraint_1_1(FA,Clause) :-
|
||
|
|
Args = [[Var|Vars],Susp],
|
||
|
|
generate_attach_a_constraint_skeleton(FA,Args,Body,Clause),
|
||
|
|
generate_attach_body_1(FA,Var,Susp,AttachBody),
|
||
|
|
make_name('attach_',FA,Fct),
|
||
|
|
RecursiveCall =.. [Fct,Vars,Susp],
|
||
|
|
Body =
|
||
|
|
(
|
||
|
|
AttachBody,
|
||
|
|
RecursiveCall
|
||
|
|
).
|
||
|
|
|
||
|
|
generate_attach_body_1(FA,Var,Susp,Body) :-
|
||
|
|
get_target_module(Mod),
|
||
|
|
Body =
|
||
|
|
( get_attr(Var, Mod, Susps) ->
|
||
|
|
NewSusps=[Susp|Susps],
|
||
|
|
put_attr(Var, Mod, NewSusps)
|
||
|
|
;
|
||
|
|
put_attr(Var, Mod, [Susp])
|
||
|
|
).
|
||
|
|
|
||
|
|
generate_attach_a_constraint_t_p(FA,Clause) :-
|
||
|
|
Args = [[Var|Vars],Susp],
|
||
|
|
generate_attach_a_constraint_skeleton(FA,Args,Body,Clause),
|
||
|
|
make_name('attach_',FA,Fct),
|
||
|
|
RecursiveCall =.. [Fct,Vars,Susp],
|
||
|
|
generate_attach_body_n(FA,Var,Susp,AttachBody),
|
||
|
|
Body =
|
||
|
|
(
|
||
|
|
AttachBody,
|
||
|
|
RecursiveCall
|
||
|
|
).
|
||
|
|
|
||
|
|
generate_attach_body_n(F/A,Var,Susp,Body) :-
|
||
|
|
get_constraint_index(F/A,Position),
|
||
|
|
or_pattern(Position,Pattern),
|
||
|
|
get_max_constraint_index(Total),
|
||
|
|
make_attr(Total,Mask,SuspsList,Attr),
|
||
|
|
nth1(Position,SuspsList,Susps),
|
||
|
|
substitute_eq(Susps,SuspsList,[Susp|Susps],SuspsList1),
|
||
|
|
make_attr(Total,Mask,SuspsList1,NewAttr1),
|
||
|
|
substitute_eq(Susps,SuspsList,[Susp],SuspsList2),
|
||
|
|
make_attr(Total,NewMask,SuspsList2,NewAttr2),
|
||
|
|
copy_term_nat(SuspsList,SuspsList3),
|
||
|
|
nth1(Position,SuspsList3,[Susp],RestSuspsList),
|
||
|
|
set_elems(RestSuspsList,[]),
|
||
|
|
make_attr(Total,Pattern,SuspsList3,NewAttr3),
|
||
|
|
get_target_module(Mod),
|
||
|
|
Body =
|
||
|
|
( get_attr(Var,Mod,TAttr) ->
|
||
|
|
TAttr = Attr,
|
||
|
|
( Mask /\ Pattern =:= Pattern ->
|
||
|
|
put_attr(Var, Mod, NewAttr1)
|
||
|
|
;
|
||
|
|
NewMask is Mask \/ Pattern,
|
||
|
|
put_attr(Var, Mod, NewAttr2)
|
||
|
|
)
|
||
|
|
;
|
||
|
|
put_attr(Var,Mod,NewAttr3)
|
||
|
|
).
|
||
|
|
|
||
|
|
%% detach_$CONSTRAINT
|
||
|
|
generate_detach_a_constraint(Constraint,[Clause1,Clause2]) :-
|
||
|
|
generate_detach_a_constraint_empty_list(Constraint,Clause1),
|
||
|
|
get_max_constraint_index(N),
|
||
|
|
( N == 1 ->
|
||
|
|
generate_detach_a_constraint_1_1(Constraint,Clause2)
|
||
|
|
;
|
||
|
|
generate_detach_a_constraint_t_p(Constraint,Clause2)
|
||
|
|
).
|
||
|
|
|
||
|
|
generate_detach_a_constraint_empty_list(FA,Clause) :-
|
||
|
|
make_name('detach_',FA,Fct),
|
||
|
|
Args = [[],_],
|
||
|
|
Head =.. [Fct | Args],
|
||
|
|
Clause = ( Head :- true).
|
||
|
|
|
||
|
|
generate_detach_a_constraint_1_1(FA,Clause) :-
|
||
|
|
make_name('detach_',FA,Fct),
|
||
|
|
Args = [[Var|Vars],Susp],
|
||
|
|
Head =.. [Fct | Args],
|
||
|
|
RecursiveCall =.. [Fct,Vars,Susp],
|
||
|
|
generate_detach_body_1(FA,Var,Susp,DetachBody),
|
||
|
|
Body =
|
||
|
|
(
|
||
|
|
DetachBody,
|
||
|
|
RecursiveCall
|
||
|
|
),
|
||
|
|
Clause = (Head :- Body).
|
||
|
|
|
||
|
|
generate_detach_body_1(FA,Var,Susp,Body) :-
|
||
|
|
get_target_module(Mod),
|
||
|
|
Body =
|
||
|
|
( get_attr(Var,Mod,Susps) ->
|
||
|
|
'chr sbag_del_element'(Susps,Susp,NewSusps),
|
||
|
|
( NewSusps == [] ->
|
||
|
|
del_attr(Var,Mod)
|
||
|
|
;
|
||
|
|
put_attr(Var,Mod,NewSusps)
|
||
|
|
)
|
||
|
|
;
|
||
|
|
true
|
||
|
|
).
|
||
|
|
|
||
|
|
generate_detach_a_constraint_t_p(FA,Clause) :-
|
||
|
|
make_name('detach_',FA,Fct),
|
||
|
|
Args = [[Var|Vars],Susp],
|
||
|
|
Head =.. [Fct | Args],
|
||
|
|
RecursiveCall =.. [Fct,Vars,Susp],
|
||
|
|
generate_detach_body_n(FA,Var,Susp,DetachBody),
|
||
|
|
Body =
|
||
|
|
(
|
||
|
|
DetachBody,
|
||
|
|
RecursiveCall
|
||
|
|
),
|
||
|
|
Clause = (Head :- Body).
|
||
|
|
|
||
|
|
generate_detach_body_n(F/A,Var,Susp,Body) :-
|
||
|
|
get_constraint_index(F/A,Position),
|
||
|
|
or_pattern(Position,Pattern),
|
||
|
|
and_pattern(Position,DelPattern),
|
||
|
|
get_max_constraint_index(Total),
|
||
|
|
make_attr(Total,Mask,SuspsList,Attr),
|
||
|
|
nth1(Position,SuspsList,Susps),
|
||
|
|
substitute_eq(Susps,SuspsList,[],SuspsList1),
|
||
|
|
make_attr(Total,NewMask,SuspsList1,Attr1),
|
||
|
|
substitute_eq(Susps,SuspsList,NewSusps,SuspsList2),
|
||
|
|
make_attr(Total,Mask,SuspsList2,Attr2),
|
||
|
|
get_target_module(Mod),
|
||
|
|
Body =
|
||
|
|
( get_attr(Var,Mod,TAttr) ->
|
||
|
|
TAttr = Attr,
|
||
|
|
( Mask /\ Pattern =:= Pattern ->
|
||
|
|
'chr sbag_del_element'(Susps,Susp,NewSusps),
|
||
|
|
( NewSusps == [] ->
|
||
|
|
NewMask is Mask /\ DelPattern,
|
||
|
|
( NewMask == 0 ->
|
||
|
|
del_attr(Var,Mod)
|
||
|
|
;
|
||
|
|
put_attr(Var,Mod,Attr1)
|
||
|
|
)
|
||
|
|
;
|
||
|
|
put_attr(Var,Mod,Attr2)
|
||
|
|
)
|
||
|
|
;
|
||
|
|
true
|
||
|
|
)
|
||
|
|
;
|
||
|
|
true
|
||
|
|
).
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
generate_indexed_variables_clauses(Constraints,Clauses) :-
|
||
|
|
( forsome(C,Constraints,chr_translate:may_trigger(C)) ->
|
||
|
|
generate_indexed_variables_clauses_(Constraints,Clauses)
|
||
|
|
;
|
||
|
|
Clauses = []
|
||
|
|
).
|
||
|
|
|
||
|
|
generate_indexed_variables_clauses_([],[]).
|
||
|
|
generate_indexed_variables_clauses_([C|Cs],Clauses) :-
|
||
|
|
( ( is_attached(C) ; chr_pp_flag(debugable,on)) ->
|
||
|
|
Clauses = [Clause|RestClauses],
|
||
|
|
generate_indexed_variables_clause(C,Clause)
|
||
|
|
;
|
||
|
|
Clauses = RestClauses
|
||
|
|
),
|
||
|
|
generate_indexed_variables_clauses_(Cs,RestClauses).
|
||
|
|
|
||
|
|
generate_indexed_variables_clause(F/A,Clause) :-
|
||
|
|
functor(Term,F,A),
|
||
|
|
get_constraint_mode(F/A,ArgModes),
|
||
|
|
Term =.. [_|Args],
|
||
|
|
create_indexed_variables_body(Args,ArgModes,Vars,1,F/A,MaybeBody,N),
|
||
|
|
( MaybeBody == empty ->
|
||
|
|
|
||
|
|
Body = (Vars = [])
|
||
|
|
; N == 0 ->
|
||
|
|
Body = term_variables(Susp,Vars)
|
||
|
|
;
|
||
|
|
MaybeBody = Body
|
||
|
|
),
|
||
|
|
Clause =
|
||
|
|
( '$indexed_variables'(Susp,Vars) :-
|
||
|
|
Susp = Term,
|
||
|
|
Body
|
||
|
|
).
|
||
|
|
|
||
|
|
create_indexed_variables_body([],[],_,_,_,empty,0).
|
||
|
|
create_indexed_variables_body([V|Vs],[Mode|Modes],Vars,I,FA,Body,N) :-
|
||
|
|
J is I + 1,
|
||
|
|
create_indexed_variables_body(Vs,Modes,Tail,J,FA,RBody,M),
|
||
|
|
( Mode \== (+),
|
||
|
|
is_indexed_argument(FA,I) ->
|
||
|
|
( RBody == empty ->
|
||
|
|
Body = term_variables(V,Vars)
|
||
|
|
;
|
||
|
|
Body = (term_variables(V,Vars,Tail),RBody)
|
||
|
|
),
|
||
|
|
N = M
|
||
|
|
;
|
||
|
|
Vars = Tail,
|
||
|
|
Body = RBody,
|
||
|
|
N is M + 1
|
||
|
|
).
|
||
|
|
|
||
|
|
generate_extra_clauses(Constraints,[A,B,C,D,E]) :-
|
||
|
|
( chr_pp_flag(reduced_indexing,on) ->
|
||
|
|
global_indexed_variables_clause(Constraints,D)
|
||
|
|
;
|
||
|
|
D =
|
||
|
|
( chr_indexed_variables(Susp,Vars) :-
|
||
|
|
'chr chr_indexed_variables'(Susp,Vars)
|
||
|
|
)
|
||
|
|
),
|
||
|
|
generate_remove_clause(A),
|
||
|
|
generate_activate_clause(B),
|
||
|
|
generate_allocate_clause(C),
|
||
|
|
generate_insert_constraint_internal(E).
|
||
|
|
|
||
|
|
generate_remove_clause(RemoveClause) :-
|
||
|
|
RemoveClause =
|
||
|
|
(
|
||
|
|
remove_constraint_internal(Susp, Agenda, Delete) :-
|
||
|
|
arg( 2, Susp, Mref),
|
||
|
|
'chr get_mutable'( State, Mref),
|
||
|
|
'chr update_mutable'( removed, Mref), % mark in any case
|
||
|
|
( compound(State) -> % passive/1
|
||
|
|
Agenda = [],
|
||
|
|
Delete = no
|
||
|
|
; State==removed ->
|
||
|
|
Agenda = [],
|
||
|
|
Delete = no
|
||
|
|
%; State==triggered ->
|
||
|
|
% Agenda = []
|
||
|
|
;
|
||
|
|
Delete = yes,
|
||
|
|
chr_indexed_variables(Susp,Agenda)
|
||
|
|
)
|
||
|
|
).
|
||
|
|
|
||
|
|
generate_activate_clause(ActivateClause) :-
|
||
|
|
ActivateClause =
|
||
|
|
(
|
||
|
|
activate_constraint(Store, Vars, Susp, Generation) :-
|
||
|
|
arg( 2, Susp, Mref),
|
||
|
|
'chr get_mutable'( State, Mref),
|
||
|
|
'chr update_mutable'( active, Mref),
|
||
|
|
( nonvar(Generation) -> % aih
|
||
|
|
true
|
||
|
|
;
|
||
|
|
arg( 4, Susp, Gref),
|
||
|
|
'chr get_mutable'( Gen, Gref),
|
||
|
|
Generation is Gen+1,
|
||
|
|
'chr update_mutable'( Generation, Gref)
|
||
|
|
),
|
||
|
|
( compound(State) -> % passive/1
|
||
|
|
term_variables( State, Vars),
|
||
|
|
'chr none_locked'( Vars),
|
||
|
|
Store = yes
|
||
|
|
; State == removed -> % the price for eager removal ...
|
||
|
|
chr_indexed_variables(Susp,Vars),
|
||
|
|
Store = yes
|
||
|
|
;
|
||
|
|
Vars = [],
|
||
|
|
Store = no
|
||
|
|
)
|
||
|
|
).
|
||
|
|
|
||
|
|
generate_allocate_clause(AllocateClause) :-
|
||
|
|
AllocateClause =
|
||
|
|
(
|
||
|
|
allocate_constraint( Closure, Self, F, Args) :-
|
||
|
|
Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args],
|
||
|
|
'chr create_mutable'(0,Gref), % Gref = mutable(0),
|
||
|
|
'chr empty_history'(History),
|
||
|
|
'chr create_mutable'(History,Href), % Href = mutable(History),
|
||
|
|
chr_indexed_variables(Self,Vars),
|
||
|
|
'chr create_mutable'(passive(Vars),Mref), % Mref = mutable(passive(Vars)),
|
||
|
|
'chr gen_id'( Id)
|
||
|
|
).
|
||
|
|
|
||
|
|
generate_insert_constraint_internal(Clause) :-
|
||
|
|
Clause =
|
||
|
|
(
|
||
|
|
insert_constraint_internal(yes, Vars, Self, Closure, F, Args) :-
|
||
|
|
Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args],
|
||
|
|
chr_indexed_variables(Self,Vars),
|
||
|
|
'chr none_locked'(Vars),
|
||
|
|
'chr create_mutable'(active,Mref), % Mref = mutable(active),
|
||
|
|
'chr create_mutable'(0,Gref), % Gref = mutable(0),
|
||
|
|
'chr empty_history'(History),
|
||
|
|
'chr create_mutable'(History,Href), % Href = mutable(History),
|
||
|
|
'chr gen_id'(Id)
|
||
|
|
).
|
||
|
|
|
||
|
|
global_indexed_variables_clause(Constraints,Clause) :-
|
||
|
|
( forsome(C,Constraints,chr_translate:may_trigger(C)) ->
|
||
|
|
Body = (Susp =.. [_,_,_,_,_,_,Term|_], '$indexed_variables'(Term,Vars))
|
||
|
|
;
|
||
|
|
Body = true,
|
||
|
|
Vars = []
|
||
|
|
),
|
||
|
|
Clause = ( chr_indexed_variables(Susp,Vars) :- Body ).
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
generate_attach_increment(Clauses) :-
|
||
|
|
get_max_constraint_index(N),
|
||
|
|
( N > 0 ->
|
||
|
|
Clauses = [Clause1,Clause2],
|
||
|
|
generate_attach_increment_empty(Clause1),
|
||
|
|
( N == 1 ->
|
||
|
|
generate_attach_increment_one(Clause2)
|
||
|
|
;
|
||
|
|
generate_attach_increment_many(N,Clause2)
|
||
|
|
)
|
||
|
|
;
|
||
|
|
Clauses = []
|
||
|
|
).
|
||
|
|
|
||
|
|
generate_attach_increment_empty((attach_increment([],_) :- true)).
|
||
|
|
|
||
|
|
generate_attach_increment_one(Clause) :-
|
||
|
|
Head = attach_increment([Var|Vars],Susps),
|
||
|
|
get_target_module(Mod),
|
||
|
|
Body =
|
||
|
|
(
|
||
|
|
'chr not_locked'(Var),
|
||
|
|
( get_attr(Var,Mod,VarSusps) ->
|
||
|
|
sort(VarSusps,SortedVarSusps),
|
||
|
|
merge(Susps,SortedVarSusps,MergedSusps),
|
||
|
|
put_attr(Var,Mod,MergedSusps)
|
||
|
|
;
|
||
|
|
put_attr(Var,Mod,Susps)
|
||
|
|
),
|
||
|
|
attach_increment(Vars,Susps)
|
||
|
|
),
|
||
|
|
Clause = (Head :- Body).
|
||
|
|
|
||
|
|
generate_attach_increment_many(N,Clause) :-
|
||
|
|
make_attr(N,Mask,SuspsList,Attr),
|
||
|
|
make_attr(N,OtherMask,OtherSuspsList,OtherAttr),
|
||
|
|
Head = attach_increment([Var|Vars],Attr),
|
||
|
|
bagof(G,X ^ Y ^ SY ^ M ^ (member2(SuspsList,OtherSuspsList,X-Y),G = (sort(Y,SY),'chr merge_attributes'(X,SY,M))),Gs),
|
||
|
|
list2conj(Gs,SortGoals),
|
||
|
|
bagof(MS,A ^ B ^ C ^ member((A,'chr merge_attributes'(B,C,MS)),Gs), MergedSuspsList),
|
||
|
|
make_attr(N,MergedMask,MergedSuspsList,NewAttr),
|
||
|
|
get_target_module(Mod),
|
||
|
|
Body =
|
||
|
|
(
|
||
|
|
'chr not_locked'(Var),
|
||
|
|
( get_attr(Var,Mod,TOtherAttr) ->
|
||
|
|
TOtherAttr = OtherAttr,
|
||
|
|
SortGoals,
|
||
|
|
MergedMask is Mask \/ OtherMask,
|
||
|
|
put_attr(Var,Mod,NewAttr)
|
||
|
|
;
|
||
|
|
put_attr(Var,Mod,Attr)
|
||
|
|
),
|
||
|
|
attach_increment(Vars,Attr)
|
||
|
|
),
|
||
|
|
Clause = (Head :- Body).
|
||
|
|
|
||
|
|
%% attr_unify_hook
|
||
|
|
generate_attr_unify_hook([Clause]) :-
|
||
|
|
get_max_constraint_index(N),
|
||
|
|
( N == 0 ->
|
||
|
|
get_target_module(Mod),
|
||
|
|
Clause =
|
||
|
|
( attr_unify_hook(Attr,Var) :-
|
||
|
|
write('ERROR: Unexpected triggering of attr_unify_hook/2 in module '),
|
||
|
|
writeln(Mod)
|
||
|
|
)
|
||
|
|
; N == 1 ->
|
||
|
|
generate_attr_unify_hook_one(Clause)
|
||
|
|
;
|
||
|
|
generate_attr_unify_hook_many(N,Clause)
|
||
|
|
).
|
||
|
|
|
||
|
|
generate_attr_unify_hook_one(Clause) :-
|
||
|
|
Head = attr_unify_hook(Susps,Other),
|
||
|
|
get_target_module(Mod),
|
||
|
|
make_run_suspensions(NewSusps,WakeNewSusps),
|
||
|
|
make_run_suspensions(Susps,WakeSusps),
|
||
|
|
Body =
|
||
|
|
(
|
||
|
|
sort(Susps, SortedSusps),
|
||
|
|
( var(Other) ->
|
||
|
|
( get_attr(Other,Mod,OtherSusps) ->
|
||
|
|
true
|
||
|
|
;
|
||
|
|
OtherSusps = []
|
||
|
|
),
|
||
|
|
sort(OtherSusps,SortedOtherSusps),
|
||
|
|
'chr merge_attributes'(SortedSusps,SortedOtherSusps,NewSusps),
|
||
|
|
put_attr(Other,Mod,NewSusps),
|
||
|
|
WakeNewSusps
|
||
|
|
;
|
||
|
|
( compound(Other) ->
|
||
|
|
term_variables(Other,OtherVars),
|
||
|
|
attach_increment(OtherVars, SortedSusps)
|
||
|
|
;
|
||
|
|
true
|
||
|
|
),
|
||
|
|
WakeSusps
|
||
|
|
)
|
||
|
|
),
|
||
|
|
Clause = (Head :- Body).
|
||
|
|
|
||
|
|
generate_attr_unify_hook_many(N,Clause) :-
|
||
|
|
make_attr(N,Mask,SuspsList,Attr),
|
||
|
|
make_attr(N,OtherMask,OtherSuspsList,OtherAttr),
|
||
|
|
bagof(Sort,A ^ B ^ ( member(A,SuspsList) , Sort = sort(A,B) ) , SortGoalList),
|
||
|
|
list2conj(SortGoalList,SortGoals),
|
||
|
|
bagof(B, A ^ member(sort(A,B),SortGoalList), SortedSuspsList),
|
||
|
|
bagof(C, D ^ E ^ F ^ G ^ (member2(SortedSuspsList,OtherSuspsList,D-E),
|
||
|
|
C = (sort(E,F),
|
||
|
|
'chr merge_attributes'(D,F,G)) ),
|
||
|
|
SortMergeGoalList),
|
||
|
|
bagof(G, D ^ F ^ H ^ member((H,'chr merge_attributes'(D,F,G)),SortMergeGoalList) , MergedSuspsList),
|
||
|
|
list2conj(SortMergeGoalList,SortMergeGoals),
|
||
|
|
make_attr(N,MergedMask,MergedSuspsList,MergedAttr),
|
||
|
|
make_attr(N,Mask,SortedSuspsList,SortedAttr),
|
||
|
|
Head = attr_unify_hook(Attr,Other),
|
||
|
|
get_target_module(Mod),
|
||
|
|
make_run_suspensions_loop(MergedSuspsList,WakeMergedSusps),
|
||
|
|
make_run_suspensions_loop(SortedSuspsList,WakeSortedSusps),
|
||
|
|
Body =
|
||
|
|
(
|
||
|
|
SortGoals,
|
||
|
|
( var(Other) ->
|
||
|
|
( get_attr(Other,Mod,TOtherAttr) ->
|
||
|
|
TOtherAttr = OtherAttr,
|
||
|
|
SortMergeGoals,
|
||
|
|
MergedMask is Mask \/ OtherMask,
|
||
|
|
put_attr(Other,Mod,MergedAttr),
|
||
|
|
WakeMergedSusps
|
||
|
|
;
|
||
|
|
put_attr(Other,Mod,SortedAttr),
|
||
|
|
WakeSortedSusps
|
||
|
|
)
|
||
|
|
;
|
||
|
|
( compound(Other) ->
|
||
|
|
term_variables(Other,OtherVars),
|
||
|
|
attach_increment(OtherVars,SortedAttr)
|
||
|
|
;
|
||
|
|
true
|
||
|
|
),
|
||
|
|
WakeSortedSusps
|
||
|
|
)
|
||
|
|
),
|
||
|
|
Clause = (Head :- Body).
|
||
|
|
|
||
|
|
make_run_suspensions(Susps,Goal) :-
|
||
|
|
( chr_pp_flag(debugable,on) ->
|
||
|
|
Goal = 'chr run_suspensions_d'(Susps)
|
||
|
|
;
|
||
|
|
Goal = 'chr run_suspensions'(Susps)
|
||
|
|
).
|
||
|
|
|
||
|
|
make_run_suspensions_loop(SuspsList,Goal) :-
|
||
|
|
( chr_pp_flag(debugable,on) ->
|
||
|
|
Goal = 'chr run_suspensions_loop_d'(SuspsList)
|
||
|
|
;
|
||
|
|
Goal = 'chr run_suspensions_loop'(SuspsList)
|
||
|
|
).
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
% $insert_in_store_F/A
|
||
|
|
% $delete_from_store_F/A
|
||
|
|
|
||
|
|
generate_insert_delete_constraints([],[]).
|
||
|
|
generate_insert_delete_constraints([FA|Rest],Clauses) :-
|
||
|
|
( is_attached(FA) ->
|
||
|
|
Clauses = [IClause,DClause|RestClauses],
|
||
|
|
generate_insert_delete_constraint(FA,IClause,DClause)
|
||
|
|
;
|
||
|
|
Clauses = RestClauses
|
||
|
|
),
|
||
|
|
generate_insert_delete_constraints(Rest,RestClauses).
|
||
|
|
|
||
|
|
generate_insert_delete_constraint(FA,IClause,DClause) :-
|
||
|
|
get_store_type(FA,StoreType),
|
||
|
|
generate_insert_constraint(StoreType,FA,IClause),
|
||
|
|
generate_delete_constraint(StoreType,FA,DClause).
|
||
|
|
|
||
|
|
generate_insert_constraint(StoreType,C,Clause) :-
|
||
|
|
make_name('$insert_in_store_',C,ClauseName),
|
||
|
|
Head =.. [ClauseName,Susp],
|
||
|
|
generate_insert_constraint_body(StoreType,C,Susp,Body),
|
||
|
|
Clause = (Head :- Body).
|
||
|
|
|
||
|
|
generate_insert_constraint_body(default,C,Susp,Body) :-
|
||
|
|
get_target_module(Mod),
|
||
|
|
get_max_constraint_index(Total),
|
||
|
|
( Total == 1 ->
|
||
|
|
generate_attach_body_1(C,Store,Susp,AttachBody)
|
||
|
|
;
|
||
|
|
generate_attach_body_n(C,Store,Susp,AttachBody)
|
||
|
|
),
|
||
|
|
Body =
|
||
|
|
(
|
||
|
|
'chr default_store'(Store),
|
||
|
|
AttachBody
|
||
|
|
).
|
||
|
|
generate_insert_constraint_body(multi_hash(Indexes),C,Susp,Body) :-
|
||
|
|
generate_multi_hash_insert_constraint_bodies(Indexes,C,Susp,Body).
|
||
|
|
generate_insert_constraint_body(global_ground,C,Susp,Body) :-
|
||
|
|
global_ground_store_name(C,StoreName),
|
||
|
|
make_get_store_goal(StoreName,Store,GetStoreGoal),
|
||
|
|
make_update_store_goal(StoreName,[Susp|Store],UpdateStoreGoal),
|
||
|
|
Body =
|
||
|
|
(
|
||
|
|
GetStoreGoal, % nb_getval(StoreName,Store),
|
||
|
|
UpdateStoreGoal % b_setval(StoreName,[Susp|Store])
|
||
|
|
).
|
||
|
|
generate_insert_constraint_body(multi_store(StoreTypes),C,Susp,Body) :-
|
||
|
|
find_with_var_identity(
|
||
|
|
B,
|
||
|
|
[Susp],
|
||
|
|
(
|
||
|
|
member(ST,StoreTypes),
|
||
|
|
chr_translate:generate_insert_constraint_body(ST,C,Susp,B)
|
||
|
|
),
|
||
|
|
Bodies
|
||
|
|
),
|
||
|
|
list2conj(Bodies,Body).
|
||
|
|
|
||
|
|
generate_multi_hash_insert_constraint_bodies([],_,_,true).
|
||
|
|
generate_multi_hash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
|
||
|
|
multi_hash_store_name(FA,Index,StoreName),
|
||
|
|
multi_hash_key(FA,Index,Susp,KeyBody,Key),
|
||
|
|
make_get_store_goal(StoreName,Store,GetStoreGoal),
|
||
|
|
Body =
|
||
|
|
(
|
||
|
|
KeyBody,
|
||
|
|
GetStoreGoal, % nb_getval(StoreName,Store),
|
||
|
|
insert_ht(Store,Key,Susp)
|
||
|
|
),
|
||
|
|
generate_multi_hash_insert_constraint_bodies(Indexes,FA,Susp,Bodies).
|
||
|
|
|
||
|
|
generate_delete_constraint(StoreType,FA,Clause) :-
|
||
|
|
make_name('$delete_from_store_',FA,ClauseName),
|
||
|
|
Head =.. [ClauseName,Susp],
|
||
|
|
generate_delete_constraint_body(StoreType,FA,Susp,Body),
|
||
|
|
Clause = (Head :- Body).
|
||
|
|
|
||
|
|
generate_delete_constraint_body(default,C,Susp,Body) :-
|
||
|
|
get_target_module(Mod),
|
||
|
|
get_max_constraint_index(Total),
|
||
|
|
( Total == 1 ->
|
||
|
|
generate_detach_body_1(C,Store,Susp,DetachBody),
|
||
|
|
Body =
|
||
|
|
(
|
||
|
|
'chr default_store'(Store),
|
||
|
|
DetachBody
|
||
|
|
)
|
||
|
|
;
|
||
|
|
generate_detach_body_n(C,Store,Susp,DetachBody),
|
||
|
|
Body =
|
||
|
|
(
|
||
|
|
'chr default_store'(Store),
|
||
|
|
DetachBody
|
||
|
|
)
|
||
|
|
).
|
||
|
|
generate_delete_constraint_body(multi_hash(Indexes),C,Susp,Body) :-
|
||
|
|
generate_multi_hash_delete_constraint_bodies(Indexes,C,Susp,Body).
|
||
|
|
generate_delete_constraint_body(global_ground,C,Susp,Body) :-
|
||
|
|
global_ground_store_name(C,StoreName),
|
||
|
|
make_get_store_goal(StoreName,Store,GetStoreGoal),
|
||
|
|
make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
|
||
|
|
Body =
|
||
|
|
(
|
||
|
|
GetStoreGoal, % nb_getval(StoreName,Store),
|
||
|
|
'chr sbag_del_element'(Store,Susp,NStore),
|
||
|
|
UpdateStoreGoal % b_setval(StoreName,NStore)
|
||
|
|
).
|
||
|
|
generate_delete_constraint_body(multi_store(StoreTypes),C,Susp,Body) :-
|
||
|
|
find_with_var_identity(
|
||
|
|
B,
|
||
|
|
[Susp],
|
||
|
|
(
|
||
|
|
member(ST,StoreTypes),
|
||
|
|
chr_translate:generate_delete_constraint_body(ST,C,Susp,B)
|
||
|
|
),
|
||
|
|
Bodies
|
||
|
|
),
|
||
|
|
list2conj(Bodies,Body).
|
||
|
|
|
||
|
|
generate_multi_hash_delete_constraint_bodies([],_,_,true).
|
||
|
|
generate_multi_hash_delete_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
|
||
|
|
multi_hash_store_name(FA,Index,StoreName),
|
||
|
|
multi_hash_key(FA,Index,Susp,KeyBody,Key),
|
||
|
|
make_get_store_goal(StoreName,Store,GetStoreGoal),
|
||
|
|
Body =
|
||
|
|
(
|
||
|
|
KeyBody,
|
||
|
|
GetStoreGoal, % nb_getval(StoreName,Store),
|
||
|
|
delete_ht(Store,Key,Susp)
|
||
|
|
),
|
||
|
|
generate_multi_hash_delete_constraint_bodies(Indexes,FA,Susp,Bodies).
|
||
|
|
|
||
|
|
generate_delete_constraint_call(FA,Susp,Call) :-
|
||
|
|
make_name('$delete_from_store_',FA,Functor),
|
||
|
|
Call =.. [Functor,Susp].
|
||
|
|
|
||
|
|
generate_insert_constraint_call(FA,Susp,Call) :-
|
||
|
|
make_name('$insert_in_store_',FA,Functor),
|
||
|
|
Call =.. [Functor,Susp].
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
|
||
|
|
generate_store_code(Constraints,[Enumerate|L]) :-
|
||
|
|
enumerate_stores_code(Constraints,Enumerate),
|
||
|
|
generate_store_code(Constraints,L,[]).
|
||
|
|
|
||
|
|
generate_store_code([],L,L).
|
||
|
|
generate_store_code([C|Cs],L,T) :-
|
||
|
|
get_store_type(C,StoreType),
|
||
|
|
generate_store_code(StoreType,C,L,L1),
|
||
|
|
generate_store_code(Cs,L1,T).
|
||
|
|
|
||
|
|
generate_store_code(default,_,L,L).
|
||
|
|
generate_store_code(multi_hash(Indexes),C,L,T) :-
|
||
|
|
multi_hash_store_initialisations(Indexes,C,L,L1),
|
||
|
|
multi_hash_via_lookups(Indexes,C,L1,T).
|
||
|
|
generate_store_code(global_ground,C,L,T) :-
|
||
|
|
global_ground_store_initialisation(C,L,T).
|
||
|
|
generate_store_code(multi_store(StoreTypes),C,L,T) :-
|
||
|
|
multi_store_generate_store_code(StoreTypes,C,L,T).
|
||
|
|
|
||
|
|
multi_store_generate_store_code([],_,L,L).
|
||
|
|
multi_store_generate_store_code([ST|STs],C,L,T) :-
|
||
|
|
generate_store_code(ST,C,L,L1),
|
||
|
|
multi_store_generate_store_code(STs,C,L1,T).
|
||
|
|
|
||
|
|
multi_hash_store_initialisations([],_,L,L).
|
||
|
|
multi_hash_store_initialisations([Index|Indexes],FA,L,T) :-
|
||
|
|
multi_hash_store_name(FA,Index,StoreName),
|
||
|
|
make_init_store_goal(StoreName,HT,InitStoreGoal),
|
||
|
|
L = [(:- (new_ht(HT),InitStoreGoal)) | L1],
|
||
|
|
multi_hash_store_initialisations(Indexes,FA,L1,T).
|
||
|
|
|
||
|
|
global_ground_store_initialisation(C,L,T) :-
|
||
|
|
global_ground_store_name(C,StoreName),
|
||
|
|
make_init_store_goal(StoreName,[],InitStoreGoal),
|
||
|
|
L = [(:- InitStoreGoal)|T].
|
||
|
|
|
||
|
|
multi_hash_via_lookups([],_,L,L).
|
||
|
|
multi_hash_via_lookups([Index|Indexes],C,L,T) :-
|
||
|
|
multi_hash_via_lookup_name(C,Index,PredName),
|
||
|
|
Head =.. [PredName,Key,SuspsList],
|
||
|
|
multi_hash_store_name(C,Index,StoreName),
|
||
|
|
make_get_store_goal(StoreName,HT,GetStoreGoal),
|
||
|
|
Body =
|
||
|
|
(
|
||
|
|
GetStoreGoal, % nb_getval(StoreName,HT),
|
||
|
|
lookup_ht(HT,Key,SuspsList)
|
||
|
|
),
|
||
|
|
L = [(Head :- Body)|L1],
|
||
|
|
multi_hash_via_lookups(Indexes,C,L1,T).
|
||
|
|
|
||
|
|
multi_hash_via_lookup_name(F/A,Index,Name) :-
|
||
|
|
( integer(Index) ->
|
||
|
|
IndexName = Index
|
||
|
|
; is_list(Index) ->
|
||
|
|
atom_concat_list(Index,IndexName)
|
||
|
|
),
|
||
|
|
atom_concat_list(['$via1_multi_hash_',F,(/),A,'-',IndexName],Name).
|
||
|
|
|
||
|
|
multi_hash_store_name(F/A,Index,Name) :-
|
||
|
|
get_target_module(Mod),
|
||
|
|
( integer(Index) ->
|
||
|
|
IndexName = Index
|
||
|
|
; is_list(Index) ->
|
||
|
|
atom_concat_list(Index,IndexName)
|
||
|
|
),
|
||
|
|
atom_concat_list(['$chr_store_multi_hash_',Mod,(:),F,(/),A,'-',IndexName],Name).
|
||
|
|
|
||
|
|
multi_hash_key(F/A,Index,Susp,KeyBody,Key) :-
|
||
|
|
( ( integer(Index) ->
|
||
|
|
I = Index
|
||
|
|
;
|
||
|
|
Index = [I]
|
||
|
|
) ->
|
||
|
|
SuspIndex is I + 6,
|
||
|
|
KeyBody = arg(SuspIndex,Susp,Key)
|
||
|
|
; is_list(Index) ->
|
||
|
|
sort(Index,Indexes),
|
||
|
|
find_with_var_identity(arg(J,Susp,KeyI)-KeyI,[Susp],(member(I,Indexes),J is I + 6),ArgKeyPairs),
|
||
|
|
pairup(Bodies,Keys,ArgKeyPairs),
|
||
|
|
Key =.. [k|Keys],
|
||
|
|
list2conj(Bodies,KeyBody)
|
||
|
|
).
|
||
|
|
|
||
|
|
multi_hash_key_args(Index,Head,KeyArgs) :-
|
||
|
|
( integer(Index) ->
|
||
|
|
arg(Index,Head,Arg),
|
||
|
|
KeyArgs = [Arg]
|
||
|
|
; is_list(Index) ->
|
||
|
|
sort(Index,Indexes),
|
||
|
|
term_variables(Head,Vars),
|
||
|
|
find_with_var_identity(Arg,Vars,(member(I,Indexes), arg(I,Head,Arg)),KeyArgs)
|
||
|
|
).
|
||
|
|
|
||
|
|
global_ground_store_name(F/A,Name) :-
|
||
|
|
get_target_module(Mod),
|
||
|
|
atom_concat_list(['$chr_store_global_ground_',Mod,(:),F,(/),A],Name).
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
enumerate_stores_code(Constraints,Clause) :-
|
||
|
|
Head = '$enumerate_suspensions'(Susp),
|
||
|
|
enumerate_store_bodies(Constraints,Susp,Bodies),
|
||
|
|
list2disj(Bodies,Body),
|
||
|
|
Clause = (Head :- Body).
|
||
|
|
|
||
|
|
enumerate_store_bodies([],_,[]).
|
||
|
|
enumerate_store_bodies([C|Cs],Susp,L) :-
|
||
|
|
( is_attached(C) ->
|
||
|
|
get_store_type(C,StoreType),
|
||
|
|
enumerate_store_body(StoreType,C,Susp,B),
|
||
|
|
L = [B|T]
|
||
|
|
;
|
||
|
|
L = T
|
||
|
|
),
|
||
|
|
enumerate_store_bodies(Cs,Susp,T).
|
||
|
|
|
||
|
|
enumerate_store_body(default,C,Susp,Body) :-
|
||
|
|
get_constraint_index(C,Index),
|
||
|
|
get_target_module(Mod),
|
||
|
|
get_max_constraint_index(MaxIndex),
|
||
|
|
Body1 =
|
||
|
|
(
|
||
|
|
'chr default_store'(GlobalStore),
|
||
|
|
get_attr(GlobalStore,Mod,Attr)
|
||
|
|
),
|
||
|
|
( MaxIndex > 1 ->
|
||
|
|
NIndex is Index + 1,
|
||
|
|
Body2 =
|
||
|
|
(
|
||
|
|
arg(NIndex,Attr,List),
|
||
|
|
'chr sbag_member'(Susp,List)
|
||
|
|
)
|
||
|
|
;
|
||
|
|
Body2 = 'chr sbag_member'(Susp,Attr)
|
||
|
|
),
|
||
|
|
Body = (Body1,Body2).
|
||
|
|
enumerate_store_body(multi_hash([Index|_]),C,Susp,Body) :-
|
||
|
|
multi_hash_enumerate_store_body(Index,C,Susp,Body).
|
||
|
|
enumerate_store_body(global_ground,C,Susp,Body) :-
|
||
|
|
global_ground_store_name(C,StoreName),
|
||
|
|
make_get_store_goal(StoreName,List,GetStoreGoal),
|
||
|
|
Body =
|
||
|
|
(
|
||
|
|
GetStoreGoal, % nb_getval(StoreName,List),
|
||
|
|
'chr sbag_member'(Susp,List)
|
||
|
|
).
|
||
|
|
enumerate_store_body(multi_store(STs),C,Susp,Body) :-
|
||
|
|
once((
|
||
|
|
member(ST,STs),
|
||
|
|
enumerate_store_body(ST,C,Susp,Body)
|
||
|
|
)).
|
||
|
|
|
||
|
|
multi_hash_enumerate_store_body(I,C,Susp,B) :-
|
||
|
|
multi_hash_store_name(C,I,StoreName),
|
||
|
|
make_get_store_goal(StoreName,HT,GetStoreGoal),
|
||
|
|
B =
|
||
|
|
(
|
||
|
|
GetStoreGoal, % nb_getval(StoreName,HT),
|
||
|
|
value_ht(HT,Susp)
|
||
|
|
).
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
check_attachments(Constraints) :-
|
||
|
|
( chr_pp_flag(check_attachments,on) ->
|
||
|
|
check_constraint_attachments(Constraints)
|
||
|
|
;
|
||
|
|
true
|
||
|
|
).
|
||
|
|
|
||
|
|
check_constraint_attachments([]).
|
||
|
|
check_constraint_attachments([C|Cs]) :-
|
||
|
|
check_constraint_attachment(C),
|
||
|
|
check_constraint_attachments(Cs).
|
||
|
|
|
||
|
|
check_constraint_attachment(C) :-
|
||
|
|
get_max_occurrence(C,MO),
|
||
|
|
check_occurrences_attachment(C,1,MO).
|
||
|
|
|
||
|
|
check_occurrences_attachment(C,O,MO) :-
|
||
|
|
( O > MO ->
|
||
|
|
true
|
||
|
|
;
|
||
|
|
check_occurrence_attachment(C,O),
|
||
|
|
NO is O + 1,
|
||
|
|
check_occurrences_attachment(C,NO,MO)
|
||
|
|
).
|
||
|
|
|
||
|
|
check_occurrence_attachment(C,O) :-
|
||
|
|
get_occurrence(C,O,RuleNb,ID),
|
||
|
|
get_rule(RuleNb,PragmaRule),
|
||
|
|
PragmaRule = pragma(rule(Heads1,Heads2,Guard,Body),ids(IDs1,IDs2),_,_,_),
|
||
|
|
( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
|
||
|
|
check_attachment_head1(Head1,ID,RuleNb,Heads1,Heads2,Guard)
|
||
|
|
; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
|
||
|
|
check_attachment_head2(Head2,ID,RuleNb,Heads1,Body)
|
||
|
|
).
|
||
|
|
|
||
|
|
check_attachment_head1(C,ID,RuleNb,H1,H2,G) :-
|
||
|
|
functor(C,F,A),
|
||
|
|
( H1 == [C],
|
||
|
|
H2 == [],
|
||
|
|
G == true,
|
||
|
|
C =.. [_|L],
|
||
|
|
no_matching(L,[]),
|
||
|
|
\+ is_passive(RuleNb,ID) ->
|
||
|
|
attached(F/A,no)
|
||
|
|
;
|
||
|
|
attached(F/A,maybe)
|
||
|
|
).
|
||
|
|
|
||
|
|
no_matching([],_).
|
||
|
|
no_matching([X|Xs],Prev) :-
|
||
|
|
var(X),
|
||
|
|
\+ memberchk_eq(X,Prev),
|
||
|
|
no_matching(Xs,[X|Prev]).
|
||
|
|
|
||
|
|
check_attachment_head2(C,ID,RuleNb,H1,B) :-
|
||
|
|
functor(C,F,A),
|
||
|
|
( is_passive(RuleNb,ID) ->
|
||
|
|
attached(F/A,maybe)
|
||
|
|
; H1 \== [],
|
||
|
|
B == true ->
|
||
|
|
attached(F/A,maybe)
|
||
|
|
;
|
||
|
|
attached(F/A,yes)
|
||
|
|
).
|
||
|
|
|
||
|
|
all_attached([]).
|
||
|
|
all_attached([C|Cs]) :-
|
||
|
|
functor(C,F,A),
|
||
|
|
is_attached(F/A),
|
||
|
|
all_attached(Cs).
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
|
||
|
|
set_constraint_indices([],M) :-
|
||
|
|
N is M - 1,
|
||
|
|
max_constraint_index(N).
|
||
|
|
set_constraint_indices([C|Cs],N) :-
|
||
|
|
( ( may_trigger(C) ; is_attached(C), get_store_type(C,default)) ->
|
||
|
|
constraint_index(C,N),
|
||
|
|
M is N + 1,
|
||
|
|
set_constraint_indices(Cs,M)
|
||
|
|
;
|
||
|
|
set_constraint_indices(Cs,N)
|
||
|
|
).
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
%% ____ _ ____ _ _ _ _
|
||
|
|
%% | _ \ _ _| | ___ / ___|___ _ __ ___ _ __ (_) | __ _| |_(_) ___ _ __
|
||
|
|
%% | |_) | | | | |/ _ \ | | / _ \| '_ ` _ \| '_ \| | |/ _` | __| |/ _ \| '_ \
|
||
|
|
%% | _ <| |_| | | __/ | |__| (_) | | | | | | |_) | | | (_| | |_| | (_) | | | |
|
||
|
|
%% |_| \_\\__,_|_|\___| \____\___/|_| |_| |_| .__/|_|_|\__,_|\__|_|\___/|_| |_|
|
||
|
|
%% |_|
|
||
|
|
|
||
|
|
constraints_code(Constraints,Rules,Clauses) :-
|
||
|
|
post_constraints(Constraints,1),
|
||
|
|
constraints_code1(1,Rules,L,[]),
|
||
|
|
clean_clauses(L,Clauses).
|
||
|
|
|
||
|
|
%% Add global data
|
||
|
|
post_constraints([],MaxIndex1) :-
|
||
|
|
MaxIndex is MaxIndex1 - 1,
|
||
|
|
constraint_count(MaxIndex).
|
||
|
|
post_constraints([F/A|Cs],N) :-
|
||
|
|
constraint(F/A,N),
|
||
|
|
M is N + 1,
|
||
|
|
post_constraints(Cs,M).
|
||
|
|
constraints_code1(I,Rules,L,T) :-
|
||
|
|
get_constraint_count(N),
|
||
|
|
( I > N ->
|
||
|
|
T = L
|
||
|
|
;
|
||
|
|
constraint_code(I,Rules,L,T1),
|
||
|
|
J is I + 1,
|
||
|
|
constraints_code1(J,Rules,T1,T)
|
||
|
|
).
|
||
|
|
|
||
|
|
%% Generate code for a single CHR constraint
|
||
|
|
constraint_code(I, Rules, L, T) :-
|
||
|
|
get_constraint(Constraint,I),
|
||
|
|
constraint_prelude(Constraint,Clause),
|
||
|
|
L = [Clause | L1],
|
||
|
|
Id1 = [0],
|
||
|
|
rules_code(Rules,I,Id1,Id2,L1,L2),
|
||
|
|
gen_cond_attach_clause(Constraint,Id2,L2,T).
|
||
|
|
|
||
|
|
%% Generate prelude predicate for a constraint.
|
||
|
|
%% f(...) :- f/a_0(...,Susp).
|
||
|
|
constraint_prelude(F/A, Clause) :-
|
||
|
|
vars_susp(A,Vars,Susp,VarsSusp),
|
||
|
|
Head =.. [ F | Vars],
|
||
|
|
build_head(F,A,[0],VarsSusp,Delegate),
|
||
|
|
get_target_module(Mod),
|
||
|
|
FTerm =.. [F|Vars],
|
||
|
|
( chr_pp_flag(debugable,on) ->
|
||
|
|
Clause =
|
||
|
|
( Head :-
|
||
|
|
allocate_constraint(Mod : Delegate, Susp, FTerm, Vars),
|
||
|
|
(
|
||
|
|
'chr debug_event'(call(Susp)),
|
||
|
|
Delegate
|
||
|
|
;
|
||
|
|
'chr debug_event'(fail(Susp)), !,
|
||
|
|
fail
|
||
|
|
),
|
||
|
|
(
|
||
|
|
'chr debug_event'(exit(Susp))
|
||
|
|
;
|
||
|
|
'chr debug_event'(redo(Susp)),
|
||
|
|
fail
|
||
|
|
)
|
||
|
|
)
|
||
|
|
;
|
||
|
|
Clause = ( Head :- Delegate )
|
||
|
|
).
|
||
|
|
|
||
|
|
gen_cond_attach_clause(F/A,Id,L,T) :-
|
||
|
|
( is_attached(F/A) ->
|
||
|
|
( Id == [0] ->
|
||
|
|
( may_trigger(F/A) ->
|
||
|
|
gen_cond_attach_goal(F/A,Body,AllArgs,Args,Susp)
|
||
|
|
;
|
||
|
|
gen_insert_constraint_internal_goal(F/A,Body,AllArgs,Args,Susp)
|
||
|
|
)
|
||
|
|
; vars_susp(A,Args,Susp,AllArgs),
|
||
|
|
gen_uncond_attach_goal(F/A,Susp,Body,_)
|
||
|
|
),
|
||
|
|
( chr_pp_flag(debugable,on) ->
|
||
|
|
Constraint =.. [F|Args],
|
||
|
|
DebugEvent = 'chr debug_event'(insert(Constraint#Susp))
|
||
|
|
;
|
||
|
|
DebugEvent = true
|
||
|
|
),
|
||
|
|
build_head(F,A,Id,AllArgs,Head),
|
||
|
|
Clause = ( Head :- DebugEvent,Body ),
|
||
|
|
L = [Clause | T]
|
||
|
|
;
|
||
|
|
L = T
|
||
|
|
).
|
||
|
|
|
||
|
|
gen_cond_attach_goal(F/A,Goal,AllArgs,Args,Susp) :-
|
||
|
|
vars_susp(A,Args,Susp,AllArgs),
|
||
|
|
build_head(F,A,[0],AllArgs,Closure),
|
||
|
|
( may_trigger(F/A) ->
|
||
|
|
make_name('attach_',F/A,AttachF),
|
||
|
|
Attach =.. [AttachF,Vars,Susp]
|
||
|
|
;
|
||
|
|
Attach = true
|
||
|
|
),
|
||
|
|
get_target_module(Mod),
|
||
|
|
FTerm =.. [F|Args],
|
||
|
|
generate_insert_constraint_call(F/A,Susp,InsertCall),
|
||
|
|
Goal =
|
||
|
|
(
|
||
|
|
( var(Susp) ->
|
||
|
|
insert_constraint_internal(Stored,Vars,Susp,Mod:Closure,FTerm,Args)
|
||
|
|
;
|
||
|
|
activate_constraint(Stored,Vars,Susp,_)
|
||
|
|
),
|
||
|
|
( Stored == yes ->
|
||
|
|
InsertCall,
|
||
|
|
Attach
|
||
|
|
;
|
||
|
|
true
|
||
|
|
)
|
||
|
|
).
|
||
|
|
|
||
|
|
gen_insert_constraint_internal_goal(F/A,Goal,AllArgs,Args,Susp) :-
|
||
|
|
vars_susp(A,Args,Susp,AllArgs),
|
||
|
|
build_head(F,A,[0],AllArgs,Closure),
|
||
|
|
( may_trigger(F/A) ->
|
||
|
|
make_name('attach_',F/A,AttachF),
|
||
|
|
Attach =.. [AttachF,Vars,Susp]
|
||
|
|
;
|
||
|
|
Attach = true
|
||
|
|
),
|
||
|
|
get_target_module(Mod),
|
||
|
|
FTerm =.. [F|Args],
|
||
|
|
generate_insert_constraint_call(F/A,Susp,InsertCall),
|
||
|
|
Goal =
|
||
|
|
(
|
||
|
|
insert_constraint_internal(_,Vars,Susp,Mod:Closure,FTerm,Args),
|
||
|
|
InsertCall,
|
||
|
|
Attach
|
||
|
|
).
|
||
|
|
|
||
|
|
gen_uncond_attach_goal(FA,Susp,AttachGoal,Generation) :-
|
||
|
|
( may_trigger(FA) ->
|
||
|
|
make_name('attach_',FA,AttachF),
|
||
|
|
Attach =.. [AttachF,Vars,Susp]
|
||
|
|
;
|
||
|
|
Attach = true
|
||
|
|
),
|
||
|
|
generate_insert_constraint_call(FA,Susp,InsertCall),
|
||
|
|
AttachGoal =
|
||
|
|
(
|
||
|
|
activate_constraint(Stored,Vars, Susp, Generation),
|
||
|
|
( Stored == yes ->
|
||
|
|
InsertCall,
|
||
|
|
Attach
|
||
|
|
;
|
||
|
|
true
|
||
|
|
)
|
||
|
|
).
|
||
|
|
|
||
|
|
%% Generate all the code for a constraint based on all CHR rules
|
||
|
|
rules_code([],_,Id,Id,L,L).
|
||
|
|
rules_code([R |Rs],I,Id1,Id3,L,T) :-
|
||
|
|
rule_code(R,I,Id1,Id2,L,T1),
|
||
|
|
rules_code(Rs,I,Id2,Id3,T1,T).
|
||
|
|
|
||
|
|
%% Generate code for a constraint based on a single CHR rule
|
||
|
|
rule_code(PragmaRule,I,Id1,Id2,L,T) :-
|
||
|
|
PragmaRule = pragma(Rule,HeadIDs,_Pragmas,_Name,_RuleNb),
|
||
|
|
HeadIDs = ids(Head1IDs,Head2IDs),
|
||
|
|
Rule = rule(Head1,Head2,_,_),
|
||
|
|
heads1_code(Head1,[],Head1IDs,[],PragmaRule,I,Id1,L,L1),
|
||
|
|
heads2_code(Head2,[],Head2IDs,[],PragmaRule,I,Id1,Id2,L1,T).
|
||
|
|
|
||
|
|
%% Generate code based on all the removed heads of a CHR rule
|
||
|
|
heads1_code([],_,_,_,_,_,_,L,L).
|
||
|
|
heads1_code([Head|Heads],RestHeads,[HeadID|HeadIDs],RestIDs,PragmaRule,I,Id,L,T) :-
|
||
|
|
PragmaRule = pragma(Rule,_,_Pragmas,_Name,RuleNb),
|
||
|
|
get_constraint(F/A,I),
|
||
|
|
( functor(Head,F,A),
|
||
|
|
\+ is_passive(RuleNb,HeadID),
|
||
|
|
\+ check_unnecessary_active(Head,RestHeads,Rule),
|
||
|
|
all_attached(Heads),
|
||
|
|
all_attached(RestHeads),
|
||
|
|
Rule = rule(_,Heads2,_,_),
|
||
|
|
all_attached(Heads2) ->
|
||
|
|
append(Heads,RestHeads,OtherHeads),
|
||
|
|
append(HeadIDs,RestIDs,OtherIDs),
|
||
|
|
head1_code(Head,OtherHeads,OtherIDs,PragmaRule,F/A,I,Id,L,L1)
|
||
|
|
;
|
||
|
|
L = L1
|
||
|
|
),
|
||
|
|
heads1_code(Heads,[Head|RestHeads],HeadIDs,[HeadID|RestIDs],PragmaRule,I,Id,L1,T).
|
||
|
|
|
||
|
|
%% Generate code based on one removed head of a CHR rule
|
||
|
|
head1_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,I,Id,L,T) :-
|
||
|
|
PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
|
||
|
|
Rule = rule(_,Head2,_,_),
|
||
|
|
( Head2 == [] ->
|
||
|
|
reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
|
||
|
|
simplification_code(Head,NOtherHeads,NOtherIDs,PragmaRule,FA,Id,L,T)
|
||
|
|
;
|
||
|
|
simpagation_head1_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,Id,L,T)
|
||
|
|
).
|
||
|
|
|
||
|
|
%% Generate code based on all the persistent heads of a CHR rule
|
||
|
|
heads2_code([],_,_,_,_,_,Id,Id,L,L).
|
||
|
|
heads2_code([Head|Heads],RestHeads,[HeadID|HeadIDs],RestIDs,PragmaRule,I,Id1,Id3,L,T) :-
|
||
|
|
PragmaRule = pragma(Rule,_,_Pragmas,_Name,RuleNb),
|
||
|
|
get_constraint(F/A,I),
|
||
|
|
( functor(Head,F,A),
|
||
|
|
\+ is_passive(RuleNb,HeadID),
|
||
|
|
\+ check_unnecessary_active(Head,RestHeads,Rule),
|
||
|
|
\+ set_semantics_rule(PragmaRule),
|
||
|
|
all_attached(Heads),
|
||
|
|
all_attached(RestHeads),
|
||
|
|
Rule = rule(Heads1,_,_,_),
|
||
|
|
all_attached(Heads1) ->
|
||
|
|
append(Heads,RestHeads,OtherHeads),
|
||
|
|
append(HeadIDs,RestIDs,OtherIDs),
|
||
|
|
length(Heads,RestHeadNb),
|
||
|
|
head2_code(Head,OtherHeads,OtherIDs,PragmaRule,RestHeadNb,F/A,Id1,L,L0),
|
||
|
|
inc_id(Id1,Id2),
|
||
|
|
gen_alloc_inc_clause(F/A,Id1,L0,L1)
|
||
|
|
;
|
||
|
|
L = L1,
|
||
|
|
Id2 = Id1
|
||
|
|
),
|
||
|
|
heads2_code(Heads,[Head|RestHeads],HeadIDs,[HeadID|RestIDs],PragmaRule,I,Id2,Id3,L1,T).
|
||
|
|
|
||
|
|
%% Generate code based on one persistent head of a CHR rule
|
||
|
|
head2_code(Head,OtherHeads,OtherIDs,PragmaRule,RestHeadNb,FA,Id,L,T) :-
|
||
|
|
PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
|
||
|
|
Rule = rule(Head1,_,_,_),
|
||
|
|
( Head1 == [] ->
|
||
|
|
reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,_),
|
||
|
|
propagation_code(Head,NOtherHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T)
|
||
|
|
;
|
||
|
|
simpagation_head2_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,Id,L,T)
|
||
|
|
).
|
||
|
|
|
||
|
|
gen_alloc_inc_clause(F/A,Id,L,T) :-
|
||
|
|
vars_susp(A,Vars,Susp,VarsSusp),
|
||
|
|
build_head(F,A,Id,VarsSusp,Head),
|
||
|
|
inc_id(Id,IncId),
|
||
|
|
build_head(F,A,IncId,VarsSusp,CallHead),
|
||
|
|
gen_allocation(Id,Vars,Susp,F/A,VarsSusp,ConditionalAlloc),
|
||
|
|
Clause =
|
||
|
|
(
|
||
|
|
Head :-
|
||
|
|
ConditionalAlloc,
|
||
|
|
CallHead
|
||
|
|
),
|
||
|
|
L = [Clause|T].
|
||
|
|
|
||
|
|
gen_cond_allocation(Vars,Susp,FA,VarsSusp,ConstraintAllocationGoal) :-
|
||
|
|
gen_allocation(Vars,Susp,FA,VarsSusp,UncondConstraintAllocationGoal),
|
||
|
|
ConstraintAllocationGoal =
|
||
|
|
( var(Susp) ->
|
||
|
|
UncondConstraintAllocationGoal
|
||
|
|
;
|
||
|
|
true
|
||
|
|
).
|
||
|
|
gen_allocation(Vars,Susp,F/A,VarsSusp,ConstraintAllocationGoal) :-
|
||
|
|
build_head(F,A,[0],VarsSusp,Term),
|
||
|
|
get_target_module(Mod),
|
||
|
|
FTerm =.. [F|Vars],
|
||
|
|
ConstraintAllocationGoal = allocate_constraint(Mod : Term, Susp, FTerm, Vars).
|
||
|
|
|
||
|
|
gen_allocation(Id,Vars,Susp,FA,VarsSusp,ConstraintAllocationGoal) :-
|
||
|
|
( Id == [0] ->
|
||
|
|
( is_attached(FA) ->
|
||
|
|
( may_trigger(FA) ->
|
||
|
|
gen_cond_allocation(Vars,Susp,FA,VarsSusp,ConstraintAllocationGoal)
|
||
|
|
;
|
||
|
|
gen_allocation(Vars,Susp,FA,VarsSusp,ConstraintAllocationGoal)
|
||
|
|
)
|
||
|
|
;
|
||
|
|
ConstraintAllocationGoal = true
|
||
|
|
)
|
||
|
|
;
|
||
|
|
ConstraintAllocationGoal = true
|
||
|
|
).
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
|
||
|
|
guard_via_reschedule(Retrievals,GuardList,Prelude,Goal) :-
|
||
|
|
( chr_pp_flag(guard_via_reschedule,on) ->
|
||
|
|
guard_via_reschedule_main(Retrievals,GuardList,Prelude,Goal)
|
||
|
|
;
|
||
|
|
append(Retrievals,GuardList,GoalList),
|
||
|
|
list2conj(GoalList,Goal)
|
||
|
|
).
|
||
|
|
|
||
|
|
guard_via_reschedule_main(Retrievals,GuardList,Prelude,Goal) :-
|
||
|
|
initialize_unit_dictionary(Prelude,Dict),
|
||
|
|
build_units(Retrievals,GuardList,Dict,Units),
|
||
|
|
dependency_reorder(Units,NUnits),
|
||
|
|
units2goal(NUnits,Goal).
|
||
|
|
|
||
|
|
units2goal([],true).
|
||
|
|
units2goal([unit(_,Goal,_,_)|Units],(Goal,Goals)) :-
|
||
|
|
units2goal(Units,Goals).
|
||
|
|
|
||
|
|
dependency_reorder(Units,NUnits) :-
|
||
|
|
dependency_reorder(Units,[],NUnits).
|
||
|
|
|
||
|
|
dependency_reorder([],Acc,Result) :-
|
||
|
|
reverse(Acc,Result).
|
||
|
|
|
||
|
|
dependency_reorder([Unit|Units],Acc,Result) :-
|
||
|
|
Unit = unit(_GID,_Goal,Type,GIDs),
|
||
|
|
( Type == fixed ->
|
||
|
|
NAcc = [Unit|Acc]
|
||
|
|
;
|
||
|
|
dependency_insert(Acc,Unit,GIDs,NAcc)
|
||
|
|
),
|
||
|
|
dependency_reorder(Units,NAcc,Result).
|
||
|
|
|
||
|
|
dependency_insert([],Unit,_,[Unit]).
|
||
|
|
dependency_insert([X|Xs],Unit,GIDs,L) :-
|
||
|
|
X = unit(GID,_,_,_),
|
||
|
|
( memberchk(GID,GIDs) ->
|
||
|
|
L = [Unit,X|Xs]
|
||
|
|
;
|
||
|
|
L = [X | T],
|
||
|
|
dependency_insert(Xs,Unit,GIDs,T)
|
||
|
|
).
|
||
|
|
|
||
|
|
build_units(Retrievals,Guard,InitialDict,Units) :-
|
||
|
|
build_retrieval_units(Retrievals,1,N,InitialDict,Dict,Units,Tail),
|
||
|
|
build_guard_units(Guard,N,Dict,Tail).
|
||
|
|
|
||
|
|
build_retrieval_units([],N,N,Dict,Dict,L,L).
|
||
|
|
build_retrieval_units([U|Us],N,M,Dict,NDict,L,T) :-
|
||
|
|
term_variables(U,Vs),
|
||
|
|
update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
|
||
|
|
L = [unit(N,U,movable,GIDs)|L1],
|
||
|
|
N1 is N + 1,
|
||
|
|
build_retrieval_units2(Us,N1,M,Dict1,NDict,L1,T).
|
||
|
|
|
||
|
|
build_retrieval_units2([],N,N,Dict,Dict,L,L).
|
||
|
|
build_retrieval_units2([U|Us],N,M,Dict,NDict,L,T) :-
|
||
|
|
term_variables(U,Vs),
|
||
|
|
update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
|
||
|
|
L = [unit(N,U,fixed,GIDs)|L1],
|
||
|
|
N1 is N + 1,
|
||
|
|
build_retrieval_units(Us,N1,M,Dict1,NDict,L1,T).
|
||
|
|
|
||
|
|
initialize_unit_dictionary(Term,Dict) :-
|
||
|
|
term_variables(Term,Vars),
|
||
|
|
pair_all_with(Vars,0,Dict).
|
||
|
|
|
||
|
|
update_unit_dictionary([],_,Dict,Dict,GIDs,GIDs).
|
||
|
|
update_unit_dictionary([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
|
||
|
|
( lookup_eq(Dict,V,GID) ->
|
||
|
|
( (GID == This ; memberchk(GID,GIDs) ) ->
|
||
|
|
GIDs1 = GIDs
|
||
|
|
;
|
||
|
|
GIDs1 = [GID|GIDs]
|
||
|
|
),
|
||
|
|
Dict1 = Dict
|
||
|
|
;
|
||
|
|
Dict1 = [V - This|Dict],
|
||
|
|
GIDs1 = GIDs
|
||
|
|
),
|
||
|
|
update_unit_dictionary(Vs,This,Dict1,NDict,GIDs1,NGIDs).
|
||
|
|
|
||
|
|
build_guard_units(Guard,N,Dict,Units) :-
|
||
|
|
( Guard = [Goal] ->
|
||
|
|
Units = [unit(N,Goal,fixed,[])]
|
||
|
|
; Guard = [Goal|Goals] ->
|
||
|
|
term_variables(Goal,Vs),
|
||
|
|
update_unit_dictionary2(Vs,N,Dict,NDict,[],GIDs),
|
||
|
|
Units = [unit(N,Goal,movable,GIDs)|RUnits],
|
||
|
|
N1 is N + 1,
|
||
|
|
build_guard_units(Goals,N1,NDict,RUnits)
|
||
|
|
).
|
||
|
|
|
||
|
|
update_unit_dictionary2([],_,Dict,Dict,GIDs,GIDs).
|
||
|
|
update_unit_dictionary2([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
|
||
|
|
( lookup_eq(Dict,V,GID) ->
|
||
|
|
( (GID == This ; memberchk(GID,GIDs) ) ->
|
||
|
|
GIDs1 = GIDs
|
||
|
|
;
|
||
|
|
GIDs1 = [GID|GIDs]
|
||
|
|
),
|
||
|
|
Dict1 = [V - This|Dict]
|
||
|
|
;
|
||
|
|
Dict1 = [V - This|Dict],
|
||
|
|
GIDs1 = GIDs
|
||
|
|
),
|
||
|
|
update_unit_dictionary2(Vs,This,Dict1,NDict,GIDs1,NGIDs).
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
%% ____ _ ____ _ _
|
||
|
|
%% / ___| ___| |_ / ___| ___ _ __ ___ __ _ _ __ | |_(_) ___ ___ _
|
||
|
|
%% \___ \ / _ \ __| \___ \ / _ \ '_ ` _ \ / _` | '_ \| __| |/ __/ __(_)
|
||
|
|
%% ___) | __/ |_ ___) | __/ | | | | | (_| | | | | |_| | (__\__ \_
|
||
|
|
%% |____/ \___|\__| |____/ \___|_| |_| |_|\__,_|_| |_|\__|_|\___|___(_)
|
||
|
|
%%
|
||
|
|
%% _ _ _ ___ __
|
||
|
|
%% | | | |_ __ (_) __ _ _ _ ___ |_ _|_ __ / _| ___ _ __ ___ _ __ ___ ___
|
||
|
|
%% | | | | '_ \| |/ _` | | | |/ _ \ | || '_ \| |_ / _ \ '__/ _ \ '_ \ / __/ _ \
|
||
|
|
%% | |_| | | | | | (_| | |_| | __/ | || | | | _| __/ | | __/ | | | (_| __/
|
||
|
|
%% \___/|_| |_|_|\__, |\__,_|\___| |___|_| |_|_| \___|_| \___|_| |_|\___\___|
|
||
|
|
%% |_|
|
||
|
|
unique_analyse_optimise(Rules,NRules) :-
|
||
|
|
( chr_pp_flag(unique_analyse_optimise,on) ->
|
||
|
|
unique_analyse_optimise_main(Rules,1,[],NRules)
|
||
|
|
;
|
||
|
|
NRules = Rules
|
||
|
|
).
|
||
|
|
|
||
|
|
unique_analyse_optimise_main([],_,_,[]).
|
||
|
|
unique_analyse_optimise_main([PRule|PRules],N,PatternList,[NPRule|NPRules]) :-
|
||
|
|
( discover_unique_pattern(PRule,N,Pattern) ->
|
||
|
|
NPatternList = [Pattern|PatternList]
|
||
|
|
;
|
||
|
|
NPatternList = PatternList
|
||
|
|
),
|
||
|
|
PRule = pragma(Rule,Ids,Pragmas,Name,RuleNb),
|
||
|
|
Rule = rule(H1,H2,_,_),
|
||
|
|
Ids = ids(Ids1,Ids2),
|
||
|
|
apply_unique_patterns_to_constraints(H1,Ids1,NPatternList,MorePragmas1),
|
||
|
|
apply_unique_patterns_to_constraints(H2,Ids2,NPatternList,MorePragmas2),
|
||
|
|
globalize_unique_pragmas(MorePragmas1,RuleNb),
|
||
|
|
globalize_unique_pragmas(MorePragmas2,RuleNb),
|
||
|
|
append([MorePragmas1,MorePragmas2,Pragmas],NPragmas),
|
||
|
|
NPRule = pragma(Rule,Ids,NPragmas,Name,RuleNb),
|
||
|
|
N1 is N + 1,
|
||
|
|
unique_analyse_optimise_main(PRules,N1,NPatternList,NPRules).
|
||
|
|
|
||
|
|
globalize_unique_pragmas([],_).
|
||
|
|
globalize_unique_pragmas([unique(ID,Vars)|R],RuleNb) :-
|
||
|
|
pragma_unique(RuleNb,ID,Vars),
|
||
|
|
globalize_unique_pragmas(R,RuleNb).
|
||
|
|
|
||
|
|
apply_unique_patterns_to_constraints([],_,_,[]).
|
||
|
|
apply_unique_patterns_to_constraints([C|Cs],[Id|Ids],Patterns,Pragmas) :-
|
||
|
|
( member(Pattern,Patterns),
|
||
|
|
apply_unique_pattern(C,Id,Pattern,Pragma) ->
|
||
|
|
Pragmas = [Pragma | RPragmas]
|
||
|
|
;
|
||
|
|
Pragmas = RPragmas
|
||
|
|
),
|
||
|
|
apply_unique_patterns_to_constraints(Cs,Ids,Patterns,RPragmas).
|
||
|
|
|
||
|
|
apply_unique_pattern(Constraint,Id,Pattern,Pragma) :-
|
||
|
|
Pattern = unique(PatternConstraint,PatternKey),
|
||
|
|
subsumes(Constraint,PatternConstraint,Unifier),
|
||
|
|
find_with_var_identity( V,
|
||
|
|
Unifier
|
||
|
|
,
|
||
|
|
(
|
||
|
|
member(T,PatternKey),
|
||
|
|
lookup_eq(Unifier,T,Term),
|
||
|
|
term_variables(Term,Vs),
|
||
|
|
member(V,Vs)
|
||
|
|
),
|
||
|
|
Vars2),
|
||
|
|
sort(Vars2,Vars3),
|
||
|
|
Vars = Vars3,
|
||
|
|
Pragma = unique(Id,Vars).
|
||
|
|
|
||
|
|
% subsumes(+Term1, +Term2, -Unifier)
|
||
|
|
%
|
||
|
|
% If Term1 is a more general term than Term2 (e.g. has a larger
|
||
|
|
% part instantiated), unify Unifier with a list Var-Value of
|
||
|
|
% variables from Term2 and their corresponding values in Term1.
|
||
|
|
|
||
|
|
subsumes(Term1,Term2,Unifier) :-
|
||
|
|
empty_ds(S0),
|
||
|
|
subsumes_aux(Term1,Term2,S0,S),
|
||
|
|
ds_to_list(S,L),
|
||
|
|
build_unifier(L,Unifier).
|
||
|
|
|
||
|
|
subsumes_aux(Term1, Term2, S0, S) :-
|
||
|
|
( compound(Term2),
|
||
|
|
functor(Term2, F, N)
|
||
|
|
-> compound(Term1), functor(Term1, F, N),
|
||
|
|
subsumes_aux(N, Term1, Term2, S0, S)
|
||
|
|
; Term1 == Term2
|
||
|
|
-> S = S0
|
||
|
|
; var(Term2),
|
||
|
|
get_ds(Term1,S0,V)
|
||
|
|
-> V == Term2, S = S0
|
||
|
|
; var(Term2),
|
||
|
|
put_ds(Term1, S0, Term2, S)
|
||
|
|
).
|
||
|
|
|
||
|
|
subsumes_aux(0, _, _, S, S) :- ! .
|
||
|
|
subsumes_aux(N, T1, T2, S0, S) :-
|
||
|
|
arg(N, T1, T1x),
|
||
|
|
arg(N, T2, T2x),
|
||
|
|
subsumes_aux(T1x, T2x, S0, S1),
|
||
|
|
M is N-1,
|
||
|
|
subsumes_aux(M, T1, T2, S1, S).
|
||
|
|
|
||
|
|
build_unifier([],[]).
|
||
|
|
build_unifier([X-V|R],[V - X | T]) :-
|
||
|
|
build_unifier(R,T).
|
||
|
|
|
||
|
|
discover_unique_pattern(PragmaRule,RuleNb,Pattern) :-
|
||
|
|
PragmaRule = pragma(Rule,_,_Pragmas,Name,RuleNb),
|
||
|
|
Rule = rule(H1,H2,Guard,_),
|
||
|
|
( H1 = [C1],
|
||
|
|
H2 = [C2] ->
|
||
|
|
true
|
||
|
|
; H1 = [C1,C2],
|
||
|
|
H2 == [] ->
|
||
|
|
true
|
||
|
|
),
|
||
|
|
check_unique_constraints(C1,C2,Guard,RuleNb,List),
|
||
|
|
term_variables(C1,Vs),
|
||
|
|
select_pragma_unique_variables(List,Vs,Key),
|
||
|
|
Pattern0 = unique(C1,Key),
|
||
|
|
copy_term_nat(Pattern0,Pattern),
|
||
|
|
( verbosity_on ->
|
||
|
|
format('Found unique pattern ~w in rule ~d~@\n',
|
||
|
|
[Pattern,RuleNb,(Name=yes(N) -> write(": "),write(N) ; true)])
|
||
|
|
;
|
||
|
|
true
|
||
|
|
).
|
||
|
|
|
||
|
|
select_pragma_unique_variables([],_,[]).
|
||
|
|
select_pragma_unique_variables([X-Y|R],Vs,L) :-
|
||
|
|
( X == Y ->
|
||
|
|
L = [X|T]
|
||
|
|
;
|
||
|
|
once((
|
||
|
|
\+ memberchk_eq(X,Vs)
|
||
|
|
;
|
||
|
|
\+ memberchk_eq(Y,Vs)
|
||
|
|
)),
|
||
|
|
L = T
|
||
|
|
),
|
||
|
|
select_pragma_unique_variables(R,Vs,T).
|
||
|
|
|
||
|
|
check_unique_constraints(C1,C2,G,RuleNb,List) :-
|
||
|
|
\+ any_passive_head(RuleNb),
|
||
|
|
variable_replacement(C1-C2,C2-C1,List),
|
||
|
|
copy_with_variable_replacement(G,OtherG,List),
|
||
|
|
negate_b(G,NotG),
|
||
|
|
once(entails_b(NotG,OtherG)).
|
||
|
|
|
||
|
|
check_unnecessary_active(Constraint,Previous,Rule) :-
|
||
|
|
( chr_pp_flag(check_unnecessary_active,full) ->
|
||
|
|
check_unnecessary_active_main(Constraint,Previous,Rule)
|
||
|
|
; chr_pp_flag(check_unnecessary_active,simplification),
|
||
|
|
Rule = rule(_,[],_,_) ->
|
||
|
|
check_unnecessary_active_main(Constraint,Previous,Rule)
|
||
|
|
;
|
||
|
|
fail
|
||
|
|
).
|
||
|
|
|
||
|
|
check_unnecessary_active_main(Constraint,Previous,Rule) :-
|
||
|
|
member(Other,Previous),
|
||
|
|
variable_replacement(Other,Constraint,List),
|
||
|
|
copy_with_variable_replacement(Rule,Rule2,List),
|
||
|
|
identical_rules(Rule,Rule2), ! .
|
||
|
|
|
||
|
|
set_semantics_rule(PragmaRule) :-
|
||
|
|
( chr_pp_flag(set_semantics_rule,on) ->
|
||
|
|
set_semantics_rule_main(PragmaRule)
|
||
|
|
;
|
||
|
|
fail
|
||
|
|
).
|
||
|
|
|
||
|
|
set_semantics_rule_main(PragmaRule) :-
|
||
|
|
PragmaRule = pragma(Rule,IDs,Pragmas,_,RuleNb),
|
||
|
|
Rule = rule([C1],[C2],true,_),
|
||
|
|
IDs = ids([ID1],[ID2]),
|
||
|
|
once(member(unique(ID1,L1),Pragmas)),
|
||
|
|
once(member(unique(ID2,L2),Pragmas)),
|
||
|
|
L1 == L2,
|
||
|
|
\+ is_passive(RuleNb,ID1).
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
%% ____ _ _____ _ _
|
||
|
|
%% | _ \ _ _| | ___ | ____|__ _ _ _(_)_ ____ _| | ___ _ __ ___ ___
|
||
|
|
%% | |_) | | | | |/ _ \ | _| / _` | | | | \ \ / / _` | |/ _ \ '_ \ / __/ _ \
|
||
|
|
%% | _ <| |_| | | __/ | |__| (_| | |_| | |\ V / (_| | | __/ | | | (_| __/
|
||
|
|
%% |_| \_\\__,_|_|\___| |_____\__, |\__,_|_| \_/ \__,_|_|\___|_| |_|\___\___|
|
||
|
|
%% |_|
|
||
|
|
% have to check for no duplicates in value list
|
||
|
|
|
||
|
|
% check wether two rules are identical
|
||
|
|
|
||
|
|
identical_rules(rule(H11,H21,G1,B1),rule(H12,H22,G2,B2)) :-
|
||
|
|
G1 == G2,
|
||
|
|
identical_bodies(B1,B2),
|
||
|
|
permutation(H11,P1),
|
||
|
|
P1 == H12,
|
||
|
|
permutation(H21,P2),
|
||
|
|
P2 == H22.
|
||
|
|
|
||
|
|
identical_bodies(B1,B2) :-
|
||
|
|
( B1 = (X1 = Y1),
|
||
|
|
B2 = (X2 = Y2) ->
|
||
|
|
( X1 == X2,
|
||
|
|
Y1 == Y2
|
||
|
|
; X1 == Y2,
|
||
|
|
X2 == Y1
|
||
|
|
),
|
||
|
|
!
|
||
|
|
; B1 == B2
|
||
|
|
).
|
||
|
|
|
||
|
|
% replace variables in list
|
||
|
|
|
||
|
|
copy_with_variable_replacement(X,Y,L) :-
|
||
|
|
( var(X) ->
|
||
|
|
( lookup_eq(L,X,Y) ->
|
||
|
|
true
|
||
|
|
; X = Y
|
||
|
|
)
|
||
|
|
; functor(X,F,A),
|
||
|
|
functor(Y,F,A),
|
||
|
|
X =.. [_|XArgs],
|
||
|
|
Y =.. [_|YArgs],
|
||
|
|
copy_with_variable_replacement_l(XArgs,YArgs,L)
|
||
|
|
).
|
||
|
|
|
||
|
|
copy_with_variable_replacement_l([],[],_).
|
||
|
|
copy_with_variable_replacement_l([X|Xs],[Y|Ys],L) :-
|
||
|
|
copy_with_variable_replacement(X,Y,L),
|
||
|
|
copy_with_variable_replacement_l(Xs,Ys,L).
|
||
|
|
|
||
|
|
%% build variable replacement list
|
||
|
|
|
||
|
|
variable_replacement(X,Y,L) :-
|
||
|
|
variable_replacement(X,Y,[],L).
|
||
|
|
|
||
|
|
variable_replacement(X,Y,L1,L2) :-
|
||
|
|
( var(X) ->
|
||
|
|
var(Y),
|
||
|
|
( lookup_eq(L1,X,Z) ->
|
||
|
|
Z == Y,
|
||
|
|
L2 = L1
|
||
|
|
; L2 = [X-Y|L1]
|
||
|
|
)
|
||
|
|
; X =.. [F|XArgs],
|
||
|
|
nonvar(Y),
|
||
|
|
Y =.. [F|YArgs],
|
||
|
|
variable_replacement_l(XArgs,YArgs,L1,L2)
|
||
|
|
).
|
||
|
|
|
||
|
|
variable_replacement_l([],[],L,L).
|
||
|
|
variable_replacement_l([X|Xs],[Y|Ys],L1,L3) :-
|
||
|
|
variable_replacement(X,Y,L1,L2),
|
||
|
|
variable_replacement_l(Xs,Ys,L2,L3).
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
%% ____ _ _ _ __ _ _ _
|
||
|
|
%% / ___|(_)_ __ ___ _ __ | (_)/ _(_) ___ __ _| |_(_) ___ _ __
|
||
|
|
%% \___ \| | '_ ` _ \| '_ \| | | |_| |/ __/ _` | __| |/ _ \| '_ \
|
||
|
|
%% ___) | | | | | | | |_) | | | _| | (_| (_| | |_| | (_) | | | |
|
||
|
|
%% |____/|_|_| |_| |_| .__/|_|_|_| |_|\___\__,_|\__|_|\___/|_| |_|
|
||
|
|
%% |_|
|
||
|
|
|
||
|
|
simplification_code(Head,RestHeads,RestIDs,PragmaRule,F/A,Id,L,T) :-
|
||
|
|
PragmaRule = pragma(Rule,_,Pragmas,_,_RuleNb),
|
||
|
|
head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
|
||
|
|
build_head(F,A,Id,HeadVars,ClauseHead),
|
||
|
|
head_arg_matches(HeadPairs,[],FirstMatching,VarDict1),
|
||
|
|
|
||
|
|
( RestHeads == [] ->
|
||
|
|
Susps = [],
|
||
|
|
VarDict = VarDict1,
|
||
|
|
GetRestHeads = []
|
||
|
|
;
|
||
|
|
rest_heads_retrieval_and_matching(RestHeads,RestIDs,Pragmas,Head,GetRestHeads,Susps,VarDict1,VarDict)
|
||
|
|
),
|
||
|
|
|
||
|
|
guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
|
||
|
|
guard_via_reschedule(GetRestHeads,GuardCopyList,ClauseHead-FirstMatching,RescheduledTest),
|
||
|
|
|
||
|
|
gen_uncond_susps_detachments(Susps,RestHeads,SuspsDetachments),
|
||
|
|
gen_cond_susp_detachment(Id,Susp,F/A,SuspDetachment),
|
||
|
|
|
||
|
|
( chr_pp_flag(debugable,on) ->
|
||
|
|
Rule = rule(_,_,Guard,Body),
|
||
|
|
my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody),
|
||
|
|
DebugTry = 'chr debug_event'( try([Susp|RestSusps],[],DebugGuard,DebugBody)),
|
||
|
|
DebugApply = 'chr debug_event'(apply([Susp|RestSusps],[],DebugGuard,DebugBody))
|
||
|
|
;
|
||
|
|
DebugTry = true,
|
||
|
|
DebugApply = true
|
||
|
|
),
|
||
|
|
|
||
|
|
Clause = ( ClauseHead :-
|
||
|
|
FirstMatching,
|
||
|
|
RescheduledTest,
|
||
|
|
DebugTry,
|
||
|
|
!,
|
||
|
|
DebugApply,
|
||
|
|
SuspsDetachments,
|
||
|
|
SuspDetachment,
|
||
|
|
BodyCopy
|
||
|
|
),
|
||
|
|
L = [Clause | T].
|
||
|
|
|
||
|
|
head_arg_matches(Pairs,VarDict,Goal,NVarDict) :-
|
||
|
|
head_arg_matches_(Pairs,VarDict,GoalList,NVarDict),
|
||
|
|
list2conj(GoalList,Goal).
|
||
|
|
|
||
|
|
head_arg_matches_([],VarDict,[],VarDict).
|
||
|
|
head_arg_matches_([Arg-Var| Rest],VarDict,GoalList,NVarDict) :-
|
||
|
|
( var(Arg) ->
|
||
|
|
( lookup_eq(VarDict,Arg,OtherVar) ->
|
||
|
|
GoalList = [Var == OtherVar | RestGoalList],
|
||
|
|
VarDict1 = VarDict
|
||
|
|
; VarDict1 = [Arg-Var | VarDict],
|
||
|
|
GoalList = RestGoalList
|
||
|
|
),
|
||
|
|
Pairs = Rest
|
||
|
|
; atomic(Arg) ->
|
||
|
|
GoalList = [ Var == Arg | RestGoalList],
|
||
|
|
VarDict = VarDict1,
|
||
|
|
Pairs = Rest
|
||
|
|
; Arg =.. [_|Args],
|
||
|
|
functor(Arg,Fct,N),
|
||
|
|
functor(Term,Fct,N),
|
||
|
|
Term =.. [_|Vars],
|
||
|
|
GoalList =[ nonvar(Var), Var = Term | RestGoalList ],
|
||
|
|
pairup(Args,Vars,NewPairs),
|
||
|
|
append(NewPairs,Rest,Pairs),
|
||
|
|
VarDict1 = VarDict
|
||
|
|
),
|
||
|
|
head_arg_matches_(Pairs,VarDict1,RestGoalList,NVarDict).
|
||
|
|
|
||
|
|
rest_heads_retrieval_and_matching(Heads,IDs,Pragmas,ActiveHead,GoalList,Susps,VarDict,NVarDict):-
|
||
|
|
rest_heads_retrieval_and_matching(Heads,IDs,Pragmas,ActiveHead,GoalList,Susps,VarDict,NVarDict,[],[],[]).
|
||
|
|
|
||
|
|
rest_heads_retrieval_and_matching(Heads,IDs,Pragmas,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict) :-
|
||
|
|
( Heads = [_|_] ->
|
||
|
|
rest_heads_retrieval_and_matching_n(Heads,IDs,Pragmas,PrevHs,PrevSusps,ActiveHead,GoalList,Susps,VarDict,NVarDict,AttrDict)
|
||
|
|
;
|
||
|
|
GoalList = [],
|
||
|
|
Susps = [],
|
||
|
|
VarDict = NVarDict
|
||
|
|
).
|
||
|
|
|
||
|
|
rest_heads_retrieval_and_matching_n([],_,_,_,_,_,[],[],VarDict,VarDict,AttrDict) :-
|
||
|
|
instantiate_pattern_goals(AttrDict).
|
||
|
|
rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],Pragmas,PrevHs,PrevSusps,ActiveHead,[ViaGoal,Goal|Goals],[Susp|Susps],VarDict,NVarDict,AttrDict) :-
|
||
|
|
functor(H,F,A),
|
||
|
|
get_store_type(F/A,StoreType),
|
||
|
|
( StoreType == default ->
|
||
|
|
passive_head_via(H,[ActiveHead|PrevHs],AttrDict,VarDict,ViaGoal,Attr,NewAttrDict),
|
||
|
|
get_max_constraint_index(N),
|
||
|
|
( N == 1 ->
|
||
|
|
VarSusps = Attr
|
||
|
|
;
|
||
|
|
get_constraint_index(F/A,Pos),
|
||
|
|
make_attr(N,_Mask,SuspsList,Attr),
|
||
|
|
nth1(Pos,SuspsList,VarSusps)
|
||
|
|
)
|
||
|
|
;
|
||
|
|
lookup_passive_head(StoreType,H,[ActiveHead|PrevHs],VarDict,ViaGoal,VarSusps),
|
||
|
|
NewAttrDict = AttrDict
|
||
|
|
),
|
||
|
|
head_info(H,A,Vars,_,_,Pairs),
|
||
|
|
head_arg_matches(Pairs,VarDict,MatchingGoal,VarDict1),
|
||
|
|
Suspension =.. [suspension,_,State,_,_,_,_|Vars],
|
||
|
|
different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals),
|
||
|
|
create_get_mutable_ref(active,State,GetMutable),
|
||
|
|
Goal1 =
|
||
|
|
(
|
||
|
|
'chr sbag_member'(Susp,VarSusps),
|
||
|
|
Susp = Suspension,
|
||
|
|
GetMutable,
|
||
|
|
DiffSuspGoals,
|
||
|
|
MatchingGoal
|
||
|
|
),
|
||
|
|
( member(unique(ID,UniqueKeus),Pragmas),
|
||
|
|
check_unique_keys(UniqueKeus,VarDict) ->
|
||
|
|
Goal = (Goal1 -> true)
|
||
|
|
;
|
||
|
|
Goal = Goal1
|
||
|
|
),
|
||
|
|
rest_heads_retrieval_and_matching_n(Hs,IDs,Pragmas,[H|PrevHs],[Susp|PrevSusps],ActiveHead,Goals,Susps,VarDict1,NVarDict,NewAttrDict).
|
||
|
|
|
||
|
|
instantiate_pattern_goals([]).
|
||
|
|
instantiate_pattern_goals([_-attr(Attr,Bits,Goal)|Rest]) :-
|
||
|
|
get_max_constraint_index(N),
|
||
|
|
( N == 1 ->
|
||
|
|
Goal = true
|
||
|
|
;
|
||
|
|
make_attr(N,Mask,_,Attr),
|
||
|
|
or_list(Bits,Pattern), !,
|
||
|
|
Goal = (Mask /\ Pattern =:= Pattern)
|
||
|
|
),
|
||
|
|
instantiate_pattern_goals(Rest).
|
||
|
|
|
||
|
|
|
||
|
|
check_unique_keys([],_).
|
||
|
|
check_unique_keys([V|Vs],Dict) :-
|
||
|
|
lookup_eq(Dict,V,_),
|
||
|
|
check_unique_keys(Vs,Dict).
|
||
|
|
|
||
|
|
% Generates tests to ensure the found constraint differs from previously found constraints
|
||
|
|
% TODO: detect more cases where constraints need be different
|
||
|
|
different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :-
|
||
|
|
( bagof(DiffSuspGoal, Pos ^ ( nth1(Pos,Heads,PreHead), \+ Head \= PreHead, nth1(Pos,Susps,PreSusp), DiffSuspGoal = (Susp \== PreSusp) ),DiffSuspGoalList) ->
|
||
|
|
list2conj(DiffSuspGoalList,DiffSuspGoals)
|
||
|
|
;
|
||
|
|
DiffSuspGoals = true
|
||
|
|
).
|
||
|
|
|
||
|
|
passive_head_via(Head,PrevHeads,AttrDict,VarDict,Goal,Attr,NewAttrDict) :-
|
||
|
|
functor(Head,F,A),
|
||
|
|
get_constraint_index(F/A,Pos),
|
||
|
|
common_variables(Head,PrevHeads,CommonVars),
|
||
|
|
translate(CommonVars,VarDict,Vars),
|
||
|
|
or_pattern(Pos,Bit),
|
||
|
|
( permutation(Vars,PermutedVars),
|
||
|
|
lookup_eq(AttrDict,PermutedVars,attr(Attr,Positions,_)) ->
|
||
|
|
member(Bit,Positions), !,
|
||
|
|
NewAttrDict = AttrDict,
|
||
|
|
Goal = true
|
||
|
|
;
|
||
|
|
Goal = (Goal1, PatternGoal),
|
||
|
|
gen_get_mod_constraints(Vars,Goal1,Attr),
|
||
|
|
NewAttrDict = [Vars - attr(Attr,[Bit|_],PatternGoal) | AttrDict]
|
||
|
|
).
|
||
|
|
|
||
|
|
common_variables(T,Ts,Vs) :-
|
||
|
|
term_variables(T,V1),
|
||
|
|
term_variables(Ts,V2),
|
||
|
|
intersect_eq(V1,V2,Vs).
|
||
|
|
|
||
|
|
gen_get_mod_constraints(L,Goal,Susps) :-
|
||
|
|
get_target_module(Mod),
|
||
|
|
( L == [] ->
|
||
|
|
Goal =
|
||
|
|
( 'chr default_store'(Global),
|
||
|
|
get_attr(Global,Mod,TSusps),
|
||
|
|
TSusps = Susps
|
||
|
|
)
|
||
|
|
;
|
||
|
|
( L = [A] ->
|
||
|
|
VIA = 'chr via_1'(A,V)
|
||
|
|
; ( L = [A,B] ->
|
||
|
|
VIA = 'chr via_2'(A,B,V)
|
||
|
|
; VIA = 'chr via'(L,V)
|
||
|
|
)
|
||
|
|
),
|
||
|
|
Goal =
|
||
|
|
( VIA,
|
||
|
|
get_attr(V,Mod,TSusps),
|
||
|
|
TSusps = Susps
|
||
|
|
)
|
||
|
|
).
|
||
|
|
|
||
|
|
guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy) :-
|
||
|
|
guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
|
||
|
|
list2conj(GuardCopyList,GuardCopy).
|
||
|
|
|
||
|
|
guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy) :-
|
||
|
|
Rule = rule(_,_,Guard,Body),
|
||
|
|
conj2list(Guard,GuardList),
|
||
|
|
split_off_simple_guard(GuardList,VarDict,GuardPrefix,RestGuardList),
|
||
|
|
my_term_copy(GuardPrefix-RestGuardList,VarDict,VarDict2,GuardPrefixCopy-RestGuardListCopyCore),
|
||
|
|
|
||
|
|
append(GuardPrefixCopy,[RestGuardCopy],GuardCopyList),
|
||
|
|
term_variables(RestGuardList,GuardVars),
|
||
|
|
term_variables(RestGuardListCopyCore,GuardCopyVars),
|
||
|
|
( chr_pp_flag(guard_locks,on),
|
||
|
|
find_with_var_identity(('chr lock'(Y)) - ('chr unlock'(Y)),
|
||
|
|
VarDict,
|
||
|
|
(member(X,GuardVars), % X is a variable appearing in the original guard
|
||
|
|
lookup_eq(VarDict,X,Y), % translate X into new variable
|
||
|
|
memberchk_eq(Y,GuardCopyVars) % redundant check? or multiple entries for X possible?
|
||
|
|
),
|
||
|
|
LocksUnlocks)
|
||
|
|
|
||
|
|
->
|
||
|
|
once(pairup(Locks,Unlocks,LocksUnlocks))
|
||
|
|
;
|
||
|
|
Locks = [],
|
||
|
|
Unlocks = []
|
||
|
|
),
|
||
|
|
list2conj(Locks,LockPhase),
|
||
|
|
list2conj(Unlocks,UnlockPhase),
|
||
|
|
list2conj(RestGuardListCopyCore,RestGuardCopyCore),
|
||
|
|
RestGuardCopy = (LockPhase,(RestGuardCopyCore,UnlockPhase)),
|
||
|
|
my_term_copy(Body,VarDict2,BodyCopy).
|
||
|
|
|
||
|
|
|
||
|
|
split_off_simple_guard([],_,[],[]).
|
||
|
|
split_off_simple_guard([G|Gs],VarDict,S,C) :-
|
||
|
|
( simple_guard(G,VarDict) ->
|
||
|
|
S = [G|Ss],
|
||
|
|
split_off_simple_guard(Gs,VarDict,Ss,C)
|
||
|
|
;
|
||
|
|
S = [],
|
||
|
|
C = [G|Gs]
|
||
|
|
).
|
||
|
|
|
||
|
|
% simple guard: cheap and benign (does not bind variables)
|
||
|
|
simple_guard(G,VarDict) :-
|
||
|
|
binds_b(G,Vars),
|
||
|
|
not(( member(V,Vars),
|
||
|
|
lookup_eq(VarDict,V,_)
|
||
|
|
)).
|
||
|
|
|
||
|
|
my_term_copy(X,Dict,Y) :-
|
||
|
|
my_term_copy(X,Dict,_,Y).
|
||
|
|
|
||
|
|
my_term_copy(X,Dict1,Dict2,Y) :-
|
||
|
|
( var(X) ->
|
||
|
|
( lookup_eq(Dict1,X,Y) ->
|
||
|
|
Dict2 = Dict1
|
||
|
|
; Dict2 = [X-Y|Dict1]
|
||
|
|
)
|
||
|
|
; functor(X,XF,XA),
|
||
|
|
functor(Y,XF,XA),
|
||
|
|
X =.. [_|XArgs],
|
||
|
|
Y =.. [_|YArgs],
|
||
|
|
my_term_copy_list(XArgs,Dict1,Dict2,YArgs)
|
||
|
|
).
|
||
|
|
|
||
|
|
my_term_copy_list([],Dict,Dict,[]).
|
||
|
|
my_term_copy_list([X|Xs],Dict1,Dict3,[Y|Ys]) :-
|
||
|
|
my_term_copy(X,Dict1,Dict2,Y),
|
||
|
|
my_term_copy_list(Xs,Dict2,Dict3,Ys).
|
||
|
|
|
||
|
|
gen_cond_susp_detachment(Id,Susp,FA,SuspDetachment) :-
|
||
|
|
( is_attached(FA) ->
|
||
|
|
( Id == [0], \+ may_trigger(FA) ->
|
||
|
|
SuspDetachment = true
|
||
|
|
;
|
||
|
|
gen_uncond_susp_detachment(Susp,FA,UnCondSuspDetachment),
|
||
|
|
SuspDetachment =
|
||
|
|
( var(Susp) ->
|
||
|
|
true
|
||
|
|
; UnCondSuspDetachment
|
||
|
|
)
|
||
|
|
)
|
||
|
|
;
|
||
|
|
SuspDetachment = true
|
||
|
|
).
|
||
|
|
|
||
|
|
gen_uncond_susp_detachment(Susp,FA,SuspDetachment) :-
|
||
|
|
( is_attached(FA) ->
|
||
|
|
( may_trigger(FA) ->
|
||
|
|
make_name('detach_',FA,Fct),
|
||
|
|
Detach =.. [Fct,Vars,Susp]
|
||
|
|
;
|
||
|
|
Detach = true
|
||
|
|
),
|
||
|
|
( chr_pp_flag(debugable,on) ->
|
||
|
|
DebugEvent = 'chr debug_event'(remove(Susp))
|
||
|
|
;
|
||
|
|
DebugEvent = true
|
||
|
|
),
|
||
|
|
generate_delete_constraint_call(FA,Susp,DeleteCall),
|
||
|
|
SuspDetachment =
|
||
|
|
(
|
||
|
|
DebugEvent,
|
||
|
|
remove_constraint_internal(Susp, Vars, Delete),
|
||
|
|
( Delete == yes ->
|
||
|
|
DeleteCall,
|
||
|
|
Detach
|
||
|
|
;
|
||
|
|
true
|
||
|
|
)
|
||
|
|
)
|
||
|
|
;
|
||
|
|
SuspDetachment = true
|
||
|
|
).
|
||
|
|
|
||
|
|
gen_uncond_susps_detachments([],[],true).
|
||
|
|
gen_uncond_susps_detachments([Susp|Susps],[Term|Terms],(SuspDetachment,SuspsDetachments)) :-
|
||
|
|
functor(Term,F,A),
|
||
|
|
gen_uncond_susp_detachment(Susp,F/A,SuspDetachment),
|
||
|
|
gen_uncond_susps_detachments(Susps,Terms,SuspsDetachments).
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
%% ____ _ _ _ _
|
||
|
|
%% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ / |
|
||
|
|
%% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ | |
|
||
|
|
%% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | | |
|
||
|
|
%% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_|
|
||
|
|
%% |_| |___/
|
||
|
|
|
||
|
|
simpagation_head1_code(Head,RestHeads,OtherIDs,PragmaRule,F/A,Id,L,T) :-
|
||
|
|
PragmaRule = pragma(Rule,ids(_,Heads2IDs),Pragmas,_Name,RuleNb),
|
||
|
|
Rule = rule(_Heads,Heads2,Guard,Body),
|
||
|
|
|
||
|
|
head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
|
||
|
|
head_arg_matches(HeadPairs,[],FirstMatching,VarDict1),
|
||
|
|
|
||
|
|
build_head(F,A,Id,HeadVars,ClauseHead),
|
||
|
|
|
||
|
|
append(RestHeads,Heads2,Heads),
|
||
|
|
append(OtherIDs,Heads2IDs,IDs),
|
||
|
|
reorder_heads(RuleNb,Head,Heads,IDs,NHeads,NIDs),
|
||
|
|
rest_heads_retrieval_and_matching(NHeads,NIDs,Pragmas,Head,GetRestHeads,Susps,VarDict1,VarDict),
|
||
|
|
split_by_ids(NIDs,Susps,OtherIDs,Susps1,Susps2),
|
||
|
|
|
||
|
|
guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
|
||
|
|
guard_via_reschedule(GetRestHeads,GuardCopyList,ClauseHead-FirstMatching,RescheduledTest),
|
||
|
|
|
||
|
|
gen_uncond_susps_detachments(Susps1,RestHeads,SuspsDetachments),
|
||
|
|
gen_cond_susp_detachment(Id,Susp,F/A,SuspDetachment),
|
||
|
|
|
||
|
|
( chr_pp_flag(debugable,on) ->
|
||
|
|
my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody),
|
||
|
|
DebugTry = 'chr debug_event'( try([Susp|Susps1],Susps2,DebugGuard,DebugBody)),
|
||
|
|
DebugApply = 'chr debug_event'(apply([Susp|Susps1],Susps2,DebugGuard,DebugBody))
|
||
|
|
;
|
||
|
|
DebugTry = true,
|
||
|
|
DebugApply = true
|
||
|
|
),
|
||
|
|
|
||
|
|
Clause = ( ClauseHead :-
|
||
|
|
FirstMatching,
|
||
|
|
RescheduledTest,
|
||
|
|
DebugTry,
|
||
|
|
!,
|
||
|
|
DebugApply,
|
||
|
|
SuspsDetachments,
|
||
|
|
SuspDetachment,
|
||
|
|
BodyCopy
|
||
|
|
),
|
||
|
|
L = [Clause | T].
|
||
|
|
|
||
|
|
split_by_ids([],[],_,[],[]).
|
||
|
|
split_by_ids([I|Is],[S|Ss],I1s,S1s,S2s) :-
|
||
|
|
( memberchk_eq(I,I1s) ->
|
||
|
|
S1s = [S | R1s],
|
||
|
|
S2s = R2s
|
||
|
|
;
|
||
|
|
S1s = R1s,
|
||
|
|
S2s = [S | R2s]
|
||
|
|
),
|
||
|
|
split_by_ids(Is,Ss,I1s,R1s,R2s).
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
%% ____ _ _ _ ____
|
||
|
|
%% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ |___ \
|
||
|
|
%% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ __) |
|
||
|
|
%% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | / __/
|
||
|
|
%% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_____|
|
||
|
|
%% |_| |___/
|
||
|
|
|
||
|
|
%% Genereate prelude + worker predicate
|
||
|
|
%% prelude calls worker
|
||
|
|
%% worker iterates over one type of removed constraints
|
||
|
|
simpagation_head2_code(Head2,RestHeads2,RestIDs,PragmaRule,FA,Id,L,T) :-
|
||
|
|
PragmaRule = pragma(Rule,ids(IDs1,_),Pragmas,_Name,RuleNb),
|
||
|
|
Rule = rule(Heads1,_,Guard,Body),
|
||
|
|
reorder_heads(RuleNb,Head2,Heads1,IDs1,[Head1|RestHeads1],[ID1|RestIDs1]), % Heads1 = [Head1|RestHeads1],
|
||
|
|
% IDs1 = [ID1|RestIDs1],
|
||
|
|
simpagation_head2_prelude(Head2,Head1,[RestHeads2,Heads1,Guard,Body],FA,Id,L,L1),
|
||
|
|
extend_id(Id,Id2),
|
||
|
|
simpagation_head2_worker(Head2,Head1,ID1,RestHeads1,RestIDs1,RestHeads2,RestIDs,PragmaRule,FA,Id2,L1,T).
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
simpagation_head2_prelude(Head,Head1,Rest,F/A,Id1,L,T) :-
|
||
|
|
head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
|
||
|
|
build_head(F,A,Id1,VarsSusp,ClauseHead),
|
||
|
|
head_arg_matches(HeadPairs,[],FirstMatching,VarDict),
|
||
|
|
|
||
|
|
lookup_passive_head(Head1,[Head],VarDict,ModConstraintsGoal,AllSusps),
|
||
|
|
|
||
|
|
gen_allocation(Id1,Vars,Susp,F/A,VarsSusp,ConstraintAllocationGoal),
|
||
|
|
|
||
|
|
extend_id(Id1,DelegateId),
|
||
|
|
extra_active_delegate_variables(Head,Rest,VarDict,ExtraVars),
|
||
|
|
append([AllSusps|VarsSusp],ExtraVars,DelegateCallVars),
|
||
|
|
build_head(F,A,DelegateId,DelegateCallVars,Delegate),
|
||
|
|
|
||
|
|
PreludeClause =
|
||
|
|
( ClauseHead :-
|
||
|
|
FirstMatching,
|
||
|
|
ModConstraintsGoal,
|
||
|
|
!,
|
||
|
|
ConstraintAllocationGoal,
|
||
|
|
Delegate
|
||
|
|
),
|
||
|
|
L = [PreludeClause|T].
|
||
|
|
|
||
|
|
extra_active_delegate_variables(Term,Terms,VarDict,Vars) :-
|
||
|
|
Term =.. [_|Args],
|
||
|
|
delegate_variables(Term,Terms,VarDict,Args,Vars).
|
||
|
|
|
||
|
|
passive_delegate_variables(Term,PrevTerms,NextTerms,VarDict,Vars) :-
|
||
|
|
term_variables(PrevTerms,PrevVars),
|
||
|
|
delegate_variables(Term,NextTerms,VarDict,PrevVars,Vars).
|
||
|
|
|
||
|
|
delegate_variables(Term,Terms,VarDict,PrevVars,Vars) :-
|
||
|
|
term_variables(Term,V1),
|
||
|
|
term_variables(Terms,V2),
|
||
|
|
intersect_eq(V1,V2,V3),
|
||
|
|
list_difference_eq(V3,PrevVars,V4),
|
||
|
|
translate(V4,VarDict,Vars).
|
||
|
|
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
simpagation_head2_worker(Head2,Head1,ID1,RestHeads1,IDs1,RestHeads2,IDs2,PragmaRule,FA,Id,L,T) :-
|
||
|
|
PragmaRule = pragma(Rule,_,_,_,_),
|
||
|
|
Rule = rule(_,_,Guard,Body),
|
||
|
|
simpagation_head2_worker_end(Head2,[Head1,RestHeads1,RestHeads2,Guard,Body],FA,Id,L,L1),
|
||
|
|
simpagation_head2_worker_body(Head2,Head1,ID1,RestHeads1,IDs1,RestHeads2,IDs2,PragmaRule,FA,Id,L1,T).
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
simpagation_head2_worker_body(Head2,Head1,ID1,RestHeads1,IDs1,RestHeads2,IDs2,PragmaRule,F/A,Id,L,T) :-
|
||
|
|
gen_var(OtherSusp),
|
||
|
|
gen_var(OtherSusps),
|
||
|
|
|
||
|
|
head_info(Head2,A,_Vars,Susp,VarsSusp,Head2Pairs),
|
||
|
|
head_arg_matches(Head2Pairs,[],_,VarDict1),
|
||
|
|
|
||
|
|
PragmaRule = pragma(Rule,_,Pragmas,_,RuleNb),
|
||
|
|
Rule = rule(_,_,Guard,Body),
|
||
|
|
extra_active_delegate_variables(Head2,[Head1,RestHeads1,RestHeads2,Guard,Body],VarDict1,ExtraVars),
|
||
|
|
append([[OtherSusp|OtherSusps]|VarsSusp],ExtraVars,HeadVars),
|
||
|
|
build_head(F,A,Id,HeadVars,ClauseHead),
|
||
|
|
|
||
|
|
functor(Head1,_OtherF,OtherA),
|
||
|
|
head_info(Head1,OtherA,OtherVars,_,_,Head1Pairs),
|
||
|
|
head_arg_matches(Head1Pairs,VarDict1,FirstMatching,VarDict2),
|
||
|
|
|
||
|
|
OtherSuspension =.. [suspension,_,OtherState,_,_,_,_|OtherVars],
|
||
|
|
create_get_mutable_ref(active,OtherState,GetMutable),
|
||
|
|
IteratorSuspTest =
|
||
|
|
( OtherSusp = OtherSuspension,
|
||
|
|
GetMutable
|
||
|
|
),
|
||
|
|
|
||
|
|
( (RestHeads1 \== [] ; RestHeads2 \== []) ->
|
||
|
|
append(RestHeads1,RestHeads2,RestHeads),
|
||
|
|
append(IDs1,IDs2,IDs),
|
||
|
|
reorder_heads(RuleNb,Head1-Head2,RestHeads,IDs,NRestHeads,NIDs),
|
||
|
|
rest_heads_retrieval_and_matching(NRestHeads,NIDs,Pragmas,[Head1,Head2],RestSuspsRetrieval,Susps,VarDict2,VarDict,[Head1],[OtherSusp],[]),
|
||
|
|
split_by_ids(NIDs,Susps,IDs1,Susps1,Susps2)
|
||
|
|
; RestSuspsRetrieval = [],
|
||
|
|
Susps1 = [],
|
||
|
|
Susps2 = [],
|
||
|
|
VarDict = VarDict2
|
||
|
|
),
|
||
|
|
|
||
|
|
gen_uncond_susps_detachments([OtherSusp | Susps1],[Head1|RestHeads1],Susps1Detachments),
|
||
|
|
|
||
|
|
append([OtherSusps|VarsSusp],ExtraVars,RecursiveVars),
|
||
|
|
build_head(F,A,Id,RecursiveVars,RecursiveCall),
|
||
|
|
append([[]|VarsSusp],ExtraVars,RecursiveVars2),
|
||
|
|
build_head(F,A,Id,RecursiveVars2,RecursiveCall2),
|
||
|
|
|
||
|
|
guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
|
||
|
|
guard_via_reschedule(RestSuspsRetrieval,GuardCopyList,v(ClauseHead,IteratorSuspTest,FirstMatching),RescheduledTest),
|
||
|
|
( BodyCopy \== true ->
|
||
|
|
gen_uncond_attach_goal(F/A,Susp,Attachment,Generation),
|
||
|
|
gen_state_cond_call(Susp,A,RecursiveCall,Generation,ConditionalRecursiveCall),
|
||
|
|
gen_state_cond_call(Susp,A,RecursiveCall2,Generation,ConditionalRecursiveCall2)
|
||
|
|
; Attachment = true,
|
||
|
|
ConditionalRecursiveCall = RecursiveCall,
|
||
|
|
ConditionalRecursiveCall2 = RecursiveCall2
|
||
|
|
),
|
||
|
|
|
||
|
|
( chr_pp_flag(debugable,on) ->
|
||
|
|
my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody),
|
||
|
|
DebugTry = 'chr debug_event'( try([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody)),
|
||
|
|
DebugApply = 'chr debug_event'(apply([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody))
|
||
|
|
;
|
||
|
|
DebugTry = true,
|
||
|
|
DebugApply = true
|
||
|
|
),
|
||
|
|
|
||
|
|
( member(unique(ID1,UniqueKeys), Pragmas),
|
||
|
|
check_unique_keys(UniqueKeys,VarDict1) ->
|
||
|
|
Clause =
|
||
|
|
( ClauseHead :-
|
||
|
|
( IteratorSuspTest,
|
||
|
|
FirstMatching ->
|
||
|
|
( RescheduledTest,
|
||
|
|
DebugTry ->
|
||
|
|
DebugApply,
|
||
|
|
Susps1Detachments,
|
||
|
|
Attachment,
|
||
|
|
BodyCopy,
|
||
|
|
ConditionalRecursiveCall2
|
||
|
|
;
|
||
|
|
RecursiveCall2
|
||
|
|
)
|
||
|
|
;
|
||
|
|
RecursiveCall
|
||
|
|
)
|
||
|
|
)
|
||
|
|
;
|
||
|
|
Clause =
|
||
|
|
( ClauseHead :-
|
||
|
|
( IteratorSuspTest,
|
||
|
|
FirstMatching,
|
||
|
|
RescheduledTest,
|
||
|
|
DebugTry ->
|
||
|
|
DebugApply,
|
||
|
|
Susps1Detachments,
|
||
|
|
Attachment,
|
||
|
|
BodyCopy,
|
||
|
|
ConditionalRecursiveCall
|
||
|
|
;
|
||
|
|
RecursiveCall
|
||
|
|
)
|
||
|
|
)
|
||
|
|
),
|
||
|
|
L = [Clause | T].
|
||
|
|
|
||
|
|
gen_state_cond_call(Susp,N,Call,Generation,ConditionalCall) :-
|
||
|
|
length(Args,N),
|
||
|
|
Suspension =.. [suspension,_,State,_,NewGeneration,_,_|Args],
|
||
|
|
create_get_mutable_ref(active,State,GetState),
|
||
|
|
create_get_mutable_ref(Generation,NewGeneration,GetGeneration),
|
||
|
|
ConditionalCall =
|
||
|
|
( Susp = Suspension,
|
||
|
|
GetState,
|
||
|
|
GetGeneration ->
|
||
|
|
'chr update_mutable'(inactive,State),
|
||
|
|
Call
|
||
|
|
; true
|
||
|
|
).
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
simpagation_head2_worker_end(Head,Rest,F/A,Id,L,T) :-
|
||
|
|
head_info(Head,A,_Vars,_Susp,VarsSusp,Pairs),
|
||
|
|
head_arg_matches(Pairs,[],_,VarDict),
|
||
|
|
extra_active_delegate_variables(Head,Rest,VarDict,ExtraVars),
|
||
|
|
append([[]|VarsSusp],ExtraVars,HeadVars),
|
||
|
|
build_head(F,A,Id,HeadVars,ClauseHead),
|
||
|
|
next_id(Id,ContinuationId),
|
||
|
|
build_head(F,A,ContinuationId,VarsSusp,ContinuationHead),
|
||
|
|
Clause = ( ClauseHead :- ContinuationHead ),
|
||
|
|
L = [Clause | T].
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
%% ____ _ _
|
||
|
|
%% | _ \ _ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __
|
||
|
|
%% | |_) | '__/ _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \
|
||
|
|
%% | __/| | | (_) | |_) | (_| | (_| | (_| | |_| | (_) | | | |
|
||
|
|
%% |_| |_| \___/| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_|
|
||
|
|
%% |_| |___/
|
||
|
|
|
||
|
|
propagation_code(Head,RestHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T) :-
|
||
|
|
( RestHeads == [] ->
|
||
|
|
propagation_single_headed(Head,Rule,RuleNb,FA,Id,L,T)
|
||
|
|
;
|
||
|
|
propagation_multi_headed(Head,RestHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T)
|
||
|
|
).
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
%% Single headed propagation
|
||
|
|
%% everything in a single clause
|
||
|
|
propagation_single_headed(Head,Rule,RuleNb,F/A,Id,L,T) :-
|
||
|
|
head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
|
||
|
|
build_head(F,A,Id,VarsSusp,ClauseHead),
|
||
|
|
|
||
|
|
inc_id(Id,NextId),
|
||
|
|
build_head(F,A,NextId,VarsSusp,NextHead),
|
||
|
|
|
||
|
|
NextCall = NextHead,
|
||
|
|
|
||
|
|
head_arg_matches(HeadPairs,[],HeadMatching,VarDict),
|
||
|
|
guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
|
||
|
|
gen_allocation(Id,Vars,Susp,F/A,VarsSusp,Allocation),
|
||
|
|
gen_uncond_attach_goal(F/A,Susp,Attachment,Generation),
|
||
|
|
|
||
|
|
gen_state_cond_call(Susp,A,NextCall,Generation,ConditionalNextCall),
|
||
|
|
|
||
|
|
( chr_pp_flag(debugable,on) ->
|
||
|
|
Rule = rule(_,_,Guard,Body),
|
||
|
|
my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody),
|
||
|
|
DebugTry = 'chr debug_event'( try([],[Susp],DebugGuard,DebugBody)),
|
||
|
|
DebugApply = 'chr debug_event'(apply([],[Susp],DebugGuard,DebugBody))
|
||
|
|
;
|
||
|
|
DebugTry = true,
|
||
|
|
DebugApply = true
|
||
|
|
),
|
||
|
|
|
||
|
|
Clause = (
|
||
|
|
ClauseHead :-
|
||
|
|
HeadMatching,
|
||
|
|
Allocation,
|
||
|
|
'chr novel_production'(Susp,RuleNb), % optimisation of t(RuleNb,Susp)
|
||
|
|
GuardCopy,
|
||
|
|
DebugTry,
|
||
|
|
!,
|
||
|
|
DebugApply,
|
||
|
|
'chr extend_history'(Susp,RuleNb),
|
||
|
|
Attachment,
|
||
|
|
BodyCopy,
|
||
|
|
ConditionalNextCall
|
||
|
|
),
|
||
|
|
L = [Clause | T].
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
%% multi headed propagation
|
||
|
|
%% prelude + predicates to accumulate the necessary combinations of suspended
|
||
|
|
%% constraints + predicate to execute the body
|
||
|
|
propagation_multi_headed(Head,RestHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T) :-
|
||
|
|
RestHeads = [First|Rest],
|
||
|
|
propagation_prelude(Head,RestHeads,Rule,FA,Id,L,L1),
|
||
|
|
extend_id(Id,ExtendedId),
|
||
|
|
propagation_nested_code(Rest,[First,Head],Rule,RuleNb,RestHeadNb,FA,ExtendedId,L1,T).
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
propagation_prelude(Head,[First|Rest],Rule,F/A,Id,L,T) :-
|
||
|
|
head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
|
||
|
|
build_head(F,A,Id,VarsSusp,PreludeHead),
|
||
|
|
head_arg_matches(HeadPairs,[],FirstMatching,VarDict),
|
||
|
|
Rule = rule(_,_,Guard,Body),
|
||
|
|
extra_active_delegate_variables(Head,[First,Rest,Guard,Body],VarDict,ExtraVars),
|
||
|
|
|
||
|
|
lookup_passive_head(First,[Head],VarDict,FirstSuspGoal,Susps),
|
||
|
|
|
||
|
|
gen_allocation(Id,Vars,Susp,F/A,VarsSusp,CondAllocation),
|
||
|
|
|
||
|
|
extend_id(Id,NestedId),
|
||
|
|
append([Susps|VarsSusp],ExtraVars,NestedVars),
|
||
|
|
build_head(F,A,NestedId,NestedVars,NestedHead),
|
||
|
|
NestedCall = NestedHead,
|
||
|
|
|
||
|
|
Prelude = (
|
||
|
|
PreludeHead :-
|
||
|
|
FirstMatching,
|
||
|
|
FirstSuspGoal,
|
||
|
|
!,
|
||
|
|
CondAllocation,
|
||
|
|
NestedCall
|
||
|
|
),
|
||
|
|
L = [Prelude|T].
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
propagation_nested_code([],[CurrentHead|PreHeads],Rule,RuleNb,RestHeadNb,FA,Id,L,T) :-
|
||
|
|
propagation_end([CurrentHead|PreHeads],[],Rule,FA,Id,L,L1),
|
||
|
|
propagation_body(CurrentHead,PreHeads,Rule,RuleNb,RestHeadNb,FA,Id,L1,T).
|
||
|
|
|
||
|
|
propagation_nested_code([Head|RestHeads],PreHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T) :-
|
||
|
|
propagation_end(PreHeads,[Head|RestHeads],Rule,FA,Id,L,L1),
|
||
|
|
propagation_accumulator([Head|RestHeads],PreHeads,Rule,FA,Id,L1,L2),
|
||
|
|
inc_id(Id,IncId),
|
||
|
|
propagation_nested_code(RestHeads,[Head|PreHeads],Rule,RuleNb,RestHeadNb,FA,IncId,L2,T).
|
||
|
|
|
||
|
|
propagation_body(CurrentHead,PreHeads,Rule,RuleNb,RestHeadNb,F/A,Id,L,T) :-
|
||
|
|
Rule = rule(_,_,Guard,Body),
|
||
|
|
get_prop_inner_loop_vars(PreHeads,[CurrentHead,Guard,Body],PreVarsAndSusps,VarDict1,Susp,RestSusps),
|
||
|
|
gen_var(OtherSusp),
|
||
|
|
gen_var(OtherSusps),
|
||
|
|
functor(CurrentHead,_OtherF,OtherA),
|
||
|
|
gen_vars(OtherA,OtherVars),
|
||
|
|
Suspension =.. [suspension,_,State,_,_,_,_|OtherVars],
|
||
|
|
create_get_mutable_ref(active,State,GetMutable),
|
||
|
|
CurrentSuspTest = (
|
||
|
|
OtherSusp = Suspension,
|
||
|
|
GetMutable
|
||
|
|
),
|
||
|
|
ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
|
||
|
|
build_head(F,A,Id,ClauseVars,ClauseHead),
|
||
|
|
RecursiveVars = [OtherSusps|PreVarsAndSusps],
|
||
|
|
build_head(F,A,Id,RecursiveVars,RecursiveHead),
|
||
|
|
RecursiveCall = RecursiveHead,
|
||
|
|
CurrentHead =.. [_|OtherArgs],
|
||
|
|
pairup(OtherArgs,OtherVars,OtherPairs),
|
||
|
|
head_arg_matches(OtherPairs,VarDict1,Matching,VarDict),
|
||
|
|
|
||
|
|
different_from_other_susps(CurrentHead,OtherSusp,PreHeads,RestSusps,DiffSuspGoals),
|
||
|
|
|
||
|
|
guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
|
||
|
|
gen_uncond_attach_goal(F/A,Susp,Attach,Generation),
|
||
|
|
gen_state_cond_call(Susp,A,RecursiveCall,Generation,ConditionalRecursiveCall),
|
||
|
|
|
||
|
|
history_susps(RestHeadNb,[OtherSusp|RestSusps],Susp,[],HistorySusps),
|
||
|
|
bagof('chr novel_production'(X,Y),( member(X,HistorySusps), Y = TupleVar) ,NovelProductionsList),
|
||
|
|
list2conj(NovelProductionsList,NovelProductions),
|
||
|
|
Tuple =.. [t,RuleNb|HistorySusps],
|
||
|
|
|
||
|
|
( chr_pp_flag(debugable,on) ->
|
||
|
|
Rule = rule(_,_,Guard,Body),
|
||
|
|
my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody),
|
||
|
|
DebugTry = 'chr debug_event'( try([],[Susp,OtherSusp|RestSusps],DebugGuard,DebugBody)),
|
||
|
|
DebugApply = 'chr debug_event'(apply([],[Susp,OtherSusp|RestSusps],DebugGuard,DebugBody))
|
||
|
|
;
|
||
|
|
DebugTry = true,
|
||
|
|
DebugApply = true
|
||
|
|
),
|
||
|
|
|
||
|
|
Clause = (
|
||
|
|
ClauseHead :-
|
||
|
|
( CurrentSuspTest,
|
||
|
|
DiffSuspGoals,
|
||
|
|
Matching,
|
||
|
|
TupleVar = Tuple,
|
||
|
|
NovelProductions,
|
||
|
|
GuardCopy,
|
||
|
|
DebugTry ->
|
||
|
|
DebugApply,
|
||
|
|
'chr extend_history'(Susp,TupleVar),
|
||
|
|
Attach,
|
||
|
|
BodyCopy,
|
||
|
|
ConditionalRecursiveCall
|
||
|
|
; RecursiveCall
|
||
|
|
)
|
||
|
|
),
|
||
|
|
L = [Clause|T].
|
||
|
|
|
||
|
|
history_susps(Count,OtherSusps,Susp,Acc,HistorySusps) :-
|
||
|
|
( Count == 0 ->
|
||
|
|
reverse(OtherSusps,ReversedSusps),
|
||
|
|
append(ReversedSusps,[Susp|Acc],HistorySusps)
|
||
|
|
;
|
||
|
|
OtherSusps = [OtherSusp|RestOtherSusps],
|
||
|
|
NCount is Count - 1,
|
||
|
|
history_susps(NCount,RestOtherSusps,Susp,[OtherSusp|Acc],HistorySusps)
|
||
|
|
).
|
||
|
|
|
||
|
|
get_prop_inner_loop_vars([Head],Terms,HeadVars,VarDict,Susp,[]) :-
|
||
|
|
!,
|
||
|
|
functor(Head,_F,A),
|
||
|
|
head_info(Head,A,_Vars,Susp,VarsSusp,Pairs),
|
||
|
|
head_arg_matches(Pairs,[],_,VarDict),
|
||
|
|
extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
|
||
|
|
append(VarsSusp,ExtraVars,HeadVars).
|
||
|
|
get_prop_inner_loop_vars([Head|Heads],Terms,VarsSusps,NVarDict,MainSusp,[Susp|RestSusps]) :-
|
||
|
|
get_prop_inner_loop_vars(Heads,[Head|Terms],RestVarsSusp,VarDict,MainSusp,RestSusps),
|
||
|
|
functor(Head,_F,A),
|
||
|
|
gen_var(Susps),
|
||
|
|
head_info(Head,A,_Vars,Susp,_VarsSusp,Pairs),
|
||
|
|
head_arg_matches(Pairs,VarDict,_,NVarDict),
|
||
|
|
passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
|
||
|
|
append(HeadVars,[Susp,Susps|RestVarsSusp],VarsSusps).
|
||
|
|
|
||
|
|
propagation_end([CurrentHead|PrevHeads],NextHeads,Rule,F/A,Id,L,T) :-
|
||
|
|
Rule = rule(_,_,Guard,Body),
|
||
|
|
gen_var_susp_list_for(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSusps,AllButFirst,FirstSusp),
|
||
|
|
|
||
|
|
Vars = [ [] | VarsAndSusps],
|
||
|
|
|
||
|
|
build_head(F,A,Id,Vars,Head),
|
||
|
|
|
||
|
|
( Id = [0|_] ->
|
||
|
|
next_id(Id,PrevId),
|
||
|
|
PrevVarsAndSusps = AllButFirst
|
||
|
|
;
|
||
|
|
dec_id(Id,PrevId),
|
||
|
|
PrevVarsAndSusps = [FirstSusp|AllButFirst]
|
||
|
|
),
|
||
|
|
|
||
|
|
build_head(F,A,PrevId,PrevVarsAndSusps,PrevHead),
|
||
|
|
PredecessorCall = PrevHead,
|
||
|
|
|
||
|
|
Clause = (
|
||
|
|
Head :-
|
||
|
|
PredecessorCall
|
||
|
|
),
|
||
|
|
L = [Clause | T].
|
||
|
|
|
||
|
|
gen_var_susp_list_for([Head],Terms,VarDict,HeadVars,VarsSusp,Susp) :-
|
||
|
|
!,
|
||
|
|
functor(Head,_F,A),
|
||
|
|
head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs),
|
||
|
|
head_arg_matches(HeadPairs,[],_,VarDict),
|
||
|
|
extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
|
||
|
|
append(VarsSusp,ExtraVars,HeadVars).
|
||
|
|
gen_var_susp_list_for([Head|Heads],Terms,NVarDict,VarsSusps,Rest,Susps) :-
|
||
|
|
gen_var_susp_list_for(Heads,[Head|Terms],VarDict,Rest,_,_),
|
||
|
|
functor(Head,_F,A),
|
||
|
|
gen_var(Susps),
|
||
|
|
head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
|
||
|
|
head_arg_matches(HeadPairs,VarDict,_,NVarDict),
|
||
|
|
passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
|
||
|
|
append(HeadVars,[Susp,Susps|Rest],VarsSusps).
|
||
|
|
|
||
|
|
propagation_accumulator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,Id,L,T) :-
|
||
|
|
Rule = rule(_,_,Guard,Body),
|
||
|
|
pre_vars_and_susps(PreHeads,[CurrentHead,NextHead,RestHeads,Guard,Body],PreVarsAndSusps,VarDict,PreSusps),
|
||
|
|
gen_var(OtherSusps),
|
||
|
|
functor(CurrentHead,_OtherF,OtherA),
|
||
|
|
gen_vars(OtherA,OtherVars),
|
||
|
|
head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
|
||
|
|
head_arg_matches(HeadPairs,VarDict,FirstMatching,VarDict1),
|
||
|
|
|
||
|
|
OtherSuspension =.. [suspension,_,State,_,_,_,_|OtherVars],
|
||
|
|
|
||
|
|
different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
|
||
|
|
create_get_mutable_ref(active,State,GetMutable),
|
||
|
|
CurrentSuspTest = (
|
||
|
|
OtherSusp = OtherSuspension,
|
||
|
|
GetMutable,
|
||
|
|
DiffSuspGoals,
|
||
|
|
FirstMatching
|
||
|
|
),
|
||
|
|
lookup_passive_head(NextHead,[CurrentHead|PreHeads],VarDict1,NextSuspGoal,NextSusps),
|
||
|
|
inc_id(Id,NestedId),
|
||
|
|
ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
|
||
|
|
build_head(F,A,Id,ClauseVars,ClauseHead),
|
||
|
|
passive_delegate_variables(CurrentHead,PreHeads,[NextHead,RestHeads,Guard,Body],VarDict1,CurrentHeadVars),
|
||
|
|
append([NextSusps|CurrentHeadVars],[OtherSusp,OtherSusps|PreVarsAndSusps],NestedVars),
|
||
|
|
build_head(F,A,NestedId,NestedVars,NestedHead),
|
||
|
|
|
||
|
|
RecursiveVars = [OtherSusps|PreVarsAndSusps],
|
||
|
|
build_head(F,A,Id,RecursiveVars,RecursiveHead),
|
||
|
|
Clause = (
|
||
|
|
ClauseHead :-
|
||
|
|
( CurrentSuspTest,
|
||
|
|
NextSuspGoal
|
||
|
|
->
|
||
|
|
NestedHead
|
||
|
|
; RecursiveHead
|
||
|
|
)
|
||
|
|
),
|
||
|
|
L = [Clause|T].
|
||
|
|
|
||
|
|
pre_vars_and_susps([Head],Terms,HeadVars,VarDict,[]) :-
|
||
|
|
!,
|
||
|
|
functor(Head,_F,A),
|
||
|
|
head_info(Head,A,_Vars,_Susp,VarsSusp,HeadPairs),
|
||
|
|
head_arg_matches(HeadPairs,[],_,VarDict),
|
||
|
|
extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
|
||
|
|
append(VarsSusp,ExtraVars,HeadVars).
|
||
|
|
pre_vars_and_susps([Head|Heads],Terms,NVSs,NVarDict,[Susp|Susps]) :-
|
||
|
|
pre_vars_and_susps(Heads,[Head|Terms],VSs,VarDict,Susps),
|
||
|
|
functor(Head,_F,A),
|
||
|
|
gen_var(NextSusps),
|
||
|
|
head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
|
||
|
|
head_arg_matches(HeadPairs,VarDict,_,NVarDict),
|
||
|
|
passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
|
||
|
|
append(HeadVars,[Susp,NextSusps|VSs],NVSs).
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
%% ____ _ _ _ _
|
||
|
|
%% | _ \ __ _ ___ ___(_)_ _____ | | | | ___ __ _ __| |
|
||
|
|
%% | |_) / _` / __/ __| \ \ / / _ \ | |_| |/ _ \/ _` |/ _` |
|
||
|
|
%% | __/ (_| \__ \__ \ |\ V / __/ | _ | __/ (_| | (_| |
|
||
|
|
%% |_| \__,_|___/___/_| \_/ \___| |_| |_|\___|\__,_|\__,_|
|
||
|
|
%%
|
||
|
|
%% ____ _ _ _
|
||
|
|
%% | _ \ ___| |_ _ __(_) _____ ____ _| |
|
||
|
|
%% | |_) / _ \ __| '__| |/ _ \ \ / / _` | |
|
||
|
|
%% | _ < __/ |_| | | | __/\ V / (_| | |
|
||
|
|
%% |_| \_\___|\__|_| |_|\___| \_/ \__,_|_|
|
||
|
|
%%
|
||
|
|
%% ____ _ _
|
||
|
|
%% | _ \ ___ ___ _ __ __| | ___ _ __(_)_ __ __ _
|
||
|
|
%% | |_) / _ \/ _ \| '__/ _` |/ _ \ '__| | '_ \ / _` |
|
||
|
|
%% | _ < __/ (_) | | | (_| | __/ | | | | | | (_| |
|
||
|
|
%% |_| \_\___|\___/|_| \__,_|\___|_| |_|_| |_|\__, |
|
||
|
|
%% |___/
|
||
|
|
|
||
|
|
reorder_heads(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
|
||
|
|
( chr_pp_flag(reorder_heads,on) ->
|
||
|
|
reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs)
|
||
|
|
;
|
||
|
|
NRestHeads = RestHeads,
|
||
|
|
NRestIDs = RestIDs
|
||
|
|
).
|
||
|
|
|
||
|
|
reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
|
||
|
|
term_variables(Head,Vars),
|
||
|
|
InitialData = entry([],[],Vars,RestHeads,RestIDs,RuleNb),
|
||
|
|
a_star(InitialData,FD^(chr_translate:final_data(FD)),N^EN^C^(chr_translate:expand_data(N,EN,C)),FinalData),
|
||
|
|
FinalData = entry(RNRestHeads,RNRestIDs,_,_,_,_),
|
||
|
|
reverse(RNRestHeads,NRestHeads),
|
||
|
|
reverse(RNRestIDs,NRestIDs).
|
||
|
|
|
||
|
|
final_data(Entry) :-
|
||
|
|
Entry = entry(_,_,_,_,[],_).
|
||
|
|
|
||
|
|
expand_data(Entry,NEntry,Cost) :-
|
||
|
|
Entry = entry(Heads,IDs,Vars,NHeads,NIDs,RuleNb),
|
||
|
|
term_variables(Entry,EVars),
|
||
|
|
NEntry = entry([Head1|Heads],[ID1|IDs],Vars1,NHeads1,NIDs1,RuleNb),
|
||
|
|
select2(Head1,ID1,NHeads,NIDs,NHeads1,NIDs1),
|
||
|
|
order_score(Head1,ID1,Vars,NHeads1,RuleNb,Cost),
|
||
|
|
term_variables([Head1|Vars],Vars1).
|
||
|
|
|
||
|
|
order_score(Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
|
||
|
|
functor(Head,F,A),
|
||
|
|
get_store_type(F/A,StoreType),
|
||
|
|
order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,Score).
|
||
|
|
|
||
|
|
order_score(default,Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
|
||
|
|
term_variables(Head,HeadVars),
|
||
|
|
term_variables(RestHeads,RestVars),
|
||
|
|
order_score_vars(HeadVars,KnownVars,RestHeads,0,Score).
|
||
|
|
order_score(multi_hash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
|
||
|
|
order_score_indexes(Indexes,Head,KnownVars,0,Score).
|
||
|
|
order_score(global_ground,Head,ID,_KnownVars,_RestHeads,RuleNb,Score) :-
|
||
|
|
functor(Head,F,A),
|
||
|
|
( get_pragma_unique(RuleNb,ID,Vars),
|
||
|
|
Vars == [] ->
|
||
|
|
Score = 1 % guaranteed O(1)
|
||
|
|
; A == 0 -> % flag constraint
|
||
|
|
Score = 10 % O(1)? [CHECK: no deleted/triggered/... constraints in store?]
|
||
|
|
; A > 0 ->
|
||
|
|
Score = 100
|
||
|
|
).
|
||
|
|
|
||
|
|
order_score(multi_store(StoreTypes),Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
|
||
|
|
find_with_var_identity(
|
||
|
|
S,
|
||
|
|
t(Head,KnownVars,RestHeads),
|
||
|
|
( member(ST,StoreTypes), chr_translate:order_score(ST,Head,ID,KnownVars,RestHeads,RuleNb,S) ),
|
||
|
|
Scores
|
||
|
|
),
|
||
|
|
min_list(Scores,Score).
|
||
|
|
|
||
|
|
|
||
|
|
order_score_indexes([],_,_,Score,Score) :-
|
||
|
|
Score > 0.
|
||
|
|
order_score_indexes([I|Is],Head,KnownVars,Score,NScore) :-
|
||
|
|
multi_hash_key_args(I,Head,Args),
|
||
|
|
( forall(Arg,Args,hprolog:memberchk_eq(Arg,KnownVars)) ->
|
||
|
|
Score1 is Score + 10
|
||
|
|
;
|
||
|
|
Score1 = Score
|
||
|
|
),
|
||
|
|
order_score_indexes(Is,Head,KnownVars,Score1,NScore).
|
||
|
|
|
||
|
|
order_score_vars([],_,_,Score,NScore) :-
|
||
|
|
( Score == 0 ->
|
||
|
|
NScore = 0
|
||
|
|
;
|
||
|
|
NScore = Score
|
||
|
|
).
|
||
|
|
order_score_vars([V|Vs],KnownVars,RestVars,Score,NScore) :-
|
||
|
|
( memberchk_eq(V,KnownVars) ->
|
||
|
|
TScore is Score + 10
|
||
|
|
; memberchk_eq(V,RestVars) ->
|
||
|
|
TScore is Score + 100
|
||
|
|
;
|
||
|
|
TScore = Score
|
||
|
|
),
|
||
|
|
order_score_vars(Vs,KnownVars,RestVars,TScore,NScore).
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
%% ___ _ _ _
|
||
|
|
%% |_ _|_ __ | (_)_ __ (_)_ __ __ _
|
||
|
|
%% | || '_ \| | | '_ \| | '_ \ / _` |
|
||
|
|
%% | || | | | | | | | | | | | | (_| |
|
||
|
|
%% |___|_| |_|_|_|_| |_|_|_| |_|\__, |
|
||
|
|
%% |___/
|
||
|
|
|
||
|
|
%% SWI begin
|
||
|
|
create_get_mutable_ref(V,M,GM) :- GM = (M = mutable(V)).
|
||
|
|
%% SWI end
|
||
|
|
|
||
|
|
%% SICStus begin
|
||
|
|
%% create_get_mutable_ref(V,M,GM) :- GM = get_mutable(V,M).
|
||
|
|
%% SICStus end
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
%% _ _ _ _ _ _ _
|
||
|
|
%% | | | | |_(_) (_) |_ _ _
|
||
|
|
%% | | | | __| | | | __| | | |
|
||
|
|
%% | |_| | |_| | | | |_| |_| |
|
||
|
|
%% \___/ \__|_|_|_|\__|\__, |
|
||
|
|
%% |___/
|
||
|
|
|
||
|
|
gen_var(_).
|
||
|
|
gen_vars(N,Xs) :-
|
||
|
|
length(Xs,N).
|
||
|
|
|
||
|
|
head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs) :-
|
||
|
|
vars_susp(A,Vars,Susp,VarsSusp),
|
||
|
|
Head =.. [_|Args],
|
||
|
|
pairup(Args,Vars,HeadPairs).
|
||
|
|
|
||
|
|
inc_id([N|Ns],[O|Ns]) :-
|
||
|
|
O is N + 1.
|
||
|
|
dec_id([N|Ns],[M|Ns]) :-
|
||
|
|
M is N - 1.
|
||
|
|
|
||
|
|
extend_id(Id,[0|Id]).
|
||
|
|
|
||
|
|
next_id([_,N|Ns],[O|Ns]) :-
|
||
|
|
O is N + 1.
|
||
|
|
|
||
|
|
build_head(F,A,Id,Args,Head) :-
|
||
|
|
buildName(F,A,Id,Name),
|
||
|
|
Head =.. [Name|Args].
|
||
|
|
|
||
|
|
buildName(Fct,Aty,List,Result) :-
|
||
|
|
atom_concat(Fct, (/) ,FctSlash),
|
||
|
|
atomic_concat(FctSlash,Aty,FctSlashAty),
|
||
|
|
buildName_(List,FctSlashAty,Result).
|
||
|
|
|
||
|
|
buildName_([],Name,Name).
|
||
|
|
buildName_([N|Ns],Name,Result) :-
|
||
|
|
buildName_(Ns,Name,Name1),
|
||
|
|
atom_concat(Name1,'__',NameDash), % '_' is a char :-(
|
||
|
|
atomic_concat(NameDash,N,Result).
|
||
|
|
|
||
|
|
vars_susp(A,Vars,Susp,VarsSusp) :-
|
||
|
|
length(Vars,A),
|
||
|
|
append(Vars,[Susp],VarsSusp).
|
||
|
|
|
||
|
|
make_attr(N,Mask,SuspsList,Attr) :-
|
||
|
|
length(SuspsList,N),
|
||
|
|
Attr =.. [v,Mask|SuspsList].
|
||
|
|
|
||
|
|
or_pattern(Pos,Pat) :-
|
||
|
|
Pow is Pos - 1,
|
||
|
|
Pat is 1 << Pow. % was 2 ** X
|
||
|
|
|
||
|
|
and_pattern(Pos,Pat) :-
|
||
|
|
X is Pos - 1,
|
||
|
|
Y is 1 << X, % was 2 ** X
|
||
|
|
Pat is (-1)*(Y + 1). % because fx (-) is redefined
|
||
|
|
|
||
|
|
conj2list(Conj,L) :- %% transform conjunctions to list
|
||
|
|
conj2list(Conj,L,[]).
|
||
|
|
|
||
|
|
conj2list(Conj,L,T) :-
|
||
|
|
Conj = (G1,G2), !,
|
||
|
|
conj2list(G1,L,T1),
|
||
|
|
conj2list(G2,T1,T).
|
||
|
|
conj2list(G,[G | T],T).
|
||
|
|
|
||
|
|
list2conj([],true).
|
||
|
|
list2conj([G],X) :- !, X = G.
|
||
|
|
list2conj([G|Gs],C) :-
|
||
|
|
( G == true -> %% remove some redundant trues
|
||
|
|
list2conj(Gs,C)
|
||
|
|
;
|
||
|
|
C = (G,R),
|
||
|
|
list2conj(Gs,R)
|
||
|
|
).
|
||
|
|
|
||
|
|
list2disj([],fail).
|
||
|
|
list2disj([G],X) :- !, X = G.
|
||
|
|
list2disj([G|Gs],C) :-
|
||
|
|
( G == fail -> %% remove some redundant fails
|
||
|
|
list2disj(Gs,C)
|
||
|
|
;
|
||
|
|
C = (G;R),
|
||
|
|
list2disj(Gs,R)
|
||
|
|
).
|
||
|
|
|
||
|
|
atom_concat_list([X],X) :- ! .
|
||
|
|
atom_concat_list([X|Xs],A) :-
|
||
|
|
atom_concat_list(Xs,B),
|
||
|
|
atomic_concat(X,B,A).
|
||
|
|
|
||
|
|
make_name(Prefix,F/A,Name) :-
|
||
|
|
atom_concat_list([Prefix,F,(/),A],Name).
|
||
|
|
|
||
|
|
set_elems([],_).
|
||
|
|
set_elems([X|Xs],X) :-
|
||
|
|
set_elems(Xs,X).
|
||
|
|
|
||
|
|
member2([X|_],[Y|_],X-Y).
|
||
|
|
member2([_|Xs],[_|Ys],P) :-
|
||
|
|
member2(Xs,Ys,P).
|
||
|
|
|
||
|
|
select2(X, Y, [X|Xs], [Y|Ys], Xs, Ys).
|
||
|
|
select2(X, Y, [X1|Xs], [Y1|Ys], [X1|NXs], [Y1|NYs]) :-
|
||
|
|
select2(X, Y, Xs, Ys, NXs, NYs).
|
||
|
|
|
||
|
|
pair_all_with([],_,[]).
|
||
|
|
pair_all_with([X|Xs],Y,[X-Y|Rest]) :-
|
||
|
|
pair_all_with(Xs,Y,Rest).
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
|
||
|
|
lookup_passive_head(Head,PreJoin,VarDict,Goal,AllSusps) :-
|
||
|
|
functor(Head,F,A),
|
||
|
|
get_store_type(F/A,StoreType),
|
||
|
|
lookup_passive_head(StoreType,Head,PreJoin,VarDict,Goal,AllSusps).
|
||
|
|
|
||
|
|
lookup_passive_head(default,Head,PreJoin,VarDict,Goal,AllSusps) :-
|
||
|
|
passive_head_via(Head,PreJoin,[],VarDict,Goal,Attr,AttrDict),
|
||
|
|
instantiate_pattern_goals(AttrDict),
|
||
|
|
get_max_constraint_index(N),
|
||
|
|
( N == 1 ->
|
||
|
|
AllSusps = Attr
|
||
|
|
;
|
||
|
|
functor(Head,F,A),
|
||
|
|
get_constraint_index(F/A,Pos),
|
||
|
|
make_attr(N,_,SuspsList,Attr),
|
||
|
|
nth1(Pos,SuspsList,AllSusps)
|
||
|
|
).
|
||
|
|
lookup_passive_head(multi_hash(Indexes),Head,_PreJoin,VarDict,Goal,AllSusps) :-
|
||
|
|
once((
|
||
|
|
member(Index,Indexes),
|
||
|
|
multi_hash_key_args(Index,Head,KeyArgs),
|
||
|
|
translate(KeyArgs,VarDict,KeyArgCopies)
|
||
|
|
)),
|
||
|
|
( KeyArgCopies = [KeyCopy] ->
|
||
|
|
true
|
||
|
|
;
|
||
|
|
KeyCopy =.. [k|KeyArgCopies]
|
||
|
|
),
|
||
|
|
functor(Head,F,A),
|
||
|
|
multi_hash_via_lookup_name(F/A,Index,ViaName),
|
||
|
|
Goal =.. [ViaName,KeyCopy,AllSusps],
|
||
|
|
update_store_type(F/A,multi_hash([Index])).
|
||
|
|
lookup_passive_head(global_ground,Head,PreJoin,_VarDict,Goal,AllSusps) :-
|
||
|
|
functor(Head,F,A),
|
||
|
|
global_ground_store_name(F/A,StoreName),
|
||
|
|
make_get_store_goal(StoreName,AllSusps,Goal), % Goal = nb_getval(StoreName,AllSusps),
|
||
|
|
update_store_type(F/A,global_ground).
|
||
|
|
lookup_passive_head(multi_store(StoreTypes),Head,PreJoin,VarDict,Goal,AllSusps) :-
|
||
|
|
once((
|
||
|
|
member(ST,StoreTypes),
|
||
|
|
lookup_passive_head(ST,Head,PreJoin,VarDict,Goal,AllSusps)
|
||
|
|
)).
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
assume_constraint_stores([]).
|
||
|
|
assume_constraint_stores([C|Cs]) :-
|
||
|
|
( \+ may_trigger(C),
|
||
|
|
is_attached(C),
|
||
|
|
get_store_type(C,default) ->
|
||
|
|
get_indexed_arguments(C,IndexedArgs),
|
||
|
|
findall(Index,(sublist(Index,IndexedArgs), Index \== []),Indexes),
|
||
|
|
assumed_store_type(C,multi_store([multi_hash(Indexes),global_ground]))
|
||
|
|
;
|
||
|
|
true
|
||
|
|
),
|
||
|
|
assume_constraint_stores(Cs).
|
||
|
|
|
||
|
|
get_indexed_arguments(C,IndexedArgs) :-
|
||
|
|
C = F/A,
|
||
|
|
get_indexed_arguments(1,A,C,IndexedArgs).
|
||
|
|
|
||
|
|
get_indexed_arguments(I,N,C,L) :-
|
||
|
|
( I > N ->
|
||
|
|
L = []
|
||
|
|
; ( is_indexed_argument(C,I) ->
|
||
|
|
L = [I|T]
|
||
|
|
;
|
||
|
|
L = T
|
||
|
|
),
|
||
|
|
J is I + 1,
|
||
|
|
get_indexed_arguments(J,N,C,T)
|
||
|
|
).
|
||
|
|
|
||
|
|
validate_store_type_assumptions([]).
|
||
|
|
validate_store_type_assumptions([C|Cs]) :-
|
||
|
|
validate_store_type_assumption(C),
|
||
|
|
validate_store_type_assumptions(Cs).
|
||
|
|
|
||
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
||
|
|
|
||
|
|
%% SWI begin
|
||
|
|
verbosity_on :- prolog_flag(verbose,V), V == yes.
|
||
|
|
%% SWI end
|
||
|
|
|
||
|
|
%% SICStus begin
|
||
|
|
%% verbosity_on. % at the moment
|
||
|
|
%% SICStus end
|