/* Part of CHR (Constraint Handling Rules) Author: Tom Schrijvers E-mail: Tom.Schrijvers@cs.kuleuven.be WWW: http://www.swi-prolog.org Copyright (c) 2004-2017, K.U. Leuven All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% %% ____ _ _ ____ ____ _ _ %% / ___| | | | _ \ / ___|___ _ __ ___ _ __ (_) | ___ _ __ %% | | | |_| | |_) | | | / _ \| '_ ` _ \| '_ \| | |/ _ \ '__| %% | |___| _ | _ < | |__| (_) | | | | | | |_) | | | __/ | %% \____|_| |_|_| \_\ \____\___/|_| |_| |_| .__/|_|_|\___|_| %% |_| %% %% 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 %% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% %% TODO {{{ %% %% URGENTLY TODO %% %% * add mode checking to debug mode %% * add groundness info to a.i.-based observation analysis %% * proper fd/index analysis %% * re-add generation checking %% * untangle CHR-level and target source-level generation & optimization %% %% AGGRESSIVE OPTIMISATION IDEAS %% %% * analyze history usage to determine whether/when %% cheaper suspension is possible: %% don't use history when all partners are passive and self never triggers %% * store constraint unconditionally for unconditional propagation rule, %% if first, i.e. without checking history and set trigger cont to next occ %% * get rid of suspension passing for never triggered constraints, %% up to allocation occurrence %% * get rid of call indirection for never triggered constraints %% up to first allocation occurrence. %% * get rid of unnecessary indirection if last active occurrence %% before unconditional removal is head2, e.g. %% a \ b <=> true. %% a <=> true. %% * Eliminate last clause of never stored constraint, if its body %% is fail, e.g. %% a ... %% a <=> fail. %% * Specialize lookup operations and indexes for functional dependencies. %% %% MORE TODO %% %% * map A \ B <=> true | true rules %% onto efficient code that empties the constraint stores of B %% in O(1) time for ground constraints where A and B do not share %% any variables %% * ground matching seems to be not optimized for compound terms %% in case of simpagation_head2 and propagation occurrences %% * analysis for storage delaying (see primes for case) %% * internal constraints declaration + analyses? %% * Do not store in global variable store if not necessary %% NOTE: affects show_store/1 %% * var_assoc multi-level store: variable - ground %% * Do not maintain/check unnecessary propagation history %% for reasons of anti-monotony %% * Strengthen storage analysis for propagation rules %% reason about bodies of rules only containing constraints %% -> fixpoint with observation analysis %% * instantiation declarations %% COMPOUND (bound to nonvar) %% avoid nonvar tests %% %% * make difference between cheap guards for reordering %% and non-binding guards for lock removal %% * fd -> 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 %% * (set semantics + functional dependency) declaration + resolution %% }}} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- module(chr_translate, [ chr_translate/2 % +Decls, -TranslatedDecls , chr_translate_line_info/3 % +DeclsWithLines, -TranslatedDecls ]). %% SWI begin {{{ :- use_module(library(lists)). :- use_module(library(sort)). :- use_module(library(ordsets)). :- use_module(library(aggregate)). :- use_module(library(apply_macros)). :- use_module(library(occurs)). :- use_module(library(assoc)). :- use_module(library(dialect/hprolog)). %% SWI end }}} % imports and operators {{{ :- use_module(chr(pairlist)). :- use_module(chr(a_star)). :- use_module(chr(listmap)). :- use_module(chr(clean_code)). :- use_module(chr(builtins)). :- use_module(chr(find)). :- use_module(chr(binomialheap)). :- use_module(chr(guard_entailment)). :- use_module(chr(chr_compiler_options)). :- use_module(chr(chr_compiler_utility)). :- use_module(chr(chr_compiler_errors)). :- include(chr(chr_op)). :- op(1150, fx, chr_type). :- op(1150, fx, chr_declaration). :- op(1130, xfx, --->). :- op(980, fx, (+)). :- op(980, fx, (-)). :- op(980, fx, (?)). :- op(1150, fx, constraints). :- op(1150, fx, chr_constraint). % }}} :- chr_option(debug,off). :- chr_option(optimize,full). :- chr_option(check_guard_bindings,off). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Type Declarations {{{ :- chr_type list(T) ---> [] ; [T|list(T)]. :- chr_type list == list(any). :- chr_type mode ---> (+) ; (-) ; (?). :- chr_type maybe(T) ---> yes(T) ; no. :- chr_type constraint ---> any / any. :- chr_type module_name == any. :- chr_type pragma_rule ---> pragma(rule,idspair,list(pragma_type),maybe(rule_name),rule_nb). :- chr_type rule ---> rule(list(any),list(any),goal,goal). :- chr_type idspair ---> ids(list(id),list(id)). :- chr_type pragma_type ---> passive(id) ; mpassive(list(id)) ; already_in_heads ; already_in_heads(id) ; no_history ; history(history_name,list(id)). :- chr_type history_name== any. :- chr_type rule_name == any. :- chr_type rule_nb == natural. :- chr_type id == natural. :- chr_type occurrence == int. :- chr_type goal == any. :- chr_type store_type ---> default ; multi_store(list(store_type)) ; multi_hash(list(list(int))) ; multi_inthash(list(list(int))) ; global_singleton ; global_ground % EXPERIMENTAL STORES ; atomic_constants(list(int),list(any),coverage) ; ground_constants(list(int),list(any),coverage) ; var_assoc_store(int,list(int)) ; identifier_store(int) ; type_indexed_identifier_store(int,any). :- chr_type coverage ---> complete ; incomplete. :- chr_type source_location ---> (atom:int). % }}} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %------------------------------------------------------------------------------% :- chr_constraint chr_source_file/1. :- chr_option(mode,chr_source_file(+)). :- chr_option(type_declaration,chr_source_file(module_name)). %------------------------------------------------------------------------------% chr_source_file(_) \ chr_source_file(_) <=> true. %------------------------------------------------------------------------------% :- chr_constraint get_chr_source_file/1. :- chr_option(mode,get_chr_source_file(-)). :- chr_option(type_declaration,get_chr_source_file(module_name)). %------------------------------------------------------------------------------% chr_source_file(Mod) \ get_chr_source_file(Query) <=> Query = Mod . get_chr_source_file(Query) <=> Query = user. %------------------------------------------------------------------------------% :- chr_constraint target_module/1. :- chr_option(mode,target_module(+)). :- chr_option(type_declaration,target_module(module_name)). %------------------------------------------------------------------------------% target_module(_) \ target_module(_) <=> true. %------------------------------------------------------------------------------% :- chr_constraint get_target_module/1. :- chr_option(mode,get_target_module(-)). :- chr_option(type_declaration,get_target_module(module_name)). %------------------------------------------------------------------------------% target_module(Mod) \ get_target_module(Query) <=> Query = Mod . get_target_module(Query) <=> Query = user. %------------------------------------------------------------------------------% :- chr_constraint source_location/2. :- chr_option(mode,source_location(+,+)). :- chr_option(type_declaration,source_location(rule_nb,source_location)). %------------------------------------------------------------------------------% source_location(RuleNb,SrcLoc) \ source_location(RuleNb,SourceLocation) <=> true. %------------------------------------------------------------------------------% :- chr_constraint get_line_number/2. :- chr_option(mode,get_line_number(+,-)). :- chr_option(type_declaration,get_line_number(rule_nb,source_location)). %------------------------------------------------------------------------------% source_location(RuleNb,SrcLoc) \ get_line_number(RuleNb,Q) <=> Q = SrcLoc. get_line_number(RuleNb,Q) <=> Q = (?):0. % no line number available :- chr_constraint indexed_argument/2. % argument instantiation may enable applicability of rule :- chr_option(mode,indexed_argument(+,+)). :- chr_option(type_declaration,indexed_argument(constraint,int)). :- chr_constraint is_indexed_argument/2. :- chr_option(mode,is_indexed_argument(+,+)). :- chr_option(type_declaration,is_indexed_argument(constraint,int)). :- chr_constraint constraint_mode/2. :- chr_option(mode,constraint_mode(+,+)). :- chr_option(type_declaration,constraint_mode(constraint,list(mode))). :- chr_constraint get_constraint_mode/2. :- chr_option(mode,get_constraint_mode(+,-)). :- chr_option(type_declaration,get_constraint_mode(constraint,list(mode))). :- chr_constraint may_trigger/1. :- chr_option(mode,may_trigger(+)). :- chr_option(type_declaration,may_trigger(constraint)). :- chr_constraint only_ground_indexed_arguments/1. :- chr_option(mode,only_ground_indexed_arguments(+)). :- chr_option(type_declaration,only_ground_indexed_arguments(constraint)). :- chr_constraint none_suspended_on_variables/0. :- chr_constraint are_none_suspended_on_variables/0. :- chr_constraint store_type/2. :- chr_option(mode,store_type(+,+)). :- chr_option(type_declaration,store_type(constraint,store_type)). :- chr_constraint get_store_type/2. :- chr_option(mode,get_store_type(+,?)). :- chr_option(type_declaration,get_store_type(constraint,store_type)). :- chr_constraint update_store_type/2. :- chr_option(mode,update_store_type(+,+)). :- chr_option(type_declaration,update_store_type(constraint,store_type)). :- chr_constraint actual_store_types/2. :- chr_option(mode,actual_store_types(+,+)). :- chr_option(type_declaration,actual_store_types(constraint,list(store_type))). :- chr_constraint assumed_store_type/2. :- chr_option(mode,assumed_store_type(+,+)). :- chr_option(type_declaration,assumed_store_type(constraint,store_type)). :- chr_constraint validate_store_type_assumption/1. :- chr_option(mode,validate_store_type_assumption(+)). :- chr_option(type_declaration,validate_store_type_assumption(constraint)). :- chr_constraint rule_count/1. :- chr_option(mode,rule_count(+)). :- chr_option(type_declaration,rule_count(natural)). :- chr_constraint inc_rule_count/1. :- chr_option(mode,inc_rule_count(-)). :- chr_option(type_declaration,inc_rule_count(natural)). rule_count(_) \ rule_count(_) <=> true. rule_count(C), inc_rule_count(NC) <=> NC is C + 1, rule_count(NC). inc_rule_count(NC) <=> NC = 1, rule_count(NC). :- chr_constraint passive/2. :- chr_option(mode,passive(+,+)). :- chr_option(type_declaration,passive(rule_nb,id)). :- chr_constraint is_passive/2. :- chr_option(mode,is_passive(+,+)). :- chr_option(type_declaration,is_passive(rule_nb,id)). :- chr_constraint any_passive_head/1. :- chr_option(mode,any_passive_head(+)). :- chr_constraint new_occurrence/4. :- chr_option(mode,new_occurrence(+,+,+,+)). :- chr_constraint occurrence/5. :- chr_option(mode,occurrence(+,+,+,+,+)). :- chr_type occurrence_type ---> simplification ; propagation. :- chr_option(type_declaration,occurrence(constraint,occurrence,rule_nb,id,occurrence_type)). :- chr_constraint get_occurrence/4. :- chr_option(mode,get_occurrence(+,+,-,-)). :- chr_constraint get_occurrence/5. :- chr_option(mode,get_occurrence(+,+,-,-,-)). :- chr_constraint get_occurrence_from_id/4. :- chr_option(mode,get_occurrence_from_id(+,-,+,+)). :- chr_constraint max_occurrence/2. :- chr_option(mode,max_occurrence(+,+)). :- chr_constraint get_max_occurrence/2. :- chr_option(mode,get_max_occurrence(+,-)). :- chr_constraint allocation_occurrence/2. :- chr_option(mode,allocation_occurrence(+,+)). :- chr_constraint get_allocation_occurrence/2. :- chr_option(mode,get_allocation_occurrence(+,-)). :- chr_constraint rule/2. :- chr_option(mode,rule(+,+)). :- chr_option(type_declaration,rule(rule_nb,pragma_rule)). :- chr_constraint get_rule/2. :- chr_option(mode,get_rule(+,-)). :- chr_option(type_declaration,get_rule(int,pragma_rule)). :- chr_constraint least_occurrence/2. :- chr_option(mode,least_occurrence(+,+)). :- chr_option(type_declaration,least_occurrence(any,list)). :- chr_constraint is_least_occurrence/1. :- chr_option(mode,is_least_occurrence(+)). indexed_argument(FA,I) \ indexed_argument(FA,I) <=> true. indexed_argument(FA,I) \ is_indexed_argument(FA,I) <=> true. is_indexed_argument(_,_) <=> fail. %%% C O N S T R A I N T M O D E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% constraint_mode(FA,_) \ constraint_mode(FA,_) <=> true. constraint_mode(FA,Mode) \ get_constraint_mode(FA,Q) <=> Q = Mode. get_constraint_mode(FA,Q) <=> FA = _ / N, replicate(N,(?),Q). %%% M A Y T R I G G E R %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% may_trigger(FA) <=> \+ has_active_occurrence(FA) | fail. constraint_mode(FA,Mode), indexed_argument(FA,I) \ may_trigger(FA) <=> nth1(I,Mode,M), M \== (+) | is_stored(FA). may_trigger(FA) <=> chr_pp_flag(debugable,on). % in debug mode, we assume everything can be triggered constraint_mode(FA,Mode), indexed_argument(FA,I) \ only_ground_indexed_arguments(FA) <=> nth1(I,Mode,M), M \== (+) | fail. only_ground_indexed_arguments(_) <=> true. none_suspended_on_variables \ none_suspended_on_variables <=> true. none_suspended_on_variables \ are_none_suspended_on_variables <=> true. are_none_suspended_on_variables <=> fail. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % STORE TYPES % % The functionality for inspecting and deciding on the different types of constraint % store / indexes for constraints. store_type(FA,StoreType) ==> chr_pp_flag(verbose,on) | format('The indexes for ~w are:\n',[FA]), format_storetype(StoreType). % chr_info(verbose,'Storetype of ~w is ~w.\n',[FA,StoreType]). format_storetype(multi_store(StoreTypes)) :- !, maplist(format_storetype,StoreTypes). format_storetype(atomic_constants(Index,Constants,_)) :- format('\t* a trie index on the argument(s) ~w for the ground terms ~w\n',[Index,Constants]). format_storetype(ground_constants(Index,Constants,_)) :- format('\t* a trie index on the argument(s) ~w for the ground terms ~w\n',[Index,Constants]). format_storetype(StoreType) :- format('\t* ~w\n',[StoreType]). % 1. Inspection % ~~~~~~~~~~~~~ % % get_store_type_normal @ store_type(FA,Store) \ get_store_type(FA,Query) <=> Query = Store. get_store_type_assumed @ assumed_store_type(FA,Store) \ get_store_type(FA,Query) <=> Query = Store. get_store_type_default @ get_store_type(_,Query) <=> Query = default. % 2. Store type registration % ~~~~~~~~~~~~~~~~~~~~~~~~~~ actual_store_types(C,STs) \ update_store_type(C,ST) <=> memberchk(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]). % 3. Final decision on store types % ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ validate_store_type_assumption(C) \ actual_store_types(C,STs), actual_atomic_multi_hash_keys(C,Index,Keys) <=> true % chr_pp_flag(experiment,on) | selectchk(multi_hash([Index]),STs,STs0), Index = [IndexPos], ( get_constraint_arg_type(C,IndexPos,Type), enumerated_atomic_type(Type,Atoms) -> /* use the type constants rather than the collected keys */ Constants = Atoms, Completeness = complete ; Constants = Keys, Completeness = incomplete ), actual_store_types(C,[atomic_constants(Index,Constants,Completeness)|STs0]). validate_store_type_assumption(C) \ actual_store_types(C,STs), actual_ground_multi_hash_keys(C,Index,Constants0) <=> true % chr_pp_flag(experiment,on) | ( Index = [IndexPos], get_constraint_arg_type(C,IndexPos,Type), Type = chr_enum(Constants) -> Completeness = complete ; Constants = Constants0, Completeness = incomplete ), selectchk(multi_hash([Index]),STs,STs0), actual_store_types(C,[ground_constants(Index,Constants,Completeness)|STs0]). get_constraint_arg_type(C,Pos,Type) :- get_constraint_type(C,Types), nth1(Pos,Types,Type0), unalias_type(Type0,Type). validate_store_type_assumption(C) \ actual_store_types(C,STs) <=> % chr_pp_flag(experiment,on), memberchk(multi_hash([[Index]]),STs), get_constraint_type(C,Types), nth1(Index,Types,Type), enumerated_atomic_type(Type,Atoms) | selectchk(multi_hash([[Index]]),STs,STs0), actual_store_types(C,[atomic_constants([Index],Atoms,complete)|STs0]). validate_store_type_assumption(C) \ actual_store_types(C,STs) <=> memberchk(multi_hash([[Index]]),STs), get_constraint_arg_type(C,Index,Type), Type = chr_enum(Constants) | selectchk(multi_hash([[Index]]),STs,STs0), actual_store_types(C,[ground_constants([Index],Constants,complete)|STs0]). validate_store_type_assumption(C), actual_store_types(C,STs), assumed_store_type(C,_) % automatic assumption <=> ( /* chr_pp_flag(experiment,on), */ maplist(partial_store,STs) -> Stores = [global_ground|STs] ; Stores = STs ), store_type(C,multi_store(Stores)). 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(C), assumed_store_type(C,_) % no lookups on constraint in debug mode <=> chr_pp_flag(debugable,on) | store_type(C,default). validate_store_type_assumption(C), assumed_store_type(C,_) % no lookups on constraint <=> store_type(C,global_ground). validate_store_type_assumption(C) <=> true. partial_store(ground_constants(_,_,incomplete)). partial_store(atomic_constants(_,_,incomplete)). %%% P A S S I V E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% passive(R,ID) \ passive(R,ID) <=> true. passive(RuleNb,ID) \ is_passive(RuleNb,ID) <=> true. is_passive(_,_) <=> fail. passive(RuleNb,_) \ any_passive_head(RuleNb) <=> true. any_passive_head(_) <=> fail. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% max_occurrence(C,N) \ max_occurrence(C,M) <=> N >= M | true. max_occurrence(C,MO), new_occurrence(C,RuleNb,ID,Type) <=> NO is MO + 1, occurrence(C,NO,RuleNb,ID,Type), max_occurrence(C,NO). new_occurrence(C,RuleNb,ID,_) <=> chr_error(internal,'new_occurrence: missing max_occurrence for ~w in rule ~w\n',[C,RuleNb]). max_occurrence(C,MON) \ get_max_occurrence(C,Q) <=> Q = MON. get_max_occurrence(C,Q) <=> chr_error(internal,'get_max_occurrence: missing max occurrence for ~w\n',[C]). occurrence(C,ON,Rule,ID,_) \ get_occurrence(C,ON,QRule,QID) <=> Rule = QRule, ID = QID. get_occurrence(C,O,_,_) <=> chr_error(internal,'get_occurrence: missing occurrence ~w:~w\n',[C,O]). occurrence(C,ON,Rule,ID,OccType) \ get_occurrence(C,ON,QRule,QID,QOccType) <=> Rule = QRule, ID = QID, OccType = QOccType. get_occurrence(C,O,_,_,_) <=> chr_error(internal,'get_occurrence: missing occurrence ~w:~w\n',[C,O]). occurrence(C,ON,Rule,ID,_) \ get_occurrence_from_id(QC,QON,Rule,ID) <=> QC = C, QON = ON. get_occurrence_from_id(C,O,_,_) <=> chr_error(internal,'get_occurrence_from_id: missing occurrence ~w:~w\n',[]). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Late allocation late_allocation_analysis(Cs) :- ( chr_pp_flag(late_allocation,on) -> maplist(late_allocation, Cs) ; true ). late_allocation(C) :- late_allocation(C,0). late_allocation(C,O) :- allocation_occurrence(C,O), !. late_allocation(C,O) :- NO is O + 1, late_allocation(C,NO). % A L L O C C A T I O N O C C U R R E N C E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% allocation_occurrence(C,0) ==> stored_in_guard_before_next_kept_occurrence(C,0). rule(RuleNb,Rule), occurrence(C,O,RuleNb,Id,Type), allocation_occurrence(C,O) ==> \+ is_passive(RuleNb,Id), Type == propagation, ( stored_in_guard_before_next_kept_occurrence(C,O) -> true ; Rule = pragma(rule([_|_],_,_,_),_,_,_,_) -> % simpagation rule is_observed(C,O) ; is_least_occurrence(RuleNb) -> % propagation rule is_observed(C,O) ; true ). stored_in_guard_before_next_kept_occurrence(C,O) :- chr_pp_flag(store_in_guards, on), NO is O + 1, stored_in_guard_lookahead(C,NO). :- chr_constraint stored_in_guard_lookahead/2. :- chr_option(mode, stored_in_guard_lookahead(+,+)). occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id) \ stored_in_guard_lookahead(C,O) <=> NO is O + 1, stored_in_guard_lookahead(C,NO). occurrence(C,O,RuleNb,Id,Type) \ stored_in_guard_lookahead(C,O) <=> Type == simplification, ( is_stored_in_guard(C,RuleNb) -> true ; NO is O + 1, stored_in_guard_lookahead(C,NO) ). stored_in_guard_lookahead(_,_) <=> fail. rule(RuleNb,Rule), occurrence(C,O,RuleNb,ID,_), allocation_occurrence(C,AO) \ least_occurrence(RuleNb,[ID|IDs]) <=> AO >= O, \+ may_trigger(C) | least_occurrence(RuleNb,IDs). rule(RuleNb,Rule), passive(RuleNb,ID) \ least_occurrence(RuleNb,[ID|IDs]) <=> least_occurrence(RuleNb,IDs). rule(RuleNb,Rule) ==> Rule = pragma(rule([],_,_,_),ids([],IDs),_,_,_) | least_occurrence(RuleNb,IDs). least_occurrence(RuleNb,[]) \ is_least_occurrence(RuleNb) <=> true. is_least_occurrence(_) <=> fail. allocation_occurrence(C,O) \ get_allocation_occurrence(C,Q) <=> Q = O. get_allocation_occurrence(_,Q) <=> chr_pp_flag(late_allocation,off), Q=0. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% rule(RuleNb,Rule) \ get_rule(RuleNb,Q) <=> Q = Rule. get_rule(_,_) <=> fail. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% C O N S T R A I N T I N D E X %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Default store constraint index assignment. :- chr_constraint constraint_index/2. % constraint_index(F/A,DefaultStoreAndAttachedIndex) :- chr_option(mode,constraint_index(+,+)). :- chr_option(type_declaration,constraint_index(constraint,int)). :- chr_constraint get_constraint_index/2. :- chr_option(mode,get_constraint_index(+,-)). :- chr_option(type_declaration,get_constraint_index(constraint,int)). :- chr_constraint get_indexed_constraint/2. :- chr_option(mode,get_indexed_constraint(+,-)). :- chr_option(type_declaration,get_indexed_constraint(int,constraint)). :- chr_constraint max_constraint_index/1. % max_constraint_index(MaxDefaultStoreAndAttachedIndex) :- chr_option(mode,max_constraint_index(+)). :- chr_option(type_declaration,max_constraint_index(int)). :- chr_constraint get_max_constraint_index/1. :- chr_option(mode,get_max_constraint_index(-)). :- chr_option(type_declaration,get_max_constraint_index(int)). constraint_index(C,Index) \ get_constraint_index(C,Query) <=> Query = Index. get_constraint_index(C,Query) <=> fail. constraint_index(C,Index) \ get_indexed_constraint(Index,Q) <=> Q = C. get_indexed_constraint(Index,Q) <=> fail. max_constraint_index(Index) \ get_max_constraint_index(Query) <=> Query = Index. get_max_constraint_index(Query) <=> Query = 0. set_constraint_indices(Constraints) :- set_constraint_indices(Constraints,1). set_constraint_indices([],M) :- N is M - 1, max_constraint_index(N). set_constraint_indices([C|Cs],N) :- ( ( chr_pp_flag(debugable, on) ; \+ only_ground_indexed_arguments(C), is_stored(C) ; is_stored(C), get_store_type(C,default) ; get_store_type(C,var_assoc_store(_,_))) -> constraint_index(C,N), M is N + 1, set_constraint_indices(Cs,M) ; set_constraint_indices(Cs,N) ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Identifier Indexes :- chr_constraint identifier_size/1. :- chr_option(mode,identifier_size(+)). :- chr_option(type_declaration,identifier_size(natural)). identifier_size(_) \ identifier_size(_) <=> true. :- chr_constraint get_identifier_size/1. :- chr_option(mode,get_identifier_size(-)). :- chr_option(type_declaration,get_identifier_size(natural)). identifier_size(Size) \ get_identifier_size(Q) <=> Q = Size. get_identifier_size(Q) <=> Q = 1. :- chr_constraint identifier_index/3. :- chr_option(mode,identifier_index(+,+,+)). :- chr_option(type_declaration,identifier_index(constraint,natural,natural)). identifier_index(C,I,_) \ identifier_index(C,I,_) <=> true. :- chr_constraint get_identifier_index/3. :- chr_option(mode,get_identifier_index(+,+,-)). :- chr_option(type_declaration,get_identifier_index(constraint,natural,natural)). identifier_index(C,I,II) \ get_identifier_index(C,I,Q) <=> Q = II. identifier_size(Size), get_identifier_index(C,I,Q) <=> NSize is Size + 1, identifier_index(C,I,NSize), identifier_size(NSize), Q = NSize. get_identifier_index(C,I,Q) <=> identifier_index(C,I,2), identifier_size(2), Q = 2. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Type Indexed Identifier Indexes :- chr_constraint type_indexed_identifier_size/2. :- chr_option(mode,type_indexed_identifier_size(+,+)). :- chr_option(type_declaration,type_indexed_identifier_size(any,natural)). type_indexed_identifier_size(IndexType,_) \ type_indexed_identifier_size(IndexType,_) <=> true. :- chr_constraint get_type_indexed_identifier_size/2. :- chr_option(mode,get_type_indexed_identifier_size(+,-)). :- chr_option(type_declaration,get_type_indexed_identifier_size(any,natural)). type_indexed_identifier_size(IndexType,Size) \ get_type_indexed_identifier_size(IndexType,Q) <=> Q = Size. get_type_indexed_identifier_size(IndexType,Q) <=> Q = 1. :- chr_constraint type_indexed_identifier_index/4. :- chr_option(mode,type_indexed_identifier_index(+,+,+,+)). :- chr_option(type_declaration,type_indexed_identifier_index(any,constraint,natural,natural)). type_indexed_identifier_index(_,C,I,_) \ type_indexed_identifier_index(_,C,I,_) <=> true. :- chr_constraint get_type_indexed_identifier_index/4. :- chr_option(mode,get_type_indexed_identifier_index(+,+,+,-)). :- chr_option(type_declaration,get_type_indexed_identifier_index(any,constraint,natural,natural)). type_indexed_identifier_index(IndexType,C,I,II) \ get_type_indexed_identifier_index(IndexType,C,I,Q) <=> Q = II. type_indexed_identifier_size(IndexType,Size), get_type_indexed_identifier_index(IndexType,C,I,Q) <=> NSize is Size + 1, type_indexed_identifier_index(IndexType,C,I,NSize), type_indexed_identifier_size(IndexType,NSize), Q = NSize. get_type_indexed_identifier_index(IndexType,C,I,Q) <=> type_indexed_identifier_index(IndexType,C,I,2), type_indexed_identifier_size(IndexType,2), Q = 2. type_indexed_identifier_structure(IndexType,Structure) :- type_indexed_identifier_name(IndexType,type_indexed_identifier_struct,Functor), get_type_indexed_identifier_size(IndexType,Arity), functor(Structure,Functor,Arity). type_indexed_identifier_name(IndexType,Prefix,Name) :- ( atom(IndexType) -> IndexTypeName = IndexType ; term_to_atom(IndexType,IndexTypeName) ), atom_concat_list([Prefix,'_',IndexTypeName],Name). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% %% Translation chr_translate(Declarations,NewDeclarations) :- chr_translate_line_info(Declarations,'bootstrap',NewDeclarations). chr_translate_line_info(Declarations0,File,NewDeclarations) :- chr_banner, restart_after_flattening(Declarations0,Declarations), init_chr_pp_flags, chr_source_file(File), /* sort out the interesting stuff from the input */ partition_clauses(Declarations,Constraints0,Rules0,OtherClauses), chr_compiler_options:sanity_check, dump_code(Declarations), check_declared_constraints(Constraints0), generate_show_constraint(Constraints0,Constraints,Rules0,Rules1), add_constraints(Constraints), add_rules(Rules1), generate_never_stored_rules(Constraints,NewRules), add_rules(NewRules), append(Rules1,NewRules,Rules), chr_analysis(Rules,Constraints,Declarations), time('constraint code generation',chr_translate:constraints_code(Constraints,ConstraintClauses)), time('validate store assumptions',chr_translate:validate_store_type_assumptions(Constraints)), phase_end(validate_store_type_assumptions), used_states_known, time('store code generation',chr_translate:store_management_preds(Constraints,StoreClauses)), % depends on actual code used insert_declarations(OtherClauses, Clauses0), chr_module_declaration(CHRModuleDeclaration), append([StoreClauses,ConstraintClauses,CHRModuleDeclaration,[end_of_file]],StuffyGeneratedClauses), clean_clauses(StuffyGeneratedClauses,GeneratedClauses), append([Clauses0,GeneratedClauses], NewDeclarations), dump_code(NewDeclarations), !. /* cut choicepoint of restart_after_flattening */ chr_analysis(Rules,Constraints,Declarations) :- maplist(pragma_rule_to_ast_rule,Rules,AstRules), check_rules(Rules,AstRules,Constraints), time('type checking',chr_translate:static_type_check(Rules,AstRules)), /* constants */ collect_constants(Rules,AstRules,Constraints,Declarations), add_occurrences(Rules,AstRules), time('functional dependency',chr_translate:functional_dependency_analysis(Rules)), time('set semantics',chr_translate:set_semantics_rules(Rules)), time('symmetry analysis',chr_translate:symmetry_analysis(Rules)), time('guard simplification',chr_translate:guard_simplification), time('late storage',chr_translate:storage_analysis(Constraints)), time('observation',chr_translate:observation_analysis(Constraints)), time('ai observation',chr_translate:ai_observation_analysis(Constraints)), time('late allocation',chr_translate:late_allocation_analysis(Constraints)), partial_wake_analysis, time('assume constraint stores',chr_translate:assume_constraint_stores(Constraints)), time('default constraint indices',chr_translate:set_constraint_indices(Constraints)), time('check storedness assertions',chr_translate:check_storedness_assertions(Constraints)), time('continuation analysis',chr_translate:continuation_analysis(Constraints)). store_management_preds(Constraints,Clauses) :- generate_attach_detach_a_constraint_all(Constraints,AttachAConstraintClauses), generate_attr_unify_hook(AttrUnifyHookClauses), generate_attach_increment(AttachIncrementClauses), generate_extra_clauses(Constraints,ExtraClauses), generate_insert_delete_constraints(Constraints,DeleteClauses), generate_attach_code(Constraints,StoreClauses), generate_counter_code(CounterClauses), generate_dynamic_type_check_clauses(TypeCheckClauses), append([AttachAConstraintClauses ,AttachIncrementClauses ,AttrUnifyHookClauses ,ExtraClauses ,DeleteClauses ,StoreClauses ,CounterClauses ,TypeCheckClauses ] ,Clauses). insert_declarations(Clauses0, Clauses) :- findall((:- use_module(chr(Module))),(auxiliary_module(Module), is_used_auxiliary_module(Module)),Decls), append(Clauses0, [(:- use_module(chr(chr_runtime)))|Decls], Clauses). auxiliary_module(chr_hashtable_store). auxiliary_module(chr_integertable_store). auxiliary_module(chr_assoc_store). generate_counter_code(Clauses) :- ( chr_pp_flag(store_counter,on) -> Clauses = [ ('$counter_init'(N1) :- nb_setval(N1,0)) , ('$counter'(N2,X1) :- nb_getval(N2,X1)), ('$counter_inc'(N) :- nb_getval(N,X), Y is X + 1, nb_setval(N,Y)), (:- '$counter_init'('$insert_counter')), (:- '$counter_init'('$delete_counter')), ('$insert_counter_inc' :- '$counter_inc'('$insert_counter')), ('$delete_counter_inc' :- '$counter_inc'('$delete_counter')), ( counter_stats(I,D) :- '$counter'('$insert_counter',I),'$counter'('$delete_counter',D)) ] ; Clauses = [] ). % for systems with multifile declaration chr_module_declaration([]) :- tmp_module, !. chr_module_declaration(CHRModuleDeclaration) :- get_target_module(Mod), ( Mod \== chr_translate, chr_pp_flag(toplevel_show_store,on) -> CHRModuleDeclaration = [ (:- multifile chr:'$chr_module'/1), chr:'$chr_module'(Mod) ] ; CHRModuleDeclaration = [] ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% %% Partitioning of clauses into constraint declarations, chr rules and other %% clauses %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% partition_clauses(+Clauses,-ConstraintDeclarations,-Rules,-OtherClauses) is det. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% partition_clauses([],[],[],[]). partition_clauses([Clause|Clauses],ConstraintDeclarations,Rules,OtherClauses) :- ( parse_rule(Clause,Rule) -> ConstraintDeclarations = RestConstraintDeclarations, Rules = [Rule|RestRules], OtherClauses = RestOtherClauses ; is_declaration(Clause,ConstraintDeclaration) -> append(ConstraintDeclaration,RestConstraintDeclarations,ConstraintDeclarations), Rules = RestRules, OtherClauses = RestOtherClauses ; is_module_declaration(Clause,Mod) -> target_module(Mod), ConstraintDeclarations = RestConstraintDeclarations, Rules = RestRules, OtherClauses = [Clause|RestOtherClauses] ; is_type_definition(Clause) -> ConstraintDeclarations = RestConstraintDeclarations, Rules = RestRules, OtherClauses = RestOtherClauses ; is_chr_declaration(Clause) -> ConstraintDeclarations = RestConstraintDeclarations, Rules = RestRules, OtherClauses = RestOtherClauses ; Clause = (handler _) -> chr_warning(deprecated(Clause),'Backward compatibility: ignoring handler/1 declaration.\n',[]), ConstraintDeclarations = RestConstraintDeclarations, Rules = RestRules, OtherClauses = RestOtherClauses ; Clause = (rules _) -> chr_warning(deprecated(Clause),'Backward compatibility: ignoring rules/1 declaration.\n',[]), ConstraintDeclarations = RestConstraintDeclarations, Rules = RestRules, OtherClauses = RestOtherClauses ; Clause = option(OptionName,OptionValue) -> chr_warning(deprecated(Clause),'Instead use `:-chr_option(~w,~w).\'\n',[OptionName,OptionValue]), handle_option(OptionName,OptionValue), ConstraintDeclarations = RestConstraintDeclarations, Rules = RestRules, OtherClauses = RestOtherClauses ; Clause = (:-chr_option(OptionName,OptionValue)) -> handle_option(OptionName,OptionValue), ConstraintDeclarations = RestConstraintDeclarations, Rules = RestRules, OtherClauses = RestOtherClauses ; Clause = ('$chr_compiled_with_version'(_)) -> ConstraintDeclarations = RestConstraintDeclarations, Rules = RestRules, OtherClauses = ['$chr_compiled_with_version'(3)|RestOtherClauses] ; ConstraintDeclarations = RestConstraintDeclarations, Rules = RestRules, OtherClauses = [Clause|RestOtherClauses] ), partition_clauses(Clauses,RestConstraintDeclarations,RestRules,RestOtherClauses). '$chr_compiled_with_version'(2). is_declaration(D, Constraints) :- %% constraint declaration ( D = (:- Decl), Decl =.. [F,Cs], F == (chr_constraint) -> conj2list(Cs,Constraints0) ; ( D = (:- Decl) -> Decl =.. [constraints,Cs] ; D =.. [constraints,Cs] ), conj2list(Cs,Constraints0), chr_warning(deprecated(D),'Instead use :- chr_constraint ~w.\n',[Cs]) ), extract_type_mode(Constraints0,Constraints). extract_type_mode([],[]). extract_type_mode([F/A|R],[F/A|R2]) :- !,extract_type_mode(R,R2). extract_type_mode([C0|R],[ConstraintSymbol|R2]) :- ( C0 = C # Annotation -> functor(C,F,A), extract_annotation(Annotation,F/A) ; C0 = C, functor(C,F,A) ), ConstraintSymbol = F/A, C =.. [_|Args], extract_types_and_modes(Args,ArgTypes,ArgModes), assert_constraint_type(ConstraintSymbol,ArgTypes), constraint_mode(ConstraintSymbol,ArgModes), extract_type_mode(R,R2). extract_annotation(stored,Symbol) :- stored_assertion(Symbol). extract_annotation(default(Goal),Symbol) :- never_stored_default(Symbol,Goal). extract_types_and_modes([],[],[]). extract_types_and_modes([X|R],[T|R2],[M|R3]) :- extract_type_and_mode(X,T,M), extract_types_and_modes(R,R2,R3). extract_type_and_mode(+(T),T,(+)) :- !. extract_type_and_mode(?(T),T,(?)) :- !. extract_type_and_mode(-(T),T,(-)) :- !. extract_type_and_mode((+),any,(+)) :- !. extract_type_and_mode((?),any,(?)) :- !. extract_type_and_mode((-),any,(-)) :- !. extract_type_and_mode(Illegal,_,_) :- chr_error(syntax(Illegal),'Illegal mode/type declaration.\n\tCorrect syntax is +type, -type or ?type\n\tor +, - or ?.\n',[]). is_chr_declaration(Declaration) :- Declaration = (:- chr_declaration Decl), ( Decl = (Pattern ---> Information) -> background_info(Pattern,Information) ; Decl = Information -> background_info([Information]) ). is_type_definition(Declaration) :- is_type_definition(Declaration,Result), assert_type_definition(Result). assert_type_definition(typedef(Name,DefList)) :- type_definition(Name,DefList). assert_type_definition(alias(Alias,Name)) :- type_alias(Alias,Name). is_type_definition(Declaration,Result) :- ( Declaration = (:- TDef) -> true ; Declaration = TDef ), TDef =.. [chr_type,TypeDef], ( TypeDef = (Name ---> Def) -> tdisj2list(Def,DefList), Result = typedef(Name,DefList) ; TypeDef = (Alias == Name) -> Result = alias(Alias,Name) ; Result = typedef(TypeDef,[]), chr_warning(syntax,'Empty type definition `~w\'.\nAre you sure you want to declare a phantom type?\n',[Declaration]) ). %% tdisj2list(+Goal,-ListOfGoals) is det. % % no removal of fails, e.g. :- type bool ---> true ; fail. tdisj2list(Conj,L) :- tdisj2list(Conj,L,[]). tdisj2list(Conj,L,T) :- Conj = (G1;G2), !, tdisj2list(G1,L,T1), tdisj2list(G2,T1,T). tdisj2list(G,[G | T],T). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% parse_rule(+term,-pragma_rule) is semidet. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% parse_rule(RI,R) :- %% name @ rule RI = (Name @ RI2), !, rule(RI2,yes(Name),R). parse_rule(RI,R) :- rule(RI,no,R). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% parse_rule(+term,-pragma_rule) is semidet. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% rule(RI,Name,R) :- RI = (RI2 pragma P), !, %% pragmas ( var(P) -> Ps = [_] % intercept variable ; conj2list(P,Ps) ), inc_rule_count(RuleCount), R = pragma(R1,IDs,Ps,Name,RuleCount), is_rule(RI2,R1,IDs,R). rule(RI,Name,R) :- inc_rule_count(RuleCount), R = pragma(R1,IDs,[],Name,RuleCount), is_rule(RI,R1,IDs,R). is_rule(RI,R,IDs,RC) :- %% propagation rule RI = (H ==> B), !, conj2list(H,Head2i), get_ids(Head2i,IDs2,Head2,RC), IDs = ids([],IDs2), ( B = (G | RB) -> R = rule([],Head2,G,RB) ; R = rule([],Head2,true,B) ). is_rule(RI,R,IDs,RC) :- %% 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,RC), get_ids(Head1i,IDs1,Head1,N,_,RC), IDs = ids(IDs1,IDs2) ; conj2list(H,Head1i), Head2 = [], get_ids(Head1i,IDs1,Head1,RC), IDs = ids(IDs1,[]) ), R = rule(Head1,Head2,Guard,Body). get_ids(Cs,IDs,NCs,RC) :- get_ids(Cs,IDs,NCs,0,_,RC). get_ids([],[],[],N,N,_). get_ids([C|Cs],[N|IDs],[NC|NCs],N,NN,RC) :- ( C = (NC # N1) -> ( var(N1) -> N1 = N ; check_direct_pragma(N1,N,RC) ) ; NC = C ), M is N + 1, get_ids(Cs,IDs,NCs, M,NN,RC). check_direct_pragma(passive,Id,PragmaRule) :- !, PragmaRule = pragma(_,_,_,_,RuleNb), passive(RuleNb,Id). check_direct_pragma(Abbrev,Id,PragmaRule) :- ( direct_pragma(FullPragma), atom_concat(Abbrev,Remainder,FullPragma) -> chr_warning(problem_pragma(Abbrev,PragmaRule),'completed `~w\' to `~w\'\n',[Abbrev,FullPragma]) ; chr_warning(unsupported_pragma(Abbrev,PragmaRule),'',[]) ). direct_pragma(passive). is_module_declaration((:- module(Mod)),Mod). is_module_declaration((:- module(Mod,_)),Mod). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Add constraints add_constraints([]). add_constraints([C|Cs]) :- max_occurrence(C,0), C = _/A, length(Mode,A), set_elems(Mode,?), constraint_mode(C,Mode), add_constraints(Cs). % Add rules add_rules([]). add_rules([Rule|Rules]) :- Rule = pragma(_,_,_,_,RuleNb), rule(RuleNb,Rule), add_rules(Rules). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% Some input verification: check_declared_constraints(Constraints) :- tree_set_empty(Acc), check_declared_constraints(Constraints,Acc). check_declared_constraints([],_). check_declared_constraints([C|Cs],Acc) :- ( tree_set_memberchk(C,Acc) -> chr_error(syntax(C),'Constraint multiply defined: ~w.\n\tRemove redundant declaration!\n',[C]) ; true ), tree_set_add(Acc,C,NAcc), check_declared_constraints(Cs,NAcc). %% - all constraints in heads are declared constraints %% - all passive pragmas refer to actual head constraints check_rules(PragmaRules,AstRules,Decls) :- maplist(check_rule(Decls),PragmaRules,AstRules). check_rule(Decls,PragmaRule,AstRule) :- PragmaRule = pragma(_Rule,_IDs,Pragmas,_Name,_N), check_ast_rule_indexing(AstRule,PragmaRule), % check_rule_indexing(PragmaRule), check_ast_trivial_propagation_rule(AstRule,PragmaRule), % check_trivial_propagation_rule(PragmaRule), check_ast_head_constraints(AstRule,Decls,PragmaRule), % Rule = rule(H1,H2,_,_), % check_head_constraints(H1,Decls,PragmaRule), % check_head_constraints(H2,Decls,PragmaRule), check_pragmas(Pragmas,PragmaRule). %------------------------------------------------------------------------------- % Make all heads passive in trivial propagation rule % ... ==> ... | true. check_ast_trivial_propagation_rule(AstRule,PragmaRule) :- AstRule = ast_rule(AstHead,_,_,AstBody,_), ( AstHead = propagation(_), AstBody == [] -> chr_warning(weird_program,'Ignoring propagation rule with empty body: ~@.\n\t\n',[format_rule(PragmaRule)]), set_rule_passive(PragmaRule) ; true ). set_rule_passive(PragmaRule) :- PragmaRule = pragma(_Rule,_IDs,_Pragmas,_Name,RuleNb), set_all_passive(RuleNb). check_trivial_propagation_rule(PragmaRule) :- PragmaRule = pragma(Rule,IDs,Pragmas,Name,RuleNb), ( Rule = rule([],_,_,true) -> chr_warning(weird_program,'Ignoring propagation rule with empty body: ~@.\n\t\n',[format_rule(PragmaRule)]), set_all_passive(RuleNb) ; true ). %------------------------------------------------------------------------------- check_ast_head_constraints(ast_rule(AstHead,_,_,_,_),Decls,PragmaRule) :- check_ast_head_constraints_(AstHead,Decls,PragmaRule). check_ast_head_constraints_(simplification(AstConstraints),Decls,PragmaRule) :- maplist(check_ast_head_constraint(Decls,PragmaRule),AstConstraints). check_ast_head_constraints_(propagation(AstConstraints),Decls,PragmaRule) :- maplist(check_ast_head_constraint(Decls,PragmaRule),AstConstraints). check_ast_head_constraints_(simpagation(AstConstraints1,AstConstraints2),Decls,PragmaRule) :- maplist(check_ast_head_constraint(Decls,PragmaRule),AstConstraints1), maplist(check_ast_head_constraint(Decls,PragmaRule),AstConstraints2). check_ast_head_constraint(Decls,PragmaRule,chr_constraint(Symbol,_,Constraint)) :- ( memberchk(Symbol,Decls) -> true ; chr_error(syntax(Constraint),'Undeclared constraint ~w in head of ~@.\n\tConstraint should be one of ~w.\n', [F/A,format_rule(PragmaRule),Decls]) ). check_head_constraints([],_,_). check_head_constraints([Constr|Rest],Decls,PragmaRule) :- functor(Constr,F,A), ( memberchk(F/A,Decls) -> check_head_constraints(Rest,Decls,PragmaRule) ; chr_error(syntax(Constr),'Undeclared constraint ~w in head of ~@.\n\tConstraint should be one of ~w.\n', [F/A,format_rule(PragmaRule),Decls]) ). %------------------------------------------------------------------------------- check_pragmas([],_). check_pragmas([Pragma|Pragmas],PragmaRule) :- check_pragma(Pragma,PragmaRule), check_pragmas(Pragmas,PragmaRule). check_pragma(Pragma,PragmaRule) :- var(Pragma), !, chr_error(syntax(Pragma),'Invalid pragma ~w in ~@.\n\tPragma should not be a variable!\n',[Pragma,format_rule(PragmaRule)]). check_pragma(passive(ID), PragmaRule) :- !, PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb), ( memberchk_eq(ID,IDs1) -> true ; memberchk_eq(ID,IDs2) -> true ; chr_error(syntax(ID),'Invalid identifier ~w in pragma passive in ~@.\n', [ID,format_rule(PragmaRule)]) ), passive(RuleNb,ID). check_pragma(mpassive(IDs), PragmaRule) :- !, PragmaRule = pragma(_,_,_,_,RuleNb), chr_warning(experimental,'Experimental pragma ~w. Use with care!\n',[mpassive(IDs)]), maplist(passive(RuleNb),IDs). check_pragma(Pragma, PragmaRule) :- Pragma = already_in_heads, !, chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]). check_pragma(Pragma, PragmaRule) :- Pragma = already_in_head(_), !, chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]). check_pragma(Pragma, PragmaRule) :- Pragma = no_history, !, chr_warning(experimental,'Experimental pragma no_history. Use with care!\n',[]), PragmaRule = pragma(_,_,_,_,N), no_history(N). check_pragma(Pragma, PragmaRule) :- Pragma = history(HistoryName,IDs), !, PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb), chr_warning(experimental,'Experimental pragma ~w. Use with care!\n',[Pragma]), ( IDs1 \== [] -> chr_error(syntax(Pragma),'Pragma history only implemented for propagation rules.\n',[]) ; \+ atom(HistoryName) -> chr_error(syntax(Pragma),'Illegal argument for pragma history: ~w is not an atom (rule number ~w).\n',[HistoryName,RuleNb]) ; \+ is_set(IDs) -> chr_error(syntax(Pragma),'Illegal argument for pragma history: ~w is not a set (rule number ~w).\n',[IDs,RuleNb]) ; check_history_pragma_ids(IDs,IDs1,IDs2) -> history(RuleNb,HistoryName,IDs) ; chr_error(syntax(Pragma),'Invalid identifier(s) in pragma ~w of rule number ~w.\n',[Pragma,RuleNb]) ). check_pragma(Pragma,PragmaRule) :- Pragma = source_location(SourceLocation), !, PragmaRule = pragma(_,_,_,_,RuleNb), source_location(RuleNb,SourceLocation). check_history_pragma_ids([], _, _). check_history_pragma_ids([ID|IDs],IDs1,IDs2) :- ( memberchk_eq(ID,IDs2) ; memberchk_eq(ID,IDs1) ), check_history_pragma_ids(IDs,IDs1,IDs2). check_pragma(Pragma,PragmaRule) :- chr_error(syntax(Pragma),'Unknown pragma ~w in ~@.\n', [Pragma,format_rule(PragmaRule)]). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% no_history(+RuleNb) is det. :- chr_constraint no_history/1. :- chr_option(mode,no_history(+)). :- chr_option(type_declaration,no_history(int)). %% has_no_history(+RuleNb) is semidet. :- chr_constraint has_no_history/1. :- chr_option(mode,has_no_history(+)). :- chr_option(type_declaration,has_no_history(int)). no_history(RuleNb) \ has_no_history(RuleNb) <=> true. has_no_history(_) <=> fail. :- chr_constraint history/3. :- chr_option(mode,history(+,+,+)). :- chr_option(type_declaration,history(any,any,list)). :- chr_constraint named_history/3. history(RuleNb,_,_), history(RuleNb,_,_) ==> chr_error(syntax,'Only one pragma history allowed per rule (rule number ~w)\n',[RuleNb]). %' history(RuleNb1,Name,IDs1), history(RuleNb2,Name,IDs2) ==> length(IDs1,L1), length(IDs2,L2), ( L1 \== L2 -> chr_error(syntax,'The history named ~w does not always range over an equal amount of occurrences.\n',[Name]) ; test_named_history_id_pairs(RuleNb1,IDs1,RuleNb2,IDs2) ). test_named_history_id_pairs(_, [], _, []). test_named_history_id_pairs(RuleNb1, [ID1|IDs1], RuleNb2, [ID2|IDs2]) :- test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2), test_named_history_id_pairs(RuleNb1,IDs1,RuleNb2,IDs2). :- chr_constraint test_named_history_id_pair/4. :- chr_option(mode,test_named_history_id_pair(+,+,+,+)). occurrence(C,_,RuleNb1,ID1,_), occurrence(C,_,RuleNb2,ID2,_) \ test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2) <=> true. test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2) <=> chr_error(syntax,'Occurrences of shared history in rules number ~w and ~w do not correspond\n', [RuleNb2,RuleNb1]). history(RuleNb,Name,IDs) \ named_history(RuleNb,QName,QIDs) <=> QName = Name, QIDs = IDs. named_history(_,_,_) <=> fail. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% format_rule(PragmaRule) :- PragmaRule = pragma(_,_,_,MaybeName,RuleNumber), ( MaybeName = yes(Name) -> write('rule '), write(Name) ; write('rule number '), write(RuleNumber) ), get_line_number(RuleNumber,SourceLocation), write(' at '), write(SourceLocation). check_ast_rule_indexing(AstRule,PragmaRule) :- AstRule = ast_rule(AstHead,AstGuard,_,_,_), tree_set_empty(EmptyVarSet), ast_head_variables(AstHead,EmptyVarSet,VarSet), ast_remove_anti_monotonic_guards(AstGuard,VarSet,MonotonicAstGuard), ast_term_list_variables(MonotonicAstGuard,EmptyVarSet,GuardVarSet), check_ast_head_indexing(AstHead,GuardVarSet), % check_indexing(H1,NG-H2), % check_indexing(H2,NG-H1), % EXPERIMENT ( chr_pp_flag(term_indexing,on) -> PragmaRule = pragma(Rule,_,_,_,_), Rule = rule(H1,H2,G,_), term_variables(H1-H2,HeadVars), remove_anti_monotonic_guards(G,HeadVars,NG), term_variables(NG,GuardVariables), append(H1,H2,Heads), check_specs_indexing(Heads,GuardVariables,Specs) ; true ). check_ast_head_indexing(simplification(H1),VarSet) :- check_ast_indexing(H1,VarSet). check_ast_head_indexing(propagation(H2),VarSet) :- check_ast_indexing(H2,VarSet). check_ast_head_indexing(simpagation(H1,H2),VarSet) :- ast_constraint_list_variables(H2,VarSet,VarSet1), check_ast_indexing(H1,VarSet1), ast_constraint_list_variables(H1,VarSet,VarSet2), check_ast_indexing(H2,VarSet2). 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), % EXPERIMENT ( chr_pp_flag(term_indexing,on) -> term_variables(NG,GuardVariables), append(H1,H2,Heads), check_specs_indexing(Heads,GuardVariables,Specs) ; true ). :- chr_constraint indexing_spec/2. :- chr_option(mode,indexing_spec(+,+)). :- chr_constraint get_indexing_spec/2. :- chr_option(mode,get_indexing_spec(+,-)). indexing_spec(FA,Spec) \ get_indexing_spec(FA,R) <=> R = Spec. get_indexing_spec(_,Spec) <=> Spec = []. indexing_spec(FA,Specs1), indexing_spec(FA,Specs2) <=> append(Specs1,Specs2,Specs), indexing_spec(FA,Specs). 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). ast_remove_anti_monotonic_guards([],_,[]). ast_remove_anti_monotonic_guards([G|Gs],VarSet,NGs) :- ( G = compound(var,1,[X],_), ast_var_memberchk(X,VarSet) -> NGs = RGs ; NGs = [G|RGs] ), ast_remove_anti_monotonic_guards(Gs,VarSet,RGs). %------------------------------------------------------------------------------- check_ast_indexing([],_). check_ast_indexing([Head|Heads],VarSet) :- Head = chr_constraint(Symbol,Args,_Constraint), ast_constraint_list_variables(Heads,VarSet,VarSet1), check_ast_indexing(Args,1,Symbol,VarSet1), ast_constraint_variables(Head,VarSet,NVarSet), check_ast_indexing(Heads,NVarSet). check_ast_indexing([],_,_,_). check_ast_indexing([Arg|Args],I,Symbol,VarSet) :- ( is_indexed_argument(Symbol,I) -> true ; ast_nonvar(Arg) -> indexed_argument(Symbol,I) ; % ast_var(Arg) -> ast_term_list_variables(Args,VarSet,VarSet1), ( ast_var_memberchk(Arg,VarSet1) -> indexed_argument(Symbol,I) ; true ) ), J is I + 1, ast_term_variables(Arg,VarSet,NVarSet), check_ast_indexing(Args,J,Symbol,NVarSet). % check_indexing(list(chr_constraint),variables) 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). %------------------------------------------------------------------------------- check_specs_indexing([],_,[]). check_specs_indexing([Head|Heads],Variables,Specs) :- Specs = [Spec|RSpecs], term_variables(Heads,OtherVariables,Variables), check_spec_indexing(Head,OtherVariables,Spec), term_variables(Head,NVariables,Variables), check_specs_indexing(Heads,NVariables,RSpecs). check_spec_indexing(Head,OtherVariables,Spec) :- functor(Head,F,A), Spec = spec(F,A,ArgSpecs), Head =.. [_|Args], check_args_spec_indexing(Args,1,OtherVariables,ArgSpecs), indexing_spec(F/A,[ArgSpecs]). check_args_spec_indexing([],_,_,[]). check_args_spec_indexing([Arg|Args],I,OtherVariables,ArgSpecs) :- term_variables(Args,Variables,OtherVariables), ( check_arg_spec_indexing(Arg,I,Variables,ArgSpec) -> ArgSpecs = [ArgSpec|RArgSpecs] ; ArgSpecs = RArgSpecs ), J is I + 1, term_variables(Arg,NOtherVariables,OtherVariables), check_args_spec_indexing(Args,J,NOtherVariables,RArgSpecs). check_arg_spec_indexing(Arg,I,Variables,ArgSpec) :- ( var(Arg) -> memberchk_eq(Arg,Variables), ArgSpec = specinfo(I,any,[]) ; functor(Arg,F,A), ArgSpec = specinfo(I,F/A,[ArgSpecs]), Arg =.. [_|Args], check_args_spec_indexing(Args,1,Variables,ArgSpecs) ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Occurrences add_occurrences(PragmaRules,AstRules) :- maplist(add_rule_occurrences,PragmaRules,AstRules). add_rule_occurrences(PragmaRule,AstRule) :- PragmaRule = pragma(_,IDs,_,_,Nb), AstRule = ast_rule(AstHead,_,_,_,_), add_head_occurrences(AstHead,IDs,Nb). add_head_occurrences(simplification(H1),ids(IDs1,_),Nb) :- maplist(add_constraint_occurrence(Nb,simplification),H1,IDs1). add_head_occurrences(propagation(H2),ids(_,IDs2),Nb) :- maplist(add_constraint_occurrence(Nb,propagation),H2,IDs2). add_head_occurrences(simpagation(H1,H2),ids(IDs1,IDs2),Nb) :- maplist(add_constraint_occurrence(Nb,simplification),H1,IDs1), maplist(add_constraint_occurrence(Nb,propagation),H2,IDs2). add_constraint_occurrence(Nb,OccType,Constraint,ID) :- Constraint = chr_constraint(Symbol,_,_), new_occurrence(Symbol,Nb,ID,OccType). % add_occurrences([],[]). % add_occurrences([Rule|Rules],[]) :- % Rule = pragma(rule(H1,H2,_,_),ids(IDs1,IDs2),_,_,Nb), % add_occurrences(H1,IDs1,simplification,Nb), % add_occurrences(H2,IDs2,propagation,Nb), % add_occurrences(Rules). % % add_occurrences([],[],_,_). % add_occurrences([H|Hs],[ID|IDs],Type,RuleNb) :- % functor(H,F,A), % FA = F/A, % new_occurrence(FA,RuleNb,ID,Type), % add_occurrences(Hs,IDs,Type,RuleNb). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Observation Analysis % % CLASSIFICATION % % % % % % :- chr_constraint observation_analysis/1. :- chr_option(mode, observation_analysis(+)). observation_analysis(Cs), rule(RuleNb,PragmaRule) # Id ==> PragmaRule = pragma(rule(_,_,Guard,Body),_,_,_,_), ( chr_pp_flag(store_in_guards, on) -> observation_analysis(RuleNb, Guard, guard, Cs) ; true ), observation_analysis(RuleNb, Body, body, Cs) pragma passive(Id). observation_analysis(_) <=> true. observation_analysis(RuleNb, Term, GB, Cs) :- ( all_spawned(RuleNb,GB) -> true ; var(Term) -> spawns_all(RuleNb,GB) ; Term = true -> true ; Term = fail -> true ; Term = '!' -> true ; Term = (T1,T2) -> observation_analysis(RuleNb,T1,GB,Cs), observation_analysis(RuleNb,T2,GB,Cs) ; Term = (T1;T2) -> observation_analysis(RuleNb,T1,GB,Cs), observation_analysis(RuleNb,T2,GB,Cs) ; Term = (T1->T2) -> observation_analysis(RuleNb,T1,GB,Cs), observation_analysis(RuleNb,T2,GB,Cs) ; Term = (\+ T) -> observation_analysis(RuleNb,T,GB,Cs) ; functor(Term,F,A), memberchk(F/A,Cs) -> spawns(RuleNb,GB,F/A) ; Term = (_ = _) -> spawns_all_triggers(RuleNb,GB) ; Term = (_ is _) -> spawns_all_triggers(RuleNb,GB) ; builtin_binds_b(Term,Vars) -> ( Vars == [] -> true ; spawns_all_triggers(RuleNb,GB) ) ; spawns_all(RuleNb,GB) ). :- chr_constraint spawns/3. :- chr_option(mode, spawns(+,+,+)). :- chr_type spawns_type ---> guard ; body. :- chr_option(type_declaration,spawns(any,spawns_type,any)). :- chr_constraint spawns_all/2, spawns_all_triggers/2. :- chr_option(mode, spawns_all(+,+)). :- chr_option(type_declaration,spawns_all(any,spawns_type)). :- chr_option(mode, spawns_all_triggers(+,+)). :- chr_option(type_declaration,spawns_all_triggers(any,spawns_type)). spawns_all(RuleNb,GB) \ spawns_all(RuleNb,GB) <=> true. spawns_all(RuleNb,guard) \ spawns_all(RuleNb,body) <=> true. spawns_all_triggers(RuleNb,GB) \ spawns_all_triggers(RuleNb,GB) <=> true. spawns_all_triggers(RuleNb,guard) \ spawns_all_triggers(RuleNb,body) <=> true. spawns(RuleNb,GB,C) \ spawns(RuleNb,GB,C) <=> true. spawns(RuleNb,guard,C) \ spawns(RuleNb,body,C) <=> true. spawns_all(RuleNb,GB) \ spawns(RuleNb,GB,_) <=> true. spawns_all(RuleNb,guard) \ spawns(RuleNb,body,_) <=> true. spawns_all(RuleNb,GB) \ spawns_all_triggers(RuleNb,GB) <=> true. spawns_all(RuleNb,guard) \ spawns_all_triggers(RuleNb,body) <=> true. spawns_all_triggers(RuleNb,GB) \ spawns(RuleNb,GB,C) <=> may_trigger(C) | true. spawns_all_triggers(RuleNb,guard) \ spawns(RuleNb,body,C) <=> may_trigger(C) | true. spawns_all(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id \ spawns(RuleNb1,GB,C1) <=> \+ is_passive(RuleNb2,O) | spawns_all(RuleNb1,GB) pragma passive(Id). occurrence(C1,_,RuleNb2,O,_)#Id, spawns_all(RuleNb2,_) ==> \+(\+ spawns_all_triggers_implies_spawns_all), % in the hope it schedules this guard early... \+ is_passive(RuleNb2,O), may_trigger(C1) | spawns_all_triggers_implies_spawns_all pragma passive(Id). :- chr_constraint spawns_all_triggers_implies_spawns_all/0. spawns_all_triggers_implies_spawns_all, spawns_all_triggers_implies_spawns_all <=> fail. spawns_all_triggers_implies_spawns_all \ spawns_all_triggers(RuleNb,GB) <=> spawns_all(RuleNb,GB). spawns_all_triggers(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id \ spawns(RuleNb1,GB,C1) <=> may_trigger(C1), \+ is_passive(RuleNb2,O) | spawns_all_triggers(RuleNb1,GB) pragma passive(Id). spawns_all_triggers(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id, spawns(RuleNb1,GB,C1) ==> \+ may_trigger(C1), \+ is_passive(RuleNb2,O) | spawns_all_triggers(RuleNb1,GB) pragma passive(Id). % a bit dangerous this rule: could start propagating too much too soon? spawns(RuleNb2,_,C2), occurrence(C1,_,RuleNb2,O,_)#Id, spawns(RuleNb1,GB,C1) ==> RuleNb1 \== RuleNb2, C1 \== C2, \+ is_passive(RuleNb2,O) | spawns(RuleNb1,GB,C2) pragma passive(Id). spawns(RuleNb2,_,C2), occurrence(C1,_,RuleNb2,O,_)#Id, spawns_all_triggers(RuleNb1,GB) ==> \+ is_passive(RuleNb2,O), may_trigger(C1), \+ may_trigger(C2) | spawns(RuleNb1,GB,C2) pragma passive(Id). :- chr_constraint all_spawned/2. :- chr_option(mode, all_spawned(+,+)). spawns_all(RuleNb,guard) \ all_spawned(RuleNb,_) <=> true. spawns_all(RuleNb,GB) \ all_spawned(RuleNb,GB) <=> true. all_spawned(RuleNb,GB) <=> fail. % Overview of the supported queries: % is_observed(+functor/artiy, +occurrence_number, +(guard;body)) % only succeeds if the occurrence is observed by the % guard resp. body (depending on the last argument) of its rule % is_observed(+functor/artiy, +occurrence_number, -) % succeeds if the occurrence is observed by either the guard or % the body of its rule % NOTE: the last argument is NOT bound by this query % % do_is_observed(+functor/artiy,+rule_number,+(guard;body)) % succeeds if the given constraint is observed by the given % guard resp. body % do_is_observed(+functor/artiy,+rule_number) % succeeds if the given constraint is observed by the given % rule (either its guard or its body) is_observed(C,O) :- is_observed(C,O,_), ai_is_observed(C,O). is_stored_in_guard(C,RuleNb) :- chr_pp_flag(store_in_guards, on), do_is_observed(C,RuleNb,guard). :- chr_constraint is_observed/3. :- chr_option(mode, is_observed(+,+,+)). occurrence(C,O,RuleNb,_,_) \ is_observed(C,O,GB) <=> do_is_observed(C,RuleNb,GB). is_observed(_,_,_) <=> fail. % this will not happen in practice :- chr_constraint do_is_observed/3. :- chr_option(mode, do_is_observed(+,+,?)). :- chr_constraint do_is_observed/2. :- chr_option(mode, do_is_observed(+,+)). do_is_observed(C,RuleNb,GB) <=> var(GB) | do_is_observed(C,RuleNb). % (1) spawns_all % a constraint C is observed if the GB of the rule it occurs in spawns all, % and some non-passive occurrence of some (possibly other) constraint % exists in a rule (could be same rule) with at least one occurrence of C spawns_all(RuleNb,GB), occurrence(_,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_) \ do_is_observed(C,RuleNb,GB) <=> \+ is_passive(RuleNb2,O) | true. spawns_all(RuleNb,_), occurrence(_,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_) \ do_is_observed(C,RuleNb) <=> \+ is_passive(RuleNb2,O) | true. % (2) spawns % a constraint C is observed if the GB of the rule it occurs in spawns a % constraint C2 that occurs non-passively in a rule (possibly the same rule) % as an occurrence of C spawns(RuleNb,GB,C2), occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_) \ do_is_observed(C,RuleNb,GB) <=> \+ is_passive(RuleNb2,O) | true. spawns(RuleNb,_,C2), occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_) \ do_is_observed(C,RuleNb) <=> \+ is_passive(RuleNb2,O) | true. % (3) spawns_all_triggers % a constraint C is observed if the GB of the rule it occurs in spawns all triggers % and some non-passive occurrence of some (possibly other) constraint that may trigger % exists in a rule (could be same rule) with at least one occurrence of C spawns_all_triggers(RuleNb,GB), occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_) \ do_is_observed(C,RuleNb,GB) <=> \+ is_passive(RuleNb2,O), may_trigger(C2) | true. spawns_all_triggers(RuleNb,_), occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_) \ do_is_observed(C,RuleNb) <=> \+ is_passive(RuleNb2,O), may_trigger(C2) | true. % (4) conservativeness do_is_observed(_,_,_) <=> chr_pp_flag(observation_analysis,off). do_is_observed(_,_) <=> chr_pp_flag(observation_analysis,off). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% %% 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) :- ( ( chr_pp_flag(debugable,on) ; is_stored(Constraint), \+ only_ground_indexed_arguments(Constraint), \+ get_store_type(Constraint,var_assoc_store(_,_)) ) -> 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_nil(Constraint,Clause1), generate_attach_a_constraint_cons(Constraint,Clause2). attach_constraint_atom(FA,Vars,Susp,Atom) :- make_name('attach_',FA,Name), Atom =.. [Name,Vars,Susp]. generate_attach_a_constraint_nil(FA,Clause) :- Clause = (Head :- true), attach_constraint_atom(FA,[],_,Head). generate_attach_a_constraint_cons(FA,Clause) :- Clause = (Head :- Body), attach_constraint_atom(FA,[Var|Vars],Susp,Head), attach_constraint_atom(FA,Vars,Susp,RecursiveCall), Body = ( AttachBody, Subscribe, RecursiveCall ), get_max_constraint_index(N), ( N == 1 -> generate_attach_body_1(FA,Var,Susp,AttachBody) ; generate_attach_body_n(FA,Var,Susp,AttachBody) ), % SWI-Prolog specific code chr_pp_flag(solver_events,NMod), ( NMod \== none -> Args = [[Var|_],Susp], get_target_module(Mod), use_auxiliary_predicate(run_suspensions), Subscribe = clp_events:subscribe(Var,NMod,Mod,Mod:'$run_suspensions'([Susp])) ; Subscribe = true ). generate_attach_body_1(FA,Var,Susp,Body) :- get_target_module(Mod), Body = ( get_attr(Var, Mod, Susps) -> put_attr(Var, Mod, [Susp|Susps]) ; put_attr(Var, Mod, [Susp]) ). generate_attach_body_n(F/A,Var,Susp,Body) :- chr_pp_flag(experiment,off), !, get_constraint_index(F/A,Position), get_max_constraint_index(Total), get_target_module(Mod), add_attr(Total,Susp,Position,TAttr,AddGoal,NTAttr), singleton_attr(Total,Susp,Position,NewAttr3), Body = ( get_attr(Var,Mod,TAttr) -> AddGoal, put_attr(Var,Mod,NTAttr) ; put_attr(Var,Mod,NewAttr3) ), !. generate_attach_body_n(F/A,Var,Susp,Body) :- chr_pp_flag(experiment,on), !, get_constraint_index(F/A,Position), or_pattern(Position,Pattern), Position1 is Position + 1, get_max_constraint_index(Total), get_target_module(Mod), singleton_attr(Total,Susp,Position,NewAttr3), Body = ( get_attr(Var,Mod,TAttr) -> arg(1,TAttr,BitVector), arg(Position1,TAttr,Susps), NBitVector is BitVector \/ Pattern, setarg(1,TAttr,NBitVector), setarg(Position1,TAttr,[Susp|Susps]) ; put_attr(Var,Mod,NewAttr3) ), !. %% detach_$CONSTRAINT generate_detach_a_constraint(Constraint,[Clause1,Clause2]) :- generate_detach_a_constraint_nil(Constraint,Clause1), generate_detach_a_constraint_cons(Constraint,Clause2). detach_constraint_atom(FA,Vars,Susp,Atom) :- make_name('detach_',FA,Name), Atom =.. [Name,Vars,Susp]. generate_detach_a_constraint_nil(FA,Clause) :- Clause = ( Head :- true), detach_constraint_atom(FA,[],_,Head). generate_detach_a_constraint_cons(FA,Clause) :- Clause = (Head :- Body), detach_constraint_atom(FA,[Var|Vars],Susp,Head), detach_constraint_atom(FA,Vars,Susp,RecursiveCall), Body = ( DetachBody, RecursiveCall ), get_max_constraint_index(N), ( N == 1 -> generate_detach_body_1(FA,Var,Susp,DetachBody) ; generate_detach_body_n(FA,Var,Susp,DetachBody) ). 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_body_n(F/A,Var,Susp,Body) :- get_constraint_index(F/A,Position), get_max_constraint_index(Total), rem_attr(Total,Var,Susp,Position,TAttr,RemGoal), get_target_module(Mod), Body = ( get_attr(Var,Mod,TAttr) -> RemGoal ; true ), !. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %------------------------------------------------------------------------------- %% generate_indexed_variables_body(+ConstraintSymbol,+ArgList,-Body,-VarList) is det. :- chr_constraint generate_indexed_variables_body/4. :- chr_option(mode,generate_indexed_variables_body(+,?,+,?)). :- chr_option(type_declaration,generate_indexed_variables_body(constraint,any,any,any)). %------------------------------------------------------------------------------- constraint_mode(F/A,ArgModes) \ generate_indexed_variables_body(F/A,Args,Body,Vars) <=> get_indexing_spec(F/A,Specs), ( chr_pp_flag(term_indexing,on) -> spectermvars(Specs,Args,F,A,Body,Vars) ; get_constraint_type_det(F/A,ArgTypes), create_indexed_variables_body(Args,ArgModes,ArgTypes,Vars,1,F/A,MaybeBody,N), ( MaybeBody == empty -> Body = true, Vars = [] ; N == 0 -> ( Args = [Term] -> true ; Term =.. [term|Args] ), Body = term_variables(Term,Vars) ; MaybeBody = Body ) ). generate_indexed_variables_body(FA,_,_,_) <=> chr_error(internal,'generate_indexed_variables_body: missing mode info for ~w.\n',[FA]). %=============================================================================== create_indexed_variables_body([],[],[],_,_,_,empty,0). create_indexed_variables_body([V|Vs],[Mode|Modes],[Type|Types],Vars,I,FA,Body,N) :- J is I + 1, create_indexed_variables_body(Vs,Modes,Types,Tail,J,FA,RBody,M), ( Mode == (?), is_indexed_argument(FA,I) -> ( atomic_type(Type) -> Body = ( ( var(V) -> Vars = [V|Tail] ; Vars = Tail ), Continuation ), ( RBody == empty -> Continuation = true, Tail = [] ; Continuation = RBody ) ; ( RBody == empty -> Body = term_variables(V,Vars) ; Body = (term_variables(V,Vars,Tail),RBody) ) ), N = M ; Mode == (-), is_indexed_argument(FA,I) -> ( RBody == empty -> Body = (Vars = [V]) ; Body = (Vars = [V|Tail],RBody) ), N is M + 1 ; Vars = Tail, Body = RBody, N is M + 1 ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % EXPERIMENTAL spectermvars(Specs,Args,F,A,Goal,Vars) :- spectermvars(Args,1,Specs,F,A,Vars,[],Goal). spectermvars([],B,_,_,A,L,L,true) :- B > A, !. spectermvars([Arg|Args],I,Specs,F,A,L,T,Goal) :- Goal = (ArgGoal,RGoal), argspecs(Specs,I,TempArgSpecs,RSpecs), merge_argspecs(TempArgSpecs,ArgSpecs), arggoal(ArgSpecs,Arg,ArgGoal,L,L1), J is I + 1, spectermvars(Args,J,RSpecs,F,A,L1,T,RGoal). argspecs([],_,[],[]). argspecs([[]|Rest],I,ArgSpecs,RestSpecs) :- argspecs(Rest,I,ArgSpecs,RestSpecs). argspecs([[specinfo(J,Spec,Args)|Specs]|Rest],I,ArgSpecs,RestSpecs) :- ( I == J -> ArgSpecs = [specinfo(J,Spec,Args)|RArgSpecs], ( Specs = [] -> RRestSpecs = RestSpecs ; RestSpecs = [Specs|RRestSpecs] ) ; ArgSpecs = RArgSpecs, RestSpecs = [[specinfo(J,Spec,Args)|Specs]|RRestSpecs] ), argspecs(Rest,I,RArgSpecs,RRestSpecs). merge_argspecs(In,Out) :- sort(In,Sorted), merge_argspecs_(Sorted,Out). merge_argspecs_([],[]). merge_argspecs_([X],R) :- !, R = [X]. merge_argspecs_([specinfo(I,F1,A1),specinfo(I,F2,A2)|Rest],R) :- ( (F1 == any ; F2 == any) -> merge_argspecs_([specinfo(I,any,[])|Rest],R) ; F1 == F2 -> append(A1,A2,A), merge_argspecs_([specinfo(I,F1,A)|Rest],R) ; R = [specinfo(I,F1,A1)|RR], merge_argspecs_([specinfo(I,F2,A2)|Rest],RR) ). arggoal(List,Arg,Goal,L,T) :- ( List == [] -> L = T, Goal = true ; List = [specinfo(_,any,_)] -> Goal = term_variables(Arg,L,T) ; Goal = ( var(Arg) -> L = [Arg|T] ; Cases ), arggoal_cases(List,Arg,L,T,Cases) ). arggoal_cases([],_,L,T,L=T). arggoal_cases([specinfo(_,FA,ArgSpecs)|Rest],Arg,L,T,Cases) :- ( ArgSpecs == [] -> Cases = RCases ; ArgSpecs == [[]] -> Cases = RCases ; FA = F/A -> Cases = (Case ; RCases), functor(Term,F,A), Term =.. [_|Args], Case = (Arg = Term -> ArgsGoal), spectermvars(Args,1,ArgSpecs,F,A,L,T,ArgsGoal) ), arggoal_cases(Rest,Arg,L,T,RCases). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% generate_extra_clauses(Constraints,List) :- generate_activate_clauses(Constraints,List,Tail0), generate_remove_clauses(Constraints,Tail0,Tail1), generate_allocate_clauses(Constraints,Tail1,Tail2), generate_insert_constraint_internal_clauses(Constraints,Tail2,Tail3), generate_novel_production(Tail3,Tail4), generate_extend_history(Tail4,Tail5), generate_run_suspensions_clauses(Constraints,Tail5,Tail6), generate_empty_named_history_initialisations(Tail6,Tail7), Tail7 = []. %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~- % remove_constraint_internal/[1/3] generate_remove_clauses([],List,List). generate_remove_clauses([C|Cs],List,Tail) :- generate_remove_clause(C,List,List1), generate_remove_clauses(Cs,List1,Tail). remove_constraint_goal(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,Goal) :- uses_state(Constraint,removed), ( chr_pp_flag(inline_insertremove,off) -> use_auxiliary_predicate(remove_constraint_internal,Constraint), Goal = ( DeleteGoal, ( Delete == yes -> DeleteYes ; DeleteNo) ), remove_constraint_atom(Constraint,Susp,Agenda,Delete,DeleteGoal) ; delay_phase_end(validate_store_type_assumptions, generate_remove_body(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,Goal) ) ). remove_constraint_atom(Constraint,Susp,Agenda,Delete,Goal) :- make_name('$remove_constraint_internal_',Constraint,Name), ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)) ) -> Goal =.. [Name, Susp,Delete] ; Goal =.. [Name,Susp,Agenda,Delete] ). generate_remove_clause(Constraint,List,Tail) :- ( is_used_auxiliary_predicate(remove_constraint_internal,Constraint) -> List = [RemoveClause|Tail], RemoveClause = (Head :- RemoveBody), remove_constraint_atom(Constraint,Susp,Agenda,Delete,Head), generate_remove_body(Constraint,Susp,Agenda,Delete = no,Delete = yes,active,RemoveBody) ; List = Tail ). generate_remove_body(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,RemoveBody) :- ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_))) -> ( Role == active -> get_update_suspension_field(Constraint,Susp,state,State,removed,GetState,GetStateValue0,UpdateState), if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue), if_used_state(Constraint,not_stored_yet,(State == not_stored_yet -> DeleteNo ; DeleteYes),DeleteYes,MaybeDelete) ; Role == partner -> get_update_suspension_field(Constraint,Susp,state,State,removed,GetState,_,UpdateState), GetStateValue = true, MaybeDelete = DeleteYes ), RemoveBody = ( GetState, GetStateValue, UpdateState, MaybeDelete ) ; static_suspension_term(Constraint,Susp2), get_static_suspension_term_field(arguments,Constraint,Susp2,Args), generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Agenda), ( chr_pp_flag(debugable,on) -> Constraint = Functor / _, get_static_suspension_term_field(functor,Constraint,Susp2,Functor) ; true ), ( Role == active -> get_update_static_suspension_field(Constraint,Susp,Susp2,state,State,removed,GetStateValue0,UpdateState), if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue), if_used_state(Constraint,not_stored_yet,(State == not_stored_yet -> Agenda = [], DeleteNo ; IndexedVariablesBody, DeleteYes),(IndexedVariablesBody,DeleteYes),MaybeDelete) ; Role == partner -> get_update_static_suspension_field(Constraint,Susp,Susp2,state,State,removed,_,UpdateState), GetStateValue = true, MaybeDelete = (IndexedVariablesBody, DeleteYes) ), RemoveBody = ( Susp = Susp2, GetStateValue, UpdateState, MaybeDelete ) ). %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~- % activate_constraint/4 generate_activate_clauses([],List,List). generate_activate_clauses([C|Cs],List,Tail) :- generate_activate_clause(C,List,List1), generate_activate_clauses(Cs,List1,Tail). activate_constraint_goal(Constraint,StoreAction,Vars,Susp,Generation,Goal) :- ( chr_pp_flag(inline_insertremove,off) -> use_auxiliary_predicate(activate_constraint,Constraint), Goal = ( ActivateGoal , (Store == yes -> StoreAction ; true) ), activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,ActivateGoal) ; delay_phase_end(validate_store_type_assumptions, activate_constraint_body(Constraint,StoreAction,true,Vars,Susp,Generation,Goal) ) ). activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,Goal) :- make_name('$activate_constraint_',Constraint,Name), ( chr_pp_flag(debugable,off), only_ground_indexed_arguments(Constraint) -> Goal =.. [Name,Store, Susp] ; chr_pp_flag(debugable,off), may_trigger(Constraint), get_store_type(Constraint,var_assoc_store(_,_)) -> Goal =.. [Name,Store, Susp, Generation] ; chr_pp_flag(debugable,off), may_trigger(Constraint), get_store_type(Constraint,var_assoc_store(_,_)) -> Goal =.. [Name,Store, Vars, Susp, Generation] ; Goal =.. [Name,Store, Vars, Susp] ). generate_activate_clause(Constraint,List,Tail) :- ( is_used_auxiliary_predicate(activate_constraint,Constraint) -> List = [Clause|Tail], Clause = (Head :- Body), activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,Head), activate_constraint_body(Constraint,Store = yes, Store = no,Vars,Susp,Generation,Body) ; List = Tail ). activate_constraint_body(Constraint,StoreYes,StoreNo,Vars,Susp,Generation,Body) :- ( chr_pp_flag(debugable,off), may_trigger(Constraint), uses_field(Constraint,generation) -> get_update_suspension_field(Constraint,Susp,generation,Gen,Generation,GetGeneration,GetGenerationValue,UpdateGeneration), GenerationHandling = (GetGeneration, GetGenerationValue, Generation is Gen+1, UpdateGeneration) ; GenerationHandling = true ), get_update_suspension_field(Constraint,Susp,state,State,active,GetState,GetStateValue0,UpdateState), if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue), ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_))) -> if_used_state(Constraint,not_stored_yet,( State == not_stored_yet -> StoreYes ; StoreNo ),StoreNo,StoreVarsGoal) ; get_dynamic_suspension_term_field(arguments,Constraint,Susp,Arguments,ArgumentsGoal), generate_indexed_variables_body(Constraint,Arguments,IndexedVariablesBody,Vars), chr_none_locked(Vars,NoneLocked), if_used_state(Constraint,not_stored_yet, ( State == not_stored_yet -> ArgumentsGoal, IndexedVariablesBody, NoneLocked, StoreYes ; % Vars = [], StoreNo ), % (Vars = [],StoreNo),StoreVarsGoal) StoreNo,StoreVarsGoal) ), Body = ( GetState, GetStateValue, UpdateState, GenerationHandling, StoreVarsGoal ). %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~- % allocate_constraint/4 generate_allocate_clauses([],List,List). generate_allocate_clauses([C|Cs],List,Tail) :- generate_allocate_clause(C,List,List1), generate_allocate_clauses(Cs,List1,Tail). allocate_constraint_goal(Constraint,Susp,Args,Goal) :- uses_state(Constraint,not_stored_yet), ( chr_pp_flag(inline_insertremove,off) -> use_auxiliary_predicate(allocate_constraint,Constraint), allocate_constraint_atom(Constraint,Susp,Args,Goal) ; Goal = (Susp = Suspension, Goal0), delay_phase_end(validate_store_type_assumptions, allocate_constraint_body(Constraint,Suspension,Args,Goal0) ) ). allocate_constraint_atom(Constraint, Susp, Args,Goal) :- make_name('$allocate_constraint_',Constraint,Name), Goal =.. [Name,Susp|Args]. generate_allocate_clause(Constraint,List,Tail) :- ( is_used_auxiliary_predicate(allocate_constraint,Constraint) -> List = [Clause|Tail], Clause = (Head :- Body), Constraint = _/A, length(Args,A), allocate_constraint_atom(Constraint,Susp,Args,Head), allocate_constraint_body(Constraint,Susp,Args,Body) ; List = Tail ). allocate_constraint_body(Constraint,Susp,Args,Body) :- static_suspension_term(Constraint,Suspension), get_static_suspension_term_field(arguments,Constraint,Suspension,Args), ( chr_pp_flag(debugable,on) -> Constraint = Functor / _, get_static_suspension_term_field(functor,Constraint,Suspension,Functor) ; true ), ( chr_pp_flag(debugable,on) -> ( may_trigger(Constraint) -> append(Args,[Susp],VarsSusp), build_head(F,A,[0],VarsSusp, ContinuationGoal), get_target_module(Mod), Continuation = Mod : ContinuationGoal ; Continuation = true ), Init = (Susp = Suspension), create_static_suspension_field(Constraint,Suspension,continuation,Continuation,CreateContinuation), create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration) ; may_trigger(Constraint), uses_field(Constraint,generation) -> create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration), Susp = Suspension, Init = true, CreateContinuation = true ; CreateGeneration = true, Susp = Suspension, Init = true, CreateContinuation = true ), ( uses_history(Constraint) -> create_static_suspension_field(Constraint,Suspension,history,t,CreateHistory) ; CreateHistory = true ), create_static_suspension_field(Constraint,Suspension,state,not_stored_yet,CreateState), ( has_suspension_field(Constraint,id) -> get_static_suspension_term_field(id,Constraint,Suspension,Id), gen_id(Id,GenID) ; GenID = true ), Body = ( Init, CreateContinuation, CreateGeneration, CreateHistory, CreateState, GenID ). gen_id(Id,'chr gen_id'(Id)). %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~- % insert_constraint_internal generate_insert_constraint_internal_clauses([],List,List). generate_insert_constraint_internal_clauses([C|Cs],List,Tail) :- generate_insert_constraint_internal_clause(C,List,List1), generate_insert_constraint_internal_clauses(Cs,List1,Tail). insert_constraint_internal_constraint_goal(Constraint, Vars, Suspension, Continuation, Args,Goal) :- ( chr_pp_flag(inline_insertremove,off) -> use_auxiliary_predicate(remove_constraint_internal,Constraint), insert_constraint_internal_constraint_atom(Constraint,Vars,Suspension,Continuation,Args,Goal) ; delay_phase_end(validate_store_type_assumptions, generate_insert_constraint_internal_body(Constraint,Suspension,Continuation,Args,Vars,Goal) ) ). insert_constraint_internal_constraint_atom(Constraint,Vars,Self,Closure,Args,Goal) :- insert_constraint_internal_constraint_name(Constraint,Name), ( chr_pp_flag(debugable,on) -> Goal =.. [Name, Vars, Self, Closure | Args] ; ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)))-> Goal =.. [Name,Self | Args] ; Goal =.. [Name,Vars, Self | Args] ). insert_constraint_internal_constraint_name(Constraint,Name) :- make_name('$insert_constraint_internal_',Constraint,Name). generate_insert_constraint_internal_clause(Constraint,List,Tail) :- ( is_used_auxiliary_predicate(insert_constraint_internal,Constraint) -> List = [Clause|Tail], Clause = (Head :- Body), Constraint = _/A, length(Args,A), insert_constraint_internal_constraint_atom(Constraint, Vars, Suspension, Continuation,Args,Head), generate_insert_constraint_internal_body(Constraint,Suspension,Continuation,Args,Vars,Body) ; List = Tail ). generate_insert_constraint_internal_body(Constraint,Susp,Continuation,Args,Vars,Body) :- static_suspension_term(Constraint,Suspension), create_static_suspension_field(Constraint,Suspension,state,active,CreateState), ( chr_pp_flag(debugable,on) -> get_static_suspension_term_field(continuation,Constraint,Suspension,Continuation), create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration) ; may_trigger(Constraint), uses_field(Constraint,generation) -> create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration) ; CreateGeneration = true ), ( chr_pp_flag(debugable,on) -> Constraint = Functor / _, get_static_suspension_term_field(functor,Constraint,Suspension,Functor) ; true ), ( uses_history(Constraint) -> create_static_suspension_field(Constraint,Suspension,history,t,CreateHistory) ; CreateHistory = true ), get_static_suspension_term_field(arguments,Constraint,Suspension,Args), List = [Clause|Tail], ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)))-> suspension_term_base_fields(Constraint,BaseFields), ( has_suspension_field(Constraint,id) -> get_static_suspension_term_field(id,Constraint,Suspension,Id), gen_id(Id,GenID) ; GenID = true ), Body = ( Susp = Suspension, CreateState, CreateGeneration, CreateHistory, GenID ) ; ( has_suspension_field(Constraint,id) -> get_static_suspension_term_field(id,Constraint,Suspension,Id), gen_id(Id,GenID) ; GenID = true ), generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Vars), chr_none_locked(Vars,NoneLocked), Body = ( Susp = Suspension, IndexedVariablesBody, NoneLocked, CreateState, CreateGeneration, CreateHistory, GenID ) ). %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~- % novel_production/2 generate_novel_production(List,Tail) :- ( is_used_auxiliary_predicate(novel_production) -> List = [Clause|Tail], Clause = ( '$novel_production'( Self, Tuple) :- % arg( 3, Self, Ref), % ARGXXX % 'chr get_mutable'( History, Ref), arg( 3, Self, History), % ARGXXX ( hprolog:get_ds( Tuple, History, _) -> fail ; true ) ) ; List = Tail ). %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~- % extend_history/2 generate_extend_history(List,Tail) :- ( is_used_auxiliary_predicate(extend_history) -> List = [Clause|Tail], Clause = ( '$extend_history'( Self, Tuple) :- % arg( 3, Self, Ref), % ARGXXX % 'chr get_mutable'( History, Ref), arg( 3, Self, History), % ARGXXX hprolog:put_ds( Tuple, History, x, NewHistory), setarg( 3, Self, NewHistory) % ARGXXX ) ; List = Tail ). %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~- % :- chr_constraint empty_named_history_initialisations/2, generate_empty_named_history_initialisation/1, find_empty_named_histories/0. generate_empty_named_history_initialisations(List, Tail) :- empty_named_history_initialisations(List, Tail), find_empty_named_histories. find_empty_named_histories, history(_, Name, []) ==> generate_empty_named_history_initialisation(Name). generate_empty_named_history_initialisation(Name) \ generate_empty_named_history_initialisation(Name) <=> true. generate_empty_named_history_initialisation(Name) \ empty_named_history_initialisations(List, Tail) # Passive <=> empty_named_history_global_variable(Name, GlobalVariable), List = [(:- nb_setval(GlobalVariable, 0))|Rest], empty_named_history_initialisations(Rest, Tail) pragma passive(Passive). find_empty_named_histories \ generate_empty_named_history_initialisation(_) # Passive <=> true pragma passive(Passive). find_empty_named_histories, empty_named_history_initialisations(List, Tail) # Passive <=> List = Tail pragma passive(Passive). find_empty_named_histories <=> chr_error(internal, 'find_empty_named_histories was not removed', []). empty_named_history_global_variable(Name, GlobalVariable) :- atom_concat('chr empty named history ', Name, GlobalVariable). empty_named_history_novel_production(Name, nb_getval(GlobalVariable, 0)) :- empty_named_history_global_variable(Name, GlobalVariable). empty_named_history_extend_history(Name, b_setval(GlobalVariable, 1)) :- empty_named_history_global_variable(Name, GlobalVariable). %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~- % run_suspensions/2 generate_run_suspensions_clauses([],List,List). generate_run_suspensions_clauses([C|Cs],List,Tail) :- generate_run_suspensions_clause(C,List,List1), generate_run_suspensions_clauses(Cs,List1,Tail). run_suspensions_goal(Constraint,Suspensions,Goal) :- make_name('$run_suspensions_',Constraint,Name), Goal =.. [Name,Suspensions]. generate_run_suspensions_clause(Constraint,List,Tail) :- ( is_used_auxiliary_predicate(run_suspensions,Constraint) -> List = [Clause1,Clause2|Tail], run_suspensions_goal(Constraint,[],Clause1), ( chr_pp_flag(debugable,on) -> run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head), get_update_suspension_field(Constraint,Suspension,state,State,triggered,GetState,GetStateValue,UpdateState), get_update_suspension_field(Constraint,Suspension,state,Post,active,GetPost,GetPostValue,UpdatePost), get_update_suspension_field(Constraint,Suspension,generation,Gen,Generation,GetGeneration,GetGenerationValue,UpdateGeneration), get_dynamic_suspension_term_field(continuation,Constraint,Suspension,Continuation,GetContinuation), run_suspensions_goal(Constraint,Suspensions,Clause2Recursion), Clause2 = ( Clause2Head :- GetState, GetStateValue, ( State==active -> UpdateState, GetGeneration, GetGenerationValue, Generation is Gen+1, UpdateGeneration, GetContinuation, ( 'chr debugging' -> ( 'chr debug_event'(wake(Suspension)), call(Continuation) ; 'chr debug_event'(fail(Suspension)), !, fail ), ( 'chr debug_event'(exit(Suspension)) ; 'chr debug_event'(redo(Suspension)), fail ) ; call(Continuation) ), GetPost, GetPostValue, ( Post==triggered -> UpdatePost % catching constraints that did not do anything ; true ) ; true ), Clause2Recursion ) ; run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head), static_suspension_term(Constraint,SuspensionTerm), get_static_suspension_term_field(arguments,Constraint,SuspensionTerm,Arguments), append(Arguments,[Suspension],VarsSusp), make_suspension_continuation_goal(Constraint,VarsSusp,Continuation), run_suspensions_goal(Constraint,Suspensions,Clause2Recursion), ( uses_field(Constraint,generation) -> get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,generation,Gen,Generation,GetGeneration,UpdateGeneration), GenerationHandling = ( GetGeneration, Generation is Gen+1, UpdateGeneration) ; GenerationHandling = true ), get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,state,State,triggered,GetState,UpdateState), get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,state,Post,active,GetPostState,UpdatePostState), if_used_state(Constraint,removed, ( GetState, ( State==active -> ReactivateConstraint ; true) ),ReactivateConstraint,CondReactivate), ReactivateConstraint = ( UpdateState, GenerationHandling, Continuation, GetPostState, ( Post==triggered -> UpdatePostState % catching constraints that did not do anything ; true ) ), Clause2 = ( Clause2Head :- Suspension = SuspensionTerm, CondReactivate, Clause2Recursion ) ) ; List = Tail ). %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% generate_attach_increment(Clauses) :- get_max_constraint_index(N), ( is_used_auxiliary_predicate(attach_increment), 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), chr_not_locked(Var,NotLocked), Body = ( NotLocked, ( get_attr(Var,Mod,VarSusps) -> sort(VarSusps,SortedVarSusps), 'chr merge_attributes'(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) :- Head = attach_increment([Var|Vars],TAttr1), % writeln(merge_attributes_1_before), merge_attributes(N,TAttr1,TAttr2,MergeGoal,Attr), % writeln(merge_attributes_1_after), get_target_module(Mod), chr_not_locked(Var,NotLocked), Body = ( NotLocked, ( get_attr(Var,Mod,TAttr2) -> MergeGoal, put_attr(Var,Mod,Attr) ; put_attr(Var,Mod,TAttr1) ), attach_increment(Vars,TAttr1) ), Clause = (Head :- Body). %% attr_unify_hook generate_attr_unify_hook(Clauses) :- get_max_constraint_index(N), ( N == 0 -> Clauses = [] ; Clauses = [GoalsClause|HookClauses], GoalsClause = attribute_goals(_,Goals,Goals), ( N == 1 -> generate_attr_unify_hook_one(HookClauses) ; generate_attr_unify_hook_many(N,HookClauses) ) ). generate_attr_unify_hook_one([Clause]) :- Head = attr_unify_hook(Susps,Other), get_target_module(Mod), get_indexed_constraint(1,C), ( get_store_type(C,ST), ( ST = default ; ST = multi_store(STs), memberchk(default,STs) ) -> make_run_suspensions(NewSusps,SortedSusps,WakeNewSusps), make_run_suspensions(SortedSusps,SortedSusps,WakeSusps), ( atomic_types_suspended_constraint(C) -> SortGoal1 = true, SortedSusps = Susps, SortGoal2 = true, SortedOtherSusps = OtherSusps, MergeGoal = (append(Susps,OtherSusps,List), sort(List,NewSusps)), NonvarBody = true ; SortGoal1 = sort(Susps, SortedSusps), SortGoal2 = sort(OtherSusps,SortedOtherSusps), MergeGoal = 'chr merge_attributes'(SortedSusps,SortedOtherSusps,NewSusps), use_auxiliary_predicate(attach_increment), NonvarBody = ( compound(Other) -> term_variables(Other,OtherVars), attach_increment(OtherVars, SortedSusps) ; true ) ), Body = ( SortGoal1, ( var(Other) -> ( get_attr(Other,Mod,OtherSusps) -> SortGoal2, MergeGoal, put_attr(Other,Mod,NewSusps), WakeNewSusps ; put_attr(Other,Mod,SortedSusps), WakeSusps ) ; NonvarBody, WakeSusps ) ), Clause = (Head :- Body) ; get_store_type(C,var_assoc_store(VarIndex,KeyIndex)) -> make_run_suspensions(List,List,WakeNewSusps), MergeGoal = (merge_into_assoc_store(Susps,OtherSusps,List)), Body = ( get_attr(Other,Mod,OtherSusps) -> MergeGoal, WakeNewSusps ; put_attr(Other,Mod,Susps) ), Clause = (Head :- Body) ). generate_attr_unify_hook_many(N,[Clause]) :- chr_pp_flag(dynattr,off), !, Head = attr_unify_hook(Attr,Other), get_target_module(Mod), make_attr(N,Mask,SuspsList,Attr), bagof(Sort,A ^ B ^ ( member(A,SuspsList) , Sort = sort(A,B) ) , SortGoalList), list2conj(SortGoalList,SortGoals), bagof(B, A ^ member(sort(A,B),SortGoalList), SortedSuspsList), merge_attributes2(N,Mask,SortedSuspsList,TOtherAttr,MergeGoal,MergedAttr), get_all_suspensions2(N,MergedAttr,MergedSuspsList), make_attr(N,Mask,SortedSuspsList,SortedAttr), make_run_suspensions_loop(MergedSuspsList,SortedSuspsList,WakeMergedSusps), make_run_suspensions_loop(SortedSuspsList,SortedSuspsList,WakeSortedSusps), ( forall((between(1,N,Index), get_indexed_constraint(Index,Constraint)),atomic_types_suspended_constraint(Constraint)) -> NonvarBody = true ; use_auxiliary_predicate(attach_increment), NonvarBody = ( compound(Other) -> term_variables(Other,OtherVars), attach_increment(OtherVars,SortedAttr) ; true ) ), Body = ( SortGoals, ( var(Other) -> ( get_attr(Other,Mod,TOtherAttr) -> MergeGoal, put_attr(Other,Mod,MergedAttr), WakeMergedSusps ; put_attr(Other,Mod,SortedAttr), WakeSortedSusps ) ; NonvarBody, WakeSortedSusps ) ), Clause = (Head :- Body). % NEW generate_attr_unify_hook_many(N,Clauses) :- Head = attr_unify_hook(Attr,Other), get_target_module(Mod), normalize_attr(Attr,NormalGoal,NormalAttr), normalize_attr(OtherAttr,NormalOtherGoal,NormalOtherAttr), merge_attributes(N,NormalAttr,NormalOtherAttr,MergeGoal,MergedAttr), make_run_suspensions(N), ( forall((between(1,N,Index), get_indexed_constraint(Index,Constraint)),atomic_types_suspended_constraint(Constraint)) -> NonvarBody = true ; use_auxiliary_predicate(attach_increment), NonvarBody = ( compound(Other) -> term_variables(Other,OtherVars), attach_increment(OtherVars,NormalAttr) ; true ) ), Body = ( NormalGoal, ( var(Other) -> ( get_attr(Other,Mod,OtherAttr) -> NormalOtherGoal, MergeGoal, put_attr(Other,Mod,MergedAttr), '$dispatch_run_suspensions'(MergedAttr) ; put_attr(Other,Mod,NormalAttr), '$dispatch_run_suspensions'(NormalAttr) ) ; NonvarBody, '$dispatch_run_suspensions'(NormalAttr) ) ), Clause = (Head :- Body), Clauses = [Clause,DispatchList1,DispatchList2|Dispatchers], DispatchList1 = ('$dispatch_run_suspensions'([])), DispatchList2 = ('$dispatch_run_suspensions'([Pos-List|Rest]) :- '$dispatch_run_suspensions'(Pos,List),'$dispatch_run_suspensions'(Rest)), run_suspensions_dispatchers(N,[],Dispatchers). % NEW run_suspensions_dispatchers(N,Acc,Dispatchers) :- ( N > 0 -> get_indexed_constraint(N,C), NAcc = [('$dispatch_run_suspensions'(N,List) :- Body)|Acc], ( may_trigger(C) -> run_suspensions_goal(C,List,Body) ; Body = true ), M is N - 1, run_suspensions_dispatchers(M,NAcc,Dispatchers) ; Dispatchers = Acc ). % NEW make_run_suspensions(N) :- ( N > 0 -> ( get_indexed_constraint(N,C), may_trigger(C) -> use_auxiliary_predicate(run_suspensions,C) ; true ), M is N - 1, make_run_suspensions(M) ; true ). make_run_suspensions(AllSusps,OneSusps,Goal) :- make_run_suspensions(1,AllSusps,OneSusps,Goal). make_run_suspensions(Index,AllSusps,OneSusps,Goal) :- ( get_indexed_constraint(Index,C), may_trigger(C) -> use_auxiliary_predicate(run_suspensions,C), ( wakes_partially(C) -> run_suspensions_goal(C,OneSusps,Goal) ; run_suspensions_goal(C,AllSusps,Goal) ) ; Goal = true ). make_run_suspensions_loop(AllSuspsList,OneSuspsList,Goal) :- make_run_suspensions_loop(AllSuspsList,OneSuspsList,1,Goal). make_run_suspensions_loop([],[],_,true). make_run_suspensions_loop([AllSusps|AllSuspsList],[OneSusps|OneSuspsList],I,(Goal,Goals)) :- make_run_suspensions(I,AllSusps,OneSusps,Goal), J is I + 1, make_run_suspensions_loop(AllSuspsList,OneSuspsList,J,Goals). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % $insert_in_store_F/A % $delete_from_store_F/A generate_insert_delete_constraints([],[]). generate_insert_delete_constraints([FA|Rest],Clauses) :- ( is_stored(FA) -> generate_insert_delete_constraint(FA,Clauses,RestClauses) ; Clauses = RestClauses ), generate_insert_delete_constraints(Rest,RestClauses). generate_insert_delete_constraint(FA,Clauses,RestClauses) :- insert_constraint_clause(FA,Clauses,RestClauses1), delete_constraint_clause(FA,RestClauses1,RestClauses). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% % insert_in_store insert_constraint_goal(FA,Susp,Vars,Goal) :- ( chr_pp_flag(inline_insertremove,off) -> use_auxiliary_predicate(insert_in_store,FA), insert_constraint_atom(FA,Susp,Goal) ; delay_phase_end(validate_store_type_assumptions, ( insert_constraint_body(FA,Susp,UsedVars,Goal), insert_constraint_direct_used_vars(UsedVars,Vars) ) ) ). insert_constraint_direct_used_vars([],_). insert_constraint_direct_used_vars([Index-Var|Rest],Vars) :- nth1(Index,Vars,Var), insert_constraint_direct_used_vars(Rest,Vars). insert_constraint_atom(FA,Susp,Call) :- make_name('$insert_in_store_',FA,Functor), Call =.. [Functor,Susp]. insert_constraint_clause(C,Clauses,RestClauses) :- ( is_used_auxiliary_predicate(insert_in_store,C) -> Clauses = [Clause|RestClauses], Clause = (Head :- InsertCounterInc,VarsBody,Body), insert_constraint_atom(C,Susp,Head), insert_constraint_body(C,Susp,UsedVars,Body), insert_constraint_used_vars(UsedVars,C,Susp,VarsBody), ( chr_pp_flag(store_counter,on) -> InsertCounterInc = '$insert_counter_inc' ; InsertCounterInc = true ) ; Clauses = RestClauses ). insert_constraint_used_vars([],_,_,true). insert_constraint_used_vars([Index-Var|Rest],C,Susp,(Goal,Goals)) :- get_dynamic_suspension_term_field(argument(Index),C,Susp,Var,Goal), insert_constraint_used_vars(Rest,C,Susp,Goals). insert_constraint_body(C,Susp,UsedVars,Body) :- get_store_type(C,StoreType), insert_constraint_body(StoreType,C,Susp,UsedVars,Body). insert_constraint_body(default,C,Susp,[],Body) :- global_list_store_name(C,StoreName), make_get_store_goal(StoreName,Store,GetStoreGoal), make_update_store_goal(StoreName,Cell,UpdateStoreGoal), ( chr_pp_flag(debugable,on) -> Cell = [Susp|Store], Body = ( GetStoreGoal, UpdateStoreGoal ) ; set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal), Body = ( GetStoreGoal, Cell = [Susp|Store], UpdateStoreGoal, ( Store = [NextSusp|_] -> SetGoal ; true ) ) ). % 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 % ). insert_constraint_body(multi_inthash(Indexes),C,Susp,[],Body) :- generate_multi_inthash_insert_constraint_bodies(Indexes,C,Susp,Body). insert_constraint_body(multi_hash(Indexes),C,Susp,MixedUsedVars,Body) :- generate_multi_hash_insert_constraint_bodies(Indexes,C,Susp,Body,MixedUsedVars), sort_out_used_vars(MixedUsedVars,UsedVars). insert_constraint_body(atomic_constants(Index,_,_),C,Susp,UsedVars,Body) :- multi_hash_key_direct(C,Index,Susp,Key,UsedVars), constants_store_index_name(C,Index,IndexName), IndexLookup =.. [IndexName,Key,StoreName], Body = ( IndexLookup -> nb_getval(StoreName,Store), b_setval(StoreName,[Susp|Store]) ; true ). insert_constraint_body(ground_constants(Index,_,_),C,Susp,UsedVars,Body) :- multi_hash_key_direct(C,Index,Susp,Key,UsedVars), constants_store_index_name(C,Index,IndexName), IndexLookup =.. [IndexName,Key,StoreName], Body = ( IndexLookup -> nb_getval(StoreName,Store), b_setval(StoreName,[Susp|Store]) ; true ). 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,Cell,UpdateStoreGoal), ( chr_pp_flag(debugable,on) -> Cell = [Susp|Store], Body = ( GetStoreGoal, UpdateStoreGoal ) ; set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal), Body = ( GetStoreGoal, Cell = [Susp|Store], UpdateStoreGoal, ( Store = [NextSusp|_] -> SetGoal ; true ) ) ). % 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]) % ). insert_constraint_body(var_assoc_store(VarIndex,AssocIndex),C,Susp,[VarIndex-Variable,AssocIndex-Key],Body) :- % TODO: generalize to more than one !!! get_target_module(Module), Body = ( get_attr(Variable,Module,AssocStore) -> insert_assoc_store(AssocStore,Key,Susp) ; new_assoc_store(AssocStore), put_attr(Variable,Module,AssocStore), insert_assoc_store(AssocStore,Key,Susp) ). insert_constraint_body(global_singleton,C,Susp,[],Body) :- global_singleton_store_name(C,StoreName), make_update_store_goal(StoreName,Susp,UpdateStoreGoal), Body = ( UpdateStoreGoal ). insert_constraint_body(multi_store(StoreTypes),C,Susp,UsedVars,Body) :- maplist(insert_constraint_body1(C,Susp),StoreTypes,NestedUsedVars,Bodies), list2conj(Bodies,Body), sort_out_used_vars(NestedUsedVars,UsedVars). insert_constraint_body1(C,Susp,StoreType,UsedVars,Body) :- insert_constraint_body(StoreType,C,Susp,UsedVars,Body). insert_constraint_body(identifier_store(Index),C,Susp,UsedVars,Body) :- UsedVars = [Index-Var], get_identifier_size(ISize), functor(Struct,struct,ISize), get_identifier_index(C,Index,IIndex), arg(IIndex,Struct,Susps), Body = (Var = Struct, setarg(IIndex,Var,[Susp|Susps])). insert_constraint_body(type_indexed_identifier_store(Index,IndexType),C,Susp,UsedVars,Body) :- UsedVars = [Index-Var], type_indexed_identifier_structure(IndexType,Struct), get_type_indexed_identifier_index(IndexType,C,Index,IIndex), arg(IIndex,Struct,Susps), Body = (Var = Struct, setarg(IIndex,Var,[Susp|Susps])). sort_out_used_vars(NestedUsedVars,UsedVars) :- flatten(NestedUsedVars,FlatUsedVars), sort(FlatUsedVars,SortedFlatUsedVars), sort_out_used_vars1(SortedFlatUsedVars,UsedVars). sort_out_used_vars1([],[]). sort_out_used_vars1([I-V],L) :- !, L = [I-V]. sort_out_used_vars1([I-X,J-Y|R],L) :- ( I == J -> X = Y, sort_out_used_vars1([I-X|R],L) ; L = [I-X|T], sort_out_used_vars1([J-Y|R],T) ). generate_multi_inthash_insert_constraint_bodies([],_,_,true). generate_multi_inthash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :- multi_hash_store_name(FA,Index,StoreName), multi_hash_key(FA,Index,Susp,KeyBody,Key), Body = ( KeyBody, nb_getval(StoreName,Store), insert_iht(Store,Key,Susp) ), generate_multi_inthash_insert_constraint_bodies(Indexes,FA,Susp,Bodies). generate_multi_hash_insert_constraint_bodies([],_,_,true,[]). generate_multi_hash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies),[UsedVars|MoreUsedVars]) :- multi_hash_store_name(FA,Index,StoreName), multi_hash_key_direct(FA,Index,Susp,Key,UsedVars), make_get_store_goal(StoreName,Store,GetStoreGoal), ( chr_pp_flag(ht_removal,on) -> ht_prev_field(Index,PrevField), set_dynamic_suspension_term_field(PrevField,FA,NextSusp,Result, SetGoal), Body = ( GetStoreGoal, insert_ht(Store,Key,Susp,Result), ( Result = [_,NextSusp|_] -> SetGoal ; true ) ) ; Body = ( GetStoreGoal, insert_ht(Store,Key,Susp) ) ), generate_multi_hash_insert_constraint_bodies(Indexes,FA,Susp,Bodies,MoreUsedVars). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% % Delete delete_constraint_clause(C,Clauses,RestClauses) :- ( is_used_auxiliary_predicate(delete_from_store,C) -> Clauses = [Clause|RestClauses], Clause = (Head :- Body), delete_constraint_atom(C,Susp,Head), C = F/A, functor(Head,F,A), delete_constraint_body(C,Head,Susp,[],Body) ; Clauses = RestClauses ). delete_constraint_goal(Head,Susp,VarDict,Goal) :- functor(Head,F,A), C = F/A, ( chr_pp_flag(inline_insertremove,off) -> use_auxiliary_predicate(delete_from_store,C), delete_constraint_atom(C,Susp,Goal) ; delay_phase_end(validate_store_type_assumptions, delete_constraint_body(C,Head,Susp,VarDict,Goal)) ). delete_constraint_atom(C,Susp,Atom) :- make_name('$delete_from_store_',C,Functor), Atom =.. [Functor,Susp]. delete_constraint_body(C,Head,Susp,VarDict,Body) :- Body = (CounterBody,DeleteBody), ( chr_pp_flag(store_counter,on) -> CounterBody = '$delete_counter_inc' ; CounterBody = true ), get_store_type(C,StoreType), delete_constraint_body(StoreType,C,Head,Susp,VarDict,DeleteBody). delete_constraint_body(default,C,_,Susp,_,Body) :- ( chr_pp_flag(debugable,on) -> global_list_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) ) ; get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal), global_list_store_name(C,StoreName), make_get_store_goal(StoreName,Store,GetStoreGoal), make_update_store_goal(StoreName,Tail,UpdateStoreGoal), set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1), set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2), Body = ( GetGoal, ( var(PredCell) -> GetStoreGoal, % nb_getval(StoreName,Store), Store = [_|Tail], UpdateStoreGoal, ( Tail = [NextSusp|_] -> SetGoal1 ; true ) ; PredCell = [_,_|Tail], setarg(2,PredCell,Tail), ( Tail = [NextSusp|_] -> SetGoal2 ; true ) ) ) ). % 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 % ) % ). delete_constraint_body(multi_inthash(Indexes),C,_,Susp,_,Body) :- generate_multi_inthash_delete_constraint_bodies(Indexes,C,Susp,Body). delete_constraint_body(multi_hash(Indexes),C,Head,Susp,VarDict,Body) :- generate_multi_hash_delete_constraint_bodies(Indexes,C,Head,Susp,VarDict,Body). delete_constraint_body(atomic_constants(Index,_,_),C,Head,Susp,VarDict,Body) :- multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key), constants_store_index_name(C,Index,IndexName), IndexLookup =.. [IndexName,Key,StoreName], Body = ( KeyBody, ( IndexLookup -> nb_getval(StoreName,Store), 'chr sbag_del_element'(Store,Susp,NStore), b_setval(StoreName,NStore) ; true )). delete_constraint_body(ground_constants(Index,_,_),C,Head,Susp,VarDict,Body) :- multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key), constants_store_index_name(C,Index,IndexName), IndexLookup =.. [IndexName,Key,StoreName], Body = ( KeyBody, ( IndexLookup -> nb_getval(StoreName,Store), 'chr sbag_del_element'(Store,Susp,NStore), b_setval(StoreName,NStore) ; true )). delete_constraint_body(global_ground,C,_,Susp,_,Body) :- ( chr_pp_flag(debugable,on) -> 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) ) ; get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal), global_ground_store_name(C,StoreName), make_get_store_goal(StoreName,Store,GetStoreGoal), make_update_store_goal(StoreName,Tail,UpdateStoreGoal), set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1), set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2), Body = ( GetGoal, ( var(PredCell) -> GetStoreGoal, % nb_getval(StoreName,Store), Store = [_|Tail], UpdateStoreGoal, ( Tail = [NextSusp|_] -> SetGoal1 ; true ) ; PredCell = [_,_|Tail], setarg(2,PredCell,Tail), ( Tail = [NextSusp|_] -> SetGoal2 ; true ) ) ) ). % 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) % ). delete_constraint_body(var_assoc_store(VarIndex,AssocIndex),C,_,Susp,_,Body) :- get_target_module(Module), get_dynamic_suspension_term_field(argument(VarIndex),C,Susp,Variable,VariableGoal), get_dynamic_suspension_term_field(argument(AssocIndex),C,Susp,Key,KeyGoal), Body = ( VariableGoal, get_attr(Variable,Module,AssocStore), KeyGoal, delete_assoc_store(AssocStore,Key,Susp) ). delete_constraint_body(global_singleton,C,_,_Susp,_,Body) :- global_singleton_store_name(C,StoreName), make_update_store_goal(StoreName,[],UpdateStoreGoal), Body = ( UpdateStoreGoal % b_setval(StoreName,[]) ). delete_constraint_body(multi_store(StoreTypes),C,Head,Susp,VarDict,Body) :- maplist(delete_constraint_body1(C,Head,Susp,VarDict),StoreTypes,Bodies), list2conj(Bodies,Body). delete_constraint_body1(C,Head,Susp,VarDict,StoreType,Body) :- delete_constraint_body(StoreType,C,Head,Susp,VarDict,Body). delete_constraint_body(identifier_store(Index),C,Head,Susp,VarDict,Body) :- get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,Index,Variable,VariableGoal), get_identifier_size(ISize), functor(Struct,struct,ISize), get_identifier_index(C,Index,IIndex), arg(IIndex,Struct,Susps), Body = ( VariableGoal, Variable = Struct, 'chr sbag_del_element'(Susps,Susp,NSusps), setarg(IIndex,Variable,NSusps) ). delete_constraint_body(type_indexed_identifier_store(Index,IndexType),C,Head,Susp,VarDict,Body) :- get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,Index,Variable,VariableGoal), type_indexed_identifier_structure(IndexType,Struct), get_type_indexed_identifier_index(IndexType,C,Index,IIndex), arg(IIndex,Struct,Susps), Body = ( VariableGoal, Variable = Struct, 'chr sbag_del_element'(Susps,Susp,NSusps), setarg(IIndex,Variable,NSusps) ). generate_multi_inthash_delete_constraint_bodies([],_,_,true). generate_multi_inthash_delete_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :- multi_hash_store_name(FA,Index,StoreName), multi_hash_key(FA,Index,Susp,KeyBody,Key), Body = ( KeyBody, nb_getval(StoreName,Store), delete_iht(Store,Key,Susp) ), generate_multi_inthash_delete_constraint_bodies(Indexes,FA,Susp,Bodies). generate_multi_hash_delete_constraint_bodies([],_,_,_,_,true). generate_multi_hash_delete_constraint_bodies([Index|Indexes],C,Head,Susp,VarDict,(Body,Bodies)) :- multi_hash_store_name(C,Index,StoreName), multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key), make_get_store_goal(StoreName,Store,GetStoreGoal), ( chr_pp_flag(ht_removal,on) -> ht_prev_field(Index,PrevField), get_dynamic_suspension_term_field(PrevField,C,Susp,Prev,GetGoal), set_dynamic_suspension_term_field(PrevField,C,NextSusp,_, SetGoal1), set_dynamic_suspension_term_field(PrevField,C,NextSusp,Prev, SetGoal2), Body = ( GetGoal, ( var(Prev) -> GetStoreGoal, KeyBody, delete_first_ht(Store,Key,Values), ( Values = [NextSusp|_] -> SetGoal1 ; true ) ; Prev = [_,_|Values], setarg(2,Prev,Values), ( Values = [NextSusp|_] -> SetGoal2 ; true ) ) ) ; Body = ( KeyBody, GetStoreGoal, % nb_getval(StoreName,Store), delete_ht(Store,Key,Susp) ) ), generate_multi_hash_delete_constraint_bodies(Indexes,FA,Head,Susp,VarDict,Bodies). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- chr_constraint module_initializer/1, module_initializers/1. module_initializers(G), module_initializer(Initializer) <=> G = (Initializer,Initializers), module_initializers(Initializers). module_initializers(G) <=> G = true. % NOTE: Do not rename or the 'chr_initialization' predicate % without warning SSS generate_attach_code(Constraints,Clauses) :- enumerate_stores_code(Constraints,Enumerate), append(Enumerate,L,Clauses), generate_attach_code(Constraints,L,T), module_initializers(Initializers), prolog_global_variables_code(PrologGlobalVariables), T = [ ('$chr_initialization' :- Initializers), (:- initialization '$chr_initialization') | PrologGlobalVariables ]. generate_attach_code([],L,L). generate_attach_code([C|Cs],L,T) :- get_store_type(C,StoreType), generate_attach_code(StoreType,C,L,L1), generate_attach_code(Cs,L1,T). generate_attach_code(default,C,L,T) :- global_list_store_initialisation(C,L,T). generate_attach_code(multi_inthash(Indexes),C,L,T) :- multi_inthash_store_initialisations(Indexes,C,L,L1), multi_inthash_via_lookups(Indexes,C,L1,T). generate_attach_code(multi_hash(Indexes),C,L,T) :- multi_hash_store_initialisations(Indexes,C,L,L1), multi_hash_lookups(Indexes,C,L1,T). generate_attach_code(atomic_constants(Index,Constants,_),C,L,T) :- constants_initializers(C,Index,Constants), atomic_constants_code(C,Index,Constants,L,T). generate_attach_code(ground_constants(Index,Constants,_),C,L,T) :- constants_initializers(C,Index,Constants), ground_constants_code(C,Index,Constants,L,T). generate_attach_code(global_ground,C,L,T) :- global_ground_store_initialisation(C,L,T). generate_attach_code(var_assoc_store(_,_),_,L,L) :- use_auxiliary_module(chr_assoc_store). generate_attach_code(global_singleton,C,L,T) :- global_singleton_store_initialisation(C,L,T). generate_attach_code(multi_store(StoreTypes),C,L,T) :- multi_store_generate_attach_code(StoreTypes,C,L,T). generate_attach_code(identifier_store(Index),C,L,T) :- get_identifier_index(C,Index,IIndex), ( IIndex == 2 -> get_identifier_size(ISize), functor(Struct,struct,ISize), Struct =.. [_,Label|Stores], set_elems(Stores,[]), Clause1 = new_identifier(Label,Struct), functor(Struct2,struct,ISize), arg(1,Struct2,Label2), Clause2 = ( user:portray(Struct2) :- write('') ), functor(Struct3,struct,ISize), arg(1,Struct3,Label3), Clause3 = identifier_label(Struct3,Label3), L = [Clause1,Clause2,Clause3|T] ; L = T ). generate_attach_code(type_indexed_identifier_store(Index,IndexType),C,L,T) :- get_type_indexed_identifier_index(IndexType,C,Index,IIndex), ( IIndex == 2 -> identifier_store_initialization(IndexType,L,L1), %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% get_type_indexed_identifier_size(IndexType,ISize), %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% type_indexed_identifier_structure(IndexType,Struct), Struct =.. [_,Label|Stores], set_elems(Stores,[]), type_indexed_identifier_name(IndexType,new_identifier,Name1), Clause1 =.. [Name1,Label,Struct], %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% Goal1 =.. [Name1,Label1b,S1b], type_indexed_identifier_structure(IndexType,Struct1b), Struct1b =.. [_,Label1b|Stores1b], set_elems(Stores1b,[]), Expansion1 = (S1b = Struct1b), Clause1b = user:goal_expansion(Goal1,Expansion1), % writeln(Clause1-Clause1b), %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% type_indexed_identifier_structure(IndexType,Struct2), arg(1,Struct2,Label2), Clause2 = ( user:portray(Struct2) :- write('') ), %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% type_indexed_identifier_structure(IndexType,Struct3), arg(1,Struct3,Label3), type_indexed_identifier_name(IndexType,identifier_label,Name3), Clause3 =.. [Name3,Struct3,Label3], %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% Goal3b =.. [Name3,S3b,L3b], type_indexed_identifier_structure(IndexType,Struct3b), arg(1,Struct3b,L3b), Expansion3b = (S3b = Struct3b), Clause3b = ( user:goal_expansion(Goal3b,Expansion3b) :- writeln(expanding)), %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% identifier_store_name(IndexType,GlobalVariable), lookup_identifier_atom(IndexType,X,IX,LookupAtom), type_indexed_identifier_name(IndexType,new_identifier,NewIdentifierFunctor), NewIdentifierGoal =.. [NewIdentifierFunctor,X,IX], Clause4 = ( LookupAtom :- nb_getval(GlobalVariable,HT), ( lookup_ht(HT,X,[IX]) -> true ; NewIdentifierGoal, insert_ht(HT,X,IX) ) ), %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% lookup_only_identifier_atom(IndexType,Y,IY,LookupOnlyAtom), Clause5 = ( LookupOnlyAtom :- nb_getval(GlobalVariable,HT0), lookup_ht(HT0,Y,[IY]) ), %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% L1 = [(:- multifile goal_expansion/2),(:- dynamic goal_expansion/2),Clause1,Clause1b,Clause2,Clause3,Clause3b,Clause4,Clause5|T] ; L = T ). constants_initializers(C,Index,Constants) :- maplist(constant_initializer(C,Index),Constants). constant_initializer(C,Index,Constant) :- constants_store_name(C,Index,Constant,StoreName), prolog_global_variable(StoreName), module_initializer(nb_setval(StoreName,[])). lookup_identifier_atom(Key,X,IX,Atom) :- atom_concat('lookup_identifier_',Key,LookupFunctor), Atom =.. [LookupFunctor,X,IX]. lookup_only_identifier_atom(Key,X,IX,Atom) :- atom_concat('lookup_only_identifier_',Key,LookupFunctor), Atom =.. [LookupFunctor,X,IX]. identifier_label_atom(IndexType,IX,X,Atom) :- type_indexed_identifier_name(IndexType,identifier_label,Name), Atom =.. [Name,IX,X]. multi_store_generate_attach_code([],_,L,L). multi_store_generate_attach_code([ST|STs],C,L,T) :- generate_attach_code(ST,C,L,L1), multi_store_generate_attach_code(STs,C,L1,T). multi_inthash_store_initialisations([],_,L,L). multi_inthash_store_initialisations([Index|Indexes],FA,L,T) :- use_auxiliary_module(chr_integertable_store), multi_hash_store_name(FA,Index,StoreName), module_initializer((new_iht(HT),nb_setval(StoreName,HT))), % L = [(:- (chr_integertable_store:new_ht(HT),nb_setval(StoreName,HT)) )|L1], L1 = L, multi_inthash_store_initialisations(Indexes,FA,L1,T). multi_hash_store_initialisations([],_,L,L). multi_hash_store_initialisations([Index|Indexes],FA,L,T) :- use_auxiliary_module(chr_hashtable_store), multi_hash_store_name(FA,Index,StoreName), prolog_global_variable(StoreName), make_init_store_goal(StoreName,HT,InitStoreGoal), module_initializer((new_ht(HT),InitStoreGoal)), L1 = L, multi_hash_store_initialisations(Indexes,FA,L1,T). global_list_store_initialisation(C,L,T) :- ( is_stored(C) -> global_list_store_name(C,StoreName), prolog_global_variable(StoreName), make_init_store_goal(StoreName,[],InitStoreGoal), module_initializer(InitStoreGoal) ; true ), L = T. global_ground_store_initialisation(C,L,T) :- global_ground_store_name(C,StoreName), prolog_global_variable(StoreName), make_init_store_goal(StoreName,[],InitStoreGoal), module_initializer(InitStoreGoal), L = T. global_singleton_store_initialisation(C,L,T) :- global_singleton_store_name(C,StoreName), prolog_global_variable(StoreName), make_init_store_goal(StoreName,[],InitStoreGoal), module_initializer(InitStoreGoal), L = T. identifier_store_initialization(IndexType,L,T) :- use_auxiliary_module(chr_hashtable_store), identifier_store_name(IndexType,StoreName), prolog_global_variable(StoreName), make_init_store_goal(StoreName,HT,InitStoreGoal), module_initializer((new_ht(HT),InitStoreGoal)), L = T. multi_inthash_via_lookups([],_,L,L). multi_inthash_via_lookups([Index|Indexes],C,L,T) :- multi_hash_lookup_head(C,Index,Key,SuspsList,Head), multi_hash_lookup_body(C,inthash,Index,Key,SuspsList,Body), L = [(Head :- Body)|L1], multi_inthash_via_lookups(Indexes,C,L1,T). multi_hash_lookups([],_,L,L). multi_hash_lookups([Index|Indexes],C,L,T) :- multi_hash_lookup_head(C,Index,Key,SuspsList,Head), multi_hash_lookup_body(C,hash,Index,Key,SuspsList,Body), L = [(Head :- Body)|L1], multi_hash_lookups(Indexes,C,L1,T). multi_hash_lookup_head(ConstraintSymbol,Index,Key,SuspsList,Head) :- multi_hash_lookup_name(ConstraintSymbol,Index,Name), Head =.. [Name,Key,SuspsList]. %% multi_hash_lookup_body(+ConstraintSymbol,+HashType,+Index,+Key,+SuspsList,-Goal) is det. % % Returns goal that performs hash table lookup. multi_hash_lookup_body(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal) :- % INLINED: get_store_type(ConstraintSymbol,multi_store(Stores)), ( memberchk(atomic_constants(Index,Constants,_),Stores) -> ( ground(Key) -> constants_store_name(ConstraintSymbol,Index,Key,StoreName), Goal = nb_getval(StoreName,SuspsList) ; constants_store_index_name(ConstraintSymbol,Index,IndexName), Lookup =.. [IndexName,Key,StoreName], Goal = (Lookup, nb_getval(StoreName,SuspsList)) ) ; memberchk(ground_constants(Index,Constants,_),Stores) -> ( ground(Key) -> constants_store_name(ConstraintSymbol,Index,Key,StoreName), Goal = nb_getval(StoreName,SuspsList) ; constants_store_index_name(ConstraintSymbol,Index,IndexName), Lookup =.. [IndexName,Key,StoreName], Goal = (Lookup, nb_getval(StoreName,SuspsList)) ) ; memberchk(multi_hash([Index]),Stores) -> multi_hash_store_name(ConstraintSymbol,Index,StoreName), make_get_store_goal(StoreName,HT,GetStoreGoal), ( HashType == hash, specialized_hash_term_call(ConstraintSymbol,Index,Key,Hash,HashCall) -> Goal = ( GetStoreGoal, % nb_getval(StoreName,HT), HashCall, % term_hash(Key,Hash), lookup_ht1(HT,Hash,Key,SuspsList) ) ; lookup_hash_call(HashType,HT,Key,SuspsList,Lookup), Goal = ( GetStoreGoal, % nb_getval(StoreName,HT), Lookup ) ) ; HashType == inthash -> multi_hash_store_name(ConstraintSymbol,Index,StoreName), make_get_store_goal(StoreName,HT,GetStoreGoal), lookup_hash_call(HashType,HT,Key,SuspsList,Lookup), Goal = ( GetStoreGoal, % nb_getval(StoreName,HT), Lookup ) % ; % chr_error(internal,'Index ~w for constraint ~w does not exist!\n',[Index,ConstraintSymbol]) % find alternative index % -> SubIndex + RestIndex % -> SubKey + RestKeys % multi_hash_lookup_goal(ConstraintSymbol,HashType,SubIndex,SubKey,SuspsList,SubGoal), % instantiate rest goal? % Goal = (SubGoal,RestGoal) ). lookup_hash_call(hash,HT,Key,SuspsList,lookup_ht(HT,Key,SuspsList)). lookup_hash_call(inthash,HT,Key,SuspsList,lookup_iht(HT,Key,SuspsList)). specialized_hash_term_call(Constraint,Index,Key,Hash,Call) :- ( ground(Key) -> % This is based on a property of SWI-Prolog's % term_hash/2 predicate: % the hash value is stable over repeated invocations % of SWI-Prolog term_hash(Key,Hash), Call = true % ; Index = [IndexPos], % get_constraint_type(Constraint,ArgTypes), % nth1(IndexPos,ArgTypes,Type), % unalias_type(Type,NormalType), % memberchk_eq(NormalType,[int,natural]) -> % ( NormalType == int -> % Call = (Hash is abs(Key)) % ; % Hash = Key, % Call = true % ) % ; % nonvar(Key), % specialize_hash_term(Key,NewKey), % NewKey \== Key, % Call = hash_term(NewKey,Hash) ). % specialize_hash_term(Term,NewTerm) :- % ( ground(Term) -> % hash_term(Term,NewTerm) % ; var(Term) -> % NewTerm = Term % ; % Term =.. [F|Args], % maplist(specialize_hash_term,Args,NewArgs), % NewTerm =.. [F|NewArgs] % ). multi_hash_lookup_goal(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal) :- % format(' * lookup of ~w on ~w with ~w.\n',[ConstraintSymbol,Index,Key]), ( /* chr_pp_flag(experiment,off) -> true ; */ atomic(Key) -> actual_atomic_multi_hash_keys(ConstraintSymbol,Index,[Key]) ; ground(Key) -> actual_ground_multi_hash_keys(ConstraintSymbol,Index,[Key]) ; ( Index = [Pos], get_constraint_arg_type(ConstraintSymbol,Pos,Type), is_chr_constants_type(Type,_,_) -> true ; actual_non_ground_multi_hash_key(ConstraintSymbol,Index) ) ), delay_phase_end(validate_store_type_assumptions, multi_hash_lookup_body(ConstraintSymbol,HashType,Index,Key,SuspsList,Goal)). :- chr_constraint actual_atomic_multi_hash_keys/3. :- chr_option(mode,actual_atomic_multi_hash_keys(+,+,?)). :- chr_constraint actual_ground_multi_hash_keys/3. :- chr_option(mode,actual_ground_multi_hash_keys(+,+,?)). :- chr_constraint actual_non_ground_multi_hash_key/2. :- chr_option(mode,actual_non_ground_multi_hash_key(+,+)). /* actual_atomic_multi_hash_keys(C,Index,Keys) ==> format('Keys: ~w - ~w : ~w\n', [C,Index,Keys]). actual_ground_multi_hash_keys(C,Index,Keys) ==> format('Keys: ~w - ~w : ~w\n', [C,Index,Keys]). actual_non_ground_multi_hash_key(C,Index) ==> format('Keys: ~w - ~w : N/A\n', [C,Index]). */ actual_atomic_multi_hash_keys(C,Index,Keys1), actual_atomic_multi_hash_keys(C,Index,Keys2) <=> append(Keys1,Keys2,Keys0), sort(Keys0,Keys), actual_atomic_multi_hash_keys(C,Index,Keys). actual_ground_multi_hash_keys(C,Index,Keys1), actual_atomic_multi_hash_keys(C,Index,Keys2) <=> append(Keys1,Keys2,Keys0), sort(Keys0,Keys), actual_ground_multi_hash_keys(C,Index,Keys). actual_ground_multi_hash_keys(C,Index,Keys1), actual_ground_multi_hash_keys(C,Index,Keys2) <=> append(Keys1,Keys2,Keys0), sort(Keys0,Keys), actual_ground_multi_hash_keys(C,Index,Keys). actual_non_ground_multi_hash_key(C,Index) \ actual_non_ground_multi_hash_key(C,Index) <=> true. actual_non_ground_multi_hash_key(C,Index) \ actual_atomic_multi_hash_keys(C,Index,_) <=> true. actual_non_ground_multi_hash_key(C,Index) \ actual_ground_multi_hash_keys(C,Index,_) <=> true. %% multi_hash_lookup_name(+ConstraintSymbol,+Index,-Name) % % Returns predicate name of hash table lookup predicate. multi_hash_lookup_name(F/A,Index,Name) :- 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), atom_concat_list(Index,IndexName), atom_concat_list(['$chr_store_multi_hash_',Mod,'____',F,'___',A,'-',IndexName],Name). multi_hash_key(FA,Index,Susp,KeyBody,Key) :- ( Index = [I] -> get_dynamic_suspension_term_field(argument(I),FA,Susp,Key,KeyBody) ; maplist(get_dynamic_suspension_term_field1(FA,Susp),Index,Keys,Bodies), Key =.. [k|Keys], list2conj(Bodies,KeyBody) ). get_dynamic_suspension_term_field1(FA,Susp,I,KeyI,Goal) :- get_dynamic_suspension_term_field(argument(I),FA,Susp,KeyI,Goal). multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key) :- ( Index = [I] -> get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,I,Key,KeyBody) ; maplist(get_suspension_argument_possibly_in_scope(Head,VarDict,Susp),Index,Keys,Bodies), Key =.. [k|Keys], list2conj(Bodies,KeyBody) ). get_suspension_argument_possibly_in_scope(Head,VarDict,Susp,Index,Arg,Goal) :- arg(Index,Head,OriginalArg), ( ground(OriginalArg), OriginalArg = '$chr_identifier_match'(Value,KeyType) -> functor(Head,F,A), lookup_identifier_atom(KeyType,Value,Arg,Goal) ; term_variables(OriginalArg,OriginalVars), copy_term_nat(OriginalArg-OriginalVars,Arg-Vars), translate(OriginalVars,VarDict,Vars) -> Goal = true ; functor(Head,F,A), C = F/A, get_dynamic_suspension_term_field(argument(Index),C,Susp,Arg,Goal) ). multi_hash_key_direct(FA,Index,Susp,Key,UsedVars) :- ( Index = [I] -> UsedVars = [I-Key] ; pairup(Index,Keys,UsedVars), Key =.. [k|Keys] ). args(Index,Head,KeyArgs) :- maplist(arg1(Head),Index,KeyArgs). split_args(Indexes,Args,IArgs,NIArgs) :- split_args(Indexes,Args,1,IArgs,NIArgs). split_args([],Args,_,[],Args). split_args([I|Is],[Arg|Args],J,IArgs,NIArgs) :- NJ is J + 1, ( I == J -> IArgs = [Arg|Rest], split_args(Is,Args,NJ,Rest,NIArgs) ; NIArgs = [Arg|Rest], split_args([I|Is],Args,NJ,IArgs,Rest) ). %------------------------------------------------------------------------------- atomic_constants_code(C,Index,Constants,L,T) :- constants_store_index_name(C,Index,IndexName), maplist(atomic_constant_code(C,Index,IndexName),Constants,Clauses), append(Clauses,T,L). atomic_constant_code(C,Index,IndexName,Constant,Clause) :- constants_store_name(C,Index,Constant,StoreName), Clause =.. [IndexName,Constant,StoreName]. %------------------------------------------------------------------------------- ground_constants_code(C,Index,Terms,L,T) :- constants_store_index_name(C,Index,IndexName), maplist(constants_store_name(C,Index),Terms,StoreNames), length(Terms,N), replicate(N,[],More), trie_index([Terms|More],StoreNames,IndexName,L,T). constants_store_name(F/A,Index,Term,Name) :- get_target_module(Mod), term_to_atom(Term,Constant), term_to_atom(Index,IndexAtom), atom_concat_list(['$chr_store_constants_',Mod,'____',F,'___',A,'___',IndexAtom,'___',Constant],Name). constants_store_index_name(F/A,Index,Name) :- get_target_module(Mod), term_to_atom(Index,IndexAtom), atom_concat_list(['$chr_store_constants_',Mod,'____',F,'___',A,'___',IndexAtom],Name). % trie index code {{{ trie_index([Patterns|MorePatterns],Results,Prefix,Clauses,Tail) :- trie_step(Patterns,Prefix,Prefix,MorePatterns,Results,Clauses,Tail). trie_step([],_,_,[],[],L,L) :- !. % length MorePatterns == length Patterns == length Results trie_step(Patterns,Symbol,Prefix,MorePatterns,Results,Clauses,T) :- MorePatterns = [List|_], length(List,N), aggregate_all(set(F/A), ( member(Pattern,Patterns), functor(Pattern,F,A) ), FAs), N1 is N + 1, trie_step_cases(FAs,N1,Patterns,MorePatterns,Results,Symbol,Prefix,Clauses,T). trie_step_cases([],_,_,_,_,_,_,Clauses,Clauses). trie_step_cases([FA|FAs],N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses,Tail) :- trie_step_case(FA,N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses,Clauses1), trie_step_cases(FAs,N,Pattern,MorePatterns,Results,Symbol,Prefix,Clauses1,Tail). trie_step_case(F/A,N,Patterns,MorePatterns,Results,Symbol,Prefix,[Clause|List],Tail) :- Clause = (Head :- Body), /* Head = Symbol(IndexPattern,V2,...,Vn,Result) */ N1 is N + 1, functor(Head,Symbol,N1), arg(1,Head,IndexPattern), Head =.. [_,_|RestArgs], once(append(Vs,[Result],RestArgs)), /* IndexPattern = F() */ functor(IndexPattern,F,A), IndexPattern =.. [_|Args], append(Args,RestArgs,RecArgs), ( RecArgs == [Result] -> /* nothing more to match on */ List = Tail, Body = true, rec_cases(Patterns,_,Results,F/A,_,_,MoreResults), MoreResults = [Result] ; /* more things to match on */ rec_cases(Patterns,MorePatterns,Results,F/A,Cases,MoreCases,MoreResults), ( MoreCases = [OneMoreCase] -> /* only one more thing to match on */ List = Tail, Body = true, append([Cases,OneMoreCase,MoreResults],RecArgs) ; /* more than one thing to match on */ /* [ x1,..., xn] [xs1,...,xsn] */ pairup(Cases,MoreCases,CasePairs), common_pattern(CasePairs,CommonPatternPair,DiffVars,Differences), append(Args,Vs,[First|Rest]), First-Rest = CommonPatternPair, % Body = RSymbol(DiffVars,Result) fresh_symbol(Prefix,RSymbol), append(DiffVars,[Result],RecCallVars), Body =.. [RSymbol|RecCallVars], maplist(head_tail,Differences,CHs,CTs), trie_step(CHs,RSymbol,Prefix,CTs,MoreResults,List,Tail) ) ). :- chr_constraint symbol_count/2. :- chr_constraint fresh_symbol/2. symbol_count(Atom,N), fresh_symbol(Atom,Symbol) <=> atom_concat(Atom,N,Symbol), M is N + 1, symbol_count(Atom,M). fresh_symbol(Atom,Symbol) ==> symbol_count(Atom,0). head_tail([H|T],H,T). rec_cases([],[],[],_,[],[],[]). rec_cases([Pattern|Patterns],[MorePattern|MorePatterns],[Result|Results],F/A,Cases,MoreCases,MoreResults) :- ( functor(Pattern,F,A), Pattern =.. [_|ArgPatterns], append(ArgPatterns,MorePattern,[Case|MoreCase]) -> Cases = [Case|NCases], MoreCases = [MoreCase|NMoreCases], MoreResults = [Result|NMoreResults], rec_cases(Patterns,MorePatterns,Results,F/A,NCases,NMoreCases,NMoreResults) ; rec_cases(Patterns,MorePatterns,Results,F/A,Cases,MoreCases,MoreResults) ). % }}} %% common_pattern(+terms,-term,-vars,-differences) is det. common_pattern(Ts,T,Vars,Differences) :- fold1(chr_translate:gct,Ts,T), term_variables(T,Vars), findall(Vars,member(T,Ts),Differences). gct(T1,T2,T) :- gct_(T1,T2,T,[],_). gct_(T1,T2,T,Dict0,Dict) :- ( nonvar(T1), nonvar(T2), functor(T1,F1,A1), functor(T2,F2,A2), F1 == F2, A1 == A2 -> functor(T,F1,A1), T1 =.. [_|Args1], T2 =.. [_|Args2], T =.. [_|Args], maplist_dcg(chr_translate:gct_,Args1,Args2,Args,Dict0,Dict) ; /* T is a variable */ ( lookup_eq(Dict0,T1+T2,T) -> /* we already have a variable for this difference */ Dict = Dict0 ; /* T is a fresh variable */ Dict = [(T1+T2)-T|Dict0] ) ). %------------------------------------------------------------------------------- global_list_store_name(F/A,Name) :- get_target_module(Mod), atom_concat_list(['$chr_store_global_list_',Mod,'____',F,'___',A],Name). global_ground_store_name(F/A,Name) :- get_target_module(Mod), atom_concat_list(['$chr_store_global_ground_',Mod,'____',F,'___',A],Name). global_singleton_store_name(F/A,Name) :- get_target_module(Mod), atom_concat_list(['$chr_store_global_singleton_',Mod,'____',F,'___',A],Name). identifier_store_name(TypeName,Name) :- get_target_module(Mod), atom_concat_list(['$chr_identifier_lookup_',Mod,'____',TypeName],Name). :- chr_constraint prolog_global_variable/1. :- chr_option(mode,prolog_global_variable(+)). :- chr_constraint prolog_global_variables/1. :- chr_option(mode,prolog_global_variables(-)). prolog_global_variable(Name) \ prolog_global_variable(Name) <=> true. prolog_global_variables(List), prolog_global_variable(Name) <=> List = [Name|Tail], prolog_global_variables(Tail). prolog_global_variables(List) <=> List = []. :- if(current_predicate(user:exception/3)). %% prolog_global_variables_code(-Code) is det. % % Generate the code for initializating global variables lazily. % This is needed to lazily initialize CHR when called in a new % thread. % % If we are compiling into a temporary module we omit this as it % breaks the module isolation. As a consequence, only one thread % can operate on the temporary module, but that is usually the % case. Temporary modules are used by library(pengines). prolog_global_variables_code([]) :- tmp_module, !. prolog_global_variables_code(Code) :- prolog_global_variables(Names), ( Names == [] -> Code = [] ; maplist(wrap_in_functor('$chr_prolog_global_variable'), Names, NameDeclarations), Code = [ (:- dynamic user:exception/3), (:- multifile user:exception/3), (user:exception(undefined_global_variable, Name, retry) :- '$chr_prolog_global_variable'(Name), '$chr_initialization' ) | NameDeclarations ] ). tmp_module :- prolog_load_context(module, Module), module_property(Module, class(temporary)). :- else. prolog_global_variables_code([]). :- endif. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %sbag_member_call(S,L,sysh:mem(S,L)). sbag_member_call(S,L,member(S,L)). update_mutable_call(A,B,'chr update_mutable'( A, B)). %update_mutable_call(A,B,setarg(1, B, A)). create_mutable_call(Value,Mutable,true) :- Mutable = mutable(Value). % create_mutable_call(Value,Mutable,'chr create_mutable'(Value,Mutable)). % get_suspension_field(Constraint,Susp,FieldName,Value,(Get0,Get1)) :- % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0), % create_get_mutable(Value,Field,Get1). % % update_suspension_field(Constraint,Susp,FieldName,NewValue,(Get,Set)) :- % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get), % update_mutable_call(NewValue,Field,Set). % % get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,Get0,Get1,Set) :- % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0), % create_get_mutable_ref(Value,Field,Get1), % update_mutable_call(NewValue,Field,Set). % % create_static_suspension_field(Constraint,Susp,FieldName,Value,Create) :- % get_static_suspension_term_field(FieldName,Constraint,Susp,Field), % create_mutable_call(Value,Field,Create). % % get_static_suspension_field(Constraint,Susp,FieldName,Value,Get) :- % get_static_suspension_term_field(FieldName,Constraint,Susp,Field), % create_get_mutable(Value,Field,Get). % % get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,Get,Set) :- % get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Field), % create_get_mutable_ref(Value,Field,Get), % update_mutable_call(NewValue,Field,Set). get_suspension_field(Constraint,Susp,FieldName,Value,Get) :- get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get). update_suspension_field(Constraint,Susp,FieldName,NewValue,Set) :- set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set). get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,true,Get,Set) :- get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get), set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set). create_static_suspension_field(Constraint,Susp,FieldName,Value,true) :- get_static_suspension_term_field(FieldName,Constraint,Susp,Value). get_static_suspension_field(Constraint,Susp,FieldName,Value,true) :- get_static_suspension_term_field(FieldName,Constraint,Susp,Value). get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,true,Set) :- get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Value), set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% enumerate_stores_code(Constraints,[Clause|List]) :- Head = '$enumerate_constraints'(Constraint), Clause = ( Head :- Body), enumerate_store_bodies(Constraints,Constraint,List), ( List = [] -> Body = fail ; Body = ( nonvar(Constraint) -> functor(Constraint,Functor,_), '$enumerate_constraints'(Functor,Constraint) ; '$enumerate_constraints'(_,Constraint) ) ). enumerate_store_bodies([],_,[]). enumerate_store_bodies([C|Cs],Constraint,L) :- ( is_stored(C) -> get_store_type(C,StoreType), ( enumerate_store_body(StoreType,C,Suspension,SuspensionBody) -> true ; chr_error(internal,'Could not generate enumeration code for constraint ~w.\n',[C]) ), get_dynamic_suspension_term_field(arguments,C,Suspension,Arguments,DynamicGoal), C = F/_, Constraint0 =.. [F|Arguments], Head = '$enumerate_constraints'(F,Constraint), Body = (SuspensionBody, DynamicGoal, Constraint = Constraint0), L = [(Head :- Body)|T] ; L = T ), enumerate_store_bodies(Cs,Constraint,T). enumerate_store_body(default,C,Susp,Body) :- global_list_store_name(C,StoreName), sbag_member_call(Susp,List,Sbag), make_get_store_goal_no_error(StoreName,List,GetStoreGoal), Body = ( GetStoreGoal, % nb_getval(StoreName,List), Sbag ). % 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, % sbag_member_call(Susp,List,Sbag), % Body2 = % ( % arg(NIndex,Attr,List), % Sbag % ) % ; % sbag_member_call(Susp,Attr,Sbag), % Body2 = Sbag % ), % Body = (Body1,Body2). enumerate_store_body(multi_inthash([Index|_]),C,Susp,Body) :- multi_inthash_enumerate_store_body(Index,C,Susp,Body). enumerate_store_body(multi_hash([Index|_]),C,Susp,Body) :- multi_hash_enumerate_store_body(Index,C,Susp,Body). enumerate_store_body(atomic_constants(Index,Constants,Completeness),C,Susp,Body) :- Completeness == complete, % fail if incomplete maplist(enumerate_constant_store_body(C,Index,Susps),Constants,Disjuncts), list2disj(Disjuncts, Disjunction), Body = ( Disjunction, member(Susp,Susps) ). enumerate_constant_store_body(C,Index,Susps,Constant,nb_getval(StoreName,Susps)) :- constants_store_name(C,Index,Constant,StoreName). enumerate_store_body(ground_constants(Index,Constants,Completeness),C,Susp,Body) :- enumerate_store_body(atomic_constants(Index,Constants,Completeness),C,Susp,Body). enumerate_store_body(global_ground,C,Susp,Body) :- global_ground_store_name(C,StoreName), sbag_member_call(Susp,List,Sbag), make_get_store_goal(StoreName,List,GetStoreGoal), Body = ( GetStoreGoal, % nb_getval(StoreName,List), Sbag ). enumerate_store_body(var_assoc_store(_,_),C,_,Body) :- Body = fail. enumerate_store_body(global_singleton,C,Susp,Body) :- global_singleton_store_name(C,StoreName), make_get_store_goal(StoreName,Susp,GetStoreGoal), Body = ( GetStoreGoal, % nb_getval(StoreName,Susp), Susp \== [] ). enumerate_store_body(multi_store(STs),C,Susp,Body) :- ( memberchk(global_ground,STs) -> enumerate_store_body(global_ground,C,Susp,Body) ; once(( member(ST,STs), enumerate_store_body(ST,C,Susp,Body) )) ). enumerate_store_body(identifier_store(Index),C,Susp,Body) :- Body = fail. enumerate_store_body(type_indexed_identifier_store(Index,IndexType),C,Susp,Body) :- Body = fail. multi_inthash_enumerate_store_body(I,C,Susp,B) :- multi_hash_store_name(C,I,StoreName), B = ( nb_getval(StoreName,HT), value_iht(HT,Susp) ). 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) ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % BACKGROUND INFORMATION (declared using :- chr_declaration) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- chr_constraint background_info/1, background_info/2, get_bg_info/1, get_bg_info/2, get_bg_info_answer/1. background_info(X), background_info(Y) <=> append(X,Y,XY), background_info(XY). background_info(X) \ get_bg_info(Q) <=> Q=X. get_bg_info(Q) <=> Q = []. background_info(T,I), get_bg_info(A,Q) ==> copy_term_nat(T,T1), subsumes_term(T1,A) | copy_term_nat(T-I,A-X), get_bg_info_answer([X]). get_bg_info_answer(X), get_bg_info_answer(Y) <=> append(X,Y,XY), get_bg_info_answer(XY). get_bg_info_answer(X) # Id, get_bg_info(A,Q) <=> Q=X pragma passive(Id). get_bg_info(_,Q) <=> Q=[]. % no info found on this term %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- chr_constraint prev_guard_list/8, prev_guard_list/6, simplify_guards/1, set_all_passive/1. :- chr_option(mode,prev_guard_list(+,+,+,+,+,+,+,+)). :- chr_option(mode,prev_guard_list(+,+,+,+,+,+)). :- chr_option(type_declaration,prev_guard_list(any,any,any,any,any,list)). :- chr_option(mode,simplify_guards(+)). :- chr_option(mode,set_all_passive(+)). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % GUARD SIMPLIFICATION %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % If the negation of the guards of earlier rules entails (part of) % the current guard, the current guard can be simplified. We can only % use earlier rules with a head that matches if the head of the current % rule does, and which make it impossible for the current rule to match % if they fire (i.e. they shouldn't be propagation rules and their % head constraints must be subsets of those of the current rule). % At this point, we know for sure that the negation of the guard % of such a rule has to be true (otherwise the earlier rule would have % fired, because of the refined operational semantics), so we can use % that information to simplify the guard by replacing all entailed % conditions by true/0. As a consequence, the never-stored analysis % (in a further phase) will detect more cases of never-stored constraints. % % e.g. c(X),d(Y) <=> X > 0 | ... % e(X) <=> X < 0 | ... % c(X) \ d(Y),e(Z) <=> X =< 0, Z >= 0, ... | ... % \____________/ % true guard_simplification :- ( chr_pp_flag(guard_simplification,on) -> precompute_head_matchings, simplify_guards(1) ; true ). % for every rule, we create a prev_guard_list where the last argument % eventually is a list of the negations of earlier guards rule(RuleNb,Rule) \ simplify_guards(RuleNb) <=> Rule = pragma(rule(Head1,Head2,Guard,_B),ids(IDs1,IDs2),_Pragmas,_Name,RuleNb), append(Head1,Head2,Heads), make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings), tree_set_empty(Done), multiple_occ_constraints_checked(Done), apply_guard_wrt_term(Heads,Guard,SubstitutedHeads), append(IDs1,IDs2,IDs), findall(tuple(C,O,RuleNb)-(-RuleNb),(member(ID,IDs),get_occurrence_from_id(C,O,RuleNb,ID)),HeapData), empty_q(EmptyHeap), insert_list_q(HeapData,EmptyHeap,Heap), next_prev_rule(Heap,_,Heap1), next_prev_rule(Heap1,PrevRuleNb,NHeap), prev_guard_list(RuleNb,PrevRuleNb,NHeap,MatchingFreeHeads,Guard,[],Matchings,[SubstitutedHeads]), NextRule is RuleNb+1, simplify_guards(NextRule). next_prev_rule(Heap,RuleNb,NHeap) :- ( find_min_q(Heap,_-Priority) -> Priority = (-RuleNb), normalize_heap(Heap,Priority,NHeap) ; RuleNb = 0, NHeap = Heap ). normalize_heap(Heap,Priority,NHeap) :- ( find_min_q(Heap,_-Priority) -> delete_min_q(Heap,Heap1,tuple(C,O,_)-_), ( O > 1 -> NO is O -1, get_occurrence(C,NO,RuleNb,_), insert_q(Heap1,tuple(C,NO,RuleNb)-(-RuleNb),Heap2) ; Heap2 = Heap1 ), normalize_heap(Heap2,Priority,NHeap) ; NHeap = Heap ). % no more rule simplify_guards(_) <=> true. % The negation of the guard of a non-propagation rule is added % if its kept head constraints are a subset of the kept constraints of % the rule we're working on, and its removed head constraints (at least one) % are a subset of the removed constraints. rule(PrevRuleNb,PrevRule) \ prev_guard_list(RuleNb,PrevRuleNb,Heap,CurrentHeads,G,GuardList,Matchings,GH) <=> PrevRule = pragma(rule(H1,H2,PrevGuard,_B),_Ids,_Pragmas,_Name,_PrevRuleNb), % PrevRuleNb == _PrevRuleNb H1 \== [], make_head_matchings_explicit(PrevRuleNb,MatchingFreeHeads,PrevMatchings), setof(Renaming,chr_translate:head_subset(MatchingFreeHeads,CurrentHeads,Renaming),Renamings) | append(H1,H2,Heads), compute_derived_info(Renamings,PrevMatchings,MatchingFreeHeads,Heads,PrevGuard,Matchings,CurrentHeads,GH,DerivedInfo,GH_New1), append(GuardList,DerivedInfo,GL1), normalize_conj_list(GL1,GL), append(GH_New1,GH,GH1), normalize_conj_list(GH1,GH_New), next_prev_rule(Heap,PrevPrevRuleNb,NHeap), % PrevPrevRuleNb is PrevRuleNb-1, prev_guard_list(RuleNb,PrevPrevRuleNb,NHeap,CurrentHeads,G,GL,Matchings,GH_New). % if this isn't the case, we skip this one and try the next rule prev_guard_list(RuleNb,N,Heap,H,G,GuardList,M,GH) <=> ( N > 0 -> next_prev_rule(Heap,N1,NHeap), % N1 is N-1, prev_guard_list(RuleNb,N1,NHeap,H,G,GuardList,M,GH) ; prev_guard_list(RuleNb,H,G,GuardList,M,GH) ). prev_guard_list(RuleNb,H,G,GuardList,M,GH) <=> GH \== [] | head_types_modes_condition(GH,H,TypeInfo), conj2list(TypeInfo,TI), term_variables(H,HeadVars), append([chr_pp_headvariables(HeadVars)|TI],GuardList,Info), normalize_conj_list(Info,InfoL), append(H,InfoL,RelevantTerms), add_background_info([G|RelevantTerms],BGInfo), append(InfoL,BGInfo,AllInfo_), normalize_conj_list(AllInfo_,AllInfo), prev_guard_list(RuleNb,H,G,AllInfo,M,[]). head_types_modes_condition([],H,true). head_types_modes_condition([GH|GHs],H,(TI1, TI2)) :- types_modes_condition(H,GH,TI1), head_types_modes_condition(GHs,H,TI2). add_background_info(Term,Info) :- get_bg_info(GeneralInfo), add_background_info2(Term,TermInfo), append(GeneralInfo,TermInfo,Info). add_background_info2(X,[]) :- var(X), !. add_background_info2([],[]) :- !. add_background_info2([X|Xs],Info) :- !, add_background_info2(X,Info1), add_background_info2(Xs,Infos), append(Info1,Infos,Info). add_background_info2(X,Info) :- (functor(X,_,A), A>0 -> X =.. [_|XArgs], add_background_info2(XArgs,XArgInfo) ; XArgInfo = [] ), get_bg_info(X,XInfo), append(XInfo,XArgInfo,Info). %% % when all earlier guards are added or skipped, we simplify the guard. % if it's different from the original one, we change the rule prev_guard_list(RuleNb,H,G,GuardList,M,[]), rule(RuleNb,Rule) <=> Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb), G \== true, % let's not try to simplify this ;) append(M,GuardList,Info), (% if guard + context is a contradiction, it should be simplified to "fail" conj2list(G,GL), append(Info,GL,GuardWithContext), guard_entailment:entails_guard(GuardWithContext,fail) -> SimpleGuard = fail ; % otherwise we try to remove redundant conjuncts simplify_guard(G,B,Info,SimpleGuard,NB) ), G \== SimpleGuard % only do this if we can change the guard | rule(RuleNb,pragma(rule(Head1,Head2,SimpleGuard,NB),Ids,Pragmas,Name,RuleNb)), prev_guard_list(RuleNb,H,SimpleGuard,GuardList,M,[]). %% normalize_conj_list(+List,-NormalList) is det. % % Removes =true= elements and flattens out conjunctions. normalize_conj_list(List,NormalList) :- list2conj(List,Conj), conj2list(Conj,NormalList). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % AUXILIARY PREDICATES (GUARD SIMPLIFICATION) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% compute_derived_info([],_PrevMatchings,_MatchingFreeHeads,_Heads,_PrevGuard,_Matchings,_H,_GH,[],[]). compute_derived_info([Renaming1|RestRenamings],PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,[DerivedInfo1|DerivedInfo2],[GH3|GH_New2]) :- copy_term(PrevMatchings-PrevGuard,FreshMatchings), variable_replacement(PrevMatchings-PrevGuard,FreshMatchings,ExtraRenaming), append(Renaming1,ExtraRenaming,Renaming2), list2conj(PrevMatchings,Match), negate_b(Match,HeadsDontMatch), make_head_matchings_explicit_not_negated2(PrevHeads,PrevMatchingFreeHeads,HeadsMatch), list2conj(HeadsMatch,HeadsMatchBut), term_variables(Renaming2,RenVars), term_variables(PrevMatchings-PrevGuard-HeadsMatch,MGVars), new_vars(MGVars,RenVars,ExtraRenaming2), append(Renaming2,ExtraRenaming2,Renaming), ( PrevGuard == true -> % true can't fail Info_ = HeadsDontMatch ; negate_b(PrevGuard,TheGuardFailed), Info_ = (HeadsDontMatch ; (HeadsMatchBut, TheGuardFailed)) ), copy_with_variable_replacement(Info_,DerivedInfo1,Renaming), copy_with_variable_replacement(PrevGuard,RenamedG2,Renaming), copy_with_variable_replacement(PrevMatchings,RenamedMatchings_,Renaming), list2conj(RenamedMatchings_,RenamedMatchings), apply_guard_wrt_term(H,RenamedG2,GH2), apply_guard_wrt_term(GH2,RenamedMatchings,GH3), compute_derived_info(RestRenamings,PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,DerivedInfo2,GH_New2). simplify_guard(G,B,Info,SG,NB) :- conj2list(G,LG), % writeq(guard_entailment:simplify_guards(Info,B,LG,SGL,NB)),nl, guard_entailment:simplify_guards(Info,B,LG,SGL,NB), list2conj(SGL,SG). new_vars([],_,[]). new_vars([A|As],RV,ER) :- ( memberchk_eq(A,RV) -> new_vars(As,RV,ER) ; ER = [A-NewA,NewA-A|ER2], new_vars(As,RV,ER2) ). %% head_subset(+Subset,+MultiSet,-Renaming) is nondet. % % check if a list of constraints is a subset of another list of constraints % (multiset-subset), meanwhile computing a variable renaming to convert % one into the other. head_subset(H,Head,Renaming) :- head_subset(H,Head,Renaming,[],_). head_subset([],Remainder,Renaming,Renaming,Remainder). head_subset([X|Xs],MultiSet,Renaming,Acc,Remainder) :- head_member(MultiSet,X,NAcc,Acc,Remainder1), head_subset(Xs,Remainder1,Renaming,NAcc,Remainder). % check if A is in the list, remove it from Headleft head_member([X|Xs],A,Renaming,Acc,Remainder) :- ( variable_replacement(A,X,Acc,Renaming), Remainder = Xs ; Remainder = [X|RRemainder], head_member(Xs,A,Renaming,Acc,RRemainder) ). %-------------------------------------------------------------------------------% % memoing code to speed up repeated computation :- chr_constraint precompute_head_matchings/0. rule(RuleNb,PragmaRule), precompute_head_matchings ==> PragmaRule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,_PrevRuleNb), append(H1,H2,Heads), make_head_matchings_explicit_(Heads,MatchingFreeHeads,Matchings), copy_term_nat(MatchingFreeHeads-Matchings,A-B), make_head_matchings_explicit_memo_table(RuleNb,A,B). precompute_head_matchings <=> true. :- chr_constraint make_head_matchings_explicit_memo_table/3. :- chr_constraint make_head_matchings_explicit_memo_lookup/3. :- chr_option(mode,make_head_matchings_explicit_memo_table(+,?,?)). :- chr_option(mode,make_head_matchings_explicit_memo_lookup(+,?,?)). make_head_matchings_explicit_memo_table(RuleNb,NHeads,Matchings) \ make_head_matchings_explicit_memo_lookup(RuleNb,Q1,Q2) <=> Q1 = NHeads, Q2 = Matchings. make_head_matchings_explicit_memo_lookup(_,_,_) <=> fail. make_head_matchings_explicit(RuleNb,MatchingFreeHeads,Matchings) :- make_head_matchings_explicit_memo_lookup(RuleNb,A,B), copy_term_nat(A-B,MatchingFreeHeads-Matchings). %-------------------------------------------------------------------------------% make_head_matchings_explicit_(Heads,MatchingFreeHeads,Matchings) :- extract_arguments(Heads,Arguments), make_matchings_explicit(Arguments,FreeVariables,[],[],_,Matchings), substitute_arguments(Heads,FreeVariables,MatchingFreeHeads). make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings) :- extract_arguments(Heads,Arguments), make_matchings_explicit_not_negated(Arguments,FreshVariables,Matchings), substitute_arguments(Heads,FreshVariables,MatchingFreeHeads). make_head_matchings_explicit_not_negated2(Heads,MatchingFreeHeads,Matchings) :- extract_arguments(Heads,Arguments1), extract_arguments(MatchingFreeHeads,Arguments2), make_matchings_explicit_not_negated(Arguments1,Arguments2,Matchings). %% extract_arguments(+ListOfConstraints,-ListOfVariables) is det. % % Returns list of arguments of given list of constraints. extract_arguments([],[]). extract_arguments([Constraint|Constraints],AllArguments) :- Constraint =.. [_|Arguments], append(Arguments,RestArguments,AllArguments), extract_arguments(Constraints,RestArguments). %% substitute_arguments(+InListOfConstraints,ListOfVariables,-OutListOfConstraints) is det. % % Substitutes arguments of constraints with those in the given list. substitute_arguments([],[],[]). substitute_arguments([Constraint|Constraints],Variables,[NConstraint|NConstraints]) :- functor(Constraint,F,N), split_at(N,Variables,Arguments,RestVariables), NConstraint =.. [F|Arguments], substitute_arguments(Constraints,RestVariables,NConstraints). make_matchings_explicit([],[],_,MC,MC,[]). make_matchings_explicit([Arg|Args],[NewVar|NewVars],VarAcc,MatchingCondition,MatchingConditionO,Matchings) :- ( var(Arg) -> ( memberchk_eq(Arg,VarAcc) -> list2disj(MatchingCondition,MatchingCondition_disj), Matchings = [(MatchingCondition_disj ; NewVar == Arg)|RestMatchings], % or only = ?? NVarAcc = VarAcc ; Matchings = RestMatchings, NewVar = Arg, NVarAcc = [Arg|VarAcc] ), MatchingCondition2 = MatchingCondition ; functor(Arg,F,A), Arg =.. [F|RecArgs], make_matchings_explicit(RecArgs,RecVars,VarAcc,MatchingCondition,MatchingCondition_,RecMatchings), FlatArg =.. [F|RecVars], ( RecMatchings == [] -> Matchings = [functor(NewVar,F,A)|RestMatchings] ; list2conj(RecMatchings,ArgM_conj), list2disj(MatchingCondition,MatchingCondition_disj), ArgM_ = (NewVar \= FlatArg ; MatchingCondition_disj ; ArgM_conj), Matchings = [ functor(NewVar,F,A) , ArgM_|RestMatchings] ), MatchingCondition2 = [ NewVar \= FlatArg |MatchingCondition_], term_variables(Args,ArgVars), append(ArgVars,VarAcc,NVarAcc) ), make_matchings_explicit(Args,NewVars,NVarAcc,MatchingCondition2,MatchingConditionO,RestMatchings). %% make_matchings_explicit_not_negated(+ListOfTerms,-ListOfVariables,-ListOfMatchings) is det. % % Returns list of new variables and list of pairwise unifications between given list and variables. make_matchings_explicit_not_negated([],[],[]). make_matchings_explicit_not_negated([X|Xs],[Var|Vars],Matchings) :- Matchings = [Var = X|RMatchings], make_matchings_explicit_not_negated(Xs,Vars,RMatchings). %% apply_guard_wrt_term(+ListOfConstraints,+Goal,-NewListOfConstraints) is det. % % (Partially) applies substitutions of =Goal= to given list. apply_guard_wrt_term([],_Guard,[]). apply_guard_wrt_term([Term|RH],Guard,[NTerm|RGH]) :- ( var(Term) -> apply_guard_wrt_variable(Guard,Term,NTerm) ; Term =.. [F|HArgs], apply_guard_wrt_term(HArgs,Guard,NewHArgs), NTerm =.. [F|NewHArgs] ), apply_guard_wrt_term(RH,Guard,RGH). %% apply_guard_wrt_variable(+Goal,+Variable,-NVariable) is det. % % (Partially) applies goal =Guard= wrt variable. apply_guard_wrt_variable((Guard1,Guard2),Variable,NVariable) :- !, apply_guard_wrt_variable(Guard1,Variable,NVariable1), apply_guard_wrt_variable(Guard2,NVariable1,NVariable). apply_guard_wrt_variable(Guard,Variable,NVariable) :- ( Guard = (X = Y), Variable == X -> NVariable = Y ; Guard = functor(AVariable,Functor,Arity), Variable == AVariable, ground(Functor), ground(Arity) -> functor(NVariable,Functor,Arity) ; NVariable = Variable ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % ALWAYS FAILING GUARDS %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% prev_guard_list(RuleNb,H,G,GuardList,M,[]),rule(RuleNb,Rule) ==> chr_pp_flag(check_impossible_rules,on), Rule = pragma(rule(_,_,G,_),_Ids,_Pragmas,_Name,RuleNb), conj2list(G,GL), append(M,GuardList,Info), append(Info,GL,GuardWithContext), guard_entailment:entails_guard(GuardWithContext,fail) | chr_warning(weird_program,'Heads will never match or guard will always fail in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]), set_all_passive(RuleNb). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % HEAD SIMPLIFICATION %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % now we check the head matchings (guard may have been simplified meanwhile) prev_guard_list(RuleNb,H,G,GuardList,M,[]) \ rule(RuleNb,Rule) <=> Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb), simplify_heads(M,GuardList,G,B,NewM,NewB), NewM \== [], extract_arguments(Head1,VH1), extract_arguments(Head2,VH2), extract_arguments(H,VH), replace_some_heads(VH1,VH2,VH,NewM,H1,H2,G,B,NewB_), substitute_arguments(Head1,H1,NewH1), substitute_arguments(Head2,H2,NewH2), append(NewB,NewB_,NewBody), list2conj(NewBody,BodyMatchings), NewRule = pragma(rule(NewH1,NewH2,G,(BodyMatchings,B)),Ids,Pragmas,Name,RuleNb), (Head1 \== NewH1 ; Head2 \== NewH2 ) | rule(RuleNb,NewRule). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % AUXILIARY PREDICATES (HEAD SIMPLIFICATION) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% replace_some_heads(H1,H2,NH,[],H1,H2,G,Body,[]) :- !. replace_some_heads([],[H2|RH2],[NH|RNH],[M|RM],[],[H2_|RH2_],G,Body,NewB) :- !, ( NH == M -> H2_ = M, replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB) ; (M = functor(X,F,A), NH == X -> length(A_args,A), (var(H2) -> NewB1 = [], H2_ =.. [F|A_args] ; H2 =.. [F|OrigArgs], use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1), H2_ =.. [F|A_args_] ), replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB2), append(NewB1,NewB2,NewB) ; H2_ = H2, replace_some_heads([],RH2,RNH,[M|RM],[],RH2_,G,Body,NewB) ) ). replace_some_heads([H1|RH1],H2,[NH|RNH],[M|RM],[H1_|RH1_],H2_,G,Body,NewB) :- !, ( NH == M -> H1_ = M, replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB) ; (M = functor(X,F,A), NH == X -> length(A_args,A), (var(H1) -> NewB1 = [], H1_ =.. [F|A_args] ; H1 =.. [F|OrigArgs], use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1), H1_ =.. [F|A_args_] ), replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB2), append(NewB1,NewB2,NewB) ; H1_ = H1, replace_some_heads(RH1,H2,RNH,[M|RM],RH1_,H2_,G,Body,NewB) ) ). use_same_args([],[],[],_,_,[]). use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :- var(OA),!, Out = OA, use_same_args(ROA,RNA,ROut,G,Body,NewB). use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :- nonvar(OA),!, ( common_variables(OA,Body) -> NewB = [NA = OA|NextB] ; NewB = NextB ), Out = NA, use_same_args(ROA,RNA,ROut,G,Body,NextB). simplify_heads([],_GuardList,_G,_Body,[],[]). simplify_heads([M|RM],GuardList,G,Body,NewM,NewB) :- M = (A = B), ( (nonvar(B) ; common_variables(B,RM-GuardList)), guard_entailment:entails_guard(GuardList,(A=B)) -> ( common_variables(B,G-RM-GuardList) -> NewB = NextB, NewM = NextM ; ( common_variables(B,Body) -> NewB = [A = B|NextB] ; NewB = NextB ), NewM = [A|NextM] ) ; ( nonvar(B), functor(B,BFu,BAr), guard_entailment:entails_guard([functor(A,BFu,BAr)|GuardList],(A=B)) -> NewB = NextB, ( common_variables(B,G-RM-GuardList) -> NewM = NextM ; NewM = [functor(A,BFu,BAr)|NextM] ) ; NewM = NextM, NewB = NextB ) ), simplify_heads(RM,[M|GuardList],G,Body,NextM,NextB). common_variables(B,G) :- term_variables(B,BVars), term_variables(G,GVars), intersect_eq(BVars,GVars,L), L \== []. set_all_passive(RuleNb), occurrence(_,_,RuleNb,ID,_) ==> passive(RuleNb,ID). set_all_passive(_) <=> true. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % OCCURRENCE SUBSUMPTION %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- chr_constraint first_occ_in_rule/4, next_occ_in_rule/6. :- chr_option(mode,first_occ_in_rule(+,+,+,+)). :- chr_option(mode,next_occ_in_rule(+,+,+,+,+,+)). :- chr_constraint multiple_occ_constraints_checked/1. :- chr_option(mode,multiple_occ_constraints_checked(+)). prev_guard_list(RuleNb,H,G,GuardList,M,[]), occurrence(C,O,RuleNb,ID,_), occurrence(C,O2,RuleNb,ID2,_), rule(RuleNb,Rule) \ multiple_occ_constraints_checked(Done) <=> O < O2, chr_pp_flag(occurrence_subsumption,on), Rule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,_RuleNb), % RuleNb == _RuleNb H1 \== [], \+ tree_set_memberchk(C,Done) | first_occ_in_rule(RuleNb,C,O,ID), tree_set_add(Done,C,NDone), multiple_occ_constraints_checked(NDone). % Find first occurrence of constraint =C= in rule =RuleNb= occurrence(C,O,RuleNb,ID,_) \ first_occ_in_rule(RuleNb,C,O2,_) <=> O < O2 | first_occ_in_rule(RuleNb,C,O,ID). first_occ_in_rule(RuleNb,C,O,ID_o1) <=> C = F/A, functor(FreshHead,F,A), next_occ_in_rule(RuleNb,C,O,ID_o1,[],FreshHead). % Skip passive occurrences. passive(RuleNb,ID_o2), occurrence(C,O2,RuleNb,ID_o2,_) \ next_occ_in_rule(RuleNb,C,O,ID_o1,Cond,FH) <=> O2 is O+1 | next_occ_in_rule(RuleNb,C,O2,ID_o1,NewCond,FH). prev_guard_list(RuleNb,H,G,GuardList,M,[]), occurrence(C,O2,RuleNb,ID_o2,_), rule(RuleNb,Rule) \ next_occ_in_rule(RuleNb,C,O,ID_o1,Cond,FH) <=> O2 is O+1, Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb) | append(H1,H2,Heads), add_failing_occ(Rule,Heads,H,ID_o1,ExtraCond,FH,M,C,Repl), ( ExtraCond == [chr_pp_void_info] -> next_occ_in_rule(RuleNb,C,O2,ID_o2,Cond,FH) ; append(ExtraCond,Cond,NewCond), add_failing_occ(Rule,Heads,H,ID_o2,CheckCond,FH,M,C,Repl2), copy_term(GuardList,FGuardList), variable_replacement(GuardList,FGuardList,GLRepl), copy_with_variable_replacement(GuardList,GuardList2,Repl), copy_with_variable_replacement(GuardList,GuardList3_,Repl2), copy_with_variable_replacement(GuardList3_,GuardList3,GLRepl), append(NewCond,GuardList2,BigCond), append(BigCond,GuardList3,BigCond2), copy_with_variable_replacement(M,M2,Repl), copy_with_variable_replacement(M,M3,Repl2), append(M3,BigCond2,BigCond3), append([chr_pp_active_constraint(FH)|M2],BigCond3,Info), list2conj(CheckCond,OccSubsum), copy_term((NewCond,BigCond2,Info,OccSubsum,FH),(NewCond2,BigCond2_,Info2,OccSubsum2,FH2)), ( OccSubsum \= chr_pp_void_info -> ( guard_entailment:entails_guard(Info2,OccSubsum2) -> passive(RuleNb,ID_o2) ; true ) ; true ),!, next_occ_in_rule(RuleNb,C,O2,ID_o2,NewCond,FH) ). next_occ_in_rule(RuleNb,C,O,ID,Cond,Args) <=> true. prev_guard_list(RuleNb,H,G,GuardList,M,[]), multiple_occ_constraints_checked(Done) <=> true. add_failing_occ(Rule,Heads,NH,ID_o1,FailCond,FH,M,C,Repl) :- Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb), append(ID2,ID1,IDs), missing_partner_cond(Heads,NH,IDs,ID_o1,MPCond,H,C), copy_term((H,Heads,NH),(FH2,FHeads,NH2)), variable_replacement((H,Heads,NH),(FH2,FHeads,NH2),Repl), copy_with_variable_replacement(G,FG,Repl), extract_explicit_matchings(FG,FG2), negate_b(FG2,NotFG), copy_with_variable_replacement(MPCond,FMPCond,Repl), ( subsumes_term(FH,FH2), FH=FH2 -> FailCond = [(NotFG;FMPCond)] ; % in this case, not much can be done % e.g. c(f(...)), c(g(...)) <=> ... FailCond = [chr_pp_void_info] ). missing_partner_cond([],[],[],ID_o1,fail,H2,C). missing_partner_cond([H|Hs],[H2|H2s],[ID_o1|IDs],ID_o1,Cond,H,C) :- !, missing_partner_cond(Hs,H2s,IDs,ID_o1,Cond,H,C). missing_partner_cond([H|Hs],[NH|NHs],[ID|IDs],ID_o1,Cond,H2,F/A) :- Cond = (chr_pp_not_in_store(H);Cond1), missing_partner_cond(Hs,NHs,IDs,ID_o1,Cond1,H2,F/A). extract_explicit_matchings((A,B),D) :- !, ( extract_explicit_matchings(A) -> extract_explicit_matchings(B,D) ; D = (A,E), extract_explicit_matchings(B,E) ). extract_explicit_matchings(A,D) :- !, ( extract_explicit_matchings(A) -> D = true ; D = A ). extract_explicit_matchings(A=B) :- var(A), var(B), !, A=B. extract_explicit_matchings(A==B) :- var(A), var(B), !, A=B. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % TYPE INFORMATION %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- chr_constraint type_definition/2, type_alias/2, constraint_type/2, get_type_definition/2, get_constraint_type/2. :- chr_option(mode,type_definition(?,?)). :- chr_option(mode,get_type_definition(?,?)). :- chr_option(mode,type_alias(?,?)). :- chr_option(mode,constraint_type(+,+)). :- chr_option(mode,get_constraint_type(+,-)). assert_constraint_type(Constraint,ArgTypes) :- ( ground(ArgTypes) -> constraint_type(Constraint,ArgTypes) ; chr_error(type_error,'Declared argument types "~w" for constraint "~w" must be ground!\n',[ArgTypes,Constraint]) ). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ % Consistency checks of type aliases type_alias(T1,T2) <=> var(T1) | chr_error(type_error,'Variable alias definition: "~w".\n',[(:- chr_type T1 == T2)]). type_alias(T1,T2) <=> var(T2) | chr_error(type_error,'Variable alias definition: "~w".\n',[(:- chr_type T1 == T2)]). type_alias(T,T2) <=> subsumes_term(T, T2) | chr_error(type_error,'Cyclic alias definition: "~w".\n',[(T == T2)]). type_alias(T1,A1), type_alias(T2,A2) <=> functor(T1,F,A), functor(T2,F,A), \+ (T1\=T2) | copy_term_nat(T1,T1_), copy_term_nat(T2,T2_), T1_ = T2_, chr_error(type_error, 'Ambiguous type aliases: you have defined \n\t`~w\'\n\t`~w\'\n\tresulting in two definitions for "~w".\n',[T1==A1,T2==A2,T1_]). type_alias(T,B) \ type_alias(X,T2) <=> functor(T,F,A), functor(T2,F,A), copy_term_nat((X,T2,T,B),(X2,T3,T1,D1)), subsumes_term(T1,T3) | % chr_info(type_information,'Inferring `~w\' from `~w\' and `~w\'.\n',[X2==D1,X==T2,T==B]), type_alias(X2,D1). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ % Consistency checks of type definitions type_definition(T1,_), type_definition(T2,_) <=> functor(T1,F,A), functor(T2,F,A) | chr_error(type_error,'Multiple definitions for type: ~w/~w.\n',[F,A]). type_definition(T1,_), type_alias(T2,_) <=> functor(T1,F,A), functor(T2,F,A) | chr_error(type_error,'Multiple definitions for type, once in a type definition and once as a type alias: ~w/~w.\n',[F,A]). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ %% get_type_definition(+Type,-Definition) is semidet. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ get_type_definition(T,Def) <=> \+ ground(T) | chr_error(type_error,'Non-ground type in constraint definition: "~w".\n',[T]). type_alias(T,D) \ get_type_definition(T2,Def) <=> nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A), copy_term_nat((T,D),(T1,D1)),T1=T2 | ( get_type_definition(D1,Def) -> true ; chr_error(type_error,'Could not find type definition for "~w" (accessed via alias "~w").\n',[D1,T1]), fail ). type_definition(T,D) \ get_type_definition(T2,Def) <=> nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A), copy_term_nat((T,D),(T1,D1)),T1=T2 | Def = D1. get_type_definition(Type,Def) <=> atomic_builtin_type(Type,_,_) | Def = [Type]. get_type_definition(Type,Def) <=> compound_builtin_type(Type,_,_,_) | Def = [Type]. get_type_definition(X,Y) <=> fail. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ %% get_type_definition_det(+Type,-Definition) is det. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ get_type_definition_det(Type,Definition) :- ( get_type_definition(Type,Definition) -> true ; chr_error(type,'Could not find type definition for type `~w\'.\n',[Type]) ). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% get_constraint_type(+ConstraintSymbol,-Types) is semidet. % % Return argument types of =ConstraintSymbol=, but fails if none where % declared. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% constraint_type(C,T) \ get_constraint_type(C,Type) <=> Type = T. get_constraint_type(_,_) <=> fail. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% get_constraint_type_det(+ConstraintSymbol,-Types) is det. % % Like =get_constraint_type/2=, but returns list of =any= types when % no types are declared. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% get_constraint_type_det(ConstraintSymbol,Types) :- ( get_constraint_type(ConstraintSymbol,Types) -> true ; ConstraintSymbol = _ / N, replicate(N,any,Types) ). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% unalias_type(+Alias,-Type) is det. % % Follows alias chain until base type is reached. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% :- chr_constraint unalias_type/2. unalias_var @ unalias_type(Alias,BaseType) <=> var(Alias) | BaseType = Alias. unalias_alias @ type_alias(AliasProtoType,ProtoType) \ unalias_type(Alias,BaseType) <=> nonvar(AliasProtoType), nonvar(Alias), functor(AliasProtoType,F,A), functor(Alias,F,A), copy_term_nat((AliasProtoType,ProtoType),(AliasInstance,Type)), Alias = AliasInstance | unalias_type(Type,BaseType). unalias_type_definition @ type_definition(ProtoType,Definition) \ unalias_type(Alias,BaseType) <=> nonvar(ProtoType), nonvar(Alias), functor(ProtoType,F,A), functor(Alias,F,A) | BaseType = Alias. unalias_atomic_builtin @ unalias_type(Alias,BaseType) <=> atomic_builtin_type(Alias,_,_) | BaseType = Alias. unalias_compound_builtin @ unalias_type(Alias,BaseType) <=> compound_builtin_type(Alias,_,_,_) | BaseType = Alias. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% types_modes_condition(+Heads,+UnrollHeads,-Condition) is det. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% :- chr_constraint types_modes_condition/3. :- chr_option(mode,types_modes_condition(+,+,?)). :- chr_option(type_declaration,types_modes_condition(list,list,goal)). types_modes_condition([],[],T) <=> T=true. constraint_mode(F/A,Modes) \ types_modes_condition([Head|Heads],[UnrollHead|UnrollHeads],Condition) <=> functor(Head,F,A) | Head =.. [_|Args], Condition = (ModesCondition, TypesCondition, RestCondition), modes_condition(Modes,Args,ModesCondition), get_constraint_type_det(F/A,Types), UnrollHead =.. [_|RealArgs], types_condition(Types,Args,RealArgs,Modes,TypesCondition), types_modes_condition(Heads,UnrollHeads,RestCondition). types_modes_condition([Head|_],_,_) <=> functor(Head,F,A), chr_error(internal,'Mode information missing for ~w.\n',[F/A]). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% modes_condition(+Modes,+Args,-Condition) is det. % % Return =Condition= on =Args= that checks =Modes=. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% modes_condition([],[],true). modes_condition([Mode|Modes],[Arg|Args],Condition) :- ( Mode == (+) -> Condition = ( ground(Arg) , RCondition ) ; Mode == (-) -> Condition = ( var(Arg) , RCondition ) ; Condition = RCondition ), modes_condition(Modes,Args,RCondition). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% types_condition(+Types,+Args,+UnrollArgs,+Modes,-Condition) is det. % % Return =Condition= on =Args= that checks =Types= given =Modes=. % =UnrollArgs= controls the depth of type definition unrolling. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% types_condition([],[],[],[],true). types_condition([Type|Types],[Arg|Args],[UnrollArg|UnrollArgs],[Mode|Modes],(DisjTypeConditionList,RCondition)) :- ( Mode == (-) -> TypeConditionList = [true] % TypeConditionList = [var(Arg)] already encoded in modes_condition ; get_type_definition_det(Type,Def), type_condition(Def,Arg,UnrollArg,Mode,TypeConditionList1), ( Mode == (+) -> TypeConditionList = TypeConditionList1 ; TypeConditionList = [(\+ ground(Arg))|TypeConditionList1] ) ), list2disj(TypeConditionList,DisjTypeConditionList), types_condition(Types,Args,UnrollArgs,Modes,RCondition). type_condition([],_,_,_,[]). type_condition([DefCase|DefCases],Arg,UnrollArg,Mode,[Condition|Conditions]) :- ( var(DefCase) -> chr_error(type,'Unexpected variable type in type definition!\n',[]) % Condition = true ; atomic_builtin_type(DefCase,Arg,Condition) -> true ; compound_builtin_type(DefCase,Arg,Condition,_) -> true ; type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition) ), type_condition(DefCases,Arg,UnrollArg,Mode,Conditions). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% :- chr_type atomic_builtin_type ---> any ; number ; float ; int ; natural ; dense_int ; chr_identifier ; chr_identifier(any) ; /* all possible values are given */ chr_enum(list(any)) ; /* all values of interest are given for the other values a handler is provided */ chr_enum(list(any),any) ; /* all possible values appear in rule heads; to distinguish between multiple chr_constants we have a key*/ chr_constants(any) ; /* all relevant values appear in rule heads; for other values a handler is provided */ chr_constants(any,any). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% ast_atomic_builtin_type(Type,AstTerm,Goal) :- ast_term_to_term(AstTerm,Term), atomic_builtin_type(Type,Term,Goal). ast_compound_builtin_type(Type,AstTerm,Goal) :- ast_term_to_term(AstTerm,Term), compound_builtin_type(Type,Term,_,Goal). atomic_builtin_type(any,_Arg,true). atomic_builtin_type(dense_int,Arg,(integer(Arg),Arg>=0)). atomic_builtin_type(int,Arg,integer(Arg)). atomic_builtin_type(number,Arg,number(Arg)). atomic_builtin_type(float,Arg,float(Arg)). atomic_builtin_type(natural,Arg,(integer(Arg),Arg>=0)). atomic_builtin_type(chr_identifier,_Arg,true). compound_builtin_type(chr_constants(_),_Arg,true,true). compound_builtin_type(chr_constants(_,_),_Arg,true,true). compound_builtin_type(chr_identifier(_),_Arg,true,true). compound_builtin_type(chr_enum(Constants),Arg,(ground(Arg), memberchk(Arg,Constants)), once(( member(Constant,Constants), unifiable(Arg,Constant,_) ) ) ). compound_builtin_type(chr_enum(_,_),Arg,true,true). is_chr_constants_type(chr_constants(Key),Key,no). is_chr_constants_type(chr_constants(Key,ErrorHandler),Key,yes(ErrorHandler)). is_chr_enum_type(chr_enum(Constants), Constants, no). is_chr_enum_type(chr_enum(Constants,Handler), Constants, yes(Handler)). type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition) :- ( nonvar(DefCase) -> functor(DefCase,F,A), ( A == 0 -> Condition = (Arg = DefCase) ; var(UnrollArg) -> Condition = functor(Arg,F,A) ; functor(UnrollArg,F,A) -> Condition = (functor(Arg,F,A),Arg=Template,ArgsCondition), DefCase =.. [_|ArgTypes], UnrollArg =.. [_|UnrollArgs], functor(Template,F,A), Template =.. [_|TemplateArgs], replicate(A,Mode,ArgModes), types_condition(ArgTypes,TemplateArgs,UnrollArgs,ArgModes,ArgsCondition) ; Condition = functor(Arg,F,A) ) ; chr_error(internal,'Illegal type definition (must be nonvar).\n',[]) ). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ % STATIC TYPE CHECKING %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ % Checks head constraints and CHR constraint calls in bodies. % % TODO: % - type clashes involving built-in types % - Prolog built-ins in guard and body % - indicate position in terms in error messages %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ :- chr_constraint static_type_check/2. % 1. Check the declared types constraint_type(Constraint,ArgTypes), static_type_check(_,_) ==> forall( ( member(ArgType,ArgTypes), sub_term(ArgType,Type) ), ( get_type_definition(Type,_) -> true ; chr_error(type_error,'Undefined type "~w" used in type declaration of "~w".\n',[Type,Constraint]) ) ). % 2. Check the rules :- chr_type type_error_src ---> head(any) ; body(any). static_type_check(PragmaRules,AstRules) <=> maplist(static_type_check_rule,PragmaRules,AstRules). static_type_check_rule(PragmaRule,AstRule) :- AstRule = ast_rule(AstHead,_AstGuard,_Guard,AstBody,_Body), ( catch( ( ast_static_type_check_head(AstHead), ast_static_type_check_body(AstBody) ), type_error(Error), ( Error = invalid_functor(Src,Term,Type) -> chr_error(type_error,'Invalid functor in ~@ of ~@:\n\t\tfound `~w\',\n\t\texpected type `~w\'!\n', [chr_translate:format_src(Src),format_rule(PragmaRule),Term,Type]) ; Error = type_clash(Var,Src1,Src2,Type1,Type2) -> chr_error(type_error,'Type clash for variable ~w in ~@:\n\t\texpected type ~w in ~@\n\t\texpected type ~w in ~@\n', [Var,format_rule(PragmaRule),Type1,chr_translate:format_src(Src1),Type2,chr_translate:format_src(Src2)]) ) ), fail % cleanup constraints ; true ). %------------------------------------------------------------------------------% % Static Type Checking: Head Constraints {{{ ast_static_type_check_head(simplification(AstConstraints)) :- maplist(ast_static_type_check_head_constraint,AstConstraints). ast_static_type_check_head(propagation(AstConstraints)) :- maplist(ast_static_type_check_head_constraint,AstConstraints). ast_static_type_check_head(simpagation(AstConstraints1,AstConstraints2)) :- maplist(ast_static_type_check_head_constraint,AstConstraints1), maplist(ast_static_type_check_head_constraint,AstConstraints2). ast_static_type_check_head_constraint(AstConstraint) :- AstConstraint = chr_constraint(Symbol,Arguments,_), get_constraint_type_det(Symbol,Types), maplist(ast_static_type_check_term(head(Head)),Arguments,Types). % }}} %------------------------------------------------------------------------------% % Static Type Checking: Terms {{{ :- chr_constraint ast_static_type_check_term/3. :- chr_option(mode,ast_static_type_check_term(?,?,?)). :- chr_option(type_declaration,ast_static_type_check_term(type_error_src,any,any)). ast_static_type_check_term(_,_,any) <=> true. ast_static_type_check_term(Src,var(Id,Var),Type) <=> ast_static_type_check_var(Id,var(Id,Var),Type,Src). ast_static_type_check_term(Src,Term,Type) <=> ast_atomic_builtin_type(Type,Term,Goal) | ( call(Goal) -> true ; throw(type_error(invalid_functor(Src,Term,Type))) ). ast_static_type_check_term(Src,Term,Type) <=> ast_compound_builtin_type(Type,Term,Goal) | ( call(Goal) -> true ; throw(type_error(invalid_functor(Src,Term,Type))) ). type_alias(AType,ADef) \ ast_static_type_check_term(Src,Term,Type) <=> functor(Type,F,A), functor(AType,F,A) | copy_term_nat(AType-ADef,Type-Def), ast_static_type_check_term(Src,Term,Def). type_definition(AType,ADef) \ ast_static_type_check_term(Src,Term,Type) <=> functor(Type,F,A), functor(AType,F,A) | copy_term_nat(AType-ADef,Type-Variants), ast_functor(Term,TF,TA), ( member(Variant,Variants), functor(Variant,TF,TA) -> ast_args(Term,Args), Variant =.. [_|Types], maplist(ast_static_type_check_term(Src),Args,Types) ; throw(type_error(invalid_functor(Src,Term,Type))) ). ast_static_type_check_term(Src,Term,Type) <=> chr_error(internal,'Undefined type ~w while type checking term ~w in ~@.\n',[Type,Term,chr_translate:format_src(Src)]). % }}} %------------------------------------------------------------------------------% % Static Type Checking: Variables {{{ :- chr_constraint ast_static_type_check_var/4. :- chr_option(mode,ast_static_type_check_var(+,?,?,?)). :- chr_option(type_declaration,ast_static_type_check_var(var_id,any,any,type_error_src)). type_alias(AType,ADef) \ ast_static_type_check_var(VarId,Var,Type,Src) <=> functor(AType,F,A), functor(Type,F,A) | copy_term_nat(AType-ADef,Type-Def), ast_static_type_check_var(VarId,Var,Def,Src). ast_static_type_check_var(VarId,Var,Type,Src) <=> atomic_builtin_type(Type,_,_) | ast_static_atomic_builtin_type_check_var(VarId,Var,Type,Src). ast_static_type_check_var(VarId,Var,Type,Src) <=> compound_builtin_type(Type,_,_,_) | true. ast_static_type_check_var(VarId,Var,Type1,Src1), ast_static_type_check_var(VarId,_Var,Type2,Src2) <=> Type1 \== Type2 | throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% :- chr_constraint ast_static_atomic_builtin_type_check_var/4. :- chr_option(mode,ast_static_atomic_builtin_type_check_var(+,?,+,?)). :- chr_option(type_declaration,ast_static_atomic_builtin_type_check_var(var_id,any,atomic_builtin_type,type_error_src)). ast_static_atomic_builtin_type_check_var(_,_,any,_) <=> true. ast_static_atomic_builtin_type_check_var(VarId,_,BuiltinType,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,BuiltinType,_) <=> true. ast_static_atomic_builtin_type_check_var(VarId,_,float,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,number,_) <=> true. ast_static_atomic_builtin_type_check_var(VarId,_,int,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,number,_) <=> true. ast_static_atomic_builtin_type_check_var(VarId,_,natural,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,number,_) <=> true. ast_static_atomic_builtin_type_check_var(VarId,_,dense_int,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,number,_) <=> true. ast_static_atomic_builtin_type_check_var(VarId,_,natural,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,int,_) <=> true. ast_static_atomic_builtin_type_check_var(VarId,_,dense_int,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,int,_) <=> true. ast_static_atomic_builtin_type_check_var(VarId,_,dense_int,_) \ ast_static_atomic_builtin_type_check_var(VarId,_,natural,_) <=> true. ast_static_atomic_builtin_type_check_var(VarId,Var,Type1,Src1), ast_static_atomic_builtin_type_check_var(VarId,_Var,Type2,Src2) <=> throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))). % }}} %------------------------------------------------------------------------------% % Static Type Checking: Bodies {{{ ast_static_type_check_body([]). ast_static_type_check_body([Goal|Goals]) :- ast_symbol(Goal,Symbol), get_constraint_type_det(Symbol,Types), ast_args(Goal,Args), maplist(ast_static_type_check_term(body(Goal)),Args,Types), ast_static_type_check_body(Goals). % }}} %------------------------------------------------------------------------------% %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% format_src(+type_error_src) is det. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% format_src(head(Head)) :- format('head ~w',[Head]). format_src(body(Goal)) :- format('body goal ~w',[Goal]). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ % Dynamic type checking %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ :- chr_constraint dynamic_type_check/0, dynamic_type_check_clauses/1, get_dynamic_type_check_clauses/1. generate_dynamic_type_check_clauses(Clauses) :- ( chr_pp_flag(debugable,on) -> dynamic_type_check, get_dynamic_type_check_clauses(Clauses0), append(Clauses0, [('$dynamic_type_check'(Type,Term) :- throw(error(type_error(Type,Term),context(_,'CHR Runtime Type Error'))) )], Clauses) ; Clauses = [] ). type_definition(T,D), dynamic_type_check ==> copy_term_nat(T-D,Type-Definition), maplist(dynamic_type_check_clause(Type),Definition,DynamicChecks), dynamic_type_check_clauses(DynamicChecks). type_alias(A,B), dynamic_type_check ==> copy_term_nat(A-B,Alias-Body), dynamic_type_check_alias_clause(Alias,Body,Clause), dynamic_type_check_clauses([Clause]). dynamic_type_check <=> findall( ('$dynamic_type_check'(Type,Term) :- Goal), ( atomic_builtin_type(Type,Term,Goal) ; compound_builtin_type(Type,Term,Goal,_) ), BuiltinChecks ), dynamic_type_check_clauses(BuiltinChecks). dynamic_type_check_clause(T,DC,Clause) :- copy_term(T-DC,Type-DefinitionClause), functor(DefinitionClause,F,A), functor(Term,F,A), DefinitionClause =.. [_|DCArgs], Term =.. [_|TermArgs], maplist(dynamic_type_check_call,DCArgs,TermArgs,RecursiveCallList), list2conj(RecursiveCallList,RecursiveCalls), Clause = ( '$dynamic_type_check'(Type,Term) :- RecursiveCalls ). dynamic_type_check_alias_clause(Alias,Body,Clause) :- Clause = ( '$dynamic_type_check'(Alias,Term) :- '$dynamic_type_check'(Body,Term) ). dynamic_type_check_call(Type,Term,Call) :- % ( nonvar(Type), atomic_builtin_type(Type,Term,Goal) -> % Call = when(nonvar(Term),Goal) % ; nonvar(Type), compound_builtin_type(Type,Term,Goal) -> % Call = when(nonvar(Term),Goal) % ; ( Type == any -> Call = true ; Call = when(nonvar(Term),once('$dynamic_type_check'(Type,Term))) ) % ) . dynamic_type_check_clauses(C1), dynamic_type_check_clauses(C2) <=> append(C1,C2,C), dynamic_type_check_clauses(C). get_dynamic_type_check_clauses(Q), dynamic_type_check_clauses(C) <=> Q = C. get_dynamic_type_check_clauses(Q) <=> Q = []. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ % Atomic Types %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ % Some optimizations can be applied for atomic types... %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ atomic_types_suspended_constraint(C) :- C = _/N, get_constraint_type(C,ArgTypes), get_constraint_mode(C,ArgModes), numlist(1,N,Indexes), maplist(atomic_types_suspended_constraint(C),ArgTypes,ArgModes,Indexes). atomic_types_suspended_constraint(C,Type,Mode,Index) :- ( is_indexed_argument(C,Index) -> ( Mode == (?) -> atomic_type(Type) ; true ) ; true ). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% atomic_type(+Type) is semidet. % % Succeeds when all values of =Type= are atomic. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% :- chr_constraint atomic_type/1. atomic_type(Type) <=> atomic_builtin_type(Type,_,_) | Type \== any. type_definition(TypePat,Def) \ atomic_type(Type) <=> functor(Type,F,A), functor(TypePat,F,A) | maplist(atomic,Def). type_alias(TypePat,Alias) \ atomic_type(Type) <=> functor(Type,F,A), functor(TypePat,F,A) | atomic(Alias), copy_term_nat(TypePat-Alias,Type-NType), atomic_type(NType). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% enumerated_atomic_type(+Type,-Atoms) is semidet. % % Succeeds when all values of =Type= are atomic % and the atom values are finitely enumerable. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% :- chr_constraint enumerated_atomic_type/2. enumerated_atomic_type(Type,_) <=> atomic_builtin_type(Type,_,_) | fail. type_definition(TypePat,Def) \ enumerated_atomic_type(Type,Atoms) <=> functor(Type,F,A), functor(TypePat,F,A) | maplist(atomic,Def), Atoms = Def. type_alias(TypePat,Alias) \ enumerated_atomic_type(Type,Atoms) <=> functor(Type,F,A), functor(TypePat,F,A) | atomic(Alias), copy_term_nat(TypePat-Alias,Type-NType), enumerated_atomic_type(NType,Atoms). enumerated_atomic_type(_,_) <=> fail. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- chr_constraint stored/3, % constraint,occurrence,(yes/no/maybe) stored_completing/3, stored_complete/3, is_stored/1, is_finally_stored/1, check_all_passive/2. :- chr_option(mode,stored(+,+,+)). :- chr_option(type_declaration,stored(any,int,storedinfo)). :- chr_type storedinfo ---> yes ; no ; maybe. :- chr_option(mode,stored_complete(+,+,+)). :- chr_option(mode,maybe_complementary_guards(+,+,?,?)). :- chr_option(mode,guard_list(+,+,+,+)). :- chr_option(mode,check_all_passive(+,+)). :- chr_option(type_declaration,check_all_passive(any,list)). % change yes in maybe when yes becomes passive passive(RuleNb,ID), occurrence(C,O,RuleNb,ID,_) \ stored(C,O,yes), stored_complete(C,RO,Yesses) <=> O < RO | NYesses is Yesses - 1, stored(C,O,maybe), stored_complete(C,RO,NYesses). % change yes in maybe when not observed ai_not_observed(C,O) \ stored(C,O,yes), stored_complete(C,RO,Yesses) <=> O < RO | NYesses is Yesses - 1, stored(C,O,maybe), stored_complete(C,RO,NYesses). occurrence(_,_,RuleNb,ID,_), occurrence(C2,_,RuleNb,_,_), stored_complete(C2,RO,0), max_occurrence(C2,MO2) ==> RO =< MO2 | % C2 is never stored passive(RuleNb,ID). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% rule(RuleNb,Rule),passive(RuleNb,Id) ==> Rule = pragma(rule(Head1,Head2,G,B),ids([Id|IDs1],IDs2),Pragmas,Name,RuleNb) | append(IDs1,IDs2,I), check_all_passive(RuleNb,I). rule(RuleNb,Rule),passive(RuleNb,Id) ==> Rule = pragma(rule(Head1,Head2,G,B),ids([],[Id|IDs2]),Pragmas,Name,RuleNb) | check_all_passive(RuleNb,IDs2). passive(RuleNb,Id) \ check_all_passive(RuleNb,[Id|IDs]) <=> check_all_passive(RuleNb,IDs). rule(RuleNb,Rule) \ check_all_passive(RuleNb,[]) <=> chr_warning(weird_program,'All heads passive in ~@.\n\tThis rule never fires. Please check your program.\n',[format_rule(Rule)]). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % collect the storage information stored(C,O,yes) \ stored_completing(C,O,Yesses) <=> NO is O + 1, NYesses is Yesses + 1, stored_completing(C,NO,NYesses). stored(C,O,maybe) \ stored_completing(C,O,Yesses) <=> NO is O + 1, stored_completing(C,NO,Yesses). stored(C,O,no) \ stored_completing(C,O,Yesses) <=> stored_complete(C,O,Yesses). stored_completing(C,O,Yesses) <=> stored_complete(C,O,Yesses). stored_complete(C,O,Yesses), occurrence(C,O2,RuleNb,Id,_) ==> O2 > O | passive(RuleNb,Id). % decide whether a constraint is stored max_occurrence(C,MO), stored_complete(C,RO,0) \ is_stored(C) <=> RO =< MO | fail. is_stored(C) <=> true. % decide whether a constraint is suspends after occurrences max_occurrence(C,MO), stored_complete(C,RO,_) \ is_finally_stored(C) <=> RO =< MO | fail. is_finally_stored(C) <=> true. storage_analysis(Constraints) :- ( chr_pp_flag(storage_analysis,on) -> check_constraint_storages(Constraints) ; true ). check_constraint_storages(Symbols) :- maplist(check_constraint_storage,Symbols). check_constraint_storage(C) :- get_max_occurrence(C,MO), check_occurrences_storage(C,1,MO). check_occurrences_storage(C,O,MO) :- ( O > MO -> stored_completing(C,1,0) ; check_occurrence_storage(C,O), NO is O + 1, check_occurrences_storage(C,NO,MO) ). check_occurrence_storage(C,O) :- get_occurrence(C,O,RuleNb,ID,OccType), ( is_passive(RuleNb,ID) -> stored(C,O,maybe) ; get_rule(RuleNb,PragmaRule), PragmaRule = pragma(rule(Heads1,Heads2,Guard,Body),ids(IDs1,IDs2),_,_,_), ( OccType == simplification, select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) -> check_storage_head1(Head1,O,Heads1,Heads2,Guard) ; OccType == propagation, select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) -> check_storage_head2(Head2,O,Heads1,Body) ) ). check_storage_head1(Head,O,H1,H2,G) :- functor(Head,F,A), C = F/A, ( H1 == [Head], H2 == [], % writeq(guard_entailment:entails_guard([chr_pp_headvariables(Head)],G)),nl, guard_entailment:entails_guard([chr_pp_headvariables(Head)],G), Head =.. [_|L], no_matching(L,[]) -> stored(C,O,no) ; stored(C,O,maybe) ). no_matching([],_). no_matching([X|Xs],Prev) :- var(X), \+ memberchk_eq(X,Prev), no_matching(Xs,[X|Prev]). check_storage_head2(Head,O,H1,B) :- functor(Head,F,A), C = F/A, ( %( ( H1 \== [], B == true ) %; % \+ is_observed(F/A,O) % always fails because observation analysis has not been performed yet %) -> stored(C,O,maybe) ; stored(C,O,yes) ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% ____ _ ____ _ _ _ _ %% | _ \ _ _| | ___ / ___|___ _ __ ___ _ __ (_) | __ _| |_(_) ___ _ __ %% | |_) | | | | |/ _ \ | | / _ \| '_ ` _ \| '_ \| | |/ _` | __| |/ _ \| '_ \ %% | _ <| |_| | | __/ | |__| (_) | | | | | | |_) | | | (_| | |_| | (_) | | | | %% |_| \_\\__,_|_|\___| \____\___/|_| |_| |_| .__/|_|_|\__,_|\__|_|\___/|_| |_| %% |_| constraints_code(Constraints,Clauses) :- (chr_pp_flag(reduced_indexing,on), forall(C,Constraints,chr_translate:only_ground_indexed_arguments(C)) -> none_suspended_on_variables ; true ), constraints_code1(Constraints,Clauses,[]). %=============================================================================== :- chr_constraint constraints_code1/3. :- chr_option(mode,constraints_code1(+,+,+)). :- chr_option(type_declaration,constraints_code1(list,any,any)). %------------------------------------------------------------------------------- constraints_code1([],L,T) <=> L = T. constraints_code1([C|RCs],L,T) <=> constraint_code(C,L,T1), constraints_code1(RCs,T1,T). %=============================================================================== :- chr_constraint constraint_code/3. :- chr_option(mode,constraint_code(+,+,+)). %------------------------------------------------------------------------------- %% Generate code for a single CHR constraint constraint_code(Constraint, L, T) <=> true | ( (chr_pp_flag(debugable,on) ; is_stored(Constraint), ( has_active_occurrence(Constraint); chr_pp_flag(late_allocation,off)), ( may_trigger(Constraint) ; get_allocation_occurrence(Constraint,AO), get_max_occurrence(Constraint,MO), MO >= AO ) ) -> constraint_prelude(Constraint,Clause), add_dummy_location(Clause,LocatedClause), L = [LocatedClause | L1] ; L = L1 ), Id = [0], occurrences_code(Constraint,1,Id,NId,L1,L2), gen_cond_attach_clause(Constraint,NId,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], make_suspension_continuation_goal(F/A,VarsSusp,Continuation), build_head(F,A,[0],VarsSusp,Delegate), ( chr_pp_flag(debugable,on) -> insert_constraint_goal(F/A,Susp,Vars,InsertCall), attach_constraint_atom(F/A,Vars2,Susp,AttachCall), delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)), insert_constraint_internal_constraint_goal(F/A, Vars2, Susp, Continuation, Vars,InsertGoal), ( get_constraint_type(F/A,ArgTypeList) -> maplist(dynamic_type_check_call,ArgTypeList,Vars,DynamicTypeCheckList), list2conj(DynamicTypeCheckList,DynamicTypeChecks) ; DynamicTypeChecks = true ), Clause = ( Head :- DynamicTypeChecks, InsertGoal, InsertCall, AttachCall, Inactive, 'chr debug_event'(insert(Head#Susp)), ( 'chr debugging' -> ( 'chr debug_event'(call(Susp)), Delegate ; 'chr debug_event'(fail(Susp)), !, fail ), ( 'chr debug_event'(exit(Susp)) ; 'chr debug_event'(redo(Susp)), fail ) ; Delegate ) ) ; get_allocation_occurrence(F/A,0) -> gen_insert_constraint_internal_goal(F/A,Goal,VarsSusp,Vars,Susp), delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)), Clause = ( Head :- Goal, Inactive, Delegate ) ; Clause = ( Head :- Delegate ) ). make_suspension_continuation_goal(F/A,VarsSusp,Goal) :- ( may_trigger(F/A) -> build_head(F,A,[0],VarsSusp,Delegate), ( chr_pp_flag(debugable,off) -> Goal = Delegate ; get_target_module(Mod), Goal = Mod:Delegate ) ; Goal = true ). %=============================================================================== :- chr_constraint has_active_occurrence/1, has_active_occurrence/2. :- chr_option(mode,has_active_occurrence(+)). :- chr_option(mode,has_active_occurrence(+,+)). :- chr_constraint memo_has_active_occurrence/1. :- chr_option(mode,memo_has_active_occurrence(+)). %------------------------------------------------------------------------------- memo_has_active_occurrence(C) \ has_active_occurrence(C) <=> true. has_active_occurrence(C) <=> has_active_occurrence(C,1), memo_has_active_occurrence(C). max_occurrence(C,MO) \ has_active_occurrence(C,O) <=> O > MO | fail. passive(RuleNb,ID),occurrence(C,O,RuleNb,ID,_) \ has_active_occurrence(C,O) <=> NO is O + 1, has_active_occurrence(C,NO). has_active_occurrence(C,O) <=> true. %=============================================================================== gen_cond_attach_clause(F/A,Id,L,T) :- ( is_finally_stored(F/A) -> get_allocation_occurrence(F/A,AllocationOccurrence), get_max_occurrence(F/A,MaxOccurrence), ( chr_pp_flag(debugable,off), MaxOccurrence < AllocationOccurrence -> ( only_ground_indexed_arguments(F/A) -> gen_insert_constraint_internal_goal(F/A,Body,AllArgs,Args,Susp) ; gen_cond_attach_goal(F/A,Body,AllArgs,Args,Susp) ) ; vars_susp(A,Args,Susp,AllArgs), gen_uncond_attach_goal(F/A,Susp,Args,Body,_) ), build_head(F,A,Id,AllArgs,Head), Clause = ( Head :- Body ), add_dummy_location(Clause,LocatedClause), L = [LocatedClause | T] ; L = T ). :- chr_constraint use_auxiliary_predicate/1. :- chr_option(mode,use_auxiliary_predicate(+)). :- chr_constraint use_auxiliary_predicate/2. :- chr_option(mode,use_auxiliary_predicate(+,+)). :- chr_constraint is_used_auxiliary_predicate/1. :- chr_option(mode,is_used_auxiliary_predicate(+)). :- chr_constraint is_used_auxiliary_predicate/2. :- chr_option(mode,is_used_auxiliary_predicate(+,+)). use_auxiliary_predicate(P) \ use_auxiliary_predicate(P) <=> true. use_auxiliary_predicate(P,C) \ use_auxiliary_predicate(P,C) <=> true. use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P) <=> true. use_auxiliary_predicate(P,_) \ is_used_auxiliary_predicate(P) <=> true. is_used_auxiliary_predicate(P) <=> fail. use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P,_) <=> true. use_auxiliary_predicate(P,C) \ is_used_auxiliary_predicate(P,C) <=> true. is_used_auxiliary_predicate(P,C) <=> fail. %------------------------------------------------------------------------------% % Only generate import statements for actually used modules. %------------------------------------------------------------------------------% :- chr_constraint use_auxiliary_module/1. :- chr_option(mode,use_auxiliary_module(+)). :- chr_constraint is_used_auxiliary_module/1. :- chr_option(mode,is_used_auxiliary_module(+)). use_auxiliary_module(P) \ use_auxiliary_module(P) <=> true. use_auxiliary_module(P) \ is_used_auxiliary_module(P) <=> true. is_used_auxiliary_module(P) <=> fail. % only called for constraints with % at least one % non-ground indexed argument gen_cond_attach_goal(F/A,Goal,AllArgs,Args,Susp) :- vars_susp(A,Args,Susp,AllArgs), make_suspension_continuation_goal(F/A,AllArgs,Closure), ( get_store_type(F/A,var_assoc_store(_,_)) -> Attach = true ; attach_constraint_atom(F/A,Vars,Susp,Attach) ), FTerm =.. [F|Args], insert_constraint_goal(F/A,Susp,Args,InsertCall), insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Closure, Args,InsertGoal), ( may_trigger(F/A) -> activate_constraint_goal(F/A,(InsertCall,Attach),Vars,Susp,_,ActivateGoal), Goal = ( ( var(Susp) -> InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args) InsertCall, Attach ; ActivateGoal % activate_constraint(Stored,Vars,Susp,_) ) ) ; Goal = ( InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args), InsertCall, Attach ) ). gen_insert_constraint_internal_goal(F/A,Goal,AllArgs,Args,Susp) :- vars_susp(A,Args,Susp,AllArgs), make_suspension_continuation_goal(F/A,AllArgs,Cont), ( \+ only_ground_indexed_arguments(F/A), \+ get_store_type(F/A,var_assoc_store(_,_)) -> attach_constraint_atom(F/A,Vars,Susp,Attach) ; Attach = true ), FTerm =.. [F|Args], insert_constraint_goal(F/A,Susp,Args,InsertCall), insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Cont, Args,InsertInternalGoal), ( only_ground_indexed_arguments(F/A), chr_pp_flag(debugable,off) -> Goal = ( InsertInternalGoal, % insert_constraint_internal(Susp,F,Args), InsertCall ) ; Goal = ( InsertInternalGoal, % insert_constraint_internal(_,Vars,Susp,Cont,F,Args), InsertCall, Attach ) ). gen_uncond_attach_goal(FA,Susp,Args,AttachGoal,Generation) :- ( \+ only_ground_indexed_arguments(FA), \+ get_store_type(FA,var_assoc_store(_,_)) -> attach_constraint_atom(FA,Vars,Susp,Attach) ; Attach = true ), insert_constraint_goal(FA,Susp,Args,InsertCall), ( chr_pp_flag(late_allocation,on) -> activate_constraint_goal(FA,(InsertCall,Attach),Vars,Susp,Generation,AttachGoal) ; activate_constraint_goal(FA,true,Vars,Susp,Generation,AttachGoal) ). %------------------------------------------------------------------------------- :- chr_constraint occurrences_code/6. :- chr_option(mode,occurrences_code(+,+,+,+,+,+)). %------------------------------------------------------------------------------- max_occurrence(C,MO) \ occurrences_code(C,O,Id,NId,L,T) <=> O > MO | NId = Id, L = T. occurrences_code(C,O,Id,NId,L,T) <=> occurrence_code(C,O,Id,Id1,L,L1), NO is O + 1, occurrences_code(C,NO,Id1,NId,L1,T). %------------------------------------------------------------------------------- :- chr_constraint occurrence_code/6. :- chr_option(mode,occurrence_code(+,+,+,+,+,+)). %------------------------------------------------------------------------------- occurrence(C,O,RuleNb,ID,_), passive(RuleNb,ID) \ occurrence_code(C,O,Id,NId,L,T) <=> ( named_history(RuleNb,_,_) -> does_use_history(C,O) ; true ), NId = Id, L = T. occurrence(C,O,RuleNb,ID,_), rule(RuleNb,PragmaRule) \ occurrence_code(C,O,Id,NId,L,T) <=> true | PragmaRule = pragma(rule(Heads1,Heads2,_,_),ids(IDs1,IDs2),_,_,_), ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) -> NId = Id, head1_code(Head1,ID,RHeads1,RIDs1,PragmaRule,C,O,Id,L,T) ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) -> head2_code(Head2,ID,RHeads2,RIDs2,PragmaRule,C,O,Id,L,L1), ( should_skip_to_next_id(C,O) -> inc_id(Id,NId), ( unconditional_occurrence(C,O) -> L1 = T ; gen_alloc_inc_clause(C,O,Id,L1,T) ) ; NId = Id, L1 = T ) ). occurrence_code(C,O,_,_,_,_) <=> chr_error(internal,'occurrence_code/6: missing information to compile ~w:~w\n',[C,O]). %------------------------------------------------------------------------------- %% Generate code based on one removed head of a CHR rule head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :- PragmaRule = pragma(Rule,_,_,_Name,RuleNb), Rule = rule(_,Head2,_,_), ( Head2 == [] -> reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs), simplification_code(Head,ID,NOtherHeads,NOtherIDs,PragmaRule,FA,O,Id,L,T) ; simpagation_head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) ). %% Generate code based on one persistent head of a CHR rule head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :- PragmaRule = pragma(Rule,_,_,_Name,RuleNb), Rule = rule(Head1,_,_,_), ( Head1 == [] -> reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs), propagation_code(Head,ID,NOtherHeads,NOtherIDs,Rule,RuleNb,FA,O,Id,L,T) ; simpagation_head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) ). gen_alloc_inc_clause(F/A,O,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_occ_allocation(F/A,O,Vars,Susp,ConditionalAlloc), Clause = ( Head :- ConditionalAlloc, CallHead ), add_dummy_location(Clause,LocatedClause), L = [LocatedClause|T]. gen_occ_allocation(FA,O,Vars,Susp,Goal) :- get_allocation_occurrence(FA,AO), get_occurrence_code_id(FA,AO,AId), get_occurrence_code_id(FA,O,Id), ( chr_pp_flag(debugable,off), Id == AId -> allocate_constraint_goal(FA,Susp,Vars,Goal0), ( may_trigger(FA) -> Goal = (var(Susp) -> Goal0 ; true) ; Goal = Goal0 ) ; Goal = true ). gen_occ_allocation_in_guard(FA,O,Vars,Susp,Goal) :- get_allocation_occurrence(FA,AO), ( chr_pp_flag(debugable,off), O < AO -> allocate_constraint_goal(FA,Susp,Vars,Goal0), ( may_trigger(FA) -> Goal = (var(Susp) -> Goal0 ; true) ; Goal = Goal0 ) ; Goal = true ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Reorders guard goals with respect to partner constraint retrieval goals and % active constraint. Returns combined partner retrieval + guard goal. guard_via_reschedule_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,GoalSkeleton) :- ( chr_pp_flag(guard_via_reschedule,on) -> guard_via_reschedule_main_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,ScheduleSkeleton), list2conj(ScheduleSkeleton,GoalSkeleton) ; length(Retrievals,RL), length(LookupSkeleton,RL), length(GuardList,GL), length(GuardListSkeleton,GL), append(LookupSkeleton,GuardListSkeleton,GoalListSkeleton), list2conj(GoalListSkeleton,GoalSkeleton) ). guard_via_reschedule_main_new(PartnerLookups,GuardList,ActiveHead, GuardListSkeleton,LookupSkeleton,ScheduleSkeleton) :- initialize_unit_dictionary(ActiveHead,Dict), maplist(wrap_in_functor(lookup),PartnerLookups,WrappedPartnerLookups), maplist(wrap_in_functor(guard),GuardList,WrappedGuardList), build_units(WrappedPartnerLookups,WrappedGuardList,Dict,Units), dependency_reorder(Units,NUnits), wrappedunits2lists(NUnits,IndexedGuardListSkeleton,LookupSkeleton,ScheduleSkeleton), sort(IndexedGuardListSkeleton,SortedIndexedGuardListSkeleton), snd_of_pairs(SortedIndexedGuardListSkeleton,GuardListSkeleton). wrappedunits2lists([],[],[],[]). wrappedunits2lists([unit(N,WrappedGoal,_,_)|Units],Gs,Ls,Ss) :- Ss = [GoalCopy|TSs], ( WrappedGoal = lookup(Goal) -> Ls = [GoalCopy|TLs], Gs = TGs ; WrappedGoal = guard(Goal) -> Gs = [N-GoalCopy|TGs], Ls = TLs ), wrappedunits2lists(Units,TGs,TLs,TSs). guard_splitting(Rule,SplitGuardList) :- Rule = rule(H1,H2,Guard,_), append(H1,H2,Heads), conj2list(Guard,GuardList), term_variables(Heads,HeadVars), split_off_simple_guard_new(GuardList,HeadVars,GuardPrefix,RestGuardList), append(GuardPrefix,[RestGuard],SplitGuardList), term_variables(RestGuardList,GuardVars1), % variables that are declared to be ground don't need to be locked ground_vars(Heads,GroundVars), list_difference_eq(HeadVars,GroundVars,LockableHeadVars), intersect_eq(LockableHeadVars,GuardVars1,GuardVars), maplist(chr_lock,GuardVars,Locks), maplist(chr_unlock,GuardVars,Unlocks), list2conj(Locks,LockPhase), list2conj(Unlocks,UnlockPhase), list2conj(RestGuardList,RestGuard1), RestGuard = (LockPhase,(RestGuard1,UnlockPhase)). guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy) :- Rule = rule(_,_,_,Body), my_term_copy(GuardList,VarDict,VarDict2,GuardCopyList), my_term_copy(Body,VarDict2,BodyCopy). split_off_simple_guard_new([],_,[],[]). split_off_simple_guard_new([G|Gs],VarDict,S,C) :- ( simple_guard_new(G,VarDict) -> S = [G|Ss], split_off_simple_guard_new(Gs,VarDict,Ss,C) ; S = [], C = [G|Gs] ). % simple guard: cheap and benign (does not bind variables) simple_guard_new(G,Vars) :- builtin_binds_b(G,BoundVars), not(( member(V,BoundVars), memberchk_eq(V,Vars) )). 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,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). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% ____ _ ____ _ _ %% / ___| ___| |_ / ___| ___ _ __ ___ __ _ _ __ | |_(_) ___ ___ _ %% \___ \ / _ \ __| \___ \ / _ \ '_ ` _ \ / _` | '_ \| __| |/ __/ __(_) %% ___) | __/ |_ ___) | __/ | | | | | (_| | | | | |_| | (__\__ \_ %% |____/ \___|\__| |____/ \___|_| |_| |_|\__,_|_| |_|\__|_|\___|___(_) %% %% _ _ _ ___ __ %% | | | |_ __ (_) __ _ _ _ ___ |_ _|_ __ / _| ___ _ __ ___ _ __ ___ ___ %% | | | | '_ \| |/ _` | | | |/ _ \ | || '_ \| |_ / _ \ '__/ _ \ '_ \ / __/ _ \ %% | |_| | | | | | (_| | |_| | __/ | || | | | _| __/ | | __/ | | | (_| __/ %% \___/|_| |_|_|\__, |\__,_|\___| |___|_| |_|_| \___|_| \___|_| |_|\___\___| %% |_| :- chr_constraint functional_dependency/4, get_functional_dependency/4. :- chr_option(mode,functional_dependency(+,+,?,?)). :- chr_option(mode,get_functional_dependency(+,+,?,?)). allocation_occurrence(C,AO), occurrence(C,O,RuleNb,_,_) \ functional_dependency(C,RuleNb,Pattern,Key) <=> RuleNb > 1, AO > O | functional_dependency(C,1,Pattern,Key). functional_dependency(C,RuleNb1,Pattern,Key) \ get_functional_dependency(C,RuleNb2,QPattern,QKey) <=> RuleNb2 >= RuleNb1 | QPattern = Pattern, QKey = Key. get_functional_dependency(_,_,_,_) <=> fail. functional_dependency_analysis(Rules) :- ( fail, chr_pp_flag(functional_dependency_analysis,on) -> functional_dependency_analysis_main(Rules) ; true ). functional_dependency_analysis_main([]). functional_dependency_analysis_main([PRule|PRules]) :- ( discover_unique_pattern(PRule,C,RuleNb,Pattern,Key) -> functional_dependency(C,RuleNb,Pattern,Key) ; true ), functional_dependency_analysis_main(PRules). discover_unique_pattern(PragmaRule,F/A,RuleNb,Pattern,Key) :- PragmaRule = pragma(Rule,_,_,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), \+ ( member(V1,Vs), lookup_eq(List,V1,V2), memberchk_eq(V2,Vs) ), select_pragma_unique_variables(Vs,List,Key1), copy_term_nat(C1-Key1,Pattern-Key), functor(C1,F,A). select_pragma_unique_variables([],_,[]). select_pragma_unique_variables([V|Vs],List,L) :- ( lookup_eq(List,V,_) -> L = T ; L = [V|T] ), select_pragma_unique_variables(Vs,List,T). % depends on functional dependency analysis % and shape of rule: C1 \ C2 <=> true. set_semantics_rules(Rules) :- ( fail, chr_pp_flag(set_semantics_rule,on) -> set_semantics_rules_main(Rules) ; true ). set_semantics_rules_main([]). set_semantics_rules_main([R|Rs]) :- set_semantics_rule_main(R), set_semantics_rules_main(Rs). set_semantics_rule_main(PragmaRule) :- PragmaRule = pragma(Rule,IDs,Pragmas,_,RuleNb), ( Rule = rule([C1],[C2],true,_), IDs = ids([ID1],[ID2]), \+ is_passive(RuleNb,ID1), functor(C1,F,A), get_functional_dependency(F/A,RuleNb,Pattern,Key), copy_term_nat(Pattern-Key,C1-Key1), copy_term_nat(Pattern-Key,C2-Key2), Key1 == Key2 -> passive(RuleNb,ID2) ; true ). 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)). % checks for rules of the shape ...,C1,C2... (<|=)=> ... % where C1 and C2 are symmteric constraints symmetry_analysis(Rules) :- ( chr_pp_flag(check_unnecessary_active,off) -> true ; symmetry_analysis_main(Rules) ). symmetry_analysis_main([]). symmetry_analysis_main([R|Rs]) :- R = pragma(Rule,ids(IDs1,IDs2),_,_,RuleNb), Rule = rule(H1,H2,_,_), ( ( \+ chr_pp_flag(check_unnecessary_active,simplification) ; H2 == [] ), H1 \== [] -> symmetry_analysis_heads_simplification(H1,IDs1,[],[],Rule,RuleNb), symmetry_analysis_heads_propagation(H2,IDs2,[],[],Rule,RuleNb) ; true ), symmetry_analysis_main(Rs). symmetry_analysis_heads_simplification([],[],_,_,_,_). symmetry_analysis_heads_simplification([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :- ( \+ is_passive(RuleNb,ID), member2(PreHs,PreIDs,PreH-PreID), \+ is_passive(RuleNb,PreID), variable_replacement(PreH,H,List), copy_with_variable_replacement(Rule,Rule2,List), identical_guarded_rules(Rule,Rule2) -> passive(RuleNb,ID) ; true ), symmetry_analysis_heads_simplification(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb). symmetry_analysis_heads_propagation([],[],_,_,_,_). symmetry_analysis_heads_propagation([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :- ( \+ is_passive(RuleNb,ID), member2(PreHs,PreIDs,PreH-PreID), \+ is_passive(RuleNb,PreID), variable_replacement(PreH,H,List), copy_with_variable_replacement(Rule,Rule2,List), identical_rules(Rule,Rule2) -> passive(RuleNb,ID) ; true ), symmetry_analysis_heads_propagation(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% ____ _ _ _ __ _ _ _ %% / ___|(_)_ __ ___ _ __ | (_)/ _(_) ___ __ _| |_(_) ___ _ __ %% \___ \| | '_ ` _ \| '_ \| | | |_| |/ __/ _` | __| |/ _ \| '_ \ %% ___) | | | | | | | |_) | | | _| | (_| (_| | |_| | (_) | | | | %% |____/|_|_| |_| |_| .__/|_|_|_| |_|\___\__,_|\__|_|\___/|_| |_| %% |_| %% {{{ simplification_code(Head,ID,RestHeads,RestIDs,PragmaRule,Symbol,O,Id,L,T) :- PragmaRule = pragma(Rule,_,Pragmas,_,RuleNb), head_info1(Head,Symbol,_Vars,Susp,HeadVars,HeadPairs), build_head(Symbol,Id,HeadVars,ClauseHead), get_constraint_mode(Symbol,Mode), head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars), guard_splitting(Rule,GuardList0), ( is_stored_in_guard(Symbol, RuleNb) -> GuardList = [Hole1|GuardList0] ; GuardList = GuardList0 ), guard_via_reschedule_new(RestHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest), rest_heads_retrieval_and_matching(RestHeads,RestIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_), guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy), ( is_stored_in_guard(Symbol, RuleNb) -> gen_occ_allocation_in_guard(Symbol,O,Vars,Susp,Allocation), gen_uncond_attach_goal(Symbol,Susp,Vars,Attachment,_), GuardCopyList = [Hole1Copy|_], Hole1Copy = (Allocation, Attachment) ; true ), partner_constraint_detachments(Susps,RestHeads,VarDict,SuspsDetachments), active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment), ( chr_pp_flag(debugable,on) -> Rule = rule(_,_,Guard,Body), my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody), sort_by_key([Susp|Susps],[ID|RestIDs],SortedSusps), DebugTry = 'chr debug_event'( try(SortedSusps,[],DebugGuard,DebugBody)), DebugApply = 'chr debug_event'(apply(SortedSusps,[],DebugGuard,DebugBody)), instrument_goal(ActualCut,DebugTry,DebugApply,Cut) ; Cut = ActualCut ), actual_cut(Symbol,O,ActualCut), Clause = ( ClauseHead :- FirstMatching, RescheduledTest, Cut, SuspsDetachments, SuspDetachment, BodyCopy ), add_location(Clause,RuleNb,LocatedClause), L = [LocatedClause | T]. actual_cut(Symbol,Occurrence,ActualCut) :- ( unconditional_occurrence(Symbol,Occurrence), chr_pp_flag(late_allocation,on) -> ActualCut = true ; ActualCut = (!) ). % }}} add_location(Clause,RuleNb,NClause) :- ( chr_pp_flag(line_numbers,on) -> get_line_number(RuleNb,File:SrcLoc), NClause = '$source_location'(File,SrcLoc):Clause ; NClause = Clause ). add_dummy_location(Clause,NClause) :- ( chr_pp_flag(line_numbers,on) -> get_chr_source_file(File), NClause = '$source_location'(File,1):Clause ; NClause = Clause ). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict) is det. % % Return goal matching newly introduced variables with variables in % previously looked-up heads. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict) :- head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,[],_). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict,+GroundVars,-NGroundVars) is det. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,GroundVars,NGroundVars) :- head_arg_matches_(Pairs,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars), list2conj(GoalList,Goal). head_arg_matches_([],[],VarDict,GroundVars,[],VarDict,GroundVars). head_arg_matches_([silent(Arg-Var)| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :- !, ( Mode == (+) -> term_variables(Arg,GroundVars0,GroundVars), head_arg_matches_(Rest,Modes,VarDict,GroundVars0,GoalList,NVarDict,NGroundVars) ; head_arg_matches_(Rest,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars) ). head_arg_matches_([Arg-Var| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :- ( var(Arg) -> ( lookup_eq(VarDict,Arg,OtherVar) -> ( Mode = (+) -> ( memberchk_eq(Arg,GroundVars) -> GoalList = [Var = OtherVar | RestGoalList], GroundVars1 = GroundVars ; GoalList = [Var == OtherVar | RestGoalList], GroundVars1 = [Arg|GroundVars] ) ; GoalList = [Var == OtherVar | RestGoalList], GroundVars1 = GroundVars ), VarDict1 = VarDict ; VarDict1 = [Arg-Var | VarDict], GoalList = RestGoalList, ( Mode = (+) -> GroundVars1 = [Arg|GroundVars] ; GroundVars1 = GroundVars ) ), Pairs = Rest, RestModes = Modes ; ground(Arg), Arg = '$chr_identifier_match'(ActualArg,IndexType) -> identifier_label_atom(IndexType,Var,ActualArg,Goal), GoalList = [Goal|RestGoalList], VarDict = VarDict1, GroundVars1 = GroundVars, Pairs = Rest, RestModes = Modes ; atomic(Arg) -> ( Mode = (+) -> GoalList = [ Var = Arg | RestGoalList] ; GoalList = [ Var == Arg | RestGoalList] ), VarDict = VarDict1, GroundVars1 = GroundVars, Pairs = Rest, RestModes = Modes ; Mode == (+), is_ground(GroundVars,Arg) -> copy_with_variable_replacement(Arg,ArgCopy,VarDict), GoalList = [ Var = ArgCopy | RestGoalList], VarDict = VarDict1, GroundVars1 = GroundVars, Pairs = Rest, RestModes = Modes ; Mode == (?), is_ground(GroundVars,Arg) -> copy_with_variable_replacement(Arg,ArgCopy,VarDict), GoalList = [ Var == ArgCopy | RestGoalList], VarDict = VarDict1, GroundVars1 = GroundVars, Pairs = Rest, RestModes = Modes ; Arg =.. [_|Args], functor(Arg,Fct,N), functor(Term,Fct,N), Term =.. [_|Vars], ( Mode = (+) -> GoalList = [ Var = Term | RestGoalList ] ; GoalList = [ nonvar(Var), Var = Term | RestGoalList ] ), pairup(Args,Vars,NewPairs), append(NewPairs,Rest,Pairs), replicate(N,Mode,NewModes), append(NewModes,Modes,RestModes), VarDict1 = VarDict, GroundVars1 = GroundVars ), head_arg_matches_(Pairs,RestModes,VarDict1,GroundVars1,RestGoalList,NVarDict,NGroundVars). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% % add_heads_types(+ListOfHeads,+VarTypes,-NVarTypes) is det. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% add_heads_types([],VarTypes,VarTypes). add_heads_types([Head|Heads],VarTypes,NVarTypes) :- add_head_types(Head,VarTypes,VarTypes1), add_heads_types(Heads,VarTypes1,NVarTypes). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% % add_head_types(+Head,+VarTypes,-NVarTypes) is det. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% add_head_types(Head,VarTypes,NVarTypes) :- functor(Head,F,A), get_constraint_type_det(F/A,ArgTypes), Head =.. [_|Args], add_args_types(Args,ArgTypes,VarTypes,NVarTypes). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% % add_args_types(+Terms,+Types,+VarTypes,-NVarTypes) is det. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% add_args_types([],[],VarTypes,VarTypes). add_args_types([Arg|Args],[Type|Types],VarTypes,NVarTypes) :- add_arg_types(Arg,Type,VarTypes,VarTypes1), add_args_types(Args,Types,VarTypes1,NVarTypes). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% % add_arg_types(+Term,+Type,+VarTypes,-NVarTypes) is det. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% % OPTIMIZATION: don't add if `any' add_arg_types(Term,Type,VarTypes,NVarTypes) :- ( Type == any -> NVarTypes = VarTypes ; var(Term) -> ( lookup_eq(VarTypes,Term,_) -> NVarTypes = VarTypes ; NVarTypes = [Term-Type|VarTypes] ) ; % nonvar NVarTypes = VarTypes % approximate with any ). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% add_heads_ground_variables(+ListOfHeads,+GroundVars,-NGroundVars) is det. % %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% add_heads_ground_variables([],GroundVars,GroundVars). add_heads_ground_variables([Head|Heads],GroundVars,NGroundVars) :- add_head_ground_variables(Head,GroundVars,GroundVars1), add_heads_ground_variables(Heads,GroundVars1,NGroundVars). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% add_head_ground_variables(+Head,+GroundVars,-GroundVars) is det. % %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% add_head_ground_variables(Head,GroundVars,NGroundVars) :- functor(Head,F,A), get_constraint_mode(F/A,ArgModes), Head =.. [_|Args], add_arg_ground_variables(Args,ArgModes,GroundVars,NGroundVars). add_arg_ground_variables([],[],GroundVars,GroundVars). add_arg_ground_variables([Arg|Args],[Mode|Modes],GroundVars,NGroundVars) :- ( Mode == (+) -> term_variables(Arg,Vars), add_var_ground_variables(Vars,GroundVars,GroundVars1) ; GroundVars = GroundVars1 ), add_arg_ground_variables(Args,Modes,GroundVars1,NGroundVars). add_var_ground_variables([],GroundVars,GroundVars). add_var_ground_variables([Var|Vars],GroundVars,NGroundVars) :- ( memberchk_eq(Var,GroundVars) -> GroundVars1 = GroundVars ; GroundVars1 = [Var|GroundVars] ), add_var_ground_variables(Vars,GroundVars1,NGroundVars). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% is_ground(+GroundVars,+Term) is semidet. % % Determine whether =Term= is always ground. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% is_ground(GroundVars,Term) :- ( ground(Term) -> true ; compound(Term) -> Term =.. [_|Args], maplist(is_ground(GroundVars),Args) ; memberchk_eq(Term,GroundVars) ). %% check_ground(+GroundVars,+Term,-Goal) is det. % % Return runtime check to see whether =Term= is ground. check_ground(GroundVars,Term,Goal) :- term_variables(Term,Variables), check_ground_variables(Variables,GroundVars,Goal). check_ground_variables([],_,true). check_ground_variables([Var|Vars],GroundVars,Goal) :- ( memberchk_eq(Var,GroundVars) -> check_ground_variables(Vars,GroundVars,Goal) ; Goal = (ground(Var), RGoal), check_ground_variables(Vars,GroundVars,RGoal) ). rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict) :- rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,[],_). rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,GroundVars,NGroundVars) :- ( Heads = [_|_] -> rest_heads_retrieval_and_matching_n(Heads,IDs,PrevHs,PrevSusps,ActiveHead,GoalList,Susps,VarDict,NVarDict,AttrDict,GroundVars,NGroundVars) ; GoalList = [], Susps = [], VarDict = NVarDict, GroundVars = NGroundVars ). rest_heads_retrieval_and_matching_n([],_,_,_,_,[],[],VarDict,VarDict,_AttrDict,GroundVars,GroundVars). rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],PrevHs,PrevSusps,ActiveHead, [Goal|Goals],[Susp|Susps],VarDict,NVarDict,_AttrDict,GroundVars,NGroundVars) :- functor(H,F,A), head_info(H,A,Vars,_,_,Pairs), get_store_type(F/A,StoreType), ( StoreType == default -> passive_head_via(H,[ActiveHead|PrevHs],VarDict,ViaGoal,VarSusps), delay_phase_end(validate_store_type_assumptions, ( static_suspension_term(F/A,Suspension), get_static_suspension_term_field(arguments,F/A,Suspension,Vars), get_static_suspension_field(F/A,Suspension,state,active,GetState) ) ), % create_get_mutable_ref(active,State,GetMutable), get_constraint_mode(F/A,Mode), head_arg_matches(Pairs,Mode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1), NPairs = Pairs, sbag_member_call(Susp,VarSusps,Sbag), ExistentialLookup = ( ViaGoal, Sbag, Susp = Suspension, % not inlined GetState ), inline_matching_goal(MatchingGoal,MatchingGoal2) ; delay_phase_end(validate_store_type_assumptions, ( static_suspension_term(F/A,Suspension), get_static_suspension_term_field(arguments,F/A,Suspension,Vars) ) ), existential_lookup(StoreType,H,[ActiveHead|PrevHs],VarDict,GroundVars,Suspension,ExistentialLookup,Susp,Pairs,NPairs), get_constraint_mode(F/A,Mode), NMode = Mode, % filter_mode(NPairs,Pairs,Mode,NMode), head_arg_matches(NPairs,NMode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1), filter_append(NPairs,VarDict1,DA_), % order important here translate(GroundVars1,DA_,GroundVarsA), translate(GroundVars1,VarDict1,GroundVarsB), inline_matching_goal(MatchingGoal,MatchingGoal2,GroundVarsA,GroundVarsB) ), different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals), Goal = ( ExistentialLookup, DiffSuspGoals, MatchingGoal2 ), rest_heads_retrieval_and_matching_n(Hs,IDs,[H|PrevHs],[Susp|PrevSusps],ActiveHead,Goals,Susps,VarDict1,NVarDict,_NewAttrDict,GroundVars1,NGroundVars). inline_matching_goal(G1,G2) :- inline_matching_goal(G1,G2,[],[]). inline_matching_goal(A==B,true,GVA,GVB) :- memberchk_eq(A,GVA), memberchk_eq(B,GVB), A=B, !. % inline_matching_goal(A=B,true,_,_) :- A=B, !. inline_matching_goal((A,B),(A2,B2),GVA,GVB) :- !, inline_matching_goal(A,A2,GVA,GVB), inline_matching_goal(B,B2,GVA,GVB). inline_matching_goal(X,X,_,_). filter_mode([],_,_,[]). filter_mode([Arg-Var|Rest],[_-V|R],[M|Ms],Modes) :- ( Var == V -> Modes = [M|MT], filter_mode(Rest,R,Ms,MT) ; filter_mode([Arg-Var|Rest],R,Ms,Modes) ). filter_append([],VarDict,VarDict). filter_append([X|Xs],VarDict,NVarDict) :- ( X = silent(_) -> filter_append(Xs,VarDict,NVarDict) ; NVarDict = [X|NVarDict0], filter_append(Xs,VarDict,NVarDict0) ). 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) :- different_from_other_susps_(Heads,Susps,Head,Susp,DiffSuspGoalList), list2conj(DiffSuspGoalList,DiffSuspGoals). different_from_other_susps_(_,[],_,_,[]) :- !. different_from_other_susps_([PreHead|Heads],[PreSusp|Susps],Head,Susp,List) :- ( functor(Head,F,A), functor(PreHead,F,A), copy_term_nat(PreHead-Head,PreHeadCopy-HeadCopy), \+ \+ PreHeadCopy = HeadCopy -> List = [Susp \== PreSusp | Tail] ; List = Tail ), different_from_other_susps_(Heads,Susps,Head,Susp,Tail). % passive_head_via(in,in,in,in,out,out,out) :- passive_head_via(Head,PrevHeads,VarDict,Goal,AllSusps) :- functor(Head,F,A), get_constraint_index(F/A,Pos), /* which static variables may contain runtime variables */ common_variables(Head,PrevHeads,CommonVars0), ground_vars([Head],GroundVars), list_difference_eq(CommonVars0,GroundVars,CommonVars), /********************************************************/ global_list_store_name(F/A,Name), GlobalGoal = nb_getval(Name,AllSusps), get_constraint_mode(F/A,ArgModes), ( Vars == [] -> Goal = GlobalGoal ; member(CommonVar,CommonVars), nth1(I,ArgModes,(-)), arg(I,Head,Arg), Arg == CommonVar -> translate([CommonVar],VarDict,[Var]), gen_get_mod_constraints(F/A,Var,AttrGoal,AllSusps), Goal = AttrGoal ; translate(CommonVars,VarDict,Vars), add_heads_types(PrevHeads,[],TypeDict), my_term_copy(TypeDict,VarDict,TypeDictCopy), gen_get_mod_constraints(F/A,Vars,TypeDictCopy,ViaGoal,AttrGoal,AllSusps), Goal = ( ViaGoal -> AttrGoal ; GlobalGoal ) ). common_variables(T,Ts,Vs) :- term_variables(T,V1), term_variables(Ts,V2), intersect_eq(V1,V2,Vs). gen_get_mod_constraints(FA,Vars,TypeDict,ViaGoal,AttrGoal,AllSusps) :- via_goal(Vars,TypeDict,ViaGoal,Var), get_target_module(Mod), AttrGoal = ( get_attr(Var,Mod,TSusps), TSuspsEqSusps % TSusps = Susps ), get_max_constraint_index(N), ( N == 1 -> TSuspsEqSusps = true, % TSusps = Susps AllSusps = TSusps ; get_constraint_index(FA,Pos), get_suspensions(N,Pos,TSusps,TSuspsEqSusps,AllSusps) ). via_goal(Vars,TypeDict,ViaGoal,Var) :- ( Vars = [] -> ViaGoal = fail ; Vars = [A] -> lookup_type(TypeDict,A,Type), ( atomic_type(Type) -> ViaGoal = var(A), A = Var ; ViaGoal = 'chr newvia_1'(A,Var) ) ; Vars = [A,B] -> ViaGoal = 'chr newvia_2'(A,B,Var) ; ViaGoal = 'chr newvia'(Vars,Var) ). lookup_type(TypeDict,Var,Type) :- ( lookup_eq(TypeDict,Var,Type) -> true ; Type = any % default type ). gen_get_mod_constraints(FA,Var,AttrGoal,AllSusps) :- get_target_module(Mod), AttrGoal = ( get_attr(Var,Mod,TSusps), TSuspsEqSusps % TSusps = Susps ), get_max_constraint_index(N), ( N == 1 -> TSuspsEqSusps = true, % TSusps = Susps AllSusps = TSusps ; get_constraint_index(FA,Pos), get_suspensions(N,Pos,TSusps,TSuspsEqSusps,AllSusps) ). 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(_,H,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), % variables that are declared to be ground don't need to be locked ground_vars(H,GroundVars), list_difference_eq(GuardVars,GroundVars,LockedGuardVars), ( chr_pp_flag(guard_locks,off) -> Locks = [], Unlocks = [] ; bagof(Lock - Unlock, X ^ Y ^ (lists:member(X,LockedGuardVars), % X is a variable appearing in the original guard pairlist:lookup_eq(VarDict,X,Y), % translate X into new variable memberchk_eq(Y,GuardCopyVars), % redundant check? or multiple entries for X possible? chr_lock(Y,Lock), chr_unlock(Y,Unlock) ), 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), \+ (( member(V,Vars), lookup_eq(VarDict,V,_) )). active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment) :- functor(Head,F,A), C = F/A, ( is_stored(C) -> ( ( Id == [0], chr_pp_flag(store_in_guards, off) ; ( get_allocation_occurrence(C,AO), get_max_occurrence(C,MO), MO < AO ) ), only_ground_indexed_arguments(C), chr_pp_flag(late_allocation,on) -> SuspDetachment = true ; gen_uncond_susp_detachment(Head,Susp,active,VarDict,UnCondSuspDetachment), ( chr_pp_flag(late_allocation,on) -> SuspDetachment = ( var(Susp) -> true ; UnCondSuspDetachment ) ; SuspDetachment = UnCondSuspDetachment ) ) ; SuspDetachment = true ). partner_constraint_detachments([],[],_,true). partner_constraint_detachments([Susp|Susps],[Head|Heads],VarDict,(SuspDetachment,SuspsDetachments)) :- gen_uncond_susp_detachment(Head,Susp,partner,VarDict,SuspDetachment), partner_constraint_detachments(Susps,Heads,VarDict,SuspsDetachments). gen_uncond_susp_detachment(Head,Susp,Role,VarDict,SuspDetachment) :- functor(Head,F,A), C = F/A, ( is_stored(C) -> SuspDetachment = ( DebugEvent, RemoveInternalGoal), ( chr_pp_flag(debugable,on) -> DebugEvent = 'chr debug_event'(remove(Susp)) ; DebugEvent = true ), remove_constraint_goal(C,Susp,Vars,true,(DeleteCall,Detach),Role,RemoveInternalGoal), delete_constraint_goal(Head,Susp,VarDict,DeleteCall), ( \+ only_ground_indexed_arguments(C), \+ get_store_type(C,var_assoc_store(_,_)) -> detach_constraint_atom(C,Vars,Susp,Detach) ; Detach = true ) ; SuspDetachment = true ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% ____ _ _ _ _ %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ / | %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ | | %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | | | %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_| %% |_| |___/ %% {{{ simpagation_head1_code(Head,ID,RestHeads,OtherIDs,PragmaRule,F/A,O,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), get_constraint_mode(F/A,Mode), head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars), build_head(F,A,Id,HeadVars,ClauseHead), append(RestHeads,Heads2,Heads), append(OtherIDs,Heads2IDs,IDs), reorder_heads(RuleNb,Head,Heads,IDs,NHeads,NIDs), guard_splitting(Rule,GuardList0), ( is_stored_in_guard(F/A, RuleNb) -> GuardList = [Hole1|GuardList0] ; GuardList = GuardList0 ), guard_via_reschedule_new(NHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest), rest_heads_retrieval_and_matching(NHeads,NIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_), split_by_ids(NIDs,Susps,OtherIDs,Susps1,Susps1IDs,Susps2,Susps2IDs), guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy), ( is_stored_in_guard(F/A, RuleNb) -> gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,_), GuardCopyList = [Hole1Copy|_], Hole1Copy = Attachment ; true ), sort_by_key(Susps1,Susps1IDs,SortedSusps1), partner_constraint_detachments(SortedSusps1,RestHeads,VarDict,SuspsDetachments), active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment), ( chr_pp_flag(debugable,on) -> my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody), sort_by_key([Susp|Susps1],[ID|Susps1IDs],RemovedSusps), sort_by_key(Susps2,Susps2IDs,KeptSusps), DebugTry = 'chr debug_event'( try(RemovedSusps,KeptSusps,DebugGuard,DebugBody)), DebugApply = 'chr debug_event'(apply(RemovedSusps,KeptSusps,DebugGuard,DebugBody)), instrument_goal((!),DebugTry,DebugApply,Cut) ; Cut = (!) ), Clause = ( ClauseHead :- FirstMatching, RescheduledTest, Cut, SuspsDetachments, SuspDetachment, BodyCopy ), add_location(Clause,RuleNb,LocatedClause), L = [LocatedClause | 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). split_by_ids([],[],_,[],[],[],[]). split_by_ids([I|Is],[S|Ss],I1s,S1s,SI1s,S2s,SI2s) :- ( memberchk_eq(I,I1s) -> S1s = [S | R1s], SI1s = [I|RSI1s], S2s = R2s, SI2s = RSI2s ; S1s = R1s, SI1s = RSI1s, S2s = [S | R2s], SI2s = [I|RSI2s] ), split_by_ids(Is,Ss,I1s,R1s,RSI1s,R2s,RSI2s). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% ____ _ _ _ ____ %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ |___ \ %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ __) | %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | / __/ %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_____| %% |_| |___/ %% Genereate prelude + worker predicate %% prelude calls worker %% worker iterates over one type of removed constraints simpagation_head2_code(Head2,ID,RestHeads2,RestIDs,PragmaRule,FA,O,Id,L,T) :- PragmaRule = pragma(Rule,ids(IDs1,IDs2),Pragmas,_Name,RuleNb), Rule = rule(Heads1,_,Guard,Body), append(Heads1,RestHeads2,Heads), append(IDs1,RestIDs,IDs), reorder_heads(RuleNb,Head2,Heads,IDs,[NHead|NHeads],[NID|NIDs]), simpagation_head2_prelude(Head2,NHead,[NHeads,Guard,Body],FA,O,Id,L,L1), extend_id(Id,Id1), ( memberchk_eq(NID,IDs2) -> simpagation_universal_searches(NHeads,NIDs,IDs2,[NHead,Head2],Rule,FA,O,NextHeads,PreHeads,NextIDs,Id1,Id2,L1,L2) ; L1 = L2, Id1 = Id2,NextHeads = NHeads, PreHeads = [NHead,Head2], NextIDs = NIDs ), universal_search_iterator_end(PreHeads,NextHeads,Rule,FA,O,Id2,L2,L3), simpagation_head2_worker(PreHeads,NextHeads,NextIDs,ID,PragmaRule,FA,O,Id2,L3,T). simpagation_universal_searches([],[],_,PreHeads,_,_,_,[],PreHeads,[],Id,Id,L,L). simpagation_universal_searches(Heads,[ID|IDs],IDs2,PreHeads,Rule,C,O,OutHeads,OutPreHeads,OutIDs,Id,NId,L,T) :- Heads = [Head|RHeads], inc_id(Id,Id1), universal_search_iterator_end(PreHeads,Heads,Rule,C,O,Id,L,L0), universal_search_iterator(Heads,PreHeads,Rule,C,O,Id,L0,L1), ( memberchk_eq(ID,IDs2) -> simpagation_universal_searches(RHeads,IDs,IDs2,[Head|PreHeads],Rule,C,O,OutHeads,OutPreHeads,OutIDs,Id1,NId,L1,T) ; NId = Id1, L1 = T, OutHeads = RHeads, OutPreHeads = [Head|PreHeads], IDs = OutIDs ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% simpagation_head2_prelude(Head,Head1,Rest,F/A,O,Id1,L,T) :- head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs), build_head(F,A,Id1,VarsSusp,ClauseHead), get_constraint_mode(F/A,Mode), head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars), lookup_passive_head(Head1,[Head],VarDict,GroundVars,ModConstraintsGoal,AllSusps), gen_occ_allocation(F/A,O,Vars,Susp,ConstraintAllocationGoal), extend_id(Id1,DelegateId), extra_active_delegate_variables(Head,[Head1|Rest],VarDict,ExtraVars), append([AllSusps|VarsSusp],ExtraVars,DelegateCallVars), build_head(F,A,[O|DelegateId],DelegateCallVars,Delegate), PreludeClause = ( ClauseHead :- FirstMatching, ModConstraintsGoal, !, ConstraintAllocationGoal, Delegate ), add_dummy_location(PreludeClause,LocatedPreludeClause), L = [LocatedPreludeClause|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([CurrentHead|PreHeads],NextHeads,NextIDs,ID,PragmaRule,F/A,O,Id,L,T) :- PragmaRule = pragma(Rule,ids(IDs1,_),Pragmas,_,RuleNb), Rule = rule(_,_,Guard,Body), get_prop_inner_loop_vars(PreHeads,[CurrentHead,NextHeads,Guard,Body],PreVarsAndSusps,VarDict,Susp,Vars,PreSusps), gen_var(OtherSusp), gen_var(OtherSusps), functor(CurrentHead,OtherF,OtherA), gen_vars(OtherA,OtherVars), head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs), get_constraint_mode(OtherF/OtherA,Mode), head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1,[],GroundVars), delay_phase_end(validate_store_type_assumptions, ( static_suspension_term(OtherF/OtherA,OtherSuspension), get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState), get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars) ) ), % create_get_mutable_ref(active,State,GetMutable), different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals), CurrentSuspTest = ( OtherSusp = OtherSuspension, GetState, DiffSuspGoals, FirstMatching ), ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps], build_head(F,A,[O|Id],ClauseVars,ClauseHead), guard_splitting(Rule,GuardList0), ( is_stored_in_guard(F/A, RuleNb) -> GuardList = [Hole1|GuardList0] ; GuardList = GuardList0 ), guard_via_reschedule_new(NextHeads,GuardList,[CurrentHead|PreHeads],GuardCopyList,RestSuspsRetrieval,RescheduledTest), rest_heads_retrieval_and_matching(NextHeads,NextIDs,[CurrentHead|PreHeads],RestSuspsRetrieval,Susps,VarDict1,VarDict2,[CurrentHead|PreHeads],[OtherSusp|PreSusps],[]), split_by_ids(NextIDs,Susps,IDs1,Susps1,Susps2), split_by_ids(NextIDs,NextHeads,IDs1,RestHeads1,_), partner_constraint_detachments([OtherSusp | Susps1],[CurrentHead|RestHeads1],VarDict2,Susps1Detachments), RecursiveVars = [OtherSusps|PreVarsAndSusps], build_head(F,A,[O|Id],RecursiveVars,RecursiveCall), RecursiveVars2 = [[]|PreVarsAndSusps], build_head(F,A,[O|Id],RecursiveVars2,RecursiveCall2), guard_body_copies3(Rule,GuardList,VarDict2,GuardCopyList,BodyCopy), ( is_stored_in_guard(F/A, RuleNb) -> GuardCopyList = [GuardAttachment|_] % once( ) ?? ; true ), ( is_observed(F/A,O) -> gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation), gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall), gen_state_cond_call(Susp,F/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 ), ( is_stored_in_guard(F/A, RuleNb) -> GuardAttachment = Attachment, BodyAttachment = true ; GuardAttachment = true, BodyAttachment = Attachment % will be true if not observed at all ), ( member(unique(ID1,UniqueKeys), Pragmas), check_unique_keys(UniqueKeys,VarDict) -> Clause = ( ClauseHead :- ( CurrentSuspTest -> ( RescheduledTest, DebugTry -> DebugApply, Susps1Detachments, BodyAttachment, BodyCopy, ConditionalRecursiveCall2 ; RecursiveCall2 ) ; RecursiveCall ) ) ; Clause = ( ClauseHead :- ( CurrentSuspTest, RescheduledTest, DebugTry -> DebugApply, Susps1Detachments, BodyAttachment, BodyCopy, ConditionalRecursiveCall ; RecursiveCall ) ) ), add_location(Clause,RuleNb,LocatedClause), L = [LocatedClause | T]. gen_state_cond_call(Susp,FA,Call,Generation,ConditionalCall) :- ( may_trigger(FA) -> does_use_field(FA,generation), delay_phase_end(validate_store_type_assumptions, ( static_suspension_term(FA,Suspension), get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState), get_static_suspension_field(FA,Suspension,generation,Generation,GetGeneration), get_static_suspension_term_field(arguments,FA,Suspension,Args) ) ) ; delay_phase_end(validate_store_type_assumptions, ( static_suspension_term(FA,Suspension), get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState), get_static_suspension_term_field(arguments,FA,Suspension,Args) ) ), GetGeneration = true ), ConditionalCall = ( Susp = Suspension, GetState, GetGeneration -> UpdateState, Call ; true ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% ____ _ _ %% | _ \ _ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ %% | |_) | '__/ _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ %% | __/| | | (_) | |_) | (_| | (_| | (_| | |_| | (_) | | | | %% |_| |_| \___/| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| %% |_| |___/ propagation_code(Head,ID,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :- ( RestHeads == [] -> propagation_single_headed(Head,ID,Rule,RuleNb,FA,O,Id,L,T) ; propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% Single headed propagation %% everything in a single clause propagation_single_headed(Head,ID,Rule,RuleNb,F/A,O,Id,ProgramList,ProgramTail) :- 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), get_constraint_mode(F/A,Mode), head_arg_matches(HeadPairs,Mode,[],HeadMatching,VarDict,[],GroundVars), guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy), % - recursive call - RecursiveCall = NextHead, actual_cut(F/A,O,ActualCut), Rule = rule(_,_,Guard,Body), ( chr_pp_flag(debugable,on) -> my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody), DebugTry = 'chr debug_event'( try([],[Susp],DebugGuard,DebugBody)), DebugApply = 'chr debug_event'(apply([],[Susp],DebugGuard,DebugBody)), instrument_goal(ActualCut,DebugTry,DebugApply,Cut) ; Cut = ActualCut ), ( may_trigger(F/A), \+ has_no_history(RuleNb)-> use_auxiliary_predicate(novel_production), use_auxiliary_predicate(extend_history), does_use_history(F/A,O), gen_occ_allocation(F/A,O,Vars,Susp,Allocation), ( named_history(RuleNb,HistoryName,HistoryIDs) -> ( HistoryIDs == [] -> empty_named_history_novel_production(HistoryName,NovelProduction), empty_named_history_extend_history(HistoryName,ExtendHistory) ; Tuple = HistoryName ) ; Tuple = RuleNb ), ( var(NovelProduction) -> NovelProduction = '$novel_production'(Susp,Tuple), ExtendHistory = '$extend_history'(Susp,Tuple) ; true ), ( is_observed(F/A,O) -> gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation), gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall) ; Attachment = true, ConditionalRecursiveCall = RecursiveCall ) ; Allocation = true, NovelProduction = true, ExtendHistory = true, ( is_observed(F/A,O) -> get_allocation_occurrence(F/A,AllocO), ( O == AllocO -> gen_insert_constraint_internal_goal(F/A,Attachment,VarsSusp,Vars,Susp), Generation = 0 ; % more room for improvement? Attachment = (Attachment1, Attachment2), gen_occ_allocation(F/A,O,Vars,Susp,Attachment1), gen_uncond_attach_goal(F/A,Susp,Vars,Attachment2,Generation) ), gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall) ; gen_occ_allocation(F/A,O,Vars,Susp,Attachment), ConditionalRecursiveCall = RecursiveCall ) ), ( is_stored_in_guard(F/A, RuleNb) -> GuardAttachment = Attachment, BodyAttachment = true ; GuardAttachment = true, BodyAttachment = Attachment % will be true if not observed at all ), Clause = ( ClauseHead :- HeadMatching, Allocation, NovelProduction, GuardAttachment, GuardCopy, Cut, ExtendHistory, BodyAttachment, BodyCopy, ConditionalRecursiveCall ), add_location(Clause,RuleNb,LocatedClause), ProgramList = [LocatedClause | ProgramTail]. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% multi headed propagation %% prelude + predicates to accumulate the necessary combinations of suspended %% constraints + predicate to execute the body propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :- RestHeads = [First|Rest], propagation_prelude(Head,RestHeads,Rule,FA,O,Id,L,L1), extend_id(Id,ExtendedId), propagation_nested_code(Rest,[First,Head],RestIDs,Rule,RuleNb,FA,O,ExtendedId,L1,T). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% propagation_prelude(Head,[First|Rest],Rule,F/A,O,Id,L,T) :- head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs), build_head(F,A,Id,VarsSusp,PreludeHead), get_constraint_mode(F/A,Mode), head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars), Rule = rule(_,_,Guard,Body), extra_active_delegate_variables(Head,[First,Rest,Guard,Body],VarDict,ExtraVars), lookup_passive_head(First,[Head],VarDict,GroundVars,FirstSuspGoal,Susps), gen_occ_allocation(F/A,O,Vars,Susp,CondAllocation), extend_id(Id,NestedId), append([Susps|VarsSusp],ExtraVars,NestedVars), build_head(F,A,[O|NestedId],NestedVars,NestedHead), NestedCall = NestedHead, Prelude = ( PreludeHead :- FirstMatching, FirstSuspGoal, !, CondAllocation, NestedCall ), add_dummy_location(Prelude,LocatedPrelude), L = [LocatedPrelude|T]. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% propagation_nested_code([],[CurrentHead|PreHeads],RestIDs,Rule,RuleNb,FA,O,Id,L,T) :- universal_search_iterator_end([CurrentHead|PreHeads],[],Rule,FA,O,Id,L,L1), propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L1,T). propagation_nested_code([Head|RestHeads],PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :- universal_search_iterator_end(PreHeads,[Head|RestHeads],Rule,FA,O,Id,L,L1), universal_search_iterator([Head|RestHeads],PreHeads,Rule,FA,O,Id,L1,L2), inc_id(Id,IncId), propagation_nested_code(RestHeads,[Head|PreHeads],RestIDs,Rule,RuleNb,FA,O,IncId,L2,T). %check_fd_lookup_condition(_,_,_,_) :- fail. check_fd_lookup_condition(F,A,_,_) :- get_store_type(F/A,global_singleton), !. check_fd_lookup_condition(F,A,CurrentHead,PreHeads) :- \+ may_trigger(F/A), get_functional_dependency(F/A,1,P,K), copy_term(P-K,CurrentHead-Key), term_variables(PreHeads,PreVars), intersect_eq(Key,PreVars,Key),!. propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,F/A,O,Id,L,T) :- Rule = rule(_,H2,Guard,Body), gen_var_susp_list_for_b(PreHeads,[CurrentHead,Guard,Body],VarDict1,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators), flatten(PreVarsAndSuspsList,PreVarsAndSusps), init(AllSusps,RestSusps), last(AllSusps,Susp), gen_var(OtherSusp), gen_var(OtherSusps), functor(CurrentHead,OtherF,OtherA), gen_vars(OtherA,OtherVars), delay_phase_end(validate_store_type_assumptions, ( static_suspension_term(OtherF/OtherA,Suspension), get_static_suspension_field(OtherF/OtherA,Suspension,state,active,GetState), get_static_suspension_term_field(arguments,OtherF/OtherA,Suspension,OtherVars) ) ), % create_get_mutable_ref(active,State,GetMutable), CurrentSuspTest = ( OtherSusp = Suspension, GetState ), ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps], build_head(F,A,[O|Id],ClauseVars,ClauseHead), ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId0), RecursiveVars = PreVarsAndSusps1 ; RecursiveVars = [OtherSusps|PreVarsAndSusps], PrevId0 = Id ), ( PrevId0 = [_] -> PrevId = PrevId0 ; PrevId = [O|PrevId0] ), build_head(F,A,PrevId,RecursiveVars,RecursiveHead), RecursiveCall = RecursiveHead, CurrentHead =.. [_|OtherArgs], pairup(OtherArgs,OtherVars,OtherPairs), get_constraint_mode(OtherF/OtherA,Mode), head_arg_matches(OtherPairs,Mode,VarDict1,Matching,VarDict), different_from_other_susps(CurrentHead,OtherSusp,PreHeads,RestSusps,DiffSuspGoals), guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy), get_occurrence(F/A,O,_,ID), ( is_observed(F/A,O) -> init(FirstVarsSusp,FirstVars), gen_uncond_attach_goal(F/A,Susp,FirstVars,Attachment,Generation), gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall) ; Attachment = true, ConditionalRecursiveCall = RecursiveCall ), ( (is_least_occurrence(RuleNb) ; has_no_history(RuleNb)) -> NovelProduction = true, ExtendHistory = true ; \+ may_trigger(F/A), maplist(is_passive(RuleNb),RestIDs) -> NovelProduction = true, ExtendHistory = true ; get_occurrence(F/A,O,_,ID), use_auxiliary_predicate(novel_production), use_auxiliary_predicate(extend_history), does_use_history(F/A,O), ( named_history(RuleNb,HistoryName,HistoryIDs) -> ( HistoryIDs == [] -> empty_named_history_novel_production(HistoryName,NovelProduction), empty_named_history_extend_history(HistoryName,ExtendHistory) ; reverse([OtherSusp|RestSusps],NamedSusps), named_history_susps(HistoryIDs,[ID|RestIDs],[Susp|NamedSusps],HistorySusps), HistorySusps = [HistorySusp|_], ( length(HistoryIDs, 1) -> ExtendHistory = '$extend_history'(HistorySusp,HistoryName), NovelProduction = '$novel_production'(HistorySusp,HistoryName) ; findall(ConstraintSymbol,(member(SomeID,HistoryIDs),get_occurrence_from_id(ConstraintSymbol,_,RuleNb,SomeID)),ConstraintSymbols), Tuple =.. [t,HistoryName|HistorySusps] ) ) ; HistorySusp = Susp, maplist(extract_symbol,H2,ConstraintSymbols), sort([ID|RestIDs],HistoryIDs), history_susps(RestIDs,[OtherSusp|RestSusps],Susp,ID,HistorySusps), Tuple =.. [t,RuleNb|HistorySusps] ), ( var(NovelProduction) -> novel_production_calls(ConstraintSymbols,HistoryIDs,HistorySusps,RuleNb,TupleVar,NovelProductions), ExtendHistory = '$extend_history'(HistorySusp,TupleVar), NovelProduction = ( TupleVar = Tuple, NovelProductions ) ; true ) ), ( chr_pp_flag(debugable,on) -> Rule = rule(_,_,Guard,Body), my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody), get_occurrence(F/A,O,_,ID), sort_by_key([Susp,OtherSusp|RestSusps],[ID|RestIDs],KeptSusps), DebugTry = 'chr debug_event'( try([],KeptSusps,DebugGuard,DebugBody)), DebugApply = 'chr debug_event'(apply([],KeptSusps,DebugGuard,DebugBody)) ; DebugTry = true, DebugApply = true ), ( is_stored_in_guard(F/A, RuleNb) -> GuardAttachment = Attachment, BodyAttachment = true ; GuardAttachment = true, BodyAttachment = Attachment % will be true if not observed at all ), Clause = ( ClauseHead :- ( CurrentSuspTest, DiffSuspGoals, Matching, NovelProduction, GuardAttachment, GuardCopy, DebugTry -> DebugApply, ExtendHistory, BodyAttachment, BodyCopy, ConditionalRecursiveCall ; RecursiveCall ) ), add_location(Clause,RuleNb,LocatedClause), L = [LocatedClause|T]. extract_symbol(Head,F/A) :- functor(Head,F,A). novel_production_calls([],[],[],_,_,true). novel_production_calls([ConstraintSymbol|ConstraintSymbols],[ID|IDs],[Suspension|Suspensions],RuleNb,Tuple,(Goal,Goals)) :- get_occurrence_from_id(ConstraintSymbol,Occurrence,RuleNb,ID), delay_phase_end(validate_store_type_assumptions,novel_production_call(ConstraintSymbol,Occurrence,'$novel_production'(Suspension,Tuple),Goal)), novel_production_calls(ConstraintSymbols,IDs,Suspensions,RuleNb,Tuple,Goals). history_susps(RestIDs,ReversedRestSusps,Susp,ID,HistorySusps) :- reverse(ReversedRestSusps,RestSusps), sort_by_key([Susp|RestSusps],[ID|RestIDs],HistorySusps). named_history_susps([],_,_,[]). named_history_susps([HistoryID|HistoryIDs],IDs,Susps,[HistorySusp|HistorySusps]) :- select2(HistoryID,HistorySusp,IDs,Susps,RestIDs,RestSusps), !, named_history_susps(HistoryIDs,RestIDs,RestSusps,HistorySusps). gen_var_susp_list_for([Head],Terms,VarDict,HeadVars,VarsSusp,Susp) :- !, functor(Head,F,A), head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs), get_constraint_mode(F/A,Mode), head_arg_matches(HeadPairs,Mode,[],_,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), get_constraint_mode(F/A,Mode), head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict), passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars), append(HeadVars,[Susp,Susps|Rest],VarsSusps). % returns % VarDict for the copies of variables in the original heads % VarsSuspsList list of lists of arguments for the successive heads % FirstVarsSusp top level arguments % SuspList list of all suspensions % Iterators list of all iterators gen_var_susp_list_for_b([Head],NextHeads,VarDict,[HeadVars],VarsSusp,[Susp],[]) :- !, functor(Head,F,A), head_info(Head,A,_Vars,Susp,VarsSusp,Pairs), % make variables for argument positions get_constraint_mode(F/A,Mode), head_arg_matches(Pairs,Mode,[],_,VarDict), % copy variables inside arguments, build dictionary extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars), % decide what additional variables are needed append(VarsSusp,ExtraVars,HeadVars). % add additional variables to head variables gen_var_susp_list_for_b([Head|Heads],NextHeads,NVarDict,[Vars|RestVars],FirstVarsSusp,[Susp|SuspList],[Susps|Iterators]) :- gen_var_susp_list_for_b(Heads,[Head|NextHeads],VarDict,RestVars,FirstVarsSusp,SuspList,Iterators), functor(Head,F,A), gen_var(Susps), head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs), get_constraint_mode(F/A,Mode), head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict), passive_delegate_variables(Head,Heads,NextHeads,NVarDict,HeadVars), append(HeadVars,[Susp,Susps],Vars). get_prop_inner_loop_vars([Head],NextHeads,HeadVars,VarDict,Susp,Vars,[]) :- !, functor(Head,F,A), head_info(Head,A,Vars,Susp,VarsSusp,Pairs), get_constraint_mode(F/A,Mode), head_arg_matches(Pairs,Mode,[],_,VarDict), extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars), append(VarsSusp,ExtraVars,HeadVars). get_prop_inner_loop_vars([Head|Heads],Terms,VarsSusps,NVarDict,MainSusp,MainVars,[Susp|RestSusps]) :- get_prop_inner_loop_vars(Heads,[Head|Terms],RestVarsSusp,VarDict,MainSusp,MainVars,RestSusps), functor(Head,F,A), gen_var(Susps), head_info(Head,A,_Vars,Susp,_VarsSusp,Pairs), get_constraint_mode(F/A,Mode), head_arg_matches(Pairs,Mode,VarDict,_,NVarDict), passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars), append(HeadVars,[Susp,Susps|RestVarsSusp],VarsSusps). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% ____ _ _ _ _ %% | _ \ __ _ ___ ___(_)_ _____ | | | | ___ __ _ __| | %% | |_) / _` / __/ __| \ \ / / _ \ | |_| |/ _ \/ _` |/ _` | %% | __/ (_| \__ \__ \ |\ V / __/ | _ | __/ (_| | (_| | %% |_| \__,_|___/___/_| \_/ \___| |_| |_|\___|\__,_|\__,_| %% %% ____ _ _ _ %% | _ \ ___| |_ _ __(_) _____ ____ _| | %% | |_) / _ \ __| '__| |/ _ \ \ / / _` | | %% | _ < __/ |_| | | | __/\ V / (_| | | %% |_| \_\___|\__|_| |_|\___| \_/ \__,_|_| %% %% ____ _ _ %% | _ \ ___ ___ _ __ __| | ___ _ __(_)_ __ __ _ %% | |_) / _ \/ _ \| '__/ _` |/ _ \ '__| | '_ \ / _` | %% | _ < __/ (_) | | | (_| | __/ | | | | | | (_| | %% |_| \_\___|\___/|_| \__,_|\___|_| |_|_| |_|\__, | %% |___/ reorder_heads(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :- ( chr_pp_flag(reorder_heads,on), length(RestHeads,Length), Length =< 6 -> 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), copy_term_nat(InitialData,InitialDataCopy), a_star(InitialDataCopy,FD^(chr_translate:final_data(FD)),N^EN^C^(chr_translate:expand_data(N,EN,C)),FinalData), InitialDataCopy = InitialData, 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), select2(Head1,ID1,NHeads,NIDs,NHeads1,NIDs1), term_variables([Head1|Vars],Vars1), NEntry = entry([Head1|Heads],[ID1|IDs],Vars1,NHeads1,NIDs1,RuleNb), order_score(Head1,ID1,Vars,NHeads1,RuleNb,Cost). % Assigns score to head based on known variables and heads to lookup % order_score(+head,+id,+knownvars,+heads,+rule_nb,-score). {{{ 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,99999,Score). % }}} %% order_score(+store+_type,+head,+id,+vars,+heads,+rule_nb,+score,-score) {{{ order_score(default,Head,_ID,KnownVars,RestHeads,RuleNb,CScore,NScore) :- term_variables(Head,HeadVars0), term_variables(RestHeads,RestVars), ground_vars([Head],GroundVars), list_difference_eq(HeadVars0,GroundVars,HeadVars), order_score_vars(HeadVars,KnownVars,RestVars,Score), NScore is min(CScore,Score). order_score(multi_inthash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,CScore,Score) :- ( CScore =< 100 -> Score = CScore ; order_score_indexes(Indexes,Head,KnownVars,Score) ). order_score(multi_hash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,CScore,Score) :- ( CScore =< 100 -> Score = CScore ; order_score_indexes(Indexes,Head,KnownVars,Score) ). order_score(global_ground,Head,ID,KnownVars,RestHeads,RuleNb,CScore,NScore) :- term_variables(Head,HeadVars), term_variables(RestHeads,RestVars), order_score_vars(HeadVars,KnownVars,RestVars,Score_), Score is Score_ * 200, NScore is min(CScore,Score). order_score(var_assoc_store(_,_),_,_,_,_,_,_,1). order_score(global_singleton,_Head,ID,_KnownVars,_RestHeads,_RuleNb,_,Score) :- Score = 1. % guaranteed O(1) order_score(multi_store(StoreTypes),Head,ID,KnownVars,RestHeads,RuleNb,CScore,Score) :- multi_order_score(StoreTypes,Head,ID,KnownVars,RestHeads,RuleNb,CScore,Score). multi_order_score([],_,_,_,_,_,Score,Score). multi_order_score([StoreType|StoreTypes],Head,ID,KnownVars,RestHeads,RuleNb,Score0,Score) :- ( order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,Score0,Score1) -> true ; Score1 = Score0 ), multi_order_score(StoreTypes,Head,ID,KnownVars,RestHeads,RuleNb,Score1,Score). order_score(identifier_store(Index),Head,ID,KnownVars,RestHeads,RuleNb,CScore,Score) :- arg(Index,Head,Arg), memberchk_eq(Arg,KnownVars), Score is min(CScore,10). order_score(type_indexed_identifier_store(Index,_),Head,ID,KnownVars,RestHeads,RuleNb,CScore,Score) :- arg(Index,Head,Arg), memberchk_eq(Arg,KnownVars), Score is min(CScore,10). % }}} %% order_score_indexes(+indexes,+head,+vars,-score). {{{ order_score_indexes(Indexes,Head,Vars,Score) :- copy_term_nat(Head+Vars,HeadCopy+VarsCopy), numbervars(VarsCopy,0,_), order_score_indexes(Indexes,HeadCopy,Score). order_score_indexes([I|Is],Head,Score) :- args(I,Head,Args), ( maplist(ground,Args) /* forall(Arg,Args,memberchk_eq(Arg,KnownVars)) */ -> Score = 100 ; order_score_indexes(Is,Head,Score) ). % }}} memberchk_eq_flip(List,Element) :- memberchk_eq(Element,List). order_score_vars(Vars,KnownVars,RestVars,Score) :- order_score_count_vars(Vars,KnownVars,RestVars,K-R-O), ( K-R-O == 0-0-0 -> Score = 0 ; K > 0 -> Score is max(10 - K,0) ; R > 0 -> Score is max(10 - R,1) * 100 ; Score is max(10-O,1) * 1000 ). order_score_count_vars([],_,_,0-0-0). order_score_count_vars([V|Vs],KnownVars,RestVars,NK-NR-NO) :- order_score_count_vars(Vs,KnownVars,RestVars,K-R-O), ( memberchk_eq(V,KnownVars) -> NK is K + 1, NR = R, NO = O ; memberchk_eq(V,RestVars) -> NR is R + 1, NK = K, NO = O ; NO is O + 1, NK = K, NR = R ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% ___ _ _ _ %% |_ _|_ __ | (_)_ __ (_)_ __ __ _ %% | || '_ \| | | '_ \| | '_ \ / _` | %% | || | | | | | | | | | | | | (_| | %% |___|_| |_|_|_|_| |_|_|_| |_|\__, | %% |___/ %% SWI begin create_get_mutable_ref(V,M,GM) :- GM = (M = mutable(V)). create_get_mutable(V,M,GM) :- M = mutable(V), GM = true. %% SWI end %% SICStus begin %% create_get_mutable(V,M,GM) :- GM = get_mutable(V,M). %% create_get_mutable_ref(V,M,GM) :- GM = get_mutable(V,M). %% SICStus end %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% _ _ _ _ _ _ _ %% | | | | |_(_) (_) |_ _ _ %% | | | | __| | | | __| | | | %% | |_| | |_| | | | |_| |_| | %% \___/ \__|_|_|_|\__|\__, | %% |___/ % Create a fresh variable. gen_var(_). % Create =N= fresh variables. gen_vars(N,Xs) :- length(Xs,N). ast_head_info1(AstHead,Vars,Susp,VarsSusp,HeadPairs) :- AstHead = chr_constraint(_/A,Args,_), vars_susp(A,Vars,Susp,VarsSusp), pairup(Args,Vars,HeadPairs). head_info1(Head,_/A,Vars,Susp,VarsSusp,HeadPairs) :- vars_susp(A,Vars,Susp,VarsSusp), Head =.. [_|Args], pairup(Args,Vars,HeadPairs). 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. % return clause Head % for F/A constraint symbol, predicate identifier Id and arguments Head build_head(F/A,Id,Args,Head) :- build_head(F,A,Id,Args,Head). build_head(F,A,Id,Args,Head) :- buildName(F,A,Id,Name), ( (chr_pp_flag(debugable,on) ; is_stored(F/A), ( has_active_occurrence(F/A) ; chr_pp_flag(late_allocation,off)), ( may_trigger(F/A) ; get_allocation_occurrence(F/A,AO), get_max_occurrence(F/A,MO), MO >= AO ) ) -> Head =.. [Name|Args] ; init(Args,ArgsWOSusp), % XXX not entirely correct! Head =.. [Name|ArgsWOSusp] ). % return predicate name Result % for Fct/Aty constraint symbol and predicate identifier List buildName(Fct,Aty,List,Result) :- ( (chr_pp_flag(debugable,on) ; (once((is_stored(Fct/Aty), ( has_active_occurrence(Fct/Aty) ; chr_pp_flag(late_allocation,off)), ( may_trigger(Fct/Aty) ; get_allocation_occurrence(Fct/Aty,AO), get_max_occurrence(Fct/Aty,MO), MO >= AO ) ; List \= [0])) ) ) -> atom_concat(Fct, '___' ,FctSlash), atomic_concat(FctSlash,Aty,FctSlashAty), buildName_(List,FctSlashAty,Result) ; Result = Fct ). 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). 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). make_name(Prefix,F/A,Name) :- atom_concat_list([Prefix,F,'___',A],Name). %=============================================================================== % Attribute for attributed variables make_attr(N,Mask,SuspsList,Attr) :- length(SuspsList,N), Attr =.. [v,Mask|SuspsList]. get_all_suspensions2(N,Attr,SuspensionsList) :- chr_pp_flag(dynattr,off), !, make_attr(N,_,SuspensionsList,Attr). % NEW get_all_suspensions2(N,Attr,Goal,SuspensionsList) :- % writeln(get_all_suspensions2), length(SuspensionsList,N), Goal = 'chr all_suspensions'(SuspensionsList,1,Attr). % NEW normalize_attr(Attr,NormalGoal,NormalAttr) :- % writeln(normalize_attr), NormalGoal = 'chr normalize_attr'(Attr,NormalAttr). get_suspensions(N,Position,TAttr,(TAttr = Attr),Suspensions) :- chr_pp_flag(dynattr,off), !, % chr_pp_flag(experiment,off), !, make_attr(N,_,SuspsList,Attr), nth1(Position,SuspsList,Suspensions). % get_suspensions(N,Position,TAttr,Goal,Suspensions) :- % chr_pp_flag(dynattr,off), % chr_pp_flag(experiment,on), !, % Position1 is Position + 1, % Goal = arg(Position1,TAttr,Suspensions). % NEW get_suspensions(N,Position,TAttr,Goal,Suspensions) :- % writeln(get_suspensions), Goal = ( memberchk(Position-Suspensions,TAttr) -> true ; Suspensions = [] ). %------------------------------------------------------------------------------- % +N: number of constraint symbols % +Suspension: source-level variable, for suspension % +Position: constraint symbol number % -Attr: source-level term, for new attribute singleton_attr(N,Suspension,Position,Attr) :- chr_pp_flag(dynattr,off), !, or_pattern(Position,Pattern), make_attr(N,Pattern,SuspsList,Attr), nth1(Position,SuspsList,[Suspension],RestSuspsList), set_elems(RestSuspsList,[]). % NEW singleton_attr(N,Suspension,Position,Attr) :- % writeln(singleton_attr), Attr = [Position-[Suspension]]. %------------------------------------------------------------------------------- % +N: number of constraint symbols % +Suspension: source-level variable, for suspension % +Position: constraint symbol number % +TAttr: source-level variable, for old attribute % -Goal: goal for creating new attribute % -NTAttr: source-level variable, for new attribute add_attr(N,Suspension,Position,TAttr,Goal,NTAttr) :- chr_pp_flag(dynattr,off), !, make_attr(N,Mask,SuspsList,Attr), or_pattern(Position,Pattern), nth1(Position,SuspsList,Susps), substitute_eq(Susps,SuspsList,[Suspension|Susps],SuspsList1), make_attr(N,Mask,SuspsList1,NewAttr1), substitute_eq(Susps,SuspsList,[Suspension],SuspsList2), make_attr(N,NewMask,SuspsList2,NewAttr2), Goal = ( TAttr = Attr, ( Mask /\ Pattern =:= Pattern -> NTAttr = NewAttr1 ; NewMask is Mask \/ Pattern, NTAttr = NewAttr2 ) ), !. % NEW add_attr(N,Suspension,Position,TAttr,Goal,NTAttr) :- % writeln(add_attr), Goal = ( 'chr select'(TAttr,Position-Suspensions,RAttr) -> NTAttr = [Position-[Suspension|Suspensions]|RAttr] ; NTAttr = [Position-[Suspension]|TAttr] ). rem_attr(N,Var,Suspension,Position,TAttr,Goal) :- chr_pp_flag(dynattr,off), chr_pp_flag(experiment,off), !, or_pattern(Position,Pattern), and_pattern(Position,DelPattern), make_attr(N,Mask,SuspsList,Attr), nth1(Position,SuspsList,Susps), substitute_eq(Susps,SuspsList,[],SuspsList1), make_attr(N,NewMask,SuspsList1,Attr1), substitute_eq(Susps,SuspsList,NewSusps,SuspsList2), make_attr(N,Mask,SuspsList2,Attr2), get_target_module(Mod), Goal = ( TAttr = Attr, ( Mask /\ Pattern =:= Pattern -> 'chr sbag_del_element'(Susps,Suspension,NewSusps), ( NewSusps == [] -> NewMask is Mask /\ DelPattern, ( NewMask == 0 -> del_attr(Var,Mod) ; put_attr(Var,Mod,Attr1) ) ; put_attr(Var,Mod,Attr2) ) ; true ) ), !. rem_attr(N,Var,Suspension,Position,TAttr,Goal) :- chr_pp_flag(dynattr,off), chr_pp_flag(experiment,on), !, or_pattern(Position,Pattern), and_pattern(Position,DelPattern), Position1 is Position + 1, get_target_module(Mod), Goal = ( arg(1,TAttr,Mask), ( Mask /\ Pattern =:= Pattern -> arg(Position1,TAttr,Susps), 'chr sbag_del_element'(Susps,Suspension,NewSusps), ( NewSusps == [] -> NewMask is Mask /\ DelPattern, ( NewMask == 0 -> del_attr(Var,Mod) ; setarg(1,TAttr,NewMask), setarg(Position1,TAttr,NewSusps) ) ; setarg(Position1,TAttr,NewSusps) ) ; true ) ), !. % NEW rem_attr(N,Var,Suspension,Position,TAttr,Goal) :- % writeln(rem_attr), get_target_module(Mod), Goal = ( 'chr select'(TAttr,Position-Suspensions,RAttr) -> 'chr sbag_del_element'(Suspensions,Suspension,NSuspensions), ( NSuspensions == [] -> ( RAttr == [] -> del_attr(Var,Mod) ; put_attr(Var,Mod,RAttr) ) ; put_attr(Var,Mod,[Position-NSuspensions|RAttr]) ) ; true ). %------------------------------------------------------------------------------- % +N: number of constraint symbols % +TAttr1: source-level variable, for attribute % +TAttr2: source-level variable, for other attribute % -Goal: goal for merging the two attributes % -Attr: source-level term, for merged attribute merge_attributes(N,TAttr1,TAttr2,Goal,Attr) :- chr_pp_flag(dynattr,off), !, make_attr(N,Mask1,SuspsList1,Attr1), merge_attributes2(N,Mask1,SuspsList1,TAttr2,Goal2,Attr), Goal = ( TAttr1 = Attr1, Goal2 ). % NEW merge_attributes(N,TAttr1,TAttr2,Goal,Attr) :- % writeln(merge_attributes), Goal = ( sort(TAttr1,Sorted1), sort(TAttr2,Sorted2), 'chr new_merge_attributes'(Sorted1,Sorted2,Attr) ). %------------------------------------------------------------------------------- % +N: number of constraint symbols % +Mask1: ... % +SuspsList1: static term, for suspensions list % +TAttr2: source-level variable, for other attribute % -Goal: goal for merging the two attributes % -Attr: source-level term, for merged attribute merge_attributes2(N,Mask1,SuspsList1,TAttr2,Goal,Attr) :- make_attr(N,Mask2,SuspsList2,Attr2), bagof(G,X ^ Y ^ SY ^ M ^ (member2(SuspsList1,SuspsList2,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), SuspsList), make_attr(N,Mask,SuspsList,Attr), Goal = ( TAttr2 = Attr2, SortGoals, Mask is Mask1 \/ Mask2 ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Storetype dependent lookup %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% lookup_passive_head(+Head,+PreviousVars,+RenamingVarDict, %% -Goal,-SuspensionList) is det. % % Create a universal lookup goal for given head. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% 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(+Head,+PreviousVars,+RenamingVarDict,+GroundVars, %% -Goal,-SuspensionList) is det. % % Create a universal lookup goal for given head. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% lookup_passive_head(Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :- functor(Head,F,A), get_store_type(F/A,StoreType), lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% lookup_passive_head(+StoreType,+Head,+PreviousVars,+RenamingVarDict, %% +GroundVars,-Goal,-SuspensionList) is det. % % Create a universal lookup goal for given head. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% lookup_passive_head(default,Head,PreJoin,VarDict,_,Goal,AllSusps) :- functor(Head,F,A), passive_head_via(Head,PreJoin,VarDict,Goal,AllSusps), update_store_type(F/A,default). lookup_passive_head(multi_inthash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :- hash_lookup_passive_head(inthash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_). lookup_passive_head(multi_hash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :- hash_lookup_passive_head(hash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_). 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(var_assoc_store(VarIndex,KeyIndex),Head,_PreJoin,VarDict,_,Goal,AllSusps) :- arg(VarIndex,Head,OVar), arg(KeyIndex,Head,OKey), translate([OVar,OKey],VarDict,[Var,Key]), get_target_module(Module), Goal = ( get_attr(Var,Module,AssocStore), lookup_assoc_store(AssocStore,Key,AllSusps) ). lookup_passive_head(global_singleton,Head,_PreJoin,_VarDict,_,Goal,AllSusps) :- functor(Head,F,A), global_singleton_store_name(F/A,StoreName), make_get_store_goal(StoreName,Susp,GetStoreGoal), Goal = (GetStoreGoal,Susp \== [],AllSusps = [Susp]), update_store_type(F/A,global_singleton). lookup_passive_head(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :- once(( member(ST,StoreTypes), lookup_passive_head(ST,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) )). lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :- functor(Head,F,A), arg(Index,Head,Var), translate([Var],VarDict,[KeyVar]), delay_phase_end(validate_store_type_assumptions, identifier_lookup(F/A,Index,AllSusps,KeyVar,Goal) ), update_store_type(F/A,identifier_store(Index)), get_identifier_index(F/A,Index,_). lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :- functor(Head,F,A), arg(Index,Head,Var), ( var(Var) -> translate([Var],VarDict,[KeyVar]), Goal = StructGoal ; ground(Var), Var = '$chr_identifier_match'(ActualVar,_) -> lookup_only_identifier_atom(IndexType,ActualVar,KeyVar,LookupGoal), Goal = (LookupGoal,StructGoal) ), delay_phase_end(validate_store_type_assumptions, type_indexed_identifier_lookup(F/A,Index,IndexType,AllSusps,KeyVar,StructGoal) ), update_store_type(F/A,type_indexed_identifier_store(Index,IndexType)), get_type_indexed_identifier_index(IndexType,F/A,Index,_). identifier_lookup(C,Index,AllSusps,KeyVar,Goal) :- get_identifier_size(ISize), functor(Struct,struct,ISize), get_identifier_index(C,Index,IIndex), arg(IIndex,Struct,AllSusps), Goal = (KeyVar = Struct). type_indexed_identifier_lookup(C,Index,IndexType,AllSusps,KeyVar,Goal) :- type_indexed_identifier_structure(IndexType,Struct), get_type_indexed_identifier_index(IndexType,C,Index,IIndex), arg(IIndex,Struct,AllSusps), Goal = (KeyVar = Struct). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% hash_lookup_passive_head(+StoreType,+Indexes,+Head,+RenamingVarDict, %% +GroundVars,-Goal,-SuspensionList,-Index) is det. % % Create a universal hash lookup goal for given head. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,Index) :- pick_hash_index(Indexes,Head,VarDict,Index,KeyArgs,KeyArgCopies), ( KeyArgCopies = [KeyCopy] -> true ; KeyCopy =.. [k|KeyArgCopies] ), functor(Head,F,A), multi_hash_lookup_goal(F/A,HashType,Index,KeyCopy,AllSusps,LookupGoal), check_ground(GroundVars,KeyArgs,OriginalGroundCheck), my_term_copy(OriginalGroundCheck,VarDict,GroundCheck), Goal = (GroundCheck,LookupGoal), ( HashType == inthash -> update_store_type(F/A,multi_inthash([Index])) ; update_store_type(F/A,multi_hash([Index])) ). pick_hash_index(Indexes,Head,VarDict,Index,KeyArgs,KeyArgCopies) :- member(Index,Indexes), args(Index,Head,KeyArgs), key_in_scope(KeyArgs,VarDict,KeyArgCopies), !. % check whether we can copy the given terms % with the given dictionary, and, if so, do so key_in_scope([],VarDict,[]). key_in_scope([Arg|Args],VarDict,[ArgCopy|ArgCopies]) :- term_variables(Arg,Vars), translate(Vars,VarDict,VarCopies), copy_term(Arg/Vars,ArgCopy/VarCopies), key_in_scope(Args,VarDict,ArgCopies). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% existential_lookup(+StoreType,+Head,+PrevVariablesHead,+RenamingVarDict, %% +GroundVariables,-SuspensionTerm,-Goal,-SuspVar, %% +VarArgDict,-NewVarArgDict) is det. % % Create existential lookup goal for given head. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% existential_lookup(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :- !, lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,UniversalGoal,AllSusps), sbag_member_call(Susp,AllSusps,Sbag), functor(Head,F,A), delay_phase_end(validate_store_type_assumptions, ( static_suspension_term(F/A,SuspTerm), get_static_suspension_field(F/A,SuspTerm,state,active,GetState) ) ), Goal = ( UniversalGoal, Sbag, Susp = SuspTerm, GetState ). existential_lookup(global_singleton,Head,_PreJoin,_VarDict,_,SuspTerm,Goal,Susp,Pairs,Pairs) :- !, functor(Head,F,A), global_singleton_store_name(F/A,StoreName), make_get_store_goal(StoreName,Susp,GetStoreGoal), Goal = ( GetStoreGoal, % nb_getval(StoreName,Susp), Susp \== [], Susp = SuspTerm ), update_store_type(F/A,global_singleton). existential_lookup(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !, once(( member(ST,StoreTypes), existential_lookup(ST,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) )). existential_lookup(multi_inthash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !, existential_hash_lookup(inthash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs). existential_lookup(multi_hash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !, existential_hash_lookup(hash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs). existential_lookup(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !, lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps), hash_index_filter(Pairs,[Index],NPairs), functor(Head,F,A), ( check_fd_lookup_condition(F,A,Head,KeyArgs) -> Sbag = (AllSusps = [Susp]) ; sbag_member_call(Susp,AllSusps,Sbag) ), delay_phase_end(validate_store_type_assumptions, ( static_suspension_term(F/A,SuspTerm), get_static_suspension_field(F/A,SuspTerm,state,active,GetState) ) ), Goal = ( LookupGoal, Sbag, Susp = SuspTerm, % not inlined GetState ). existential_lookup(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !, lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps), hash_index_filter(Pairs,[Index],NPairs), functor(Head,F,A), ( check_fd_lookup_condition(F,A,Head,KeyArgs) -> Sbag = (AllSusps = [Susp]) ; sbag_member_call(Susp,AllSusps,Sbag) ), delay_phase_end(validate_store_type_assumptions, ( static_suspension_term(F/A,SuspTerm), get_static_suspension_field(F/A,SuspTerm,state,active,GetState) ) ), Goal = ( LookupGoal, Sbag, Susp = SuspTerm, % not inlined GetState ). existential_lookup(StoreType,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :- lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,UGoal,Susps), sbag_member_call(Susp,Susps,Sbag), functor(Head,F,A), delay_phase_end(validate_store_type_assumptions, ( static_suspension_term(F/A,SuspTerm), get_static_suspension_field(F/A,SuspTerm,state,active,GetState) ) ), Goal = ( UGoal, Sbag, Susp = SuspTerm, % not inlined GetState ). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% existential_hash_lookup(+StoreType,+Indexes,+Head,+RenamingVarDict, %% +GroundVariables,-SuspensionTerm,-Goal,-SuspVar, %% +VarArgDict,-NewVarArgDict) is det. % % Create existential hash lookup goal for given head. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% existential_hash_lookup(HashType,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,LookupGoal,AllSusps,Index), hash_index_filter(Pairs,Index,NPairs), functor(Head,F,A), ( check_fd_lookup_condition(F,A,Head,KeyArgs) -> Sbag = (AllSusps = [Susp]) ; sbag_member_call(Susp,AllSusps,Sbag) ), delay_phase_end(validate_store_type_assumptions, ( static_suspension_term(F/A,SuspTerm), get_static_suspension_field(F/A,SuspTerm,state,active,GetState) ) ), Goal = ( LookupGoal, Sbag, Susp = SuspTerm, % not inlined GetState ). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% hash_index_filter(+Pairs,+Index,-NPairs) is det. % % Filter out pairs already covered by given hash index. % makes them 'silent' %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% hash_index_filter(Pairs,Index,NPairs) :- hash_index_filter(Pairs,Index,1,NPairs). hash_index_filter([],_,_,[]). hash_index_filter([P|Ps],Index,N,NPairs) :- ( Index = [I|Is] -> NN is N + 1, ( I > N -> NPairs = [P|NPs], hash_index_filter(Ps,[I|Is],NN,NPs) ; I == N -> NPairs = [silent(P)|NPs], hash_index_filter(Ps,Is,NN,NPs) ) ; NPairs = [P|Ps] ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %------------------------------------------------------------------------------% %% assume_constraint_stores(+ConstraintSymbols) is det. % % Compute all constraint store types that are possible for the given % =ConstraintSymbols=. %------------------------------------------------------------------------------% assume_constraint_stores([]). assume_constraint_stores([C|Cs]) :- ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(C) ; chr_pp_flag(mixed_stores,on) ), is_stored(C), get_store_type(C,default) -> get_indexed_arguments(C,AllIndexedArgs), get_constraint_mode(C,Modes), aggregate_all(bag(Index)-count, (member(Index,AllIndexedArgs),nth1(Index,Modes,+)), IndexedArgs-NbIndexedArgs), % Construct Index Combinations ( NbIndexedArgs > 10 -> findall([Index],member(Index,IndexedArgs),Indexes) ; findall(Index,(sublist(Index,IndexedArgs), Index \== []),UnsortedIndexes), predsort(longer_list,UnsortedIndexes,Indexes) ), % EXPERIMENTAL HEURISTIC % findall(Index, ( % member(Arg1,IndexedArgs), % member(Arg2,IndexedArgs), % Arg1 =< Arg2, % sort([Arg1,Arg2], Index) % ), UnsortedIndexes), % predsort(longer_list,UnsortedIndexes,Indexes), % Choose Index Type ( get_functional_dependency(C,1,Pattern,Key), all_distinct_var_args(Pattern), Key == [] -> assumed_store_type(C,global_singleton) ; ( only_ground_indexed_arguments(C) ; NbIndexedArgs > 0 ) -> get_constraint_type_det(C,ArgTypes), partition_indexes(Indexes,ArgTypes,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes), ( IntHashIndexes = [] -> Stores = Stores1 ; Stores = [multi_inthash(IntHashIndexes)|Stores1] ), ( HashIndexes = [] -> Stores1 = Stores2 ; Stores1 = [multi_hash(HashIndexes)|Stores2] ), ( IdentifierIndexes = [] -> Stores2 = Stores3 ; maplist(wrap_in_functor(identifier_store),IdentifierIndexes,WrappedIdentifierIndexes), append(WrappedIdentifierIndexes,Stores3,Stores2) ), append(CompoundIdentifierIndexes,Stores4,Stores3), ( only_ground_indexed_arguments(C) -> Stores4 = [global_ground] ; Stores4 = [default] ), assumed_store_type(C,multi_store(Stores)) ; true ) ; true ), assume_constraint_stores(Cs). %------------------------------------------------------------------------------% %% partition_indexes(+Indexes,+Types, %% -HashIndexes,-IntHashIndexes,-IdentifierIndexes) is det. %------------------------------------------------------------------------------% partition_indexes([],_,[],[],[],[]). partition_indexes([Index|Indexes],Types,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes) :- ( Index = [I], nth1(I,Types,Type), unalias_type(Type,UnAliasedType), UnAliasedType == chr_identifier -> IdentifierIndexes = [I|RIdentifierIndexes], IntHashIndexes = RIntHashIndexes, HashIndexes = RHashIndexes, CompoundIdentifierIndexes = RCompoundIdentifierIndexes ; Index = [I], nth1(I,Types,Type), unalias_type(Type,UnAliasedType), nonvar(UnAliasedType), UnAliasedType = chr_identifier(IndexType) -> CompoundIdentifierIndexes = [type_indexed_identifier_store(I,IndexType)|RCompoundIdentifierIndexes], IdentifierIndexes = RIdentifierIndexes, IntHashIndexes = RIntHashIndexes, HashIndexes = RHashIndexes ; Index = [I], nth1(I,Types,Type), unalias_type(Type,UnAliasedType), UnAliasedType == dense_int -> IntHashIndexes = [Index|RIntHashIndexes], HashIndexes = RHashIndexes, IdentifierIndexes = RIdentifierIndexes, CompoundIdentifierIndexes = RCompoundIdentifierIndexes ; member(I,Index), nth1(I,Types,Type), unalias_type(Type,UnAliasedType), nonvar(UnAliasedType), UnAliasedType = chr_identifier(_) -> % don't use chr_identifiers in hash indexes IntHashIndexes = RIntHashIndexes, HashIndexes = RHashIndexes, IdentifierIndexes = RIdentifierIndexes, CompoundIdentifierIndexes = RCompoundIdentifierIndexes ; IntHashIndexes = RIntHashIndexes, HashIndexes = [Index|RHashIndexes], IdentifierIndexes = RIdentifierIndexes, CompoundIdentifierIndexes = RCompoundIdentifierIndexes ), partition_indexes(Indexes,Types,RHashIndexes,RIntHashIndexes,RIdentifierIndexes,RCompoundIdentifierIndexes). longer_list(R,L1,L2) :- length(L1,N1), length(L2,N2), compare(Rt,N2,N1), ( Rt == (=) -> compare(R,L1,L2) ; R = Rt ). all_distinct_var_args(Term) :- copy_term_nat(Term,TermCopy), functor(Term,F,A), functor(Pattern,F,A), Pattern =@= TermCopy. 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). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % new code generation universal_search_iterator_end([CurrentHead|PrevHeads],NextHeads,Rule,F/A,O,Id,L,T) :- Rule = rule(H1,_,Guard,Body), gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators), universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId0), flatten(VarsAndSuspsList,VarsAndSusps), Vars = [ [] | VarsAndSusps], build_head(F,A,[O|Id],Vars,Head), ( PrevId0 = [_] -> get_success_continuation_code_id(F/A,O,PredictedPrevId), % format('~w == ~w ?\n',[PrevId0,PredictedPrevId]), PrevId = [PredictedPrevId] % PrevId = PrevId0 ; PrevId = [O|PrevId0] ), build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall), Clause = ( Head :- PredecessorCall), add_dummy_location(Clause,LocatedClause), L = [LocatedClause | T]. % ( H1 == [], % functor(CurrentHead,CF,CA), % check_fd_lookup_condition(CF,CA,CurrentHead,PrevHeads) -> % L = T % ; % gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators), % universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId), % flatten(VarsAndSuspsList,VarsAndSusps), % Vars = [ [] | VarsAndSusps], % build_head(F,A,Id,Vars,Head), % build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall), % Clause = ( Head :- PredecessorCall), % L = [Clause | T] % ). % skips back intelligently over global_singleton lookups universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,BaseCallArgs,PrevIterators,PrevVarsAndSusps,PrevId) :- ( Id = [0|_] -> % TOM: add partial success continuation optimization here! next_id(Id,PrevId), PrevVarsAndSusps = BaseCallArgs ; VarsAndSuspsList = [_|AllButFirstList], dec_id(Id,PrevId1), ( PrevHeads = [PrevHead|PrevHeads1], functor(PrevHead,F,A), check_fd_lookup_condition(F,A,PrevHead,PrevHeads1) -> PrevIterators = [_|PrevIterators1], universal_search_iterator_failure_vars(PrevHeads1,PrevId1,AllButFirstList,BaseCallArgs,PrevIterators1,PrevVarsAndSusps,PrevId) ; PrevId = PrevId1, flatten(AllButFirstList,AllButFirst), PrevIterators = [PrevIterator|_], PrevVarsAndSusps = [PrevIterator|AllButFirst] ) ). universal_search_iterator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,O,Id,L,T) :- Rule = rule(_,_,Guard,Body), gen_var_susp_list_for_b(PreHeads,[CurrentHead,NextHead,RestHeads,Guard,Body],VarDict,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators), init(AllSusps,PreSusps), flatten(PreVarsAndSuspsList,PreVarsAndSusps), gen_var(OtherSusps), functor(CurrentHead,OtherF,OtherA), gen_vars(OtherA,OtherVars), head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs), get_constraint_mode(OtherF/OtherA,Mode), head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1), delay_phase_end(validate_store_type_assumptions, ( static_suspension_term(OtherF/OtherA,OtherSuspension), get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState), get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars) ) ), different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals), % create_get_mutable_ref(active,State,GetMutable), CurrentSuspTest = ( OtherSusp = OtherSuspension, GetState, DiffSuspGoals, FirstMatching ), add_heads_ground_variables([CurrentHead|PreHeads],[],GroundVars), lookup_passive_head(NextHead,[CurrentHead|PreHeads],VarDict1,GroundVars,NextSuspGoal,NextSusps), inc_id(Id,NestedId), ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps], build_head(F,A,[O|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,[O|NestedId],NestedVars,NestedHead), ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId0), RecursiveVars = PreVarsAndSusps1 ; RecursiveVars = [OtherSusps|PreVarsAndSusps], PrevId0 = Id ), ( PrevId0 = [_] -> PrevId = PrevId0 ; PrevId = [O|PrevId0] ), build_head(F,A,PrevId,RecursiveVars,RecursiveHead), Clause = ( ClauseHead :- ( CurrentSuspTest, NextSuspGoal -> NestedHead ; RecursiveHead ) ), add_dummy_location(Clause,LocatedClause), L = [LocatedClause|T]. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Observation Analysis % % CLASSIFICATION % Enabled % % Analysis based on Abstract Interpretation paper. % % TODO: % stronger analysis domain [research] :- chr_constraint initial_call_pattern/1, call_pattern/1, call_pattern_worker/1, final_answer_pattern/2, abstract_constraints/1, depends_on/2, depends_on_ap/4, depends_on_goal/2, ai_observed_internal/2, % ai_observed/2, ai_not_observed_internal/2, ai_not_observed/2, ai_is_observed/2, depends_on_as/3, ai_observation_gather_results/0. :- chr_type abstract_domain ---> odom(program_point,list(constraint)). :- chr_type program_point == any. :- chr_option(mode,initial_call_pattern(+)). :- chr_option(type_declaration,call_pattern(abstract_domain)). :- chr_option(mode,call_pattern(+)). :- chr_option(type_declaration,call_pattern(abstract_domain)). :- chr_option(mode,call_pattern_worker(+)). :- chr_option(type_declaration,call_pattern_worker(abstract_domain)). :- chr_option(mode,final_answer_pattern(+,+)). :- chr_option(type_declaration,final_answer_pattern(abstract_domain,abstract_domain)). :- chr_option(mode,abstract_constraints(+)). :- chr_option(type_declaration,abstract_constraints(list)). :- chr_option(mode,depends_on(+,+)). :- chr_option(type_declaration,depends_on(abstract_domain,abstract_domain)). :- chr_option(mode,depends_on_as(+,+,+)). :- chr_option(mode,depends_on_ap(+,+,+,+)). :- chr_option(mode,depends_on_goal(+,+)). :- chr_option(mode,ai_is_observed(+,+)). :- chr_option(mode,ai_not_observed(+,+)). % :- chr_option(mode,ai_observed(+,+)). :- chr_option(mode,ai_not_observed_internal(+,+)). :- chr_option(mode,ai_observed_internal(+,+)). abstract_constraints_fd @ abstract_constraints(_) \ abstract_constraints(_) <=> true. ai_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true. ai_not_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true. ai_observed_internal(C,O) \ ai_observed_internal(C,O) <=> true. ai_not_observed(C,O) \ ai_is_observed(C,O) <=> fail. ai_is_observed(_,_) <=> true. ai_observation_gather_results \ ai_observed_internal(C,O) <=> true. % ai_observed(C,O). ai_observation_gather_results \ ai_not_observed_internal(C,O) <=> ai_not_observed(C,O). ai_observation_gather_results <=> true. %------------------------------------------------------------------------------% % Main Analysis Entry %------------------------------------------------------------------------------% ai_observation_analysis(ACs) :- ( chr_pp_flag(ai_observation_analysis,on), get_target_module(Module), '$chr_compiled_with_version'(3) -> % , Module \== guard_entailment -> list_to_ord_set(ACs,ACSet), abstract_constraints(ACSet), ai_observation_schedule_initial_calls(ACSet,ACSet), ai_observation_gather_results ; true ). ai_observation_schedule_initial_calls([],_). ai_observation_schedule_initial_calls([AC|RACs],ACs) :- ai_observation_schedule_initial_call(AC,ACs), ai_observation_schedule_initial_calls(RACs,ACs). ai_observation_schedule_initial_call(AC,ACs) :- ai_observation_top(AC,CallPattern), % ai_observation_bot(AC,ACs,CallPattern), initial_call_pattern(CallPattern). ai_observation_schedule_new_calls([],AP). ai_observation_schedule_new_calls([AC|ACs],AP) :- AP = odom(_,Set), initial_call_pattern(odom(AC,Set)), ai_observation_schedule_new_calls(ACs,AP). final_answer_pattern(CP,AP1) \ final_answer_pattern(CP,AP2) <=> ai_observation_leq(AP2,AP1) | true. initial_call_pattern(CP) \ initial_call_pattern(CP) <=> true. initial_call_pattern(CP) ==> call_pattern(CP). initial_call_pattern(CP), final_answer_pattern(CP,AP), abstract_constraints(ACs) # ID3 ==> ai_observation_schedule_new_calls(ACs,AP) pragma passive(ID3). call_pattern(CP) \ call_pattern(CP) <=> true. depends_on(CP1,CP2), final_answer_pattern(CP2,AP) ==> final_answer_pattern(CP1,AP). %call_pattern(CP) ==> writeln(call_pattern(CP)). call_pattern(CP) ==> call_pattern_worker(CP). %------------------------------------------------------------------------------% % Abstract Goal %------------------------------------------------------------------------------% % AbstractGoala %call_pattern(odom([],Set)) ==> % final_answer_pattern(odom([],Set),odom([],Set)). call_pattern_worker(odom([],Set)) <=> % writeln(' - AbstractGoal'(odom([],Set))), final_answer_pattern(odom([],Set),odom([],Set)). % AbstractGoalb call_pattern_worker(odom([G|Gs],Set)) <=> % writeln(' - AbstractGoal'(odom([G|Gs],Set))), CP1 = odom(G,Set), depends_on_goal(odom([G|Gs],Set),CP1), call_pattern(CP1). depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2) \ depends_on(CP1,_) # ID <=> true pragma passive(ID). depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2) ==> CP1 = odom([_|Gs],_), AP2 = odom([],Set), CCP = odom(Gs,Set), call_pattern(CCP), depends_on(CP1,CCP). %------------------------------------------------------------------------------% % Abstract Disjunction %------------------------------------------------------------------------------% call_pattern_worker(odom((AG1;AG2),Set)) <=> CP = odom((AG1;AG2),Set), InitialAnswerApproximation = odom([],Set), final_answer_pattern(CP,InitialAnswerApproximation), CP1 = odom(AG1,Set), CP2 = odom(AG2,Set), call_pattern(CP1), call_pattern(CP2), depends_on_as(CP,CP1,CP2). %------------------------------------------------------------------------------% % Abstract Solve %------------------------------------------------------------------------------% call_pattern_worker(odom(builtin,Set)) <=> % writeln(' - AbstractSolve'(odom(builtin,Set))), ord_empty(EmptySet), final_answer_pattern(odom(builtin,Set),odom([],EmptySet)). %------------------------------------------------------------------------------% % Abstract Drop %------------------------------------------------------------------------------% max_occurrence(C,MO) # ID2 \ call_pattern_worker(odom(occ(C,O),Set)) <=> O > MO | % writeln(' - AbstractDrop'(odom(occ(C,O),Set))), final_answer_pattern(odom(occ(C,O),Set),odom([],Set)) pragma passive(ID2). %------------------------------------------------------------------------------% % Abstract Activate %------------------------------------------------------------------------------% call_pattern_worker(odom(AC,Set)) <=> AC = _ / _ | % writeln(' - AbstractActivate'(odom(AC,Set))), CP = odom(occ(AC,1),Set), call_pattern(CP), depends_on(odom(AC,Set),CP). %------------------------------------------------------------------------------% % Abstract Passive %------------------------------------------------------------------------------% occurrence(C,O,RuleNb,ID,_) # ID2 \ call_pattern_worker(odom(occ(C,O),Set)) <=> is_passive(RuleNb,ID) | % writeln(' - AbstractPassive'(odom(occ(C,O),Set))), % DEFAULT NO is O + 1, DCP = odom(occ(C,NO),Set), call_pattern(DCP), final_answer_pattern(odom(occ(C,O),Set),odom([],Set)), depends_on(odom(occ(C,O),Set),DCP) pragma passive(ID2). %------------------------------------------------------------------------------% % Abstract Simplify %------------------------------------------------------------------------------% % AbstractSimplify occurrence(C,O,RuleNb,ID,simplification) # ID2 \ call_pattern_worker(odom(occ(C,O),Set)) <=> \+ is_passive(RuleNb,ID) | % writeln(' - AbstractPassive'(odom(occ(C,O),Set))), ai_observation_memo_simplification_rest_heads(C,O,AbstractRestHeads), ai_observation_observe_set(Set,AbstractRestHeads,Set2), ai_observation_memo_abstract_goal(RuleNb,AG), call_pattern(odom(AG,Set2)), % DEFAULT NO is O + 1, DCP = odom(occ(C,NO),Set), call_pattern(DCP), depends_on_as(odom(occ(C,O),Set),odom(AG,Set2),DCP), % DEADLOCK AVOIDANCE final_answer_pattern(odom(occ(C,O),Set),odom([],Set)) pragma passive(ID2). depends_on_as(CP,CPS,CPD), final_answer_pattern(CPS,APS), final_answer_pattern(CPD,APD) ==> ai_observation_lub(APS,APD,AP), final_answer_pattern(CP,AP). :- chr_constraint ai_observation_memo_simplification_rest_heads/3, ai_observation_memoed_simplification_rest_heads/3. :- chr_option(mode,ai_observation_memo_simplification_rest_heads(+,+,?)). :- chr_option(mode,ai_observation_memoed_simplification_rest_heads(+,+,+)). ai_observation_memoed_simplification_rest_heads(C,O,RH) \ ai_observation_memo_simplification_rest_heads(C,O,QRH) <=> QRH = RH. abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_simplification_rest_heads(C,O,QRH) <=> Rule = pragma(rule(H1,H2,_,_),ids(IDs1,_),_,_,_), once(select2(ID,_,IDs1,H1,_,RestH1)), ai_observation_abstract_constraints(RestH1,ACs,ARestHeads), ai_observation_abstract_constraints(H2,ACs,AH2), append(ARestHeads,AH2,AbstractHeads), sort(AbstractHeads,QRH), ai_observation_memoed_simplification_rest_heads(C,O,QRH) pragma passive(ID1), passive(ID2), passive(ID3). ai_observation_memo_simplification_rest_heads(_,_,_) <=> fail. %------------------------------------------------------------------------------% % Abstract Propagate %------------------------------------------------------------------------------% % AbstractPropagate occurrence(C,O,RuleNb,ID,propagation) # ID2 \ call_pattern_worker(odom(occ(C,O),Set)) <=> \+ is_passive(RuleNb,ID) | % writeln(' - AbstractPropagate'(odom(occ(C,O),Set))), % observe partners ai_observation_memo_propagation_rest_heads(C,O,AHs), ai_observation_observe_set(Set,AHs,Set2), ord_add_element(Set2,C,Set3), ai_observation_memo_abstract_goal(RuleNb,AG), call_pattern(odom(AG,Set3)), ( ord_memberchk(C,Set2) -> Delete = no ; Delete = yes ), % DEFAULT NO is O + 1, DCP = odom(occ(C,NO),Set), call_pattern(DCP), depends_on_ap(odom(occ(C,O),Set),odom(AG,Set3),DCP,Delete) pragma passive(ID2). :- chr_constraint ai_observation_memo_propagation_rest_heads/3, ai_observation_memoed_propagation_rest_heads/3. :- chr_option(mode,ai_observation_memo_propagation_rest_heads(+,+,?)). :- chr_option(mode,ai_observation_memoed_propagation_rest_heads(+,+,+)). ai_observation_memoed_propagation_rest_heads(C,O,RH) \ ai_observation_memo_propagation_rest_heads(C,O,QRH) <=> QRH = RH. abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_propagation_rest_heads(C,O,QRH) <=> Rule = pragma(rule(H1,H2,_,_),ids(_,IDs2),_,_,_), once(select2(ID,_,IDs2,H2,_,RestH2)), ai_observation_abstract_constraints(RestH2,ACs,ARestHeads), ai_observation_abstract_constraints(H1,ACs,AH1), append(ARestHeads,AH1,AbstractHeads), sort(AbstractHeads,QRH), ai_observation_memoed_propagation_rest_heads(C,O,QRH) pragma passive(ID1), passive(ID2), passive(ID3). ai_observation_memo_propagation_rest_heads(_,_,_) <=> fail. depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPD,APD) ==> final_answer_pattern(CP,APD). depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPP,APP), final_answer_pattern(CPD,APD) ==> true | CP = odom(occ(C,O),_), ( ai_observation_is_observed(APP,C) -> ai_observed_internal(C,O) ; ai_not_observed_internal(C,O) ), ( Delete == yes -> APP = odom([],Set0), ord_del_element(Set0,C,Set), NAPP = odom([],Set) ; NAPP = APP ), ai_observation_lub(NAPP,APD,AP), final_answer_pattern(CP,AP). %------------------------------------------------------------------------------% % Catch All %------------------------------------------------------------------------------% call_pattern_worker(CP) <=> chr_error(internal,'AI observation analysis: unexpected abstract state ~w\n',[CP]). %------------------------------------------------------------------------------% % Auxiliary Predicates %------------------------------------------------------------------------------% ai_observation_lub(odom(AG,S1),odom(AG,S2),odom(AG,S3)) :- ord_intersection(S1,S2,S3). ai_observation_bot(AG,AS,odom(AG,AS)). ai_observation_top(AG,odom(AG,EmptyS)) :- ord_empty(EmptyS). ai_observation_leq(odom(AG,S1),odom(AG,S2)) :- ord_subset(S2,S1). ai_observation_observe_set(S,ACSet,NS) :- ord_subtract(S,ACSet,NS). ai_observation_abstract_constraint(C,ACs,AC) :- functor(C,F,A), AC = F/A, memberchk(AC,ACs). ai_observation_abstract_constraints(Cs,ACs,NACs) :- findall(NAC,(member(C,Cs),ai_observation_abstract_constraint(C,ACs,NAC)),NACs). %------------------------------------------------------------------------------% % Abstraction of Rule Bodies %------------------------------------------------------------------------------% :- chr_constraint ai_observation_memoed_abstract_goal/2, ai_observation_memo_abstract_goal/2. :- chr_option(mode,ai_observation_memoed_abstract_goal(+,+)). :- chr_option(mode,ai_observation_memo_abstract_goal(+,?)). ai_observation_memoed_abstract_goal(RuleNb,AG) # ID1 \ ai_observation_memo_abstract_goal(RuleNb,QAG) <=> QAG = AG pragma passive(ID1). rule(RuleNb,Rule) # ID1, abstract_constraints(ACs) # ID2 \ ai_observation_memo_abstract_goal(RuleNb,QAG) <=> Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_), ai_observation_abstract_goal_(H1,H2,Guard,Body,ACs,AG), QAG = AG, ai_observation_memoed_abstract_goal(RuleNb,AG) pragma passive(ID1), passive(ID2). ai_observation_abstract_goal_(H1,H2,Guard,G,ACs,AG) :- % also guard: e.g. b, c(X) ==> Y=X | p(Y). term_variables((H1,H2,Guard),HVars), append(H1,H2,Heads), % variables that are declared to be ground are safe, ground_vars(Heads,GroundVars), % so we remove them from the list of 'dangerous' head variables list_difference_eq(HVars,GroundVars,HV), ai_observation_abstract_goal(G,ACs,AG,[],HV),!. % writeln(ai_observation_abstract_goal(G,ACs,AG,[],HV)). % HV are 'dangerous' variables, all others are fresh and safe ground_vars([],[]). ground_vars([H|Hs],GroundVars) :- functor(H,F,A), get_constraint_mode(F/A,Mode), % TOM: fix this code! head_info(H,A,_Vars,_Susp,_HeadVars,HeadPairs), head_arg_matches(HeadPairs,Mode,[],_FirstMatching,_VarDict1,[],GroundVars1), ground_vars(Hs,GroundVars2), append(GroundVars1,GroundVars2,GroundVars). ai_observation_abstract_goal((G1,G2),ACs,List,Tail,HV) :- !, % conjunction ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV), ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV). ai_observation_abstract_goal((G1;G2),ACs,[(ABranch1;ABranch2)|Tail],Tail,HV) :- !, % disjunction ai_observation_abstract_goal(G1,ACs,ABranch1,[],HV), ai_observation_abstract_goal(G2,ACs,ABranch2,[],HV). ai_observation_abstract_goal((G1->G2),ACs,List,Tail,HV) :- !, % if-then ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV), ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV). ai_observation_abstract_goal(C,ACs,[AC|Tail],Tail,HV) :- ai_observation_abstract_constraint(C,ACs,AC), !. % CHR constraint ai_observation_abstract_goal(true,_,Tail,Tail,_) :- !. ai_observation_abstract_goal(writeln(_),_,Tail,Tail,_) :- !. % non-CHR constraint is safe if it only binds fresh variables ai_observation_abstract_goal(G,_,Tail,Tail,HV) :- builtin_binds_b(G,Vars), intersect_eq(Vars,HV,[]), !. ai_observation_abstract_goal(G,_,[AG|Tail],Tail,_) :- AG = builtin. % default case if goal is not recognized/safe ai_observation_is_observed(odom(_,ACSet),AC) :- \+ ord_memberchk(AC,ACSet). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% unconditional_occurrence(C,O) :- get_occurrence(C,O,RuleNb,ID), get_rule(RuleNb,PRule), PRule = pragma(ORule,_,_,_,_), copy_term_nat(ORule,Rule), Rule = rule(H1,H2,Guard,_), guard_entailment:entails_guard([chr_pp_headvariables(H1,H2)],Guard), once(( H1 = [Head], H2 == [] ; H2 = [Head], H1 == [], \+ may_trigger(C) )), all_distinct_var_args(Head). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ % Partial wake analysis % % In a Var = Var unification do not wake up constraints of both variables, % but rather only those of one variable. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ :- chr_constraint partial_wake_analysis/0. :- chr_constraint no_partial_wake/1. :- chr_option(mode,no_partial_wake(+)). :- chr_constraint wakes_partially/1. :- chr_option(mode,wakes_partially(+)). partial_wake_analysis, occurrence(FA,O,RuleNb,ID,Type), rule(RuleNb,Rule), constraint_mode(FA,ArgModes) ==> Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_), ( is_passive(RuleNb,ID) -> true ; Type == simplification -> select(H,H1,RestH1), H =.. [_|Args], term_variables(Guard,Vars), partial_wake_args(Args,ArgModes,Vars,FA) ; % Type == propagation -> select(H,H2,RestH2), H =.. [_|Args], term_variables(Guard,Vars), partial_wake_args(Args,ArgModes,Vars,FA) ). partial_wake_args([],_,_,_). partial_wake_args([Arg|Args],[Mode|Modes],Vars,C) :- ( Mode \== (+) -> ( nonvar(Arg) -> no_partial_wake(C) ; memberchk_eq(Arg,Vars) -> no_partial_wake(C) ; true ) ; true ), partial_wake_args(Args,Modes,Vars,C). no_partial_wake(C) \ no_partial_wake(C) <=> true. no_partial_wake(C) \ wakes_partially(C) <=> fail. wakes_partially(C) <=> true. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Generate rules that implement chr_show_store/1 functionality. % % CLASSIFICATION % Experimental % Unused % % Generates additional rules: % % $show, C1 # ID ==> writeln(C1) pragma passive(ID). % ... % $show, Cn # ID ==> writeln(Cn) pragma passive(ID). % $show <=> true. generate_show_constraint(Constraints0,Constraints,Rules0,Rules) :- ( chr_pp_flag(show,on) -> Constraints = ['$show'/0|Constraints0], generate_show_rules(Constraints0,Rules,[Rule|Rules0]), inc_rule_count(RuleNb), Rule = pragma( rule(['$show'],[],true,true), ids([0],[]), [], no, RuleNb ) ; Constraints = Constraints0, Rules = Rules0 ). generate_show_rules([],Rules,Rules). generate_show_rules([F/A|Rest],[Rule|Tail],Rules) :- functor(C,F,A), inc_rule_count(RuleNb), Rule = pragma( rule([],['$show',C],true,writeln(C)), ids([],[0,1]), [passive(1)], no, RuleNb ), generate_show_rules(Rest,Tail,Rules). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Custom supension term layout static_suspension_term(F/A,Suspension) :- suspension_term_base(F/A,Base), Arity is Base + A, functor(Suspension,suspension,Arity). has_suspension_field(FA,Field) :- suspension_term_base_fields(FA,Fields), memberchk(Field,Fields). suspension_term_base(FA,Base) :- suspension_term_base_fields(FA,Fields), length(Fields,Base). suspension_term_base_fields(FA,Fields) :- ( chr_pp_flag(debugable,on) -> % 1. ID % 2. State % 3. Propagation History % 4. Generation Number % 5. Continuation Goal % 6. Functor Fields = [id,state,history,generation,continuation,functor] ; ( uses_history(FA) -> Fields = [id,state,history|Fields2] ; only_ground_indexed_arguments(FA), get_functional_dependency(FA,1,_,_) -> Fields = [state|Fields2] ; Fields = [id,state|Fields2] ), ( only_ground_indexed_arguments(FA) -> get_store_type(FA,StoreType), basic_store_types(StoreType,BasicStoreTypes), ( memberchk(global_ground,BasicStoreTypes) -> % 1. ID % 2. State % 3. Propagation History % 4. Global List Prev Fields2 = [global_list_prev|Fields3] ; % 1. ID % 2. State % 3. Propagation History Fields2 = Fields3 ), ( chr_pp_flag(ht_removal,on) -> ht_prev_fields(BasicStoreTypes,Fields3) ; Fields3 = [] ) ; may_trigger(FA) -> % 1. ID % 2. State % 3. Propagation History ( uses_field(FA,generation) -> % 4. Generation Number % 5. Global List Prev Fields2 = [generation,global_list_prev|Fields3] ; Fields2 = [global_list_prev|Fields3] ), ( chr_pp_flag(mixed_stores,on), chr_pp_flag(ht_removal,on) -> get_store_type(FA,StoreType), basic_store_types(StoreType,BasicStoreTypes), ht_prev_fields(BasicStoreTypes,Fields3) ; Fields3 = [] ) ; % 1. ID % 2. State % 3. Propagation History % 4. Global List Prev Fields2 = [global_list_prev|Fields3], ( chr_pp_flag(mixed_stores,on), chr_pp_flag(ht_removal,on) -> get_store_type(FA,StoreType), basic_store_types(StoreType,BasicStoreTypes), ht_prev_fields(BasicStoreTypes,Fields3) ; Fields3 = [] ) ) ). ht_prev_fields(Stores,Prevs) :- ht_prev_fields_int(Stores,PrevsList), append(PrevsList,Prevs). ht_prev_fields_int([],[]). ht_prev_fields_int([H|T],Fields) :- ( H = multi_hash(Indexes) -> maplist(ht_prev_field,Indexes,FH), Fields = [FH|FT] ; Fields = FT ), ht_prev_fields_int(T,FT). ht_prev_field(Index,Field) :- atomic_list_concat(['multi_hash_prev-'|Index],Field). get_static_suspension_term_field(FieldName,FA,StaticSuspension,Field) :- suspension_term_base_fields(FA,Fields), nth1(Index,Fields,FieldName), !, arg(Index,StaticSuspension,Field). get_static_suspension_term_field(arguments,FA,StaticSuspension,Field) :- !, suspension_term_base(FA,Base), StaticSuspension =.. [_|Args], drop(Base,Args,Field). get_static_suspension_term_field(FieldName,FA,_StaticSuspension,_Field) :- chr_error(internal,'Trying to obtain field ~w of ~w, wich does not have it!',[FieldName,FA]). get_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :- suspension_term_base_fields(FA,Fields), nth1(Index,Fields,FieldName), !, Goal = arg(Index,DynamicSuspension,Field). get_dynamic_suspension_term_field(arguments,FA,DynamicSuspension,Field,Goal) :- !, static_suspension_term(FA,StaticSuspension), get_static_suspension_term_field(arguments,FA,StaticSuspension,Field), Goal = (DynamicSuspension = StaticSuspension). get_dynamic_suspension_term_field(argument(I),FA,DynamicSuspension,Field,Goal) :- !, suspension_term_base(FA,Base), Index is I + Base, Goal = arg(Index,DynamicSuspension,Field). get_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :- chr_error(internal,'Dynamic goal to get ~w of ~w, which does not have this field!',[FieldName,FA]). set_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :- suspension_term_base_fields(FA,Fields), nth1(Index,Fields,FieldName), !, Goal = setarg(Index,DynamicSuspension,Field). set_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :- chr_error(internal,'Dynamic goal to set ~w of ~w, which does not have this field!',[FieldName,FA]). basic_store_types(multi_store(Types),Types) :- !. basic_store_types(Type,[Type]). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % :- chr_constraint phase_end/1, delay_phase_end/2. :- chr_option(mode,phase_end(+)). :- chr_option(mode,delay_phase_end(+,?)). phase_end(Phase) \ delay_phase_end(Phase,Goal) <=> call(Goal). % phase_end(Phase) <=> true. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- chr_constraint does_use_history/2, uses_history/1, novel_production_call/4. :- chr_option(mode,uses_history(+)). :- chr_option(mode,does_use_history(+,+)). :- chr_option(mode,novel_production_call(+,+,?,?)). does_use_history(FA,Occ) \ does_use_history(FA,Occ) <=> true. does_use_history(FA,_) \ uses_history(FA) <=> true. uses_history(_FA) <=> fail. does_use_history(FA,Occ) \ novel_production_call(FA,Occ,PossibleGoal,Goal) <=> Goal = PossibleGoal. novel_production_call(FA,_,_PossibleGoal,Goal) <=> Goal = true. :- chr_constraint does_use_field/2, uses_field/2. :- chr_option(mode,uses_field(+,+)). :- chr_option(mode,does_use_field(+,+)). does_use_field(FA,Field) \ does_use_field(FA,Field) <=> true. does_use_field(FA,Field) \ uses_field(FA,Field) <=> true. uses_field(_FA,_Field) <=> fail. :- chr_constraint uses_state/2, if_used_state/5, used_states_known/0. :- chr_option(mode,uses_state(+,+)). :- chr_option(mode,if_used_state(+,+,?,?,?)). % states ::= not_stored_yet | passive | active | triggered | removed % % allocate CREATES not_stored_yet % remove CHECKS not_stored_yet % activate CHECKS not_stored_yet % % ==> no allocate THEN no not_stored_yet % recurs CREATES inactive % lookup CHECKS inactive % insert CREATES active % activate CREATES active % lookup CHECKS active % recurs CHECKS active % runsusp CREATES triggered % lookup CHECKS triggered % % ==> no runsusp THEN no triggered % remove CREATES removed % runsusp CHECKS removed % lookup CHECKS removed % recurs CHECKS removed % % ==> no remove THEN no removed % ==> no allocate, no remove, no active/inactive distinction THEN no state at all... uses_state(Constraint,State) \ uses_state(Constraint,State) <=> true. used_states_known, uses_state(Constraint,State) \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal) <=> ResultGoal = Used. used_states_known \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal) <=> ResultGoal = NotUsed. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % CHECK STOREDNESS ANNOTATIONS AND GENERATE DEFAULT SIMPLIFICATION RULES % (Feature for SSS) % % 1. Checking % ~~~~~~~~~~~ % % When the programmer enables the `declare_stored_constraints' option, i.e. writes % % :- chr_option(declare_stored_constraints,on). % % the compiler will check for the storedness of constraints. % % By default, the compiler assumes that the programmer wants his constraints to % be never-stored. Hence, a warning will be issues when a constraint is actually % stored. % % Such warnings are suppressed, if the programmer adds the `# stored' modifier % to a constraint declaration, i.e. writes % % :- chr_constraint c(...) # stored. % % In that case a warning is issued when the constraint is never-stored. % % NOTE: Checking is only performed if `storage_analysis' is on. Otherwise, all % constraints are stored anyway. % % % 2. Rule Generation % ~~~~~~~~~~~~~~~~~~ % % When the programmer enables the `declare_stored_constraints' option, i.e. writes % % :- chr_option(declare_stored_constraints,on). % % the compiler will generate default simplification rules for constraints. % % By default, no default rule is generated for a constraint. However, if the % programmer writes a default/1 annotation in the constraint declaration, i.e. writes % % :- chr_constraint c(...) # default(Goal). % % where `Goal' is a ground and callable goal (e.g. `true', `fail' or `throw(error)'), % the compiler generates a rule: % % c(_,...,_) <=> Goal. % % at the end of the program. If multiple default rules are generated, for several constraints, % then the order of the default rules is not specified. :- chr_constraint stored_assertion/1. :- chr_option(mode,stored_assertion(+)). :- chr_option(type_declaration,stored_assertion(constraint)). :- chr_constraint never_stored_default/2. :- chr_option(mode,never_stored_default(+,?)). :- chr_option(type_declaration,never_stored_default(constraint,any)). % Rule Generation % ~~~~~~~~~~~~~~~ generate_never_stored_rules(Constraints,Rules) :- ( chr_pp_flag(declare_stored_constraints,on) -> never_stored_rules(Constraints,Rules) ; Rules = [] ). :- chr_constraint never_stored_rules/2. :- chr_option(mode,never_stored_rules(+,?)). :- chr_option(type_declaration,never_stored_rules(list(constraint),any)). never_stored_rules([],Rules) <=> Rules = []. never_stored_default(Constraint,Goal) \ never_stored_rules([Constraint|Constraints],Rules) <=> Constraint = F/A, functor(Head,F,A), inc_rule_count(RuleNb), Rule = pragma( rule([Head],[],true,Goal), ids([0],[]), [], no, RuleNb ), Rules = [Rule|Tail], never_stored_rules(Constraints,Tail). never_stored_rules([_|Constraints],Rules) <=> never_stored_rules(Constraints,Rules). % Checking % ~~~~~~~~ check_storedness_assertions(Constraints) :- ( chr_pp_flag(storage_analysis,on), chr_pp_flag(declare_stored_constraints,on) -> forall(Constraint,Constraints,check_storedness_assertion(Constraint)) ; true ). :- chr_constraint check_storedness_assertion/1. :- chr_option(mode,check_storedness_assertion(+)). :- chr_option(type_declaration,check_storedness_assertion(constraint)). check_storedness_assertion(Constraint), stored_assertion(Constraint) <=> ( is_stored(Constraint) -> true ; chr_warning(assertion_failed,'Constraint ~w is not stored. However, it was asserted to be stored.\n',[Constraint]) ). never_stored_default(Constraint,_) \ check_storedness_assertion(Constraint) <=> ( is_finally_stored(Constraint) -> chr_warning(assertion_failed,'Constraint ~w is stored. However, it was asserted not to be stored.\n',[Constraint]) ; is_stored(Constraint) -> chr_warning(assertion_failed,'Constraint ~w is temporarily stored. However, it was asserted not to be stored.\n',[Constraint]) ; true ). % never-stored, no default goal check_storedness_assertion(Constraint) <=> ( is_finally_stored(Constraint) -> chr_warning(assertion_failed,'Constraint ~w is stored. However, it was asserted not to be stored.\n',[Constraint]) ; is_stored(Constraint) -> chr_warning(assertion_failed,'Constraint ~w is temporarily stored. However, it was asserted not to be stored.\n',[Constraint]) ; true ). %^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ % success continuation analysis % TODO % also use for forward jumping improvement! % use Prolog indexing for generated code % % EXPORTED % % should_skip_to_next_id(C,O) % % get_occurrence_code_id(C,O,Id) % %vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv continuation_analysis(ConstraintSymbols) :- maplist(analyse_continuations,ConstraintSymbols). analyse_continuations(C) :- % 1. compute success continuations of the % occurrences of constraint C continuation_analysis(C,1), % 2. determine for which occurrences % to skip to next code id get_max_occurrence(C,MO), LO is MO + 1, bulk_propagation(C,1,LO), % 3. determine code id for each occurrence set_occurrence_code_id(C,1,0). % 1. Compute the success continuations of constrait C %------------------------------------------------------------------------------- continuation_analysis(C,O) :- get_max_occurrence(C,MO), ( O > MO -> true ; O == MO -> NextO is O + 1, continuation_occurrence(C,O,NextO) ; constraint_continuation(C,O,MO,NextO), continuation_occurrence(C,O,NextO), NO is O + 1, continuation_analysis(C,NO) ). constraint_continuation(C,O,MO,NextO) :- ( get_occurrence_head(C,O,Head) -> NO is O + 1, ( between(NO,MO,NextO), get_occurrence_head(C,NextO,NextHead), unifiable(Head,NextHead,_) -> true ; NextO is MO + 1 ) ; % current occurrence is passive NextO = MO ). get_occurrence_head(C,O,Head) :- get_occurrence(C,O,RuleNb,Id), \+ is_passive(RuleNb,Id), get_rule(RuleNb,Rule), Rule = pragma(rule(H1,H2,_,_),ids(Ids1,Ids2),_,_,_), ( select2(Id,Head,Ids1,H1,_,_) -> true ; select2(Id,Head,Ids2,H2,_,_) ). :- chr_constraint continuation_occurrence/3. :- chr_option(mode,continuation_occurrence(+,+,+)). :- chr_constraint get_success_continuation_occurrence/3. :- chr_option(mode,get_success_continuation_occurrence(+,+,-)). continuation_occurrence(C,O,NO) \ get_success_continuation_occurrence(C,O,X) <=> X = NO. get_success_continuation_occurrence(C,O,X) <=> chr_error(internal,'Success continuation not found for ~w.\n',[C:O]). % 2. figure out when to skip to next code id %------------------------------------------------------------------------------- % don't go beyond the last occurrence % we have to go to next id for storage here :- chr_constraint skip_to_next_id/2. :- chr_option(mode,skip_to_next_id(+,+)). :- chr_constraint should_skip_to_next_id/2. :- chr_option(mode,should_skip_to_next_id(+,+)). skip_to_next_id(C,O) \ should_skip_to_next_id(C,O) <=> true. should_skip_to_next_id(_,_) <=> fail. :- chr_constraint bulk_propagation/3. :- chr_option(mode,bulk_propagation(+,+,+)). max_occurrence(C,MO) \ bulk_propagation(C,O,_) <=> O >= MO | skip_to_next_id(C,O). % we have to go to the next id here because % a predecessor needs it bulk_propagation(C,O,LO) <=> LO =:= O + 1 | skip_to_next_id(C,O), get_max_occurrence(C,MO), NLO is MO + 1, bulk_propagation(C,LO,NLO). % we have to go to the next id here because % we're running into a simplification rule % IMPROVE: propagate back to propagation predecessor (IF ANY) occurrence(C,NO,_,_,simplification) \ bulk_propagation(C,O,LO) <=> NO =:= O + 1 | skip_to_next_id(C,O), get_max_occurrence(C,MO), NLO is MO + 1, bulk_propagation(C,NO,NLO). % we skip the next id here % and go to the next occurrence continuation_occurrence(C,O,NextO) \ bulk_propagation(C,O,LO) <=> NextO > O + 1 | NLO is min(LO,NextO), NO is O + 1, bulk_propagation(C,NO,NLO). % default case % err on the safe side bulk_propagation(C,O,LO) <=> skip_to_next_id(C,O), get_max_occurrence(C,MO), NLO is MO + 1, NO is O + 1, bulk_propagation(C,NO,NLO). skip_to_next_id(C,O) \ skip_to_next_id(C,O) <=> true. % if this occurrence is passive, but has to skip, % then the previous one must skip instead... % IMPROVE reasoning is conservative occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id), skip_to_next_id(C,O) ==> O > 1 | PO is O - 1, skip_to_next_id(C,PO). % 3. determine code id of each occurrence %------------------------------------------------------------------------------- :- chr_constraint set_occurrence_code_id/3. :- chr_option(mode,set_occurrence_code_id(+,+,+)). :- chr_constraint occurrence_code_id/3. :- chr_option(mode,occurrence_code_id(+,+,+)). % stop at the end set_occurrence_code_id(C,O,IdNb) <=> get_max_occurrence(C,MO), O > MO | occurrence_code_id(C,O,IdNb). % passive occurrences don't change the code id occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id) \ set_occurrence_code_id(C,O,IdNb) <=> occurrence_code_id(C,O,IdNb), NO is O + 1, set_occurrence_code_id(C,NO,IdNb). occurrence(C,O,RuleNb,Id,simplification) \ set_occurrence_code_id(C,O,IdNb) <=> occurrence_code_id(C,O,IdNb), NO is O + 1, set_occurrence_code_id(C,NO,IdNb). occurrence(C,O,RuleNb,Id,propagation), skip_to_next_id(C,O) \ set_occurrence_code_id(C,O,IdNb) <=> occurrence_code_id(C,O,IdNb), NO is O + 1, NIdNb is IdNb + 1, set_occurrence_code_id(C,NO,NIdNb). occurrence(C,O,RuleNb,Id,propagation) \ set_occurrence_code_id(C,O,IdNb) <=> occurrence_code_id(C,O,IdNb), NO is O + 1, set_occurrence_code_id(C,NO,IdNb). % occurrence_code_id(C,O,IdNb) ==> writeln(occurrence_code_id(C,O,IdNb)). :- chr_constraint get_occurrence_code_id/3. :- chr_option(mode,get_occurrence_code_id(+,+,-)). occurrence_code_id(C,O,IdNb) \ get_occurrence_code_id(C,O,X) <=> X = IdNb. get_occurrence_code_id(C,O,X) <=> ( O == 0 -> true % X = 0 ; format('no occurrence code for ~w!\n',[C:O]) ). get_success_continuation_code_id(C,O,NextId) :- get_success_continuation_occurrence(C,O,NextO), get_occurrence_code_id(C,NextO,NextId). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % COLLECT CONSTANTS FOR INLINING % % for SSS %%% TODO: APPLY NEW DICT FORMAT DOWNWARDS % collect_constants(+rules,+ast_rules,+constraint_symbols,+clauses) {{{ collect_constants(Rules,AstRules,Constraints,Clauses0) :- ( not_restarted, chr_pp_flag(experiment,on) -> ( chr_pp_flag(sss,on) -> Dictionary = [fep/4-[2,3]-[[a,b]-fep1,[c,d]-fep2]-no], copy_term_nat(Clauses0,Clauses), flatten_clauses(Clauses,Dictionary,FlatClauses), install_new_declarations_and_restart(FlatClauses) ; maplist(collect_rule_constants(Constraints),AstRules), ( chr_pp_flag(verbose,on) -> print_chr_constants ; true ), ( chr_pp_flag(experiment,on) -> flattening_dictionary(Constraints,Dictionary), copy_term_nat(Clauses0,Clauses), flatten_clauses(Clauses,Dictionary,FlatClauses), install_new_declarations_and_restart(FlatClauses) ; true ) ) ; true ). :- chr_constraint chr_constants/1. :- chr_option(mode,chr_constants(+)). :- chr_constraint get_chr_constants/1. chr_constants(Constants) \ get_chr_constants(Q) <=> Q = Constants. get_chr_constants(Q) <=> chr_warning(internal,'No constants found for key ~w.\n',[Key]), Q = []. % collect_rule_constants(+constraint_symbols,+ast_rule) {{{ collect_rule_constants(Constraints,AstRule) :- AstRule = ast_rule(AstHead,_,_,AstBody,_), collect_head_constants(AstHead), collect_body_constants(AstBody,Constraints). collect_head_constants(simplification(H1)) :- maplist(collect_constraint_constants,H1). collect_head_constants(propagation(H2)) :- maplist(collect_constraint_constants,H2). collect_head_constants(simpagation(H1,H2)) :- maplist(collect_constraint_constants,H1), maplist(collect_constraint_constants,H2). collect_body_constants(AstBody,Constraints) :- maplist(collect_goal_constants(Constraints),AstBody). collect_goal_constants(Constraints,Goal) :- ( ast_nonvar(Goal) -> ast_symbol(Goal,Symbol), ( memberchk(Symbol,Constraints) -> ast_term_to_term(Goal,Term), ast_args(Goal,Arguments), collect_constraint_constants(chr_constraint(Symbol,Arguments,Term)) ; Symbol == (:)/2, ast_args(Goal,[Arg1,Goal2]), Arg1 = atomic(Mod), get_target_module(Module), Mod == Module, ast_nonvar(Goal2), ast_symbol(Goal2,Symbol2), memberchk(Symbol2,Constraints) -> ast_term_to_term(Goal2,Term2), ast_args(Goal2,Arguments2), collect_constraint_constants(chr_constraint(Symbol2,Arguments2,Term2)) ; true ) ; true ). collect_constraint_constants(Head) :- Head = chr_constraint(Symbol,Arguments,_), get_constraint_type_det(Symbol,Types), collect_all_arg_constants(Arguments,Types,[]). collect_all_arg_constants([],[],Constants) :- ( Constants \== [] -> add_chr_constants(Constants) ; true ). collect_all_arg_constants([Arg|Args],[Type|Types],Constants0) :- unalias_type(Type,NormalizedType), ( is_chr_constants_type(NormalizedType,Key,_) -> ( ast_ground(Arg) -> ast_term_to_term(Arg,Term), collect_all_arg_constants(Args,Types,[Key-Term|Constants0]) ; % no useful information here true ) ; collect_all_arg_constants(Args,Types,Constants0) ). add_chr_constants(Pairs) :- keysort(Pairs,SortedPairs), add_chr_constants_(SortedPairs). :- chr_constraint add_chr_constants_/1. :- chr_option(mode,add_chr_constants_(+)). add_chr_constants_(Constants), chr_constants(MoreConstants) <=> sort([Constants|MoreConstants],NConstants), chr_constants(NConstants). add_chr_constants_(Constants) <=> chr_constants([Constants]). % }}} :- chr_constraint print_chr_constants/0. % {{{ print_chr_constants, chr_constants(Constants) # Id ==> format('\t* chr_constants : ~w.\n',[Constants]) pragma passive(Id). print_chr_constants <=> true. % }}} % flattening_dictionary(+constraint_symbols,-dictionary) {{{ flattening_dictionary([],[]). flattening_dictionary([CS|CSs],Dictionary) :- ( flattening_dictionary_entry(CS,Entry) -> Dictionary = [Entry|Rest] ; Dictionary = Rest ), flattening_dictionary(CSs,Rest). flattening_dictionary_entry(CS,Entry) :- get_constraint_type_det(CS,Types), constant_positions(Types,1,Positions,Keys,Handler,MaybeEnum), ( Positions \== [] -> % there are chr_constant arguments pairup(Keys,Constants,Pairs0), keysort(Pairs0,Pairs), Entry = CS-Positions-Specs-Handler, get_chr_constants(ConstantsList), findall(Spec, ( member(Pairs,ConstantsList) , flat_spec(CS,Positions,Constants,Spec) ), Specs) ; MaybeEnum == yes -> enum_positions(Types,1,EnumPositions,ConstantsLists,EnumHandler), Entry = CS-EnumPositions-Specs-EnumHandler, findall(Spec, ( cartesian_product(Terms,ConstantsLists) , flat_spec(CS,EnumPositions,Terms,Spec) ), Specs) ). constant_positions([],_,[],[],no,no). constant_positions([Type|Types],I,Positions,Keys,Handler,MaybeEnum) :- unalias_type(Type,NormalizedType), ( is_chr_constants_type(NormalizedType,Key,ErrorHandler) -> compose_error_handlers(ErrorHandler,NHandler,Handler), Positions = [I|NPositions], Keys = [Key|NKeys], MaybeEnum = NMaybeEnum ; ( is_chr_enum_type(NormalizedType,_,_) -> MaybeEnum = yes ; MaybeEnum = NMaybeEnum ), NPositions = Positions, NKeys = Keys, NHandler = Handler ), J is I + 1, constant_positions(Types,J,NPositions,NKeys,NHandler,NMaybeEnum). compose_error_handlers(no,Handler,Handler). compose_error_handlers(yes(Handler),_,yes(Handler)). enum_positions([],_,[],[],no). enum_positions([Type|Types],I,Positions,ConstantsLists,Handler) :- unalias_type(Type,NormalizedType), ( is_chr_enum_type(NormalizedType,Constants,ErrorHandler) -> compose_error_handlers(ErrorHandler,NHandler,Handler), Positions = [I|NPositions], ConstantsLists = [Constants|NConstantsLists] ; Positions = NPositions, ConstantsLists = NConstantsLists, Handler = NHandler ), J is I + 1, enum_positions(Types,J,NPositions,NConstantsLists,NHandler). cartesian_product([],[]). cartesian_product([E|Es],[L|Ls]) :- member(E,L), cartesian_product(Es,Ls). flat_spec(C/N,Positions,Terms,Spec) :- Spec = Terms - Functor, term_to_atom(Terms,TermsAtom), term_to_atom(Positions,PositionsAtom), atom_concat_list(['$flat_',C,'/',N,'___',PositionsAtom,'___',TermsAtom],Functor). % }}} % }}} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % RESTART AFTER FLATTENING {{{ restart_after_flattening(Declarations,Declarations) :- nb_setval('$chr_restart_after_flattening',started). restart_after_flattening(_,Declarations) :- nb_getval('$chr_restart_after_flattening',restart(Declarations)), nb_setval('$chr_restart_after_flattening',restarted). not_restarted :- nb_getval('$chr_restart_after_flattening',started). install_new_declarations_and_restart(Declarations) :- nb_setval('$chr_restart_after_flattening',restart(Declarations)), fail. /* fails to choicepoint of restart_after_flattening */ % }}} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % FLATTENING {{{ % DONE % -) generate dictionary from collected chr_constants % enable with :- chr_option(experiment,on). % -) issue constraint declarations for constraints not present in % dictionary % -) integrate with CHR compiler % -) pass Mike's test code (full syntactic support for current CHR code) % -) rewrite the body using the inliner % % TODO: % -) refined semantics correctness issue % -) incorporate chr_enum into dictionary generation %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% flatten_clauses(Clauses,Dict,NClauses) :- flatten_readcontent(Clauses,Rules,Symbols,ModeDecls,_TypeDefs,TypeDecls,RestClauses), flatten_clauses_(Dict,Rules,RestClauses,Symbols,ModeDecls,TypeDecls,NClauses). flatten_clauses_(Dict,Clauses,RestClauses,Symbols,ModeDecls,TypeDecls,NClauses) :- auxiliary_constraints_declarations(Dict,ModeDecls,TypeDecls,NClauses0), dispatching_rules(Dict,NClauses1), declarations(Symbols,Dict,ModeDecls,TypeDecls,NClauses2), flatten_rules(Clauses,Dict,NClauses3), append([RestClauses,NClauses0,NClauses1,NClauses2,NClauses3],NClauses). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ % Declarations for non-flattened constraints % declarations(+constraint_symbols,+dict,+mode_decls,+type_decls,-clauses) {{{ declarations(ConstraintSymbols,Dict,ModeDecls,TypeDecls,Declarations) :- findall(Symbol,(member(Symbol,ConstraintSymbols), \+ memberchk(Symbol-_-_-_,Dict)),Symbols), maplist(declaration(ModeDecls,TypeDecls),Symbols,DeclarationsList), flatten(DeclarationsList,Declarations). declaration(ModeDecls,TypeDecls,ConstraintSymbol, [(:- chr_constraint ConstraintSymbol), (:- chr_option(mode,ModeDeclPattern)), (:- chr_option(type_declaration,TypeDeclPattern)) ]) :- ConstraintSymbol = Functor / Arity, % print optional mode declaration functor(ModeDeclPattern,Functor,Arity), ( memberchk(ModeDeclPattern,ModeDecls) -> true ; replicate(Arity,(?),Modes), ModeDeclPattern =.. [_|Modes] ), % print optional type declaration functor(TypeDeclPattern,Functor,Arity), ( memberchk(TypeDeclPattern,TypeDecls) -> true ; replicate(Arity,any,Types), TypeDeclPattern =.. [_|Types] ). % }}} %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ % read clauses from file % CHR are returned % declared constaints are returned % type definitions are returned and printed % mode declarations are returned % other clauses are returned % flatten_readcontent(+clauses,-rules,-symbols,-mode_decls,-type_defs,-type_decls,-rest_clauses) {{{ flatten_readcontent([],[],[],[],[],[],[]). flatten_readcontent([Clause|RClauses],Rules,ConstraintSymbols,ModeDecls,TypeDefs,TypeDecls,RestClauses) :- % read(Clause), ( Clause == end_of_file -> Rules = [], ConstraintSymbols = [], ModeDecls = [], TypeDecls = [], TypeDefs = [], RestClauses = [] ; crude_is_rule(Clause) -> Rules = [Clause|RestRules], flatten_readcontent(RClauses,RestRules,ConstraintSymbols,ModeDecls,TypeDefs,TypeDecls,RestClauses) ; pure_is_declaration(Clause,SomeConstraintSymbols,SomeModeDecls,SomeTypeDecls) -> append(SomeConstraintSymbols,RestConstraintSymbols,ConstraintSymbols), append(SomeModeDecls,RestModeDecls,ModeDecls), append(SomeTypeDecls,RestTypeDecls,TypeDecls), flatten_readcontent(RClauses,Rules,RestConstraintSymbols,RestModeDecls,TypeDefs,RestTypeDecls,RestClauses) ; is_mode_declaration(Clause,ModeDecl) -> ModeDecls = [ModeDecl|RestModeDecls], flatten_readcontent(RClauses,Rules,ConstraintSymbols,RestModeDecls,TypeDefs,TypeDecls,RestClauses) ; is_type_declaration(Clause,TypeDecl) -> TypeDecls = [TypeDecl|RestTypeDecls], flatten_readcontent(RClauses,Rules,ConstraintSymbols,ModeDecls,TypeDefs,RestTypeDecls,RestClauses) ; is_type_definition(Clause,TypeDef) -> RestClauses = [Clause|NRestClauses], TypeDefs = [TypeDef|RestTypeDefs], flatten_readcontent(RClauses,Rules,ConstraintSymbols,ModeDecls,RestTypeDefs,TypeDecls,NRestClauses) ; ( Clause = (:- op(A,B,C)) -> % assert operators in order to read and print them out properly op(A,B,C) ; true ), RestClauses = [Clause|NRestClauses], flatten_readcontent(RClauses,Rules,ConstraintSymbols,ModeDecls,TypeDefs,TypeDecls,NRestClauses) ). crude_is_rule((_ @ _)). crude_is_rule((_ pragma _)). crude_is_rule((_ ==> _)). crude_is_rule((_ <=> _)). pure_is_declaration(D, Constraints,Modes,Types) :- %% constraint declaration D = (:- Decl), Decl =.. [F,Cs], F == (chr_constraint), conj2list(Cs,Constraints0), pure_extract_type_mode(Constraints0,Constraints,Modes,Types). pure_extract_type_mode([],[],[],[]). pure_extract_type_mode([F/A|R],[F/A|R2],Modes,Types) :- !, pure_extract_type_mode(R,R2,Modes,Types). pure_extract_type_mode([C|R],[ConstraintSymbol|R2],[Mode|Modes],Types) :- functor(C,F,A), ConstraintSymbol = F/A, C =.. [_|Args], extract_types_and_modes(Args,ArgTypes,ArgModes), Mode =.. [F|ArgModes], ( forall(member(ArgType,ArgTypes),ArgType == any) -> Types = RTypes ; Types = [Type|RTypes], Type =.. [F|ArgTypes] ), pure_extract_type_mode(R,R2,Modes,RTypes). is_mode_declaration((:- chr_option(mode,ModeDecl)),ModeDecl). is_type_declaration((:- chr_option(type_declaration,TypeDecl)),TypeDecl). % }}} %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ % DECLARATIONS FOR FLATTENED CONSTRAINTS % including mode and type declarations % auxiliary_constraints_declarations(+dict,+mode_decls,+type_decls,-constraint_specs) {{{ auxiliary_constraints_declarations(Dict,ModeDecls,TypeDecls,ConstraintSpecs) :- findall(ConstraintSpec,auxiliary_constraints_declaration(Dict,ModeDecls,TypeDecls,ConstraintSpec),ConstraintSpecs0), flatten(ConstraintSpecs0,ConstraintSpecs). auxiliary_constraints_declaration(Dict,ModeDecls,TypeDecls, [(:- chr_constraint ConstraintSpec), (:- chr_option(mode,NewModeDecl)), (:- chr_option(type_declaration,NewTypeDecl))]) :- member(C/N-I-SFs-_,Dict), arg_modes(C,N,ModeDecls,Modes), specialize_modes(Modes,I,SpecializedModes), arg_types(C,N,TypeDecls,Types), specialize_types(Types,I,SpecializedTypes), length(I,IndexSize), AN is N - IndexSize, member(_Term-F,SFs), ConstraintSpec = F/AN, NewModeDecl =.. [F|SpecializedModes], NewTypeDecl =.. [F|SpecializedTypes]. arg_modes(C,N,ModeDecls,ArgModes) :- functor(ConstraintPattern,C,N), ( memberchk(ConstraintPattern,ModeDecls) -> ConstraintPattern =.. [_|ArgModes] ; replicate(N,?,ArgModes) ). specialize_modes(Modes,I,SpecializedModes) :- split_args(I,Modes,_,SpecializedModes). arg_types(C,N,TypeDecls,ArgTypes) :- functor(ConstraintPattern,C,N), ( memberchk(ConstraintPattern,TypeDecls) -> ConstraintPattern =.. [_|ArgTypes] ; replicate(N,any,ArgTypes) ). specialize_types(Types,I,SpecializedTypes) :- split_args(I,Types,_,SpecializedTypes). % }}} %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ % DISPATCHING RULES % % dispatching_rules(+dict,-newrules) % {{{ % This code generates a decision tree for calling the appropriate specialized % constraint based on the particular value of the argument the constraint % is being specialized on. % % In case an error handler is provided, the handler is called with the % unexpected constraint. dispatching_rules([],[]). dispatching_rules([CN-I-SFs-MaybeErrorHandler|Dict], DispatchingRules) :- constraint_dispatching_rule(SFs,CN,I,MaybeErrorHandler,DispatchingRules,RestDispatchingRules), dispatching_rules(Dict,RestDispatchingRules). constraint_dispatching_rule(SFs,C/N,I,MaybeErrorHandler,Rules,RestRules) :- ( increasing_numbers(I,1) -> /* index on first arguments */ Rules0 = Rules, NCN = C/N ; /* reorder arguments for 1st argument indexing */ functor(Head,C,N), Head =.. [_|Args], split_args(I,Args,GroundArgs,OtherArgs), append(GroundArgs,OtherArgs,ShuffledArgs), atom_concat(C,'_$shuffled',NC), Body =.. [NC|ShuffledArgs], [(Head :- Body)|Rules0] = Rules, NCN = NC / N ), Context = swap(C,I), dispatching_rule_term_cases(SFs,I,NCN,MaybeErrorHandler,Context,Rules0,RestRules). increasing_numbers([],_). increasing_numbers([X|Ys],X) :- Y is X + 1, increasing_numbers(Ys,Y). dispatching_rule_term_cases(SFs,I,NC/N,MaybeErrorHandler,Context,Rules,RestRules) :- length(I,IndexLength), once(pairup(TermLists,Functors,SFs)), maplist(head_tail,TermLists,Heads,Tails), Payload is N - IndexLength, maplist(wrap_in_functor(dispatching_action),Functors,Actions), dispatch_trie_index(Heads,Tails,Payload,MaybeErrorHandler,Context,Actions,NC,Rules,RestRules). dispatching_action(Functor,PayloadArgs,Goal) :- Goal =.. [Functor|PayloadArgs]. dispatch_trie_index(Patterns,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Prefix,Clauses,Tail) :- dispatch_trie_step(Patterns,Prefix,Prefix,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Clauses,Tail). dispatch_trie_step([],_,_,_,[],_,_,[],L,L) :- !. % length MorePatterns == length Patterns == length Results dispatch_trie_step(Patterns,Symbol,Prefix,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Clauses,T) :- MorePatterns = [List|_], length(List,N), aggregate_all(set(F/A), ( member(Pattern,Patterns), functor(Pattern,F,A) ), FAs), N1 is N + 1, dispatch_trie_step_cases(FAs,N1,Patterns,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Symbol,Prefix,Clauses,T). dispatch_trie_step_cases([],N,_,_,Payload,MaybeErrorHandler,Context,_,Symbol,_,Clauses0,Clauses) :- ( MaybeErrorHandler = yes(ErrorHandler) -> Clauses0 = [ErrorClause|Clauses], ErrorClause = (Head :- Body), Arity is N + Payload, functor(Head,Symbol,Arity), reconstruct_original_term(Context,Head,Term), Body =.. [ErrorHandler,Term] ; Clauses0 = Clauses ). dispatch_trie_step_cases([FA|FAs],N,Pattern,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Symbol,Prefix,Clauses,Tail) :- dispatch_trie_step_case(FA,N,Pattern,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Symbol,Prefix,Clauses,Clauses1), dispatch_trie_step_cases(FAs,N,Pattern,MorePatterns,Payload,MaybeErrorHandler,Context,Actions,Symbol,Prefix,Clauses1,Tail). dispatch_trie_step_case(F/A,N,Patterns,MorePatterns,Payload,MaybeErrorHandler,Context0,Actions,Symbol,Prefix,[Clause|List],Tail) :- Clause = (Head :- Cut, Body), ( MaybeErrorHandler = yes(_) -> Cut = (!) ; Cut = true ), /* Head = Symbol(IndexPattern,V2,...,Vn,Payload) */ N1 is N + Payload, functor(Head,Symbol,N1), arg(1,Head,IndexPattern), Head =.. [_,_|RestArgs], length(PayloadArgs,Payload), once(append(Vs,PayloadArgs,RestArgs)), /* IndexPattern = F(...) */ functor(IndexPattern,F,A), Context1 = index_functor(F,A,Context0), IndexPattern =.. [_|Args], append(Args,RestArgs,RecArgs), ( RecArgs == PayloadArgs -> /* nothing more to match on */ List = Tail, rec_cases(Patterns,_,Actions,F/A,_,_,MoreActions), MoreActions = [Action], call(Action,PayloadArgs,Body) ; /* more things to match on */ rec_cases(Patterns,MorePatterns,Actions,F/A,Cases,MoreCases,MoreActions), ( MoreActions = [OneMoreAction] -> /* only one more thing to match on */ MoreCases = [OneMoreCase], append([Cases,OneMoreCase,PayloadArgs],RecArgs), List = Tail, call(OneMoreAction,PayloadArgs,Body) ; /* more than one thing to match on */ /* [ x1,..., xn] [xs1,...,xsn] */ pairup(Cases,MoreCases,CasePairs), common_pattern(CasePairs,CommonPatternPair,DiffVars,Differences), append(Args,Vs,[First|Rest]), First-Rest = CommonPatternPair, Context2 = gct([First|Rest],Context1), fresh_symbol(Prefix,RSymbol), append(DiffVars,PayloadArgs,RecCallVars), Body =.. [RSymbol|RecCallVars], findall(CH-CT,member([CH|CT],Differences),CPairs), once(pairup(CHs,CTs,CPairs)), dispatch_trie_step(CHs,RSymbol,Prefix,CTs,Payload,MaybeErrorHandler,Context2,MoreActions,List,Tail) ) ). % split(list,int,before,at,after). split([X|Xs],I,Before,At,After) :- ( I == 1 -> Before = [], At = X, After = Xs ; J is I - 1, Before = [X|RBefore], split(Xs,J,RBefore,At,After) ). % reconstruct_original_term(Context,CurrentTerm,OriginalTerm) % % context ::= swap(functor,positions) % | index_functor(functor,arity,context) % | gct(Pattern,Context) reconstruct_original_term(swap(Functor,Positions),Term,OriginalTerm) :- functor(Term,_,Arity), functor(OriginalTerm,Functor,Arity), OriginalTerm =.. [_|OriginalArgs], split_args(Positions,OriginalArgs,IndexArgs,OtherArgs), Term =.. [_|Args], append(IndexArgs,OtherArgs,Args). reconstruct_original_term(index_functor(Functor,Arity,Context),Term0,OriginalTerm) :- Term0 =.. [Predicate|Args], split_at(Arity,Args,IndexArgs,RestArgs), Index =.. [Functor|IndexArgs], Term1 =.. [Predicate,Index|RestArgs], reconstruct_original_term(Context,Term1,OriginalTerm). reconstruct_original_term(gct(PatternList,Context),Term0,OriginalTerm) :- copy_term_nat(PatternList,IndexTerms), term_variables(IndexTerms,Variables), Term0 =.. [Predicate|Args0], append(Variables,RestArgs,Args0), append(IndexTerms,RestArgs,Args1), Term1 =.. [Predicate|Args1], reconstruct_original_term(Context,Term1,OriginalTerm). % }}} %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ % SUBSTITUTE CONSTRAINT SYMBOL FUNCTORS % % flatten_rules(+rule_clauses,+dict,-rule_clauses). % % dict :== list(functor/arity-list(int)-list(list(term)-functor)-maybe(error_handler)) % {{{ flatten_rules(Rules,Dict,FlatRules) :- flatten_rules1(Rules,Dict,FlatRulesList), flatten(FlatRulesList,FlatRules). flatten_rules1([],_,[]). flatten_rules1([Rule|Rules],Dict,[FlatRules|FlatRulesList]) :- findall(FlatRule,flatten_rule(Rule,Dict,FlatRule),FlatRules), flatten_rules1(Rules,Dict,FlatRulesList). flatten_rule((Name @ Rule),Dict,(Name @ NRule)) :- !, flatten_rule(Rule,Dict,NRule). flatten_rule((Rule pragma Pragmas),Dict,(NRule pragma Pragmas)) :- !, flatten_rule(Rule,Dict,NRule). flatten_rule((H ==> B),Dict,(NH ==> NB)) :- !, flatten_heads(H,Dict,NH), flatten_body(B,Dict,NB). flatten_rule((H1 \ H2 <=> B),Dict,(NH1 \ NH2 <=> NB)) :- !, flatten_heads((H1,H2),Dict,(NH1,NH2)), flatten_body(B,Dict,NB). flatten_rule((H <=> B),Dict,(NH <=> NB)) :- flatten_heads(H,Dict,NH), flatten_body(B,Dict,NB). flatten_heads((H1,H2),Dict,(NH1,NH2)) :- !, flatten_heads(H1,Dict,NH1), flatten_heads(H2,Dict,NH2). flatten_heads((H # Annotation),Dict,(NH # Annotation)) :- !, flatten_heads(H,Dict,NH). flatten_heads(H,Dict,NH) :- ( functor(H,C,N), memberchk(C/N-ArgPositions-SFs-_,Dict) -> H =.. [_|AllArgs], split_args(ArgPositions,AllArgs,GroundArgs,OtherArgs), member(GroundArgs-Name,SFs), NH =.. [Name|OtherArgs] ; NH = H ). flatten_body((Guard | Body),Dict,(NGuard | NBody)) :- !, conj2list(Guard,Guards), maplist(flatten_goal(Dict),Guards,NGuards), list2conj(NGuards,NGuard), conj2list(Body,Goals), maplist(flatten_goal(Dict),Goals,NGoals), list2conj(NGoals,NBody). flatten_body(Body,Dict,NBody) :- conj2list(Body,Goals), maplist(flatten_goal(Dict),Goals,NGoals), list2conj(NGoals,NBody). flatten_goal(Dict,Goal,NGoal) :- var(Goal), !, NGoal = Goal. flatten_goal(Dict,Goal,NGoal) :- ( is_specializable_goal(Goal,Dict,ArgPositions) -> specialize_goal(Goal,ArgPositions,NGoal) ; Goal = Mod : TheGoal, get_target_module(Module), Mod == Module, nonvar(TheGoal), is_specializable_goal(TheGoal,Dict,ArgPositions) -> specialize_goal(TheGoal,ArgPositions,NTheGoal), NGoal = Mod : NTheGoal ; partial_eval(Goal,NGoal) -> true ; NGoal = Goal ). %-------------------------------------------------------------------------------% % Specialize body/guard goal %-------------------------------------------------------------------------------% is_specializable_goal(Goal,Dict,ArgPositions) :- functor(Goal,C,N), memberchk(C/N-ArgPositions-_-_,Dict), args(ArgPositions,Goal,Args), ground(Args). specialize_goal(Goal,ArgPositions,NGoal) :- functor(Goal,C,N), Goal =.. [_|Args], split_args(ArgPositions,Args,GroundTerms,Others), flat_spec(C/N,ArgPositions,GroundTerms,_-Functor), NGoal =.. [Functor|Others]. %-------------------------------------------------------------------------------% % Partially evaluate predicates %-------------------------------------------------------------------------------% % append([],Y,Z) >--> Y = Z % append(X,[],Z) >--> X = Z partial_eval(append(L1,L2,L3),NGoal) :- ( L1 == [] -> NGoal = (L3 = L2) ; L2 == [] -> NGoal = (L3 = L1) ). % flatten_path(L1,L2) >--> flatten_path(L1',L2) % where flatten(L1,L1') partial_eval(flatten_path(L1,L2),NGoal) :- nonvar(L1), flatten(L1,FlatterL1), FlatterL1 \== L1 -> NGoal = flatten_path(FlatterL1,L2). % }}} % }}} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% dump_code(Clauses) :- ( chr_pp_flag(dump,on) -> maplist(portray_clause,Clauses) ; true ). chr_banner :- chr_info(banner,'\tThe K.U.Leuven CHR System\n\t\tMain Developer:\tTom Schrijvers\n\t\tContributors:\tJon Sneyers, Bart Demoen, Jan Wielemaker\n\t\tCopyright:\tK.U.Leuven, Belgium\n\t\tURL:\t\thttp://www.cs.kuleuven.be/~~toms/CHR/\n',[]). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % LOCKING {{{ chr_none_locked(Vars,Goal) :- chr_pp_flag(guard_locks,Flag), ( Flag == off -> Goal = true ; Flag == on -> Goal = 'chr none_locked'( Vars) ; Flag == error -> Goal = 'chr none_error_locked'( Vars) ). chr_not_locked(Var,Goal) :- chr_pp_flag(guard_locks,Flag), ( Flag == off -> Goal = true ; Flag == on -> Goal = 'chr not_locked'( Var) ; Flag == error -> Goal = 'chr not_error_locked'( Var) ). chr_lock(Var,Goal) :- chr_pp_flag(guard_locks,Flag), ( Flag == off -> Goal = true ; Flag == on -> Goal = 'chr lock'( Var) ; Flag == error -> Goal = 'chr error_lock'( Var) ). chr_unlock(Var,Goal) :- chr_pp_flag(guard_locks,Flag), ( Flag == off -> Goal = true ; Flag == on -> Goal = 'chr unlock'( Var) ; Flag == error -> Goal = 'chr unerror_lock'( Var) ). % }}} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % AST representation % each AST representation caches the original term % % ast_term ::= atomic(Term) % | compound(Functor,Arity,list(ast_term),Term) % | var(int,Term) % -- unique integer identifier % Conversion Predicate {{{ :- chr_type var_id == natural. term_to_ast_term(Term,AstTerm,VarEnv,NVarEnv) :- ( atomic(Term) -> AstTerm = atomic(Term), NVarEnv = VarEnv ; compound(Term) -> functor(Term,Functor,Arity), AstTerm = compound(Functor,Arity,AstTerms,Term), Term =.. [_|Args], maplist_dcg(chr_translate:term_to_ast_term,Args,AstTerms,VarEnv,NVarEnv) ; var(Term) -> var_to_ast_term(Term,VarEnv,AstTerm,NVarEnv) ). var_to_ast_term(Var,Env,AstTerm,NVarEnv) :- Env = VarDict - VarId, ( lookup_eq(VarDict,Var,AstTerm) -> NVarEnv = Env ; AstTerm = var(VarId,Var), NVarId is VarId + 1, NVarDict = [Var - AstTerm|VarDict], NVarEnv = NVarDict - NVarId ). % ast_constraint ::= chr_constraint(Symbol,Arguments,Constraint) chr_constraint_to_ast_constraint(CHRConstraint,AstConstraint,VarEnv,NVarEnv) :- AstConstraint = chr_constraint(Functor/Arity,AstTerms,CHRConstraint), functor(CHRConstraint,Functor,Arity), CHRConstraint =.. [_|Arguments], maplist_dcg(chr_translate:term_to_ast_term,Arguments,AstTerms,VarEnv,NVarEnv). % ast_head ::= simplification(list(chr_constraint)) % | propagation(list(chr_constraint)) % | simpagation(list(chr_constraint),list(chr_constraint)) % head_id ::= int % ast_guard ::= list(ast_term) % ast_body ::= list(ast_term) % ast_rule ::= ast_rule(ast_head,ast_guard,guard,ast_body,body) rule_to_ast_rule(Rule,AstRule) :- AstRule = ast_rule(Head,AstGuard,Guard,AstBody,Body), Rule = rule(H1,H2,Guard,Body), EmptyVarEnv = []-1, ( H1 == [] -> Head = propagation(AstConstraints), maplist_dcg(chr_translate:chr_constraint_to_ast_constraint,H2,AstConstraints,EmptyVarEnv,VarEnv1) ; H2 == [] -> Head = simplification(AstConstraints), maplist_dcg(chr_translate:chr_constraint_to_ast_constraint,H1,AstConstraints,EmptyVarEnv,VarEnv1) ; Head = simpagation(RemovedAstConstraints,KeptAstConstraints), maplist_dcg(chr_translate:chr_constraint_to_ast_constraint,H1,RemovedAstConstraints,EmptyVarEnv,VarEnv0), maplist_dcg(chr_translate:chr_constraint_to_ast_constraint,H2,KeptAstConstraints,VarEnv0,VarEnv1) ), conj2list(Guard,GuardList), maplist_dcg(chr_translate:term_to_ast_term,GuardList,AstGuard,VarEnv1,VarEnv2), conj2list(Body,BodyList), maplist_dcg(chr_translate:term_to_ast_term,BodyList,AstBody,VarEnv2,_). pragma_rule_to_ast_rule(pragma(Rule,_,_,_,_),AstRule) :- rule_to_ast_rule(Rule,AstRule). check_rule_to_ast_rule(Rule) :- ( rule_to_ast_rule(Rule,AstRule) -> writeln(AstRule) ; writeln(failed(rule_to_ast_rule(Rule,AstRule))) ). % }}} % AST Utility Predicates {{{ ast_term_to_term(var(_,Var),Var). ast_term_to_term(atomic(Atom),Atom). ast_term_to_term(compound(_,_,_,Compound),Compound). ast_nonvar(atomic(_)). ast_nonvar(compound(_,_,_,_)). ast_ground(atomic(_)). ast_ground(compound(_,_,Arguments,_)) :- maplist(ast_ground,Arguments). %------------------------------------------------------------------------------% % Check whether a term is ground, given a set of variables that are ground. %------------------------------------------------------------------------------% ast_is_ground(VarSet,AstTerm) :- ast_is_ground_(AstTerm,VarSet). ast_is_ground_(var(VarId,_),VarSet) :- tree_set_memberchk(VarId,VarSet). ast_is_ground_(atomic(_),_). ast_is_ground_(compound(_,_,Arguments,_),VarSet) :- maplist(ast_is_ground(VarSet),Arguments). %------------------------------------------------------------------------------% ast_functor(atomic(Atom),Atom,0). ast_functor(compound(Functor,Arity,_,_),Functor,Arity). ast_symbol(atomic(Atom),Atom/0). ast_symbol(compound(Functor,Arity,_,_),Functor/Arity). ast_args(atomic(_),[]). ast_args(compound(_,_,Arguments,_),Arguments). %------------------------------------------------------------------------------% % Add variables in a term to a given set. %------------------------------------------------------------------------------% ast_term_variables(atomic(_),Set,Set). ast_term_variables(compound(_,_,Args,_),Set,NSet) :- ast_term_list_variables(Args,Set,NSet). ast_term_variables(var(VarId,_),Set,NSet) :- tree_set_add(Set,VarId,NSet). ast_term_list_variables(Terms,Set,NSet) :- fold(Terms,chr_translate:ast_term_variables,Set,NSet). %------------------------------------------------------------------------------% ast_constraint_variables(chr_constraint(_,Args,_),Set,NSet) :- ast_term_list_variables(Args,Set,NSet). ast_constraint_list_variables(Constraints,Set,NSet) :- fold(Constraints,chr_translate:ast_constraint_variables,Set,NSet). ast_head_variables(simplification(H1),Set,NSet) :- ast_constraint_list_variables(H1,Set,NSet). ast_head_variables(propagation(H2),Set,NSet) :- ast_constraint_list_variables(H2,Set,NSet). ast_head_variables(simpagation(H1,H2),Set,NSet) :- ast_constraint_list_variables(H1,Set,Set1), ast_constraint_list_variables(H2,Set1,NSet). ast_var_memberchk(var(VarId,_),Set) :- tree_set_memberchk(VarId,Set). %------------------------------------------------------------------------------% % Return term based on AST-term with variables mapped. %------------------------------------------------------------------------------% ast_instantiate(Map,AstTerm,Term) :- ast_instantiate_(AstTerm,Map,Term). ast_instantiate_(var(VarId,_),Map,Term) :- get_assoc(VarId,Map,Term). ast_instantiate_(atomic(Atom),_,Atom). ast_instantiate_(compound(Functor,Arity,Arguments,_),Map,Term) :- functor(Term,Functor,Arity), Term =.. [_|Terms], maplist(ast_instantiate(Map),Arguments,Terms). %------------------------------------------------------------------------------% % }}} %------------------------------------------------------------------------------% % ast_head_arg_matches_(list(silent_pair(ast_term,var) % ,modes % ,map(var_id,...) % ,set(variables) % ,list(goal) % ,vardict % ,set(variables) % ) %------------------------------------------------------------------------------% ast_head_arg_matches_([],[],VarDict,GroundVars,[],VarDict,GroundVars). ast_head_arg_matches_([silent(Arg-Var)| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :- !, ( Mode == (+) -> ast_term_variables(Arg,GroundVars0,GroundVars), ast_head_arg_matches_(Rest,Modes,VarDict,GroundVars0,GoalList,NVarDict,NGroundVars) ; ast_head_arg_matches_(Rest,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars) ). ast_head_arg_matches_([Arg-Var| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :- ( Arg = var(VarId,_) -> ( get_assoc(VarId,VarDict,OtherVar) -> ( Mode = (+) -> ( tree_set_memberchk(VarId,GroundVars) -> GoalList = [Var = OtherVar | RestGoalList], GroundVars1 = GroundVars ; GoalList = [Var == OtherVar | RestGoalList], tree_set_add(GroundVars,VarId,GroundVars1) ) ; GoalList = [Var == OtherVar | RestGoalList], GroundVars1 = GroundVars ), VarDict1 = VarDict ; put_assoc(VarId,VarDict,Var,VarDict1), GoalList = RestGoalList, ( Mode = (+) -> tree_set_add(GroundVars,VarId,GroundVars1) ; GroundVars1 = GroundVars ) ), Pairs = Rest, RestModes = Modes ; ground(Arg), Arg = '$chr_identifier_match'(ActualArg,IndexType) -> % TODO identifier_label_atom(IndexType,Var,ActualArg,Goal), GoalList = [Goal|RestGoalList], VarDict = VarDict1, GroundVars1 = GroundVars, Pairs = Rest, RestModes = Modes ; Arg = atomic(Atom) -> ( Mode = (+) -> GoalList = [ Var = Atom | RestGoalList] ; GoalList = [ Var == Atom | RestGoalList] ), VarDict = VarDict1, GroundVars1 = GroundVars, Pairs = Rest, RestModes = Modes ; Mode == (+), ast_is_ground(GroundVars,Arg) -> ast_instantiate(VarDict,Arg,ArgInst), GoalList = [ Var = ArgInst | RestGoalList], VarDict = VarDict1, GroundVars1 = GroundVars, Pairs = Rest, RestModes = Modes ; Mode == (?), ast_is_ground(GroundVars,Arg) -> ast_instantiate(VarDict,Arg,ArgInst), GoalList = [ Var == ArgInst | RestGoalList], VarDict = VarDict1, GroundVars1 = GroundVars, Pairs = Rest, RestModes = Modes ; Arg = compound(Functor,Arity,Arguments,_), functor(Term,Functor,Arity), Term =.. [_|Vars], ( Mode = (+) -> GoalList = [ Var = Term | RestGoalList ] ; GoalList = [ nonvar(Var), Var = Term | RestGoalList ] ), pairup(Arguments,Vars,NewPairs), append(NewPairs,Rest,Pairs), replicate(N,Mode,NewModes), append(NewModes,Modes,RestModes), VarDict1 = VarDict, GroundVars1 = GroundVars ), ast_head_arg_matches_(Pairs,RestModes,VarDict1,GroundVars1,RestGoalList,NVarDict,NGroundVars).