3 Part of CHR (Constraint Handling Rules)
6 E-mail: Tom.Schrijvers@cs.kuleuven.be
7 WWW: http://www.swi-prolog.org
8 Copyright (C): 2003-2004, K.U. Leuven
10 This program is free software; you can redistribute it and/or
11 modify it under the terms of the GNU General Public License
12 as published by the Free Software Foundation; either version 2
13 of the License, or (at your option) any later version.
15 This program is distributed in the hope that it will be useful,
16 but WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 GNU General Public License for more details.
20 You should have received a copy of the GNU Lesser General Public
21 License along with this library; if not, write to the Free Software
22 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
24 As a special exception, if you link this library with other files,
25 compiled with a Free Software compiler, to produce an executable, this
26 library does not by itself cause the resulting executable to be covered
27 by the GNU General Public License. This exception does not however
28 invalidate any other reasons why the executable file might be covered by
29 the GNU General Public License.
32 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
34 %% ____ _ _ ____ ____ _ _
35 %% / ___| | | | _ \ / ___|___ _ __ ___ _ __ (_) | ___ _ __
36 %% | | | |_| | |_) | | | / _ \| '_ ` _ \| '_ \| | |/ _ \ '__|
37 %% | |___| _ | _ < | |__| (_) | | | | | | |_) | | | __/ |
38 %% \____|_| |_|_| \_\ \____\___/|_| |_| |_| .__/|_|_|\___|_|
41 %% hProlog CHR compiler:
43 %% * by Tom Schrijvers, K.U. Leuven, Tom.Schrijvers@cs.kuleuven.be
45 %% * based on the SICStus CHR compilation by Christian Holzbaur
47 %% First working version: 6 June 2003
49 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
53 %% * add groundness info to a.i.-based observation analysis
54 %% * proper fd/index analysis
55 %% * re-add generation checking
56 %% * untangle CHR-level and traget source-level generation & optimization
58 %% AGGRESSIVE OPTIMISATION IDEAS
60 %% * success continuation optimization
61 %% * analyze history usage to determine whether/when
62 %% cheaper suspension is possible:
63 %% don't use history when all partners are passive and self never triggers
64 %% * store constraint unconditionally for unconditional propagation rule,
65 %% if first, i.e. without checking history and set trigger cont to next occ
66 %% * get rid of suspension passing for never triggered constraints,
67 %% up to allocation occurrence
68 %% * get rid of call indirection for never triggered constraints
69 %% up to first allocation occurrence.
70 %% * get rid of unnecessary indirection if last active occurrence
71 %% before unconditional removal is head2, e.g.
74 %% * Eliminate last clause of never stored constraint, if its body
76 %% * Specialize lookup operations and indexes for functional dependencies.
80 %% * generate code to empty all constraint stores of a module (Bart Demoen)
81 %% * map A \ B <=> true | true rules
82 %% onto efficient code that empties the constraint stores of B
83 %% in O(1) time for ground constraints where A and B do not share
85 %% * ground matching seems to be not optimized for compound terms
86 %% in case of simpagation_head2 and propagation occurrences
87 %% * Do not unnecessarily generate store operations.
88 %% * analysis for storage delaying (see primes for case)
89 %% * internal constraints declaration + analyses?
90 %% * Do not store in global variable store if not necessary
91 %% NOTE: affects show_store/1
92 %% * multi-level store: variable - ground
93 %% * Do not maintain/check unnecessary propagation history
94 %% for reasons of anti-monotony
95 %% * Strengthen storage analysis for propagation rules
96 %% reason about bodies of rules only containing constraints
97 %% -> fixpoint with observation analysis
98 %% * instantiation declarations
99 %% VARIABLE (never bound) (-)
100 %% specialize via_1 and others to a compile time unification
101 %% COMPOUND (bound to nonvar)
102 %% avoid nonvar tests
104 %% * make difference between cheap guards for reordering
105 %% and non-binding guards for lock removal
106 %% * unqiue -> once/[] transformation for propagation
107 %% * cheap guards interleaved with head retrieval + faster
108 %% via-retrieval + non-empty checking for propagation rules
109 %% redo for simpagation_head2 prelude
110 %% * intelligent backtracking for simplification/simpagation rule
111 %% generator_1(X),'_$savecp'(CP_1),
118 %% ('_$cutto'(CP_1), fail)
122 %% or recently developped cascading-supported approach
123 %% * intelligent backtracking for propagation rule
124 %% use additional boolean argument for each possible smart backtracking
125 %% when boolean at end of list true -> no smart backtracking
126 %% false -> smart backtracking
127 %% only works for rules with at least 3 constraints in the head
128 %% * (set semantics + functional dependency) declaration + resolution
131 %% * identify cases where prefixes of partner lookups for subsequent occurrences can be
134 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
135 :- module(chr_translate,
136 [ chr_translate/2 % +Decls, -TranslatedDecls
139 :- use_module(library(lists),[member/2, append/3,reverse/2,permutation/2,last/2]).
140 :- use_module(library(ordsets)).
143 :- use_module(hprolog).
144 :- use_module(pairlist).
145 :- use_module(a_star).
146 :- use_module(listmap).
147 :- use_module(clean_code).
148 :- use_module(builtins).
150 :- use_module(guard_entailment).
151 :- use_module(chr_compiler_options).
152 :- use_module(chr_compiler_utility).
153 :- use_module(chr_compiler_errors).
155 :- op(1150, fx, chr_type).
156 :- op(1130, xfx, --->).
160 :- op(1150, fx, constraints).
161 :- op(1150, fx, chr_constraint).
163 :- chr_option(debug,off).
164 :- chr_option(optimize,full).
166 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
168 target_module/1, % target_module(Module)
171 indexed_argument/2, % argument instantiation may enable applicability of rule
172 is_indexed_argument/2,
175 get_constraint_mode/2,
178 only_ground_indexed_arguments/1,
179 none_suspended_on_variables/0,
180 are_none_suspended_on_variables/0,
185 actual_store_types/2,
186 assumed_store_type/2,
187 validate_store_type_assumption/1,
199 get_occurrence_from_id/4,
202 get_max_occurrence/2,
204 allocation_occurrence/2,
205 get_allocation_occurrence/2,
209 is_least_occurrence/1
212 :- chr_option(check_guard_bindings,off).
214 :- chr_option(mode,target_module(+)).
215 :- chr_option(mode,indexed_argument(+,+)).
216 :- chr_option(mode,constraint_mode(+,+)).
217 :- chr_option(mode,may_trigger(+)).
218 :- chr_option(mode,store_type(+,+)).
219 :- chr_option(mode,actual_store_types(+,+)).
220 :- chr_option(mode,assumed_store_type(+,+)).
221 :- chr_option(mode,rule_count(+)).
222 :- chr_option(mode,passive(+,+)).
223 :- chr_option(mode,occurrence(+,+,+,+,+)).
224 :- chr_option(mode,max_occurrence(+,+)).
225 :- chr_option(mode,allocation_occurrence(+,+)).
226 :- chr_option(mode,rule(+,+)).
227 :- chr_option(mode,least_occurrence(+,+)).
228 :- chr_option(mode,is_least_occurrence(+)).
230 :- chr_option(type_definition,type(list,[ [], [any|list] ])).
231 :- chr_option(type_definition,type(constraint,[ any / any ])).
233 :- chr_option(type_declaration,constraint_mode(constraint,list)).
235 target_module(_) \ target_module(_) <=> true.
236 target_module(Mod) \ get_target_module(Query)
238 get_target_module(Query)
241 indexed_argument(FA,I) \ indexed_argument(FA,I) <=> true.
242 indexed_argument(FA,I) \ is_indexed_argument(FA,I) <=> true.
243 is_indexed_argument(_,_) <=> fail.
245 %%% C O N S T R A I N T M O D E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
247 constraint_mode(FA,_) \ constraint_mode(FA,_) <=> true.
248 constraint_mode(FA,Mode) \ get_constraint_mode(FA,Q) <=>
250 get_constraint_mode(FA,Q) <=>
254 %%% M A Y T R I G G E R %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
256 may_trigger(FA) <=> \+ has_active_occurrence(FA) | fail.
257 constraint_mode(FA,Mode), indexed_argument(FA,I) \ may_trigger(FA) <=>
261 may_trigger(FA) <=> chr_pp_flag(debugable,on). % in debug mode, we assume everything can be triggered
263 constraint_mode(FA,Mode), indexed_argument(FA,I) \ only_ground_indexed_arguments(FA)
269 only_ground_indexed_arguments(_) <=>
272 none_suspended_on_variables \ none_suspended_on_variables <=> true.
273 none_suspended_on_variables \ are_none_suspended_on_variables <=> true.
274 are_none_suspended_on_variables <=> fail.
275 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
277 store_type(FA,atom_hash(Index)) <=> store_type(FA,multi_hash([Index])).
278 store_type(FA,Store) \ get_store_type(FA,Query)
280 assumed_store_type(FA,Store) \ get_store_type(FA,Query)
282 get_store_type(_,Query)
285 actual_store_types(C,STs) \ update_store_type(C,ST)
286 <=> member(ST,STs) | true.
287 update_store_type(C,ST), actual_store_types(C,STs)
289 actual_store_types(C,[ST|STs]).
290 update_store_type(C,ST)
292 actual_store_types(C,[ST]).
294 % refine store type assumption
295 validate_store_type_assumption(C), actual_store_types(C,STs), assumed_store_type(C,_) % automatic assumption
297 store_type(C,multi_store(STs)).
298 validate_store_type_assumption(C), actual_store_types(C,STs), store_type(C,_) % user assumption
300 store_type(C,multi_store(STs)).
301 validate_store_type_assumption(C), assumed_store_type(C,_) % no lookups on constraint in debug mode
303 chr_pp_flag(debugable,on)
305 store_type(C,default).
306 validate_store_type_assumption(C), assumed_store_type(C,_) % no lookups on constraint
307 <=> store_type(C,global_ground).
308 validate_store_type_assumption(C)
311 rule_count(C), inc_rule_count(NC)
312 <=> NC is C + 1, rule_count(NC).
314 <=> NC = 1, rule_count(NC).
316 %%% P A S S I V E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
317 passive(R,ID) \ passive(R,ID) <=> true.
319 passive(RuleNb,ID) \ is_passive(RuleNb,ID) <=> true.
320 is_passive(_,_) <=> fail.
322 passive(RuleNb,_) \ any_passive_head(RuleNb)
326 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
328 max_occurrence(C,N) \ max_occurrence(C,M)
331 max_occurrence(C,MO), new_occurrence(C,RuleNb,ID,Type) <=>
333 occurrence(C,NO,RuleNb,ID,Type),
334 max_occurrence(C,NO).
335 new_occurrence(C,RuleNb,ID,_) <=>
336 chr_error(internal,'new_occurrence: missing max_occurrence for ~w in rule ~w\n',[C,RuleNb]).
338 max_occurrence(C,MON) \ get_max_occurrence(C,Q)
340 get_max_occurrence(C,Q)
341 <=> chr_error(internal,'get_max_occurrence: missing max occurrence for ~w\n',[C]).
343 occurrence(C,ON,Rule,ID,_) \ get_occurrence(C,ON,QRule,QID)
344 <=> Rule = QRule, ID = QID.
345 get_occurrence(C,O,_,_)
346 <=> chr_error(internal,'get_occurrence: missing occurrence ~w:~w\n',[C,O]).
348 occurrence(C,ON,Rule,ID,_) \ get_occurrence_from_id(C,QON,Rule,ID)
350 get_occurrence_from_id(C,O,_,_)
351 <=> chr_error(internal,'get_occurrence_from_id: missing occurrence ~w:~w\n',[]).
353 % A L L O C C A T I O N O C C U R R E N C E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
355 % cannot store constraint at passive occurrence
356 occurrence(C,O,RuleNb,ID,_), passive(RuleNb,ID) \ allocation_occurrence(C,O)
357 <=> NO is O + 1, allocation_occurrence(C,NO).
358 % need not store constraint that is removed
359 rule(RuleNb,Rule), occurrence(C,O,RuleNb,ID,_) \ allocation_occurrence(C,O)
360 <=> Rule = pragma(_,ids(IDs1,_),_,_,_), member(ID,IDs1)
361 | NO is O + 1, allocation_occurrence(C,NO).
362 % need not store constraint when body is true
363 rule(RuleNb,Rule), occurrence(C,O,RuleNb,_,_) \ allocation_occurrence(C,O)
364 <=> Rule = pragma(rule(_,_,_,true),_,_,_,_)
365 | NO is O + 1, allocation_occurrence(C,NO).
366 % need not store constraint if does not observe itself
367 rule(RuleNb,Rule), occurrence(C,O,RuleNb,_,_) \ allocation_occurrence(C,O)
368 <=> Rule = pragma(rule([_|_],_,_,_),_,_,_,_), \+ is_observed(C,O)
369 | NO is O + 1, allocation_occurrence(C,NO).
370 % need not store constraint if does not observe itself and cannot trigger
371 rule(RuleNb,Rule), occurrence(C,O,RuleNb,_,_), least_occurrence(RuleNb,[])
372 \ allocation_occurrence(C,O)
373 <=> Rule = pragma(rule([],Heads,_,_),_,_,_,_), \+ is_observed(C,O)
374 | NO is O + 1, allocation_occurrence(C,NO).
376 rule(RuleNb,Rule), occurrence(C,O,RuleNb,ID,_), allocation_occurrence(C,AO)
377 \ least_occurrence(RuleNb,[ID|IDs])
378 <=> AO >= O, \+ may_trigger(C) |
379 least_occurrence(RuleNb,IDs).
380 rule(RuleNb,Rule), passive(RuleNb,ID)
381 \ least_occurrence(RuleNb,[ID|IDs])
382 <=> least_occurrence(RuleNb,IDs).
385 ==> Rule = pragma(rule([],_,_,_),ids([],IDs),_,_,_) |
386 least_occurrence(RuleNb,IDs).
388 least_occurrence(RuleNb,[]) \ is_least_occurrence(RuleNb)
390 is_least_occurrence(_)
393 allocation_occurrence(C,O) \ get_allocation_occurrence(C,Q)
395 get_allocation_occurrence(_,Q)
396 <=> chr_pp_flag(late_allocation,off), Q=0.
397 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
399 rule(RuleNb,Rule) \ get_rule(RuleNb,Q)
404 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
406 %%% C O N S T R A I N T I N D E X %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
408 constraint_index/2, % constraint_index(F/A,DefaultStoreAndAttachedIndex)
409 get_constraint_index/2,
410 get_indexed_constraint/2,
411 max_constraint_index/1, % max_constraint_index(MaxDefaultStoreAndAttachedIndex)
412 get_max_constraint_index/1.
414 :- chr_option(mode,constraint_index(+,+)).
415 :- chr_option(mode,max_constraint_index(+)).
417 constraint_index(C,Index) \ get_constraint_index(C,Query)
419 get_constraint_index(C,Query)
422 constraint_index(C,Index) \ get_indexed_constraint(Index,Q)
424 get_indexed_constraint(Index,Q)
427 max_constraint_index(Index) \ get_max_constraint_index(Query)
429 get_max_constraint_index(Query)
432 set_constraint_indices(Constraints) :-
433 set_constraint_indices(Constraints,1).
434 set_constraint_indices([],M) :-
436 max_constraint_index(N).
437 set_constraint_indices([C|Cs],N) :-
438 ( ( chr_pp_flag(debugable, on) ; \+ only_ground_indexed_arguments(C), is_stored(C) ; is_stored(C), get_store_type(C,default)
439 ; get_store_type(C,var_assoc_store(_,_))) ->
440 constraint_index(C,N),
442 set_constraint_indices(Cs,M)
444 set_constraint_indices(Cs,N)
447 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
452 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
456 chr_translate(Declarations,NewDeclarations) :-
457 chr_info(banner,'\tThe K.U.Leuven CHR System\t\n\t\tContributors:\tTom Schrijvers, Jon Sneyers, Bart Demoen,\n\t\t\t\tJan Wielemaker\n\t\tCopyright:\tK.U.Leuven, Belgium\n\t\tURL:\t\thttp://www.cs.kuleuven.be/~~toms/CHR/\n',[]),
459 partition_clauses(Declarations,Constraints0,Rules0,OtherClauses),
460 check_declared_constraints(Constraints0),
461 generate_show_constraint(Constraints0,Constraints,Rules0,Rules),
462 add_constraints(Constraints),
465 check_rules(Rules,Constraints),
467 add_occurrences(Rules),
468 time(fd_analysis,chr_translate:functional_dependency_analysis(Rules)),
469 time(set_semantics_rules,chr_translate:set_semantics_rules(Rules)),
470 time(symmetry_analysis,chr_translate:symmetry_analysis(Rules)),
471 time(guard_simplification,chr_translate:guard_simplification),
472 time(storage_analysis,chr_translate:storage_analysis(Constraints)),
473 time(observation_analysis,chr_translate:observation_analysis(Constraints)),
474 time(ai_observation_analysis,chr_translate:ai_observation_analysis(Constraints)),
475 time(late_allocation_analysis,chr_translate:late_allocation_analysis(Constraints)),
476 partial_wake_analysis,
477 time(assume_constraint_stores,chr_translate:assume_constraint_stores(Constraints)),
478 time(set_constraint_indices,chr_translate:set_constraint_indices(Constraints)),
480 time(constraints_code,chr_translate:constraints_code(Constraints,ConstraintClauses)),
481 time(validate_store_type_assumptions,chr_translate:validate_store_type_assumptions(Constraints)),
482 phase_end(validate_store_type_assumptions),
484 time(store_management_preds,chr_translate:store_management_preds(Constraints,StoreClauses)), % depends on actual code used
485 insert_declarations(OtherClauses, Clauses0),
486 chr_module_declaration(CHRModuleDeclaration),
487 append([StoreClauses,ConstraintClauses,CHRModuleDeclaration,[end_of_file]],StuffyGeneratedClauses),
488 clean_clauses(StuffyGeneratedClauses,GeneratedClauses),
489 append([Clauses0,GeneratedClauses], NewDeclarations).
491 store_management_preds(Constraints,Clauses) :-
492 generate_attach_detach_a_constraint_all(Constraints,AttachAConstraintClauses),
493 generate_attr_unify_hook(AttrUnifyHookClauses),
494 generate_attach_increment(AttachIncrementClauses),
495 generate_extra_clauses(Constraints,ExtraClauses),
496 generate_insert_delete_constraints(Constraints,DeleteClauses),
497 generate_attach_code(Constraints,StoreClauses),
498 generate_counter_code(CounterClauses),
499 generate_dynamic_type_check_clauses(TypeCheckClauses),
500 append([AttachAConstraintClauses
502 ,AttachIncrementClauses
503 ,AttrUnifyHookClauses
513 insert_declarations(Clauses0, Clauses) :-
514 findall(:- use_module(chr(Module)),(auxiliary_module(Module), is_used_auxiliary_module(Module)),Decls),
515 append(Clauses0, [:- use_module(chr(chr_runtime))|Decls], Clauses).
517 auxiliary_module(chr_hashtable_store).
518 auxiliary_module(chr_integertable_store).
519 auxiliary_module(chr_assoc_store).
521 generate_counter_code(Clauses) :-
522 ( chr_pp_flag(store_counter,on) ->
524 ('$counter_init'(N1) :- nb_setval(N1,0)) ,
525 ('$counter'(N2,X1) :- nb_getval(N2,X1)),
526 ('$counter_inc'(N) :- nb_getval(N,X), Y is X + 1, nb_setval(N,Y)),
527 (:- '$counter_init'('$insert_counter')),
528 (:- '$counter_init'('$delete_counter')),
529 ('$insert_counter_inc' :- '$counter_inc'('$insert_counter')),
530 ('$delete_counter_inc' :- '$counter_inc'('$delete_counter')),
531 ( counter_stats(I,D) :- '$counter'('$insert_counter',I),'$counter'('$delete_counter',D))
537 % for systems with multifile declaration
538 chr_module_declaration(CHRModuleDeclaration) :-
539 get_target_module(Mod),
540 ( Mod \== chr_translate, chr_pp_flag(toplevel_show_store,on) ->
541 CHRModuleDeclaration = [
542 (:- multifile chr:'$chr_module'/1),
543 chr:'$chr_module'(Mod)
546 CHRModuleDeclaration = []
550 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
552 %% Partitioning of clauses into constraint declarations, chr rules and other
555 partition_clauses([],[],[],[]).
556 partition_clauses([C|Cs],Ds,Rs,OCs) :-
561 ; is_declaration(C,D) ->
565 ; is_module_declaration(C,Mod) ->
570 ; is_type_definition(C) ->
575 chr_warning(deprecated(C),'Backward compatibility: ignoring handler/1 declaration.\n',[]),
580 chr_warning(deprecated(C),'Backward compatibility: ignoring rules/1 declaration.\n',[]),
584 ; C = option(OptionName,OptionValue) ->
585 chr_warning(deprecated(C),'Instead use :- chr_option(~w,~w).\n',[OptionName,OptionValue]),
586 handle_option(OptionName,OptionValue),
590 ; C = (:- chr_option(OptionName,OptionValue)) ->
591 handle_option(OptionName,OptionValue),
595 ; C = ('$chr_compiled_with_version'(_)) ->
598 OCs = ['$chr_compiled_with_version'(3)|ROCs]
603 partition_clauses(Cs,RDs,RRs,ROCs).
605 '$chr_compiled_with_version'(2).
607 is_declaration(D, Constraints) :- %% constraint declaration
608 ( D = (:- Decl), Decl =.. [F,Cs], F == (chr_constraint) ->
609 conj2list(Cs,Constraints0)
612 Decl =.. [constraints,Cs]
614 D =.. [constraints,Cs]
616 conj2list(Cs,Constraints0),
617 chr_warning(deprecated(D),'Instead use :- chr_constraint ~w.\n',[Cs])
619 extract_type_mode(Constraints0,Constraints).
621 extract_type_mode([],[]).
622 extract_type_mode([F/A|R],[F/A|R2]) :- !,extract_type_mode(R,R2).
623 extract_type_mode([C|R],[C2|R2]) :-
624 functor(C,F,A),C2=F/A,
626 extract_types_and_modes(Args,ArgTypes,ArgModes),
627 constraint_type(F/A,ArgTypes),
628 constraint_mode(F/A,ArgModes),
629 extract_type_mode(R,R2).
631 extract_types_and_modes([],[],[]).
632 extract_types_and_modes([X|R],[T|R2],[M|R3]) :-
633 extract_type_and_mode(X,T,M),
634 extract_types_and_modes(R,R2,R3).
636 extract_type_and_mode(+(T),T,(+)) :- !.
637 extract_type_and_mode(?(T),T,(?)) :- !.
638 extract_type_and_mode(-(T),T,(-)) :- !.
639 extract_type_and_mode((+),any,(+)) :- !.
640 extract_type_and_mode((?),any,(?)) :- !.
641 extract_type_and_mode((-),any,(-)) :- !.
642 extract_type_and_mode(Illegal,_,_) :-
643 chr_error(syntax(Illegal),'Illegal mode/type declaration.\n\tCorrect syntax is +type, -type or ?type\n\tor +, - or ?.\n',[]).
645 is_type_definition(D) :-
651 TDef =.. [chr_type,TypeDef],
652 ( TypeDef = (Name ---> Def) ->
653 tdisj2list(Def,DefList),
654 type_definition(Name,DefList)
655 ; TypeDef = (Alias == Name) ->
656 type_alias(Alias,Name)
658 chr_warning(syntax,'Illegal type definition "~w".\n\tIgnoring this malformed type definition.\n',[TypeDef])
661 % no removal of fails, e.g. :- type bool ---> true ; fail.
662 tdisj2list(Conj,L) :-
663 tdisj2list(Conj,L,[]).
664 tdisj2list(Conj,L,T) :-
668 tdisj2list(G,[G | T],T).
678 %% yesno(string), :: maybe rule nane
679 %% int :: rule number
688 %% list(constraint), :: constraints to be removed
689 %% list(constraint), :: surviving constraints
694 parse_rule(RI,R) :- %% name @ rule
695 RI = (Name @ RI2), !,
696 rule(RI2,yes(Name),R).
701 RI = (RI2 pragma P), !, %% pragmas
703 Ps = [_] % intercept variable
707 inc_rule_count(RuleCount),
708 R = pragma(R1,IDs,Ps,Name,RuleCount),
709 is_rule(RI2,R1,IDs,R).
711 inc_rule_count(RuleCount),
712 R = pragma(R1,IDs,[],Name,RuleCount),
713 is_rule(RI,R1,IDs,R).
715 is_rule(RI,R,IDs,RC) :- %% propagation rule
718 get_ids(Head2i,IDs2,Head2,RC),
721 R = rule([],Head2,G,RB)
723 R = rule([],Head2,true,B)
725 is_rule(RI,R,IDs,RC) :- %% simplification/simpagation rule
734 conj2list(H1,Head2i),
735 conj2list(H2,Head1i),
736 get_ids(Head2i,IDs2,Head2,0,N,RC),
737 get_ids(Head1i,IDs1,Head1,N,_,RC),
739 ; conj2list(H,Head1i),
741 get_ids(Head1i,IDs1,Head1,RC),
744 R = rule(Head1,Head2,Guard,Body).
746 get_ids(Cs,IDs,NCs,RC) :-
747 get_ids(Cs,IDs,NCs,0,_,RC).
749 get_ids([],[],[],N,N,_).
750 get_ids([C|Cs],[N|IDs],[NC|NCs],N,NN,RC) :-
755 check_direct_pragma(N1,N,RC)
761 get_ids(Cs,IDs,NCs, M,NN,RC).
763 direct_pragma(passive).
764 check_direct_pragma(passive,N,R) :-
765 R = pragma(_,ids(IDs1,IDs2),_,_,RuleNb), passive(RuleNb,N).
766 check_direct_pragma(Abbrev,N,RC) :-
768 atom_concat(Abbrev,Remainder,X) ->
769 chr_warning(problem_pragma(Abbrev,RC),'completed "~w" to "~w"\n',[Abbrev,X])
771 chr_warning(unsupported_pragma(Abbrev,RC),'',[])
774 is_module_declaration((:- module(Mod)),Mod).
775 is_module_declaration((:- module(Mod,_)),Mod).
777 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
779 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
782 add_constraints([C|Cs]) :-
787 constraint_mode(C,Mode),
792 add_rules([Rule|Rules]) :-
793 Rule = pragma(_,_,_,_,RuleNb),
797 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
799 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
800 %% Some input verification:
802 check_declared_constraints(Constraints) :-
803 check_declared_constraints(Constraints,[]).
805 check_declared_constraints([],_).
806 check_declared_constraints([C|Cs],Acc) :-
807 ( memberchk_eq(C,Acc) ->
808 chr_error(syntax(C),'Constraint multiply defined: ~w.\n\tRemove redundant declaration!\n',[C])
812 check_declared_constraints(Cs,[C|Acc]).
814 %% - all constraints in heads are declared constraints
815 %% - all passive pragmas refer to actual head constraints
818 check_rules([PragmaRule|Rest],Decls) :-
819 check_rule(PragmaRule,Decls),
820 check_rules(Rest,Decls).
822 check_rule(PragmaRule,Decls) :-
823 check_rule_indexing(PragmaRule),
824 check_trivial_propagation_rule(PragmaRule),
825 PragmaRule = pragma(Rule,_IDs,Pragmas,_Name,_N),
826 Rule = rule(H1,H2,_,_),
827 append(H1,H2,HeadConstraints),
828 check_head_constraints(HeadConstraints,Decls,PragmaRule),
829 check_pragmas(Pragmas,PragmaRule).
831 % Make all heads passive in trivial propagation rule
832 % ... ==> ... | true.
833 check_trivial_propagation_rule(PragmaRule) :-
834 PragmaRule = pragma(Rule,IDs,Pragmas,Name,RuleNb),
835 ( Rule = rule([],_,_,true) ->
836 chr_warning(weird_program,'Ignoring propagation rule with empty body: ~@.\n\t\n',[format_rule(PragmaRule)]),
837 set_all_passive(RuleNb)
842 check_head_constraints([],_,_).
843 check_head_constraints([Constr|Rest],Decls,PragmaRule) :-
845 ( member(F/A,Decls) ->
846 check_head_constraints(Rest,Decls,PragmaRule)
848 chr_error(syntax(Constr),'Undeclared constraint ~w in head of ~@.\n\tConstraint should be one of ~w.\n', [F/A,format_rule(PragmaRule),Decls]) ).
851 check_pragmas([Pragma|Pragmas],PragmaRule) :-
852 check_pragma(Pragma,PragmaRule),
853 check_pragmas(Pragmas,PragmaRule).
855 check_pragma(Pragma,PragmaRule) :-
857 chr_error(syntax(Pragma),'Invalid pragma ~w in ~@.\n\tPragma should not be a variable!\n',[Pragma,format_rule(PragmaRule)]).
858 check_pragma(passive(ID), PragmaRule) :-
860 PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb),
861 ( memberchk_eq(ID,IDs1) ->
863 ; memberchk_eq(ID,IDs2) ->
866 chr_error(syntax(ID),'Invalid identifier ~w in pragma passive in ~@.\n', [ID,format_rule(PragmaRule)])
870 check_pragma(Pragma, PragmaRule) :-
871 Pragma = already_in_heads,
873 chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]).
875 check_pragma(Pragma, PragmaRule) :-
876 Pragma = already_in_head(_),
878 chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]).
880 check_pragma(Pragma, PragmaRule) :-
883 chr_warning(experimental,'Experimental pragma no_history. Use with care!\n',[]),
884 PragmaRule = pragma(_,_,_,_,N),
887 check_pragma(Pragma,PragmaRule) :-
888 chr_error(syntax(Pragma),'Unknown pragma ~w in ~@.\n', [Pragma,format_rule(PragmaRule)]).
894 :- chr_option(mode,no_history(+)).
896 no_history(RuleNb) \ has_no_history(RuleNb) <=> true.
897 has_no_history(_) <=> fail.
899 format_rule(PragmaRule) :-
900 PragmaRule = pragma(_,_,_,MaybeName,N),
901 ( MaybeName = yes(Name) ->
902 write('rule '), write(Name)
904 write('rule number '), write(N)
907 check_rule_indexing(PragmaRule) :-
908 PragmaRule = pragma(Rule,_,_,_,_),
909 Rule = rule(H1,H2,G,_),
910 term_variables(H1-H2,HeadVars),
911 remove_anti_monotonic_guards(G,HeadVars,NG),
912 check_indexing(H1,NG-H2),
913 check_indexing(H2,NG-H1),
915 ( chr_pp_flag(term_indexing,on) ->
916 term_variables(NG,GuardVariables),
918 check_specs_indexing(Heads,GuardVariables,Specs)
927 :- chr_option(mode,indexing_spec(+,+)).
929 indexing_spec(FA,Spec) \ get_indexing_spec(FA,R) <=> R = Spec.
930 get_indexing_spec(_,Spec) <=> Spec = [].
932 indexing_spec(FA,Specs1), indexing_spec(FA,Specs2)
934 append(Specs1,Specs2,Specs),
935 indexing_spec(FA,Specs).
937 remove_anti_monotonic_guards(G,Vars,NG) :-
939 remove_anti_monotonic_guard_list(GL,Vars,NGL),
942 remove_anti_monotonic_guard_list([],_,[]).
943 remove_anti_monotonic_guard_list([G|Gs],Vars,NGs) :-
944 ( G = var(X), memberchk_eq(X,Vars) ->
946 % TODO: this is not correct
947 % ; G = functor(Term,Functor,Arity), % isotonic
948 % \+ memberchk_eq(Functor,Vars), \+ memberchk_eq(Arity,Vars) ->
953 remove_anti_monotonic_guard_list(Gs,Vars,RGs).
955 check_indexing([],_).
956 check_indexing([Head|Heads],Other) :-
959 term_variables(Heads-Other,OtherVars),
960 check_indexing(Args,1,F/A,OtherVars),
961 check_indexing(Heads,[Head|Other]).
963 check_indexing([],_,_,_).
964 check_indexing([Arg|Args],I,FA,OtherVars) :-
965 ( is_indexed_argument(FA,I) ->
968 indexed_argument(FA,I)
970 term_variables(Args,ArgsVars),
971 append(ArgsVars,OtherVars,RestVars),
972 ( memberchk_eq(Arg,RestVars) ->
973 indexed_argument(FA,I)
979 term_variables(Arg,NVars),
980 append(NVars,OtherVars,NOtherVars),
981 check_indexing(Args,J,FA,NOtherVars).
983 check_specs_indexing([],_,[]).
984 check_specs_indexing([Head|Heads],Variables,Specs) :-
985 Specs = [Spec|RSpecs],
986 term_variables(Heads,OtherVariables,Variables),
987 check_spec_indexing(Head,OtherVariables,Spec),
988 term_variables(Head,NVariables,Variables),
989 check_specs_indexing(Heads,NVariables,RSpecs).
991 check_spec_indexing(Head,OtherVariables,Spec) :-
993 Spec = spec(F,A,ArgSpecs),
995 check_args_spec_indexing(Args,1,OtherVariables,ArgSpecs),
996 indexing_spec(F/A,[ArgSpecs]).
998 check_args_spec_indexing([],_,_,[]).
999 check_args_spec_indexing([Arg|Args],I,OtherVariables,ArgSpecs) :-
1000 term_variables(Args,Variables,OtherVariables),
1001 ( check_arg_spec_indexing(Arg,I,Variables,ArgSpec) ->
1002 ArgSpecs = [ArgSpec|RArgSpecs]
1004 ArgSpecs = RArgSpecs
1007 term_variables(Arg,NOtherVariables,OtherVariables),
1008 check_args_spec_indexing(Args,J,NOtherVariables,RArgSpecs).
1010 check_arg_spec_indexing(Arg,I,Variables,ArgSpec) :-
1012 memberchk_eq(Arg,Variables),
1013 ArgSpec = specinfo(I,any,[])
1016 ArgSpec = specinfo(I,F/A,[ArgSpecs]),
1018 check_args_spec_indexing(Args,1,Variables,ArgSpecs)
1021 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1023 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1026 add_occurrences([]).
1027 add_occurrences([Rule|Rules]) :-
1028 Rule = pragma(rule(H1,H2,_,_),ids(IDs1,IDs2),_,_,Nb),
1029 add_occurrences(H1,IDs1,simplification,Nb),
1030 add_occurrences(H2,IDs2,propagation,Nb),
1031 add_occurrences(Rules).
1033 add_occurrences([],[],_,_).
1034 add_occurrences([H|Hs],[ID|IDs],Type,RuleNb) :-
1037 new_occurrence(FA,RuleNb,ID,Type),
1038 add_occurrences(Hs,IDs,Type,RuleNb).
1040 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1042 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1043 % Observation Analysis
1048 % - approximative: should make decision in late allocation analysis per body
1053 is_self_observer(C),
1054 ai_is_observed(C,O).
1059 observes_indirectly/2,
1063 :- chr_option(mode,observes(+,+)).
1064 :- chr_option(mode,spawns_observer(+,+)).
1065 :- chr_option(mode,observes_indirectly(+,+)).
1067 spawns_observer(C1,C2) \ spawns_observer(C1,C2) <=> true.
1068 observes(C1,C2) \ observes(C1,C2) <=> true.
1070 observes_indirectly(C1,C2) \ observes_indirectly(C1,C2) <=> true.
1072 spawns_observer(C1,C2), observes(C2,C3) ==> observes_indirectly(C1,C3).
1073 spawns_observer(C1,C2), observes_indirectly(C2,C3) ==> observes_indirectly(C1,C3).
1075 observes_indirectly(C,C) \ is_self_observer(C) <=> true.
1076 is_self_observer(_) <=> chr_pp_flag(observation_analysis,off).
1077 % true if analysis has not been run,
1078 % false if analysis has been run
1080 observation_analysis(Cs) :-
1081 ( chr_pp_flag(observation_analysis,on) ->
1082 observation_analysis(Cs,Cs)
1087 observation_analysis([],_).
1088 observation_analysis([C|Cs],Constraints) :-
1089 get_max_occurrence(C,MO),
1090 observation_analysis_occurrences(C,1,MO,Constraints),
1091 observation_analysis(Cs,Constraints).
1093 observation_analysis_occurrences(C,O,MO,Cs) :-
1097 observation_analysis_occurrence(C,O,Cs),
1099 observation_analysis_occurrences(C,NO,MO,Cs)
1102 observation_analysis_occurrence(C,O,Cs) :-
1103 get_occurrence(C,O,RuleNb,ID),
1104 ( is_passive(RuleNb,ID) ->
1107 get_rule(RuleNb,PragmaRule),
1108 PragmaRule = pragma(rule(Heads1,Heads2,_,Body),ids(IDs1,IDs2),_,_,_),
1109 ( select2(ID,_Head,IDs1,Heads1,_RIDs1,RHeads1) ->
1110 append(RHeads1,Heads2,OtherHeads)
1111 ; select2(ID,_Head,IDs2,Heads2,_RIDs2,RHeads2) ->
1112 append(RHeads2,Heads1,OtherHeads)
1114 observe_heads(C,OtherHeads),
1115 observe_body(C,Body,Cs)
1118 observe_heads(C,Heads) :-
1119 findall(F/A,(member(H,Heads),functor(H,F,A)),Cs),
1122 observe_all(C,Cs) :-
1132 spawns_observer(C,C1),
1137 spawn_all_triggers(C,Cs) :-
1139 ( may_trigger(C1) ->
1140 spawns_observer(C,C1)
1144 spawn_all_triggers(C,Cr)
1149 observe_body(C,Body,Cs) :-
1157 observe_body(C,B1,Cs),
1158 observe_body(C,B2,Cs)
1160 observe_body(C,B1,Cs),
1161 observe_body(C,B2,Cs)
1162 ; Body = (B1->B2) ->
1163 observe_body(C,B1,Cs),
1164 observe_body(C,B2,Cs)
1165 ; functor(Body,F,A), member(F/A,Cs) ->
1166 spawns_observer(C,F/A)
1168 spawn_all_triggers(C,Cs)
1169 ; Body = (_ is _) ->
1170 spawn_all_triggers(C,Cs)
1171 ; builtin_binds_b(Body,Vars) ->
1175 spawn_all_triggers(C,Cs)
1181 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1183 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1186 late_allocation_analysis(Cs) :-
1187 ( chr_pp_flag(late_allocation,on) ->
1193 late_allocation([]).
1194 late_allocation([C|Cs]) :-
1195 allocation_occurrence(C,1),
1196 late_allocation(Cs).
1197 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1200 %% Generated predicates
1201 %% attach_$CONSTRAINT
1203 %% detach_$CONSTRAINT
1206 %% attach_$CONSTRAINT
1207 generate_attach_detach_a_constraint_all([],[]).
1208 generate_attach_detach_a_constraint_all([Constraint|Constraints],Clauses) :-
1209 ( ( chr_pp_flag(debugable,on) ; is_stored(Constraint), \+ only_ground_indexed_arguments(Constraint), \+ get_store_type(Constraint,var_assoc_store(_,_)) ) ->
1210 generate_attach_a_constraint(Constraint,Clauses1),
1211 generate_detach_a_constraint(Constraint,Clauses2)
1216 generate_attach_detach_a_constraint_all(Constraints,Clauses3),
1217 append([Clauses1,Clauses2,Clauses3],Clauses).
1219 generate_attach_a_constraint(Constraint,[Clause1,Clause2]) :-
1220 generate_attach_a_constraint_nil(Constraint,Clause1),
1221 generate_attach_a_constraint_cons(Constraint,Clause2).
1223 attach_constraint_atom(FA,Vars,Susp,Atom) :-
1224 make_name('attach_',FA,Name),
1225 Atom =.. [Name,Vars,Susp].
1227 generate_attach_a_constraint_nil(FA,Clause) :-
1228 Clause = (Head :- true),
1229 attach_constraint_atom(FA,[],_,Head).
1231 generate_attach_a_constraint_cons(FA,Clause) :-
1232 Clause = (Head :- Body),
1233 attach_constraint_atom(FA,[Var|Vars],Susp,Head),
1234 attach_constraint_atom(FA,Vars,Susp,RecursiveCall),
1235 Body = ( AttachBody, Subscribe, RecursiveCall ),
1236 get_max_constraint_index(N),
1238 generate_attach_body_1(FA,Var,Susp,AttachBody)
1240 generate_attach_body_n(FA,Var,Susp,AttachBody)
1242 % SWI-Prolog specific code
1243 chr_pp_flag(solver_events,NMod),
1245 Args = [[Var|_],Susp],
1246 get_target_module(Mod),
1247 use_auxiliary_predicate(run_suspensions),
1248 Subscribe = clp_events:subscribe(Var,NMod,Mod,Mod:'$run_suspensions'([Susp]))
1253 generate_attach_body_1(FA,Var,Susp,Body) :-
1254 get_target_module(Mod),
1256 ( get_attr(Var, Mod, Susps) ->
1257 put_attr(Var, Mod, [Susp|Susps])
1259 put_attr(Var, Mod, [Susp])
1262 generate_attach_body_n(F/A,Var,Susp,Body) :-
1263 get_constraint_index(F/A,Position),
1264 or_pattern(Position,Pattern),
1265 get_max_constraint_index(Total),
1266 make_attr(Total,Mask,SuspsList,Attr),
1267 nth1(Position,SuspsList,Susps),
1268 substitute(Susps,SuspsList,[Susp|Susps],SuspsList1),
1269 make_attr(Total,Mask,SuspsList1,NewAttr1),
1270 substitute(Susps,SuspsList,[Susp],SuspsList2),
1271 make_attr(Total,NewMask,SuspsList2,NewAttr2),
1272 copy_term(SuspsList,SuspsList3),
1273 nth1(Position,SuspsList3,[Susp]),
1274 chr_delete(SuspsList3,[Susp],RestSuspsList),
1275 set_elems(RestSuspsList,[]),
1276 make_attr(Total,Pattern,SuspsList3,NewAttr3),
1277 get_target_module(Mod),
1279 ( get_attr(Var,Mod,TAttr) ->
1281 ( Mask /\ Pattern =:= Pattern ->
1282 put_attr(Var, Mod, NewAttr1)
1284 NewMask is Mask \/ Pattern,
1285 put_attr(Var, Mod, NewAttr2)
1288 put_attr(Var,Mod,NewAttr3)
1291 %% detach_$CONSTRAINT
1292 generate_detach_a_constraint(Constraint,[Clause1,Clause2]) :-
1293 generate_detach_a_constraint_nil(Constraint,Clause1),
1294 generate_detach_a_constraint_cons(Constraint,Clause2).
1296 detach_constraint_atom(FA,Vars,Susp,Atom) :-
1297 make_name('detach_',FA,Name),
1298 Atom =.. [Name,Vars,Susp].
1300 generate_detach_a_constraint_nil(FA,Clause) :-
1301 Clause = ( Head :- true),
1302 detach_constraint_atom(FA,[],_,Head).
1304 generate_detach_a_constraint_cons(FA,Clause) :-
1305 Clause = (Head :- Body),
1306 detach_constraint_atom(FA,[Var|Vars],Susp,Head),
1307 detach_constraint_atom(FA,Vars,Susp,RecursiveCall),
1308 Body = ( DetachBody, RecursiveCall ),
1309 get_max_constraint_index(N),
1311 generate_detach_body_1(FA,Var,Susp,DetachBody)
1313 generate_detach_body_n(FA,Var,Susp,DetachBody)
1316 generate_detach_body_1(FA,Var,Susp,Body) :-
1317 get_target_module(Mod),
1319 ( get_attr(Var,Mod,Susps) ->
1320 'chr sbag_del_element'(Susps,Susp,NewSusps),
1324 put_attr(Var,Mod,NewSusps)
1330 generate_detach_body_n(F/A,Var,Susp,Body) :-
1331 get_constraint_index(F/A,Position),
1332 or_pattern(Position,Pattern),
1333 and_pattern(Position,DelPattern),
1334 get_max_constraint_index(Total),
1335 make_attr(Total,Mask,SuspsList,Attr),
1336 nth1(Position,SuspsList,Susps),
1337 substitute(Susps,SuspsList,[],SuspsList1),
1338 make_attr(Total,NewMask,SuspsList1,Attr1),
1339 substitute(Susps,SuspsList,NewSusps,SuspsList2),
1340 make_attr(Total,Mask,SuspsList2,Attr2),
1341 get_target_module(Mod),
1343 ( get_attr(Var,Mod,TAttr) ->
1345 ( Mask /\ Pattern =:= Pattern ->
1346 'chr sbag_del_element'(Susps,Susp,NewSusps),
1348 NewMask is Mask /\ DelPattern,
1352 put_attr(Var,Mod,Attr1)
1355 put_attr(Var,Mod,Attr2)
1364 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1365 :- chr_constraint generate_indexed_variables_body/4.
1366 :- chr_option(mode,generate_indexed_variables_body(+,?,+,?)).
1367 %-------------------------------------------------------------------------------
1368 constraint_mode(F/A,ArgModes) \ generate_indexed_variables_body(F/A,Args,Body,Vars) <=>
1369 get_indexing_spec(F/A,Specs),
1370 ( chr_pp_flag(term_indexing,on) ->
1371 spectermvars(Specs,Args,F,A,Body,Vars)
1373 create_indexed_variables_body(Args,ArgModes,Vars,1,F/A,MaybeBody,N),
1374 ( MaybeBody == empty ->
1378 Term =.. [term|Args],
1379 Body = term_variables(Term,Vars)
1384 generate_indexed_variables_body(FA,_,_,_) <=>
1385 chr_error(internal,'generate_indexed_variables_body: missing mode info for ~w.\n',[FA]).
1386 %===============================================================================
1388 create_indexed_variables_body([],[],_,_,_,empty,0).
1389 create_indexed_variables_body([V|Vs],[Mode|Modes],Vars,I,FA,Body,N) :-
1391 create_indexed_variables_body(Vs,Modes,Tail,J,FA,RBody,M),
1393 is_indexed_argument(FA,I) ->
1395 Body = term_variables(V,Vars)
1397 Body = (term_variables(V,Vars,Tail),RBody)
1400 ; Mode == (-), is_indexed_argument(FA,I) ->
1404 Body = (Vars = [V|Tail],RBody)
1412 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1414 spectermvars(Specs,Args,F,A,Goal,Vars) :-
1415 spectermvars(Args,1,Specs,F,A,Vars,[],Goal).
1417 spectermvars([],B,_,_,A,L,L,true) :- B > A, !.
1418 spectermvars([Arg|Args],I,Specs,F,A,L,T,Goal) :-
1419 Goal = (ArgGoal,RGoal),
1420 argspecs(Specs,I,TempArgSpecs,RSpecs),
1421 merge_argspecs(TempArgSpecs,ArgSpecs),
1422 arggoal(ArgSpecs,Arg,ArgGoal,L,L1),
1424 spectermvars(Args,J,RSpecs,F,A,L1,T,RGoal).
1426 argspecs([],_,[],[]).
1427 argspecs([[]|Rest],I,ArgSpecs,RestSpecs) :-
1428 argspecs(Rest,I,ArgSpecs,RestSpecs).
1429 argspecs([[specinfo(J,Spec,Args)|Specs]|Rest],I,ArgSpecs,RestSpecs) :-
1431 ArgSpecs = [specinfo(J,Spec,Args)|RArgSpecs],
1433 RRestSpecs = RestSpecs
1435 RestSpecs = [Specs|RRestSpecs]
1438 ArgSpecs = RArgSpecs,
1439 RestSpecs = [[specinfo(J,Spec,Args)|Specs]|RRestSpecs]
1441 argspecs(Rest,I,RArgSpecs,RRestSpecs).
1443 merge_argspecs(In,Out) :-
1445 merge_argspecs_(Sorted,Out).
1447 merge_argspecs_([],[]).
1448 merge_argspecs_([X],R) :- !, R = [X].
1449 merge_argspecs_([specinfo(I,F1,A1),specinfo(I,F2,A2)|Rest],R) :-
1450 ( (F1 == any ; F2 == any) ->
1451 merge_argspecs_([specinfo(I,any,[])|Rest],R)
1454 merge_argspecs_([specinfo(I,F1,A)|Rest],R)
1456 R = [specinfo(I,F1,A1)|RR],
1457 merge_argspecs_([specinfo(I,F2,A2)|Rest],RR)
1460 arggoal(List,Arg,Goal,L,T) :-
1464 ; List = [specinfo(_,any,_)] ->
1465 Goal = term_variables(Arg,L,T)
1473 arggoal_cases(List,Arg,L,T,Cases)
1476 arggoal_cases([],_,L,T,L=T).
1477 arggoal_cases([specinfo(_,FA,ArgSpecs)|Rest],Arg,L,T,Cases) :-
1480 ; ArgSpecs == [[]] ->
1483 Cases = (Case ; RCases),
1486 Case = (Arg = Term -> ArgsGoal),
1487 spectermvars(Args,1,ArgSpecs,F,A,L,T,ArgsGoal)
1489 arggoal_cases(Rest,Arg,L,T,RCases).
1490 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1492 generate_extra_clauses(Constraints,List) :-
1493 generate_activate_clauses(Constraints,List,Tail0),
1494 generate_remove_clauses(Constraints,Tail0,Tail1),
1495 generate_allocate_clauses(Constraints,Tail1,Tail2),
1496 generate_insert_constraint_internal_clauses(Constraints,Tail2,Tail3),
1497 generate_novel_production(Tail3,Tail4),
1498 generate_extend_history(Tail4,Tail5),
1499 generate_run_suspensions_clauses(Constraints,Tail5,Tail6),
1502 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
1503 % remove_constraint_internal/[1/3]
1505 generate_remove_clauses([],List,List).
1506 generate_remove_clauses([C|Cs],List,Tail) :-
1507 generate_remove_clause(C,List,List1),
1508 generate_remove_clauses(Cs,List1,Tail).
1510 remove_constraint_goal(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Goal) :-
1511 uses_state(Constraint,removed),
1512 ( chr_pp_flag(inline_insertremove,off) ->
1513 use_auxiliary_predicate(remove_constraint_internal,Constraint),
1514 Goal = ( DeleteGoal, ( Delete == yes -> DeleteYes ; DeleteNo) ),
1515 remove_constraint_atom(Constraint,Susp,Agenda,Delete,DeleteGoal)
1517 delay_phase_end(validate_store_type_assumptions,
1518 generate_remove_body(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Goal)
1522 remove_constraint_atom(Constraint,Susp,Agenda,Delete,Goal) :-
1523 make_name('$remove_constraint_internal_',Constraint,Name),
1524 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)) ) ->
1525 Goal =.. [Name, Susp,Delete]
1527 Goal =.. [Name,Susp,Agenda,Delete]
1530 generate_remove_clause(Constraint,List,Tail) :-
1531 ( is_used_auxiliary_predicate(remove_constraint_internal,Constraint) ->
1532 List = [RemoveClause|Tail],
1533 RemoveClause = (Head :- RemoveBody),
1534 remove_constraint_atom(Constraint,Susp,Agenda,Delete,Head),
1535 generate_remove_body(Constraint,Susp,Agenda,Delete = no,Delete = yes,RemoveBody)
1540 generate_remove_body(Constraint,Susp,Agenda,DeleteNo,DeleteYes,RemoveBody) :-
1541 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_))) ->
1542 get_update_suspension_field(Constraint,Susp,state,State,removed,GetState,GetStateValue0,UpdateState),
1543 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
1544 if_used_state(Constraint,not_stored_yet,(State == not_stored_yet -> DeleteNo ; DeleteYes),DeleteYes,MaybeDelete),
1553 static_suspension_term(Constraint,Susp2),
1554 get_static_suspension_term_field(arguments,Constraint,Susp2,Args),
1555 generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Agenda),
1556 ( chr_pp_flag(debugable,on) ->
1557 Constraint = Functor / _,
1558 get_static_suspension_term_field(functor,Constraint,Susp2,Functor)
1562 get_update_static_suspension_field(Constraint,Susp,Susp2,state,State,removed,GetStateValue0,UpdateState),
1563 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
1564 if_used_state(Constraint,not_stored_yet,(State == not_stored_yet -> Agenda = [], DeleteNo ; IndexedVariablesBody, DeleteYes),(IndexedVariablesBody,DeleteYes),MaybeDelete),
1574 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
1575 % activate_constraint/4
1577 generate_activate_clauses([],List,List).
1578 generate_activate_clauses([C|Cs],List,Tail) :-
1579 generate_activate_clause(C,List,List1),
1580 generate_activate_clauses(Cs,List1,Tail).
1582 activate_constraint_goal(Constraint,StoreAction,Vars,Susp,Generation,Goal) :-
1583 ( chr_pp_flag(inline_insertremove,off) ->
1584 use_auxiliary_predicate(activate_constraint,Constraint),
1585 Goal = ( ActivateGoal , (Store == yes -> StoreAction ; true) ),
1586 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,ActivateGoal)
1588 delay_phase_end(validate_store_type_assumptions,
1589 activate_constraint_body(Constraint,StoreAction,true,Vars,Susp,Generation,Goal)
1593 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,Goal) :-
1594 make_name('$activate_constraint_',Constraint,Name),
1595 ( chr_pp_flag(debugable,off), only_ground_indexed_arguments(Constraint) ->
1596 Goal =.. [Name,Store, Susp]
1597 ; chr_pp_flag(debugable,off), may_trigger(Constraint), get_store_type(Constraint,var_assoc_store(_,_)) ->
1598 Goal =.. [Name,Store, Susp, Generation]
1599 ; chr_pp_flag(debugable,off), may_trigger(Constraint), get_store_type(Constraint,var_assoc_store(_,_)) ->
1600 Goal =.. [Name,Store, Vars, Susp, Generation]
1602 Goal =.. [Name,Store, Vars, Susp]
1605 generate_activate_clause(Constraint,List,Tail) :-
1606 ( is_used_auxiliary_predicate(activate_constraint,Constraint) ->
1607 List = [Clause|Tail],
1608 Clause = (Head :- Body),
1609 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,Head),
1610 activate_constraint_body(Constraint,Store = yes, Store = no,Vars,Susp,Generation,Body)
1615 activate_constraint_body(Constraint,StoreYes,StoreNo,Vars,Susp,Generation,Body) :-
1616 ( chr_pp_flag(debugable,off), may_trigger(Constraint), uses_field(Constraint,generation) ->
1617 get_update_suspension_field(Constraint,Susp,generation,Gen,Generation,GetGeneration,GetGenerationValue,UpdateGeneration),
1618 GenerationHandling = (GetGeneration, GetGenerationValue, Generation is Gen+1, UpdateGeneration)
1620 GenerationHandling = true
1622 get_update_suspension_field(Constraint,Susp,state,State,active,GetState,GetStateValue0,UpdateState),
1623 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
1624 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_))) ->
1625 if_used_state(Constraint,not_stored_yet,( State == not_stored_yet -> StoreYes ; StoreNo ),StoreNo,StoreVarsGoal)
1627 get_dynamic_suspension_term_field(arguments,Constraint,Susp,Arguments,ArgumentsGoal),
1628 generate_indexed_variables_body(Constraint,Arguments,IndexedVariablesBody,Vars),
1629 ( chr_pp_flag(guard_locks,off) ->
1632 NoneLocked = 'chr none_locked'( Vars)
1634 if_used_state(Constraint,not_stored_yet,
1635 ( State == not_stored_yet ->
1637 IndexedVariablesBody,
1644 (Vars = [],StoreNo),StoreVarsGoal)
1654 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
1655 % allocate_constraint/4
1657 generate_allocate_clauses([],List,List).
1658 generate_allocate_clauses([C|Cs],List,Tail) :-
1659 generate_allocate_clause(C,List,List1),
1660 generate_allocate_clauses(Cs,List1,Tail).
1662 allocate_constraint_goal(Constraint,Susp,Args,Goal) :-
1663 uses_state(Constraint,not_stored_yet),
1664 ( chr_pp_flag(inline_insertremove,off) ->
1665 use_auxiliary_predicate(allocate_constraint,Constraint),
1666 allocate_constraint_atom(Constraint,Susp,Args,Goal)
1668 Goal = (Susp = Suspension, Goal0),
1669 delay_phase_end(validate_store_type_assumptions,
1670 allocate_constraint_body(Constraint,Suspension,Args,Goal0)
1674 allocate_constraint_atom(Constraint, Susp, Args,Goal) :-
1675 make_name('$allocate_constraint_',Constraint,Name),
1676 Goal =.. [Name,Susp|Args].
1678 generate_allocate_clause(Constraint,List,Tail) :-
1679 ( is_used_auxiliary_predicate(allocate_constraint,Constraint) ->
1680 List = [Clause|Tail],
1681 Clause = (Head :- Body),
1684 allocate_constraint_atom(Constraint,Susp,Args,Head),
1685 allocate_constraint_body(Constraint,Susp,Args,Body)
1690 allocate_constraint_body(Constraint,Susp,Args,Body) :-
1691 static_suspension_term(Constraint,Suspension),
1692 get_static_suspension_term_field(arguments,Constraint,Suspension,Args),
1693 ( chr_pp_flag(debugable,on) ->
1694 Constraint = Functor / _,
1695 get_static_suspension_term_field(functor,Constraint,Suspension,Functor)
1699 ( chr_pp_flag(debugable,on) ->
1700 ( may_trigger(Constraint) ->
1701 append(Args,[Susp],VarsSusp),
1702 build_head(F,A,[0],VarsSusp, ContinuationGoal),
1703 get_target_module(Mod),
1704 Continuation = Mod : ContinuationGoal
1708 Init = (Susp = Suspension),
1709 create_static_suspension_field(Constraint,Suspension,continuation,Continuation,CreateContinuation),
1710 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
1711 ; may_trigger(Constraint), uses_field(Constraint,generation) ->
1712 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration),
1713 Susp = Suspension, Init = true, CreateContinuation = true
1715 CreateGeneration = true, Susp = Suspension, Init = true, CreateContinuation = true
1717 ( uses_history(Constraint) ->
1718 create_static_suspension_field(Constraint,Suspension,history,t,CreateHistory)
1720 CreateHistory = true
1722 create_static_suspension_field(Constraint,Suspension,state,not_stored_yet,CreateState),
1723 ( has_suspension_field(Constraint,id) ->
1724 get_static_suspension_term_field(id,Constraint,Suspension,Id),
1725 GenID = 'chr gen_id'(Id)
1739 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
1740 % insert_constraint_internal
1742 generate_insert_constraint_internal_clauses([],List,List).
1743 generate_insert_constraint_internal_clauses([C|Cs],List,Tail) :-
1744 generate_insert_constraint_internal_clause(C,List,List1),
1745 generate_insert_constraint_internal_clauses(Cs,List1,Tail).
1747 insert_constraint_internal_constraint_goal(Constraint, Vars, Suspension, Continuation, Args,Goal) :-
1748 ( chr_pp_flag(inline_insertremove,off) ->
1749 use_auxiliary_predicate(remove_constraint_internal,Constraint),
1750 insert_constraint_internal_constraint_atom(Constraint,Vars,Suspension,Continuation,Args,Goal)
1752 delay_phase_end(validate_store_type_assumptions,
1753 generate_insert_constraint_internal_body(Constraint,Suspension,Continuation,Args,Vars,Goal)
1758 insert_constraint_internal_constraint_atom(Constraint,Vars,Self,Closure,Args,Goal) :-
1759 insert_constraint_internal_constraint_name(Constraint,Name),
1760 ( chr_pp_flag(debugable,on) ->
1761 Goal =.. [Name, Vars, Self, Closure | Args]
1762 ; ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)))->
1763 Goal =.. [Name,Self | Args]
1765 Goal =.. [Name,Vars, Self | Args]
1768 insert_constraint_internal_constraint_name(Constraint,Name) :-
1769 make_name('$insert_constraint_internal_',Constraint,Name).
1771 generate_insert_constraint_internal_clause(Constraint,List,Tail) :-
1772 ( is_used_auxiliary_predicate(insert_constraint_internal,Constraint) ->
1773 List = [Clause|Tail],
1774 Clause = (Head :- Body),
1777 insert_constraint_internal_constraint_atom(Constraint, Vars, Suspension, Continuation,Args,Head),
1778 generate_insert_constraint_internal_body(Constraint,Suspension,Continuation,Args,Vars,Body)
1784 generate_insert_constraint_internal_body(Constraint,Susp,Continuation,Args,Vars,Body) :-
1785 static_suspension_term(Constraint,Suspension),
1786 create_static_suspension_field(Constraint,Suspension,state,active,CreateState),
1787 ( chr_pp_flag(debugable,on) ->
1788 get_static_suspension_term_field(continuation,Constraint,Suspension,Continuation),
1789 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
1790 ; may_trigger(Constraint), uses_field(Constraint,generation) ->
1791 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
1793 CreateGeneration = true
1795 ( chr_pp_flag(debugable,on) ->
1796 Constraint = Functor / _,
1797 get_static_suspension_term_field(functor,Constraint,Suspension,Functor)
1801 ( uses_history(Constraint) ->
1802 create_static_suspension_field(Constraint,Suspension,history,t,CreateHistory)
1804 CreateHistory = true
1806 get_static_suspension_term_field(arguments,Constraint,Suspension,Args),
1807 List = [Clause|Tail],
1808 ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)))->
1809 suspension_term_base_fields(Constraint,BaseFields),
1810 ( has_suspension_field(Constraint,id) ->
1811 get_static_suspension_term_field(id,Constraint,Suspension,Id),
1812 GenID = 'chr gen_id'(Id)
1825 ( has_suspension_field(Constraint,id) ->
1826 get_static_suspension_term_field(id,Constraint,Suspension,Id),
1827 GenID = 'chr gen_id'(Id)
1831 generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Vars),
1832 ( chr_pp_flag(guard_locks,off) ->
1835 NoneLocked = 'chr none_locked'( Vars)
1840 IndexedVariablesBody,
1849 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
1850 % novel_production/2
1852 generate_novel_production(List,Tail) :-
1853 ( is_used_auxiliary_predicate(novel_production) ->
1854 List = [Clause|Tail],
1857 '$novel_production'( Self, Tuple) :-
1858 % arg( 3, Self, Ref), % ARGXXX
1859 % 'chr get_mutable'( History, Ref),
1860 arg( 3, Self, History), % ARGXXX
1861 ( hprolog:get_ds( Tuple, History, _) ->
1871 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
1874 generate_extend_history(List,Tail) :-
1875 ( is_used_auxiliary_predicate(extend_history) ->
1876 List = [Clause|Tail],
1879 '$extend_history'( Self, Tuple) :-
1880 % arg( 3, Self, Ref), % ARGXXX
1881 % 'chr get_mutable'( History, Ref),
1882 arg( 3, Self, History), % ARGXXX
1883 hprolog:put_ds( Tuple, History, x, NewHistory),
1884 setarg( 3, Self, NewHistory) % ARGXXX
1890 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
1893 generate_run_suspensions_clauses([],List,List).
1894 generate_run_suspensions_clauses([C|Cs],List,Tail) :-
1895 generate_run_suspensions_clause(C,List,List1),
1896 generate_run_suspensions_clauses(Cs,List1,Tail).
1898 run_suspensions_goal(Constraint,Suspensions,Goal) :-
1899 make_name('$run_suspensions_',Constraint,Name),
1900 Goal =.. [Name,Suspensions].
1902 generate_run_suspensions_clause(Constraint,List,Tail) :-
1903 ( is_used_auxiliary_predicate(run_suspensions,Constraint) ->
1904 List = [Clause1,Clause2|Tail],
1905 run_suspensions_goal(Constraint,[],Clause1),
1906 ( chr_pp_flag(debugable,on) ->
1907 run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head),
1908 get_update_suspension_field(Constraint,Suspension,state,State,triggered,GetState,GetStateValue,UpdateState),
1909 get_update_suspension_field(Constraint,Suspension,state,Post,active,GetPost,GetPostValue,UpdatePost),
1910 get_update_suspension_field(Constraint,Suspension,generation,Gen,Generation,GetGeneration,GetGenerationValue,UpdateGeneration),
1911 get_dynamic_suspension_term_field(continuation,Constraint,Suspension,Continuation,GetContinuation),
1912 run_suspensions_goal(Constraint,Suspensions,Clause2Recursion),
1922 Generation is Gen+1,
1926 'chr debug_event'(wake(Suspension)),
1929 'chr debug_event'(fail(Suspension)), !,
1933 'chr debug_event'(exit(Suspension))
1935 'chr debug_event'(redo(Suspension)),
1940 ( Post==triggered ->
1941 UpdatePost % catching constraints that did not do anything
1951 run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head),
1952 static_suspension_term(Constraint,SuspensionTerm),
1953 get_static_suspension_term_field(arguments,Constraint,SuspensionTerm,Arguments),
1954 append(Arguments,[Suspension],VarsSusp),
1955 make_suspension_continuation_goal(Constraint,VarsSusp,Continuation),
1956 run_suspensions_goal(Constraint,Suspensions,Clause2Recursion),
1957 ( uses_field(Constraint,generation) ->
1958 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,generation,Gen,Generation,GetGeneration,UpdateGeneration),
1959 GenerationHandling = ( GetGeneration, Generation is Gen+1, UpdateGeneration)
1961 GenerationHandling = true
1963 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,state,State,triggered,GetState,UpdateState),
1964 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,state,Post,active,GetPostState,UpdatePostState),
1965 if_used_state(Constraint,removed,
1968 -> ReactivateConstraint
1970 ),ReactivateConstraint,CondReactivate),
1971 ReactivateConstraint =
1977 ( Post==triggered ->
1978 UpdatePostState % catching constraints that did not do anything
1986 Suspension = SuspensionTerm,
1995 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
1997 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1998 generate_attach_increment(Clauses) :-
1999 get_max_constraint_index(N),
2000 ( is_used_auxiliary_predicate(attach_increment), N > 0 ->
2001 Clauses = [Clause1,Clause2],
2002 generate_attach_increment_empty(Clause1),
2004 generate_attach_increment_one(Clause2)
2006 generate_attach_increment_many(N,Clause2)
2012 generate_attach_increment_empty((attach_increment([],_) :- true)).
2014 generate_attach_increment_one(Clause) :-
2015 Head = attach_increment([Var|Vars],Susps),
2016 get_target_module(Mod),
2017 ( chr_pp_flag(guard_locks,off) ->
2020 NotLocked = 'chr not_locked'( Var)
2025 ( get_attr(Var,Mod,VarSusps) ->
2026 sort(VarSusps,SortedVarSusps),
2027 'chr merge_attributes'(Susps,SortedVarSusps,MergedSusps),
2028 put_attr(Var,Mod,MergedSusps)
2030 put_attr(Var,Mod,Susps)
2032 attach_increment(Vars,Susps)
2034 Clause = (Head :- Body).
2036 generate_attach_increment_many(N,Clause) :-
2037 make_attr(N,Mask,SuspsList,Attr),
2038 make_attr(N,OtherMask,OtherSuspsList,OtherAttr),
2039 Head = attach_increment([Var|Vars],Attr),
2040 bagof(G,X ^ Y ^ SY ^ M ^ (member2(SuspsList,OtherSuspsList,X-Y),G = (sort(Y,SY),'chr merge_attributes'(X,SY,M))),Gs),
2041 list2conj(Gs,SortGoals),
2042 bagof(MS,A ^ B ^ C ^ member((A,'chr merge_attributes'(B,C,MS)),Gs), MergedSuspsList),
2043 make_attr(N,MergedMask,MergedSuspsList,NewAttr),
2044 get_target_module(Mod),
2045 ( chr_pp_flag(guard_locks,off) ->
2048 NotLocked = 'chr not_locked'( Var)
2053 ( get_attr(Var,Mod,TOtherAttr) ->
2054 TOtherAttr = OtherAttr,
2056 MergedMask is Mask \/ OtherMask,
2057 put_attr(Var,Mod,NewAttr)
2059 put_attr(Var,Mod,Attr)
2061 attach_increment(Vars,Attr)
2063 Clause = (Head :- Body).
2066 generate_attr_unify_hook(Clauses) :-
2067 get_max_constraint_index(N),
2073 generate_attr_unify_hook_one(Clause)
2075 generate_attr_unify_hook_many(N,Clause)
2079 generate_attr_unify_hook_one(Clause) :-
2080 Head = attr_unify_hook(Susps,Other),
2081 get_target_module(Mod),
2082 get_indexed_constraint(1,C),
2083 ( get_store_type(C,default) ->
2084 make_run_suspensions(NewSusps,SortedSusps,WakeNewSusps),
2085 make_run_suspensions(SortedSusps,SortedSusps,WakeSusps),
2086 ( atomic_types_suspended_constraint(C) ->
2088 SortedSusps = Susps,
2090 SortedOtherSusps = OtherSusps,
2091 MergeGoal = (append(Susps,OtherSusps,List), sort(List,NewSusps)),
2094 SortGoal1 = sort(Susps, SortedSusps),
2095 SortGoal2 = sort(OtherSusps,SortedOtherSusps),
2096 MergeGoal = 'chr merge_attributes'(SortedSusps,SortedOtherSusps,NewSusps),
2097 use_auxiliary_predicate(attach_increment),
2099 ( compound(Other) ->
2100 term_variables(Other,OtherVars),
2101 attach_increment(OtherVars, SortedSusps)
2110 ( get_attr(Other,Mod,OtherSusps) ->
2113 put_attr(Other,Mod,NewSusps),
2116 put_attr(Other,Mod,SortedSusps),
2124 Clause = (Head :- Body)
2125 ; get_store_type(C,var_assoc_store(VarIndex,KeyIndex)) ->
2126 make_run_suspensions(List,List,WakeNewSusps),
2127 MergeGoal = (merge_into_assoc_store(Susps,OtherSusps,List)),
2129 ( get_attr(Other,Mod,OtherSusps) ->
2133 put_attr(Other,Mod,Susps)
2135 Clause = (Head :- Body)
2139 generate_attr_unify_hook_many(N,Clause) :-
2140 make_attr(N,Mask,SuspsList,Attr),
2141 make_attr(N,OtherMask,OtherSuspsList,OtherAttr),
2142 bagof(Sort,A ^ B ^ ( member(A,SuspsList) , Sort = sort(A,B) ) , SortGoalList),
2143 list2conj(SortGoalList,SortGoals),
2144 bagof(B, A ^ member(sort(A,B),SortGoalList), SortedSuspsList),
2145 bagof(C, D ^ E ^ F ^ G ^ (member2(SortedSuspsList,OtherSuspsList,D-E),
2147 'chr merge_attributes'(D,F,G)) ),
2149 bagof(G, D ^ F ^ H ^ member((H,'chr merge_attributes'(D,F,G)),SortMergeGoalList) , MergedSuspsList),
2150 list2conj(SortMergeGoalList,SortMergeGoals),
2151 make_attr(N,MergedMask,MergedSuspsList,MergedAttr),
2152 make_attr(N,Mask,SortedSuspsList,SortedAttr),
2153 Head = attr_unify_hook(Attr,Other),
2154 get_target_module(Mod),
2155 make_run_suspensions_loop(MergedSuspsList,SortedSuspsList,WakeMergedSusps),
2156 make_run_suspensions_loop(SortedSuspsList,SortedSuspsList,WakeSortedSusps),
2157 ( forall((between(1,N,Index), get_indexed_constraint(Index,Constraint)),atomic_types_suspended_constraint(Constraint)) ->
2160 use_auxiliary_predicate(attach_increment),
2162 ( compound(Other) ->
2163 term_variables(Other,OtherVars),
2164 attach_increment(OtherVars,SortedAttr)
2173 ( get_attr(Other,Mod,TOtherAttr) ->
2174 TOtherAttr = OtherAttr,
2176 MergedMask is Mask \/ OtherMask,
2177 put_attr(Other,Mod,MergedAttr),
2180 put_attr(Other,Mod,SortedAttr),
2188 Clause = (Head :- Body).
2190 make_run_suspensions(AllSusps,OneSusps,Goal) :-
2191 make_run_suspensions(1,AllSusps,OneSusps,Goal).
2193 make_run_suspensions(Index,AllSusps,OneSusps,Goal) :-
2194 ( get_indexed_constraint(Index,C), may_trigger(C) ->
2195 use_auxiliary_predicate(run_suspensions,C),
2196 ( wakes_partially(C) ->
2197 run_suspensions_goal(C,OneSusps,Goal)
2199 run_suspensions_goal(C,AllSusps,Goal)
2205 make_run_suspensions_loop(AllSuspsList,OneSuspsList,Goal) :-
2206 make_run_suspensions_loop(AllSuspsList,OneSuspsList,1,Goal).
2208 make_run_suspensions_loop([],[],_,true).
2209 make_run_suspensions_loop([AllSusps|AllSuspsList],[OneSusps|OneSuspsList],I,(Goal,Goals)) :-
2210 make_run_suspensions(I,AllSusps,OneSusps,Goal),
2212 make_run_suspensions_loop(AllSuspsList,OneSuspsList,J,Goals).
2214 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2215 % $insert_in_store_F/A
2216 % $delete_from_store_F/A
2218 generate_insert_delete_constraints([],[]).
2219 generate_insert_delete_constraints([FA|Rest],Clauses) :-
2221 generate_insert_delete_constraint(FA,Clauses,RestClauses)
2223 Clauses = RestClauses
2225 generate_insert_delete_constraints(Rest,RestClauses).
2227 generate_insert_delete_constraint(FA,Clauses,RestClauses) :-
2228 insert_constraint_clause(FA,Clauses,RestClauses1),
2229 RestClauses1 = [DClause|RestClauses],
2230 get_store_type(FA,StoreType),
2231 generate_delete_constraint(StoreType,FA,DClause).
2233 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
2236 insert_constraint_goal(FA,Susp,Vars,Goal) :-
2237 ( chr_pp_flag(inline_insertremove,off) ->
2238 use_auxiliary_predicate(insert_in_store,FA),
2239 insert_constraint_atom(FA,Susp,Goal)
2241 delay_phase_end(validate_store_type_assumptions,
2242 ( insert_constraint_body(FA,Susp,UsedVars,Goal),
2243 insert_constraint_direct_used_vars(UsedVars,Vars)
2248 insert_constraint_direct_used_vars([],_).
2249 insert_constraint_direct_used_vars([Index-Var|Rest],Vars) :-
2250 nth1(Index,Vars,Var),
2251 insert_constraint_direct_used_vars(Rest,Vars).
2253 insert_constraint_atom(FA,Susp,Call) :-
2254 make_name('$insert_in_store_',FA,Functor),
2255 Call =.. [Functor,Susp].
2257 insert_constraint_clause(C,Clauses,RestClauses) :-
2258 ( is_used_auxiliary_predicate(insert_in_store,C) ->
2259 Clauses = [Clause|RestClauses],
2260 Clause = (Head :- InsertCounterInc,VarsBody,Body),
2261 insert_constraint_atom(C,Susp,Head),
2262 insert_constraint_body(C,Susp,UsedVars,Body),
2263 insert_constraint_used_vars(UsedVars,C,Susp,VarsBody),
2264 ( chr_pp_flag(store_counter,on) ->
2265 InsertCounterInc = '$insert_counter_inc'
2267 InsertCounterInc = true
2270 Clauses = RestClauses
2273 insert_constraint_used_vars([],_,_,true).
2274 insert_constraint_used_vars([Index-Var|Rest],C,Susp,(Goal,Goals)) :-
2275 get_dynamic_suspension_term_field(argument(Index),C,Susp,Var,Goal),
2276 insert_constraint_used_vars(Rest,C,Susp,Goals).
2278 insert_constraint_body(C,Susp,UsedVars,Body) :-
2279 get_store_type(C,StoreType),
2280 insert_constraint_body(StoreType,C,Susp,UsedVars,Body).
2282 insert_constraint_body(default,C,Susp,[],Body) :-
2283 global_list_store_name(C,StoreName),
2284 make_get_store_goal(StoreName,Store,GetStoreGoal),
2285 make_update_store_goal(StoreName,Cell,UpdateStoreGoal),
2286 ( chr_pp_flag(debugable,on) ->
2287 Cell = [Susp|Store],
2294 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal),
2298 Cell = [Susp|Store],
2300 ( Store = [NextSusp|_] ->
2307 % get_target_module(Mod),
2308 % get_max_constraint_index(Total),
2310 % generate_attach_body_1(C,Store,Susp,AttachBody)
2312 % generate_attach_body_n(C,Store,Susp,AttachBody)
2316 % 'chr default_store'(Store),
2319 insert_constraint_body(multi_inthash(Indexes),C,Susp,[],Body) :-
2320 generate_multi_inthash_insert_constraint_bodies(Indexes,C,Susp,Body).
2321 insert_constraint_body(multi_hash(Indexes),C,Susp,MixedUsedVars,Body) :-
2322 generate_multi_hash_insert_constraint_bodies(Indexes,C,Susp,Body,MixedUsedVars),
2323 sort_out_used_vars(MixedUsedVars,UsedVars).
2324 insert_constraint_body(global_ground,C,Susp,[],Body) :-
2325 global_ground_store_name(C,StoreName),
2326 make_get_store_goal(StoreName,Store,GetStoreGoal),
2327 make_update_store_goal(StoreName,Cell,UpdateStoreGoal),
2328 ( chr_pp_flag(debugable,on) ->
2329 Cell = [Susp|Store],
2336 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal),
2340 Cell = [Susp|Store],
2342 ( Store = [NextSusp|_] ->
2349 % global_ground_store_name(C,StoreName),
2350 % make_get_store_goal(StoreName,Store,GetStoreGoal),
2351 % make_update_store_goal(StoreName,[Susp|Store],UpdateStoreGoal),
2354 % GetStoreGoal, % nb_getval(StoreName,Store),
2355 % UpdateStoreGoal % b_setval(StoreName,[Susp|Store])
2357 insert_constraint_body(var_assoc_store(VarIndex,AssocIndex),C,Susp,[VarIndex-Variable,AssocIndex-Key],Body) :-
2358 % TODO: generalize to more than one !!!
2359 get_target_module(Module),
2360 Body = ( get_attr(Variable,Module,AssocStore) ->
2361 insert_assoc_store(AssocStore,Key,Susp)
2363 new_assoc_store(AssocStore),
2364 put_attr(Variable,Module,AssocStore),
2365 insert_assoc_store(AssocStore,Key,Susp)
2368 insert_constraint_body(global_singleton,C,Susp,[],Body) :-
2369 global_singleton_store_name(C,StoreName),
2370 make_update_store_goal(StoreName,Susp,UpdateStoreGoal),
2375 insert_constraint_body(multi_store(StoreTypes),C,Susp,UsedVars,Body) :-
2376 find_with_var_identity(
2380 member(ST,StoreTypes),
2381 chr_translate:insert_constraint_body(ST,C,Susp,UV,B)
2385 once(pairup(Bodies,NestedUsedVars,BodiesUsedVars)),
2386 list2conj(Bodies,Body),
2387 sort_out_used_vars(NestedUsedVars,UsedVars).
2390 sort_out_used_vars(NestedUsedVars,UsedVars) :-
2391 flatten(NestedUsedVars,FlatUsedVars),
2392 sort(FlatUsedVars,SortedFlatUsedVars),
2393 sort_out_used_vars1(SortedFlatUsedVars,UsedVars).
2395 sort_out_used_vars1([],[]).
2396 sort_out_used_vars1([I-V],L) :- !, L = [I-V].
2397 sort_out_used_vars1([I-X,J-Y|R],L) :-
2400 sort_out_used_vars1([I-X|R],L)
2403 sort_out_used_vars1([J-Y|R],T)
2406 generate_multi_inthash_insert_constraint_bodies([],_,_,true).
2407 generate_multi_inthash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
2408 multi_hash_store_name(FA,Index,StoreName),
2409 multi_hash_key(FA,Index,Susp,KeyBody,Key),
2413 nb_getval(StoreName,Store),
2414 insert_iht(Store,Key,Susp)
2416 generate_multi_inthash_insert_constraint_bodies(Indexes,FA,Susp,Bodies).
2418 generate_multi_hash_insert_constraint_bodies([],_,_,true,[]).
2419 generate_multi_hash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies),[UsedVars|MoreUsedVars]) :-
2420 multi_hash_store_name(FA,Index,StoreName),
2421 multi_hash_key_direct(FA,Index,Susp,Key,UsedVars),
2422 make_get_store_goal(StoreName,Store,GetStoreGoal),
2426 insert_ht(Store,Key,Susp)
2428 generate_multi_hash_insert_constraint_bodies(Indexes,FA,Susp,Bodies,MoreUsedVars).
2430 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
2433 generate_delete_constraint(StoreType,FA,Clause) :-
2434 generate_delete_constraint_call(FA,Susp,Head),
2435 generate_delete_constraint_body(StoreType,FA,Susp,Body),
2436 ( chr_pp_flag(store_counter,on) ->
2437 DeleteCounterInc = '$delete_counter_inc'
2439 DeleteCounterInc = true
2441 Clause = (Head :- DeleteCounterInc, Body).
2443 generate_delete_constraint_body(default,C,Susp,Body) :-
2444 ( chr_pp_flag(debugable,on) ->
2445 global_list_store_name(C,StoreName),
2446 make_get_store_goal(StoreName,Store,GetStoreGoal),
2447 make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
2450 GetStoreGoal, % nb_getval(StoreName,Store),
2451 'chr sbag_del_element'(Store,Susp,NStore),
2452 UpdateStoreGoal % b_setval(StoreName,NStore)
2455 get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal),
2456 global_list_store_name(C,StoreName),
2457 make_get_store_goal(StoreName,Store,GetStoreGoal),
2458 make_update_store_goal(StoreName,Tail,UpdateStoreGoal),
2459 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1),
2460 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2),
2465 GetStoreGoal, % nb_getval(StoreName,Store),
2468 ( Tail = [NextSusp|_] ->
2474 PredCell = [_,_|Tail],
2475 setarg(2,PredCell,Tail),
2476 ( Tail = [NextSusp|_] ->
2484 % get_target_module(Mod),
2485 % get_max_constraint_index(Total),
2487 % generate_detach_body_1(C,Store,Susp,DetachBody),
2490 % 'chr default_store'(Store),
2494 % generate_detach_body_n(C,Store,Susp,DetachBody),
2497 % 'chr default_store'(Store),
2501 generate_delete_constraint_body(multi_inthash(Indexes),C,Susp,Body) :-
2502 generate_multi_inthash_delete_constraint_bodies(Indexes,C,Susp,Body).
2503 generate_delete_constraint_body(multi_hash(Indexes),C,Susp,Body) :-
2504 generate_multi_hash_delete_constraint_bodies(Indexes,C,Susp,Body).
2505 generate_delete_constraint_body(global_ground,C,Susp,Body) :-
2506 ( chr_pp_flag(debugable,on) ->
2507 global_ground_store_name(C,StoreName),
2508 make_get_store_goal(StoreName,Store,GetStoreGoal),
2509 make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
2512 GetStoreGoal, % nb_getval(StoreName,Store),
2513 'chr sbag_del_element'(Store,Susp,NStore),
2514 UpdateStoreGoal % b_setval(StoreName,NStore)
2517 get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal),
2518 global_ground_store_name(C,StoreName),
2519 make_get_store_goal(StoreName,Store,GetStoreGoal),
2520 make_update_store_goal(StoreName,Tail,UpdateStoreGoal),
2521 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1),
2522 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2),
2527 GetStoreGoal, % nb_getval(StoreName,Store),
2530 ( Tail = [NextSusp|_] ->
2536 PredCell = [_,_|Tail],
2537 setarg(2,PredCell,Tail),
2538 ( Tail = [NextSusp|_] ->
2546 % global_ground_store_name(C,StoreName),
2547 % make_get_store_goal(StoreName,Store,GetStoreGoal),
2548 % make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
2551 % GetStoreGoal, % nb_getval(StoreName,Store),
2552 % 'chr sbag_del_element'(Store,Susp,NStore),
2553 % UpdateStoreGoal % b_setval(StoreName,NStore)
2555 generate_delete_constraint_body(var_assoc_store(VarIndex,AssocIndex),C,Susp,Body) :-
2556 get_target_module(Module),
2557 get_dynamic_suspension_term_field(argument(VarIndex),C,Susp,Variable,VariableGoal),
2558 get_dynamic_suspension_term_field(argument(AssocIndex),C,Susp,Key,KeyGoal),
2561 get_attr(Variable,Module,AssocStore),
2563 delete_assoc_store(AssocStore,Key,Susp)
2565 generate_delete_constraint_body(global_singleton,C,_Susp,Body) :-
2566 global_singleton_store_name(C,StoreName),
2567 make_update_store_goal(StoreName,[],UpdateStoreGoal),
2570 UpdateStoreGoal % b_setval(StoreName,[])
2572 generate_delete_constraint_body(multi_store(StoreTypes),C,Susp,Body) :-
2573 find_with_var_identity(
2577 member(ST,StoreTypes),
2578 chr_translate:generate_delete_constraint_body(ST,C,Susp,B)
2582 list2conj(Bodies,Body).
2584 generate_multi_inthash_delete_constraint_bodies([],_,_,true).
2585 generate_multi_inthash_delete_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
2586 multi_hash_store_name(FA,Index,StoreName),
2587 multi_hash_key(FA,Index,Susp,KeyBody,Key),
2591 nb_getval(StoreName,Store),
2592 delete_iht(Store,Key,Susp)
2594 generate_multi_inthash_delete_constraint_bodies(Indexes,FA,Susp,Bodies).
2595 generate_multi_hash_delete_constraint_bodies([],_,_,true).
2596 generate_multi_hash_delete_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
2597 multi_hash_store_name(FA,Index,StoreName),
2598 multi_hash_key(FA,Index,Susp,KeyBody,Key),
2599 make_get_store_goal(StoreName,Store,GetStoreGoal),
2603 GetStoreGoal, % nb_getval(StoreName,Store),
2604 delete_ht(Store,Key,Susp)
2606 generate_multi_hash_delete_constraint_bodies(Indexes,FA,Susp,Bodies).
2608 generate_delete_constraint_call(FA,Susp,Call) :-
2609 make_name('$delete_from_store_',FA,Functor),
2610 Call =.. [Functor,Susp].
2612 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2615 module_initializer/1,
2616 module_initializers/1.
2618 module_initializers(G), module_initializer(Initializer) <=>
2619 G = (Initializer,Initializers),
2620 module_initializers(Initializers).
2622 module_initializers(G) <=>
2625 generate_attach_code(Constraints,[Enumerate|L]) :-
2626 enumerate_stores_code(Constraints,Enumerate),
2627 generate_attach_code(Constraints,L,T),
2628 module_initializers(Initializers),
2629 prolog_global_variables_code(PrologGlobalVariables),
2630 T = [('$chr_initialization' :- Initializers),(:- '$chr_initialization')|PrologGlobalVariables].
2632 generate_attach_code([],L,L).
2633 generate_attach_code([C|Cs],L,T) :-
2634 get_store_type(C,StoreType),
2635 generate_attach_code(StoreType,C,L,L1),
2636 generate_attach_code(Cs,L1,T).
2638 generate_attach_code(default,C,L,T) :-
2639 global_list_store_initialisation(C,L,T).
2640 generate_attach_code(multi_inthash(Indexes),C,L,T) :-
2641 multi_inthash_store_initialisations(Indexes,C,L,L1),
2642 multi_inthash_via_lookups(Indexes,C,L1,T).
2643 generate_attach_code(multi_hash(Indexes),C,L,T) :-
2644 multi_hash_store_initialisations(Indexes,C,L,L1),
2645 multi_hash_via_lookups(Indexes,C,L1,T).
2646 generate_attach_code(global_ground,C,L,T) :-
2647 global_ground_store_initialisation(C,L,T).
2648 generate_attach_code(var_assoc_store(_,_),_,L,L) :-
2649 use_auxiliary_module(chr_assoc_store).
2650 generate_attach_code(global_singleton,C,L,T) :-
2651 global_singleton_store_initialisation(C,L,T).
2652 generate_attach_code(multi_store(StoreTypes),C,L,T) :-
2653 multi_store_generate_attach_code(StoreTypes,C,L,T).
2655 multi_store_generate_attach_code([],_,L,L).
2656 multi_store_generate_attach_code([ST|STs],C,L,T) :-
2657 generate_attach_code(ST,C,L,L1),
2658 multi_store_generate_attach_code(STs,C,L1,T).
2660 multi_inthash_store_initialisations([],_,L,L).
2661 multi_inthash_store_initialisations([Index|Indexes],FA,L,T) :-
2662 use_auxiliary_module(chr_integertable_store),
2663 multi_hash_store_name(FA,Index,StoreName),
2664 module_initializer((new_iht(HT),nb_setval(StoreName,HT))),
2665 % L = [(:- (chr_integertable_store:new_ht(HT),nb_setval(StoreName,HT)) )|L1],
2667 multi_inthash_store_initialisations(Indexes,FA,L1,T).
2668 multi_hash_store_initialisations([],_,L,L).
2669 multi_hash_store_initialisations([Index|Indexes],FA,L,T) :-
2670 use_auxiliary_module(chr_hashtable_store),
2671 multi_hash_store_name(FA,Index,StoreName),
2672 prolog_global_variable(StoreName),
2673 make_init_store_goal(StoreName,HT,InitStoreGoal),
2674 module_initializer((new_ht(HT),InitStoreGoal)),
2676 multi_hash_store_initialisations(Indexes,FA,L1,T).
2678 global_list_store_initialisation(C,L,T) :-
2679 global_list_store_name(C,StoreName),
2680 prolog_global_variable(StoreName),
2681 make_init_store_goal(StoreName,[],InitStoreGoal),
2682 module_initializer(InitStoreGoal),
2684 global_ground_store_initialisation(C,L,T) :-
2685 global_ground_store_name(C,StoreName),
2686 prolog_global_variable(StoreName),
2687 make_init_store_goal(StoreName,[],InitStoreGoal),
2688 module_initializer(InitStoreGoal),
2690 global_singleton_store_initialisation(C,L,T) :-
2691 global_singleton_store_name(C,StoreName),
2692 prolog_global_variable(StoreName),
2693 make_init_store_goal(StoreName,[],InitStoreGoal),
2694 module_initializer(InitStoreGoal),
2697 multi_inthash_via_lookups([],_,L,L).
2698 multi_inthash_via_lookups([Index|Indexes],C,L,T) :-
2699 multi_hash_via_lookup_name(C,Index,PredName),
2700 Head =.. [PredName,Key,SuspsList],
2701 multi_hash_store_name(C,Index,StoreName),
2704 nb_getval(StoreName,HT),
2705 lookup_iht(HT,Key,SuspsList)
2707 L = [(Head :- Body)|L1],
2708 multi_inthash_via_lookups(Indexes,C,L1,T).
2709 multi_hash_via_lookups([],_,L,L).
2710 multi_hash_via_lookups([Index|Indexes],C,L,T) :-
2711 multi_hash_via_lookup_name(C,Index,PredName),
2712 Head =.. [PredName,Key,SuspsList],
2713 multi_hash_store_name(C,Index,StoreName),
2714 make_get_store_goal(StoreName,HT,GetStoreGoal),
2717 GetStoreGoal, % nb_getval(StoreName,HT),
2718 lookup_ht(HT,Key,SuspsList)
2720 L = [(Head :- Body)|L1],
2721 multi_hash_via_lookups(Indexes,C,L1,T).
2723 multi_hash_via_lookup_name(F/A,Index,Name) :-
2727 atom_concat_list(Index,IndexName)
2729 atom_concat_list(['$via1_multi_hash_',F,(/),A,'-',IndexName],Name).
2731 multi_hash_store_name(F/A,Index,Name) :-
2732 get_target_module(Mod),
2736 atom_concat_list(Index,IndexName)
2738 atom_concat_list(['$chr_store_multi_hash_',Mod,(:),F,(/),A,'-',IndexName],Name).
2740 multi_hash_key(FA,Index,Susp,KeyBody,Key) :-
2741 ( ( integer(Index) ->
2746 get_dynamic_suspension_term_field(argument(I),FA,Susp,Key,KeyBody)
2748 sort(Index,Indexes),
2749 find_with_var_identity(Goal-KeyI,[Susp],(member(I,Indexes),get_dynamic_suspension_term_field(argument(I),FA,Susp,KeyI,Goal)),ArgKeyPairs),
2750 once(pairup(Bodies,Keys,ArgKeyPairs)),
2752 list2conj(Bodies,KeyBody)
2755 multi_hash_key_direct(FA,Index,Susp,Key,UsedVars) :-
2756 ( ( integer(Index) ->
2763 sort(Index,Indexes),
2764 pairup(Indexes,Keys,UsedVars),
2768 multi_hash_key_args(Index,Head,KeyArgs) :-
2770 arg(Index,Head,Arg),
2773 sort(Index,Indexes),
2774 term_variables(Head,Vars),
2775 find_with_var_identity(Arg,Vars,(member(I,Indexes), arg(I,Head,Arg)),KeyArgs)
2778 global_list_store_name(F/A,Name) :-
2779 get_target_module(Mod),
2780 atom_concat_list(['$chr_store_global_list_',Mod,(:),F,(/),A],Name).
2781 global_ground_store_name(F/A,Name) :-
2782 get_target_module(Mod),
2783 atom_concat_list(['$chr_store_global_ground_',Mod,(:),F,(/),A],Name).
2784 global_singleton_store_name(F/A,Name) :-
2785 get_target_module(Mod),
2786 atom_concat_list(['$chr_store_global_singleton_',Mod,(:),F,(/),A],Name).
2789 prolog_global_variable/1,
2790 prolog_global_variables/1.
2792 :- chr_option(mode,prolog_global_variable(+)).
2793 :- chr_option(mode,prolog_global_variable(2)).
2795 prolog_global_variable(Name) \ prolog_global_variable(Name) <=> true.
2797 prolog_global_variables(List), prolog_global_variable(Name) <=>
2799 prolog_global_variables(Tail).
2800 prolog_global_variables(List) <=> List = [].
2803 prolog_global_variables_code(Code) :-
2804 prolog_global_variables(Names),
2808 findall('$chr_prolog_global_variable'(Name),member(Name,Names),NameDeclarations),
2809 Code = [(:- dynamic user:exception/3),
2810 (:- multifile user:exception/3),
2811 (user:exception(undefined_global_variable,Name,retry) :-
2813 '$chr_prolog_global_variable'(Name),
2814 '$chr_initialization'
2823 prolog_global_variables_code([]).
2825 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2826 %sbag_member_call(S,L,sysh:mem(S,L)).
2827 sbag_member_call(S,L,'chr sbag_member'(S,L)).
2828 %sbag_member_call(S,L,member(S,L)).
2829 update_mutable_call(A,B,'chr update_mutable'( A, B)).
2830 %update_mutable_call(A,B,setarg(1, B, A)).
2831 create_mutable_call(Value,Mutable,true) :- Mutable = mutable(Value).
2832 % create_mutable_call(Value,Mutable,'chr create_mutable'(Value,Mutable)).
2834 % get_suspension_field(Constraint,Susp,FieldName,Value,(Get0,Get1)) :-
2835 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0),
2836 % create_get_mutable(Value,Field,Get1).
2838 % update_suspension_field(Constraint,Susp,FieldName,NewValue,(Get,Set)) :-
2839 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get),
2840 % update_mutable_call(NewValue,Field,Set).
2842 % get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,Get0,Get1,Set) :-
2843 % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0),
2844 % create_get_mutable_ref(Value,Field,Get1),
2845 % update_mutable_call(NewValue,Field,Set).
2847 % create_static_suspension_field(Constraint,Susp,FieldName,Value,Create) :-
2848 % get_static_suspension_term_field(FieldName,Constraint,Susp,Field),
2849 % create_mutable_call(Value,Field,Create).
2851 % get_static_suspension_field(Constraint,Susp,FieldName,Value,Get) :-
2852 % get_static_suspension_term_field(FieldName,Constraint,Susp,Field),
2853 % create_get_mutable(Value,Field,Get).
2855 % get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,Get,Set) :-
2856 % get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Field),
2857 % create_get_mutable_ref(Value,Field,Get),
2858 % update_mutable_call(NewValue,Field,Set).
2860 get_suspension_field(Constraint,Susp,FieldName,Value,Get) :-
2861 get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get).
2863 update_suspension_field(Constraint,Susp,FieldName,NewValue,Set) :-
2864 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
2866 get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,true,Get,Set) :-
2867 get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get),
2868 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
2870 create_static_suspension_field(Constraint,Susp,FieldName,Value,true) :-
2871 get_static_suspension_term_field(FieldName,Constraint,Susp,Value).
2873 get_static_suspension_field(Constraint,Susp,FieldName,Value,true) :-
2874 get_static_suspension_term_field(FieldName,Constraint,Susp,Value).
2876 get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,true,Set) :-
2877 get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Value),
2878 set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
2880 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2882 enumerate_stores_code(Constraints,Clause) :-
2883 Head = '$enumerate_constraints'(Constraint),
2884 enumerate_store_bodies(Constraints,Constraint,Bodies),
2885 list2disj(Bodies,Body),
2886 Clause = (Head :- Body).
2888 enumerate_store_bodies([],_,[]).
2889 enumerate_store_bodies([C|Cs],Constraint,L) :-
2891 get_store_type(C,StoreType),
2892 enumerate_store_body(StoreType,C,Suspension,SuspensionBody),
2893 get_dynamic_suspension_term_field(arguments,C,Suspension,Arguments,DynamicGoal),
2895 Constraint0 =.. [F|Arguments],
2896 Body = (SuspensionBody, DynamicGoal, Constraint = Constraint0),
2901 enumerate_store_bodies(Cs,Constraint,T).
2903 enumerate_store_body(default,C,Susp,Body) :-
2904 global_list_store_name(C,StoreName),
2905 sbag_member_call(Susp,List,Sbag),
2906 make_get_store_goal(StoreName,List,GetStoreGoal),
2909 GetStoreGoal, % nb_getval(StoreName,List),
2912 % get_constraint_index(C,Index),
2913 % get_target_module(Mod),
2914 % get_max_constraint_index(MaxIndex),
2917 % 'chr default_store'(GlobalStore),
2918 % get_attr(GlobalStore,Mod,Attr)
2921 % NIndex is Index + 1,
2922 % sbag_member_call(Susp,List,Sbag),
2925 % arg(NIndex,Attr,List),
2929 % sbag_member_call(Susp,Attr,Sbag),
2932 % Body = (Body1,Body2).
2933 enumerate_store_body(multi_inthash([Index|_]),C,Susp,Body) :-
2934 multi_inthash_enumerate_store_body(Index,C,Susp,Body).
2935 enumerate_store_body(multi_hash([Index|_]),C,Susp,Body) :-
2936 multi_hash_enumerate_store_body(Index,C,Susp,Body).
2937 enumerate_store_body(global_ground,C,Susp,Body) :-
2938 global_ground_store_name(C,StoreName),
2939 sbag_member_call(Susp,List,Sbag),
2940 make_get_store_goal(StoreName,List,GetStoreGoal),
2943 GetStoreGoal, % nb_getval(StoreName,List),
2946 enumerate_store_body(var_assoc_store(_,_),C,_,Body) :-
2948 enumerate_store_body(global_singleton,C,Susp,Body) :-
2949 global_singleton_store_name(C,StoreName),
2950 make_get_store_goal(StoreName,Susp,GetStoreGoal),
2953 GetStoreGoal, % nb_getval(StoreName,Susp),
2956 enumerate_store_body(multi_store(STs),C,Susp,Body) :-
2959 enumerate_store_body(ST,C,Susp,Body)
2962 multi_inthash_enumerate_store_body(I,C,Susp,B) :-
2963 multi_hash_store_name(C,I,StoreName),
2966 nb_getval(StoreName,HT),
2969 multi_hash_enumerate_store_body(I,C,Susp,B) :-
2970 multi_hash_store_name(C,I,StoreName),
2971 make_get_store_goal(StoreName,HT,GetStoreGoal),
2974 GetStoreGoal, % nb_getval(StoreName,HT),
2978 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2986 :- chr_option(mode,prev_guard_list(+,+,+,+,+,+,+)).
2987 :- chr_option(mode,simplify_guards(+)).
2988 :- chr_option(mode,set_all_passive(+)).
2990 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2991 % GUARD SIMPLIFICATION
2992 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2993 % If the negation of the guards of earlier rules entails (part of)
2994 % the current guard, the current guard can be simplified. We can only
2995 % use earlier rules with a head that matches if the head of the current
2996 % rule does, and which make it impossible for the current rule to match
2997 % if they fire (i.e. they shouldn't be propagation rules and their
2998 % head constraints must be subsets of those of the current rule).
2999 % At this point, we know for sure that the negation of the guard
3000 % of such a rule has to be true (otherwise the earlier rule would have
3001 % fired, because of the refined operational semantics), so we can use
3002 % that information to simplify the guard by replacing all entailed
3003 % conditions by true/0. As a consequence, the never-stored analysis
3004 % (in a further phase) will detect more cases of never-stored constraints.
3006 % e.g. c(X),d(Y) <=> X > 0 | ...
3007 % e(X) <=> X < 0 | ...
3008 % c(X) \ d(Y),e(Z) <=> X =< 0, Z >= 0, ... | ...
3012 guard_simplification :-
3013 ( chr_pp_flag(guard_simplification,on) ->
3014 multiple_occ_constraints_checked([]),
3020 % for every rule, we create a prev_guard_list where the last argument
3021 % eventually is a list of the negations of earlier guards
3022 rule(RuleNb,Rule) \ simplify_guards(RuleNb) <=>
3023 Rule = pragma(rule(Head1,Head2,G,_B),_Ids,_Pragmas,_Name,RuleNb),
3024 append(Head1,Head2,Heads),
3025 make_head_matchings_explicit_not_negated(Heads,UniqueVarsHeads,Matchings),
3026 add_guard_to_head(Heads,G,GHeads),
3027 PrevRule is RuleNb-1,
3028 prev_guard_list(RuleNb,PrevRule,UniqueVarsHeads,G,[],Matchings,[GHeads]),
3029 multiple_occ_constraints_checked([]),
3030 NextRule is RuleNb+1, simplify_guards(NextRule).
3032 simplify_guards(_) <=> true.
3034 % the negation of the guard of a non-propagation rule is added
3035 % if its kept head constraints are a subset of the kept constraints of
3036 % the rule we're working on, and its removed head constraints (at least one)
3037 % are a subset of the removed constraints
3038 rule(N,Rule) \ prev_guard_list(RuleNb,N,H,G,GuardList,M,GH) <=>
3039 Rule = pragma(rule(H1,H2,G2,_B),_Ids,_Pragmas,_Name,N),
3041 append(H1,H2,Heads),
3042 make_head_matchings_explicit(Heads,UniqueVarsHeads,Matchings),
3043 setof(Renaming,chr_translate:head_subset(UniqueVarsHeads,H,Renaming),Renamings),
3046 compute_derived_info(Matchings,Renamings,UniqueVarsHeads,Heads,G2,M,H,GH,DerivedInfo,GH_New1),
3047 append(GuardList,DerivedInfo,GL1),
3050 append(GH_New1,GH,GH1),
3052 conj2list(GH_,GH_New),
3054 prev_guard_list(RuleNb,N1,H,G,GL,M,GH_New).
3057 % if this isn't the case, we skip this one and try the next rule
3058 prev_guard_list(RuleNb,N,H,G,GuardList,M,GH) <=> N > 0 |
3059 N1 is N-1, prev_guard_list(RuleNb,N1,H,G,GuardList,M,GH).
3061 prev_guard_list(RuleNb,0,H,G,GuardList,M,GH) <=>
3063 add_type_information_(H,GH,TypeInfo),
3064 conj2list(TypeInfo,TI),
3065 term_variables(H,HeadVars),
3066 append([chr_pp_headvariables(HeadVars)|TI],GuardList,Info),
3067 list2conj(Info,InfoC),
3068 conj2list(InfoC,InfoL),
3069 prev_guard_list(RuleNb,0,H,G,InfoL,M,[]).
3071 add_type_information_(H,[],true) :- !.
3072 add_type_information_(H,[GH|GHs],TI) :- !,
3073 add_type_information(H,GH,TI1),
3075 add_type_information_(H,GHs,TI2).
3077 % when all earlier guards are added or skipped, we simplify the guard.
3078 % if it's different from the original one, we change the rule
3079 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]), rule(RuleNb,Rule) <=>
3080 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
3081 G \== true, % let's not try to simplify this ;)
3082 append(M,GuardList,Info),
3083 simplify_guard(G,B,Info,SimpleGuard,NB),
3085 rule(RuleNb,pragma(rule(Head1,Head2,SimpleGuard,NB),Ids,Pragmas,Name,RuleNb)),
3086 prev_guard_list(RuleNb,0,H,SimpleGuard,GuardList,M,[]).
3089 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3090 % AUXILIARY PREDICATES (GUARD SIMPLIFICATION)
3091 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3093 compute_derived_info(Matchings,[],UniqueVarsHeads,Heads,G2,M,H,GH,[],[]) :- !.
3095 compute_derived_info(Matchings,[Renaming1|RR],UniqueVarsHeads,Heads,G2,M,H,GH,DerivedInfo,GH_New) :- !,
3096 copy_term(Matchings-G2,FreshMatchings),
3097 variable_replacement(Matchings-G2,FreshMatchings,ExtraRenaming),
3098 append(Renaming1,ExtraRenaming,Renaming2),
3099 list2conj(Matchings,Match),
3100 negate_b(Match,HeadsDontMatch),
3101 make_head_matchings_explicit_not_negated2(Heads,UniqueVarsHeads,HeadsMatch),
3102 list2conj(HeadsMatch,HeadsMatchBut),
3103 term_variables(Renaming2,RenVars),
3104 term_variables(Matchings-G2-HeadsMatch,MGVars),
3105 new_vars(MGVars,RenVars,ExtraRenaming2),
3106 append(Renaming2,ExtraRenaming2,Renaming),
3107 negate_b(G2,TheGuardFailed),
3108 ( G2 == true -> % true can't fail
3109 Info_ = HeadsDontMatch
3111 Info_ = (HeadsDontMatch ; (HeadsMatchBut, TheGuardFailed))
3113 copy_with_variable_replacement(Info_,DerivedInfo1,Renaming),
3114 copy_with_variable_replacement(G2,RenamedG2,Renaming),
3115 copy_with_variable_replacement(Matchings,RenamedMatchings_,Renaming),
3116 list2conj(RenamedMatchings_,RenamedMatchings),
3117 add_guard_to_head(H,RenamedG2,GH2),
3118 add_guard_to_head(GH2,RenamedMatchings,GH3),
3119 compute_derived_info(Matchings,RR,UniqueVarsHeads,Heads,G2,M,H,GH,DerivedInfo2,GH_New2),
3120 append([DerivedInfo1],DerivedInfo2,DerivedInfo),
3121 append([GH3],GH_New2,GH_New).
3124 simplify_guard(G,B,Info,SG,NB) :-
3126 guard_entailment:simplify_guards(Info,B,LG,SGL,NB),
3131 new_vars([A|As],RV,ER) :-
3132 ( memberchk_eq(A,RV) ->
3135 ER = [A-NewA,NewA-A|ER2],
3139 % check if a list of constraints is a subset of another list of constraints
3140 % (multiset-subset), meanwhile computing a variable renaming to convert
3141 % one into the other.
3142 head_subset(H,Head,Renaming) :-
3143 head_subset(H,Head,Renaming,[],_).
3145 % empty list is a subset of everything
3146 head_subset([],Head,Renaming,Cumul,Headleft) :- !,
3150 % first constraint has to be in the list, the rest has to be a subset
3151 % of the list with one occurrence of the first constraint removed
3152 % (has to be multiset-subset)
3153 head_subset([A|B],Head,Renaming,Cumul,Headleft) :- !,
3154 head_subset(A,Head,R1,Cumul,Headleft1),
3155 head_subset(B,Headleft1,R2,R1,Headleft2),
3157 Headleft = Headleft2.
3159 % check if A is in the list, remove it from Headleft
3160 head_subset(A,[X|Y],Renaming,Cumul,Headleft) :- !,
3161 ( head_subset(A,X,R1,Cumul,HL1),
3165 head_subset(A,Y,R2,Cumul,HL2),
3170 % A is X if there's a variable renaming to make them identical
3171 head_subset(A,X,Renaming,Cumul,Headleft) :-
3172 variable_replacement(A,X,Cumul,Renaming),
3175 make_head_matchings_explicit(Heads,UniqueVarsHeads,Matchings) :-
3176 extract_variables(Heads,VH1),
3177 make_matchings_explicit(VH1,H1_,[],[],_,Matchings),
3178 insert_variables(H1_,Heads,UniqueVarsHeads).
3180 make_head_matchings_explicit_not_negated(Heads,UniqueVarsHeads,Matchings) :-
3181 extract_variables(Heads,VH1),
3182 make_matchings_explicit_not_negated(VH1,H1_,[],Matchings),
3183 insert_variables(H1_,Heads,UniqueVarsHeads).
3185 make_head_matchings_explicit_not_negated2(Heads,UniqueVarsHeads,Matchings) :-
3186 extract_variables(Heads,VH1),
3187 extract_variables(UniqueVarsHeads,UV),
3188 make_matchings_explicit_not_negated(VH1,UV,[],Matchings).
3191 extract_variables([],[]).
3192 extract_variables([X|R],V) :-
3194 extract_variables(R,V2),
3197 insert_variables([],[],[]) :- !.
3198 insert_variables(Vars,[C|R],[C2|R2]) :-
3201 take_first_N(Vars,N,Args2,RestVars),
3203 insert_variables(RestVars,R,R2).
3205 take_first_N(Vars,0,[],Vars) :- !.
3206 take_first_N([X|R],N,[X|R2],RestVars) :-
3208 take_first_N(R,N1,R2,RestVars).
3210 make_matchings_explicit([],[],_,MC,MC,[]).
3211 make_matchings_explicit([X|R],[NewVar|R2],C,MC,MCO,M) :-
3213 ( memberchk_eq(X,C) ->
3214 list2disj(MC,MC_disj),
3215 M = [(MC_disj ; NewVar == X)|M2], % or only = ??
3226 make_matchings_explicit(Args,NewArgs,C,MC,MC_,ArgM),
3229 M = [functor(NewVar,F,A) |M2]
3231 list2conj(ArgM,ArgM_conj),
3232 list2disj(MC,MC_disj),
3233 ArgM_ = (NewVar \= X_ ; MC_disj ; ArgM_conj),
3234 M = [ functor(NewVar,F,A) , ArgM_|M2]
3236 MC2 = [ NewVar \= X_ |MC_],
3237 term_variables(Args,ArgVars),
3238 append(C,ArgVars,C2)
3240 make_matchings_explicit(R,R2,C2,MC2,MCO,M2).
3243 make_matchings_explicit_not_negated([],[],_,[]).
3244 make_matchings_explicit_not_negated([X|R],[NewVar|R2],C,M) :-
3245 M = [NewVar = X|M2],
3247 make_matchings_explicit_not_negated(R,R2,C2,M2).
3250 add_guard_to_head([],G,[]).
3251 add_guard_to_head([H|RH],G,[GH|RGH]) :-
3253 find_guard_info_for_var(H,G,GH)
3257 add_guard_to_head(HArgs,G,NewHArgs),
3260 add_guard_to_head(RH,G,RGH).
3262 find_guard_info_for_var(H,(G1,G2),GH) :- !,
3263 find_guard_info_for_var(H,G1,GH1),
3264 find_guard_info_for_var(GH1,G2,GH).
3266 find_guard_info_for_var(H,G,GH) :-
3267 (G = (H1 = A), H == H1 ->
3270 (G = functor(H2,HF,HA), H == H2, ground(HF), ground(HA) ->
3278 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3279 % ALWAYS FAILING HEADS
3280 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3282 rule(RuleNb,Rule) \ prev_guard_list(RuleNb,0,H,G,GuardList,M,[]) <=>
3283 chr_pp_flag(check_impossible_rules,on),
3284 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
3285 append(M,GuardList,Info),
3286 guard_entailment:entails_guard(Info,fail) |
3287 chr_warning(weird_program,'Heads will never match in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]),
3288 set_all_passive(RuleNb).
3290 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3291 % HEAD SIMPLIFICATION
3292 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3294 % now we check the head matchings (guard may have been simplified meanwhile)
3295 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]) \ rule(RuleNb,Rule) <=>
3296 Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
3297 simplify_heads(M,GuardList,G,B,NewM,NewB),
3299 extract_variables(Head1,VH1),
3300 extract_variables(Head2,VH2),
3301 extract_variables(H,VH),
3302 replace_some_heads(VH1,VH2,VH,NewM,H1,H2,G,B,NewB_),
3303 insert_variables(H1,Head1,NewH1),
3304 insert_variables(H2,Head2,NewH2),
3305 append(NewB,NewB_,NewBody),
3306 list2conj(NewBody,BodyMatchings),
3307 NewRule = pragma(rule(NewH1,NewH2,G,(BodyMatchings,B)),Ids,Pragmas,Name,RuleNb),
3308 (Head1 \== NewH1 ; Head2 \== NewH2 )
3310 rule(RuleNb,NewRule).
3314 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3315 % AUXILIARY PREDICATES (HEAD SIMPLIFICATION)
3316 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3318 replace_some_heads(H1,H2,NH,[],H1,H2,G,Body,[]) :- !.
3319 replace_some_heads([],[H2|RH2],[NH|RNH],[M|RM],[],[H2_|RH2_],G,Body,NewB) :- !,
3322 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB)
3324 (M = functor(X,F,A), NH == X ->
3330 H2 =.. [F|OrigArgs],
3331 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
3334 replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB2),
3335 append(NewB1,NewB2,NewB)
3338 replace_some_heads([],RH2,RNH,[M|RM],[],RH2_,G,Body,NewB)
3342 replace_some_heads([H1|RH1],H2,[NH|RNH],[M|RM],[H1_|RH1_],H2_,G,Body,NewB) :- !,
3345 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB)
3347 (M = functor(X,F,A), NH == X ->
3353 H1 =.. [F|OrigArgs],
3354 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
3357 replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB2),
3358 append(NewB1,NewB2,NewB)
3361 replace_some_heads(RH1,H2,RNH,[M|RM],RH1_,H2_,G,Body,NewB)
3365 use_same_args([],[],[],_,_,[]).
3366 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
3369 use_same_args(ROA,RNA,ROut,G,Body,NewB).
3370 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
3372 ( vars_occur_in(OA,Body) ->
3373 NewB = [NA = OA|NextB]
3378 use_same_args(ROA,RNA,ROut,G,Body,NextB).
3381 simplify_heads([],_GuardList,_G,_Body,[],[]).
3382 simplify_heads([M|RM],GuardList,G,Body,NewM,NewB) :-
3384 ( (nonvar(B) ; vars_occur_in(B,RM-GuardList)),
3385 guard_entailment:entails_guard(GuardList,(A=B)) ->
3386 ( vars_occur_in(B,G-RM-GuardList) ->
3390 ( vars_occur_in(B,Body) ->
3391 NewB = [A = B|NextB]
3398 ( nonvar(B), functor(B,BFu,BAr),
3399 guard_entailment:entails_guard([functor(A,BFu,BAr)|GuardList],(A=B)) ->
3401 ( vars_occur_in(B,G-RM-GuardList) ->
3404 NewM = [functor(A,BFu,BAr)|NextM]
3411 simplify_heads(RM,[M|GuardList],G,Body,NextM,NextB).
3413 vars_occur_in(B,G) :-
3414 term_variables(B,BVars),
3415 term_variables(G,GVars),
3416 intersect_eq(BVars,GVars,L),
3420 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3421 % ALWAYS FAILING GUARDS
3422 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3424 set_all_passive(RuleNb), occurrence(_,_,RuleNb,ID,_) ==> passive(RuleNb,ID).
3425 set_all_passive(_) <=> true.
3427 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]),rule(RuleNb,Rule) ==>
3428 chr_pp_flag(check_impossible_rules,on),
3429 Rule = pragma(rule(_,_,G,_),_Ids,_Pragmas,_Name,RuleNb),
3431 guard_entailment:entails_guard(GL,fail) |
3432 chr_warning(weird_program,'Guard will always fail in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]),
3433 set_all_passive(RuleNb).
3437 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3438 % OCCURRENCE SUBSUMPTION
3439 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3442 first_occ_in_rule/4,
3444 multiple_occ_constraints_checked/1.
3446 :- chr_option(mode,first_occ_in_rule(+,+,+,+)).
3447 :- chr_option(mode,next_occ_in_rule(+,+,+,+,+,+)).
3448 :- chr_option(mode,multiple_occ_constraints_checked(+)).
3452 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]),
3453 occurrence(C,O,RuleNb,ID,_), occurrence(C,O2,RuleNb,ID2,_), rule(RuleNb,Rule)
3454 \ multiple_occ_constraints_checked(Done) <=>
3456 chr_pp_flag(occurrence_subsumption,on),
3457 Rule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,RuleNb),
3459 \+ memberchk_eq(C,Done) |
3460 first_occ_in_rule(RuleNb,C,O,ID),
3461 multiple_occ_constraints_checked([C|Done]).
3464 occurrence(C,O,RuleNb,ID,_) \ first_occ_in_rule(RuleNb,C,O2,_) <=> O < O2 |
3465 first_occ_in_rule(RuleNb,C,O,ID).
3467 first_occ_in_rule(RuleNb,C,O,ID_o1) <=>
3469 functor(FreshHead,F,A),
3470 next_occ_in_rule(RuleNb,C,O,ID_o1,[],FreshHead).
3472 passive(RuleNb,ID_o2), occurrence(C,O2,RuleNb,ID_o2,_)
3473 \ next_occ_in_rule(RuleNb,C,O,ID_o1,Cond,FH) <=> O2 is O+1 |
3474 next_occ_in_rule(RuleNb,C,O2,ID_o1,NewCond,FH).
3477 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]),
3478 occurrence(C,O2,RuleNb,ID_o2,_), rule(RuleNb,Rule) \
3479 next_occ_in_rule(RuleNb,C,O,ID_o1,Cond,FH) <=>
3481 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb)
3483 append(H1,H2,Heads),
3484 add_failing_occ(Rule,Heads,H,ID_o1,ExtraCond,FH,M,C,Repl),
3485 ( ExtraCond == [chr_pp_void_info] ->
3486 next_occ_in_rule(RuleNb,C,O2,ID_o2,Cond,FH)
3488 append(ExtraCond,Cond,NewCond),
3489 add_failing_occ(Rule,Heads,H,ID_o2,CheckCond,FH,M,C,Repl2),
3490 copy_term(GuardList,FGuardList),
3491 variable_replacement(GuardList,FGuardList,GLRepl),
3492 copy_with_variable_replacement(GuardList,GuardList2,Repl),
3493 copy_with_variable_replacement(GuardList,GuardList3_,Repl2),
3494 copy_with_variable_replacement(GuardList3_,GuardList3,GLRepl),
3495 append(NewCond,GuardList2,BigCond),
3496 append(BigCond,GuardList3,BigCond2),
3497 copy_with_variable_replacement(M,M2,Repl),
3498 copy_with_variable_replacement(M,M3,Repl2),
3499 append(M3,BigCond2,BigCond3),
3500 append([chr_pp_active_constraint(FH)|M2],BigCond3,Info),
3501 list2conj(CheckCond,OccSubsum),
3502 copy_term((NewCond,BigCond2,Info,OccSubsum,FH),(NewCond2,BigCond2_,Info2,OccSubsum2,FH2)),
3503 term_variables(NewCond2-FH2,InfoVars),
3504 flatten_stuff(Info2,Info3),
3505 flatten_stuff(OccSubsum2,OccSubsum3),
3506 ( OccSubsum \= chr_pp_void_info,
3507 unify_stuff(InfoVars,Info3,OccSubsum3), !,
3508 ( guard_entailment:entails_guard(Info2,OccSubsum2) ->
3509 passive(RuleNb,ID_o2)
3515 next_occ_in_rule(RuleNb,C,O2,ID_o2,NewCond,FH)
3519 next_occ_in_rule(RuleNb,C,O,ID,Cond,Args) <=> true.
3520 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]),
3521 multiple_occ_constraints_checked(Done) <=> true.
3523 flatten_stuff([A|B],C) :- !,
3524 flatten_stuff(A,C1),
3525 flatten_stuff(B,C2),
3527 flatten_stuff((A;B),C) :- !,
3528 flatten_stuff(A,C1),
3529 flatten_stuff(B,C2),
3531 flatten_stuff((A,B),C) :- !,
3532 flatten_stuff(A,C1),
3533 flatten_stuff(B,C2),
3536 flatten_stuff(chr_pp_not_in_store(A),[A]) :- !.
3537 flatten_stuff(X,[]).
3539 unify_stuff(AllInfo,[],[]).
3541 unify_stuff(AllInfo,[H|RInfo],[I|ROS]) :-
3543 term_variables(H,HVars),
3544 term_variables(I,IVars),
3545 intersect_eq(HVars,IVars,SharedVars),
3546 check_safe_unif(H,I,SharedVars),
3547 variable_replacement(H,I,Repl),
3548 check_replacement(Repl),
3549 term_variables(Repl,ReplVars),
3550 list_difference_eq(ReplVars,HVars,LDiff),
3551 intersect_eq(AllInfo,LDiff,LDiff2),
3554 unify_stuff(AllInfo,RInfo,ROS),!.
3556 unify_stuff(AllInfo,X,[Y|ROS]) :-
3557 unify_stuff(AllInfo,X,ROS).
3559 unify_stuff(AllInfo,[Y|RInfo],X) :-
3560 unify_stuff(AllInfo,RInfo,X).
3562 check_safe_unif(H,I,SV) :- var(H), !, var(I),
3563 ( (memberchk_eq(H,SV);memberchk_eq(I,SV)) ->
3569 check_safe_unif([],[],SV) :- !.
3570 check_safe_unif([H|Hs],[I|Is],SV) :- !,
3571 check_safe_unif(H,I,SV),!,
3572 check_safe_unif(Hs,Is,SV).
3574 check_safe_unif(H,I,SV) :-
3575 nonvar(H),!,nonvar(I),
3578 check_safe_unif(HA,IA,SV).
3580 check_safe_unif2(H,I) :- var(H), !.
3582 check_safe_unif2([],[]) :- !.
3583 check_safe_unif2([H|Hs],[I|Is]) :- !,
3584 check_safe_unif2(H,I),!,
3585 check_safe_unif2(Hs,Is).
3587 check_safe_unif2(H,I) :-
3588 nonvar(H),!,nonvar(I),
3591 check_safe_unif2(HA,IA).
3594 check_replacement(Repl) :-
3595 check_replacement(Repl,FirstVars),
3596 sort(FirstVars,Sorted),
3598 length(FirstVars,L).
3600 check_replacement([],[]).
3601 check_replacement([A-B|R],[A|RC]) :- check_replacement(R,RC).
3604 add_failing_occ(Rule,Heads,NH,ID_o1,FailCond,FH,M,C,Repl) :-
3605 Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb),
3606 append(ID2,ID1,IDs),
3607 missing_partner_cond(Heads,NH,IDs,ID_o1,MPCond,H,C),
3608 copy_term((H,Heads,NH),(FH2,FHeads,NH2)),
3609 variable_replacement((H,Heads,NH),(FH2,FHeads,NH2),Repl),
3610 copy_with_variable_replacement(G,FG,Repl),
3611 extract_explicit_matchings(FG,FG2),
3612 negate_b(FG2,NotFG),
3613 copy_with_variable_replacement(MPCond,FMPCond,Repl),
3614 ( check_safe_unif2(FH,FH2), FH=FH2 ->
3615 FailCond = [(NotFG;FMPCond)]
3617 % in this case, not much can be done
3618 % e.g. c(f(...)), c(g(...)) <=> ...
3619 FailCond = [chr_pp_void_info]
3624 missing_partner_cond([],[],[],ID_o1,fail,H2,C).
3625 missing_partner_cond([H|Hs],[H2|H2s],[ID_o1|IDs],ID_o1,Cond,H,C) :- !,
3626 missing_partner_cond(Hs,H2s,IDs,ID_o1,Cond,H,C).
3627 missing_partner_cond([H|Hs],[NH|NHs],[ID|IDs],ID_o1,Cond,H2,F/A) :-
3628 Cond = (chr_pp_not_in_store(H);Cond1),
3629 missing_partner_cond(Hs,NHs,IDs,ID_o1,Cond1,H2,F/A).
3632 extract_explicit_matchings(A=B) :-
3633 var(A), var(B), !, A=B.
3634 extract_explicit_matchings(A==B) :-
3635 var(A), var(B), !, A=B.
3637 extract_explicit_matchings((A,B),D) :- !,
3638 ( extract_explicit_matchings(A) ->
3639 extract_explicit_matchings(B,D)
3642 extract_explicit_matchings(B,E)
3644 extract_explicit_matchings(A,D) :- !,
3645 ( extract_explicit_matchings(A) ->
3654 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3656 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3662 get_type_definition/2,
3663 get_constraint_type/2,
3664 add_type_information/3.
3667 :- chr_option(mode,type_definition(?,?)).
3668 :- chr_option(mode,type_alias(?,?)).
3669 :- chr_option(mode,constraint_type(+,+)).
3670 :- chr_option(mode,add_type_information(+,+,?)).
3671 :- chr_option(type_declaration,add_type_information(list,list,any)).
3673 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3674 % Consistency checks of type aliases
3676 type_alias(T,T2) <=>
3677 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
3678 copy_term((T,T2),(X,Y)),oneway_unification(Y,X) |
3679 chr_error(type_error,'Cyclic alias definition: "~w".\n',[(T == T2)]).
3681 type_alias(T1,A1), type_alias(T2,A2) <=>
3682 nonvar(T1),nonvar(T2),functor(T1,F,A),functor(T2,F,A),
3684 copy_term_nat(T1,T1_),
3685 copy_term_nat(T2,T2_),
3687 chr_error(type_error,
3688 '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_]).
3690 type_alias(T,B) \ type_alias(X,T2) <=>
3691 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
3692 copy_term_nat((X,T2,T,B),(X2,T3,T1,D1)),oneway_unification(T3,T1) |
3693 chr_info(type_information,'Inferring `~w\' from `~w\' and `~w\'.\n',[X2==D1,X==T2,T==B]),
3696 oneway_unification(X,Y) :-
3697 term_variables(X,XVars),
3698 chr_runtime:lockv(XVars),
3700 chr_runtime:unlockv(XVars).
3702 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3703 % Consistency checks of type definitions
3705 type_definition(T1,_), type_definition(T2,_)
3707 functor(T1,F,A), functor(T2,F,A)
3709 chr_error(type_error,'Multiple definitions for type: ~w/~w.\n',[F,A]).
3711 type_definition(T1,_), type_alias(T2,_)
3713 functor(T1,F,A), functor(T2,F,A)
3715 chr_error(type_error,'Multiple definitions for type, once in a type definition and once as a type alias: ~w/~w.\n',[F,A]).
3717 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3718 % get_type_definition
3720 get_type_definition(T,Def) <=> \+ ground(T) |
3721 chr_error(type_error,'Non-ground type in constraint definition: "~w".\n',[T]).
3723 type_alias(T,D) \ get_type_definition(T2,Def) <=>
3724 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
3725 copy_term_nat((T,D),(T1,D1)),T1=T2 |
3726 (get_type_definition(D1,Def) ->
3729 chr_error(type_error,'Could not find type definition for "~w" (accessed via alias "~w").\n',[D1,T1]), fail
3732 type_definition(T,D) \ get_type_definition(T2,Def) <=>
3733 nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
3734 copy_term_nat((T,D),(T1,D1)),T1=T2 | Def = D1.
3735 get_type_definition(T2,Def) <=>
3736 builtin_type(T2,_,_) | Def = [T2].
3737 get_type_definition(X,Y) <=> fail.
3739 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3740 % get_constraint_type
3742 constraint_type(C,T) \ get_constraint_type(C,Type) <=> Type = T.
3743 get_constraint_type(_,_) <=> fail.
3745 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3746 % add_type_information
3748 add_type_information([],[],T) <=> T=true.
3750 constraint_mode(F/A,Modes)
3751 \ add_type_information([Head|R],[RealHead|RRH],TypeInfo) <=>
3754 RealHead =.. [_|RealArgs],
3755 add_mode_info(Modes,Args,ModeInfo),
3756 TypeInfo = (ModeInfo, TI),
3757 (get_constraint_type(F/A,Types) ->
3758 types2condition(Types,Args,RealArgs,Modes,TI2),
3759 list2conj(TI2,ConjTI),
3761 add_type_information(R,RRH,RTI)
3763 add_type_information(R,RRH,TI)
3767 add_type_information([Head|R],_,TypeInfo) <=>
3769 chr_error(internal,'Mode information missing for ~w.\n',[F/A]).
3772 add_mode_info([],[],true).
3773 add_mode_info([(+)|Modes],[A|Args],MI) :- !,
3774 MI = (ground(A), ModeInfo),
3775 add_mode_info(Modes,Args,ModeInfo).
3776 add_mode_info([M|Modes],[A|Args],MI) :-
3777 add_mode_info(Modes,Args,MI).
3780 types2condition([],[],[],[],[]).
3781 types2condition([Type|Types],[Arg|Args],[RealArg|RAs],[Mode|Modes],TI) :-
3782 ( get_type_definition(Type,Def) ->
3783 type2condition(Def,Arg,RealArg,TC),
3785 TC_ = [(\+ ground(Arg))|TC]
3789 list2disj(TC_,DisjTC),
3791 types2condition(Types,Args,RAs,Modes,RTI)
3793 chr_error(internal,'Could not find type definition for ~w.\n',[Type])
3797 type2condition([],Arg,_,[]).
3798 type2condition([Def|Defs],Arg,RealArg,TC) :-
3799 ( builtin_type(Def,Arg,C) ->
3802 real_type(Def,Arg,RealArg,C)
3805 type2condition(Defs,Arg,RealArg,RTC),
3808 item2list([],[]) :- !.
3809 item2list([X|Y],[X|Y]) :- !.
3810 item2list(N,L) :- L = [N].
3812 builtin_type(X,Arg,true) :- var(X),!.
3813 builtin_type(X,Arg,Goal) :- builtin_type_nonvar(X,Arg,Goal).
3815 builtin_type_nonvar(any,Arg,true).
3816 builtin_type_nonvar(dense_int,Arg,(integer(Arg),Arg>=0)).
3817 builtin_type_nonvar(int,Arg,integer(Arg)).
3818 builtin_type_nonvar(number,Arg,number(Arg)).
3819 builtin_type_nonvar(float,Arg,float(Arg)).
3820 builtin_type_nonvar(natural,Arg,(integer(Arg),Arg>=0)).
3822 real_type(Def,Arg,RealArg,C) :-
3832 C = functor(Arg,F,A)
3834 ( functor(RealArg,F,A) ->
3835 RealArg =.. [_|RAArgs],
3836 nested_types(TArgs,AA,RAArgs,ACond),
3837 C = (functor(Arg,F,A),Arg=Def2,ACond)
3839 C = functor(Arg,F,A)
3844 chr_error(internal,'Illegal type definition (must be nonvar).\n',[])
3846 nested_types([],[],[],true).
3847 nested_types([T|RT],[A|RA],[RealA|RRA],C) :-
3848 ( get_type_definition(T,Def) ->
3849 type2condition(Def,A,RealA,TC),
3850 list2disj(TC,DisjTC),
3852 nested_types(RT,RA,RRA,RC)
3854 chr_error(internal,'Undefined type ~w inside type definition.\n',[T])
3857 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3858 % Static type checking
3859 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3860 % Checks head constraints and CHR constraint calls in bodies.
3863 % - type clashes involving built-in types
3864 % - Prolog built-ins in guard and body
3865 % - indicate position in terms in error messages
3866 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3868 static_type_check/0.
3870 rule(_,Rule), static_type_check
3872 copy_term_nat(Rule,RuleCopy),
3873 RuleCopy = pragma(rule(Head1,Head2,G,Body),ids(IDs1,IDs2),Pragmas,Name,RuleNb),
3876 ( static_type_check_heads(Head1),
3877 static_type_check_heads(Head2),
3878 conj2list(Body,GoalList),
3879 static_type_check_body(GoalList)
3882 ( Error = invalid_functor(Src,Term,Type) ->
3883 chr_error(type_error,'Invalid functor in ~@ of ~@:\n\t\tfound `~w\',\n\t\texpected type `~w\'!\n',
3884 [chr_translate:format_src(Src),format_rule(Rule),Term,Type])
3885 ; Error = type_clash(Var,Src1,Src2,Type1,Type2) ->
3886 chr_error(type_error,'Type clash for variable ~w in ~@:\n\t\texpected type ~w in ~@\n\t\texpected type ~w in ~@\n',
3887 [Var,format_rule(Rule),Type1,chr_translate:format_src(Src1),Type2,chr_translate:format_src(Src2)])
3890 fail % cleanup constraints
3896 static_type_check <=> true.
3898 static_type_check_heads([]).
3899 static_type_check_heads([Head|Heads]) :-
3900 static_type_check_head(Head),
3901 static_type_check_heads(Heads).
3903 static_type_check_head(Head) :-
3905 ( get_constraint_type(F/A,Types) ->
3907 maplist(static_type_check_term(head(Head)),Args,Types)
3908 ; % no type declared
3912 static_type_check_body([]).
3913 static_type_check_body([Goal|Goals]) :-
3915 ( get_constraint_type(F/A,Types) ->
3917 maplist(static_type_check_term(body(Goal)),Args,Types)
3918 ; % not a CHR constraint or no type declared
3921 static_type_check_body(Goals).
3923 :- chr_constraint static_type_check_term/3.
3925 static_type_check_term(Src,Term,Type)
3929 static_type_check_var(Src,Term,Type).
3930 static_type_check_term(Src,Term,Type)
3932 builtin_type_nonvar(Type,Term,Goal)
3937 throw(type_error(invalid_funtor(Src,Term,Type)))
3939 type_alias(AType,ADef) \ static_type_check_term(Src,Term,Type)
3944 copy_term_nat(AType-ADef,Type-Def),
3945 static_type_check_term(Src,Term,Def).
3947 type_definition(AType,ADef) \ static_type_check_term(Src,Term,Type)
3952 copy_term_nat(AType-ADef,Type-Variants),
3953 functor(Term,TF,TA),
3954 ( member(Variant,Variants), functor(Variant,TF,TA) ->
3956 Variant =.. [_|Types],
3957 maplist(static_type_check_term(Src),Args,Types)
3959 throw(type_error(invalid_functor(Src,Term,Type)))
3962 static_type_check_term(Src,Term,Type)
3964 chr_error(internal,'Undefined type ~w while type checking term ~w in ~@.\n',[Type,Term,chr_translate:format_src(Src)]).
3966 :- chr_constraint static_type_check_var/3.
3968 type_alias(AType,ADef) \ static_type_check_var(Src,Var,Type)
3973 copy_term_nat(AType-ADef,Type-Def),
3974 static_type_check_var(Src,Var,Def).
3976 static_type_check_var(Src,Var,Type)
3978 builtin_type_nonvar(Type,_,_)
3983 static_type_check_var(Src1,Var,Type1), static_type_check_var(Src2,Var,Type2)
3987 throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))).
3989 format_src(head(Head)) :- format('head ~w',[Head]).
3990 format_src(body(Goal)) :- format('body goal ~w',[Goal]).
3992 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3993 % Dynamic type checking
3994 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3997 dynamic_type_check/0,
3998 dynamic_type_check_clauses/1,
3999 get_dynamic_type_check_clauses/1.
4001 generate_dynamic_type_check_clauses(Clauses) :-
4002 ( chr_pp_flag(debugable,on) ->
4004 get_dynamic_type_check_clauses(Clauses0),
4006 [('$dynamic_type_check'(Type,Term) :-
4007 throw(error(type_error(Type,Term),context(_,'CHR Runtime Type Error')))
4014 type_definition(T,D), dynamic_type_check
4016 copy_term_nat(T-D,Type-Definition),
4017 maplist(dynamic_type_check_clause(Type),Definition,DynamicChecks),
4018 dynamic_type_check_clauses(DynamicChecks).
4019 type_alias(A,B), dynamic_type_check
4021 copy_term_nat(A-B,Alias-Body),
4022 dynamic_type_check_alias_clause(Alias,Body,Clause),
4023 dynamic_type_check_clauses([Clause]).
4025 dynamic_type_check <=>
4026 findall(('$dynamic_type_check'(Type,Term) :- !, Goal),builtin_type_nonvar(Type,Term,Goal), BuiltinChecks),
4027 dynamic_type_check_clauses(BuiltinChecks).
4029 dynamic_type_check_clause(T,DC,Clause) :-
4030 copy_term(T-DC,Type-DefinitionClause),
4031 functor(DefinitionClause,F,A),
4033 DefinitionClause =.. [_|DCArgs],
4034 Term =.. [_|TermArgs],
4035 maplist(dynamic_type_check_call,DCArgs,TermArgs,RecursiveCallList),
4036 list2conj(RecursiveCallList,RecursiveCalls),
4038 '$dynamic_type_check'(Type,Term) :- !,
4042 dynamic_type_check_alias_clause(Alias,Body,Clause) :-
4044 '$dynamic_type_check'(Alias,Term) :- !,
4045 '$dynamic_type_check'(Body,Term)
4048 dynamic_type_check_call(Type,Term,Call) :-
4049 ( nonvar(Type), builtin_type_nonvar(Type,Term,Goal) ->
4050 Call = when(nonvar(Term),Goal)
4052 Call = when(nonvar(Term),'$dynamic_type_check'(Type,Term))
4055 dynamic_type_check_clauses(C1), dynamic_type_check_clauses(C2)
4058 dynamic_type_check_clauses(C).
4060 get_dynamic_type_check_clauses(Q), dynamic_type_check_clauses(C)
4063 get_dynamic_type_check_clauses(Q)
4067 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4069 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4070 % Some optimizations can be applied for atomic types...
4071 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4073 atomic_types_suspended_constraint(C) :-
4075 get_constraint_type(C,ArgTypes),
4076 get_constraint_mode(C,ArgModes),
4077 findall(I,between(1,N,I),Indexes),
4078 maplist(atomic_types_suspended_constraint(C),ArgTypes,ArgModes,Indexes).
4080 atomic_types_suspended_constraint(C,Type,Mode,Index) :-
4081 ( is_indexed_argument(C,Index) ->
4091 :- chr_constraint atomic_type/1.
4093 atomic_type(Type) <=> builtin_type_nonvar(Type,_,_) | Type \== any.
4095 type_definition(TypePat,Def) \ atomic_type(Type)
4097 functor(Type,F,A), functor(TypePat,F,A)
4099 forall(member(Term,Def),atomic(Term)).
4101 type_alias(TypePat,Alias) \ atomic_type(Type)
4103 functor(Type,F,A), functor(TypePat,F,A)
4106 copy_term_nat(TypePat-Alias,Type-NType),
4109 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4112 stored/3, % constraint,occurrence,(yes/no/maybe)
4113 stored_completing/3,
4116 is_finally_stored/1,
4117 check_all_passive/2.
4119 :- chr_option(mode,stored(+,+,+)).
4120 :- chr_option(type_declaration,stored(any,int,storedinfo)).
4121 :- chr_option(type_definition,type(storedinfo,[yes,no,maybe])).
4122 :- chr_option(mode,stored_complete(+,+,+)).
4123 :- chr_option(mode,maybe_complementary_guards(+,+,?,?)).
4124 :- chr_option(mode,guard_list(+,+,+,+)).
4125 :- chr_option(mode,check_all_passive(+,+)).
4127 % change yes in maybe when yes becomes passive
4128 passive(RuleNb,ID), occurrence(C,O,RuleNb,ID,_) \
4129 stored(C,O,yes), stored_complete(C,RO,Yesses)
4130 <=> O < RO | NYesses is Yesses - 1,
4131 stored(C,O,maybe), stored_complete(C,RO,NYesses).
4132 % change yes in maybe when not observed
4133 ai_not_observed(C,O) \ stored(C,O,yes), stored_complete(C,RO,Yesses)
4135 NYesses is Yesses - 1,
4136 stored(C,O,maybe), stored_complete(C,RO,NYesses).
4138 occurrence(_,_,RuleNb,ID,_), occurrence(C2,_,RuleNb,_,_), stored_complete(C2,RO,0), max_occurrence(C2,MO2)
4139 ==> RO =< MO2 | % C2 is never stored
4145 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4147 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
4148 Rule = pragma(rule(Head1,Head2,G,B),ids([Id|IDs1],IDs2),Pragmas,Name,RuleNb) |
4149 append(IDs1,IDs2,I), check_all_passive(RuleNb,I).
4151 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
4152 Rule = pragma(rule(Head1,Head2,G,B),ids([],[Id|IDs2]),Pragmas,Name,RuleNb) |
4153 check_all_passive(RuleNb,IDs2).
4155 passive(RuleNb,Id) \ check_all_passive(RuleNb,[Id|IDs]) <=>
4156 check_all_passive(RuleNb,IDs).
4158 rule(RuleNb,Rule) \ check_all_passive(RuleNb,[]) <=>
4159 chr_warning(weird_program,'All heads passive in ~@.\n\tThis rule never fires. Please check your program.\n',[format_rule(Rule)]).
4161 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4163 % collect the storage information
4164 stored(C,O,yes) \ stored_completing(C,O,Yesses)
4165 <=> NO is O + 1, NYesses is Yesses + 1,
4166 stored_completing(C,NO,NYesses).
4167 stored(C,O,maybe) \ stored_completing(C,O,Yesses)
4169 stored_completing(C,NO,Yesses).
4171 stored(C,O,no) \ stored_completing(C,O,Yesses)
4172 <=> stored_complete(C,O,Yesses).
4173 stored_completing(C,O,Yesses)
4174 <=> stored_complete(C,O,Yesses).
4176 stored_complete(C,O,Yesses), occurrence(C,O2,RuleNb,Id,_) ==>
4177 O2 > O | passive(RuleNb,Id).
4179 % decide whether a constraint is stored
4180 max_occurrence(C,MO), stored_complete(C,RO,0) \ is_stored(C)
4181 <=> RO =< MO | fail.
4182 is_stored(C) <=> true.
4184 % decide whether a constraint is suspends after occurrences
4185 max_occurrence(C,MO), stored_complete(C,RO,_) \ is_finally_stored(C)
4186 <=> RO =< MO | fail.
4187 is_finally_stored(C) <=> true.
4189 storage_analysis(Constraints) :-
4190 ( chr_pp_flag(storage_analysis,on) ->
4191 check_constraint_storages(Constraints)
4196 check_constraint_storages([]).
4197 check_constraint_storages([C|Cs]) :-
4198 check_constraint_storage(C),
4199 check_constraint_storages(Cs).
4201 check_constraint_storage(C) :-
4202 get_max_occurrence(C,MO),
4203 check_occurrences_storage(C,1,MO).
4205 check_occurrences_storage(C,O,MO) :-
4207 stored_completing(C,1,0)
4209 check_occurrence_storage(C,O),
4211 check_occurrences_storage(C,NO,MO)
4214 check_occurrence_storage(C,O) :-
4215 get_occurrence(C,O,RuleNb,ID),
4216 ( is_passive(RuleNb,ID) ->
4219 get_rule(RuleNb,PragmaRule),
4220 PragmaRule = pragma(rule(Heads1,Heads2,Guard,Body),ids(IDs1,IDs2),_,_,_),
4221 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
4222 check_storage_head1(Head1,O,Heads1,Heads2,Guard)
4223 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
4224 check_storage_head2(Head2,O,Heads1,Body)
4228 check_storage_head1(Head,O,H1,H2,G) :-
4233 guard_entailment:entails_guard([chr_pp_headvariables(Head)],G),
4235 no_matching(L,[]) ->
4242 no_matching([X|Xs],Prev) :-
4244 \+ memberchk_eq(X,Prev),
4245 no_matching(Xs,[X|Prev]).
4247 check_storage_head2(Head,O,H1,B) :-
4251 (H1 \== [], B == true )
4253 % \+ is_observed(F/A,O) % always fails because observation analysis has not been performed yet
4261 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4263 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4264 %% ____ _ ____ _ _ _ _
4265 %% | _ \ _ _| | ___ / ___|___ _ __ ___ _ __ (_) | __ _| |_(_) ___ _ __
4266 %% | |_) | | | | |/ _ \ | | / _ \| '_ ` _ \| '_ \| | |/ _` | __| |/ _ \| '_ \
4267 %% | _ <| |_| | | __/ | |__| (_) | | | | | | |_) | | | (_| | |_| | (_) | | | |
4268 %% |_| \_\\__,_|_|\___| \____\___/|_| |_| |_| .__/|_|_|\__,_|\__|_|\___/|_| |_|
4271 constraints_code(Constraints,Clauses) :-
4272 (chr_pp_flag(reduced_indexing,on),
4273 \+ forsome(C,Constraints,\+ chr_translate:only_ground_indexed_arguments(C)) ->
4274 none_suspended_on_variables
4278 constraints_code1(Constraints,Clauses,[]).
4280 %===============================================================================
4281 :- chr_constraint constraints_code1/3.
4282 :- chr_option(mode,constraints_code1(+,+,+)).
4283 :- chr_option(type_declaration,constraints_code(list,any,any)).
4284 %-------------------------------------------------------------------------------
4285 constraints_code1([],L,T) <=> L = T.
4286 constraints_code1([C|RCs],L,T)
4288 constraint_code(C,L,T1),
4289 constraints_code1(RCs,T1,T).
4290 %===============================================================================
4291 :- chr_constraint constraint_code/3.
4292 :- chr_option(mode,constraint_code(+,+,+)).
4293 %-------------------------------------------------------------------------------
4294 %% Generate code for a single CHR constraint
4295 constraint_code(Constraint, L, T)
4297 | ( (chr_pp_flag(debugable,on) ;
4298 is_stored(Constraint), ( has_active_occurrence(Constraint); chr_pp_flag(late_allocation,off)),
4299 ( may_trigger(Constraint) ;
4300 get_allocation_occurrence(Constraint,AO),
4301 get_max_occurrence(Constraint,MO), MO >= AO ) )
4303 constraint_prelude(Constraint,Clause),
4309 occurrences_code(Constraint,1,Id,NId,L1,L2),
4310 gen_cond_attach_clause(Constraint,NId,L2,T).
4312 %===============================================================================
4313 %% Generate prelude predicate for a constraint.
4314 %% f(...) :- f/a_0(...,Susp).
4315 constraint_prelude(F/A, Clause) :-
4316 vars_susp(A,Vars,Susp,VarsSusp),
4317 Head =.. [ F | Vars],
4318 make_suspension_continuation_goal(F/A,VarsSusp,Continuation),
4319 build_head(F,A,[0],VarsSusp,Delegate),
4320 ( chr_pp_flag(debugable,on) ->
4321 insert_constraint_goal(F/A,Susp,Vars,InsertCall),
4322 attach_constraint_atom(F/A,Vars2,Susp,AttachCall),
4323 delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)),
4324 insert_constraint_internal_constraint_goal(F/A, Vars2, Susp, Continuation, Vars,InsertGoal),
4326 ( get_constraint_type(F/A,ArgTypeList) ->
4327 maplist(dynamic_type_check_call,ArgTypeList,Vars,DynamicTypeCheckList),
4328 list2conj(DynamicTypeCheckList,DynamicTypeChecks)
4330 DynamicTypeChecks = true
4340 'chr debug_event'(insert(Head#Susp)),
4342 'chr debug_event'(call(Susp)),
4345 'chr debug_event'(fail(Susp)), !,
4349 'chr debug_event'(exit(Susp))
4351 'chr debug_event'(redo(Susp)),
4355 ; get_allocation_occurrence(F/A,0) ->
4356 gen_insert_constraint_internal_goal(F/A,Goal,VarsSusp,Vars,Susp),
4357 delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)),
4358 Clause = ( Head :- Goal, Inactive, Delegate )
4360 Clause = ( Head :- Delegate )
4363 make_suspension_continuation_goal(F/A,VarsSusp,Goal) :-
4364 ( may_trigger(F/A) ->
4365 build_head(F,A,[0],VarsSusp,Delegate),
4366 ( chr_pp_flag(debugable,off) ->
4369 get_target_module(Mod),
4376 %===============================================================================
4377 :- chr_constraint has_active_occurrence/1, has_active_occurrence/2.
4378 %-------------------------------------------------------------------------------
4379 has_active_occurrence(C) <=> has_active_occurrence(C,1).
4381 max_occurrence(C,MO) \ has_active_occurrence(C,O) <=>
4383 passive(RuleNb,ID),occurrence(C,O,RuleNb,ID,_) \
4384 has_active_occurrence(C,O) <=>
4386 has_active_occurrence(C,NO).
4387 has_active_occurrence(C,O) <=> true.
4388 %===============================================================================
4390 gen_cond_attach_clause(F/A,Id,L,T) :-
4391 ( is_finally_stored(F/A) ->
4392 get_allocation_occurrence(F/A,AllocationOccurrence),
4393 get_max_occurrence(F/A,MaxOccurrence),
4394 ( chr_pp_flag(debugable,off), MaxOccurrence < AllocationOccurrence ->
4395 ( only_ground_indexed_arguments(F/A) ->
4396 gen_insert_constraint_internal_goal(F/A,Body,AllArgs,Args,Susp)
4398 gen_cond_attach_goal(F/A,Body,AllArgs,Args,Susp)
4400 ; vars_susp(A,Args,Susp,AllArgs),
4401 gen_uncond_attach_goal(F/A,Susp,Args,Body,_)
4403 build_head(F,A,Id,AllArgs,Head),
4404 Clause = ( Head :- Body ),
4411 use_auxiliary_predicate/1,
4412 use_auxiliary_predicate/2,
4413 is_used_auxiliary_predicate/1,
4414 is_used_auxiliary_predicate/2.
4416 :- chr_option(mode,use_auxiliary_predicate(+)).
4417 :- chr_option(mode,use_auxiliary_predicate(+,+)).
4419 use_auxiliary_predicate(P) \ use_auxiliary_predicate(P) <=> true.
4421 use_auxiliary_predicate(P,C) \ use_auxiliary_predicate(P,C) <=> true.
4423 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P) <=> true.
4425 use_auxiliary_predicate(P,_) \ is_used_auxiliary_predicate(P) <=> true.
4427 is_used_auxiliary_predicate(P) <=> fail.
4429 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P,_) <=> true.
4430 use_auxiliary_predicate(P,C) \ is_used_auxiliary_predicate(P,C) <=> true.
4432 is_used_auxiliary_predicate(P,C) <=> fail.
4434 %------------------------------------------------------------------------------%
4435 % Only generate import statements for actually used modules.
4436 %------------------------------------------------------------------------------%
4439 use_auxiliary_module/1,
4440 is_used_auxiliary_module/1.
4442 :- chr_option(mode,use_auxiliary_module(+)).
4444 use_auxiliary_module(P) \ use_auxiliary_module(P) <=> true.
4446 use_auxiliary_module(P) \ is_used_auxiliary_module(P) <=> true.
4448 is_used_auxiliary_module(P) <=> fail.
4450 % only called for constraints with
4452 % non-ground indexed argument
4453 gen_cond_attach_goal(F/A,Goal,AllArgs,Args,Susp) :-
4454 vars_susp(A,Args,Susp,AllArgs),
4455 make_suspension_continuation_goal(F/A,AllArgs,Closure),
4456 ( get_store_type(F/A,var_assoc_store(_,_)) ->
4459 attach_constraint_atom(F/A,Vars,Susp,Attach)
4462 insert_constraint_goal(F/A,Susp,Args,InsertCall),
4463 insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Closure, Args,InsertGoal),
4464 ( may_trigger(F/A) ->
4465 activate_constraint_goal(F/A,(InsertCall,Attach),Vars,Susp,_,ActivateGoal),
4469 InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args)
4473 ActivateGoal % activate_constraint(Stored,Vars,Susp,_)
4479 InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args),
4485 gen_insert_constraint_internal_goal(F/A,Goal,AllArgs,Args,Susp) :-
4486 vars_susp(A,Args,Susp,AllArgs),
4487 make_suspension_continuation_goal(F/A,AllArgs,Cont),
4488 ( \+ only_ground_indexed_arguments(F/A), \+ get_store_type(F/A,var_assoc_store(_,_)) ->
4489 attach_constraint_atom(F/A,Vars,Susp,Attach)
4494 insert_constraint_goal(F/A,Susp,Args,InsertCall),
4495 insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Cont, Args,InsertInternalGoal),
4496 ( only_ground_indexed_arguments(F/A), chr_pp_flag(debugable,off) ->
4499 InsertInternalGoal, % insert_constraint_internal(Susp,F,Args),
4505 InsertInternalGoal, % insert_constraint_internal(_,Vars,Susp,Cont,F,Args),
4511 gen_uncond_attach_goal(FA,Susp,Args,AttachGoal,Generation) :-
4512 ( \+ only_ground_indexed_arguments(FA), \+ get_store_type(FA,var_assoc_store(_,_)) ->
4513 attach_constraint_atom(FA,Vars,Susp,Attach)
4517 insert_constraint_goal(FA,Susp,Args,InsertCall),
4518 ( chr_pp_flag(late_allocation,on) ->
4519 activate_constraint_goal(FA,(InsertCall,Attach),Vars,Susp,Generation,AttachGoal)
4521 activate_constraint_goal(FA,true,Vars,Susp,Generation,AttachGoal)
4524 %-------------------------------------------------------------------------------
4525 :- chr_constraint occurrences_code/6.
4526 :- chr_option(mode,occurrences_code(+,+,+,+,+,+)).
4527 %-------------------------------------------------------------------------------
4528 max_occurrence(C,MO) \ occurrences_code(C,O,Id,NId,L,T)
4531 occurrences_code(C,O,Id,NId,L,T)
4533 occurrence_code(C,O,Id,Id1,L,L1),
4535 occurrences_code(C,NO,Id1,NId,L1,T).
4536 %-------------------------------------------------------------------------------
4537 :- chr_constraint occurrence_code/6.
4538 :- chr_option(mode,occurrence_code(+,+,+,+,+,+)).
4539 %-------------------------------------------------------------------------------
4540 occurrence(C,O,RuleNb,ID,_), passive(RuleNb,ID) \ occurrence_code(C,O,Id,NId,L,T)
4541 <=> NId = Id, L = T.
4542 occurrence(C,O,RuleNb,ID,_), rule(RuleNb,PragmaRule) \ occurrence_code(C,O,Id,NId,L,T)
4544 PragmaRule = pragma(rule(Heads1,Heads2,_,_),ids(IDs1,IDs2),_,_,_),
4545 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
4547 head1_code(Head1,ID,RHeads1,RIDs1,PragmaRule,C,O,Id,L,T)
4548 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
4549 head2_code(Head2,ID,RHeads2,RIDs2,PragmaRule,C,O,Id,L,L1),
4551 ( unconditional_occurrence(C,O) ->
4554 gen_alloc_inc_clause(C,O,Id,L1,T)
4558 occurrence_code(C,O,_,_,_,_)
4560 chr_error(internal,'occurrence_code/6: missing information to compile ~w:~w\n',[C,O]).
4561 %-------------------------------------------------------------------------------
4563 %% Generate code based on one removed head of a CHR rule
4564 head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
4565 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
4566 Rule = rule(_,Head2,_,_),
4568 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
4569 simplification_code(Head,ID,NOtherHeads,NOtherIDs,PragmaRule,FA,O,Id,L,T)
4571 simpagation_head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,Id,L,T)
4574 %% Generate code based on one persistent head of a CHR rule
4575 head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
4576 PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
4577 Rule = rule(Head1,_,_,_),
4579 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
4580 propagation_code(Head,ID,NOtherHeads,NOtherIDs,Rule,RuleNb,FA,O,Id,L,T)
4582 simpagation_head2_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T)
4585 gen_alloc_inc_clause(F/A,O,Id,L,T) :-
4586 vars_susp(A,Vars,Susp,VarsSusp),
4587 build_head(F,A,Id,VarsSusp,Head),
4589 build_head(F,A,IncId,VarsSusp,CallHead),
4590 gen_occ_allocation(F/A,O,Vars,Susp,ConditionalAlloc),
4599 gen_occ_allocation(FA,O,Vars,Susp,Goal) :-
4600 get_allocation_occurrence(FA,AO),
4601 ( chr_pp_flag(debugable,off), O == AO ->
4602 allocate_constraint_goal(FA,Susp,Vars,Goal0),
4603 ( may_trigger(FA) ->
4604 Goal = (var(Susp) -> Goal0 ; true)
4611 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4613 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4615 % Reorders guard goals with respect to partner constraint retrieval goals and
4616 % active constraint. Returns combined partner retrieval + guard goal.
4618 guard_via_reschedule_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,GoalSkeleton) :-
4619 ( chr_pp_flag(guard_via_reschedule,on) ->
4620 guard_via_reschedule_main_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
4621 list2conj(ScheduleSkeleton,GoalSkeleton)
4623 length(Retrievals,RL), length(LookupSkeleton,RL),
4624 length(GuardList,GL), length(GuardListSkeleton,GL),
4625 append(LookupSkeleton,GuardListSkeleton,GoalListSkeleton),
4626 list2conj(GoalListSkeleton,GoalSkeleton)
4628 guard_via_reschedule_main_new(PartnerLookups,GuardList,ActiveHead,
4629 GuardListSkeleton,LookupSkeleton,ScheduleSkeleton) :-
4630 initialize_unit_dictionary(ActiveHead,Dict),
4631 maplist(wrap_in_functor(lookup),PartnerLookups,WrappedPartnerLookups),
4632 maplist(wrap_in_functor(guard),GuardList,WrappedGuardList),
4633 build_units(WrappedPartnerLookups,WrappedGuardList,Dict,Units),
4634 dependency_reorder(Units,NUnits),
4635 wrappedunits2lists(NUnits,IndexedGuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
4636 sort(IndexedGuardListSkeleton,SortedIndexedGuardListSkeleton),
4637 snd_of_pairs(SortedIndexedGuardListSkeleton,GuardListSkeleton).
4639 wrap_in_functor(Functor,X,Term) :-
4640 Term =.. [Functor,X].
4642 wrappedunits2lists([],[],[],[]).
4643 wrappedunits2lists([unit(N,WrappedGoal,_,_)|Units],Gs,Ls,Ss) :-
4644 Ss = [GoalCopy|TSs],
4645 ( WrappedGoal = lookup(Goal) ->
4646 Ls = [GoalCopy|TLs],
4648 ; WrappedGoal = guard(Goal) ->
4649 Gs = [N-GoalCopy|TGs],
4652 wrappedunits2lists(Units,TGs,TLs,TSs).
4654 guard_splitting(Rule,SplitGuardList) :-
4655 Rule = rule(H1,H2,Guard,_),
4656 append(H1,H2,Heads),
4657 conj2list(Guard,GuardList),
4658 term_variables(Heads,HeadVars),
4659 split_off_simple_guard_new(GuardList,HeadVars,GuardPrefix,RestGuardList),
4660 append(GuardPrefix,[RestGuard],SplitGuardList),
4661 term_variables(RestGuardList,GuardVars1),
4662 % variables that are declared to be ground don't need to be locked
4663 ground_vars(Heads,GroundVars),
4664 list_difference_eq(HeadVars,GroundVars,LockableHeadVars),
4665 intersect_eq(LockableHeadVars,GuardVars1,GuardVars),
4666 ( chr_pp_flag(guard_locks,on),
4667 bagof(('chr lock'(X)) - ('chr unlock'(X)), (lists:member(X,GuardVars)), LocksUnlocks) ->
4668 once(pairup(Locks,Unlocks,LocksUnlocks))
4673 list2conj(Locks,LockPhase),
4674 list2conj(Unlocks,UnlockPhase),
4675 list2conj(RestGuardList,RestGuard1),
4676 RestGuard = (LockPhase,(RestGuard1,UnlockPhase)).
4678 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy) :-
4679 Rule = rule(_,_,_,Body),
4680 my_term_copy(GuardList,VarDict,VarDict2,GuardCopyList),
4681 my_term_copy(Body,VarDict2,BodyCopy).
4684 split_off_simple_guard_new([],_,[],[]).
4685 split_off_simple_guard_new([G|Gs],VarDict,S,C) :-
4686 ( simple_guard_new(G,VarDict) ->
4688 split_off_simple_guard_new(Gs,VarDict,Ss,C)
4694 % simple guard: cheap and benign (does not bind variables)
4695 simple_guard_new(G,Vars) :-
4696 binds_b(G,BoundVars),
4697 \+ (( member(V,BoundVars),
4698 memberchk_eq(V,Vars)
4701 dependency_reorder(Units,NUnits) :-
4702 dependency_reorder(Units,[],NUnits).
4704 dependency_reorder([],Acc,Result) :-
4705 reverse(Acc,Result).
4707 dependency_reorder([Unit|Units],Acc,Result) :-
4708 Unit = unit(_GID,_Goal,Type,GIDs),
4712 dependency_insert(Acc,Unit,GIDs,NAcc)
4714 dependency_reorder(Units,NAcc,Result).
4716 dependency_insert([],Unit,_,[Unit]).
4717 dependency_insert([X|Xs],Unit,GIDs,L) :-
4718 X = unit(GID,_,_,_),
4719 ( memberchk(GID,GIDs) ->
4723 dependency_insert(Xs,Unit,GIDs,T)
4726 build_units(Retrievals,Guard,InitialDict,Units) :-
4727 build_retrieval_units(Retrievals,1,N,InitialDict,Dict,Units,Tail),
4728 build_guard_units(Guard,N,Dict,Tail).
4730 build_retrieval_units([],N,N,Dict,Dict,L,L).
4731 build_retrieval_units([U|Us],N,M,Dict,NDict,L,T) :-
4732 term_variables(U,Vs),
4733 update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
4734 L = [unit(N,U,fixed,GIDs)|L1],
4736 build_retrieval_units(Us,N1,M,Dict1,NDict,L1,T).
4738 initialize_unit_dictionary(Term,Dict) :-
4739 term_variables(Term,Vars),
4740 pair_all_with(Vars,0,Dict).
4742 update_unit_dictionary([],_,Dict,Dict,GIDs,GIDs).
4743 update_unit_dictionary([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
4744 ( lookup_eq(Dict,V,GID) ->
4745 ( (GID == This ; memberchk(GID,GIDs) ) ->
4752 Dict1 = [V - This|Dict],
4755 update_unit_dictionary(Vs,This,Dict1,NDict,GIDs1,NGIDs).
4757 build_guard_units(Guard,N,Dict,Units) :-
4759 Units = [unit(N,Goal,fixed,[])]
4760 ; Guard = [Goal|Goals] ->
4761 term_variables(Goal,Vs),
4762 update_unit_dictionary2(Vs,N,Dict,NDict,[],GIDs),
4763 Units = [unit(N,Goal,movable,GIDs)|RUnits],
4765 build_guard_units(Goals,N1,NDict,RUnits)
4768 update_unit_dictionary2([],_,Dict,Dict,GIDs,GIDs).
4769 update_unit_dictionary2([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
4770 ( lookup_eq(Dict,V,GID) ->
4771 ( (GID == This ; memberchk(GID,GIDs) ) ->
4776 Dict1 = [V - This|Dict]
4778 Dict1 = [V - This|Dict],
4781 update_unit_dictionary2(Vs,This,Dict1,NDict,GIDs1,NGIDs).
4783 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4785 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4787 %% / ___| ___| |_ / ___| ___ _ __ ___ __ _ _ __ | |_(_) ___ ___ _
4788 %% \___ \ / _ \ __| \___ \ / _ \ '_ ` _ \ / _` | '_ \| __| |/ __/ __(_)
4789 %% ___) | __/ |_ ___) | __/ | | | | | (_| | | | | |_| | (__\__ \_
4790 %% |____/ \___|\__| |____/ \___|_| |_| |_|\__,_|_| |_|\__|_|\___|___(_)
4793 %% | | | |_ __ (_) __ _ _ _ ___ |_ _|_ __ / _| ___ _ __ ___ _ __ ___ ___
4794 %% | | | | '_ \| |/ _` | | | |/ _ \ | || '_ \| |_ / _ \ '__/ _ \ '_ \ / __/ _ \
4795 %% | |_| | | | | | (_| | |_| | __/ | || | | | _| __/ | | __/ | | | (_| __/
4796 %% \___/|_| |_|_|\__, |\__,_|\___| |___|_| |_|_| \___|_| \___|_| |_|\___\___|
4799 functional_dependency/4,
4800 get_functional_dependency/4.
4802 :- chr_option(mode,functional_dependency(+,+,?,?)).
4804 allocation_occurrence(C,AO), occurrence(C,O,RuleNb,_,_) \ functional_dependency(C,RuleNb,Pattern,Key)
4808 functional_dependency(C,1,Pattern,Key).
4810 functional_dependency(C,RuleNb1,Pattern,Key) \ get_functional_dependency(C,RuleNb2,QPattern,QKey)
4814 QPattern = Pattern, QKey = Key.
4815 get_functional_dependency(_,_,_,_)
4819 functional_dependency_analysis(Rules) :-
4820 ( chr_pp_flag(functional_dependency_analysis,on) ->
4821 functional_dependency_analysis_main(Rules)
4826 functional_dependency_analysis_main([]).
4827 functional_dependency_analysis_main([PRule|PRules]) :-
4828 ( discover_unique_pattern(PRule,C,RuleNb,Pattern,Key) ->
4829 functional_dependency(C,RuleNb,Pattern,Key)
4833 functional_dependency_analysis_main(PRules).
4835 discover_unique_pattern(PragmaRule,F/A,RuleNb,Pattern,Key) :-
4836 PragmaRule = pragma(Rule,_,_,Name,RuleNb),
4837 Rule = rule(H1,H2,Guard,_),
4845 check_unique_constraints(C1,C2,Guard,RuleNb,List),
4846 term_variables(C1,Vs),
4849 lookup_eq(List,V1,V2),
4852 select_pragma_unique_variables(Vs,List,Key1),
4853 copy_term_nat(C1-Key1,Pattern-Key),
4856 select_pragma_unique_variables([],_,[]).
4857 select_pragma_unique_variables([V|Vs],List,L) :-
4858 ( lookup_eq(List,V,_) ->
4863 select_pragma_unique_variables(Vs,List,T).
4865 % depends on functional dependency analysis
4866 % and shape of rule: C1 \ C2 <=> true.
4867 set_semantics_rules(Rules) :-
4868 ( chr_pp_flag(set_semantics_rule,on) ->
4869 set_semantics_rules_main(Rules)
4874 set_semantics_rules_main([]).
4875 set_semantics_rules_main([R|Rs]) :-
4876 set_semantics_rule_main(R),
4877 set_semantics_rules_main(Rs).
4879 set_semantics_rule_main(PragmaRule) :-
4880 PragmaRule = pragma(Rule,IDs,Pragmas,_,RuleNb),
4881 ( Rule = rule([C1],[C2],true,_),
4882 IDs = ids([ID1],[ID2]),
4883 \+ is_passive(RuleNb,ID1),
4885 get_functional_dependency(F/A,RuleNb,Pattern,Key),
4886 copy_term_nat(Pattern-Key,C1-Key1),
4887 copy_term_nat(Pattern-Key,C2-Key2),
4894 check_unique_constraints(C1,C2,G,RuleNb,List) :-
4895 \+ any_passive_head(RuleNb),
4896 variable_replacement(C1-C2,C2-C1,List),
4897 copy_with_variable_replacement(G,OtherG,List),
4899 once(entails_b(NotG,OtherG)).
4901 % checks for rules of the shape ...,C1,C2... (<|=)==> ...
4902 % where C1 and C2 are symmteric constraints
4903 symmetry_analysis(Rules) :-
4904 ( chr_pp_flag(check_unnecessary_active,off) ->
4907 symmetry_analysis_main(Rules)
4910 symmetry_analysis_main([]).
4911 symmetry_analysis_main([R|Rs]) :-
4912 R = pragma(Rule,ids(IDs1,IDs2),_,_,RuleNb),
4913 Rule = rule(H1,H2,_,_),
4914 ( ( \+ chr_pp_flag(check_unnecessary_active,simplification)
4915 ; H2 == [] ), H1 \== [] ->
4916 symmetry_analysis_heads(H1,IDs1,[],[],Rule,RuleNb),
4917 symmetry_analysis_heads(H2,IDs2,[],[],Rule,RuleNb)
4921 symmetry_analysis_main(Rs).
4923 symmetry_analysis_heads([],[],_,_,_,_).
4924 symmetry_analysis_heads([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
4925 ( \+ is_passive(RuleNb,ID),
4926 member2(PreHs,PreIDs,PreH-PreID),
4927 \+ is_passive(RuleNb,PreID),
4928 variable_replacement(PreH,H,List),
4929 copy_with_variable_replacement(Rule,Rule2,List),
4930 identical_rules(Rule,Rule2) ->
4935 symmetry_analysis_heads(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
4937 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4939 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4940 %% ____ _ _ _ __ _ _ _
4941 %% / ___|(_)_ __ ___ _ __ | (_)/ _(_) ___ __ _| |_(_) ___ _ __
4942 %% \___ \| | '_ ` _ \| '_ \| | | |_| |/ __/ _` | __| |/ _ \| '_ \
4943 %% ___) | | | | | | | |_) | | | _| | (_| (_| | |_| | (_) | | | |
4944 %% |____/|_|_| |_| |_| .__/|_|_|_| |_|\___\__,_|\__|_|\___/|_| |_|
4947 simplification_code(Head,ID,RestHeads,RestIDs,PragmaRule,F/A,O,Id,L,T) :-
4948 PragmaRule = pragma(Rule,_,Pragmas,_,_RuleNb),
4949 head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
4950 build_head(F,A,Id,HeadVars,ClauseHead),
4951 get_constraint_mode(F/A,Mode),
4952 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
4954 guard_splitting(Rule,GuardList),
4955 guard_via_reschedule_new(RestHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),
4957 rest_heads_retrieval_and_matching(RestHeads,RestIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
4959 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
4961 gen_uncond_susps_detachments(Susps,RestHeads,SuspsDetachments),
4962 gen_cond_susp_detachment(Id,Susp,F/A,SuspDetachment),
4964 ( chr_pp_flag(debugable,on) ->
4965 Rule = rule(_,_,Guard,Body),
4966 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
4967 sort_by_key([Susp|Susps],[ID|RestIDs],SortedSusps),
4968 DebugTry = 'chr debug_event'( try(SortedSusps,[],DebugGuard,DebugBody)),
4969 DebugApply = 'chr debug_event'(apply(SortedSusps,[],DebugGuard,DebugBody)),
4970 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
4974 ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) -> ActualCut = true ; ActualCut = (!) ),
4975 Clause = ( ClauseHead :-
4985 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict) :-
4986 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,[],_).
4988 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,GroundVars,NGroundVars) :-
4989 head_arg_matches_(Pairs,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars),
4990 list2conj(GoalList,Goal).
4992 head_arg_matches_([],[],VarDict,GroundVars,[],VarDict,GroundVars).
4993 head_arg_matches_([Arg-Var| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :-
4995 ( lookup_eq(VarDict,Arg,OtherVar) ->
4997 ( memberchk_eq(Arg,GroundVars) ->
4998 GoalList = [Var = OtherVar | RestGoalList],
4999 GroundVars1 = GroundVars
5001 GoalList = [Var == OtherVar | RestGoalList],
5002 GroundVars1 = [Arg|GroundVars]
5005 GoalList = [Var == OtherVar | RestGoalList],
5006 GroundVars1 = GroundVars
5009 ; VarDict1 = [Arg-Var | VarDict],
5010 GoalList = RestGoalList,
5012 GroundVars1 = [Arg|GroundVars]
5014 GroundVars1 = GroundVars
5021 GoalList = [ Var = Arg | RestGoalList]
5023 GoalList = [ Var == Arg | RestGoalList]
5026 GroundVars1 = GroundVars,
5029 ; Mode == (+), is_ground(GroundVars,Arg) ->
5030 copy_with_variable_replacement(Arg,ArgCopy,VarDict),
5031 GoalList = [ Var = ArgCopy | RestGoalList],
5033 GroundVars1 = GroundVars,
5038 functor(Term,Fct,N),
5041 GoalList = [ Var = Term | RestGoalList ]
5043 GoalList = [ nonvar(Var), Var = Term | RestGoalList ]
5045 pairup(Args,Vars,NewPairs),
5046 append(NewPairs,Rest,Pairs),
5047 replicate(N,Mode,NewModes),
5048 append(NewModes,Modes,RestModes),
5050 GroundVars1 = GroundVars
5052 head_arg_matches_(Pairs,RestModes,VarDict1,GroundVars1,RestGoalList,NVarDict,NGroundVars).
5054 is_ground(GroundVars,Term) :-
5059 maplist(is_ground(GroundVars),Args)
5061 memberchk_eq(Term,GroundVars)
5064 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict) :-
5065 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,[],_).
5067 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,GroundVars,NGroundVars) :-
5069 rest_heads_retrieval_and_matching_n(Heads,IDs,PrevHs,PrevSusps,ActiveHead,GoalList,Susps,VarDict,NVarDict,AttrDict,GroundVars,NGroundVars)
5074 GroundVars = NGroundVars
5077 rest_heads_retrieval_and_matching_n([],_,_,_,_,[],[],VarDict,VarDict,_AttrDict,GroundVars,GroundVars).
5078 rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],PrevHs,PrevSusps,ActiveHead,
5079 [Goal|Goals],[Susp|Susps],VarDict,NVarDict,_AttrDict,GroundVars,NGroundVars) :-
5081 head_info(H,A,Vars,_,_,Pairs),
5082 get_store_type(F/A,StoreType),
5083 ( StoreType == default ->
5084 passive_head_via(H,[ActiveHead|PrevHs],VarDict,ViaGoal,VarSusps),
5085 delay_phase_end(validate_store_type_assumptions,
5086 ( static_suspension_term(F/A,Suspension),
5087 get_static_suspension_term_field(arguments,F/A,Suspension,Vars),
5088 get_static_suspension_field(F/A,Suspension,state,active,GetState)
5091 % create_get_mutable_ref(active,State,GetMutable),
5092 get_constraint_mode(F/A,Mode),
5093 head_arg_matches(Pairs,Mode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1),
5095 sbag_member_call(Susp,VarSusps,Sbag),
5096 ExistentialLookup = (
5099 Susp = Suspension, % not inlined
5103 delay_phase_end(validate_store_type_assumptions,
5104 ( static_suspension_term(F/A,Suspension),
5105 get_static_suspension_term_field(arguments,F/A,Suspension,Vars)
5108 existential_lookup(StoreType,H,[ActiveHead|PrevHs],VarDict,Suspension,ExistentialLookup,Susp,Pairs,NPairs),
5109 get_constraint_mode(F/A,Mode),
5110 filter_mode(NPairs,Pairs,Mode,NMode),
5111 head_arg_matches(NPairs,NMode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1)
5113 different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals),
5114 append(NPairs,VarDict1,DA_), % order important here
5115 translate(GroundVars1,DA_,GroundVarsA),
5116 translate(GroundVars1,VarDict1,GroundVarsB),
5117 inline_matching_goal(MatchingGoal,MatchingGoal2,GroundVarsA,GroundVarsB),
5124 rest_heads_retrieval_and_matching_n(Hs,IDs,[H|PrevHs],[Susp|PrevSusps],ActiveHead,Goals,Susps,VarDict1,NVarDict,_NewAttrDict,GroundVars1,NGroundVars).
5126 inline_matching_goal(A==B,true,GVA,GVB) :-
5127 memberchk_eq(A,GVA),
5128 memberchk_eq(B,GVB),
5131 % inline_matching_goal(A=B,true,_,_) :- A=B, !.
5132 inline_matching_goal((A,B),(A2,B2),GVA,GVB) :- !,
5133 inline_matching_goal(A,A2,GVA,GVB),
5134 inline_matching_goal(B,B2,GVA,GVB).
5135 inline_matching_goal(X,X,_,_).
5138 filter_mode([],_,_,[]).
5139 filter_mode([Arg-Var|Rest],[_-V|R],[M|Ms],Modes) :-
5142 filter_mode(Rest,R,Ms,MT)
5144 filter_mode([Arg-Var|Rest],R,Ms,Modes)
5147 check_unique_keys([],_).
5148 check_unique_keys([V|Vs],Dict) :-
5149 lookup_eq(Dict,V,_),
5150 check_unique_keys(Vs,Dict).
5152 % Generates tests to ensure the found constraint differs from previously found constraints
5153 % TODO: detect more cases where constraints need be different
5154 different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :-
5155 different_from_other_susps_(Heads,Susps,Head,Susp,DiffSuspGoalList),
5156 list2conj(DiffSuspGoalList,DiffSuspGoals).
5158 different_from_other_susps_(_,[],_,_,[]) :- !.
5159 different_from_other_susps_([PreHead|Heads],[PreSusp|Susps],Head,Susp,List) :-
5160 ( functor(Head,F,A), functor(PreHead,F,A),
5161 copy_term_nat(PreHead-Head,PreHeadCopy-HeadCopy),
5162 \+ \+ PreHeadCopy = HeadCopy ->
5164 List = [Susp \== PreSusp | Tail]
5168 different_from_other_susps_(Heads,Susps,Head,Susp,Tail).
5170 % passive_head_via(in,in,in,in,out,out,out) :-
5171 passive_head_via(Head,PrevHeads,VarDict,Goal,AllSusps) :-
5173 get_constraint_index(F/A,Pos),
5174 common_variables(Head,PrevHeads,CommonVars),
5175 global_list_store_name(F/A,Name),
5176 GlobalGoal = nb_getval(Name,AllSusps),
5177 get_constraint_mode(F/A,ArgModes),
5180 ; member(CommonVar,CommonVars), nth(I,ArgModes,(-)), arg(I,Head,Arg), Arg == CommonVar ->
5181 translate([CommonVar],VarDict,[Var]),
5182 gen_get_mod_constraints(F/A,Var,AttrGoal,AllSusps),
5185 translate(CommonVars,VarDict,Vars),
5186 gen_get_mod_constraints(F/A,Vars,ViaGoal,AttrGoal,AllSusps),
5195 common_variables(T,Ts,Vs) :-
5196 term_variables(T,V1),
5197 term_variables(Ts,V2),
5198 intersect_eq(V1,V2,Vs).
5200 gen_get_mod_constraints(FA,Vars,ViaGoal,AttrGoal,AllSusps) :-
5201 get_target_module(Mod),
5203 ViaGoal = 'chr newvia_1'(A,V)
5205 ViaGoal = 'chr newvia_2'(A,B,V)
5207 ViaGoal = 'chr newvia'(Vars,V)
5210 ( get_attr(V,Mod,TSusps),
5211 TSuspsEqSusps % TSusps = Susps
5213 get_max_constraint_index(N),
5215 TSuspsEqSusps = true, % TSusps = Susps
5218 TSuspsEqSusps = (TSusps = Susps),
5219 get_constraint_index(FA,Pos),
5220 make_attr(N,_,SuspsList,Susps),
5221 nth1(Pos,SuspsList,AllSusps)
5223 gen_get_mod_constraints(FA,Var,AttrGoal,AllSusps) :-
5224 get_target_module(Mod),
5226 ( get_attr(Var,Mod,TSusps),
5227 TSuspsEqSusps % TSusps = Susps
5229 get_max_constraint_index(N),
5231 TSuspsEqSusps = true, % TSusps = Susps
5234 TSuspsEqSusps = (TSusps = Susps),
5235 get_constraint_index(FA,Pos),
5236 make_attr(N,_,SuspsList,Susps),
5237 nth1(Pos,SuspsList,AllSusps)
5240 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy) :-
5241 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
5242 list2conj(GuardCopyList,GuardCopy).
5244 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy) :-
5245 Rule = rule(H,_,Guard,Body),
5246 conj2list(Guard,GuardList),
5247 split_off_simple_guard(GuardList,VarDict,GuardPrefix,RestGuardList),
5248 my_term_copy(GuardPrefix-RestGuardList,VarDict,VarDict2,GuardPrefixCopy-RestGuardListCopyCore),
5250 append(GuardPrefixCopy,[RestGuardCopy],GuardCopyList),
5251 term_variables(RestGuardList,GuardVars),
5252 term_variables(RestGuardListCopyCore,GuardCopyVars),
5253 % variables that are declared to be ground don't need to be locked
5254 ground_vars(H,GroundVars),
5255 list_difference_eq(GuardVars,GroundVars,GuardVars_),
5256 ( chr_pp_flag(guard_locks,on),
5257 bagof(('chr lock'(Y)) - ('chr unlock'(Y)),
5258 X ^ (lists:member(X,GuardVars), % X is a variable appearing in the original guard
5259 pairlist:lookup_eq(VarDict,X,Y), % translate X into new variable
5260 memberchk_eq(Y,GuardCopyVars) % redundant check? or multiple entries for X possible?
5263 once(pairup(Locks,Unlocks,LocksUnlocks))
5268 list2conj(Locks,LockPhase),
5269 list2conj(Unlocks,UnlockPhase),
5270 list2conj(RestGuardListCopyCore,RestGuardCopyCore),
5271 RestGuardCopy = (LockPhase,(RestGuardCopyCore,UnlockPhase)),
5272 my_term_copy(Body,VarDict2,BodyCopy).
5275 split_off_simple_guard([],_,[],[]).
5276 split_off_simple_guard([G|Gs],VarDict,S,C) :-
5277 ( simple_guard(G,VarDict) ->
5279 split_off_simple_guard(Gs,VarDict,Ss,C)
5285 % simple guard: cheap and benign (does not bind variables)
5286 simple_guard(G,VarDict) :-
5288 \+ (( member(V,Vars),
5289 lookup_eq(VarDict,V,_)
5292 gen_cond_susp_detachment(Id,Susp,FA,SuspDetachment) :-
5295 (get_allocation_occurrence(FA,AO),
5296 get_max_occurrence(FA,MO),
5298 only_ground_indexed_arguments(FA), chr_pp_flag(late_allocation,on) ->
5299 SuspDetachment = true
5301 gen_uncond_susp_detachment(Susp,FA,UnCondSuspDetachment),
5302 ( chr_pp_flag(late_allocation,on) ->
5306 ; UnCondSuspDetachment
5309 SuspDetachment = UnCondSuspDetachment
5313 SuspDetachment = true
5316 gen_uncond_susp_detachment(Susp,FA,SuspDetachment) :-
5318 ( \+ only_ground_indexed_arguments(FA), \+ get_store_type(FA,var_assoc_store(_,_)) ->
5319 detach_constraint_atom(FA,Vars,Susp,Detach)
5323 ( chr_pp_flag(debugable,on) ->
5324 DebugEvent = 'chr debug_event'(remove(Susp))
5328 generate_delete_constraint_call(FA,Susp,DeleteCall),
5329 remove_constraint_goal(FA,Susp,Vars,true,(DeleteCall,Detach),RemoveInternalGoal),
5330 SuspDetachment = ( DebugEvent, RemoveInternalGoal)
5332 SuspDetachment = true
5335 gen_uncond_susps_detachments([],[],true).
5336 gen_uncond_susps_detachments([Susp|Susps],[Term|Terms],(SuspDetachment,SuspsDetachments)) :-
5338 gen_uncond_susp_detachment(Susp,F/A,SuspDetachment),
5339 gen_uncond_susps_detachments(Susps,Terms,SuspsDetachments).
5341 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5343 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5345 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ / |
5346 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ | |
5347 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | | |
5348 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_|
5351 simpagation_head1_code(Head,ID,RestHeads,OtherIDs,PragmaRule,F/A,Id,L,T) :-
5352 PragmaRule = pragma(Rule,ids(_,Heads2IDs),Pragmas,_Name,_RuleNb),
5353 Rule = rule(_Heads,Heads2,Guard,Body),
5355 head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
5356 get_constraint_mode(F/A,Mode),
5357 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
5359 build_head(F,A,Id,HeadVars,ClauseHead),
5361 append(RestHeads,Heads2,Heads),
5362 append(OtherIDs,Heads2IDs,IDs),
5363 reorder_heads(RuleNb,Head,Heads,IDs,NHeads,NIDs),
5365 guard_splitting(Rule,GuardList),
5366 guard_via_reschedule_new(NHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),
5368 rest_heads_retrieval_and_matching(NHeads,NIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
5369 split_by_ids(NIDs,Susps,OtherIDs,Susps1,Susps1IDs,Susps2,Susps2IDs),
5371 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
5373 sort_by_key(Susps1,Susps1IDs,SortedSusps1),
5374 gen_uncond_susps_detachments(SortedSusps1,RestHeads,SuspsDetachments),
5375 gen_cond_susp_detachment(Id,Susp,F/A,SuspDetachment),
5377 ( chr_pp_flag(debugable,on) ->
5378 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
5379 sort_by_key([Susp|Susps1],[ID|Susps1IDs],RemovedSusps),
5380 sort_by_key(Susps2,Susps2IDs,KeptSusps),
5381 DebugTry = 'chr debug_event'( try(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
5382 DebugApply = 'chr debug_event'(apply(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
5383 instrument_goal((!),DebugTry,DebugApply,Cut)
5388 Clause = ( ClauseHead :-
5398 split_by_ids([],[],_,[],[]).
5399 split_by_ids([I|Is],[S|Ss],I1s,S1s,S2s) :-
5400 ( memberchk_eq(I,I1s) ->
5407 split_by_ids(Is,Ss,I1s,R1s,R2s).
5409 split_by_ids([],[],_,[],[],[],[]).
5410 split_by_ids([I|Is],[S|Ss],I1s,S1s,SI1s,S2s,SI2s) :-
5411 ( memberchk_eq(I,I1s) ->
5422 split_by_ids(Is,Ss,I1s,R1s,RSI1s,R2s,RSI2s).
5423 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5426 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5428 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ |___ \
5429 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ __) |
5430 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | / __/
5431 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_____|
5434 %% Genereate prelude + worker predicate
5435 %% prelude calls worker
5436 %% worker iterates over one type of removed constraints
5437 simpagation_head2_code(Head2,RestHeads2,RestIDs,PragmaRule,FA,O,Id,L,T) :-
5438 PragmaRule = pragma(Rule,ids(IDs1,IDs2),Pragmas,_Name,RuleNb),
5439 Rule = rule(Heads1,_,Guard,Body),
5440 append(Heads1,RestHeads2,Heads),
5441 append(IDs1,RestIDs,IDs),
5442 reorder_heads(RuleNb,Head2,Heads,IDs,[NHead|NHeads],[NID|NIDs]),
5443 simpagation_head2_prelude(Head2,NHead,[NHeads,Guard,Body],FA,O,Id,L,L1),
5445 ( memberchk_eq(NID,IDs2) ->
5446 simpagation_universal_searches(NHeads,NIDs,IDs2,[NHead,Head2],Rule,FA,NextHeads,PreHeads,NextIDs,Id1,Id2,L1,L2)
5448 L1 = L2, Id1 = Id2,NextHeads = NHeads, PreHeads = [NHead,Head2], NextIDs = NIDs
5450 universal_search_iterator_end(PreHeads,NextHeads,Rule,FA,Id2,L2,L3),
5451 simpagation_head2_worker(PreHeads,NextHeads,NextIDs,PragmaRule,FA,O,Id2,L3,T).
5453 simpagation_universal_searches([],[],_,PreHeads,_,_,[],PreHeads,[],Id,Id,L,L).
5454 simpagation_universal_searches(Heads,[ID|IDs],IDs2,PreHeads,Rule,C,OutHeads,OutPreHeads,OutIDs,Id,NId,L,T) :-
5455 Heads = [Head|RHeads],
5457 universal_search_iterator_end(PreHeads,Heads,Rule,C,Id,L,L0),
5458 universal_search_iterator(Heads,PreHeads,Rule,C,Id,L0,L1),
5459 ( memberchk_eq(ID,IDs2) ->
5460 simpagation_universal_searches(RHeads,IDs,IDs2,[Head|PreHeads],Rule,C,OutHeads,OutPreHeads,OutIDs,Id1,NId,L1,T)
5462 NId = Id1, L1 = T, OutHeads = RHeads, OutPreHeads = [Head|PreHeads], IDs = OutIDs
5465 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5466 simpagation_head2_prelude(Head,Head1,Rest,F/A,O,Id1,L,T) :-
5467 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
5468 build_head(F,A,Id1,VarsSusp,ClauseHead),
5469 get_constraint_mode(F/A,Mode),
5470 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict),
5472 lookup_passive_head(Head1,[Head],VarDict,ModConstraintsGoal,AllSusps),
5474 gen_occ_allocation(F/A,O,Vars,Susp,ConstraintAllocationGoal),
5476 extend_id(Id1,DelegateId),
5477 extra_active_delegate_variables(Head,[Head1|Rest],VarDict,ExtraVars),
5478 append([AllSusps|VarsSusp],ExtraVars,DelegateCallVars),
5479 build_head(F,A,DelegateId,DelegateCallVars,Delegate),
5486 ConstraintAllocationGoal,
5489 L = [PreludeClause|T].
5491 extra_active_delegate_variables(Term,Terms,VarDict,Vars) :-
5493 delegate_variables(Term,Terms,VarDict,Args,Vars).
5495 passive_delegate_variables(Term,PrevTerms,NextTerms,VarDict,Vars) :-
5496 term_variables(PrevTerms,PrevVars),
5497 delegate_variables(Term,NextTerms,VarDict,PrevVars,Vars).
5499 delegate_variables(Term,Terms,VarDict,PrevVars,Vars) :-
5500 term_variables(Term,V1),
5501 term_variables(Terms,V2),
5502 intersect_eq(V1,V2,V3),
5503 list_difference_eq(V3,PrevVars,V4),
5504 translate(V4,VarDict,Vars).
5507 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5508 simpagation_head2_worker([CurrentHead|PreHeads],NextHeads,NextIDs,PragmaRule,F/A,O,Id,L,T) :-
5509 PragmaRule = pragma(Rule,ids(IDs1,_),Pragmas,_,RuleNb),
5510 Rule = rule(_,_,Guard,Body),
5511 get_prop_inner_loop_vars(PreHeads,[CurrentHead,NextHeads,Guard,Body],PreVarsAndSusps,VarDict,Susp,Vars,PreSusps),
5514 gen_var(OtherSusps),
5516 functor(CurrentHead,OtherF,OtherA),
5517 gen_vars(OtherA,OtherVars),
5518 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
5519 get_constraint_mode(OtherF/OtherA,Mode),
5520 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1,[],GroundVars),
5522 delay_phase_end(validate_store_type_assumptions,
5523 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
5524 get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState),
5525 get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
5528 % create_get_mutable_ref(active,State,GetMutable),
5529 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
5531 OtherSusp = OtherSuspension,
5537 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
5538 build_head(F,A,Id,ClauseVars,ClauseHead),
5540 guard_splitting(Rule,GuardList),
5541 guard_via_reschedule_new(NextHeads,GuardList,[CurrentHead|PreHeads],GuardCopyList,RestSuspsRetrieval,RescheduledTest),
5543 rest_heads_retrieval_and_matching(NextHeads,NextIDs,[CurrentHead|PreHeads],RestSuspsRetrieval,Susps,VarDict1,VarDict2,[CurrentHead|PreHeads],[OtherSusp|PreSusps],[]),
5544 split_by_ids(NextIDs,Susps,IDs1,Susps1,Susps2),
5545 split_by_ids(NextIDs,NextHeads,IDs1,RestHeads1,_),
5547 gen_uncond_susps_detachments([OtherSusp | Susps1],[CurrentHead|RestHeads1],Susps1Detachments),
5549 RecursiveVars = [OtherSusps|PreVarsAndSusps],
5550 build_head(F,A,Id,RecursiveVars,RecursiveCall),
5551 RecursiveVars2 = [[]|PreVarsAndSusps],
5552 build_head(F,A,Id,RecursiveVars2,RecursiveCall2),
5554 guard_body_copies3(Rule,GuardList,VarDict2,GuardCopyList,BodyCopy),
5555 ( BodyCopy \== true, is_observed(F/A,O) ->
5556 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation),
5557 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall),
5558 gen_state_cond_call(Susp,F/A,RecursiveCall2,Generation,ConditionalRecursiveCall2)
5559 ; Attachment = true,
5560 ConditionalRecursiveCall = RecursiveCall,
5561 ConditionalRecursiveCall2 = RecursiveCall2
5564 ( chr_pp_flag(debugable,on) ->
5565 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
5566 DebugTry = 'chr debug_event'( try([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody)),
5567 DebugApply = 'chr debug_event'(apply([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody))
5573 ( member(unique(ID1,UniqueKeys), Pragmas),
5574 check_unique_keys(UniqueKeys,VarDict) ->
5577 ( CurrentSuspTest ->
5584 ConditionalRecursiveCall2
5602 ConditionalRecursiveCall
5610 gen_state_cond_call(Susp,FA,Call,Generation,ConditionalCall) :-
5611 ( may_trigger(FA) ->
5612 does_use_field(FA,generation),
5613 delay_phase_end(validate_store_type_assumptions,
5614 ( static_suspension_term(FA,Suspension),
5615 get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState),
5616 get_static_suspension_field(FA,Suspension,generation,Generation,GetGeneration),
5617 get_static_suspension_term_field(arguments,FA,Suspension,Args)
5621 delay_phase_end(validate_store_type_assumptions,
5622 ( static_suspension_term(FA,Suspension),
5623 get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState),
5624 get_static_suspension_term_field(arguments,FA,Suspension,Args)
5627 GetGeneration = true
5630 ( Susp = Suspension,
5639 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5642 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5644 %% | _ \ _ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __
5645 %% | |_) | '__/ _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \
5646 %% | __/| | | (_) | |_) | (_| | (_| | (_| | |_| | (_) | | | |
5647 %% |_| |_| \___/| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_|
5650 propagation_code(Head,ID,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
5651 ( RestHeads == [] ->
5652 propagation_single_headed(Head,Rule,RuleNb,FA,O,Id,L,T)
5654 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T)
5656 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5657 %% Single headed propagation
5658 %% everything in a single clause
5659 propagation_single_headed(Head,Rule,RuleNb,F/A,O,Id,ProgramList,ProgramTail) :-
5660 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
5661 build_head(F,A,Id,VarsSusp,ClauseHead),
5664 build_head(F,A,NextId,VarsSusp,NextHead),
5666 get_constraint_mode(F/A,Mode),
5667 head_arg_matches(HeadPairs,Mode,[],HeadMatching,VarDict,[],GroundVars),
5668 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
5669 gen_occ_allocation(F/A,O,Vars,Susp,Allocation),
5671 % - recursive call -
5672 RecursiveCall = NextHead,
5673 ( Body \== true, is_observed(F/A,O) ->
5674 gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation),
5675 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
5676 ; Attachment = true,
5677 ConditionalRecursiveCall = RecursiveCall
5680 ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) ->
5686 ( chr_pp_flag(debugable,on) ->
5687 Rule = rule(_,_,Guard,Body),
5688 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
5689 DebugTry = 'chr debug_event'( try([],[Susp],DebugGuard,DebugBody)),
5690 DebugApply = 'chr debug_event'(apply([],[Susp],DebugGuard,DebugBody)),
5691 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
5695 ( may_trigger(F/A), \+ has_no_history(RuleNb)->
5696 use_auxiliary_predicate(novel_production),
5697 use_auxiliary_predicate(extend_history),
5698 does_use_history(F/A,O),
5699 NovelProduction = '$novel_production'(Susp,RuleNb), % optimisation of t(RuleNb,Susp)
5700 ExtendHistory = '$extend_history'(Susp,RuleNb)
5702 NovelProduction = true,
5703 ExtendHistory = true
5716 ConditionalRecursiveCall
5718 ProgramList = [Clause | ProgramTail].
5720 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5721 %% multi headed propagation
5722 %% prelude + predicates to accumulate the necessary combinations of suspended
5723 %% constraints + predicate to execute the body
5724 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
5725 RestHeads = [First|Rest],
5726 propagation_prelude(Head,RestHeads,Rule,FA,O,Id,L,L1),
5727 extend_id(Id,ExtendedId),
5728 propagation_nested_code(Rest,[First,Head],RestIDs,Rule,RuleNb,FA,O,ExtendedId,L1,T).
5730 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5731 propagation_prelude(Head,[First|Rest],Rule,F/A,O,Id,L,T) :-
5732 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
5733 build_head(F,A,Id,VarsSusp,PreludeHead),
5734 get_constraint_mode(F/A,Mode),
5735 head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict),
5736 Rule = rule(_,_,Guard,Body),
5737 extra_active_delegate_variables(Head,[First,Rest,Guard,Body],VarDict,ExtraVars),
5739 lookup_passive_head(First,[Head],VarDict,FirstSuspGoal,Susps),
5741 gen_occ_allocation(F/A,O,Vars,Susp,CondAllocation),
5743 extend_id(Id,NestedId),
5744 append([Susps|VarsSusp],ExtraVars,NestedVars),
5745 build_head(F,A,NestedId,NestedVars,NestedHead),
5746 NestedCall = NestedHead,
5758 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5759 propagation_nested_code([],[CurrentHead|PreHeads],RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
5760 universal_search_iterator_end([CurrentHead|PreHeads],[],Rule,FA,Id,L,L1),
5761 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L1,T).
5763 propagation_nested_code([Head|RestHeads],PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
5764 universal_search_iterator_end(PreHeads,[Head|RestHeads],Rule,FA,Id,L,L1),
5765 universal_search_iterator([Head|RestHeads],PreHeads,Rule,FA,Id,L1,L2),
5767 propagation_nested_code(RestHeads,[Head|PreHeads],RestIDs,Rule,RuleNb,FA,O,IncId,L2,T).
5769 %check_fd_lookup_condition(_,_,_,_) :- fail.
5770 check_fd_lookup_condition(F,A,_,_) :-
5771 get_store_type(F/A,global_singleton), !.
5772 check_fd_lookup_condition(F,A,CurrentHead,PreHeads) :-
5773 \+ may_trigger(F/A),
5774 get_functional_dependency(F/A,1,P,K),
5775 copy_term(P-K,CurrentHead-Key),
5776 term_variables(PreHeads,PreVars),
5777 intersect_eq(Key,PreVars,Key),!.
5779 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,F/A,O,Id,L,T) :-
5780 Rule = rule(_,H2,Guard,Body),
5781 gen_var_susp_list_for_b(PreHeads,[CurrentHead,Guard,Body],VarDict1,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
5782 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
5783 init(AllSusps,RestSusps),
5784 last(AllSusps,Susp),
5786 gen_var(OtherSusps),
5787 functor(CurrentHead,OtherF,OtherA),
5788 gen_vars(OtherA,OtherVars),
5789 delay_phase_end(validate_store_type_assumptions,
5790 ( static_suspension_term(OtherF/OtherA,Suspension),
5791 get_static_suspension_field(OtherF/OtherA,Suspension,state,active,GetState),
5792 get_static_suspension_term_field(arguments,OtherF/OtherA,Suspension,OtherVars)
5795 % create_get_mutable_ref(active,State,GetMutable),
5797 OtherSusp = Suspension,
5800 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
5801 build_head(F,A,Id,ClauseVars,ClauseHead),
5802 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
5803 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId),
5804 RecursiveVars = PreVarsAndSusps1
5806 RecursiveVars = [OtherSusps|PreVarsAndSusps],
5809 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
5810 RecursiveCall = RecursiveHead,
5811 CurrentHead =.. [_|OtherArgs],
5812 pairup(OtherArgs,OtherVars,OtherPairs),
5813 get_constraint_mode(OtherF/OtherA,Mode),
5814 head_arg_matches(OtherPairs,Mode,VarDict1,Matching,VarDict),
5816 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,RestSusps,DiffSuspGoals),
5817 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
5819 ( BodyCopy \== true, is_observed(F/A,O) ->
5820 init(FirstVarsSusp,FirstVars),
5821 gen_uncond_attach_goal(F/A,Susp,FirstVars,Attach,Generation),
5822 gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
5824 ConditionalRecursiveCall = RecursiveCall
5826 ( (is_least_occurrence(RuleNb) ; has_no_history(RuleNb)) ->
5827 NovelProduction = true,
5828 ExtendHistory = true
5830 get_occurrence(F/A,O,_,ID),
5831 history_susps(RestIDs,[OtherSusp|RestSusps],Susp,ID,HistorySusps),
5832 Tuple =.. [t,RuleNb|HistorySusps],
5833 findall(Functor/Arity,(member(H,H2),functor(H,Functor,Arity)),ConstraintSymbols),
5834 sort([ID|RestIDs],HistoryIDs),
5835 ( \+ may_trigger(F/A), forall(member(SomeID,RestIDs),(chr_translate:is_passive(RuleNb,SomeID))) ->
5836 NovelProduction = true,
5837 ExtendHistory = true
5839 use_auxiliary_predicate(novel_production),
5840 use_auxiliary_predicate(extend_history),
5841 does_use_history(F/A,O),
5842 novel_production_calls(ConstraintSymbols,HistoryIDs,HistorySusps,RuleNb,TupleVar,NovelProductions),
5843 NovelProduction = ( TupleVar = Tuple, NovelProductions),
5844 ExtendHistory = '$extend_history'(Susp,TupleVar)
5849 ( chr_pp_flag(debugable,on) ->
5850 Rule = rule(_,_,Guard,Body),
5851 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),
5852 get_occurrence(F/A,O,_,ID),
5853 sort_by_key([Susp,OtherSusp|RestSusps],[ID|RestIDs],KeptSusps),
5854 DebugTry = 'chr debug_event'( try([],KeptSusps,DebugGuard,DebugBody)),
5855 DebugApply = 'chr debug_event'(apply([],KeptSusps,DebugGuard,DebugBody))
5873 ConditionalRecursiveCall
5879 novel_production_calls([],[],[],_,_,true).
5880 novel_production_calls([ConstraintSymbol|ConstraintSymbols],[ID|IDs],[Suspension|Suspensions],RuleNb,Tuple,(Goal,Goals)) :-
5881 get_occurrence_from_id(ConstraintSymbol,Occurrence,RuleNb,ID),
5882 delay_phase_end(validate_store_type_assumptions,novel_production_call(ConstraintSymbol,Occurrence,'$novel_production'(Suspension,Tuple),Goal)),
5883 novel_production_calls(ConstraintSymbols,IDs,Suspensions,RuleNb,Tuple,Goals).
5885 history_susps(RestIDs,ReversedRestSusps,Susp,ID,HistorySusps) :-
5886 reverse(ReversedRestSusps,RestSusps),
5887 sort_by_key([Susp|RestSusps],[ID|RestIDs],HistorySusps).
5890 gen_var_susp_list_for([Head],Terms,VarDict,HeadVars,VarsSusp,Susp) :-
5893 head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs),
5894 get_constraint_mode(F/A,Mode),
5895 head_arg_matches(HeadPairs,Mode,[],_,VarDict),
5896 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
5897 append(VarsSusp,ExtraVars,HeadVars).
5898 gen_var_susp_list_for([Head|Heads],Terms,NVarDict,VarsSusps,Rest,Susps) :-
5899 gen_var_susp_list_for(Heads,[Head|Terms],VarDict,Rest,_,_),
5902 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
5903 get_constraint_mode(F/A,Mode),
5904 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
5905 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
5906 append(HeadVars,[Susp,Susps|Rest],VarsSusps).
5909 % VarDict for the copies of variables in the original heads
5910 % VarsSuspsList list of lists of arguments for the successive heads
5911 % FirstVarsSusp top level arguments
5912 % SuspList list of all suspensions
5913 % Iterators list of all iterators
5914 gen_var_susp_list_for_b([Head],NextHeads,VarDict,[HeadVars],VarsSusp,[Susp],[]) :-
5917 head_info(Head,A,_Vars,Susp,VarsSusp,Pairs), % make variables for argument positions
5918 get_constraint_mode(F/A,Mode),
5919 head_arg_matches(Pairs,Mode,[],_,VarDict), % copy variables inside arguments, build dictionary
5920 extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars), % decide what additional variables are needed
5921 append(VarsSusp,ExtraVars,HeadVars). % add additional variables to head variables
5922 gen_var_susp_list_for_b([Head|Heads],NextHeads,NVarDict,[Vars|RestVars],FirstVarsSusp,[Susp|SuspList],[Susps|Iterators]) :-
5923 gen_var_susp_list_for_b(Heads,[Head|NextHeads],VarDict,RestVars,FirstVarsSusp,SuspList,Iterators),
5926 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
5927 get_constraint_mode(F/A,Mode),
5928 head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
5929 passive_delegate_variables(Head,Heads,NextHeads,NVarDict,HeadVars),
5930 append(HeadVars,[Susp,Susps],Vars).
5932 get_prop_inner_loop_vars([Head],NextHeads,HeadVars,VarDict,Susp,Vars,[]) :-
5935 head_info(Head,A,Vars,Susp,VarsSusp,Pairs),
5936 get_constraint_mode(F/A,Mode),
5937 head_arg_matches(Pairs,Mode,[],_,VarDict),
5938 extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars),
5939 append(VarsSusp,ExtraVars,HeadVars).
5940 get_prop_inner_loop_vars([Head|Heads],Terms,VarsSusps,NVarDict,MainSusp,MainVars,[Susp|RestSusps]) :-
5941 get_prop_inner_loop_vars(Heads,[Head|Terms],RestVarsSusp,VarDict,MainSusp,MainVars,RestSusps),
5944 head_info(Head,A,_Vars,Susp,_VarsSusp,Pairs),
5945 get_constraint_mode(F/A,Mode),
5946 head_arg_matches(Pairs,Mode,VarDict,_,NVarDict),
5947 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
5948 append(HeadVars,[Susp,Susps|RestVarsSusp],VarsSusps).
5950 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5952 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5954 %% | _ \ __ _ ___ ___(_)_ _____ | | | | ___ __ _ __| |
5955 %% | |_) / _` / __/ __| \ \ / / _ \ | |_| |/ _ \/ _` |/ _` |
5956 %% | __/ (_| \__ \__ \ |\ V / __/ | _ | __/ (_| | (_| |
5957 %% |_| \__,_|___/___/_| \_/ \___| |_| |_|\___|\__,_|\__,_|
5960 %% | _ \ ___| |_ _ __(_) _____ ____ _| |
5961 %% | |_) / _ \ __| '__| |/ _ \ \ / / _` | |
5962 %% | _ < __/ |_| | | | __/\ V / (_| | |
5963 %% |_| \_\___|\__|_| |_|\___| \_/ \__,_|_|
5966 %% | _ \ ___ ___ _ __ __| | ___ _ __(_)_ __ __ _
5967 %% | |_) / _ \/ _ \| '__/ _` |/ _ \ '__| | '_ \ / _` |
5968 %% | _ < __/ (_) | | | (_| | __/ | | | | | | (_| |
5969 %% |_| \_\___|\___/|_| \__,_|\___|_| |_|_| |_|\__, |
5972 reorder_heads(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
5973 ( chr_pp_flag(reorder_heads,on), length(RestHeads,Length), Length =< 6 ->
5974 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs)
5976 NRestHeads = RestHeads,
5980 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
5981 term_variables(Head,Vars),
5982 InitialData = entry([],[],Vars,RestHeads,RestIDs,RuleNb),
5983 copy_term_nat(InitialData,InitialDataCopy),
5984 a_star(InitialDataCopy,FD^(chr_translate:final_data(FD)),N^EN^C^(chr_translate:expand_data(N,EN,C)),FinalData),
5985 InitialDataCopy = InitialData,
5986 FinalData = entry(RNRestHeads,RNRestIDs,_,_,_,_),
5987 reverse(RNRestHeads,NRestHeads),
5988 reverse(RNRestIDs,NRestIDs).
5990 final_data(Entry) :-
5991 Entry = entry(_,_,_,_,[],_).
5993 expand_data(Entry,NEntry,Cost) :-
5994 Entry = entry(Heads,IDs,Vars,NHeads,NIDs,RuleNb),
5995 select2(Head1,ID1,NHeads,NIDs,NHeads1,NIDs1),
5996 term_variables([Head1|Vars],Vars1),
5997 NEntry = entry([Head1|Heads],[ID1|IDs],Vars1,NHeads1,NIDs1,RuleNb),
5998 order_score(Head1,ID1,Vars,NHeads1,RuleNb,Cost).
6000 % Assigns score to head based on known variables and heads to lookup
6001 order_score(Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
6003 get_store_type(F/A,StoreType),
6004 order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,Score).
6006 order_score(default,Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
6007 term_variables(Head,HeadVars),
6008 term_variables(RestHeads,RestVars),
6009 order_score_vars(HeadVars,KnownVars,RestVars,Score).
6010 order_score(multi_inthash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
6011 order_score_indexes(Indexes,Head,KnownVars,0,Score).
6012 order_score(multi_hash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
6013 order_score_indexes(Indexes,Head,KnownVars,0,Score).
6014 order_score(global_ground,Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
6015 term_variables(Head,HeadVars),
6016 term_variables(RestHeads,RestVars),
6017 order_score_vars(HeadVars,KnownVars,RestVars,Score_),
6018 Score is Score_ * 2.
6019 order_score(var_assoc_store(_,_),_,_,_,_,_,1).
6020 order_score(global_singleton,_Head,ID,_KnownVars,_RestHeads,_RuleNb,Score) :-
6021 Score = 1. % guaranteed O(1)
6023 order_score(multi_store(StoreTypes),Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
6024 find_with_var_identity(
6026 t(Head,KnownVars,RestHeads),
6027 ( lists:member(ST,StoreTypes), chr_translate:order_score(ST,Head,ID,KnownVars,RestHeads,RuleNb,S) ),
6030 min_list(Scores,Score).
6033 order_score_indexes([],_,_,Score,NScore) :-
6034 Score > 0, NScore = 100.
6035 order_score_indexes([I|Is],Head,KnownVars,Score,NScore) :-
6036 multi_hash_key_args(I,Head,Args),
6037 ( forall(Arg,Args,memberchk_eq(Arg,KnownVars)) ->
6042 order_score_indexes(Is,Head,KnownVars,Score1,NScore).
6044 order_score_vars(Vars,KnownVars,RestVars,Score) :-
6045 order_score_count_vars(Vars,KnownVars,RestVars,K-R-O),
6049 Score is max(10 - K,0)
6051 Score is max(10 - R,1) * 10
6053 Score is max(10-O,1) * 100
6055 order_score_count_vars([],_,_,0-0-0).
6056 order_score_count_vars([V|Vs],KnownVars,RestVars,NK-NR-NO) :-
6057 order_score_count_vars(Vs,KnownVars,RestVars,K-R-O),
6058 ( memberchk_eq(V,KnownVars) ->
6061 ; memberchk_eq(V,RestVars) ->
6069 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6071 %% |_ _|_ __ | (_)_ __ (_)_ __ __ _
6072 %% | || '_ \| | | '_ \| | '_ \ / _` |
6073 %% | || | | | | | | | | | | | | (_| |
6074 %% |___|_| |_|_|_|_| |_|_|_| |_|\__, |
6078 create_get_mutable_ref(V,M,GM) :- GM = (M = mutable(V)).
6079 create_get_mutable(V,M,GM) :- M = mutable(V), GM = true.
6083 %% create_get_mutable(V,M,GM) :- GM = get_mutable(V,M).
6084 %% create_get_mutable_ref(V,M,GM) :- GM = get_mutable(V,M).
6087 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6089 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6091 %% | | | | |_(_) (_) |_ _ _
6092 %% | | | | __| | | | __| | | |
6093 %% | |_| | |_| | | | |_| |_| |
6094 %% \___/ \__|_|_|_|\__|\__, |
6101 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs) :-
6102 vars_susp(A,Vars,Susp,VarsSusp),
6104 pairup(Args,Vars,HeadPairs).
6106 inc_id([N|Ns],[O|Ns]) :-
6108 dec_id([N|Ns],[M|Ns]) :-
6111 extend_id(Id,[0|Id]).
6113 next_id([_,N|Ns],[O|Ns]) :-
6116 build_head(F,A,Id,Args,Head) :-
6117 buildName(F,A,Id,Name),
6118 ( (chr_pp_flag(debugable,on) ; is_stored(F/A), has_active_occurrence(F/A),
6119 ( may_trigger(F/A) ;
6120 get_allocation_occurrence(F/A,AO),
6121 get_max_occurrence(F/A,MO),
6123 Head =.. [Name|Args]
6125 init(Args,ArgsWOSusp), % XXX not entirely correct!
6126 Head =.. [Name|ArgsWOSusp]
6129 buildName(Fct,Aty,List,Result) :-
6130 ( (chr_pp_flag(debugable,on) ; (once((is_stored(Fct/Aty), ( has_active_occurrence(Fct/Aty) ; chr_pp_flag(late_allocation,off)),
6131 ( may_trigger(Fct/Aty) ; get_allocation_occurrence(Fct/Aty,AO), get_max_occurrence(Fct/Aty,MO),
6132 MO >= AO ) ; List \= [0])) ) ) ->
6133 atom_concat(Fct, (/) ,FctSlash),
6134 atomic_concat(FctSlash,Aty,FctSlashAty),
6135 buildName_(List,FctSlashAty,Result)
6140 buildName_([],Name,Name).
6141 buildName_([N|Ns],Name,Result) :-
6142 buildName_(Ns,Name,Name1),
6143 atom_concat(Name1,'__',NameDash), % '_' is a char :-(
6144 atomic_concat(NameDash,N,Result).
6146 vars_susp(A,Vars,Susp,VarsSusp) :-
6148 append(Vars,[Susp],VarsSusp).
6150 make_attr(N,Mask,SuspsList,Attr) :-
6151 length(SuspsList,N),
6152 Attr =.. [v,Mask|SuspsList].
6154 or_pattern(Pos,Pat) :-
6156 Pat is 1 << Pow. % was 2 ** X
6158 and_pattern(Pos,Pat) :-
6160 Y is 1 << X, % was 2 ** X
6161 Pat is (-1)*(Y + 1).
6163 make_name(Prefix,F/A,Name) :-
6164 atom_concat_list([Prefix,F,(/),A],Name).
6166 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6167 % Storetype dependent lookup
6168 lookup_passive_head(Head,PreJoin,VarDict,Goal,AllSusps) :-
6170 get_store_type(F/A,StoreType),
6171 lookup_passive_head(StoreType,Head,PreJoin,VarDict,Goal,AllSusps).
6173 lookup_passive_head(default,Head,PreJoin,VarDict,Goal,AllSusps) :-
6175 passive_head_via(Head,PreJoin,VarDict,Goal,AllSusps).
6176 lookup_passive_head(multi_inthash(Indexes),Head,_PreJoin,VarDict,Goal,AllSusps) :-
6178 member(Index,Indexes),
6179 multi_hash_key_args(Index,Head,KeyArgs),
6180 (translate(KeyArgs,VarDict,KeyArgCopies) ;
6181 ground(KeyArgs), KeyArgCopies = KeyArgs )
6183 ( KeyArgCopies = [KeyCopy] ->
6186 KeyCopy =.. [k|KeyArgCopies]
6189 multi_hash_via_lookup_name(F/A,Index,ViaName),
6190 Goal =.. [ViaName,KeyCopy,AllSusps],
6191 update_store_type(F/A,multi_inthash([Index])).
6192 lookup_passive_head(multi_hash(Indexes),Head,_PreJoin,VarDict,Goal,AllSusps) :-
6194 member(Index,Indexes),
6195 multi_hash_key_args(Index,Head,KeyArgs),
6196 (translate(KeyArgs,VarDict,KeyArgCopies) ;
6197 ground(KeyArgs), KeyArgCopies = KeyArgs )
6199 ( KeyArgCopies = [KeyCopy] ->
6202 KeyCopy =.. [k|KeyArgCopies]
6205 multi_hash_via_lookup_name(F/A,Index,ViaName),
6206 Goal =.. [ViaName,KeyCopy,AllSusps],
6207 update_store_type(F/A,multi_hash([Index])).
6208 lookup_passive_head(global_ground,Head,_PreJoin,_VarDict,Goal,AllSusps) :-
6210 global_ground_store_name(F/A,StoreName),
6211 make_get_store_goal(StoreName,AllSusps,Goal), % Goal = nb_getval(StoreName,AllSusps),
6212 update_store_type(F/A,global_ground).
6213 lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,_PreJoin,VarDict,Goal,AllSusps) :-
6214 arg(VarIndex,Head,OVar),
6215 arg(KeyIndex,Head,OKey),
6216 translate([OVar,OKey],VarDict,[Var,Key]),
6217 get_target_module(Module),
6219 get_attr(Var,Module,AssocStore),
6220 lookup_assoc_store(AssocStore,Key,AllSusps)
6222 lookup_passive_head(global_singleton,Head,_PreJoin,_VarDict,Goal,AllSusps) :-
6224 global_singleton_store_name(F/A,StoreName),
6225 make_get_store_goal(StoreName,Susp,GetStoreGoal),
6226 Goal = (GetStoreGoal,Susp \== [],AllSusps = [Susp]),
6227 update_store_type(F/A,global_singleton).
6228 lookup_passive_head(multi_store(StoreTypes),Head,PreJoin,VarDict,Goal,AllSusps) :-
6230 member(ST,StoreTypes),
6231 lookup_passive_head(ST,Head,PreJoin,VarDict,Goal,AllSusps)
6234 existential_lookup(var_assoc_store(VarIndex,KeyIndex),Head,_PreJoin,VarDict,SuspTerm,Goal,Susp,Pairs,Pairs) :- !,
6235 arg(VarIndex,Head,OVar),
6236 arg(KeyIndex,Head,OKey),
6237 translate([OVar,OKey],VarDict,[Var,Key]),
6238 get_target_module(Module),
6239 sbag_member_call(Susp,AllSusps,Sbag),
6241 delay_phase_end(validate_store_type_assumptions,
6242 ( static_suspension_term(F/A,SuspTerm),
6243 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
6247 get_attr(Var,Module,AssocStore),
6248 lookup_assoc_store(AssocStore,Key,AllSusps),
6253 existential_lookup(global_singleton,Head,_PreJoin,_VarDict,SuspTerm,Goal,Susp,Pairs,Pairs) :- !,
6255 global_singleton_store_name(F/A,StoreName),
6256 make_get_store_goal(StoreName,Susp,GetStoreGoal),
6258 GetStoreGoal, % nb_getval(StoreName,Susp),
6262 update_store_type(F/A,global_singleton).
6263 existential_lookup(multi_store(StoreTypes),Head,PreJoin,VarDict,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
6265 member(ST,StoreTypes),
6266 existential_lookup(ST,Head,PreJoin,VarDict,SuspTerm,Goal,Susp,Pairs,NPairs)
6268 existential_lookup(multi_inthash(Indexes),Head,_PreJoin,VarDict,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
6270 member(Index,Indexes),
6271 multi_hash_key_args(Index,Head,KeyArgs),
6272 (translate(KeyArgs,VarDict,KeyArgCopies) ;
6273 ground(KeyArgs), KeyArgCopies = KeyArgs )
6275 ( KeyArgCopies = [KeyCopy] ->
6278 KeyCopy =.. [k|KeyArgCopies]
6281 multi_hash_via_lookup_name(F/A,Index,ViaName),
6282 LookupGoal =.. [ViaName,KeyCopy,AllSusps],
6283 delay_phase_end(validate_store_type_assumptions,
6284 ( static_suspension_term(F/A,SuspTerm),
6285 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
6288 sbag_member_call(Susp,AllSusps,Sbag),
6292 Susp = SuspTerm, % not inlined
6295 hash_index_filter(Pairs,Index,NPairs),
6296 update_store_type(F/A,multi_inthash([Index])).
6297 existential_lookup(multi_hash(Indexes),Head,PreJoin,VarDict,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
6299 member(Index,Indexes),
6300 multi_hash_key_args(Index,Head,KeyArgs),
6301 (translate(KeyArgs,VarDict,KeyArgCopies) ;
6302 ground(KeyArgs), KeyArgCopies = KeyArgs )
6304 ( KeyArgCopies = [KeyCopy] ->
6307 KeyCopy =.. [k|KeyArgCopies]
6310 multi_hash_via_lookup_name(F/A,Index,ViaName),
6311 LookupGoal =.. [ViaName,KeyCopy,AllSusps],
6312 ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
6313 Sbag = (AllSusps = [Susp])
6315 sbag_member_call(Susp,AllSusps,Sbag)
6317 delay_phase_end(validate_store_type_assumptions,
6318 ( static_suspension_term(F/A,SuspTerm),
6319 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
6325 Susp = SuspTerm, % not inlined
6328 hash_index_filter(Pairs,Index,NPairs),
6329 update_store_type(F/A,multi_hash([Index])).
6330 existential_lookup(StoreType,Head,PreJoin,VarDict,SuspTerm,Goal,Susp,Pairs,Pairs) :-
6331 lookup_passive_head(StoreType,Head,PreJoin,VarDict,UGoal,Susps),
6332 sbag_member_call(Susp,Susps,Sbag),
6334 delay_phase_end(validate_store_type_assumptions,
6335 ( static_suspension_term(F/A,SuspTerm),
6336 get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
6342 Susp = SuspTerm, % not inlined
6346 hash_index_filter(Pairs,Index,NPairs) :-
6352 hash_index_filter(Pairs,NIndex,1,NPairs).
6354 hash_index_filter([],_,_,[]).
6355 hash_index_filter([P|Ps],Index,N,NPairs) :-
6360 hash_index_filter(Ps,[I|Is],NN,NPs)
6363 hash_index_filter(Ps,Is,NN,NPs)
6369 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6370 assume_constraint_stores([]).
6371 assume_constraint_stores([C|Cs]) :-
6372 ( only_ground_indexed_arguments(C),
6374 get_store_type(C,default) ->
6375 get_indexed_arguments(C,IndexedArgs),
6376 % TODO: O(2^n) is not robust for too many indexed arguments,
6377 % reject some possible indexes...
6378 % or replace brute force index generation with other approach
6379 length(IndexedArgs,NbIndexedArgs),
6380 ( NbIndexedArgs > 10 ->
6381 findall([Index],member(Index,IndexedArgs),Indexes)
6383 findall(Index,(sublist(Index,IndexedArgs), Index \== []),UnsortedIndexes),
6384 predsort(longer_list,UnsortedIndexes,Indexes)
6386 ( get_functional_dependency(C,1,Pattern,Key),
6387 all_distinct_var_args(Pattern), Key == [] ->
6388 assumed_store_type(C,global_singleton)
6390 ( get_constraint_type(C,Type),
6391 findall(Index,(member(Index,Indexes), Index = [I],
6392 nth(I,Type,dense_int)),IndexesA),
6394 list_difference_eq(Indexes,IndexesA,IndexesB),
6395 ( IndexesB \== [] ->
6396 assumed_store_type(C,multi_store([multi_inthash(IndexesA),multi_hash(IndexesB),global_ground]))
6398 assumed_store_type(C,multi_store([multi_inthash(IndexesA),global_ground]))
6401 assumed_store_type(C,multi_store([multi_hash(Indexes),global_ground]))
6407 assume_constraint_stores(Cs).
6409 longer_list(R,L1,L2) :-
6419 all_distinct_var_args(Term) :-
6421 copy_term_nat(Args,NArgs),
6422 all_distinct_var_args_(NArgs).
6424 all_distinct_var_args_([]).
6425 all_distinct_var_args_([X|Xs]) :-
6428 all_distinct_var_args_(Xs).
6430 get_indexed_arguments(C,IndexedArgs) :-
6432 get_indexed_arguments(1,A,C,IndexedArgs).
6434 get_indexed_arguments(I,N,C,L) :-
6437 ; ( is_indexed_argument(C,I) ->
6443 get_indexed_arguments(J,N,C,T)
6446 validate_store_type_assumptions([]).
6447 validate_store_type_assumptions([C|Cs]) :-
6448 validate_store_type_assumption(C),
6449 validate_store_type_assumptions(Cs).
6451 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6452 % new code generation
6453 universal_search_iterator_end([CurrentHead|PrevHeads],NextHeads,Rule,F/A,Id,L,T) :-
6454 Rule = rule(H1,_,Guard,Body),
6456 functor(CurrentHead,CF,CA),
6457 check_fd_lookup_condition(CF,CA,CurrentHead,PrevHeads) ->
6460 gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators),
6461 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId),
6462 flatten(VarsAndSuspsList,VarsAndSusps),
6463 Vars = [ [] | VarsAndSusps],
6464 build_head(F,A,Id,Vars,Head),
6465 build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
6466 Clause = ( Head :- PredecessorCall),
6470 % skips back intelligently over global_singleton lookups
6471 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,BaseCallArgs,PrevIterators,PrevVarsAndSusps,PrevId) :-
6474 PrevVarsAndSusps = BaseCallArgs
6476 VarsAndSuspsList = [_|AllButFirstList],
6478 ( PrevHeads = [PrevHead|PrevHeads1],
6479 functor(PrevHead,F,A),
6480 check_fd_lookup_condition(F,A,PrevHead,PrevHeads1) ->
6481 PrevIterators = [_|PrevIterators1],
6482 universal_search_iterator_failure_vars(PrevHeads1,PrevId1,AllButFirstList,BaseCallArgs,PrevIterators1,PrevVarsAndSusps,PrevId)
6485 flatten(AllButFirstList,AllButFirst),
6486 PrevIterators = [PrevIterator|_],
6487 PrevVarsAndSusps = [PrevIterator|AllButFirst]
6491 universal_search_iterator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,Id,L,T) :-
6492 Rule = rule(_,_,Guard,Body),
6493 gen_var_susp_list_for_b(PreHeads,[CurrentHead,NextHead,RestHeads,Guard,Body],VarDict,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
6494 init(AllSusps,PreSusps),
6495 flatten(PreVarsAndSuspsList,PreVarsAndSusps),
6496 gen_var(OtherSusps),
6497 functor(CurrentHead,OtherF,OtherA),
6498 gen_vars(OtherA,OtherVars),
6499 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
6500 get_constraint_mode(OtherF/OtherA,Mode),
6501 head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1),
6503 delay_phase_end(validate_store_type_assumptions,
6504 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
6505 get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState),
6506 get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
6510 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
6511 % create_get_mutable_ref(active,State,GetMutable),
6513 OtherSusp = OtherSuspension,
6518 lookup_passive_head(NextHead,[CurrentHead|PreHeads],VarDict1,NextSuspGoal,NextSusps),
6519 inc_id(Id,NestedId),
6520 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
6521 build_head(F,A,Id,ClauseVars,ClauseHead),
6522 passive_delegate_variables(CurrentHead,PreHeads,[NextHead,RestHeads,Guard,Body],VarDict1,CurrentHeadVars),
6523 append([NextSusps|CurrentHeadVars],[OtherSusp,OtherSusps|PreVarsAndSusps],NestedVars),
6524 build_head(F,A,NestedId,NestedVars,NestedHead),
6526 ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime
6527 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId),
6528 RecursiveVars = PreVarsAndSusps1
6530 RecursiveVars = [OtherSusps|PreVarsAndSusps],
6533 build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
6546 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6548 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6549 % Observation Analysis
6554 % Analysis based on Abstract Interpretation paper.
6557 % stronger analysis domain [research]
6560 initial_call_pattern/1,
6562 call_pattern_worker/1,
6563 final_answer_pattern/2,
6564 abstract_constraints/1,
6568 ai_observed_internal/2,
6570 ai_not_observed_internal/2,
6574 ai_observation_gather_results/0.
6576 :- chr_option(type_definition,type(abstract_domain,[odom(any,any)])).
6578 :- chr_option(mode,initial_call_pattern(+)).
6579 :- chr_option(type_declaration,call_pattern(abstract_domain)).
6581 :- chr_option(mode,call_pattern(+)).
6582 :- chr_option(type_declaration,call_pattern(abstract_domain)).
6584 :- chr_option(mode,call_pattern_worker(+)).
6585 :- chr_option(type_declaration,call_pattern_worker(abstract_domain)).
6587 :- chr_option(mode,final_answer_pattern(+,+)).
6588 :- chr_option(type_declaration,final_answer_pattern(abstract_domain,abstract_domain)).
6590 :- chr_option(mode,abstract_constraints(+)).
6591 :- chr_option(type_declaration,abstract_constraints(list)).
6593 :- chr_option(mode,depends_on(+,+)).
6594 :- chr_option(type_declaration,depends_on(abstract_domain,abstract_domain)).
6596 :- chr_option(mode,depends_on_as(+,+,+)).
6597 :- chr_option(mode,depends_on_ap(+,+,+,+)).
6598 :- chr_option(mode,depends_on_goal(+,+)).
6599 :- chr_option(mode,ai_is_observed(+,+)).
6600 :- chr_option(mode,ai_not_observed(+,+)).
6601 % :- chr_option(mode,ai_observed(+,+)).
6602 :- chr_option(mode,ai_not_observed_internal(+,+)).
6603 :- chr_option(mode,ai_observed_internal(+,+)).
6606 abstract_constraints_fd @
6607 abstract_constraints(_) \ abstract_constraints(_) <=> true.
6609 ai_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
6610 ai_not_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
6611 ai_observed_internal(C,O) \ ai_observed_internal(C,O) <=> true.
6613 ai_not_observed(C,O) \ ai_is_observed(C,O) <=> fail.
6614 ai_is_observed(_,_) <=> true.
6616 ai_observation_gather_results \ ai_observed_internal(C,O) <=> true. % ai_observed(C,O).
6617 ai_observation_gather_results \ ai_not_observed_internal(C,O) <=> ai_not_observed(C,O).
6618 ai_observation_gather_results <=> true.
6620 %------------------------------------------------------------------------------%
6621 % Main Analysis Entry
6622 %------------------------------------------------------------------------------%
6623 ai_observation_analysis(ACs) :-
6624 ( chr_pp_flag(ai_observation_analysis,on),
6625 get_target_module(Module), '$chr_compiled_with_version'(3) -> % , Module \== guard_entailment ->
6626 list_to_ord_set(ACs,ACSet),
6627 abstract_constraints(ACSet),
6628 ai_observation_schedule_initial_calls(ACSet,ACSet),
6629 ai_observation_gather_results
6634 ai_observation_schedule_initial_calls([],_).
6635 ai_observation_schedule_initial_calls([AC|RACs],ACs) :-
6636 ai_observation_schedule_initial_call(AC,ACs),
6637 ai_observation_schedule_initial_calls(RACs,ACs).
6639 ai_observation_schedule_initial_call(AC,ACs) :-
6640 ai_observation_top(AC,CallPattern),
6641 % ai_observation_bot(AC,ACs,CallPattern),
6642 initial_call_pattern(CallPattern).
6644 ai_observation_schedule_new_calls([],AP).
6645 ai_observation_schedule_new_calls([AC|ACs],AP) :-
6647 initial_call_pattern(odom(AC,Set)),
6648 ai_observation_schedule_new_calls(ACs,AP).
6650 final_answer_pattern(CP,AP1) \ final_answer_pattern(CP,AP2)
6652 ai_observation_leq(AP2,AP1)
6656 initial_call_pattern(CP) \ initial_call_pattern(CP) <=> true.
6658 initial_call_pattern(CP) ==> call_pattern(CP).
6660 initial_call_pattern(CP), final_answer_pattern(CP,AP), abstract_constraints(ACs) # ID3
6662 ai_observation_schedule_new_calls(ACs,AP)
6666 call_pattern(CP) \ call_pattern(CP) <=> true.
6668 depends_on(CP1,CP2), final_answer_pattern(CP2,AP) ==>
6669 final_answer_pattern(CP1,AP).
6671 %call_pattern(CP) ==> writeln(call_pattern(CP)).
6673 call_pattern(CP) ==> call_pattern_worker(CP).
6675 %------------------------------------------------------------------------------%
6677 %------------------------------------------------------------------------------%
6680 %call_pattern(odom([],Set)) ==>
6681 % final_answer_pattern(odom([],Set),odom([],Set)).
6683 call_pattern_worker(odom([],Set)) <=>
6684 % writeln(' - AbstractGoal'(odom([],Set))),
6685 final_answer_pattern(odom([],Set),odom([],Set)).
6688 call_pattern_worker(odom([G|Gs],Set)) <=>
6689 % writeln(' - AbstractGoal'(odom([G|Gs],Set))),
6691 depends_on_goal(odom([G|Gs],Set),CP1),
6694 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2) \ depends_on(CP1,_) # ID
6695 <=> true pragma passive(ID).
6696 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2)
6698 CP1 = odom([_|Gs],_),
6702 depends_on(CP1,CCP).
6704 %------------------------------------------------------------------------------%
6706 %------------------------------------------------------------------------------%
6707 call_pattern_worker(odom(builtin,Set)) <=>
6708 % writeln(' - AbstractSolve'(odom(builtin,Set))),
6709 ord_empty(EmptySet),
6710 final_answer_pattern(odom(builtin,Set),odom([],EmptySet)).
6712 %------------------------------------------------------------------------------%
6714 %------------------------------------------------------------------------------%
6715 max_occurrence(C,MO) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
6719 % writeln(' - AbstractDrop'(odom(occ(C,O),Set))),
6720 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
6724 %------------------------------------------------------------------------------%
6726 %------------------------------------------------------------------------------%
6727 call_pattern_worker(odom(AC,Set))
6731 % writeln(' - AbstractActivate'(odom(AC,Set))),
6732 CP = odom(occ(AC,1),Set),
6734 depends_on(odom(AC,Set),CP).
6736 %------------------------------------------------------------------------------%
6738 %------------------------------------------------------------------------------%
6739 occurrence(C,O,RuleNb,ID,_) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
6741 is_passive(RuleNb,ID)
6743 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
6746 DCP = odom(occ(C,NO),Set),
6748 final_answer_pattern(odom(occ(C,O),Set),odom([],Set)),
6749 depends_on(odom(occ(C,O),Set),DCP)
6752 %------------------------------------------------------------------------------%
6754 %------------------------------------------------------------------------------%
6757 occurrence(C,O,RuleNb,ID,simplification) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
6759 \+ is_passive(RuleNb,ID)
6761 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
6762 ai_observation_memo_simplification_rest_heads(C,O,AbstractRestHeads),
6763 ai_observation_observe_set(Set,AbstractRestHeads,Set2),
6764 ai_observation_memo_abstract_goal(RuleNb,AG),
6765 call_pattern(odom(AG,Set2)),
6768 DCP = odom(occ(C,NO),Set),
6770 depends_on_as(odom(occ(C,O),Set),odom(AG,Set2),DCP),
6771 % DEADLOCK AVOIDANCE
6772 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
6776 depends_on_as(CP,CPS,CPD),
6777 final_answer_pattern(CPS,APS),
6778 final_answer_pattern(CPD,APD) ==>
6779 ai_observation_lub(APS,APD,AP),
6780 final_answer_pattern(CP,AP).
6784 ai_observation_memo_simplification_rest_heads/3,
6785 ai_observation_memoed_simplification_rest_heads/3.
6787 :- chr_option(mode,ai_observation_memo_simplification_rest_heads(+,+,?)).
6788 :- chr_option(mode,ai_observation_memoed_simplification_rest_heads(+,+,+)).
6790 ai_observation_memoed_simplification_rest_heads(C,O,RH) \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
6793 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
6795 Rule = pragma(rule(H1,H2,_,_),ids(IDs1,_),_,_,_),
6796 once(select2(ID,_,IDs1,H1,_,RestH1)),
6797 ai_observation_abstract_constraints(RestH1,ACs,ARestHeads),
6798 ai_observation_abstract_constraints(H2,ACs,AH2),
6799 append(ARestHeads,AH2,AbstractHeads),
6800 sort(AbstractHeads,QRH),
6801 ai_observation_memoed_simplification_rest_heads(C,O,QRH)
6807 ai_observation_memo_simplification_rest_heads(_,_,_) <=> fail.
6809 %------------------------------------------------------------------------------%
6810 % Abstract Propagate
6811 %------------------------------------------------------------------------------%
6815 occurrence(C,O,RuleNb,ID,propagation) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
6817 \+ is_passive(RuleNb,ID)
6819 % writeln(' - AbstractPropagate'(odom(occ(C,O),Set))),
6821 ai_observation_memo_propagation_rest_heads(C,O,AHs),
6822 ai_observation_observe_set(Set,AHs,Set2),
6823 ord_add_element(Set2,C,Set3),
6824 ai_observation_memo_abstract_goal(RuleNb,AG),
6825 call_pattern(odom(AG,Set3)),
6826 ( ord_memberchk(C,Set2) ->
6833 DCP = odom(occ(C,NO),Set),
6835 depends_on_ap(odom(occ(C,O),Set),odom(AG,Set3),DCP,Delete)
6840 ai_observation_memo_propagation_rest_heads/3,
6841 ai_observation_memoed_propagation_rest_heads/3.
6843 :- chr_option(mode,ai_observation_memo_propagation_rest_heads(+,+,?)).
6844 :- chr_option(mode,ai_observation_memoed_propagation_rest_heads(+,+,+)).
6846 ai_observation_memoed_propagation_rest_heads(C,O,RH) \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
6849 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
6851 Rule = pragma(rule(H1,H2,_,_),ids(_,IDs2),_,_,_),
6852 once(select2(ID,_,IDs2,H2,_,RestH2)),
6853 ai_observation_abstract_constraints(RestH2,ACs,ARestHeads),
6854 ai_observation_abstract_constraints(H1,ACs,AH1),
6855 append(ARestHeads,AH1,AbstractHeads),
6856 sort(AbstractHeads,QRH),
6857 ai_observation_memoed_propagation_rest_heads(C,O,QRH)
6863 ai_observation_memo_propagation_rest_heads(_,_,_) <=> fail.
6865 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPD,APD) ==>
6866 final_answer_pattern(CP,APD).
6867 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPP,APP),
6868 final_answer_pattern(CPD,APD) ==>
6870 CP = odom(occ(C,O),_),
6871 ( ai_observation_is_observed(APP,C) ->
6872 ai_observed_internal(C,O)
6874 ai_not_observed_internal(C,O)
6877 APP = odom([],Set0),
6878 ord_del_element(Set0,C,Set),
6883 ai_observation_lub(NAPP,APD,AP),
6884 final_answer_pattern(CP,AP).
6886 %------------------------------------------------------------------------------%
6888 %------------------------------------------------------------------------------%
6890 call_pattern_worker(CP) <=> chr_error(internal,'AI observation analysis: unexpected abstract state ~w\n',[CP]).
6892 %------------------------------------------------------------------------------%
6893 % Auxiliary Predicates
6894 %------------------------------------------------------------------------------%
6896 ai_observation_lub(odom(AG,S1),odom(AG,S2),odom(AG,S3)) :-
6897 ord_intersection(S1,S2,S3).
6899 ai_observation_bot(AG,AS,odom(AG,AS)).
6901 ai_observation_top(AG,odom(AG,EmptyS)) :-
6904 ai_observation_leq(odom(AG,S1),odom(AG,S2)) :-
6907 ai_observation_observe_set(S,ACSet,NS) :-
6908 ord_subtract(S,ACSet,NS).
6910 ai_observation_abstract_constraint(C,ACs,AC) :-
6915 ai_observation_abstract_constraints(Cs,ACs,NACs) :-
6916 findall(NAC,(member(C,Cs),ai_observation_abstract_constraint(C,ACs,NAC)),NACs).
6918 %------------------------------------------------------------------------------%
6919 % Abstraction of Rule Bodies
6920 %------------------------------------------------------------------------------%
6923 ai_observation_memoed_abstract_goal/2,
6924 ai_observation_memo_abstract_goal/2.
6926 :- chr_option(mode,ai_observation_memoed_abstract_goal(+,+)).
6927 :- chr_option(mode,ai_observation_memo_abstract_goal(+,?)).
6929 ai_observation_memoed_abstract_goal(RuleNb,AG) # ID1 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
6935 rule(RuleNb,Rule) # ID1, abstract_constraints(ACs) # ID2 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
6937 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
6938 ai_observation_abstract_goal_(H1,H2,Guard,Body,ACs,AG),
6940 ai_observation_memoed_abstract_goal(RuleNb,AG)
6945 ai_observation_abstract_goal_(H1,H2,Guard,G,ACs,AG) :-
6946 % also guard: e.g. b, c(X) ==> Y=X | p(Y).
6947 term_variables((H1,H2,Guard),HVars),
6948 append(H1,H2,Heads),
6949 % variables that are declared to be ground are safe,
6950 ground_vars(Heads,GroundVars),
6951 % so we remove them from the list of 'dangerous' head variables
6952 list_difference_eq(HVars,GroundVars,HV),
6953 ai_observation_abstract_goal(G,ACs,AG,[],HV),!.
6954 % writeln(ai_observation_abstract_goal(G,ACs,AG,[],HV)).
6955 % HV are 'dangerous' variables, all others are fresh and safe
6958 ground_vars([H|Hs],GroundVars) :-
6960 get_constraint_mode(F/A,Mode),
6961 head_info(H,A,_Vars,_Susp,_HeadVars,HeadPairs),
6962 head_arg_matches(HeadPairs,Mode,[],_FirstMatching,_VarDict1,[],GroundVars1),
6963 ground_vars(Hs,GroundVars2),
6964 append(GroundVars1,GroundVars2,GroundVars).
6966 ai_observation_abstract_goal((G1,G2),ACs,List,Tail,HV) :- !, % conjunction
6967 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
6968 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
6969 ai_observation_abstract_goal((G1;G2),ACs,List,Tail,HV) :- !, % disjunction
6970 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
6971 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
6972 ai_observation_abstract_goal((G1->G2),ACs,List,Tail,HV) :- !, % if-then
6973 ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
6974 ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
6975 ai_observation_abstract_goal(C,ACs,[AC|Tail],Tail,HV) :-
6976 ai_observation_abstract_constraint(C,ACs,AC), !. % CHR constraint
6977 ai_observation_abstract_goal(true,_,Tail,Tail,_) :- !.
6978 ai_observation_abstract_goal(writeln(_),_,Tail,Tail,_) :- !.
6979 % non-CHR constraint is safe if it only binds fresh variables
6980 ai_observation_abstract_goal(G,_,Tail,Tail,HV) :-
6981 builtin_binds_b(G,Vars),
6982 intersect_eq(Vars,HV,[]),
6984 ai_observation_abstract_goal(G,_,[AG|Tail],Tail,_) :-
6985 AG = builtin. % default case if goal is not recognized/safe
6987 ai_observation_is_observed(odom(_,ACSet),AC) :-
6988 \+ ord_memberchk(AC,ACSet).
6990 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6991 unconditional_occurrence(C,O) :-
6992 get_occurrence(C,O,RuleNb,ID),
6993 get_rule(RuleNb,PRule),
6994 PRule = pragma(ORule,_,_,_,_),
6995 copy_term_nat(ORule,Rule),
6996 Rule = rule(H1,H2,Guard,_),
6997 guard_entailment:entails_guard([chr_pp_headvariables(H1,H2)],Guard),
6999 H1 = [Head], H2 == []
7001 H2 = [Head], H1 == [], \+ may_trigger(C)
7005 unconditional_occurrence_args(Args).
7007 unconditional_occurrence_args([]).
7008 unconditional_occurrence_args([X|Xs]) :-
7011 unconditional_occurrence_args(Xs).
7013 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7015 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
7016 % Partial wake analysis
7018 % In a Var = Var unification do not wake up constraints of both variables,
7019 % but rather only those of one variable.
7020 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
7023 partial_wake_analysis/0,
7027 partial_wake_analysis, occurrence(FA,O,RuleNb,ID,Type), rule(RuleNb,Rule), constraint_mode(FA,ArgModes)
7029 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
7030 ( is_passive(RuleNb,ID) ->
7032 ; Type == simplification ->
7033 select(H,H1,RestH1),
7035 term_variables(Guard,Vars),
7036 partial_wake_args(Args,ArgModes,Vars,FA)
7037 ; % Type == propagation ->
7038 select(H,H2,RestH2),
7040 term_variables(Guard,Vars),
7041 partial_wake_args(Args,ArgModes,Vars,FA)
7044 partial_wake_args([],_,_,_).
7045 partial_wake_args([Arg|Args],[Mode|Modes],Vars,C) :-
7049 ; memberchk_eq(Arg,Vars) ->
7057 partial_wake_args(Args,Modes,Vars,C).
7059 no_partial_wake(C) \ no_partial_wake(C) <=> true.
7061 no_partial_wake(C) \ wakes_partially(C) <=> fail.
7063 wakes_partially(C) <=> true.
7066 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7067 % Generate rules that implement chr_show_store/1 functionality.
7073 % Generates additional rules:
7075 % $show, C1 # ID ==> writeln(C1) pragma passive(ID).
7077 % $show, Cn # ID ==> writeln(Cn) pragma passive(ID).
7080 generate_show_constraint(Constraints0,Constraints,Rules0,Rules) :-
7081 ( chr_pp_flag(show,on) ->
7082 Constraints = ['$show'/0|Constraints0],
7083 generate_show_rules(Constraints0,Rules,[Rule|Rules0]),
7084 inc_rule_count(RuleNb),
7086 rule(['$show'],[],true,true),
7093 Constraints = Constraints0,
7097 generate_show_rules([],Rules,Rules).
7098 generate_show_rules([F/A|Rest],[Rule|Tail],Rules) :-
7100 inc_rule_count(RuleNb),
7102 rule([],['$show',C],true,writeln(C)),
7108 generate_show_rules(Rest,Tail,Rules).
7110 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7111 % Custom supension term layout
7113 static_suspension_term(F/A,Suspension) :-
7114 suspension_term_base(F/A,Base),
7116 functor(Suspension,suspension,Arity).
7118 has_suspension_field(FA,Field) :-
7119 suspension_term_base_fields(FA,Fields),
7120 memberchk(Field,Fields).
7122 suspension_term_base(FA,Base) :-
7123 suspension_term_base_fields(FA,Fields),
7124 length(Fields,Base).
7126 suspension_term_base_fields(FA,Fields) :-
7127 ( chr_pp_flag(debugable,on) ->
7130 % 3. Propagation History
7131 % 4. Generation Number
7132 % 5. Continuation Goal
7134 Fields = [id,state,history,generation,continuation,functor]
7136 ( uses_history(FA) ->
7137 Fields = [id,state,history|Fields2]
7138 ; only_ground_indexed_arguments(FA), get_functional_dependency(FA,1,_,_) ->
7139 Fields = [state|Fields2]
7141 Fields = [id,state|Fields2]
7143 ( only_ground_indexed_arguments(FA) ->
7144 get_store_type(FA,StoreType),
7145 basic_store_types(StoreType,BasicStoreTypes),
7146 ( memberchk(global_ground,BasicStoreTypes) ->
7149 % 3. Propagation History
7150 % 4. Global List Prev
7151 Fields2 = [global_list_prev]
7155 % 3. Propagation History
7158 ; may_trigger(FA) ->
7161 % 3. Propagation History
7162 ( uses_field(FA,generation) ->
7163 % 4. Generation Number
7164 % 5. Global List Prev
7165 Fields2 = [generation,global_list_prev]
7167 Fields2 = [global_list_prev]
7172 % 3. Propagation History
7173 % 4. Global List Prev
7174 Fields2 = [global_list_prev]
7178 get_static_suspension_term_field(FieldName,FA,StaticSuspension,Field) :-
7179 suspension_term_base_fields(FA,Fields),
7180 nth(Index,Fields,FieldName), !,
7181 arg(Index,StaticSuspension,Field).
7182 get_static_suspension_term_field(arguments,FA,StaticSuspension,Field) :- !,
7183 suspension_term_base(FA,Base),
7184 StaticSuspension =.. [_|Args],
7185 drop(Base,Args,Field).
7186 get_static_suspension_term_field(FieldName,FA,_StaticSuspension,_Field) :-
7187 chr_error(internal,'Trying to obtain field ~w of ~w, wich does not have it!',[FieldName,FA]).
7190 get_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
7191 suspension_term_base_fields(FA,Fields),
7192 nth(Index,Fields,FieldName), !,
7193 Goal = arg(Index,DynamicSuspension,Field).
7194 get_dynamic_suspension_term_field(arguments,FA,DynamicSuspension,Field,Goal) :- !,
7195 static_suspension_term(FA,StaticSuspension),
7196 get_static_suspension_term_field(arguments,FA,StaticSuspension,Field),
7197 Goal = (DynamicSuspension = StaticSuspension).
7198 get_dynamic_suspension_term_field(argument(I),FA,DynamicSuspension,Field,Goal) :- !,
7199 suspension_term_base(FA,Base),
7201 Goal = arg(Index,DynamicSuspension,Field).
7202 get_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
7203 chr_error(internal,'Dynamic goal to get ~w of ~w, which does not have this field!',[FieldName,FA]).
7206 set_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
7207 suspension_term_base_fields(FA,Fields),
7208 nth(Index,Fields,FieldName), !,
7209 Goal = setarg(Index,DynamicSuspension,Field).
7210 set_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
7211 chr_error(internal,'Dynamic goal to set ~w of ~w, which does not have this field!',[FieldName,FA]).
7213 basic_store_types(multi_store(Types),Types) :- !.
7214 basic_store_types(Type,[Type]).
7216 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7223 :- chr_option(mode,phase_end(+)).
7224 :- chr_option(mode,delay_phase_end(+,?)).
7226 phase_end(Phase) \ delay_phase_end(Phase,Goal) <=> call(Goal).
7227 % phase_end(Phase) <=> true.
7230 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7234 novel_production_call/4.
7236 :- chr_option(mode,uses_history(+)).
7237 :- chr_option(mode,does_use_history(+,+)).
7238 :- chr_option(mode,novel_production_call(+,+,?,?)).
7240 does_use_history(FA,Occ) \ does_use_history(FA,Occ) <=> true.
7241 does_use_history(FA,_) \ uses_history(FA) <=> true.
7242 uses_history(_FA) <=> fail.
7244 does_use_history(FA,Occ) \ novel_production_call(FA,Occ,PossibleGoal,Goal) <=> Goal = PossibleGoal.
7245 novel_production_call(FA,_,_PossibleGoal,Goal) <=> Goal = true.
7251 :- chr_option(mode,uses_field(+,+)).
7252 :- chr_option(mode,does_use_field(+,+)).
7254 does_use_field(FA,Field) \ does_use_field(FA,Field) <=> true.
7255 does_use_field(FA,Field) \ uses_field(FA,Field) <=> true.
7256 uses_field(_FA,_Field) <=> fail.
7261 used_states_known/0.
7263 :- chr_option(mode,uses_state(+,+)).
7264 :- chr_option(mode,if_used_state(+,+,?,?,?)).
7267 % states ::= not_stored_yet | passive | active | triggered | removed
7269 % allocate CREATES not_stored_yet
7270 % remove CHECKS not_stored_yet
7271 % activate CHECKS not_stored_yet
7273 % ==> no allocate THEN no not_stored_yet
7275 % recurs CREATES inactive
7276 % lookup CHECKS inactive
7278 % insert CREATES active
7279 % activate CREATES active
7280 % lookup CHECKS active
7281 % recurs CHECKS active
7283 % runsusp CREATES triggered
7284 % lookup CHECKS triggered
7286 % ==> no runsusp THEN no triggered
7288 % remove CREATES removed
7289 % runsusp CHECKS removed
7290 % lookup CHECKS removed
7291 % recurs CHECKS removed
7293 % ==> no remove THEN no removed
7295 % ==> no allocate, no remove, no active/inactive distinction THEN no state at all...
7297 uses_state(Constraint,State) \ uses_state(Constraint,State) <=> true.
7299 used_states_known, uses_state(Constraint,State) \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal)
7300 <=> ResultGoal = Used.
7301 used_states_known \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal)
7302 <=> ResultGoal = NotUsed.
7303 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7304 % % In-place updates
7306 % inplace_updates(Constraints) :-
7307 % ( chr_pp_flag(inplace_updates,off) ->
7310 % inplace_updates0(Constraints)
7313 % inplace_updates0([]).
7314 % inplace_updates([C|Cs]) :-
7315 % inplace_update_allowed(C),
7316 % inplace_updates0(Cs).
7319 % inplace_update_allowed/1,
7320 % inplace_update_safe/1,
7321 % is_safe_inplace_update/1,
7322 % partial_remove_insert/7.
7324 % :- chr_option(mode,inplace_update_allowed(+)).
7325 % :- chr_option(mode,inplace_update_safe(+)).
7326 % :- chr_option(mode,is_safe_inplace_update(+)).
7327 % :- chr_option(mode,partial_remove_insert(+,?,?,?,?,?)).
7329 % % pointless to even check for in-place updates if C is never removed
7330 % occurrence(C,ON,RuleNb,ID,_), rule(RuleNb,Rule) \ inplace_update_allowed(C)
7336 % inplace_update_allowed(C) ==> reuse_susps_test(C).
7338 % inplace_update_allowed(C) <=> inplace_update_safe(C).
7341 % safe_body_check/5,
7342 % all_occs_passive_or_safe/2.
7344 % abstract_constraints(ACs) \ safe_body_check(H1,H2,Guard,G,C)
7346 % ai_observation_abstract_goal_(H1,H2,Guard,G,ACs,AG),
7347 % check_abstract_body_safety(AG,C).
7349 % safe_body_check(H1,H2,Guard,G,C) <=> fail.
7351 % check_abstract_body_safety([],_).
7352 % check_abstract_body_safety([builtin|_],_) :- !, fail.
7353 % check_abstract_body_safety([AC|Rest],C) :-
7354 % all_occs_passive_or_safe(AC,C),
7355 % check_abstract_body_safety(Rest,C).
7357 % % this breaks loops
7358 % this_one_should_not_be_all_passive @
7359 % all_occs_passive_or_safe(AC,C), all_occs_passive_or_safe(AC,C) <=> fail.
7361 % abstract_constraints(ACs), occurrence(AC,ON,RuleNb,ID,_), rule(RuleNb,Rule), all_occs_passive_or_safe(AC,C)
7363 % \+ is_passive(RuleNb,ID),
7364 % Rule = pragma(rule(Hr,Hk,Guard,Body),ids(IDr,IDk),_,_,_)
7366 % ai_observation_abstract_constraints(Hr,ACs,ARemovedHeads),
7367 % %not safe if it is removed
7368 % \+ memberchk_eq(C,ARemovedHeads),
7369 % safe_body_check(Hr,Hk,Guard,Body,C).
7371 % all_occs_passive_or_safe(AC,C) <=> true.
7373 % check_passive([],RuleNb).
7374 % check_passive([ID|IDs],RuleNb) :-
7375 % is_passive(RuleNb,ID),
7376 % check_passive(IDs,RuleNb).
7378 % inplace_update_safe(C) \ is_safe_inplace_update(C) <=> true.
7379 % is_safe_inplace_update(C) <=> fail.
7381 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7384 % inplace_updates2/0,
7387 % inplace_updates2 \ maybe_inplace(C,_,Del,Ins,DelClause,InsClause,_,_,_,_,_,_,_,_,_,_)#Id
7389 % chr_pp_flag(inplace_updates,off)
7397 % maybe_inplace(C,Susp,Del,Ins,DelClause,InsClause,UpdateDelClause,UpdateInsClause,UpdatedArgs,_,OrigVars,TheNewVars,V1,V2,NewState,ResetHistory)#Id
7401 % ( fix_stores(C,Susp,UpdatedArgs,OrigVars,TheNewVars,UpdatedIndexes,RemoveFromModifiedStores,ReInsertIntoModifiedStores,UpdateInsClause,V1,V2,RSA) ->
7402 % ( reuse_susps_history_reset_needed(C) ->
7403 % update_suspension_field(C,Susp,history,t,ResetHistory)
7405 % ResetHistory = true
7407 % ( has_active_occurrence(C) ->
7409 % InsClause =.. [_|NewVars],
7410 % append(NewVars,[Susp],VarsSusp),
7411 % ( (chr_pp_flag(debugable,on) ; is_stored(C), ( has_active_occurrence(C); chr_pp_flag(late_allocation,off)), ( may_trigger(C) ; get_allocation_occurrence(C,AO), get_max_occurrence(C,MO), MO >= AO ) ) ->
7412 % build_head(F,A,[0],VarsSusp,Delegate),
7413 % ConstraintCall = (SetNewState,Delegate),
7414 % ( NewState = inactive ->
7415 % SetNewState = true
7417 % update_suspension_field(C,Susp,state,inactive,SetNewState)
7419 % reuse_susps_removed_needed(C),
7420 % Del = (RemoveFromModifiedStores,UpdateDelClause),
7421 % Ins = (ReInsertIntoModifiedStores,RSA,ConstraintCall)
7427 % Del = (RemoveFromModifiedStores,UpdateDelClause),
7428 % Ins = (ReInsertIntoModifiedStores,RSA),
7430 % (NewState = active -> true ; true)
7441 % fix_stores(C,Susp,UpdatedArgs,OrigVars,TheNewVars,UpdatedIndexes,RemoveFromModifiedStores,ReInsertIntoModifiedStores,SetArgs,V1,V2,RestSetArgs) :-
7442 % suspension_term_base(C,Base),
7443 % get_store_type(C,StoreType),
7444 % ( StoreType == default ->
7445 % RemoveFromModifiedStores = true,
7447 % none_indexed(UpdatedArgs,C),
7448 % UpdatedIndexes = [],
7449 % ReInsertIntoModifiedStores = true,
7450 % keep_nonindex_setargs(SetArgs,RestSetArgs,Base)
7452 % UpdatedIndexes = UpdatedArgs,
7453 % attach_constraint_atom(C,NewVars2,Susp,Attach),
7454 % detach_constraint_atom(C,OrigVars2,Susp,Detach),
7455 % ReInsertIntoModifiedStores = ('chr attach_diff'(OrigVars,TheNewVars,OrigVars2,NewVars2), Detach, Attach),
7456 % keep_nonindex_setargs(SetArgs,RestSetArgs,Base)
7459 % indexargs(StoreType,KeepArgs),
7460 % intersect_eq(KeepArgs,UpdatedArgs,UpdatedIndexes1),
7461 % multi_arg_updated_indexes(StoreType,UpdatedIndexes1,UpdatedIndexes,ModifiedStore),
7462 % generate_insert_constraint_body2(ModifiedStore,C,Susp,V1,V2,ReInsertIntoModifiedStores),
7463 % keep_nonindex_setargs(SetArgs,UpdatedIndexes1,RestSetArgs,Base),
7464 % RemoveFromModifiedStores = true
7467 % keep_nonindex_setargs(SetArgs,RestSetArgs,Base) :-
7468 % keep_nonindex_setargs(SetArgs,[],RestSetArgs,Base).
7470 % keep_nonindex_setargs(SetArgs,UpdatedIndexes1,RestSetArgs,Base) :-
7471 % conj2list(SetArgs,SA),
7472 % keep_nonindex_setargs_(SA,UpdatedIndexes1,RSA,Base),
7473 % list2conj(RSA,RestSetArgs).
7475 % keep_nonindex_setargs_([],_,[],_).
7476 % keep_nonindex_setargs_([X|Rest],UI,[X|Rest2],Base) :-
7478 % keep_nonindex_setargs_(Rest,UI,Rest2,Base).
7479 % keep_nonindex_setargs_([setarg(Pos,X,Y)|Rest],UI,Rest2,Base) :-
7480 % CPos is Pos - 6,!, % TOM: What is the magic number 6?
7481 % ( memberchk(CPos,UI) ->
7485 % CPos2 is CPos + Base,
7486 % Rest2 = [setarg(CPos2,X,Y)|R2]
7488 % Rest2 = [setarg(Pos,X,Y)|R2]
7491 % keep_nonindex_setargs_(Rest,UI,R2,Base).
7492 % keep_nonindex_setargs_([X|Rest],UI,[X|Rest2],Base) :-
7493 % keep_nonindex_setargs_(Rest,UI,Rest2,Base).
7496 % generate_insert_constraint_body2(multi_inthash(Indexes),C,Susp,O,N,Body) :-
7497 % generate_multi_inthash_insert_constraint_bodies2(Indexes,C,Susp,O,N,Body).
7498 % generate_insert_constraint_body2(multi_hash(Indexes),C,Susp,O,N,Body) :-
7499 % generate_multi_hash_insert_constraint_bodies2(Indexes,C,Susp,O,N,Body).
7500 % generate_insert_constraint_body2(multi_store(StoreTypes),C,Susp,O,N,Body) :-
7502 % find_with_var_identity(
7506 % lists:member(ST,StoreTypes),
7507 % generate_insert_constraint_body2(ST,C,Susp,O,N,B)
7511 % list2conj(Bodies,Body).
7513 % generate_multi_inthash_insert_constraint_bodies2([],_,_,_,_,true).
7514 % generate_multi_inthash_insert_constraint_bodies2([Index|Indexes],FA,Susp,O,N,(Body,Bodies)) :-
7515 % multi_hash_store_name(FA,Index,StoreName),
7519 % set_dynamic_suspension_term_field(argument(Pos),FA,Susp,New,UpdateArgument),
7525 % nb_getval(StoreName,Store),
7526 % chr_integertable_store:delete_ht(Store,Orig,Susp),
7528 % chr_integertable_store:insert_ht(Store,New,Susp)
7531 % generate_multi_inthash_insert_constraint_bodies2(Indexes,FA,Susp,O,N,Bodies).
7532 % generate_multi_hash_insert_constraint_bodies2([],_,_,_,_,true).
7533 % generate_multi_hash_insert_constraint_bodies2([Index|Indexes],FA,Susp,O,N,(Body,Bodies)) :-
7534 % multi_hash_store_name(FA,Index,StoreName),
7535 % multi_hash_key2(FA,Index,Susp,O,N,Key1,Key2,SetArgs),
7541 % nb_getval(StoreName,Store),
7542 % chr_hashtable_store:delete_ht(Store,Key1,Susp),
7544 % chr_hashtable_store:insert_ht(Store,Key2,Susp)
7547 % generate_multi_hash_insert_constraint_bodies2(Indexes,FA,Susp,O,N,Bodies).
7549 % multi_hash_key2(F/A,Index,Susp,O,N,Key1,Key2,SetArgs) :-
7550 % ( ( integer(Index) ->
7557 % set_dynamic_suspension_term_field(argument(I),F/A,Susp,Key2,SetArgs)
7559 % ; is_list(Index) ->
7560 % sort(Index,Indexes),
7562 % find_with_var_identity(
7563 % SetArg-(KeyO-KeyI),
7565 % (lists:member(I,Indexes),
7566 % lists:nth(I,N,KeyI),
7567 % lists:nth(I,O,KeyO),
7568 % set_dynamic_suspension_term_field(argument(I),F/A,Susp,KeyI,SetArg)),
7570 % pairup(Bodies,Keys,ArgKeyPairs),
7571 % pairup(OldKey,NewKey,Keys),
7572 % Key1 =.. [k|OldKey],
7573 % Key2 =.. [k|NewKey],
7574 % list2conj(Bodies,SetArgs)
7578 % avoid_redundant_arg_getval([],_,_,[]).
7579 % avoid_redundant_arg_getval([arg(Pos,Susp,Var)|Rest],SetArgs,GetVals,Rest2) :-
7580 % already_set(SetArgs,Pos,Susp,Var), !,
7581 % avoid_redundant_arg_getval(Rest,SetArgs,GetVals,Rest2).
7582 % avoid_redundant_arg_getval([nb_getval(Table,Var)|Rest],SetArgs,GetVals,Rest2) :-
7583 % already_got(GetVals,Table,Var), !,
7584 % avoid_redundant_arg_getval(Rest,SetArgs,GetVals,Rest2).
7585 % avoid_redundant_arg_getval([X|Rest],SetArgs,GetVals,[X|Rest2]) :-
7586 % avoid_redundant_arg_getval(Rest,SetArgs,GetVals,Rest2).
7588 % already_set([setarg(Pos,Susp2,Var2)|_],Pos,Susp,Var) :-
7589 % Susp == Susp2, !, Var = Var2.
7590 % already_set([_|Rest],Pos,Susp,Var) :-
7591 % already_set(Rest,Pos,Susp,Var).
7593 % already_got([nb_getval(Table,Var2)|_],Table,Var) :-
7595 % already_got([_|Rest],Table,Var) :- already_got(Rest,Table,Var).
7599 % % TOM: Is this predicate used?
7601 % get_store_type(C,StoreType),
7603 % StoreType = global_singleton
7605 % StoreType = multi_store([global_singleton])
7609 % inplace_updates2 \ reuse_susps_removed(_,_,X) <=> X = true.
7610 % inplace_updates2 \ reuse_susps_active(_,_,X) <=> X = true.
7612 % inplace_updates2 \
7613 % partial_remove_insert(F/A,X,TheNewVars,PartialRemove,PartialInsert,SetArgs,V2)
7615 % (get_store_type(F/A,StoreType),
7616 % (StoreType \== default ->
7617 % indexargs(StoreType,UpdatedArgs)
7619 % length(UpdatedArgs,A),
7620 % fill_inc_numbers(UpdatedArgs,1)
7623 % fix_stores(F/A,X,UpdatedArgs,V1,TheNewVars
7624 % , UpdatedIndexes, RemoveFromModifiedStores,
7625 % ReInsertIntoModifiedStores,SetArgs,V1,V2,RemainingSetArgs) ->
7626 % term_variables(ReInsertIntoModifiedStores,UsedVars),
7627 % suspension_term_base(F/A,Base),
7629 % getorigvars(V1,Base1,X,UsedVars,GetOrigVars2),
7633 % RemoveFromModifiedStores),
7634 % PartialInsert = (ReInsertIntoModifiedStores,RemainingSetArgs)
7636 % writeln('ERROR: could not fix stores')
7641 % getorigvars([],_,_,_,true).
7642 % getorigvars([V|Vs],Pos,Susp,UV,T) :-
7644 % (memberchk_eq(V,UV) ->
7645 % T = (arg(Pos,Susp,V),RT),
7646 % getorigvars(Vs,Pos1,Susp,UV,RT)
7648 % getorigvars(Vs,Pos1,Susp,UV,T)
7651 % fill_inc_numbers([],_).
7652 % fill_inc_numbers([A|As],A) :- B is A+1, fill_inc_numbers(As,B).
7654 % inplace_updates2 <=> true.
7656 % get_extra_constraint_clauses([],_C,[],[]).
7657 % get_extra_constraint_clauses([A|RC],C,EC,EC2) :-
7658 % once((A = (Head :- B) ; A = Head)),
7659 % ( Head = (C-H2) ->
7660 % EC = [(H2 :- B)|REC],
7666 % get_extra_constraint_clauses(RC,C,REC,REC2).
7668 % :- chr_constraint onlyone/1, isonlyone/1.
7669 % :- chr_option(mode,onlyone(+)).
7670 % :- chr_option(mode,isonlyone(+)).
7672 % onlyone(C) \ onlyone(C) <=> true.
7673 % onlyone(C) \ isonlyone(C) <=> true.
7674 % isonlyone(C) <=> fail.
7677 % none_indexed([],_).
7678 % none_indexed([A|As],C) :-
7679 % ( is_indexed_argument(C,A), get_constraint_mode(C,Mode), nth(A,Mode,M), M \== (+) ->
7682 % none_indexed(As,C)
7686 % multi_arg_updated_indexes(multi_inthash(Indices),UI,UpdInd,multi_inthash(UpdInd)) :- !,
7687 % find_updated(Indices,UI,UpdInd).
7688 % multi_arg_updated_indexes(multi_hash(Indices),UI,UpdInd,multi_hash(UpdInd)) :- !,
7689 % find_updated(Indices,UI,UpdInd).
7691 % find_updated([],_,[]).
7692 % find_updated([Ind|RInd],UI,RInd2) :-
7693 % intersect_eq(Ind,UI,[]), !,
7694 % find_updated(RInd,UI,RInd2).
7695 % find_updated([Ind|RInd],UI,[Ind|RInd2]) :- !,
7696 % find_updated(RInd,UI,RInd2).
7698 % multi_arg_updated_indexes(multi_store([]),_,[],multi_store([])) :- !.
7699 % multi_arg_updated_indexes(multi_store([S|Ss]),UI,UI2,multi_store([AS|ASs])) :- !,
7700 % multi_arg_updated_indexes(S,UI,X1,AS),
7701 % multi_arg_updated_indexes(multi_store(Ss),UI,X2,multi_store(ASs)),
7702 % append(X1,X2,Args_),
7704 % multi_arg_updated_indexes(_,_,[],multi_store([])).
7709 % indexargs(multi_inthash(Indexes),Args) :- !,indexes2args(Indexes,Args).
7710 % indexargs(multi_hash(Indexes),Args) :- !,indexes2args(Indexes,Args).
7711 % indexargs(multi_store([]),[]) :- !.
7712 % indexargs(multi_store([S|Ss]),Args) :- !,
7714 % indexargs(multi_store(Ss),A2),
7715 % append(A1,A2,Args_),
7717 % indexargs(global_ground,[]).
7718 % indexargs(global_singleton,[]).
7719 % % no default store (need to add support for correct detach-attach)
7721 % indexes2args([],[]).
7722 % indexes2args([[]|R],Ys) :- !, indexes2args(R,Ys).
7723 % indexes2args([[X|Xs]|R],[X|Ys]) :- !,indexes2args([Xs|R],Ys).
7724 % indexes2args([X|R],[X|Ys]) :- !,indexes2args(R,Ys).