11456 lines
367 KiB
Plaintext
11456 lines
367 KiB
Plaintext
/* $Id$
|
|
|
|
Part of CHR (Constraint Handling Rules)
|
|
|
|
Author: Tom Schrijvers
|
|
E-mail: Tom.Schrijvers@cs.kuleuven.be
|
|
WWW: http://www.swi-prolog.org
|
|
Copyright (C): 2003-2004, K.U. Leuven
|
|
|
|
This program is free software; you can redistribute it and/or
|
|
modify it under the terms of the GNU General Public License
|
|
as published by the Free Software Foundation; either version 2
|
|
of the License, or (at your option) any later version.
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
GNU General Public License for more details.
|
|
|
|
You should have received a copy of the GNU Lesser General Public
|
|
License along with this library; if not, write to the Free Software
|
|
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
|
|
|
As a special exception, if you link this library with other files,
|
|
compiled with a Free Software compiler, to produce an executable, this
|
|
library does not by itself cause the resulting executable to be covered
|
|
by the GNU General Public License. This exception does not however
|
|
invalidate any other reasons why the executable file might be covered by
|
|
the GNU General Public License.
|
|
*/
|
|
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
%%
|
|
%% ____ _ _ ____ ____ _ _
|
|
%% / ___| | | | _ \ / ___|___ _ __ ___ _ __ (_) | ___ _ __
|
|
%% | | | |_| | |_) | | | / _ \| '_ ` _ \| '_ \| | |/ _ \ '__|
|
|
%% | |___| _ | _ < | |__| (_) | | | | | | |_) | | | __/ |
|
|
%% \____|_| |_|_| \_\ \____\___/|_| |_| |_| .__/|_|_|\___|_|
|
|
%% |_|
|
|
%%
|
|
%% hProlog CHR compiler:
|
|
%%
|
|
%% * by Tom Schrijvers, K.U. Leuven, Tom.Schrijvers@cs.kuleuven.be
|
|
%%
|
|
%% * based on the SICStus CHR compilation by Christian Holzbaur
|
|
%%
|
|
%% First working version: 6 June 2003
|
|
%%
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
%%
|
|
%% 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),[member/2, append/3,reverse/2,permutation/2,last/2]).
|
|
:- 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(pairlist).
|
|
:- use_module(a_star).
|
|
:- use_module(listmap).
|
|
:- use_module(clean_code).
|
|
:- use_module(builtins).
|
|
:- use_module(find).
|
|
:- use_module(binomialheap).
|
|
:- use_module(guard_entailment).
|
|
:- use_module(chr_compiler_options).
|
|
:- use_module(chr_compiler_utility).
|
|
:- use_module(chr_compiler_errors).
|
|
:- include(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_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 line_number/2.
|
|
:- chr_option(mode,line_number(+,+)).
|
|
:- chr_option(type_declaration,line_number(rule_nb,int)).
|
|
%------------------------------------------------------------------------------%
|
|
line_number(RuleNb,LineNb) \ line_number(RuleNb,LineNumber) <=> true.
|
|
|
|
%------------------------------------------------------------------------------%
|
|
:- chr_constraint get_line_number/2.
|
|
:- chr_option(mode,get_line_number(+,-)).
|
|
:- chr_option(type_declaration,get_line_number(rule_nb,int)).
|
|
%------------------------------------------------------------------------------%
|
|
line_number(RuleNb,LineNb) \ get_line_number(RuleNb,Q) <=> Q = LineNb.
|
|
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(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 = line_number(LineNumber),
|
|
!,
|
|
PragmaRule = pragma(_,_,_,_,RuleNb),
|
|
line_number(RuleNb,LineNumber).
|
|
|
|
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,LineNumber),
|
|
write(' (line '),
|
|
write(LineNumber),
|
|
write(')').
|
|
|
|
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 debug_event'(wake(Suspension)),
|
|
call(Continuation)
|
|
;
|
|
'chr debug_event'(fail(Suspension)), !,
|
|
fail
|
|
),
|
|
(
|
|
'chr debug_event'(exit(Suspension))
|
|
;
|
|
'chr debug_event'(redo(Suspension)),
|
|
fail
|
|
),
|
|
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.
|
|
|
|
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),
|
|
% Do not rename or the 'chr_initialization' predicate
|
|
% without warning SSS
|
|
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('<id:'),
|
|
print(Label2),
|
|
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('<id:'),
|
|
print(Label2),
|
|
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, % hash_term(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
|
|
% hash_term/2 predicate:
|
|
% the hash value is stable over repeated invocations
|
|
% of SWI-Prolog
|
|
hash_term(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 = [].
|
|
|
|
%% SWI begin
|
|
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
|
|
]
|
|
).
|
|
%% SWI end
|
|
%% SICStus begin
|
|
% prolog_global_variables_code([]).
|
|
%% SICStus end
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
%sbag_member_call(S,L,sysh:mem(S,L)).
|
|
sbag_member_call(S,L,'chr sbag_member'(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(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_chk(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(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) <=>
|
|
functor(T,F,A),
|
|
functor(T2,F,A),
|
|
copy_term((T,T2),(X,Y)), subsumes(X,Y)
|
|
|
|
|
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(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 debug_event'(call(Susp)),
|
|
Delegate
|
|
;
|
|
'chr debug_event'(fail(Susp)), !,
|
|
fail
|
|
),
|
|
(
|
|
'chr debug_event'(exit(Susp))
|
|
;
|
|
'chr debug_event'(redo(Susp)),
|
|
fail
|
|
)
|
|
)
|
|
; 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_chr_source_file(File),
|
|
get_line_number(RuleNb,LineNb),
|
|
NClause = '$source_location'(File,LineNb):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) :-
|
|
concat_atom(['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).
|